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-2019, 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 Erroutc; use Erroutc; 36with Exp_Ch11; use Exp_Ch11; 37with Exp_Util; use Exp_Util; 38with Fname; use Fname; 39with Freeze; use Freeze; 40with Lib; use Lib; 41with Lib.Xref; use Lib.Xref; 42with Namet.Sp; use Namet.Sp; 43with Nlists; use Nlists; 44with Nmake; use Nmake; 45with Output; use Output; 46with Restrict; use Restrict; 47with Rident; use Rident; 48with Rtsfind; use Rtsfind; 49with Sem; use Sem; 50with Sem_Aux; use Sem_Aux; 51with Sem_Attr; use Sem_Attr; 52with Sem_Ch6; use Sem_Ch6; 53with Sem_Ch8; use Sem_Ch8; 54with Sem_Disp; use Sem_Disp; 55with Sem_Elab; use Sem_Elab; 56with Sem_Eval; use Sem_Eval; 57with Sem_Prag; use Sem_Prag; 58with Sem_Res; use Sem_Res; 59with Sem_Warn; use Sem_Warn; 60with Sem_Type; use Sem_Type; 61with Sinfo; use Sinfo; 62with Sinput; use Sinput; 63with Stand; use Stand; 64with Style; 65with Stringt; use Stringt; 66with Targparm; use Targparm; 67with Tbuild; use Tbuild; 68with Ttypes; use Ttypes; 69with Uname; use Uname; 70 71with GNAT.HTable; use GNAT.HTable; 72 73package body Sem_Util is 74 75 --------------------------- 76 -- Local Data Structures -- 77 --------------------------- 78 79 Invalid_Binder_Values : array (Scalar_Id) of Entity_Id := (others => Empty); 80 -- A collection to hold the entities of the variables declared in package 81 -- System.Scalar_Values which describe the invalid values of scalar types. 82 83 Invalid_Binder_Values_Set : Boolean := False; 84 -- This flag prevents multiple attempts to initialize Invalid_Binder_Values 85 86 Invalid_Floats : array (Float_Scalar_Id) of Ureal := (others => No_Ureal); 87 -- A collection to hold the invalid values of float types as specified by 88 -- pragma Initialize_Scalars. 89 90 Invalid_Integers : array (Integer_Scalar_Id) of Uint := (others => No_Uint); 91 -- A collection to hold the invalid values of integer types as specified 92 -- by pragma Initialize_Scalars. 93 94 ----------------------- 95 -- Local Subprograms -- 96 ----------------------- 97 98 function Build_Component_Subtype 99 (C : List_Id; 100 Loc : Source_Ptr; 101 T : Entity_Id) return Node_Id; 102 -- This function builds the subtype for Build_Actual_Subtype_Of_Component 103 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints, 104 -- Loc is the source location, T is the original subtype. 105 106 procedure Examine_Array_Bounds 107 (Typ : Entity_Id; 108 All_Static : out Boolean; 109 Has_Empty : out Boolean); 110 -- Inspect the index constraints of array type Typ. Flag All_Static is set 111 -- when all ranges are static. Flag Has_Empty is set only when All_Static 112 -- is set and indicates that at least one range is empty. 113 114 function Has_Enabled_Property 115 (Item_Id : Entity_Id; 116 Property : Name_Id) return Boolean; 117 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled. 118 -- Determine whether an abstract state or a variable denoted by entity 119 -- Item_Id has enabled property Property. 120 121 function Has_Null_Extension (T : Entity_Id) return Boolean; 122 -- T is a derived tagged type. Check whether the type extension is null. 123 -- If the parent type is fully initialized, T can be treated as such. 124 125 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean; 126 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type 127 -- with discriminants whose default values are static, examine only the 128 -- components in the selected variant to determine whether all of them 129 -- have a default. 130 131 type Null_Status_Kind is 132 (Is_Null, 133 -- This value indicates that a subexpression is known to have a null 134 -- value at compile time. 135 136 Is_Non_Null, 137 -- This value indicates that a subexpression is known to have a non-null 138 -- value at compile time. 139 140 Unknown); 141 -- This value indicates that it cannot be determined at compile time 142 -- whether a subexpression yields a null or non-null value. 143 144 function Null_Status (N : Node_Id) return Null_Status_Kind; 145 -- Determine whether subexpression N of an access type yields a null value, 146 -- a non-null value, or the value cannot be determined at compile time. The 147 -- routine does not take simple flow diagnostics into account, it relies on 148 -- static facts such as the presence of null exclusions. 149 150 function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean; 151 function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean; 152 -- ???We retain the old and new algorithms for Requires_Transient_Scope for 153 -- the time being. New_Requires_Transient_Scope is used by default; the 154 -- debug switch -gnatdQ can be used to do Old_Requires_Transient_Scope 155 -- instead. The intent is to use this temporarily to measure before/after 156 -- efficiency. Note: when this temporary code is removed, the documentation 157 -- of dQ in debug.adb should be removed. 158 159 procedure Results_Differ 160 (Id : Entity_Id; 161 Old_Val : Boolean; 162 New_Val : Boolean); 163 -- ???Debugging code. Called when the Old_Val and New_Val differ. This 164 -- routine will be removed eventially when New_Requires_Transient_Scope 165 -- becomes Requires_Transient_Scope and Old_Requires_Transient_Scope is 166 -- eliminated. 167 168 function Subprogram_Name (N : Node_Id) return String; 169 -- Return the fully qualified name of the enclosing subprogram for the 170 -- given node N, with file:line:col information appended, e.g. 171 -- "subp:file:line:col", corresponding to the source location of the 172 -- body of the subprogram. 173 174 ------------------------------ 175 -- Abstract_Interface_List -- 176 ------------------------------ 177 178 function Abstract_Interface_List (Typ : Entity_Id) return List_Id is 179 Nod : Node_Id; 180 181 begin 182 if Is_Concurrent_Type (Typ) then 183 184 -- If we are dealing with a synchronized subtype, go to the base 185 -- type, whose declaration has the interface list. 186 187 Nod := Declaration_Node (Base_Type (Typ)); 188 189 if Nkind_In (Nod, N_Full_Type_Declaration, 190 N_Private_Type_Declaration) 191 then 192 return Empty_List; 193 end if; 194 195 elsif Ekind (Typ) = E_Record_Type_With_Private then 196 if Nkind (Parent (Typ)) = N_Full_Type_Declaration then 197 Nod := Type_Definition (Parent (Typ)); 198 199 elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then 200 if Present (Full_View (Typ)) 201 and then 202 Nkind (Parent (Full_View (Typ))) = N_Full_Type_Declaration 203 then 204 Nod := Type_Definition (Parent (Full_View (Typ))); 205 206 -- If the full-view is not available we cannot do anything else 207 -- here (the source has errors). 208 209 else 210 return Empty_List; 211 end if; 212 213 -- Support for generic formals with interfaces is still missing ??? 214 215 elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then 216 return Empty_List; 217 218 else 219 pragma Assert 220 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration); 221 Nod := Parent (Typ); 222 end if; 223 224 elsif Ekind (Typ) = E_Record_Subtype then 225 Nod := Type_Definition (Parent (Etype (Typ))); 226 227 elsif Ekind (Typ) = E_Record_Subtype_With_Private then 228 229 -- Recurse, because parent may still be a private extension. Also 230 -- note that the full view of the subtype or the full view of its 231 -- base type may (both) be unavailable. 232 233 return Abstract_Interface_List (Etype (Typ)); 234 235 elsif Ekind (Typ) = E_Record_Type then 236 if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then 237 Nod := Formal_Type_Definition (Parent (Typ)); 238 else 239 Nod := Type_Definition (Parent (Typ)); 240 end if; 241 242 -- Otherwise the type is of a kind which does not implement interfaces 243 244 else 245 return Empty_List; 246 end if; 247 248 return Interface_List (Nod); 249 end Abstract_Interface_List; 250 251 -------------------------------- 252 -- Add_Access_Type_To_Process -- 253 -------------------------------- 254 255 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is 256 L : Elist_Id; 257 258 begin 259 Ensure_Freeze_Node (E); 260 L := Access_Types_To_Process (Freeze_Node (E)); 261 262 if No (L) then 263 L := New_Elmt_List; 264 Set_Access_Types_To_Process (Freeze_Node (E), L); 265 end if; 266 267 Append_Elmt (A, L); 268 end Add_Access_Type_To_Process; 269 270 -------------------------- 271 -- Add_Block_Identifier -- 272 -------------------------- 273 274 procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is 275 Loc : constant Source_Ptr := Sloc (N); 276 277 begin 278 pragma Assert (Nkind (N) = N_Block_Statement); 279 280 -- The block already has a label, return its entity 281 282 if Present (Identifier (N)) then 283 Id := Entity (Identifier (N)); 284 285 -- Create a new block label and set its attributes 286 287 else 288 Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); 289 Set_Etype (Id, Standard_Void_Type); 290 Set_Parent (Id, N); 291 292 Set_Identifier (N, New_Occurrence_Of (Id, Loc)); 293 Set_Block_Node (Id, Identifier (N)); 294 end if; 295 end Add_Block_Identifier; 296 297 ---------------------------- 298 -- Add_Global_Declaration -- 299 ---------------------------- 300 301 procedure Add_Global_Declaration (N : Node_Id) is 302 Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit)); 303 304 begin 305 if No (Declarations (Aux_Node)) then 306 Set_Declarations (Aux_Node, New_List); 307 end if; 308 309 Append_To (Declarations (Aux_Node), N); 310 Analyze (N); 311 end Add_Global_Declaration; 312 313 -------------------------------- 314 -- Address_Integer_Convert_OK -- 315 -------------------------------- 316 317 function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is 318 begin 319 if Allow_Integer_Address 320 and then ((Is_Descendant_Of_Address (T1) 321 and then Is_Private_Type (T1) 322 and then Is_Integer_Type (T2)) 323 or else 324 (Is_Descendant_Of_Address (T2) 325 and then Is_Private_Type (T2) 326 and then Is_Integer_Type (T1))) 327 then 328 return True; 329 else 330 return False; 331 end if; 332 end Address_Integer_Convert_OK; 333 334 ------------------- 335 -- Address_Value -- 336 ------------------- 337 338 function Address_Value (N : Node_Id) return Node_Id is 339 Expr : Node_Id := N; 340 341 begin 342 loop 343 -- For constant, get constant expression 344 345 if Is_Entity_Name (Expr) 346 and then Ekind (Entity (Expr)) = E_Constant 347 then 348 Expr := Constant_Value (Entity (Expr)); 349 350 -- For unchecked conversion, get result to convert 351 352 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then 353 Expr := Expression (Expr); 354 355 -- For (common case) of To_Address call, get argument 356 357 elsif Nkind (Expr) = N_Function_Call 358 and then Is_Entity_Name (Name (Expr)) 359 and then Is_RTE (Entity (Name (Expr)), RE_To_Address) 360 then 361 Expr := First (Parameter_Associations (Expr)); 362 363 if Nkind (Expr) = N_Parameter_Association then 364 Expr := Explicit_Actual_Parameter (Expr); 365 end if; 366 367 -- We finally have the real expression 368 369 else 370 exit; 371 end if; 372 end loop; 373 374 return Expr; 375 end Address_Value; 376 377 ----------------- 378 -- Addressable -- 379 ----------------- 380 381 -- For now, just 8/16/32/64 382 383 function Addressable (V : Uint) return Boolean is 384 begin 385 return V = Uint_8 or else 386 V = Uint_16 or else 387 V = Uint_32 or else 388 V = Uint_64; 389 end Addressable; 390 391 function Addressable (V : Int) return Boolean is 392 begin 393 return V = 8 or else 394 V = 16 or else 395 V = 32 or else 396 V = 64; 397 end Addressable; 398 399 --------------------------------- 400 -- Aggregate_Constraint_Checks -- 401 --------------------------------- 402 403 procedure Aggregate_Constraint_Checks 404 (Exp : Node_Id; 405 Check_Typ : Entity_Id) 406 is 407 Exp_Typ : constant Entity_Id := Etype (Exp); 408 409 begin 410 if Raises_Constraint_Error (Exp) then 411 return; 412 end if; 413 414 -- Ada 2005 (AI-230): Generate a conversion to an anonymous access 415 -- component's type to force the appropriate accessibility checks. 416 417 -- Ada 2005 (AI-231): Generate conversion to the null-excluding type to 418 -- force the corresponding run-time check 419 420 if Is_Access_Type (Check_Typ) 421 and then Is_Local_Anonymous_Access (Check_Typ) 422 then 423 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); 424 Analyze_And_Resolve (Exp, Check_Typ); 425 Check_Unset_Reference (Exp); 426 end if; 427 428 -- What follows is really expansion activity, so check that expansion 429 -- is on and is allowed. In GNATprove mode, we also want check flags to 430 -- be added in the tree, so that the formal verification can rely on 431 -- those to be present. In GNATprove mode for formal verification, some 432 -- treatment typically only done during expansion needs to be performed 433 -- on the tree, but it should not be applied inside generics. Otherwise, 434 -- this breaks the name resolution mechanism for generic instances. 435 436 if not Expander_Active 437 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode) 438 then 439 return; 440 end if; 441 442 if Is_Access_Type (Check_Typ) 443 and then Can_Never_Be_Null (Check_Typ) 444 and then not Can_Never_Be_Null (Exp_Typ) 445 then 446 Install_Null_Excluding_Check (Exp); 447 end if; 448 449 -- First check if we have to insert discriminant checks 450 451 if Has_Discriminants (Exp_Typ) then 452 Apply_Discriminant_Check (Exp, Check_Typ); 453 454 -- Next emit length checks for array aggregates 455 456 elsif Is_Array_Type (Exp_Typ) then 457 Apply_Length_Check (Exp, Check_Typ); 458 459 -- Finally emit scalar and string checks. If we are dealing with a 460 -- scalar literal we need to check by hand because the Etype of 461 -- literals is not necessarily correct. 462 463 elsif Is_Scalar_Type (Exp_Typ) 464 and then Compile_Time_Known_Value (Exp) 465 then 466 if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then 467 Apply_Compile_Time_Constraint_Error 468 (Exp, "value not in range of}??", CE_Range_Check_Failed, 469 Ent => Base_Type (Check_Typ), 470 Typ => Base_Type (Check_Typ)); 471 472 elsif Is_Out_Of_Range (Exp, Check_Typ) then 473 Apply_Compile_Time_Constraint_Error 474 (Exp, "value not in range of}??", CE_Range_Check_Failed, 475 Ent => Check_Typ, 476 Typ => Check_Typ); 477 478 elsif not Range_Checks_Suppressed (Check_Typ) then 479 Apply_Scalar_Range_Check (Exp, Check_Typ); 480 end if; 481 482 -- Verify that target type is also scalar, to prevent view anomalies 483 -- in instantiations. 484 485 elsif (Is_Scalar_Type (Exp_Typ) 486 or else Nkind (Exp) = N_String_Literal) 487 and then Is_Scalar_Type (Check_Typ) 488 and then Exp_Typ /= Check_Typ 489 then 490 if Is_Entity_Name (Exp) 491 and then Ekind (Entity (Exp)) = E_Constant 492 then 493 -- If expression is a constant, it is worthwhile checking whether 494 -- it is a bound of the type. 495 496 if (Is_Entity_Name (Type_Low_Bound (Check_Typ)) 497 and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ))) 498 or else 499 (Is_Entity_Name (Type_High_Bound (Check_Typ)) 500 and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ))) 501 then 502 return; 503 504 else 505 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); 506 Analyze_And_Resolve (Exp, Check_Typ); 507 Check_Unset_Reference (Exp); 508 end if; 509 510 -- Could use a comment on this case ??? 511 512 else 513 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); 514 Analyze_And_Resolve (Exp, Check_Typ); 515 Check_Unset_Reference (Exp); 516 end if; 517 518 end if; 519 end Aggregate_Constraint_Checks; 520 521 ----------------------- 522 -- Alignment_In_Bits -- 523 ----------------------- 524 525 function Alignment_In_Bits (E : Entity_Id) return Uint is 526 begin 527 return Alignment (E) * System_Storage_Unit; 528 end Alignment_In_Bits; 529 530 -------------------------------------- 531 -- All_Composite_Constraints_Static -- 532 -------------------------------------- 533 534 function All_Composite_Constraints_Static 535 (Constr : Node_Id) return Boolean 536 is 537 begin 538 if No (Constr) or else Error_Posted (Constr) then 539 return True; 540 end if; 541 542 case Nkind (Constr) is 543 when N_Subexpr => 544 if Nkind (Constr) in N_Has_Entity 545 and then Present (Entity (Constr)) 546 then 547 if Is_Type (Entity (Constr)) then 548 return 549 not Is_Discrete_Type (Entity (Constr)) 550 or else Is_OK_Static_Subtype (Entity (Constr)); 551 end if; 552 553 elsif Nkind (Constr) = N_Range then 554 return 555 Is_OK_Static_Expression (Low_Bound (Constr)) 556 and then 557 Is_OK_Static_Expression (High_Bound (Constr)); 558 559 elsif Nkind (Constr) = N_Attribute_Reference 560 and then Attribute_Name (Constr) = Name_Range 561 then 562 return 563 Is_OK_Static_Expression 564 (Type_Low_Bound (Etype (Prefix (Constr)))) 565 and then 566 Is_OK_Static_Expression 567 (Type_High_Bound (Etype (Prefix (Constr)))); 568 end if; 569 570 return 571 not Present (Etype (Constr)) -- previous error 572 or else not Is_Discrete_Type (Etype (Constr)) 573 or else Is_OK_Static_Expression (Constr); 574 575 when N_Discriminant_Association => 576 return All_Composite_Constraints_Static (Expression (Constr)); 577 578 when N_Range_Constraint => 579 return 580 All_Composite_Constraints_Static (Range_Expression (Constr)); 581 582 when N_Index_Or_Discriminant_Constraint => 583 declare 584 One_Cstr : Entity_Id; 585 begin 586 One_Cstr := First (Constraints (Constr)); 587 while Present (One_Cstr) loop 588 if not All_Composite_Constraints_Static (One_Cstr) then 589 return False; 590 end if; 591 592 Next (One_Cstr); 593 end loop; 594 end; 595 596 return True; 597 598 when N_Subtype_Indication => 599 return 600 All_Composite_Constraints_Static (Subtype_Mark (Constr)) 601 and then 602 All_Composite_Constraints_Static (Constraint (Constr)); 603 604 when others => 605 raise Program_Error; 606 end case; 607 end All_Composite_Constraints_Static; 608 609 ------------------------ 610 -- Append_Entity_Name -- 611 ------------------------ 612 613 procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is 614 Temp : Bounded_String; 615 616 procedure Inner (E : Entity_Id); 617 -- Inner recursive routine, keep outer routine nonrecursive to ease 618 -- debugging when we get strange results from this routine. 619 620 ----------- 621 -- Inner -- 622 ----------- 623 624 procedure Inner (E : Entity_Id) is 625 Scop : Node_Id; 626 627 begin 628 -- If entity has an internal name, skip by it, and print its scope. 629 -- Note that we strip a final R from the name before the test; this 630 -- is needed for some cases of instantiations. 631 632 declare 633 E_Name : Bounded_String; 634 635 begin 636 Append (E_Name, Chars (E)); 637 638 if E_Name.Chars (E_Name.Length) = 'R' then 639 E_Name.Length := E_Name.Length - 1; 640 end if; 641 642 if Is_Internal_Name (E_Name) then 643 Inner (Scope (E)); 644 return; 645 end if; 646 end; 647 648 Scop := Scope (E); 649 650 -- Just print entity name if its scope is at the outer level 651 652 if Scop = Standard_Standard then 653 null; 654 655 -- If scope comes from source, write scope and entity 656 657 elsif Comes_From_Source (Scop) then 658 Append_Entity_Name (Temp, Scop); 659 Append (Temp, '.'); 660 661 -- If in wrapper package skip past it 662 663 elsif Present (Scop) and then Is_Wrapper_Package (Scop) then 664 Append_Entity_Name (Temp, Scope (Scop)); 665 Append (Temp, '.'); 666 667 -- Otherwise nothing to output (happens in unnamed block statements) 668 669 else 670 null; 671 end if; 672 673 -- Output the name 674 675 declare 676 E_Name : Bounded_String; 677 678 begin 679 Append_Unqualified_Decoded (E_Name, Chars (E)); 680 681 -- Remove trailing upper-case letters from the name (useful for 682 -- dealing with some cases of internal names generated in the case 683 -- of references from within a generic). 684 685 while E_Name.Length > 1 686 and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z' 687 loop 688 E_Name.Length := E_Name.Length - 1; 689 end loop; 690 691 -- Adjust casing appropriately (gets name from source if possible) 692 693 Adjust_Name_Case (E_Name, Sloc (E)); 694 Append (Temp, E_Name); 695 end; 696 end Inner; 697 698 -- Start of processing for Append_Entity_Name 699 700 begin 701 Inner (E); 702 Append (Buf, Temp); 703 end Append_Entity_Name; 704 705 --------------------------------- 706 -- Append_Inherited_Subprogram -- 707 --------------------------------- 708 709 procedure Append_Inherited_Subprogram (S : Entity_Id) is 710 Par : constant Entity_Id := Alias (S); 711 -- The parent subprogram 712 713 Scop : constant Entity_Id := Scope (Par); 714 -- The scope of definition of the parent subprogram 715 716 Typ : constant Entity_Id := Defining_Entity (Parent (S)); 717 -- The derived type of which S is a primitive operation 718 719 Decl : Node_Id; 720 Next_E : Entity_Id; 721 722 begin 723 if Ekind (Current_Scope) = E_Package 724 and then In_Private_Part (Current_Scope) 725 and then Has_Private_Declaration (Typ) 726 and then Is_Tagged_Type (Typ) 727 and then Scop = Current_Scope 728 then 729 -- The inherited operation is available at the earliest place after 730 -- the derived type declaration (RM 7.3.1 (6/1)). This is only 731 -- relevant for type extensions. If the parent operation appears 732 -- after the type extension, the operation is not visible. 733 734 Decl := First 735 (Visible_Declarations 736 (Package_Specification (Current_Scope))); 737 while Present (Decl) loop 738 if Nkind (Decl) = N_Private_Extension_Declaration 739 and then Defining_Entity (Decl) = Typ 740 then 741 if Sloc (Decl) > Sloc (Par) then 742 Next_E := Next_Entity (Par); 743 Link_Entities (Par, S); 744 Link_Entities (S, Next_E); 745 return; 746 747 else 748 exit; 749 end if; 750 end if; 751 752 Next (Decl); 753 end loop; 754 end if; 755 756 -- If partial view is not a type extension, or it appears before the 757 -- subprogram declaration, insert normally at end of entity list. 758 759 Append_Entity (S, Current_Scope); 760 end Append_Inherited_Subprogram; 761 762 ----------------------------------------- 763 -- Apply_Compile_Time_Constraint_Error -- 764 ----------------------------------------- 765 766 procedure Apply_Compile_Time_Constraint_Error 767 (N : Node_Id; 768 Msg : String; 769 Reason : RT_Exception_Code; 770 Ent : Entity_Id := Empty; 771 Typ : Entity_Id := Empty; 772 Loc : Source_Ptr := No_Location; 773 Rep : Boolean := True; 774 Warn : Boolean := False) 775 is 776 Stat : constant Boolean := Is_Static_Expression (N); 777 R_Stat : constant Node_Id := 778 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason); 779 Rtyp : Entity_Id; 780 781 begin 782 if No (Typ) then 783 Rtyp := Etype (N); 784 else 785 Rtyp := Typ; 786 end if; 787 788 Discard_Node 789 (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn)); 790 791 -- In GNATprove mode, do not replace the node with an exception raised. 792 -- In such a case, either the call to Compile_Time_Constraint_Error 793 -- issues an error which stops analysis, or it issues a warning in 794 -- a few cases where a suitable check flag is set for GNATprove to 795 -- generate a check message. 796 797 if not Rep or GNATprove_Mode then 798 return; 799 end if; 800 801 -- Now we replace the node by an N_Raise_Constraint_Error node 802 -- This does not need reanalyzing, so set it as analyzed now. 803 804 Rewrite (N, R_Stat); 805 Set_Analyzed (N, True); 806 807 Set_Etype (N, Rtyp); 808 Set_Raises_Constraint_Error (N); 809 810 -- Now deal with possible local raise handling 811 812 Possible_Local_Raise (N, Standard_Constraint_Error); 813 814 -- If the original expression was marked as static, the result is 815 -- still marked as static, but the Raises_Constraint_Error flag is 816 -- always set so that further static evaluation is not attempted. 817 818 if Stat then 819 Set_Is_Static_Expression (N); 820 end if; 821 end Apply_Compile_Time_Constraint_Error; 822 823 --------------------------- 824 -- Async_Readers_Enabled -- 825 --------------------------- 826 827 function Async_Readers_Enabled (Id : Entity_Id) return Boolean is 828 begin 829 return Has_Enabled_Property (Id, Name_Async_Readers); 830 end Async_Readers_Enabled; 831 832 --------------------------- 833 -- Async_Writers_Enabled -- 834 --------------------------- 835 836 function Async_Writers_Enabled (Id : Entity_Id) return Boolean is 837 begin 838 return Has_Enabled_Property (Id, Name_Async_Writers); 839 end Async_Writers_Enabled; 840 841 -------------------------------------- 842 -- Available_Full_View_Of_Component -- 843 -------------------------------------- 844 845 function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is 846 ST : constant Entity_Id := Scope (T); 847 SCT : constant Entity_Id := Scope (Component_Type (T)); 848 begin 849 return In_Open_Scopes (ST) 850 and then In_Open_Scopes (SCT) 851 and then Scope_Depth (ST) >= Scope_Depth (SCT); 852 end Available_Full_View_Of_Component; 853 854 ------------------- 855 -- Bad_Attribute -- 856 ------------------- 857 858 procedure Bad_Attribute 859 (N : Node_Id; 860 Nam : Name_Id; 861 Warn : Boolean := False) 862 is 863 begin 864 Error_Msg_Warn := Warn; 865 Error_Msg_N ("unrecognized attribute&<<", N); 866 867 -- Check for possible misspelling 868 869 Error_Msg_Name_1 := First_Attribute_Name; 870 while Error_Msg_Name_1 <= Last_Attribute_Name loop 871 if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then 872 Error_Msg_N -- CODEFIX 873 ("\possible misspelling of %<<", N); 874 exit; 875 end if; 876 877 Error_Msg_Name_1 := Error_Msg_Name_1 + 1; 878 end loop; 879 end Bad_Attribute; 880 881 -------------------------------- 882 -- Bad_Predicated_Subtype_Use -- 883 -------------------------------- 884 885 procedure Bad_Predicated_Subtype_Use 886 (Msg : String; 887 N : Node_Id; 888 Typ : Entity_Id; 889 Suggest_Static : Boolean := False) 890 is 891 Gen : Entity_Id; 892 893 begin 894 -- Avoid cascaded errors 895 896 if Error_Posted (N) then 897 return; 898 end if; 899 900 if Inside_A_Generic then 901 Gen := Current_Scope; 902 while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop 903 Gen := Scope (Gen); 904 end loop; 905 906 if No (Gen) then 907 return; 908 end if; 909 910 if Is_Generic_Formal (Typ) and then Is_Discrete_Type (Typ) then 911 Set_No_Predicate_On_Actual (Typ); 912 end if; 913 914 elsif Has_Predicates (Typ) then 915 if Is_Generic_Actual_Type (Typ) then 916 917 -- The restriction on loop parameters is only that the type 918 -- should have no dynamic predicates. 919 920 if Nkind (Parent (N)) = N_Loop_Parameter_Specification 921 and then not Has_Dynamic_Predicate_Aspect (Typ) 922 and then Is_OK_Static_Subtype (Typ) 923 then 924 return; 925 end if; 926 927 Gen := Current_Scope; 928 while not Is_Generic_Instance (Gen) loop 929 Gen := Scope (Gen); 930 end loop; 931 932 pragma Assert (Present (Gen)); 933 934 if Ekind (Gen) = E_Package and then In_Package_Body (Gen) then 935 Error_Msg_Warn := SPARK_Mode /= On; 936 Error_Msg_FE (Msg & "<<", N, Typ); 937 Error_Msg_F ("\Program_Error [<<", N); 938 939 Insert_Action (N, 940 Make_Raise_Program_Error (Sloc (N), 941 Reason => PE_Bad_Predicated_Generic_Type)); 942 943 else 944 Error_Msg_FE (Msg & "<<", N, Typ); 945 end if; 946 947 else 948 Error_Msg_FE (Msg, N, Typ); 949 end if; 950 951 -- Emit an optional suggestion on how to remedy the error if the 952 -- context warrants it. 953 954 if Suggest_Static and then Has_Static_Predicate (Typ) then 955 Error_Msg_FE ("\predicate of & should be marked static", N, Typ); 956 end if; 957 end if; 958 end Bad_Predicated_Subtype_Use; 959 960 ----------------------------------------- 961 -- Bad_Unordered_Enumeration_Reference -- 962 ----------------------------------------- 963 964 function Bad_Unordered_Enumeration_Reference 965 (N : Node_Id; 966 T : Entity_Id) return Boolean 967 is 968 begin 969 return Is_Enumeration_Type (T) 970 and then Warn_On_Unordered_Enumeration_Type 971 and then not Is_Generic_Type (T) 972 and then Comes_From_Source (N) 973 and then not Has_Pragma_Ordered (T) 974 and then not In_Same_Extended_Unit (N, T); 975 end Bad_Unordered_Enumeration_Reference; 976 977 ---------------------------- 978 -- Begin_Keyword_Location -- 979 ---------------------------- 980 981 function Begin_Keyword_Location (N : Node_Id) return Source_Ptr is 982 HSS : Node_Id; 983 984 begin 985 pragma Assert (Nkind_In (N, N_Block_Statement, 986 N_Entry_Body, 987 N_Package_Body, 988 N_Subprogram_Body, 989 N_Task_Body)); 990 991 HSS := Handled_Statement_Sequence (N); 992 993 -- When the handled sequence of statements comes from source, the 994 -- location of the "begin" keyword is that of the sequence itself. 995 -- Note that an internal construct may inherit a source sequence. 996 997 if Comes_From_Source (HSS) then 998 return Sloc (HSS); 999 1000 -- The parser generates an internal handled sequence of statements to 1001 -- capture the location of the "begin" keyword if present in the source. 1002 -- Since there are no source statements, the location of the "begin" 1003 -- keyword is effectively that of the "end" keyword. 1004 1005 elsif Comes_From_Source (N) then 1006 return Sloc (HSS); 1007 1008 -- Otherwise the construct is internal and should carry the location of 1009 -- the original construct which prompted its creation. 1010 1011 else 1012 return Sloc (N); 1013 end if; 1014 end Begin_Keyword_Location; 1015 1016 -------------------------- 1017 -- Build_Actual_Subtype -- 1018 -------------------------- 1019 1020 function Build_Actual_Subtype 1021 (T : Entity_Id; 1022 N : Node_Or_Entity_Id) return Node_Id 1023 is 1024 Loc : Source_Ptr; 1025 -- Normally Sloc (N), but may point to corresponding body in some cases 1026 1027 Constraints : List_Id; 1028 Decl : Node_Id; 1029 Discr : Entity_Id; 1030 Hi : Node_Id; 1031 Lo : Node_Id; 1032 Subt : Entity_Id; 1033 Disc_Type : Entity_Id; 1034 Obj : Node_Id; 1035 1036 begin 1037 Loc := Sloc (N); 1038 1039 if Nkind (N) = N_Defining_Identifier then 1040 Obj := New_Occurrence_Of (N, Loc); 1041 1042 -- If this is a formal parameter of a subprogram declaration, and 1043 -- we are compiling the body, we want the declaration for the 1044 -- actual subtype to carry the source position of the body, to 1045 -- prevent anomalies in gdb when stepping through the code. 1046 1047 if Is_Formal (N) then 1048 declare 1049 Decl : constant Node_Id := Unit_Declaration_Node (Scope (N)); 1050 begin 1051 if Nkind (Decl) = N_Subprogram_Declaration 1052 and then Present (Corresponding_Body (Decl)) 1053 then 1054 Loc := Sloc (Corresponding_Body (Decl)); 1055 end if; 1056 end; 1057 end if; 1058 1059 else 1060 Obj := N; 1061 end if; 1062 1063 if Is_Array_Type (T) then 1064 Constraints := New_List; 1065 for J in 1 .. Number_Dimensions (T) loop 1066 1067 -- Build an array subtype declaration with the nominal subtype and 1068 -- the bounds of the actual. Add the declaration in front of the 1069 -- local declarations for the subprogram, for analysis before any 1070 -- reference to the formal in the body. 1071 1072 Lo := 1073 Make_Attribute_Reference (Loc, 1074 Prefix => 1075 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), 1076 Attribute_Name => Name_First, 1077 Expressions => New_List ( 1078 Make_Integer_Literal (Loc, J))); 1079 1080 Hi := 1081 Make_Attribute_Reference (Loc, 1082 Prefix => 1083 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), 1084 Attribute_Name => Name_Last, 1085 Expressions => New_List ( 1086 Make_Integer_Literal (Loc, J))); 1087 1088 Append (Make_Range (Loc, Lo, Hi), Constraints); 1089 end loop; 1090 1091 -- If the type has unknown discriminants there is no constrained 1092 -- subtype to build. This is never called for a formal or for a 1093 -- lhs, so returning the type is ok ??? 1094 1095 elsif Has_Unknown_Discriminants (T) then 1096 return T; 1097 1098 else 1099 Constraints := New_List; 1100 1101 -- Type T is a generic derived type, inherit the discriminants from 1102 -- the parent type. 1103 1104 if Is_Private_Type (T) 1105 and then No (Full_View (T)) 1106 1107 -- T was flagged as an error if it was declared as a formal 1108 -- derived type with known discriminants. In this case there 1109 -- is no need to look at the parent type since T already carries 1110 -- its own discriminants. 1111 1112 and then not Error_Posted (T) 1113 then 1114 Disc_Type := Etype (Base_Type (T)); 1115 else 1116 Disc_Type := T; 1117 end if; 1118 1119 Discr := First_Discriminant (Disc_Type); 1120 while Present (Discr) loop 1121 Append_To (Constraints, 1122 Make_Selected_Component (Loc, 1123 Prefix => 1124 Duplicate_Subexpr_No_Checks (Obj), 1125 Selector_Name => New_Occurrence_Of (Discr, Loc))); 1126 Next_Discriminant (Discr); 1127 end loop; 1128 end if; 1129 1130 Subt := Make_Temporary (Loc, 'S', Related_Node => N); 1131 Set_Is_Internal (Subt); 1132 1133 Decl := 1134 Make_Subtype_Declaration (Loc, 1135 Defining_Identifier => Subt, 1136 Subtype_Indication => 1137 Make_Subtype_Indication (Loc, 1138 Subtype_Mark => New_Occurrence_Of (T, Loc), 1139 Constraint => 1140 Make_Index_Or_Discriminant_Constraint (Loc, 1141 Constraints => Constraints))); 1142 1143 Mark_Rewrite_Insertion (Decl); 1144 return Decl; 1145 end Build_Actual_Subtype; 1146 1147 --------------------------------------- 1148 -- Build_Actual_Subtype_Of_Component -- 1149 --------------------------------------- 1150 1151 function Build_Actual_Subtype_Of_Component 1152 (T : Entity_Id; 1153 N : Node_Id) return Node_Id 1154 is 1155 Loc : constant Source_Ptr := Sloc (N); 1156 P : constant Node_Id := Prefix (N); 1157 D : Elmt_Id; 1158 Id : Node_Id; 1159 Index_Typ : Entity_Id; 1160 1161 Desig_Typ : Entity_Id; 1162 -- This is either a copy of T, or if T is an access type, then it is 1163 -- the directly designated type of this access type. 1164 1165 function Build_Actual_Array_Constraint return List_Id; 1166 -- If one or more of the bounds of the component depends on 1167 -- discriminants, build actual constraint using the discriminants 1168 -- of the prefix. 1169 1170 function Build_Actual_Record_Constraint return List_Id; 1171 -- Similar to previous one, for discriminated components constrained 1172 -- by the discriminant of the enclosing object. 1173 1174 ----------------------------------- 1175 -- Build_Actual_Array_Constraint -- 1176 ----------------------------------- 1177 1178 function Build_Actual_Array_Constraint return List_Id is 1179 Constraints : constant List_Id := New_List; 1180 Indx : Node_Id; 1181 Hi : Node_Id; 1182 Lo : Node_Id; 1183 Old_Hi : Node_Id; 1184 Old_Lo : Node_Id; 1185 1186 begin 1187 Indx := First_Index (Desig_Typ); 1188 while Present (Indx) loop 1189 Old_Lo := Type_Low_Bound (Etype (Indx)); 1190 Old_Hi := Type_High_Bound (Etype (Indx)); 1191 1192 if Denotes_Discriminant (Old_Lo) then 1193 Lo := 1194 Make_Selected_Component (Loc, 1195 Prefix => New_Copy_Tree (P), 1196 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc)); 1197 1198 else 1199 Lo := New_Copy_Tree (Old_Lo); 1200 1201 -- The new bound will be reanalyzed in the enclosing 1202 -- declaration. For literal bounds that come from a type 1203 -- declaration, the type of the context must be imposed, so 1204 -- insure that analysis will take place. For non-universal 1205 -- types this is not strictly necessary. 1206 1207 Set_Analyzed (Lo, False); 1208 end if; 1209 1210 if Denotes_Discriminant (Old_Hi) then 1211 Hi := 1212 Make_Selected_Component (Loc, 1213 Prefix => New_Copy_Tree (P), 1214 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc)); 1215 1216 else 1217 Hi := New_Copy_Tree (Old_Hi); 1218 Set_Analyzed (Hi, False); 1219 end if; 1220 1221 Append (Make_Range (Loc, Lo, Hi), Constraints); 1222 Next_Index (Indx); 1223 end loop; 1224 1225 return Constraints; 1226 end Build_Actual_Array_Constraint; 1227 1228 ------------------------------------ 1229 -- Build_Actual_Record_Constraint -- 1230 ------------------------------------ 1231 1232 function Build_Actual_Record_Constraint return List_Id is 1233 Constraints : constant List_Id := New_List; 1234 D : Elmt_Id; 1235 D_Val : Node_Id; 1236 1237 begin 1238 D := First_Elmt (Discriminant_Constraint (Desig_Typ)); 1239 while Present (D) loop 1240 if Denotes_Discriminant (Node (D)) then 1241 D_Val := Make_Selected_Component (Loc, 1242 Prefix => New_Copy_Tree (P), 1243 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc)); 1244 1245 else 1246 D_Val := New_Copy_Tree (Node (D)); 1247 end if; 1248 1249 Append (D_Val, Constraints); 1250 Next_Elmt (D); 1251 end loop; 1252 1253 return Constraints; 1254 end Build_Actual_Record_Constraint; 1255 1256 -- Start of processing for Build_Actual_Subtype_Of_Component 1257 1258 begin 1259 -- Why the test for Spec_Expression mode here??? 1260 1261 if In_Spec_Expression then 1262 return Empty; 1263 1264 -- More comments for the rest of this body would be good ??? 1265 1266 elsif Nkind (N) = N_Explicit_Dereference then 1267 if Is_Composite_Type (T) 1268 and then not Is_Constrained (T) 1269 and then not (Is_Class_Wide_Type (T) 1270 and then Is_Constrained (Root_Type (T))) 1271 and then not Has_Unknown_Discriminants (T) 1272 then 1273 -- If the type of the dereference is already constrained, it is an 1274 -- actual subtype. 1275 1276 if Is_Array_Type (Etype (N)) 1277 and then Is_Constrained (Etype (N)) 1278 then 1279 return Empty; 1280 else 1281 Remove_Side_Effects (P); 1282 return Build_Actual_Subtype (T, N); 1283 end if; 1284 else 1285 return Empty; 1286 end if; 1287 end if; 1288 1289 if Ekind (T) = E_Access_Subtype then 1290 Desig_Typ := Designated_Type (T); 1291 else 1292 Desig_Typ := T; 1293 end if; 1294 1295 if Ekind (Desig_Typ) = E_Array_Subtype then 1296 Id := First_Index (Desig_Typ); 1297 while Present (Id) loop 1298 Index_Typ := Underlying_Type (Etype (Id)); 1299 1300 if Denotes_Discriminant (Type_Low_Bound (Index_Typ)) 1301 or else 1302 Denotes_Discriminant (Type_High_Bound (Index_Typ)) 1303 then 1304 Remove_Side_Effects (P); 1305 return 1306 Build_Component_Subtype 1307 (Build_Actual_Array_Constraint, Loc, Base_Type (T)); 1308 end if; 1309 1310 Next_Index (Id); 1311 end loop; 1312 1313 elsif Is_Composite_Type (Desig_Typ) 1314 and then Has_Discriminants (Desig_Typ) 1315 and then not Has_Unknown_Discriminants (Desig_Typ) 1316 then 1317 if Is_Private_Type (Desig_Typ) 1318 and then No (Discriminant_Constraint (Desig_Typ)) 1319 then 1320 Desig_Typ := Full_View (Desig_Typ); 1321 end if; 1322 1323 D := First_Elmt (Discriminant_Constraint (Desig_Typ)); 1324 while Present (D) loop 1325 if Denotes_Discriminant (Node (D)) then 1326 Remove_Side_Effects (P); 1327 return 1328 Build_Component_Subtype ( 1329 Build_Actual_Record_Constraint, Loc, Base_Type (T)); 1330 end if; 1331 1332 Next_Elmt (D); 1333 end loop; 1334 end if; 1335 1336 -- If none of the above, the actual and nominal subtypes are the same 1337 1338 return Empty; 1339 end Build_Actual_Subtype_Of_Component; 1340 1341 --------------------------------- 1342 -- Build_Class_Wide_Clone_Body -- 1343 --------------------------------- 1344 1345 procedure Build_Class_Wide_Clone_Body 1346 (Spec_Id : Entity_Id; 1347 Bod : Node_Id) 1348 is 1349 Loc : constant Source_Ptr := Sloc (Bod); 1350 Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id); 1351 Clone_Body : Node_Id; 1352 1353 begin 1354 -- The declaration of the class-wide clone was created when the 1355 -- corresponding class-wide condition was analyzed. 1356 1357 Clone_Body := 1358 Make_Subprogram_Body (Loc, 1359 Specification => 1360 Copy_Subprogram_Spec (Parent (Clone_Id)), 1361 Declarations => Declarations (Bod), 1362 Handled_Statement_Sequence => Handled_Statement_Sequence (Bod)); 1363 1364 -- The new operation is internal and overriding indicators do not apply 1365 -- (the original primitive may have carried one). 1366 1367 Set_Must_Override (Specification (Clone_Body), False); 1368 1369 -- If the subprogram body is the proper body of a stub, insert the 1370 -- subprogram after the stub, i.e. the same declarative region as 1371 -- the original sugprogram. 1372 1373 if Nkind (Parent (Bod)) = N_Subunit then 1374 Insert_After (Corresponding_Stub (Parent (Bod)), Clone_Body); 1375 1376 else 1377 Insert_Before (Bod, Clone_Body); 1378 end if; 1379 1380 Analyze (Clone_Body); 1381 end Build_Class_Wide_Clone_Body; 1382 1383 --------------------------------- 1384 -- Build_Class_Wide_Clone_Call -- 1385 --------------------------------- 1386 1387 function Build_Class_Wide_Clone_Call 1388 (Loc : Source_Ptr; 1389 Decls : List_Id; 1390 Spec_Id : Entity_Id; 1391 Spec : Node_Id) return Node_Id 1392 is 1393 Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id); 1394 Par_Type : constant Entity_Id := Find_Dispatching_Type (Spec_Id); 1395 1396 Actuals : List_Id; 1397 Call : Node_Id; 1398 Formal : Entity_Id; 1399 New_Body : Node_Id; 1400 New_F_Spec : Entity_Id; 1401 New_Formal : Entity_Id; 1402 1403 begin 1404 Actuals := Empty_List; 1405 Formal := First_Formal (Spec_Id); 1406 New_F_Spec := First (Parameter_Specifications (Spec)); 1407 1408 -- Build parameter association for call to class-wide clone. 1409 1410 while Present (Formal) loop 1411 New_Formal := Defining_Identifier (New_F_Spec); 1412 1413 -- If controlling argument and operation is inherited, add conversion 1414 -- to parent type for the call. 1415 1416 if Etype (Formal) = Par_Type 1417 and then not Is_Empty_List (Decls) 1418 then 1419 Append_To (Actuals, 1420 Make_Type_Conversion (Loc, 1421 New_Occurrence_Of (Par_Type, Loc), 1422 New_Occurrence_Of (New_Formal, Loc))); 1423 1424 else 1425 Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc)); 1426 end if; 1427 1428 Next_Formal (Formal); 1429 Next (New_F_Spec); 1430 end loop; 1431 1432 if Ekind (Spec_Id) = E_Procedure then 1433 Call := 1434 Make_Procedure_Call_Statement (Loc, 1435 Name => New_Occurrence_Of (Clone_Id, Loc), 1436 Parameter_Associations => Actuals); 1437 else 1438 Call := 1439 Make_Simple_Return_Statement (Loc, 1440 Expression => 1441 Make_Function_Call (Loc, 1442 Name => New_Occurrence_Of (Clone_Id, Loc), 1443 Parameter_Associations => Actuals)); 1444 end if; 1445 1446 New_Body := 1447 Make_Subprogram_Body (Loc, 1448 Specification => 1449 Copy_Subprogram_Spec (Spec), 1450 Declarations => Decls, 1451 Handled_Statement_Sequence => 1452 Make_Handled_Sequence_Of_Statements (Loc, 1453 Statements => New_List (Call), 1454 End_Label => Make_Identifier (Loc, Chars (Spec_Id)))); 1455 1456 return New_Body; 1457 end Build_Class_Wide_Clone_Call; 1458 1459 --------------------------------- 1460 -- Build_Class_Wide_Clone_Decl -- 1461 --------------------------------- 1462 1463 procedure Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id) is 1464 Loc : constant Source_Ptr := Sloc (Spec_Id); 1465 Clone_Id : constant Entity_Id := 1466 Make_Defining_Identifier (Loc, 1467 New_External_Name (Chars (Spec_Id), Suffix => "CL")); 1468 1469 Decl : Node_Id; 1470 Spec : Node_Id; 1471 1472 begin 1473 Spec := Copy_Subprogram_Spec (Parent (Spec_Id)); 1474 Set_Must_Override (Spec, False); 1475 Set_Must_Not_Override (Spec, False); 1476 Set_Defining_Unit_Name (Spec, Clone_Id); 1477 1478 Decl := Make_Subprogram_Declaration (Loc, Spec); 1479 Append (Decl, List_Containing (Unit_Declaration_Node (Spec_Id))); 1480 1481 -- Link clone to original subprogram, for use when building body and 1482 -- wrapper call to inherited operation. 1483 1484 Set_Class_Wide_Clone (Spec_Id, Clone_Id); 1485 end Build_Class_Wide_Clone_Decl; 1486 1487 ----------------------------- 1488 -- Build_Component_Subtype -- 1489 ----------------------------- 1490 1491 function Build_Component_Subtype 1492 (C : List_Id; 1493 Loc : Source_Ptr; 1494 T : Entity_Id) return Node_Id 1495 is 1496 Subt : Entity_Id; 1497 Decl : Node_Id; 1498 1499 begin 1500 -- Unchecked_Union components do not require component subtypes 1501 1502 if Is_Unchecked_Union (T) then 1503 return Empty; 1504 end if; 1505 1506 Subt := Make_Temporary (Loc, 'S'); 1507 Set_Is_Internal (Subt); 1508 1509 Decl := 1510 Make_Subtype_Declaration (Loc, 1511 Defining_Identifier => Subt, 1512 Subtype_Indication => 1513 Make_Subtype_Indication (Loc, 1514 Subtype_Mark => New_Occurrence_Of (Base_Type (T), Loc), 1515 Constraint => 1516 Make_Index_Or_Discriminant_Constraint (Loc, 1517 Constraints => C))); 1518 1519 Mark_Rewrite_Insertion (Decl); 1520 return Decl; 1521 end Build_Component_Subtype; 1522 1523 --------------------------- 1524 -- Build_Default_Subtype -- 1525 --------------------------- 1526 1527 function Build_Default_Subtype 1528 (T : Entity_Id; 1529 N : Node_Id) return Entity_Id 1530 is 1531 Loc : constant Source_Ptr := Sloc (N); 1532 Disc : Entity_Id; 1533 1534 Bas : Entity_Id; 1535 -- The base type that is to be constrained by the defaults 1536 1537 begin 1538 if not Has_Discriminants (T) or else Is_Constrained (T) then 1539 return T; 1540 end if; 1541 1542 Bas := Base_Type (T); 1543 1544 -- If T is non-private but its base type is private, this is the 1545 -- completion of a subtype declaration whose parent type is private 1546 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants 1547 -- are to be found in the full view of the base. Check that the private 1548 -- status of T and its base differ. 1549 1550 if Is_Private_Type (Bas) 1551 and then not Is_Private_Type (T) 1552 and then Present (Full_View (Bas)) 1553 then 1554 Bas := Full_View (Bas); 1555 end if; 1556 1557 Disc := First_Discriminant (T); 1558 1559 if No (Discriminant_Default_Value (Disc)) then 1560 return T; 1561 end if; 1562 1563 declare 1564 Act : constant Entity_Id := Make_Temporary (Loc, 'S'); 1565 Constraints : constant List_Id := New_List; 1566 Decl : Node_Id; 1567 1568 begin 1569 while Present (Disc) loop 1570 Append_To (Constraints, 1571 New_Copy_Tree (Discriminant_Default_Value (Disc))); 1572 Next_Discriminant (Disc); 1573 end loop; 1574 1575 Decl := 1576 Make_Subtype_Declaration (Loc, 1577 Defining_Identifier => Act, 1578 Subtype_Indication => 1579 Make_Subtype_Indication (Loc, 1580 Subtype_Mark => New_Occurrence_Of (Bas, Loc), 1581 Constraint => 1582 Make_Index_Or_Discriminant_Constraint (Loc, 1583 Constraints => Constraints))); 1584 1585 Insert_Action (N, Decl); 1586 1587 -- If the context is a component declaration the subtype declaration 1588 -- will be analyzed when the enclosing type is frozen, otherwise do 1589 -- it now. 1590 1591 if Ekind (Current_Scope) /= E_Record_Type then 1592 Analyze (Decl); 1593 end if; 1594 1595 return Act; 1596 end; 1597 end Build_Default_Subtype; 1598 1599 -------------------------------------------- 1600 -- Build_Discriminal_Subtype_Of_Component -- 1601 -------------------------------------------- 1602 1603 function Build_Discriminal_Subtype_Of_Component 1604 (T : Entity_Id) return Node_Id 1605 is 1606 Loc : constant Source_Ptr := Sloc (T); 1607 D : Elmt_Id; 1608 Id : Node_Id; 1609 1610 function Build_Discriminal_Array_Constraint return List_Id; 1611 -- If one or more of the bounds of the component depends on 1612 -- discriminants, build actual constraint using the discriminants 1613 -- of the prefix. 1614 1615 function Build_Discriminal_Record_Constraint return List_Id; 1616 -- Similar to previous one, for discriminated components constrained by 1617 -- the discriminant of the enclosing object. 1618 1619 ---------------------------------------- 1620 -- Build_Discriminal_Array_Constraint -- 1621 ---------------------------------------- 1622 1623 function Build_Discriminal_Array_Constraint return List_Id is 1624 Constraints : constant List_Id := New_List; 1625 Indx : Node_Id; 1626 Hi : Node_Id; 1627 Lo : Node_Id; 1628 Old_Hi : Node_Id; 1629 Old_Lo : Node_Id; 1630 1631 begin 1632 Indx := First_Index (T); 1633 while Present (Indx) loop 1634 Old_Lo := Type_Low_Bound (Etype (Indx)); 1635 Old_Hi := Type_High_Bound (Etype (Indx)); 1636 1637 if Denotes_Discriminant (Old_Lo) then 1638 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc); 1639 1640 else 1641 Lo := New_Copy_Tree (Old_Lo); 1642 end if; 1643 1644 if Denotes_Discriminant (Old_Hi) then 1645 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc); 1646 1647 else 1648 Hi := New_Copy_Tree (Old_Hi); 1649 end if; 1650 1651 Append (Make_Range (Loc, Lo, Hi), Constraints); 1652 Next_Index (Indx); 1653 end loop; 1654 1655 return Constraints; 1656 end Build_Discriminal_Array_Constraint; 1657 1658 ----------------------------------------- 1659 -- Build_Discriminal_Record_Constraint -- 1660 ----------------------------------------- 1661 1662 function Build_Discriminal_Record_Constraint return List_Id is 1663 Constraints : constant List_Id := New_List; 1664 D : Elmt_Id; 1665 D_Val : Node_Id; 1666 1667 begin 1668 D := First_Elmt (Discriminant_Constraint (T)); 1669 while Present (D) loop 1670 if Denotes_Discriminant (Node (D)) then 1671 D_Val := 1672 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc); 1673 else 1674 D_Val := New_Copy_Tree (Node (D)); 1675 end if; 1676 1677 Append (D_Val, Constraints); 1678 Next_Elmt (D); 1679 end loop; 1680 1681 return Constraints; 1682 end Build_Discriminal_Record_Constraint; 1683 1684 -- Start of processing for Build_Discriminal_Subtype_Of_Component 1685 1686 begin 1687 if Ekind (T) = E_Array_Subtype then 1688 Id := First_Index (T); 1689 while Present (Id) loop 1690 if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) 1691 or else 1692 Denotes_Discriminant (Type_High_Bound (Etype (Id))) 1693 then 1694 return Build_Component_Subtype 1695 (Build_Discriminal_Array_Constraint, Loc, T); 1696 end if; 1697 1698 Next_Index (Id); 1699 end loop; 1700 1701 elsif Ekind (T) = E_Record_Subtype 1702 and then Has_Discriminants (T) 1703 and then not Has_Unknown_Discriminants (T) 1704 then 1705 D := First_Elmt (Discriminant_Constraint (T)); 1706 while Present (D) loop 1707 if Denotes_Discriminant (Node (D)) then 1708 return Build_Component_Subtype 1709 (Build_Discriminal_Record_Constraint, Loc, T); 1710 end if; 1711 1712 Next_Elmt (D); 1713 end loop; 1714 end if; 1715 1716 -- If none of the above, the actual and nominal subtypes are the same 1717 1718 return Empty; 1719 end Build_Discriminal_Subtype_Of_Component; 1720 1721 ------------------------------ 1722 -- Build_Elaboration_Entity -- 1723 ------------------------------ 1724 1725 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is 1726 Loc : constant Source_Ptr := Sloc (N); 1727 Decl : Node_Id; 1728 Elab_Ent : Entity_Id; 1729 1730 procedure Set_Package_Name (Ent : Entity_Id); 1731 -- Given an entity, sets the fully qualified name of the entity in 1732 -- Name_Buffer, with components separated by double underscores. This 1733 -- is a recursive routine that climbs the scope chain to Standard. 1734 1735 ---------------------- 1736 -- Set_Package_Name -- 1737 ---------------------- 1738 1739 procedure Set_Package_Name (Ent : Entity_Id) is 1740 begin 1741 if Scope (Ent) /= Standard_Standard then 1742 Set_Package_Name (Scope (Ent)); 1743 1744 declare 1745 Nam : constant String := Get_Name_String (Chars (Ent)); 1746 begin 1747 Name_Buffer (Name_Len + 1) := '_'; 1748 Name_Buffer (Name_Len + 2) := '_'; 1749 Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam; 1750 Name_Len := Name_Len + Nam'Length + 2; 1751 end; 1752 1753 else 1754 Get_Name_String (Chars (Ent)); 1755 end if; 1756 end Set_Package_Name; 1757 1758 -- Start of processing for Build_Elaboration_Entity 1759 1760 begin 1761 -- Ignore call if already constructed 1762 1763 if Present (Elaboration_Entity (Spec_Id)) then 1764 return; 1765 1766 -- Ignore in ASIS mode, elaboration entity is not in source and plays 1767 -- no role in analysis. 1768 1769 elsif ASIS_Mode then 1770 return; 1771 1772 -- Do not generate an elaboration entity in GNATprove move because the 1773 -- elaboration counter is a form of expansion. 1774 1775 elsif GNATprove_Mode then 1776 return; 1777 1778 -- See if we need elaboration entity 1779 1780 -- We always need an elaboration entity when preserving control flow, as 1781 -- we want to remain explicit about the unit's elaboration order. 1782 1783 elsif Opt.Suppress_Control_Flow_Optimizations then 1784 null; 1785 1786 -- We always need an elaboration entity for the dynamic elaboration 1787 -- model, since it is needed to properly generate the PE exception for 1788 -- access before elaboration. 1789 1790 elsif Dynamic_Elaboration_Checks then 1791 null; 1792 1793 -- For the static model, we don't need the elaboration counter if this 1794 -- unit is sure to have no elaboration code, since that means there 1795 -- is no elaboration unit to be called. Note that we can't just decide 1796 -- after the fact by looking to see whether there was elaboration code, 1797 -- because that's too late to make this decision. 1798 1799 elsif Restriction_Active (No_Elaboration_Code) then 1800 return; 1801 1802 -- Similarly, for the static model, we can skip the elaboration counter 1803 -- if we have the No_Multiple_Elaboration restriction, since for the 1804 -- static model, that's the only purpose of the counter (to avoid 1805 -- multiple elaboration). 1806 1807 elsif Restriction_Active (No_Multiple_Elaboration) then 1808 return; 1809 end if; 1810 1811 -- Here we need the elaboration entity 1812 1813 -- Construct name of elaboration entity as xxx_E, where xxx is the unit 1814 -- name with dots replaced by double underscore. We have to manually 1815 -- construct this name, since it will be elaborated in the outer scope, 1816 -- and thus will not have the unit name automatically prepended. 1817 1818 Set_Package_Name (Spec_Id); 1819 Add_Str_To_Name_Buffer ("_E"); 1820 1821 -- Create elaboration counter 1822 1823 Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find); 1824 Set_Elaboration_Entity (Spec_Id, Elab_Ent); 1825 1826 Decl := 1827 Make_Object_Declaration (Loc, 1828 Defining_Identifier => Elab_Ent, 1829 Object_Definition => 1830 New_Occurrence_Of (Standard_Short_Integer, Loc), 1831 Expression => Make_Integer_Literal (Loc, Uint_0)); 1832 1833 Push_Scope (Standard_Standard); 1834 Add_Global_Declaration (Decl); 1835 Pop_Scope; 1836 1837 -- Reset True_Constant indication, since we will indeed assign a value 1838 -- to the variable in the binder main. We also kill the Current_Value 1839 -- and Last_Assignment fields for the same reason. 1840 1841 Set_Is_True_Constant (Elab_Ent, False); 1842 Set_Current_Value (Elab_Ent, Empty); 1843 Set_Last_Assignment (Elab_Ent, Empty); 1844 1845 -- We do not want any further qualification of the name (if we did not 1846 -- do this, we would pick up the name of the generic package in the case 1847 -- of a library level generic instantiation). 1848 1849 Set_Has_Qualified_Name (Elab_Ent); 1850 Set_Has_Fully_Qualified_Name (Elab_Ent); 1851 end Build_Elaboration_Entity; 1852 1853 -------------------------------- 1854 -- Build_Explicit_Dereference -- 1855 -------------------------------- 1856 1857 procedure Build_Explicit_Dereference 1858 (Expr : Node_Id; 1859 Disc : Entity_Id) 1860 is 1861 Loc : constant Source_Ptr := Sloc (Expr); 1862 I : Interp_Index; 1863 It : Interp; 1864 1865 begin 1866 -- An entity of a type with a reference aspect is overloaded with 1867 -- both interpretations: with and without the dereference. Now that 1868 -- the dereference is made explicit, set the type of the node properly, 1869 -- to prevent anomalies in the backend. Same if the expression is an 1870 -- overloaded function call whose return type has a reference aspect. 1871 1872 if Is_Entity_Name (Expr) then 1873 Set_Etype (Expr, Etype (Entity (Expr))); 1874 1875 -- The designated entity will not be examined again when resolving 1876 -- the dereference, so generate a reference to it now. 1877 1878 Generate_Reference (Entity (Expr), Expr); 1879 1880 elsif Nkind (Expr) = N_Function_Call then 1881 1882 -- If the name of the indexing function is overloaded, locate the one 1883 -- whose return type has an implicit dereference on the desired 1884 -- discriminant, and set entity and type of function call. 1885 1886 if Is_Overloaded (Name (Expr)) then 1887 Get_First_Interp (Name (Expr), I, It); 1888 1889 while Present (It.Nam) loop 1890 if Ekind ((It.Typ)) = E_Record_Type 1891 and then First_Entity ((It.Typ)) = Disc 1892 then 1893 Set_Entity (Name (Expr), It.Nam); 1894 Set_Etype (Name (Expr), Etype (It.Nam)); 1895 exit; 1896 end if; 1897 1898 Get_Next_Interp (I, It); 1899 end loop; 1900 end if; 1901 1902 -- Set type of call from resolved function name. 1903 1904 Set_Etype (Expr, Etype (Name (Expr))); 1905 end if; 1906 1907 Set_Is_Overloaded (Expr, False); 1908 1909 -- The expression will often be a generalized indexing that yields a 1910 -- container element that is then dereferenced, in which case the 1911 -- generalized indexing call is also non-overloaded. 1912 1913 if Nkind (Expr) = N_Indexed_Component 1914 and then Present (Generalized_Indexing (Expr)) 1915 then 1916 Set_Is_Overloaded (Generalized_Indexing (Expr), False); 1917 end if; 1918 1919 Rewrite (Expr, 1920 Make_Explicit_Dereference (Loc, 1921 Prefix => 1922 Make_Selected_Component (Loc, 1923 Prefix => Relocate_Node (Expr), 1924 Selector_Name => New_Occurrence_Of (Disc, Loc)))); 1925 Set_Etype (Prefix (Expr), Etype (Disc)); 1926 Set_Etype (Expr, Designated_Type (Etype (Disc))); 1927 end Build_Explicit_Dereference; 1928 1929 --------------------------- 1930 -- Build_Overriding_Spec -- 1931 --------------------------- 1932 1933 function Build_Overriding_Spec 1934 (Op : Entity_Id; 1935 Typ : Entity_Id) return Node_Id 1936 is 1937 Loc : constant Source_Ptr := Sloc (Typ); 1938 Par_Typ : constant Entity_Id := Find_Dispatching_Type (Op); 1939 Spec : constant Node_Id := Specification (Unit_Declaration_Node (Op)); 1940 1941 Formal_Spec : Node_Id; 1942 Formal_Type : Node_Id; 1943 New_Spec : Node_Id; 1944 1945 begin 1946 New_Spec := Copy_Subprogram_Spec (Spec); 1947 1948 Formal_Spec := First (Parameter_Specifications (New_Spec)); 1949 while Present (Formal_Spec) loop 1950 Formal_Type := Parameter_Type (Formal_Spec); 1951 1952 if Is_Entity_Name (Formal_Type) 1953 and then Entity (Formal_Type) = Par_Typ 1954 then 1955 Rewrite (Formal_Type, New_Occurrence_Of (Typ, Loc)); 1956 end if; 1957 1958 -- Nothing needs to be done for access parameters 1959 1960 Next (Formal_Spec); 1961 end loop; 1962 1963 return New_Spec; 1964 end Build_Overriding_Spec; 1965 1966 ----------------------------------- 1967 -- Cannot_Raise_Constraint_Error -- 1968 ----------------------------------- 1969 1970 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is 1971 begin 1972 if Compile_Time_Known_Value (Expr) then 1973 return True; 1974 1975 elsif Do_Range_Check (Expr) then 1976 return False; 1977 1978 elsif Raises_Constraint_Error (Expr) then 1979 return False; 1980 1981 else 1982 case Nkind (Expr) is 1983 when N_Identifier => 1984 return True; 1985 1986 when N_Expanded_Name => 1987 return True; 1988 1989 when N_Selected_Component => 1990 return not Do_Discriminant_Check (Expr); 1991 1992 when N_Attribute_Reference => 1993 if Do_Overflow_Check (Expr) then 1994 return False; 1995 1996 elsif No (Expressions (Expr)) then 1997 return True; 1998 1999 else 2000 declare 2001 N : Node_Id; 2002 2003 begin 2004 N := First (Expressions (Expr)); 2005 while Present (N) loop 2006 if Cannot_Raise_Constraint_Error (N) then 2007 Next (N); 2008 else 2009 return False; 2010 end if; 2011 end loop; 2012 2013 return True; 2014 end; 2015 end if; 2016 2017 when N_Type_Conversion => 2018 if Do_Overflow_Check (Expr) 2019 or else Do_Length_Check (Expr) 2020 or else Do_Tag_Check (Expr) 2021 then 2022 return False; 2023 else 2024 return Cannot_Raise_Constraint_Error (Expression (Expr)); 2025 end if; 2026 2027 when N_Unchecked_Type_Conversion => 2028 return Cannot_Raise_Constraint_Error (Expression (Expr)); 2029 2030 when N_Unary_Op => 2031 if Do_Overflow_Check (Expr) then 2032 return False; 2033 else 2034 return Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 2035 end if; 2036 2037 when N_Op_Divide 2038 | N_Op_Mod 2039 | N_Op_Rem 2040 => 2041 if Do_Division_Check (Expr) 2042 or else 2043 Do_Overflow_Check (Expr) 2044 then 2045 return False; 2046 else 2047 return 2048 Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) 2049 and then 2050 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 2051 end if; 2052 2053 when N_Op_Add 2054 | N_Op_And 2055 | N_Op_Concat 2056 | N_Op_Eq 2057 | N_Op_Expon 2058 | N_Op_Ge 2059 | N_Op_Gt 2060 | N_Op_Le 2061 | N_Op_Lt 2062 | N_Op_Multiply 2063 | N_Op_Ne 2064 | N_Op_Or 2065 | N_Op_Rotate_Left 2066 | N_Op_Rotate_Right 2067 | N_Op_Shift_Left 2068 | N_Op_Shift_Right 2069 | N_Op_Shift_Right_Arithmetic 2070 | N_Op_Subtract 2071 | N_Op_Xor 2072 => 2073 if Do_Overflow_Check (Expr) then 2074 return False; 2075 else 2076 return 2077 Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) 2078 and then 2079 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 2080 end if; 2081 2082 when others => 2083 return False; 2084 end case; 2085 end if; 2086 end Cannot_Raise_Constraint_Error; 2087 2088 ----------------------------------------- 2089 -- Check_Dynamically_Tagged_Expression -- 2090 ----------------------------------------- 2091 2092 procedure Check_Dynamically_Tagged_Expression 2093 (Expr : Node_Id; 2094 Typ : Entity_Id; 2095 Related_Nod : Node_Id) 2096 is 2097 begin 2098 pragma Assert (Is_Tagged_Type (Typ)); 2099 2100 -- In order to avoid spurious errors when analyzing the expanded code, 2101 -- this check is done only for nodes that come from source and for 2102 -- actuals of generic instantiations. 2103 2104 if (Comes_From_Source (Related_Nod) 2105 or else In_Generic_Actual (Expr)) 2106 and then (Is_Class_Wide_Type (Etype (Expr)) 2107 or else Is_Dynamically_Tagged (Expr)) 2108 and then not Is_Class_Wide_Type (Typ) 2109 then 2110 Error_Msg_N ("dynamically tagged expression not allowed!", Expr); 2111 end if; 2112 end Check_Dynamically_Tagged_Expression; 2113 2114 -------------------------- 2115 -- Check_Fully_Declared -- 2116 -------------------------- 2117 2118 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is 2119 begin 2120 if Ekind (T) = E_Incomplete_Type then 2121 2122 -- Ada 2005 (AI-50217): If the type is available through a limited 2123 -- with_clause, verify that its full view has been analyzed. 2124 2125 if From_Limited_With (T) 2126 and then Present (Non_Limited_View (T)) 2127 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type 2128 then 2129 -- The non-limited view is fully declared 2130 2131 null; 2132 2133 else 2134 Error_Msg_NE 2135 ("premature usage of incomplete}", N, First_Subtype (T)); 2136 end if; 2137 2138 -- Need comments for these tests ??? 2139 2140 elsif Has_Private_Component (T) 2141 and then not Is_Generic_Type (Root_Type (T)) 2142 and then not In_Spec_Expression 2143 then 2144 -- Special case: if T is the anonymous type created for a single 2145 -- task or protected object, use the name of the source object. 2146 2147 if Is_Concurrent_Type (T) 2148 and then not Comes_From_Source (T) 2149 and then Nkind (N) = N_Object_Declaration 2150 then 2151 Error_Msg_NE 2152 ("type of& has incomplete component", 2153 N, Defining_Identifier (N)); 2154 else 2155 Error_Msg_NE 2156 ("premature usage of incomplete}", 2157 N, First_Subtype (T)); 2158 end if; 2159 end if; 2160 end Check_Fully_Declared; 2161 2162 ------------------------------------------- 2163 -- Check_Function_With_Address_Parameter -- 2164 ------------------------------------------- 2165 2166 procedure Check_Function_With_Address_Parameter (Subp_Id : Entity_Id) is 2167 F : Entity_Id; 2168 T : Entity_Id; 2169 2170 begin 2171 F := First_Formal (Subp_Id); 2172 while Present (F) loop 2173 T := Etype (F); 2174 2175 if Is_Private_Type (T) and then Present (Full_View (T)) then 2176 T := Full_View (T); 2177 end if; 2178 2179 if Is_Descendant_Of_Address (T) or else Is_Limited_Type (T) then 2180 Set_Is_Pure (Subp_Id, False); 2181 exit; 2182 end if; 2183 2184 Next_Formal (F); 2185 end loop; 2186 end Check_Function_With_Address_Parameter; 2187 2188 ------------------------------------- 2189 -- Check_Function_Writable_Actuals -- 2190 ------------------------------------- 2191 2192 procedure Check_Function_Writable_Actuals (N : Node_Id) is 2193 Writable_Actuals_List : Elist_Id := No_Elist; 2194 Identifiers_List : Elist_Id := No_Elist; 2195 Aggr_Error_Node : Node_Id := Empty; 2196 Error_Node : Node_Id := Empty; 2197 2198 procedure Collect_Identifiers (N : Node_Id); 2199 -- In a single traversal of subtree N collect in Writable_Actuals_List 2200 -- all the actuals of functions with writable actuals, and in the list 2201 -- Identifiers_List collect all the identifiers that are not actuals of 2202 -- functions with writable actuals. If a writable actual is referenced 2203 -- twice as writable actual then Error_Node is set to reference its 2204 -- second occurrence, the error is reported, and the tree traversal 2205 -- is abandoned. 2206 2207 procedure Preanalyze_Without_Errors (N : Node_Id); 2208 -- Preanalyze N without reporting errors. Very dubious, you can't just 2209 -- go analyzing things more than once??? 2210 2211 ------------------------- 2212 -- Collect_Identifiers -- 2213 ------------------------- 2214 2215 procedure Collect_Identifiers (N : Node_Id) is 2216 2217 function Check_Node (N : Node_Id) return Traverse_Result; 2218 -- Process a single node during the tree traversal to collect the 2219 -- writable actuals of functions and all the identifiers which are 2220 -- not writable actuals of functions. 2221 2222 function Contains (List : Elist_Id; N : Node_Id) return Boolean; 2223 -- Returns True if List has a node whose Entity is Entity (N) 2224 2225 ---------------- 2226 -- Check_Node -- 2227 ---------------- 2228 2229 function Check_Node (N : Node_Id) return Traverse_Result is 2230 Is_Writable_Actual : Boolean := False; 2231 Id : Entity_Id; 2232 2233 begin 2234 if Nkind (N) = N_Identifier then 2235 2236 -- No analysis possible if the entity is not decorated 2237 2238 if No (Entity (N)) then 2239 return Skip; 2240 2241 -- Don't collect identifiers of packages, called functions, etc 2242 2243 elsif Ekind_In (Entity (N), E_Package, 2244 E_Function, 2245 E_Procedure, 2246 E_Entry) 2247 then 2248 return Skip; 2249 2250 -- For rewritten nodes, continue the traversal in the original 2251 -- subtree. Needed to handle aggregates in original expressions 2252 -- extracted from the tree by Remove_Side_Effects. 2253 2254 elsif Is_Rewrite_Substitution (N) then 2255 Collect_Identifiers (Original_Node (N)); 2256 return Skip; 2257 2258 -- For now we skip aggregate discriminants, since they require 2259 -- performing the analysis in two phases to identify conflicts: 2260 -- first one analyzing discriminants and second one analyzing 2261 -- the rest of components (since at run time, discriminants are 2262 -- evaluated prior to components): too much computation cost 2263 -- to identify a corner case??? 2264 2265 elsif Nkind (Parent (N)) = N_Component_Association 2266 and then Nkind_In (Parent (Parent (N)), 2267 N_Aggregate, 2268 N_Extension_Aggregate) 2269 then 2270 declare 2271 Choice : constant Node_Id := First (Choices (Parent (N))); 2272 2273 begin 2274 if Ekind (Entity (N)) = E_Discriminant then 2275 return Skip; 2276 2277 elsif Expression (Parent (N)) = N 2278 and then Nkind (Choice) = N_Identifier 2279 and then Ekind (Entity (Choice)) = E_Discriminant 2280 then 2281 return Skip; 2282 end if; 2283 end; 2284 2285 -- Analyze if N is a writable actual of a function 2286 2287 elsif Nkind (Parent (N)) = N_Function_Call then 2288 declare 2289 Call : constant Node_Id := Parent (N); 2290 Actual : Node_Id; 2291 Formal : Node_Id; 2292 2293 begin 2294 Id := Get_Called_Entity (Call); 2295 2296 -- In case of previous error, no check is possible 2297 2298 if No (Id) then 2299 return Abandon; 2300 end if; 2301 2302 if Ekind_In (Id, E_Function, E_Generic_Function) 2303 and then Has_Out_Or_In_Out_Parameter (Id) 2304 then 2305 Formal := First_Formal (Id); 2306 Actual := First_Actual (Call); 2307 while Present (Actual) and then Present (Formal) loop 2308 if Actual = N then 2309 if Ekind_In (Formal, E_Out_Parameter, 2310 E_In_Out_Parameter) 2311 then 2312 Is_Writable_Actual := True; 2313 end if; 2314 2315 exit; 2316 end if; 2317 2318 Next_Formal (Formal); 2319 Next_Actual (Actual); 2320 end loop; 2321 end if; 2322 end; 2323 end if; 2324 2325 if Is_Writable_Actual then 2326 2327 -- Skip checking the error in non-elementary types since 2328 -- RM 6.4.1(6.15/3) is restricted to elementary types, but 2329 -- store this actual in Writable_Actuals_List since it is 2330 -- needed to perform checks on other constructs that have 2331 -- arbitrary order of evaluation (for example, aggregates). 2332 2333 if not Is_Elementary_Type (Etype (N)) then 2334 if not Contains (Writable_Actuals_List, N) then 2335 Append_New_Elmt (N, To => Writable_Actuals_List); 2336 end if; 2337 2338 -- Second occurrence of an elementary type writable actual 2339 2340 elsif Contains (Writable_Actuals_List, N) then 2341 2342 -- Report the error on the second occurrence of the 2343 -- identifier. We cannot assume that N is the second 2344 -- occurrence (according to their location in the 2345 -- sources), since Traverse_Func walks through Field2 2346 -- last (see comment in the body of Traverse_Func). 2347 2348 declare 2349 Elmt : Elmt_Id; 2350 2351 begin 2352 Elmt := First_Elmt (Writable_Actuals_List); 2353 while Present (Elmt) 2354 and then Entity (Node (Elmt)) /= Entity (N) 2355 loop 2356 Next_Elmt (Elmt); 2357 end loop; 2358 2359 if Sloc (N) > Sloc (Node (Elmt)) then 2360 Error_Node := N; 2361 else 2362 Error_Node := Node (Elmt); 2363 end if; 2364 2365 Error_Msg_NE 2366 ("value may be affected by call to & " 2367 & "because order of evaluation is arbitrary", 2368 Error_Node, Id); 2369 return Abandon; 2370 end; 2371 2372 -- First occurrence of a elementary type writable actual 2373 2374 else 2375 Append_New_Elmt (N, To => Writable_Actuals_List); 2376 end if; 2377 2378 else 2379 if Identifiers_List = No_Elist then 2380 Identifiers_List := New_Elmt_List; 2381 end if; 2382 2383 Append_Unique_Elmt (N, Identifiers_List); 2384 end if; 2385 end if; 2386 2387 return OK; 2388 end Check_Node; 2389 2390 -------------- 2391 -- Contains -- 2392 -------------- 2393 2394 function Contains 2395 (List : Elist_Id; 2396 N : Node_Id) return Boolean 2397 is 2398 pragma Assert (Nkind (N) in N_Has_Entity); 2399 2400 Elmt : Elmt_Id; 2401 2402 begin 2403 if List = No_Elist then 2404 return False; 2405 end if; 2406 2407 Elmt := First_Elmt (List); 2408 while Present (Elmt) loop 2409 if Entity (Node (Elmt)) = Entity (N) then 2410 return True; 2411 else 2412 Next_Elmt (Elmt); 2413 end if; 2414 end loop; 2415 2416 return False; 2417 end Contains; 2418 2419 ------------------ 2420 -- Do_Traversal -- 2421 ------------------ 2422 2423 procedure Do_Traversal is new Traverse_Proc (Check_Node); 2424 -- The traversal procedure 2425 2426 -- Start of processing for Collect_Identifiers 2427 2428 begin 2429 if Present (Error_Node) then 2430 return; 2431 end if; 2432 2433 if Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then 2434 return; 2435 end if; 2436 2437 Do_Traversal (N); 2438 end Collect_Identifiers; 2439 2440 ------------------------------- 2441 -- Preanalyze_Without_Errors -- 2442 ------------------------------- 2443 2444 procedure Preanalyze_Without_Errors (N : Node_Id) is 2445 Status : constant Boolean := Get_Ignore_Errors; 2446 begin 2447 Set_Ignore_Errors (True); 2448 Preanalyze (N); 2449 Set_Ignore_Errors (Status); 2450 end Preanalyze_Without_Errors; 2451 2452 -- Start of processing for Check_Function_Writable_Actuals 2453 2454 begin 2455 -- The check only applies to Ada 2012 code on which Check_Actuals has 2456 -- been set, and only to constructs that have multiple constituents 2457 -- whose order of evaluation is not specified by the language. 2458 2459 if Ada_Version < Ada_2012 2460 or else not Check_Actuals (N) 2461 or else (not (Nkind (N) in N_Op) 2462 and then not (Nkind (N) in N_Membership_Test) 2463 and then not Nkind_In (N, N_Range, 2464 N_Aggregate, 2465 N_Extension_Aggregate, 2466 N_Full_Type_Declaration, 2467 N_Function_Call, 2468 N_Procedure_Call_Statement, 2469 N_Entry_Call_Statement)) 2470 or else (Nkind (N) = N_Full_Type_Declaration 2471 and then not Is_Record_Type (Defining_Identifier (N))) 2472 2473 -- In addition, this check only applies to source code, not to code 2474 -- generated by constraint checks. 2475 2476 or else not Comes_From_Source (N) 2477 then 2478 return; 2479 end if; 2480 2481 -- If a construct C has two or more direct constituents that are names 2482 -- or expressions whose evaluation may occur in an arbitrary order, at 2483 -- least one of which contains a function call with an in out or out 2484 -- parameter, then the construct is legal only if: for each name N that 2485 -- is passed as a parameter of mode in out or out to some inner function 2486 -- call C2 (not including the construct C itself), there is no other 2487 -- name anywhere within a direct constituent of the construct C other 2488 -- than the one containing C2, that is known to refer to the same 2489 -- object (RM 6.4.1(6.17/3)). 2490 2491 case Nkind (N) is 2492 when N_Range => 2493 Collect_Identifiers (Low_Bound (N)); 2494 Collect_Identifiers (High_Bound (N)); 2495 2496 when N_Membership_Test 2497 | N_Op 2498 => 2499 declare 2500 Expr : Node_Id; 2501 2502 begin 2503 Collect_Identifiers (Left_Opnd (N)); 2504 2505 if Present (Right_Opnd (N)) then 2506 Collect_Identifiers (Right_Opnd (N)); 2507 end if; 2508 2509 if Nkind_In (N, N_In, N_Not_In) 2510 and then Present (Alternatives (N)) 2511 then 2512 Expr := First (Alternatives (N)); 2513 while Present (Expr) loop 2514 Collect_Identifiers (Expr); 2515 2516 Next (Expr); 2517 end loop; 2518 end if; 2519 end; 2520 2521 when N_Full_Type_Declaration => 2522 declare 2523 function Get_Record_Part (N : Node_Id) return Node_Id; 2524 -- Return the record part of this record type definition 2525 2526 function Get_Record_Part (N : Node_Id) return Node_Id is 2527 Type_Def : constant Node_Id := Type_Definition (N); 2528 begin 2529 if Nkind (Type_Def) = N_Derived_Type_Definition then 2530 return Record_Extension_Part (Type_Def); 2531 else 2532 return Type_Def; 2533 end if; 2534 end Get_Record_Part; 2535 2536 Comp : Node_Id; 2537 Def_Id : Entity_Id := Defining_Identifier (N); 2538 Rec : Node_Id := Get_Record_Part (N); 2539 2540 begin 2541 -- No need to perform any analysis if the record has no 2542 -- components 2543 2544 if No (Rec) or else No (Component_List (Rec)) then 2545 return; 2546 end if; 2547 2548 -- Collect the identifiers starting from the deepest 2549 -- derivation. Done to report the error in the deepest 2550 -- derivation. 2551 2552 loop 2553 if Present (Component_List (Rec)) then 2554 Comp := First (Component_Items (Component_List (Rec))); 2555 while Present (Comp) loop 2556 if Nkind (Comp) = N_Component_Declaration 2557 and then Present (Expression (Comp)) 2558 then 2559 Collect_Identifiers (Expression (Comp)); 2560 end if; 2561 2562 Next (Comp); 2563 end loop; 2564 end if; 2565 2566 exit when No (Underlying_Type (Etype (Def_Id))) 2567 or else Base_Type (Underlying_Type (Etype (Def_Id))) 2568 = Def_Id; 2569 2570 Def_Id := Base_Type (Underlying_Type (Etype (Def_Id))); 2571 Rec := Get_Record_Part (Parent (Def_Id)); 2572 end loop; 2573 end; 2574 2575 when N_Entry_Call_Statement 2576 | N_Subprogram_Call 2577 => 2578 declare 2579 Id : constant Entity_Id := Get_Called_Entity (N); 2580 Formal : Node_Id; 2581 Actual : Node_Id; 2582 2583 begin 2584 Formal := First_Formal (Id); 2585 Actual := First_Actual (N); 2586 while Present (Actual) and then Present (Formal) loop 2587 if Ekind_In (Formal, E_Out_Parameter, 2588 E_In_Out_Parameter) 2589 then 2590 Collect_Identifiers (Actual); 2591 end if; 2592 2593 Next_Formal (Formal); 2594 Next_Actual (Actual); 2595 end loop; 2596 end; 2597 2598 when N_Aggregate 2599 | N_Extension_Aggregate 2600 => 2601 declare 2602 Assoc : Node_Id; 2603 Choice : Node_Id; 2604 Comp_Expr : Node_Id; 2605 2606 begin 2607 -- Handle the N_Others_Choice of array aggregates with static 2608 -- bounds. There is no need to perform this analysis in 2609 -- aggregates without static bounds since we cannot evaluate 2610 -- if the N_Others_Choice covers several elements. There is 2611 -- no need to handle the N_Others choice of record aggregates 2612 -- since at this stage it has been already expanded by 2613 -- Resolve_Record_Aggregate. 2614 2615 if Is_Array_Type (Etype (N)) 2616 and then Nkind (N) = N_Aggregate 2617 and then Present (Aggregate_Bounds (N)) 2618 and then Compile_Time_Known_Bounds (Etype (N)) 2619 and then Expr_Value (High_Bound (Aggregate_Bounds (N))) 2620 > 2621 Expr_Value (Low_Bound (Aggregate_Bounds (N))) 2622 then 2623 declare 2624 Count_Components : Uint := Uint_0; 2625 Num_Components : Uint; 2626 Others_Assoc : Node_Id; 2627 Others_Choice : Node_Id := Empty; 2628 Others_Box_Present : Boolean := False; 2629 2630 begin 2631 -- Count positional associations 2632 2633 if Present (Expressions (N)) then 2634 Comp_Expr := First (Expressions (N)); 2635 while Present (Comp_Expr) loop 2636 Count_Components := Count_Components + 1; 2637 Next (Comp_Expr); 2638 end loop; 2639 end if; 2640 2641 -- Count the rest of elements and locate the N_Others 2642 -- choice (if any) 2643 2644 Assoc := First (Component_Associations (N)); 2645 while Present (Assoc) loop 2646 Choice := First (Choices (Assoc)); 2647 while Present (Choice) loop 2648 if Nkind (Choice) = N_Others_Choice then 2649 Others_Assoc := Assoc; 2650 Others_Choice := Choice; 2651 Others_Box_Present := Box_Present (Assoc); 2652 2653 -- Count several components 2654 2655 elsif Nkind_In (Choice, N_Range, 2656 N_Subtype_Indication) 2657 or else (Is_Entity_Name (Choice) 2658 and then Is_Type (Entity (Choice))) 2659 then 2660 declare 2661 L, H : Node_Id; 2662 begin 2663 Get_Index_Bounds (Choice, L, H); 2664 pragma Assert 2665 (Compile_Time_Known_Value (L) 2666 and then Compile_Time_Known_Value (H)); 2667 Count_Components := 2668 Count_Components 2669 + Expr_Value (H) - Expr_Value (L) + 1; 2670 end; 2671 2672 -- Count single component. No other case available 2673 -- since we are handling an aggregate with static 2674 -- bounds. 2675 2676 else 2677 pragma Assert (Is_OK_Static_Expression (Choice) 2678 or else Nkind (Choice) = N_Identifier 2679 or else Nkind (Choice) = N_Integer_Literal); 2680 2681 Count_Components := Count_Components + 1; 2682 end if; 2683 2684 Next (Choice); 2685 end loop; 2686 2687 Next (Assoc); 2688 end loop; 2689 2690 Num_Components := 2691 Expr_Value (High_Bound (Aggregate_Bounds (N))) - 2692 Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1; 2693 2694 pragma Assert (Count_Components <= Num_Components); 2695 2696 -- Handle the N_Others choice if it covers several 2697 -- components 2698 2699 if Present (Others_Choice) 2700 and then (Num_Components - Count_Components) > 1 2701 then 2702 if not Others_Box_Present then 2703 2704 -- At this stage, if expansion is active, the 2705 -- expression of the others choice has not been 2706 -- analyzed. Hence we generate a duplicate and 2707 -- we analyze it silently to have available the 2708 -- minimum decoration required to collect the 2709 -- identifiers. 2710 2711 if not Expander_Active then 2712 Comp_Expr := Expression (Others_Assoc); 2713 else 2714 Comp_Expr := 2715 New_Copy_Tree (Expression (Others_Assoc)); 2716 Preanalyze_Without_Errors (Comp_Expr); 2717 end if; 2718 2719 Collect_Identifiers (Comp_Expr); 2720 2721 if Writable_Actuals_List /= No_Elist then 2722 2723 -- As suggested by Robert, at current stage we 2724 -- report occurrences of this case as warnings. 2725 2726 Error_Msg_N 2727 ("writable function parameter may affect " 2728 & "value in other component because order " 2729 & "of evaluation is unspecified??", 2730 Node (First_Elmt (Writable_Actuals_List))); 2731 end if; 2732 end if; 2733 end if; 2734 end; 2735 2736 -- For an array aggregate, a discrete_choice_list that has 2737 -- a nonstatic range is considered as two or more separate 2738 -- occurrences of the expression (RM 6.4.1(20/3)). 2739 2740 elsif Is_Array_Type (Etype (N)) 2741 and then Nkind (N) = N_Aggregate 2742 and then Present (Aggregate_Bounds (N)) 2743 and then not Compile_Time_Known_Bounds (Etype (N)) 2744 then 2745 -- Collect identifiers found in the dynamic bounds 2746 2747 declare 2748 Count_Components : Natural := 0; 2749 Low, High : Node_Id; 2750 2751 begin 2752 Assoc := First (Component_Associations (N)); 2753 while Present (Assoc) loop 2754 Choice := First (Choices (Assoc)); 2755 while Present (Choice) loop 2756 if Nkind_In (Choice, N_Range, 2757 N_Subtype_Indication) 2758 or else (Is_Entity_Name (Choice) 2759 and then Is_Type (Entity (Choice))) 2760 then 2761 Get_Index_Bounds (Choice, Low, High); 2762 2763 if not Compile_Time_Known_Value (Low) then 2764 Collect_Identifiers (Low); 2765 2766 if No (Aggr_Error_Node) then 2767 Aggr_Error_Node := Low; 2768 end if; 2769 end if; 2770 2771 if not Compile_Time_Known_Value (High) then 2772 Collect_Identifiers (High); 2773 2774 if No (Aggr_Error_Node) then 2775 Aggr_Error_Node := High; 2776 end if; 2777 end if; 2778 2779 -- The RM rule is violated if there is more than 2780 -- a single choice in a component association. 2781 2782 else 2783 Count_Components := Count_Components + 1; 2784 2785 if No (Aggr_Error_Node) 2786 and then Count_Components > 1 2787 then 2788 Aggr_Error_Node := Choice; 2789 end if; 2790 2791 if not Compile_Time_Known_Value (Choice) then 2792 Collect_Identifiers (Choice); 2793 end if; 2794 end if; 2795 2796 Next (Choice); 2797 end loop; 2798 2799 Next (Assoc); 2800 end loop; 2801 end; 2802 end if; 2803 2804 -- Handle ancestor part of extension aggregates 2805 2806 if Nkind (N) = N_Extension_Aggregate then 2807 Collect_Identifiers (Ancestor_Part (N)); 2808 end if; 2809 2810 -- Handle positional associations 2811 2812 if Present (Expressions (N)) then 2813 Comp_Expr := First (Expressions (N)); 2814 while Present (Comp_Expr) loop 2815 if not Is_OK_Static_Expression (Comp_Expr) then 2816 Collect_Identifiers (Comp_Expr); 2817 end if; 2818 2819 Next (Comp_Expr); 2820 end loop; 2821 end if; 2822 2823 -- Handle discrete associations 2824 2825 if Present (Component_Associations (N)) then 2826 Assoc := First (Component_Associations (N)); 2827 while Present (Assoc) loop 2828 2829 if not Box_Present (Assoc) then 2830 Choice := First (Choices (Assoc)); 2831 while Present (Choice) loop 2832 2833 -- For now we skip discriminants since it requires 2834 -- performing the analysis in two phases: first one 2835 -- analyzing discriminants and second one analyzing 2836 -- the rest of components since discriminants are 2837 -- evaluated prior to components: too much extra 2838 -- work to detect a corner case??? 2839 2840 if Nkind (Choice) in N_Has_Entity 2841 and then Present (Entity (Choice)) 2842 and then Ekind (Entity (Choice)) = E_Discriminant 2843 then 2844 null; 2845 2846 elsif Box_Present (Assoc) then 2847 null; 2848 2849 else 2850 if not Analyzed (Expression (Assoc)) then 2851 Comp_Expr := 2852 New_Copy_Tree (Expression (Assoc)); 2853 Set_Parent (Comp_Expr, Parent (N)); 2854 Preanalyze_Without_Errors (Comp_Expr); 2855 else 2856 Comp_Expr := Expression (Assoc); 2857 end if; 2858 2859 Collect_Identifiers (Comp_Expr); 2860 end if; 2861 2862 Next (Choice); 2863 end loop; 2864 end if; 2865 2866 Next (Assoc); 2867 end loop; 2868 end if; 2869 end; 2870 2871 when others => 2872 return; 2873 end case; 2874 2875 -- No further action needed if we already reported an error 2876 2877 if Present (Error_Node) then 2878 return; 2879 end if; 2880 2881 -- Check violation of RM 6.20/3 in aggregates 2882 2883 if Present (Aggr_Error_Node) 2884 and then Writable_Actuals_List /= No_Elist 2885 then 2886 Error_Msg_N 2887 ("value may be affected by call in other component because they " 2888 & "are evaluated in unspecified order", 2889 Node (First_Elmt (Writable_Actuals_List))); 2890 return; 2891 end if; 2892 2893 -- Check if some writable argument of a function is referenced 2894 2895 if Writable_Actuals_List /= No_Elist 2896 and then Identifiers_List /= No_Elist 2897 then 2898 declare 2899 Elmt_1 : Elmt_Id; 2900 Elmt_2 : Elmt_Id; 2901 2902 begin 2903 Elmt_1 := First_Elmt (Writable_Actuals_List); 2904 while Present (Elmt_1) loop 2905 Elmt_2 := First_Elmt (Identifiers_List); 2906 while Present (Elmt_2) loop 2907 if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then 2908 case Nkind (Parent (Node (Elmt_2))) is 2909 when N_Aggregate 2910 | N_Component_Association 2911 | N_Component_Declaration 2912 => 2913 Error_Msg_N 2914 ("value may be affected by call in other " 2915 & "component because they are evaluated " 2916 & "in unspecified order", 2917 Node (Elmt_2)); 2918 2919 when N_In 2920 | N_Not_In 2921 => 2922 Error_Msg_N 2923 ("value may be affected by call in other " 2924 & "alternative because they are evaluated " 2925 & "in unspecified order", 2926 Node (Elmt_2)); 2927 2928 when others => 2929 Error_Msg_N 2930 ("value of actual may be affected by call in " 2931 & "other actual because they are evaluated " 2932 & "in unspecified order", 2933 Node (Elmt_2)); 2934 end case; 2935 end if; 2936 2937 Next_Elmt (Elmt_2); 2938 end loop; 2939 2940 Next_Elmt (Elmt_1); 2941 end loop; 2942 end; 2943 end if; 2944 end Check_Function_Writable_Actuals; 2945 2946 -------------------------------- 2947 -- Check_Implicit_Dereference -- 2948 -------------------------------- 2949 2950 procedure Check_Implicit_Dereference (N : Node_Id; Typ : Entity_Id) is 2951 Disc : Entity_Id; 2952 Desig : Entity_Id; 2953 Nam : Node_Id; 2954 2955 begin 2956 if Nkind (N) = N_Indexed_Component 2957 and then Present (Generalized_Indexing (N)) 2958 then 2959 Nam := Generalized_Indexing (N); 2960 else 2961 Nam := N; 2962 end if; 2963 2964 if Ada_Version < Ada_2012 2965 or else not Has_Implicit_Dereference (Base_Type (Typ)) 2966 then 2967 return; 2968 2969 elsif not Comes_From_Source (N) 2970 and then Nkind (N) /= N_Indexed_Component 2971 then 2972 return; 2973 2974 elsif Is_Entity_Name (Nam) and then Is_Type (Entity (Nam)) then 2975 null; 2976 2977 else 2978 Disc := First_Discriminant (Typ); 2979 while Present (Disc) loop 2980 if Has_Implicit_Dereference (Disc) then 2981 Desig := Designated_Type (Etype (Disc)); 2982 Add_One_Interp (Nam, Disc, Desig); 2983 2984 -- If the node is a generalized indexing, add interpretation 2985 -- to that node as well, for subsequent resolution. 2986 2987 if Nkind (N) = N_Indexed_Component then 2988 Add_One_Interp (N, Disc, Desig); 2989 end if; 2990 2991 -- If the operation comes from a generic unit and the context 2992 -- is a selected component, the selector name may be global 2993 -- and set in the instance already. Remove the entity to 2994 -- force resolution of the selected component, and the 2995 -- generation of an explicit dereference if needed. 2996 2997 if In_Instance 2998 and then Nkind (Parent (Nam)) = N_Selected_Component 2999 then 3000 Set_Entity (Selector_Name (Parent (Nam)), Empty); 3001 end if; 3002 3003 exit; 3004 end if; 3005 3006 Next_Discriminant (Disc); 3007 end loop; 3008 end if; 3009 end Check_Implicit_Dereference; 3010 3011 ---------------------------------- 3012 -- Check_Internal_Protected_Use -- 3013 ---------------------------------- 3014 3015 procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is 3016 S : Entity_Id; 3017 Prot : Entity_Id; 3018 3019 begin 3020 Prot := Empty; 3021 3022 S := Current_Scope; 3023 while Present (S) loop 3024 if S = Standard_Standard then 3025 exit; 3026 3027 elsif Ekind (S) = E_Function 3028 and then Ekind (Scope (S)) = E_Protected_Type 3029 then 3030 Prot := Scope (S); 3031 exit; 3032 end if; 3033 3034 S := Scope (S); 3035 end loop; 3036 3037 if Present (Prot) 3038 and then Scope (Nam) = Prot 3039 and then Ekind (Nam) /= E_Function 3040 then 3041 -- An indirect function call (e.g. a callback within a protected 3042 -- function body) is not statically illegal. If the access type is 3043 -- anonymous and is the type of an access parameter, the scope of Nam 3044 -- will be the protected type, but it is not a protected operation. 3045 3046 if Ekind (Nam) = E_Subprogram_Type 3047 and then Nkind (Associated_Node_For_Itype (Nam)) = 3048 N_Function_Specification 3049 then 3050 null; 3051 3052 elsif Nkind (N) = N_Subprogram_Renaming_Declaration then 3053 Error_Msg_N 3054 ("within protected function cannot use protected procedure in " 3055 & "renaming or as generic actual", N); 3056 3057 elsif Nkind (N) = N_Attribute_Reference then 3058 Error_Msg_N 3059 ("within protected function cannot take access of protected " 3060 & "procedure", N); 3061 3062 else 3063 Error_Msg_N 3064 ("within protected function, protected object is constant", N); 3065 Error_Msg_N 3066 ("\cannot call operation that may modify it", N); 3067 end if; 3068 end if; 3069 3070 -- Verify that an internal call does not appear within a precondition 3071 -- of a protected operation. This implements AI12-0166. 3072 -- The precondition aspect has been rewritten as a pragma Precondition 3073 -- and we check whether the scope of the called subprogram is the same 3074 -- as that of the entity to which the aspect applies. 3075 3076 if Convention (Nam) = Convention_Protected then 3077 declare 3078 P : Node_Id; 3079 3080 begin 3081 P := Parent (N); 3082 while Present (P) loop 3083 if Nkind (P) = N_Pragma 3084 and then Chars (Pragma_Identifier (P)) = Name_Precondition 3085 and then From_Aspect_Specification (P) 3086 and then 3087 Scope (Entity (Corresponding_Aspect (P))) = Scope (Nam) 3088 then 3089 Error_Msg_N 3090 ("internal call cannot appear in precondition of " 3091 & "protected operation", N); 3092 return; 3093 3094 elsif Nkind (P) = N_Pragma 3095 and then Chars (Pragma_Identifier (P)) = Name_Contract_Cases 3096 then 3097 -- Check whether call is in a case guard. It is legal in a 3098 -- consequence. 3099 3100 P := N; 3101 while Present (P) loop 3102 if Nkind (Parent (P)) = N_Component_Association 3103 and then P /= Expression (Parent (P)) 3104 then 3105 Error_Msg_N 3106 ("internal call cannot appear in case guard in a " 3107 & "contract case", N); 3108 end if; 3109 3110 P := Parent (P); 3111 end loop; 3112 3113 return; 3114 3115 elsif Nkind (P) = N_Parameter_Specification 3116 and then Scope (Current_Scope) = Scope (Nam) 3117 and then Nkind_In (Parent (P), N_Entry_Declaration, 3118 N_Subprogram_Declaration) 3119 then 3120 Error_Msg_N 3121 ("internal call cannot appear in default for formal of " 3122 & "protected operation", N); 3123 return; 3124 end if; 3125 3126 P := Parent (P); 3127 end loop; 3128 end; 3129 end if; 3130 end Check_Internal_Protected_Use; 3131 3132 --------------------------------------- 3133 -- Check_Later_Vs_Basic_Declarations -- 3134 --------------------------------------- 3135 3136 procedure Check_Later_Vs_Basic_Declarations 3137 (Decls : List_Id; 3138 During_Parsing : Boolean) 3139 is 3140 Body_Sloc : Source_Ptr; 3141 Decl : Node_Id; 3142 3143 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean; 3144 -- Return whether Decl is considered as a declarative item. 3145 -- When During_Parsing is True, the semantics of Ada 83 is followed. 3146 -- When During_Parsing is False, the semantics of SPARK is followed. 3147 3148 ------------------------------- 3149 -- Is_Later_Declarative_Item -- 3150 ------------------------------- 3151 3152 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is 3153 begin 3154 if Nkind (Decl) in N_Later_Decl_Item then 3155 return True; 3156 3157 elsif Nkind (Decl) = N_Pragma then 3158 return True; 3159 3160 elsif During_Parsing then 3161 return False; 3162 3163 -- In SPARK, a package declaration is not considered as a later 3164 -- declarative item. 3165 3166 elsif Nkind (Decl) = N_Package_Declaration then 3167 return False; 3168 3169 -- In SPARK, a renaming is considered as a later declarative item 3170 3171 elsif Nkind (Decl) in N_Renaming_Declaration then 3172 return True; 3173 3174 else 3175 return False; 3176 end if; 3177 end Is_Later_Declarative_Item; 3178 3179 -- Start of processing for Check_Later_Vs_Basic_Declarations 3180 3181 begin 3182 Decl := First (Decls); 3183 3184 -- Loop through sequence of basic declarative items 3185 3186 Outer : while Present (Decl) loop 3187 if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body) 3188 and then Nkind (Decl) not in N_Body_Stub 3189 then 3190 Next (Decl); 3191 3192 -- Once a body is encountered, we only allow later declarative 3193 -- items. The inner loop checks the rest of the list. 3194 3195 else 3196 Body_Sloc := Sloc (Decl); 3197 3198 Inner : while Present (Decl) loop 3199 if not Is_Later_Declarative_Item (Decl) then 3200 if During_Parsing then 3201 if Ada_Version = Ada_83 then 3202 Error_Msg_Sloc := Body_Sloc; 3203 Error_Msg_N 3204 ("(Ada 83) decl cannot appear after body#", Decl); 3205 end if; 3206 else 3207 Error_Msg_Sloc := Body_Sloc; 3208 Check_SPARK_05_Restriction 3209 ("decl cannot appear after body#", Decl); 3210 end if; 3211 end if; 3212 3213 Next (Decl); 3214 end loop Inner; 3215 end if; 3216 end loop Outer; 3217 end Check_Later_Vs_Basic_Declarations; 3218 3219 --------------------------- 3220 -- Check_No_Hidden_State -- 3221 --------------------------- 3222 3223 procedure Check_No_Hidden_State (Id : Entity_Id) is 3224 Context : Entity_Id := Empty; 3225 Not_Visible : Boolean := False; 3226 Scop : Entity_Id; 3227 3228 begin 3229 pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable)); 3230 3231 -- Nothing to do for internally-generated abstract states and variables 3232 -- because they do not represent the hidden state of the source unit. 3233 3234 if not Comes_From_Source (Id) then 3235 return; 3236 end if; 3237 3238 -- Find the proper context where the object or state appears 3239 3240 Scop := Scope (Id); 3241 while Present (Scop) loop 3242 Context := Scop; 3243 3244 -- Keep track of the context's visibility 3245 3246 Not_Visible := Not_Visible or else In_Private_Part (Context); 3247 3248 -- Prevent the search from going too far 3249 3250 if Context = Standard_Standard then 3251 return; 3252 3253 -- Objects and states that appear immediately within a subprogram or 3254 -- inside a construct nested within a subprogram do not introduce a 3255 -- hidden state. They behave as local variable declarations. 3256 3257 elsif Is_Subprogram (Context) then 3258 return; 3259 3260 -- When examining a package body, use the entity of the spec as it 3261 -- carries the abstract state declarations. 3262 3263 elsif Ekind (Context) = E_Package_Body then 3264 Context := Spec_Entity (Context); 3265 end if; 3266 3267 -- Stop the traversal when a package subject to a null abstract state 3268 -- has been found. 3269 3270 if Ekind_In (Context, E_Generic_Package, E_Package) 3271 and then Has_Null_Abstract_State (Context) 3272 then 3273 exit; 3274 end if; 3275 3276 Scop := Scope (Scop); 3277 end loop; 3278 3279 -- At this point we know that there is at least one package with a null 3280 -- abstract state in visibility. Emit an error message unconditionally 3281 -- if the entity being processed is a state because the placement of the 3282 -- related package is irrelevant. This is not the case for objects as 3283 -- the intermediate context matters. 3284 3285 if Present (Context) 3286 and then (Ekind (Id) = E_Abstract_State or else Not_Visible) 3287 then 3288 Error_Msg_N ("cannot introduce hidden state &", Id); 3289 Error_Msg_NE ("\package & has null abstract state", Id, Context); 3290 end if; 3291 end Check_No_Hidden_State; 3292 3293 ---------------------------------------- 3294 -- Check_Nonvolatile_Function_Profile -- 3295 ---------------------------------------- 3296 3297 procedure Check_Nonvolatile_Function_Profile (Func_Id : Entity_Id) is 3298 Formal : Entity_Id; 3299 3300 begin 3301 -- Inspect all formal parameters 3302 3303 Formal := First_Formal (Func_Id); 3304 while Present (Formal) loop 3305 if Is_Effectively_Volatile (Etype (Formal)) then 3306 Error_Msg_NE 3307 ("nonvolatile function & cannot have a volatile parameter", 3308 Formal, Func_Id); 3309 end if; 3310 3311 Next_Formal (Formal); 3312 end loop; 3313 3314 -- Inspect the return type 3315 3316 if Is_Effectively_Volatile (Etype (Func_Id)) then 3317 Error_Msg_NE 3318 ("nonvolatile function & cannot have a volatile return type", 3319 Result_Definition (Parent (Func_Id)), Func_Id); 3320 end if; 3321 end Check_Nonvolatile_Function_Profile; 3322 3323 ----------------------------- 3324 -- Check_Part_Of_Reference -- 3325 ----------------------------- 3326 3327 procedure Check_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id) is 3328 function Is_Enclosing_Package_Body 3329 (Body_Decl : Node_Id; 3330 Obj_Id : Entity_Id) return Boolean; 3331 pragma Inline (Is_Enclosing_Package_Body); 3332 -- Determine whether package body Body_Decl or its corresponding spec 3333 -- immediately encloses the declaration of object Obj_Id. 3334 3335 function Is_Internal_Declaration_Or_Body 3336 (Decl : Node_Id) return Boolean; 3337 pragma Inline (Is_Internal_Declaration_Or_Body); 3338 -- Determine whether declaration or body denoted by Decl is internal 3339 3340 function Is_Single_Declaration_Or_Body 3341 (Decl : Node_Id; 3342 Conc_Typ : Entity_Id) return Boolean; 3343 pragma Inline (Is_Single_Declaration_Or_Body); 3344 -- Determine whether protected/task declaration or body denoted by Decl 3345 -- belongs to single concurrent type Conc_Typ. 3346 3347 function Is_Single_Task_Pragma 3348 (Prag : Node_Id; 3349 Task_Typ : Entity_Id) return Boolean; 3350 pragma Inline (Is_Single_Task_Pragma); 3351 -- Determine whether pragma Prag belongs to single task type Task_Typ 3352 3353 ------------------------------- 3354 -- Is_Enclosing_Package_Body -- 3355 ------------------------------- 3356 3357 function Is_Enclosing_Package_Body 3358 (Body_Decl : Node_Id; 3359 Obj_Id : Entity_Id) return Boolean 3360 is 3361 Obj_Context : Node_Id; 3362 3363 begin 3364 -- Find the context of the object declaration 3365 3366 Obj_Context := Parent (Declaration_Node (Obj_Id)); 3367 3368 if Nkind (Obj_Context) = N_Package_Specification then 3369 Obj_Context := Parent (Obj_Context); 3370 end if; 3371 3372 -- The object appears immediately within the package body 3373 3374 if Obj_Context = Body_Decl then 3375 return True; 3376 3377 -- The object appears immediately within the corresponding spec 3378 3379 elsif Nkind (Obj_Context) = N_Package_Declaration 3380 and then Unit_Declaration_Node (Corresponding_Spec (Body_Decl)) = 3381 Obj_Context 3382 then 3383 return True; 3384 end if; 3385 3386 return False; 3387 end Is_Enclosing_Package_Body; 3388 3389 ------------------------------------- 3390 -- Is_Internal_Declaration_Or_Body -- 3391 ------------------------------------- 3392 3393 function Is_Internal_Declaration_Or_Body 3394 (Decl : Node_Id) return Boolean 3395 is 3396 begin 3397 if Comes_From_Source (Decl) then 3398 return False; 3399 3400 -- A body generated for an expression function which has not been 3401 -- inserted into the tree yet (In_Spec_Expression is True) is not 3402 -- considered internal. 3403 3404 elsif Nkind (Decl) = N_Subprogram_Body 3405 and then Was_Expression_Function (Decl) 3406 and then not In_Spec_Expression 3407 then 3408 return False; 3409 end if; 3410 3411 return True; 3412 end Is_Internal_Declaration_Or_Body; 3413 3414 ----------------------------------- 3415 -- Is_Single_Declaration_Or_Body -- 3416 ----------------------------------- 3417 3418 function Is_Single_Declaration_Or_Body 3419 (Decl : Node_Id; 3420 Conc_Typ : Entity_Id) return Boolean 3421 is 3422 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl); 3423 3424 begin 3425 return 3426 Present (Anonymous_Object (Spec_Id)) 3427 and then Anonymous_Object (Spec_Id) = Conc_Typ; 3428 end Is_Single_Declaration_Or_Body; 3429 3430 --------------------------- 3431 -- Is_Single_Task_Pragma -- 3432 --------------------------- 3433 3434 function Is_Single_Task_Pragma 3435 (Prag : Node_Id; 3436 Task_Typ : Entity_Id) return Boolean 3437 is 3438 Decl : constant Node_Id := Find_Related_Declaration_Or_Body (Prag); 3439 3440 begin 3441 -- To qualify, the pragma must be associated with single task type 3442 -- Task_Typ. 3443 3444 return 3445 Is_Single_Task_Object (Task_Typ) 3446 and then Nkind (Decl) = N_Object_Declaration 3447 and then Defining_Entity (Decl) = Task_Typ; 3448 end Is_Single_Task_Pragma; 3449 3450 -- Local variables 3451 3452 Conc_Obj : constant Entity_Id := Encapsulating_State (Var_Id); 3453 Par : Node_Id; 3454 Prag_Nam : Name_Id; 3455 Prev : Node_Id; 3456 3457 -- Start of processing for Check_Part_Of_Reference 3458 3459 begin 3460 -- Nothing to do when the variable was recorded, but did not become a 3461 -- constituent of a single concurrent type. 3462 3463 if No (Conc_Obj) then 3464 return; 3465 end if; 3466 3467 -- Traverse the parent chain looking for a suitable context for the 3468 -- reference to the concurrent constituent. 3469 3470 Prev := Ref; 3471 Par := Parent (Prev); 3472 while Present (Par) loop 3473 if Nkind (Par) = N_Pragma then 3474 Prag_Nam := Pragma_Name (Par); 3475 3476 -- A concurrent constituent is allowed to appear in pragmas 3477 -- Initial_Condition and Initializes as this is part of the 3478 -- elaboration checks for the constituent (SPARK RM 9(3)). 3479 3480 if Nam_In (Prag_Nam, Name_Initial_Condition, Name_Initializes) then 3481 return; 3482 3483 -- When the reference appears within pragma Depends or Global, 3484 -- check whether the pragma applies to a single task type. Note 3485 -- that the pragma may not encapsulated by the type definition, 3486 -- but this is still a valid context. 3487 3488 elsif Nam_In (Prag_Nam, Name_Depends, Name_Global) 3489 and then Is_Single_Task_Pragma (Par, Conc_Obj) 3490 then 3491 return; 3492 end if; 3493 3494 -- The reference appears somewhere in the definition of a single 3495 -- concurrent type (SPARK RM 9(3)). 3496 3497 elsif Nkind_In (Par, N_Single_Protected_Declaration, 3498 N_Single_Task_Declaration) 3499 and then Defining_Entity (Par) = Conc_Obj 3500 then 3501 return; 3502 3503 -- The reference appears within the declaration or body of a single 3504 -- concurrent type (SPARK RM 9(3)). 3505 3506 elsif Nkind_In (Par, N_Protected_Body, 3507 N_Protected_Type_Declaration, 3508 N_Task_Body, 3509 N_Task_Type_Declaration) 3510 and then Is_Single_Declaration_Or_Body (Par, Conc_Obj) 3511 then 3512 return; 3513 3514 -- The reference appears within the statement list of the object's 3515 -- immediately enclosing package (SPARK RM 9(3)). 3516 3517 elsif Nkind (Par) = N_Package_Body 3518 and then Nkind (Prev) = N_Handled_Sequence_Of_Statements 3519 and then Is_Enclosing_Package_Body (Par, Var_Id) 3520 then 3521 return; 3522 3523 -- The reference has been relocated within an internally generated 3524 -- package or subprogram. Assume that the reference is legal as the 3525 -- real check was already performed in the original context of the 3526 -- reference. 3527 3528 elsif Nkind_In (Par, N_Package_Body, 3529 N_Package_Declaration, 3530 N_Subprogram_Body, 3531 N_Subprogram_Declaration) 3532 and then Is_Internal_Declaration_Or_Body (Par) 3533 then 3534 return; 3535 3536 -- The reference has been relocated to an inlined body for GNATprove. 3537 -- Assume that the reference is legal as the real check was already 3538 -- performed in the original context of the reference. 3539 3540 elsif GNATprove_Mode 3541 and then Nkind (Par) = N_Subprogram_Body 3542 and then Chars (Defining_Entity (Par)) = Name_uParent 3543 then 3544 return; 3545 end if; 3546 3547 Prev := Par; 3548 Par := Parent (Prev); 3549 end loop; 3550 3551 -- At this point it is known that the reference does not appear within a 3552 -- legal context. 3553 3554 Error_Msg_NE 3555 ("reference to variable & cannot appear in this context", Ref, Var_Id); 3556 Error_Msg_Name_1 := Chars (Var_Id); 3557 3558 if Is_Single_Protected_Object (Conc_Obj) then 3559 Error_Msg_NE 3560 ("\% is constituent of single protected type &", Ref, Conc_Obj); 3561 3562 else 3563 Error_Msg_NE 3564 ("\% is constituent of single task type &", Ref, Conc_Obj); 3565 end if; 3566 end Check_Part_Of_Reference; 3567 3568 ------------------------------------------ 3569 -- Check_Potentially_Blocking_Operation -- 3570 ------------------------------------------ 3571 3572 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is 3573 S : Entity_Id; 3574 3575 begin 3576 -- N is one of the potentially blocking operations listed in 9.5.1(8). 3577 -- When pragma Detect_Blocking is active, the run time will raise 3578 -- Program_Error. Here we only issue a warning, since we generally 3579 -- support the use of potentially blocking operations in the absence 3580 -- of the pragma. 3581 3582 -- Indirect blocking through a subprogram call cannot be diagnosed 3583 -- statically without interprocedural analysis, so we do not attempt 3584 -- to do it here. 3585 3586 S := Scope (Current_Scope); 3587 while Present (S) and then S /= Standard_Standard loop 3588 if Is_Protected_Type (S) then 3589 Error_Msg_N 3590 ("potentially blocking operation in protected operation??", N); 3591 return; 3592 end if; 3593 3594 S := Scope (S); 3595 end loop; 3596 end Check_Potentially_Blocking_Operation; 3597 3598 ------------------------------------ 3599 -- Check_Previous_Null_Procedure -- 3600 ------------------------------------ 3601 3602 procedure Check_Previous_Null_Procedure 3603 (Decl : Node_Id; 3604 Prev : Entity_Id) 3605 is 3606 begin 3607 if Ekind (Prev) = E_Procedure 3608 and then Nkind (Parent (Prev)) = N_Procedure_Specification 3609 and then Null_Present (Parent (Prev)) 3610 then 3611 Error_Msg_Sloc := Sloc (Prev); 3612 Error_Msg_N 3613 ("declaration cannot complete previous null procedure#", Decl); 3614 end if; 3615 end Check_Previous_Null_Procedure; 3616 3617 --------------------------------- 3618 -- Check_Result_And_Post_State -- 3619 --------------------------------- 3620 3621 procedure Check_Result_And_Post_State (Subp_Id : Entity_Id) is 3622 procedure Check_Result_And_Post_State_In_Pragma 3623 (Prag : Node_Id; 3624 Result_Seen : in out Boolean); 3625 -- Determine whether pragma Prag mentions attribute 'Result and whether 3626 -- the pragma contains an expression that evaluates differently in pre- 3627 -- and post-state. Prag is a [refined] postcondition or a contract-cases 3628 -- pragma. Result_Seen is set when the pragma mentions attribute 'Result 3629 3630 function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean; 3631 -- Determine whether subprogram Subp_Id contains at least one IN OUT 3632 -- formal parameter. 3633 3634 ------------------------------------------- 3635 -- Check_Result_And_Post_State_In_Pragma -- 3636 ------------------------------------------- 3637 3638 procedure Check_Result_And_Post_State_In_Pragma 3639 (Prag : Node_Id; 3640 Result_Seen : in out Boolean) 3641 is 3642 procedure Check_Conjunct (Expr : Node_Id); 3643 -- Check an individual conjunct in a conjunction of Boolean 3644 -- expressions, connected by "and" or "and then" operators. 3645 3646 procedure Check_Conjuncts (Expr : Node_Id); 3647 -- Apply the post-state check to every conjunct in an expression, in 3648 -- case this is a conjunction of Boolean expressions. Otherwise apply 3649 -- it to the expression as a whole. 3650 3651 procedure Check_Expression (Expr : Node_Id); 3652 -- Perform the 'Result and post-state checks on a given expression 3653 3654 function Is_Function_Result (N : Node_Id) return Traverse_Result; 3655 -- Attempt to find attribute 'Result in a subtree denoted by N 3656 3657 function Is_Trivial_Boolean (N : Node_Id) return Boolean; 3658 -- Determine whether source node N denotes "True" or "False" 3659 3660 function Mentions_Post_State (N : Node_Id) return Boolean; 3661 -- Determine whether a subtree denoted by N mentions any construct 3662 -- that denotes a post-state. 3663 3664 procedure Check_Function_Result is 3665 new Traverse_Proc (Is_Function_Result); 3666 3667 -------------------- 3668 -- Check_Conjunct -- 3669 -------------------- 3670 3671 procedure Check_Conjunct (Expr : Node_Id) is 3672 function Adjust_Message (Msg : String) return String; 3673 -- Prepend a prefix to the input message Msg denoting that the 3674 -- message applies to a conjunct in the expression, when this 3675 -- is the case. 3676 3677 function Applied_On_Conjunct return Boolean; 3678 -- Returns True if the message applies to a conjunct in the 3679 -- expression, instead of the whole expression. 3680 3681 function Has_Global_Output (Subp : Entity_Id) return Boolean; 3682 -- Returns True if Subp has an output in its Global contract 3683 3684 function Has_No_Output (Subp : Entity_Id) return Boolean; 3685 -- Returns True if Subp has no declared output: no function 3686 -- result, no output parameter, and no output in its Global 3687 -- contract. 3688 3689 -------------------- 3690 -- Adjust_Message -- 3691 -------------------- 3692 3693 function Adjust_Message (Msg : String) return String is 3694 begin 3695 if Applied_On_Conjunct then 3696 return "conjunct in " & Msg; 3697 else 3698 return Msg; 3699 end if; 3700 end Adjust_Message; 3701 3702 ------------------------- 3703 -- Applied_On_Conjunct -- 3704 ------------------------- 3705 3706 function Applied_On_Conjunct return Boolean is 3707 begin 3708 -- Expr is the conjunct of an enclosing "and" expression 3709 3710 return Nkind (Parent (Expr)) in N_Subexpr 3711 3712 -- or Expr is a conjunct of an enclosing "and then" 3713 -- expression in a postcondition aspect that was split into 3714 -- multiple pragmas. The first conjunct has the "and then" 3715 -- expression as Original_Node, and other conjuncts have 3716 -- Split_PCC set to True. 3717 3718 or else Nkind (Original_Node (Expr)) = N_And_Then 3719 or else Split_PPC (Prag); 3720 end Applied_On_Conjunct; 3721 3722 ----------------------- 3723 -- Has_Global_Output -- 3724 ----------------------- 3725 3726 function Has_Global_Output (Subp : Entity_Id) return Boolean is 3727 Global : constant Node_Id := Get_Pragma (Subp, Pragma_Global); 3728 List : Node_Id; 3729 Assoc : Node_Id; 3730 3731 begin 3732 if No (Global) then 3733 return False; 3734 end if; 3735 3736 List := Expression (Get_Argument (Global, Subp)); 3737 3738 -- Empty list (no global items) or single global item 3739 -- declaration (only input items). 3740 3741 if Nkind_In (List, N_Null, 3742 N_Expanded_Name, 3743 N_Identifier, 3744 N_Selected_Component) 3745 then 3746 return False; 3747 3748 -- Simple global list (only input items) or moded global list 3749 -- declaration. 3750 3751 elsif Nkind (List) = N_Aggregate then 3752 if Present (Expressions (List)) then 3753 return False; 3754 3755 else 3756 Assoc := First (Component_Associations (List)); 3757 while Present (Assoc) loop 3758 if Chars (First (Choices (Assoc))) /= Name_Input then 3759 return True; 3760 end if; 3761 3762 Next (Assoc); 3763 end loop; 3764 3765 return False; 3766 end if; 3767 3768 -- To accommodate partial decoration of disabled SPARK 3769 -- features, this routine may be called with illegal input. 3770 -- If this is the case, do not raise Program_Error. 3771 3772 else 3773 return False; 3774 end if; 3775 end Has_Global_Output; 3776 3777 ------------------- 3778 -- Has_No_Output -- 3779 ------------------- 3780 3781 function Has_No_Output (Subp : Entity_Id) return Boolean is 3782 Param : Node_Id; 3783 3784 begin 3785 -- A function has its result as output 3786 3787 if Ekind (Subp) = E_Function then 3788 return False; 3789 end if; 3790 3791 -- An OUT or IN OUT parameter is an output 3792 3793 Param := First_Formal (Subp); 3794 while Present (Param) loop 3795 if Ekind_In (Param, E_Out_Parameter, E_In_Out_Parameter) then 3796 return False; 3797 end if; 3798 3799 Next_Formal (Param); 3800 end loop; 3801 3802 -- An item of mode Output or In_Out in the Global contract is 3803 -- an output. 3804 3805 if Has_Global_Output (Subp) then 3806 return False; 3807 end if; 3808 3809 return True; 3810 end Has_No_Output; 3811 3812 -- Local variables 3813 3814 Err_Node : Node_Id; 3815 -- Error node when reporting a warning on a (refined) 3816 -- postcondition. 3817 3818 -- Start of processing for Check_Conjunct 3819 3820 begin 3821 if Applied_On_Conjunct then 3822 Err_Node := Expr; 3823 else 3824 Err_Node := Prag; 3825 end if; 3826 3827 -- Do not report missing reference to outcome in postcondition if 3828 -- either the postcondition is trivially True or False, or if the 3829 -- subprogram is ghost and has no declared output. 3830 3831 if not Is_Trivial_Boolean (Expr) 3832 and then not Mentions_Post_State (Expr) 3833 and then not (Is_Ghost_Entity (Subp_Id) 3834 and then Has_No_Output (Subp_Id)) 3835 then 3836 if Pragma_Name (Prag) = Name_Contract_Cases then 3837 Error_Msg_NE (Adjust_Message 3838 ("contract case does not check the outcome of calling " 3839 & "&?T?"), Expr, Subp_Id); 3840 3841 elsif Pragma_Name (Prag) = Name_Refined_Post then 3842 Error_Msg_NE (Adjust_Message 3843 ("refined postcondition does not check the outcome of " 3844 & "calling &?T?"), Err_Node, Subp_Id); 3845 3846 else 3847 Error_Msg_NE (Adjust_Message 3848 ("postcondition does not check the outcome of calling " 3849 & "&?T?"), Err_Node, Subp_Id); 3850 end if; 3851 end if; 3852 end Check_Conjunct; 3853 3854 --------------------- 3855 -- Check_Conjuncts -- 3856 --------------------- 3857 3858 procedure Check_Conjuncts (Expr : Node_Id) is 3859 begin 3860 if Nkind_In (Expr, N_Op_And, N_And_Then) then 3861 Check_Conjuncts (Left_Opnd (Expr)); 3862 Check_Conjuncts (Right_Opnd (Expr)); 3863 else 3864 Check_Conjunct (Expr); 3865 end if; 3866 end Check_Conjuncts; 3867 3868 ---------------------- 3869 -- Check_Expression -- 3870 ---------------------- 3871 3872 procedure Check_Expression (Expr : Node_Id) is 3873 begin 3874 if not Is_Trivial_Boolean (Expr) then 3875 Check_Function_Result (Expr); 3876 Check_Conjuncts (Expr); 3877 end if; 3878 end Check_Expression; 3879 3880 ------------------------ 3881 -- Is_Function_Result -- 3882 ------------------------ 3883 3884 function Is_Function_Result (N : Node_Id) return Traverse_Result is 3885 begin 3886 if Is_Attribute_Result (N) then 3887 Result_Seen := True; 3888 return Abandon; 3889 3890 -- Warn on infinite recursion if call is to current function 3891 3892 elsif Nkind (N) = N_Function_Call 3893 and then Is_Entity_Name (Name (N)) 3894 and then Entity (Name (N)) = Subp_Id 3895 and then not Is_Potentially_Unevaluated (N) 3896 then 3897 Error_Msg_NE 3898 ("call to & within its postcondition will lead to infinite " 3899 & "recursion?", N, Subp_Id); 3900 return OK; 3901 3902 -- Continue the traversal 3903 3904 else 3905 return OK; 3906 end if; 3907 end Is_Function_Result; 3908 3909 ------------------------ 3910 -- Is_Trivial_Boolean -- 3911 ------------------------ 3912 3913 function Is_Trivial_Boolean (N : Node_Id) return Boolean is 3914 begin 3915 return 3916 Comes_From_Source (N) 3917 and then Is_Entity_Name (N) 3918 and then (Entity (N) = Standard_True 3919 or else 3920 Entity (N) = Standard_False); 3921 end Is_Trivial_Boolean; 3922 3923 ------------------------- 3924 -- Mentions_Post_State -- 3925 ------------------------- 3926 3927 function Mentions_Post_State (N : Node_Id) return Boolean is 3928 Post_State_Seen : Boolean := False; 3929 3930 function Is_Post_State (N : Node_Id) return Traverse_Result; 3931 -- Attempt to find a construct that denotes a post-state. If this 3932 -- is the case, set flag Post_State_Seen. 3933 3934 ------------------- 3935 -- Is_Post_State -- 3936 ------------------- 3937 3938 function Is_Post_State (N : Node_Id) return Traverse_Result is 3939 Ent : Entity_Id; 3940 3941 begin 3942 if Nkind_In (N, N_Explicit_Dereference, N_Function_Call) then 3943 Post_State_Seen := True; 3944 return Abandon; 3945 3946 elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then 3947 Ent := Entity (N); 3948 3949 -- Treat an undecorated reference as OK 3950 3951 if No (Ent) 3952 3953 -- A reference to an assignable entity is considered a 3954 -- change in the post-state of a subprogram. 3955 3956 or else Ekind_In (Ent, E_Generic_In_Out_Parameter, 3957 E_In_Out_Parameter, 3958 E_Out_Parameter, 3959 E_Variable) 3960 3961 -- The reference may be modified through a dereference 3962 3963 or else (Is_Access_Type (Etype (Ent)) 3964 and then Nkind (Parent (N)) = 3965 N_Selected_Component) 3966 then 3967 Post_State_Seen := True; 3968 return Abandon; 3969 end if; 3970 3971 elsif Nkind (N) = N_Attribute_Reference then 3972 if Attribute_Name (N) = Name_Old then 3973 return Skip; 3974 3975 elsif Attribute_Name (N) = Name_Result then 3976 Post_State_Seen := True; 3977 return Abandon; 3978 end if; 3979 end if; 3980 3981 return OK; 3982 end Is_Post_State; 3983 3984 procedure Find_Post_State is new Traverse_Proc (Is_Post_State); 3985 3986 -- Start of processing for Mentions_Post_State 3987 3988 begin 3989 Find_Post_State (N); 3990 3991 return Post_State_Seen; 3992 end Mentions_Post_State; 3993 3994 -- Local variables 3995 3996 Expr : constant Node_Id := 3997 Get_Pragma_Arg 3998 (First (Pragma_Argument_Associations (Prag))); 3999 Nam : constant Name_Id := Pragma_Name (Prag); 4000 CCase : Node_Id; 4001 4002 -- Start of processing for Check_Result_And_Post_State_In_Pragma 4003 4004 begin 4005 -- Examine all consequences 4006 4007 if Nam = Name_Contract_Cases then 4008 CCase := First (Component_Associations (Expr)); 4009 while Present (CCase) loop 4010 Check_Expression (Expression (CCase)); 4011 4012 Next (CCase); 4013 end loop; 4014 4015 -- Examine the expression of a postcondition 4016 4017 else pragma Assert (Nam_In (Nam, Name_Postcondition, 4018 Name_Refined_Post)); 4019 Check_Expression (Expr); 4020 end if; 4021 end Check_Result_And_Post_State_In_Pragma; 4022 4023 -------------------------- 4024 -- Has_In_Out_Parameter -- 4025 -------------------------- 4026 4027 function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean is 4028 Formal : Entity_Id; 4029 4030 begin 4031 -- Traverse the formals looking for an IN OUT parameter 4032 4033 Formal := First_Formal (Subp_Id); 4034 while Present (Formal) loop 4035 if Ekind (Formal) = E_In_Out_Parameter then 4036 return True; 4037 end if; 4038 4039 Next_Formal (Formal); 4040 end loop; 4041 4042 return False; 4043 end Has_In_Out_Parameter; 4044 4045 -- Local variables 4046 4047 Items : constant Node_Id := Contract (Subp_Id); 4048 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); 4049 Case_Prag : Node_Id := Empty; 4050 Post_Prag : Node_Id := Empty; 4051 Prag : Node_Id; 4052 Seen_In_Case : Boolean := False; 4053 Seen_In_Post : Boolean := False; 4054 Spec_Id : Entity_Id; 4055 4056 -- Start of processing for Check_Result_And_Post_State 4057 4058 begin 4059 -- The lack of attribute 'Result or a post-state is classified as a 4060 -- suspicious contract. Do not perform the check if the corresponding 4061 -- swich is not set. 4062 4063 if not Warn_On_Suspicious_Contract then 4064 return; 4065 4066 -- Nothing to do if there is no contract 4067 4068 elsif No (Items) then 4069 return; 4070 end if; 4071 4072 -- Retrieve the entity of the subprogram spec (if any) 4073 4074 if Nkind (Subp_Decl) = N_Subprogram_Body 4075 and then Present (Corresponding_Spec (Subp_Decl)) 4076 then 4077 Spec_Id := Corresponding_Spec (Subp_Decl); 4078 4079 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 4080 and then Present (Corresponding_Spec_Of_Stub (Subp_Decl)) 4081 then 4082 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl); 4083 4084 else 4085 Spec_Id := Subp_Id; 4086 end if; 4087 4088 -- Examine all postconditions for attribute 'Result and a post-state 4089 4090 Prag := Pre_Post_Conditions (Items); 4091 while Present (Prag) loop 4092 if Nam_In (Pragma_Name_Unmapped (Prag), 4093 Name_Postcondition, Name_Refined_Post) 4094 and then not Error_Posted (Prag) 4095 then 4096 Post_Prag := Prag; 4097 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Post); 4098 end if; 4099 4100 Prag := Next_Pragma (Prag); 4101 end loop; 4102 4103 -- Examine the contract cases of the subprogram for attribute 'Result 4104 -- and a post-state. 4105 4106 Prag := Contract_Test_Cases (Items); 4107 while Present (Prag) loop 4108 if Pragma_Name (Prag) = Name_Contract_Cases 4109 and then not Error_Posted (Prag) 4110 then 4111 Case_Prag := Prag; 4112 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Case); 4113 end if; 4114 4115 Prag := Next_Pragma (Prag); 4116 end loop; 4117 4118 -- Do not emit any errors if the subprogram is not a function 4119 4120 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then 4121 null; 4122 4123 -- Regardless of whether the function has postconditions or contract 4124 -- cases, or whether they mention attribute 'Result, an IN OUT formal 4125 -- parameter is always treated as a result. 4126 4127 elsif Has_In_Out_Parameter (Spec_Id) then 4128 null; 4129 4130 -- The function has both a postcondition and contract cases and they do 4131 -- not mention attribute 'Result. 4132 4133 elsif Present (Case_Prag) 4134 and then not Seen_In_Case 4135 and then Present (Post_Prag) 4136 and then not Seen_In_Post 4137 then 4138 Error_Msg_N 4139 ("neither postcondition nor contract cases mention function " 4140 & "result?T?", Post_Prag); 4141 4142 -- The function has contract cases only and they do not mention 4143 -- attribute 'Result. 4144 4145 elsif Present (Case_Prag) and then not Seen_In_Case then 4146 Error_Msg_N ("contract cases do not mention result?T?", Case_Prag); 4147 4148 -- The function has postconditions only and they do not mention 4149 -- attribute 'Result. 4150 4151 elsif Present (Post_Prag) and then not Seen_In_Post then 4152 Error_Msg_N 4153 ("postcondition does not mention function result?T?", Post_Prag); 4154 end if; 4155 end Check_Result_And_Post_State; 4156 4157 ----------------------------- 4158 -- Check_State_Refinements -- 4159 ----------------------------- 4160 4161 procedure Check_State_Refinements 4162 (Context : Node_Id; 4163 Is_Main_Unit : Boolean := False) 4164 is 4165 procedure Check_Package (Pack : Node_Id); 4166 -- Verify that all abstract states of a [generic] package denoted by its 4167 -- declarative node Pack have proper refinement. Recursively verify the 4168 -- visible and private declarations of the [generic] package for other 4169 -- nested packages. 4170 4171 procedure Check_Packages_In (Decls : List_Id); 4172 -- Seek out [generic] package declarations within declarative list Decls 4173 -- and verify the status of their abstract state refinement. 4174 4175 function SPARK_Mode_Is_Off (N : Node_Id) return Boolean; 4176 -- Determine whether construct N is subject to pragma SPARK_Mode Off 4177 4178 ------------------- 4179 -- Check_Package -- 4180 ------------------- 4181 4182 procedure Check_Package (Pack : Node_Id) is 4183 Body_Id : constant Entity_Id := Corresponding_Body (Pack); 4184 Spec : constant Node_Id := Specification (Pack); 4185 States : constant Elist_Id := 4186 Abstract_States (Defining_Entity (Pack)); 4187 4188 State_Elmt : Elmt_Id; 4189 State_Id : Entity_Id; 4190 4191 begin 4192 -- Do not verify proper state refinement when the package is subject 4193 -- to pragma SPARK_Mode Off because this disables the requirement for 4194 -- state refinement. 4195 4196 if SPARK_Mode_Is_Off (Pack) then 4197 null; 4198 4199 -- State refinement can only occur in a completing package body. Do 4200 -- not verify proper state refinement when the body is subject to 4201 -- pragma SPARK_Mode Off because this disables the requirement for 4202 -- state refinement. 4203 4204 elsif Present (Body_Id) 4205 and then SPARK_Mode_Is_Off (Unit_Declaration_Node (Body_Id)) 4206 then 4207 null; 4208 4209 -- Do not verify proper state refinement when the package is an 4210 -- instance as this check was already performed in the generic. 4211 4212 elsif Present (Generic_Parent (Spec)) then 4213 null; 4214 4215 -- Otherwise examine the contents of the package 4216 4217 else 4218 if Present (States) then 4219 State_Elmt := First_Elmt (States); 4220 while Present (State_Elmt) loop 4221 State_Id := Node (State_Elmt); 4222 4223 -- Emit an error when a non-null state lacks any form of 4224 -- refinement. 4225 4226 if not Is_Null_State (State_Id) 4227 and then not Has_Null_Refinement (State_Id) 4228 and then not Has_Non_Null_Refinement (State_Id) 4229 then 4230 Error_Msg_N ("state & requires refinement", State_Id); 4231 end if; 4232 4233 Next_Elmt (State_Elmt); 4234 end loop; 4235 end if; 4236 4237 Check_Packages_In (Visible_Declarations (Spec)); 4238 Check_Packages_In (Private_Declarations (Spec)); 4239 end if; 4240 end Check_Package; 4241 4242 ----------------------- 4243 -- Check_Packages_In -- 4244 ----------------------- 4245 4246 procedure Check_Packages_In (Decls : List_Id) is 4247 Decl : Node_Id; 4248 4249 begin 4250 if Present (Decls) then 4251 Decl := First (Decls); 4252 while Present (Decl) loop 4253 if Nkind_In (Decl, N_Generic_Package_Declaration, 4254 N_Package_Declaration) 4255 then 4256 Check_Package (Decl); 4257 end if; 4258 4259 Next (Decl); 4260 end loop; 4261 end if; 4262 end Check_Packages_In; 4263 4264 ----------------------- 4265 -- SPARK_Mode_Is_Off -- 4266 ----------------------- 4267 4268 function SPARK_Mode_Is_Off (N : Node_Id) return Boolean is 4269 Id : constant Entity_Id := Defining_Entity (N); 4270 Prag : constant Node_Id := SPARK_Pragma (Id); 4271 4272 begin 4273 -- Default the mode to "off" when the context is an instance and all 4274 -- SPARK_Mode pragmas found within are to be ignored. 4275 4276 if Ignore_SPARK_Mode_Pragmas (Id) then 4277 return True; 4278 4279 else 4280 return 4281 Present (Prag) 4282 and then Get_SPARK_Mode_From_Annotation (Prag) = Off; 4283 end if; 4284 end SPARK_Mode_Is_Off; 4285 4286 -- Start of processing for Check_State_Refinements 4287 4288 begin 4289 -- A block may declare a nested package 4290 4291 if Nkind (Context) = N_Block_Statement then 4292 Check_Packages_In (Declarations (Context)); 4293 4294 -- An entry, protected, subprogram, or task body may declare a nested 4295 -- package. 4296 4297 elsif Nkind_In (Context, N_Entry_Body, 4298 N_Protected_Body, 4299 N_Subprogram_Body, 4300 N_Task_Body) 4301 then 4302 -- Do not verify proper state refinement when the body is subject to 4303 -- pragma SPARK_Mode Off because this disables the requirement for 4304 -- state refinement. 4305 4306 if not SPARK_Mode_Is_Off (Context) then 4307 Check_Packages_In (Declarations (Context)); 4308 end if; 4309 4310 -- A package body may declare a nested package 4311 4312 elsif Nkind (Context) = N_Package_Body then 4313 Check_Package (Unit_Declaration_Node (Corresponding_Spec (Context))); 4314 4315 -- Do not verify proper state refinement when the body is subject to 4316 -- pragma SPARK_Mode Off because this disables the requirement for 4317 -- state refinement. 4318 4319 if not SPARK_Mode_Is_Off (Context) then 4320 Check_Packages_In (Declarations (Context)); 4321 end if; 4322 4323 -- A library level [generic] package may declare a nested package 4324 4325 elsif Nkind_In (Context, N_Generic_Package_Declaration, 4326 N_Package_Declaration) 4327 and then Is_Main_Unit 4328 then 4329 Check_Package (Context); 4330 end if; 4331 end Check_State_Refinements; 4332 4333 ------------------------------ 4334 -- Check_Unprotected_Access -- 4335 ------------------------------ 4336 4337 procedure Check_Unprotected_Access 4338 (Context : Node_Id; 4339 Expr : Node_Id) 4340 is 4341 Cont_Encl_Typ : Entity_Id; 4342 Pref_Encl_Typ : Entity_Id; 4343 4344 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id; 4345 -- Check whether Obj is a private component of a protected object. 4346 -- Return the protected type where the component resides, Empty 4347 -- otherwise. 4348 4349 function Is_Public_Operation return Boolean; 4350 -- Verify that the enclosing operation is callable from outside the 4351 -- protected object, to minimize false positives. 4352 4353 ------------------------------ 4354 -- Enclosing_Protected_Type -- 4355 ------------------------------ 4356 4357 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is 4358 begin 4359 if Is_Entity_Name (Obj) then 4360 declare 4361 Ent : Entity_Id := Entity (Obj); 4362 4363 begin 4364 -- The object can be a renaming of a private component, use 4365 -- the original record component. 4366 4367 if Is_Prival (Ent) then 4368 Ent := Prival_Link (Ent); 4369 end if; 4370 4371 if Is_Protected_Type (Scope (Ent)) then 4372 return Scope (Ent); 4373 end if; 4374 end; 4375 end if; 4376 4377 -- For indexed and selected components, recursively check the prefix 4378 4379 if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then 4380 return Enclosing_Protected_Type (Prefix (Obj)); 4381 4382 -- The object does not denote a protected component 4383 4384 else 4385 return Empty; 4386 end if; 4387 end Enclosing_Protected_Type; 4388 4389 ------------------------- 4390 -- Is_Public_Operation -- 4391 ------------------------- 4392 4393 function Is_Public_Operation return Boolean is 4394 S : Entity_Id; 4395 E : Entity_Id; 4396 4397 begin 4398 S := Current_Scope; 4399 while Present (S) and then S /= Pref_Encl_Typ loop 4400 if Scope (S) = Pref_Encl_Typ then 4401 E := First_Entity (Pref_Encl_Typ); 4402 while Present (E) 4403 and then E /= First_Private_Entity (Pref_Encl_Typ) 4404 loop 4405 if E = S then 4406 return True; 4407 end if; 4408 4409 Next_Entity (E); 4410 end loop; 4411 end if; 4412 4413 S := Scope (S); 4414 end loop; 4415 4416 return False; 4417 end Is_Public_Operation; 4418 4419 -- Start of processing for Check_Unprotected_Access 4420 4421 begin 4422 if Nkind (Expr) = N_Attribute_Reference 4423 and then Attribute_Name (Expr) = Name_Unchecked_Access 4424 then 4425 Cont_Encl_Typ := Enclosing_Protected_Type (Context); 4426 Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr)); 4427 4428 -- Check whether we are trying to export a protected component to a 4429 -- context with an equal or lower access level. 4430 4431 if Present (Pref_Encl_Typ) 4432 and then No (Cont_Encl_Typ) 4433 and then Is_Public_Operation 4434 and then Scope_Depth (Pref_Encl_Typ) >= 4435 Object_Access_Level (Context) 4436 then 4437 Error_Msg_N 4438 ("??possible unprotected access to protected data", Expr); 4439 end if; 4440 end if; 4441 end Check_Unprotected_Access; 4442 4443 ------------------------------ 4444 -- Check_Unused_Body_States -- 4445 ------------------------------ 4446 4447 procedure Check_Unused_Body_States (Body_Id : Entity_Id) is 4448 procedure Process_Refinement_Clause 4449 (Clause : Node_Id; 4450 States : Elist_Id); 4451 -- Inspect all constituents of refinement clause Clause and remove any 4452 -- matches from body state list States. 4453 4454 procedure Report_Unused_Body_States (States : Elist_Id); 4455 -- Emit errors for each abstract state or object found in list States 4456 4457 ------------------------------- 4458 -- Process_Refinement_Clause -- 4459 ------------------------------- 4460 4461 procedure Process_Refinement_Clause 4462 (Clause : Node_Id; 4463 States : Elist_Id) 4464 is 4465 procedure Process_Constituent (Constit : Node_Id); 4466 -- Remove constituent Constit from body state list States 4467 4468 ------------------------- 4469 -- Process_Constituent -- 4470 ------------------------- 4471 4472 procedure Process_Constituent (Constit : Node_Id) is 4473 Constit_Id : Entity_Id; 4474 4475 begin 4476 -- Guard against illegal constituents. Only abstract states and 4477 -- objects can appear on the right hand side of a refinement. 4478 4479 if Is_Entity_Name (Constit) then 4480 Constit_Id := Entity_Of (Constit); 4481 4482 if Present (Constit_Id) 4483 and then Ekind_In (Constit_Id, E_Abstract_State, 4484 E_Constant, 4485 E_Variable) 4486 then 4487 Remove (States, Constit_Id); 4488 end if; 4489 end if; 4490 end Process_Constituent; 4491 4492 -- Local variables 4493 4494 Constit : Node_Id; 4495 4496 -- Start of processing for Process_Refinement_Clause 4497 4498 begin 4499 if Nkind (Clause) = N_Component_Association then 4500 Constit := Expression (Clause); 4501 4502 -- Multiple constituents appear as an aggregate 4503 4504 if Nkind (Constit) = N_Aggregate then 4505 Constit := First (Expressions (Constit)); 4506 while Present (Constit) loop 4507 Process_Constituent (Constit); 4508 Next (Constit); 4509 end loop; 4510 4511 -- Various forms of a single constituent 4512 4513 else 4514 Process_Constituent (Constit); 4515 end if; 4516 end if; 4517 end Process_Refinement_Clause; 4518 4519 ------------------------------- 4520 -- Report_Unused_Body_States -- 4521 ------------------------------- 4522 4523 procedure Report_Unused_Body_States (States : Elist_Id) is 4524 Posted : Boolean := False; 4525 State_Elmt : Elmt_Id; 4526 State_Id : Entity_Id; 4527 4528 begin 4529 if Present (States) then 4530 State_Elmt := First_Elmt (States); 4531 while Present (State_Elmt) loop 4532 State_Id := Node (State_Elmt); 4533 4534 -- Constants are part of the hidden state of a package, but the 4535 -- compiler cannot determine whether they have variable input 4536 -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a 4537 -- hidden state. Do not emit an error when a constant does not 4538 -- participate in a state refinement, even though it acts as a 4539 -- hidden state. 4540 4541 if Ekind (State_Id) = E_Constant then 4542 null; 4543 4544 -- Generate an error message of the form: 4545 4546 -- body of package ... has unused hidden states 4547 -- abstract state ... defined at ... 4548 -- variable ... defined at ... 4549 4550 else 4551 if not Posted then 4552 Posted := True; 4553 SPARK_Msg_N 4554 ("body of package & has unused hidden states", Body_Id); 4555 end if; 4556 4557 Error_Msg_Sloc := Sloc (State_Id); 4558 4559 if Ekind (State_Id) = E_Abstract_State then 4560 SPARK_Msg_NE 4561 ("\abstract state & defined #", Body_Id, State_Id); 4562 4563 else 4564 SPARK_Msg_NE ("\variable & defined #", Body_Id, State_Id); 4565 end if; 4566 end if; 4567 4568 Next_Elmt (State_Elmt); 4569 end loop; 4570 end if; 4571 end Report_Unused_Body_States; 4572 4573 -- Local variables 4574 4575 Prag : constant Node_Id := Get_Pragma (Body_Id, Pragma_Refined_State); 4576 Spec_Id : constant Entity_Id := Spec_Entity (Body_Id); 4577 Clause : Node_Id; 4578 States : Elist_Id; 4579 4580 -- Start of processing for Check_Unused_Body_States 4581 4582 begin 4583 -- Inspect the clauses of pragma Refined_State and determine whether all 4584 -- visible states declared within the package body participate in the 4585 -- refinement. 4586 4587 if Present (Prag) then 4588 Clause := Expression (Get_Argument (Prag, Spec_Id)); 4589 States := Collect_Body_States (Body_Id); 4590 4591 -- Multiple non-null state refinements appear as an aggregate 4592 4593 if Nkind (Clause) = N_Aggregate then 4594 Clause := First (Component_Associations (Clause)); 4595 while Present (Clause) loop 4596 Process_Refinement_Clause (Clause, States); 4597 Next (Clause); 4598 end loop; 4599 4600 -- Various forms of a single state refinement 4601 4602 else 4603 Process_Refinement_Clause (Clause, States); 4604 end if; 4605 4606 -- Ensure that all abstract states and objects declared in the 4607 -- package body state space are utilized as constituents. 4608 4609 Report_Unused_Body_States (States); 4610 end if; 4611 end Check_Unused_Body_States; 4612 4613 ----------------- 4614 -- Choice_List -- 4615 ----------------- 4616 4617 function Choice_List (N : Node_Id) return List_Id is 4618 begin 4619 if Nkind (N) = N_Iterated_Component_Association then 4620 return Discrete_Choices (N); 4621 else 4622 return Choices (N); 4623 end if; 4624 end Choice_List; 4625 4626 ------------------------- 4627 -- Collect_Body_States -- 4628 ------------------------- 4629 4630 function Collect_Body_States (Body_Id : Entity_Id) return Elist_Id is 4631 function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean; 4632 -- Determine whether object Obj_Id is a suitable visible state of a 4633 -- package body. 4634 4635 procedure Collect_Visible_States 4636 (Pack_Id : Entity_Id; 4637 States : in out Elist_Id); 4638 -- Gather the entities of all abstract states and objects declared in 4639 -- the visible state space of package Pack_Id. 4640 4641 ---------------------------- 4642 -- Collect_Visible_States -- 4643 ---------------------------- 4644 4645 procedure Collect_Visible_States 4646 (Pack_Id : Entity_Id; 4647 States : in out Elist_Id) 4648 is 4649 Item_Id : Entity_Id; 4650 4651 begin 4652 -- Traverse the entity chain of the package and inspect all visible 4653 -- items. 4654 4655 Item_Id := First_Entity (Pack_Id); 4656 while Present (Item_Id) and then not In_Private_Part (Item_Id) loop 4657 4658 -- Do not consider internally generated items as those cannot be 4659 -- named and participate in refinement. 4660 4661 if not Comes_From_Source (Item_Id) then 4662 null; 4663 4664 elsif Ekind (Item_Id) = E_Abstract_State then 4665 Append_New_Elmt (Item_Id, States); 4666 4667 elsif Ekind_In (Item_Id, E_Constant, E_Variable) 4668 and then Is_Visible_Object (Item_Id) 4669 then 4670 Append_New_Elmt (Item_Id, States); 4671 4672 -- Recursively gather the visible states of a nested package 4673 4674 elsif Ekind (Item_Id) = E_Package then 4675 Collect_Visible_States (Item_Id, States); 4676 end if; 4677 4678 Next_Entity (Item_Id); 4679 end loop; 4680 end Collect_Visible_States; 4681 4682 ----------------------- 4683 -- Is_Visible_Object -- 4684 ----------------------- 4685 4686 function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean is 4687 begin 4688 -- Objects that map generic formals to their actuals are not visible 4689 -- from outside the generic instantiation. 4690 4691 if Present (Corresponding_Generic_Association 4692 (Declaration_Node (Obj_Id))) 4693 then 4694 return False; 4695 4696 -- Constituents of a single protected/task type act as components of 4697 -- the type and are not visible from outside the type. 4698 4699 elsif Ekind (Obj_Id) = E_Variable 4700 and then Present (Encapsulating_State (Obj_Id)) 4701 and then Is_Single_Concurrent_Object (Encapsulating_State (Obj_Id)) 4702 then 4703 return False; 4704 4705 else 4706 return True; 4707 end if; 4708 end Is_Visible_Object; 4709 4710 -- Local variables 4711 4712 Body_Decl : constant Node_Id := Unit_Declaration_Node (Body_Id); 4713 Decl : Node_Id; 4714 Item_Id : Entity_Id; 4715 States : Elist_Id := No_Elist; 4716 4717 -- Start of processing for Collect_Body_States 4718 4719 begin 4720 -- Inspect the declarations of the body looking for source objects, 4721 -- packages and package instantiations. Note that even though this 4722 -- processing is very similar to Collect_Visible_States, a package 4723 -- body does not have a First/Next_Entity list. 4724 4725 Decl := First (Declarations (Body_Decl)); 4726 while Present (Decl) loop 4727 4728 -- Capture source objects as internally generated temporaries cannot 4729 -- be named and participate in refinement. 4730 4731 if Nkind (Decl) = N_Object_Declaration then 4732 Item_Id := Defining_Entity (Decl); 4733 4734 if Comes_From_Source (Item_Id) 4735 and then Is_Visible_Object (Item_Id) 4736 then 4737 Append_New_Elmt (Item_Id, States); 4738 end if; 4739 4740 -- Capture the visible abstract states and objects of a source 4741 -- package [instantiation]. 4742 4743 elsif Nkind (Decl) = N_Package_Declaration then 4744 Item_Id := Defining_Entity (Decl); 4745 4746 if Comes_From_Source (Item_Id) then 4747 Collect_Visible_States (Item_Id, States); 4748 end if; 4749 end if; 4750 4751 Next (Decl); 4752 end loop; 4753 4754 return States; 4755 end Collect_Body_States; 4756 4757 ------------------------ 4758 -- Collect_Interfaces -- 4759 ------------------------ 4760 4761 procedure Collect_Interfaces 4762 (T : Entity_Id; 4763 Ifaces_List : out Elist_Id; 4764 Exclude_Parents : Boolean := False; 4765 Use_Full_View : Boolean := True) 4766 is 4767 procedure Collect (Typ : Entity_Id); 4768 -- Subsidiary subprogram used to traverse the whole list 4769 -- of directly and indirectly implemented interfaces 4770 4771 ------------- 4772 -- Collect -- 4773 ------------- 4774 4775 procedure Collect (Typ : Entity_Id) is 4776 Ancestor : Entity_Id; 4777 Full_T : Entity_Id; 4778 Id : Node_Id; 4779 Iface : Entity_Id; 4780 4781 begin 4782 Full_T := Typ; 4783 4784 -- Handle private types and subtypes 4785 4786 if Use_Full_View 4787 and then Is_Private_Type (Typ) 4788 and then Present (Full_View (Typ)) 4789 then 4790 Full_T := Full_View (Typ); 4791 4792 if Ekind (Full_T) = E_Record_Subtype then 4793 Full_T := Etype (Typ); 4794 4795 if Present (Full_View (Full_T)) then 4796 Full_T := Full_View (Full_T); 4797 end if; 4798 end if; 4799 end if; 4800 4801 -- Include the ancestor if we are generating the whole list of 4802 -- abstract interfaces. 4803 4804 if Etype (Full_T) /= Typ 4805 4806 -- Protect the frontend against wrong sources. For example: 4807 4808 -- package P is 4809 -- type A is tagged null record; 4810 -- type B is new A with private; 4811 -- type C is new A with private; 4812 -- private 4813 -- type B is new C with null record; 4814 -- type C is new B with null record; 4815 -- end P; 4816 4817 and then Etype (Full_T) /= T 4818 then 4819 Ancestor := Etype (Full_T); 4820 Collect (Ancestor); 4821 4822 if Is_Interface (Ancestor) and then not Exclude_Parents then 4823 Append_Unique_Elmt (Ancestor, Ifaces_List); 4824 end if; 4825 end if; 4826 4827 -- Traverse the graph of ancestor interfaces 4828 4829 if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then 4830 Id := First (Abstract_Interface_List (Full_T)); 4831 while Present (Id) loop 4832 Iface := Etype (Id); 4833 4834 -- Protect against wrong uses. For example: 4835 -- type I is interface; 4836 -- type O is tagged null record; 4837 -- type Wrong is new I and O with null record; -- ERROR 4838 4839 if Is_Interface (Iface) then 4840 if Exclude_Parents 4841 and then Etype (T) /= T 4842 and then Interface_Present_In_Ancestor (Etype (T), Iface) 4843 then 4844 null; 4845 else 4846 Collect (Iface); 4847 Append_Unique_Elmt (Iface, Ifaces_List); 4848 end if; 4849 end if; 4850 4851 Next (Id); 4852 end loop; 4853 end if; 4854 end Collect; 4855 4856 -- Start of processing for Collect_Interfaces 4857 4858 begin 4859 pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T)); 4860 Ifaces_List := New_Elmt_List; 4861 Collect (T); 4862 end Collect_Interfaces; 4863 4864 ---------------------------------- 4865 -- Collect_Interface_Components -- 4866 ---------------------------------- 4867 4868 procedure Collect_Interface_Components 4869 (Tagged_Type : Entity_Id; 4870 Components_List : out Elist_Id) 4871 is 4872 procedure Collect (Typ : Entity_Id); 4873 -- Subsidiary subprogram used to climb to the parents 4874 4875 ------------- 4876 -- Collect -- 4877 ------------- 4878 4879 procedure Collect (Typ : Entity_Id) is 4880 Tag_Comp : Entity_Id; 4881 Parent_Typ : Entity_Id; 4882 4883 begin 4884 -- Handle private types 4885 4886 if Present (Full_View (Etype (Typ))) then 4887 Parent_Typ := Full_View (Etype (Typ)); 4888 else 4889 Parent_Typ := Etype (Typ); 4890 end if; 4891 4892 if Parent_Typ /= Typ 4893 4894 -- Protect the frontend against wrong sources. For example: 4895 4896 -- package P is 4897 -- type A is tagged null record; 4898 -- type B is new A with private; 4899 -- type C is new A with private; 4900 -- private 4901 -- type B is new C with null record; 4902 -- type C is new B with null record; 4903 -- end P; 4904 4905 and then Parent_Typ /= Tagged_Type 4906 then 4907 Collect (Parent_Typ); 4908 end if; 4909 4910 -- Collect the components containing tags of secondary dispatch 4911 -- tables. 4912 4913 Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ)); 4914 while Present (Tag_Comp) loop 4915 pragma Assert (Present (Related_Type (Tag_Comp))); 4916 Append_Elmt (Tag_Comp, Components_List); 4917 4918 Tag_Comp := Next_Tag_Component (Tag_Comp); 4919 end loop; 4920 end Collect; 4921 4922 -- Start of processing for Collect_Interface_Components 4923 4924 begin 4925 pragma Assert (Ekind (Tagged_Type) = E_Record_Type 4926 and then Is_Tagged_Type (Tagged_Type)); 4927 4928 Components_List := New_Elmt_List; 4929 Collect (Tagged_Type); 4930 end Collect_Interface_Components; 4931 4932 ----------------------------- 4933 -- Collect_Interfaces_Info -- 4934 ----------------------------- 4935 4936 procedure Collect_Interfaces_Info 4937 (T : Entity_Id; 4938 Ifaces_List : out Elist_Id; 4939 Components_List : out Elist_Id; 4940 Tags_List : out Elist_Id) 4941 is 4942 Comps_List : Elist_Id; 4943 Comp_Elmt : Elmt_Id; 4944 Comp_Iface : Entity_Id; 4945 Iface_Elmt : Elmt_Id; 4946 Iface : Entity_Id; 4947 4948 function Search_Tag (Iface : Entity_Id) return Entity_Id; 4949 -- Search for the secondary tag associated with the interface type 4950 -- Iface that is implemented by T. 4951 4952 ---------------- 4953 -- Search_Tag -- 4954 ---------------- 4955 4956 function Search_Tag (Iface : Entity_Id) return Entity_Id is 4957 ADT : Elmt_Id; 4958 begin 4959 if not Is_CPP_Class (T) then 4960 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T)))); 4961 else 4962 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T))); 4963 end if; 4964 4965 while Present (ADT) 4966 and then Is_Tag (Node (ADT)) 4967 and then Related_Type (Node (ADT)) /= Iface 4968 loop 4969 -- Skip secondary dispatch table referencing thunks to user 4970 -- defined primitives covered by this interface. 4971 4972 pragma Assert (Has_Suffix (Node (ADT), 'P')); 4973 Next_Elmt (ADT); 4974 4975 -- Skip secondary dispatch tables of Ada types 4976 4977 if not Is_CPP_Class (T) then 4978 4979 -- Skip secondary dispatch table referencing thunks to 4980 -- predefined primitives. 4981 4982 pragma Assert (Has_Suffix (Node (ADT), 'Y')); 4983 Next_Elmt (ADT); 4984 4985 -- Skip secondary dispatch table referencing user-defined 4986 -- primitives covered by this interface. 4987 4988 pragma Assert (Has_Suffix (Node (ADT), 'D')); 4989 Next_Elmt (ADT); 4990 4991 -- Skip secondary dispatch table referencing predefined 4992 -- primitives. 4993 4994 pragma Assert (Has_Suffix (Node (ADT), 'Z')); 4995 Next_Elmt (ADT); 4996 end if; 4997 end loop; 4998 4999 pragma Assert (Is_Tag (Node (ADT))); 5000 return Node (ADT); 5001 end Search_Tag; 5002 5003 -- Start of processing for Collect_Interfaces_Info 5004 5005 begin 5006 Collect_Interfaces (T, Ifaces_List); 5007 Collect_Interface_Components (T, Comps_List); 5008 5009 -- Search for the record component and tag associated with each 5010 -- interface type of T. 5011 5012 Components_List := New_Elmt_List; 5013 Tags_List := New_Elmt_List; 5014 5015 Iface_Elmt := First_Elmt (Ifaces_List); 5016 while Present (Iface_Elmt) loop 5017 Iface := Node (Iface_Elmt); 5018 5019 -- Associate the primary tag component and the primary dispatch table 5020 -- with all the interfaces that are parents of T 5021 5022 if Is_Ancestor (Iface, T, Use_Full_View => True) then 5023 Append_Elmt (First_Tag_Component (T), Components_List); 5024 Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List); 5025 5026 -- Otherwise search for the tag component and secondary dispatch 5027 -- table of Iface 5028 5029 else 5030 Comp_Elmt := First_Elmt (Comps_List); 5031 while Present (Comp_Elmt) loop 5032 Comp_Iface := Related_Type (Node (Comp_Elmt)); 5033 5034 if Comp_Iface = Iface 5035 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True) 5036 then 5037 Append_Elmt (Node (Comp_Elmt), Components_List); 5038 Append_Elmt (Search_Tag (Comp_Iface), Tags_List); 5039 exit; 5040 end if; 5041 5042 Next_Elmt (Comp_Elmt); 5043 end loop; 5044 pragma Assert (Present (Comp_Elmt)); 5045 end if; 5046 5047 Next_Elmt (Iface_Elmt); 5048 end loop; 5049 end Collect_Interfaces_Info; 5050 5051 --------------------- 5052 -- Collect_Parents -- 5053 --------------------- 5054 5055 procedure Collect_Parents 5056 (T : Entity_Id; 5057 List : out Elist_Id; 5058 Use_Full_View : Boolean := True) 5059 is 5060 Current_Typ : Entity_Id := T; 5061 Parent_Typ : Entity_Id; 5062 5063 begin 5064 List := New_Elmt_List; 5065 5066 -- No action if the if the type has no parents 5067 5068 if T = Etype (T) then 5069 return; 5070 end if; 5071 5072 loop 5073 Parent_Typ := Etype (Current_Typ); 5074 5075 if Is_Private_Type (Parent_Typ) 5076 and then Present (Full_View (Parent_Typ)) 5077 and then Use_Full_View 5078 then 5079 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 5080 end if; 5081 5082 Append_Elmt (Parent_Typ, List); 5083 5084 exit when Parent_Typ = Current_Typ; 5085 Current_Typ := Parent_Typ; 5086 end loop; 5087 end Collect_Parents; 5088 5089 ---------------------------------- 5090 -- Collect_Primitive_Operations -- 5091 ---------------------------------- 5092 5093 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is 5094 B_Type : constant Entity_Id := Base_Type (T); 5095 5096 function Match (E : Entity_Id) return Boolean; 5097 -- True if E's base type is B_Type, or E is of an anonymous access type 5098 -- and the base type of its designated type is B_Type. 5099 5100 ----------- 5101 -- Match -- 5102 ----------- 5103 5104 function Match (E : Entity_Id) return Boolean is 5105 Etyp : Entity_Id := Etype (E); 5106 5107 begin 5108 if Ekind (Etyp) = E_Anonymous_Access_Type then 5109 Etyp := Designated_Type (Etyp); 5110 end if; 5111 5112 -- In Ada 2012 a primitive operation may have a formal of an 5113 -- incomplete view of the parent type. 5114 5115 return Base_Type (Etyp) = B_Type 5116 or else 5117 (Ada_Version >= Ada_2012 5118 and then Ekind (Etyp) = E_Incomplete_Type 5119 and then Full_View (Etyp) = B_Type); 5120 end Match; 5121 5122 -- Local variables 5123 5124 B_Decl : constant Node_Id := Original_Node (Parent (B_Type)); 5125 B_Scope : Entity_Id := Scope (B_Type); 5126 Op_List : Elist_Id; 5127 Eq_Prims_List : Elist_Id := No_Elist; 5128 Formal : Entity_Id; 5129 Is_Prim : Boolean; 5130 Is_Type_In_Pkg : Boolean; 5131 Formal_Derived : Boolean := False; 5132 Id : Entity_Id; 5133 5134 -- Start of processing for Collect_Primitive_Operations 5135 5136 begin 5137 -- For tagged types, the primitive operations are collected as they 5138 -- are declared, and held in an explicit list which is simply returned. 5139 5140 if Is_Tagged_Type (B_Type) then 5141 return Primitive_Operations (B_Type); 5142 5143 -- An untagged generic type that is a derived type inherits the 5144 -- primitive operations of its parent type. Other formal types only 5145 -- have predefined operators, which are not explicitly represented. 5146 5147 elsif Is_Generic_Type (B_Type) then 5148 if Nkind (B_Decl) = N_Formal_Type_Declaration 5149 and then Nkind (Formal_Type_Definition (B_Decl)) = 5150 N_Formal_Derived_Type_Definition 5151 then 5152 Formal_Derived := True; 5153 else 5154 return New_Elmt_List; 5155 end if; 5156 end if; 5157 5158 Op_List := New_Elmt_List; 5159 5160 if B_Scope = Standard_Standard then 5161 if B_Type = Standard_String then 5162 Append_Elmt (Standard_Op_Concat, Op_List); 5163 5164 elsif B_Type = Standard_Wide_String then 5165 Append_Elmt (Standard_Op_Concatw, Op_List); 5166 5167 else 5168 null; 5169 end if; 5170 5171 -- Locate the primitive subprograms of the type 5172 5173 else 5174 -- The primitive operations appear after the base type, except if the 5175 -- derivation happens within the private part of B_Scope and the type 5176 -- is a private type, in which case both the type and some primitive 5177 -- operations may appear before the base type, and the list of 5178 -- candidates starts after the type. 5179 5180 if In_Open_Scopes (B_Scope) 5181 and then Scope (T) = B_Scope 5182 and then In_Private_Part (B_Scope) 5183 then 5184 Id := Next_Entity (T); 5185 5186 -- In Ada 2012, If the type has an incomplete partial view, there may 5187 -- be primitive operations declared before the full view, so we need 5188 -- to start scanning from the incomplete view, which is earlier on 5189 -- the entity chain. 5190 5191 elsif Nkind (Parent (B_Type)) = N_Full_Type_Declaration 5192 and then Present (Incomplete_View (Parent (B_Type))) 5193 then 5194 Id := Defining_Entity (Incomplete_View (Parent (B_Type))); 5195 5196 -- If T is a derived from a type with an incomplete view declared 5197 -- elsewhere, that incomplete view is irrelevant, we want the 5198 -- operations in the scope of T. 5199 5200 if Scope (Id) /= Scope (B_Type) then 5201 Id := Next_Entity (B_Type); 5202 end if; 5203 5204 else 5205 Id := Next_Entity (B_Type); 5206 end if; 5207 5208 -- Set flag if this is a type in a package spec 5209 5210 Is_Type_In_Pkg := 5211 Is_Package_Or_Generic_Package (B_Scope) 5212 and then 5213 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /= 5214 N_Package_Body; 5215 5216 while Present (Id) loop 5217 5218 -- Test whether the result type or any of the parameter types of 5219 -- each subprogram following the type match that type when the 5220 -- type is declared in a package spec, is a derived type, or the 5221 -- subprogram is marked as primitive. (The Is_Primitive test is 5222 -- needed to find primitives of nonderived types in declarative 5223 -- parts that happen to override the predefined "=" operator.) 5224 5225 -- Note that generic formal subprograms are not considered to be 5226 -- primitive operations and thus are never inherited. 5227 5228 if Is_Overloadable (Id) 5229 and then (Is_Type_In_Pkg 5230 or else Is_Derived_Type (B_Type) 5231 or else Is_Primitive (Id)) 5232 and then Nkind (Parent (Parent (Id))) 5233 not in N_Formal_Subprogram_Declaration 5234 then 5235 Is_Prim := False; 5236 5237 if Match (Id) then 5238 Is_Prim := True; 5239 5240 else 5241 Formal := First_Formal (Id); 5242 while Present (Formal) loop 5243 if Match (Formal) then 5244 Is_Prim := True; 5245 exit; 5246 end if; 5247 5248 Next_Formal (Formal); 5249 end loop; 5250 end if; 5251 5252 -- For a formal derived type, the only primitives are the ones 5253 -- inherited from the parent type. Operations appearing in the 5254 -- package declaration are not primitive for it. 5255 5256 if Is_Prim 5257 and then (not Formal_Derived or else Present (Alias (Id))) 5258 then 5259 -- In the special case of an equality operator aliased to 5260 -- an overriding dispatching equality belonging to the same 5261 -- type, we don't include it in the list of primitives. 5262 -- This avoids inheriting multiple equality operators when 5263 -- deriving from untagged private types whose full type is 5264 -- tagged, which can otherwise cause ambiguities. Note that 5265 -- this should only happen for this kind of untagged parent 5266 -- type, since normally dispatching operations are inherited 5267 -- using the type's Primitive_Operations list. 5268 5269 if Chars (Id) = Name_Op_Eq 5270 and then Is_Dispatching_Operation (Id) 5271 and then Present (Alias (Id)) 5272 and then Present (Overridden_Operation (Alias (Id))) 5273 and then Base_Type (Etype (First_Entity (Id))) = 5274 Base_Type (Etype (First_Entity (Alias (Id)))) 5275 then 5276 null; 5277 5278 -- Include the subprogram in the list of primitives 5279 5280 else 5281 Append_Elmt (Id, Op_List); 5282 5283 -- Save collected equality primitives for later filtering 5284 -- (if we are processing a private type for which we can 5285 -- collect several candidates). 5286 5287 if Inherits_From_Tagged_Full_View (T) 5288 and then Chars (Id) = Name_Op_Eq 5289 and then Etype (First_Formal (Id)) = 5290 Etype (Next_Formal (First_Formal (Id))) 5291 then 5292 if No (Eq_Prims_List) then 5293 Eq_Prims_List := New_Elmt_List; 5294 end if; 5295 5296 Append_Elmt (Id, Eq_Prims_List); 5297 end if; 5298 end if; 5299 end if; 5300 end if; 5301 5302 Next_Entity (Id); 5303 5304 -- For a type declared in System, some of its operations may 5305 -- appear in the target-specific extension to System. 5306 5307 if No (Id) 5308 and then B_Scope = RTU_Entity (System) 5309 and then Present_System_Aux 5310 then 5311 B_Scope := System_Aux_Id; 5312 Id := First_Entity (System_Aux_Id); 5313 end if; 5314 end loop; 5315 5316 -- Filter collected equality primitives 5317 5318 if Inherits_From_Tagged_Full_View (T) 5319 and then Present (Eq_Prims_List) 5320 then 5321 declare 5322 First : constant Elmt_Id := First_Elmt (Eq_Prims_List); 5323 Second : Elmt_Id; 5324 5325 begin 5326 pragma Assert (No (Next_Elmt (First)) 5327 or else No (Next_Elmt (Next_Elmt (First)))); 5328 5329 -- No action needed if we have collected a single equality 5330 -- primitive 5331 5332 if Present (Next_Elmt (First)) then 5333 Second := Next_Elmt (First); 5334 5335 if Is_Dispatching_Operation 5336 (Ultimate_Alias (Node (First))) 5337 then 5338 Remove (Op_List, Node (First)); 5339 5340 elsif Is_Dispatching_Operation 5341 (Ultimate_Alias (Node (Second))) 5342 then 5343 Remove (Op_List, Node (Second)); 5344 5345 else 5346 pragma Assert (False); 5347 raise Program_Error; 5348 end if; 5349 end if; 5350 end; 5351 end if; 5352 end if; 5353 5354 return Op_List; 5355 end Collect_Primitive_Operations; 5356 5357 ----------------------------------- 5358 -- Compile_Time_Constraint_Error -- 5359 ----------------------------------- 5360 5361 function Compile_Time_Constraint_Error 5362 (N : Node_Id; 5363 Msg : String; 5364 Ent : Entity_Id := Empty; 5365 Loc : Source_Ptr := No_Location; 5366 Warn : Boolean := False) return Node_Id 5367 is 5368 Msgc : String (1 .. Msg'Length + 3); 5369 -- Copy of message, with room for possible ?? or << and ! at end 5370 5371 Msgl : Natural; 5372 Wmsg : Boolean; 5373 Eloc : Source_Ptr; 5374 5375 -- Start of processing for Compile_Time_Constraint_Error 5376 5377 begin 5378 -- If this is a warning, convert it into an error if we are in code 5379 -- subject to SPARK_Mode being set On, unless Warn is True to force a 5380 -- warning. The rationale is that a compile-time constraint error should 5381 -- lead to an error instead of a warning when SPARK_Mode is On, but in 5382 -- a few cases we prefer to issue a warning and generate both a suitable 5383 -- run-time error in GNAT and a suitable check message in GNATprove. 5384 -- Those cases are those that likely correspond to deactivated SPARK 5385 -- code, so that this kind of code can be compiled and analyzed instead 5386 -- of being rejected. 5387 5388 Error_Msg_Warn := Warn or SPARK_Mode /= On; 5389 5390 -- A static constraint error in an instance body is not a fatal error. 5391 -- we choose to inhibit the message altogether, because there is no 5392 -- obvious node (for now) on which to post it. On the other hand the 5393 -- offending node must be replaced with a constraint_error in any case. 5394 5395 -- No messages are generated if we already posted an error on this node 5396 5397 if not Error_Posted (N) then 5398 if Loc /= No_Location then 5399 Eloc := Loc; 5400 else 5401 Eloc := Sloc (N); 5402 end if; 5403 5404 -- Copy message to Msgc, converting any ? in the message into < 5405 -- instead, so that we have an error in GNATprove mode. 5406 5407 Msgl := Msg'Length; 5408 5409 for J in 1 .. Msgl loop 5410 if Msg (J) = '?' and then (J = 1 or else Msg (J - 1) /= ''') then 5411 Msgc (J) := '<'; 5412 else 5413 Msgc (J) := Msg (J); 5414 end if; 5415 end loop; 5416 5417 -- Message is a warning, even in Ada 95 case 5418 5419 if Msg (Msg'Last) = '?' or else Msg (Msg'Last) = '<' then 5420 Wmsg := True; 5421 5422 -- In Ada 83, all messages are warnings. In the private part and the 5423 -- body of an instance, constraint_checks are only warnings. We also 5424 -- make this a warning if the Warn parameter is set. 5425 5426 elsif Warn 5427 or else (Ada_Version = Ada_83 and then Comes_From_Source (N)) 5428 or else In_Instance_Not_Visible 5429 then 5430 Msgl := Msgl + 1; 5431 Msgc (Msgl) := '<'; 5432 Msgl := Msgl + 1; 5433 Msgc (Msgl) := '<'; 5434 Wmsg := True; 5435 5436 -- Otherwise we have a real error message (Ada 95 static case) and we 5437 -- make this an unconditional message. Note that in the warning case 5438 -- we do not make the message unconditional, it seems reasonable to 5439 -- delete messages like this (about exceptions that will be raised) 5440 -- in dead code. 5441 5442 else 5443 Wmsg := False; 5444 Msgl := Msgl + 1; 5445 Msgc (Msgl) := '!'; 5446 end if; 5447 5448 -- One more test, skip the warning if the related expression is 5449 -- statically unevaluated, since we don't want to warn about what 5450 -- will happen when something is evaluated if it never will be 5451 -- evaluated. 5452 5453 if not Is_Statically_Unevaluated (N) then 5454 if Present (Ent) then 5455 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc); 5456 else 5457 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc); 5458 end if; 5459 5460 if Wmsg then 5461 5462 -- Check whether the context is an Init_Proc 5463 5464 if Inside_Init_Proc then 5465 declare 5466 Conc_Typ : constant Entity_Id := 5467 Corresponding_Concurrent_Type 5468 (Entity (Parameter_Type (First 5469 (Parameter_Specifications 5470 (Parent (Current_Scope)))))); 5471 5472 begin 5473 -- Don't complain if the corresponding concurrent type 5474 -- doesn't come from source (i.e. a single task/protected 5475 -- object). 5476 5477 if Present (Conc_Typ) 5478 and then not Comes_From_Source (Conc_Typ) 5479 then 5480 Error_Msg_NEL 5481 ("\& [<<", N, Standard_Constraint_Error, Eloc); 5482 5483 else 5484 if GNATprove_Mode then 5485 Error_Msg_NEL 5486 ("\& would have been raised for objects of this " 5487 & "type", N, Standard_Constraint_Error, Eloc); 5488 else 5489 Error_Msg_NEL 5490 ("\& will be raised for objects of this type??", 5491 N, Standard_Constraint_Error, Eloc); 5492 end if; 5493 end if; 5494 end; 5495 5496 else 5497 Error_Msg_NEL ("\& [<<", N, Standard_Constraint_Error, Eloc); 5498 end if; 5499 5500 else 5501 Error_Msg ("\static expression fails Constraint_Check", Eloc); 5502 Set_Error_Posted (N); 5503 end if; 5504 end if; 5505 end if; 5506 5507 return N; 5508 end Compile_Time_Constraint_Error; 5509 5510 ----------------------- 5511 -- Conditional_Delay -- 5512 ----------------------- 5513 5514 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is 5515 begin 5516 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then 5517 Set_Has_Delayed_Freeze (New_Ent); 5518 end if; 5519 end Conditional_Delay; 5520 5521 ------------------------- 5522 -- Copy_Component_List -- 5523 ------------------------- 5524 5525 function Copy_Component_List 5526 (R_Typ : Entity_Id; 5527 Loc : Source_Ptr) return List_Id 5528 is 5529 Comp : Node_Id; 5530 Comps : constant List_Id := New_List; 5531 5532 begin 5533 Comp := First_Component (Underlying_Type (R_Typ)); 5534 while Present (Comp) loop 5535 if Comes_From_Source (Comp) then 5536 declare 5537 Comp_Decl : constant Node_Id := Declaration_Node (Comp); 5538 begin 5539 Append_To (Comps, 5540 Make_Component_Declaration (Loc, 5541 Defining_Identifier => 5542 Make_Defining_Identifier (Loc, Chars (Comp)), 5543 Component_Definition => 5544 New_Copy_Tree 5545 (Component_Definition (Comp_Decl), New_Sloc => Loc))); 5546 end; 5547 end if; 5548 5549 Next_Component (Comp); 5550 end loop; 5551 5552 return Comps; 5553 end Copy_Component_List; 5554 5555 ------------------------- 5556 -- Copy_Parameter_List -- 5557 ------------------------- 5558 5559 function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is 5560 Loc : constant Source_Ptr := Sloc (Subp_Id); 5561 Plist : List_Id; 5562 Formal : Entity_Id; 5563 5564 begin 5565 if No (First_Formal (Subp_Id)) then 5566 return No_List; 5567 else 5568 Plist := New_List; 5569 Formal := First_Formal (Subp_Id); 5570 while Present (Formal) loop 5571 Append_To (Plist, 5572 Make_Parameter_Specification (Loc, 5573 Defining_Identifier => 5574 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), 5575 In_Present => In_Present (Parent (Formal)), 5576 Out_Present => Out_Present (Parent (Formal)), 5577 Parameter_Type => 5578 New_Occurrence_Of (Etype (Formal), Loc), 5579 Expression => 5580 New_Copy_Tree (Expression (Parent (Formal))))); 5581 5582 Next_Formal (Formal); 5583 end loop; 5584 end if; 5585 5586 return Plist; 5587 end Copy_Parameter_List; 5588 5589 ---------------------------- 5590 -- Copy_SPARK_Mode_Aspect -- 5591 ---------------------------- 5592 5593 procedure Copy_SPARK_Mode_Aspect (From : Node_Id; To : Node_Id) is 5594 pragma Assert (not Has_Aspects (To)); 5595 Asp : Node_Id; 5596 5597 begin 5598 if Has_Aspects (From) then 5599 Asp := Find_Aspect (Defining_Entity (From), Aspect_SPARK_Mode); 5600 5601 if Present (Asp) then 5602 Set_Aspect_Specifications (To, New_List (New_Copy_Tree (Asp))); 5603 Set_Has_Aspects (To, True); 5604 end if; 5605 end if; 5606 end Copy_SPARK_Mode_Aspect; 5607 5608 -------------------------- 5609 -- Copy_Subprogram_Spec -- 5610 -------------------------- 5611 5612 function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id is 5613 Def_Id : Node_Id; 5614 Formal_Spec : Node_Id; 5615 Result : Node_Id; 5616 5617 begin 5618 -- The structure of the original tree must be replicated without any 5619 -- alterations. Use New_Copy_Tree for this purpose. 5620 5621 Result := New_Copy_Tree (Spec); 5622 5623 -- However, the spec of a null procedure carries the corresponding null 5624 -- statement of the body (created by the parser), and this cannot be 5625 -- shared with the new subprogram spec. 5626 5627 if Nkind (Result) = N_Procedure_Specification then 5628 Set_Null_Statement (Result, Empty); 5629 end if; 5630 5631 -- Create a new entity for the defining unit name 5632 5633 Def_Id := Defining_Unit_Name (Result); 5634 Set_Defining_Unit_Name (Result, 5635 Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id))); 5636 5637 -- Create new entities for the formal parameters 5638 5639 if Present (Parameter_Specifications (Result)) then 5640 Formal_Spec := First (Parameter_Specifications (Result)); 5641 while Present (Formal_Spec) loop 5642 Def_Id := Defining_Identifier (Formal_Spec); 5643 Set_Defining_Identifier (Formal_Spec, 5644 Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id))); 5645 5646 Next (Formal_Spec); 5647 end loop; 5648 end if; 5649 5650 return Result; 5651 end Copy_Subprogram_Spec; 5652 5653 -------------------------------- 5654 -- Corresponding_Generic_Type -- 5655 -------------------------------- 5656 5657 function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is 5658 Inst : Entity_Id; 5659 Gen : Entity_Id; 5660 Typ : Entity_Id; 5661 5662 begin 5663 if not Is_Generic_Actual_Type (T) then 5664 return Any_Type; 5665 5666 -- If the actual is the actual of an enclosing instance, resolution 5667 -- was correct in the generic. 5668 5669 elsif Nkind (Parent (T)) = N_Subtype_Declaration 5670 and then Is_Entity_Name (Subtype_Indication (Parent (T))) 5671 and then 5672 Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T)))) 5673 then 5674 return Any_Type; 5675 5676 else 5677 Inst := Scope (T); 5678 5679 if Is_Wrapper_Package (Inst) then 5680 Inst := Related_Instance (Inst); 5681 end if; 5682 5683 Gen := 5684 Generic_Parent 5685 (Specification (Unit_Declaration_Node (Inst))); 5686 5687 -- Generic actual has the same name as the corresponding formal 5688 5689 Typ := First_Entity (Gen); 5690 while Present (Typ) loop 5691 if Chars (Typ) = Chars (T) then 5692 return Typ; 5693 end if; 5694 5695 Next_Entity (Typ); 5696 end loop; 5697 5698 return Any_Type; 5699 end if; 5700 end Corresponding_Generic_Type; 5701 5702 -------------------- 5703 -- Current_Entity -- 5704 -------------------- 5705 5706 -- The currently visible definition for a given identifier is the 5707 -- one most chained at the start of the visibility chain, i.e. the 5708 -- one that is referenced by the Node_Id value of the name of the 5709 -- given identifier. 5710 5711 function Current_Entity (N : Node_Id) return Entity_Id is 5712 begin 5713 return Get_Name_Entity_Id (Chars (N)); 5714 end Current_Entity; 5715 5716 ----------------------------- 5717 -- Current_Entity_In_Scope -- 5718 ----------------------------- 5719 5720 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is 5721 E : Entity_Id; 5722 CS : constant Entity_Id := Current_Scope; 5723 5724 Transient_Case : constant Boolean := Scope_Is_Transient; 5725 5726 begin 5727 E := Get_Name_Entity_Id (Chars (N)); 5728 while Present (E) 5729 and then Scope (E) /= CS 5730 and then (not Transient_Case or else Scope (E) /= Scope (CS)) 5731 loop 5732 E := Homonym (E); 5733 end loop; 5734 5735 return E; 5736 end Current_Entity_In_Scope; 5737 5738 ------------------- 5739 -- Current_Scope -- 5740 ------------------- 5741 5742 function Current_Scope return Entity_Id is 5743 begin 5744 if Scope_Stack.Last = -1 then 5745 return Standard_Standard; 5746 else 5747 declare 5748 C : constant Entity_Id := 5749 Scope_Stack.Table (Scope_Stack.Last).Entity; 5750 begin 5751 if Present (C) then 5752 return C; 5753 else 5754 return Standard_Standard; 5755 end if; 5756 end; 5757 end if; 5758 end Current_Scope; 5759 5760 ---------------------------- 5761 -- Current_Scope_No_Loops -- 5762 ---------------------------- 5763 5764 function Current_Scope_No_Loops return Entity_Id is 5765 S : Entity_Id; 5766 5767 begin 5768 -- Examine the scope stack starting from the current scope and skip any 5769 -- internally generated loops. 5770 5771 S := Current_Scope; 5772 while Present (S) and then S /= Standard_Standard loop 5773 if Ekind (S) = E_Loop and then not Comes_From_Source (S) then 5774 S := Scope (S); 5775 else 5776 exit; 5777 end if; 5778 end loop; 5779 5780 return S; 5781 end Current_Scope_No_Loops; 5782 5783 ------------------------ 5784 -- Current_Subprogram -- 5785 ------------------------ 5786 5787 function Current_Subprogram return Entity_Id is 5788 Scop : constant Entity_Id := Current_Scope; 5789 begin 5790 if Is_Subprogram_Or_Generic_Subprogram (Scop) then 5791 return Scop; 5792 else 5793 return Enclosing_Subprogram (Scop); 5794 end if; 5795 end Current_Subprogram; 5796 5797 ---------------------------------- 5798 -- Deepest_Type_Access_Level -- 5799 ---------------------------------- 5800 5801 function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is 5802 begin 5803 if Ekind (Typ) = E_Anonymous_Access_Type 5804 and then not Is_Local_Anonymous_Access (Typ) 5805 and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration 5806 then 5807 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous 5808 -- access type. 5809 5810 return 5811 Scope_Depth (Enclosing_Dynamic_Scope 5812 (Defining_Identifier 5813 (Associated_Node_For_Itype (Typ)))); 5814 5815 -- For generic formal type, return Int'Last (infinite). 5816 -- See comment preceding Is_Generic_Type call in Type_Access_Level. 5817 5818 elsif Is_Generic_Type (Root_Type (Typ)) then 5819 return UI_From_Int (Int'Last); 5820 5821 else 5822 return Type_Access_Level (Typ); 5823 end if; 5824 end Deepest_Type_Access_Level; 5825 5826 --------------------- 5827 -- Defining_Entity -- 5828 --------------------- 5829 5830 function Defining_Entity (N : Node_Id) return Entity_Id is 5831 begin 5832 case Nkind (N) is 5833 when N_Abstract_Subprogram_Declaration 5834 | N_Expression_Function 5835 | N_Formal_Subprogram_Declaration 5836 | N_Generic_Package_Declaration 5837 | N_Generic_Subprogram_Declaration 5838 | N_Package_Declaration 5839 | N_Subprogram_Body 5840 | N_Subprogram_Body_Stub 5841 | N_Subprogram_Declaration 5842 | N_Subprogram_Renaming_Declaration 5843 => 5844 return Defining_Entity (Specification (N)); 5845 5846 when N_Component_Declaration 5847 | N_Defining_Program_Unit_Name 5848 | N_Discriminant_Specification 5849 | N_Entry_Body 5850 | N_Entry_Declaration 5851 | N_Entry_Index_Specification 5852 | N_Exception_Declaration 5853 | N_Exception_Renaming_Declaration 5854 | N_Formal_Object_Declaration 5855 | N_Formal_Package_Declaration 5856 | N_Formal_Type_Declaration 5857 | N_Full_Type_Declaration 5858 | N_Implicit_Label_Declaration 5859 | N_Incomplete_Type_Declaration 5860 | N_Iterator_Specification 5861 | N_Loop_Parameter_Specification 5862 | N_Number_Declaration 5863 | N_Object_Declaration 5864 | N_Object_Renaming_Declaration 5865 | N_Package_Body_Stub 5866 | N_Parameter_Specification 5867 | N_Private_Extension_Declaration 5868 | N_Private_Type_Declaration 5869 | N_Protected_Body 5870 | N_Protected_Body_Stub 5871 | N_Protected_Type_Declaration 5872 | N_Single_Protected_Declaration 5873 | N_Single_Task_Declaration 5874 | N_Subtype_Declaration 5875 | N_Task_Body 5876 | N_Task_Body_Stub 5877 | N_Task_Type_Declaration 5878 => 5879 return Defining_Identifier (N); 5880 5881 when N_Compilation_Unit => 5882 return Defining_Entity (Unit (N)); 5883 5884 when N_Subunit => 5885 return Defining_Entity (Proper_Body (N)); 5886 5887 when N_Function_Instantiation 5888 | N_Function_Specification 5889 | N_Generic_Function_Renaming_Declaration 5890 | N_Generic_Package_Renaming_Declaration 5891 | N_Generic_Procedure_Renaming_Declaration 5892 | N_Package_Body 5893 | N_Package_Instantiation 5894 | N_Package_Renaming_Declaration 5895 | N_Package_Specification 5896 | N_Procedure_Instantiation 5897 | N_Procedure_Specification 5898 => 5899 declare 5900 Nam : constant Node_Id := Defining_Unit_Name (N); 5901 Err : Entity_Id := Empty; 5902 5903 begin 5904 if Nkind (Nam) in N_Entity then 5905 return Nam; 5906 5907 -- For Error, make up a name and attach to declaration so we 5908 -- can continue semantic analysis. 5909 5910 elsif Nam = Error then 5911 Err := Make_Temporary (Sloc (N), 'T'); 5912 Set_Defining_Unit_Name (N, Err); 5913 5914 return Err; 5915 5916 -- If not an entity, get defining identifier 5917 5918 else 5919 return Defining_Identifier (Nam); 5920 end if; 5921 end; 5922 5923 when N_Block_Statement 5924 | N_Loop_Statement 5925 => 5926 return Entity (Identifier (N)); 5927 5928 when others => 5929 raise Program_Error; 5930 end case; 5931 end Defining_Entity; 5932 5933 -------------------------- 5934 -- Denotes_Discriminant -- 5935 -------------------------- 5936 5937 function Denotes_Discriminant 5938 (N : Node_Id; 5939 Check_Concurrent : Boolean := False) return Boolean 5940 is 5941 E : Entity_Id; 5942 5943 begin 5944 if not Is_Entity_Name (N) or else No (Entity (N)) then 5945 return False; 5946 else 5947 E := Entity (N); 5948 end if; 5949 5950 -- If we are checking for a protected type, the discriminant may have 5951 -- been rewritten as the corresponding discriminal of the original type 5952 -- or of the corresponding concurrent record, depending on whether we 5953 -- are in the spec or body of the protected type. 5954 5955 return Ekind (E) = E_Discriminant 5956 or else 5957 (Check_Concurrent 5958 and then Ekind (E) = E_In_Parameter 5959 and then Present (Discriminal_Link (E)) 5960 and then 5961 (Is_Concurrent_Type (Scope (Discriminal_Link (E))) 5962 or else 5963 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E))))); 5964 end Denotes_Discriminant; 5965 5966 ------------------------- 5967 -- Denotes_Same_Object -- 5968 ------------------------- 5969 5970 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is 5971 function Is_Renaming (N : Node_Id) return Boolean; 5972 -- Return true if N names a renaming entity 5973 5974 function Is_Valid_Renaming (N : Node_Id) return Boolean; 5975 -- For renamings, return False if the prefix of any dereference within 5976 -- the renamed object_name is a variable, or any expression within the 5977 -- renamed object_name contains references to variables or calls on 5978 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3)) 5979 5980 ----------------- 5981 -- Is_Renaming -- 5982 ----------------- 5983 5984 function Is_Renaming (N : Node_Id) return Boolean is 5985 begin 5986 return 5987 Is_Entity_Name (N) and then Present (Renamed_Entity (Entity (N))); 5988 end Is_Renaming; 5989 5990 ----------------------- 5991 -- Is_Valid_Renaming -- 5992 ----------------------- 5993 5994 function Is_Valid_Renaming (N : Node_Id) return Boolean is 5995 function Check_Renaming (N : Node_Id) return Boolean; 5996 -- Recursive function used to traverse all the prefixes of N 5997 5998 -------------------- 5999 -- Check_Renaming -- 6000 -------------------- 6001 6002 function Check_Renaming (N : Node_Id) return Boolean is 6003 begin 6004 if Is_Renaming (N) 6005 and then not Check_Renaming (Renamed_Entity (Entity (N))) 6006 then 6007 return False; 6008 end if; 6009 6010 if Nkind (N) = N_Indexed_Component then 6011 declare 6012 Indx : Node_Id; 6013 6014 begin 6015 Indx := First (Expressions (N)); 6016 while Present (Indx) loop 6017 if not Is_OK_Static_Expression (Indx) then 6018 return False; 6019 end if; 6020 6021 Next_Index (Indx); 6022 end loop; 6023 end; 6024 end if; 6025 6026 if Has_Prefix (N) then 6027 declare 6028 P : constant Node_Id := Prefix (N); 6029 6030 begin 6031 if Nkind (N) = N_Explicit_Dereference 6032 and then Is_Variable (P) 6033 then 6034 return False; 6035 6036 elsif Is_Entity_Name (P) 6037 and then Ekind (Entity (P)) = E_Function 6038 then 6039 return False; 6040 6041 elsif Nkind (P) = N_Function_Call then 6042 return False; 6043 end if; 6044 6045 -- Recursion to continue traversing the prefix of the 6046 -- renaming expression 6047 6048 return Check_Renaming (P); 6049 end; 6050 end if; 6051 6052 return True; 6053 end Check_Renaming; 6054 6055 -- Start of processing for Is_Valid_Renaming 6056 6057 begin 6058 return Check_Renaming (N); 6059 end Is_Valid_Renaming; 6060 6061 -- Local variables 6062 6063 Obj1 : Node_Id := A1; 6064 Obj2 : Node_Id := A2; 6065 6066 -- Start of processing for Denotes_Same_Object 6067 6068 begin 6069 -- Both names statically denote the same stand-alone object or parameter 6070 -- (RM 6.4.1(6.5/3)) 6071 6072 if Is_Entity_Name (Obj1) 6073 and then Is_Entity_Name (Obj2) 6074 and then Entity (Obj1) = Entity (Obj2) 6075 then 6076 return True; 6077 end if; 6078 6079 -- For renamings, the prefix of any dereference within the renamed 6080 -- object_name is not a variable, and any expression within the 6081 -- renamed object_name contains no references to variables nor 6082 -- calls on nonstatic functions (RM 6.4.1(6.10/3)). 6083 6084 if Is_Renaming (Obj1) then 6085 if Is_Valid_Renaming (Obj1) then 6086 Obj1 := Renamed_Entity (Entity (Obj1)); 6087 else 6088 return False; 6089 end if; 6090 end if; 6091 6092 if Is_Renaming (Obj2) then 6093 if Is_Valid_Renaming (Obj2) then 6094 Obj2 := Renamed_Entity (Entity (Obj2)); 6095 else 6096 return False; 6097 end if; 6098 end if; 6099 6100 -- No match if not same node kind (such cases are handled by 6101 -- Denotes_Same_Prefix) 6102 6103 if Nkind (Obj1) /= Nkind (Obj2) then 6104 return False; 6105 6106 -- After handling valid renamings, one of the two names statically 6107 -- denoted a renaming declaration whose renamed object_name is known 6108 -- to denote the same object as the other (RM 6.4.1(6.10/3)) 6109 6110 elsif Is_Entity_Name (Obj1) then 6111 if Is_Entity_Name (Obj2) then 6112 return Entity (Obj1) = Entity (Obj2); 6113 else 6114 return False; 6115 end if; 6116 6117 -- Both names are selected_components, their prefixes are known to 6118 -- denote the same object, and their selector_names denote the same 6119 -- component (RM 6.4.1(6.6/3)). 6120 6121 elsif Nkind (Obj1) = N_Selected_Component then 6122 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) 6123 and then 6124 Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2)); 6125 6126 -- Both names are dereferences and the dereferenced names are known to 6127 -- denote the same object (RM 6.4.1(6.7/3)) 6128 6129 elsif Nkind (Obj1) = N_Explicit_Dereference then 6130 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)); 6131 6132 -- Both names are indexed_components, their prefixes are known to denote 6133 -- the same object, and each of the pairs of corresponding index values 6134 -- are either both static expressions with the same static value or both 6135 -- names that are known to denote the same object (RM 6.4.1(6.8/3)) 6136 6137 elsif Nkind (Obj1) = N_Indexed_Component then 6138 if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then 6139 return False; 6140 else 6141 declare 6142 Indx1 : Node_Id; 6143 Indx2 : Node_Id; 6144 6145 begin 6146 Indx1 := First (Expressions (Obj1)); 6147 Indx2 := First (Expressions (Obj2)); 6148 while Present (Indx1) loop 6149 6150 -- Indexes must denote the same static value or same object 6151 6152 if Is_OK_Static_Expression (Indx1) then 6153 if not Is_OK_Static_Expression (Indx2) then 6154 return False; 6155 6156 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then 6157 return False; 6158 end if; 6159 6160 elsif not Denotes_Same_Object (Indx1, Indx2) then 6161 return False; 6162 end if; 6163 6164 Next (Indx1); 6165 Next (Indx2); 6166 end loop; 6167 6168 return True; 6169 end; 6170 end if; 6171 6172 -- Both names are slices, their prefixes are known to denote the same 6173 -- object, and the two slices have statically matching index constraints 6174 -- (RM 6.4.1(6.9/3)) 6175 6176 elsif Nkind (Obj1) = N_Slice 6177 and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) 6178 then 6179 declare 6180 Lo1, Lo2, Hi1, Hi2 : Node_Id; 6181 6182 begin 6183 Get_Index_Bounds (Etype (Obj1), Lo1, Hi1); 6184 Get_Index_Bounds (Etype (Obj2), Lo2, Hi2); 6185 6186 -- Check whether bounds are statically identical. There is no 6187 -- attempt to detect partial overlap of slices. 6188 6189 return Denotes_Same_Object (Lo1, Lo2) 6190 and then 6191 Denotes_Same_Object (Hi1, Hi2); 6192 end; 6193 6194 -- In the recursion, literals appear as indexes 6195 6196 elsif Nkind (Obj1) = N_Integer_Literal 6197 and then 6198 Nkind (Obj2) = N_Integer_Literal 6199 then 6200 return Intval (Obj1) = Intval (Obj2); 6201 6202 else 6203 return False; 6204 end if; 6205 end Denotes_Same_Object; 6206 6207 ------------------------- 6208 -- Denotes_Same_Prefix -- 6209 ------------------------- 6210 6211 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is 6212 begin 6213 if Is_Entity_Name (A1) then 6214 if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) 6215 and then not Is_Access_Type (Etype (A1)) 6216 then 6217 return Denotes_Same_Object (A1, Prefix (A2)) 6218 or else Denotes_Same_Prefix (A1, Prefix (A2)); 6219 else 6220 return False; 6221 end if; 6222 6223 elsif Is_Entity_Name (A2) then 6224 return Denotes_Same_Prefix (A1 => A2, A2 => A1); 6225 6226 elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice) 6227 and then 6228 Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice) 6229 then 6230 declare 6231 Root1, Root2 : Node_Id; 6232 Depth1, Depth2 : Nat := 0; 6233 6234 begin 6235 Root1 := Prefix (A1); 6236 while not Is_Entity_Name (Root1) loop 6237 if not Nkind_In 6238 (Root1, N_Selected_Component, N_Indexed_Component) 6239 then 6240 return False; 6241 else 6242 Root1 := Prefix (Root1); 6243 end if; 6244 6245 Depth1 := Depth1 + 1; 6246 end loop; 6247 6248 Root2 := Prefix (A2); 6249 while not Is_Entity_Name (Root2) loop 6250 if not Nkind_In (Root2, N_Selected_Component, 6251 N_Indexed_Component) 6252 then 6253 return False; 6254 else 6255 Root2 := Prefix (Root2); 6256 end if; 6257 6258 Depth2 := Depth2 + 1; 6259 end loop; 6260 6261 -- If both have the same depth and they do not denote the same 6262 -- object, they are disjoint and no warning is needed. 6263 6264 if Depth1 = Depth2 then 6265 return False; 6266 6267 elsif Depth1 > Depth2 then 6268 Root1 := Prefix (A1); 6269 for J in 1 .. Depth1 - Depth2 - 1 loop 6270 Root1 := Prefix (Root1); 6271 end loop; 6272 6273 return Denotes_Same_Object (Root1, A2); 6274 6275 else 6276 Root2 := Prefix (A2); 6277 for J in 1 .. Depth2 - Depth1 - 1 loop 6278 Root2 := Prefix (Root2); 6279 end loop; 6280 6281 return Denotes_Same_Object (A1, Root2); 6282 end if; 6283 end; 6284 6285 else 6286 return False; 6287 end if; 6288 end Denotes_Same_Prefix; 6289 6290 ---------------------- 6291 -- Denotes_Variable -- 6292 ---------------------- 6293 6294 function Denotes_Variable (N : Node_Id) return Boolean is 6295 begin 6296 return Is_Variable (N) and then Paren_Count (N) = 0; 6297 end Denotes_Variable; 6298 6299 ----------------------------- 6300 -- Depends_On_Discriminant -- 6301 ----------------------------- 6302 6303 function Depends_On_Discriminant (N : Node_Id) return Boolean is 6304 L : Node_Id; 6305 H : Node_Id; 6306 6307 begin 6308 Get_Index_Bounds (N, L, H); 6309 return Denotes_Discriminant (L) or else Denotes_Discriminant (H); 6310 end Depends_On_Discriminant; 6311 6312 ------------------------- 6313 -- Designate_Same_Unit -- 6314 ------------------------- 6315 6316 function Designate_Same_Unit 6317 (Name1 : Node_Id; 6318 Name2 : Node_Id) return Boolean 6319 is 6320 K1 : constant Node_Kind := Nkind (Name1); 6321 K2 : constant Node_Kind := Nkind (Name2); 6322 6323 function Prefix_Node (N : Node_Id) return Node_Id; 6324 -- Returns the parent unit name node of a defining program unit name 6325 -- or the prefix if N is a selected component or an expanded name. 6326 6327 function Select_Node (N : Node_Id) return Node_Id; 6328 -- Returns the defining identifier node of a defining program unit 6329 -- name or the selector node if N is a selected component or an 6330 -- expanded name. 6331 6332 ----------------- 6333 -- Prefix_Node -- 6334 ----------------- 6335 6336 function Prefix_Node (N : Node_Id) return Node_Id is 6337 begin 6338 if Nkind (N) = N_Defining_Program_Unit_Name then 6339 return Name (N); 6340 else 6341 return Prefix (N); 6342 end if; 6343 end Prefix_Node; 6344 6345 ----------------- 6346 -- Select_Node -- 6347 ----------------- 6348 6349 function Select_Node (N : Node_Id) return Node_Id is 6350 begin 6351 if Nkind (N) = N_Defining_Program_Unit_Name then 6352 return Defining_Identifier (N); 6353 else 6354 return Selector_Name (N); 6355 end if; 6356 end Select_Node; 6357 6358 -- Start of processing for Designate_Same_Unit 6359 6360 begin 6361 if Nkind_In (K1, N_Identifier, N_Defining_Identifier) 6362 and then 6363 Nkind_In (K2, N_Identifier, N_Defining_Identifier) 6364 then 6365 return Chars (Name1) = Chars (Name2); 6366 6367 elsif Nkind_In (K1, N_Expanded_Name, 6368 N_Selected_Component, 6369 N_Defining_Program_Unit_Name) 6370 and then 6371 Nkind_In (K2, N_Expanded_Name, 6372 N_Selected_Component, 6373 N_Defining_Program_Unit_Name) 6374 then 6375 return 6376 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2))) 6377 and then 6378 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2)); 6379 6380 else 6381 return False; 6382 end if; 6383 end Designate_Same_Unit; 6384 6385 --------------------------------------------- 6386 -- Diagnose_Iterated_Component_Association -- 6387 --------------------------------------------- 6388 6389 procedure Diagnose_Iterated_Component_Association (N : Node_Id) is 6390 Def_Id : constant Entity_Id := Defining_Identifier (N); 6391 Aggr : Node_Id; 6392 6393 begin 6394 -- Determine whether the iterated component association appears within 6395 -- an aggregate. If this is the case, raise Program_Error because the 6396 -- iterated component association cannot be left in the tree as is and 6397 -- must always be processed by the related aggregate. 6398 6399 Aggr := N; 6400 while Present (Aggr) loop 6401 if Nkind (Aggr) = N_Aggregate then 6402 raise Program_Error; 6403 6404 -- Prevent the search from going too far 6405 6406 elsif Is_Body_Or_Package_Declaration (Aggr) then 6407 exit; 6408 end if; 6409 6410 Aggr := Parent (Aggr); 6411 end loop; 6412 6413 -- At this point it is known that the iterated component association is 6414 -- not within an aggregate. This is really a quantified expression with 6415 -- a missing "all" or "some" quantifier. 6416 6417 Error_Msg_N ("missing quantifier", Def_Id); 6418 6419 -- Rewrite the iterated component association as True to prevent any 6420 -- cascaded errors. 6421 6422 Rewrite (N, New_Occurrence_Of (Standard_True, Sloc (N))); 6423 Analyze (N); 6424 end Diagnose_Iterated_Component_Association; 6425 6426 --------------------------------- 6427 -- Dynamic_Accessibility_Level -- 6428 --------------------------------- 6429 6430 function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is 6431 Loc : constant Source_Ptr := Sloc (Expr); 6432 6433 function Make_Level_Literal (Level : Uint) return Node_Id; 6434 -- Construct an integer literal representing an accessibility level 6435 -- with its type set to Natural. 6436 6437 ------------------------ 6438 -- Make_Level_Literal -- 6439 ------------------------ 6440 6441 function Make_Level_Literal (Level : Uint) return Node_Id is 6442 Result : constant Node_Id := Make_Integer_Literal (Loc, Level); 6443 6444 begin 6445 Set_Etype (Result, Standard_Natural); 6446 return Result; 6447 end Make_Level_Literal; 6448 6449 -- Local variables 6450 6451 E : Entity_Id; 6452 6453 -- Start of processing for Dynamic_Accessibility_Level 6454 6455 begin 6456 if Is_Entity_Name (Expr) then 6457 E := Entity (Expr); 6458 6459 if Present (Renamed_Object (E)) then 6460 return Dynamic_Accessibility_Level (Renamed_Object (E)); 6461 end if; 6462 6463 if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then 6464 if Present (Extra_Accessibility (E)) then 6465 return New_Occurrence_Of (Extra_Accessibility (E), Loc); 6466 end if; 6467 end if; 6468 end if; 6469 6470 -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ??? 6471 6472 case Nkind (Expr) is 6473 6474 -- For access discriminant, the level of the enclosing object 6475 6476 when N_Selected_Component => 6477 if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant 6478 and then Ekind (Etype (Entity (Selector_Name (Expr)))) = 6479 E_Anonymous_Access_Type 6480 then 6481 return Make_Level_Literal (Object_Access_Level (Expr)); 6482 end if; 6483 6484 when N_Attribute_Reference => 6485 case Get_Attribute_Id (Attribute_Name (Expr)) is 6486 6487 -- For X'Access, the level of the prefix X 6488 6489 when Attribute_Access => 6490 return Make_Level_Literal 6491 (Object_Access_Level (Prefix (Expr))); 6492 6493 -- Treat the unchecked attributes as library-level 6494 6495 when Attribute_Unchecked_Access 6496 | Attribute_Unrestricted_Access 6497 => 6498 return Make_Level_Literal (Scope_Depth (Standard_Standard)); 6499 6500 -- No other access-valued attributes 6501 6502 when others => 6503 raise Program_Error; 6504 end case; 6505 6506 when N_Allocator => 6507 6508 -- Unimplemented: depends on context. As an actual parameter where 6509 -- formal type is anonymous, use 6510 -- Scope_Depth (Current_Scope) + 1. 6511 -- For other cases, see 3.10.2(14/3) and following. ??? 6512 6513 null; 6514 6515 when N_Type_Conversion => 6516 if not Is_Local_Anonymous_Access (Etype (Expr)) then 6517 6518 -- Handle type conversions introduced for a rename of an 6519 -- Ada 2012 stand-alone object of an anonymous access type. 6520 6521 return Dynamic_Accessibility_Level (Expression (Expr)); 6522 end if; 6523 6524 when others => 6525 null; 6526 end case; 6527 6528 return Make_Level_Literal (Type_Access_Level (Etype (Expr))); 6529 end Dynamic_Accessibility_Level; 6530 6531 ------------------------ 6532 -- Discriminated_Size -- 6533 ------------------------ 6534 6535 function Discriminated_Size (Comp : Entity_Id) return Boolean is 6536 function Non_Static_Bound (Bound : Node_Id) return Boolean; 6537 -- Check whether the bound of an index is non-static and does denote 6538 -- a discriminant, in which case any object of the type (protected or 6539 -- otherwise) will have a non-static size. 6540 6541 ---------------------- 6542 -- Non_Static_Bound -- 6543 ---------------------- 6544 6545 function Non_Static_Bound (Bound : Node_Id) return Boolean is 6546 begin 6547 if Is_OK_Static_Expression (Bound) then 6548 return False; 6549 6550 -- If the bound is given by a discriminant it is non-static 6551 -- (A static constraint replaces the reference with the value). 6552 -- In an protected object the discriminant has been replaced by 6553 -- the corresponding discriminal within the protected operation. 6554 6555 elsif Is_Entity_Name (Bound) 6556 and then 6557 (Ekind (Entity (Bound)) = E_Discriminant 6558 or else Present (Discriminal_Link (Entity (Bound)))) 6559 then 6560 return False; 6561 6562 else 6563 return True; 6564 end if; 6565 end Non_Static_Bound; 6566 6567 -- Local variables 6568 6569 Typ : constant Entity_Id := Etype (Comp); 6570 Index : Node_Id; 6571 6572 -- Start of processing for Discriminated_Size 6573 6574 begin 6575 if not Is_Array_Type (Typ) then 6576 return False; 6577 end if; 6578 6579 if Ekind (Typ) = E_Array_Subtype then 6580 Index := First_Index (Typ); 6581 while Present (Index) loop 6582 if Non_Static_Bound (Low_Bound (Index)) 6583 or else Non_Static_Bound (High_Bound (Index)) 6584 then 6585 return False; 6586 end if; 6587 6588 Next_Index (Index); 6589 end loop; 6590 6591 return True; 6592 end if; 6593 6594 return False; 6595 end Discriminated_Size; 6596 6597 ----------------------------------- 6598 -- Effective_Extra_Accessibility -- 6599 ----------------------------------- 6600 6601 function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is 6602 begin 6603 if Present (Renamed_Object (Id)) 6604 and then Is_Entity_Name (Renamed_Object (Id)) 6605 then 6606 return Effective_Extra_Accessibility (Entity (Renamed_Object (Id))); 6607 else 6608 return Extra_Accessibility (Id); 6609 end if; 6610 end Effective_Extra_Accessibility; 6611 6612 ----------------------------- 6613 -- Effective_Reads_Enabled -- 6614 ----------------------------- 6615 6616 function Effective_Reads_Enabled (Id : Entity_Id) return Boolean is 6617 begin 6618 return Has_Enabled_Property (Id, Name_Effective_Reads); 6619 end Effective_Reads_Enabled; 6620 6621 ------------------------------ 6622 -- Effective_Writes_Enabled -- 6623 ------------------------------ 6624 6625 function Effective_Writes_Enabled (Id : Entity_Id) return Boolean is 6626 begin 6627 return Has_Enabled_Property (Id, Name_Effective_Writes); 6628 end Effective_Writes_Enabled; 6629 6630 ------------------------------ 6631 -- Enclosing_Comp_Unit_Node -- 6632 ------------------------------ 6633 6634 function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is 6635 Current_Node : Node_Id; 6636 6637 begin 6638 Current_Node := N; 6639 while Present (Current_Node) 6640 and then Nkind (Current_Node) /= N_Compilation_Unit 6641 loop 6642 Current_Node := Parent (Current_Node); 6643 end loop; 6644 6645 if Nkind (Current_Node) /= N_Compilation_Unit then 6646 return Empty; 6647 else 6648 return Current_Node; 6649 end if; 6650 end Enclosing_Comp_Unit_Node; 6651 6652 -------------------------- 6653 -- Enclosing_CPP_Parent -- 6654 -------------------------- 6655 6656 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is 6657 Parent_Typ : Entity_Id := Typ; 6658 6659 begin 6660 while not Is_CPP_Class (Parent_Typ) 6661 and then Etype (Parent_Typ) /= Parent_Typ 6662 loop 6663 Parent_Typ := Etype (Parent_Typ); 6664 6665 if Is_Private_Type (Parent_Typ) then 6666 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 6667 end if; 6668 end loop; 6669 6670 pragma Assert (Is_CPP_Class (Parent_Typ)); 6671 return Parent_Typ; 6672 end Enclosing_CPP_Parent; 6673 6674 --------------------------- 6675 -- Enclosing_Declaration -- 6676 --------------------------- 6677 6678 function Enclosing_Declaration (N : Node_Id) return Node_Id is 6679 Decl : Node_Id := N; 6680 6681 begin 6682 while Present (Decl) 6683 and then not (Nkind (Decl) in N_Declaration 6684 or else 6685 Nkind (Decl) in N_Later_Decl_Item 6686 or else 6687 Nkind (Decl) = N_Number_Declaration) 6688 loop 6689 Decl := Parent (Decl); 6690 end loop; 6691 6692 return Decl; 6693 end Enclosing_Declaration; 6694 6695 ---------------------------- 6696 -- Enclosing_Generic_Body -- 6697 ---------------------------- 6698 6699 function Enclosing_Generic_Body 6700 (N : Node_Id) return Node_Id 6701 is 6702 P : Node_Id; 6703 Decl : Node_Id; 6704 Spec : Node_Id; 6705 6706 begin 6707 P := Parent (N); 6708 while Present (P) loop 6709 if Nkind (P) = N_Package_Body 6710 or else Nkind (P) = N_Subprogram_Body 6711 then 6712 Spec := Corresponding_Spec (P); 6713 6714 if Present (Spec) then 6715 Decl := Unit_Declaration_Node (Spec); 6716 6717 if Nkind (Decl) = N_Generic_Package_Declaration 6718 or else Nkind (Decl) = N_Generic_Subprogram_Declaration 6719 then 6720 return P; 6721 end if; 6722 end if; 6723 end if; 6724 6725 P := Parent (P); 6726 end loop; 6727 6728 return Empty; 6729 end Enclosing_Generic_Body; 6730 6731 ---------------------------- 6732 -- Enclosing_Generic_Unit -- 6733 ---------------------------- 6734 6735 function Enclosing_Generic_Unit 6736 (N : Node_Id) return Node_Id 6737 is 6738 P : Node_Id; 6739 Decl : Node_Id; 6740 Spec : Node_Id; 6741 6742 begin 6743 P := Parent (N); 6744 while Present (P) loop 6745 if Nkind (P) = N_Generic_Package_Declaration 6746 or else Nkind (P) = N_Generic_Subprogram_Declaration 6747 then 6748 return P; 6749 6750 elsif Nkind (P) = N_Package_Body 6751 or else Nkind (P) = N_Subprogram_Body 6752 then 6753 Spec := Corresponding_Spec (P); 6754 6755 if Present (Spec) then 6756 Decl := Unit_Declaration_Node (Spec); 6757 6758 if Nkind (Decl) = N_Generic_Package_Declaration 6759 or else Nkind (Decl) = N_Generic_Subprogram_Declaration 6760 then 6761 return Decl; 6762 end if; 6763 end if; 6764 end if; 6765 6766 P := Parent (P); 6767 end loop; 6768 6769 return Empty; 6770 end Enclosing_Generic_Unit; 6771 6772 ------------------------------- 6773 -- Enclosing_Lib_Unit_Entity -- 6774 ------------------------------- 6775 6776 function Enclosing_Lib_Unit_Entity 6777 (E : Entity_Id := Current_Scope) return Entity_Id 6778 is 6779 Unit_Entity : Entity_Id; 6780 6781 begin 6782 -- Look for enclosing library unit entity by following scope links. 6783 -- Equivalent to, but faster than indexing through the scope stack. 6784 6785 Unit_Entity := E; 6786 while (Present (Scope (Unit_Entity)) 6787 and then Scope (Unit_Entity) /= Standard_Standard) 6788 and not Is_Child_Unit (Unit_Entity) 6789 loop 6790 Unit_Entity := Scope (Unit_Entity); 6791 end loop; 6792 6793 return Unit_Entity; 6794 end Enclosing_Lib_Unit_Entity; 6795 6796 ----------------------------- 6797 -- Enclosing_Lib_Unit_Node -- 6798 ----------------------------- 6799 6800 function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is 6801 Encl_Unit : Node_Id; 6802 6803 begin 6804 Encl_Unit := Enclosing_Comp_Unit_Node (N); 6805 while Present (Encl_Unit) 6806 and then Nkind (Unit (Encl_Unit)) = N_Subunit 6807 loop 6808 Encl_Unit := Library_Unit (Encl_Unit); 6809 end loop; 6810 6811 pragma Assert (Nkind (Encl_Unit) = N_Compilation_Unit); 6812 return Encl_Unit; 6813 end Enclosing_Lib_Unit_Node; 6814 6815 ----------------------- 6816 -- Enclosing_Package -- 6817 ----------------------- 6818 6819 function Enclosing_Package (E : Entity_Id) return Entity_Id is 6820 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E); 6821 6822 begin 6823 if Dynamic_Scope = Standard_Standard then 6824 return Standard_Standard; 6825 6826 elsif Dynamic_Scope = Empty then 6827 return Empty; 6828 6829 elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body, 6830 E_Generic_Package) 6831 then 6832 return Dynamic_Scope; 6833 6834 else 6835 return Enclosing_Package (Dynamic_Scope); 6836 end if; 6837 end Enclosing_Package; 6838 6839 ------------------------------------- 6840 -- Enclosing_Package_Or_Subprogram -- 6841 ------------------------------------- 6842 6843 function Enclosing_Package_Or_Subprogram (E : Entity_Id) return Entity_Id is 6844 S : Entity_Id; 6845 6846 begin 6847 S := Scope (E); 6848 while Present (S) loop 6849 if Is_Package_Or_Generic_Package (S) 6850 or else Ekind (S) = E_Package_Body 6851 then 6852 return S; 6853 6854 elsif Is_Subprogram_Or_Generic_Subprogram (S) 6855 or else Ekind (S) = E_Subprogram_Body 6856 then 6857 return S; 6858 6859 else 6860 S := Scope (S); 6861 end if; 6862 end loop; 6863 6864 return Empty; 6865 end Enclosing_Package_Or_Subprogram; 6866 6867 -------------------------- 6868 -- Enclosing_Subprogram -- 6869 -------------------------- 6870 6871 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is 6872 Dyn_Scop : constant Entity_Id := Enclosing_Dynamic_Scope (E); 6873 6874 begin 6875 if Dyn_Scop = Standard_Standard then 6876 return Empty; 6877 6878 elsif Dyn_Scop = Empty then 6879 return Empty; 6880 6881 elsif Ekind (Dyn_Scop) = E_Subprogram_Body then 6882 return Corresponding_Spec (Parent (Parent (Dyn_Scop))); 6883 6884 elsif Ekind_In (Dyn_Scop, E_Block, E_Return_Statement) then 6885 return Enclosing_Subprogram (Dyn_Scop); 6886 6887 elsif Ekind (Dyn_Scop) = E_Entry then 6888 6889 -- For a task entry, return the enclosing subprogram of the 6890 -- task itself. 6891 6892 if Ekind (Scope (Dyn_Scop)) = E_Task_Type then 6893 return Enclosing_Subprogram (Dyn_Scop); 6894 6895 -- A protected entry is rewritten as a protected procedure which is 6896 -- the desired enclosing subprogram. This is relevant when unnesting 6897 -- a procedure local to an entry body. 6898 6899 else 6900 return Protected_Body_Subprogram (Dyn_Scop); 6901 end if; 6902 6903 elsif Ekind (Dyn_Scop) = E_Task_Type then 6904 return Get_Task_Body_Procedure (Dyn_Scop); 6905 6906 -- The scope may appear as a private type or as a private extension 6907 -- whose completion is a task or protected type. 6908 6909 elsif Ekind_In (Dyn_Scop, E_Limited_Private_Type, 6910 E_Record_Type_With_Private) 6911 and then Present (Full_View (Dyn_Scop)) 6912 and then Ekind_In (Full_View (Dyn_Scop), E_Task_Type, E_Protected_Type) 6913 then 6914 return Get_Task_Body_Procedure (Full_View (Dyn_Scop)); 6915 6916 -- No body is generated if the protected operation is eliminated 6917 6918 elsif Convention (Dyn_Scop) = Convention_Protected 6919 and then not Is_Eliminated (Dyn_Scop) 6920 and then Present (Protected_Body_Subprogram (Dyn_Scop)) 6921 then 6922 return Protected_Body_Subprogram (Dyn_Scop); 6923 6924 else 6925 return Dyn_Scop; 6926 end if; 6927 end Enclosing_Subprogram; 6928 6929 -------------------------- 6930 -- End_Keyword_Location -- 6931 -------------------------- 6932 6933 function End_Keyword_Location (N : Node_Id) return Source_Ptr is 6934 function End_Label_Loc (Nod : Node_Id) return Source_Ptr; 6935 -- Return the source location of Nod's end label according to the 6936 -- following precedence rules: 6937 -- 6938 -- 1) If the end label exists, return its location 6939 -- 2) If Nod exists, return its location 6940 -- 3) Return the location of N 6941 6942 ------------------- 6943 -- End_Label_Loc -- 6944 ------------------- 6945 6946 function End_Label_Loc (Nod : Node_Id) return Source_Ptr is 6947 Label : Node_Id; 6948 6949 begin 6950 if Present (Nod) then 6951 Label := End_Label (Nod); 6952 6953 if Present (Label) then 6954 return Sloc (Label); 6955 else 6956 return Sloc (Nod); 6957 end if; 6958 6959 else 6960 return Sloc (N); 6961 end if; 6962 end End_Label_Loc; 6963 6964 -- Local variables 6965 6966 Owner : Node_Id; 6967 6968 -- Start of processing for End_Keyword_Location 6969 6970 begin 6971 if Nkind_In (N, N_Block_Statement, 6972 N_Entry_Body, 6973 N_Package_Body, 6974 N_Subprogram_Body, 6975 N_Task_Body) 6976 then 6977 Owner := Handled_Statement_Sequence (N); 6978 6979 elsif Nkind (N) = N_Package_Declaration then 6980 Owner := Specification (N); 6981 6982 elsif Nkind (N) = N_Protected_Body then 6983 Owner := N; 6984 6985 elsif Nkind_In (N, N_Protected_Type_Declaration, 6986 N_Single_Protected_Declaration) 6987 then 6988 Owner := Protected_Definition (N); 6989 6990 elsif Nkind_In (N, N_Single_Task_Declaration, 6991 N_Task_Type_Declaration) 6992 then 6993 Owner := Task_Definition (N); 6994 6995 -- This routine should not be called with other contexts 6996 6997 else 6998 pragma Assert (False); 6999 null; 7000 end if; 7001 7002 return End_Label_Loc (Owner); 7003 end End_Keyword_Location; 7004 7005 ------------------------ 7006 -- Ensure_Freeze_Node -- 7007 ------------------------ 7008 7009 procedure Ensure_Freeze_Node (E : Entity_Id) is 7010 FN : Node_Id; 7011 begin 7012 if No (Freeze_Node (E)) then 7013 FN := Make_Freeze_Entity (Sloc (E)); 7014 Set_Has_Delayed_Freeze (E); 7015 Set_Freeze_Node (E, FN); 7016 Set_Access_Types_To_Process (FN, No_Elist); 7017 Set_TSS_Elist (FN, No_Elist); 7018 Set_Entity (FN, E); 7019 end if; 7020 end Ensure_Freeze_Node; 7021 7022 ---------------- 7023 -- Enter_Name -- 7024 ---------------- 7025 7026 procedure Enter_Name (Def_Id : Entity_Id) is 7027 C : constant Entity_Id := Current_Entity (Def_Id); 7028 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); 7029 S : constant Entity_Id := Current_Scope; 7030 7031 begin 7032 Generate_Definition (Def_Id); 7033 7034 -- Add new name to current scope declarations. Check for duplicate 7035 -- declaration, which may or may not be a genuine error. 7036 7037 if Present (E) then 7038 7039 -- Case of previous entity entered because of a missing declaration 7040 -- or else a bad subtype indication. Best is to use the new entity, 7041 -- and make the previous one invisible. 7042 7043 if Etype (E) = Any_Type then 7044 Set_Is_Immediately_Visible (E, False); 7045 7046 -- Case of renaming declaration constructed for package instances. 7047 -- if there is an explicit declaration with the same identifier, 7048 -- the renaming is not immediately visible any longer, but remains 7049 -- visible through selected component notation. 7050 7051 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration 7052 and then not Comes_From_Source (E) 7053 then 7054 Set_Is_Immediately_Visible (E, False); 7055 7056 -- The new entity may be the package renaming, which has the same 7057 -- same name as a generic formal which has been seen already. 7058 7059 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration 7060 and then not Comes_From_Source (Def_Id) 7061 then 7062 Set_Is_Immediately_Visible (E, False); 7063 7064 -- For a fat pointer corresponding to a remote access to subprogram, 7065 -- we use the same identifier as the RAS type, so that the proper 7066 -- name appears in the stub. This type is only retrieved through 7067 -- the RAS type and never by visibility, and is not added to the 7068 -- visibility list (see below). 7069 7070 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration 7071 and then Ekind (Def_Id) = E_Record_Type 7072 and then Present (Corresponding_Remote_Type (Def_Id)) 7073 then 7074 null; 7075 7076 -- Case of an implicit operation or derived literal. The new entity 7077 -- hides the implicit one, which is removed from all visibility, 7078 -- i.e. the entity list of its scope, and homonym chain of its name. 7079 7080 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E)) 7081 or else Is_Internal (E) 7082 then 7083 declare 7084 Decl : constant Node_Id := Parent (E); 7085 Prev : Entity_Id; 7086 Prev_Vis : Entity_Id; 7087 7088 begin 7089 -- If E is an implicit declaration, it cannot be the first 7090 -- entity in the scope. 7091 7092 Prev := First_Entity (Current_Scope); 7093 while Present (Prev) and then Next_Entity (Prev) /= E loop 7094 Next_Entity (Prev); 7095 end loop; 7096 7097 if No (Prev) then 7098 7099 -- If E is not on the entity chain of the current scope, 7100 -- it is an implicit declaration in the generic formal 7101 -- part of a generic subprogram. When analyzing the body, 7102 -- the generic formals are visible but not on the entity 7103 -- chain of the subprogram. The new entity will become 7104 -- the visible one in the body. 7105 7106 pragma Assert 7107 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration); 7108 null; 7109 7110 else 7111 Link_Entities (Prev, Next_Entity (E)); 7112 7113 if No (Next_Entity (Prev)) then 7114 Set_Last_Entity (Current_Scope, Prev); 7115 end if; 7116 7117 if E = Current_Entity (E) then 7118 Prev_Vis := Empty; 7119 7120 else 7121 Prev_Vis := Current_Entity (E); 7122 while Homonym (Prev_Vis) /= E loop 7123 Prev_Vis := Homonym (Prev_Vis); 7124 end loop; 7125 end if; 7126 7127 if Present (Prev_Vis) then 7128 7129 -- Skip E in the visibility chain 7130 7131 Set_Homonym (Prev_Vis, Homonym (E)); 7132 7133 else 7134 Set_Name_Entity_Id (Chars (E), Homonym (E)); 7135 end if; 7136 end if; 7137 end; 7138 7139 -- This section of code could use a comment ??? 7140 7141 elsif Present (Etype (E)) 7142 and then Is_Concurrent_Type (Etype (E)) 7143 and then E = Def_Id 7144 then 7145 return; 7146 7147 -- If the homograph is a protected component renaming, it should not 7148 -- be hiding the current entity. Such renamings are treated as weak 7149 -- declarations. 7150 7151 elsif Is_Prival (E) then 7152 Set_Is_Immediately_Visible (E, False); 7153 7154 -- In this case the current entity is a protected component renaming. 7155 -- Perform minimal decoration by setting the scope and return since 7156 -- the prival should not be hiding other visible entities. 7157 7158 elsif Is_Prival (Def_Id) then 7159 Set_Scope (Def_Id, Current_Scope); 7160 return; 7161 7162 -- Analogous to privals, the discriminal generated for an entry index 7163 -- parameter acts as a weak declaration. Perform minimal decoration 7164 -- to avoid bogus errors. 7165 7166 elsif Is_Discriminal (Def_Id) 7167 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter 7168 then 7169 Set_Scope (Def_Id, Current_Scope); 7170 return; 7171 7172 -- In the body or private part of an instance, a type extension may 7173 -- introduce a component with the same name as that of an actual. The 7174 -- legality rule is not enforced, but the semantics of the full type 7175 -- with two components of same name are not clear at this point??? 7176 7177 elsif In_Instance_Not_Visible then 7178 null; 7179 7180 -- When compiling a package body, some child units may have become 7181 -- visible. They cannot conflict with local entities that hide them. 7182 7183 elsif Is_Child_Unit (E) 7184 and then In_Open_Scopes (Scope (E)) 7185 and then not Is_Immediately_Visible (E) 7186 then 7187 null; 7188 7189 -- Conversely, with front-end inlining we may compile the parent body 7190 -- first, and a child unit subsequently. The context is now the 7191 -- parent spec, and body entities are not visible. 7192 7193 elsif Is_Child_Unit (Def_Id) 7194 and then Is_Package_Body_Entity (E) 7195 and then not In_Package_Body (Current_Scope) 7196 then 7197 null; 7198 7199 -- Case of genuine duplicate declaration 7200 7201 else 7202 Error_Msg_Sloc := Sloc (E); 7203 7204 -- If the previous declaration is an incomplete type declaration 7205 -- this may be an attempt to complete it with a private type. The 7206 -- following avoids confusing cascaded errors. 7207 7208 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration 7209 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration 7210 then 7211 Error_Msg_N 7212 ("incomplete type cannot be completed with a private " & 7213 "declaration", Parent (Def_Id)); 7214 Set_Is_Immediately_Visible (E, False); 7215 Set_Full_View (E, Def_Id); 7216 7217 -- An inherited component of a record conflicts with a new 7218 -- discriminant. The discriminant is inserted first in the scope, 7219 -- but the error should be posted on it, not on the component. 7220 7221 elsif Ekind (E) = E_Discriminant 7222 and then Present (Scope (Def_Id)) 7223 and then Scope (Def_Id) /= Current_Scope 7224 then 7225 Error_Msg_Sloc := Sloc (Def_Id); 7226 Error_Msg_N ("& conflicts with declaration#", E); 7227 return; 7228 7229 -- If the name of the unit appears in its own context clause, a 7230 -- dummy package with the name has already been created, and the 7231 -- error emitted. Try to continue quietly. 7232 7233 elsif Error_Posted (E) 7234 and then Sloc (E) = No_Location 7235 and then Nkind (Parent (E)) = N_Package_Specification 7236 and then Current_Scope = Standard_Standard 7237 then 7238 Set_Scope (Def_Id, Current_Scope); 7239 return; 7240 7241 else 7242 Error_Msg_N ("& conflicts with declaration#", Def_Id); 7243 7244 -- Avoid cascaded messages with duplicate components in 7245 -- derived types. 7246 7247 if Ekind_In (E, E_Component, E_Discriminant) then 7248 return; 7249 end if; 7250 end if; 7251 7252 if Nkind (Parent (Parent (Def_Id))) = 7253 N_Generic_Subprogram_Declaration 7254 and then Def_Id = 7255 Defining_Entity (Specification (Parent (Parent (Def_Id)))) 7256 then 7257 Error_Msg_N ("\generic units cannot be overloaded", Def_Id); 7258 end if; 7259 7260 -- If entity is in standard, then we are in trouble, because it 7261 -- means that we have a library package with a duplicated name. 7262 -- That's hard to recover from, so abort. 7263 7264 if S = Standard_Standard then 7265 raise Unrecoverable_Error; 7266 7267 -- Otherwise we continue with the declaration. Having two 7268 -- identical declarations should not cause us too much trouble. 7269 7270 else 7271 null; 7272 end if; 7273 end if; 7274 end if; 7275 7276 -- If we fall through, declaration is OK, at least OK enough to continue 7277 7278 -- If Def_Id is a discriminant or a record component we are in the midst 7279 -- of inheriting components in a derived record definition. Preserve 7280 -- their Ekind and Etype. 7281 7282 if Ekind_In (Def_Id, E_Discriminant, E_Component) then 7283 null; 7284 7285 -- If a type is already set, leave it alone (happens when a type 7286 -- declaration is reanalyzed following a call to the optimizer). 7287 7288 elsif Present (Etype (Def_Id)) then 7289 null; 7290 7291 -- Otherwise, the kind E_Void insures that premature uses of the entity 7292 -- will be detected. Any_Type insures that no cascaded errors will occur 7293 7294 else 7295 Set_Ekind (Def_Id, E_Void); 7296 Set_Etype (Def_Id, Any_Type); 7297 end if; 7298 7299 -- Inherited discriminants and components in derived record types are 7300 -- immediately visible. Itypes are not. 7301 7302 -- Unless the Itype is for a record type with a corresponding remote 7303 -- type (what is that about, it was not commented ???) 7304 7305 if Ekind_In (Def_Id, E_Discriminant, E_Component) 7306 or else 7307 ((not Is_Record_Type (Def_Id) 7308 or else No (Corresponding_Remote_Type (Def_Id))) 7309 and then not Is_Itype (Def_Id)) 7310 then 7311 Set_Is_Immediately_Visible (Def_Id); 7312 Set_Current_Entity (Def_Id); 7313 end if; 7314 7315 Set_Homonym (Def_Id, C); 7316 Append_Entity (Def_Id, S); 7317 Set_Public_Status (Def_Id); 7318 7319 -- Declaring a homonym is not allowed in SPARK ... 7320 7321 if Present (C) and then Restriction_Check_Required (SPARK_05) then 7322 declare 7323 Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id); 7324 Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id); 7325 Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C); 7326 7327 begin 7328 -- ... unless the new declaration is in a subprogram, and the 7329 -- visible declaration is a variable declaration or a parameter 7330 -- specification outside that subprogram. 7331 7332 if Present (Enclosing_Subp) 7333 and then Nkind_In (Parent (C), N_Object_Declaration, 7334 N_Parameter_Specification) 7335 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp) 7336 then 7337 null; 7338 7339 -- ... or the new declaration is in a package, and the visible 7340 -- declaration occurs outside that package. 7341 7342 elsif Present (Enclosing_Pack) 7343 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack) 7344 then 7345 null; 7346 7347 -- ... or the new declaration is a component declaration in a 7348 -- record type definition. 7349 7350 elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then 7351 null; 7352 7353 -- Don't issue error for non-source entities 7354 7355 elsif Comes_From_Source (Def_Id) 7356 and then Comes_From_Source (C) 7357 then 7358 Error_Msg_Sloc := Sloc (C); 7359 Check_SPARK_05_Restriction 7360 ("redeclaration of identifier &#", Def_Id); 7361 end if; 7362 end; 7363 end if; 7364 7365 -- Warn if new entity hides an old one 7366 7367 if Warn_On_Hiding and then Present (C) 7368 7369 -- Don't warn for record components since they always have a well 7370 -- defined scope which does not confuse other uses. Note that in 7371 -- some cases, Ekind has not been set yet. 7372 7373 and then Ekind (C) /= E_Component 7374 and then Ekind (C) /= E_Discriminant 7375 and then Nkind (Parent (C)) /= N_Component_Declaration 7376 and then Ekind (Def_Id) /= E_Component 7377 and then Ekind (Def_Id) /= E_Discriminant 7378 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration 7379 7380 -- Don't warn for one character variables. It is too common to use 7381 -- such variables as locals and will just cause too many false hits. 7382 7383 and then Length_Of_Name (Chars (C)) /= 1 7384 7385 -- Don't warn for non-source entities 7386 7387 and then Comes_From_Source (C) 7388 and then Comes_From_Source (Def_Id) 7389 7390 -- Don't warn unless entity in question is in extended main source 7391 7392 and then In_Extended_Main_Source_Unit (Def_Id) 7393 7394 -- Finally, the hidden entity must be either immediately visible or 7395 -- use visible (i.e. from a used package). 7396 7397 and then 7398 (Is_Immediately_Visible (C) 7399 or else 7400 Is_Potentially_Use_Visible (C)) 7401 then 7402 Error_Msg_Sloc := Sloc (C); 7403 Error_Msg_N ("declaration hides &#?h?", Def_Id); 7404 end if; 7405 end Enter_Name; 7406 7407 --------------- 7408 -- Entity_Of -- 7409 --------------- 7410 7411 function Entity_Of (N : Node_Id) return Entity_Id is 7412 Id : Entity_Id; 7413 Ren : Node_Id; 7414 7415 begin 7416 -- Assume that the arbitrary node does not have an entity 7417 7418 Id := Empty; 7419 7420 if Is_Entity_Name (N) then 7421 Id := Entity (N); 7422 7423 -- Follow a possible chain of renamings to reach the earliest renamed 7424 -- source object. 7425 7426 while Present (Id) 7427 and then Is_Object (Id) 7428 and then Present (Renamed_Object (Id)) 7429 loop 7430 Ren := Renamed_Object (Id); 7431 7432 -- The reference renames an abstract state or a whole object 7433 7434 -- Obj : ...; 7435 -- Ren : ... renames Obj; 7436 7437 if Is_Entity_Name (Ren) then 7438 7439 -- Do not follow a renaming that goes through a generic formal, 7440 -- because these entities are hidden and must not be referenced 7441 -- from outside the generic. 7442 7443 if Is_Hidden (Entity (Ren)) then 7444 exit; 7445 7446 else 7447 Id := Entity (Ren); 7448 end if; 7449 7450 -- The reference renames a function result. Check the original 7451 -- node in case expansion relocates the function call. 7452 7453 -- Ren : ... renames Func_Call; 7454 7455 elsif Nkind (Original_Node (Ren)) = N_Function_Call then 7456 exit; 7457 7458 -- Otherwise the reference renames something which does not yield 7459 -- an abstract state or a whole object. Treat the reference as not 7460 -- having a proper entity for SPARK legality purposes. 7461 7462 else 7463 Id := Empty; 7464 exit; 7465 end if; 7466 end loop; 7467 end if; 7468 7469 return Id; 7470 end Entity_Of; 7471 7472 -------------------------- 7473 -- Examine_Array_Bounds -- 7474 -------------------------- 7475 7476 procedure Examine_Array_Bounds 7477 (Typ : Entity_Id; 7478 All_Static : out Boolean; 7479 Has_Empty : out Boolean) 7480 is 7481 function Is_OK_Static_Bound (Bound : Node_Id) return Boolean; 7482 -- Determine whether bound Bound is a suitable static bound 7483 7484 ------------------------ 7485 -- Is_OK_Static_Bound -- 7486 ------------------------ 7487 7488 function Is_OK_Static_Bound (Bound : Node_Id) return Boolean is 7489 begin 7490 return 7491 not Error_Posted (Bound) 7492 and then Is_OK_Static_Expression (Bound); 7493 end Is_OK_Static_Bound; 7494 7495 -- Local variables 7496 7497 Hi_Bound : Node_Id; 7498 Index : Node_Id; 7499 Lo_Bound : Node_Id; 7500 7501 -- Start of processing for Examine_Array_Bounds 7502 7503 begin 7504 -- An unconstrained array type does not have static bounds, and it is 7505 -- not known whether they are empty or not. 7506 7507 if not Is_Constrained (Typ) then 7508 All_Static := False; 7509 Has_Empty := False; 7510 7511 -- A string literal has static bounds, and is not empty as long as it 7512 -- contains at least one character. 7513 7514 elsif Ekind (Typ) = E_String_Literal_Subtype then 7515 All_Static := True; 7516 Has_Empty := String_Literal_Length (Typ) > 0; 7517 end if; 7518 7519 -- Assume that all bounds are static and not empty 7520 7521 All_Static := True; 7522 Has_Empty := False; 7523 7524 -- Examine each index 7525 7526 Index := First_Index (Typ); 7527 while Present (Index) loop 7528 if Is_Discrete_Type (Etype (Index)) then 7529 Get_Index_Bounds (Index, Lo_Bound, Hi_Bound); 7530 7531 if Is_OK_Static_Bound (Lo_Bound) 7532 and then 7533 Is_OK_Static_Bound (Hi_Bound) 7534 then 7535 -- The static bounds produce an empty range 7536 7537 if Is_Null_Range (Lo_Bound, Hi_Bound) then 7538 Has_Empty := True; 7539 end if; 7540 7541 -- Otherwise at least one of the bounds is not static 7542 7543 else 7544 All_Static := False; 7545 end if; 7546 7547 -- Otherwise the index is non-discrete, therefore not static 7548 7549 else 7550 All_Static := False; 7551 end if; 7552 7553 Next_Index (Index); 7554 end loop; 7555 end Examine_Array_Bounds; 7556 7557 -------------------------- 7558 -- Explain_Limited_Type -- 7559 -------------------------- 7560 7561 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is 7562 C : Entity_Id; 7563 7564 begin 7565 -- For array, component type must be limited 7566 7567 if Is_Array_Type (T) then 7568 Error_Msg_Node_2 := T; 7569 Error_Msg_NE 7570 ("\component type& of type& is limited", N, Component_Type (T)); 7571 Explain_Limited_Type (Component_Type (T), N); 7572 7573 elsif Is_Record_Type (T) then 7574 7575 -- No need for extra messages if explicit limited record 7576 7577 if Is_Limited_Record (Base_Type (T)) then 7578 return; 7579 end if; 7580 7581 -- Otherwise find a limited component. Check only components that 7582 -- come from source, or inherited components that appear in the 7583 -- source of the ancestor. 7584 7585 C := First_Component (T); 7586 while Present (C) loop 7587 if Is_Limited_Type (Etype (C)) 7588 and then 7589 (Comes_From_Source (C) 7590 or else 7591 (Present (Original_Record_Component (C)) 7592 and then 7593 Comes_From_Source (Original_Record_Component (C)))) 7594 then 7595 Error_Msg_Node_2 := T; 7596 Error_Msg_NE ("\component& of type& has limited type", N, C); 7597 Explain_Limited_Type (Etype (C), N); 7598 return; 7599 end if; 7600 7601 Next_Component (C); 7602 end loop; 7603 7604 -- The type may be declared explicitly limited, even if no component 7605 -- of it is limited, in which case we fall out of the loop. 7606 return; 7607 end if; 7608 end Explain_Limited_Type; 7609 7610 --------------------------------------- 7611 -- Expression_Of_Expression_Function -- 7612 --------------------------------------- 7613 7614 function Expression_Of_Expression_Function 7615 (Subp : Entity_Id) return Node_Id 7616 is 7617 Expr_Func : Node_Id; 7618 7619 begin 7620 pragma Assert (Is_Expression_Function_Or_Completion (Subp)); 7621 7622 if Nkind (Original_Node (Subprogram_Spec (Subp))) = 7623 N_Expression_Function 7624 then 7625 Expr_Func := Original_Node (Subprogram_Spec (Subp)); 7626 7627 elsif Nkind (Original_Node (Subprogram_Body (Subp))) = 7628 N_Expression_Function 7629 then 7630 Expr_Func := Original_Node (Subprogram_Body (Subp)); 7631 7632 else 7633 pragma Assert (False); 7634 null; 7635 end if; 7636 7637 return Original_Node (Expression (Expr_Func)); 7638 end Expression_Of_Expression_Function; 7639 7640 ------------------------------- 7641 -- Extensions_Visible_Status -- 7642 ------------------------------- 7643 7644 function Extensions_Visible_Status 7645 (Id : Entity_Id) return Extensions_Visible_Mode 7646 is 7647 Arg : Node_Id; 7648 Decl : Node_Id; 7649 Expr : Node_Id; 7650 Prag : Node_Id; 7651 Subp : Entity_Id; 7652 7653 begin 7654 -- When a formal parameter is subject to Extensions_Visible, the pragma 7655 -- is stored in the contract of related subprogram. 7656 7657 if Is_Formal (Id) then 7658 Subp := Scope (Id); 7659 7660 elsif Is_Subprogram_Or_Generic_Subprogram (Id) then 7661 Subp := Id; 7662 7663 -- No other construct carries this pragma 7664 7665 else 7666 return Extensions_Visible_None; 7667 end if; 7668 7669 Prag := Get_Pragma (Subp, Pragma_Extensions_Visible); 7670 7671 -- In certain cases analysis may request the Extensions_Visible status 7672 -- of an expression function before the pragma has been analyzed yet. 7673 -- Inspect the declarative items after the expression function looking 7674 -- for the pragma (if any). 7675 7676 if No (Prag) and then Is_Expression_Function (Subp) then 7677 Decl := Next (Unit_Declaration_Node (Subp)); 7678 while Present (Decl) loop 7679 if Nkind (Decl) = N_Pragma 7680 and then Pragma_Name (Decl) = Name_Extensions_Visible 7681 then 7682 Prag := Decl; 7683 exit; 7684 7685 -- A source construct ends the region where Extensions_Visible may 7686 -- appear, stop the traversal. An expanded expression function is 7687 -- no longer a source construct, but it must still be recognized. 7688 7689 elsif Comes_From_Source (Decl) 7690 or else 7691 (Nkind_In (Decl, N_Subprogram_Body, 7692 N_Subprogram_Declaration) 7693 and then Is_Expression_Function (Defining_Entity (Decl))) 7694 then 7695 exit; 7696 end if; 7697 7698 Next (Decl); 7699 end loop; 7700 end if; 7701 7702 -- Extract the value from the Boolean expression (if any) 7703 7704 if Present (Prag) then 7705 Arg := First (Pragma_Argument_Associations (Prag)); 7706 7707 if Present (Arg) then 7708 Expr := Get_Pragma_Arg (Arg); 7709 7710 -- When the associated subprogram is an expression function, the 7711 -- argument of the pragma may not have been analyzed. 7712 7713 if not Analyzed (Expr) then 7714 Preanalyze_And_Resolve (Expr, Standard_Boolean); 7715 end if; 7716 7717 -- Guard against cascading errors when the argument of pragma 7718 -- Extensions_Visible is not a valid static Boolean expression. 7719 7720 if Error_Posted (Expr) then 7721 return Extensions_Visible_None; 7722 7723 elsif Is_True (Expr_Value (Expr)) then 7724 return Extensions_Visible_True; 7725 7726 else 7727 return Extensions_Visible_False; 7728 end if; 7729 7730 -- Otherwise the aspect or pragma defaults to True 7731 7732 else 7733 return Extensions_Visible_True; 7734 end if; 7735 7736 -- Otherwise aspect or pragma Extensions_Visible is not inherited or 7737 -- directly specified. In SPARK code, its value defaults to "False". 7738 7739 elsif SPARK_Mode = On then 7740 return Extensions_Visible_False; 7741 7742 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to 7743 -- "True". 7744 7745 else 7746 return Extensions_Visible_True; 7747 end if; 7748 end Extensions_Visible_Status; 7749 7750 ----------------- 7751 -- Find_Actual -- 7752 ----------------- 7753 7754 procedure Find_Actual 7755 (N : Node_Id; 7756 Formal : out Entity_Id; 7757 Call : out Node_Id) 7758 is 7759 Context : constant Node_Id := Parent (N); 7760 Actual : Node_Id; 7761 Call_Nam : Node_Id; 7762 7763 begin 7764 if Nkind_In (Context, N_Indexed_Component, N_Selected_Component) 7765 and then N = Prefix (Context) 7766 then 7767 Find_Actual (Context, Formal, Call); 7768 return; 7769 7770 elsif Nkind (Context) = N_Parameter_Association 7771 and then N = Explicit_Actual_Parameter (Context) 7772 then 7773 Call := Parent (Context); 7774 7775 elsif Nkind_In (Context, N_Entry_Call_Statement, 7776 N_Function_Call, 7777 N_Procedure_Call_Statement) 7778 then 7779 Call := Context; 7780 7781 else 7782 Formal := Empty; 7783 Call := Empty; 7784 return; 7785 end if; 7786 7787 -- If we have a call to a subprogram look for the parameter. Note that 7788 -- we exclude overloaded calls, since we don't know enough to be sure 7789 -- of giving the right answer in this case. 7790 7791 if Nkind_In (Call, N_Entry_Call_Statement, 7792 N_Function_Call, 7793 N_Procedure_Call_Statement) 7794 then 7795 Call_Nam := Name (Call); 7796 7797 -- A call to a protected or task entry appears as a selected 7798 -- component rather than an expanded name. 7799 7800 if Nkind (Call_Nam) = N_Selected_Component then 7801 Call_Nam := Selector_Name (Call_Nam); 7802 end if; 7803 7804 if Is_Entity_Name (Call_Nam) 7805 and then Present (Entity (Call_Nam)) 7806 and then Is_Overloadable (Entity (Call_Nam)) 7807 and then not Is_Overloaded (Call_Nam) 7808 then 7809 -- If node is name in call it is not an actual 7810 7811 if N = Call_Nam then 7812 Formal := Empty; 7813 Call := Empty; 7814 return; 7815 end if; 7816 7817 -- Fall here if we are definitely a parameter 7818 7819 Actual := First_Actual (Call); 7820 Formal := First_Formal (Entity (Call_Nam)); 7821 while Present (Formal) and then Present (Actual) loop 7822 if Actual = N then 7823 return; 7824 7825 -- An actual that is the prefix in a prefixed call may have 7826 -- been rewritten in the call, after the deferred reference 7827 -- was collected. Check if sloc and kinds and names match. 7828 7829 elsif Sloc (Actual) = Sloc (N) 7830 and then Nkind (Actual) = N_Identifier 7831 and then Nkind (Actual) = Nkind (N) 7832 and then Chars (Actual) = Chars (N) 7833 then 7834 return; 7835 7836 else 7837 Actual := Next_Actual (Actual); 7838 Formal := Next_Formal (Formal); 7839 end if; 7840 end loop; 7841 end if; 7842 end if; 7843 7844 -- Fall through here if we did not find matching actual 7845 7846 Formal := Empty; 7847 Call := Empty; 7848 end Find_Actual; 7849 7850 --------------------------- 7851 -- Find_Body_Discriminal -- 7852 --------------------------- 7853 7854 function Find_Body_Discriminal 7855 (Spec_Discriminant : Entity_Id) return Entity_Id 7856 is 7857 Tsk : Entity_Id; 7858 Disc : Entity_Id; 7859 7860 begin 7861 -- If expansion is suppressed, then the scope can be the concurrent type 7862 -- itself rather than a corresponding concurrent record type. 7863 7864 if Is_Concurrent_Type (Scope (Spec_Discriminant)) then 7865 Tsk := Scope (Spec_Discriminant); 7866 7867 else 7868 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant))); 7869 7870 Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant)); 7871 end if; 7872 7873 -- Find discriminant of original concurrent type, and use its current 7874 -- discriminal, which is the renaming within the task/protected body. 7875 7876 Disc := First_Discriminant (Tsk); 7877 while Present (Disc) loop 7878 if Chars (Disc) = Chars (Spec_Discriminant) then 7879 return Discriminal (Disc); 7880 end if; 7881 7882 Next_Discriminant (Disc); 7883 end loop; 7884 7885 -- That loop should always succeed in finding a matching entry and 7886 -- returning. Fatal error if not. 7887 7888 raise Program_Error; 7889 end Find_Body_Discriminal; 7890 7891 ------------------------------------- 7892 -- Find_Corresponding_Discriminant -- 7893 ------------------------------------- 7894 7895 function Find_Corresponding_Discriminant 7896 (Id : Node_Id; 7897 Typ : Entity_Id) return Entity_Id 7898 is 7899 Par_Disc : Entity_Id; 7900 Old_Disc : Entity_Id; 7901 New_Disc : Entity_Id; 7902 7903 begin 7904 Par_Disc := Original_Record_Component (Original_Discriminant (Id)); 7905 7906 -- The original type may currently be private, and the discriminant 7907 -- only appear on its full view. 7908 7909 if Is_Private_Type (Scope (Par_Disc)) 7910 and then not Has_Discriminants (Scope (Par_Disc)) 7911 and then Present (Full_View (Scope (Par_Disc))) 7912 then 7913 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc))); 7914 else 7915 Old_Disc := First_Discriminant (Scope (Par_Disc)); 7916 end if; 7917 7918 if Is_Class_Wide_Type (Typ) then 7919 New_Disc := First_Discriminant (Root_Type (Typ)); 7920 else 7921 New_Disc := First_Discriminant (Typ); 7922 end if; 7923 7924 while Present (Old_Disc) and then Present (New_Disc) loop 7925 if Old_Disc = Par_Disc then 7926 return New_Disc; 7927 end if; 7928 7929 Next_Discriminant (Old_Disc); 7930 Next_Discriminant (New_Disc); 7931 end loop; 7932 7933 -- Should always find it 7934 7935 raise Program_Error; 7936 end Find_Corresponding_Discriminant; 7937 7938 ------------------- 7939 -- Find_DIC_Type -- 7940 ------------------- 7941 7942 function Find_DIC_Type (Typ : Entity_Id) return Entity_Id is 7943 Curr_Typ : Entity_Id; 7944 -- The current type being examined in the parent hierarchy traversal 7945 7946 DIC_Typ : Entity_Id; 7947 -- The type which carries the DIC pragma. This variable denotes the 7948 -- partial view when private types are involved. 7949 7950 Par_Typ : Entity_Id; 7951 -- The parent type of the current type. This variable denotes the full 7952 -- view when private types are involved. 7953 7954 begin 7955 -- The input type defines its own DIC pragma, therefore it is the owner 7956 7957 if Has_Own_DIC (Typ) then 7958 DIC_Typ := Typ; 7959 7960 -- Otherwise the DIC pragma is inherited from a parent type 7961 7962 else 7963 pragma Assert (Has_Inherited_DIC (Typ)); 7964 7965 -- Climb the parent chain 7966 7967 Curr_Typ := Typ; 7968 loop 7969 -- Inspect the parent type. Do not consider subtypes as they 7970 -- inherit the DIC attributes from their base types. 7971 7972 DIC_Typ := Base_Type (Etype (Curr_Typ)); 7973 7974 -- Look at the full view of a private type because the type may 7975 -- have a hidden parent introduced in the full view. 7976 7977 Par_Typ := DIC_Typ; 7978 7979 if Is_Private_Type (Par_Typ) 7980 and then Present (Full_View (Par_Typ)) 7981 then 7982 Par_Typ := Full_View (Par_Typ); 7983 end if; 7984 7985 -- Stop the climb once the nearest parent type which defines a DIC 7986 -- pragma of its own is encountered or when the root of the parent 7987 -- chain is reached. 7988 7989 exit when Has_Own_DIC (DIC_Typ) or else Curr_Typ = Par_Typ; 7990 7991 Curr_Typ := Par_Typ; 7992 end loop; 7993 end if; 7994 7995 return DIC_Typ; 7996 end Find_DIC_Type; 7997 7998 ---------------------------------- 7999 -- Find_Enclosing_Iterator_Loop -- 8000 ---------------------------------- 8001 8002 function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id is 8003 Constr : Node_Id; 8004 S : Entity_Id; 8005 8006 begin 8007 -- Traverse the scope chain looking for an iterator loop. Such loops are 8008 -- usually transformed into blocks, hence the use of Original_Node. 8009 8010 S := Id; 8011 while Present (S) and then S /= Standard_Standard loop 8012 if Ekind (S) = E_Loop 8013 and then Nkind (Parent (S)) = N_Implicit_Label_Declaration 8014 then 8015 Constr := Original_Node (Label_Construct (Parent (S))); 8016 8017 if Nkind (Constr) = N_Loop_Statement 8018 and then Present (Iteration_Scheme (Constr)) 8019 and then Nkind (Iterator_Specification 8020 (Iteration_Scheme (Constr))) = 8021 N_Iterator_Specification 8022 then 8023 return S; 8024 end if; 8025 end if; 8026 8027 S := Scope (S); 8028 end loop; 8029 8030 return Empty; 8031 end Find_Enclosing_Iterator_Loop; 8032 8033 -------------------------- 8034 -- Find_Enclosing_Scope -- 8035 -------------------------- 8036 8037 function Find_Enclosing_Scope (N : Node_Id) return Entity_Id is 8038 Par : Node_Id; 8039 8040 begin 8041 -- Examine the parent chain looking for a construct which defines a 8042 -- scope. 8043 8044 Par := Parent (N); 8045 while Present (Par) loop 8046 case Nkind (Par) is 8047 8048 -- The construct denotes a declaration, the proper scope is its 8049 -- entity. 8050 8051 when N_Entry_Declaration 8052 | N_Expression_Function 8053 | N_Full_Type_Declaration 8054 | N_Generic_Package_Declaration 8055 | N_Generic_Subprogram_Declaration 8056 | N_Package_Declaration 8057 | N_Private_Extension_Declaration 8058 | N_Protected_Type_Declaration 8059 | N_Single_Protected_Declaration 8060 | N_Single_Task_Declaration 8061 | N_Subprogram_Declaration 8062 | N_Task_Type_Declaration 8063 => 8064 return Defining_Entity (Par); 8065 8066 -- The construct denotes a body, the proper scope is the entity of 8067 -- the corresponding spec or that of the body if the body does not 8068 -- complete a previous declaration. 8069 8070 when N_Entry_Body 8071 | N_Package_Body 8072 | N_Protected_Body 8073 | N_Subprogram_Body 8074 | N_Task_Body 8075 => 8076 return Unique_Defining_Entity (Par); 8077 8078 -- Special cases 8079 8080 -- Blocks carry either a source or an internally-generated scope, 8081 -- unless the block is a byproduct of exception handling. 8082 8083 when N_Block_Statement => 8084 if not Exception_Junk (Par) then 8085 return Entity (Identifier (Par)); 8086 end if; 8087 8088 -- Loops carry an internally-generated scope 8089 8090 when N_Loop_Statement => 8091 return Entity (Identifier (Par)); 8092 8093 -- Extended return statements carry an internally-generated scope 8094 8095 when N_Extended_Return_Statement => 8096 return Return_Statement_Entity (Par); 8097 8098 -- A traversal from a subunit continues via the corresponding stub 8099 8100 when N_Subunit => 8101 Par := Corresponding_Stub (Par); 8102 8103 when others => 8104 null; 8105 end case; 8106 8107 Par := Parent (Par); 8108 end loop; 8109 8110 return Standard_Standard; 8111 end Find_Enclosing_Scope; 8112 8113 ------------------------------------ 8114 -- Find_Loop_In_Conditional_Block -- 8115 ------------------------------------ 8116 8117 function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is 8118 Stmt : Node_Id; 8119 8120 begin 8121 Stmt := N; 8122 8123 if Nkind (Stmt) = N_If_Statement then 8124 Stmt := First (Then_Statements (Stmt)); 8125 end if; 8126 8127 pragma Assert (Nkind (Stmt) = N_Block_Statement); 8128 8129 -- Inspect the statements of the conditional block. In general the loop 8130 -- should be the first statement in the statement sequence of the block, 8131 -- but the finalization machinery may have introduced extra object 8132 -- declarations. 8133 8134 Stmt := First (Statements (Handled_Statement_Sequence (Stmt))); 8135 while Present (Stmt) loop 8136 if Nkind (Stmt) = N_Loop_Statement then 8137 return Stmt; 8138 end if; 8139 8140 Next (Stmt); 8141 end loop; 8142 8143 -- The expansion of attribute 'Loop_Entry produced a malformed block 8144 8145 raise Program_Error; 8146 end Find_Loop_In_Conditional_Block; 8147 8148 -------------------------- 8149 -- Find_Overlaid_Entity -- 8150 -------------------------- 8151 8152 procedure Find_Overlaid_Entity 8153 (N : Node_Id; 8154 Ent : out Entity_Id; 8155 Off : out Boolean) 8156 is 8157 Expr : Node_Id; 8158 8159 begin 8160 -- We are looking for one of the two following forms: 8161 8162 -- for X'Address use Y'Address 8163 8164 -- or 8165 8166 -- Const : constant Address := expr; 8167 -- ... 8168 -- for X'Address use Const; 8169 8170 -- In the second case, the expr is either Y'Address, or recursively a 8171 -- constant that eventually references Y'Address. 8172 8173 Ent := Empty; 8174 Off := False; 8175 8176 if Nkind (N) = N_Attribute_Definition_Clause 8177 and then Chars (N) = Name_Address 8178 then 8179 Expr := Expression (N); 8180 8181 -- This loop checks the form of the expression for Y'Address, 8182 -- using recursion to deal with intermediate constants. 8183 8184 loop 8185 -- Check for Y'Address 8186 8187 if Nkind (Expr) = N_Attribute_Reference 8188 and then Attribute_Name (Expr) = Name_Address 8189 then 8190 Expr := Prefix (Expr); 8191 exit; 8192 8193 -- Check for Const where Const is a constant entity 8194 8195 elsif Is_Entity_Name (Expr) 8196 and then Ekind (Entity (Expr)) = E_Constant 8197 then 8198 Expr := Constant_Value (Entity (Expr)); 8199 8200 -- Anything else does not need checking 8201 8202 else 8203 return; 8204 end if; 8205 end loop; 8206 8207 -- This loop checks the form of the prefix for an entity, using 8208 -- recursion to deal with intermediate components. 8209 8210 loop 8211 -- Check for Y where Y is an entity 8212 8213 if Is_Entity_Name (Expr) then 8214 Ent := Entity (Expr); 8215 return; 8216 8217 -- Check for components 8218 8219 elsif 8220 Nkind_In (Expr, N_Selected_Component, N_Indexed_Component) 8221 then 8222 Expr := Prefix (Expr); 8223 Off := True; 8224 8225 -- Anything else does not need checking 8226 8227 else 8228 return; 8229 end if; 8230 end loop; 8231 end if; 8232 end Find_Overlaid_Entity; 8233 8234 ------------------------- 8235 -- Find_Parameter_Type -- 8236 ------------------------- 8237 8238 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is 8239 begin 8240 if Nkind (Param) /= N_Parameter_Specification then 8241 return Empty; 8242 8243 -- For an access parameter, obtain the type from the formal entity 8244 -- itself, because access to subprogram nodes do not carry a type. 8245 -- Shouldn't we always use the formal entity ??? 8246 8247 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then 8248 return Etype (Defining_Identifier (Param)); 8249 8250 else 8251 return Etype (Parameter_Type (Param)); 8252 end if; 8253 end Find_Parameter_Type; 8254 8255 ----------------------------------- 8256 -- Find_Placement_In_State_Space -- 8257 ----------------------------------- 8258 8259 procedure Find_Placement_In_State_Space 8260 (Item_Id : Entity_Id; 8261 Placement : out State_Space_Kind; 8262 Pack_Id : out Entity_Id) 8263 is 8264 Context : Entity_Id; 8265 8266 begin 8267 -- Assume that the item does not appear in the state space of a package 8268 8269 Placement := Not_In_Package; 8270 Pack_Id := Empty; 8271 8272 -- Climb the scope stack and examine the enclosing context 8273 8274 Context := Scope (Item_Id); 8275 while Present (Context) and then Context /= Standard_Standard loop 8276 if Is_Package_Or_Generic_Package (Context) then 8277 Pack_Id := Context; 8278 8279 -- A package body is a cut off point for the traversal as the item 8280 -- cannot be visible to the outside from this point on. Note that 8281 -- this test must be done first as a body is also classified as a 8282 -- private part. 8283 8284 if In_Package_Body (Context) then 8285 Placement := Body_State_Space; 8286 return; 8287 8288 -- The private part of a package is a cut off point for the 8289 -- traversal as the item cannot be visible to the outside from 8290 -- this point on. 8291 8292 elsif In_Private_Part (Context) then 8293 Placement := Private_State_Space; 8294 return; 8295 8296 -- When the item appears in the visible state space of a package, 8297 -- continue to climb the scope stack as this may not be the final 8298 -- state space. 8299 8300 else 8301 Placement := Visible_State_Space; 8302 8303 -- The visible state space of a child unit acts as the proper 8304 -- placement of an item. 8305 8306 if Is_Child_Unit (Context) then 8307 return; 8308 end if; 8309 end if; 8310 8311 -- The item or its enclosing package appear in a construct that has 8312 -- no state space. 8313 8314 else 8315 Placement := Not_In_Package; 8316 return; 8317 end if; 8318 8319 Context := Scope (Context); 8320 end loop; 8321 end Find_Placement_In_State_Space; 8322 8323 ----------------------- 8324 -- Find_Primitive_Eq -- 8325 ----------------------- 8326 8327 function Find_Primitive_Eq (Typ : Entity_Id) return Entity_Id is 8328 function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id; 8329 -- Search for the equality primitive; return Empty if the primitive is 8330 -- not found. 8331 8332 ------------------ 8333 -- Find_Eq_Prim -- 8334 ------------------ 8335 8336 function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id is 8337 Prim : Entity_Id; 8338 Prim_Elmt : Elmt_Id; 8339 8340 begin 8341 Prim_Elmt := First_Elmt (Prims_List); 8342 while Present (Prim_Elmt) loop 8343 Prim := Node (Prim_Elmt); 8344 8345 -- Locate primitive equality with the right signature 8346 8347 if Chars (Prim) = Name_Op_Eq 8348 and then Etype (First_Formal (Prim)) = 8349 Etype (Next_Formal (First_Formal (Prim))) 8350 and then Base_Type (Etype (Prim)) = Standard_Boolean 8351 then 8352 return Prim; 8353 end if; 8354 8355 Next_Elmt (Prim_Elmt); 8356 end loop; 8357 8358 return Empty; 8359 end Find_Eq_Prim; 8360 8361 -- Local Variables 8362 8363 Eq_Prim : Entity_Id; 8364 Full_Type : Entity_Id; 8365 8366 -- Start of processing for Find_Primitive_Eq 8367 8368 begin 8369 if Is_Private_Type (Typ) then 8370 Full_Type := Underlying_Type (Typ); 8371 else 8372 Full_Type := Typ; 8373 end if; 8374 8375 if No (Full_Type) then 8376 return Empty; 8377 end if; 8378 8379 Full_Type := Base_Type (Full_Type); 8380 8381 -- When the base type itself is private, use the full view 8382 8383 if Is_Private_Type (Full_Type) then 8384 Full_Type := Underlying_Type (Full_Type); 8385 end if; 8386 8387 if Is_Class_Wide_Type (Full_Type) then 8388 Full_Type := Root_Type (Full_Type); 8389 end if; 8390 8391 if not Is_Tagged_Type (Full_Type) then 8392 Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ)); 8393 8394 -- If this is an untagged private type completed with a derivation of 8395 -- an untagged private type whose full view is a tagged type, we use 8396 -- the primitive operations of the private parent type (since it does 8397 -- not have a full view, and also because its equality primitive may 8398 -- have been overridden in its untagged full view). If no equality was 8399 -- defined for it then take its dispatching equality primitive. 8400 8401 elsif Inherits_From_Tagged_Full_View (Typ) then 8402 Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ)); 8403 8404 if No (Eq_Prim) then 8405 Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type)); 8406 end if; 8407 8408 else 8409 Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type)); 8410 end if; 8411 8412 return Eq_Prim; 8413 end Find_Primitive_Eq; 8414 8415 ------------------------ 8416 -- Find_Specific_Type -- 8417 ------------------------ 8418 8419 function Find_Specific_Type (CW : Entity_Id) return Entity_Id is 8420 Typ : Entity_Id := Root_Type (CW); 8421 8422 begin 8423 if Ekind (Typ) = E_Incomplete_Type then 8424 if From_Limited_With (Typ) then 8425 Typ := Non_Limited_View (Typ); 8426 else 8427 Typ := Full_View (Typ); 8428 end if; 8429 end if; 8430 8431 if Is_Private_Type (Typ) 8432 and then not Is_Tagged_Type (Typ) 8433 and then Present (Full_View (Typ)) 8434 then 8435 return Full_View (Typ); 8436 else 8437 return Typ; 8438 end if; 8439 end Find_Specific_Type; 8440 8441 ----------------------------- 8442 -- Find_Static_Alternative -- 8443 ----------------------------- 8444 8445 function Find_Static_Alternative (N : Node_Id) return Node_Id is 8446 Expr : constant Node_Id := Expression (N); 8447 Val : constant Uint := Expr_Value (Expr); 8448 Alt : Node_Id; 8449 Choice : Node_Id; 8450 8451 begin 8452 Alt := First (Alternatives (N)); 8453 8454 Search : loop 8455 if Nkind (Alt) /= N_Pragma then 8456 Choice := First (Discrete_Choices (Alt)); 8457 while Present (Choice) loop 8458 8459 -- Others choice, always matches 8460 8461 if Nkind (Choice) = N_Others_Choice then 8462 exit Search; 8463 8464 -- Range, check if value is in the range 8465 8466 elsif Nkind (Choice) = N_Range then 8467 exit Search when 8468 Val >= Expr_Value (Low_Bound (Choice)) 8469 and then 8470 Val <= Expr_Value (High_Bound (Choice)); 8471 8472 -- Choice is a subtype name. Note that we know it must 8473 -- be a static subtype, since otherwise it would have 8474 -- been diagnosed as illegal. 8475 8476 elsif Is_Entity_Name (Choice) 8477 and then Is_Type (Entity (Choice)) 8478 then 8479 exit Search when Is_In_Range (Expr, Etype (Choice), 8480 Assume_Valid => False); 8481 8482 -- Choice is a subtype indication 8483 8484 elsif Nkind (Choice) = N_Subtype_Indication then 8485 declare 8486 C : constant Node_Id := Constraint (Choice); 8487 R : constant Node_Id := Range_Expression (C); 8488 8489 begin 8490 exit Search when 8491 Val >= Expr_Value (Low_Bound (R)) 8492 and then 8493 Val <= Expr_Value (High_Bound (R)); 8494 end; 8495 8496 -- Choice is a simple expression 8497 8498 else 8499 exit Search when Val = Expr_Value (Choice); 8500 end if; 8501 8502 Next (Choice); 8503 end loop; 8504 end if; 8505 8506 Next (Alt); 8507 pragma Assert (Present (Alt)); 8508 end loop Search; 8509 8510 -- The above loop *must* terminate by finding a match, since we know the 8511 -- case statement is valid, and the value of the expression is known at 8512 -- compile time. When we fall out of the loop, Alt points to the 8513 -- alternative that we know will be selected at run time. 8514 8515 return Alt; 8516 end Find_Static_Alternative; 8517 8518 ------------------ 8519 -- First_Actual -- 8520 ------------------ 8521 8522 function First_Actual (Node : Node_Id) return Node_Id is 8523 N : Node_Id; 8524 8525 begin 8526 if No (Parameter_Associations (Node)) then 8527 return Empty; 8528 end if; 8529 8530 N := First (Parameter_Associations (Node)); 8531 8532 if Nkind (N) = N_Parameter_Association then 8533 return First_Named_Actual (Node); 8534 else 8535 return N; 8536 end if; 8537 end First_Actual; 8538 8539 ------------------ 8540 -- First_Global -- 8541 ------------------ 8542 8543 function First_Global 8544 (Subp : Entity_Id; 8545 Global_Mode : Name_Id; 8546 Refined : Boolean := False) return Node_Id 8547 is 8548 function First_From_Global_List 8549 (List : Node_Id; 8550 Global_Mode : Name_Id := Name_Input) return Entity_Id; 8551 -- Get the first item with suitable mode from List 8552 8553 ---------------------------- 8554 -- First_From_Global_List -- 8555 ---------------------------- 8556 8557 function First_From_Global_List 8558 (List : Node_Id; 8559 Global_Mode : Name_Id := Name_Input) return Entity_Id 8560 is 8561 Assoc : Node_Id; 8562 8563 begin 8564 -- Empty list (no global items) 8565 8566 if Nkind (List) = N_Null then 8567 return Empty; 8568 8569 -- Single global item declaration (only input items) 8570 8571 elsif Nkind_In (List, N_Expanded_Name, N_Identifier) then 8572 if Global_Mode = Name_Input then 8573 return List; 8574 else 8575 return Empty; 8576 end if; 8577 8578 -- Simple global list (only input items) or moded global list 8579 -- declaration. 8580 8581 elsif Nkind (List) = N_Aggregate then 8582 if Present (Expressions (List)) then 8583 if Global_Mode = Name_Input then 8584 return First (Expressions (List)); 8585 else 8586 return Empty; 8587 end if; 8588 8589 else 8590 Assoc := First (Component_Associations (List)); 8591 while Present (Assoc) loop 8592 8593 -- When we find the desired mode in an association, call 8594 -- recursively First_From_Global_List as if the mode was 8595 -- Name_Input, in order to reuse the existing machinery 8596 -- for the other cases. 8597 8598 if Chars (First (Choices (Assoc))) = Global_Mode then 8599 return First_From_Global_List (Expression (Assoc)); 8600 end if; 8601 8602 Next (Assoc); 8603 end loop; 8604 8605 return Empty; 8606 end if; 8607 8608 -- To accommodate partial decoration of disabled SPARK features, 8609 -- this routine may be called with illegal input. If this is the 8610 -- case, do not raise Program_Error. 8611 8612 else 8613 return Empty; 8614 end if; 8615 end First_From_Global_List; 8616 8617 -- Local variables 8618 8619 Global : Node_Id := Empty; 8620 Body_Id : Entity_Id; 8621 8622 begin 8623 pragma Assert (Nam_In (Global_Mode, Name_In_Out, 8624 Name_Input, 8625 Name_Output, 8626 Name_Proof_In)); 8627 8628 -- Retrieve the suitable pragma Global or Refined_Global. In the second 8629 -- case, it can only be located on the body entity. 8630 8631 if Refined then 8632 Body_Id := Subprogram_Body_Entity (Subp); 8633 if Present (Body_Id) then 8634 Global := Get_Pragma (Body_Id, Pragma_Refined_Global); 8635 end if; 8636 else 8637 Global := Get_Pragma (Subp, Pragma_Global); 8638 end if; 8639 8640 -- No corresponding global if pragma is not present 8641 8642 if No (Global) then 8643 return Empty; 8644 8645 -- Otherwise retrieve the corresponding list of items depending on the 8646 -- Global_Mode. 8647 8648 else 8649 return First_From_Global_List 8650 (Expression (Get_Argument (Global, Subp)), Global_Mode); 8651 end if; 8652 end First_Global; 8653 8654 ------------- 8655 -- Fix_Msg -- 8656 ------------- 8657 8658 function Fix_Msg (Id : Entity_Id; Msg : String) return String is 8659 Is_Task : constant Boolean := 8660 Ekind_In (Id, E_Task_Body, E_Task_Type) 8661 or else Is_Single_Task_Object (Id); 8662 Msg_Last : constant Natural := Msg'Last; 8663 Msg_Index : Natural; 8664 Res : String (Msg'Range) := (others => ' '); 8665 Res_Index : Natural; 8666 8667 begin 8668 -- Copy all characters from the input message Msg to result Res with 8669 -- suitable replacements. 8670 8671 Msg_Index := Msg'First; 8672 Res_Index := Res'First; 8673 while Msg_Index <= Msg_Last loop 8674 8675 -- Replace "subprogram" with a different word 8676 8677 if Msg_Index <= Msg_Last - 10 8678 and then Msg (Msg_Index .. Msg_Index + 9) = "subprogram" 8679 then 8680 if Ekind_In (Id, E_Entry, E_Entry_Family) then 8681 Res (Res_Index .. Res_Index + 4) := "entry"; 8682 Res_Index := Res_Index + 5; 8683 8684 elsif Is_Task then 8685 Res (Res_Index .. Res_Index + 8) := "task type"; 8686 Res_Index := Res_Index + 9; 8687 8688 else 8689 Res (Res_Index .. Res_Index + 9) := "subprogram"; 8690 Res_Index := Res_Index + 10; 8691 end if; 8692 8693 Msg_Index := Msg_Index + 10; 8694 8695 -- Replace "protected" with a different word 8696 8697 elsif Msg_Index <= Msg_Last - 9 8698 and then Msg (Msg_Index .. Msg_Index + 8) = "protected" 8699 and then Is_Task 8700 then 8701 Res (Res_Index .. Res_Index + 3) := "task"; 8702 Res_Index := Res_Index + 4; 8703 Msg_Index := Msg_Index + 9; 8704 8705 -- Otherwise copy the character 8706 8707 else 8708 Res (Res_Index) := Msg (Msg_Index); 8709 Msg_Index := Msg_Index + 1; 8710 Res_Index := Res_Index + 1; 8711 end if; 8712 end loop; 8713 8714 return Res (Res'First .. Res_Index - 1); 8715 end Fix_Msg; 8716 8717 ------------------------- 8718 -- From_Nested_Package -- 8719 ------------------------- 8720 8721 function From_Nested_Package (T : Entity_Id) return Boolean is 8722 Pack : constant Entity_Id := Scope (T); 8723 8724 begin 8725 return 8726 Ekind (Pack) = E_Package 8727 and then not Is_Frozen (Pack) 8728 and then not Scope_Within_Or_Same (Current_Scope, Pack) 8729 and then In_Open_Scopes (Scope (Pack)); 8730 end From_Nested_Package; 8731 8732 ----------------------- 8733 -- Gather_Components -- 8734 ----------------------- 8735 8736 procedure Gather_Components 8737 (Typ : Entity_Id; 8738 Comp_List : Node_Id; 8739 Governed_By : List_Id; 8740 Into : Elist_Id; 8741 Report_Errors : out Boolean) 8742 is 8743 Assoc : Node_Id; 8744 Variant : Node_Id; 8745 Discrete_Choice : Node_Id; 8746 Comp_Item : Node_Id; 8747 8748 Discrim : Entity_Id; 8749 Discrim_Name : Node_Id; 8750 Discrim_Value : Node_Id; 8751 8752 begin 8753 Report_Errors := False; 8754 8755 if No (Comp_List) or else Null_Present (Comp_List) then 8756 return; 8757 8758 elsif Present (Component_Items (Comp_List)) then 8759 Comp_Item := First (Component_Items (Comp_List)); 8760 8761 else 8762 Comp_Item := Empty; 8763 end if; 8764 8765 while Present (Comp_Item) loop 8766 8767 -- Skip the tag of a tagged record, the interface tags, as well 8768 -- as all items that are not user components (anonymous types, 8769 -- rep clauses, Parent field, controller field). 8770 8771 if Nkind (Comp_Item) = N_Component_Declaration then 8772 declare 8773 Comp : constant Entity_Id := Defining_Identifier (Comp_Item); 8774 begin 8775 if not Is_Tag (Comp) and then Chars (Comp) /= Name_uParent then 8776 Append_Elmt (Comp, Into); 8777 end if; 8778 end; 8779 end if; 8780 8781 Next (Comp_Item); 8782 end loop; 8783 8784 if No (Variant_Part (Comp_List)) then 8785 return; 8786 else 8787 Discrim_Name := Name (Variant_Part (Comp_List)); 8788 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); 8789 end if; 8790 8791 -- Look for the discriminant that governs this variant part. 8792 -- The discriminant *must* be in the Governed_By List 8793 8794 Assoc := First (Governed_By); 8795 Find_Constraint : loop 8796 Discrim := First (Choices (Assoc)); 8797 exit Find_Constraint when 8798 Chars (Discrim_Name) = Chars (Discrim) 8799 or else 8800 (Present (Corresponding_Discriminant (Entity (Discrim))) 8801 and then Chars (Corresponding_Discriminant 8802 (Entity (Discrim))) = Chars (Discrim_Name)) 8803 or else 8804 Chars (Original_Record_Component (Entity (Discrim))) = 8805 Chars (Discrim_Name); 8806 8807 if No (Next (Assoc)) then 8808 if not Is_Constrained (Typ) and then Is_Derived_Type (Typ) then 8809 8810 -- If the type is a tagged type with inherited discriminants, 8811 -- use the stored constraint on the parent in order to find 8812 -- the values of discriminants that are otherwise hidden by an 8813 -- explicit constraint. Renamed discriminants are handled in 8814 -- the code above. 8815 8816 -- If several parent discriminants are renamed by a single 8817 -- discriminant of the derived type, the call to obtain the 8818 -- Corresponding_Discriminant field only retrieves the last 8819 -- of them. We recover the constraint on the others from the 8820 -- Stored_Constraint as well. 8821 8822 -- An inherited discriminant may have been constrained in a 8823 -- later ancestor (not the immediate parent) so we must examine 8824 -- the stored constraint of all of them to locate the inherited 8825 -- value. 8826 8827 declare 8828 C : Elmt_Id; 8829 D : Entity_Id; 8830 T : Entity_Id := Typ; 8831 8832 begin 8833 while Is_Derived_Type (T) loop 8834 if Present (Stored_Constraint (T)) then 8835 D := First_Discriminant (Etype (T)); 8836 C := First_Elmt (Stored_Constraint (T)); 8837 while Present (D) and then Present (C) loop 8838 if Chars (Discrim_Name) = Chars (D) then 8839 if Is_Entity_Name (Node (C)) 8840 and then Entity (Node (C)) = Entity (Discrim) 8841 then 8842 -- D is renamed by Discrim, whose value is 8843 -- given in Assoc. 8844 8845 null; 8846 8847 else 8848 Assoc := 8849 Make_Component_Association (Sloc (Typ), 8850 New_List 8851 (New_Occurrence_Of (D, Sloc (Typ))), 8852 Duplicate_Subexpr_No_Checks (Node (C))); 8853 end if; 8854 8855 exit Find_Constraint; 8856 end if; 8857 8858 Next_Discriminant (D); 8859 Next_Elmt (C); 8860 end loop; 8861 end if; 8862 8863 -- Discriminant may be inherited from ancestor 8864 8865 T := Etype (T); 8866 end loop; 8867 end; 8868 end if; 8869 end if; 8870 8871 if No (Next (Assoc)) then 8872 Error_Msg_NE 8873 (" missing value for discriminant&", 8874 First (Governed_By), Discrim_Name); 8875 8876 Report_Errors := True; 8877 return; 8878 end if; 8879 8880 Next (Assoc); 8881 end loop Find_Constraint; 8882 8883 Discrim_Value := Expression (Assoc); 8884 8885 if not Is_OK_Static_Expression (Discrim_Value) then 8886 8887 -- If the variant part is governed by a discriminant of the type 8888 -- this is an error. If the variant part and the discriminant are 8889 -- inherited from an ancestor this is legal (AI05-120) unless the 8890 -- components are being gathered for an aggregate, in which case 8891 -- the caller must check Report_Errors. 8892 8893 if Scope (Original_Record_Component 8894 ((Entity (First (Choices (Assoc)))))) = Typ 8895 then 8896 Error_Msg_FE 8897 ("value for discriminant & must be static!", 8898 Discrim_Value, Discrim); 8899 Why_Not_Static (Discrim_Value); 8900 end if; 8901 8902 Report_Errors := True; 8903 return; 8904 end if; 8905 8906 Search_For_Discriminant_Value : declare 8907 Low : Node_Id; 8908 High : Node_Id; 8909 8910 UI_High : Uint; 8911 UI_Low : Uint; 8912 UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value); 8913 8914 begin 8915 Find_Discrete_Value : while Present (Variant) loop 8916 Discrete_Choice := First (Discrete_Choices (Variant)); 8917 while Present (Discrete_Choice) loop 8918 exit Find_Discrete_Value when 8919 Nkind (Discrete_Choice) = N_Others_Choice; 8920 8921 Get_Index_Bounds (Discrete_Choice, Low, High); 8922 8923 UI_Low := Expr_Value (Low); 8924 UI_High := Expr_Value (High); 8925 8926 exit Find_Discrete_Value when 8927 UI_Low <= UI_Discrim_Value 8928 and then 8929 UI_High >= UI_Discrim_Value; 8930 8931 Next (Discrete_Choice); 8932 end loop; 8933 8934 Next_Non_Pragma (Variant); 8935 end loop Find_Discrete_Value; 8936 end Search_For_Discriminant_Value; 8937 8938 -- The case statement must include a variant that corresponds to the 8939 -- value of the discriminant, unless the discriminant type has a 8940 -- static predicate. In that case the absence of an others_choice that 8941 -- would cover this value becomes a run-time error (3.8,1 (21.1/2)). 8942 8943 if No (Variant) 8944 and then not Has_Static_Predicate (Etype (Discrim_Name)) 8945 then 8946 Error_Msg_NE 8947 ("value of discriminant & is out of range", Discrim_Value, Discrim); 8948 Report_Errors := True; 8949 return; 8950 end if; 8951 8952 -- If we have found the corresponding choice, recursively add its 8953 -- components to the Into list. The nested components are part of 8954 -- the same record type. 8955 8956 if Present (Variant) then 8957 Gather_Components 8958 (Typ, Component_List (Variant), Governed_By, Into, Report_Errors); 8959 end if; 8960 end Gather_Components; 8961 8962 ------------------------ 8963 -- Get_Actual_Subtype -- 8964 ------------------------ 8965 8966 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is 8967 Typ : constant Entity_Id := Etype (N); 8968 Utyp : Entity_Id := Underlying_Type (Typ); 8969 Decl : Node_Id; 8970 Atyp : Entity_Id; 8971 8972 begin 8973 if No (Utyp) then 8974 Utyp := Typ; 8975 end if; 8976 8977 -- If what we have is an identifier that references a subprogram 8978 -- formal, or a variable or constant object, then we get the actual 8979 -- subtype from the referenced entity if one has been built. 8980 8981 if Nkind (N) = N_Identifier 8982 and then 8983 (Is_Formal (Entity (N)) 8984 or else Ekind (Entity (N)) = E_Constant 8985 or else Ekind (Entity (N)) = E_Variable) 8986 and then Present (Actual_Subtype (Entity (N))) 8987 then 8988 return Actual_Subtype (Entity (N)); 8989 8990 -- Actual subtype of unchecked union is always itself. We never need 8991 -- the "real" actual subtype. If we did, we couldn't get it anyway 8992 -- because the discriminant is not available. The restrictions on 8993 -- Unchecked_Union are designed to make sure that this is OK. 8994 8995 elsif Is_Unchecked_Union (Base_Type (Utyp)) then 8996 return Typ; 8997 8998 -- Here for the unconstrained case, we must find actual subtype 8999 -- No actual subtype is available, so we must build it on the fly. 9000 9001 -- Checking the type, not the underlying type, for constrainedness 9002 -- seems to be necessary. Maybe all the tests should be on the type??? 9003 9004 elsif (not Is_Constrained (Typ)) 9005 and then (Is_Array_Type (Utyp) 9006 or else (Is_Record_Type (Utyp) 9007 and then Has_Discriminants (Utyp))) 9008 and then not Has_Unknown_Discriminants (Utyp) 9009 and then not (Ekind (Utyp) = E_String_Literal_Subtype) 9010 then 9011 -- Nothing to do if in spec expression (why not???) 9012 9013 if In_Spec_Expression then 9014 return Typ; 9015 9016 elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then 9017 9018 -- If the type has no discriminants, there is no subtype to 9019 -- build, even if the underlying type is discriminated. 9020 9021 return Typ; 9022 9023 -- Else build the actual subtype 9024 9025 else 9026 Decl := Build_Actual_Subtype (Typ, N); 9027 9028 -- The call may yield a declaration, or just return the entity 9029 9030 if Decl = Typ then 9031 return Typ; 9032 end if; 9033 9034 Atyp := Defining_Identifier (Decl); 9035 9036 -- If Build_Actual_Subtype generated a new declaration then use it 9037 9038 if Atyp /= Typ then 9039 9040 -- The actual subtype is an Itype, so analyze the declaration, 9041 -- but do not attach it to the tree, to get the type defined. 9042 9043 Set_Parent (Decl, N); 9044 Set_Is_Itype (Atyp); 9045 Analyze (Decl, Suppress => All_Checks); 9046 Set_Associated_Node_For_Itype (Atyp, N); 9047 Set_Has_Delayed_Freeze (Atyp, False); 9048 9049 -- We need to freeze the actual subtype immediately. This is 9050 -- needed, because otherwise this Itype will not get frozen 9051 -- at all, and it is always safe to freeze on creation because 9052 -- any associated types must be frozen at this point. 9053 9054 Freeze_Itype (Atyp, N); 9055 return Atyp; 9056 9057 -- Otherwise we did not build a declaration, so return original 9058 9059 else 9060 return Typ; 9061 end if; 9062 end if; 9063 9064 -- For all remaining cases, the actual subtype is the same as 9065 -- the nominal type. 9066 9067 else 9068 return Typ; 9069 end if; 9070 end Get_Actual_Subtype; 9071 9072 ------------------------------------- 9073 -- Get_Actual_Subtype_If_Available -- 9074 ------------------------------------- 9075 9076 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is 9077 Typ : constant Entity_Id := Etype (N); 9078 9079 begin 9080 -- If what we have is an identifier that references a subprogram 9081 -- formal, or a variable or constant object, then we get the actual 9082 -- subtype from the referenced entity if one has been built. 9083 9084 if Nkind (N) = N_Identifier 9085 and then 9086 (Is_Formal (Entity (N)) 9087 or else Ekind (Entity (N)) = E_Constant 9088 or else Ekind (Entity (N)) = E_Variable) 9089 and then Present (Actual_Subtype (Entity (N))) 9090 then 9091 return Actual_Subtype (Entity (N)); 9092 9093 -- Otherwise the Etype of N is returned unchanged 9094 9095 else 9096 return Typ; 9097 end if; 9098 end Get_Actual_Subtype_If_Available; 9099 9100 ------------------------ 9101 -- Get_Body_From_Stub -- 9102 ------------------------ 9103 9104 function Get_Body_From_Stub (N : Node_Id) return Node_Id is 9105 begin 9106 return Proper_Body (Unit (Library_Unit (N))); 9107 end Get_Body_From_Stub; 9108 9109 --------------------- 9110 -- Get_Cursor_Type -- 9111 --------------------- 9112 9113 function Get_Cursor_Type 9114 (Aspect : Node_Id; 9115 Typ : Entity_Id) return Entity_Id 9116 is 9117 Assoc : Node_Id; 9118 Func : Entity_Id; 9119 First_Op : Entity_Id; 9120 Cursor : Entity_Id; 9121 9122 begin 9123 -- If error already detected, return 9124 9125 if Error_Posted (Aspect) then 9126 return Any_Type; 9127 end if; 9128 9129 -- The cursor type for an Iterable aspect is the return type of a 9130 -- non-overloaded First primitive operation. Locate association for 9131 -- First. 9132 9133 Assoc := First (Component_Associations (Expression (Aspect))); 9134 First_Op := Any_Id; 9135 while Present (Assoc) loop 9136 if Chars (First (Choices (Assoc))) = Name_First then 9137 First_Op := Expression (Assoc); 9138 exit; 9139 end if; 9140 9141 Next (Assoc); 9142 end loop; 9143 9144 if First_Op = Any_Id then 9145 Error_Msg_N ("aspect Iterable must specify First operation", Aspect); 9146 return Any_Type; 9147 9148 elsif not Analyzed (First_Op) then 9149 Analyze (First_Op); 9150 end if; 9151 9152 Cursor := Any_Type; 9153 9154 -- Locate function with desired name and profile in scope of type 9155 -- In the rare case where the type is an integer type, a base type 9156 -- is created for it, check that the base type of the first formal 9157 -- of First matches the base type of the domain. 9158 9159 Func := First_Entity (Scope (Typ)); 9160 while Present (Func) loop 9161 if Chars (Func) = Chars (First_Op) 9162 and then Ekind (Func) = E_Function 9163 and then Present (First_Formal (Func)) 9164 and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ) 9165 and then No (Next_Formal (First_Formal (Func))) 9166 then 9167 if Cursor /= Any_Type then 9168 Error_Msg_N 9169 ("Operation First for iterable type must be unique", Aspect); 9170 return Any_Type; 9171 else 9172 Cursor := Etype (Func); 9173 end if; 9174 end if; 9175 9176 Next_Entity (Func); 9177 end loop; 9178 9179 -- If not found, no way to resolve remaining primitives. 9180 9181 if Cursor = Any_Type then 9182 Error_Msg_N 9183 ("primitive operation for Iterable type must appear " 9184 & "in the same list of declarations as the type", Aspect); 9185 end if; 9186 9187 return Cursor; 9188 end Get_Cursor_Type; 9189 9190 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is 9191 begin 9192 return Etype (Get_Iterable_Type_Primitive (Typ, Name_First)); 9193 end Get_Cursor_Type; 9194 9195 ------------------------------- 9196 -- Get_Default_External_Name -- 9197 ------------------------------- 9198 9199 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is 9200 begin 9201 Get_Decoded_Name_String (Chars (E)); 9202 9203 if Opt.External_Name_Imp_Casing = Uppercase then 9204 Set_Casing (All_Upper_Case); 9205 else 9206 Set_Casing (All_Lower_Case); 9207 end if; 9208 9209 return 9210 Make_String_Literal (Sloc (E), 9211 Strval => String_From_Name_Buffer); 9212 end Get_Default_External_Name; 9213 9214 -------------------------- 9215 -- Get_Enclosing_Object -- 9216 -------------------------- 9217 9218 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is 9219 begin 9220 if Is_Entity_Name (N) then 9221 return Entity (N); 9222 else 9223 case Nkind (N) is 9224 when N_Indexed_Component 9225 | N_Selected_Component 9226 | N_Slice 9227 => 9228 -- If not generating code, a dereference may be left implicit. 9229 -- In thoses cases, return Empty. 9230 9231 if Is_Access_Type (Etype (Prefix (N))) then 9232 return Empty; 9233 else 9234 return Get_Enclosing_Object (Prefix (N)); 9235 end if; 9236 9237 when N_Type_Conversion => 9238 return Get_Enclosing_Object (Expression (N)); 9239 9240 when others => 9241 return Empty; 9242 end case; 9243 end if; 9244 end Get_Enclosing_Object; 9245 9246 --------------------------- 9247 -- Get_Enum_Lit_From_Pos -- 9248 --------------------------- 9249 9250 function Get_Enum_Lit_From_Pos 9251 (T : Entity_Id; 9252 Pos : Uint; 9253 Loc : Source_Ptr) return Node_Id 9254 is 9255 Btyp : Entity_Id := Base_Type (T); 9256 Lit : Node_Id; 9257 LLoc : Source_Ptr; 9258 9259 begin 9260 -- In the case where the literal is of type Character, Wide_Character 9261 -- or Wide_Wide_Character or of a type derived from them, there needs 9262 -- to be some special handling since there is no explicit chain of 9263 -- literals to search. Instead, an N_Character_Literal node is created 9264 -- with the appropriate Char_Code and Chars fields. 9265 9266 if Is_Standard_Character_Type (T) then 9267 Set_Character_Literal_Name (UI_To_CC (Pos)); 9268 9269 return 9270 Make_Character_Literal (Loc, 9271 Chars => Name_Find, 9272 Char_Literal_Value => Pos); 9273 9274 -- For all other cases, we have a complete table of literals, and 9275 -- we simply iterate through the chain of literal until the one 9276 -- with the desired position value is found. 9277 9278 else 9279 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then 9280 Btyp := Full_View (Btyp); 9281 end if; 9282 9283 Lit := First_Literal (Btyp); 9284 9285 -- Position in the enumeration type starts at 0 9286 9287 if UI_To_Int (Pos) < 0 then 9288 raise Constraint_Error; 9289 end if; 9290 9291 for J in 1 .. UI_To_Int (Pos) loop 9292 Next_Literal (Lit); 9293 9294 -- If Lit is Empty, Pos is not in range, so raise Constraint_Error 9295 -- inside the loop to avoid calling Next_Literal on Empty. 9296 9297 if No (Lit) then 9298 raise Constraint_Error; 9299 end if; 9300 end loop; 9301 9302 -- Create a new node from Lit, with source location provided by Loc 9303 -- if not equal to No_Location, or by copying the source location of 9304 -- Lit otherwise. 9305 9306 LLoc := Loc; 9307 9308 if LLoc = No_Location then 9309 LLoc := Sloc (Lit); 9310 end if; 9311 9312 return New_Occurrence_Of (Lit, LLoc); 9313 end if; 9314 end Get_Enum_Lit_From_Pos; 9315 9316 ------------------------ 9317 -- Get_Generic_Entity -- 9318 ------------------------ 9319 9320 function Get_Generic_Entity (N : Node_Id) return Entity_Id is 9321 Ent : constant Entity_Id := Entity (Name (N)); 9322 begin 9323 if Present (Renamed_Object (Ent)) then 9324 return Renamed_Object (Ent); 9325 else 9326 return Ent; 9327 end if; 9328 end Get_Generic_Entity; 9329 9330 ------------------------------------- 9331 -- Get_Incomplete_View_Of_Ancestor -- 9332 ------------------------------------- 9333 9334 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is 9335 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 9336 Par_Scope : Entity_Id; 9337 Par_Type : Entity_Id; 9338 9339 begin 9340 -- The incomplete view of an ancestor is only relevant for private 9341 -- derived types in child units. 9342 9343 if not Is_Derived_Type (E) 9344 or else not Is_Child_Unit (Cur_Unit) 9345 then 9346 return Empty; 9347 9348 else 9349 Par_Scope := Scope (Cur_Unit); 9350 if No (Par_Scope) then 9351 return Empty; 9352 end if; 9353 9354 Par_Type := Etype (Base_Type (E)); 9355 9356 -- Traverse list of ancestor types until we find one declared in 9357 -- a parent or grandparent unit (two levels seem sufficient). 9358 9359 while Present (Par_Type) loop 9360 if Scope (Par_Type) = Par_Scope 9361 or else Scope (Par_Type) = Scope (Par_Scope) 9362 then 9363 return Par_Type; 9364 9365 elsif not Is_Derived_Type (Par_Type) then 9366 return Empty; 9367 9368 else 9369 Par_Type := Etype (Base_Type (Par_Type)); 9370 end if; 9371 end loop; 9372 9373 -- If none found, there is no relevant ancestor type. 9374 9375 return Empty; 9376 end if; 9377 end Get_Incomplete_View_Of_Ancestor; 9378 9379 ---------------------- 9380 -- Get_Index_Bounds -- 9381 ---------------------- 9382 9383 procedure Get_Index_Bounds 9384 (N : Node_Id; 9385 L : out Node_Id; 9386 H : out Node_Id; 9387 Use_Full_View : Boolean := False) 9388 is 9389 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id; 9390 -- Obtain the scalar range of type Typ. If flag Use_Full_View is set and 9391 -- Typ qualifies, the scalar range is obtained from the full view of the 9392 -- type. 9393 9394 -------------------------- 9395 -- Scalar_Range_Of_Type -- 9396 -------------------------- 9397 9398 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id is 9399 T : Entity_Id := Typ; 9400 9401 begin 9402 if Use_Full_View and then Present (Full_View (T)) then 9403 T := Full_View (T); 9404 end if; 9405 9406 return Scalar_Range (T); 9407 end Scalar_Range_Of_Type; 9408 9409 -- Local variables 9410 9411 Kind : constant Node_Kind := Nkind (N); 9412 Rng : Node_Id; 9413 9414 -- Start of processing for Get_Index_Bounds 9415 9416 begin 9417 if Kind = N_Range then 9418 L := Low_Bound (N); 9419 H := High_Bound (N); 9420 9421 elsif Kind = N_Subtype_Indication then 9422 Rng := Range_Expression (Constraint (N)); 9423 9424 if Rng = Error then 9425 L := Error; 9426 H := Error; 9427 return; 9428 9429 else 9430 L := Low_Bound (Range_Expression (Constraint (N))); 9431 H := High_Bound (Range_Expression (Constraint (N))); 9432 end if; 9433 9434 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then 9435 Rng := Scalar_Range_Of_Type (Entity (N)); 9436 9437 if Error_Posted (Rng) then 9438 L := Error; 9439 H := Error; 9440 9441 elsif Nkind (Rng) = N_Subtype_Indication then 9442 Get_Index_Bounds (Rng, L, H); 9443 9444 else 9445 L := Low_Bound (Rng); 9446 H := High_Bound (Rng); 9447 end if; 9448 9449 else 9450 -- N is an expression, indicating a range with one value 9451 9452 L := N; 9453 H := N; 9454 end if; 9455 end Get_Index_Bounds; 9456 9457 ----------------------------- 9458 -- Get_Interfacing_Aspects -- 9459 ----------------------------- 9460 9461 procedure Get_Interfacing_Aspects 9462 (Iface_Asp : Node_Id; 9463 Conv_Asp : out Node_Id; 9464 EN_Asp : out Node_Id; 9465 Expo_Asp : out Node_Id; 9466 Imp_Asp : out Node_Id; 9467 LN_Asp : out Node_Id; 9468 Do_Checks : Boolean := False) 9469 is 9470 procedure Save_Or_Duplication_Error 9471 (Asp : Node_Id; 9472 To : in out Node_Id); 9473 -- Save the value of aspect Asp in node To. If To already has a value, 9474 -- then this is considered a duplicate use of aspect. Emit an error if 9475 -- flag Do_Checks is set. 9476 9477 ------------------------------- 9478 -- Save_Or_Duplication_Error -- 9479 ------------------------------- 9480 9481 procedure Save_Or_Duplication_Error 9482 (Asp : Node_Id; 9483 To : in out Node_Id) 9484 is 9485 begin 9486 -- Detect an extra aspect and issue an error 9487 9488 if Present (To) then 9489 if Do_Checks then 9490 Error_Msg_Name_1 := Chars (Identifier (Asp)); 9491 Error_Msg_Sloc := Sloc (To); 9492 Error_Msg_N ("aspect % previously given #", Asp); 9493 end if; 9494 9495 -- Otherwise capture the aspect 9496 9497 else 9498 To := Asp; 9499 end if; 9500 end Save_Or_Duplication_Error; 9501 9502 -- Local variables 9503 9504 Asp : Node_Id; 9505 Asp_Id : Aspect_Id; 9506 9507 -- The following variables capture each individual aspect 9508 9509 Conv : Node_Id := Empty; 9510 EN : Node_Id := Empty; 9511 Expo : Node_Id := Empty; 9512 Imp : Node_Id := Empty; 9513 LN : Node_Id := Empty; 9514 9515 -- Start of processing for Get_Interfacing_Aspects 9516 9517 begin 9518 -- The input interfacing aspect should reside in an aspect specification 9519 -- list. 9520 9521 pragma Assert (Is_List_Member (Iface_Asp)); 9522 9523 -- Examine the aspect specifications of the related entity. Find and 9524 -- capture all interfacing aspects. Detect duplicates and emit errors 9525 -- if applicable. 9526 9527 Asp := First (List_Containing (Iface_Asp)); 9528 while Present (Asp) loop 9529 Asp_Id := Get_Aspect_Id (Asp); 9530 9531 if Asp_Id = Aspect_Convention then 9532 Save_Or_Duplication_Error (Asp, Conv); 9533 9534 elsif Asp_Id = Aspect_External_Name then 9535 Save_Or_Duplication_Error (Asp, EN); 9536 9537 elsif Asp_Id = Aspect_Export then 9538 Save_Or_Duplication_Error (Asp, Expo); 9539 9540 elsif Asp_Id = Aspect_Import then 9541 Save_Or_Duplication_Error (Asp, Imp); 9542 9543 elsif Asp_Id = Aspect_Link_Name then 9544 Save_Or_Duplication_Error (Asp, LN); 9545 end if; 9546 9547 Next (Asp); 9548 end loop; 9549 9550 Conv_Asp := Conv; 9551 EN_Asp := EN; 9552 Expo_Asp := Expo; 9553 Imp_Asp := Imp; 9554 LN_Asp := LN; 9555 end Get_Interfacing_Aspects; 9556 9557 --------------------------------- 9558 -- Get_Iterable_Type_Primitive -- 9559 --------------------------------- 9560 9561 function Get_Iterable_Type_Primitive 9562 (Typ : Entity_Id; 9563 Nam : Name_Id) return Entity_Id 9564 is 9565 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable); 9566 Assoc : Node_Id; 9567 9568 begin 9569 if No (Funcs) then 9570 return Empty; 9571 9572 else 9573 Assoc := First (Component_Associations (Funcs)); 9574 while Present (Assoc) loop 9575 if Chars (First (Choices (Assoc))) = Nam then 9576 return Entity (Expression (Assoc)); 9577 end if; 9578 9579 Assoc := Next (Assoc); 9580 end loop; 9581 9582 return Empty; 9583 end if; 9584 end Get_Iterable_Type_Primitive; 9585 9586 ---------------------------------- 9587 -- Get_Library_Unit_Name_String -- 9588 ---------------------------------- 9589 9590 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is 9591 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node); 9592 9593 begin 9594 Get_Unit_Name_String (Unit_Name_Id); 9595 9596 -- Remove seven last character (" (spec)" or " (body)") 9597 9598 Name_Len := Name_Len - 7; 9599 pragma Assert (Name_Buffer (Name_Len + 1) = ' '); 9600 end Get_Library_Unit_Name_String; 9601 9602 -------------------------- 9603 -- Get_Max_Queue_Length -- 9604 -------------------------- 9605 9606 function Get_Max_Queue_Length (Id : Entity_Id) return Uint is 9607 pragma Assert (Is_Entry (Id)); 9608 Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length); 9609 9610 begin 9611 -- A value of 0 represents no maximum specified, and entries and entry 9612 -- families with no Max_Queue_Length aspect or pragma default to it. 9613 9614 if not Present (Prag) then 9615 return Uint_0; 9616 end if; 9617 9618 return Intval (Expression (First (Pragma_Argument_Associations (Prag)))); 9619 end Get_Max_Queue_Length; 9620 9621 ------------------------ 9622 -- Get_Name_Entity_Id -- 9623 ------------------------ 9624 9625 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is 9626 begin 9627 return Entity_Id (Get_Name_Table_Int (Id)); 9628 end Get_Name_Entity_Id; 9629 9630 ------------------------------ 9631 -- Get_Name_From_CTC_Pragma -- 9632 ------------------------------ 9633 9634 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is 9635 Arg : constant Node_Id := 9636 Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 9637 begin 9638 return Strval (Expr_Value_S (Arg)); 9639 end Get_Name_From_CTC_Pragma; 9640 9641 ----------------------- 9642 -- Get_Parent_Entity -- 9643 ----------------------- 9644 9645 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is 9646 begin 9647 if Nkind (Unit) = N_Package_Body 9648 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation 9649 then 9650 return Defining_Entity 9651 (Specification (Instance_Spec (Original_Node (Unit)))); 9652 elsif Nkind (Unit) = N_Package_Instantiation then 9653 return Defining_Entity (Specification (Instance_Spec (Unit))); 9654 else 9655 return Defining_Entity (Unit); 9656 end if; 9657 end Get_Parent_Entity; 9658 9659 ------------------- 9660 -- Get_Pragma_Id -- 9661 ------------------- 9662 9663 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is 9664 begin 9665 return Get_Pragma_Id (Pragma_Name_Unmapped (N)); 9666 end Get_Pragma_Id; 9667 9668 ------------------------ 9669 -- Get_Qualified_Name -- 9670 ------------------------ 9671 9672 function Get_Qualified_Name 9673 (Id : Entity_Id; 9674 Suffix : Entity_Id := Empty) return Name_Id 9675 is 9676 Suffix_Nam : Name_Id := No_Name; 9677 9678 begin 9679 if Present (Suffix) then 9680 Suffix_Nam := Chars (Suffix); 9681 end if; 9682 9683 return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id)); 9684 end Get_Qualified_Name; 9685 9686 function Get_Qualified_Name 9687 (Nam : Name_Id; 9688 Suffix : Name_Id := No_Name; 9689 Scop : Entity_Id := Current_Scope) return Name_Id 9690 is 9691 procedure Add_Scope (S : Entity_Id); 9692 -- Add the fully qualified form of scope S to the name buffer. The 9693 -- format is: 9694 -- s-1__s__ 9695 9696 --------------- 9697 -- Add_Scope -- 9698 --------------- 9699 9700 procedure Add_Scope (S : Entity_Id) is 9701 begin 9702 if S = Empty then 9703 null; 9704 9705 elsif S = Standard_Standard then 9706 null; 9707 9708 else 9709 Add_Scope (Scope (S)); 9710 Get_Name_String_And_Append (Chars (S)); 9711 Add_Str_To_Name_Buffer ("__"); 9712 end if; 9713 end Add_Scope; 9714 9715 -- Start of processing for Get_Qualified_Name 9716 9717 begin 9718 Name_Len := 0; 9719 Add_Scope (Scop); 9720 9721 -- Append the base name after all scopes have been chained 9722 9723 Get_Name_String_And_Append (Nam); 9724 9725 -- Append the suffix (if present) 9726 9727 if Suffix /= No_Name then 9728 Add_Str_To_Name_Buffer ("__"); 9729 Get_Name_String_And_Append (Suffix); 9730 end if; 9731 9732 return Name_Find; 9733 end Get_Qualified_Name; 9734 9735 ----------------------- 9736 -- Get_Reason_String -- 9737 ----------------------- 9738 9739 procedure Get_Reason_String (N : Node_Id) is 9740 begin 9741 if Nkind (N) = N_String_Literal then 9742 Store_String_Chars (Strval (N)); 9743 9744 elsif Nkind (N) = N_Op_Concat then 9745 Get_Reason_String (Left_Opnd (N)); 9746 Get_Reason_String (Right_Opnd (N)); 9747 9748 -- If not of required form, error 9749 9750 else 9751 Error_Msg_N 9752 ("Reason for pragma Warnings has wrong form", N); 9753 Error_Msg_N 9754 ("\must be string literal or concatenation of string literals", N); 9755 return; 9756 end if; 9757 end Get_Reason_String; 9758 9759 -------------------------------- 9760 -- Get_Reference_Discriminant -- 9761 -------------------------------- 9762 9763 function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is 9764 D : Entity_Id; 9765 9766 begin 9767 D := First_Discriminant (Typ); 9768 while Present (D) loop 9769 if Has_Implicit_Dereference (D) then 9770 return D; 9771 end if; 9772 Next_Discriminant (D); 9773 end loop; 9774 9775 return Empty; 9776 end Get_Reference_Discriminant; 9777 9778 --------------------------- 9779 -- Get_Referenced_Object -- 9780 --------------------------- 9781 9782 function Get_Referenced_Object (N : Node_Id) return Node_Id is 9783 R : Node_Id; 9784 9785 begin 9786 R := N; 9787 while Is_Entity_Name (R) 9788 and then Present (Renamed_Object (Entity (R))) 9789 loop 9790 R := Renamed_Object (Entity (R)); 9791 end loop; 9792 9793 return R; 9794 end Get_Referenced_Object; 9795 9796 ------------------------ 9797 -- Get_Renamed_Entity -- 9798 ------------------------ 9799 9800 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is 9801 R : Entity_Id; 9802 9803 begin 9804 R := E; 9805 while Present (Renamed_Entity (R)) loop 9806 R := Renamed_Entity (R); 9807 end loop; 9808 9809 return R; 9810 end Get_Renamed_Entity; 9811 9812 ----------------------- 9813 -- Get_Return_Object -- 9814 ----------------------- 9815 9816 function Get_Return_Object (N : Node_Id) return Entity_Id is 9817 Decl : Node_Id; 9818 9819 begin 9820 Decl := First (Return_Object_Declarations (N)); 9821 while Present (Decl) loop 9822 exit when Nkind (Decl) = N_Object_Declaration 9823 and then Is_Return_Object (Defining_Identifier (Decl)); 9824 Next (Decl); 9825 end loop; 9826 9827 pragma Assert (Present (Decl)); 9828 return Defining_Identifier (Decl); 9829 end Get_Return_Object; 9830 9831 --------------------------- 9832 -- Get_Subprogram_Entity -- 9833 --------------------------- 9834 9835 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is 9836 Subp : Node_Id; 9837 Subp_Id : Entity_Id; 9838 9839 begin 9840 if Nkind (Nod) = N_Accept_Statement then 9841 Subp := Entry_Direct_Name (Nod); 9842 9843 elsif Nkind (Nod) = N_Slice then 9844 Subp := Prefix (Nod); 9845 9846 else 9847 Subp := Name (Nod); 9848 end if; 9849 9850 -- Strip the subprogram call 9851 9852 loop 9853 if Nkind_In (Subp, N_Explicit_Dereference, 9854 N_Indexed_Component, 9855 N_Selected_Component) 9856 then 9857 Subp := Prefix (Subp); 9858 9859 elsif Nkind_In (Subp, N_Type_Conversion, 9860 N_Unchecked_Type_Conversion) 9861 then 9862 Subp := Expression (Subp); 9863 9864 else 9865 exit; 9866 end if; 9867 end loop; 9868 9869 -- Extract the entity of the subprogram call 9870 9871 if Is_Entity_Name (Subp) then 9872 Subp_Id := Entity (Subp); 9873 9874 if Ekind (Subp_Id) = E_Access_Subprogram_Type then 9875 Subp_Id := Directly_Designated_Type (Subp_Id); 9876 end if; 9877 9878 if Is_Subprogram (Subp_Id) then 9879 return Subp_Id; 9880 else 9881 return Empty; 9882 end if; 9883 9884 -- The search did not find a construct that denotes a subprogram 9885 9886 else 9887 return Empty; 9888 end if; 9889 end Get_Subprogram_Entity; 9890 9891 ----------------------------- 9892 -- Get_Task_Body_Procedure -- 9893 ----------------------------- 9894 9895 function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is 9896 begin 9897 -- Note: A task type may be the completion of a private type with 9898 -- discriminants. When performing elaboration checks on a task 9899 -- declaration, the current view of the type may be the private one, 9900 -- and the procedure that holds the body of the task is held in its 9901 -- underlying type. 9902 9903 -- This is an odd function, why not have Task_Body_Procedure do 9904 -- the following digging??? 9905 9906 return Task_Body_Procedure (Underlying_Type (Root_Type (E))); 9907 end Get_Task_Body_Procedure; 9908 9909 ------------------------- 9910 -- Get_User_Defined_Eq -- 9911 ------------------------- 9912 9913 function Get_User_Defined_Eq (E : Entity_Id) return Entity_Id is 9914 Prim : Elmt_Id; 9915 Op : Entity_Id; 9916 9917 begin 9918 Prim := First_Elmt (Collect_Primitive_Operations (E)); 9919 while Present (Prim) loop 9920 Op := Node (Prim); 9921 9922 if Chars (Op) = Name_Op_Eq 9923 and then Etype (Op) = Standard_Boolean 9924 and then Etype (First_Formal (Op)) = E 9925 and then Etype (Next_Formal (First_Formal (Op))) = E 9926 then 9927 return Op; 9928 end if; 9929 9930 Next_Elmt (Prim); 9931 end loop; 9932 9933 return Empty; 9934 end Get_User_Defined_Eq; 9935 9936 --------------- 9937 -- Get_Views -- 9938 --------------- 9939 9940 procedure Get_Views 9941 (Typ : Entity_Id; 9942 Priv_Typ : out Entity_Id; 9943 Full_Typ : out Entity_Id; 9944 Full_Base : out Entity_Id; 9945 CRec_Typ : out Entity_Id) 9946 is 9947 IP_View : Entity_Id; 9948 9949 begin 9950 -- Assume that none of the views can be recovered 9951 9952 Priv_Typ := Empty; 9953 Full_Typ := Empty; 9954 Full_Base := Empty; 9955 CRec_Typ := Empty; 9956 9957 -- The input type is the corresponding record type of a protected or a 9958 -- task type. 9959 9960 if Ekind (Typ) = E_Record_Type 9961 and then Is_Concurrent_Record_Type (Typ) 9962 then 9963 CRec_Typ := Typ; 9964 Full_Typ := Corresponding_Concurrent_Type (CRec_Typ); 9965 Full_Base := Base_Type (Full_Typ); 9966 Priv_Typ := Incomplete_Or_Partial_View (Full_Typ); 9967 9968 -- Otherwise the input type denotes an arbitrary type 9969 9970 else 9971 IP_View := Incomplete_Or_Partial_View (Typ); 9972 9973 -- The input type denotes the full view of a private type 9974 9975 if Present (IP_View) then 9976 Priv_Typ := IP_View; 9977 Full_Typ := Typ; 9978 9979 -- The input type is a private type 9980 9981 elsif Is_Private_Type (Typ) then 9982 Priv_Typ := Typ; 9983 Full_Typ := Full_View (Priv_Typ); 9984 9985 -- Otherwise the input type does not have any views 9986 9987 else 9988 Full_Typ := Typ; 9989 end if; 9990 9991 if Present (Full_Typ) then 9992 Full_Base := Base_Type (Full_Typ); 9993 9994 if Ekind_In (Full_Typ, E_Protected_Type, E_Task_Type) then 9995 CRec_Typ := Corresponding_Record_Type (Full_Typ); 9996 end if; 9997 end if; 9998 end if; 9999 end Get_Views; 10000 10001 ----------------------- 10002 -- Has_Access_Values -- 10003 ----------------------- 10004 10005 function Has_Access_Values (T : Entity_Id) return Boolean is 10006 Typ : constant Entity_Id := Underlying_Type (T); 10007 10008 begin 10009 -- Case of a private type which is not completed yet. This can only 10010 -- happen in the case of a generic format type appearing directly, or 10011 -- as a component of the type to which this function is being applied 10012 -- at the top level. Return False in this case, since we certainly do 10013 -- not know that the type contains access types. 10014 10015 if No (Typ) then 10016 return False; 10017 10018 elsif Is_Access_Type (Typ) then 10019 return True; 10020 10021 elsif Is_Array_Type (Typ) then 10022 return Has_Access_Values (Component_Type (Typ)); 10023 10024 elsif Is_Record_Type (Typ) then 10025 declare 10026 Comp : Entity_Id; 10027 10028 begin 10029 -- Loop to Check components 10030 10031 Comp := First_Component_Or_Discriminant (Typ); 10032 while Present (Comp) loop 10033 10034 -- Check for access component, tag field does not count, even 10035 -- though it is implemented internally using an access type. 10036 10037 if Has_Access_Values (Etype (Comp)) 10038 and then Chars (Comp) /= Name_uTag 10039 then 10040 return True; 10041 end if; 10042 10043 Next_Component_Or_Discriminant (Comp); 10044 end loop; 10045 end; 10046 10047 return False; 10048 10049 else 10050 return False; 10051 end if; 10052 end Has_Access_Values; 10053 10054 ------------------------------ 10055 -- Has_Compatible_Alignment -- 10056 ------------------------------ 10057 10058 function Has_Compatible_Alignment 10059 (Obj : Entity_Id; 10060 Expr : Node_Id; 10061 Layout_Done : Boolean) return Alignment_Result 10062 is 10063 function Has_Compatible_Alignment_Internal 10064 (Obj : Entity_Id; 10065 Expr : Node_Id; 10066 Layout_Done : Boolean; 10067 Default : Alignment_Result) return Alignment_Result; 10068 -- This is the internal recursive function that actually does the work. 10069 -- There is one additional parameter, which says what the result should 10070 -- be if no alignment information is found, and there is no definite 10071 -- indication of compatible alignments. At the outer level, this is set 10072 -- to Unknown, but for internal recursive calls in the case where types 10073 -- are known to be correct, it is set to Known_Compatible. 10074 10075 --------------------------------------- 10076 -- Has_Compatible_Alignment_Internal -- 10077 --------------------------------------- 10078 10079 function Has_Compatible_Alignment_Internal 10080 (Obj : Entity_Id; 10081 Expr : Node_Id; 10082 Layout_Done : Boolean; 10083 Default : Alignment_Result) return Alignment_Result 10084 is 10085 Result : Alignment_Result := Known_Compatible; 10086 -- Holds the current status of the result. Note that once a value of 10087 -- Known_Incompatible is set, it is sticky and does not get changed 10088 -- to Unknown (the value in Result only gets worse as we go along, 10089 -- never better). 10090 10091 Offs : Uint := No_Uint; 10092 -- Set to a factor of the offset from the base object when Expr is a 10093 -- selected or indexed component, based on Component_Bit_Offset and 10094 -- Component_Size respectively. A negative value is used to represent 10095 -- a value which is not known at compile time. 10096 10097 procedure Check_Prefix; 10098 -- Checks the prefix recursively in the case where the expression 10099 -- is an indexed or selected component. 10100 10101 procedure Set_Result (R : Alignment_Result); 10102 -- If R represents a worse outcome (unknown instead of known 10103 -- compatible, or known incompatible), then set Result to R. 10104 10105 ------------------ 10106 -- Check_Prefix -- 10107 ------------------ 10108 10109 procedure Check_Prefix is 10110 begin 10111 -- The subtlety here is that in doing a recursive call to check 10112 -- the prefix, we have to decide what to do in the case where we 10113 -- don't find any specific indication of an alignment problem. 10114 10115 -- At the outer level, we normally set Unknown as the result in 10116 -- this case, since we can only set Known_Compatible if we really 10117 -- know that the alignment value is OK, but for the recursive 10118 -- call, in the case where the types match, and we have not 10119 -- specified a peculiar alignment for the object, we are only 10120 -- concerned about suspicious rep clauses, the default case does 10121 -- not affect us, since the compiler will, in the absence of such 10122 -- rep clauses, ensure that the alignment is correct. 10123 10124 if Default = Known_Compatible 10125 or else 10126 (Etype (Obj) = Etype (Expr) 10127 and then (Unknown_Alignment (Obj) 10128 or else 10129 Alignment (Obj) = Alignment (Etype (Obj)))) 10130 then 10131 Set_Result 10132 (Has_Compatible_Alignment_Internal 10133 (Obj, Prefix (Expr), Layout_Done, Known_Compatible)); 10134 10135 -- In all other cases, we need a full check on the prefix 10136 10137 else 10138 Set_Result 10139 (Has_Compatible_Alignment_Internal 10140 (Obj, Prefix (Expr), Layout_Done, Unknown)); 10141 end if; 10142 end Check_Prefix; 10143 10144 ---------------- 10145 -- Set_Result -- 10146 ---------------- 10147 10148 procedure Set_Result (R : Alignment_Result) is 10149 begin 10150 if R > Result then 10151 Result := R; 10152 end if; 10153 end Set_Result; 10154 10155 -- Start of processing for Has_Compatible_Alignment_Internal 10156 10157 begin 10158 -- If Expr is a selected component, we must make sure there is no 10159 -- potentially troublesome component clause and that the record is 10160 -- not packed if the layout is not done. 10161 10162 if Nkind (Expr) = N_Selected_Component then 10163 10164 -- Packing generates unknown alignment if layout is not done 10165 10166 if Is_Packed (Etype (Prefix (Expr))) and then not Layout_Done then 10167 Set_Result (Unknown); 10168 end if; 10169 10170 -- Check prefix and component offset 10171 10172 Check_Prefix; 10173 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr))); 10174 10175 -- If Expr is an indexed component, we must make sure there is no 10176 -- potentially troublesome Component_Size clause and that the array 10177 -- is not bit-packed if the layout is not done. 10178 10179 elsif Nkind (Expr) = N_Indexed_Component then 10180 declare 10181 Typ : constant Entity_Id := Etype (Prefix (Expr)); 10182 10183 begin 10184 -- Packing generates unknown alignment if layout is not done 10185 10186 if Is_Bit_Packed_Array (Typ) and then not Layout_Done then 10187 Set_Result (Unknown); 10188 end if; 10189 10190 -- Check prefix and component offset (or at least size) 10191 10192 Check_Prefix; 10193 Offs := Indexed_Component_Bit_Offset (Expr); 10194 if Offs = No_Uint then 10195 Offs := Component_Size (Typ); 10196 end if; 10197 end; 10198 end if; 10199 10200 -- If we have a null offset, the result is entirely determined by 10201 -- the base object and has already been computed recursively. 10202 10203 if Offs = Uint_0 then 10204 null; 10205 10206 -- Case where we know the alignment of the object 10207 10208 elsif Known_Alignment (Obj) then 10209 declare 10210 ObjA : constant Uint := Alignment (Obj); 10211 ExpA : Uint := No_Uint; 10212 SizA : Uint := No_Uint; 10213 10214 begin 10215 -- If alignment of Obj is 1, then we are always OK 10216 10217 if ObjA = 1 then 10218 Set_Result (Known_Compatible); 10219 10220 -- Alignment of Obj is greater than 1, so we need to check 10221 10222 else 10223 -- If we have an offset, see if it is compatible 10224 10225 if Offs /= No_Uint and Offs > Uint_0 then 10226 if Offs mod (System_Storage_Unit * ObjA) /= 0 then 10227 Set_Result (Known_Incompatible); 10228 end if; 10229 10230 -- See if Expr is an object with known alignment 10231 10232 elsif Is_Entity_Name (Expr) 10233 and then Known_Alignment (Entity (Expr)) 10234 then 10235 ExpA := Alignment (Entity (Expr)); 10236 10237 -- Otherwise, we can use the alignment of the type of 10238 -- Expr given that we already checked for 10239 -- discombobulating rep clauses for the cases of indexed 10240 -- and selected components above. 10241 10242 elsif Known_Alignment (Etype (Expr)) then 10243 ExpA := Alignment (Etype (Expr)); 10244 10245 -- Otherwise the alignment is unknown 10246 10247 else 10248 Set_Result (Default); 10249 end if; 10250 10251 -- If we got an alignment, see if it is acceptable 10252 10253 if ExpA /= No_Uint and then ExpA < ObjA then 10254 Set_Result (Known_Incompatible); 10255 end if; 10256 10257 -- If Expr is not a piece of a larger object, see if size 10258 -- is given. If so, check that it is not too small for the 10259 -- required alignment. 10260 10261 if Offs /= No_Uint then 10262 null; 10263 10264 -- See if Expr is an object with known size 10265 10266 elsif Is_Entity_Name (Expr) 10267 and then Known_Static_Esize (Entity (Expr)) 10268 then 10269 SizA := Esize (Entity (Expr)); 10270 10271 -- Otherwise, we check the object size of the Expr type 10272 10273 elsif Known_Static_Esize (Etype (Expr)) then 10274 SizA := Esize (Etype (Expr)); 10275 end if; 10276 10277 -- If we got a size, see if it is a multiple of the Obj 10278 -- alignment, if not, then the alignment cannot be 10279 -- acceptable, since the size is always a multiple of the 10280 -- alignment. 10281 10282 if SizA /= No_Uint then 10283 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then 10284 Set_Result (Known_Incompatible); 10285 end if; 10286 end if; 10287 end if; 10288 end; 10289 10290 -- If we do not know required alignment, any non-zero offset is a 10291 -- potential problem (but certainly may be OK, so result is unknown). 10292 10293 elsif Offs /= No_Uint then 10294 Set_Result (Unknown); 10295 10296 -- If we can't find the result by direct comparison of alignment 10297 -- values, then there is still one case that we can determine known 10298 -- result, and that is when we can determine that the types are the 10299 -- same, and no alignments are specified. Then we known that the 10300 -- alignments are compatible, even if we don't know the alignment 10301 -- value in the front end. 10302 10303 elsif Etype (Obj) = Etype (Expr) then 10304 10305 -- Types are the same, but we have to check for possible size 10306 -- and alignments on the Expr object that may make the alignment 10307 -- different, even though the types are the same. 10308 10309 if Is_Entity_Name (Expr) then 10310 10311 -- First check alignment of the Expr object. Any alignment less 10312 -- than Maximum_Alignment is worrisome since this is the case 10313 -- where we do not know the alignment of Obj. 10314 10315 if Known_Alignment (Entity (Expr)) 10316 and then UI_To_Int (Alignment (Entity (Expr))) < 10317 Ttypes.Maximum_Alignment 10318 then 10319 Set_Result (Unknown); 10320 10321 -- Now check size of Expr object. Any size that is not an 10322 -- even multiple of Maximum_Alignment is also worrisome 10323 -- since it may cause the alignment of the object to be less 10324 -- than the alignment of the type. 10325 10326 elsif Known_Static_Esize (Entity (Expr)) 10327 and then 10328 (UI_To_Int (Esize (Entity (Expr))) mod 10329 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)) 10330 /= 0 10331 then 10332 Set_Result (Unknown); 10333 10334 -- Otherwise same type is decisive 10335 10336 else 10337 Set_Result (Known_Compatible); 10338 end if; 10339 end if; 10340 10341 -- Another case to deal with is when there is an explicit size or 10342 -- alignment clause when the types are not the same. If so, then the 10343 -- result is Unknown. We don't need to do this test if the Default is 10344 -- Unknown, since that result will be set in any case. 10345 10346 elsif Default /= Unknown 10347 and then (Has_Size_Clause (Etype (Expr)) 10348 or else 10349 Has_Alignment_Clause (Etype (Expr))) 10350 then 10351 Set_Result (Unknown); 10352 10353 -- If no indication found, set default 10354 10355 else 10356 Set_Result (Default); 10357 end if; 10358 10359 -- Return worst result found 10360 10361 return Result; 10362 end Has_Compatible_Alignment_Internal; 10363 10364 -- Start of processing for Has_Compatible_Alignment 10365 10366 begin 10367 -- If Obj has no specified alignment, then set alignment from the type 10368 -- alignment. Perhaps we should always do this, but for sure we should 10369 -- do it when there is an address clause since we can do more if the 10370 -- alignment is known. 10371 10372 if Unknown_Alignment (Obj) then 10373 Set_Alignment (Obj, Alignment (Etype (Obj))); 10374 end if; 10375 10376 -- Now do the internal call that does all the work 10377 10378 return 10379 Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown); 10380 end Has_Compatible_Alignment; 10381 10382 ---------------------- 10383 -- Has_Declarations -- 10384 ---------------------- 10385 10386 function Has_Declarations (N : Node_Id) return Boolean is 10387 begin 10388 return Nkind_In (Nkind (N), N_Accept_Statement, 10389 N_Block_Statement, 10390 N_Compilation_Unit_Aux, 10391 N_Entry_Body, 10392 N_Package_Body, 10393 N_Protected_Body, 10394 N_Subprogram_Body, 10395 N_Task_Body, 10396 N_Package_Specification); 10397 end Has_Declarations; 10398 10399 --------------------------------- 10400 -- Has_Defaulted_Discriminants -- 10401 --------------------------------- 10402 10403 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is 10404 begin 10405 return Has_Discriminants (Typ) 10406 and then Present (First_Discriminant (Typ)) 10407 and then Present (Discriminant_Default_Value 10408 (First_Discriminant (Typ))); 10409 end Has_Defaulted_Discriminants; 10410 10411 ------------------- 10412 -- Has_Denormals -- 10413 ------------------- 10414 10415 function Has_Denormals (E : Entity_Id) return Boolean is 10416 begin 10417 return Is_Floating_Point_Type (E) and then Denorm_On_Target; 10418 end Has_Denormals; 10419 10420 ------------------------------------------- 10421 -- Has_Discriminant_Dependent_Constraint -- 10422 ------------------------------------------- 10423 10424 function Has_Discriminant_Dependent_Constraint 10425 (Comp : Entity_Id) return Boolean 10426 is 10427 Comp_Decl : constant Node_Id := Parent (Comp); 10428 Subt_Indic : Node_Id; 10429 Constr : Node_Id; 10430 Assn : Node_Id; 10431 10432 begin 10433 -- Discriminants can't depend on discriminants 10434 10435 if Ekind (Comp) = E_Discriminant then 10436 return False; 10437 10438 else 10439 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl)); 10440 10441 if Nkind (Subt_Indic) = N_Subtype_Indication then 10442 Constr := Constraint (Subt_Indic); 10443 10444 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then 10445 Assn := First (Constraints (Constr)); 10446 while Present (Assn) loop 10447 case Nkind (Assn) is 10448 when N_Identifier 10449 | N_Range 10450 | N_Subtype_Indication 10451 => 10452 if Depends_On_Discriminant (Assn) then 10453 return True; 10454 end if; 10455 10456 when N_Discriminant_Association => 10457 if Depends_On_Discriminant (Expression (Assn)) then 10458 return True; 10459 end if; 10460 10461 when others => 10462 null; 10463 end case; 10464 10465 Next (Assn); 10466 end loop; 10467 end if; 10468 end if; 10469 end if; 10470 10471 return False; 10472 end Has_Discriminant_Dependent_Constraint; 10473 10474 -------------------------------------- 10475 -- Has_Effectively_Volatile_Profile -- 10476 -------------------------------------- 10477 10478 function Has_Effectively_Volatile_Profile 10479 (Subp_Id : Entity_Id) return Boolean 10480 is 10481 Formal : Entity_Id; 10482 10483 begin 10484 -- Inspect the formal parameters looking for an effectively volatile 10485 -- type. 10486 10487 Formal := First_Formal (Subp_Id); 10488 while Present (Formal) loop 10489 if Is_Effectively_Volatile (Etype (Formal)) then 10490 return True; 10491 end if; 10492 10493 Next_Formal (Formal); 10494 end loop; 10495 10496 -- Inspect the return type of functions 10497 10498 if Ekind_In (Subp_Id, E_Function, E_Generic_Function) 10499 and then Is_Effectively_Volatile (Etype (Subp_Id)) 10500 then 10501 return True; 10502 end if; 10503 10504 return False; 10505 end Has_Effectively_Volatile_Profile; 10506 10507 -------------------------- 10508 -- Has_Enabled_Property -- 10509 -------------------------- 10510 10511 function Has_Enabled_Property 10512 (Item_Id : Entity_Id; 10513 Property : Name_Id) return Boolean 10514 is 10515 function Protected_Object_Has_Enabled_Property return Boolean; 10516 -- Determine whether a protected object denoted by Item_Id has the 10517 -- property enabled. 10518 10519 function State_Has_Enabled_Property return Boolean; 10520 -- Determine whether a state denoted by Item_Id has the property enabled 10521 10522 function Variable_Has_Enabled_Property return Boolean; 10523 -- Determine whether a variable denoted by Item_Id has the property 10524 -- enabled. 10525 10526 ------------------------------------------- 10527 -- Protected_Object_Has_Enabled_Property -- 10528 ------------------------------------------- 10529 10530 function Protected_Object_Has_Enabled_Property return Boolean is 10531 Constits : constant Elist_Id := Part_Of_Constituents (Item_Id); 10532 Constit_Elmt : Elmt_Id; 10533 Constit_Id : Entity_Id; 10534 10535 begin 10536 -- Protected objects always have the properties Async_Readers and 10537 -- Async_Writers (SPARK RM 7.1.2(16)). 10538 10539 if Property = Name_Async_Readers 10540 or else Property = Name_Async_Writers 10541 then 10542 return True; 10543 10544 -- Protected objects that have Part_Of components also inherit their 10545 -- properties Effective_Reads and Effective_Writes 10546 -- (SPARK RM 7.1.2(16)). 10547 10548 elsif Present (Constits) then 10549 Constit_Elmt := First_Elmt (Constits); 10550 while Present (Constit_Elmt) loop 10551 Constit_Id := Node (Constit_Elmt); 10552 10553 if Has_Enabled_Property (Constit_Id, Property) then 10554 return True; 10555 end if; 10556 10557 Next_Elmt (Constit_Elmt); 10558 end loop; 10559 end if; 10560 10561 return False; 10562 end Protected_Object_Has_Enabled_Property; 10563 10564 -------------------------------- 10565 -- State_Has_Enabled_Property -- 10566 -------------------------------- 10567 10568 function State_Has_Enabled_Property return Boolean is 10569 Decl : constant Node_Id := Parent (Item_Id); 10570 10571 procedure Find_Simple_Properties 10572 (Has_External : out Boolean; 10573 Has_Synchronous : out Boolean); 10574 -- Extract the simple properties associated with declaration Decl 10575 10576 function Is_Enabled_External_Property return Boolean; 10577 -- Determine whether property Property appears within the external 10578 -- property list of declaration Decl, and return its status. 10579 10580 ---------------------------- 10581 -- Find_Simple_Properties -- 10582 ---------------------------- 10583 10584 procedure Find_Simple_Properties 10585 (Has_External : out Boolean; 10586 Has_Synchronous : out Boolean) 10587 is 10588 Opt : Node_Id; 10589 10590 begin 10591 -- Assume that none of the properties are available 10592 10593 Has_External := False; 10594 Has_Synchronous := False; 10595 10596 Opt := First (Expressions (Decl)); 10597 while Present (Opt) loop 10598 if Nkind (Opt) = N_Identifier then 10599 if Chars (Opt) = Name_External then 10600 Has_External := True; 10601 10602 elsif Chars (Opt) = Name_Synchronous then 10603 Has_Synchronous := True; 10604 end if; 10605 end if; 10606 10607 Next (Opt); 10608 end loop; 10609 end Find_Simple_Properties; 10610 10611 ---------------------------------- 10612 -- Is_Enabled_External_Property -- 10613 ---------------------------------- 10614 10615 function Is_Enabled_External_Property return Boolean is 10616 Opt : Node_Id; 10617 Opt_Nam : Node_Id; 10618 Prop : Node_Id; 10619 Prop_Nam : Node_Id; 10620 Props : Node_Id; 10621 10622 begin 10623 Opt := First (Component_Associations (Decl)); 10624 while Present (Opt) loop 10625 Opt_Nam := First (Choices (Opt)); 10626 10627 if Nkind (Opt_Nam) = N_Identifier 10628 and then Chars (Opt_Nam) = Name_External 10629 then 10630 Props := Expression (Opt); 10631 10632 -- Multiple properties appear as an aggregate 10633 10634 if Nkind (Props) = N_Aggregate then 10635 10636 -- Simple property form 10637 10638 Prop := First (Expressions (Props)); 10639 while Present (Prop) loop 10640 if Chars (Prop) = Property then 10641 return True; 10642 end if; 10643 10644 Next (Prop); 10645 end loop; 10646 10647 -- Property with expression form 10648 10649 Prop := First (Component_Associations (Props)); 10650 while Present (Prop) loop 10651 Prop_Nam := First (Choices (Prop)); 10652 10653 -- The property can be represented in two ways: 10654 -- others => <value> 10655 -- <property> => <value> 10656 10657 if Nkind (Prop_Nam) = N_Others_Choice 10658 or else (Nkind (Prop_Nam) = N_Identifier 10659 and then Chars (Prop_Nam) = Property) 10660 then 10661 return Is_True (Expr_Value (Expression (Prop))); 10662 end if; 10663 10664 Next (Prop); 10665 end loop; 10666 10667 -- Single property 10668 10669 else 10670 return Chars (Props) = Property; 10671 end if; 10672 end if; 10673 10674 Next (Opt); 10675 end loop; 10676 10677 return False; 10678 end Is_Enabled_External_Property; 10679 10680 -- Local variables 10681 10682 Has_External : Boolean; 10683 Has_Synchronous : Boolean; 10684 10685 -- Start of processing for State_Has_Enabled_Property 10686 10687 begin 10688 -- The declaration of an external abstract state appears as an 10689 -- extension aggregate. If this is not the case, properties can 10690 -- never be set. 10691 10692 if Nkind (Decl) /= N_Extension_Aggregate then 10693 return False; 10694 end if; 10695 10696 Find_Simple_Properties (Has_External, Has_Synchronous); 10697 10698 -- Simple option External enables all properties (SPARK RM 7.1.2(2)) 10699 10700 if Has_External then 10701 return True; 10702 10703 -- Option External may enable or disable specific properties 10704 10705 elsif Is_Enabled_External_Property then 10706 return True; 10707 10708 -- Simple option Synchronous 10709 -- 10710 -- enables disables 10711 -- Asynch_Readers Effective_Reads 10712 -- Asynch_Writers Effective_Writes 10713 -- 10714 -- Note that both forms of External have higher precedence than 10715 -- Synchronous (SPARK RM 7.1.4(10)). 10716 10717 elsif Has_Synchronous then 10718 return Nam_In (Property, Name_Async_Readers, Name_Async_Writers); 10719 end if; 10720 10721 return False; 10722 end State_Has_Enabled_Property; 10723 10724 ----------------------------------- 10725 -- Variable_Has_Enabled_Property -- 10726 ----------------------------------- 10727 10728 function Variable_Has_Enabled_Property return Boolean is 10729 function Is_Enabled (Prag : Node_Id) return Boolean; 10730 -- Determine whether property pragma Prag (if present) denotes an 10731 -- enabled property. 10732 10733 ---------------- 10734 -- Is_Enabled -- 10735 ---------------- 10736 10737 function Is_Enabled (Prag : Node_Id) return Boolean is 10738 Arg1 : Node_Id; 10739 10740 begin 10741 if Present (Prag) then 10742 Arg1 := First (Pragma_Argument_Associations (Prag)); 10743 10744 -- The pragma has an optional Boolean expression, the related 10745 -- property is enabled only when the expression evaluates to 10746 -- True. 10747 10748 if Present (Arg1) then 10749 return Is_True (Expr_Value (Get_Pragma_Arg (Arg1))); 10750 10751 -- Otherwise the lack of expression enables the property by 10752 -- default. 10753 10754 else 10755 return True; 10756 end if; 10757 10758 -- The property was never set in the first place 10759 10760 else 10761 return False; 10762 end if; 10763 end Is_Enabled; 10764 10765 -- Local variables 10766 10767 AR : constant Node_Id := 10768 Get_Pragma (Item_Id, Pragma_Async_Readers); 10769 AW : constant Node_Id := 10770 Get_Pragma (Item_Id, Pragma_Async_Writers); 10771 ER : constant Node_Id := 10772 Get_Pragma (Item_Id, Pragma_Effective_Reads); 10773 EW : constant Node_Id := 10774 Get_Pragma (Item_Id, Pragma_Effective_Writes); 10775 10776 -- Start of processing for Variable_Has_Enabled_Property 10777 10778 begin 10779 -- A non-effectively volatile object can never possess external 10780 -- properties. 10781 10782 if not Is_Effectively_Volatile (Item_Id) then 10783 return False; 10784 10785 -- External properties related to variables come in two flavors - 10786 -- explicit and implicit. The explicit case is characterized by the 10787 -- presence of a property pragma with an optional Boolean flag. The 10788 -- property is enabled when the flag evaluates to True or the flag is 10789 -- missing altogether. 10790 10791 elsif Property = Name_Async_Readers and then Is_Enabled (AR) then 10792 return True; 10793 10794 elsif Property = Name_Async_Writers and then Is_Enabled (AW) then 10795 return True; 10796 10797 elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then 10798 return True; 10799 10800 elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then 10801 return True; 10802 10803 -- The implicit case lacks all property pragmas 10804 10805 elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then 10806 if Is_Protected_Type (Etype (Item_Id)) then 10807 return Protected_Object_Has_Enabled_Property; 10808 else 10809 return True; 10810 end if; 10811 10812 else 10813 return False; 10814 end if; 10815 end Variable_Has_Enabled_Property; 10816 10817 -- Start of processing for Has_Enabled_Property 10818 10819 begin 10820 -- Abstract states and variables have a flexible scheme of specifying 10821 -- external properties. 10822 10823 if Ekind (Item_Id) = E_Abstract_State then 10824 return State_Has_Enabled_Property; 10825 10826 elsif Ekind (Item_Id) = E_Variable then 10827 return Variable_Has_Enabled_Property; 10828 10829 -- By default, protected objects only have the properties Async_Readers 10830 -- and Async_Writers. If they have Part_Of components, they also inherit 10831 -- their properties Effective_Reads and Effective_Writes 10832 -- (SPARK RM 7.1.2(16)). 10833 10834 elsif Ekind (Item_Id) = E_Protected_Object then 10835 return Protected_Object_Has_Enabled_Property; 10836 10837 -- Otherwise a property is enabled when the related item is effectively 10838 -- volatile. 10839 10840 else 10841 return Is_Effectively_Volatile (Item_Id); 10842 end if; 10843 end Has_Enabled_Property; 10844 10845 ------------------------------------- 10846 -- Has_Full_Default_Initialization -- 10847 ------------------------------------- 10848 10849 function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is 10850 Comp : Entity_Id; 10851 10852 begin 10853 -- A type subject to pragma Default_Initial_Condition may be fully 10854 -- default initialized depending on inheritance and the argument of 10855 -- the pragma. Since any type may act as the full view of a private 10856 -- type, this check must be performed prior to the specialized tests 10857 -- below. 10858 10859 if Has_Fully_Default_Initializing_DIC_Pragma (Typ) then 10860 return True; 10861 end if; 10862 10863 -- A scalar type is fully default initialized if it is subject to aspect 10864 -- Default_Value. 10865 10866 if Is_Scalar_Type (Typ) then 10867 return Has_Default_Aspect (Typ); 10868 10869 -- An access type is fully default initialized by default 10870 10871 elsif Is_Access_Type (Typ) then 10872 return True; 10873 10874 -- An array type is fully default initialized if its element type is 10875 -- scalar and the array type carries aspect Default_Component_Value or 10876 -- the element type is fully default initialized. 10877 10878 elsif Is_Array_Type (Typ) then 10879 return 10880 Has_Default_Aspect (Typ) 10881 or else Has_Full_Default_Initialization (Component_Type (Typ)); 10882 10883 -- A protected type, record type, or type extension is fully default 10884 -- initialized if all its components either carry an initialization 10885 -- expression or have a type that is fully default initialized. The 10886 -- parent type of a type extension must be fully default initialized. 10887 10888 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then 10889 10890 -- Inspect all entities defined in the scope of the type, looking for 10891 -- uninitialized components. 10892 10893 Comp := First_Entity (Typ); 10894 while Present (Comp) loop 10895 if Ekind (Comp) = E_Component 10896 and then Comes_From_Source (Comp) 10897 and then No (Expression (Parent (Comp))) 10898 and then not Has_Full_Default_Initialization (Etype (Comp)) 10899 then 10900 return False; 10901 end if; 10902 10903 Next_Entity (Comp); 10904 end loop; 10905 10906 -- Ensure that the parent type of a type extension is fully default 10907 -- initialized. 10908 10909 if Etype (Typ) /= Typ 10910 and then not Has_Full_Default_Initialization (Etype (Typ)) 10911 then 10912 return False; 10913 end if; 10914 10915 -- If we get here, then all components and parent portion are fully 10916 -- default initialized. 10917 10918 return True; 10919 10920 -- A task type is fully default initialized by default 10921 10922 elsif Is_Task_Type (Typ) then 10923 return True; 10924 10925 -- Otherwise the type is not fully default initialized 10926 10927 else 10928 return False; 10929 end if; 10930 end Has_Full_Default_Initialization; 10931 10932 ----------------------------------------------- 10933 -- Has_Fully_Default_Initializing_DIC_Pragma -- 10934 ----------------------------------------------- 10935 10936 function Has_Fully_Default_Initializing_DIC_Pragma 10937 (Typ : Entity_Id) return Boolean 10938 is 10939 Args : List_Id; 10940 Prag : Node_Id; 10941 10942 begin 10943 -- A type that inherits pragma Default_Initial_Condition from a parent 10944 -- type is automatically fully default initialized. 10945 10946 if Has_Inherited_DIC (Typ) then 10947 return True; 10948 10949 -- Otherwise the type is fully default initialized only when the pragma 10950 -- appears without an argument, or the argument is non-null. 10951 10952 elsif Has_Own_DIC (Typ) then 10953 Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition); 10954 pragma Assert (Present (Prag)); 10955 Args := Pragma_Argument_Associations (Prag); 10956 10957 -- The pragma appears without an argument in which case it defaults 10958 -- to True. 10959 10960 if No (Args) then 10961 return True; 10962 10963 -- The pragma appears with a non-null expression 10964 10965 elsif Nkind (Get_Pragma_Arg (First (Args))) /= N_Null then 10966 return True; 10967 end if; 10968 end if; 10969 10970 return False; 10971 end Has_Fully_Default_Initializing_DIC_Pragma; 10972 10973 -------------------- 10974 -- Has_Infinities -- 10975 -------------------- 10976 10977 function Has_Infinities (E : Entity_Id) return Boolean is 10978 begin 10979 return 10980 Is_Floating_Point_Type (E) 10981 and then Nkind (Scalar_Range (E)) = N_Range 10982 and then Includes_Infinities (Scalar_Range (E)); 10983 end Has_Infinities; 10984 10985 -------------------- 10986 -- Has_Interfaces -- 10987 -------------------- 10988 10989 function Has_Interfaces 10990 (T : Entity_Id; 10991 Use_Full_View : Boolean := True) return Boolean 10992 is 10993 Typ : Entity_Id := Base_Type (T); 10994 10995 begin 10996 -- Handle concurrent types 10997 10998 if Is_Concurrent_Type (Typ) then 10999 Typ := Corresponding_Record_Type (Typ); 11000 end if; 11001 11002 if not Present (Typ) 11003 or else not Is_Record_Type (Typ) 11004 or else not Is_Tagged_Type (Typ) 11005 then 11006 return False; 11007 end if; 11008 11009 -- Handle private types 11010 11011 if Use_Full_View and then Present (Full_View (Typ)) then 11012 Typ := Full_View (Typ); 11013 end if; 11014 11015 -- Handle concurrent record types 11016 11017 if Is_Concurrent_Record_Type (Typ) 11018 and then Is_Non_Empty_List (Abstract_Interface_List (Typ)) 11019 then 11020 return True; 11021 end if; 11022 11023 loop 11024 if Is_Interface (Typ) 11025 or else 11026 (Is_Record_Type (Typ) 11027 and then Present (Interfaces (Typ)) 11028 and then not Is_Empty_Elmt_List (Interfaces (Typ))) 11029 then 11030 return True; 11031 end if; 11032 11033 exit when Etype (Typ) = Typ 11034 11035 -- Handle private types 11036 11037 or else (Present (Full_View (Etype (Typ))) 11038 and then Full_View (Etype (Typ)) = Typ) 11039 11040 -- Protect frontend against wrong sources with cyclic derivations 11041 11042 or else Etype (Typ) = T; 11043 11044 -- Climb to the ancestor type handling private types 11045 11046 if Present (Full_View (Etype (Typ))) then 11047 Typ := Full_View (Etype (Typ)); 11048 else 11049 Typ := Etype (Typ); 11050 end if; 11051 end loop; 11052 11053 return False; 11054 end Has_Interfaces; 11055 11056 -------------------------- 11057 -- Has_Max_Queue_Length -- 11058 -------------------------- 11059 11060 function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is 11061 begin 11062 return 11063 Ekind (Id) = E_Entry 11064 and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length)); 11065 end Has_Max_Queue_Length; 11066 11067 --------------------------------- 11068 -- Has_No_Obvious_Side_Effects -- 11069 --------------------------------- 11070 11071 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is 11072 begin 11073 -- For now handle literals, constants, and non-volatile variables and 11074 -- expressions combining these with operators or short circuit forms. 11075 11076 if Nkind (N) in N_Numeric_Or_String_Literal then 11077 return True; 11078 11079 elsif Nkind (N) = N_Character_Literal then 11080 return True; 11081 11082 elsif Nkind (N) in N_Unary_Op then 11083 return Has_No_Obvious_Side_Effects (Right_Opnd (N)); 11084 11085 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then 11086 return Has_No_Obvious_Side_Effects (Left_Opnd (N)) 11087 and then 11088 Has_No_Obvious_Side_Effects (Right_Opnd (N)); 11089 11090 elsif Nkind (N) = N_Expression_With_Actions 11091 and then Is_Empty_List (Actions (N)) 11092 then 11093 return Has_No_Obvious_Side_Effects (Expression (N)); 11094 11095 elsif Nkind (N) in N_Has_Entity then 11096 return Present (Entity (N)) 11097 and then Ekind_In (Entity (N), E_Variable, 11098 E_Constant, 11099 E_Enumeration_Literal, 11100 E_In_Parameter, 11101 E_Out_Parameter, 11102 E_In_Out_Parameter) 11103 and then not Is_Volatile (Entity (N)); 11104 11105 else 11106 return False; 11107 end if; 11108 end Has_No_Obvious_Side_Effects; 11109 11110 ----------------------------- 11111 -- Has_Non_Null_Refinement -- 11112 ----------------------------- 11113 11114 function Has_Non_Null_Refinement (Id : Entity_Id) return Boolean is 11115 Constits : Elist_Id; 11116 11117 begin 11118 pragma Assert (Ekind (Id) = E_Abstract_State); 11119 Constits := Refinement_Constituents (Id); 11120 11121 -- For a refinement to be non-null, the first constituent must be 11122 -- anything other than null. 11123 11124 return 11125 Present (Constits) 11126 and then Nkind (Node (First_Elmt (Constits))) /= N_Null; 11127 end Has_Non_Null_Refinement; 11128 11129 ----------------------------- 11130 -- Has_Non_Null_Statements -- 11131 ----------------------------- 11132 11133 function Has_Non_Null_Statements (L : List_Id) return Boolean is 11134 Node : Node_Id; 11135 11136 begin 11137 if Is_Non_Empty_List (L) then 11138 Node := First (L); 11139 11140 loop 11141 if Nkind (Node) /= N_Null_Statement then 11142 return True; 11143 end if; 11144 11145 Next (Node); 11146 exit when Node = Empty; 11147 end loop; 11148 end if; 11149 11150 return False; 11151 end Has_Non_Null_Statements; 11152 11153 ---------------------------------- 11154 -- Has_Non_Trivial_Precondition -- 11155 ---------------------------------- 11156 11157 function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is 11158 Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre); 11159 11160 begin 11161 return 11162 Present (Pre) 11163 and then Class_Present (Pre) 11164 and then not Is_Entity_Name (Expression (Pre)); 11165 end Has_Non_Trivial_Precondition; 11166 11167 ------------------- 11168 -- Has_Null_Body -- 11169 ------------------- 11170 11171 function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is 11172 Body_Id : Entity_Id; 11173 Decl : Node_Id; 11174 Spec : Node_Id; 11175 Stmt1 : Node_Id; 11176 Stmt2 : Node_Id; 11177 11178 begin 11179 Spec := Parent (Proc_Id); 11180 Decl := Parent (Spec); 11181 11182 -- Retrieve the entity of the procedure body (e.g. invariant proc). 11183 11184 if Nkind (Spec) = N_Procedure_Specification 11185 and then Nkind (Decl) = N_Subprogram_Declaration 11186 then 11187 Body_Id := Corresponding_Body (Decl); 11188 11189 -- The body acts as a spec 11190 11191 else 11192 Body_Id := Proc_Id; 11193 end if; 11194 11195 -- The body will be generated later 11196 11197 if No (Body_Id) then 11198 return False; 11199 end if; 11200 11201 Spec := Parent (Body_Id); 11202 Decl := Parent (Spec); 11203 11204 pragma Assert 11205 (Nkind (Spec) = N_Procedure_Specification 11206 and then Nkind (Decl) = N_Subprogram_Body); 11207 11208 Stmt1 := First (Statements (Handled_Statement_Sequence (Decl))); 11209 11210 -- Look for a null statement followed by an optional return 11211 -- statement. 11212 11213 if Nkind (Stmt1) = N_Null_Statement then 11214 Stmt2 := Next (Stmt1); 11215 11216 if Present (Stmt2) then 11217 return Nkind (Stmt2) = N_Simple_Return_Statement; 11218 else 11219 return True; 11220 end if; 11221 end if; 11222 11223 return False; 11224 end Has_Null_Body; 11225 11226 ------------------------ 11227 -- Has_Null_Exclusion -- 11228 ------------------------ 11229 11230 function Has_Null_Exclusion (N : Node_Id) return Boolean is 11231 begin 11232 case Nkind (N) is 11233 when N_Access_Definition 11234 | N_Access_Function_Definition 11235 | N_Access_Procedure_Definition 11236 | N_Access_To_Object_Definition 11237 | N_Allocator 11238 | N_Derived_Type_Definition 11239 | N_Function_Specification 11240 | N_Subtype_Declaration 11241 => 11242 return Null_Exclusion_Present (N); 11243 11244 when N_Component_Definition 11245 | N_Formal_Object_Declaration 11246 | N_Object_Renaming_Declaration 11247 => 11248 if Present (Subtype_Mark (N)) then 11249 return Null_Exclusion_Present (N); 11250 else pragma Assert (Present (Access_Definition (N))); 11251 return Null_Exclusion_Present (Access_Definition (N)); 11252 end if; 11253 11254 when N_Discriminant_Specification => 11255 if Nkind (Discriminant_Type (N)) = N_Access_Definition then 11256 return Null_Exclusion_Present (Discriminant_Type (N)); 11257 else 11258 return Null_Exclusion_Present (N); 11259 end if; 11260 11261 when N_Object_Declaration => 11262 if Nkind (Object_Definition (N)) = N_Access_Definition then 11263 return Null_Exclusion_Present (Object_Definition (N)); 11264 else 11265 return Null_Exclusion_Present (N); 11266 end if; 11267 11268 when N_Parameter_Specification => 11269 if Nkind (Parameter_Type (N)) = N_Access_Definition then 11270 return Null_Exclusion_Present (Parameter_Type (N)); 11271 else 11272 return Null_Exclusion_Present (N); 11273 end if; 11274 11275 when others => 11276 return False; 11277 end case; 11278 end Has_Null_Exclusion; 11279 11280 ------------------------ 11281 -- Has_Null_Extension -- 11282 ------------------------ 11283 11284 function Has_Null_Extension (T : Entity_Id) return Boolean is 11285 B : constant Entity_Id := Base_Type (T); 11286 Comps : Node_Id; 11287 Ext : Node_Id; 11288 11289 begin 11290 if Nkind (Parent (B)) = N_Full_Type_Declaration 11291 and then Present (Record_Extension_Part (Type_Definition (Parent (B)))) 11292 then 11293 Ext := Record_Extension_Part (Type_Definition (Parent (B))); 11294 11295 if Present (Ext) then 11296 if Null_Present (Ext) then 11297 return True; 11298 else 11299 Comps := Component_List (Ext); 11300 11301 -- The null component list is rewritten during analysis to 11302 -- include the parent component. Any other component indicates 11303 -- that the extension was not originally null. 11304 11305 return Null_Present (Comps) 11306 or else No (Next (First (Component_Items (Comps)))); 11307 end if; 11308 else 11309 return False; 11310 end if; 11311 11312 else 11313 return False; 11314 end if; 11315 end Has_Null_Extension; 11316 11317 ------------------------- 11318 -- Has_Null_Refinement -- 11319 ------------------------- 11320 11321 function Has_Null_Refinement (Id : Entity_Id) return Boolean is 11322 Constits : Elist_Id; 11323 11324 begin 11325 pragma Assert (Ekind (Id) = E_Abstract_State); 11326 Constits := Refinement_Constituents (Id); 11327 11328 -- For a refinement to be null, the state's sole constituent must be a 11329 -- null. 11330 11331 return 11332 Present (Constits) 11333 and then Nkind (Node (First_Elmt (Constits))) = N_Null; 11334 end Has_Null_Refinement; 11335 11336 ------------------------------- 11337 -- Has_Overriding_Initialize -- 11338 ------------------------------- 11339 11340 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is 11341 BT : constant Entity_Id := Base_Type (T); 11342 P : Elmt_Id; 11343 11344 begin 11345 if Is_Controlled (BT) then 11346 if Is_RTU (Scope (BT), Ada_Finalization) then 11347 return False; 11348 11349 elsif Present (Primitive_Operations (BT)) then 11350 P := First_Elmt (Primitive_Operations (BT)); 11351 while Present (P) loop 11352 declare 11353 Init : constant Entity_Id := Node (P); 11354 Formal : constant Entity_Id := First_Formal (Init); 11355 begin 11356 if Ekind (Init) = E_Procedure 11357 and then Chars (Init) = Name_Initialize 11358 and then Comes_From_Source (Init) 11359 and then Present (Formal) 11360 and then Etype (Formal) = BT 11361 and then No (Next_Formal (Formal)) 11362 and then (Ada_Version < Ada_2012 11363 or else not Null_Present (Parent (Init))) 11364 then 11365 return True; 11366 end if; 11367 end; 11368 11369 Next_Elmt (P); 11370 end loop; 11371 end if; 11372 11373 -- Here if type itself does not have a non-null Initialize operation: 11374 -- check immediate ancestor. 11375 11376 if Is_Derived_Type (BT) 11377 and then Has_Overriding_Initialize (Etype (BT)) 11378 then 11379 return True; 11380 end if; 11381 end if; 11382 11383 return False; 11384 end Has_Overriding_Initialize; 11385 11386 -------------------------------------- 11387 -- Has_Preelaborable_Initialization -- 11388 -------------------------------------- 11389 11390 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is 11391 Has_PE : Boolean; 11392 11393 procedure Check_Components (E : Entity_Id); 11394 -- Check component/discriminant chain, sets Has_PE False if a component 11395 -- or discriminant does not meet the preelaborable initialization rules. 11396 11397 ---------------------- 11398 -- Check_Components -- 11399 ---------------------- 11400 11401 procedure Check_Components (E : Entity_Id) is 11402 Ent : Entity_Id; 11403 Exp : Node_Id; 11404 11405 begin 11406 -- Loop through entities of record or protected type 11407 11408 Ent := E; 11409 while Present (Ent) loop 11410 11411 -- We are interested only in components and discriminants 11412 11413 Exp := Empty; 11414 11415 case Ekind (Ent) is 11416 when E_Component => 11417 11418 -- Get default expression if any. If there is no declaration 11419 -- node, it means we have an internal entity. The parent and 11420 -- tag fields are examples of such entities. For such cases, 11421 -- we just test the type of the entity. 11422 11423 if Present (Declaration_Node (Ent)) then 11424 Exp := Expression (Declaration_Node (Ent)); 11425 end if; 11426 11427 when E_Discriminant => 11428 11429 -- Note: for a renamed discriminant, the Declaration_Node 11430 -- may point to the one from the ancestor, and have a 11431 -- different expression, so use the proper attribute to 11432 -- retrieve the expression from the derived constraint. 11433 11434 Exp := Discriminant_Default_Value (Ent); 11435 11436 when others => 11437 goto Check_Next_Entity; 11438 end case; 11439 11440 -- A component has PI if it has no default expression and the 11441 -- component type has PI. 11442 11443 if No (Exp) then 11444 if not Has_Preelaborable_Initialization (Etype (Ent)) then 11445 Has_PE := False; 11446 exit; 11447 end if; 11448 11449 -- Require the default expression to be preelaborable 11450 11451 elsif not Is_Preelaborable_Construct (Exp) then 11452 Has_PE := False; 11453 exit; 11454 end if; 11455 11456 <<Check_Next_Entity>> 11457 Next_Entity (Ent); 11458 end loop; 11459 end Check_Components; 11460 11461 -- Start of processing for Has_Preelaborable_Initialization 11462 11463 begin 11464 -- Immediate return if already marked as known preelaborable init. This 11465 -- covers types for which this function has already been called once 11466 -- and returned True (in which case the result is cached), and also 11467 -- types to which a pragma Preelaborable_Initialization applies. 11468 11469 if Known_To_Have_Preelab_Init (E) then 11470 return True; 11471 end if; 11472 11473 -- If the type is a subtype representing a generic actual type, then 11474 -- test whether its base type has preelaborable initialization since 11475 -- the subtype representing the actual does not inherit this attribute 11476 -- from the actual or formal. (but maybe it should???) 11477 11478 if Is_Generic_Actual_Type (E) then 11479 return Has_Preelaborable_Initialization (Base_Type (E)); 11480 end if; 11481 11482 -- All elementary types have preelaborable initialization 11483 11484 if Is_Elementary_Type (E) then 11485 Has_PE := True; 11486 11487 -- Array types have PI if the component type has PI 11488 11489 elsif Is_Array_Type (E) then 11490 Has_PE := Has_Preelaborable_Initialization (Component_Type (E)); 11491 11492 -- A derived type has preelaborable initialization if its parent type 11493 -- has preelaborable initialization and (in the case of a derived record 11494 -- extension) if the non-inherited components all have preelaborable 11495 -- initialization. However, a user-defined controlled type with an 11496 -- overriding Initialize procedure does not have preelaborable 11497 -- initialization. 11498 11499 elsif Is_Derived_Type (E) then 11500 11501 -- If the derived type is a private extension then it doesn't have 11502 -- preelaborable initialization. 11503 11504 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then 11505 return False; 11506 end if; 11507 11508 -- First check whether ancestor type has preelaborable initialization 11509 11510 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E))); 11511 11512 -- If OK, check extension components (if any) 11513 11514 if Has_PE and then Is_Record_Type (E) then 11515 Check_Components (First_Entity (E)); 11516 end if; 11517 11518 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type 11519 -- with a user defined Initialize procedure does not have PI. If 11520 -- the type is untagged, the control primitives come from a component 11521 -- that has already been checked. 11522 11523 if Has_PE 11524 and then Is_Controlled (E) 11525 and then Is_Tagged_Type (E) 11526 and then Has_Overriding_Initialize (E) 11527 then 11528 Has_PE := False; 11529 end if; 11530 11531 -- Private types not derived from a type having preelaborable init and 11532 -- that are not marked with pragma Preelaborable_Initialization do not 11533 -- have preelaborable initialization. 11534 11535 elsif Is_Private_Type (E) then 11536 return False; 11537 11538 -- Record type has PI if it is non private and all components have PI 11539 11540 elsif Is_Record_Type (E) then 11541 Has_PE := True; 11542 Check_Components (First_Entity (E)); 11543 11544 -- Protected types must not have entries, and components must meet 11545 -- same set of rules as for record components. 11546 11547 elsif Is_Protected_Type (E) then 11548 if Has_Entries (E) then 11549 Has_PE := False; 11550 else 11551 Has_PE := True; 11552 Check_Components (First_Entity (E)); 11553 Check_Components (First_Private_Entity (E)); 11554 end if; 11555 11556 -- Type System.Address always has preelaborable initialization 11557 11558 elsif Is_RTE (E, RE_Address) then 11559 Has_PE := True; 11560 11561 -- In all other cases, type does not have preelaborable initialization 11562 11563 else 11564 return False; 11565 end if; 11566 11567 -- If type has preelaborable initialization, cache result 11568 11569 if Has_PE then 11570 Set_Known_To_Have_Preelab_Init (E); 11571 end if; 11572 11573 return Has_PE; 11574 end Has_Preelaborable_Initialization; 11575 11576 ---------------- 11577 -- Has_Prefix -- 11578 ---------------- 11579 11580 function Has_Prefix (N : Node_Id) return Boolean is 11581 begin 11582 return 11583 Nkind_In (N, N_Attribute_Reference, 11584 N_Expanded_Name, 11585 N_Explicit_Dereference, 11586 N_Indexed_Component, 11587 N_Reference, 11588 N_Selected_Component, 11589 N_Slice); 11590 end Has_Prefix; 11591 11592 --------------------------- 11593 -- Has_Private_Component -- 11594 --------------------------- 11595 11596 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is 11597 Btype : Entity_Id := Base_Type (Type_Id); 11598 Component : Entity_Id; 11599 11600 begin 11601 if Error_Posted (Type_Id) 11602 or else Error_Posted (Btype) 11603 then 11604 return False; 11605 end if; 11606 11607 if Is_Class_Wide_Type (Btype) then 11608 Btype := Root_Type (Btype); 11609 end if; 11610 11611 if Is_Private_Type (Btype) then 11612 declare 11613 UT : constant Entity_Id := Underlying_Type (Btype); 11614 begin 11615 if No (UT) then 11616 if No (Full_View (Btype)) then 11617 return not Is_Generic_Type (Btype) 11618 and then 11619 not Is_Generic_Type (Root_Type (Btype)); 11620 else 11621 return not Is_Generic_Type (Root_Type (Full_View (Btype))); 11622 end if; 11623 else 11624 return not Is_Frozen (UT) and then Has_Private_Component (UT); 11625 end if; 11626 end; 11627 11628 elsif Is_Array_Type (Btype) then 11629 return Has_Private_Component (Component_Type (Btype)); 11630 11631 elsif Is_Record_Type (Btype) then 11632 Component := First_Component (Btype); 11633 while Present (Component) loop 11634 if Has_Private_Component (Etype (Component)) then 11635 return True; 11636 end if; 11637 11638 Next_Component (Component); 11639 end loop; 11640 11641 return False; 11642 11643 elsif Is_Protected_Type (Btype) 11644 and then Present (Corresponding_Record_Type (Btype)) 11645 then 11646 return Has_Private_Component (Corresponding_Record_Type (Btype)); 11647 11648 else 11649 return False; 11650 end if; 11651 end Has_Private_Component; 11652 11653 ---------------------- 11654 -- Has_Signed_Zeros -- 11655 ---------------------- 11656 11657 function Has_Signed_Zeros (E : Entity_Id) return Boolean is 11658 begin 11659 return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target; 11660 end Has_Signed_Zeros; 11661 11662 ------------------------------ 11663 -- Has_Significant_Contract -- 11664 ------------------------------ 11665 11666 function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is 11667 Subp_Nam : constant Name_Id := Chars (Subp_Id); 11668 11669 begin 11670 -- _Finalizer procedure 11671 11672 if Subp_Nam = Name_uFinalizer then 11673 return False; 11674 11675 -- _Postconditions procedure 11676 11677 elsif Subp_Nam = Name_uPostconditions then 11678 return False; 11679 11680 -- Predicate function 11681 11682 elsif Ekind (Subp_Id) = E_Function 11683 and then Is_Predicate_Function (Subp_Id) 11684 then 11685 return False; 11686 11687 -- TSS subprogram 11688 11689 elsif Get_TSS_Name (Subp_Id) /= TSS_Null then 11690 return False; 11691 11692 else 11693 return True; 11694 end if; 11695 end Has_Significant_Contract; 11696 11697 ----------------------------- 11698 -- Has_Static_Array_Bounds -- 11699 ----------------------------- 11700 11701 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is 11702 All_Static : Boolean; 11703 Dummy : Boolean; 11704 11705 begin 11706 Examine_Array_Bounds (Typ, All_Static, Dummy); 11707 11708 return All_Static; 11709 end Has_Static_Array_Bounds; 11710 11711 --------------------------------------- 11712 -- Has_Static_Non_Empty_Array_Bounds -- 11713 --------------------------------------- 11714 11715 function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean is 11716 All_Static : Boolean; 11717 Has_Empty : Boolean; 11718 11719 begin 11720 Examine_Array_Bounds (Typ, All_Static, Has_Empty); 11721 11722 return All_Static and not Has_Empty; 11723 end Has_Static_Non_Empty_Array_Bounds; 11724 11725 ---------------- 11726 -- Has_Stream -- 11727 ---------------- 11728 11729 function Has_Stream (T : Entity_Id) return Boolean is 11730 E : Entity_Id; 11731 11732 begin 11733 if No (T) then 11734 return False; 11735 11736 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then 11737 return True; 11738 11739 elsif Is_Array_Type (T) then 11740 return Has_Stream (Component_Type (T)); 11741 11742 elsif Is_Record_Type (T) then 11743 E := First_Component (T); 11744 while Present (E) loop 11745 if Has_Stream (Etype (E)) then 11746 return True; 11747 else 11748 Next_Component (E); 11749 end if; 11750 end loop; 11751 11752 return False; 11753 11754 elsif Is_Private_Type (T) then 11755 return Has_Stream (Underlying_Type (T)); 11756 11757 else 11758 return False; 11759 end if; 11760 end Has_Stream; 11761 11762 ---------------- 11763 -- Has_Suffix -- 11764 ---------------- 11765 11766 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is 11767 begin 11768 Get_Name_String (Chars (E)); 11769 return Name_Buffer (Name_Len) = Suffix; 11770 end Has_Suffix; 11771 11772 ---------------- 11773 -- Add_Suffix -- 11774 ---------------- 11775 11776 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is 11777 begin 11778 Get_Name_String (Chars (E)); 11779 Add_Char_To_Name_Buffer (Suffix); 11780 return Name_Find; 11781 end Add_Suffix; 11782 11783 ------------------- 11784 -- Remove_Suffix -- 11785 ------------------- 11786 11787 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is 11788 begin 11789 pragma Assert (Has_Suffix (E, Suffix)); 11790 Get_Name_String (Chars (E)); 11791 Name_Len := Name_Len - 1; 11792 return Name_Find; 11793 end Remove_Suffix; 11794 11795 ---------------------------------- 11796 -- Replace_Null_By_Null_Address -- 11797 ---------------------------------- 11798 11799 procedure Replace_Null_By_Null_Address (N : Node_Id) is 11800 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id); 11801 -- Replace operand Op with a reference to Null_Address when the operand 11802 -- denotes a null Address. Other_Op denotes the other operand. 11803 11804 -------------------------- 11805 -- Replace_Null_Operand -- 11806 -------------------------- 11807 11808 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id) is 11809 begin 11810 -- Check the type of the complementary operand since the N_Null node 11811 -- has not been decorated yet. 11812 11813 if Nkind (Op) = N_Null 11814 and then Is_Descendant_Of_Address (Etype (Other_Op)) 11815 then 11816 Rewrite (Op, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (Op))); 11817 end if; 11818 end Replace_Null_Operand; 11819 11820 -- Start of processing for Replace_Null_By_Null_Address 11821 11822 begin 11823 pragma Assert (Relaxed_RM_Semantics); 11824 pragma Assert (Nkind_In (N, N_Null, 11825 N_Op_Eq, 11826 N_Op_Ge, 11827 N_Op_Gt, 11828 N_Op_Le, 11829 N_Op_Lt, 11830 N_Op_Ne)); 11831 11832 if Nkind (N) = N_Null then 11833 Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); 11834 11835 else 11836 declare 11837 L : constant Node_Id := Left_Opnd (N); 11838 R : constant Node_Id := Right_Opnd (N); 11839 11840 begin 11841 Replace_Null_Operand (L, Other_Op => R); 11842 Replace_Null_Operand (R, Other_Op => L); 11843 end; 11844 end if; 11845 end Replace_Null_By_Null_Address; 11846 11847 -------------------------- 11848 -- Has_Tagged_Component -- 11849 -------------------------- 11850 11851 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is 11852 Comp : Entity_Id; 11853 11854 begin 11855 if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then 11856 return Has_Tagged_Component (Underlying_Type (Typ)); 11857 11858 elsif Is_Array_Type (Typ) then 11859 return Has_Tagged_Component (Component_Type (Typ)); 11860 11861 elsif Is_Tagged_Type (Typ) then 11862 return True; 11863 11864 elsif Is_Record_Type (Typ) then 11865 Comp := First_Component (Typ); 11866 while Present (Comp) loop 11867 if Has_Tagged_Component (Etype (Comp)) then 11868 return True; 11869 end if; 11870 11871 Next_Component (Comp); 11872 end loop; 11873 11874 return False; 11875 11876 else 11877 return False; 11878 end if; 11879 end Has_Tagged_Component; 11880 11881 ----------------------------- 11882 -- Has_Undefined_Reference -- 11883 ----------------------------- 11884 11885 function Has_Undefined_Reference (Expr : Node_Id) return Boolean is 11886 Has_Undef_Ref : Boolean := False; 11887 -- Flag set when expression Expr contains at least one undefined 11888 -- reference. 11889 11890 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result; 11891 -- Determine whether N denotes a reference and if it does, whether it is 11892 -- undefined. 11893 11894 ---------------------------- 11895 -- Is_Undefined_Reference -- 11896 ---------------------------- 11897 11898 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result is 11899 begin 11900 if Is_Entity_Name (N) 11901 and then Present (Entity (N)) 11902 and then Entity (N) = Any_Id 11903 then 11904 Has_Undef_Ref := True; 11905 return Abandon; 11906 end if; 11907 11908 return OK; 11909 end Is_Undefined_Reference; 11910 11911 procedure Find_Undefined_References is 11912 new Traverse_Proc (Is_Undefined_Reference); 11913 11914 -- Start of processing for Has_Undefined_Reference 11915 11916 begin 11917 Find_Undefined_References (Expr); 11918 11919 return Has_Undef_Ref; 11920 end Has_Undefined_Reference; 11921 11922 ---------------------------- 11923 -- Has_Volatile_Component -- 11924 ---------------------------- 11925 11926 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is 11927 Comp : Entity_Id; 11928 11929 begin 11930 if Has_Volatile_Components (Typ) then 11931 return True; 11932 11933 elsif Is_Array_Type (Typ) then 11934 return Is_Volatile (Component_Type (Typ)); 11935 11936 elsif Is_Record_Type (Typ) then 11937 Comp := First_Component (Typ); 11938 while Present (Comp) loop 11939 if Is_Volatile_Object (Comp) then 11940 return True; 11941 end if; 11942 11943 Comp := Next_Component (Comp); 11944 end loop; 11945 end if; 11946 11947 return False; 11948 end Has_Volatile_Component; 11949 11950 ------------------------- 11951 -- Implementation_Kind -- 11952 ------------------------- 11953 11954 function Implementation_Kind (Subp : Entity_Id) return Name_Id is 11955 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented); 11956 Arg : Node_Id; 11957 begin 11958 pragma Assert (Present (Impl_Prag)); 11959 Arg := Last (Pragma_Argument_Associations (Impl_Prag)); 11960 return Chars (Get_Pragma_Arg (Arg)); 11961 end Implementation_Kind; 11962 11963 -------------------------- 11964 -- Implements_Interface -- 11965 -------------------------- 11966 11967 function Implements_Interface 11968 (Typ_Ent : Entity_Id; 11969 Iface_Ent : Entity_Id; 11970 Exclude_Parents : Boolean := False) return Boolean 11971 is 11972 Ifaces_List : Elist_Id; 11973 Elmt : Elmt_Id; 11974 Iface : Entity_Id := Base_Type (Iface_Ent); 11975 Typ : Entity_Id := Base_Type (Typ_Ent); 11976 11977 begin 11978 if Is_Class_Wide_Type (Typ) then 11979 Typ := Root_Type (Typ); 11980 end if; 11981 11982 if not Has_Interfaces (Typ) then 11983 return False; 11984 end if; 11985 11986 if Is_Class_Wide_Type (Iface) then 11987 Iface := Root_Type (Iface); 11988 end if; 11989 11990 Collect_Interfaces (Typ, Ifaces_List); 11991 11992 Elmt := First_Elmt (Ifaces_List); 11993 while Present (Elmt) loop 11994 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True) 11995 and then Exclude_Parents 11996 then 11997 null; 11998 11999 elsif Node (Elmt) = Iface then 12000 return True; 12001 end if; 12002 12003 Next_Elmt (Elmt); 12004 end loop; 12005 12006 return False; 12007 end Implements_Interface; 12008 12009 ------------------------------------ 12010 -- In_Assertion_Expression_Pragma -- 12011 ------------------------------------ 12012 12013 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is 12014 Par : Node_Id; 12015 Prag : Node_Id := Empty; 12016 12017 begin 12018 -- Climb the parent chain looking for an enclosing pragma 12019 12020 Par := N; 12021 while Present (Par) loop 12022 if Nkind (Par) = N_Pragma then 12023 Prag := Par; 12024 exit; 12025 12026 -- Precondition-like pragmas are expanded into if statements, check 12027 -- the original node instead. 12028 12029 elsif Nkind (Original_Node (Par)) = N_Pragma then 12030 Prag := Original_Node (Par); 12031 exit; 12032 12033 -- The expansion of attribute 'Old generates a constant to capture 12034 -- the result of the prefix. If the parent traversal reaches 12035 -- one of these constants, then the node technically came from a 12036 -- postcondition-like pragma. Note that the Ekind is not tested here 12037 -- because N may be the expression of an object declaration which is 12038 -- currently being analyzed. Such objects carry Ekind of E_Void. 12039 12040 elsif Nkind (Par) = N_Object_Declaration 12041 and then Constant_Present (Par) 12042 and then Stores_Attribute_Old_Prefix (Defining_Entity (Par)) 12043 then 12044 return True; 12045 12046 -- Prevent the search from going too far 12047 12048 elsif Is_Body_Or_Package_Declaration (Par) then 12049 return False; 12050 end if; 12051 12052 Par := Parent (Par); 12053 end loop; 12054 12055 return 12056 Present (Prag) 12057 and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag)); 12058 end In_Assertion_Expression_Pragma; 12059 12060 ---------------------- 12061 -- In_Generic_Scope -- 12062 ---------------------- 12063 12064 function In_Generic_Scope (E : Entity_Id) return Boolean is 12065 S : Entity_Id; 12066 12067 begin 12068 S := Scope (E); 12069 while Present (S) and then S /= Standard_Standard loop 12070 if Is_Generic_Unit (S) then 12071 return True; 12072 end if; 12073 12074 S := Scope (S); 12075 end loop; 12076 12077 return False; 12078 end In_Generic_Scope; 12079 12080 ----------------- 12081 -- In_Instance -- 12082 ----------------- 12083 12084 function In_Instance return Boolean is 12085 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 12086 S : Entity_Id; 12087 12088 begin 12089 S := Current_Scope; 12090 while Present (S) and then S /= Standard_Standard loop 12091 if Is_Generic_Instance (S) then 12092 12093 -- A child instance is always compiled in the context of a parent 12094 -- instance. Nevertheless, the actuals are not analyzed in an 12095 -- instance context. We detect this case by examining the current 12096 -- compilation unit, which must be a child instance, and checking 12097 -- that it is not currently on the scope stack. 12098 12099 if Is_Child_Unit (Curr_Unit) 12100 and then Nkind (Unit (Cunit (Current_Sem_Unit))) = 12101 N_Package_Instantiation 12102 and then not In_Open_Scopes (Curr_Unit) 12103 then 12104 return False; 12105 else 12106 return True; 12107 end if; 12108 end if; 12109 12110 S := Scope (S); 12111 end loop; 12112 12113 return False; 12114 end In_Instance; 12115 12116 ---------------------- 12117 -- In_Instance_Body -- 12118 ---------------------- 12119 12120 function In_Instance_Body return Boolean is 12121 S : Entity_Id; 12122 12123 begin 12124 S := Current_Scope; 12125 while Present (S) and then S /= Standard_Standard loop 12126 if Ekind_In (S, E_Function, E_Procedure) 12127 and then Is_Generic_Instance (S) 12128 then 12129 return True; 12130 12131 elsif Ekind (S) = E_Package 12132 and then In_Package_Body (S) 12133 and then Is_Generic_Instance (S) 12134 then 12135 return True; 12136 end if; 12137 12138 S := Scope (S); 12139 end loop; 12140 12141 return False; 12142 end In_Instance_Body; 12143 12144 ----------------------------- 12145 -- In_Instance_Not_Visible -- 12146 ----------------------------- 12147 12148 function In_Instance_Not_Visible return Boolean is 12149 S : Entity_Id; 12150 12151 begin 12152 S := Current_Scope; 12153 while Present (S) and then S /= Standard_Standard loop 12154 if Ekind_In (S, E_Function, E_Procedure) 12155 and then Is_Generic_Instance (S) 12156 then 12157 return True; 12158 12159 elsif Ekind (S) = E_Package 12160 and then (In_Package_Body (S) or else In_Private_Part (S)) 12161 and then Is_Generic_Instance (S) 12162 then 12163 return True; 12164 end if; 12165 12166 S := Scope (S); 12167 end loop; 12168 12169 return False; 12170 end In_Instance_Not_Visible; 12171 12172 ------------------------------ 12173 -- In_Instance_Visible_Part -- 12174 ------------------------------ 12175 12176 function In_Instance_Visible_Part 12177 (Id : Entity_Id := Current_Scope) return Boolean 12178 is 12179 Inst : Entity_Id; 12180 12181 begin 12182 Inst := Id; 12183 while Present (Inst) and then Inst /= Standard_Standard loop 12184 if Ekind (Inst) = E_Package 12185 and then Is_Generic_Instance (Inst) 12186 and then not In_Package_Body (Inst) 12187 and then not In_Private_Part (Inst) 12188 then 12189 return True; 12190 end if; 12191 12192 Inst := Scope (Inst); 12193 end loop; 12194 12195 return False; 12196 end In_Instance_Visible_Part; 12197 12198 --------------------- 12199 -- In_Package_Body -- 12200 --------------------- 12201 12202 function In_Package_Body return Boolean is 12203 S : Entity_Id; 12204 12205 begin 12206 S := Current_Scope; 12207 while Present (S) and then S /= Standard_Standard loop 12208 if Ekind (S) = E_Package and then In_Package_Body (S) then 12209 return True; 12210 else 12211 S := Scope (S); 12212 end if; 12213 end loop; 12214 12215 return False; 12216 end In_Package_Body; 12217 12218 -------------------------- 12219 -- In_Pragma_Expression -- 12220 -------------------------- 12221 12222 function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean is 12223 P : Node_Id; 12224 begin 12225 P := Parent (N); 12226 loop 12227 if No (P) then 12228 return False; 12229 elsif Nkind (P) = N_Pragma and then Pragma_Name (P) = Nam then 12230 return True; 12231 else 12232 P := Parent (P); 12233 end if; 12234 end loop; 12235 end In_Pragma_Expression; 12236 12237 --------------------------- 12238 -- In_Pre_Post_Condition -- 12239 --------------------------- 12240 12241 function In_Pre_Post_Condition (N : Node_Id) return Boolean is 12242 Par : Node_Id; 12243 Prag : Node_Id := Empty; 12244 Prag_Id : Pragma_Id; 12245 12246 begin 12247 -- Climb the parent chain looking for an enclosing pragma 12248 12249 Par := N; 12250 while Present (Par) loop 12251 if Nkind (Par) = N_Pragma then 12252 Prag := Par; 12253 exit; 12254 12255 -- Prevent the search from going too far 12256 12257 elsif Is_Body_Or_Package_Declaration (Par) then 12258 exit; 12259 end if; 12260 12261 Par := Parent (Par); 12262 end loop; 12263 12264 if Present (Prag) then 12265 Prag_Id := Get_Pragma_Id (Prag); 12266 12267 return 12268 Prag_Id = Pragma_Post 12269 or else Prag_Id = Pragma_Post_Class 12270 or else Prag_Id = Pragma_Postcondition 12271 or else Prag_Id = Pragma_Pre 12272 or else Prag_Id = Pragma_Pre_Class 12273 or else Prag_Id = Pragma_Precondition; 12274 12275 -- Otherwise the node is not enclosed by a pre/postcondition pragma 12276 12277 else 12278 return False; 12279 end if; 12280 end In_Pre_Post_Condition; 12281 12282 ------------------------------------- 12283 -- In_Reverse_Storage_Order_Object -- 12284 ------------------------------------- 12285 12286 function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is 12287 Pref : Node_Id; 12288 Btyp : Entity_Id := Empty; 12289 12290 begin 12291 -- Climb up indexed components 12292 12293 Pref := N; 12294 loop 12295 case Nkind (Pref) is 12296 when N_Selected_Component => 12297 Pref := Prefix (Pref); 12298 exit; 12299 12300 when N_Indexed_Component => 12301 Pref := Prefix (Pref); 12302 12303 when others => 12304 Pref := Empty; 12305 exit; 12306 end case; 12307 end loop; 12308 12309 if Present (Pref) then 12310 Btyp := Base_Type (Etype (Pref)); 12311 end if; 12312 12313 return Present (Btyp) 12314 and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp)) 12315 and then Reverse_Storage_Order (Btyp); 12316 end In_Reverse_Storage_Order_Object; 12317 12318 ------------------------------ 12319 -- In_Same_Declarative_Part -- 12320 ------------------------------ 12321 12322 function In_Same_Declarative_Part 12323 (Context : Node_Id; 12324 N : Node_Id) return Boolean 12325 is 12326 Cont : Node_Id := Context; 12327 Nod : Node_Id; 12328 12329 begin 12330 if Nkind (Cont) = N_Compilation_Unit_Aux then 12331 Cont := Parent (Cont); 12332 end if; 12333 12334 Nod := Parent (N); 12335 while Present (Nod) loop 12336 if Nod = Cont then 12337 return True; 12338 12339 elsif Nkind_In (Nod, N_Accept_Statement, 12340 N_Block_Statement, 12341 N_Compilation_Unit, 12342 N_Entry_Body, 12343 N_Package_Body, 12344 N_Package_Declaration, 12345 N_Protected_Body, 12346 N_Subprogram_Body, 12347 N_Task_Body) 12348 then 12349 return False; 12350 12351 elsif Nkind (Nod) = N_Subunit then 12352 Nod := Corresponding_Stub (Nod); 12353 12354 else 12355 Nod := Parent (Nod); 12356 end if; 12357 end loop; 12358 12359 return False; 12360 end In_Same_Declarative_Part; 12361 12362 -------------------------------------- 12363 -- In_Subprogram_Or_Concurrent_Unit -- 12364 -------------------------------------- 12365 12366 function In_Subprogram_Or_Concurrent_Unit return Boolean is 12367 E : Entity_Id; 12368 K : Entity_Kind; 12369 12370 begin 12371 -- Use scope chain to check successively outer scopes 12372 12373 E := Current_Scope; 12374 loop 12375 K := Ekind (E); 12376 12377 if K in Subprogram_Kind 12378 or else K in Concurrent_Kind 12379 or else K in Generic_Subprogram_Kind 12380 then 12381 return True; 12382 12383 elsif E = Standard_Standard then 12384 return False; 12385 end if; 12386 12387 E := Scope (E); 12388 end loop; 12389 end In_Subprogram_Or_Concurrent_Unit; 12390 12391 ---------------- 12392 -- In_Subtree -- 12393 ---------------- 12394 12395 function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is 12396 Curr : Node_Id; 12397 12398 begin 12399 Curr := N; 12400 while Present (Curr) loop 12401 if Curr = Root then 12402 return True; 12403 end if; 12404 12405 Curr := Parent (Curr); 12406 end loop; 12407 12408 return False; 12409 end In_Subtree; 12410 12411 ---------------- 12412 -- In_Subtree -- 12413 ---------------- 12414 12415 function In_Subtree 12416 (N : Node_Id; 12417 Root1 : Node_Id; 12418 Root2 : Node_Id) return Boolean 12419 is 12420 Curr : Node_Id; 12421 12422 begin 12423 Curr := N; 12424 while Present (Curr) loop 12425 if Curr = Root1 or else Curr = Root2 then 12426 return True; 12427 end if; 12428 12429 Curr := Parent (Curr); 12430 end loop; 12431 12432 return False; 12433 end In_Subtree; 12434 12435 --------------------- 12436 -- In_Visible_Part -- 12437 --------------------- 12438 12439 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is 12440 begin 12441 return Is_Package_Or_Generic_Package (Scope_Id) 12442 and then In_Open_Scopes (Scope_Id) 12443 and then not In_Package_Body (Scope_Id) 12444 and then not In_Private_Part (Scope_Id); 12445 end In_Visible_Part; 12446 12447 -------------------------------- 12448 -- Incomplete_Or_Partial_View -- 12449 -------------------------------- 12450 12451 function Incomplete_Or_Partial_View (Id : Entity_Id) return Entity_Id is 12452 function Inspect_Decls 12453 (Decls : List_Id; 12454 Taft : Boolean := False) return Entity_Id; 12455 -- Check whether a declarative region contains the incomplete or partial 12456 -- view of Id. 12457 12458 ------------------- 12459 -- Inspect_Decls -- 12460 ------------------- 12461 12462 function Inspect_Decls 12463 (Decls : List_Id; 12464 Taft : Boolean := False) return Entity_Id 12465 is 12466 Decl : Node_Id; 12467 Match : Node_Id; 12468 12469 begin 12470 Decl := First (Decls); 12471 while Present (Decl) loop 12472 Match := Empty; 12473 12474 -- The partial view of a Taft-amendment type is an incomplete 12475 -- type. 12476 12477 if Taft then 12478 if Nkind (Decl) = N_Incomplete_Type_Declaration then 12479 Match := Defining_Identifier (Decl); 12480 end if; 12481 12482 -- Otherwise look for a private type whose full view matches the 12483 -- input type. Note that this checks full_type_declaration nodes 12484 -- to account for derivations from a private type where the type 12485 -- declaration hold the partial view and the full view is an 12486 -- itype. 12487 12488 elsif Nkind_In (Decl, N_Full_Type_Declaration, 12489 N_Private_Extension_Declaration, 12490 N_Private_Type_Declaration) 12491 then 12492 Match := Defining_Identifier (Decl); 12493 end if; 12494 12495 -- Guard against unanalyzed entities 12496 12497 if Present (Match) 12498 and then Is_Type (Match) 12499 and then Present (Full_View (Match)) 12500 and then Full_View (Match) = Id 12501 then 12502 return Match; 12503 end if; 12504 12505 Next (Decl); 12506 end loop; 12507 12508 return Empty; 12509 end Inspect_Decls; 12510 12511 -- Local variables 12512 12513 Prev : Entity_Id; 12514 12515 -- Start of processing for Incomplete_Or_Partial_View 12516 12517 begin 12518 -- Deferred constant or incomplete type case 12519 12520 Prev := Current_Entity_In_Scope (Id); 12521 12522 if Present (Prev) 12523 and then (Is_Incomplete_Type (Prev) or else Ekind (Prev) = E_Constant) 12524 and then Present (Full_View (Prev)) 12525 and then Full_View (Prev) = Id 12526 then 12527 return Prev; 12528 end if; 12529 12530 -- Private or Taft amendment type case 12531 12532 declare 12533 Pkg : constant Entity_Id := Scope (Id); 12534 Pkg_Decl : Node_Id := Pkg; 12535 12536 begin 12537 if Present (Pkg) 12538 and then Ekind_In (Pkg, E_Generic_Package, E_Package) 12539 then 12540 while Nkind (Pkg_Decl) /= N_Package_Specification loop 12541 Pkg_Decl := Parent (Pkg_Decl); 12542 end loop; 12543 12544 -- It is knows that Typ has a private view, look for it in the 12545 -- visible declarations of the enclosing scope. A special case 12546 -- of this is when the two views have been exchanged - the full 12547 -- appears earlier than the private. 12548 12549 if Has_Private_Declaration (Id) then 12550 Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl)); 12551 12552 -- Exchanged view case, look in the private declarations 12553 12554 if No (Prev) then 12555 Prev := Inspect_Decls (Private_Declarations (Pkg_Decl)); 12556 end if; 12557 12558 return Prev; 12559 12560 -- Otherwise if this is the package body, then Typ is a potential 12561 -- Taft amendment type. The incomplete view should be located in 12562 -- the private declarations of the enclosing scope. 12563 12564 elsif In_Package_Body (Pkg) then 12565 return Inspect_Decls (Private_Declarations (Pkg_Decl), True); 12566 end if; 12567 end if; 12568 end; 12569 12570 -- The type has no incomplete or private view 12571 12572 return Empty; 12573 end Incomplete_Or_Partial_View; 12574 12575 --------------------------------------- 12576 -- Incomplete_View_From_Limited_With -- 12577 --------------------------------------- 12578 12579 function Incomplete_View_From_Limited_With 12580 (Typ : Entity_Id) return Entity_Id 12581 is 12582 begin 12583 -- It might make sense to make this an attribute in Einfo, and set it 12584 -- in Sem_Ch10 in Build_Shadow_Entity. However, we're running short on 12585 -- slots for new attributes, and it seems a bit simpler to just search 12586 -- the Limited_View (if it exists) for an incomplete type whose 12587 -- Non_Limited_View is Typ. 12588 12589 if Ekind (Scope (Typ)) = E_Package 12590 and then Present (Limited_View (Scope (Typ))) 12591 then 12592 declare 12593 Ent : Entity_Id := First_Entity (Limited_View (Scope (Typ))); 12594 begin 12595 while Present (Ent) loop 12596 if Ekind (Ent) in Incomplete_Kind 12597 and then Non_Limited_View (Ent) = Typ 12598 then 12599 return Ent; 12600 end if; 12601 12602 Ent := Next_Entity (Ent); 12603 end loop; 12604 end; 12605 end if; 12606 12607 return Typ; 12608 end Incomplete_View_From_Limited_With; 12609 12610 ---------------------------------- 12611 -- Indexed_Component_Bit_Offset -- 12612 ---------------------------------- 12613 12614 function Indexed_Component_Bit_Offset (N : Node_Id) return Uint is 12615 Exp : constant Node_Id := First (Expressions (N)); 12616 Typ : constant Entity_Id := Etype (Prefix (N)); 12617 Off : constant Uint := Component_Size (Typ); 12618 Ind : Node_Id; 12619 12620 begin 12621 -- Return early if the component size is not known or variable 12622 12623 if Off = No_Uint or else Off < Uint_0 then 12624 return No_Uint; 12625 end if; 12626 12627 -- Deal with the degenerate case of an empty component 12628 12629 if Off = Uint_0 then 12630 return Off; 12631 end if; 12632 12633 -- Check that both the index value and the low bound are known 12634 12635 if not Compile_Time_Known_Value (Exp) then 12636 return No_Uint; 12637 end if; 12638 12639 Ind := First_Index (Typ); 12640 if No (Ind) then 12641 return No_Uint; 12642 end if; 12643 12644 if Nkind (Ind) = N_Subtype_Indication then 12645 Ind := Constraint (Ind); 12646 12647 if Nkind (Ind) = N_Range_Constraint then 12648 Ind := Range_Expression (Ind); 12649 end if; 12650 end if; 12651 12652 if Nkind (Ind) /= N_Range 12653 or else not Compile_Time_Known_Value (Low_Bound (Ind)) 12654 then 12655 return No_Uint; 12656 end if; 12657 12658 -- Return the scaled offset 12659 12660 return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound ((Ind)))); 12661 end Indexed_Component_Bit_Offset; 12662 12663 ---------------------------- 12664 -- Inherit_Rep_Item_Chain -- 12665 ---------------------------- 12666 12667 procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is 12668 Item : Node_Id; 12669 Next_Item : Node_Id; 12670 12671 begin 12672 -- There are several inheritance scenarios to consider depending on 12673 -- whether both types have rep item chains and whether the destination 12674 -- type already inherits part of the source type's rep item chain. 12675 12676 -- 1) The source type lacks a rep item chain 12677 -- From_Typ ---> Empty 12678 -- 12679 -- Typ --------> Item (or Empty) 12680 12681 -- In this case inheritance cannot take place because there are no items 12682 -- to inherit. 12683 12684 -- 2) The destination type lacks a rep item chain 12685 -- From_Typ ---> Item ---> ... 12686 -- 12687 -- Typ --------> Empty 12688 12689 -- Inheritance takes place by setting the First_Rep_Item of the 12690 -- destination type to the First_Rep_Item of the source type. 12691 -- From_Typ ---> Item ---> ... 12692 -- ^ 12693 -- Typ -----------+ 12694 12695 -- 3.1) Both source and destination types have at least one rep item. 12696 -- The destination type does NOT inherit a rep item from the source 12697 -- type. 12698 -- From_Typ ---> Item ---> Item 12699 -- 12700 -- Typ --------> Item ---> Item 12701 12702 -- Inheritance takes place by setting the Next_Rep_Item of the last item 12703 -- of the destination type to the First_Rep_Item of the source type. 12704 -- From_Typ -------------------> Item ---> Item 12705 -- ^ 12706 -- Typ --------> Item ---> Item --+ 12707 12708 -- 3.2) Both source and destination types have at least one rep item. 12709 -- The destination type DOES inherit part of the rep item chain of the 12710 -- source type. 12711 -- From_Typ ---> Item ---> Item ---> Item 12712 -- ^ 12713 -- Typ --------> Item ------+ 12714 12715 -- This rare case arises when the full view of a private extension must 12716 -- inherit the rep item chain from the full view of its parent type and 12717 -- the full view of the parent type contains extra rep items. Currently 12718 -- only invariants may lead to such form of inheritance. 12719 12720 -- type From_Typ is tagged private 12721 -- with Type_Invariant'Class => Item_2; 12722 12723 -- type Typ is new From_Typ with private 12724 -- with Type_Invariant => Item_4; 12725 12726 -- At this point the rep item chains contain the following items 12727 12728 -- From_Typ -----------> Item_2 ---> Item_3 12729 -- ^ 12730 -- Typ --------> Item_4 --+ 12731 12732 -- The full views of both types may introduce extra invariants 12733 12734 -- type From_Typ is tagged null record 12735 -- with Type_Invariant => Item_1; 12736 12737 -- type Typ is new From_Typ with null record; 12738 12739 -- The full view of Typ would have to inherit any new rep items added to 12740 -- the full view of From_Typ. 12741 12742 -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3 12743 -- ^ 12744 -- Typ --------> Item_4 --+ 12745 12746 -- To achieve this form of inheritance, the destination type must first 12747 -- sever the link between its own rep chain and that of the source type, 12748 -- then inheritance 3.1 takes place. 12749 12750 -- Case 1: The source type lacks a rep item chain 12751 12752 if No (First_Rep_Item (From_Typ)) then 12753 return; 12754 12755 -- Case 2: The destination type lacks a rep item chain 12756 12757 elsif No (First_Rep_Item (Typ)) then 12758 Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ)); 12759 12760 -- Case 3: Both the source and destination types have at least one rep 12761 -- item. Traverse the rep item chain of the destination type to find the 12762 -- last rep item. 12763 12764 else 12765 Item := Empty; 12766 Next_Item := First_Rep_Item (Typ); 12767 while Present (Next_Item) loop 12768 12769 -- Detect a link between the destination type's rep chain and that 12770 -- of the source type. There are two possibilities: 12771 12772 -- Variant 1 12773 -- Next_Item 12774 -- V 12775 -- From_Typ ---> Item_1 ---> 12776 -- ^ 12777 -- Typ -----------+ 12778 -- 12779 -- Item is Empty 12780 12781 -- Variant 2 12782 -- Next_Item 12783 -- V 12784 -- From_Typ ---> Item_1 ---> Item_2 ---> 12785 -- ^ 12786 -- Typ --------> Item_3 ------+ 12787 -- ^ 12788 -- Item 12789 12790 if Has_Rep_Item (From_Typ, Next_Item) then 12791 exit; 12792 end if; 12793 12794 Item := Next_Item; 12795 Next_Item := Next_Rep_Item (Next_Item); 12796 end loop; 12797 12798 -- Inherit the source type's rep item chain 12799 12800 if Present (Item) then 12801 Set_Next_Rep_Item (Item, First_Rep_Item (From_Typ)); 12802 else 12803 Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ)); 12804 end if; 12805 end if; 12806 end Inherit_Rep_Item_Chain; 12807 12808 ------------------------------------ 12809 -- Inherits_From_Tagged_Full_View -- 12810 ------------------------------------ 12811 12812 function Inherits_From_Tagged_Full_View (Typ : Entity_Id) return Boolean is 12813 begin 12814 return Is_Private_Type (Typ) 12815 and then Present (Full_View (Typ)) 12816 and then Is_Private_Type (Full_View (Typ)) 12817 and then not Is_Tagged_Type (Full_View (Typ)) 12818 and then Present (Underlying_Type (Full_View (Typ))) 12819 and then Is_Tagged_Type (Underlying_Type (Full_View (Typ))); 12820 end Inherits_From_Tagged_Full_View; 12821 12822 --------------------------------- 12823 -- Insert_Explicit_Dereference -- 12824 --------------------------------- 12825 12826 procedure Insert_Explicit_Dereference (N : Node_Id) is 12827 New_Prefix : constant Node_Id := Relocate_Node (N); 12828 Ent : Entity_Id := Empty; 12829 Pref : Node_Id; 12830 I : Interp_Index; 12831 It : Interp; 12832 T : Entity_Id; 12833 12834 begin 12835 Save_Interps (N, New_Prefix); 12836 12837 Rewrite (N, 12838 Make_Explicit_Dereference (Sloc (Parent (N)), 12839 Prefix => New_Prefix)); 12840 12841 Set_Etype (N, Designated_Type (Etype (New_Prefix))); 12842 12843 if Is_Overloaded (New_Prefix) then 12844 12845 -- The dereference is also overloaded, and its interpretations are 12846 -- the designated types of the interpretations of the original node. 12847 12848 Set_Etype (N, Any_Type); 12849 12850 Get_First_Interp (New_Prefix, I, It); 12851 while Present (It.Nam) loop 12852 T := It.Typ; 12853 12854 if Is_Access_Type (T) then 12855 Add_One_Interp (N, Designated_Type (T), Designated_Type (T)); 12856 end if; 12857 12858 Get_Next_Interp (I, It); 12859 end loop; 12860 12861 End_Interp_List; 12862 12863 else 12864 -- Prefix is unambiguous: mark the original prefix (which might 12865 -- Come_From_Source) as a reference, since the new (relocated) one 12866 -- won't be taken into account. 12867 12868 if Is_Entity_Name (New_Prefix) then 12869 Ent := Entity (New_Prefix); 12870 Pref := New_Prefix; 12871 12872 -- For a retrieval of a subcomponent of some composite object, 12873 -- retrieve the ultimate entity if there is one. 12874 12875 elsif Nkind_In (New_Prefix, N_Selected_Component, 12876 N_Indexed_Component) 12877 then 12878 Pref := Prefix (New_Prefix); 12879 while Present (Pref) 12880 and then Nkind_In (Pref, N_Selected_Component, 12881 N_Indexed_Component) 12882 loop 12883 Pref := Prefix (Pref); 12884 end loop; 12885 12886 if Present (Pref) and then Is_Entity_Name (Pref) then 12887 Ent := Entity (Pref); 12888 end if; 12889 end if; 12890 12891 -- Place the reference on the entity node 12892 12893 if Present (Ent) then 12894 Generate_Reference (Ent, Pref); 12895 end if; 12896 end if; 12897 end Insert_Explicit_Dereference; 12898 12899 ------------------------------------------ 12900 -- Inspect_Deferred_Constant_Completion -- 12901 ------------------------------------------ 12902 12903 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is 12904 Decl : Node_Id; 12905 12906 begin 12907 Decl := First (Decls); 12908 while Present (Decl) loop 12909 12910 -- Deferred constant signature 12911 12912 if Nkind (Decl) = N_Object_Declaration 12913 and then Constant_Present (Decl) 12914 and then No (Expression (Decl)) 12915 12916 -- No need to check internally generated constants 12917 12918 and then Comes_From_Source (Decl) 12919 12920 -- The constant is not completed. A full object declaration or a 12921 -- pragma Import complete a deferred constant. 12922 12923 and then not Has_Completion (Defining_Identifier (Decl)) 12924 then 12925 Error_Msg_N 12926 ("constant declaration requires initialization expression", 12927 Defining_Identifier (Decl)); 12928 end if; 12929 12930 Decl := Next (Decl); 12931 end loop; 12932 end Inspect_Deferred_Constant_Completion; 12933 12934 ------------------------------- 12935 -- Install_Elaboration_Model -- 12936 ------------------------------- 12937 12938 procedure Install_Elaboration_Model (Unit_Id : Entity_Id) is 12939 function Find_Elaboration_Checks_Pragma (L : List_Id) return Node_Id; 12940 -- Try to find pragma Elaboration_Checks in arbitrary list L. Return 12941 -- Empty if there is no such pragma. 12942 12943 ------------------------------------ 12944 -- Find_Elaboration_Checks_Pragma -- 12945 ------------------------------------ 12946 12947 function Find_Elaboration_Checks_Pragma (L : List_Id) return Node_Id is 12948 Item : Node_Id; 12949 12950 begin 12951 Item := First (L); 12952 while Present (Item) loop 12953 if Nkind (Item) = N_Pragma 12954 and then Pragma_Name (Item) = Name_Elaboration_Checks 12955 then 12956 return Item; 12957 end if; 12958 12959 Next (Item); 12960 end loop; 12961 12962 return Empty; 12963 end Find_Elaboration_Checks_Pragma; 12964 12965 -- Local variables 12966 12967 Args : List_Id; 12968 Model : Node_Id; 12969 Prag : Node_Id; 12970 Unit : Node_Id; 12971 12972 -- Start of processing for Install_Elaboration_Model 12973 12974 begin 12975 -- Nothing to do when the unit does not exist 12976 12977 if No (Unit_Id) then 12978 return; 12979 end if; 12980 12981 Unit := Parent (Unit_Declaration_Node (Unit_Id)); 12982 12983 -- Nothing to do when the unit is not a library unit 12984 12985 if Nkind (Unit) /= N_Compilation_Unit then 12986 return; 12987 end if; 12988 12989 Prag := Find_Elaboration_Checks_Pragma (Context_Items (Unit)); 12990 12991 -- The compilation unit is subject to pragma Elaboration_Checks. Set the 12992 -- elaboration model as specified by the pragma. 12993 12994 if Present (Prag) then 12995 Args := Pragma_Argument_Associations (Prag); 12996 12997 -- Guard against an illegal pragma. The sole argument must be an 12998 -- identifier which specifies either Dynamic or Static model. 12999 13000 if Present (Args) then 13001 Model := Get_Pragma_Arg (First (Args)); 13002 13003 if Nkind (Model) = N_Identifier then 13004 Dynamic_Elaboration_Checks := Chars (Model) = Name_Dynamic; 13005 end if; 13006 end if; 13007 end if; 13008 end Install_Elaboration_Model; 13009 13010 ----------------------------- 13011 -- Install_Generic_Formals -- 13012 ----------------------------- 13013 13014 procedure Install_Generic_Formals (Subp_Id : Entity_Id) is 13015 E : Entity_Id; 13016 13017 begin 13018 pragma Assert (Is_Generic_Subprogram (Subp_Id)); 13019 13020 E := First_Entity (Subp_Id); 13021 while Present (E) loop 13022 Install_Entity (E); 13023 Next_Entity (E); 13024 end loop; 13025 end Install_Generic_Formals; 13026 13027 ------------------------ 13028 -- Install_SPARK_Mode -- 13029 ------------------------ 13030 13031 procedure Install_SPARK_Mode (Mode : SPARK_Mode_Type; Prag : Node_Id) is 13032 begin 13033 SPARK_Mode := Mode; 13034 SPARK_Mode_Pragma := Prag; 13035 end Install_SPARK_Mode; 13036 13037 -------------------------- 13038 -- Invalid_Scalar_Value -- 13039 -------------------------- 13040 13041 function Invalid_Scalar_Value 13042 (Loc : Source_Ptr; 13043 Scal_Typ : Scalar_Id) return Node_Id 13044 is 13045 function Invalid_Binder_Value return Node_Id; 13046 -- Return a reference to the corresponding invalid value for type 13047 -- Scal_Typ as defined in unit System.Scalar_Values. 13048 13049 function Invalid_Float_Value return Node_Id; 13050 -- Return the invalid value of float type Scal_Typ 13051 13052 function Invalid_Integer_Value return Node_Id; 13053 -- Return the invalid value of integer type Scal_Typ 13054 13055 procedure Set_Invalid_Binder_Values; 13056 -- Set the contents of collection Invalid_Binder_Values 13057 13058 -------------------------- 13059 -- Invalid_Binder_Value -- 13060 -------------------------- 13061 13062 function Invalid_Binder_Value return Node_Id is 13063 Val_Id : Entity_Id; 13064 13065 begin 13066 -- Initialize the collection of invalid binder values the first time 13067 -- around. 13068 13069 Set_Invalid_Binder_Values; 13070 13071 -- Obtain the corresponding variable from System.Scalar_Values which 13072 -- holds the invalid value for this type. 13073 13074 Val_Id := Invalid_Binder_Values (Scal_Typ); 13075 pragma Assert (Present (Val_Id)); 13076 13077 return New_Occurrence_Of (Val_Id, Loc); 13078 end Invalid_Binder_Value; 13079 13080 ------------------------- 13081 -- Invalid_Float_Value -- 13082 ------------------------- 13083 13084 function Invalid_Float_Value return Node_Id is 13085 Value : constant Ureal := Invalid_Floats (Scal_Typ); 13086 13087 begin 13088 -- Pragma Invalid_Scalars did not specify an invalid value for this 13089 -- type. Fall back to the value provided by the binder. 13090 13091 if Value = No_Ureal then 13092 return Invalid_Binder_Value; 13093 else 13094 return Make_Real_Literal (Loc, Realval => Value); 13095 end if; 13096 end Invalid_Float_Value; 13097 13098 --------------------------- 13099 -- Invalid_Integer_Value -- 13100 --------------------------- 13101 13102 function Invalid_Integer_Value return Node_Id is 13103 Value : constant Uint := Invalid_Integers (Scal_Typ); 13104 13105 begin 13106 -- Pragma Invalid_Scalars did not specify an invalid value for this 13107 -- type. Fall back to the value provided by the binder. 13108 13109 if Value = No_Uint then 13110 return Invalid_Binder_Value; 13111 else 13112 return Make_Integer_Literal (Loc, Intval => Value); 13113 end if; 13114 end Invalid_Integer_Value; 13115 13116 ------------------------------- 13117 -- Set_Invalid_Binder_Values -- 13118 ------------------------------- 13119 13120 procedure Set_Invalid_Binder_Values is 13121 begin 13122 if not Invalid_Binder_Values_Set then 13123 Invalid_Binder_Values_Set := True; 13124 13125 -- Initialize the contents of the collection once since RTE calls 13126 -- are not cheap. 13127 13128 Invalid_Binder_Values := 13129 (Name_Short_Float => RTE (RE_IS_Isf), 13130 Name_Float => RTE (RE_IS_Ifl), 13131 Name_Long_Float => RTE (RE_IS_Ilf), 13132 Name_Long_Long_Float => RTE (RE_IS_Ill), 13133 Name_Signed_8 => RTE (RE_IS_Is1), 13134 Name_Signed_16 => RTE (RE_IS_Is2), 13135 Name_Signed_32 => RTE (RE_IS_Is4), 13136 Name_Signed_64 => RTE (RE_IS_Is8), 13137 Name_Unsigned_8 => RTE (RE_IS_Iu1), 13138 Name_Unsigned_16 => RTE (RE_IS_Iu2), 13139 Name_Unsigned_32 => RTE (RE_IS_Iu4), 13140 Name_Unsigned_64 => RTE (RE_IS_Iu8)); 13141 end if; 13142 end Set_Invalid_Binder_Values; 13143 13144 -- Start of processing for Invalid_Scalar_Value 13145 13146 begin 13147 if Scal_Typ in Float_Scalar_Id then 13148 return Invalid_Float_Value; 13149 13150 else pragma Assert (Scal_Typ in Integer_Scalar_Id); 13151 return Invalid_Integer_Value; 13152 end if; 13153 end Invalid_Scalar_Value; 13154 13155 ----------------------------- 13156 -- Is_Actual_Out_Parameter -- 13157 ----------------------------- 13158 13159 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is 13160 Formal : Entity_Id; 13161 Call : Node_Id; 13162 begin 13163 Find_Actual (N, Formal, Call); 13164 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter; 13165 end Is_Actual_Out_Parameter; 13166 13167 ------------------------- 13168 -- Is_Actual_Parameter -- 13169 ------------------------- 13170 13171 function Is_Actual_Parameter (N : Node_Id) return Boolean is 13172 PK : constant Node_Kind := Nkind (Parent (N)); 13173 13174 begin 13175 case PK is 13176 when N_Parameter_Association => 13177 return N = Explicit_Actual_Parameter (Parent (N)); 13178 13179 when N_Subprogram_Call => 13180 return Is_List_Member (N) 13181 and then 13182 List_Containing (N) = Parameter_Associations (Parent (N)); 13183 13184 when others => 13185 return False; 13186 end case; 13187 end Is_Actual_Parameter; 13188 13189 -------------------------------- 13190 -- Is_Actual_Tagged_Parameter -- 13191 -------------------------------- 13192 13193 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is 13194 Formal : Entity_Id; 13195 Call : Node_Id; 13196 begin 13197 Find_Actual (N, Formal, Call); 13198 return Present (Formal) and then Is_Tagged_Type (Etype (Formal)); 13199 end Is_Actual_Tagged_Parameter; 13200 13201 --------------------- 13202 -- Is_Aliased_View -- 13203 --------------------- 13204 13205 function Is_Aliased_View (Obj : Node_Id) return Boolean is 13206 E : Entity_Id; 13207 13208 begin 13209 if Is_Entity_Name (Obj) then 13210 E := Entity (Obj); 13211 13212 return 13213 (Is_Object (E) 13214 and then 13215 (Is_Aliased (E) 13216 or else (Present (Renamed_Object (E)) 13217 and then Is_Aliased_View (Renamed_Object (E))))) 13218 13219 or else ((Is_Formal (E) or else Is_Formal_Object (E)) 13220 and then Is_Tagged_Type (Etype (E))) 13221 13222 or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E)) 13223 13224 -- Current instance of type, either directly or as rewritten 13225 -- reference to the current object. 13226 13227 or else (Is_Entity_Name (Original_Node (Obj)) 13228 and then Present (Entity (Original_Node (Obj))) 13229 and then Is_Type (Entity (Original_Node (Obj)))) 13230 13231 or else (Is_Type (E) and then E = Current_Scope) 13232 13233 or else (Is_Incomplete_Or_Private_Type (E) 13234 and then Full_View (E) = Current_Scope) 13235 13236 -- Ada 2012 AI05-0053: the return object of an extended return 13237 -- statement is aliased if its type is immutably limited. 13238 13239 or else (Is_Return_Object (E) 13240 and then Is_Limited_View (Etype (E))); 13241 13242 elsif Nkind (Obj) = N_Selected_Component then 13243 return Is_Aliased (Entity (Selector_Name (Obj))); 13244 13245 elsif Nkind (Obj) = N_Indexed_Component then 13246 return Has_Aliased_Components (Etype (Prefix (Obj))) 13247 or else 13248 (Is_Access_Type (Etype (Prefix (Obj))) 13249 and then Has_Aliased_Components 13250 (Designated_Type (Etype (Prefix (Obj))))); 13251 13252 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then 13253 return Is_Tagged_Type (Etype (Obj)) 13254 and then Is_Aliased_View (Expression (Obj)); 13255 13256 elsif Nkind (Obj) = N_Explicit_Dereference then 13257 return Nkind (Original_Node (Obj)) /= N_Function_Call; 13258 13259 else 13260 return False; 13261 end if; 13262 end Is_Aliased_View; 13263 13264 ------------------------- 13265 -- Is_Ancestor_Package -- 13266 ------------------------- 13267 13268 function Is_Ancestor_Package 13269 (E1 : Entity_Id; 13270 E2 : Entity_Id) return Boolean 13271 is 13272 Par : Entity_Id; 13273 13274 begin 13275 Par := E2; 13276 while Present (Par) and then Par /= Standard_Standard loop 13277 if Par = E1 then 13278 return True; 13279 end if; 13280 13281 Par := Scope (Par); 13282 end loop; 13283 13284 return False; 13285 end Is_Ancestor_Package; 13286 13287 ---------------------- 13288 -- Is_Atomic_Object -- 13289 ---------------------- 13290 13291 function Is_Atomic_Object (N : Node_Id) return Boolean is 13292 function Is_Atomic_Entity (Id : Entity_Id) return Boolean; 13293 pragma Inline (Is_Atomic_Entity); 13294 -- Determine whether arbitrary entity Id is either atomic or has atomic 13295 -- components. 13296 13297 function Is_Atomic_Prefix (Pref : Node_Id) return Boolean; 13298 -- Determine whether prefix Pref of an indexed or selected component is 13299 -- an atomic object. 13300 13301 ---------------------- 13302 -- Is_Atomic_Entity -- 13303 ---------------------- 13304 13305 function Is_Atomic_Entity (Id : Entity_Id) return Boolean is 13306 begin 13307 return Is_Atomic (Id) or else Has_Atomic_Components (Id); 13308 end Is_Atomic_Entity; 13309 13310 ---------------------- 13311 -- Is_Atomic_Prefix -- 13312 ---------------------- 13313 13314 function Is_Atomic_Prefix (Pref : Node_Id) return Boolean is 13315 Typ : constant Entity_Id := Etype (Pref); 13316 13317 begin 13318 if Is_Access_Type (Typ) then 13319 return Has_Atomic_Components (Designated_Type (Typ)); 13320 13321 elsif Is_Atomic_Entity (Typ) then 13322 return True; 13323 13324 elsif Is_Entity_Name (Pref) 13325 and then Is_Atomic_Entity (Entity (Pref)) 13326 then 13327 return True; 13328 13329 elsif Nkind (Pref) = N_Indexed_Component then 13330 return Is_Atomic_Prefix (Prefix (Pref)); 13331 13332 elsif Nkind (Pref) = N_Selected_Component then 13333 return 13334 Is_Atomic_Prefix (Prefix (Pref)) 13335 or else Is_Atomic (Entity (Selector_Name (Pref))); 13336 end if; 13337 13338 return False; 13339 end Is_Atomic_Prefix; 13340 13341 -- Start of processing for Is_Atomic_Object 13342 13343 begin 13344 if Is_Entity_Name (N) then 13345 return Is_Atomic_Object_Entity (Entity (N)); 13346 13347 elsif Nkind (N) = N_Indexed_Component then 13348 return Is_Atomic (Etype (N)) or else Is_Atomic_Prefix (Prefix (N)); 13349 13350 elsif Nkind (N) = N_Selected_Component then 13351 return 13352 Is_Atomic (Etype (N)) 13353 or else Is_Atomic_Prefix (Prefix (N)) 13354 or else Is_Atomic (Entity (Selector_Name (N))); 13355 end if; 13356 13357 return False; 13358 end Is_Atomic_Object; 13359 13360 ----------------------------- 13361 -- Is_Atomic_Object_Entity -- 13362 ----------------------------- 13363 13364 function Is_Atomic_Object_Entity (Id : Entity_Id) return Boolean is 13365 begin 13366 return 13367 Is_Object (Id) 13368 and then (Is_Atomic (Id) or else Is_Atomic (Etype (Id))); 13369 end Is_Atomic_Object_Entity; 13370 13371 ----------------------------- 13372 -- Is_Atomic_Or_VFA_Object -- 13373 ----------------------------- 13374 13375 function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean is 13376 begin 13377 return Is_Atomic_Object (N) 13378 or else (Is_Object_Reference (N) 13379 and then Is_Entity_Name (N) 13380 and then (Is_Volatile_Full_Access (Entity (N)) 13381 or else 13382 Is_Volatile_Full_Access (Etype (Entity (N))))); 13383 end Is_Atomic_Or_VFA_Object; 13384 13385 ------------------------- 13386 -- Is_Attribute_Result -- 13387 ------------------------- 13388 13389 function Is_Attribute_Result (N : Node_Id) return Boolean is 13390 begin 13391 return Nkind (N) = N_Attribute_Reference 13392 and then Attribute_Name (N) = Name_Result; 13393 end Is_Attribute_Result; 13394 13395 ------------------------- 13396 -- Is_Attribute_Update -- 13397 ------------------------- 13398 13399 function Is_Attribute_Update (N : Node_Id) return Boolean is 13400 begin 13401 return Nkind (N) = N_Attribute_Reference 13402 and then Attribute_Name (N) = Name_Update; 13403 end Is_Attribute_Update; 13404 13405 ------------------------------------ 13406 -- Is_Body_Or_Package_Declaration -- 13407 ------------------------------------ 13408 13409 function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is 13410 begin 13411 return Is_Body (N) or else Nkind (N) = N_Package_Declaration; 13412 end Is_Body_Or_Package_Declaration; 13413 13414 ----------------------- 13415 -- Is_Bounded_String -- 13416 ----------------------- 13417 13418 function Is_Bounded_String (T : Entity_Id) return Boolean is 13419 Under : constant Entity_Id := Underlying_Type (Root_Type (T)); 13420 13421 begin 13422 -- Check whether T is ultimately derived from Ada.Strings.Superbounded. 13423 -- Super_String, or one of the [Wide_]Wide_ versions. This will 13424 -- be True for all the Bounded_String types in instances of the 13425 -- Generic_Bounded_Length generics, and for types derived from those. 13426 13427 return Present (Under) 13428 and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else 13429 Is_RTE (Root_Type (Under), RO_WI_Super_String) or else 13430 Is_RTE (Root_Type (Under), RO_WW_Super_String)); 13431 end Is_Bounded_String; 13432 13433 --------------------- 13434 -- Is_CCT_Instance -- 13435 --------------------- 13436 13437 function Is_CCT_Instance 13438 (Ref_Id : Entity_Id; 13439 Context_Id : Entity_Id) return Boolean 13440 is 13441 begin 13442 pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type)); 13443 13444 if Is_Single_Task_Object (Context_Id) then 13445 return Scope_Within_Or_Same (Etype (Context_Id), Ref_Id); 13446 13447 else 13448 pragma Assert (Ekind_In (Context_Id, E_Entry, 13449 E_Entry_Family, 13450 E_Function, 13451 E_Package, 13452 E_Procedure, 13453 E_Protected_Type, 13454 E_Task_Type) 13455 or else 13456 Is_Record_Type (Context_Id)); 13457 return Scope_Within_Or_Same (Context_Id, Ref_Id); 13458 end if; 13459 end Is_CCT_Instance; 13460 13461 ------------------------- 13462 -- Is_Child_Or_Sibling -- 13463 ------------------------- 13464 13465 function Is_Child_Or_Sibling 13466 (Pack_1 : Entity_Id; 13467 Pack_2 : Entity_Id) return Boolean 13468 is 13469 function Distance_From_Standard (Pack : Entity_Id) return Nat; 13470 -- Given an arbitrary package, return the number of "climbs" necessary 13471 -- to reach scope Standard_Standard. 13472 13473 procedure Equalize_Depths 13474 (Pack : in out Entity_Id; 13475 Depth : in out Nat; 13476 Depth_To_Reach : Nat); 13477 -- Given an arbitrary package, its depth and a target depth to reach, 13478 -- climb the scope chain until the said depth is reached. The pointer 13479 -- to the package and its depth a modified during the climb. 13480 13481 ---------------------------- 13482 -- Distance_From_Standard -- 13483 ---------------------------- 13484 13485 function Distance_From_Standard (Pack : Entity_Id) return Nat is 13486 Dist : Nat; 13487 Scop : Entity_Id; 13488 13489 begin 13490 Dist := 0; 13491 Scop := Pack; 13492 while Present (Scop) and then Scop /= Standard_Standard loop 13493 Dist := Dist + 1; 13494 Scop := Scope (Scop); 13495 end loop; 13496 13497 return Dist; 13498 end Distance_From_Standard; 13499 13500 --------------------- 13501 -- Equalize_Depths -- 13502 --------------------- 13503 13504 procedure Equalize_Depths 13505 (Pack : in out Entity_Id; 13506 Depth : in out Nat; 13507 Depth_To_Reach : Nat) 13508 is 13509 begin 13510 -- The package must be at a greater or equal depth 13511 13512 if Depth < Depth_To_Reach then 13513 raise Program_Error; 13514 end if; 13515 13516 -- Climb the scope chain until the desired depth is reached 13517 13518 while Present (Pack) and then Depth /= Depth_To_Reach loop 13519 Pack := Scope (Pack); 13520 Depth := Depth - 1; 13521 end loop; 13522 end Equalize_Depths; 13523 13524 -- Local variables 13525 13526 P_1 : Entity_Id := Pack_1; 13527 P_1_Child : Boolean := False; 13528 P_1_Depth : Nat := Distance_From_Standard (P_1); 13529 P_2 : Entity_Id := Pack_2; 13530 P_2_Child : Boolean := False; 13531 P_2_Depth : Nat := Distance_From_Standard (P_2); 13532 13533 -- Start of processing for Is_Child_Or_Sibling 13534 13535 begin 13536 pragma Assert 13537 (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package); 13538 13539 -- Both packages denote the same entity, therefore they cannot be 13540 -- children or siblings. 13541 13542 if P_1 = P_2 then 13543 return False; 13544 13545 -- One of the packages is at a deeper level than the other. Note that 13546 -- both may still come from different hierarchies. 13547 13548 -- (root) P_2 13549 -- / \ : 13550 -- X P_2 or X 13551 -- : : 13552 -- P_1 P_1 13553 13554 elsif P_1_Depth > P_2_Depth then 13555 Equalize_Depths 13556 (Pack => P_1, 13557 Depth => P_1_Depth, 13558 Depth_To_Reach => P_2_Depth); 13559 P_1_Child := True; 13560 13561 -- (root) P_1 13562 -- / \ : 13563 -- P_1 X or X 13564 -- : : 13565 -- P_2 P_2 13566 13567 elsif P_2_Depth > P_1_Depth then 13568 Equalize_Depths 13569 (Pack => P_2, 13570 Depth => P_2_Depth, 13571 Depth_To_Reach => P_1_Depth); 13572 P_2_Child := True; 13573 end if; 13574 13575 -- At this stage the package pointers have been elevated to the same 13576 -- depth. If the related entities are the same, then one package is a 13577 -- potential child of the other: 13578 13579 -- P_1 13580 -- : 13581 -- X became P_1 P_2 or vice versa 13582 -- : 13583 -- P_2 13584 13585 if P_1 = P_2 then 13586 if P_1_Child then 13587 return Is_Child_Unit (Pack_1); 13588 13589 else pragma Assert (P_2_Child); 13590 return Is_Child_Unit (Pack_2); 13591 end if; 13592 13593 -- The packages may come from the same package chain or from entirely 13594 -- different hierarcies. To determine this, climb the scope stack until 13595 -- a common root is found. 13596 13597 -- (root) (root 1) (root 2) 13598 -- / \ | | 13599 -- P_1 P_2 P_1 P_2 13600 13601 else 13602 while Present (P_1) and then Present (P_2) loop 13603 13604 -- The two packages may be siblings 13605 13606 if P_1 = P_2 then 13607 return Is_Child_Unit (Pack_1) and then Is_Child_Unit (Pack_2); 13608 end if; 13609 13610 P_1 := Scope (P_1); 13611 P_2 := Scope (P_2); 13612 end loop; 13613 end if; 13614 13615 return False; 13616 end Is_Child_Or_Sibling; 13617 13618 ----------------------------- 13619 -- Is_Concurrent_Interface -- 13620 ----------------------------- 13621 13622 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is 13623 begin 13624 return Is_Interface (T) 13625 and then 13626 (Is_Protected_Interface (T) 13627 or else Is_Synchronized_Interface (T) 13628 or else Is_Task_Interface (T)); 13629 end Is_Concurrent_Interface; 13630 13631 ----------------------- 13632 -- Is_Constant_Bound -- 13633 ----------------------- 13634 13635 function Is_Constant_Bound (Exp : Node_Id) return Boolean is 13636 begin 13637 if Compile_Time_Known_Value (Exp) then 13638 return True; 13639 13640 elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then 13641 return Is_Constant_Object (Entity (Exp)) 13642 or else Ekind (Entity (Exp)) = E_Enumeration_Literal; 13643 13644 elsif Nkind (Exp) in N_Binary_Op then 13645 return Is_Constant_Bound (Left_Opnd (Exp)) 13646 and then Is_Constant_Bound (Right_Opnd (Exp)) 13647 and then Scope (Entity (Exp)) = Standard_Standard; 13648 13649 else 13650 return False; 13651 end if; 13652 end Is_Constant_Bound; 13653 13654 --------------------------- 13655 -- Is_Container_Element -- 13656 --------------------------- 13657 13658 function Is_Container_Element (Exp : Node_Id) return Boolean is 13659 Loc : constant Source_Ptr := Sloc (Exp); 13660 Pref : constant Node_Id := Prefix (Exp); 13661 13662 Call : Node_Id; 13663 -- Call to an indexing aspect 13664 13665 Cont_Typ : Entity_Id; 13666 -- The type of the container being accessed 13667 13668 Elem_Typ : Entity_Id; 13669 -- Its element type 13670 13671 Indexing : Entity_Id; 13672 Is_Const : Boolean; 13673 -- Indicates that constant indexing is used, and the element is thus 13674 -- a constant. 13675 13676 Ref_Typ : Entity_Id; 13677 -- The reference type returned by the indexing operation 13678 13679 begin 13680 -- If C is a container, in a context that imposes the element type of 13681 -- that container, the indexing notation C (X) is rewritten as: 13682 13683 -- Indexing (C, X).Discr.all 13684 13685 -- where Indexing is one of the indexing aspects of the container. 13686 -- If the context does not require a reference, the construct can be 13687 -- rewritten as 13688 13689 -- Element (C, X) 13690 13691 -- First, verify that the construct has the proper form 13692 13693 if not Expander_Active then 13694 return False; 13695 13696 elsif Nkind (Pref) /= N_Selected_Component then 13697 return False; 13698 13699 elsif Nkind (Prefix (Pref)) /= N_Function_Call then 13700 return False; 13701 13702 else 13703 Call := Prefix (Pref); 13704 Ref_Typ := Etype (Call); 13705 end if; 13706 13707 if not Has_Implicit_Dereference (Ref_Typ) 13708 or else No (First (Parameter_Associations (Call))) 13709 or else not Is_Entity_Name (Name (Call)) 13710 then 13711 return False; 13712 end if; 13713 13714 -- Retrieve type of container object, and its iterator aspects 13715 13716 Cont_Typ := Etype (First (Parameter_Associations (Call))); 13717 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Constant_Indexing); 13718 Is_Const := False; 13719 13720 if No (Indexing) then 13721 13722 -- Container should have at least one indexing operation 13723 13724 return False; 13725 13726 elsif Entity (Name (Call)) /= Entity (Indexing) then 13727 13728 -- This may be a variable indexing operation 13729 13730 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Variable_Indexing); 13731 13732 if No (Indexing) 13733 or else Entity (Name (Call)) /= Entity (Indexing) 13734 then 13735 return False; 13736 end if; 13737 13738 else 13739 Is_Const := True; 13740 end if; 13741 13742 Elem_Typ := Find_Value_Of_Aspect (Cont_Typ, Aspect_Iterator_Element); 13743 13744 if No (Elem_Typ) or else Entity (Elem_Typ) /= Etype (Exp) then 13745 return False; 13746 end if; 13747 13748 -- Check that the expression is not the target of an assignment, in 13749 -- which case the rewriting is not possible. 13750 13751 if not Is_Const then 13752 declare 13753 Par : Node_Id; 13754 13755 begin 13756 Par := Exp; 13757 while Present (Par) 13758 loop 13759 if Nkind (Parent (Par)) = N_Assignment_Statement 13760 and then Par = Name (Parent (Par)) 13761 then 13762 return False; 13763 13764 -- A renaming produces a reference, and the transformation 13765 -- does not apply. 13766 13767 elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then 13768 return False; 13769 13770 elsif Nkind_In 13771 (Nkind (Parent (Par)), N_Function_Call, 13772 N_Procedure_Call_Statement, 13773 N_Entry_Call_Statement) 13774 then 13775 -- Check that the element is not part of an actual for an 13776 -- in-out parameter. 13777 13778 declare 13779 F : Entity_Id; 13780 A : Node_Id; 13781 13782 begin 13783 F := First_Formal (Entity (Name (Parent (Par)))); 13784 A := First (Parameter_Associations (Parent (Par))); 13785 while Present (F) loop 13786 if A = Par and then Ekind (F) /= E_In_Parameter then 13787 return False; 13788 end if; 13789 13790 Next_Formal (F); 13791 Next (A); 13792 end loop; 13793 end; 13794 13795 -- E_In_Parameter in a call: element is not modified. 13796 13797 exit; 13798 end if; 13799 13800 Par := Parent (Par); 13801 end loop; 13802 end; 13803 end if; 13804 13805 -- The expression has the proper form and the context requires the 13806 -- element type. Retrieve the Element function of the container and 13807 -- rewrite the construct as a call to it. 13808 13809 declare 13810 Op : Elmt_Id; 13811 13812 begin 13813 Op := First_Elmt (Primitive_Operations (Cont_Typ)); 13814 while Present (Op) loop 13815 exit when Chars (Node (Op)) = Name_Element; 13816 Next_Elmt (Op); 13817 end loop; 13818 13819 if No (Op) then 13820 return False; 13821 13822 else 13823 Rewrite (Exp, 13824 Make_Function_Call (Loc, 13825 Name => New_Occurrence_Of (Node (Op), Loc), 13826 Parameter_Associations => Parameter_Associations (Call))); 13827 Analyze_And_Resolve (Exp, Entity (Elem_Typ)); 13828 return True; 13829 end if; 13830 end; 13831 end Is_Container_Element; 13832 13833 ---------------------------- 13834 -- Is_Contract_Annotation -- 13835 ---------------------------- 13836 13837 function Is_Contract_Annotation (Item : Node_Id) return Boolean is 13838 begin 13839 return Is_Package_Contract_Annotation (Item) 13840 or else 13841 Is_Subprogram_Contract_Annotation (Item); 13842 end Is_Contract_Annotation; 13843 13844 -------------------------------------- 13845 -- Is_Controlling_Limited_Procedure -- 13846 -------------------------------------- 13847 13848 function Is_Controlling_Limited_Procedure 13849 (Proc_Nam : Entity_Id) return Boolean 13850 is 13851 Param : Node_Id; 13852 Param_Typ : Entity_Id := Empty; 13853 13854 begin 13855 if Ekind (Proc_Nam) = E_Procedure 13856 and then Present (Parameter_Specifications (Parent (Proc_Nam))) 13857 then 13858 Param := 13859 Parameter_Type 13860 (First (Parameter_Specifications (Parent (Proc_Nam)))); 13861 13862 -- The formal may be an anonymous access type 13863 13864 if Nkind (Param) = N_Access_Definition then 13865 Param_Typ := Entity (Subtype_Mark (Param)); 13866 else 13867 Param_Typ := Etype (Param); 13868 end if; 13869 13870 -- In the case where an Itype was created for a dispatchin call, the 13871 -- procedure call has been rewritten. The actual may be an access to 13872 -- interface type in which case it is the designated type that is the 13873 -- controlling type. 13874 13875 elsif Present (Associated_Node_For_Itype (Proc_Nam)) 13876 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam))) 13877 and then 13878 Present (Parameter_Associations 13879 (Associated_Node_For_Itype (Proc_Nam))) 13880 then 13881 Param_Typ := 13882 Etype (First (Parameter_Associations 13883 (Associated_Node_For_Itype (Proc_Nam)))); 13884 13885 if Ekind (Param_Typ) = E_Anonymous_Access_Type then 13886 Param_Typ := Directly_Designated_Type (Param_Typ); 13887 end if; 13888 end if; 13889 13890 if Present (Param_Typ) then 13891 return 13892 Is_Interface (Param_Typ) 13893 and then Is_Limited_Record (Param_Typ); 13894 end if; 13895 13896 return False; 13897 end Is_Controlling_Limited_Procedure; 13898 13899 ----------------------------- 13900 -- Is_CPP_Constructor_Call -- 13901 ----------------------------- 13902 13903 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is 13904 begin 13905 return Nkind (N) = N_Function_Call 13906 and then Is_CPP_Class (Etype (Etype (N))) 13907 and then Is_Constructor (Entity (Name (N))) 13908 and then Is_Imported (Entity (Name (N))); 13909 end Is_CPP_Constructor_Call; 13910 13911 ------------------------- 13912 -- Is_Current_Instance -- 13913 ------------------------- 13914 13915 function Is_Current_Instance (N : Node_Id) return Boolean is 13916 Typ : constant Entity_Id := Entity (N); 13917 P : Node_Id; 13918 13919 begin 13920 -- Simplest case: entity is a concurrent type and we are currently 13921 -- inside the body. This will eventually be expanded into a call to 13922 -- Self (for tasks) or _object (for protected objects). 13923 13924 if Is_Concurrent_Type (Typ) and then In_Open_Scopes (Typ) then 13925 return True; 13926 13927 else 13928 -- Check whether the context is a (sub)type declaration for the 13929 -- type entity. 13930 13931 P := Parent (N); 13932 while Present (P) loop 13933 if Nkind_In (P, N_Full_Type_Declaration, 13934 N_Private_Type_Declaration, 13935 N_Subtype_Declaration) 13936 and then Comes_From_Source (P) 13937 and then Defining_Entity (P) = Typ 13938 then 13939 return True; 13940 13941 -- A subtype name may appear in an aspect specification for a 13942 -- Predicate_Failure aspect, for which we do not construct a 13943 -- wrapper procedure. The subtype will be replaced by the 13944 -- expression being tested when the corresponding predicate 13945 -- check is expanded. 13946 13947 elsif Nkind (P) = N_Aspect_Specification 13948 and then Nkind (Parent (P)) = N_Subtype_Declaration 13949 then 13950 return True; 13951 13952 elsif Nkind (P) = N_Pragma 13953 and then Get_Pragma_Id (P) = Pragma_Predicate_Failure 13954 then 13955 return True; 13956 end if; 13957 13958 P := Parent (P); 13959 end loop; 13960 end if; 13961 13962 -- In any other context this is not a current occurrence 13963 13964 return False; 13965 end Is_Current_Instance; 13966 13967 -------------------- 13968 -- Is_Declaration -- 13969 -------------------- 13970 13971 function Is_Declaration 13972 (N : Node_Id; 13973 Body_OK : Boolean := True; 13974 Concurrent_OK : Boolean := True; 13975 Formal_OK : Boolean := True; 13976 Generic_OK : Boolean := True; 13977 Instantiation_OK : Boolean := True; 13978 Renaming_OK : Boolean := True; 13979 Stub_OK : Boolean := True; 13980 Subprogram_OK : Boolean := True; 13981 Type_OK : Boolean := True) return Boolean 13982 is 13983 begin 13984 case Nkind (N) is 13985 13986 -- Body declarations 13987 13988 when N_Proper_Body => 13989 return Body_OK; 13990 13991 -- Concurrent type declarations 13992 13993 when N_Protected_Type_Declaration 13994 | N_Single_Protected_Declaration 13995 | N_Single_Task_Declaration 13996 | N_Task_Type_Declaration 13997 => 13998 return Concurrent_OK or Type_OK; 13999 14000 -- Formal declarations 14001 14002 when N_Formal_Abstract_Subprogram_Declaration 14003 | N_Formal_Concrete_Subprogram_Declaration 14004 | N_Formal_Object_Declaration 14005 | N_Formal_Package_Declaration 14006 | N_Formal_Type_Declaration 14007 => 14008 return Formal_OK; 14009 14010 -- Generic declarations 14011 14012 when N_Generic_Package_Declaration 14013 | N_Generic_Subprogram_Declaration 14014 => 14015 return Generic_OK; 14016 14017 -- Generic instantiations 14018 14019 when N_Function_Instantiation 14020 | N_Package_Instantiation 14021 | N_Procedure_Instantiation 14022 => 14023 return Instantiation_OK; 14024 14025 -- Generic renaming declarations 14026 14027 when N_Generic_Renaming_Declaration => 14028 return Generic_OK or Renaming_OK; 14029 14030 -- Renaming declarations 14031 14032 when N_Exception_Renaming_Declaration 14033 | N_Object_Renaming_Declaration 14034 | N_Package_Renaming_Declaration 14035 | N_Subprogram_Renaming_Declaration 14036 => 14037 return Renaming_OK; 14038 14039 -- Stub declarations 14040 14041 when N_Body_Stub => 14042 return Stub_OK; 14043 14044 -- Subprogram declarations 14045 14046 when N_Abstract_Subprogram_Declaration 14047 | N_Entry_Declaration 14048 | N_Expression_Function 14049 | N_Subprogram_Declaration 14050 => 14051 return Subprogram_OK; 14052 14053 -- Type declarations 14054 14055 when N_Full_Type_Declaration 14056 | N_Incomplete_Type_Declaration 14057 | N_Private_Extension_Declaration 14058 | N_Private_Type_Declaration 14059 | N_Subtype_Declaration 14060 => 14061 return Type_OK; 14062 14063 -- Miscellaneous 14064 14065 when N_Component_Declaration 14066 | N_Exception_Declaration 14067 | N_Implicit_Label_Declaration 14068 | N_Number_Declaration 14069 | N_Object_Declaration 14070 | N_Package_Declaration 14071 => 14072 return True; 14073 14074 when others => 14075 return False; 14076 end case; 14077 end Is_Declaration; 14078 14079 -------------------------------- 14080 -- Is_Declared_Within_Variant -- 14081 -------------------------------- 14082 14083 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is 14084 Comp_Decl : constant Node_Id := Parent (Comp); 14085 Comp_List : constant Node_Id := Parent (Comp_Decl); 14086 begin 14087 return Nkind (Parent (Comp_List)) = N_Variant; 14088 end Is_Declared_Within_Variant; 14089 14090 ---------------------------------------------- 14091 -- Is_Dependent_Component_Of_Mutable_Object -- 14092 ---------------------------------------------- 14093 14094 function Is_Dependent_Component_Of_Mutable_Object 14095 (Object : Node_Id) return Boolean 14096 is 14097 P : Node_Id; 14098 Prefix_Type : Entity_Id; 14099 P_Aliased : Boolean := False; 14100 Comp : Entity_Id; 14101 14102 Deref : Node_Id := Object; 14103 -- Dereference node, in something like X.all.Y(2) 14104 14105 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object 14106 14107 begin 14108 -- Find the dereference node if any 14109 14110 while Nkind_In (Deref, N_Indexed_Component, 14111 N_Selected_Component, 14112 N_Slice) 14113 loop 14114 Deref := Prefix (Deref); 14115 end loop; 14116 14117 -- If the prefix is a qualified expression of a variable, then function 14118 -- Is_Variable will return False for that because a qualified expression 14119 -- denotes a constant view, so we need to get the name being qualified 14120 -- so we can test below whether that's a variable (or a dereference). 14121 14122 if Nkind (Deref) = N_Qualified_Expression then 14123 Deref := Expression (Deref); 14124 end if; 14125 14126 -- Ada 2005: If we have a component or slice of a dereference, something 14127 -- like X.all.Y (2) and the type of X is access-to-constant, Is_Variable 14128 -- will return False, because it is indeed a constant view. But it might 14129 -- be a view of a variable object, so we want the following condition to 14130 -- be True in that case. 14131 14132 if Is_Variable (Object) 14133 or else Is_Variable (Deref) 14134 or else (Ada_Version >= Ada_2005 14135 and then (Nkind (Deref) = N_Explicit_Dereference 14136 or else Is_Access_Type (Etype (Deref)))) 14137 then 14138 if Nkind (Object) = N_Selected_Component then 14139 14140 -- If the selector is not a component, then we definitely return 14141 -- False (it could be a function selector in a prefix form call 14142 -- occurring in an iterator specification). 14143 14144 if not Ekind_In (Entity (Selector_Name (Object)), E_Component, 14145 E_Discriminant) 14146 then 14147 return False; 14148 end if; 14149 14150 -- Get the original node of the prefix in case it has been 14151 -- rewritten, which can occur, for example, in qualified 14152 -- expression cases. Also, a discriminant check on a selected 14153 -- component may be expanded into a dereference when removing 14154 -- side effects, and the subtype of the original node may be 14155 -- unconstrained. 14156 14157 P := Original_Node (Prefix (Object)); 14158 Prefix_Type := Etype (P); 14159 14160 -- If the prefix is a qualified expression, we want to look at its 14161 -- operand. 14162 14163 if Nkind (P) = N_Qualified_Expression then 14164 P := Expression (P); 14165 Prefix_Type := Etype (P); 14166 end if; 14167 14168 if Is_Entity_Name (P) then 14169 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then 14170 Prefix_Type := Base_Type (Prefix_Type); 14171 end if; 14172 14173 if Is_Aliased (Entity (P)) then 14174 P_Aliased := True; 14175 end if; 14176 14177 -- For explicit dereferences we get the access prefix so we can 14178 -- treat this similarly to implicit dereferences and examine the 14179 -- kind of the access type and its designated subtype further 14180 -- below. 14181 14182 elsif Nkind (P) = N_Explicit_Dereference then 14183 P := Prefix (P); 14184 Prefix_Type := Etype (P); 14185 14186 else 14187 -- Check for prefix being an aliased component??? 14188 14189 null; 14190 end if; 14191 14192 -- A heap object is constrained by its initial value 14193 14194 -- Ada 2005 (AI-363): Always assume the object could be mutable in 14195 -- the dereferenced case, since the access value might denote an 14196 -- unconstrained aliased object, whereas in Ada 95 the designated 14197 -- object is guaranteed to be constrained. A worst-case assumption 14198 -- has to apply in Ada 2005 because we can't tell at compile 14199 -- time whether the object is "constrained by its initial value", 14200 -- despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic 14201 -- rules (these rules are acknowledged to need fixing). We don't 14202 -- impose this more stringent checking for earlier Ada versions or 14203 -- when Relaxed_RM_Semantics applies (the latter for CodePeer's 14204 -- benefit, though it's unclear on why using -gnat95 would not be 14205 -- sufficient???). 14206 14207 if Ada_Version < Ada_2005 or else Relaxed_RM_Semantics then 14208 if Is_Access_Type (Prefix_Type) 14209 or else Nkind (P) = N_Explicit_Dereference 14210 then 14211 return False; 14212 end if; 14213 14214 else pragma Assert (Ada_Version >= Ada_2005); 14215 if Is_Access_Type (Prefix_Type) then 14216 -- We need to make sure we have the base subtype, in case 14217 -- this is actually an access subtype (whose Ekind will be 14218 -- E_Access_Subtype). 14219 14220 Prefix_Type := Etype (Prefix_Type); 14221 14222 -- If the access type is pool-specific, and there is no 14223 -- constrained partial view of the designated type, then the 14224 -- designated object is known to be constrained. If it's a 14225 -- formal access type and the renaming is in the generic 14226 -- spec, we also treat it as pool-specific (known to be 14227 -- constrained), but assume the worst if in the generic body 14228 -- (see RM 3.3(23.3/3)). 14229 14230 if Ekind (Prefix_Type) = E_Access_Type 14231 and then (not Is_Generic_Type (Prefix_Type) 14232 or else not In_Generic_Body (Current_Scope)) 14233 and then not Object_Type_Has_Constrained_Partial_View 14234 (Typ => Designated_Type (Prefix_Type), 14235 Scop => Current_Scope) 14236 then 14237 return False; 14238 14239 -- Otherwise (general access type, or there is a constrained 14240 -- partial view of the designated type), we need to check 14241 -- based on the designated type. 14242 14243 else 14244 Prefix_Type := Designated_Type (Prefix_Type); 14245 end if; 14246 end if; 14247 end if; 14248 14249 Comp := 14250 Original_Record_Component (Entity (Selector_Name (Object))); 14251 14252 -- As per AI-0017, the renaming is illegal in a generic body, even 14253 -- if the subtype is indefinite (only applies to prefixes of an 14254 -- untagged formal type, see RM 3.3 (23.11/3)). 14255 14256 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable 14257 14258 if not Is_Constrained (Prefix_Type) 14259 and then (Is_Definite_Subtype (Prefix_Type) 14260 or else 14261 (not Is_Tagged_Type (Prefix_Type) 14262 and then Is_Generic_Type (Prefix_Type) 14263 and then In_Generic_Body (Current_Scope))) 14264 14265 and then (Is_Declared_Within_Variant (Comp) 14266 or else Has_Discriminant_Dependent_Constraint (Comp)) 14267 and then (not P_Aliased or else Ada_Version >= Ada_2005) 14268 then 14269 return True; 14270 14271 -- If the prefix is of an access type at this point, then we want 14272 -- to return False, rather than calling this function recursively 14273 -- on the access object (which itself might be a discriminant- 14274 -- dependent component of some other object, but that isn't 14275 -- relevant to checking the object passed to us). This avoids 14276 -- issuing wrong errors when compiling with -gnatc, where there 14277 -- can be implicit dereferences that have not been expanded. 14278 14279 elsif Is_Access_Type (Etype (Prefix (Object))) then 14280 return False; 14281 14282 else 14283 return 14284 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 14285 end if; 14286 14287 elsif Nkind (Object) = N_Indexed_Component 14288 or else Nkind (Object) = N_Slice 14289 then 14290 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 14291 14292 -- A type conversion that Is_Variable is a view conversion: 14293 -- go back to the denoted object. 14294 14295 elsif Nkind (Object) = N_Type_Conversion then 14296 return 14297 Is_Dependent_Component_Of_Mutable_Object (Expression (Object)); 14298 end if; 14299 end if; 14300 14301 return False; 14302 end Is_Dependent_Component_Of_Mutable_Object; 14303 14304 --------------------- 14305 -- Is_Dereferenced -- 14306 --------------------- 14307 14308 function Is_Dereferenced (N : Node_Id) return Boolean is 14309 P : constant Node_Id := Parent (N); 14310 begin 14311 return Nkind_In (P, N_Selected_Component, 14312 N_Explicit_Dereference, 14313 N_Indexed_Component, 14314 N_Slice) 14315 and then Prefix (P) = N; 14316 end Is_Dereferenced; 14317 14318 ---------------------- 14319 -- Is_Descendant_Of -- 14320 ---------------------- 14321 14322 function Is_Descendant_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is 14323 T : Entity_Id; 14324 Etyp : Entity_Id; 14325 14326 begin 14327 pragma Assert (Nkind (T1) in N_Entity); 14328 pragma Assert (Nkind (T2) in N_Entity); 14329 14330 T := Base_Type (T1); 14331 14332 -- Immediate return if the types match 14333 14334 if T = T2 then 14335 return True; 14336 14337 -- Comment needed here ??? 14338 14339 elsif Ekind (T) = E_Class_Wide_Type then 14340 return Etype (T) = T2; 14341 14342 -- All other cases 14343 14344 else 14345 loop 14346 Etyp := Etype (T); 14347 14348 -- Done if we found the type we are looking for 14349 14350 if Etyp = T2 then 14351 return True; 14352 14353 -- Done if no more derivations to check 14354 14355 elsif T = T1 14356 or else T = Etyp 14357 then 14358 return False; 14359 14360 -- Following test catches error cases resulting from prev errors 14361 14362 elsif No (Etyp) then 14363 return False; 14364 14365 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then 14366 return False; 14367 14368 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then 14369 return False; 14370 end if; 14371 14372 T := Base_Type (Etyp); 14373 end loop; 14374 end if; 14375 end Is_Descendant_Of; 14376 14377 ---------------------------------------- 14378 -- Is_Descendant_Of_Suspension_Object -- 14379 ---------------------------------------- 14380 14381 function Is_Descendant_Of_Suspension_Object 14382 (Typ : Entity_Id) return Boolean 14383 is 14384 Cur_Typ : Entity_Id; 14385 Par_Typ : Entity_Id; 14386 14387 begin 14388 -- Climb the type derivation chain checking each parent type against 14389 -- Suspension_Object. 14390 14391 Cur_Typ := Base_Type (Typ); 14392 while Present (Cur_Typ) loop 14393 Par_Typ := Etype (Cur_Typ); 14394 14395 -- The current type is a match 14396 14397 if Is_Suspension_Object (Cur_Typ) then 14398 return True; 14399 14400 -- Stop the traversal once the root of the derivation chain has been 14401 -- reached. In that case the current type is its own base type. 14402 14403 elsif Cur_Typ = Par_Typ then 14404 exit; 14405 end if; 14406 14407 Cur_Typ := Base_Type (Par_Typ); 14408 end loop; 14409 14410 return False; 14411 end Is_Descendant_Of_Suspension_Object; 14412 14413 --------------------------------------------- 14414 -- Is_Double_Precision_Floating_Point_Type -- 14415 --------------------------------------------- 14416 14417 function Is_Double_Precision_Floating_Point_Type 14418 (E : Entity_Id) return Boolean is 14419 begin 14420 return Is_Floating_Point_Type (E) 14421 and then Machine_Radix_Value (E) = Uint_2 14422 and then Machine_Mantissa_Value (E) = UI_From_Int (53) 14423 and then Machine_Emax_Value (E) = Uint_2 ** Uint_10 14424 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_10); 14425 end Is_Double_Precision_Floating_Point_Type; 14426 14427 ----------------------------- 14428 -- Is_Effectively_Volatile -- 14429 ----------------------------- 14430 14431 function Is_Effectively_Volatile (Id : Entity_Id) return Boolean is 14432 begin 14433 if Is_Type (Id) then 14434 14435 -- An arbitrary type is effectively volatile when it is subject to 14436 -- pragma Atomic or Volatile. 14437 14438 if Is_Volatile (Id) then 14439 return True; 14440 14441 -- An array type is effectively volatile when it is subject to pragma 14442 -- Atomic_Components or Volatile_Components or its component type is 14443 -- effectively volatile. 14444 14445 elsif Is_Array_Type (Id) then 14446 declare 14447 Anc : Entity_Id := Base_Type (Id); 14448 begin 14449 if Is_Private_Type (Anc) then 14450 Anc := Full_View (Anc); 14451 end if; 14452 14453 -- Test for presence of ancestor, as the full view of a private 14454 -- type may be missing in case of error. 14455 14456 return 14457 Has_Volatile_Components (Id) 14458 or else 14459 (Present (Anc) 14460 and then Is_Effectively_Volatile (Component_Type (Anc))); 14461 end; 14462 14463 -- A protected type is always volatile 14464 14465 elsif Is_Protected_Type (Id) then 14466 return True; 14467 14468 -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is 14469 -- automatically volatile. 14470 14471 elsif Is_Descendant_Of_Suspension_Object (Id) then 14472 return True; 14473 14474 -- Otherwise the type is not effectively volatile 14475 14476 else 14477 return False; 14478 end if; 14479 14480 -- Otherwise Id denotes an object 14481 14482 else 14483 return 14484 Is_Volatile (Id) 14485 or else Has_Volatile_Components (Id) 14486 or else Is_Effectively_Volatile (Etype (Id)); 14487 end if; 14488 end Is_Effectively_Volatile; 14489 14490 ------------------------------------ 14491 -- Is_Effectively_Volatile_Object -- 14492 ------------------------------------ 14493 14494 function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean is 14495 begin 14496 if Is_Entity_Name (N) then 14497 return Is_Effectively_Volatile (Entity (N)); 14498 14499 elsif Nkind (N) = N_Indexed_Component then 14500 return Is_Effectively_Volatile_Object (Prefix (N)); 14501 14502 elsif Nkind (N) = N_Selected_Component then 14503 return 14504 Is_Effectively_Volatile_Object (Prefix (N)) 14505 or else 14506 Is_Effectively_Volatile_Object (Selector_Name (N)); 14507 14508 else 14509 return False; 14510 end if; 14511 end Is_Effectively_Volatile_Object; 14512 14513 ------------------- 14514 -- Is_Entry_Body -- 14515 ------------------- 14516 14517 function Is_Entry_Body (Id : Entity_Id) return Boolean is 14518 begin 14519 return 14520 Ekind_In (Id, E_Entry, E_Entry_Family) 14521 and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Body; 14522 end Is_Entry_Body; 14523 14524 -------------------------- 14525 -- Is_Entry_Declaration -- 14526 -------------------------- 14527 14528 function Is_Entry_Declaration (Id : Entity_Id) return Boolean is 14529 begin 14530 return 14531 Ekind_In (Id, E_Entry, E_Entry_Family) 14532 and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Declaration; 14533 end Is_Entry_Declaration; 14534 14535 ------------------------------------ 14536 -- Is_Expanded_Priority_Attribute -- 14537 ------------------------------------ 14538 14539 function Is_Expanded_Priority_Attribute (E : Entity_Id) return Boolean is 14540 begin 14541 return 14542 Nkind (E) = N_Function_Call 14543 and then not Configurable_Run_Time_Mode 14544 and then (Entity (Name (E)) = RTE (RE_Get_Ceiling) 14545 or else Entity (Name (E)) = RTE (RO_PE_Get_Ceiling)); 14546 end Is_Expanded_Priority_Attribute; 14547 14548 ---------------------------- 14549 -- Is_Expression_Function -- 14550 ---------------------------- 14551 14552 function Is_Expression_Function (Subp : Entity_Id) return Boolean is 14553 begin 14554 if Ekind_In (Subp, E_Function, E_Subprogram_Body) then 14555 return 14556 Nkind (Original_Node (Unit_Declaration_Node (Subp))) = 14557 N_Expression_Function; 14558 else 14559 return False; 14560 end if; 14561 end Is_Expression_Function; 14562 14563 ------------------------------------------ 14564 -- Is_Expression_Function_Or_Completion -- 14565 ------------------------------------------ 14566 14567 function Is_Expression_Function_Or_Completion 14568 (Subp : Entity_Id) return Boolean 14569 is 14570 Subp_Decl : Node_Id; 14571 14572 begin 14573 if Ekind (Subp) = E_Function then 14574 Subp_Decl := Unit_Declaration_Node (Subp); 14575 14576 -- The function declaration is either an expression function or is 14577 -- completed by an expression function body. 14578 14579 return 14580 Is_Expression_Function (Subp) 14581 or else (Nkind (Subp_Decl) = N_Subprogram_Declaration 14582 and then Present (Corresponding_Body (Subp_Decl)) 14583 and then Is_Expression_Function 14584 (Corresponding_Body (Subp_Decl))); 14585 14586 elsif Ekind (Subp) = E_Subprogram_Body then 14587 return Is_Expression_Function (Subp); 14588 14589 else 14590 return False; 14591 end if; 14592 end Is_Expression_Function_Or_Completion; 14593 14594 ----------------------- 14595 -- Is_EVF_Expression -- 14596 ----------------------- 14597 14598 function Is_EVF_Expression (N : Node_Id) return Boolean is 14599 Orig_N : constant Node_Id := Original_Node (N); 14600 Alt : Node_Id; 14601 Expr : Node_Id; 14602 Id : Entity_Id; 14603 14604 begin 14605 -- Detect a reference to a formal parameter of a specific tagged type 14606 -- whose related subprogram is subject to pragma Expresions_Visible with 14607 -- value "False". 14608 14609 if Is_Entity_Name (N) and then Present (Entity (N)) then 14610 Id := Entity (N); 14611 14612 return 14613 Is_Formal (Id) 14614 and then Is_Specific_Tagged_Type (Etype (Id)) 14615 and then Extensions_Visible_Status (Id) = 14616 Extensions_Visible_False; 14617 14618 -- A case expression is an EVF expression when it contains at least one 14619 -- EVF dependent_expression. Note that a case expression may have been 14620 -- expanded, hence the use of Original_Node. 14621 14622 elsif Nkind (Orig_N) = N_Case_Expression then 14623 Alt := First (Alternatives (Orig_N)); 14624 while Present (Alt) loop 14625 if Is_EVF_Expression (Expression (Alt)) then 14626 return True; 14627 end if; 14628 14629 Next (Alt); 14630 end loop; 14631 14632 -- An if expression is an EVF expression when it contains at least one 14633 -- EVF dependent_expression. Note that an if expression may have been 14634 -- expanded, hence the use of Original_Node. 14635 14636 elsif Nkind (Orig_N) = N_If_Expression then 14637 Expr := Next (First (Expressions (Orig_N))); 14638 while Present (Expr) loop 14639 if Is_EVF_Expression (Expr) then 14640 return True; 14641 end if; 14642 14643 Next (Expr); 14644 end loop; 14645 14646 -- A qualified expression or a type conversion is an EVF expression when 14647 -- its operand is an EVF expression. 14648 14649 elsif Nkind_In (N, N_Qualified_Expression, 14650 N_Unchecked_Type_Conversion, 14651 N_Type_Conversion) 14652 then 14653 return Is_EVF_Expression (Expression (N)); 14654 14655 -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when 14656 -- their prefix denotes an EVF expression. 14657 14658 elsif Nkind (N) = N_Attribute_Reference 14659 and then Nam_In (Attribute_Name (N), Name_Loop_Entry, 14660 Name_Old, 14661 Name_Update) 14662 then 14663 return Is_EVF_Expression (Prefix (N)); 14664 end if; 14665 14666 return False; 14667 end Is_EVF_Expression; 14668 14669 -------------- 14670 -- Is_False -- 14671 -------------- 14672 14673 function Is_False (U : Uint) return Boolean is 14674 begin 14675 return (U = 0); 14676 end Is_False; 14677 14678 --------------------------- 14679 -- Is_Fixed_Model_Number -- 14680 --------------------------- 14681 14682 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is 14683 S : constant Ureal := Small_Value (T); 14684 M : Urealp.Save_Mark; 14685 R : Boolean; 14686 14687 begin 14688 M := Urealp.Mark; 14689 R := (U = UR_Trunc (U / S) * S); 14690 Urealp.Release (M); 14691 return R; 14692 end Is_Fixed_Model_Number; 14693 14694 ------------------------------- 14695 -- Is_Fully_Initialized_Type -- 14696 ------------------------------- 14697 14698 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is 14699 begin 14700 -- Scalar types 14701 14702 if Is_Scalar_Type (Typ) then 14703 14704 -- A scalar type with an aspect Default_Value is fully initialized 14705 14706 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization 14707 -- of a scalar type, but we don't take that into account here, since 14708 -- we don't want these to affect warnings. 14709 14710 return Has_Default_Aspect (Typ); 14711 14712 elsif Is_Access_Type (Typ) then 14713 return True; 14714 14715 elsif Is_Array_Type (Typ) then 14716 if Is_Fully_Initialized_Type (Component_Type (Typ)) 14717 or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ)) 14718 then 14719 return True; 14720 end if; 14721 14722 -- An interesting case, if we have a constrained type one of whose 14723 -- bounds is known to be null, then there are no elements to be 14724 -- initialized, so all the elements are initialized. 14725 14726 if Is_Constrained (Typ) then 14727 declare 14728 Indx : Node_Id; 14729 Indx_Typ : Entity_Id; 14730 Lbd, Hbd : Node_Id; 14731 14732 begin 14733 Indx := First_Index (Typ); 14734 while Present (Indx) loop 14735 if Etype (Indx) = Any_Type then 14736 return False; 14737 14738 -- If index is a range, use directly 14739 14740 elsif Nkind (Indx) = N_Range then 14741 Lbd := Low_Bound (Indx); 14742 Hbd := High_Bound (Indx); 14743 14744 else 14745 Indx_Typ := Etype (Indx); 14746 14747 if Is_Private_Type (Indx_Typ) then 14748 Indx_Typ := Full_View (Indx_Typ); 14749 end if; 14750 14751 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then 14752 return False; 14753 else 14754 Lbd := Type_Low_Bound (Indx_Typ); 14755 Hbd := Type_High_Bound (Indx_Typ); 14756 end if; 14757 end if; 14758 14759 if Compile_Time_Known_Value (Lbd) 14760 and then 14761 Compile_Time_Known_Value (Hbd) 14762 then 14763 if Expr_Value (Hbd) < Expr_Value (Lbd) then 14764 return True; 14765 end if; 14766 end if; 14767 14768 Next_Index (Indx); 14769 end loop; 14770 end; 14771 end if; 14772 14773 -- If no null indexes, then type is not fully initialized 14774 14775 return False; 14776 14777 -- Record types 14778 14779 elsif Is_Record_Type (Typ) then 14780 if Has_Discriminants (Typ) 14781 and then 14782 Present (Discriminant_Default_Value (First_Discriminant (Typ))) 14783 and then Is_Fully_Initialized_Variant (Typ) 14784 then 14785 return True; 14786 end if; 14787 14788 -- We consider bounded string types to be fully initialized, because 14789 -- otherwise we get false alarms when the Data component is not 14790 -- default-initialized. 14791 14792 if Is_Bounded_String (Typ) then 14793 return True; 14794 end if; 14795 14796 -- Controlled records are considered to be fully initialized if 14797 -- there is a user defined Initialize routine. This may not be 14798 -- entirely correct, but as the spec notes, we are guessing here 14799 -- what is best from the point of view of issuing warnings. 14800 14801 if Is_Controlled (Typ) then 14802 declare 14803 Utyp : constant Entity_Id := Underlying_Type (Typ); 14804 14805 begin 14806 if Present (Utyp) then 14807 declare 14808 Init : constant Entity_Id := 14809 (Find_Optional_Prim_Op 14810 (Underlying_Type (Typ), Name_Initialize)); 14811 14812 begin 14813 if Present (Init) 14814 and then Comes_From_Source (Init) 14815 and then not In_Predefined_Unit (Init) 14816 then 14817 return True; 14818 14819 elsif Has_Null_Extension (Typ) 14820 and then 14821 Is_Fully_Initialized_Type 14822 (Etype (Base_Type (Typ))) 14823 then 14824 return True; 14825 end if; 14826 end; 14827 end if; 14828 end; 14829 end if; 14830 14831 -- Otherwise see if all record components are initialized 14832 14833 declare 14834 Ent : Entity_Id; 14835 14836 begin 14837 Ent := First_Entity (Typ); 14838 while Present (Ent) loop 14839 if Ekind (Ent) = E_Component 14840 and then (No (Parent (Ent)) 14841 or else No (Expression (Parent (Ent)))) 14842 and then not Is_Fully_Initialized_Type (Etype (Ent)) 14843 14844 -- Special VM case for tag components, which need to be 14845 -- defined in this case, but are never initialized as VMs 14846 -- are using other dispatching mechanisms. Ignore this 14847 -- uninitialized case. Note that this applies both to the 14848 -- uTag entry and the main vtable pointer (CPP_Class case). 14849 14850 and then (Tagged_Type_Expansion or else not Is_Tag (Ent)) 14851 then 14852 return False; 14853 end if; 14854 14855 Next_Entity (Ent); 14856 end loop; 14857 end; 14858 14859 -- No uninitialized components, so type is fully initialized. 14860 -- Note that this catches the case of no components as well. 14861 14862 return True; 14863 14864 elsif Is_Concurrent_Type (Typ) then 14865 return True; 14866 14867 elsif Is_Private_Type (Typ) then 14868 declare 14869 U : constant Entity_Id := Underlying_Type (Typ); 14870 14871 begin 14872 if No (U) then 14873 return False; 14874 else 14875 return Is_Fully_Initialized_Type (U); 14876 end if; 14877 end; 14878 14879 else 14880 return False; 14881 end if; 14882 end Is_Fully_Initialized_Type; 14883 14884 ---------------------------------- 14885 -- Is_Fully_Initialized_Variant -- 14886 ---------------------------------- 14887 14888 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is 14889 Loc : constant Source_Ptr := Sloc (Typ); 14890 Constraints : constant List_Id := New_List; 14891 Components : constant Elist_Id := New_Elmt_List; 14892 Comp_Elmt : Elmt_Id; 14893 Comp_Id : Node_Id; 14894 Comp_List : Node_Id; 14895 Discr : Entity_Id; 14896 Discr_Val : Node_Id; 14897 14898 Report_Errors : Boolean; 14899 pragma Warnings (Off, Report_Errors); 14900 14901 begin 14902 if Serious_Errors_Detected > 0 then 14903 return False; 14904 end if; 14905 14906 if Is_Record_Type (Typ) 14907 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration 14908 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition 14909 then 14910 Comp_List := Component_List (Type_Definition (Parent (Typ))); 14911 14912 Discr := First_Discriminant (Typ); 14913 while Present (Discr) loop 14914 if Nkind (Parent (Discr)) = N_Discriminant_Specification then 14915 Discr_Val := Expression (Parent (Discr)); 14916 14917 if Present (Discr_Val) 14918 and then Is_OK_Static_Expression (Discr_Val) 14919 then 14920 Append_To (Constraints, 14921 Make_Component_Association (Loc, 14922 Choices => New_List (New_Occurrence_Of (Discr, Loc)), 14923 Expression => New_Copy (Discr_Val))); 14924 else 14925 return False; 14926 end if; 14927 else 14928 return False; 14929 end if; 14930 14931 Next_Discriminant (Discr); 14932 end loop; 14933 14934 Gather_Components 14935 (Typ => Typ, 14936 Comp_List => Comp_List, 14937 Governed_By => Constraints, 14938 Into => Components, 14939 Report_Errors => Report_Errors); 14940 14941 -- Check that each component present is fully initialized 14942 14943 Comp_Elmt := First_Elmt (Components); 14944 while Present (Comp_Elmt) loop 14945 Comp_Id := Node (Comp_Elmt); 14946 14947 if Ekind (Comp_Id) = E_Component 14948 and then (No (Parent (Comp_Id)) 14949 or else No (Expression (Parent (Comp_Id)))) 14950 and then not Is_Fully_Initialized_Type (Etype (Comp_Id)) 14951 then 14952 return False; 14953 end if; 14954 14955 Next_Elmt (Comp_Elmt); 14956 end loop; 14957 14958 return True; 14959 14960 elsif Is_Private_Type (Typ) then 14961 declare 14962 U : constant Entity_Id := Underlying_Type (Typ); 14963 14964 begin 14965 if No (U) then 14966 return False; 14967 else 14968 return Is_Fully_Initialized_Variant (U); 14969 end if; 14970 end; 14971 14972 else 14973 return False; 14974 end if; 14975 end Is_Fully_Initialized_Variant; 14976 14977 ------------------------------------ 14978 -- Is_Generic_Declaration_Or_Body -- 14979 ------------------------------------ 14980 14981 function Is_Generic_Declaration_Or_Body (Decl : Node_Id) return Boolean is 14982 Spec_Decl : Node_Id; 14983 14984 begin 14985 -- Package/subprogram body 14986 14987 if Nkind_In (Decl, N_Package_Body, N_Subprogram_Body) 14988 and then Present (Corresponding_Spec (Decl)) 14989 then 14990 Spec_Decl := Unit_Declaration_Node (Corresponding_Spec (Decl)); 14991 14992 -- Package/subprogram body stub 14993 14994 elsif Nkind_In (Decl, N_Package_Body_Stub, N_Subprogram_Body_Stub) 14995 and then Present (Corresponding_Spec_Of_Stub (Decl)) 14996 then 14997 Spec_Decl := 14998 Unit_Declaration_Node (Corresponding_Spec_Of_Stub (Decl)); 14999 15000 -- All other cases 15001 15002 else 15003 Spec_Decl := Decl; 15004 end if; 15005 15006 -- Rather than inspecting the defining entity of the spec declaration, 15007 -- look at its Nkind. This takes care of the case where the analysis of 15008 -- a generic body modifies the Ekind of its spec to allow for recursive 15009 -- calls. 15010 15011 return 15012 Nkind_In (Spec_Decl, N_Generic_Package_Declaration, 15013 N_Generic_Subprogram_Declaration); 15014 end Is_Generic_Declaration_Or_Body; 15015 15016 ---------------------------- 15017 -- Is_Inherited_Operation -- 15018 ---------------------------- 15019 15020 function Is_Inherited_Operation (E : Entity_Id) return Boolean is 15021 pragma Assert (Is_Overloadable (E)); 15022 Kind : constant Node_Kind := Nkind (Parent (E)); 15023 begin 15024 return Kind = N_Full_Type_Declaration 15025 or else Kind = N_Private_Extension_Declaration 15026 or else Kind = N_Subtype_Declaration 15027 or else (Ekind (E) = E_Enumeration_Literal 15028 and then Is_Derived_Type (Etype (E))); 15029 end Is_Inherited_Operation; 15030 15031 ------------------------------------- 15032 -- Is_Inherited_Operation_For_Type -- 15033 ------------------------------------- 15034 15035 function Is_Inherited_Operation_For_Type 15036 (E : Entity_Id; 15037 Typ : Entity_Id) return Boolean 15038 is 15039 begin 15040 -- Check that the operation has been created by the type declaration 15041 15042 return Is_Inherited_Operation (E) 15043 and then Defining_Identifier (Parent (E)) = Typ; 15044 end Is_Inherited_Operation_For_Type; 15045 15046 -------------------------------------- 15047 -- Is_Inlinable_Expression_Function -- 15048 -------------------------------------- 15049 15050 function Is_Inlinable_Expression_Function 15051 (Subp : Entity_Id) return Boolean 15052 is 15053 Return_Expr : Node_Id; 15054 15055 begin 15056 if Is_Expression_Function_Or_Completion (Subp) 15057 and then Has_Pragma_Inline_Always (Subp) 15058 and then Needs_No_Actuals (Subp) 15059 and then No (Contract (Subp)) 15060 and then not Is_Dispatching_Operation (Subp) 15061 and then Needs_Finalization (Etype (Subp)) 15062 and then not Is_Class_Wide_Type (Etype (Subp)) 15063 and then not (Has_Invariants (Etype (Subp))) 15064 and then Present (Subprogram_Body (Subp)) 15065 and then Was_Expression_Function (Subprogram_Body (Subp)) 15066 then 15067 Return_Expr := Expression_Of_Expression_Function (Subp); 15068 15069 -- The returned object must not have a qualified expression and its 15070 -- nominal subtype must be statically compatible with the result 15071 -- subtype of the expression function. 15072 15073 return 15074 Nkind (Return_Expr) = N_Identifier 15075 and then Etype (Return_Expr) = Etype (Subp); 15076 end if; 15077 15078 return False; 15079 end Is_Inlinable_Expression_Function; 15080 15081 ----------------- 15082 -- Is_Iterator -- 15083 ----------------- 15084 15085 function Is_Iterator (Typ : Entity_Id) return Boolean is 15086 function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean; 15087 -- Determine whether type Iter_Typ is a predefined forward or reversible 15088 -- iterator. 15089 15090 ---------------------- 15091 -- Denotes_Iterator -- 15092 ---------------------- 15093 15094 function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean is 15095 begin 15096 -- Check that the name matches, and that the ultimate ancestor is in 15097 -- a predefined unit, i.e the one that declares iterator interfaces. 15098 15099 return 15100 Nam_In (Chars (Iter_Typ), Name_Forward_Iterator, 15101 Name_Reversible_Iterator) 15102 and then In_Predefined_Unit (Root_Type (Iter_Typ)); 15103 end Denotes_Iterator; 15104 15105 -- Local variables 15106 15107 Iface_Elmt : Elmt_Id; 15108 Ifaces : Elist_Id; 15109 15110 -- Start of processing for Is_Iterator 15111 15112 begin 15113 -- The type may be a subtype of a descendant of the proper instance of 15114 -- the predefined interface type, so we must use the root type of the 15115 -- given type. The same is done for Is_Reversible_Iterator. 15116 15117 if Is_Class_Wide_Type (Typ) 15118 and then Denotes_Iterator (Root_Type (Typ)) 15119 then 15120 return True; 15121 15122 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then 15123 return False; 15124 15125 elsif Present (Find_Value_Of_Aspect (Typ, Aspect_Iterable)) then 15126 return True; 15127 15128 else 15129 Collect_Interfaces (Typ, Ifaces); 15130 15131 Iface_Elmt := First_Elmt (Ifaces); 15132 while Present (Iface_Elmt) loop 15133 if Denotes_Iterator (Node (Iface_Elmt)) then 15134 return True; 15135 end if; 15136 15137 Next_Elmt (Iface_Elmt); 15138 end loop; 15139 15140 return False; 15141 end if; 15142 end Is_Iterator; 15143 15144 ---------------------------- 15145 -- Is_Iterator_Over_Array -- 15146 ---------------------------- 15147 15148 function Is_Iterator_Over_Array (N : Node_Id) return Boolean is 15149 Container : constant Node_Id := Name (N); 15150 Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); 15151 begin 15152 return Is_Array_Type (Container_Typ); 15153 end Is_Iterator_Over_Array; 15154 15155 ------------ 15156 -- Is_LHS -- 15157 ------------ 15158 15159 -- We seem to have a lot of overlapping functions that do similar things 15160 -- (testing for left hand sides or lvalues???). 15161 15162 function Is_LHS (N : Node_Id) return Is_LHS_Result is 15163 P : constant Node_Id := Parent (N); 15164 15165 begin 15166 -- Return True if we are the left hand side of an assignment statement 15167 15168 if Nkind (P) = N_Assignment_Statement then 15169 if Name (P) = N then 15170 return Yes; 15171 else 15172 return No; 15173 end if; 15174 15175 -- Case of prefix of indexed or selected component or slice 15176 15177 elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice) 15178 and then N = Prefix (P) 15179 then 15180 -- Here we have the case where the parent P is N.Q or N(Q .. R). 15181 -- If P is an LHS, then N is also effectively an LHS, but there 15182 -- is an important exception. If N is of an access type, then 15183 -- what we really have is N.all.Q (or N.all(Q .. R)). In either 15184 -- case this makes N.all a left hand side but not N itself. 15185 15186 -- If we don't know the type yet, this is the case where we return 15187 -- Unknown, since the answer depends on the type which is unknown. 15188 15189 if No (Etype (N)) then 15190 return Unknown; 15191 15192 -- We have an Etype set, so we can check it 15193 15194 elsif Is_Access_Type (Etype (N)) then 15195 return No; 15196 15197 -- OK, not access type case, so just test whole expression 15198 15199 else 15200 return Is_LHS (P); 15201 end if; 15202 15203 -- All other cases are not left hand sides 15204 15205 else 15206 return No; 15207 end if; 15208 end Is_LHS; 15209 15210 ----------------------------- 15211 -- Is_Library_Level_Entity -- 15212 ----------------------------- 15213 15214 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is 15215 begin 15216 -- The following is a small optimization, and it also properly handles 15217 -- discriminals, which in task bodies might appear in expressions before 15218 -- the corresponding procedure has been created, and which therefore do 15219 -- not have an assigned scope. 15220 15221 if Is_Formal (E) then 15222 return False; 15223 end if; 15224 15225 -- Normal test is simply that the enclosing dynamic scope is Standard 15226 15227 return Enclosing_Dynamic_Scope (E) = Standard_Standard; 15228 end Is_Library_Level_Entity; 15229 15230 -------------------------------- 15231 -- Is_Limited_Class_Wide_Type -- 15232 -------------------------------- 15233 15234 function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is 15235 begin 15236 return 15237 Is_Class_Wide_Type (Typ) 15238 and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ)); 15239 end Is_Limited_Class_Wide_Type; 15240 15241 --------------------------------- 15242 -- Is_Local_Variable_Reference -- 15243 --------------------------------- 15244 15245 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is 15246 begin 15247 if not Is_Entity_Name (Expr) then 15248 return False; 15249 15250 else 15251 declare 15252 Ent : constant Entity_Id := Entity (Expr); 15253 Sub : constant Entity_Id := Enclosing_Subprogram (Ent); 15254 begin 15255 if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then 15256 return False; 15257 else 15258 return Present (Sub) and then Sub = Current_Subprogram; 15259 end if; 15260 end; 15261 end if; 15262 end Is_Local_Variable_Reference; 15263 15264 ----------------------- 15265 -- Is_Name_Reference -- 15266 ----------------------- 15267 15268 function Is_Name_Reference (N : Node_Id) return Boolean is 15269 begin 15270 if Is_Entity_Name (N) then 15271 return Present (Entity (N)) and then Is_Object (Entity (N)); 15272 end if; 15273 15274 case Nkind (N) is 15275 when N_Indexed_Component 15276 | N_Slice 15277 => 15278 return 15279 Is_Name_Reference (Prefix (N)) 15280 or else Is_Access_Type (Etype (Prefix (N))); 15281 15282 -- Attributes 'Input, 'Old and 'Result produce objects 15283 15284 when N_Attribute_Reference => 15285 return 15286 Nam_In (Attribute_Name (N), Name_Input, Name_Old, Name_Result); 15287 15288 when N_Selected_Component => 15289 return 15290 Is_Name_Reference (Selector_Name (N)) 15291 and then 15292 (Is_Name_Reference (Prefix (N)) 15293 or else Is_Access_Type (Etype (Prefix (N)))); 15294 15295 when N_Explicit_Dereference => 15296 return True; 15297 15298 -- A view conversion of a tagged name is a name reference 15299 15300 when N_Type_Conversion => 15301 return 15302 Is_Tagged_Type (Etype (Subtype_Mark (N))) 15303 and then Is_Tagged_Type (Etype (Expression (N))) 15304 and then Is_Name_Reference (Expression (N)); 15305 15306 -- An unchecked type conversion is considered to be a name if the 15307 -- operand is a name (this construction arises only as a result of 15308 -- expansion activities). 15309 15310 when N_Unchecked_Type_Conversion => 15311 return Is_Name_Reference (Expression (N)); 15312 15313 when others => 15314 return False; 15315 end case; 15316 end Is_Name_Reference; 15317 15318 ------------------------------------ 15319 -- Is_Non_Preelaborable_Construct -- 15320 ------------------------------------ 15321 15322 function Is_Non_Preelaborable_Construct (N : Node_Id) return Boolean is 15323 15324 -- NOTE: the routines within Is_Non_Preelaborable_Construct are 15325 -- intentionally unnested to avoid deep indentation of code. 15326 15327 Non_Preelaborable : exception; 15328 -- This exception is raised when the construct violates preelaborability 15329 -- to terminate the recursion. 15330 15331 procedure Visit (Nod : Node_Id); 15332 -- Semantically inspect construct Nod to determine whether it violates 15333 -- preelaborability. This routine raises Non_Preelaborable. 15334 15335 procedure Visit_List (List : List_Id); 15336 pragma Inline (Visit_List); 15337 -- Invoke Visit on each element of list List. This routine raises 15338 -- Non_Preelaborable. 15339 15340 procedure Visit_Pragma (Prag : Node_Id); 15341 pragma Inline (Visit_Pragma); 15342 -- Semantically inspect pragma Prag to determine whether it violates 15343 -- preelaborability. This routine raises Non_Preelaborable. 15344 15345 procedure Visit_Subexpression (Expr : Node_Id); 15346 pragma Inline (Visit_Subexpression); 15347 -- Semantically inspect expression Expr to determine whether it violates 15348 -- preelaborability. This routine raises Non_Preelaborable. 15349 15350 ----------- 15351 -- Visit -- 15352 ----------- 15353 15354 procedure Visit (Nod : Node_Id) is 15355 begin 15356 case Nkind (Nod) is 15357 15358 -- Declarations 15359 15360 when N_Component_Declaration => 15361 15362 -- Defining_Identifier is left out because it is not relevant 15363 -- for preelaborability. 15364 15365 Visit (Component_Definition (Nod)); 15366 Visit (Expression (Nod)); 15367 15368 when N_Derived_Type_Definition => 15369 15370 -- Interface_List is left out because it is not relevant for 15371 -- preelaborability. 15372 15373 Visit (Record_Extension_Part (Nod)); 15374 Visit (Subtype_Indication (Nod)); 15375 15376 when N_Entry_Declaration => 15377 15378 -- A protected type with at leat one entry is not preelaborable 15379 -- while task types are never preelaborable. This renders entry 15380 -- declarations non-preelaborable. 15381 15382 raise Non_Preelaborable; 15383 15384 when N_Full_Type_Declaration => 15385 15386 -- Defining_Identifier and Discriminant_Specifications are left 15387 -- out because they are not relevant for preelaborability. 15388 15389 Visit (Type_Definition (Nod)); 15390 15391 when N_Function_Instantiation 15392 | N_Package_Instantiation 15393 | N_Procedure_Instantiation 15394 => 15395 -- Defining_Unit_Name and Name are left out because they are 15396 -- not relevant for preelaborability. 15397 15398 Visit_List (Generic_Associations (Nod)); 15399 15400 when N_Object_Declaration => 15401 15402 -- Defining_Identifier is left out because it is not relevant 15403 -- for preelaborability. 15404 15405 Visit (Object_Definition (Nod)); 15406 15407 if Has_Init_Expression (Nod) then 15408 Visit (Expression (Nod)); 15409 15410 elsif not Has_Preelaborable_Initialization 15411 (Etype (Defining_Entity (Nod))) 15412 then 15413 raise Non_Preelaborable; 15414 end if; 15415 15416 when N_Private_Extension_Declaration 15417 | N_Subtype_Declaration 15418 => 15419 -- Defining_Identifier, Discriminant_Specifications, and 15420 -- Interface_List are left out because they are not relevant 15421 -- for preelaborability. 15422 15423 Visit (Subtype_Indication (Nod)); 15424 15425 when N_Protected_Type_Declaration 15426 | N_Single_Protected_Declaration 15427 => 15428 -- Defining_Identifier, Discriminant_Specifications, and 15429 -- Interface_List are left out because they are not relevant 15430 -- for preelaborability. 15431 15432 Visit (Protected_Definition (Nod)); 15433 15434 -- A [single] task type is never preelaborable 15435 15436 when N_Single_Task_Declaration 15437 | N_Task_Type_Declaration 15438 => 15439 raise Non_Preelaborable; 15440 15441 -- Pragmas 15442 15443 when N_Pragma => 15444 Visit_Pragma (Nod); 15445 15446 -- Statements 15447 15448 when N_Statement_Other_Than_Procedure_Call => 15449 if Nkind (Nod) /= N_Null_Statement then 15450 raise Non_Preelaborable; 15451 end if; 15452 15453 -- Subexpressions 15454 15455 when N_Subexpr => 15456 Visit_Subexpression (Nod); 15457 15458 -- Special 15459 15460 when N_Access_To_Object_Definition => 15461 Visit (Subtype_Indication (Nod)); 15462 15463 when N_Case_Expression_Alternative => 15464 Visit (Expression (Nod)); 15465 Visit_List (Discrete_Choices (Nod)); 15466 15467 when N_Component_Definition => 15468 Visit (Access_Definition (Nod)); 15469 Visit (Subtype_Indication (Nod)); 15470 15471 when N_Component_List => 15472 Visit_List (Component_Items (Nod)); 15473 Visit (Variant_Part (Nod)); 15474 15475 when N_Constrained_Array_Definition => 15476 Visit_List (Discrete_Subtype_Definitions (Nod)); 15477 Visit (Component_Definition (Nod)); 15478 15479 when N_Delta_Constraint 15480 | N_Digits_Constraint 15481 => 15482 -- Delta_Expression and Digits_Expression are left out because 15483 -- they are not relevant for preelaborability. 15484 15485 Visit (Range_Constraint (Nod)); 15486 15487 when N_Discriminant_Specification => 15488 15489 -- Defining_Identifier and Expression are left out because they 15490 -- are not relevant for preelaborability. 15491 15492 Visit (Discriminant_Type (Nod)); 15493 15494 when N_Generic_Association => 15495 15496 -- Selector_Name is left out because it is not relevant for 15497 -- preelaborability. 15498 15499 Visit (Explicit_Generic_Actual_Parameter (Nod)); 15500 15501 when N_Index_Or_Discriminant_Constraint => 15502 Visit_List (Constraints (Nod)); 15503 15504 when N_Iterator_Specification => 15505 15506 -- Defining_Identifier is left out because it is not relevant 15507 -- for preelaborability. 15508 15509 Visit (Name (Nod)); 15510 Visit (Subtype_Indication (Nod)); 15511 15512 when N_Loop_Parameter_Specification => 15513 15514 -- Defining_Identifier is left out because it is not relevant 15515 -- for preelaborability. 15516 15517 Visit (Discrete_Subtype_Definition (Nod)); 15518 15519 when N_Protected_Definition => 15520 15521 -- End_Label is left out because it is not relevant for 15522 -- preelaborability. 15523 15524 Visit_List (Private_Declarations (Nod)); 15525 Visit_List (Visible_Declarations (Nod)); 15526 15527 when N_Range_Constraint => 15528 Visit (Range_Expression (Nod)); 15529 15530 when N_Record_Definition 15531 | N_Variant 15532 => 15533 -- End_Label, Discrete_Choices, and Interface_List are left out 15534 -- because they are not relevant for preelaborability. 15535 15536 Visit (Component_List (Nod)); 15537 15538 when N_Subtype_Indication => 15539 15540 -- Subtype_Mark is left out because it is not relevant for 15541 -- preelaborability. 15542 15543 Visit (Constraint (Nod)); 15544 15545 when N_Unconstrained_Array_Definition => 15546 15547 -- Subtype_Marks is left out because it is not relevant for 15548 -- preelaborability. 15549 15550 Visit (Component_Definition (Nod)); 15551 15552 when N_Variant_Part => 15553 15554 -- Name is left out because it is not relevant for 15555 -- preelaborability. 15556 15557 Visit_List (Variants (Nod)); 15558 15559 -- Default 15560 15561 when others => 15562 null; 15563 end case; 15564 end Visit; 15565 15566 ---------------- 15567 -- Visit_List -- 15568 ---------------- 15569 15570 procedure Visit_List (List : List_Id) is 15571 Nod : Node_Id; 15572 15573 begin 15574 if Present (List) then 15575 Nod := First (List); 15576 while Present (Nod) loop 15577 Visit (Nod); 15578 Next (Nod); 15579 end loop; 15580 end if; 15581 end Visit_List; 15582 15583 ------------------ 15584 -- Visit_Pragma -- 15585 ------------------ 15586 15587 procedure Visit_Pragma (Prag : Node_Id) is 15588 begin 15589 case Get_Pragma_Id (Prag) is 15590 when Pragma_Assert 15591 | Pragma_Assert_And_Cut 15592 | Pragma_Assume 15593 | Pragma_Async_Readers 15594 | Pragma_Async_Writers 15595 | Pragma_Attribute_Definition 15596 | Pragma_Check 15597 | Pragma_Constant_After_Elaboration 15598 | Pragma_CPU 15599 | Pragma_Deadline_Floor 15600 | Pragma_Dispatching_Domain 15601 | Pragma_Effective_Reads 15602 | Pragma_Effective_Writes 15603 | Pragma_Extensions_Visible 15604 | Pragma_Ghost 15605 | Pragma_Secondary_Stack_Size 15606 | Pragma_Task_Name 15607 | Pragma_Volatile_Function 15608 => 15609 Visit_List (Pragma_Argument_Associations (Prag)); 15610 15611 -- Default 15612 15613 when others => 15614 null; 15615 end case; 15616 end Visit_Pragma; 15617 15618 ------------------------- 15619 -- Visit_Subexpression -- 15620 ------------------------- 15621 15622 procedure Visit_Subexpression (Expr : Node_Id) is 15623 procedure Visit_Aggregate (Aggr : Node_Id); 15624 pragma Inline (Visit_Aggregate); 15625 -- Semantically inspect aggregate Aggr to determine whether it 15626 -- violates preelaborability. 15627 15628 --------------------- 15629 -- Visit_Aggregate -- 15630 --------------------- 15631 15632 procedure Visit_Aggregate (Aggr : Node_Id) is 15633 begin 15634 if not Is_Preelaborable_Aggregate (Aggr) then 15635 raise Non_Preelaborable; 15636 end if; 15637 end Visit_Aggregate; 15638 15639 -- Start of processing for Visit_Subexpression 15640 15641 begin 15642 case Nkind (Expr) is 15643 when N_Allocator 15644 | N_Qualified_Expression 15645 | N_Type_Conversion 15646 | N_Unchecked_Expression 15647 | N_Unchecked_Type_Conversion 15648 => 15649 -- Subpool_Handle_Name and Subtype_Mark are left out because 15650 -- they are not relevant for preelaborability. 15651 15652 Visit (Expression (Expr)); 15653 15654 when N_Aggregate 15655 | N_Extension_Aggregate 15656 => 15657 Visit_Aggregate (Expr); 15658 15659 when N_Attribute_Reference 15660 | N_Explicit_Dereference 15661 | N_Reference 15662 => 15663 -- Attribute_Name and Expressions are left out because they are 15664 -- not relevant for preelaborability. 15665 15666 Visit (Prefix (Expr)); 15667 15668 when N_Case_Expression => 15669 15670 -- End_Span is left out because it is not relevant for 15671 -- preelaborability. 15672 15673 Visit_List (Alternatives (Expr)); 15674 Visit (Expression (Expr)); 15675 15676 when N_Delta_Aggregate => 15677 Visit_Aggregate (Expr); 15678 Visit (Expression (Expr)); 15679 15680 when N_Expression_With_Actions => 15681 Visit_List (Actions (Expr)); 15682 Visit (Expression (Expr)); 15683 15684 when N_If_Expression => 15685 Visit_List (Expressions (Expr)); 15686 15687 when N_Quantified_Expression => 15688 Visit (Condition (Expr)); 15689 Visit (Iterator_Specification (Expr)); 15690 Visit (Loop_Parameter_Specification (Expr)); 15691 15692 when N_Range => 15693 Visit (High_Bound (Expr)); 15694 Visit (Low_Bound (Expr)); 15695 15696 when N_Slice => 15697 Visit (Discrete_Range (Expr)); 15698 Visit (Prefix (Expr)); 15699 15700 -- Default 15701 15702 when others => 15703 15704 -- The evaluation of an object name is not preelaborable, 15705 -- unless the name is a static expression (checked further 15706 -- below), or statically denotes a discriminant. 15707 15708 if Is_Entity_Name (Expr) then 15709 Object_Name : declare 15710 Id : constant Entity_Id := Entity (Expr); 15711 15712 begin 15713 if Is_Object (Id) then 15714 if Ekind (Id) = E_Discriminant then 15715 null; 15716 15717 elsif Ekind_In (Id, E_Constant, E_In_Parameter) 15718 and then Present (Discriminal_Link (Id)) 15719 then 15720 null; 15721 15722 else 15723 raise Non_Preelaborable; 15724 end if; 15725 end if; 15726 end Object_Name; 15727 15728 -- A non-static expression is not preelaborable 15729 15730 elsif not Is_OK_Static_Expression (Expr) then 15731 raise Non_Preelaborable; 15732 end if; 15733 end case; 15734 end Visit_Subexpression; 15735 15736 -- Start of processing for Is_Non_Preelaborable_Construct 15737 15738 begin 15739 Visit (N); 15740 15741 -- At this point it is known that the construct is preelaborable 15742 15743 return False; 15744 15745 exception 15746 15747 -- The elaboration of the construct performs an action which violates 15748 -- preelaborability. 15749 15750 when Non_Preelaborable => 15751 return True; 15752 end Is_Non_Preelaborable_Construct; 15753 15754 --------------------------------- 15755 -- Is_Nontrivial_DIC_Procedure -- 15756 --------------------------------- 15757 15758 function Is_Nontrivial_DIC_Procedure (Id : Entity_Id) return Boolean is 15759 Body_Decl : Node_Id; 15760 Stmt : Node_Id; 15761 15762 begin 15763 if Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id) then 15764 Body_Decl := 15765 Unit_Declaration_Node 15766 (Corresponding_Body (Unit_Declaration_Node (Id))); 15767 15768 -- The body of the Default_Initial_Condition procedure must contain 15769 -- at least one statement, otherwise the generation of the subprogram 15770 -- body failed. 15771 15772 pragma Assert (Present (Handled_Statement_Sequence (Body_Decl))); 15773 15774 -- To qualify as nontrivial, the first statement of the procedure 15775 -- must be a check in the form of an if statement. If the original 15776 -- Default_Initial_Condition expression was folded, then the first 15777 -- statement is not a check. 15778 15779 Stmt := First (Statements (Handled_Statement_Sequence (Body_Decl))); 15780 15781 return 15782 Nkind (Stmt) = N_If_Statement 15783 and then Nkind (Original_Node (Stmt)) = N_Pragma; 15784 end if; 15785 15786 return False; 15787 end Is_Nontrivial_DIC_Procedure; 15788 15789 ------------------------- 15790 -- Is_Null_Record_Type -- 15791 ------------------------- 15792 15793 function Is_Null_Record_Type (T : Entity_Id) return Boolean is 15794 Decl : constant Node_Id := Parent (T); 15795 begin 15796 return Nkind (Decl) = N_Full_Type_Declaration 15797 and then Nkind (Type_Definition (Decl)) = N_Record_Definition 15798 and then 15799 (No (Component_List (Type_Definition (Decl))) 15800 or else Null_Present (Component_List (Type_Definition (Decl)))); 15801 end Is_Null_Record_Type; 15802 15803 --------------------- 15804 -- Is_Object_Image -- 15805 --------------------- 15806 15807 function Is_Object_Image (Prefix : Node_Id) return Boolean is 15808 begin 15809 -- When the type of the prefix is not scalar, then the prefix is not 15810 -- valid in any scenario. 15811 15812 if not Is_Scalar_Type (Etype (Prefix)) then 15813 return False; 15814 end if; 15815 15816 -- Here we test for the case that the prefix is not a type and assume 15817 -- if it is not then it must be a named value or an object reference. 15818 -- This is because the parser always checks that prefixes of attributes 15819 -- are named. 15820 15821 return not (Is_Entity_Name (Prefix) and then Is_Type (Entity (Prefix))); 15822 end Is_Object_Image; 15823 15824 ------------------------- 15825 -- Is_Object_Reference -- 15826 ------------------------- 15827 15828 function Is_Object_Reference (N : Node_Id) return Boolean is 15829 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean; 15830 -- Determine whether N is the name of an internally-generated renaming 15831 15832 -------------------------------------- 15833 -- Is_Internally_Generated_Renaming -- 15834 -------------------------------------- 15835 15836 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is 15837 P : Node_Id; 15838 15839 begin 15840 P := N; 15841 while Present (P) loop 15842 if Nkind (P) = N_Object_Renaming_Declaration then 15843 return not Comes_From_Source (P); 15844 elsif Is_List_Member (P) then 15845 return False; 15846 end if; 15847 15848 P := Parent (P); 15849 end loop; 15850 15851 return False; 15852 end Is_Internally_Generated_Renaming; 15853 15854 -- Start of processing for Is_Object_Reference 15855 15856 begin 15857 if Is_Entity_Name (N) then 15858 return Present (Entity (N)) and then Is_Object (Entity (N)); 15859 15860 else 15861 case Nkind (N) is 15862 when N_Indexed_Component 15863 | N_Slice 15864 => 15865 return 15866 Is_Object_Reference (Prefix (N)) 15867 or else Is_Access_Type (Etype (Prefix (N))); 15868 15869 -- In Ada 95, a function call is a constant object; a procedure 15870 -- call is not. 15871 15872 -- Note that predefined operators are functions as well, and so 15873 -- are attributes that are (can be renamed as) functions. 15874 15875 when N_Binary_Op 15876 | N_Function_Call 15877 | N_Unary_Op 15878 => 15879 return Etype (N) /= Standard_Void_Type; 15880 15881 -- Attributes references 'Loop_Entry, 'Old, and 'Result yield 15882 -- objects, even though they are not functions. 15883 15884 when N_Attribute_Reference => 15885 return 15886 Nam_In (Attribute_Name (N), Name_Loop_Entry, 15887 Name_Old, 15888 Name_Result) 15889 or else Is_Function_Attribute_Name (Attribute_Name (N)); 15890 15891 when N_Selected_Component => 15892 return 15893 Is_Object_Reference (Selector_Name (N)) 15894 and then 15895 (Is_Object_Reference (Prefix (N)) 15896 or else Is_Access_Type (Etype (Prefix (N)))); 15897 15898 -- An explicit dereference denotes an object, except that a 15899 -- conditional expression gets turned into an explicit dereference 15900 -- in some cases, and conditional expressions are not object 15901 -- names. 15902 15903 when N_Explicit_Dereference => 15904 return not Nkind_In (Original_Node (N), N_Case_Expression, 15905 N_If_Expression); 15906 15907 -- A view conversion of a tagged object is an object reference 15908 15909 when N_Type_Conversion => 15910 return Is_Tagged_Type (Etype (Subtype_Mark (N))) 15911 and then Is_Tagged_Type (Etype (Expression (N))) 15912 and then Is_Object_Reference (Expression (N)); 15913 15914 -- An unchecked type conversion is considered to be an object if 15915 -- the operand is an object (this construction arises only as a 15916 -- result of expansion activities). 15917 15918 when N_Unchecked_Type_Conversion => 15919 return True; 15920 15921 -- Allow string literals to act as objects as long as they appear 15922 -- in internally-generated renamings. The expansion of iterators 15923 -- may generate such renamings when the range involves a string 15924 -- literal. 15925 15926 when N_String_Literal => 15927 return Is_Internally_Generated_Renaming (Parent (N)); 15928 15929 -- AI05-0003: In Ada 2012 a qualified expression is a name. 15930 -- This allows disambiguation of function calls and the use 15931 -- of aggregates in more contexts. 15932 15933 when N_Qualified_Expression => 15934 if Ada_Version < Ada_2012 then 15935 return False; 15936 else 15937 return Is_Object_Reference (Expression (N)) 15938 or else Nkind (Expression (N)) = N_Aggregate; 15939 end if; 15940 15941 when others => 15942 return False; 15943 end case; 15944 end if; 15945 end Is_Object_Reference; 15946 15947 ----------------------------------- 15948 -- Is_OK_Variable_For_Out_Formal -- 15949 ----------------------------------- 15950 15951 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is 15952 begin 15953 Note_Possible_Modification (AV, Sure => True); 15954 15955 -- We must reject parenthesized variable names. Comes_From_Source is 15956 -- checked because there are currently cases where the compiler violates 15957 -- this rule (e.g. passing a task object to its controlled Initialize 15958 -- routine). This should be properly documented in sinfo??? 15959 15960 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then 15961 return False; 15962 15963 -- A variable is always allowed 15964 15965 elsif Is_Variable (AV) then 15966 return True; 15967 15968 -- Generalized indexing operations are rewritten as explicit 15969 -- dereferences, and it is only during resolution that we can 15970 -- check whether the context requires an access_to_variable type. 15971 15972 elsif Nkind (AV) = N_Explicit_Dereference 15973 and then Ada_Version >= Ada_2012 15974 and then Nkind (Original_Node (AV)) = N_Indexed_Component 15975 and then Present (Etype (Original_Node (AV))) 15976 and then Has_Implicit_Dereference (Etype (Original_Node (AV))) 15977 then 15978 return not Is_Access_Constant (Etype (Prefix (AV))); 15979 15980 -- Unchecked conversions are allowed only if they come from the 15981 -- generated code, which sometimes uses unchecked conversions for out 15982 -- parameters in cases where code generation is unaffected. We tell 15983 -- source unchecked conversions by seeing if they are rewrites of 15984 -- an original Unchecked_Conversion function call, or of an explicit 15985 -- conversion of a function call or an aggregate (as may happen in the 15986 -- expansion of a packed array aggregate). 15987 15988 elsif Nkind (AV) = N_Unchecked_Type_Conversion then 15989 if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then 15990 return False; 15991 15992 elsif Comes_From_Source (AV) 15993 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call 15994 then 15995 return False; 15996 15997 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then 15998 return Is_OK_Variable_For_Out_Formal (Expression (AV)); 15999 16000 else 16001 return True; 16002 end if; 16003 16004 -- Normal type conversions are allowed if argument is a variable 16005 16006 elsif Nkind (AV) = N_Type_Conversion then 16007 if Is_Variable (Expression (AV)) 16008 and then Paren_Count (Expression (AV)) = 0 16009 then 16010 Note_Possible_Modification (Expression (AV), Sure => True); 16011 return True; 16012 16013 -- We also allow a non-parenthesized expression that raises 16014 -- constraint error if it rewrites what used to be a variable 16015 16016 elsif Raises_Constraint_Error (Expression (AV)) 16017 and then Paren_Count (Expression (AV)) = 0 16018 and then Is_Variable (Original_Node (Expression (AV))) 16019 then 16020 return True; 16021 16022 -- Type conversion of something other than a variable 16023 16024 else 16025 return False; 16026 end if; 16027 16028 -- If this node is rewritten, then test the original form, if that is 16029 -- OK, then we consider the rewritten node OK (for example, if the 16030 -- original node is a conversion, then Is_Variable will not be true 16031 -- but we still want to allow the conversion if it converts a variable). 16032 16033 elsif Is_Rewrite_Substitution (AV) then 16034 16035 -- In Ada 2012, the explicit dereference may be a rewritten call to a 16036 -- Reference function. 16037 16038 if Ada_Version >= Ada_2012 16039 and then Nkind (Original_Node (AV)) = N_Function_Call 16040 and then 16041 Has_Implicit_Dereference (Etype (Name (Original_Node (AV)))) 16042 then 16043 16044 -- Check that this is not a constant reference. 16045 16046 return not Is_Access_Constant (Etype (Prefix (AV))); 16047 16048 elsif Has_Implicit_Dereference (Etype (Original_Node (AV))) then 16049 return 16050 not Is_Access_Constant (Etype 16051 (Get_Reference_Discriminant (Etype (Original_Node (AV))))); 16052 16053 else 16054 return Is_OK_Variable_For_Out_Formal (Original_Node (AV)); 16055 end if; 16056 16057 -- All other non-variables are rejected 16058 16059 else 16060 return False; 16061 end if; 16062 end Is_OK_Variable_For_Out_Formal; 16063 16064 ---------------------------- 16065 -- Is_OK_Volatile_Context -- 16066 ---------------------------- 16067 16068 function Is_OK_Volatile_Context 16069 (Context : Node_Id; 16070 Obj_Ref : Node_Id) return Boolean 16071 is 16072 function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean; 16073 -- Determine whether an arbitrary node denotes a call to a protected 16074 -- entry, function, or procedure in prefixed form where the prefix is 16075 -- Obj_Ref. 16076 16077 function Within_Check (Nod : Node_Id) return Boolean; 16078 -- Determine whether an arbitrary node appears in a check node 16079 16080 function Within_Volatile_Function (Id : Entity_Id) return Boolean; 16081 -- Determine whether an arbitrary entity appears in a volatile function 16082 16083 --------------------------------- 16084 -- Is_Protected_Operation_Call -- 16085 --------------------------------- 16086 16087 function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean is 16088 Pref : Node_Id; 16089 Subp : Node_Id; 16090 16091 begin 16092 -- A call to a protected operations retains its selected component 16093 -- form as opposed to other prefixed calls that are transformed in 16094 -- expanded names. 16095 16096 if Nkind (Nod) = N_Selected_Component then 16097 Pref := Prefix (Nod); 16098 Subp := Selector_Name (Nod); 16099 16100 return 16101 Pref = Obj_Ref 16102 and then Present (Etype (Pref)) 16103 and then Is_Protected_Type (Etype (Pref)) 16104 and then Is_Entity_Name (Subp) 16105 and then Present (Entity (Subp)) 16106 and then Ekind_In (Entity (Subp), E_Entry, 16107 E_Entry_Family, 16108 E_Function, 16109 E_Procedure); 16110 else 16111 return False; 16112 end if; 16113 end Is_Protected_Operation_Call; 16114 16115 ------------------ 16116 -- Within_Check -- 16117 ------------------ 16118 16119 function Within_Check (Nod : Node_Id) return Boolean is 16120 Par : Node_Id; 16121 16122 begin 16123 -- Climb the parent chain looking for a check node 16124 16125 Par := Nod; 16126 while Present (Par) loop 16127 if Nkind (Par) in N_Raise_xxx_Error then 16128 return True; 16129 16130 -- Prevent the search from going too far 16131 16132 elsif Is_Body_Or_Package_Declaration (Par) then 16133 exit; 16134 end if; 16135 16136 Par := Parent (Par); 16137 end loop; 16138 16139 return False; 16140 end Within_Check; 16141 16142 ------------------------------ 16143 -- Within_Volatile_Function -- 16144 ------------------------------ 16145 16146 function Within_Volatile_Function (Id : Entity_Id) return Boolean is 16147 Func_Id : Entity_Id; 16148 16149 begin 16150 -- Traverse the scope stack looking for a [generic] function 16151 16152 Func_Id := Id; 16153 while Present (Func_Id) and then Func_Id /= Standard_Standard loop 16154 if Ekind_In (Func_Id, E_Function, E_Generic_Function) then 16155 return Is_Volatile_Function (Func_Id); 16156 end if; 16157 16158 Func_Id := Scope (Func_Id); 16159 end loop; 16160 16161 return False; 16162 end Within_Volatile_Function; 16163 16164 -- Local variables 16165 16166 Obj_Id : Entity_Id; 16167 16168 -- Start of processing for Is_OK_Volatile_Context 16169 16170 begin 16171 -- The volatile object appears on either side of an assignment 16172 16173 if Nkind (Context) = N_Assignment_Statement then 16174 return True; 16175 16176 -- The volatile object is part of the initialization expression of 16177 -- another object. 16178 16179 elsif Nkind (Context) = N_Object_Declaration 16180 and then Present (Expression (Context)) 16181 and then Expression (Context) = Obj_Ref 16182 then 16183 Obj_Id := Defining_Entity (Context); 16184 16185 -- The volatile object acts as the initialization expression of an 16186 -- extended return statement. This is valid context as long as the 16187 -- function is volatile. 16188 16189 if Is_Return_Object (Obj_Id) then 16190 return Within_Volatile_Function (Obj_Id); 16191 16192 -- Otherwise this is a normal object initialization 16193 16194 else 16195 return True; 16196 end if; 16197 16198 -- The volatile object acts as the name of a renaming declaration 16199 16200 elsif Nkind (Context) = N_Object_Renaming_Declaration 16201 and then Name (Context) = Obj_Ref 16202 then 16203 return True; 16204 16205 -- The volatile object appears as an actual parameter in a call to an 16206 -- instance of Unchecked_Conversion whose result is renamed. 16207 16208 elsif Nkind (Context) = N_Function_Call 16209 and then Is_Entity_Name (Name (Context)) 16210 and then Is_Unchecked_Conversion_Instance (Entity (Name (Context))) 16211 and then Nkind (Parent (Context)) = N_Object_Renaming_Declaration 16212 then 16213 return True; 16214 16215 -- The volatile object is actually the prefix in a protected entry, 16216 -- function, or procedure call. 16217 16218 elsif Is_Protected_Operation_Call (Context) then 16219 return True; 16220 16221 -- The volatile object appears as the expression of a simple return 16222 -- statement that applies to a volatile function. 16223 16224 elsif Nkind (Context) = N_Simple_Return_Statement 16225 and then Expression (Context) = Obj_Ref 16226 then 16227 return 16228 Within_Volatile_Function (Return_Statement_Entity (Context)); 16229 16230 -- The volatile object appears as the prefix of a name occurring in a 16231 -- non-interfering context. 16232 16233 elsif Nkind_In (Context, N_Attribute_Reference, 16234 N_Explicit_Dereference, 16235 N_Indexed_Component, 16236 N_Selected_Component, 16237 N_Slice) 16238 and then Prefix (Context) = Obj_Ref 16239 and then Is_OK_Volatile_Context 16240 (Context => Parent (Context), 16241 Obj_Ref => Context) 16242 then 16243 return True; 16244 16245 -- The volatile object appears as the prefix of attributes Address, 16246 -- Alignment, Component_Size, First, First_Bit, Last, Last_Bit, Length, 16247 -- Position, Size, Storage_Size. 16248 16249 elsif Nkind (Context) = N_Attribute_Reference 16250 and then Prefix (Context) = Obj_Ref 16251 and then Nam_In (Attribute_Name (Context), Name_Address, 16252 Name_Alignment, 16253 Name_Component_Size, 16254 Name_First, 16255 Name_First_Bit, 16256 Name_Last, 16257 Name_Last_Bit, 16258 Name_Length, 16259 Name_Position, 16260 Name_Size, 16261 Name_Storage_Size) 16262 then 16263 return True; 16264 16265 -- The volatile object appears as the expression of a type conversion 16266 -- occurring in a non-interfering context. 16267 16268 elsif Nkind_In (Context, N_Type_Conversion, 16269 N_Unchecked_Type_Conversion) 16270 and then Expression (Context) = Obj_Ref 16271 and then Is_OK_Volatile_Context 16272 (Context => Parent (Context), 16273 Obj_Ref => Context) 16274 then 16275 return True; 16276 16277 -- The volatile object appears as the expression in a delay statement 16278 16279 elsif Nkind (Context) in N_Delay_Statement then 16280 return True; 16281 16282 -- Allow references to volatile objects in various checks. This is not a 16283 -- direct SPARK 2014 requirement. 16284 16285 elsif Within_Check (Context) then 16286 return True; 16287 16288 -- Assume that references to effectively volatile objects that appear 16289 -- as actual parameters in a subprogram call are always legal. A full 16290 -- legality check is done when the actuals are resolved (see routine 16291 -- Resolve_Actuals). 16292 16293 elsif Within_Subprogram_Call (Context) then 16294 return True; 16295 16296 -- Otherwise the context is not suitable for an effectively volatile 16297 -- object. 16298 16299 else 16300 return False; 16301 end if; 16302 end Is_OK_Volatile_Context; 16303 16304 ------------------------------------ 16305 -- Is_Package_Contract_Annotation -- 16306 ------------------------------------ 16307 16308 function Is_Package_Contract_Annotation (Item : Node_Id) return Boolean is 16309 Nam : Name_Id; 16310 16311 begin 16312 if Nkind (Item) = N_Aspect_Specification then 16313 Nam := Chars (Identifier (Item)); 16314 16315 else pragma Assert (Nkind (Item) = N_Pragma); 16316 Nam := Pragma_Name (Item); 16317 end if; 16318 16319 return Nam = Name_Abstract_State 16320 or else Nam = Name_Initial_Condition 16321 or else Nam = Name_Initializes 16322 or else Nam = Name_Refined_State; 16323 end Is_Package_Contract_Annotation; 16324 16325 ----------------------------------- 16326 -- Is_Partially_Initialized_Type -- 16327 ----------------------------------- 16328 16329 function Is_Partially_Initialized_Type 16330 (Typ : Entity_Id; 16331 Include_Implicit : Boolean := True) return Boolean 16332 is 16333 begin 16334 if Is_Scalar_Type (Typ) then 16335 return False; 16336 16337 elsif Is_Access_Type (Typ) then 16338 return Include_Implicit; 16339 16340 elsif Is_Array_Type (Typ) then 16341 16342 -- If component type is partially initialized, so is array type 16343 16344 if Is_Partially_Initialized_Type 16345 (Component_Type (Typ), Include_Implicit) 16346 then 16347 return True; 16348 16349 -- Otherwise we are only partially initialized if we are fully 16350 -- initialized (this is the empty array case, no point in us 16351 -- duplicating that code here). 16352 16353 else 16354 return Is_Fully_Initialized_Type (Typ); 16355 end if; 16356 16357 elsif Is_Record_Type (Typ) then 16358 16359 -- A discriminated type is always partially initialized if in 16360 -- all mode 16361 16362 if Has_Discriminants (Typ) and then Include_Implicit then 16363 return True; 16364 16365 -- A tagged type is always partially initialized 16366 16367 elsif Is_Tagged_Type (Typ) then 16368 return True; 16369 16370 -- Case of non-discriminated record 16371 16372 else 16373 declare 16374 Ent : Entity_Id; 16375 16376 Component_Present : Boolean := False; 16377 -- Set True if at least one component is present. If no 16378 -- components are present, then record type is fully 16379 -- initialized (another odd case, like the null array). 16380 16381 begin 16382 -- Loop through components 16383 16384 Ent := First_Entity (Typ); 16385 while Present (Ent) loop 16386 if Ekind (Ent) = E_Component then 16387 Component_Present := True; 16388 16389 -- If a component has an initialization expression then 16390 -- the enclosing record type is partially initialized 16391 16392 if Present (Parent (Ent)) 16393 and then Present (Expression (Parent (Ent))) 16394 then 16395 return True; 16396 16397 -- If a component is of a type which is itself partially 16398 -- initialized, then the enclosing record type is also. 16399 16400 elsif Is_Partially_Initialized_Type 16401 (Etype (Ent), Include_Implicit) 16402 then 16403 return True; 16404 end if; 16405 end if; 16406 16407 Next_Entity (Ent); 16408 end loop; 16409 16410 -- No initialized components found. If we found any components 16411 -- they were all uninitialized so the result is false. 16412 16413 if Component_Present then 16414 return False; 16415 16416 -- But if we found no components, then all the components are 16417 -- initialized so we consider the type to be initialized. 16418 16419 else 16420 return True; 16421 end if; 16422 end; 16423 end if; 16424 16425 -- Concurrent types are always fully initialized 16426 16427 elsif Is_Concurrent_Type (Typ) then 16428 return True; 16429 16430 -- For a private type, go to underlying type. If there is no underlying 16431 -- type then just assume this partially initialized. Not clear if this 16432 -- can happen in a non-error case, but no harm in testing for this. 16433 16434 elsif Is_Private_Type (Typ) then 16435 declare 16436 U : constant Entity_Id := Underlying_Type (Typ); 16437 begin 16438 if No (U) then 16439 return True; 16440 else 16441 return Is_Partially_Initialized_Type (U, Include_Implicit); 16442 end if; 16443 end; 16444 16445 -- For any other type (are there any?) assume partially initialized 16446 16447 else 16448 return True; 16449 end if; 16450 end Is_Partially_Initialized_Type; 16451 16452 ------------------------------------ 16453 -- Is_Potentially_Persistent_Type -- 16454 ------------------------------------ 16455 16456 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is 16457 Comp : Entity_Id; 16458 Indx : Node_Id; 16459 16460 begin 16461 -- For private type, test corresponding full type 16462 16463 if Is_Private_Type (T) then 16464 return Is_Potentially_Persistent_Type (Full_View (T)); 16465 16466 -- Scalar types are potentially persistent 16467 16468 elsif Is_Scalar_Type (T) then 16469 return True; 16470 16471 -- Record type is potentially persistent if not tagged and the types of 16472 -- all it components are potentially persistent, and no component has 16473 -- an initialization expression. 16474 16475 elsif Is_Record_Type (T) 16476 and then not Is_Tagged_Type (T) 16477 and then not Is_Partially_Initialized_Type (T) 16478 then 16479 Comp := First_Component (T); 16480 while Present (Comp) loop 16481 if not Is_Potentially_Persistent_Type (Etype (Comp)) then 16482 return False; 16483 else 16484 Next_Entity (Comp); 16485 end if; 16486 end loop; 16487 16488 return True; 16489 16490 -- Array type is potentially persistent if its component type is 16491 -- potentially persistent and if all its constraints are static. 16492 16493 elsif Is_Array_Type (T) then 16494 if not Is_Potentially_Persistent_Type (Component_Type (T)) then 16495 return False; 16496 end if; 16497 16498 Indx := First_Index (T); 16499 while Present (Indx) loop 16500 if not Is_OK_Static_Subtype (Etype (Indx)) then 16501 return False; 16502 else 16503 Next_Index (Indx); 16504 end if; 16505 end loop; 16506 16507 return True; 16508 16509 -- All other types are not potentially persistent 16510 16511 else 16512 return False; 16513 end if; 16514 end Is_Potentially_Persistent_Type; 16515 16516 -------------------------------- 16517 -- Is_Potentially_Unevaluated -- 16518 -------------------------------- 16519 16520 function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is 16521 Par : Node_Id; 16522 Expr : Node_Id; 16523 16524 begin 16525 Expr := N; 16526 Par := N; 16527 16528 -- A postcondition whose expression is a short-circuit is broken down 16529 -- into individual aspects for better exception reporting. The original 16530 -- short-circuit expression is rewritten as the second operand, and an 16531 -- occurrence of 'Old in that operand is potentially unevaluated. 16532 -- See sem_ch13.adb for details of this transformation. The reference 16533 -- to 'Old may appear within an expression, so we must look for the 16534 -- enclosing pragma argument in the tree that contains the reference. 16535 16536 while Present (Par) 16537 and then Nkind (Par) /= N_Pragma_Argument_Association 16538 loop 16539 if Is_Rewrite_Substitution (Par) 16540 and then Nkind (Original_Node (Par)) = N_And_Then 16541 then 16542 return True; 16543 end if; 16544 16545 Par := Parent (Par); 16546 end loop; 16547 16548 -- Other cases; 'Old appears within other expression (not the top-level 16549 -- conjunct in a postcondition) with a potentially unevaluated operand. 16550 16551 Par := Parent (Expr); 16552 while not Nkind_In (Par, N_And_Then, 16553 N_Case_Expression, 16554 N_If_Expression, 16555 N_In, 16556 N_Not_In, 16557 N_Or_Else, 16558 N_Quantified_Expression) 16559 loop 16560 Expr := Par; 16561 Par := Parent (Par); 16562 16563 -- If the context is not an expression, or if is the result of 16564 -- expansion of an enclosing construct (such as another attribute) 16565 -- the predicate does not apply. 16566 16567 if Nkind (Par) = N_Case_Expression_Alternative then 16568 null; 16569 16570 elsif Nkind (Par) not in N_Subexpr 16571 or else not Comes_From_Source (Par) 16572 then 16573 return False; 16574 end if; 16575 end loop; 16576 16577 if Nkind (Par) = N_If_Expression then 16578 return Is_Elsif (Par) or else Expr /= First (Expressions (Par)); 16579 16580 elsif Nkind (Par) = N_Case_Expression then 16581 return Expr /= Expression (Par); 16582 16583 elsif Nkind_In (Par, N_And_Then, N_Or_Else) then 16584 return Expr = Right_Opnd (Par); 16585 16586 elsif Nkind_In (Par, N_In, N_Not_In) then 16587 16588 -- If the membership includes several alternatives, only the first is 16589 -- definitely evaluated. 16590 16591 if Present (Alternatives (Par)) then 16592 return Expr /= First (Alternatives (Par)); 16593 16594 -- If this is a range membership both bounds are evaluated 16595 16596 else 16597 return False; 16598 end if; 16599 16600 elsif Nkind (Par) = N_Quantified_Expression then 16601 return Expr = Condition (Par); 16602 16603 else 16604 return False; 16605 end if; 16606 end Is_Potentially_Unevaluated; 16607 16608 ----------------------------------------- 16609 -- Is_Predefined_Dispatching_Operation -- 16610 ----------------------------------------- 16611 16612 function Is_Predefined_Dispatching_Operation 16613 (E : Entity_Id) return Boolean 16614 is 16615 TSS_Name : TSS_Name_Type; 16616 16617 begin 16618 if not Is_Dispatching_Operation (E) then 16619 return False; 16620 end if; 16621 16622 Get_Name_String (Chars (E)); 16623 16624 -- Most predefined primitives have internally generated names. Equality 16625 -- must be treated differently; the predefined operation is recognized 16626 -- as a homogeneous binary operator that returns Boolean. 16627 16628 if Name_Len > TSS_Name_Type'Last then 16629 TSS_Name := 16630 TSS_Name_Type 16631 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); 16632 16633 if Nam_In (Chars (E), Name_uAssign, Name_uSize) 16634 or else 16635 (Chars (E) = Name_Op_Eq 16636 and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) 16637 or else TSS_Name = TSS_Deep_Adjust 16638 or else TSS_Name = TSS_Deep_Finalize 16639 or else TSS_Name = TSS_Stream_Input 16640 or else TSS_Name = TSS_Stream_Output 16641 or else TSS_Name = TSS_Stream_Read 16642 or else TSS_Name = TSS_Stream_Write 16643 or else Is_Predefined_Interface_Primitive (E) 16644 then 16645 return True; 16646 end if; 16647 end if; 16648 16649 return False; 16650 end Is_Predefined_Dispatching_Operation; 16651 16652 --------------------------------------- 16653 -- Is_Predefined_Interface_Primitive -- 16654 --------------------------------------- 16655 16656 function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is 16657 begin 16658 -- In VM targets we don't restrict the functionality of this test to 16659 -- compiling in Ada 2005 mode since in VM targets any tagged type has 16660 -- these primitives. 16661 16662 return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion) 16663 and then Nam_In (Chars (E), Name_uDisp_Asynchronous_Select, 16664 Name_uDisp_Conditional_Select, 16665 Name_uDisp_Get_Prim_Op_Kind, 16666 Name_uDisp_Get_Task_Id, 16667 Name_uDisp_Requeue, 16668 Name_uDisp_Timed_Select); 16669 end Is_Predefined_Interface_Primitive; 16670 16671 --------------------------------------- 16672 -- Is_Predefined_Internal_Operation -- 16673 --------------------------------------- 16674 16675 function Is_Predefined_Internal_Operation 16676 (E : Entity_Id) return Boolean 16677 is 16678 TSS_Name : TSS_Name_Type; 16679 16680 begin 16681 if not Is_Dispatching_Operation (E) then 16682 return False; 16683 end if; 16684 16685 Get_Name_String (Chars (E)); 16686 16687 -- Most predefined primitives have internally generated names. Equality 16688 -- must be treated differently; the predefined operation is recognized 16689 -- as a homogeneous binary operator that returns Boolean. 16690 16691 if Name_Len > TSS_Name_Type'Last then 16692 TSS_Name := 16693 TSS_Name_Type 16694 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); 16695 16696 if Nam_In (Chars (E), Name_uSize, Name_uAssign) 16697 or else 16698 (Chars (E) = Name_Op_Eq 16699 and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) 16700 or else TSS_Name = TSS_Deep_Adjust 16701 or else TSS_Name = TSS_Deep_Finalize 16702 or else Is_Predefined_Interface_Primitive (E) 16703 then 16704 return True; 16705 end if; 16706 end if; 16707 16708 return False; 16709 end Is_Predefined_Internal_Operation; 16710 16711 -------------------------------- 16712 -- Is_Preelaborable_Aggregate -- 16713 -------------------------------- 16714 16715 function Is_Preelaborable_Aggregate (Aggr : Node_Id) return Boolean is 16716 Aggr_Typ : constant Entity_Id := Etype (Aggr); 16717 Array_Aggr : constant Boolean := Is_Array_Type (Aggr_Typ); 16718 16719 Anc_Part : Node_Id; 16720 Assoc : Node_Id; 16721 Choice : Node_Id; 16722 Comp_Typ : Entity_Id := Empty; -- init to avoid warning 16723 Expr : Node_Id; 16724 16725 begin 16726 if Array_Aggr then 16727 Comp_Typ := Component_Type (Aggr_Typ); 16728 end if; 16729 16730 -- Inspect the ancestor part 16731 16732 if Nkind (Aggr) = N_Extension_Aggregate then 16733 Anc_Part := Ancestor_Part (Aggr); 16734 16735 -- The ancestor denotes a subtype mark 16736 16737 if Is_Entity_Name (Anc_Part) 16738 and then Is_Type (Entity (Anc_Part)) 16739 then 16740 if not Has_Preelaborable_Initialization (Entity (Anc_Part)) then 16741 return False; 16742 end if; 16743 16744 -- Otherwise the ancestor denotes an expression 16745 16746 elsif not Is_Preelaborable_Construct (Anc_Part) then 16747 return False; 16748 end if; 16749 end if; 16750 16751 -- Inspect the positional associations 16752 16753 Expr := First (Expressions (Aggr)); 16754 while Present (Expr) loop 16755 if not Is_Preelaborable_Construct (Expr) then 16756 return False; 16757 end if; 16758 16759 Next (Expr); 16760 end loop; 16761 16762 -- Inspect the named associations 16763 16764 Assoc := First (Component_Associations (Aggr)); 16765 while Present (Assoc) loop 16766 16767 -- Inspect the choices of the current named association 16768 16769 Choice := First (Choices (Assoc)); 16770 while Present (Choice) loop 16771 if Array_Aggr then 16772 16773 -- For a choice to be preelaborable, it must denote either a 16774 -- static range or a static expression. 16775 16776 if Nkind (Choice) = N_Others_Choice then 16777 null; 16778 16779 elsif Nkind (Choice) = N_Range then 16780 if not Is_OK_Static_Range (Choice) then 16781 return False; 16782 end if; 16783 16784 elsif not Is_OK_Static_Expression (Choice) then 16785 return False; 16786 end if; 16787 16788 else 16789 Comp_Typ := Etype (Choice); 16790 end if; 16791 16792 Next (Choice); 16793 end loop; 16794 16795 -- The type of the choice must have preelaborable initialization if 16796 -- the association carries a <>. 16797 16798 pragma Assert (Present (Comp_Typ)); 16799 if Box_Present (Assoc) then 16800 if not Has_Preelaborable_Initialization (Comp_Typ) then 16801 return False; 16802 end if; 16803 16804 -- The type of the expression must have preelaborable initialization 16805 16806 elsif not Is_Preelaborable_Construct (Expression (Assoc)) then 16807 return False; 16808 end if; 16809 16810 Next (Assoc); 16811 end loop; 16812 16813 -- At this point the aggregate is preelaborable 16814 16815 return True; 16816 end Is_Preelaborable_Aggregate; 16817 16818 -------------------------------- 16819 -- Is_Preelaborable_Construct -- 16820 -------------------------------- 16821 16822 function Is_Preelaborable_Construct (N : Node_Id) return Boolean is 16823 begin 16824 -- Aggregates 16825 16826 if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then 16827 return Is_Preelaborable_Aggregate (N); 16828 16829 -- Attributes are allowed in general, even if their prefix is a formal 16830 -- type. It seems that certain attributes known not to be static might 16831 -- not be allowed, but there are no rules to prevent them. 16832 16833 elsif Nkind (N) = N_Attribute_Reference then 16834 return True; 16835 16836 -- Expressions 16837 16838 elsif Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then 16839 return True; 16840 16841 elsif Nkind (N) = N_Qualified_Expression then 16842 return Is_Preelaborable_Construct (Expression (N)); 16843 16844 -- Names are preelaborable when they denote a discriminant of an 16845 -- enclosing type. Discriminals are also considered for this check. 16846 16847 elsif Is_Entity_Name (N) 16848 and then Present (Entity (N)) 16849 and then 16850 (Ekind (Entity (N)) = E_Discriminant 16851 or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter) 16852 and then Present (Discriminal_Link (Entity (N))))) 16853 then 16854 return True; 16855 16856 -- Statements 16857 16858 elsif Nkind (N) = N_Null then 16859 return True; 16860 16861 -- Otherwise the construct is not preelaborable 16862 16863 else 16864 return False; 16865 end if; 16866 end Is_Preelaborable_Construct; 16867 16868 --------------------------------- 16869 -- Is_Protected_Self_Reference -- 16870 --------------------------------- 16871 16872 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is 16873 16874 function In_Access_Definition (N : Node_Id) return Boolean; 16875 -- Returns true if N belongs to an access definition 16876 16877 -------------------------- 16878 -- In_Access_Definition -- 16879 -------------------------- 16880 16881 function In_Access_Definition (N : Node_Id) return Boolean is 16882 P : Node_Id; 16883 16884 begin 16885 P := Parent (N); 16886 while Present (P) loop 16887 if Nkind (P) = N_Access_Definition then 16888 return True; 16889 end if; 16890 16891 P := Parent (P); 16892 end loop; 16893 16894 return False; 16895 end In_Access_Definition; 16896 16897 -- Start of processing for Is_Protected_Self_Reference 16898 16899 begin 16900 -- Verify that prefix is analyzed and has the proper form. Note that 16901 -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also 16902 -- produce the address of an entity, do not analyze their prefix 16903 -- because they denote entities that are not necessarily visible. 16904 -- Neither of them can apply to a protected type. 16905 16906 return Ada_Version >= Ada_2005 16907 and then Is_Entity_Name (N) 16908 and then Present (Entity (N)) 16909 and then Is_Protected_Type (Entity (N)) 16910 and then In_Open_Scopes (Entity (N)) 16911 and then not In_Access_Definition (N); 16912 end Is_Protected_Self_Reference; 16913 16914 ----------------------------- 16915 -- Is_RCI_Pkg_Spec_Or_Body -- 16916 ----------------------------- 16917 16918 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is 16919 16920 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean; 16921 -- Return True if the unit of Cunit is an RCI package declaration 16922 16923 --------------------------- 16924 -- Is_RCI_Pkg_Decl_Cunit -- 16925 --------------------------- 16926 16927 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is 16928 The_Unit : constant Node_Id := Unit (Cunit); 16929 16930 begin 16931 if Nkind (The_Unit) /= N_Package_Declaration then 16932 return False; 16933 end if; 16934 16935 return Is_Remote_Call_Interface (Defining_Entity (The_Unit)); 16936 end Is_RCI_Pkg_Decl_Cunit; 16937 16938 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body 16939 16940 begin 16941 return Is_RCI_Pkg_Decl_Cunit (Cunit) 16942 or else 16943 (Nkind (Unit (Cunit)) = N_Package_Body 16944 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit))); 16945 end Is_RCI_Pkg_Spec_Or_Body; 16946 16947 ----------------------------------------- 16948 -- Is_Remote_Access_To_Class_Wide_Type -- 16949 ----------------------------------------- 16950 16951 function Is_Remote_Access_To_Class_Wide_Type 16952 (E : Entity_Id) return Boolean 16953 is 16954 begin 16955 -- A remote access to class-wide type is a general access to object type 16956 -- declared in the visible part of a Remote_Types or Remote_Call_ 16957 -- Interface unit. 16958 16959 return Ekind (E) = E_General_Access_Type 16960 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); 16961 end Is_Remote_Access_To_Class_Wide_Type; 16962 16963 ----------------------------------------- 16964 -- Is_Remote_Access_To_Subprogram_Type -- 16965 ----------------------------------------- 16966 16967 function Is_Remote_Access_To_Subprogram_Type 16968 (E : Entity_Id) return Boolean 16969 is 16970 begin 16971 return (Ekind (E) = E_Access_Subprogram_Type 16972 or else (Ekind (E) = E_Record_Type 16973 and then Present (Corresponding_Remote_Type (E)))) 16974 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); 16975 end Is_Remote_Access_To_Subprogram_Type; 16976 16977 -------------------- 16978 -- Is_Remote_Call -- 16979 -------------------- 16980 16981 function Is_Remote_Call (N : Node_Id) return Boolean is 16982 begin 16983 if Nkind (N) not in N_Subprogram_Call then 16984 16985 -- An entry call cannot be remote 16986 16987 return False; 16988 16989 elsif Nkind (Name (N)) in N_Has_Entity 16990 and then Is_Remote_Call_Interface (Entity (Name (N))) 16991 then 16992 -- A subprogram declared in the spec of a RCI package is remote 16993 16994 return True; 16995 16996 elsif Nkind (Name (N)) = N_Explicit_Dereference 16997 and then Is_Remote_Access_To_Subprogram_Type 16998 (Etype (Prefix (Name (N)))) 16999 then 17000 -- The dereference of a RAS is a remote call 17001 17002 return True; 17003 17004 elsif Present (Controlling_Argument (N)) 17005 and then Is_Remote_Access_To_Class_Wide_Type 17006 (Etype (Controlling_Argument (N))) 17007 then 17008 -- Any primitive operation call with a controlling argument of 17009 -- a RACW type is a remote call. 17010 17011 return True; 17012 end if; 17013 17014 -- All other calls are local calls 17015 17016 return False; 17017 end Is_Remote_Call; 17018 17019 ---------------------- 17020 -- Is_Renamed_Entry -- 17021 ---------------------- 17022 17023 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is 17024 Orig_Node : Node_Id := Empty; 17025 Subp_Decl : Node_Id := Parent (Parent (Proc_Nam)); 17026 17027 function Is_Entry (Nam : Node_Id) return Boolean; 17028 -- Determine whether Nam is an entry. Traverse selectors if there are 17029 -- nested selected components. 17030 17031 -------------- 17032 -- Is_Entry -- 17033 -------------- 17034 17035 function Is_Entry (Nam : Node_Id) return Boolean is 17036 begin 17037 if Nkind (Nam) = N_Selected_Component then 17038 return Is_Entry (Selector_Name (Nam)); 17039 end if; 17040 17041 return Ekind (Entity (Nam)) = E_Entry; 17042 end Is_Entry; 17043 17044 -- Start of processing for Is_Renamed_Entry 17045 17046 begin 17047 if Present (Alias (Proc_Nam)) then 17048 Subp_Decl := Parent (Parent (Alias (Proc_Nam))); 17049 end if; 17050 17051 -- Look for a rewritten subprogram renaming declaration 17052 17053 if Nkind (Subp_Decl) = N_Subprogram_Declaration 17054 and then Present (Original_Node (Subp_Decl)) 17055 then 17056 Orig_Node := Original_Node (Subp_Decl); 17057 end if; 17058 17059 -- The rewritten subprogram is actually an entry 17060 17061 if Present (Orig_Node) 17062 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration 17063 and then Is_Entry (Name (Orig_Node)) 17064 then 17065 return True; 17066 end if; 17067 17068 return False; 17069 end Is_Renamed_Entry; 17070 17071 ----------------------------- 17072 -- Is_Renaming_Declaration -- 17073 ----------------------------- 17074 17075 function Is_Renaming_Declaration (N : Node_Id) return Boolean is 17076 begin 17077 case Nkind (N) is 17078 when N_Exception_Renaming_Declaration 17079 | N_Generic_Function_Renaming_Declaration 17080 | N_Generic_Package_Renaming_Declaration 17081 | N_Generic_Procedure_Renaming_Declaration 17082 | N_Object_Renaming_Declaration 17083 | N_Package_Renaming_Declaration 17084 | N_Subprogram_Renaming_Declaration 17085 => 17086 return True; 17087 17088 when others => 17089 return False; 17090 end case; 17091 end Is_Renaming_Declaration; 17092 17093 ---------------------------- 17094 -- Is_Reversible_Iterator -- 17095 ---------------------------- 17096 17097 function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is 17098 Ifaces_List : Elist_Id; 17099 Iface_Elmt : Elmt_Id; 17100 Iface : Entity_Id; 17101 17102 begin 17103 if Is_Class_Wide_Type (Typ) 17104 and then Chars (Root_Type (Typ)) = Name_Reversible_Iterator 17105 and then In_Predefined_Unit (Root_Type (Typ)) 17106 then 17107 return True; 17108 17109 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then 17110 return False; 17111 17112 else 17113 Collect_Interfaces (Typ, Ifaces_List); 17114 17115 Iface_Elmt := First_Elmt (Ifaces_List); 17116 while Present (Iface_Elmt) loop 17117 Iface := Node (Iface_Elmt); 17118 if Chars (Iface) = Name_Reversible_Iterator 17119 and then In_Predefined_Unit (Iface) 17120 then 17121 return True; 17122 end if; 17123 17124 Next_Elmt (Iface_Elmt); 17125 end loop; 17126 end if; 17127 17128 return False; 17129 end Is_Reversible_Iterator; 17130 17131 ---------------------- 17132 -- Is_Selector_Name -- 17133 ---------------------- 17134 17135 function Is_Selector_Name (N : Node_Id) return Boolean is 17136 begin 17137 if not Is_List_Member (N) then 17138 declare 17139 P : constant Node_Id := Parent (N); 17140 begin 17141 return Nkind_In (P, N_Expanded_Name, 17142 N_Generic_Association, 17143 N_Parameter_Association, 17144 N_Selected_Component) 17145 and then Selector_Name (P) = N; 17146 end; 17147 17148 else 17149 declare 17150 L : constant List_Id := List_Containing (N); 17151 P : constant Node_Id := Parent (L); 17152 begin 17153 return (Nkind (P) = N_Discriminant_Association 17154 and then Selector_Names (P) = L) 17155 or else 17156 (Nkind (P) = N_Component_Association 17157 and then Choices (P) = L); 17158 end; 17159 end if; 17160 end Is_Selector_Name; 17161 17162 --------------------------------- 17163 -- Is_Single_Concurrent_Object -- 17164 --------------------------------- 17165 17166 function Is_Single_Concurrent_Object (Id : Entity_Id) return Boolean is 17167 begin 17168 return 17169 Is_Single_Protected_Object (Id) or else Is_Single_Task_Object (Id); 17170 end Is_Single_Concurrent_Object; 17171 17172 ------------------------------- 17173 -- Is_Single_Concurrent_Type -- 17174 ------------------------------- 17175 17176 function Is_Single_Concurrent_Type (Id : Entity_Id) return Boolean is 17177 begin 17178 return 17179 Ekind_In (Id, E_Protected_Type, E_Task_Type) 17180 and then Is_Single_Concurrent_Type_Declaration 17181 (Declaration_Node (Id)); 17182 end Is_Single_Concurrent_Type; 17183 17184 ------------------------------------------- 17185 -- Is_Single_Concurrent_Type_Declaration -- 17186 ------------------------------------------- 17187 17188 function Is_Single_Concurrent_Type_Declaration 17189 (N : Node_Id) return Boolean 17190 is 17191 begin 17192 return Nkind_In (Original_Node (N), N_Single_Protected_Declaration, 17193 N_Single_Task_Declaration); 17194 end Is_Single_Concurrent_Type_Declaration; 17195 17196 --------------------------------------------- 17197 -- Is_Single_Precision_Floating_Point_Type -- 17198 --------------------------------------------- 17199 17200 function Is_Single_Precision_Floating_Point_Type 17201 (E : Entity_Id) return Boolean is 17202 begin 17203 return Is_Floating_Point_Type (E) 17204 and then Machine_Radix_Value (E) = Uint_2 17205 and then Machine_Mantissa_Value (E) = Uint_24 17206 and then Machine_Emax_Value (E) = Uint_2 ** Uint_7 17207 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_7); 17208 end Is_Single_Precision_Floating_Point_Type; 17209 17210 -------------------------------- 17211 -- Is_Single_Protected_Object -- 17212 -------------------------------- 17213 17214 function Is_Single_Protected_Object (Id : Entity_Id) return Boolean is 17215 begin 17216 return 17217 Ekind (Id) = E_Variable 17218 and then Ekind (Etype (Id)) = E_Protected_Type 17219 and then Is_Single_Concurrent_Type (Etype (Id)); 17220 end Is_Single_Protected_Object; 17221 17222 --------------------------- 17223 -- Is_Single_Task_Object -- 17224 --------------------------- 17225 17226 function Is_Single_Task_Object (Id : Entity_Id) return Boolean is 17227 begin 17228 return 17229 Ekind (Id) = E_Variable 17230 and then Ekind (Etype (Id)) = E_Task_Type 17231 and then Is_Single_Concurrent_Type (Etype (Id)); 17232 end Is_Single_Task_Object; 17233 17234 ------------------------------------- 17235 -- Is_SPARK_05_Initialization_Expr -- 17236 ------------------------------------- 17237 17238 function Is_SPARK_05_Initialization_Expr (N : Node_Id) return Boolean is 17239 Is_Ok : Boolean; 17240 Expr : Node_Id; 17241 Comp_Assn : Node_Id; 17242 Orig_N : constant Node_Id := Original_Node (N); 17243 17244 begin 17245 Is_Ok := True; 17246 17247 if not Comes_From_Source (Orig_N) then 17248 goto Done; 17249 end if; 17250 17251 pragma Assert (Nkind (Orig_N) in N_Subexpr); 17252 17253 case Nkind (Orig_N) is 17254 when N_Character_Literal 17255 | N_Integer_Literal 17256 | N_Real_Literal 17257 | N_String_Literal 17258 => 17259 null; 17260 17261 when N_Expanded_Name 17262 | N_Identifier 17263 => 17264 if Is_Entity_Name (Orig_N) 17265 and then Present (Entity (Orig_N)) -- needed in some cases 17266 then 17267 case Ekind (Entity (Orig_N)) is 17268 when E_Constant 17269 | E_Enumeration_Literal 17270 | E_Named_Integer 17271 | E_Named_Real 17272 => 17273 null; 17274 17275 when others => 17276 if Is_Type (Entity (Orig_N)) then 17277 null; 17278 else 17279 Is_Ok := False; 17280 end if; 17281 end case; 17282 end if; 17283 17284 when N_Qualified_Expression 17285 | N_Type_Conversion 17286 => 17287 Is_Ok := Is_SPARK_05_Initialization_Expr (Expression (Orig_N)); 17288 17289 when N_Unary_Op => 17290 Is_Ok := Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N)); 17291 17292 when N_Binary_Op 17293 | N_Membership_Test 17294 | N_Short_Circuit 17295 => 17296 Is_Ok := Is_SPARK_05_Initialization_Expr (Left_Opnd (Orig_N)) 17297 and then 17298 Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N)); 17299 17300 when N_Aggregate 17301 | N_Extension_Aggregate 17302 => 17303 if Nkind (Orig_N) = N_Extension_Aggregate then 17304 Is_Ok := 17305 Is_SPARK_05_Initialization_Expr (Ancestor_Part (Orig_N)); 17306 end if; 17307 17308 Expr := First (Expressions (Orig_N)); 17309 while Present (Expr) loop 17310 if not Is_SPARK_05_Initialization_Expr (Expr) then 17311 Is_Ok := False; 17312 goto Done; 17313 end if; 17314 17315 Next (Expr); 17316 end loop; 17317 17318 Comp_Assn := First (Component_Associations (Orig_N)); 17319 while Present (Comp_Assn) loop 17320 Expr := Expression (Comp_Assn); 17321 17322 -- Note: test for Present here needed for box assocation 17323 17324 if Present (Expr) 17325 and then not Is_SPARK_05_Initialization_Expr (Expr) 17326 then 17327 Is_Ok := False; 17328 goto Done; 17329 end if; 17330 17331 Next (Comp_Assn); 17332 end loop; 17333 17334 when N_Attribute_Reference => 17335 if Nkind (Prefix (Orig_N)) in N_Subexpr then 17336 Is_Ok := Is_SPARK_05_Initialization_Expr (Prefix (Orig_N)); 17337 end if; 17338 17339 Expr := First (Expressions (Orig_N)); 17340 while Present (Expr) loop 17341 if not Is_SPARK_05_Initialization_Expr (Expr) then 17342 Is_Ok := False; 17343 goto Done; 17344 end if; 17345 17346 Next (Expr); 17347 end loop; 17348 17349 -- Selected components might be expanded named not yet resolved, so 17350 -- default on the safe side. (Eg on sparklex.ads) 17351 17352 when N_Selected_Component => 17353 null; 17354 17355 when others => 17356 Is_Ok := False; 17357 end case; 17358 17359 <<Done>> 17360 return Is_Ok; 17361 end Is_SPARK_05_Initialization_Expr; 17362 17363 ---------------------------------- 17364 -- Is_SPARK_05_Object_Reference -- 17365 ---------------------------------- 17366 17367 function Is_SPARK_05_Object_Reference (N : Node_Id) return Boolean is 17368 begin 17369 if Is_Entity_Name (N) then 17370 return Present (Entity (N)) 17371 and then 17372 (Ekind_In (Entity (N), E_Constant, E_Variable) 17373 or else Ekind (Entity (N)) in Formal_Kind); 17374 17375 else 17376 case Nkind (N) is 17377 when N_Selected_Component => 17378 return Is_SPARK_05_Object_Reference (Prefix (N)); 17379 17380 when others => 17381 return False; 17382 end case; 17383 end if; 17384 end Is_SPARK_05_Object_Reference; 17385 17386 ----------------------------- 17387 -- Is_Specific_Tagged_Type -- 17388 ----------------------------- 17389 17390 function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean is 17391 Full_Typ : Entity_Id; 17392 17393 begin 17394 -- Handle private types 17395 17396 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 17397 Full_Typ := Full_View (Typ); 17398 else 17399 Full_Typ := Typ; 17400 end if; 17401 17402 -- A specific tagged type is a non-class-wide tagged type 17403 17404 return Is_Tagged_Type (Full_Typ) and not Is_Class_Wide_Type (Full_Typ); 17405 end Is_Specific_Tagged_Type; 17406 17407 ------------------ 17408 -- Is_Statement -- 17409 ------------------ 17410 17411 function Is_Statement (N : Node_Id) return Boolean is 17412 begin 17413 return 17414 Nkind (N) in N_Statement_Other_Than_Procedure_Call 17415 or else Nkind (N) = N_Procedure_Call_Statement; 17416 end Is_Statement; 17417 17418 --------------------------------------- 17419 -- Is_Subprogram_Contract_Annotation -- 17420 --------------------------------------- 17421 17422 function Is_Subprogram_Contract_Annotation 17423 (Item : Node_Id) return Boolean 17424 is 17425 Nam : Name_Id; 17426 17427 begin 17428 if Nkind (Item) = N_Aspect_Specification then 17429 Nam := Chars (Identifier (Item)); 17430 17431 else pragma Assert (Nkind (Item) = N_Pragma); 17432 Nam := Pragma_Name (Item); 17433 end if; 17434 17435 return Nam = Name_Contract_Cases 17436 or else Nam = Name_Depends 17437 or else Nam = Name_Extensions_Visible 17438 or else Nam = Name_Global 17439 or else Nam = Name_Post 17440 or else Nam = Name_Post_Class 17441 or else Nam = Name_Postcondition 17442 or else Nam = Name_Pre 17443 or else Nam = Name_Pre_Class 17444 or else Nam = Name_Precondition 17445 or else Nam = Name_Refined_Depends 17446 or else Nam = Name_Refined_Global 17447 or else Nam = Name_Refined_Post 17448 or else Nam = Name_Test_Case; 17449 end Is_Subprogram_Contract_Annotation; 17450 17451 -------------------------------------------------- 17452 -- Is_Subprogram_Stub_Without_Prior_Declaration -- 17453 -------------------------------------------------- 17454 17455 function Is_Subprogram_Stub_Without_Prior_Declaration 17456 (N : Node_Id) return Boolean 17457 is 17458 begin 17459 pragma Assert (Nkind (N) = N_Subprogram_Body_Stub); 17460 17461 case Ekind (Defining_Entity (N)) is 17462 17463 -- A subprogram stub without prior declaration serves as declaration 17464 -- for the actual subprogram body. As such, it has an attached 17465 -- defining entity of E_Function or E_Procedure. 17466 17467 when E_Function 17468 | E_Procedure 17469 => 17470 return True; 17471 17472 -- Otherwise, it is completes a [generic] subprogram declaration 17473 17474 when E_Generic_Function 17475 | E_Generic_Procedure 17476 | E_Subprogram_Body 17477 => 17478 return False; 17479 17480 when others => 17481 raise Program_Error; 17482 end case; 17483 end Is_Subprogram_Stub_Without_Prior_Declaration; 17484 17485 --------------------------- 17486 -- Is_Suitable_Primitive -- 17487 --------------------------- 17488 17489 function Is_Suitable_Primitive (Subp_Id : Entity_Id) return Boolean is 17490 begin 17491 -- The Default_Initial_Condition and invariant procedures must not be 17492 -- treated as primitive operations even when they apply to a tagged 17493 -- type. These routines must not act as targets of dispatching calls 17494 -- because they already utilize class-wide-precondition semantics to 17495 -- handle inheritance and overriding. 17496 17497 if Ekind (Subp_Id) = E_Procedure 17498 and then (Is_DIC_Procedure (Subp_Id) 17499 or else 17500 Is_Invariant_Procedure (Subp_Id)) 17501 then 17502 return False; 17503 end if; 17504 17505 return True; 17506 end Is_Suitable_Primitive; 17507 17508 -------------------------- 17509 -- Is_Suspension_Object -- 17510 -------------------------- 17511 17512 function Is_Suspension_Object (Id : Entity_Id) return Boolean is 17513 begin 17514 -- This approach does an exact name match rather than to rely on 17515 -- RTSfind. Routine Is_Effectively_Volatile is used by clients of the 17516 -- front end at point where all auxiliary tables are locked and any 17517 -- modifications to them are treated as violations. Do not tamper with 17518 -- the tables, instead examine the Chars fields of all the scopes of Id. 17519 17520 return 17521 Chars (Id) = Name_Suspension_Object 17522 and then Present (Scope (Id)) 17523 and then Chars (Scope (Id)) = Name_Synchronous_Task_Control 17524 and then Present (Scope (Scope (Id))) 17525 and then Chars (Scope (Scope (Id))) = Name_Ada 17526 and then Present (Scope (Scope (Scope (Id)))) 17527 and then Scope (Scope (Scope (Id))) = Standard_Standard; 17528 end Is_Suspension_Object; 17529 17530 ---------------------------- 17531 -- Is_Synchronized_Object -- 17532 ---------------------------- 17533 17534 function Is_Synchronized_Object (Id : Entity_Id) return Boolean is 17535 Prag : Node_Id; 17536 17537 begin 17538 if Is_Object (Id) then 17539 17540 -- The object is synchronized if it is of a type that yields a 17541 -- synchronized object. 17542 17543 if Yields_Synchronized_Object (Etype (Id)) then 17544 return True; 17545 17546 -- The object is synchronized if it is atomic and Async_Writers is 17547 -- enabled. 17548 17549 elsif Is_Atomic_Object_Entity (Id) 17550 and then Async_Writers_Enabled (Id) 17551 then 17552 return True; 17553 17554 -- A constant is a synchronized object by default 17555 17556 elsif Ekind (Id) = E_Constant then 17557 return True; 17558 17559 -- A variable is a synchronized object if it is subject to pragma 17560 -- Constant_After_Elaboration. 17561 17562 elsif Ekind (Id) = E_Variable then 17563 Prag := Get_Pragma (Id, Pragma_Constant_After_Elaboration); 17564 17565 return Present (Prag) and then Is_Enabled_Pragma (Prag); 17566 end if; 17567 end if; 17568 17569 -- Otherwise the input is not an object or it does not qualify as a 17570 -- synchronized object. 17571 17572 return False; 17573 end Is_Synchronized_Object; 17574 17575 --------------------------------- 17576 -- Is_Synchronized_Tagged_Type -- 17577 --------------------------------- 17578 17579 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is 17580 Kind : constant Entity_Kind := Ekind (Base_Type (E)); 17581 17582 begin 17583 -- A task or protected type derived from an interface is a tagged type. 17584 -- Such a tagged type is called a synchronized tagged type, as are 17585 -- synchronized interfaces and private extensions whose declaration 17586 -- includes the reserved word synchronized. 17587 17588 return (Is_Tagged_Type (E) 17589 and then (Kind = E_Task_Type 17590 or else 17591 Kind = E_Protected_Type)) 17592 or else 17593 (Is_Interface (E) 17594 and then Is_Synchronized_Interface (E)) 17595 or else 17596 (Ekind (E) = E_Record_Type_With_Private 17597 and then Nkind (Parent (E)) = N_Private_Extension_Declaration 17598 and then (Synchronized_Present (Parent (E)) 17599 or else Is_Synchronized_Interface (Etype (E)))); 17600 end Is_Synchronized_Tagged_Type; 17601 17602 ----------------- 17603 -- Is_Transfer -- 17604 ----------------- 17605 17606 function Is_Transfer (N : Node_Id) return Boolean is 17607 Kind : constant Node_Kind := Nkind (N); 17608 17609 begin 17610 if Kind = N_Simple_Return_Statement 17611 or else 17612 Kind = N_Extended_Return_Statement 17613 or else 17614 Kind = N_Goto_Statement 17615 or else 17616 Kind = N_Raise_Statement 17617 or else 17618 Kind = N_Requeue_Statement 17619 then 17620 return True; 17621 17622 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error) 17623 and then No (Condition (N)) 17624 then 17625 return True; 17626 17627 elsif Kind = N_Procedure_Call_Statement 17628 and then Is_Entity_Name (Name (N)) 17629 and then Present (Entity (Name (N))) 17630 and then No_Return (Entity (Name (N))) 17631 then 17632 return True; 17633 17634 elsif Nkind (Original_Node (N)) = N_Raise_Statement then 17635 return True; 17636 17637 else 17638 return False; 17639 end if; 17640 end Is_Transfer; 17641 17642 ------------- 17643 -- Is_True -- 17644 ------------- 17645 17646 function Is_True (U : Uint) return Boolean is 17647 begin 17648 return (U /= 0); 17649 end Is_True; 17650 17651 -------------------------------------- 17652 -- Is_Unchecked_Conversion_Instance -- 17653 -------------------------------------- 17654 17655 function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean is 17656 Par : Node_Id; 17657 17658 begin 17659 -- Look for a function whose generic parent is the predefined intrinsic 17660 -- function Unchecked_Conversion, or for one that renames such an 17661 -- instance. 17662 17663 if Ekind (Id) = E_Function then 17664 Par := Parent (Id); 17665 17666 if Nkind (Par) = N_Function_Specification then 17667 Par := Generic_Parent (Par); 17668 17669 if Present (Par) then 17670 return 17671 Chars (Par) = Name_Unchecked_Conversion 17672 and then Is_Intrinsic_Subprogram (Par) 17673 and then In_Predefined_Unit (Par); 17674 else 17675 return 17676 Present (Alias (Id)) 17677 and then Is_Unchecked_Conversion_Instance (Alias (Id)); 17678 end if; 17679 end if; 17680 end if; 17681 17682 return False; 17683 end Is_Unchecked_Conversion_Instance; 17684 17685 ------------------------------- 17686 -- Is_Universal_Numeric_Type -- 17687 ------------------------------- 17688 17689 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is 17690 begin 17691 return T = Universal_Integer or else T = Universal_Real; 17692 end Is_Universal_Numeric_Type; 17693 17694 ------------------------------ 17695 -- Is_User_Defined_Equality -- 17696 ------------------------------ 17697 17698 function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is 17699 begin 17700 return Ekind (Id) = E_Function 17701 and then Chars (Id) = Name_Op_Eq 17702 and then Comes_From_Source (Id) 17703 17704 -- Internally generated equalities have a full type declaration 17705 -- as their parent. 17706 17707 and then Nkind (Parent (Id)) = N_Function_Specification; 17708 end Is_User_Defined_Equality; 17709 17710 -------------------------------------- 17711 -- Is_Validation_Variable_Reference -- 17712 -------------------------------------- 17713 17714 function Is_Validation_Variable_Reference (N : Node_Id) return Boolean is 17715 Var : constant Node_Id := Unqual_Conv (N); 17716 Var_Id : Entity_Id; 17717 17718 begin 17719 Var_Id := Empty; 17720 17721 if Is_Entity_Name (Var) then 17722 Var_Id := Entity (Var); 17723 end if; 17724 17725 return 17726 Present (Var_Id) 17727 and then Ekind (Var_Id) = E_Variable 17728 and then Present (Validated_Object (Var_Id)); 17729 end Is_Validation_Variable_Reference; 17730 17731 ---------------------------- 17732 -- Is_Variable_Size_Array -- 17733 ---------------------------- 17734 17735 function Is_Variable_Size_Array (E : Entity_Id) return Boolean is 17736 Idx : Node_Id; 17737 17738 begin 17739 pragma Assert (Is_Array_Type (E)); 17740 17741 -- Check if some index is initialized with a non-constant value 17742 17743 Idx := First_Index (E); 17744 while Present (Idx) loop 17745 if Nkind (Idx) = N_Range then 17746 if not Is_Constant_Bound (Low_Bound (Idx)) 17747 or else not Is_Constant_Bound (High_Bound (Idx)) 17748 then 17749 return True; 17750 end if; 17751 end if; 17752 17753 Idx := Next_Index (Idx); 17754 end loop; 17755 17756 return False; 17757 end Is_Variable_Size_Array; 17758 17759 ----------------------------- 17760 -- Is_Variable_Size_Record -- 17761 ----------------------------- 17762 17763 function Is_Variable_Size_Record (E : Entity_Id) return Boolean is 17764 Comp : Entity_Id; 17765 Comp_Typ : Entity_Id; 17766 17767 begin 17768 pragma Assert (Is_Record_Type (E)); 17769 17770 Comp := First_Component (E); 17771 while Present (Comp) loop 17772 Comp_Typ := Underlying_Type (Etype (Comp)); 17773 17774 -- Recursive call if the record type has discriminants 17775 17776 if Is_Record_Type (Comp_Typ) 17777 and then Has_Discriminants (Comp_Typ) 17778 and then Is_Variable_Size_Record (Comp_Typ) 17779 then 17780 return True; 17781 17782 elsif Is_Array_Type (Comp_Typ) 17783 and then Is_Variable_Size_Array (Comp_Typ) 17784 then 17785 return True; 17786 end if; 17787 17788 Next_Component (Comp); 17789 end loop; 17790 17791 return False; 17792 end Is_Variable_Size_Record; 17793 17794 ----------------- 17795 -- Is_Variable -- 17796 ----------------- 17797 17798 function Is_Variable 17799 (N : Node_Id; 17800 Use_Original_Node : Boolean := True) return Boolean 17801 is 17802 Orig_Node : Node_Id; 17803 17804 function In_Protected_Function (E : Entity_Id) return Boolean; 17805 -- Within a protected function, the private components of the enclosing 17806 -- protected type are constants. A function nested within a (protected) 17807 -- procedure is not itself protected. Within the body of a protected 17808 -- function the current instance of the protected type is a constant. 17809 17810 function Is_Variable_Prefix (P : Node_Id) return Boolean; 17811 -- Prefixes can involve implicit dereferences, in which case we must 17812 -- test for the case of a reference of a constant access type, which can 17813 -- can never be a variable. 17814 17815 --------------------------- 17816 -- In_Protected_Function -- 17817 --------------------------- 17818 17819 function In_Protected_Function (E : Entity_Id) return Boolean is 17820 Prot : Entity_Id; 17821 S : Entity_Id; 17822 17823 begin 17824 -- E is the current instance of a type 17825 17826 if Is_Type (E) then 17827 Prot := E; 17828 17829 -- E is an object 17830 17831 else 17832 Prot := Scope (E); 17833 end if; 17834 17835 if not Is_Protected_Type (Prot) then 17836 return False; 17837 17838 else 17839 S := Current_Scope; 17840 while Present (S) and then S /= Prot loop 17841 if Ekind (S) = E_Function and then Scope (S) = Prot then 17842 return True; 17843 end if; 17844 17845 S := Scope (S); 17846 end loop; 17847 17848 return False; 17849 end if; 17850 end In_Protected_Function; 17851 17852 ------------------------ 17853 -- Is_Variable_Prefix -- 17854 ------------------------ 17855 17856 function Is_Variable_Prefix (P : Node_Id) return Boolean is 17857 begin 17858 if Is_Access_Type (Etype (P)) then 17859 return not Is_Access_Constant (Root_Type (Etype (P))); 17860 17861 -- For the case of an indexed component whose prefix has a packed 17862 -- array type, the prefix has been rewritten into a type conversion. 17863 -- Determine variable-ness from the converted expression. 17864 17865 elsif Nkind (P) = N_Type_Conversion 17866 and then not Comes_From_Source (P) 17867 and then Is_Array_Type (Etype (P)) 17868 and then Is_Packed (Etype (P)) 17869 then 17870 return Is_Variable (Expression (P)); 17871 17872 else 17873 return Is_Variable (P); 17874 end if; 17875 end Is_Variable_Prefix; 17876 17877 -- Start of processing for Is_Variable 17878 17879 begin 17880 -- Special check, allow x'Deref(expr) as a variable 17881 17882 if Nkind (N) = N_Attribute_Reference 17883 and then Attribute_Name (N) = Name_Deref 17884 then 17885 return True; 17886 end if; 17887 17888 -- Check if we perform the test on the original node since this may be a 17889 -- test of syntactic categories which must not be disturbed by whatever 17890 -- rewriting might have occurred. For example, an aggregate, which is 17891 -- certainly NOT a variable, could be turned into a variable by 17892 -- expansion. 17893 17894 if Use_Original_Node then 17895 Orig_Node := Original_Node (N); 17896 else 17897 Orig_Node := N; 17898 end if; 17899 17900 -- Definitely OK if Assignment_OK is set. Since this is something that 17901 -- only gets set for expanded nodes, the test is on N, not Orig_Node. 17902 17903 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then 17904 return True; 17905 17906 -- Normally we go to the original node, but there is one exception where 17907 -- we use the rewritten node, namely when it is an explicit dereference. 17908 -- The generated code may rewrite a prefix which is an access type with 17909 -- an explicit dereference. The dereference is a variable, even though 17910 -- the original node may not be (since it could be a constant of the 17911 -- access type). 17912 17913 -- In Ada 2005 we have a further case to consider: the prefix may be a 17914 -- function call given in prefix notation. The original node appears to 17915 -- be a selected component, but we need to examine the call. 17916 17917 elsif Nkind (N) = N_Explicit_Dereference 17918 and then Nkind (Orig_Node) /= N_Explicit_Dereference 17919 and then Present (Etype (Orig_Node)) 17920 and then Is_Access_Type (Etype (Orig_Node)) 17921 then 17922 -- Note that if the prefix is an explicit dereference that does not 17923 -- come from source, we must check for a rewritten function call in 17924 -- prefixed notation before other forms of rewriting, to prevent a 17925 -- compiler crash. 17926 17927 return 17928 (Nkind (Orig_Node) = N_Function_Call 17929 and then not Is_Access_Constant (Etype (Prefix (N)))) 17930 or else 17931 Is_Variable_Prefix (Original_Node (Prefix (N))); 17932 17933 -- in Ada 2012, the dereference may have been added for a type with 17934 -- a declared implicit dereference aspect. Check that it is not an 17935 -- access to constant. 17936 17937 elsif Nkind (N) = N_Explicit_Dereference 17938 and then Present (Etype (Orig_Node)) 17939 and then Ada_Version >= Ada_2012 17940 and then Has_Implicit_Dereference (Etype (Orig_Node)) 17941 then 17942 return not Is_Access_Constant (Etype (Prefix (N))); 17943 17944 -- A function call is never a variable 17945 17946 elsif Nkind (N) = N_Function_Call then 17947 return False; 17948 17949 -- All remaining checks use the original node 17950 17951 elsif Is_Entity_Name (Orig_Node) 17952 and then Present (Entity (Orig_Node)) 17953 then 17954 declare 17955 E : constant Entity_Id := Entity (Orig_Node); 17956 K : constant Entity_Kind := Ekind (E); 17957 17958 begin 17959 if Is_Loop_Parameter (E) then 17960 return False; 17961 end if; 17962 17963 return (K = E_Variable 17964 and then Nkind (Parent (E)) /= N_Exception_Handler) 17965 or else (K = E_Component 17966 and then not In_Protected_Function (E)) 17967 or else K = E_Out_Parameter 17968 or else K = E_In_Out_Parameter 17969 or else K = E_Generic_In_Out_Parameter 17970 17971 -- Current instance of type. If this is a protected type, check 17972 -- we are not within the body of one of its protected functions. 17973 17974 or else (Is_Type (E) 17975 and then In_Open_Scopes (E) 17976 and then not In_Protected_Function (E)) 17977 17978 or else (Is_Incomplete_Or_Private_Type (E) 17979 and then In_Open_Scopes (Full_View (E))); 17980 end; 17981 17982 else 17983 case Nkind (Orig_Node) is 17984 when N_Indexed_Component 17985 | N_Slice 17986 => 17987 return Is_Variable_Prefix (Prefix (Orig_Node)); 17988 17989 when N_Selected_Component => 17990 return (Is_Variable (Selector_Name (Orig_Node)) 17991 and then Is_Variable_Prefix (Prefix (Orig_Node))) 17992 or else 17993 (Nkind (N) = N_Expanded_Name 17994 and then Scope (Entity (N)) = Entity (Prefix (N))); 17995 17996 -- For an explicit dereference, the type of the prefix cannot 17997 -- be an access to constant or an access to subprogram. 17998 17999 when N_Explicit_Dereference => 18000 declare 18001 Typ : constant Entity_Id := Etype (Prefix (Orig_Node)); 18002 begin 18003 return Is_Access_Type (Typ) 18004 and then not Is_Access_Constant (Root_Type (Typ)) 18005 and then Ekind (Typ) /= E_Access_Subprogram_Type; 18006 end; 18007 18008 -- The type conversion is the case where we do not deal with the 18009 -- context dependent special case of an actual parameter. Thus 18010 -- the type conversion is only considered a variable for the 18011 -- purposes of this routine if the target type is tagged. However, 18012 -- a type conversion is considered to be a variable if it does not 18013 -- come from source (this deals for example with the conversions 18014 -- of expressions to their actual subtypes). 18015 18016 when N_Type_Conversion => 18017 return Is_Variable (Expression (Orig_Node)) 18018 and then 18019 (not Comes_From_Source (Orig_Node) 18020 or else 18021 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node))) 18022 and then 18023 Is_Tagged_Type (Etype (Expression (Orig_Node))))); 18024 18025 -- GNAT allows an unchecked type conversion as a variable. This 18026 -- only affects the generation of internal expanded code, since 18027 -- calls to instantiations of Unchecked_Conversion are never 18028 -- considered variables (since they are function calls). 18029 18030 when N_Unchecked_Type_Conversion => 18031 return Is_Variable (Expression (Orig_Node)); 18032 18033 when others => 18034 return False; 18035 end case; 18036 end if; 18037 end Is_Variable; 18038 18039 --------------------------- 18040 -- Is_Visibly_Controlled -- 18041 --------------------------- 18042 18043 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is 18044 Root : constant Entity_Id := Root_Type (T); 18045 begin 18046 return Chars (Scope (Root)) = Name_Finalization 18047 and then Chars (Scope (Scope (Root))) = Name_Ada 18048 and then Scope (Scope (Scope (Root))) = Standard_Standard; 18049 end Is_Visibly_Controlled; 18050 18051 -------------------------- 18052 -- Is_Volatile_Function -- 18053 -------------------------- 18054 18055 function Is_Volatile_Function (Func_Id : Entity_Id) return Boolean is 18056 begin 18057 pragma Assert (Ekind_In (Func_Id, E_Function, E_Generic_Function)); 18058 18059 -- A function declared within a protected type is volatile 18060 18061 if Is_Protected_Type (Scope (Func_Id)) then 18062 return True; 18063 18064 -- An instance of Ada.Unchecked_Conversion is a volatile function if 18065 -- either the source or the target are effectively volatile. 18066 18067 elsif Is_Unchecked_Conversion_Instance (Func_Id) 18068 and then Has_Effectively_Volatile_Profile (Func_Id) 18069 then 18070 return True; 18071 18072 -- Otherwise the function is treated as volatile if it is subject to 18073 -- enabled pragma Volatile_Function. 18074 18075 else 18076 return 18077 Is_Enabled_Pragma (Get_Pragma (Func_Id, Pragma_Volatile_Function)); 18078 end if; 18079 end Is_Volatile_Function; 18080 18081 ------------------------ 18082 -- Is_Volatile_Object -- 18083 ------------------------ 18084 18085 function Is_Volatile_Object (N : Node_Id) return Boolean is 18086 function Is_Volatile_Prefix (N : Node_Id) return Boolean; 18087 -- If prefix is an implicit dereference, examine designated type 18088 18089 function Object_Has_Volatile_Components (N : Node_Id) return Boolean; 18090 -- Determines if given object has volatile components 18091 18092 ------------------------ 18093 -- Is_Volatile_Prefix -- 18094 ------------------------ 18095 18096 function Is_Volatile_Prefix (N : Node_Id) return Boolean is 18097 Typ : constant Entity_Id := Etype (N); 18098 18099 begin 18100 if Is_Access_Type (Typ) then 18101 declare 18102 Dtyp : constant Entity_Id := Designated_Type (Typ); 18103 18104 begin 18105 return Is_Volatile (Dtyp) 18106 or else Has_Volatile_Components (Dtyp); 18107 end; 18108 18109 else 18110 return Object_Has_Volatile_Components (N); 18111 end if; 18112 end Is_Volatile_Prefix; 18113 18114 ------------------------------------ 18115 -- Object_Has_Volatile_Components -- 18116 ------------------------------------ 18117 18118 function Object_Has_Volatile_Components (N : Node_Id) return Boolean is 18119 Typ : constant Entity_Id := Etype (N); 18120 18121 begin 18122 if Is_Volatile (Typ) 18123 or else Has_Volatile_Components (Typ) 18124 then 18125 return True; 18126 18127 elsif Is_Entity_Name (N) 18128 and then (Has_Volatile_Components (Entity (N)) 18129 or else Is_Volatile (Entity (N))) 18130 then 18131 return True; 18132 18133 elsif Nkind (N) = N_Indexed_Component 18134 or else Nkind (N) = N_Selected_Component 18135 then 18136 return Is_Volatile_Prefix (Prefix (N)); 18137 18138 else 18139 return False; 18140 end if; 18141 end Object_Has_Volatile_Components; 18142 18143 -- Start of processing for Is_Volatile_Object 18144 18145 begin 18146 if Nkind (N) = N_Defining_Identifier then 18147 return Is_Volatile (N) or else Is_Volatile (Etype (N)); 18148 18149 elsif Nkind (N) = N_Expanded_Name then 18150 return Is_Volatile_Object (Entity (N)); 18151 18152 elsif Is_Volatile (Etype (N)) 18153 or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N))) 18154 then 18155 return True; 18156 18157 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) 18158 and then Is_Volatile_Prefix (Prefix (N)) 18159 then 18160 return True; 18161 18162 elsif Nkind (N) = N_Selected_Component 18163 and then Is_Volatile (Entity (Selector_Name (N))) 18164 then 18165 return True; 18166 18167 else 18168 return False; 18169 end if; 18170 end Is_Volatile_Object; 18171 18172 ----------------------------- 18173 -- Iterate_Call_Parameters -- 18174 ----------------------------- 18175 18176 procedure Iterate_Call_Parameters (Call : Node_Id) is 18177 Actual : Node_Id := First_Actual (Call); 18178 Formal : Entity_Id := First_Formal (Get_Called_Entity (Call)); 18179 18180 begin 18181 while Present (Formal) and then Present (Actual) loop 18182 Handle_Parameter (Formal, Actual); 18183 18184 Next_Formal (Formal); 18185 Next_Actual (Actual); 18186 end loop; 18187 18188 pragma Assert (No (Formal)); 18189 pragma Assert (No (Actual)); 18190 end Iterate_Call_Parameters; 18191 18192 --------------------------- 18193 -- Itype_Has_Declaration -- 18194 --------------------------- 18195 18196 function Itype_Has_Declaration (Id : Entity_Id) return Boolean is 18197 begin 18198 pragma Assert (Is_Itype (Id)); 18199 return Present (Parent (Id)) 18200 and then Nkind_In (Parent (Id), N_Full_Type_Declaration, 18201 N_Subtype_Declaration) 18202 and then Defining_Entity (Parent (Id)) = Id; 18203 end Itype_Has_Declaration; 18204 18205 ------------------------- 18206 -- Kill_Current_Values -- 18207 ------------------------- 18208 18209 procedure Kill_Current_Values 18210 (Ent : Entity_Id; 18211 Last_Assignment_Only : Boolean := False) 18212 is 18213 begin 18214 if Is_Assignable (Ent) then 18215 Set_Last_Assignment (Ent, Empty); 18216 end if; 18217 18218 if Is_Object (Ent) then 18219 if not Last_Assignment_Only then 18220 Kill_Checks (Ent); 18221 Set_Current_Value (Ent, Empty); 18222 18223 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags 18224 -- for a constant. Once the constant is elaborated, its value is 18225 -- not changed, therefore the associated flags that describe the 18226 -- value should not be modified either. 18227 18228 if Ekind (Ent) = E_Constant then 18229 null; 18230 18231 -- Non-constant entities 18232 18233 else 18234 if not Can_Never_Be_Null (Ent) then 18235 Set_Is_Known_Non_Null (Ent, False); 18236 end if; 18237 18238 Set_Is_Known_Null (Ent, False); 18239 18240 -- Reset the Is_Known_Valid flag unless the type is always 18241 -- valid. This does not apply to a loop parameter because its 18242 -- bounds are defined by the loop header and therefore always 18243 -- valid. 18244 18245 if not Is_Known_Valid (Etype (Ent)) 18246 and then Ekind (Ent) /= E_Loop_Parameter 18247 then 18248 Set_Is_Known_Valid (Ent, False); 18249 end if; 18250 end if; 18251 end if; 18252 end if; 18253 end Kill_Current_Values; 18254 18255 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is 18256 S : Entity_Id; 18257 18258 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id); 18259 -- Clear current value for entity E and all entities chained to E 18260 18261 ------------------------------------------ 18262 -- Kill_Current_Values_For_Entity_Chain -- 18263 ------------------------------------------ 18264 18265 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is 18266 Ent : Entity_Id; 18267 begin 18268 Ent := E; 18269 while Present (Ent) loop 18270 Kill_Current_Values (Ent, Last_Assignment_Only); 18271 Next_Entity (Ent); 18272 end loop; 18273 end Kill_Current_Values_For_Entity_Chain; 18274 18275 -- Start of processing for Kill_Current_Values 18276 18277 begin 18278 -- Kill all saved checks, a special case of killing saved values 18279 18280 if not Last_Assignment_Only then 18281 Kill_All_Checks; 18282 end if; 18283 18284 -- Loop through relevant scopes, which includes the current scope and 18285 -- any parent scopes if the current scope is a block or a package. 18286 18287 S := Current_Scope; 18288 Scope_Loop : loop 18289 18290 -- Clear current values of all entities in current scope 18291 18292 Kill_Current_Values_For_Entity_Chain (First_Entity (S)); 18293 18294 -- If scope is a package, also clear current values of all private 18295 -- entities in the scope. 18296 18297 if Is_Package_Or_Generic_Package (S) 18298 or else Is_Concurrent_Type (S) 18299 then 18300 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S)); 18301 end if; 18302 18303 -- If this is a not a subprogram, deal with parents 18304 18305 if not Is_Subprogram (S) then 18306 S := Scope (S); 18307 exit Scope_Loop when S = Standard_Standard; 18308 else 18309 exit Scope_Loop; 18310 end if; 18311 end loop Scope_Loop; 18312 end Kill_Current_Values; 18313 18314 -------------------------- 18315 -- Kill_Size_Check_Code -- 18316 -------------------------- 18317 18318 procedure Kill_Size_Check_Code (E : Entity_Id) is 18319 begin 18320 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 18321 and then Present (Size_Check_Code (E)) 18322 then 18323 Remove (Size_Check_Code (E)); 18324 Set_Size_Check_Code (E, Empty); 18325 end if; 18326 end Kill_Size_Check_Code; 18327 18328 -------------------- 18329 -- Known_Non_Null -- 18330 -------------------- 18331 18332 function Known_Non_Null (N : Node_Id) return Boolean is 18333 Status : constant Null_Status_Kind := Null_Status (N); 18334 18335 Id : Entity_Id; 18336 Op : Node_Kind; 18337 Val : Node_Id; 18338 18339 begin 18340 -- The expression yields a non-null value ignoring simple flow analysis 18341 18342 if Status = Is_Non_Null then 18343 return True; 18344 18345 -- Otherwise check whether N is a reference to an entity that appears 18346 -- within a conditional construct. 18347 18348 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 18349 18350 -- First check if we are in decisive conditional 18351 18352 Get_Current_Value_Condition (N, Op, Val); 18353 18354 if Known_Null (Val) then 18355 if Op = N_Op_Eq then 18356 return False; 18357 elsif Op = N_Op_Ne then 18358 return True; 18359 end if; 18360 end if; 18361 18362 -- If OK to do replacement, test Is_Known_Non_Null flag 18363 18364 Id := Entity (N); 18365 18366 if OK_To_Do_Constant_Replacement (Id) then 18367 return Is_Known_Non_Null (Id); 18368 end if; 18369 end if; 18370 18371 -- Otherwise it is not possible to determine whether N yields a non-null 18372 -- value. 18373 18374 return False; 18375 end Known_Non_Null; 18376 18377 ---------------- 18378 -- Known_Null -- 18379 ---------------- 18380 18381 function Known_Null (N : Node_Id) return Boolean is 18382 Status : constant Null_Status_Kind := Null_Status (N); 18383 18384 Id : Entity_Id; 18385 Op : Node_Kind; 18386 Val : Node_Id; 18387 18388 begin 18389 -- The expression yields a null value ignoring simple flow analysis 18390 18391 if Status = Is_Null then 18392 return True; 18393 18394 -- Otherwise check whether N is a reference to an entity that appears 18395 -- within a conditional construct. 18396 18397 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 18398 18399 -- First check if we are in decisive conditional 18400 18401 Get_Current_Value_Condition (N, Op, Val); 18402 18403 if Known_Null (Val) then 18404 if Op = N_Op_Eq then 18405 return True; 18406 elsif Op = N_Op_Ne then 18407 return False; 18408 end if; 18409 end if; 18410 18411 -- If OK to do replacement, test Is_Known_Null flag 18412 18413 Id := Entity (N); 18414 18415 if OK_To_Do_Constant_Replacement (Id) then 18416 return Is_Known_Null (Id); 18417 end if; 18418 end if; 18419 18420 -- Otherwise it is not possible to determine whether N yields a null 18421 -- value. 18422 18423 return False; 18424 end Known_Null; 18425 18426 -------------------------- 18427 -- Known_To_Be_Assigned -- 18428 -------------------------- 18429 18430 function Known_To_Be_Assigned (N : Node_Id) return Boolean is 18431 P : constant Node_Id := Parent (N); 18432 18433 begin 18434 case Nkind (P) is 18435 18436 -- Test left side of assignment 18437 18438 when N_Assignment_Statement => 18439 return N = Name (P); 18440 18441 -- Function call arguments are never lvalues 18442 18443 when N_Function_Call => 18444 return False; 18445 18446 -- Positional parameter for procedure or accept call 18447 18448 when N_Accept_Statement 18449 | N_Procedure_Call_Statement 18450 => 18451 declare 18452 Proc : Entity_Id; 18453 Form : Entity_Id; 18454 Act : Node_Id; 18455 18456 begin 18457 Proc := Get_Subprogram_Entity (P); 18458 18459 if No (Proc) then 18460 return False; 18461 end if; 18462 18463 -- If we are not a list member, something is strange, so 18464 -- be conservative and return False. 18465 18466 if not Is_List_Member (N) then 18467 return False; 18468 end if; 18469 18470 -- We are going to find the right formal by stepping forward 18471 -- through the formals, as we step backwards in the actuals. 18472 18473 Form := First_Formal (Proc); 18474 Act := N; 18475 loop 18476 -- If no formal, something is weird, so be conservative 18477 -- and return False. 18478 18479 if No (Form) then 18480 return False; 18481 end if; 18482 18483 Prev (Act); 18484 exit when No (Act); 18485 Next_Formal (Form); 18486 end loop; 18487 18488 return Ekind (Form) /= E_In_Parameter; 18489 end; 18490 18491 -- Named parameter for procedure or accept call 18492 18493 when N_Parameter_Association => 18494 declare 18495 Proc : Entity_Id; 18496 Form : Entity_Id; 18497 18498 begin 18499 Proc := Get_Subprogram_Entity (Parent (P)); 18500 18501 if No (Proc) then 18502 return False; 18503 end if; 18504 18505 -- Loop through formals to find the one that matches 18506 18507 Form := First_Formal (Proc); 18508 loop 18509 -- If no matching formal, that's peculiar, some kind of 18510 -- previous error, so return False to be conservative. 18511 -- Actually this also happens in legal code in the case 18512 -- where P is a parameter association for an Extra_Formal??? 18513 18514 if No (Form) then 18515 return False; 18516 end if; 18517 18518 -- Else test for match 18519 18520 if Chars (Form) = Chars (Selector_Name (P)) then 18521 return Ekind (Form) /= E_In_Parameter; 18522 end if; 18523 18524 Next_Formal (Form); 18525 end loop; 18526 end; 18527 18528 -- Test for appearing in a conversion that itself appears 18529 -- in an lvalue context, since this should be an lvalue. 18530 18531 when N_Type_Conversion => 18532 return Known_To_Be_Assigned (P); 18533 18534 -- All other references are definitely not known to be modifications 18535 18536 when others => 18537 return False; 18538 end case; 18539 end Known_To_Be_Assigned; 18540 18541 --------------------------- 18542 -- Last_Source_Statement -- 18543 --------------------------- 18544 18545 function Last_Source_Statement (HSS : Node_Id) return Node_Id is 18546 N : Node_Id; 18547 18548 begin 18549 N := Last (Statements (HSS)); 18550 while Present (N) loop 18551 exit when Comes_From_Source (N); 18552 Prev (N); 18553 end loop; 18554 18555 return N; 18556 end Last_Source_Statement; 18557 18558 ----------------------- 18559 -- Mark_Coextensions -- 18560 ----------------------- 18561 18562 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is 18563 Is_Dynamic : Boolean; 18564 -- Indicates whether the context causes nested coextensions to be 18565 -- dynamic or static 18566 18567 function Mark_Allocator (N : Node_Id) return Traverse_Result; 18568 -- Recognize an allocator node and label it as a dynamic coextension 18569 18570 -------------------- 18571 -- Mark_Allocator -- 18572 -------------------- 18573 18574 function Mark_Allocator (N : Node_Id) return Traverse_Result is 18575 begin 18576 if Nkind (N) = N_Allocator then 18577 if Is_Dynamic then 18578 Set_Is_Static_Coextension (N, False); 18579 Set_Is_Dynamic_Coextension (N); 18580 18581 -- If the allocator expression is potentially dynamic, it may 18582 -- be expanded out of order and require dynamic allocation 18583 -- anyway, so we treat the coextension itself as dynamic. 18584 -- Potential optimization ??? 18585 18586 elsif Nkind (Expression (N)) = N_Qualified_Expression 18587 and then Nkind (Expression (Expression (N))) = N_Op_Concat 18588 then 18589 Set_Is_Static_Coextension (N, False); 18590 Set_Is_Dynamic_Coextension (N); 18591 else 18592 Set_Is_Dynamic_Coextension (N, False); 18593 Set_Is_Static_Coextension (N); 18594 end if; 18595 end if; 18596 18597 return OK; 18598 end Mark_Allocator; 18599 18600 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator); 18601 18602 -- Start of processing for Mark_Coextensions 18603 18604 begin 18605 -- An allocator that appears on the right-hand side of an assignment is 18606 -- treated as a potentially dynamic coextension when the right-hand side 18607 -- is an allocator or a qualified expression. 18608 18609 -- Obj := new ...'(new Coextension ...); 18610 18611 if Nkind (Context_Nod) = N_Assignment_Statement then 18612 Is_Dynamic := 18613 Nkind_In (Expression (Context_Nod), N_Allocator, 18614 N_Qualified_Expression); 18615 18616 -- An allocator that appears within the expression of a simple return 18617 -- statement is treated as a potentially dynamic coextension when the 18618 -- expression is either aggregate, allocator, or qualified expression. 18619 18620 -- return (new Coextension ...); 18621 -- return new ...'(new Coextension ...); 18622 18623 elsif Nkind (Context_Nod) = N_Simple_Return_Statement then 18624 Is_Dynamic := 18625 Nkind_In (Expression (Context_Nod), N_Aggregate, 18626 N_Allocator, 18627 N_Qualified_Expression); 18628 18629 -- An alloctor that appears within the initialization expression of an 18630 -- object declaration is considered a potentially dynamic coextension 18631 -- when the initialization expression is an allocator or a qualified 18632 -- expression. 18633 18634 -- Obj : ... := new ...'(new Coextension ...); 18635 18636 -- A similar case arises when the object declaration is part of an 18637 -- extended return statement. 18638 18639 -- return Obj : ... := new ...'(new Coextension ...); 18640 -- return Obj : ... := (new Coextension ...); 18641 18642 elsif Nkind (Context_Nod) = N_Object_Declaration then 18643 Is_Dynamic := 18644 Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression) 18645 or else 18646 Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement; 18647 18648 -- This routine should not be called with constructs that cannot contain 18649 -- coextensions. 18650 18651 else 18652 raise Program_Error; 18653 end if; 18654 18655 Mark_Allocators (Root_Nod); 18656 end Mark_Coextensions; 18657 18658 --------------------------------- 18659 -- Mark_Elaboration_Attributes -- 18660 --------------------------------- 18661 18662 procedure Mark_Elaboration_Attributes 18663 (N_Id : Node_Or_Entity_Id; 18664 Checks : Boolean := False; 18665 Level : Boolean := False; 18666 Modes : Boolean := False; 18667 Warnings : Boolean := False) 18668 is 18669 function Elaboration_Checks_OK 18670 (Target_Id : Entity_Id; 18671 Context_Id : Entity_Id) return Boolean; 18672 -- Determine whether elaboration checks are enabled for target Target_Id 18673 -- which resides within context Context_Id. 18674 18675 procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id); 18676 -- Preserve relevant attributes of the context in arbitrary entity Id 18677 18678 procedure Mark_Elaboration_Attributes_Node (N : Node_Id); 18679 -- Preserve relevant attributes of the context in arbitrary node N 18680 18681 --------------------------- 18682 -- Elaboration_Checks_OK -- 18683 --------------------------- 18684 18685 function Elaboration_Checks_OK 18686 (Target_Id : Entity_Id; 18687 Context_Id : Entity_Id) return Boolean 18688 is 18689 Encl_Scop : Entity_Id; 18690 18691 begin 18692 -- Elaboration checks are suppressed for the target 18693 18694 if Elaboration_Checks_Suppressed (Target_Id) then 18695 return False; 18696 end if; 18697 18698 -- Otherwise elaboration checks are OK for the target, but may be 18699 -- suppressed for the context where the target is declared. 18700 18701 Encl_Scop := Context_Id; 18702 while Present (Encl_Scop) and then Encl_Scop /= Standard_Standard loop 18703 if Elaboration_Checks_Suppressed (Encl_Scop) then 18704 return False; 18705 end if; 18706 18707 Encl_Scop := Scope (Encl_Scop); 18708 end loop; 18709 18710 -- Neither the target nor its declarative context have elaboration 18711 -- checks suppressed. 18712 18713 return True; 18714 end Elaboration_Checks_OK; 18715 18716 ------------------------------------ 18717 -- Mark_Elaboration_Attributes_Id -- 18718 ------------------------------------ 18719 18720 procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id) is 18721 begin 18722 -- Mark the status of elaboration checks in effect. Do not reset the 18723 -- status in case the entity is reanalyzed with checks suppressed. 18724 18725 if Checks and then not Is_Elaboration_Checks_OK_Id (Id) then 18726 Set_Is_Elaboration_Checks_OK_Id (Id, 18727 Elaboration_Checks_OK 18728 (Target_Id => Id, 18729 Context_Id => Scope (Id))); 18730 end if; 18731 18732 -- Mark the status of elaboration warnings in effect. Do not reset 18733 -- the status in case the entity is reanalyzed with warnings off. 18734 18735 if Warnings and then not Is_Elaboration_Warnings_OK_Id (Id) then 18736 Set_Is_Elaboration_Warnings_OK_Id (Id, Elab_Warnings); 18737 end if; 18738 end Mark_Elaboration_Attributes_Id; 18739 18740 -------------------------------------- 18741 -- Mark_Elaboration_Attributes_Node -- 18742 -------------------------------------- 18743 18744 procedure Mark_Elaboration_Attributes_Node (N : Node_Id) is 18745 function Extract_Name (N : Node_Id) return Node_Id; 18746 -- Obtain the Name attribute of call or instantiation N 18747 18748 ------------------ 18749 -- Extract_Name -- 18750 ------------------ 18751 18752 function Extract_Name (N : Node_Id) return Node_Id is 18753 Nam : Node_Id; 18754 18755 begin 18756 Nam := Name (N); 18757 18758 -- A call to an entry family appears in indexed form 18759 18760 if Nkind (Nam) = N_Indexed_Component then 18761 Nam := Prefix (Nam); 18762 end if; 18763 18764 -- The name may also appear in qualified form 18765 18766 if Nkind (Nam) = N_Selected_Component then 18767 Nam := Selector_Name (Nam); 18768 end if; 18769 18770 return Nam; 18771 end Extract_Name; 18772 18773 -- Local variables 18774 18775 Context_Id : Entity_Id; 18776 Nam : Node_Id; 18777 18778 -- Start of processing for Mark_Elaboration_Attributes_Node 18779 18780 begin 18781 -- Mark the status of elaboration checks in effect. Do not reset the 18782 -- status in case the node is reanalyzed with checks suppressed. 18783 18784 if Checks and then not Is_Elaboration_Checks_OK_Node (N) then 18785 18786 -- Assignments, attribute references, and variable references do 18787 -- not have a "declarative" context. 18788 18789 Context_Id := Empty; 18790 18791 -- The status of elaboration checks for calls and instantiations 18792 -- depends on the most recent pragma Suppress/Unsuppress, as well 18793 -- as the suppression status of the context where the target is 18794 -- defined. 18795 18796 -- package Pack is 18797 -- function Func ...; 18798 -- end Pack; 18799 18800 -- with Pack; 18801 -- procedure Main is 18802 -- pragma Suppress (Elaboration_Checks, Pack); 18803 -- X : ... := Pack.Func; 18804 -- ... 18805 18806 -- In the example above, the call to Func has elaboration checks 18807 -- enabled because there is no active general purpose suppression 18808 -- pragma, however the elaboration checks of Pack are explicitly 18809 -- suppressed. As a result the elaboration checks of the call must 18810 -- be disabled in order to preserve this dependency. 18811 18812 if Nkind_In (N, N_Entry_Call_Statement, 18813 N_Function_Call, 18814 N_Function_Instantiation, 18815 N_Package_Instantiation, 18816 N_Procedure_Call_Statement, 18817 N_Procedure_Instantiation) 18818 then 18819 Nam := Extract_Name (N); 18820 18821 if Is_Entity_Name (Nam) and then Present (Entity (Nam)) then 18822 Context_Id := Scope (Entity (Nam)); 18823 end if; 18824 end if; 18825 18826 Set_Is_Elaboration_Checks_OK_Node (N, 18827 Elaboration_Checks_OK 18828 (Target_Id => Empty, 18829 Context_Id => Context_Id)); 18830 end if; 18831 18832 -- Mark the enclosing level of the node. Do not reset the status in 18833 -- case the node is relocated and reanalyzed. 18834 18835 if Level and then not Is_Declaration_Level_Node (N) then 18836 Set_Is_Declaration_Level_Node (N, 18837 Find_Enclosing_Level (N) = Declaration_Level); 18838 end if; 18839 18840 -- Mark the Ghost and SPARK mode in effect 18841 18842 if Modes then 18843 if Ghost_Mode = Ignore then 18844 Set_Is_Ignored_Ghost_Node (N); 18845 end if; 18846 18847 if SPARK_Mode = On then 18848 Set_Is_SPARK_Mode_On_Node (N); 18849 end if; 18850 end if; 18851 18852 -- Mark the status of elaboration warnings in effect. Do not reset 18853 -- the status in case the node is reanalyzed with warnings off. 18854 18855 if Warnings and then not Is_Elaboration_Warnings_OK_Node (N) then 18856 Set_Is_Elaboration_Warnings_OK_Node (N, Elab_Warnings); 18857 end if; 18858 end Mark_Elaboration_Attributes_Node; 18859 18860 -- Start of processing for Mark_Elaboration_Attributes 18861 18862 begin 18863 -- Do not capture any elaboration-related attributes when switch -gnatH 18864 -- (legacy elaboration checking mode enabled) is in effect because the 18865 -- attributes are useless to the legacy model. 18866 18867 if Legacy_Elaboration_Checks then 18868 return; 18869 end if; 18870 18871 if Nkind (N_Id) in N_Entity then 18872 Mark_Elaboration_Attributes_Id (N_Id); 18873 else 18874 Mark_Elaboration_Attributes_Node (N_Id); 18875 end if; 18876 end Mark_Elaboration_Attributes; 18877 18878 ---------------------------------- 18879 -- Matching_Static_Array_Bounds -- 18880 ---------------------------------- 18881 18882 function Matching_Static_Array_Bounds 18883 (L_Typ : Node_Id; 18884 R_Typ : Node_Id) return Boolean 18885 is 18886 L_Ndims : constant Nat := Number_Dimensions (L_Typ); 18887 R_Ndims : constant Nat := Number_Dimensions (R_Typ); 18888 18889 L_Index : Node_Id := Empty; -- init to ... 18890 R_Index : Node_Id := Empty; -- ...avoid warnings 18891 L_Low : Node_Id; 18892 L_High : Node_Id; 18893 L_Len : Uint; 18894 R_Low : Node_Id; 18895 R_High : Node_Id; 18896 R_Len : Uint; 18897 18898 begin 18899 if L_Ndims /= R_Ndims then 18900 return False; 18901 end if; 18902 18903 -- Unconstrained types do not have static bounds 18904 18905 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then 18906 return False; 18907 end if; 18908 18909 -- First treat specially the first dimension, as the lower bound and 18910 -- length of string literals are not stored like those of arrays. 18911 18912 if Ekind (L_Typ) = E_String_Literal_Subtype then 18913 L_Low := String_Literal_Low_Bound (L_Typ); 18914 L_Len := String_Literal_Length (L_Typ); 18915 else 18916 L_Index := First_Index (L_Typ); 18917 Get_Index_Bounds (L_Index, L_Low, L_High); 18918 18919 if Is_OK_Static_Expression (L_Low) 18920 and then 18921 Is_OK_Static_Expression (L_High) 18922 then 18923 if Expr_Value (L_High) < Expr_Value (L_Low) then 18924 L_Len := Uint_0; 18925 else 18926 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1; 18927 end if; 18928 else 18929 return False; 18930 end if; 18931 end if; 18932 18933 if Ekind (R_Typ) = E_String_Literal_Subtype then 18934 R_Low := String_Literal_Low_Bound (R_Typ); 18935 R_Len := String_Literal_Length (R_Typ); 18936 else 18937 R_Index := First_Index (R_Typ); 18938 Get_Index_Bounds (R_Index, R_Low, R_High); 18939 18940 if Is_OK_Static_Expression (R_Low) 18941 and then 18942 Is_OK_Static_Expression (R_High) 18943 then 18944 if Expr_Value (R_High) < Expr_Value (R_Low) then 18945 R_Len := Uint_0; 18946 else 18947 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1; 18948 end if; 18949 else 18950 return False; 18951 end if; 18952 end if; 18953 18954 if (Is_OK_Static_Expression (L_Low) 18955 and then 18956 Is_OK_Static_Expression (R_Low)) 18957 and then Expr_Value (L_Low) = Expr_Value (R_Low) 18958 and then L_Len = R_Len 18959 then 18960 null; 18961 else 18962 return False; 18963 end if; 18964 18965 -- Then treat all other dimensions 18966 18967 for Indx in 2 .. L_Ndims loop 18968 Next (L_Index); 18969 Next (R_Index); 18970 18971 Get_Index_Bounds (L_Index, L_Low, L_High); 18972 Get_Index_Bounds (R_Index, R_Low, R_High); 18973 18974 if (Is_OK_Static_Expression (L_Low) and then 18975 Is_OK_Static_Expression (L_High) and then 18976 Is_OK_Static_Expression (R_Low) and then 18977 Is_OK_Static_Expression (R_High)) 18978 and then (Expr_Value (L_Low) = Expr_Value (R_Low) 18979 and then 18980 Expr_Value (L_High) = Expr_Value (R_High)) 18981 then 18982 null; 18983 else 18984 return False; 18985 end if; 18986 end loop; 18987 18988 -- If we fall through the loop, all indexes matched 18989 18990 return True; 18991 end Matching_Static_Array_Bounds; 18992 18993 ------------------- 18994 -- May_Be_Lvalue -- 18995 ------------------- 18996 18997 function May_Be_Lvalue (N : Node_Id) return Boolean is 18998 P : constant Node_Id := Parent (N); 18999 19000 begin 19001 case Nkind (P) is 19002 19003 -- Test left side of assignment 19004 19005 when N_Assignment_Statement => 19006 return N = Name (P); 19007 19008 -- Test prefix of component or attribute. Note that the prefix of an 19009 -- explicit or implicit dereference cannot be an l-value. In the case 19010 -- of a 'Read attribute, the reference can be an actual in the 19011 -- argument list of the attribute. 19012 19013 when N_Attribute_Reference => 19014 return (N = Prefix (P) 19015 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P))) 19016 or else 19017 Attribute_Name (P) = Name_Read; 19018 19019 -- For an expanded name, the name is an lvalue if the expanded name 19020 -- is an lvalue, but the prefix is never an lvalue, since it is just 19021 -- the scope where the name is found. 19022 19023 when N_Expanded_Name => 19024 if N = Prefix (P) then 19025 return May_Be_Lvalue (P); 19026 else 19027 return False; 19028 end if; 19029 19030 -- For a selected component A.B, A is certainly an lvalue if A.B is. 19031 -- B is a little interesting, if we have A.B := 3, there is some 19032 -- discussion as to whether B is an lvalue or not, we choose to say 19033 -- it is. Note however that A is not an lvalue if it is of an access 19034 -- type since this is an implicit dereference. 19035 19036 when N_Selected_Component => 19037 if N = Prefix (P) 19038 and then Present (Etype (N)) 19039 and then Is_Access_Type (Etype (N)) 19040 then 19041 return False; 19042 else 19043 return May_Be_Lvalue (P); 19044 end if; 19045 19046 -- For an indexed component or slice, the index or slice bounds is 19047 -- never an lvalue. The prefix is an lvalue if the indexed component 19048 -- or slice is an lvalue, except if it is an access type, where we 19049 -- have an implicit dereference. 19050 19051 when N_Indexed_Component 19052 | N_Slice 19053 => 19054 if N /= Prefix (P) 19055 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N))) 19056 then 19057 return False; 19058 else 19059 return May_Be_Lvalue (P); 19060 end if; 19061 19062 -- Prefix of a reference is an lvalue if the reference is an lvalue 19063 19064 when N_Reference => 19065 return May_Be_Lvalue (P); 19066 19067 -- Prefix of explicit dereference is never an lvalue 19068 19069 when N_Explicit_Dereference => 19070 return False; 19071 19072 -- Positional parameter for subprogram, entry, or accept call. 19073 -- In older versions of Ada function call arguments are never 19074 -- lvalues. In Ada 2012 functions can have in-out parameters. 19075 19076 when N_Accept_Statement 19077 | N_Entry_Call_Statement 19078 | N_Subprogram_Call 19079 => 19080 if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then 19081 return False; 19082 end if; 19083 19084 -- The following mechanism is clumsy and fragile. A single flag 19085 -- set in Resolve_Actuals would be preferable ??? 19086 19087 declare 19088 Proc : Entity_Id; 19089 Form : Entity_Id; 19090 Act : Node_Id; 19091 19092 begin 19093 Proc := Get_Subprogram_Entity (P); 19094 19095 if No (Proc) then 19096 return True; 19097 end if; 19098 19099 -- If we are not a list member, something is strange, so be 19100 -- conservative and return True. 19101 19102 if not Is_List_Member (N) then 19103 return True; 19104 end if; 19105 19106 -- We are going to find the right formal by stepping forward 19107 -- through the formals, as we step backwards in the actuals. 19108 19109 Form := First_Formal (Proc); 19110 Act := N; 19111 loop 19112 -- If no formal, something is weird, so be conservative and 19113 -- return True. 19114 19115 if No (Form) then 19116 return True; 19117 end if; 19118 19119 Prev (Act); 19120 exit when No (Act); 19121 Next_Formal (Form); 19122 end loop; 19123 19124 return Ekind (Form) /= E_In_Parameter; 19125 end; 19126 19127 -- Named parameter for procedure or accept call 19128 19129 when N_Parameter_Association => 19130 declare 19131 Proc : Entity_Id; 19132 Form : Entity_Id; 19133 19134 begin 19135 Proc := Get_Subprogram_Entity (Parent (P)); 19136 19137 if No (Proc) then 19138 return True; 19139 end if; 19140 19141 -- Loop through formals to find the one that matches 19142 19143 Form := First_Formal (Proc); 19144 loop 19145 -- If no matching formal, that's peculiar, some kind of 19146 -- previous error, so return True to be conservative. 19147 -- Actually happens with legal code for an unresolved call 19148 -- where we may get the wrong homonym??? 19149 19150 if No (Form) then 19151 return True; 19152 end if; 19153 19154 -- Else test for match 19155 19156 if Chars (Form) = Chars (Selector_Name (P)) then 19157 return Ekind (Form) /= E_In_Parameter; 19158 end if; 19159 19160 Next_Formal (Form); 19161 end loop; 19162 end; 19163 19164 -- Test for appearing in a conversion that itself appears in an 19165 -- lvalue context, since this should be an lvalue. 19166 19167 when N_Type_Conversion => 19168 return May_Be_Lvalue (P); 19169 19170 -- Test for appearance in object renaming declaration 19171 19172 when N_Object_Renaming_Declaration => 19173 return True; 19174 19175 -- All other references are definitely not lvalues 19176 19177 when others => 19178 return False; 19179 end case; 19180 end May_Be_Lvalue; 19181 19182 ----------------- 19183 -- Might_Raise -- 19184 ----------------- 19185 19186 function Might_Raise (N : Node_Id) return Boolean is 19187 Result : Boolean := False; 19188 19189 function Process (N : Node_Id) return Traverse_Result; 19190 -- Set Result to True if we find something that could raise an exception 19191 19192 ------------- 19193 -- Process -- 19194 ------------- 19195 19196 function Process (N : Node_Id) return Traverse_Result is 19197 begin 19198 if Nkind_In (N, N_Procedure_Call_Statement, 19199 N_Function_Call, 19200 N_Raise_Statement, 19201 N_Raise_Constraint_Error, 19202 N_Raise_Program_Error, 19203 N_Raise_Storage_Error) 19204 then 19205 Result := True; 19206 return Abandon; 19207 else 19208 return OK; 19209 end if; 19210 end Process; 19211 19212 procedure Set_Result is new Traverse_Proc (Process); 19213 19214 -- Start of processing for Might_Raise 19215 19216 begin 19217 -- False if exceptions can't be propagated 19218 19219 if No_Exception_Handlers_Set then 19220 return False; 19221 end if; 19222 19223 -- If the checks handled by the back end are not disabled, we cannot 19224 -- ensure that no exception will be raised. 19225 19226 if not Access_Checks_Suppressed (Empty) 19227 or else not Discriminant_Checks_Suppressed (Empty) 19228 or else not Range_Checks_Suppressed (Empty) 19229 or else not Index_Checks_Suppressed (Empty) 19230 or else Opt.Stack_Checking_Enabled 19231 then 19232 return True; 19233 end if; 19234 19235 Set_Result (N); 19236 return Result; 19237 end Might_Raise; 19238 19239 -------------------------------- 19240 -- Nearest_Enclosing_Instance -- 19241 -------------------------------- 19242 19243 function Nearest_Enclosing_Instance (E : Entity_Id) return Entity_Id is 19244 Inst : Entity_Id; 19245 19246 begin 19247 Inst := Scope (E); 19248 while Present (Inst) and then Inst /= Standard_Standard loop 19249 if Is_Generic_Instance (Inst) then 19250 return Inst; 19251 end if; 19252 19253 Inst := Scope (Inst); 19254 end loop; 19255 19256 return Empty; 19257 end Nearest_Enclosing_Instance; 19258 19259 ---------------------- 19260 -- Needs_One_Actual -- 19261 ---------------------- 19262 19263 function Needs_One_Actual (E : Entity_Id) return Boolean is 19264 Formal : Entity_Id; 19265 19266 begin 19267 -- Ada 2005 or later, and formals present. The first formal must be 19268 -- of a type that supports prefix notation: a controlling argument, 19269 -- a class-wide type, or an access to such. 19270 19271 if Ada_Version >= Ada_2005 19272 and then Present (First_Formal (E)) 19273 and then No (Default_Value (First_Formal (E))) 19274 and then 19275 (Is_Controlling_Formal (First_Formal (E)) 19276 or else Is_Class_Wide_Type (Etype (First_Formal (E))) 19277 or else Is_Anonymous_Access_Type (Etype (First_Formal (E)))) 19278 then 19279 Formal := Next_Formal (First_Formal (E)); 19280 while Present (Formal) loop 19281 if No (Default_Value (Formal)) then 19282 return False; 19283 end if; 19284 19285 Next_Formal (Formal); 19286 end loop; 19287 19288 return True; 19289 19290 -- Ada 83/95 or no formals 19291 19292 else 19293 return False; 19294 end if; 19295 end Needs_One_Actual; 19296 19297 --------------------------------- 19298 -- Needs_Simple_Initialization -- 19299 --------------------------------- 19300 19301 function Needs_Simple_Initialization 19302 (Typ : Entity_Id; 19303 Consider_IS : Boolean := True) return Boolean 19304 is 19305 Consider_IS_NS : constant Boolean := 19306 Normalize_Scalars or (Initialize_Scalars and Consider_IS); 19307 19308 begin 19309 -- Never need initialization if it is suppressed 19310 19311 if Initialization_Suppressed (Typ) then 19312 return False; 19313 end if; 19314 19315 -- Check for private type, in which case test applies to the underlying 19316 -- type of the private type. 19317 19318 if Is_Private_Type (Typ) then 19319 declare 19320 RT : constant Entity_Id := Underlying_Type (Typ); 19321 begin 19322 if Present (RT) then 19323 return Needs_Simple_Initialization (RT); 19324 else 19325 return False; 19326 end if; 19327 end; 19328 19329 -- Scalar type with Default_Value aspect requires initialization 19330 19331 elsif Is_Scalar_Type (Typ) and then Has_Default_Aspect (Typ) then 19332 return True; 19333 19334 -- Cases needing simple initialization are access types, and, if pragma 19335 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar 19336 -- types. 19337 19338 elsif Is_Access_Type (Typ) 19339 or else (Consider_IS_NS and then (Is_Scalar_Type (Typ))) 19340 then 19341 return True; 19342 19343 -- If Initialize/Normalize_Scalars is in effect, string objects also 19344 -- need initialization, unless they are created in the course of 19345 -- expanding an aggregate (since in the latter case they will be 19346 -- filled with appropriate initializing values before they are used). 19347 19348 elsif Consider_IS_NS 19349 and then Is_Standard_String_Type (Typ) 19350 and then 19351 (not Is_Itype (Typ) 19352 or else Nkind (Associated_Node_For_Itype (Typ)) /= N_Aggregate) 19353 then 19354 return True; 19355 19356 else 19357 return False; 19358 end if; 19359 end Needs_Simple_Initialization; 19360 19361 ------------------------------------- 19362 -- Needs_Variable_Reference_Marker -- 19363 ------------------------------------- 19364 19365 function Needs_Variable_Reference_Marker 19366 (N : Node_Id; 19367 Calls_OK : Boolean) return Boolean 19368 is 19369 function Within_Suitable_Context (Ref : Node_Id) return Boolean; 19370 -- Deteremine whether variable reference Ref appears within a suitable 19371 -- context that allows the creation of a marker. 19372 19373 ----------------------------- 19374 -- Within_Suitable_Context -- 19375 ----------------------------- 19376 19377 function Within_Suitable_Context (Ref : Node_Id) return Boolean is 19378 Par : Node_Id; 19379 19380 begin 19381 Par := Ref; 19382 while Present (Par) loop 19383 19384 -- The context is not suitable when the reference appears within 19385 -- the formal part of an instantiation which acts as compilation 19386 -- unit because there is no proper list for the insertion of the 19387 -- marker. 19388 19389 if Nkind (Par) = N_Generic_Association 19390 and then Nkind (Parent (Par)) in N_Generic_Instantiation 19391 and then Nkind (Parent (Parent (Par))) = N_Compilation_Unit 19392 then 19393 return False; 19394 19395 -- The context is not suitable when the reference appears within 19396 -- a pragma. If the pragma has run-time semantics, the reference 19397 -- will be reconsidered once the pragma is expanded. 19398 19399 elsif Nkind (Par) = N_Pragma then 19400 return False; 19401 19402 -- The context is not suitable when the reference appears within a 19403 -- subprogram call, and the caller requests this behavior. 19404 19405 elsif not Calls_OK 19406 and then Nkind_In (Par, N_Entry_Call_Statement, 19407 N_Function_Call, 19408 N_Procedure_Call_Statement) 19409 then 19410 return False; 19411 19412 -- Prevent the search from going too far 19413 19414 elsif Is_Body_Or_Package_Declaration (Par) then 19415 exit; 19416 end if; 19417 19418 Par := Parent (Par); 19419 end loop; 19420 19421 return True; 19422 end Within_Suitable_Context; 19423 19424 -- Local variables 19425 19426 Prag : Node_Id; 19427 Var_Id : Entity_Id; 19428 19429 -- Start of processing for Needs_Variable_Reference_Marker 19430 19431 begin 19432 -- No marker needs to be created when switch -gnatH (legacy elaboration 19433 -- checking mode enabled) is in effect because the legacy ABE mechanism 19434 -- does not use markers. 19435 19436 if Legacy_Elaboration_Checks then 19437 return False; 19438 19439 -- No marker needs to be created for ASIS because ABE diagnostics and 19440 -- checks are not performed in this mode. 19441 19442 elsif ASIS_Mode then 19443 return False; 19444 19445 -- No marker needs to be created when the reference is preanalyzed 19446 -- because the marker will be inserted in the wrong place. 19447 19448 elsif Preanalysis_Active then 19449 return False; 19450 19451 -- Only references warrant a marker 19452 19453 elsif not Nkind_In (N, N_Expanded_Name, N_Identifier) then 19454 return False; 19455 19456 -- Only source references warrant a marker 19457 19458 elsif not Comes_From_Source (N) then 19459 return False; 19460 19461 -- No marker needs to be created when the reference is erroneous, left 19462 -- in a bad state, or does not denote a variable. 19463 19464 elsif not (Present (Entity (N)) 19465 and then Ekind (Entity (N)) = E_Variable 19466 and then Entity (N) /= Any_Id) 19467 then 19468 return False; 19469 end if; 19470 19471 Var_Id := Entity (N); 19472 Prag := SPARK_Pragma (Var_Id); 19473 19474 -- Both the variable and reference must appear in SPARK_Mode On regions 19475 -- because this elaboration scenario falls under the SPARK rules. 19476 19477 if not (Comes_From_Source (Var_Id) 19478 and then Present (Prag) 19479 and then Get_SPARK_Mode_From_Annotation (Prag) = On 19480 and then Is_SPARK_Mode_On_Node (N)) 19481 then 19482 return False; 19483 19484 -- No marker needs to be created when the reference does not appear 19485 -- within a suitable context (see body for details). 19486 19487 -- Performance note: parent traversal 19488 19489 elsif not Within_Suitable_Context (N) then 19490 return False; 19491 end if; 19492 19493 -- At this point it is known that the variable reference will play a 19494 -- role in ABE diagnostics and requires a marker. 19495 19496 return True; 19497 end Needs_Variable_Reference_Marker; 19498 19499 ------------------------ 19500 -- New_Copy_List_Tree -- 19501 ------------------------ 19502 19503 function New_Copy_List_Tree (List : List_Id) return List_Id is 19504 NL : List_Id; 19505 E : Node_Id; 19506 19507 begin 19508 if List = No_List then 19509 return No_List; 19510 19511 else 19512 NL := New_List; 19513 E := First (List); 19514 19515 while Present (E) loop 19516 Append (New_Copy_Tree (E), NL); 19517 E := Next (E); 19518 end loop; 19519 19520 return NL; 19521 end if; 19522 end New_Copy_List_Tree; 19523 19524 ------------------- 19525 -- New_Copy_Tree -- 19526 ------------------- 19527 19528 -- The following tables play a key role in replicating entities and Itypes. 19529 -- They are intentionally declared at the library level rather than within 19530 -- New_Copy_Tree to avoid elaborating them on each call. This performance 19531 -- optimization saves up to 2% of the entire compilation time spent in the 19532 -- front end. Care should be taken to reset the tables on each new call to 19533 -- New_Copy_Tree. 19534 19535 NCT_Table_Max : constant := 511; 19536 19537 subtype NCT_Table_Index is Nat range 0 .. NCT_Table_Max - 1; 19538 19539 function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index; 19540 -- Obtain the hash value of node or entity Key 19541 19542 -------------------- 19543 -- NCT_Table_Hash -- 19544 -------------------- 19545 19546 function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index is 19547 begin 19548 return NCT_Table_Index (Key mod NCT_Table_Max); 19549 end NCT_Table_Hash; 19550 19551 ---------------------- 19552 -- NCT_New_Entities -- 19553 ---------------------- 19554 19555 -- The following table maps old entities and Itypes to their corresponding 19556 -- new entities and Itypes. 19557 19558 -- Aaa -> Xxx 19559 19560 package NCT_New_Entities is new Simple_HTable ( 19561 Header_Num => NCT_Table_Index, 19562 Element => Entity_Id, 19563 No_Element => Empty, 19564 Key => Entity_Id, 19565 Hash => NCT_Table_Hash, 19566 Equal => "="); 19567 19568 ------------------------ 19569 -- NCT_Pending_Itypes -- 19570 ------------------------ 19571 19572 -- The following table maps old Associated_Node_For_Itype nodes to a set of 19573 -- new itypes. Given a set of old Itypes Aaa, Bbb, and Ccc, where all three 19574 -- have the same Associated_Node_For_Itype Ppp, and their corresponding new 19575 -- Itypes Xxx, Yyy, Zzz, the table contains the following mapping: 19576 19577 -- Ppp -> (Xxx, Yyy, Zzz) 19578 19579 -- The set is expressed as an Elist 19580 19581 package NCT_Pending_Itypes is new Simple_HTable ( 19582 Header_Num => NCT_Table_Index, 19583 Element => Elist_Id, 19584 No_Element => No_Elist, 19585 Key => Node_Id, 19586 Hash => NCT_Table_Hash, 19587 Equal => "="); 19588 19589 NCT_Tables_In_Use : Boolean := False; 19590 -- This flag keeps track of whether the two tables NCT_New_Entities and 19591 -- NCT_Pending_Itypes are in use. The flag is part of an optimization 19592 -- where certain operations are not performed if the tables are not in 19593 -- use. This saves up to 8% of the entire compilation time spent in the 19594 -- front end. 19595 19596 ------------------- 19597 -- New_Copy_Tree -- 19598 ------------------- 19599 19600 function New_Copy_Tree 19601 (Source : Node_Id; 19602 Map : Elist_Id := No_Elist; 19603 New_Sloc : Source_Ptr := No_Location; 19604 New_Scope : Entity_Id := Empty; 19605 Scopes_In_EWA_OK : Boolean := False) return Node_Id 19606 is 19607 -- This routine performs low-level tree manipulations and needs access 19608 -- to the internals of the tree. 19609 19610 use Atree.Unchecked_Access; 19611 use Atree_Private_Part; 19612 19613 EWA_Level : Nat := 0; 19614 -- This counter keeps track of how many N_Expression_With_Actions nodes 19615 -- are encountered during a depth-first traversal of the subtree. These 19616 -- nodes may define new entities in their Actions lists and thus require 19617 -- special processing. 19618 19619 EWA_Inner_Scope_Level : Nat := 0; 19620 -- This counter keeps track of how many scoping constructs appear within 19621 -- an N_Expression_With_Actions node. 19622 19623 procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id); 19624 pragma Inline (Add_New_Entity); 19625 -- Add an entry in the NCT_New_Entities table which maps key Old_Id to 19626 -- value New_Id. Old_Id is an entity which appears within the Actions 19627 -- list of an N_Expression_With_Actions node, or within an entity map. 19628 -- New_Id is the corresponding new entity generated during Phase 1. 19629 19630 procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id); 19631 pragma Inline (Add_New_Entity); 19632 -- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to 19633 -- value Itype. Assoc_Nod is the associated node of an itype. Itype is 19634 -- an itype. 19635 19636 procedure Build_NCT_Tables (Entity_Map : Elist_Id); 19637 pragma Inline (Build_NCT_Tables); 19638 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with the 19639 -- information supplied in entity map Entity_Map. The format of the 19640 -- entity map must be as follows: 19641 -- 19642 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN 19643 19644 function Copy_Any_Node_With_Replacement 19645 (N : Node_Or_Entity_Id) return Node_Or_Entity_Id; 19646 pragma Inline (Copy_Any_Node_With_Replacement); 19647 -- Replicate entity or node N by invoking one of the following routines: 19648 -- 19649 -- Copy_Node_With_Replacement 19650 -- Corresponding_Entity 19651 19652 function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id; 19653 -- Replicate the elements of entity list List 19654 19655 function Copy_Field_With_Replacement 19656 (Field : Union_Id; 19657 Old_Par : Node_Id := Empty; 19658 New_Par : Node_Id := Empty; 19659 Semantic : Boolean := False) return Union_Id; 19660 -- Replicate field Field by invoking one of the following routines: 19661 -- 19662 -- Copy_Elist_With_Replacement 19663 -- Copy_List_With_Replacement 19664 -- Copy_Node_With_Replacement 19665 -- Corresponding_Entity 19666 -- 19667 -- If the field is not an entity list, entity, itype, syntactic list, 19668 -- or node, then the field is returned unchanged. The routine always 19669 -- replicates entities, itypes, and valid syntactic fields. Old_Par is 19670 -- the expected parent of a syntactic field. New_Par is the new parent 19671 -- associated with a replicated syntactic field. Flag Semantic should 19672 -- be set when the input is a semantic field. 19673 19674 function Copy_List_With_Replacement (List : List_Id) return List_Id; 19675 -- Replicate the elements of syntactic list List 19676 19677 function Copy_Node_With_Replacement (N : Node_Id) return Node_Id; 19678 -- Replicate node N 19679 19680 function Corresponding_Entity (Id : Entity_Id) return Entity_Id; 19681 pragma Inline (Corresponding_Entity); 19682 -- Return the corresponding new entity of Id generated during Phase 1. 19683 -- If there is no such entity, return Id. 19684 19685 function In_Entity_Map 19686 (Id : Entity_Id; 19687 Entity_Map : Elist_Id) return Boolean; 19688 pragma Inline (In_Entity_Map); 19689 -- Determine whether entity Id is one of the old ids specified in entity 19690 -- map Entity_Map. The format of the entity map must be as follows: 19691 -- 19692 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN 19693 19694 procedure Update_CFS_Sloc (N : Node_Or_Entity_Id); 19695 pragma Inline (Update_CFS_Sloc); 19696 -- Update the Comes_From_Source and Sloc attributes of node or entity N 19697 19698 procedure Update_First_Real_Statement 19699 (Old_HSS : Node_Id; 19700 New_HSS : Node_Id); 19701 pragma Inline (Update_First_Real_Statement); 19702 -- Update semantic attribute First_Real_Statement of handled sequence of 19703 -- statements New_HSS based on handled sequence of statements Old_HSS. 19704 19705 procedure Update_Named_Associations 19706 (Old_Call : Node_Id; 19707 New_Call : Node_Id); 19708 pragma Inline (Update_Named_Associations); 19709 -- Update semantic chain First/Next_Named_Association of call New_call 19710 -- based on call Old_Call. 19711 19712 procedure Update_New_Entities (Entity_Map : Elist_Id); 19713 pragma Inline (Update_New_Entities); 19714 -- Update the semantic attributes of all new entities generated during 19715 -- Phase 1 that do not appear in entity map Entity_Map. The format of 19716 -- the entity map must be as follows: 19717 -- 19718 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN 19719 19720 procedure Update_Pending_Itypes 19721 (Old_Assoc : Node_Id; 19722 New_Assoc : Node_Id); 19723 pragma Inline (Update_Pending_Itypes); 19724 -- Update semantic attribute Associated_Node_For_Itype to refer to node 19725 -- New_Assoc for all itypes whose associated node is Old_Assoc. 19726 19727 procedure Update_Semantic_Fields (Id : Entity_Id); 19728 pragma Inline (Update_Semantic_Fields); 19729 -- Subsidiary to Update_New_Entities. Update semantic fields of entity 19730 -- or itype Id. 19731 19732 procedure Visit_Any_Node (N : Node_Or_Entity_Id); 19733 pragma Inline (Visit_Any_Node); 19734 -- Visit entity of node N by invoking one of the following routines: 19735 -- 19736 -- Visit_Entity 19737 -- Visit_Itype 19738 -- Visit_Node 19739 19740 procedure Visit_Elist (List : Elist_Id); 19741 -- Visit the elements of entity list List 19742 19743 procedure Visit_Entity (Id : Entity_Id); 19744 -- Visit entity Id. This action may create a new entity of Id and save 19745 -- it in table NCT_New_Entities. 19746 19747 procedure Visit_Field 19748 (Field : Union_Id; 19749 Par_Nod : Node_Id := Empty; 19750 Semantic : Boolean := False); 19751 -- Visit field Field by invoking one of the following routines: 19752 -- 19753 -- Visit_Elist 19754 -- Visit_Entity 19755 -- Visit_Itype 19756 -- Visit_List 19757 -- Visit_Node 19758 -- 19759 -- If the field is not an entity list, entity, itype, syntactic list, 19760 -- or node, then the field is not visited. The routine always visits 19761 -- valid syntactic fields. Par_Nod is the expected parent of the 19762 -- syntactic field. Flag Semantic should be set when the input is a 19763 -- semantic field. 19764 19765 procedure Visit_Itype (Itype : Entity_Id); 19766 -- Visit itype Itype. This action may create a new entity for Itype and 19767 -- save it in table NCT_New_Entities. In addition, the routine may map 19768 -- the associated node of Itype to the new itype in NCT_Pending_Itypes. 19769 19770 procedure Visit_List (List : List_Id); 19771 -- Visit the elements of syntactic list List 19772 19773 procedure Visit_Node (N : Node_Id); 19774 -- Visit node N 19775 19776 procedure Visit_Semantic_Fields (Id : Entity_Id); 19777 pragma Inline (Visit_Semantic_Fields); 19778 -- Subsidiary to Visit_Entity and Visit_Itype. Visit common semantic 19779 -- fields of entity or itype Id. 19780 19781 -------------------- 19782 -- Add_New_Entity -- 19783 -------------------- 19784 19785 procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id) is 19786 begin 19787 pragma Assert (Present (Old_Id)); 19788 pragma Assert (Present (New_Id)); 19789 pragma Assert (Nkind (Old_Id) in N_Entity); 19790 pragma Assert (Nkind (New_Id) in N_Entity); 19791 19792 NCT_Tables_In_Use := True; 19793 19794 -- Sanity check the NCT_New_Entities table. No previous mapping with 19795 -- key Old_Id should exist. 19796 19797 pragma Assert (No (NCT_New_Entities.Get (Old_Id))); 19798 19799 -- Establish the mapping 19800 19801 -- Old_Id -> New_Id 19802 19803 NCT_New_Entities.Set (Old_Id, New_Id); 19804 end Add_New_Entity; 19805 19806 ----------------------- 19807 -- Add_Pending_Itype -- 19808 ----------------------- 19809 19810 procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id) is 19811 Itypes : Elist_Id; 19812 19813 begin 19814 pragma Assert (Present (Assoc_Nod)); 19815 pragma Assert (Present (Itype)); 19816 pragma Assert (Nkind (Itype) in N_Entity); 19817 pragma Assert (Is_Itype (Itype)); 19818 19819 NCT_Tables_In_Use := True; 19820 19821 -- It is not possible to sanity check the NCT_Pendint_Itypes table 19822 -- directly because a single node may act as the associated node for 19823 -- multiple itypes. 19824 19825 Itypes := NCT_Pending_Itypes.Get (Assoc_Nod); 19826 19827 if No (Itypes) then 19828 Itypes := New_Elmt_List; 19829 NCT_Pending_Itypes.Set (Assoc_Nod, Itypes); 19830 end if; 19831 19832 -- Establish the mapping 19833 19834 -- Assoc_Nod -> (Itype, ...) 19835 19836 -- Avoid inserting the same itype multiple times. This involves a 19837 -- linear search, however the set of itypes with the same associated 19838 -- node is very small. 19839 19840 Append_Unique_Elmt (Itype, Itypes); 19841 end Add_Pending_Itype; 19842 19843 ---------------------- 19844 -- Build_NCT_Tables -- 19845 ---------------------- 19846 19847 procedure Build_NCT_Tables (Entity_Map : Elist_Id) is 19848 Elmt : Elmt_Id; 19849 Old_Id : Entity_Id; 19850 New_Id : Entity_Id; 19851 19852 begin 19853 -- Nothing to do when there is no entity map 19854 19855 if No (Entity_Map) then 19856 return; 19857 end if; 19858 19859 Elmt := First_Elmt (Entity_Map); 19860 while Present (Elmt) loop 19861 19862 -- Extract the (Old_Id, New_Id) pair from the entity map 19863 19864 Old_Id := Node (Elmt); 19865 Next_Elmt (Elmt); 19866 19867 New_Id := Node (Elmt); 19868 Next_Elmt (Elmt); 19869 19870 -- Establish the following mapping within table NCT_New_Entities 19871 19872 -- Old_Id -> New_Id 19873 19874 Add_New_Entity (Old_Id, New_Id); 19875 19876 -- Establish the following mapping within table NCT_Pending_Itypes 19877 -- when the new entity is an itype. 19878 19879 -- Assoc_Nod -> (New_Id, ...) 19880 19881 -- IMPORTANT: the associated node is that of the old itype because 19882 -- the node will be replicated in Phase 2. 19883 19884 if Is_Itype (Old_Id) then 19885 Add_Pending_Itype 19886 (Assoc_Nod => Associated_Node_For_Itype (Old_Id), 19887 Itype => New_Id); 19888 end if; 19889 end loop; 19890 end Build_NCT_Tables; 19891 19892 ------------------------------------ 19893 -- Copy_Any_Node_With_Replacement -- 19894 ------------------------------------ 19895 19896 function Copy_Any_Node_With_Replacement 19897 (N : Node_Or_Entity_Id) return Node_Or_Entity_Id 19898 is 19899 begin 19900 if Nkind (N) in N_Entity then 19901 return Corresponding_Entity (N); 19902 else 19903 return Copy_Node_With_Replacement (N); 19904 end if; 19905 end Copy_Any_Node_With_Replacement; 19906 19907 --------------------------------- 19908 -- Copy_Elist_With_Replacement -- 19909 --------------------------------- 19910 19911 function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id is 19912 Elmt : Elmt_Id; 19913 Result : Elist_Id; 19914 19915 begin 19916 -- Copy the contents of the old list. Note that the list itself may 19917 -- be empty, in which case the routine returns a new empty list. This 19918 -- avoids sharing lists between subtrees. The element of an entity 19919 -- list could be an entity or a node, hence the invocation of routine 19920 -- Copy_Any_Node_With_Replacement. 19921 19922 if Present (List) then 19923 Result := New_Elmt_List; 19924 19925 Elmt := First_Elmt (List); 19926 while Present (Elmt) loop 19927 Append_Elmt 19928 (Copy_Any_Node_With_Replacement (Node (Elmt)), Result); 19929 19930 Next_Elmt (Elmt); 19931 end loop; 19932 19933 -- Otherwise the list does not exist 19934 19935 else 19936 Result := No_Elist; 19937 end if; 19938 19939 return Result; 19940 end Copy_Elist_With_Replacement; 19941 19942 --------------------------------- 19943 -- Copy_Field_With_Replacement -- 19944 --------------------------------- 19945 19946 function Copy_Field_With_Replacement 19947 (Field : Union_Id; 19948 Old_Par : Node_Id := Empty; 19949 New_Par : Node_Id := Empty; 19950 Semantic : Boolean := False) return Union_Id 19951 is 19952 begin 19953 -- The field is empty 19954 19955 if Field = Union_Id (Empty) then 19956 return Field; 19957 19958 -- The field is an entity/itype/node 19959 19960 elsif Field in Node_Range then 19961 declare 19962 Old_N : constant Node_Id := Node_Id (Field); 19963 Syntactic : constant Boolean := Parent (Old_N) = Old_Par; 19964 19965 New_N : Node_Id; 19966 19967 begin 19968 -- The field is an entity/itype 19969 19970 if Nkind (Old_N) in N_Entity then 19971 19972 -- An entity/itype is always replicated 19973 19974 New_N := Corresponding_Entity (Old_N); 19975 19976 -- Update the parent pointer when the entity is a syntactic 19977 -- field. Note that itypes do not have parent pointers. 19978 19979 if Syntactic and then New_N /= Old_N then 19980 Set_Parent (New_N, New_Par); 19981 end if; 19982 19983 -- The field is a node 19984 19985 else 19986 -- A node is replicated when it is either a syntactic field 19987 -- or when the caller treats it as a semantic attribute. 19988 19989 if Syntactic or else Semantic then 19990 New_N := Copy_Node_With_Replacement (Old_N); 19991 19992 -- Update the parent pointer when the node is a syntactic 19993 -- field. 19994 19995 if Syntactic and then New_N /= Old_N then 19996 Set_Parent (New_N, New_Par); 19997 end if; 19998 19999 -- Otherwise the node is returned unchanged 20000 20001 else 20002 New_N := Old_N; 20003 end if; 20004 end if; 20005 20006 return Union_Id (New_N); 20007 end; 20008 20009 -- The field is an entity list 20010 20011 elsif Field in Elist_Range then 20012 return Union_Id (Copy_Elist_With_Replacement (Elist_Id (Field))); 20013 20014 -- The field is a syntactic list 20015 20016 elsif Field in List_Range then 20017 declare 20018 Old_List : constant List_Id := List_Id (Field); 20019 Syntactic : constant Boolean := Parent (Old_List) = Old_Par; 20020 20021 New_List : List_Id; 20022 20023 begin 20024 -- A list is replicated when it is either a syntactic field or 20025 -- when the caller treats it as a semantic attribute. 20026 20027 if Syntactic or else Semantic then 20028 New_List := Copy_List_With_Replacement (Old_List); 20029 20030 -- Update the parent pointer when the list is a syntactic 20031 -- field. 20032 20033 if Syntactic and then New_List /= Old_List then 20034 Set_Parent (New_List, New_Par); 20035 end if; 20036 20037 -- Otherwise the list is returned unchanged 20038 20039 else 20040 New_List := Old_List; 20041 end if; 20042 20043 return Union_Id (New_List); 20044 end; 20045 20046 -- Otherwise the field denotes an attribute that does not need to be 20047 -- replicated (Chars, literals, etc). 20048 20049 else 20050 return Field; 20051 end if; 20052 end Copy_Field_With_Replacement; 20053 20054 -------------------------------- 20055 -- Copy_List_With_Replacement -- 20056 -------------------------------- 20057 20058 function Copy_List_With_Replacement (List : List_Id) return List_Id is 20059 Elmt : Node_Id; 20060 Result : List_Id; 20061 20062 begin 20063 -- Copy the contents of the old list. Note that the list itself may 20064 -- be empty, in which case the routine returns a new empty list. This 20065 -- avoids sharing lists between subtrees. The element of a syntactic 20066 -- list is always a node, never an entity or itype, hence the call to 20067 -- routine Copy_Node_With_Replacement. 20068 20069 if Present (List) then 20070 Result := New_List; 20071 20072 Elmt := First (List); 20073 while Present (Elmt) loop 20074 Append (Copy_Node_With_Replacement (Elmt), Result); 20075 20076 Next (Elmt); 20077 end loop; 20078 20079 -- Otherwise the list does not exist 20080 20081 else 20082 Result := No_List; 20083 end if; 20084 20085 return Result; 20086 end Copy_List_With_Replacement; 20087 20088 -------------------------------- 20089 -- Copy_Node_With_Replacement -- 20090 -------------------------------- 20091 20092 function Copy_Node_With_Replacement (N : Node_Id) return Node_Id is 20093 Result : Node_Id; 20094 20095 begin 20096 -- Assume that the node must be returned unchanged 20097 20098 Result := N; 20099 20100 if N > Empty_Or_Error then 20101 pragma Assert (Nkind (N) not in N_Entity); 20102 20103 Result := New_Copy (N); 20104 20105 Set_Field1 (Result, 20106 Copy_Field_With_Replacement 20107 (Field => Field1 (Result), 20108 Old_Par => N, 20109 New_Par => Result)); 20110 20111 Set_Field2 (Result, 20112 Copy_Field_With_Replacement 20113 (Field => Field2 (Result), 20114 Old_Par => N, 20115 New_Par => Result)); 20116 20117 Set_Field3 (Result, 20118 Copy_Field_With_Replacement 20119 (Field => Field3 (Result), 20120 Old_Par => N, 20121 New_Par => Result)); 20122 20123 Set_Field4 (Result, 20124 Copy_Field_With_Replacement 20125 (Field => Field4 (Result), 20126 Old_Par => N, 20127 New_Par => Result)); 20128 20129 Set_Field5 (Result, 20130 Copy_Field_With_Replacement 20131 (Field => Field5 (Result), 20132 Old_Par => N, 20133 New_Par => Result)); 20134 20135 -- Update the Comes_From_Source and Sloc attributes of the node 20136 -- in case the caller has supplied new values. 20137 20138 Update_CFS_Sloc (Result); 20139 20140 -- Update the Associated_Node_For_Itype attribute of all itypes 20141 -- created during Phase 1 whose associated node is N. As a result 20142 -- the Associated_Node_For_Itype refers to the replicated node. 20143 -- No action needs to be taken when the Associated_Node_For_Itype 20144 -- refers to an entity because this was already handled during 20145 -- Phase 1, in Visit_Itype. 20146 20147 Update_Pending_Itypes 20148 (Old_Assoc => N, 20149 New_Assoc => Result); 20150 20151 -- Update the First/Next_Named_Association chain for a replicated 20152 -- call. 20153 20154 if Nkind_In (N, N_Entry_Call_Statement, 20155 N_Function_Call, 20156 N_Procedure_Call_Statement) 20157 then 20158 Update_Named_Associations 20159 (Old_Call => N, 20160 New_Call => Result); 20161 20162 -- Update the Renamed_Object attribute of a replicated object 20163 -- declaration. 20164 20165 elsif Nkind (N) = N_Object_Renaming_Declaration then 20166 Set_Renamed_Object (Defining_Entity (Result), Name (Result)); 20167 20168 -- Update the First_Real_Statement attribute of a replicated 20169 -- handled sequence of statements. 20170 20171 elsif Nkind (N) = N_Handled_Sequence_Of_Statements then 20172 Update_First_Real_Statement 20173 (Old_HSS => N, 20174 New_HSS => Result); 20175 end if; 20176 end if; 20177 20178 return Result; 20179 end Copy_Node_With_Replacement; 20180 20181 -------------------------- 20182 -- Corresponding_Entity -- 20183 -------------------------- 20184 20185 function Corresponding_Entity (Id : Entity_Id) return Entity_Id is 20186 New_Id : Entity_Id; 20187 Result : Entity_Id; 20188 20189 begin 20190 -- Assume that the entity must be returned unchanged 20191 20192 Result := Id; 20193 20194 if Id > Empty_Or_Error then 20195 pragma Assert (Nkind (Id) in N_Entity); 20196 20197 -- Determine whether the entity has a corresponding new entity 20198 -- generated during Phase 1 and if it does, use it. 20199 20200 if NCT_Tables_In_Use then 20201 New_Id := NCT_New_Entities.Get (Id); 20202 20203 if Present (New_Id) then 20204 Result := New_Id; 20205 end if; 20206 end if; 20207 end if; 20208 20209 return Result; 20210 end Corresponding_Entity; 20211 20212 ------------------- 20213 -- In_Entity_Map -- 20214 ------------------- 20215 20216 function In_Entity_Map 20217 (Id : Entity_Id; 20218 Entity_Map : Elist_Id) return Boolean 20219 is 20220 Elmt : Elmt_Id; 20221 Old_Id : Entity_Id; 20222 20223 begin 20224 -- The entity map contains pairs (Old_Id, New_Id). The advancement 20225 -- step always skips the New_Id portion of the pair. 20226 20227 if Present (Entity_Map) then 20228 Elmt := First_Elmt (Entity_Map); 20229 while Present (Elmt) loop 20230 Old_Id := Node (Elmt); 20231 20232 if Old_Id = Id then 20233 return True; 20234 end if; 20235 20236 Next_Elmt (Elmt); 20237 Next_Elmt (Elmt); 20238 end loop; 20239 end if; 20240 20241 return False; 20242 end In_Entity_Map; 20243 20244 --------------------- 20245 -- Update_CFS_Sloc -- 20246 --------------------- 20247 20248 procedure Update_CFS_Sloc (N : Node_Or_Entity_Id) is 20249 begin 20250 -- A new source location defaults the Comes_From_Source attribute 20251 20252 if New_Sloc /= No_Location then 20253 Set_Comes_From_Source (N, Default_Node.Comes_From_Source); 20254 Set_Sloc (N, New_Sloc); 20255 end if; 20256 end Update_CFS_Sloc; 20257 20258 --------------------------------- 20259 -- Update_First_Real_Statement -- 20260 --------------------------------- 20261 20262 procedure Update_First_Real_Statement 20263 (Old_HSS : Node_Id; 20264 New_HSS : Node_Id) 20265 is 20266 Old_First_Stmt : constant Node_Id := First_Real_Statement (Old_HSS); 20267 20268 New_Stmt : Node_Id; 20269 Old_Stmt : Node_Id; 20270 20271 begin 20272 -- Recreate the First_Real_Statement attribute of a handled sequence 20273 -- of statements by traversing the statement lists of both sequences 20274 -- in parallel. 20275 20276 if Present (Old_First_Stmt) then 20277 New_Stmt := First (Statements (New_HSS)); 20278 Old_Stmt := First (Statements (Old_HSS)); 20279 while Present (Old_Stmt) and then Old_Stmt /= Old_First_Stmt loop 20280 Next (New_Stmt); 20281 Next (Old_Stmt); 20282 end loop; 20283 20284 pragma Assert (Present (New_Stmt)); 20285 pragma Assert (Present (Old_Stmt)); 20286 20287 Set_First_Real_Statement (New_HSS, New_Stmt); 20288 end if; 20289 end Update_First_Real_Statement; 20290 20291 ------------------------------- 20292 -- Update_Named_Associations -- 20293 ------------------------------- 20294 20295 procedure Update_Named_Associations 20296 (Old_Call : Node_Id; 20297 New_Call : Node_Id) 20298 is 20299 New_Act : Node_Id; 20300 New_Next : Node_Id; 20301 Old_Act : Node_Id; 20302 Old_Next : Node_Id; 20303 20304 begin 20305 -- Recreate the First/Next_Named_Actual chain of a call by traversing 20306 -- the chains of both the old and new calls in parallel. 20307 20308 New_Act := First (Parameter_Associations (New_Call)); 20309 Old_Act := First (Parameter_Associations (Old_Call)); 20310 while Present (Old_Act) loop 20311 if Nkind (Old_Act) = N_Parameter_Association 20312 and then Present (Next_Named_Actual (Old_Act)) 20313 then 20314 if First_Named_Actual (Old_Call) = 20315 Explicit_Actual_Parameter (Old_Act) 20316 then 20317 Set_First_Named_Actual (New_Call, 20318 Explicit_Actual_Parameter (New_Act)); 20319 end if; 20320 20321 -- Scan the actual parameter list to find the next suitable 20322 -- named actual. Note that the list may be out of order. 20323 20324 New_Next := First (Parameter_Associations (New_Call)); 20325 Old_Next := First (Parameter_Associations (Old_Call)); 20326 while Nkind (Old_Next) /= N_Parameter_Association 20327 or else Explicit_Actual_Parameter (Old_Next) /= 20328 Next_Named_Actual (Old_Act) 20329 loop 20330 Next (New_Next); 20331 Next (Old_Next); 20332 end loop; 20333 20334 Set_Next_Named_Actual (New_Act, 20335 Explicit_Actual_Parameter (New_Next)); 20336 end if; 20337 20338 Next (New_Act); 20339 Next (Old_Act); 20340 end loop; 20341 end Update_Named_Associations; 20342 20343 ------------------------- 20344 -- Update_New_Entities -- 20345 ------------------------- 20346 20347 procedure Update_New_Entities (Entity_Map : Elist_Id) is 20348 New_Id : Entity_Id := Empty; 20349 Old_Id : Entity_Id := Empty; 20350 20351 begin 20352 if NCT_Tables_In_Use then 20353 NCT_New_Entities.Get_First (Old_Id, New_Id); 20354 20355 -- Update the semantic fields of all new entities created during 20356 -- Phase 1 which were not supplied via an entity map. 20357 -- ??? Is there a better way of distinguishing those? 20358 20359 while Present (Old_Id) and then Present (New_Id) loop 20360 if not (Present (Entity_Map) 20361 and then In_Entity_Map (Old_Id, Entity_Map)) 20362 then 20363 Update_Semantic_Fields (New_Id); 20364 end if; 20365 20366 NCT_New_Entities.Get_Next (Old_Id, New_Id); 20367 end loop; 20368 end if; 20369 end Update_New_Entities; 20370 20371 --------------------------- 20372 -- Update_Pending_Itypes -- 20373 --------------------------- 20374 20375 procedure Update_Pending_Itypes 20376 (Old_Assoc : Node_Id; 20377 New_Assoc : Node_Id) 20378 is 20379 Item : Elmt_Id; 20380 Itypes : Elist_Id; 20381 20382 begin 20383 if NCT_Tables_In_Use then 20384 Itypes := NCT_Pending_Itypes.Get (Old_Assoc); 20385 20386 -- Update the Associated_Node_For_Itype attribute for all itypes 20387 -- which originally refer to Old_Assoc to designate New_Assoc. 20388 20389 if Present (Itypes) then 20390 Item := First_Elmt (Itypes); 20391 while Present (Item) loop 20392 Set_Associated_Node_For_Itype (Node (Item), New_Assoc); 20393 20394 Next_Elmt (Item); 20395 end loop; 20396 end if; 20397 end if; 20398 end Update_Pending_Itypes; 20399 20400 ---------------------------- 20401 -- Update_Semantic_Fields -- 20402 ---------------------------- 20403 20404 procedure Update_Semantic_Fields (Id : Entity_Id) is 20405 begin 20406 -- Discriminant_Constraint 20407 20408 if Is_Type (Id) and then Has_Discriminants (Base_Type (Id)) then 20409 Set_Discriminant_Constraint (Id, Elist_Id ( 20410 Copy_Field_With_Replacement 20411 (Field => Union_Id (Discriminant_Constraint (Id)), 20412 Semantic => True))); 20413 end if; 20414 20415 -- Etype 20416 20417 Set_Etype (Id, Node_Id ( 20418 Copy_Field_With_Replacement 20419 (Field => Union_Id (Etype (Id)), 20420 Semantic => True))); 20421 20422 -- First_Index 20423 -- Packed_Array_Impl_Type 20424 20425 if Is_Array_Type (Id) then 20426 if Present (First_Index (Id)) then 20427 Set_First_Index (Id, First (List_Id ( 20428 Copy_Field_With_Replacement 20429 (Field => Union_Id (List_Containing (First_Index (Id))), 20430 Semantic => True)))); 20431 end if; 20432 20433 if Is_Packed (Id) then 20434 Set_Packed_Array_Impl_Type (Id, Node_Id ( 20435 Copy_Field_With_Replacement 20436 (Field => Union_Id (Packed_Array_Impl_Type (Id)), 20437 Semantic => True))); 20438 end if; 20439 end if; 20440 20441 -- Prev_Entity 20442 20443 Set_Prev_Entity (Id, Node_Id ( 20444 Copy_Field_With_Replacement 20445 (Field => Union_Id (Prev_Entity (Id)), 20446 Semantic => True))); 20447 20448 -- Next_Entity 20449 20450 Set_Next_Entity (Id, Node_Id ( 20451 Copy_Field_With_Replacement 20452 (Field => Union_Id (Next_Entity (Id)), 20453 Semantic => True))); 20454 20455 -- Scalar_Range 20456 20457 if Is_Discrete_Type (Id) then 20458 Set_Scalar_Range (Id, Node_Id ( 20459 Copy_Field_With_Replacement 20460 (Field => Union_Id (Scalar_Range (Id)), 20461 Semantic => True))); 20462 end if; 20463 20464 -- Scope 20465 20466 -- Update the scope when the caller specified an explicit one 20467 20468 if Present (New_Scope) then 20469 Set_Scope (Id, New_Scope); 20470 else 20471 Set_Scope (Id, Node_Id ( 20472 Copy_Field_With_Replacement 20473 (Field => Union_Id (Scope (Id)), 20474 Semantic => True))); 20475 end if; 20476 end Update_Semantic_Fields; 20477 20478 -------------------- 20479 -- Visit_Any_Node -- 20480 -------------------- 20481 20482 procedure Visit_Any_Node (N : Node_Or_Entity_Id) is 20483 begin 20484 if Nkind (N) in N_Entity then 20485 if Is_Itype (N) then 20486 Visit_Itype (N); 20487 else 20488 Visit_Entity (N); 20489 end if; 20490 else 20491 Visit_Node (N); 20492 end if; 20493 end Visit_Any_Node; 20494 20495 ----------------- 20496 -- Visit_Elist -- 20497 ----------------- 20498 20499 procedure Visit_Elist (List : Elist_Id) is 20500 Elmt : Elmt_Id; 20501 20502 begin 20503 -- The element of an entity list could be an entity, itype, or a 20504 -- node, hence the call to Visit_Any_Node. 20505 20506 if Present (List) then 20507 Elmt := First_Elmt (List); 20508 while Present (Elmt) loop 20509 Visit_Any_Node (Node (Elmt)); 20510 20511 Next_Elmt (Elmt); 20512 end loop; 20513 end if; 20514 end Visit_Elist; 20515 20516 ------------------ 20517 -- Visit_Entity -- 20518 ------------------ 20519 20520 procedure Visit_Entity (Id : Entity_Id) is 20521 New_Id : Entity_Id; 20522 20523 begin 20524 pragma Assert (Nkind (Id) in N_Entity); 20525 pragma Assert (not Is_Itype (Id)); 20526 20527 -- Nothing to do when the entity is not defined in the Actions list 20528 -- of an N_Expression_With_Actions node. 20529 20530 if EWA_Level = 0 then 20531 return; 20532 20533 -- Nothing to do when the entity is defined in a scoping construct 20534 -- within an N_Expression_With_Actions node, unless the caller has 20535 -- requested their replication. 20536 20537 -- ??? should this restriction be eliminated? 20538 20539 elsif EWA_Inner_Scope_Level > 0 and then not Scopes_In_EWA_OK then 20540 return; 20541 20542 -- Nothing to do when the entity does not denote a construct that 20543 -- may appear within an N_Expression_With_Actions node. Relaxing 20544 -- this restriction leads to a performance penalty. 20545 20546 -- ??? this list is flaky, and may hide dormant bugs 20547 20548 elsif not Ekind_In (Id, E_Block, 20549 E_Constant, 20550 E_Label, 20551 E_Procedure, 20552 E_Variable) 20553 and then not Is_Type (Id) 20554 then 20555 return; 20556 20557 -- Nothing to do when the entity was already visited 20558 20559 elsif NCT_Tables_In_Use 20560 and then Present (NCT_New_Entities.Get (Id)) 20561 then 20562 return; 20563 20564 -- Nothing to do when the declaration node of the entity is not in 20565 -- the subtree being replicated. 20566 20567 elsif not In_Subtree 20568 (N => Declaration_Node (Id), 20569 Root => Source) 20570 then 20571 return; 20572 end if; 20573 20574 -- Create a new entity by directly copying the old entity. This 20575 -- action causes all attributes of the old entity to be inherited. 20576 20577 New_Id := New_Copy (Id); 20578 20579 -- Create a new name for the new entity because the back end needs 20580 -- distinct names for debugging purposes. 20581 20582 Set_Chars (New_Id, New_Internal_Name ('T')); 20583 20584 -- Update the Comes_From_Source and Sloc attributes of the entity in 20585 -- case the caller has supplied new values. 20586 20587 Update_CFS_Sloc (New_Id); 20588 20589 -- Establish the following mapping within table NCT_New_Entities: 20590 20591 -- Id -> New_Id 20592 20593 Add_New_Entity (Id, New_Id); 20594 20595 -- Deal with the semantic fields of entities. The fields are visited 20596 -- because they may mention entities which reside within the subtree 20597 -- being copied. 20598 20599 Visit_Semantic_Fields (Id); 20600 end Visit_Entity; 20601 20602 ----------------- 20603 -- Visit_Field -- 20604 ----------------- 20605 20606 procedure Visit_Field 20607 (Field : Union_Id; 20608 Par_Nod : Node_Id := Empty; 20609 Semantic : Boolean := False) 20610 is 20611 begin 20612 -- The field is empty 20613 20614 if Field = Union_Id (Empty) then 20615 return; 20616 20617 -- The field is an entity/itype/node 20618 20619 elsif Field in Node_Range then 20620 declare 20621 N : constant Node_Id := Node_Id (Field); 20622 20623 begin 20624 -- The field is an entity/itype 20625 20626 if Nkind (N) in N_Entity then 20627 20628 -- Itypes are always visited 20629 20630 if Is_Itype (N) then 20631 Visit_Itype (N); 20632 20633 -- An entity is visited when it is either a syntactic field 20634 -- or when the caller treats it as a semantic attribute. 20635 20636 elsif Parent (N) = Par_Nod or else Semantic then 20637 Visit_Entity (N); 20638 end if; 20639 20640 -- The field is a node 20641 20642 else 20643 -- A node is visited when it is either a syntactic field or 20644 -- when the caller treats it as a semantic attribute. 20645 20646 if Parent (N) = Par_Nod or else Semantic then 20647 Visit_Node (N); 20648 end if; 20649 end if; 20650 end; 20651 20652 -- The field is an entity list 20653 20654 elsif Field in Elist_Range then 20655 Visit_Elist (Elist_Id (Field)); 20656 20657 -- The field is a syntax list 20658 20659 elsif Field in List_Range then 20660 declare 20661 List : constant List_Id := List_Id (Field); 20662 20663 begin 20664 -- A syntax list is visited when it is either a syntactic field 20665 -- or when the caller treats it as a semantic attribute. 20666 20667 if Parent (List) = Par_Nod or else Semantic then 20668 Visit_List (List); 20669 end if; 20670 end; 20671 20672 -- Otherwise the field denotes information which does not need to be 20673 -- visited (chars, literals, etc.). 20674 20675 else 20676 null; 20677 end if; 20678 end Visit_Field; 20679 20680 ----------------- 20681 -- Visit_Itype -- 20682 ----------------- 20683 20684 procedure Visit_Itype (Itype : Entity_Id) is 20685 New_Assoc : Node_Id; 20686 New_Itype : Entity_Id; 20687 Old_Assoc : Node_Id; 20688 20689 begin 20690 pragma Assert (Nkind (Itype) in N_Entity); 20691 pragma Assert (Is_Itype (Itype)); 20692 20693 -- Itypes that describe the designated type of access to subprograms 20694 -- have the structure of subprogram declarations, with signatures, 20695 -- etc. Either we duplicate the signatures completely, or choose to 20696 -- share such itypes, which is fine because their elaboration will 20697 -- have no side effects. 20698 20699 if Ekind (Itype) = E_Subprogram_Type then 20700 return; 20701 20702 -- Nothing to do if the itype was already visited 20703 20704 elsif NCT_Tables_In_Use 20705 and then Present (NCT_New_Entities.Get (Itype)) 20706 then 20707 return; 20708 20709 -- Nothing to do if the associated node of the itype is not within 20710 -- the subtree being replicated. 20711 20712 elsif not In_Subtree 20713 (N => Associated_Node_For_Itype (Itype), 20714 Root => Source) 20715 then 20716 return; 20717 end if; 20718 20719 -- Create a new itype by directly copying the old itype. This action 20720 -- causes all attributes of the old itype to be inherited. 20721 20722 New_Itype := New_Copy (Itype); 20723 20724 -- Create a new name for the new itype because the back end requires 20725 -- distinct names for debugging purposes. 20726 20727 Set_Chars (New_Itype, New_Internal_Name ('T')); 20728 20729 -- Update the Comes_From_Source and Sloc attributes of the itype in 20730 -- case the caller has supplied new values. 20731 20732 Update_CFS_Sloc (New_Itype); 20733 20734 -- Establish the following mapping within table NCT_New_Entities: 20735 20736 -- Itype -> New_Itype 20737 20738 Add_New_Entity (Itype, New_Itype); 20739 20740 -- The new itype must be unfrozen because the resulting subtree may 20741 -- be inserted anywhere and cause an earlier or later freezing. 20742 20743 if Present (Freeze_Node (New_Itype)) then 20744 Set_Freeze_Node (New_Itype, Empty); 20745 Set_Is_Frozen (New_Itype, False); 20746 end if; 20747 20748 -- If a record subtype is simply copied, the entity list will be 20749 -- shared. Thus cloned_Subtype must be set to indicate the sharing. 20750 -- ??? What does this do? 20751 20752 if Ekind_In (Itype, E_Class_Wide_Subtype, E_Record_Subtype) then 20753 Set_Cloned_Subtype (New_Itype, Itype); 20754 end if; 20755 20756 -- The associated node may denote an entity, in which case it may 20757 -- already have a new corresponding entity created during a prior 20758 -- call to Visit_Entity or Visit_Itype for the same subtree. 20759 20760 -- Given 20761 -- Old_Assoc ---------> New_Assoc 20762 20763 -- Created by Visit_Itype 20764 -- Itype -------------> New_Itype 20765 -- ANFI = Old_Assoc ANFI = Old_Assoc < must be updated 20766 20767 -- In the example above, Old_Assoc is an arbitrary entity that was 20768 -- already visited for the same subtree and has a corresponding new 20769 -- entity New_Assoc. Old_Assoc was inherited by New_Itype by virtue 20770 -- of copying entities, however it must be updated to New_Assoc. 20771 20772 Old_Assoc := Associated_Node_For_Itype (Itype); 20773 20774 if Nkind (Old_Assoc) in N_Entity then 20775 if NCT_Tables_In_Use then 20776 New_Assoc := NCT_New_Entities.Get (Old_Assoc); 20777 20778 if Present (New_Assoc) then 20779 Set_Associated_Node_For_Itype (New_Itype, New_Assoc); 20780 end if; 20781 end if; 20782 20783 -- Otherwise the associated node denotes a node. Postpone the update 20784 -- until Phase 2 when the node is replicated. Establish the following 20785 -- mapping within table NCT_Pending_Itypes: 20786 20787 -- Old_Assoc -> (New_Type, ...) 20788 20789 else 20790 Add_Pending_Itype (Old_Assoc, New_Itype); 20791 end if; 20792 20793 -- Deal with the semantic fields of itypes. The fields are visited 20794 -- because they may mention entities that reside within the subtree 20795 -- being copied. 20796 20797 Visit_Semantic_Fields (Itype); 20798 end Visit_Itype; 20799 20800 ---------------- 20801 -- Visit_List -- 20802 ---------------- 20803 20804 procedure Visit_List (List : List_Id) is 20805 Elmt : Node_Id; 20806 20807 begin 20808 -- Note that the element of a syntactic list is always a node, never 20809 -- an entity or itype, hence the call to Visit_Node. 20810 20811 if Present (List) then 20812 Elmt := First (List); 20813 while Present (Elmt) loop 20814 Visit_Node (Elmt); 20815 20816 Next (Elmt); 20817 end loop; 20818 end if; 20819 end Visit_List; 20820 20821 ---------------- 20822 -- Visit_Node -- 20823 ---------------- 20824 20825 procedure Visit_Node (N : Node_Or_Entity_Id) is 20826 begin 20827 pragma Assert (Nkind (N) not in N_Entity); 20828 20829 if Nkind (N) = N_Expression_With_Actions then 20830 EWA_Level := EWA_Level + 1; 20831 20832 elsif EWA_Level > 0 20833 and then Nkind_In (N, N_Block_Statement, 20834 N_Subprogram_Body, 20835 N_Subprogram_Declaration) 20836 then 20837 EWA_Inner_Scope_Level := EWA_Inner_Scope_Level + 1; 20838 end if; 20839 20840 Visit_Field 20841 (Field => Field1 (N), 20842 Par_Nod => N); 20843 20844 Visit_Field 20845 (Field => Field2 (N), 20846 Par_Nod => N); 20847 20848 Visit_Field 20849 (Field => Field3 (N), 20850 Par_Nod => N); 20851 20852 Visit_Field 20853 (Field => Field4 (N), 20854 Par_Nod => N); 20855 20856 Visit_Field 20857 (Field => Field5 (N), 20858 Par_Nod => N); 20859 20860 if EWA_Level > 0 20861 and then Nkind_In (N, N_Block_Statement, 20862 N_Subprogram_Body, 20863 N_Subprogram_Declaration) 20864 then 20865 EWA_Inner_Scope_Level := EWA_Inner_Scope_Level - 1; 20866 20867 elsif Nkind (N) = N_Expression_With_Actions then 20868 EWA_Level := EWA_Level - 1; 20869 end if; 20870 end Visit_Node; 20871 20872 --------------------------- 20873 -- Visit_Semantic_Fields -- 20874 --------------------------- 20875 20876 procedure Visit_Semantic_Fields (Id : Entity_Id) is 20877 begin 20878 pragma Assert (Nkind (Id) in N_Entity); 20879 20880 -- Discriminant_Constraint 20881 20882 if Is_Type (Id) and then Has_Discriminants (Base_Type (Id)) then 20883 Visit_Field 20884 (Field => Union_Id (Discriminant_Constraint (Id)), 20885 Semantic => True); 20886 end if; 20887 20888 -- Etype 20889 20890 Visit_Field 20891 (Field => Union_Id (Etype (Id)), 20892 Semantic => True); 20893 20894 -- First_Index 20895 -- Packed_Array_Impl_Type 20896 20897 if Is_Array_Type (Id) then 20898 if Present (First_Index (Id)) then 20899 Visit_Field 20900 (Field => Union_Id (List_Containing (First_Index (Id))), 20901 Semantic => True); 20902 end if; 20903 20904 if Is_Packed (Id) then 20905 Visit_Field 20906 (Field => Union_Id (Packed_Array_Impl_Type (Id)), 20907 Semantic => True); 20908 end if; 20909 end if; 20910 20911 -- Scalar_Range 20912 20913 if Is_Discrete_Type (Id) then 20914 Visit_Field 20915 (Field => Union_Id (Scalar_Range (Id)), 20916 Semantic => True); 20917 end if; 20918 end Visit_Semantic_Fields; 20919 20920 -- Start of processing for New_Copy_Tree 20921 20922 begin 20923 -- Routine New_Copy_Tree performs a deep copy of a subtree by creating 20924 -- shallow copies for each node within, and then updating the child and 20925 -- parent pointers accordingly. This process is straightforward, however 20926 -- the routine must deal with the following complications: 20927 20928 -- * Entities defined within N_Expression_With_Actions nodes must be 20929 -- replicated rather than shared to avoid introducing two identical 20930 -- symbols within the same scope. Note that no other expression can 20931 -- currently define entities. 20932 20933 -- do 20934 -- Source_Low : ...; 20935 -- Source_High : ...; 20936 20937 -- <reference to Source_Low> 20938 -- <reference to Source_High> 20939 -- in ... end; 20940 20941 -- New_Copy_Tree handles this case by first creating new entities 20942 -- and then updating all existing references to point to these new 20943 -- entities. 20944 20945 -- do 20946 -- New_Low : ...; 20947 -- New_High : ...; 20948 20949 -- <reference to New_Low> 20950 -- <reference to New_High> 20951 -- in ... end; 20952 20953 -- * Itypes defined within the subtree must be replicated to avoid any 20954 -- dependencies on invalid or inaccessible data. 20955 20956 -- subtype Source_Itype is ... range Source_Low .. Source_High; 20957 20958 -- New_Copy_Tree handles this case by first creating a new itype in 20959 -- the same fashion as entities, and then updating various relevant 20960 -- constraints. 20961 20962 -- subtype New_Itype is ... range New_Low .. New_High; 20963 20964 -- * The Associated_Node_For_Itype field of itypes must be updated to 20965 -- reference the proper replicated entity or node. 20966 20967 -- * Semantic fields of entities such as Etype and Scope must be 20968 -- updated to reference the proper replicated entities. 20969 20970 -- * Semantic fields of nodes such as First_Real_Statement must be 20971 -- updated to reference the proper replicated nodes. 20972 20973 -- To meet all these demands, routine New_Copy_Tree is split into two 20974 -- phases. 20975 20976 -- Phase 1 traverses the tree in order to locate entities and itypes 20977 -- defined within the subtree. New entities are generated and saved in 20978 -- table NCT_New_Entities. The semantic fields of all new entities and 20979 -- itypes are then updated accordingly. 20980 20981 -- Phase 2 traverses the tree in order to replicate each node. Various 20982 -- semantic fields of nodes and entities are updated accordingly. 20983 20984 -- Preparatory phase. Clear the contents of tables NCT_New_Entities and 20985 -- NCT_Pending_Itypes in case a previous call to New_Copy_Tree left some 20986 -- data inside. 20987 20988 if NCT_Tables_In_Use then 20989 NCT_Tables_In_Use := False; 20990 20991 NCT_New_Entities.Reset; 20992 NCT_Pending_Itypes.Reset; 20993 end if; 20994 20995 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with data 20996 -- supplied by a linear entity map. The tables offer faster access to 20997 -- the same data. 20998 20999 Build_NCT_Tables (Map); 21000 21001 -- Execute Phase 1. Traverse the subtree and generate new entities for 21002 -- the following cases: 21003 21004 -- * An entity defined within an N_Expression_With_Actions node 21005 21006 -- * An itype referenced within the subtree where the associated node 21007 -- is also in the subtree. 21008 21009 -- All new entities are accessible via table NCT_New_Entities, which 21010 -- contains mappings of the form: 21011 21012 -- Old_Entity -> New_Entity 21013 -- Old_Itype -> New_Itype 21014 21015 -- In addition, the associated nodes of all new itypes are mapped in 21016 -- table NCT_Pending_Itypes: 21017 21018 -- Assoc_Nod -> (New_Itype1, New_Itype2, .., New_ItypeN) 21019 21020 Visit_Any_Node (Source); 21021 21022 -- Update the semantic attributes of all new entities generated during 21023 -- Phase 1 before starting Phase 2. The updates could be performed in 21024 -- routine Corresponding_Entity, however this may cause the same entity 21025 -- to be updated multiple times, effectively generating useless nodes. 21026 -- Keeping the updates separates from Phase 2 ensures that only one set 21027 -- of attributes is generated for an entity at any one time. 21028 21029 Update_New_Entities (Map); 21030 21031 -- Execute Phase 2. Replicate the source subtree one node at a time. 21032 -- The following transformations take place: 21033 21034 -- * References to entities and itypes are updated to refer to the 21035 -- new entities and itypes generated during Phase 1. 21036 21037 -- * All Associated_Node_For_Itype attributes of itypes are updated 21038 -- to refer to the new replicated Associated_Node_For_Itype. 21039 21040 return Copy_Node_With_Replacement (Source); 21041 end New_Copy_Tree; 21042 21043 ------------------------- 21044 -- New_External_Entity -- 21045 ------------------------- 21046 21047 function New_External_Entity 21048 (Kind : Entity_Kind; 21049 Scope_Id : Entity_Id; 21050 Sloc_Value : Source_Ptr; 21051 Related_Id : Entity_Id; 21052 Suffix : Character; 21053 Suffix_Index : Int := 0; 21054 Prefix : Character := ' ') return Entity_Id 21055 is 21056 N : constant Entity_Id := 21057 Make_Defining_Identifier (Sloc_Value, 21058 New_External_Name 21059 (Chars (Related_Id), Suffix, Suffix_Index, Prefix)); 21060 21061 begin 21062 Set_Ekind (N, Kind); 21063 Set_Is_Internal (N, True); 21064 Append_Entity (N, Scope_Id); 21065 Set_Public_Status (N); 21066 21067 if Kind in Type_Kind then 21068 Init_Size_Align (N); 21069 end if; 21070 21071 return N; 21072 end New_External_Entity; 21073 21074 ------------------------- 21075 -- New_Internal_Entity -- 21076 ------------------------- 21077 21078 function New_Internal_Entity 21079 (Kind : Entity_Kind; 21080 Scope_Id : Entity_Id; 21081 Sloc_Value : Source_Ptr; 21082 Id_Char : Character) return Entity_Id 21083 is 21084 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); 21085 21086 begin 21087 Set_Ekind (N, Kind); 21088 Set_Is_Internal (N, True); 21089 Append_Entity (N, Scope_Id); 21090 21091 if Kind in Type_Kind then 21092 Init_Size_Align (N); 21093 end if; 21094 21095 return N; 21096 end New_Internal_Entity; 21097 21098 ----------------- 21099 -- Next_Actual -- 21100 ----------------- 21101 21102 function Next_Actual (Actual_Id : Node_Id) return Node_Id is 21103 Par : constant Node_Id := Parent (Actual_Id); 21104 N : Node_Id; 21105 21106 begin 21107 -- If we are pointing at a positional parameter, it is a member of a 21108 -- node list (the list of parameters), and the next parameter is the 21109 -- next node on the list, unless we hit a parameter association, then 21110 -- we shift to using the chain whose head is the First_Named_Actual in 21111 -- the parent, and then is threaded using the Next_Named_Actual of the 21112 -- Parameter_Association. All this fiddling is because the original node 21113 -- list is in the textual call order, and what we need is the 21114 -- declaration order. 21115 21116 if Is_List_Member (Actual_Id) then 21117 N := Next (Actual_Id); 21118 21119 if Nkind (N) = N_Parameter_Association then 21120 21121 -- In case of a build-in-place call, the call will no longer be a 21122 -- call; it will have been rewritten. 21123 21124 if Nkind_In (Par, N_Entry_Call_Statement, 21125 N_Function_Call, 21126 N_Procedure_Call_Statement) 21127 then 21128 return First_Named_Actual (Par); 21129 21130 -- In case of a call rewritten in GNATprove mode while "inlining 21131 -- for proof" go to the original call. 21132 21133 elsif Nkind (Par) = N_Null_Statement then 21134 pragma Assert 21135 (GNATprove_Mode 21136 and then 21137 Nkind (Original_Node (Par)) in N_Subprogram_Call); 21138 21139 return First_Named_Actual (Original_Node (Par)); 21140 else 21141 return Empty; 21142 end if; 21143 else 21144 return N; 21145 end if; 21146 21147 else 21148 return Next_Named_Actual (Parent (Actual_Id)); 21149 end if; 21150 end Next_Actual; 21151 21152 procedure Next_Actual (Actual_Id : in out Node_Id) is 21153 begin 21154 Actual_Id := Next_Actual (Actual_Id); 21155 end Next_Actual; 21156 21157 ----------------- 21158 -- Next_Global -- 21159 ----------------- 21160 21161 function Next_Global (Node : Node_Id) return Node_Id is 21162 begin 21163 -- The global item may either be in a list, or by itself, in which case 21164 -- there is no next global item with the same mode. 21165 21166 if Is_List_Member (Node) then 21167 return Next (Node); 21168 else 21169 return Empty; 21170 end if; 21171 end Next_Global; 21172 21173 procedure Next_Global (Node : in out Node_Id) is 21174 begin 21175 Node := Next_Global (Node); 21176 end Next_Global; 21177 21178 ---------------------------------- 21179 -- New_Requires_Transient_Scope -- 21180 ---------------------------------- 21181 21182 function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean is 21183 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean; 21184 -- This is called for untagged records and protected types, with 21185 -- nondefaulted discriminants. Returns True if the size of function 21186 -- results is known at the call site, False otherwise. Returns False 21187 -- if there is a variant part that depends on the discriminants of 21188 -- this type, or if there is an array constrained by the discriminants 21189 -- of this type. ???Currently, this is overly conservative (the array 21190 -- could be nested inside some other record that is constrained by 21191 -- nondiscriminants). That is, the recursive calls are too conservative. 21192 21193 function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean; 21194 -- Returns True if Typ is a nonlimited record with defaulted 21195 -- discriminants whose max size makes it unsuitable for allocating on 21196 -- the primary stack. 21197 21198 ------------------------------ 21199 -- Caller_Known_Size_Record -- 21200 ------------------------------ 21201 21202 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is 21203 pragma Assert (Typ = Underlying_Type (Typ)); 21204 21205 begin 21206 if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then 21207 return False; 21208 end if; 21209 21210 declare 21211 Comp : Entity_Id; 21212 21213 begin 21214 Comp := First_Entity (Typ); 21215 while Present (Comp) loop 21216 21217 -- Only look at E_Component entities. No need to look at 21218 -- E_Discriminant entities, and we must ignore internal 21219 -- subtypes generated for constrained components. 21220 21221 if Ekind (Comp) = E_Component then 21222 declare 21223 Comp_Type : constant Entity_Id := 21224 Underlying_Type (Etype (Comp)); 21225 21226 begin 21227 if Is_Record_Type (Comp_Type) 21228 or else 21229 Is_Protected_Type (Comp_Type) 21230 then 21231 if not Caller_Known_Size_Record (Comp_Type) then 21232 return False; 21233 end if; 21234 21235 elsif Is_Array_Type (Comp_Type) then 21236 if Size_Depends_On_Discriminant (Comp_Type) then 21237 return False; 21238 end if; 21239 end if; 21240 end; 21241 end if; 21242 21243 Next_Entity (Comp); 21244 end loop; 21245 end; 21246 21247 return True; 21248 end Caller_Known_Size_Record; 21249 21250 ------------------------------ 21251 -- Large_Max_Size_Mutable -- 21252 ------------------------------ 21253 21254 function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is 21255 pragma Assert (Typ = Underlying_Type (Typ)); 21256 21257 function Is_Large_Discrete_Type (T : Entity_Id) return Boolean; 21258 -- Returns true if the discrete type T has a large range 21259 21260 ---------------------------- 21261 -- Is_Large_Discrete_Type -- 21262 ---------------------------- 21263 21264 function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is 21265 Threshold : constant Int := 16; 21266 -- Arbitrary threshold above which we consider it "large". We want 21267 -- a fairly large threshold, because these large types really 21268 -- shouldn't have default discriminants in the first place, in 21269 -- most cases. 21270 21271 begin 21272 return UI_To_Int (RM_Size (T)) > Threshold; 21273 end Is_Large_Discrete_Type; 21274 21275 -- Start of processing for Large_Max_Size_Mutable 21276 21277 begin 21278 if Is_Record_Type (Typ) 21279 and then not Is_Limited_View (Typ) 21280 and then Has_Defaulted_Discriminants (Typ) 21281 then 21282 -- Loop through the components, looking for an array whose upper 21283 -- bound(s) depends on discriminants, where both the subtype of 21284 -- the discriminant and the index subtype are too large. 21285 21286 declare 21287 Comp : Entity_Id; 21288 21289 begin 21290 Comp := First_Entity (Typ); 21291 while Present (Comp) loop 21292 if Ekind (Comp) = E_Component then 21293 declare 21294 Comp_Type : constant Entity_Id := 21295 Underlying_Type (Etype (Comp)); 21296 21297 Hi : Node_Id; 21298 Indx : Node_Id; 21299 Ityp : Entity_Id; 21300 21301 begin 21302 if Is_Array_Type (Comp_Type) then 21303 Indx := First_Index (Comp_Type); 21304 21305 while Present (Indx) loop 21306 Ityp := Etype (Indx); 21307 Hi := Type_High_Bound (Ityp); 21308 21309 if Nkind (Hi) = N_Identifier 21310 and then Ekind (Entity (Hi)) = E_Discriminant 21311 and then Is_Large_Discrete_Type (Ityp) 21312 and then Is_Large_Discrete_Type 21313 (Etype (Entity (Hi))) 21314 then 21315 return True; 21316 end if; 21317 21318 Next_Index (Indx); 21319 end loop; 21320 end if; 21321 end; 21322 end if; 21323 21324 Next_Entity (Comp); 21325 end loop; 21326 end; 21327 end if; 21328 21329 return False; 21330 end Large_Max_Size_Mutable; 21331 21332 -- Local declarations 21333 21334 Typ : constant Entity_Id := Underlying_Type (Id); 21335 21336 -- Start of processing for New_Requires_Transient_Scope 21337 21338 begin 21339 -- This is a private type which is not completed yet. This can only 21340 -- happen in a default expression (of a formal parameter or of a 21341 -- record component). Do not expand transient scope in this case. 21342 21343 if No (Typ) then 21344 return False; 21345 21346 -- Do not expand transient scope for non-existent procedure return or 21347 -- string literal types. 21348 21349 elsif Typ = Standard_Void_Type 21350 or else Ekind (Typ) = E_String_Literal_Subtype 21351 then 21352 return False; 21353 21354 -- If Typ is a generic formal incomplete type, then we want to look at 21355 -- the actual type. 21356 21357 elsif Ekind (Typ) = E_Record_Subtype 21358 and then Present (Cloned_Subtype (Typ)) 21359 then 21360 return New_Requires_Transient_Scope (Cloned_Subtype (Typ)); 21361 21362 -- Functions returning specific tagged types may dispatch on result, so 21363 -- their returned value is allocated on the secondary stack, even in the 21364 -- definite case. We must treat nondispatching functions the same way, 21365 -- because access-to-function types can point at both, so the calling 21366 -- conventions must be compatible. Is_Tagged_Type includes controlled 21367 -- types and class-wide types. Controlled type temporaries need 21368 -- finalization. 21369 21370 -- ???It's not clear why we need to return noncontrolled types with 21371 -- controlled components on the secondary stack. 21372 21373 elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then 21374 return True; 21375 21376 -- Untagged definite subtypes are known size. This includes all 21377 -- elementary [sub]types. Tasks are known size even if they have 21378 -- discriminants. So we return False here, with one exception: 21379 -- For a type like: 21380 -- type T (Last : Natural := 0) is 21381 -- X : String (1 .. Last); 21382 -- end record; 21383 -- we return True. That's because for "P(F(...));", where F returns T, 21384 -- we don't know the size of the result at the call site, so if we 21385 -- allocated it on the primary stack, we would have to allocate the 21386 -- maximum size, which is way too big. 21387 21388 elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then 21389 return Large_Max_Size_Mutable (Typ); 21390 21391 -- Indefinite (discriminated) untagged record or protected type 21392 21393 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then 21394 return not Caller_Known_Size_Record (Typ); 21395 21396 -- Unconstrained array 21397 21398 else 21399 pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ)); 21400 return True; 21401 end if; 21402 end New_Requires_Transient_Scope; 21403 21404 -------------------------- 21405 -- No_Heap_Finalization -- 21406 -------------------------- 21407 21408 function No_Heap_Finalization (Typ : Entity_Id) return Boolean is 21409 begin 21410 if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) 21411 and then Is_Library_Level_Entity (Typ) 21412 then 21413 -- A global No_Heap_Finalization pragma applies to all library-level 21414 -- named access-to-object types. 21415 21416 if Present (No_Heap_Finalization_Pragma) then 21417 return True; 21418 21419 -- The library-level named access-to-object type itself is subject to 21420 -- pragma No_Heap_Finalization. 21421 21422 elsif Present (Get_Pragma (Typ, Pragma_No_Heap_Finalization)) then 21423 return True; 21424 end if; 21425 end if; 21426 21427 return False; 21428 end No_Heap_Finalization; 21429 21430 ----------------------- 21431 -- Normalize_Actuals -- 21432 ----------------------- 21433 21434 -- Chain actuals according to formals of subprogram. If there are no named 21435 -- associations, the chain is simply the list of Parameter Associations, 21436 -- since the order is the same as the declaration order. If there are named 21437 -- associations, then the First_Named_Actual field in the N_Function_Call 21438 -- or N_Procedure_Call_Statement node points to the Parameter_Association 21439 -- node for the parameter that comes first in declaration order. The 21440 -- remaining named parameters are then chained in declaration order using 21441 -- Next_Named_Actual. 21442 21443 -- This routine also verifies that the number of actuals is compatible with 21444 -- the number and default values of formals, but performs no type checking 21445 -- (type checking is done by the caller). 21446 21447 -- If the matching succeeds, Success is set to True and the caller proceeds 21448 -- with type-checking. If the match is unsuccessful, then Success is set to 21449 -- False, and the caller attempts a different interpretation, if there is 21450 -- one. 21451 21452 -- If the flag Report is on, the call is not overloaded, and a failure to 21453 -- match can be reported here, rather than in the caller. 21454 21455 procedure Normalize_Actuals 21456 (N : Node_Id; 21457 S : Entity_Id; 21458 Report : Boolean; 21459 Success : out Boolean) 21460 is 21461 Actuals : constant List_Id := Parameter_Associations (N); 21462 Actual : Node_Id := Empty; 21463 Formal : Entity_Id; 21464 Last : Node_Id := Empty; 21465 First_Named : Node_Id := Empty; 21466 Found : Boolean; 21467 21468 Formals_To_Match : Integer := 0; 21469 Actuals_To_Match : Integer := 0; 21470 21471 procedure Chain (A : Node_Id); 21472 -- Add named actual at the proper place in the list, using the 21473 -- Next_Named_Actual link. 21474 21475 function Reporting return Boolean; 21476 -- Determines if an error is to be reported. To report an error, we 21477 -- need Report to be True, and also we do not report errors caused 21478 -- by calls to init procs that occur within other init procs. Such 21479 -- errors must always be cascaded errors, since if all the types are 21480 -- declared correctly, the compiler will certainly build decent calls. 21481 21482 ----------- 21483 -- Chain -- 21484 ----------- 21485 21486 procedure Chain (A : Node_Id) is 21487 begin 21488 if No (Last) then 21489 21490 -- Call node points to first actual in list 21491 21492 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A)); 21493 21494 else 21495 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A)); 21496 end if; 21497 21498 Last := A; 21499 Set_Next_Named_Actual (Last, Empty); 21500 end Chain; 21501 21502 --------------- 21503 -- Reporting -- 21504 --------------- 21505 21506 function Reporting return Boolean is 21507 begin 21508 if not Report then 21509 return False; 21510 21511 elsif not Within_Init_Proc then 21512 return True; 21513 21514 elsif Is_Init_Proc (Entity (Name (N))) then 21515 return False; 21516 21517 else 21518 return True; 21519 end if; 21520 end Reporting; 21521 21522 -- Start of processing for Normalize_Actuals 21523 21524 begin 21525 if Is_Access_Type (S) then 21526 21527 -- The name in the call is a function call that returns an access 21528 -- to subprogram. The designated type has the list of formals. 21529 21530 Formal := First_Formal (Designated_Type (S)); 21531 else 21532 Formal := First_Formal (S); 21533 end if; 21534 21535 while Present (Formal) loop 21536 Formals_To_Match := Formals_To_Match + 1; 21537 Next_Formal (Formal); 21538 end loop; 21539 21540 -- Find if there is a named association, and verify that no positional 21541 -- associations appear after named ones. 21542 21543 if Present (Actuals) then 21544 Actual := First (Actuals); 21545 end if; 21546 21547 while Present (Actual) 21548 and then Nkind (Actual) /= N_Parameter_Association 21549 loop 21550 Actuals_To_Match := Actuals_To_Match + 1; 21551 Next (Actual); 21552 end loop; 21553 21554 if No (Actual) and Actuals_To_Match = Formals_To_Match then 21555 21556 -- Most common case: positional notation, no defaults 21557 21558 Success := True; 21559 return; 21560 21561 elsif Actuals_To_Match > Formals_To_Match then 21562 21563 -- Too many actuals: will not work 21564 21565 if Reporting then 21566 if Is_Entity_Name (Name (N)) then 21567 Error_Msg_N ("too many arguments in call to&", Name (N)); 21568 else 21569 Error_Msg_N ("too many arguments in call", N); 21570 end if; 21571 end if; 21572 21573 Success := False; 21574 return; 21575 end if; 21576 21577 First_Named := Actual; 21578 21579 while Present (Actual) loop 21580 if Nkind (Actual) /= N_Parameter_Association then 21581 Error_Msg_N 21582 ("positional parameters not allowed after named ones", Actual); 21583 Success := False; 21584 return; 21585 21586 else 21587 Actuals_To_Match := Actuals_To_Match + 1; 21588 end if; 21589 21590 Next (Actual); 21591 end loop; 21592 21593 if Present (Actuals) then 21594 Actual := First (Actuals); 21595 end if; 21596 21597 Formal := First_Formal (S); 21598 while Present (Formal) loop 21599 21600 -- Match the formals in order. If the corresponding actual is 21601 -- positional, nothing to do. Else scan the list of named actuals 21602 -- to find the one with the right name. 21603 21604 if Present (Actual) 21605 and then Nkind (Actual) /= N_Parameter_Association 21606 then 21607 Next (Actual); 21608 Actuals_To_Match := Actuals_To_Match - 1; 21609 Formals_To_Match := Formals_To_Match - 1; 21610 21611 else 21612 -- For named parameters, search the list of actuals to find 21613 -- one that matches the next formal name. 21614 21615 Actual := First_Named; 21616 Found := False; 21617 while Present (Actual) loop 21618 if Chars (Selector_Name (Actual)) = Chars (Formal) then 21619 Found := True; 21620 Chain (Actual); 21621 Actuals_To_Match := Actuals_To_Match - 1; 21622 Formals_To_Match := Formals_To_Match - 1; 21623 exit; 21624 end if; 21625 21626 Next (Actual); 21627 end loop; 21628 21629 if not Found then 21630 if Ekind (Formal) /= E_In_Parameter 21631 or else No (Default_Value (Formal)) 21632 then 21633 if Reporting then 21634 if (Comes_From_Source (S) 21635 or else Sloc (S) = Standard_Location) 21636 and then Is_Overloadable (S) 21637 then 21638 if No (Actuals) 21639 and then 21640 Nkind_In (Parent (N), N_Procedure_Call_Statement, 21641 N_Function_Call, 21642 N_Parameter_Association) 21643 and then Ekind (S) /= E_Function 21644 then 21645 Set_Etype (N, Etype (S)); 21646 21647 else 21648 Error_Msg_Name_1 := Chars (S); 21649 Error_Msg_Sloc := Sloc (S); 21650 Error_Msg_NE 21651 ("missing argument for parameter & " 21652 & "in call to % declared #", N, Formal); 21653 end if; 21654 21655 elsif Is_Overloadable (S) then 21656 Error_Msg_Name_1 := Chars (S); 21657 21658 -- Point to type derivation that generated the 21659 -- operation. 21660 21661 Error_Msg_Sloc := Sloc (Parent (S)); 21662 21663 Error_Msg_NE 21664 ("missing argument for parameter & " 21665 & "in call to % (inherited) #", N, Formal); 21666 21667 else 21668 Error_Msg_NE 21669 ("missing argument for parameter &", N, Formal); 21670 end if; 21671 end if; 21672 21673 Success := False; 21674 return; 21675 21676 else 21677 Formals_To_Match := Formals_To_Match - 1; 21678 end if; 21679 end if; 21680 end if; 21681 21682 Next_Formal (Formal); 21683 end loop; 21684 21685 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then 21686 Success := True; 21687 return; 21688 21689 else 21690 if Reporting then 21691 21692 -- Find some superfluous named actual that did not get 21693 -- attached to the list of associations. 21694 21695 Actual := First (Actuals); 21696 while Present (Actual) loop 21697 if Nkind (Actual) = N_Parameter_Association 21698 and then Actual /= Last 21699 and then No (Next_Named_Actual (Actual)) 21700 then 21701 -- A validity check may introduce a copy of a call that 21702 -- includes an extra actual (for example for an unrelated 21703 -- accessibility check). Check that the extra actual matches 21704 -- some extra formal, which must exist already because 21705 -- subprogram must be frozen at this point. 21706 21707 if Present (Extra_Formals (S)) 21708 and then not Comes_From_Source (Actual) 21709 and then Nkind (Actual) = N_Parameter_Association 21710 and then Chars (Extra_Formals (S)) = 21711 Chars (Selector_Name (Actual)) 21712 then 21713 null; 21714 else 21715 Error_Msg_N 21716 ("unmatched actual & in call", Selector_Name (Actual)); 21717 exit; 21718 end if; 21719 end if; 21720 21721 Next (Actual); 21722 end loop; 21723 end if; 21724 21725 Success := False; 21726 return; 21727 end if; 21728 end Normalize_Actuals; 21729 21730 -------------------------------- 21731 -- Note_Possible_Modification -- 21732 -------------------------------- 21733 21734 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is 21735 Modification_Comes_From_Source : constant Boolean := 21736 Comes_From_Source (Parent (N)); 21737 21738 Ent : Entity_Id; 21739 Exp : Node_Id; 21740 21741 begin 21742 -- Loop to find referenced entity, if there is one 21743 21744 Exp := N; 21745 loop 21746 Ent := Empty; 21747 21748 if Is_Entity_Name (Exp) then 21749 Ent := Entity (Exp); 21750 21751 -- If the entity is missing, it is an undeclared identifier, 21752 -- and there is nothing to annotate. 21753 21754 if No (Ent) then 21755 return; 21756 end if; 21757 21758 elsif Nkind (Exp) = N_Explicit_Dereference then 21759 declare 21760 P : constant Node_Id := Prefix (Exp); 21761 21762 begin 21763 -- In formal verification mode, keep track of all reads and 21764 -- writes through explicit dereferences. 21765 21766 if GNATprove_Mode then 21767 SPARK_Specific.Generate_Dereference (N, 'm'); 21768 end if; 21769 21770 if Nkind (P) = N_Selected_Component 21771 and then Present (Entry_Formal (Entity (Selector_Name (P)))) 21772 then 21773 -- Case of a reference to an entry formal 21774 21775 Ent := Entry_Formal (Entity (Selector_Name (P))); 21776 21777 elsif Nkind (P) = N_Identifier 21778 and then Nkind (Parent (Entity (P))) = N_Object_Declaration 21779 and then Present (Expression (Parent (Entity (P)))) 21780 and then Nkind (Expression (Parent (Entity (P)))) = 21781 N_Reference 21782 then 21783 -- Case of a reference to a value on which side effects have 21784 -- been removed. 21785 21786 Exp := Prefix (Expression (Parent (Entity (P)))); 21787 goto Continue; 21788 21789 else 21790 return; 21791 end if; 21792 end; 21793 21794 elsif Nkind_In (Exp, N_Type_Conversion, 21795 N_Unchecked_Type_Conversion) 21796 then 21797 Exp := Expression (Exp); 21798 goto Continue; 21799 21800 elsif Nkind_In (Exp, N_Slice, 21801 N_Indexed_Component, 21802 N_Selected_Component) 21803 then 21804 -- Special check, if the prefix is an access type, then return 21805 -- since we are modifying the thing pointed to, not the prefix. 21806 -- When we are expanding, most usually the prefix is replaced 21807 -- by an explicit dereference, and this test is not needed, but 21808 -- in some cases (notably -gnatc mode and generics) when we do 21809 -- not do full expansion, we need this special test. 21810 21811 if Is_Access_Type (Etype (Prefix (Exp))) then 21812 return; 21813 21814 -- Otherwise go to prefix and keep going 21815 21816 else 21817 Exp := Prefix (Exp); 21818 goto Continue; 21819 end if; 21820 21821 -- All other cases, not a modification 21822 21823 else 21824 return; 21825 end if; 21826 21827 -- Now look for entity being referenced 21828 21829 if Present (Ent) then 21830 if Is_Object (Ent) then 21831 if Comes_From_Source (Exp) 21832 or else Modification_Comes_From_Source 21833 then 21834 -- Give warning if pragma unmodified is given and we are 21835 -- sure this is a modification. 21836 21837 if Has_Pragma_Unmodified (Ent) and then Sure then 21838 21839 -- Note that the entity may be present only as a result 21840 -- of pragma Unused. 21841 21842 if Has_Pragma_Unused (Ent) then 21843 Error_Msg_NE ("??pragma Unused given for &!", N, Ent); 21844 else 21845 Error_Msg_NE 21846 ("??pragma Unmodified given for &!", N, Ent); 21847 end if; 21848 end if; 21849 21850 Set_Never_Set_In_Source (Ent, False); 21851 end if; 21852 21853 Set_Is_True_Constant (Ent, False); 21854 Set_Current_Value (Ent, Empty); 21855 Set_Is_Known_Null (Ent, False); 21856 21857 if not Can_Never_Be_Null (Ent) then 21858 Set_Is_Known_Non_Null (Ent, False); 21859 end if; 21860 21861 -- Follow renaming chain 21862 21863 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant) 21864 and then Present (Renamed_Object (Ent)) 21865 then 21866 Exp := Renamed_Object (Ent); 21867 21868 -- If the entity is the loop variable in an iteration over 21869 -- a container, retrieve container expression to indicate 21870 -- possible modification. 21871 21872 if Present (Related_Expression (Ent)) 21873 and then Nkind (Parent (Related_Expression (Ent))) = 21874 N_Iterator_Specification 21875 then 21876 Exp := Original_Node (Related_Expression (Ent)); 21877 end if; 21878 21879 goto Continue; 21880 21881 -- The expression may be the renaming of a subcomponent of an 21882 -- array or container. The assignment to the subcomponent is 21883 -- a modification of the container. 21884 21885 elsif Comes_From_Source (Original_Node (Exp)) 21886 and then Nkind_In (Original_Node (Exp), N_Selected_Component, 21887 N_Indexed_Component) 21888 then 21889 Exp := Prefix (Original_Node (Exp)); 21890 goto Continue; 21891 end if; 21892 21893 -- Generate a reference only if the assignment comes from 21894 -- source. This excludes, for example, calls to a dispatching 21895 -- assignment operation when the left-hand side is tagged. In 21896 -- GNATprove mode, we need those references also on generated 21897 -- code, as these are used to compute the local effects of 21898 -- subprograms. 21899 21900 if Modification_Comes_From_Source or GNATprove_Mode then 21901 Generate_Reference (Ent, Exp, 'm'); 21902 21903 -- If the target of the assignment is the bound variable 21904 -- in an iterator, indicate that the corresponding array 21905 -- or container is also modified. 21906 21907 if Ada_Version >= Ada_2012 21908 and then Nkind (Parent (Ent)) = N_Iterator_Specification 21909 then 21910 declare 21911 Domain : constant Node_Id := Name (Parent (Ent)); 21912 21913 begin 21914 -- TBD : in the full version of the construct, the 21915 -- domain of iteration can be given by an expression. 21916 21917 if Is_Entity_Name (Domain) then 21918 Generate_Reference (Entity (Domain), Exp, 'm'); 21919 Set_Is_True_Constant (Entity (Domain), False); 21920 Set_Never_Set_In_Source (Entity (Domain), False); 21921 end if; 21922 end; 21923 end if; 21924 end if; 21925 end if; 21926 21927 Kill_Checks (Ent); 21928 21929 -- If we are sure this is a modification from source, and we know 21930 -- this modifies a constant, then give an appropriate warning. 21931 21932 if Sure 21933 and then Modification_Comes_From_Source 21934 and then Overlays_Constant (Ent) 21935 and then Address_Clause_Overlay_Warnings 21936 then 21937 declare 21938 Addr : constant Node_Id := Address_Clause (Ent); 21939 O_Ent : Entity_Id; 21940 Off : Boolean; 21941 21942 begin 21943 Find_Overlaid_Entity (Addr, O_Ent, Off); 21944 21945 Error_Msg_Sloc := Sloc (Addr); 21946 Error_Msg_NE 21947 ("??constant& may be modified via address clause#", 21948 N, O_Ent); 21949 end; 21950 end if; 21951 21952 return; 21953 end if; 21954 21955 <<Continue>> 21956 null; 21957 end loop; 21958 end Note_Possible_Modification; 21959 21960 ----------------- 21961 -- Null_Status -- 21962 ----------------- 21963 21964 function Null_Status (N : Node_Id) return Null_Status_Kind is 21965 function Is_Null_Excluding_Def (Def : Node_Id) return Boolean; 21966 -- Determine whether definition Def carries a null exclusion 21967 21968 function Null_Status_Of_Entity (Id : Entity_Id) return Null_Status_Kind; 21969 -- Determine the null status of arbitrary entity Id 21970 21971 function Null_Status_Of_Type (Typ : Entity_Id) return Null_Status_Kind; 21972 -- Determine the null status of type Typ 21973 21974 --------------------------- 21975 -- Is_Null_Excluding_Def -- 21976 --------------------------- 21977 21978 function Is_Null_Excluding_Def (Def : Node_Id) return Boolean is 21979 begin 21980 return 21981 Nkind_In (Def, N_Access_Definition, 21982 N_Access_Function_Definition, 21983 N_Access_Procedure_Definition, 21984 N_Access_To_Object_Definition, 21985 N_Component_Definition, 21986 N_Derived_Type_Definition) 21987 and then Null_Exclusion_Present (Def); 21988 end Is_Null_Excluding_Def; 21989 21990 --------------------------- 21991 -- Null_Status_Of_Entity -- 21992 --------------------------- 21993 21994 function Null_Status_Of_Entity 21995 (Id : Entity_Id) return Null_Status_Kind 21996 is 21997 Decl : constant Node_Id := Declaration_Node (Id); 21998 Def : Node_Id; 21999 22000 begin 22001 -- The value of an imported or exported entity may be set externally 22002 -- regardless of a null exclusion. As a result, the value cannot be 22003 -- determined statically. 22004 22005 if Is_Imported (Id) or else Is_Exported (Id) then 22006 return Unknown; 22007 22008 elsif Nkind_In (Decl, N_Component_Declaration, 22009 N_Discriminant_Specification, 22010 N_Formal_Object_Declaration, 22011 N_Object_Declaration, 22012 N_Object_Renaming_Declaration, 22013 N_Parameter_Specification) 22014 then 22015 -- A component declaration yields a non-null value when either 22016 -- its component definition or access definition carries a null 22017 -- exclusion. 22018 22019 if Nkind (Decl) = N_Component_Declaration then 22020 Def := Component_Definition (Decl); 22021 22022 if Is_Null_Excluding_Def (Def) then 22023 return Is_Non_Null; 22024 end if; 22025 22026 Def := Access_Definition (Def); 22027 22028 if Present (Def) and then Is_Null_Excluding_Def (Def) then 22029 return Is_Non_Null; 22030 end if; 22031 22032 -- A formal object declaration yields a non-null value if its 22033 -- access definition carries a null exclusion. If the object is 22034 -- default initialized, then the value depends on the expression. 22035 22036 elsif Nkind (Decl) = N_Formal_Object_Declaration then 22037 Def := Access_Definition (Decl); 22038 22039 if Present (Def) and then Is_Null_Excluding_Def (Def) then 22040 return Is_Non_Null; 22041 end if; 22042 22043 -- A constant may yield a null or non-null value depending on its 22044 -- initialization expression. 22045 22046 elsif Ekind (Id) = E_Constant then 22047 return Null_Status (Constant_Value (Id)); 22048 22049 -- The construct yields a non-null value when it has a null 22050 -- exclusion. 22051 22052 elsif Null_Exclusion_Present (Decl) then 22053 return Is_Non_Null; 22054 22055 -- An object renaming declaration yields a non-null value if its 22056 -- access definition carries a null exclusion. Otherwise the value 22057 -- depends on the renamed name. 22058 22059 elsif Nkind (Decl) = N_Object_Renaming_Declaration then 22060 Def := Access_Definition (Decl); 22061 22062 if Present (Def) and then Is_Null_Excluding_Def (Def) then 22063 return Is_Non_Null; 22064 22065 else 22066 return Null_Status (Name (Decl)); 22067 end if; 22068 end if; 22069 end if; 22070 22071 -- At this point the declaration of the entity does not carry a null 22072 -- exclusion and lacks an initialization expression. Check the status 22073 -- of its type. 22074 22075 return Null_Status_Of_Type (Etype (Id)); 22076 end Null_Status_Of_Entity; 22077 22078 ------------------------- 22079 -- Null_Status_Of_Type -- 22080 ------------------------- 22081 22082 function Null_Status_Of_Type (Typ : Entity_Id) return Null_Status_Kind is 22083 Curr : Entity_Id; 22084 Decl : Node_Id; 22085 22086 begin 22087 -- Traverse the type chain looking for types with null exclusion 22088 22089 Curr := Typ; 22090 while Present (Curr) and then Etype (Curr) /= Curr loop 22091 Decl := Parent (Curr); 22092 22093 -- Guard against itypes which do not always have declarations. A 22094 -- type yields a non-null value if it carries a null exclusion. 22095 22096 if Present (Decl) then 22097 if Nkind (Decl) = N_Full_Type_Declaration 22098 and then Is_Null_Excluding_Def (Type_Definition (Decl)) 22099 then 22100 return Is_Non_Null; 22101 22102 elsif Nkind (Decl) = N_Subtype_Declaration 22103 and then Null_Exclusion_Present (Decl) 22104 then 22105 return Is_Non_Null; 22106 end if; 22107 end if; 22108 22109 Curr := Etype (Curr); 22110 end loop; 22111 22112 -- The type chain does not contain any null excluding types 22113 22114 return Unknown; 22115 end Null_Status_Of_Type; 22116 22117 -- Start of processing for Null_Status 22118 22119 begin 22120 -- An allocator always creates a non-null value 22121 22122 if Nkind (N) = N_Allocator then 22123 return Is_Non_Null; 22124 22125 -- Taking the 'Access of something yields a non-null value 22126 22127 elsif Nkind (N) = N_Attribute_Reference 22128 and then Nam_In (Attribute_Name (N), Name_Access, 22129 Name_Unchecked_Access, 22130 Name_Unrestricted_Access) 22131 then 22132 return Is_Non_Null; 22133 22134 -- "null" yields null 22135 22136 elsif Nkind (N) = N_Null then 22137 return Is_Null; 22138 22139 -- Check the status of the operand of a type conversion 22140 22141 elsif Nkind (N) = N_Type_Conversion then 22142 return Null_Status (Expression (N)); 22143 22144 -- The input denotes a reference to an entity. Determine whether the 22145 -- entity or its type yields a null or non-null value. 22146 22147 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 22148 return Null_Status_Of_Entity (Entity (N)); 22149 end if; 22150 22151 -- Otherwise it is not possible to determine the null status of the 22152 -- subexpression at compile time without resorting to simple flow 22153 -- analysis. 22154 22155 return Unknown; 22156 end Null_Status; 22157 22158 -------------------------------------- 22159 -- Null_To_Null_Address_Convert_OK -- 22160 -------------------------------------- 22161 22162 function Null_To_Null_Address_Convert_OK 22163 (N : Node_Id; 22164 Typ : Entity_Id := Empty) return Boolean 22165 is 22166 begin 22167 if not Relaxed_RM_Semantics then 22168 return False; 22169 end if; 22170 22171 if Nkind (N) = N_Null then 22172 return Present (Typ) and then Is_Descendant_Of_Address (Typ); 22173 22174 elsif Nkind_In (N, N_Op_Eq, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt, N_Op_Ne) 22175 then 22176 declare 22177 L : constant Node_Id := Left_Opnd (N); 22178 R : constant Node_Id := Right_Opnd (N); 22179 22180 begin 22181 -- We check the Etype of the complementary operand since the 22182 -- N_Null node is not decorated at this stage. 22183 22184 return 22185 ((Nkind (L) = N_Null 22186 and then Is_Descendant_Of_Address (Etype (R))) 22187 or else 22188 (Nkind (R) = N_Null 22189 and then Is_Descendant_Of_Address (Etype (L)))); 22190 end; 22191 end if; 22192 22193 return False; 22194 end Null_To_Null_Address_Convert_OK; 22195 22196 --------------------------------- 22197 -- Number_Of_Elements_In_Array -- 22198 --------------------------------- 22199 22200 function Number_Of_Elements_In_Array (T : Entity_Id) return Int is 22201 Indx : Node_Id; 22202 Typ : Entity_Id; 22203 Low : Node_Id; 22204 High : Node_Id; 22205 Num : Int := 1; 22206 22207 begin 22208 pragma Assert (Is_Array_Type (T)); 22209 22210 Indx := First_Index (T); 22211 while Present (Indx) loop 22212 Typ := Underlying_Type (Etype (Indx)); 22213 22214 -- Never look at junk bounds of a generic type 22215 22216 if Is_Generic_Type (Typ) then 22217 return 0; 22218 end if; 22219 22220 -- Check the array bounds are known at compile time and return zero 22221 -- if they are not. 22222 22223 Low := Type_Low_Bound (Typ); 22224 High := Type_High_Bound (Typ); 22225 22226 if not Compile_Time_Known_Value (Low) then 22227 return 0; 22228 elsif not Compile_Time_Known_Value (High) then 22229 return 0; 22230 else 22231 Num := 22232 Num * UI_To_Int ((Expr_Value (High) - Expr_Value (Low) + 1)); 22233 end if; 22234 22235 Next_Index (Indx); 22236 end loop; 22237 22238 return Num; 22239 end Number_Of_Elements_In_Array; 22240 22241 ------------------------- 22242 -- Object_Access_Level -- 22243 ------------------------- 22244 22245 -- Returns the static accessibility level of the view denoted by Obj. Note 22246 -- that the value returned is the result of a call to Scope_Depth. Only 22247 -- scope depths associated with dynamic scopes can actually be returned. 22248 -- Since only relative levels matter for accessibility checking, the fact 22249 -- that the distance between successive levels of accessibility is not 22250 -- always one is immaterial (invariant: if level(E2) is deeper than 22251 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)). 22252 22253 function Object_Access_Level (Obj : Node_Id) return Uint is 22254 function Is_Interface_Conversion (N : Node_Id) return Boolean; 22255 -- Determine whether N is a construct of the form 22256 -- Some_Type (Operand._tag'Address) 22257 -- This construct appears in the context of dispatching calls. 22258 22259 function Reference_To (Obj : Node_Id) return Node_Id; 22260 -- An explicit dereference is created when removing side effects from 22261 -- expressions for constraint checking purposes. In this case a local 22262 -- access type is created for it. The correct access level is that of 22263 -- the original source node. We detect this case by noting that the 22264 -- prefix of the dereference is created by an object declaration whose 22265 -- initial expression is a reference. 22266 22267 ----------------------------- 22268 -- Is_Interface_Conversion -- 22269 ----------------------------- 22270 22271 function Is_Interface_Conversion (N : Node_Id) return Boolean is 22272 begin 22273 return Nkind (N) = N_Unchecked_Type_Conversion 22274 and then Nkind (Expression (N)) = N_Attribute_Reference 22275 and then Attribute_Name (Expression (N)) = Name_Address; 22276 end Is_Interface_Conversion; 22277 22278 ------------------ 22279 -- Reference_To -- 22280 ------------------ 22281 22282 function Reference_To (Obj : Node_Id) return Node_Id is 22283 Pref : constant Node_Id := Prefix (Obj); 22284 begin 22285 if Is_Entity_Name (Pref) 22286 and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration 22287 and then Present (Expression (Parent (Entity (Pref)))) 22288 and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference 22289 then 22290 return (Prefix (Expression (Parent (Entity (Pref))))); 22291 else 22292 return Empty; 22293 end if; 22294 end Reference_To; 22295 22296 -- Local variables 22297 22298 E : Entity_Id; 22299 22300 -- Start of processing for Object_Access_Level 22301 22302 begin 22303 if Nkind (Obj) = N_Defining_Identifier 22304 or else Is_Entity_Name (Obj) 22305 then 22306 if Nkind (Obj) = N_Defining_Identifier then 22307 E := Obj; 22308 else 22309 E := Entity (Obj); 22310 end if; 22311 22312 if Is_Prival (E) then 22313 E := Prival_Link (E); 22314 end if; 22315 22316 -- If E is a type then it denotes a current instance. For this case 22317 -- we add one to the normal accessibility level of the type to ensure 22318 -- that current instances are treated as always being deeper than 22319 -- than the level of any visible named access type (see 3.10.2(21)). 22320 22321 if Is_Type (E) then 22322 return Type_Access_Level (E) + 1; 22323 22324 elsif Present (Renamed_Object (E)) then 22325 return Object_Access_Level (Renamed_Object (E)); 22326 22327 -- Similarly, if E is a component of the current instance of a 22328 -- protected type, any instance of it is assumed to be at a deeper 22329 -- level than the type. For a protected object (whose type is an 22330 -- anonymous protected type) its components are at the same level 22331 -- as the type itself. 22332 22333 elsif not Is_Overloadable (E) 22334 and then Ekind (Scope (E)) = E_Protected_Type 22335 and then Comes_From_Source (Scope (E)) 22336 then 22337 return Type_Access_Level (Scope (E)) + 1; 22338 22339 else 22340 -- Aliased formals of functions take their access level from the 22341 -- point of call, i.e. require a dynamic check. For static check 22342 -- purposes, this is smaller than the level of the subprogram 22343 -- itself. For procedures the aliased makes no difference. 22344 22345 if Is_Formal (E) 22346 and then Is_Aliased (E) 22347 and then Ekind (Scope (E)) = E_Function 22348 then 22349 return Type_Access_Level (Etype (E)); 22350 22351 else 22352 return Scope_Depth (Enclosing_Dynamic_Scope (E)); 22353 end if; 22354 end if; 22355 22356 elsif Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then 22357 if Is_Access_Type (Etype (Prefix (Obj))) then 22358 return Type_Access_Level (Etype (Prefix (Obj))); 22359 else 22360 return Object_Access_Level (Prefix (Obj)); 22361 end if; 22362 22363 elsif Nkind (Obj) = N_Explicit_Dereference then 22364 22365 -- If the prefix is a selected access discriminant then we make a 22366 -- recursive call on the prefix, which will in turn check the level 22367 -- of the prefix object of the selected discriminant. 22368 22369 -- In Ada 2012, if the discriminant has implicit dereference and 22370 -- the context is a selected component, treat this as an object of 22371 -- unknown scope (see below). This is necessary in compile-only mode; 22372 -- otherwise expansion will already have transformed the prefix into 22373 -- a temporary. 22374 22375 if Nkind (Prefix (Obj)) = N_Selected_Component 22376 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type 22377 and then 22378 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant 22379 and then 22380 (not Has_Implicit_Dereference 22381 (Entity (Selector_Name (Prefix (Obj)))) 22382 or else Nkind (Parent (Obj)) /= N_Selected_Component) 22383 then 22384 return Object_Access_Level (Prefix (Obj)); 22385 22386 -- Detect an interface conversion in the context of a dispatching 22387 -- call. Use the original form of the conversion to find the access 22388 -- level of the operand. 22389 22390 elsif Is_Interface (Etype (Obj)) 22391 and then Is_Interface_Conversion (Prefix (Obj)) 22392 and then Nkind (Original_Node (Obj)) = N_Type_Conversion 22393 then 22394 return Object_Access_Level (Original_Node (Obj)); 22395 22396 elsif not Comes_From_Source (Obj) then 22397 declare 22398 Ref : constant Node_Id := Reference_To (Obj); 22399 begin 22400 if Present (Ref) then 22401 return Object_Access_Level (Ref); 22402 else 22403 return Type_Access_Level (Etype (Prefix (Obj))); 22404 end if; 22405 end; 22406 22407 else 22408 return Type_Access_Level (Etype (Prefix (Obj))); 22409 end if; 22410 22411 elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then 22412 return Object_Access_Level (Expression (Obj)); 22413 22414 elsif Nkind (Obj) = N_Function_Call then 22415 22416 -- Function results are objects, so we get either the access level of 22417 -- the function or, in the case of an indirect call, the level of the 22418 -- access-to-subprogram type. (This code is used for Ada 95, but it 22419 -- looks wrong, because it seems that we should be checking the level 22420 -- of the call itself, even for Ada 95. However, using the Ada 2005 22421 -- version of the code causes regressions in several tests that are 22422 -- compiled with -gnat95. ???) 22423 22424 if Ada_Version < Ada_2005 then 22425 if Is_Entity_Name (Name (Obj)) then 22426 return Subprogram_Access_Level (Entity (Name (Obj))); 22427 else 22428 return Type_Access_Level (Etype (Prefix (Name (Obj)))); 22429 end if; 22430 22431 -- For Ada 2005, the level of the result object of a function call is 22432 -- defined to be the level of the call's innermost enclosing master. 22433 -- We determine that by querying the depth of the innermost enclosing 22434 -- dynamic scope. 22435 22436 else 22437 Return_Master_Scope_Depth_Of_Call : declare 22438 function Innermost_Master_Scope_Depth 22439 (N : Node_Id) return Uint; 22440 -- Returns the scope depth of the given node's innermost 22441 -- enclosing dynamic scope (effectively the accessibility 22442 -- level of the innermost enclosing master). 22443 22444 ---------------------------------- 22445 -- Innermost_Master_Scope_Depth -- 22446 ---------------------------------- 22447 22448 function Innermost_Master_Scope_Depth 22449 (N : Node_Id) return Uint 22450 is 22451 Node_Par : Node_Id := Parent (N); 22452 22453 begin 22454 -- Locate the nearest enclosing node (by traversing Parents) 22455 -- that Defining_Entity can be applied to, and return the 22456 -- depth of that entity's nearest enclosing dynamic scope. 22457 22458 while Present (Node_Par) loop 22459 case Nkind (Node_Par) is 22460 when N_Abstract_Subprogram_Declaration 22461 | N_Block_Statement 22462 | N_Body_Stub 22463 | N_Component_Declaration 22464 | N_Entry_Body 22465 | N_Entry_Declaration 22466 | N_Exception_Declaration 22467 | N_Formal_Object_Declaration 22468 | N_Formal_Package_Declaration 22469 | N_Formal_Subprogram_Declaration 22470 | N_Formal_Type_Declaration 22471 | N_Full_Type_Declaration 22472 | N_Function_Specification 22473 | N_Generic_Declaration 22474 | N_Generic_Instantiation 22475 | N_Implicit_Label_Declaration 22476 | N_Incomplete_Type_Declaration 22477 | N_Loop_Parameter_Specification 22478 | N_Number_Declaration 22479 | N_Object_Declaration 22480 | N_Package_Declaration 22481 | N_Package_Specification 22482 | N_Parameter_Specification 22483 | N_Private_Extension_Declaration 22484 | N_Private_Type_Declaration 22485 | N_Procedure_Specification 22486 | N_Proper_Body 22487 | N_Protected_Type_Declaration 22488 | N_Renaming_Declaration 22489 | N_Single_Protected_Declaration 22490 | N_Single_Task_Declaration 22491 | N_Subprogram_Declaration 22492 | N_Subtype_Declaration 22493 | N_Subunit 22494 | N_Task_Type_Declaration 22495 => 22496 return Scope_Depth 22497 (Nearest_Dynamic_Scope 22498 (Defining_Entity (Node_Par))); 22499 22500 -- For a return statement within a function, return 22501 -- the depth of the function itself. This is not just 22502 -- a small optimization, but matters when analyzing 22503 -- the expression in an expression function before 22504 -- the body is created. 22505 22506 when N_Simple_Return_Statement => 22507 if Ekind (Current_Scope) = E_Function then 22508 return Scope_Depth (Current_Scope); 22509 end if; 22510 22511 when others => 22512 null; 22513 end case; 22514 22515 Node_Par := Parent (Node_Par); 22516 end loop; 22517 22518 pragma Assert (False); 22519 22520 -- Should never reach the following return 22521 22522 return Scope_Depth (Current_Scope) + 1; 22523 end Innermost_Master_Scope_Depth; 22524 22525 -- Start of processing for Return_Master_Scope_Depth_Of_Call 22526 22527 begin 22528 return Innermost_Master_Scope_Depth (Obj); 22529 end Return_Master_Scope_Depth_Of_Call; 22530 end if; 22531 22532 -- For convenience we handle qualified expressions, even though they 22533 -- aren't technically object names. 22534 22535 elsif Nkind (Obj) = N_Qualified_Expression then 22536 return Object_Access_Level (Expression (Obj)); 22537 22538 -- Ditto for aggregates. They have the level of the temporary that 22539 -- will hold their value. 22540 22541 elsif Nkind (Obj) = N_Aggregate then 22542 return Object_Access_Level (Current_Scope); 22543 22544 -- Otherwise return the scope level of Standard. (If there are cases 22545 -- that fall through to this point they will be treated as having 22546 -- global accessibility for now. ???) 22547 22548 else 22549 return Scope_Depth (Standard_Standard); 22550 end if; 22551 end Object_Access_Level; 22552 22553 ---------------------------------- 22554 -- Old_Requires_Transient_Scope -- 22555 ---------------------------------- 22556 22557 function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean is 22558 Typ : constant Entity_Id := Underlying_Type (Id); 22559 22560 begin 22561 -- This is a private type which is not completed yet. This can only 22562 -- happen in a default expression (of a formal parameter or of a 22563 -- record component). Do not expand transient scope in this case. 22564 22565 if No (Typ) then 22566 return False; 22567 22568 -- Do not expand transient scope for non-existent procedure return 22569 22570 elsif Typ = Standard_Void_Type then 22571 return False; 22572 22573 -- Elementary types do not require a transient scope 22574 22575 elsif Is_Elementary_Type (Typ) then 22576 return False; 22577 22578 -- Generally, indefinite subtypes require a transient scope, since the 22579 -- back end cannot generate temporaries, since this is not a valid type 22580 -- for declaring an object. It might be possible to relax this in the 22581 -- future, e.g. by declaring the maximum possible space for the type. 22582 22583 elsif not Is_Definite_Subtype (Typ) then 22584 return True; 22585 22586 -- Functions returning tagged types may dispatch on result so their 22587 -- returned value is allocated on the secondary stack. Controlled 22588 -- type temporaries need finalization. 22589 22590 elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then 22591 return True; 22592 22593 -- Record type 22594 22595 elsif Is_Record_Type (Typ) then 22596 declare 22597 Comp : Entity_Id; 22598 22599 begin 22600 Comp := First_Entity (Typ); 22601 while Present (Comp) loop 22602 if Ekind (Comp) = E_Component then 22603 22604 -- ???It's not clear we need a full recursive call to 22605 -- Old_Requires_Transient_Scope here. Note that the 22606 -- following can't happen. 22607 22608 pragma Assert (Is_Definite_Subtype (Etype (Comp))); 22609 pragma Assert (not Has_Controlled_Component (Etype (Comp))); 22610 22611 if Old_Requires_Transient_Scope (Etype (Comp)) then 22612 return True; 22613 end if; 22614 end if; 22615 22616 Next_Entity (Comp); 22617 end loop; 22618 end; 22619 22620 return False; 22621 22622 -- String literal types never require transient scope 22623 22624 elsif Ekind (Typ) = E_String_Literal_Subtype then 22625 return False; 22626 22627 -- Array type. Note that we already know that this is a constrained 22628 -- array, since unconstrained arrays will fail the indefinite test. 22629 22630 elsif Is_Array_Type (Typ) then 22631 22632 -- If component type requires a transient scope, the array does too 22633 22634 if Old_Requires_Transient_Scope (Component_Type (Typ)) then 22635 return True; 22636 22637 -- Otherwise, we only need a transient scope if the size depends on 22638 -- the value of one or more discriminants. 22639 22640 else 22641 return Size_Depends_On_Discriminant (Typ); 22642 end if; 22643 22644 -- All other cases do not require a transient scope 22645 22646 else 22647 pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ)); 22648 return False; 22649 end if; 22650 end Old_Requires_Transient_Scope; 22651 22652 --------------------------------- 22653 -- Original_Aspect_Pragma_Name -- 22654 --------------------------------- 22655 22656 function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id is 22657 Item : Node_Id; 22658 Item_Nam : Name_Id; 22659 22660 begin 22661 pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma)); 22662 22663 Item := N; 22664 22665 -- The pragma was generated to emulate an aspect, use the original 22666 -- aspect specification. 22667 22668 if Nkind (Item) = N_Pragma and then From_Aspect_Specification (Item) then 22669 Item := Corresponding_Aspect (Item); 22670 end if; 22671 22672 -- Retrieve the name of the aspect/pragma. Note that Pre, Pre_Class, 22673 -- Post and Post_Class rewrite their pragma identifier to preserve the 22674 -- original name. 22675 -- ??? this is kludgey 22676 22677 if Nkind (Item) = N_Pragma then 22678 Item_Nam := Chars (Original_Node (Pragma_Identifier (Item))); 22679 22680 else 22681 pragma Assert (Nkind (Item) = N_Aspect_Specification); 22682 Item_Nam := Chars (Identifier (Item)); 22683 end if; 22684 22685 -- Deal with 'Class by converting the name to its _XXX form 22686 22687 if Class_Present (Item) then 22688 if Item_Nam = Name_Invariant then 22689 Item_Nam := Name_uInvariant; 22690 22691 elsif Item_Nam = Name_Post then 22692 Item_Nam := Name_uPost; 22693 22694 elsif Item_Nam = Name_Pre then 22695 Item_Nam := Name_uPre; 22696 22697 elsif Nam_In (Item_Nam, Name_Type_Invariant, 22698 Name_Type_Invariant_Class) 22699 then 22700 Item_Nam := Name_uType_Invariant; 22701 22702 -- Nothing to do for other cases (e.g. a Check that derived from 22703 -- Pre_Class and has the flag set). Also we do nothing if the name 22704 -- is already in special _xxx form. 22705 22706 end if; 22707 end if; 22708 22709 return Item_Nam; 22710 end Original_Aspect_Pragma_Name; 22711 22712 -------------------------------------- 22713 -- Original_Corresponding_Operation -- 22714 -------------------------------------- 22715 22716 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id 22717 is 22718 Typ : constant Entity_Id := Find_Dispatching_Type (S); 22719 22720 begin 22721 -- If S is an inherited primitive S2 the original corresponding 22722 -- operation of S is the original corresponding operation of S2 22723 22724 if Present (Alias (S)) 22725 and then Find_Dispatching_Type (Alias (S)) /= Typ 22726 then 22727 return Original_Corresponding_Operation (Alias (S)); 22728 22729 -- If S overrides an inherited subprogram S2 the original corresponding 22730 -- operation of S is the original corresponding operation of S2 22731 22732 elsif Present (Overridden_Operation (S)) then 22733 return Original_Corresponding_Operation (Overridden_Operation (S)); 22734 22735 -- otherwise it is S itself 22736 22737 else 22738 return S; 22739 end if; 22740 end Original_Corresponding_Operation; 22741 22742 ------------------- 22743 -- Output_Entity -- 22744 ------------------- 22745 22746 procedure Output_Entity (Id : Entity_Id) is 22747 Scop : Entity_Id; 22748 22749 begin 22750 Scop := Scope (Id); 22751 22752 -- The entity may lack a scope when it is in the process of being 22753 -- analyzed. Use the current scope as an approximation. 22754 22755 if No (Scop) then 22756 Scop := Current_Scope; 22757 end if; 22758 22759 Output_Name (Chars (Id), Scop); 22760 end Output_Entity; 22761 22762 ----------------- 22763 -- Output_Name -- 22764 ----------------- 22765 22766 procedure Output_Name (Nam : Name_Id; Scop : Entity_Id := Current_Scope) is 22767 begin 22768 Write_Str 22769 (Get_Name_String 22770 (Get_Qualified_Name 22771 (Nam => Nam, 22772 Suffix => No_Name, 22773 Scop => Scop))); 22774 Write_Eol; 22775 end Output_Name; 22776 22777 ---------------------- 22778 -- Policy_In_Effect -- 22779 ---------------------- 22780 22781 function Policy_In_Effect (Policy : Name_Id) return Name_Id is 22782 function Policy_In_List (List : Node_Id) return Name_Id; 22783 -- Determine the mode of a policy in a N_Pragma list 22784 22785 -------------------- 22786 -- Policy_In_List -- 22787 -------------------- 22788 22789 function Policy_In_List (List : Node_Id) return Name_Id is 22790 Arg1 : Node_Id; 22791 Arg2 : Node_Id; 22792 Prag : Node_Id; 22793 22794 begin 22795 Prag := List; 22796 while Present (Prag) loop 22797 Arg1 := First (Pragma_Argument_Associations (Prag)); 22798 Arg2 := Next (Arg1); 22799 22800 Arg1 := Get_Pragma_Arg (Arg1); 22801 Arg2 := Get_Pragma_Arg (Arg2); 22802 22803 -- The current Check_Policy pragma matches the requested policy or 22804 -- appears in the single argument form (Assertion, policy_id). 22805 22806 if Nam_In (Chars (Arg1), Name_Assertion, Policy) then 22807 return Chars (Arg2); 22808 end if; 22809 22810 Prag := Next_Pragma (Prag); 22811 end loop; 22812 22813 return No_Name; 22814 end Policy_In_List; 22815 22816 -- Local variables 22817 22818 Kind : Name_Id; 22819 22820 -- Start of processing for Policy_In_Effect 22821 22822 begin 22823 if not Is_Valid_Assertion_Kind (Policy) then 22824 raise Program_Error; 22825 end if; 22826 22827 -- Inspect all policy pragmas that appear within scopes (if any) 22828 22829 Kind := Policy_In_List (Check_Policy_List); 22830 22831 -- Inspect all configuration policy pragmas (if any) 22832 22833 if Kind = No_Name then 22834 Kind := Policy_In_List (Check_Policy_List_Config); 22835 end if; 22836 22837 -- The context lacks policy pragmas, determine the mode based on whether 22838 -- assertions are enabled at the configuration level. This ensures that 22839 -- the policy is preserved when analyzing generics. 22840 22841 if Kind = No_Name then 22842 if Assertions_Enabled_Config then 22843 Kind := Name_Check; 22844 else 22845 Kind := Name_Ignore; 22846 end if; 22847 end if; 22848 22849 -- In CodePeer mode and GNATprove mode, we need to consider all 22850 -- assertions, unless they are disabled. Force Name_Check on 22851 -- ignored assertions. 22852 22853 if Nam_In (Kind, Name_Ignore, Name_Off) 22854 and then (CodePeer_Mode or GNATprove_Mode) 22855 then 22856 Kind := Name_Check; 22857 end if; 22858 22859 return Kind; 22860 end Policy_In_Effect; 22861 22862 ---------------------------------- 22863 -- Predicate_Tests_On_Arguments -- 22864 ---------------------------------- 22865 22866 function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean is 22867 begin 22868 -- Always test predicates on indirect call 22869 22870 if Ekind (Subp) = E_Subprogram_Type then 22871 return True; 22872 22873 -- Do not test predicates on call to generated default Finalize, since 22874 -- we are not interested in whether something we are finalizing (and 22875 -- typically destroying) satisfies its predicates. 22876 22877 elsif Chars (Subp) = Name_Finalize 22878 and then not Comes_From_Source (Subp) 22879 then 22880 return False; 22881 22882 -- Do not test predicates on any internally generated routines 22883 22884 elsif Is_Internal_Name (Chars (Subp)) then 22885 return False; 22886 22887 -- Do not test predicates on call to Init_Proc, since if needed the 22888 -- predicate test will occur at some other point. 22889 22890 elsif Is_Init_Proc (Subp) then 22891 return False; 22892 22893 -- Do not test predicates on call to predicate function, since this 22894 -- would cause infinite recursion. 22895 22896 elsif Ekind (Subp) = E_Function 22897 and then (Is_Predicate_Function (Subp) 22898 or else 22899 Is_Predicate_Function_M (Subp)) 22900 then 22901 return False; 22902 22903 -- For now, no other exceptions 22904 22905 else 22906 return True; 22907 end if; 22908 end Predicate_Tests_On_Arguments; 22909 22910 ----------------------- 22911 -- Private_Component -- 22912 ----------------------- 22913 22914 function Private_Component (Type_Id : Entity_Id) return Entity_Id is 22915 Ancestor : constant Entity_Id := Base_Type (Type_Id); 22916 22917 function Trace_Components 22918 (T : Entity_Id; 22919 Check : Boolean) return Entity_Id; 22920 -- Recursive function that does the work, and checks against circular 22921 -- definition for each subcomponent type. 22922 22923 ---------------------- 22924 -- Trace_Components -- 22925 ---------------------- 22926 22927 function Trace_Components 22928 (T : Entity_Id; 22929 Check : Boolean) return Entity_Id 22930 is 22931 Btype : constant Entity_Id := Base_Type (T); 22932 Component : Entity_Id; 22933 P : Entity_Id; 22934 Candidate : Entity_Id := Empty; 22935 22936 begin 22937 if Check and then Btype = Ancestor then 22938 Error_Msg_N ("circular type definition", Type_Id); 22939 return Any_Type; 22940 end if; 22941 22942 if Is_Private_Type (Btype) and then not Is_Generic_Type (Btype) then 22943 if Present (Full_View (Btype)) 22944 and then Is_Record_Type (Full_View (Btype)) 22945 and then not Is_Frozen (Btype) 22946 then 22947 -- To indicate that the ancestor depends on a private type, the 22948 -- current Btype is sufficient. However, to check for circular 22949 -- definition we must recurse on the full view. 22950 22951 Candidate := Trace_Components (Full_View (Btype), True); 22952 22953 if Candidate = Any_Type then 22954 return Any_Type; 22955 else 22956 return Btype; 22957 end if; 22958 22959 else 22960 return Btype; 22961 end if; 22962 22963 elsif Is_Array_Type (Btype) then 22964 return Trace_Components (Component_Type (Btype), True); 22965 22966 elsif Is_Record_Type (Btype) then 22967 Component := First_Entity (Btype); 22968 while Present (Component) 22969 and then Comes_From_Source (Component) 22970 loop 22971 -- Skip anonymous types generated by constrained components 22972 22973 if not Is_Type (Component) then 22974 P := Trace_Components (Etype (Component), True); 22975 22976 if Present (P) then 22977 if P = Any_Type then 22978 return P; 22979 else 22980 Candidate := P; 22981 end if; 22982 end if; 22983 end if; 22984 22985 Next_Entity (Component); 22986 end loop; 22987 22988 return Candidate; 22989 22990 else 22991 return Empty; 22992 end if; 22993 end Trace_Components; 22994 22995 -- Start of processing for Private_Component 22996 22997 begin 22998 return Trace_Components (Type_Id, False); 22999 end Private_Component; 23000 23001 --------------------------- 23002 -- Primitive_Names_Match -- 23003 --------------------------- 23004 23005 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is 23006 function Non_Internal_Name (E : Entity_Id) return Name_Id; 23007 -- Given an internal name, returns the corresponding non-internal name 23008 23009 ------------------------ 23010 -- Non_Internal_Name -- 23011 ------------------------ 23012 23013 function Non_Internal_Name (E : Entity_Id) return Name_Id is 23014 begin 23015 Get_Name_String (Chars (E)); 23016 Name_Len := Name_Len - 1; 23017 return Name_Find; 23018 end Non_Internal_Name; 23019 23020 -- Start of processing for Primitive_Names_Match 23021 23022 begin 23023 pragma Assert (Present (E1) and then Present (E2)); 23024 23025 return Chars (E1) = Chars (E2) 23026 or else 23027 (not Is_Internal_Name (Chars (E1)) 23028 and then Is_Internal_Name (Chars (E2)) 23029 and then Non_Internal_Name (E2) = Chars (E1)) 23030 or else 23031 (not Is_Internal_Name (Chars (E2)) 23032 and then Is_Internal_Name (Chars (E1)) 23033 and then Non_Internal_Name (E1) = Chars (E2)) 23034 or else 23035 (Is_Predefined_Dispatching_Operation (E1) 23036 and then Is_Predefined_Dispatching_Operation (E2) 23037 and then Same_TSS (E1, E2)) 23038 or else 23039 (Is_Init_Proc (E1) and then Is_Init_Proc (E2)); 23040 end Primitive_Names_Match; 23041 23042 ----------------------- 23043 -- Process_End_Label -- 23044 ----------------------- 23045 23046 procedure Process_End_Label 23047 (N : Node_Id; 23048 Typ : Character; 23049 Ent : Entity_Id) 23050 is 23051 Loc : Source_Ptr; 23052 Nam : Node_Id; 23053 Scop : Entity_Id; 23054 23055 Label_Ref : Boolean; 23056 -- Set True if reference to end label itself is required 23057 23058 Endl : Node_Id; 23059 -- Gets set to the operator symbol or identifier that references the 23060 -- entity Ent. For the child unit case, this is the identifier from the 23061 -- designator. For other cases, this is simply Endl. 23062 23063 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id); 23064 -- N is an identifier node that appears as a parent unit reference in 23065 -- the case where Ent is a child unit. This procedure generates an 23066 -- appropriate cross-reference entry. E is the corresponding entity. 23067 23068 ------------------------- 23069 -- Generate_Parent_Ref -- 23070 ------------------------- 23071 23072 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is 23073 begin 23074 -- If names do not match, something weird, skip reference 23075 23076 if Chars (E) = Chars (N) then 23077 23078 -- Generate the reference. We do NOT consider this as a reference 23079 -- for unreferenced symbol purposes. 23080 23081 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True); 23082 23083 if Style_Check then 23084 Style.Check_Identifier (N, E); 23085 end if; 23086 end if; 23087 end Generate_Parent_Ref; 23088 23089 -- Start of processing for Process_End_Label 23090 23091 begin 23092 -- If no node, ignore. This happens in some error situations, and 23093 -- also for some internally generated structures where no end label 23094 -- references are required in any case. 23095 23096 if No (N) then 23097 return; 23098 end if; 23099 23100 -- Nothing to do if no End_Label, happens for internally generated 23101 -- constructs where we don't want an end label reference anyway. Also 23102 -- nothing to do if Endl is a string literal, which means there was 23103 -- some prior error (bad operator symbol) 23104 23105 Endl := End_Label (N); 23106 23107 if No (Endl) or else Nkind (Endl) = N_String_Literal then 23108 return; 23109 end if; 23110 23111 -- Reference node is not in extended main source unit 23112 23113 if not In_Extended_Main_Source_Unit (N) then 23114 23115 -- Generally we do not collect references except for the extended 23116 -- main source unit. The one exception is the 'e' entry for a 23117 -- package spec, where it is useful for a client to have the 23118 -- ending information to define scopes. 23119 23120 if Typ /= 'e' then 23121 return; 23122 23123 else 23124 Label_Ref := False; 23125 23126 -- For this case, we can ignore any parent references, but we 23127 -- need the package name itself for the 'e' entry. 23128 23129 if Nkind (Endl) = N_Designator then 23130 Endl := Identifier (Endl); 23131 end if; 23132 end if; 23133 23134 -- Reference is in extended main source unit 23135 23136 else 23137 Label_Ref := True; 23138 23139 -- For designator, generate references for the parent entries 23140 23141 if Nkind (Endl) = N_Designator then 23142 23143 -- Generate references for the prefix if the END line comes from 23144 -- source (otherwise we do not need these references) We climb the 23145 -- scope stack to find the expected entities. 23146 23147 if Comes_From_Source (Endl) then 23148 Nam := Name (Endl); 23149 Scop := Current_Scope; 23150 while Nkind (Nam) = N_Selected_Component loop 23151 Scop := Scope (Scop); 23152 exit when No (Scop); 23153 Generate_Parent_Ref (Selector_Name (Nam), Scop); 23154 Nam := Prefix (Nam); 23155 end loop; 23156 23157 if Present (Scop) then 23158 Generate_Parent_Ref (Nam, Scope (Scop)); 23159 end if; 23160 end if; 23161 23162 Endl := Identifier (Endl); 23163 end if; 23164 end if; 23165 23166 -- If the end label is not for the given entity, then either we have 23167 -- some previous error, or this is a generic instantiation for which 23168 -- we do not need to make a cross-reference in this case anyway. In 23169 -- either case we simply ignore the call. 23170 23171 if Chars (Ent) /= Chars (Endl) then 23172 return; 23173 end if; 23174 23175 -- If label was really there, then generate a normal reference and then 23176 -- adjust the location in the end label to point past the name (which 23177 -- should almost always be the semicolon). 23178 23179 Loc := Sloc (Endl); 23180 23181 if Comes_From_Source (Endl) then 23182 23183 -- If a label reference is required, then do the style check and 23184 -- generate an l-type cross-reference entry for the label 23185 23186 if Label_Ref then 23187 if Style_Check then 23188 Style.Check_Identifier (Endl, Ent); 23189 end if; 23190 23191 Generate_Reference (Ent, Endl, 'l', Set_Ref => False); 23192 end if; 23193 23194 -- Set the location to point past the label (normally this will 23195 -- mean the semicolon immediately following the label). This is 23196 -- done for the sake of the 'e' or 't' entry generated below. 23197 23198 Get_Decoded_Name_String (Chars (Endl)); 23199 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len)); 23200 23201 else 23202 -- In SPARK mode, no missing label is allowed for packages and 23203 -- subprogram bodies. Detect those cases by testing whether 23204 -- Process_End_Label was called for a body (Typ = 't') or a package. 23205 23206 if Restriction_Check_Required (SPARK_05) 23207 and then (Typ = 't' or else Ekind (Ent) = E_Package) 23208 then 23209 Error_Msg_Node_1 := Endl; 23210 Check_SPARK_05_Restriction 23211 ("`END &` required", Endl, Force => True); 23212 end if; 23213 end if; 23214 23215 -- Now generate the e/t reference 23216 23217 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True); 23218 23219 -- Restore Sloc, in case modified above, since we have an identifier 23220 -- and the normal Sloc should be left set in the tree. 23221 23222 Set_Sloc (Endl, Loc); 23223 end Process_End_Label; 23224 23225 -------------------------------- 23226 -- Propagate_Concurrent_Flags -- 23227 -------------------------------- 23228 23229 procedure Propagate_Concurrent_Flags 23230 (Typ : Entity_Id; 23231 Comp_Typ : Entity_Id) 23232 is 23233 begin 23234 if Has_Task (Comp_Typ) then 23235 Set_Has_Task (Typ); 23236 end if; 23237 23238 if Has_Protected (Comp_Typ) then 23239 Set_Has_Protected (Typ); 23240 end if; 23241 23242 if Has_Timing_Event (Comp_Typ) then 23243 Set_Has_Timing_Event (Typ); 23244 end if; 23245 end Propagate_Concurrent_Flags; 23246 23247 ------------------------------ 23248 -- Propagate_DIC_Attributes -- 23249 ------------------------------ 23250 23251 procedure Propagate_DIC_Attributes 23252 (Typ : Entity_Id; 23253 From_Typ : Entity_Id) 23254 is 23255 DIC_Proc : Entity_Id; 23256 23257 begin 23258 if Present (Typ) and then Present (From_Typ) then 23259 pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ)); 23260 23261 -- Nothing to do if both the source and the destination denote the 23262 -- same type. 23263 23264 if From_Typ = Typ then 23265 return; 23266 end if; 23267 23268 DIC_Proc := DIC_Procedure (From_Typ); 23269 23270 -- The setting of the attributes is intentionally conservative. This 23271 -- prevents accidental clobbering of enabled attributes. 23272 23273 if Has_Inherited_DIC (From_Typ) 23274 and then not Has_Inherited_DIC (Typ) 23275 then 23276 Set_Has_Inherited_DIC (Typ); 23277 end if; 23278 23279 if Has_Own_DIC (From_Typ) and then not Has_Own_DIC (Typ) then 23280 Set_Has_Own_DIC (Typ); 23281 end if; 23282 23283 if Present (DIC_Proc) and then No (DIC_Procedure (Typ)) then 23284 Set_DIC_Procedure (Typ, DIC_Proc); 23285 end if; 23286 end if; 23287 end Propagate_DIC_Attributes; 23288 23289 ------------------------------------ 23290 -- Propagate_Invariant_Attributes -- 23291 ------------------------------------ 23292 23293 procedure Propagate_Invariant_Attributes 23294 (Typ : Entity_Id; 23295 From_Typ : Entity_Id) 23296 is 23297 Full_IP : Entity_Id; 23298 Part_IP : Entity_Id; 23299 23300 begin 23301 if Present (Typ) and then Present (From_Typ) then 23302 pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ)); 23303 23304 -- Nothing to do if both the source and the destination denote the 23305 -- same type. 23306 23307 if From_Typ = Typ then 23308 return; 23309 end if; 23310 23311 Full_IP := Invariant_Procedure (From_Typ); 23312 Part_IP := Partial_Invariant_Procedure (From_Typ); 23313 23314 -- The setting of the attributes is intentionally conservative. This 23315 -- prevents accidental clobbering of enabled attributes. 23316 23317 if Has_Inheritable_Invariants (From_Typ) 23318 and then not Has_Inheritable_Invariants (Typ) 23319 then 23320 Set_Has_Inheritable_Invariants (Typ); 23321 end if; 23322 23323 if Has_Inherited_Invariants (From_Typ) 23324 and then not Has_Inherited_Invariants (Typ) 23325 then 23326 Set_Has_Inherited_Invariants (Typ); 23327 end if; 23328 23329 if Has_Own_Invariants (From_Typ) 23330 and then not Has_Own_Invariants (Typ) 23331 then 23332 Set_Has_Own_Invariants (Typ); 23333 end if; 23334 23335 if Present (Full_IP) and then No (Invariant_Procedure (Typ)) then 23336 Set_Invariant_Procedure (Typ, Full_IP); 23337 end if; 23338 23339 if Present (Part_IP) and then No (Partial_Invariant_Procedure (Typ)) 23340 then 23341 Set_Partial_Invariant_Procedure (Typ, Part_IP); 23342 end if; 23343 end if; 23344 end Propagate_Invariant_Attributes; 23345 23346 --------------------------------------- 23347 -- Record_Possible_Part_Of_Reference -- 23348 --------------------------------------- 23349 23350 procedure Record_Possible_Part_Of_Reference 23351 (Var_Id : Entity_Id; 23352 Ref : Node_Id) 23353 is 23354 Encap : constant Entity_Id := Encapsulating_State (Var_Id); 23355 Refs : Elist_Id; 23356 23357 begin 23358 -- The variable is a constituent of a single protected/task type. Such 23359 -- a variable acts as a component of the type and must appear within a 23360 -- specific region (SPARK RM 9(3)). Instead of recording the reference, 23361 -- verify its legality now. 23362 23363 if Present (Encap) and then Is_Single_Concurrent_Object (Encap) then 23364 Check_Part_Of_Reference (Var_Id, Ref); 23365 23366 -- The variable is subject to pragma Part_Of and may eventually become a 23367 -- constituent of a single protected/task type. Record the reference to 23368 -- verify its placement when the contract of the variable is analyzed. 23369 23370 elsif Present (Get_Pragma (Var_Id, Pragma_Part_Of)) then 23371 Refs := Part_Of_References (Var_Id); 23372 23373 if No (Refs) then 23374 Refs := New_Elmt_List; 23375 Set_Part_Of_References (Var_Id, Refs); 23376 end if; 23377 23378 Append_Elmt (Ref, Refs); 23379 end if; 23380 end Record_Possible_Part_Of_Reference; 23381 23382 ---------------- 23383 -- Referenced -- 23384 ---------------- 23385 23386 function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is 23387 Seen : Boolean := False; 23388 23389 function Is_Reference (N : Node_Id) return Traverse_Result; 23390 -- Determine whether node N denotes a reference to Id. If this is the 23391 -- case, set global flag Seen to True and stop the traversal. 23392 23393 ------------------ 23394 -- Is_Reference -- 23395 ------------------ 23396 23397 function Is_Reference (N : Node_Id) return Traverse_Result is 23398 begin 23399 if Is_Entity_Name (N) 23400 and then Present (Entity (N)) 23401 and then Entity (N) = Id 23402 then 23403 Seen := True; 23404 return Abandon; 23405 else 23406 return OK; 23407 end if; 23408 end Is_Reference; 23409 23410 procedure Inspect_Expression is new Traverse_Proc (Is_Reference); 23411 23412 -- Start of processing for Referenced 23413 23414 begin 23415 Inspect_Expression (Expr); 23416 return Seen; 23417 end Referenced; 23418 23419 ------------------------------------ 23420 -- References_Generic_Formal_Type -- 23421 ------------------------------------ 23422 23423 function References_Generic_Formal_Type (N : Node_Id) return Boolean is 23424 23425 function Process (N : Node_Id) return Traverse_Result; 23426 -- Process one node in search for generic formal type 23427 23428 ------------- 23429 -- Process -- 23430 ------------- 23431 23432 function Process (N : Node_Id) return Traverse_Result is 23433 begin 23434 if Nkind (N) in N_Has_Entity then 23435 declare 23436 E : constant Entity_Id := Entity (N); 23437 begin 23438 if Present (E) then 23439 if Is_Generic_Type (E) then 23440 return Abandon; 23441 elsif Present (Etype (E)) 23442 and then Is_Generic_Type (Etype (E)) 23443 then 23444 return Abandon; 23445 end if; 23446 end if; 23447 end; 23448 end if; 23449 23450 return Atree.OK; 23451 end Process; 23452 23453 function Traverse is new Traverse_Func (Process); 23454 -- Traverse tree to look for generic type 23455 23456 begin 23457 if Inside_A_Generic then 23458 return Traverse (N) = Abandon; 23459 else 23460 return False; 23461 end if; 23462 end References_Generic_Formal_Type; 23463 23464 ------------------------------- 23465 -- Remove_Entity_And_Homonym -- 23466 ------------------------------- 23467 23468 procedure Remove_Entity_And_Homonym (Id : Entity_Id) is 23469 begin 23470 Remove_Entity (Id); 23471 Remove_Homonym (Id); 23472 end Remove_Entity_And_Homonym; 23473 23474 -------------------- 23475 -- Remove_Homonym -- 23476 -------------------- 23477 23478 procedure Remove_Homonym (Id : Entity_Id) is 23479 Hom : Entity_Id; 23480 Prev : Entity_Id := Empty; 23481 23482 begin 23483 if Id = Current_Entity (Id) then 23484 if Present (Homonym (Id)) then 23485 Set_Current_Entity (Homonym (Id)); 23486 else 23487 Set_Name_Entity_Id (Chars (Id), Empty); 23488 end if; 23489 23490 else 23491 Hom := Current_Entity (Id); 23492 while Present (Hom) and then Hom /= Id loop 23493 Prev := Hom; 23494 Hom := Homonym (Hom); 23495 end loop; 23496 23497 -- If Id is not on the homonym chain, nothing to do 23498 23499 if Present (Hom) then 23500 Set_Homonym (Prev, Homonym (Id)); 23501 end if; 23502 end if; 23503 end Remove_Homonym; 23504 23505 ------------------------------ 23506 -- Remove_Overloaded_Entity -- 23507 ------------------------------ 23508 23509 procedure Remove_Overloaded_Entity (Id : Entity_Id) is 23510 procedure Remove_Primitive_Of (Typ : Entity_Id); 23511 -- Remove primitive subprogram Id from the list of primitives that 23512 -- belong to type Typ. 23513 23514 ------------------------- 23515 -- Remove_Primitive_Of -- 23516 ------------------------- 23517 23518 procedure Remove_Primitive_Of (Typ : Entity_Id) is 23519 Prims : Elist_Id; 23520 23521 begin 23522 if Is_Tagged_Type (Typ) then 23523 Prims := Direct_Primitive_Operations (Typ); 23524 23525 if Present (Prims) then 23526 Remove (Prims, Id); 23527 end if; 23528 end if; 23529 end Remove_Primitive_Of; 23530 23531 -- Local variables 23532 23533 Formal : Entity_Id; 23534 23535 -- Start of processing for Remove_Overloaded_Entity 23536 23537 begin 23538 Remove_Entity_And_Homonym (Id); 23539 23540 -- The entity denotes a primitive subprogram. Remove it from the list of 23541 -- primitives of the associated controlling type. 23542 23543 if Ekind_In (Id, E_Function, E_Procedure) and then Is_Primitive (Id) then 23544 Formal := First_Formal (Id); 23545 while Present (Formal) loop 23546 if Is_Controlling_Formal (Formal) then 23547 Remove_Primitive_Of (Etype (Formal)); 23548 exit; 23549 end if; 23550 23551 Next_Formal (Formal); 23552 end loop; 23553 23554 if Ekind (Id) = E_Function and then Has_Controlling_Result (Id) then 23555 Remove_Primitive_Of (Etype (Id)); 23556 end if; 23557 end if; 23558 end Remove_Overloaded_Entity; 23559 23560 --------------------- 23561 -- Rep_To_Pos_Flag -- 23562 --------------------- 23563 23564 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is 23565 begin 23566 return New_Occurrence_Of 23567 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc); 23568 end Rep_To_Pos_Flag; 23569 23570 -------------------- 23571 -- Require_Entity -- 23572 -------------------- 23573 23574 procedure Require_Entity (N : Node_Id) is 23575 begin 23576 if Is_Entity_Name (N) and then No (Entity (N)) then 23577 if Total_Errors_Detected /= 0 then 23578 Set_Entity (N, Any_Id); 23579 else 23580 raise Program_Error; 23581 end if; 23582 end if; 23583 end Require_Entity; 23584 23585 ------------------------------ 23586 -- Requires_Transient_Scope -- 23587 ------------------------------ 23588 23589 -- A transient scope is required when variable-sized temporaries are 23590 -- allocated on the secondary stack, or when finalization actions must be 23591 -- generated before the next instruction. 23592 23593 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is 23594 Old_Result : constant Boolean := Old_Requires_Transient_Scope (Id); 23595 23596 begin 23597 if Debug_Flag_QQ then 23598 return Old_Result; 23599 end if; 23600 23601 declare 23602 New_Result : constant Boolean := New_Requires_Transient_Scope (Id); 23603 23604 begin 23605 -- Assert that we're not putting things on the secondary stack if we 23606 -- didn't before; we are trying to AVOID secondary stack when 23607 -- possible. 23608 23609 if not Old_Result then 23610 pragma Assert (not New_Result); 23611 null; 23612 end if; 23613 23614 if New_Result /= Old_Result then 23615 Results_Differ (Id, Old_Result, New_Result); 23616 end if; 23617 23618 return New_Result; 23619 end; 23620 end Requires_Transient_Scope; 23621 23622 -------------------- 23623 -- Results_Differ -- 23624 -------------------- 23625 23626 procedure Results_Differ 23627 (Id : Entity_Id; 23628 Old_Val : Boolean; 23629 New_Val : Boolean) 23630 is 23631 begin 23632 if False then -- False to disable; True for debugging 23633 Treepr.Print_Tree_Node (Id); 23634 23635 if Old_Val = New_Val then 23636 raise Program_Error; 23637 end if; 23638 end if; 23639 end Results_Differ; 23640 23641 -------------------------- 23642 -- Reset_Analyzed_Flags -- 23643 -------------------------- 23644 23645 procedure Reset_Analyzed_Flags (N : Node_Id) is 23646 function Clear_Analyzed (N : Node_Id) return Traverse_Result; 23647 -- Function used to reset Analyzed flags in tree. Note that we do 23648 -- not reset Analyzed flags in entities, since there is no need to 23649 -- reanalyze entities, and indeed, it is wrong to do so, since it 23650 -- can result in generating auxiliary stuff more than once. 23651 23652 -------------------- 23653 -- Clear_Analyzed -- 23654 -------------------- 23655 23656 function Clear_Analyzed (N : Node_Id) return Traverse_Result is 23657 begin 23658 if Nkind (N) not in N_Entity then 23659 Set_Analyzed (N, False); 23660 end if; 23661 23662 return OK; 23663 end Clear_Analyzed; 23664 23665 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed); 23666 23667 -- Start of processing for Reset_Analyzed_Flags 23668 23669 begin 23670 Reset_Analyzed (N); 23671 end Reset_Analyzed_Flags; 23672 23673 ------------------------ 23674 -- Restore_SPARK_Mode -- 23675 ------------------------ 23676 23677 procedure Restore_SPARK_Mode 23678 (Mode : SPARK_Mode_Type; 23679 Prag : Node_Id) 23680 is 23681 begin 23682 SPARK_Mode := Mode; 23683 SPARK_Mode_Pragma := Prag; 23684 end Restore_SPARK_Mode; 23685 23686 -------------------------------- 23687 -- Returns_Unconstrained_Type -- 23688 -------------------------------- 23689 23690 function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is 23691 begin 23692 return Ekind (Subp) = E_Function 23693 and then not Is_Scalar_Type (Etype (Subp)) 23694 and then not Is_Access_Type (Etype (Subp)) 23695 and then not Is_Constrained (Etype (Subp)); 23696 end Returns_Unconstrained_Type; 23697 23698 ---------------------------- 23699 -- Root_Type_Of_Full_View -- 23700 ---------------------------- 23701 23702 function Root_Type_Of_Full_View (T : Entity_Id) return Entity_Id is 23703 Rtyp : constant Entity_Id := Root_Type (T); 23704 23705 begin 23706 -- The root type of the full view may itself be a private type. Keep 23707 -- looking for the ultimate derivation parent. 23708 23709 if Is_Private_Type (Rtyp) and then Present (Full_View (Rtyp)) then 23710 return Root_Type_Of_Full_View (Full_View (Rtyp)); 23711 else 23712 return Rtyp; 23713 end if; 23714 end Root_Type_Of_Full_View; 23715 23716 --------------------------- 23717 -- Safe_To_Capture_Value -- 23718 --------------------------- 23719 23720 function Safe_To_Capture_Value 23721 (N : Node_Id; 23722 Ent : Entity_Id; 23723 Cond : Boolean := False) return Boolean 23724 is 23725 begin 23726 -- The only entities for which we track constant values are variables 23727 -- which are not renamings, constants, out parameters, and in out 23728 -- parameters, so check if we have this case. 23729 23730 -- Note: it may seem odd to track constant values for constants, but in 23731 -- fact this routine is used for other purposes than simply capturing 23732 -- the value. In particular, the setting of Known[_Non]_Null. 23733 23734 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent))) 23735 or else 23736 Ekind_In (Ent, E_Constant, E_Out_Parameter, E_In_Out_Parameter) 23737 then 23738 null; 23739 23740 -- For conditionals, we also allow loop parameters and all formals, 23741 -- including in parameters. 23742 23743 elsif Cond and then Ekind_In (Ent, E_Loop_Parameter, E_In_Parameter) then 23744 null; 23745 23746 -- For all other cases, not just unsafe, but impossible to capture 23747 -- Current_Value, since the above are the only entities which have 23748 -- Current_Value fields. 23749 23750 else 23751 return False; 23752 end if; 23753 23754 -- Skip if volatile or aliased, since funny things might be going on in 23755 -- these cases which we cannot necessarily track. Also skip any variable 23756 -- for which an address clause is given, or whose address is taken. Also 23757 -- never capture value of library level variables (an attempt to do so 23758 -- can occur in the case of package elaboration code). 23759 23760 if Treat_As_Volatile (Ent) 23761 or else Is_Aliased (Ent) 23762 or else Present (Address_Clause (Ent)) 23763 or else Address_Taken (Ent) 23764 or else (Is_Library_Level_Entity (Ent) 23765 and then Ekind (Ent) = E_Variable) 23766 then 23767 return False; 23768 end if; 23769 23770 -- OK, all above conditions are met. We also require that the scope of 23771 -- the reference be the same as the scope of the entity, not counting 23772 -- packages and blocks and loops. 23773 23774 declare 23775 E_Scope : constant Entity_Id := Scope (Ent); 23776 R_Scope : Entity_Id; 23777 23778 begin 23779 R_Scope := Current_Scope; 23780 while R_Scope /= Standard_Standard loop 23781 exit when R_Scope = E_Scope; 23782 23783 if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then 23784 return False; 23785 else 23786 R_Scope := Scope (R_Scope); 23787 end if; 23788 end loop; 23789 end; 23790 23791 -- We also require that the reference does not appear in a context 23792 -- where it is not sure to be executed (i.e. a conditional context 23793 -- or an exception handler). We skip this if Cond is True, since the 23794 -- capturing of values from conditional tests handles this ok. 23795 23796 if Cond then 23797 return True; 23798 end if; 23799 23800 declare 23801 Desc : Node_Id; 23802 P : Node_Id; 23803 23804 begin 23805 Desc := N; 23806 23807 -- Seems dubious that case expressions are not handled here ??? 23808 23809 P := Parent (N); 23810 while Present (P) loop 23811 if Nkind (P) = N_If_Statement 23812 or else Nkind (P) = N_Case_Statement 23813 or else (Nkind (P) in N_Short_Circuit 23814 and then Desc = Right_Opnd (P)) 23815 or else (Nkind (P) = N_If_Expression 23816 and then Desc /= First (Expressions (P))) 23817 or else Nkind (P) = N_Exception_Handler 23818 or else Nkind (P) = N_Selective_Accept 23819 or else Nkind (P) = N_Conditional_Entry_Call 23820 or else Nkind (P) = N_Timed_Entry_Call 23821 or else Nkind (P) = N_Asynchronous_Select 23822 then 23823 return False; 23824 23825 else 23826 Desc := P; 23827 P := Parent (P); 23828 23829 -- A special Ada 2012 case: the original node may be part 23830 -- of the else_actions of a conditional expression, in which 23831 -- case it might not have been expanded yet, and appears in 23832 -- a non-syntactic list of actions. In that case it is clearly 23833 -- not safe to save a value. 23834 23835 if No (P) 23836 and then Is_List_Member (Desc) 23837 and then No (Parent (List_Containing (Desc))) 23838 then 23839 return False; 23840 end if; 23841 end if; 23842 end loop; 23843 end; 23844 23845 -- OK, looks safe to set value 23846 23847 return True; 23848 end Safe_To_Capture_Value; 23849 23850 --------------- 23851 -- Same_Name -- 23852 --------------- 23853 23854 function Same_Name (N1, N2 : Node_Id) return Boolean is 23855 K1 : constant Node_Kind := Nkind (N1); 23856 K2 : constant Node_Kind := Nkind (N2); 23857 23858 begin 23859 if (K1 = N_Identifier or else K1 = N_Defining_Identifier) 23860 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier) 23861 then 23862 return Chars (N1) = Chars (N2); 23863 23864 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name) 23865 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name) 23866 then 23867 return Same_Name (Selector_Name (N1), Selector_Name (N2)) 23868 and then Same_Name (Prefix (N1), Prefix (N2)); 23869 23870 else 23871 return False; 23872 end if; 23873 end Same_Name; 23874 23875 ----------------- 23876 -- Same_Object -- 23877 ----------------- 23878 23879 function Same_Object (Node1, Node2 : Node_Id) return Boolean is 23880 N1 : constant Node_Id := Original_Node (Node1); 23881 N2 : constant Node_Id := Original_Node (Node2); 23882 -- We do the tests on original nodes, since we are most interested 23883 -- in the original source, not any expansion that got in the way. 23884 23885 K1 : constant Node_Kind := Nkind (N1); 23886 K2 : constant Node_Kind := Nkind (N2); 23887 23888 begin 23889 -- First case, both are entities with same entity 23890 23891 if K1 in N_Has_Entity and then K2 in N_Has_Entity then 23892 declare 23893 EN1 : constant Entity_Id := Entity (N1); 23894 EN2 : constant Entity_Id := Entity (N2); 23895 begin 23896 if Present (EN1) and then Present (EN2) 23897 and then (Ekind_In (EN1, E_Variable, E_Constant) 23898 or else Is_Formal (EN1)) 23899 and then EN1 = EN2 23900 then 23901 return True; 23902 end if; 23903 end; 23904 end if; 23905 23906 -- Second case, selected component with same selector, same record 23907 23908 if K1 = N_Selected_Component 23909 and then K2 = N_Selected_Component 23910 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2)) 23911 then 23912 return Same_Object (Prefix (N1), Prefix (N2)); 23913 23914 -- Third case, indexed component with same subscripts, same array 23915 23916 elsif K1 = N_Indexed_Component 23917 and then K2 = N_Indexed_Component 23918 and then Same_Object (Prefix (N1), Prefix (N2)) 23919 then 23920 declare 23921 E1, E2 : Node_Id; 23922 begin 23923 E1 := First (Expressions (N1)); 23924 E2 := First (Expressions (N2)); 23925 while Present (E1) loop 23926 if not Same_Value (E1, E2) then 23927 return False; 23928 else 23929 Next (E1); 23930 Next (E2); 23931 end if; 23932 end loop; 23933 23934 return True; 23935 end; 23936 23937 -- Fourth case, slice of same array with same bounds 23938 23939 elsif K1 = N_Slice 23940 and then K2 = N_Slice 23941 and then Nkind (Discrete_Range (N1)) = N_Range 23942 and then Nkind (Discrete_Range (N2)) = N_Range 23943 and then Same_Value (Low_Bound (Discrete_Range (N1)), 23944 Low_Bound (Discrete_Range (N2))) 23945 and then Same_Value (High_Bound (Discrete_Range (N1)), 23946 High_Bound (Discrete_Range (N2))) 23947 then 23948 return Same_Name (Prefix (N1), Prefix (N2)); 23949 23950 -- All other cases, not clearly the same object 23951 23952 else 23953 return False; 23954 end if; 23955 end Same_Object; 23956 23957 --------------- 23958 -- Same_Type -- 23959 --------------- 23960 23961 function Same_Type (T1, T2 : Entity_Id) return Boolean is 23962 begin 23963 if T1 = T2 then 23964 return True; 23965 23966 elsif not Is_Constrained (T1) 23967 and then not Is_Constrained (T2) 23968 and then Base_Type (T1) = Base_Type (T2) 23969 then 23970 return True; 23971 23972 -- For now don't bother with case of identical constraints, to be 23973 -- fiddled with later on perhaps (this is only used for optimization 23974 -- purposes, so it is not critical to do a best possible job) 23975 23976 else 23977 return False; 23978 end if; 23979 end Same_Type; 23980 23981 ---------------- 23982 -- Same_Value -- 23983 ---------------- 23984 23985 function Same_Value (Node1, Node2 : Node_Id) return Boolean is 23986 begin 23987 if Compile_Time_Known_Value (Node1) 23988 and then Compile_Time_Known_Value (Node2) 23989 then 23990 -- Handle properly compile-time expressions that are not 23991 -- scalar. 23992 23993 if Is_String_Type (Etype (Node1)) then 23994 return Expr_Value_S (Node1) = Expr_Value_S (Node2); 23995 23996 else 23997 return Expr_Value (Node1) = Expr_Value (Node2); 23998 end if; 23999 24000 elsif Same_Object (Node1, Node2) then 24001 return True; 24002 else 24003 return False; 24004 end if; 24005 end Same_Value; 24006 24007 -------------------- 24008 -- Set_SPARK_Mode -- 24009 -------------------- 24010 24011 procedure Set_SPARK_Mode (Context : Entity_Id) is 24012 begin 24013 -- Do not consider illegal or partially decorated constructs 24014 24015 if Ekind (Context) = E_Void or else Error_Posted (Context) then 24016 null; 24017 24018 elsif Present (SPARK_Pragma (Context)) then 24019 Install_SPARK_Mode 24020 (Mode => Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Context)), 24021 Prag => SPARK_Pragma (Context)); 24022 end if; 24023 end Set_SPARK_Mode; 24024 24025 ------------------------- 24026 -- Scalar_Part_Present -- 24027 ------------------------- 24028 24029 function Scalar_Part_Present (Typ : Entity_Id) return Boolean is 24030 Val_Typ : constant Entity_Id := Validated_View (Typ); 24031 Field : Entity_Id; 24032 24033 begin 24034 if Is_Scalar_Type (Val_Typ) then 24035 return True; 24036 24037 elsif Is_Array_Type (Val_Typ) then 24038 return Scalar_Part_Present (Component_Type (Val_Typ)); 24039 24040 elsif Is_Record_Type (Val_Typ) then 24041 Field := First_Component_Or_Discriminant (Val_Typ); 24042 while Present (Field) loop 24043 if Scalar_Part_Present (Etype (Field)) then 24044 return True; 24045 end if; 24046 24047 Next_Component_Or_Discriminant (Field); 24048 end loop; 24049 end if; 24050 24051 return False; 24052 end Scalar_Part_Present; 24053 24054 ------------------------ 24055 -- Scope_Is_Transient -- 24056 ------------------------ 24057 24058 function Scope_Is_Transient return Boolean is 24059 begin 24060 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient; 24061 end Scope_Is_Transient; 24062 24063 ------------------ 24064 -- Scope_Within -- 24065 ------------------ 24066 24067 function Scope_Within 24068 (Inner : Entity_Id; 24069 Outer : Entity_Id) return Boolean 24070 is 24071 Curr : Entity_Id; 24072 24073 begin 24074 Curr := Inner; 24075 while Present (Curr) and then Curr /= Standard_Standard loop 24076 Curr := Scope (Curr); 24077 24078 if Curr = Outer then 24079 return True; 24080 24081 -- A selective accept body appears within a task type, but the 24082 -- enclosing subprogram is the procedure of the task body. 24083 24084 elsif Ekind (Curr) = E_Task_Type 24085 and then Outer = Task_Body_Procedure (Curr) 24086 then 24087 return True; 24088 24089 -- Ditto for the body of a protected operation 24090 24091 elsif Is_Subprogram (Curr) 24092 and then Outer = Protected_Body_Subprogram (Curr) 24093 then 24094 return True; 24095 24096 -- Outside of its scope, a synchronized type may just be private 24097 24098 elsif Is_Private_Type (Curr) 24099 and then Present (Full_View (Curr)) 24100 and then Is_Concurrent_Type (Full_View (Curr)) 24101 then 24102 return Scope_Within (Full_View (Curr), Outer); 24103 end if; 24104 end loop; 24105 24106 return False; 24107 end Scope_Within; 24108 24109 -------------------------- 24110 -- Scope_Within_Or_Same -- 24111 -------------------------- 24112 24113 function Scope_Within_Or_Same 24114 (Inner : Entity_Id; 24115 Outer : Entity_Id) return Boolean 24116 is 24117 Curr : Entity_Id; 24118 24119 begin 24120 Curr := Inner; 24121 while Present (Curr) and then Curr /= Standard_Standard loop 24122 if Curr = Outer then 24123 return True; 24124 end if; 24125 24126 Curr := Scope (Curr); 24127 end loop; 24128 24129 return False; 24130 end Scope_Within_Or_Same; 24131 24132 -------------------- 24133 -- Set_Convention -- 24134 -------------------- 24135 24136 procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is 24137 begin 24138 Basic_Set_Convention (E, Val); 24139 24140 if Is_Type (E) 24141 and then Is_Access_Subprogram_Type (Base_Type (E)) 24142 and then Has_Foreign_Convention (E) 24143 then 24144 Set_Can_Use_Internal_Rep (E, False); 24145 end if; 24146 24147 -- If E is an object, including a component, and the type of E is an 24148 -- anonymous access type with no convention set, then also set the 24149 -- convention of the anonymous access type. We do not do this for 24150 -- anonymous protected types, since protected types always have the 24151 -- default convention. 24152 24153 if Present (Etype (E)) 24154 and then (Is_Object (E) 24155 24156 -- Allow E_Void (happens for pragma Convention appearing 24157 -- in the middle of a record applying to a component) 24158 24159 or else Ekind (E) = E_Void) 24160 then 24161 declare 24162 Typ : constant Entity_Id := Etype (E); 24163 24164 begin 24165 if Ekind_In (Typ, E_Anonymous_Access_Type, 24166 E_Anonymous_Access_Subprogram_Type) 24167 and then not Has_Convention_Pragma (Typ) 24168 then 24169 Basic_Set_Convention (Typ, Val); 24170 Set_Has_Convention_Pragma (Typ); 24171 24172 -- And for the access subprogram type, deal similarly with the 24173 -- designated E_Subprogram_Type, which is always internal. 24174 24175 if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then 24176 declare 24177 Dtype : constant Entity_Id := Designated_Type (Typ); 24178 begin 24179 if Ekind (Dtype) = E_Subprogram_Type 24180 and then not Has_Convention_Pragma (Dtype) 24181 then 24182 Basic_Set_Convention (Dtype, Val); 24183 Set_Has_Convention_Pragma (Dtype); 24184 end if; 24185 end; 24186 end if; 24187 end if; 24188 end; 24189 end if; 24190 end Set_Convention; 24191 24192 ------------------------ 24193 -- Set_Current_Entity -- 24194 ------------------------ 24195 24196 -- The given entity is to be set as the currently visible definition of its 24197 -- associated name (i.e. the Node_Id associated with its name). All we have 24198 -- to do is to get the name from the identifier, and then set the 24199 -- associated Node_Id to point to the given entity. 24200 24201 procedure Set_Current_Entity (E : Entity_Id) is 24202 begin 24203 Set_Name_Entity_Id (Chars (E), E); 24204 end Set_Current_Entity; 24205 24206 --------------------------- 24207 -- Set_Debug_Info_Needed -- 24208 --------------------------- 24209 24210 procedure Set_Debug_Info_Needed (T : Entity_Id) is 24211 24212 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id); 24213 pragma Inline (Set_Debug_Info_Needed_If_Not_Set); 24214 -- Used to set debug info in a related node if not set already 24215 24216 -------------------------------------- 24217 -- Set_Debug_Info_Needed_If_Not_Set -- 24218 -------------------------------------- 24219 24220 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is 24221 begin 24222 if Present (E) and then not Needs_Debug_Info (E) then 24223 Set_Debug_Info_Needed (E); 24224 24225 -- For a private type, indicate that the full view also needs 24226 -- debug information. 24227 24228 if Is_Type (E) 24229 and then Is_Private_Type (E) 24230 and then Present (Full_View (E)) 24231 then 24232 Set_Debug_Info_Needed (Full_View (E)); 24233 end if; 24234 end if; 24235 end Set_Debug_Info_Needed_If_Not_Set; 24236 24237 -- Start of processing for Set_Debug_Info_Needed 24238 24239 begin 24240 -- Nothing to do if there is no available entity 24241 24242 if No (T) then 24243 return; 24244 24245 -- Nothing to do for an entity with suppressed debug information 24246 24247 elsif Debug_Info_Off (T) then 24248 return; 24249 24250 -- Nothing to do for an ignored Ghost entity because the entity will be 24251 -- eliminated from the tree. 24252 24253 elsif Is_Ignored_Ghost_Entity (T) then 24254 return; 24255 24256 -- Nothing to do if entity comes from a predefined file. Library files 24257 -- are compiled without debug information, but inlined bodies of these 24258 -- routines may appear in user code, and debug information on them ends 24259 -- up complicating debugging the user code. 24260 24261 elsif In_Inlined_Body and then In_Predefined_Unit (T) then 24262 Set_Needs_Debug_Info (T, False); 24263 end if; 24264 24265 -- Set flag in entity itself. Note that we will go through the following 24266 -- circuitry even if the flag is already set on T. That's intentional, 24267 -- it makes sure that the flag will be set in subsidiary entities. 24268 24269 Set_Needs_Debug_Info (T); 24270 24271 -- Set flag on subsidiary entities if not set already 24272 24273 if Is_Object (T) then 24274 Set_Debug_Info_Needed_If_Not_Set (Etype (T)); 24275 24276 elsif Is_Type (T) then 24277 Set_Debug_Info_Needed_If_Not_Set (Etype (T)); 24278 24279 if Is_Record_Type (T) then 24280 declare 24281 Ent : Entity_Id := First_Entity (T); 24282 begin 24283 while Present (Ent) loop 24284 Set_Debug_Info_Needed_If_Not_Set (Ent); 24285 Next_Entity (Ent); 24286 end loop; 24287 end; 24288 24289 -- For a class wide subtype, we also need debug information 24290 -- for the equivalent type. 24291 24292 if Ekind (T) = E_Class_Wide_Subtype then 24293 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T)); 24294 end if; 24295 24296 elsif Is_Array_Type (T) then 24297 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T)); 24298 24299 declare 24300 Indx : Node_Id := First_Index (T); 24301 begin 24302 while Present (Indx) loop 24303 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx)); 24304 Indx := Next_Index (Indx); 24305 end loop; 24306 end; 24307 24308 -- For a packed array type, we also need debug information for 24309 -- the type used to represent the packed array. Conversely, we 24310 -- also need it for the former if we need it for the latter. 24311 24312 if Is_Packed (T) then 24313 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Impl_Type (T)); 24314 end if; 24315 24316 if Is_Packed_Array_Impl_Type (T) then 24317 Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T)); 24318 end if; 24319 24320 elsif Is_Access_Type (T) then 24321 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T)); 24322 24323 elsif Is_Private_Type (T) then 24324 declare 24325 FV : constant Entity_Id := Full_View (T); 24326 24327 begin 24328 Set_Debug_Info_Needed_If_Not_Set (FV); 24329 24330 -- If the full view is itself a derived private type, we need 24331 -- debug information on its underlying type. 24332 24333 if Present (FV) 24334 and then Is_Private_Type (FV) 24335 and then Present (Underlying_Full_View (FV)) 24336 then 24337 Set_Needs_Debug_Info (Underlying_Full_View (FV)); 24338 end if; 24339 end; 24340 24341 elsif Is_Protected_Type (T) then 24342 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T)); 24343 24344 elsif Is_Scalar_Type (T) then 24345 24346 -- If the subrange bounds are materialized by dedicated constant 24347 -- objects, also include them in the debug info to make sure the 24348 -- debugger can properly use them. 24349 24350 if Present (Scalar_Range (T)) 24351 and then Nkind (Scalar_Range (T)) = N_Range 24352 then 24353 declare 24354 Low_Bnd : constant Node_Id := Type_Low_Bound (T); 24355 High_Bnd : constant Node_Id := Type_High_Bound (T); 24356 24357 begin 24358 if Is_Entity_Name (Low_Bnd) then 24359 Set_Debug_Info_Needed_If_Not_Set (Entity (Low_Bnd)); 24360 end if; 24361 24362 if Is_Entity_Name (High_Bnd) then 24363 Set_Debug_Info_Needed_If_Not_Set (Entity (High_Bnd)); 24364 end if; 24365 end; 24366 end if; 24367 end if; 24368 end if; 24369 end Set_Debug_Info_Needed; 24370 24371 ---------------------------- 24372 -- Set_Entity_With_Checks -- 24373 ---------------------------- 24374 24375 procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id) is 24376 Val_Actual : Entity_Id; 24377 Nod : Node_Id; 24378 Post_Node : Node_Id; 24379 24380 begin 24381 -- Unconditionally set the entity 24382 24383 Set_Entity (N, Val); 24384 24385 -- The node to post on is the selector in the case of an expanded name, 24386 -- and otherwise the node itself. 24387 24388 if Nkind (N) = N_Expanded_Name then 24389 Post_Node := Selector_Name (N); 24390 else 24391 Post_Node := N; 24392 end if; 24393 24394 -- Check for violation of No_Fixed_IO 24395 24396 if Restriction_Check_Required (No_Fixed_IO) 24397 and then 24398 ((RTU_Loaded (Ada_Text_IO) 24399 and then (Is_RTE (Val, RE_Decimal_IO) 24400 or else 24401 Is_RTE (Val, RE_Fixed_IO))) 24402 24403 or else 24404 (RTU_Loaded (Ada_Wide_Text_IO) 24405 and then (Is_RTE (Val, RO_WT_Decimal_IO) 24406 or else 24407 Is_RTE (Val, RO_WT_Fixed_IO))) 24408 24409 or else 24410 (RTU_Loaded (Ada_Wide_Wide_Text_IO) 24411 and then (Is_RTE (Val, RO_WW_Decimal_IO) 24412 or else 24413 Is_RTE (Val, RO_WW_Fixed_IO)))) 24414 24415 -- A special extra check, don't complain about a reference from within 24416 -- the Ada.Interrupts package itself! 24417 24418 and then not In_Same_Extended_Unit (N, Val) 24419 then 24420 Check_Restriction (No_Fixed_IO, Post_Node); 24421 end if; 24422 24423 -- Remaining checks are only done on source nodes. Note that we test 24424 -- for violation of No_Fixed_IO even on non-source nodes, because the 24425 -- cases for checking violations of this restriction are instantiations 24426 -- where the reference in the instance has Comes_From_Source False. 24427 24428 if not Comes_From_Source (N) then 24429 return; 24430 end if; 24431 24432 -- Check for violation of No_Abort_Statements, which is triggered by 24433 -- call to Ada.Task_Identification.Abort_Task. 24434 24435 if Restriction_Check_Required (No_Abort_Statements) 24436 and then (Is_RTE (Val, RE_Abort_Task)) 24437 24438 -- A special extra check, don't complain about a reference from within 24439 -- the Ada.Task_Identification package itself! 24440 24441 and then not In_Same_Extended_Unit (N, Val) 24442 then 24443 Check_Restriction (No_Abort_Statements, Post_Node); 24444 end if; 24445 24446 if Val = Standard_Long_Long_Integer then 24447 Check_Restriction (No_Long_Long_Integers, Post_Node); 24448 end if; 24449 24450 -- Check for violation of No_Dynamic_Attachment 24451 24452 if Restriction_Check_Required (No_Dynamic_Attachment) 24453 and then RTU_Loaded (Ada_Interrupts) 24454 and then (Is_RTE (Val, RE_Is_Reserved) or else 24455 Is_RTE (Val, RE_Is_Attached) or else 24456 Is_RTE (Val, RE_Current_Handler) or else 24457 Is_RTE (Val, RE_Attach_Handler) or else 24458 Is_RTE (Val, RE_Exchange_Handler) or else 24459 Is_RTE (Val, RE_Detach_Handler) or else 24460 Is_RTE (Val, RE_Reference)) 24461 24462 -- A special extra check, don't complain about a reference from within 24463 -- the Ada.Interrupts package itself! 24464 24465 and then not In_Same_Extended_Unit (N, Val) 24466 then 24467 Check_Restriction (No_Dynamic_Attachment, Post_Node); 24468 end if; 24469 24470 -- Check for No_Implementation_Identifiers 24471 24472 if Restriction_Check_Required (No_Implementation_Identifiers) then 24473 24474 -- We have an implementation defined entity if it is marked as 24475 -- implementation defined, or is defined in a package marked as 24476 -- implementation defined. However, library packages themselves 24477 -- are excluded (we don't want to flag Interfaces itself, just 24478 -- the entities within it). 24479 24480 if (Is_Implementation_Defined (Val) 24481 or else 24482 (Present (Scope (Val)) 24483 and then Is_Implementation_Defined (Scope (Val)))) 24484 and then not (Ekind_In (Val, E_Package, E_Generic_Package) 24485 and then Is_Library_Level_Entity (Val)) 24486 then 24487 Check_Restriction (No_Implementation_Identifiers, Post_Node); 24488 end if; 24489 end if; 24490 24491 -- Do the style check 24492 24493 if Style_Check 24494 and then not Suppress_Style_Checks (Val) 24495 and then not In_Instance 24496 then 24497 if Nkind (N) = N_Identifier then 24498 Nod := N; 24499 elsif Nkind (N) = N_Expanded_Name then 24500 Nod := Selector_Name (N); 24501 else 24502 return; 24503 end if; 24504 24505 -- A special situation arises for derived operations, where we want 24506 -- to do the check against the parent (since the Sloc of the derived 24507 -- operation points to the derived type declaration itself). 24508 24509 Val_Actual := Val; 24510 while not Comes_From_Source (Val_Actual) 24511 and then Nkind (Val_Actual) in N_Entity 24512 and then (Ekind (Val_Actual) = E_Enumeration_Literal 24513 or else Is_Subprogram_Or_Generic_Subprogram (Val_Actual)) 24514 and then Present (Alias (Val_Actual)) 24515 loop 24516 Val_Actual := Alias (Val_Actual); 24517 end loop; 24518 24519 -- Renaming declarations for generic actuals do not come from source, 24520 -- and have a different name from that of the entity they rename, so 24521 -- there is no style check to perform here. 24522 24523 if Chars (Nod) = Chars (Val_Actual) then 24524 Style.Check_Identifier (Nod, Val_Actual); 24525 end if; 24526 end if; 24527 24528 Set_Entity (N, Val); 24529 end Set_Entity_With_Checks; 24530 24531 ------------------------------ 24532 -- Set_Invalid_Scalar_Value -- 24533 ------------------------------ 24534 24535 procedure Set_Invalid_Scalar_Value 24536 (Scal_Typ : Float_Scalar_Id; 24537 Value : Ureal) 24538 is 24539 Slot : Ureal renames Invalid_Floats (Scal_Typ); 24540 24541 begin 24542 -- Detect an attempt to set a different value for the same scalar type 24543 24544 pragma Assert (Slot = No_Ureal); 24545 Slot := Value; 24546 end Set_Invalid_Scalar_Value; 24547 24548 ------------------------------ 24549 -- Set_Invalid_Scalar_Value -- 24550 ------------------------------ 24551 24552 procedure Set_Invalid_Scalar_Value 24553 (Scal_Typ : Integer_Scalar_Id; 24554 Value : Uint) 24555 is 24556 Slot : Uint renames Invalid_Integers (Scal_Typ); 24557 24558 begin 24559 -- Detect an attempt to set a different value for the same scalar type 24560 24561 pragma Assert (Slot = No_Uint); 24562 Slot := Value; 24563 end Set_Invalid_Scalar_Value; 24564 24565 ------------------------ 24566 -- Set_Name_Entity_Id -- 24567 ------------------------ 24568 24569 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is 24570 begin 24571 Set_Name_Table_Int (Id, Int (Val)); 24572 end Set_Name_Entity_Id; 24573 24574 --------------------- 24575 -- Set_Next_Actual -- 24576 --------------------- 24577 24578 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is 24579 begin 24580 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then 24581 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id); 24582 end if; 24583 end Set_Next_Actual; 24584 24585 ---------------------------------- 24586 -- Set_Optimize_Alignment_Flags -- 24587 ---------------------------------- 24588 24589 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is 24590 begin 24591 if Optimize_Alignment = 'S' then 24592 Set_Optimize_Alignment_Space (E); 24593 elsif Optimize_Alignment = 'T' then 24594 Set_Optimize_Alignment_Time (E); 24595 end if; 24596 end Set_Optimize_Alignment_Flags; 24597 24598 ----------------------- 24599 -- Set_Public_Status -- 24600 ----------------------- 24601 24602 procedure Set_Public_Status (Id : Entity_Id) is 24603 S : constant Entity_Id := Current_Scope; 24604 24605 function Within_HSS_Or_If (E : Entity_Id) return Boolean; 24606 -- Determines if E is defined within handled statement sequence or 24607 -- an if statement, returns True if so, False otherwise. 24608 24609 ---------------------- 24610 -- Within_HSS_Or_If -- 24611 ---------------------- 24612 24613 function Within_HSS_Or_If (E : Entity_Id) return Boolean is 24614 N : Node_Id; 24615 begin 24616 N := Declaration_Node (E); 24617 loop 24618 N := Parent (N); 24619 24620 if No (N) then 24621 return False; 24622 24623 elsif Nkind_In (N, N_Handled_Sequence_Of_Statements, 24624 N_If_Statement) 24625 then 24626 return True; 24627 end if; 24628 end loop; 24629 end Within_HSS_Or_If; 24630 24631 -- Start of processing for Set_Public_Status 24632 24633 begin 24634 -- Everything in the scope of Standard is public 24635 24636 if S = Standard_Standard then 24637 Set_Is_Public (Id); 24638 24639 -- Entity is definitely not public if enclosing scope is not public 24640 24641 elsif not Is_Public (S) then 24642 return; 24643 24644 -- An object or function declaration that occurs in a handled sequence 24645 -- of statements or within an if statement is the declaration for a 24646 -- temporary object or local subprogram generated by the expander. It 24647 -- never needs to be made public and furthermore, making it public can 24648 -- cause back end problems. 24649 24650 elsif Nkind_In (Parent (Id), N_Object_Declaration, 24651 N_Function_Specification) 24652 and then Within_HSS_Or_If (Id) 24653 then 24654 return; 24655 24656 -- Entities in public packages or records are public 24657 24658 elsif Ekind (S) = E_Package or Is_Record_Type (S) then 24659 Set_Is_Public (Id); 24660 24661 -- The bounds of an entry family declaration can generate object 24662 -- declarations that are visible to the back-end, e.g. in the 24663 -- the declaration of a composite type that contains tasks. 24664 24665 elsif Is_Concurrent_Type (S) 24666 and then not Has_Completion (S) 24667 and then Nkind (Parent (Id)) = N_Object_Declaration 24668 then 24669 Set_Is_Public (Id); 24670 end if; 24671 end Set_Public_Status; 24672 24673 ----------------------------- 24674 -- Set_Referenced_Modified -- 24675 ----------------------------- 24676 24677 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is 24678 Pref : Node_Id; 24679 24680 begin 24681 -- Deal with indexed or selected component where prefix is modified 24682 24683 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then 24684 Pref := Prefix (N); 24685 24686 -- If prefix is access type, then it is the designated object that is 24687 -- being modified, which means we have no entity to set the flag on. 24688 24689 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then 24690 return; 24691 24692 -- Otherwise chase the prefix 24693 24694 else 24695 Set_Referenced_Modified (Pref, Out_Param); 24696 end if; 24697 24698 -- Otherwise see if we have an entity name (only other case to process) 24699 24700 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 24701 Set_Referenced_As_LHS (Entity (N), not Out_Param); 24702 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param); 24703 end if; 24704 end Set_Referenced_Modified; 24705 24706 ------------------ 24707 -- Set_Rep_Info -- 24708 ------------------ 24709 24710 procedure Set_Rep_Info (T1 : Entity_Id; T2 : Entity_Id) is 24711 begin 24712 Set_Is_Atomic (T1, Is_Atomic (T2)); 24713 Set_Is_Independent (T1, Is_Independent (T2)); 24714 Set_Is_Volatile_Full_Access (T1, Is_Volatile_Full_Access (T2)); 24715 24716 if Is_Base_Type (T1) then 24717 Set_Is_Volatile (T1, Is_Volatile (T2)); 24718 end if; 24719 end Set_Rep_Info; 24720 24721 ---------------------------- 24722 -- Set_Scope_Is_Transient -- 24723 ---------------------------- 24724 24725 procedure Set_Scope_Is_Transient (V : Boolean := True) is 24726 begin 24727 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V; 24728 end Set_Scope_Is_Transient; 24729 24730 ------------------- 24731 -- Set_Size_Info -- 24732 ------------------- 24733 24734 procedure Set_Size_Info (T1, T2 : Entity_Id) is 24735 begin 24736 -- We copy Esize, but not RM_Size, since in general RM_Size is 24737 -- subtype specific and does not get inherited by all subtypes. 24738 24739 Set_Esize (T1, Esize (T2)); 24740 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2)); 24741 24742 if Is_Discrete_Or_Fixed_Point_Type (T1) 24743 and then 24744 Is_Discrete_Or_Fixed_Point_Type (T2) 24745 then 24746 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2)); 24747 end if; 24748 24749 Set_Alignment (T1, Alignment (T2)); 24750 end Set_Size_Info; 24751 24752 ------------------------------ 24753 -- Should_Ignore_Pragma_Par -- 24754 ------------------------------ 24755 24756 function Should_Ignore_Pragma_Par (Prag_Name : Name_Id) return Boolean is 24757 pragma Assert (Compiler_State = Parsing); 24758 -- This one can't work during semantic analysis, because we don't have a 24759 -- correct Current_Source_File. 24760 24761 Result : constant Boolean := 24762 Get_Name_Table_Boolean3 (Prag_Name) 24763 and then not Is_Internal_File_Name 24764 (File_Name (Current_Source_File)); 24765 begin 24766 return Result; 24767 end Should_Ignore_Pragma_Par; 24768 24769 ------------------------------ 24770 -- Should_Ignore_Pragma_Sem -- 24771 ------------------------------ 24772 24773 function Should_Ignore_Pragma_Sem (N : Node_Id) return Boolean is 24774 pragma Assert (Compiler_State = Analyzing); 24775 Prag_Name : constant Name_Id := Pragma_Name (N); 24776 Result : constant Boolean := 24777 Get_Name_Table_Boolean3 (Prag_Name) 24778 and then not In_Internal_Unit (N); 24779 24780 begin 24781 return Result; 24782 end Should_Ignore_Pragma_Sem; 24783 24784 -------------------- 24785 -- Static_Boolean -- 24786 -------------------- 24787 24788 function Static_Boolean (N : Node_Id) return Uint is 24789 begin 24790 Analyze_And_Resolve (N, Standard_Boolean); 24791 24792 if N = Error 24793 or else Error_Posted (N) 24794 or else Etype (N) = Any_Type 24795 then 24796 return No_Uint; 24797 end if; 24798 24799 if Is_OK_Static_Expression (N) then 24800 if not Raises_Constraint_Error (N) then 24801 return Expr_Value (N); 24802 else 24803 return No_Uint; 24804 end if; 24805 24806 elsif Etype (N) = Any_Type then 24807 return No_Uint; 24808 24809 else 24810 Flag_Non_Static_Expr 24811 ("static boolean expression required here", N); 24812 return No_Uint; 24813 end if; 24814 end Static_Boolean; 24815 24816 -------------------- 24817 -- Static_Integer -- 24818 -------------------- 24819 24820 function Static_Integer (N : Node_Id) return Uint is 24821 begin 24822 Analyze_And_Resolve (N, Any_Integer); 24823 24824 if N = Error 24825 or else Error_Posted (N) 24826 or else Etype (N) = Any_Type 24827 then 24828 return No_Uint; 24829 end if; 24830 24831 if Is_OK_Static_Expression (N) then 24832 if not Raises_Constraint_Error (N) then 24833 return Expr_Value (N); 24834 else 24835 return No_Uint; 24836 end if; 24837 24838 elsif Etype (N) = Any_Type then 24839 return No_Uint; 24840 24841 else 24842 Flag_Non_Static_Expr 24843 ("static integer expression required here", N); 24844 return No_Uint; 24845 end if; 24846 end Static_Integer; 24847 24848 -------------------------- 24849 -- Statically_Different -- 24850 -------------------------- 24851 24852 function Statically_Different (E1, E2 : Node_Id) return Boolean is 24853 R1 : constant Node_Id := Get_Referenced_Object (E1); 24854 R2 : constant Node_Id := Get_Referenced_Object (E2); 24855 begin 24856 return Is_Entity_Name (R1) 24857 and then Is_Entity_Name (R2) 24858 and then Entity (R1) /= Entity (R2) 24859 and then not Is_Formal (Entity (R1)) 24860 and then not Is_Formal (Entity (R2)); 24861 end Statically_Different; 24862 24863 -------------------------------------- 24864 -- Subject_To_Loop_Entry_Attributes -- 24865 -------------------------------------- 24866 24867 function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is 24868 Stmt : Node_Id; 24869 24870 begin 24871 Stmt := N; 24872 24873 -- The expansion mechanism transform a loop subject to at least one 24874 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack 24875 -- the conditional part. 24876 24877 if Nkind_In (Stmt, N_Block_Statement, N_If_Statement) 24878 and then Nkind (Original_Node (N)) = N_Loop_Statement 24879 then 24880 Stmt := Original_Node (N); 24881 end if; 24882 24883 return 24884 Nkind (Stmt) = N_Loop_Statement 24885 and then Present (Identifier (Stmt)) 24886 and then Present (Entity (Identifier (Stmt))) 24887 and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt))); 24888 end Subject_To_Loop_Entry_Attributes; 24889 24890 ----------------------------- 24891 -- Subprogram_Access_Level -- 24892 ----------------------------- 24893 24894 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is 24895 begin 24896 if Present (Alias (Subp)) then 24897 return Subprogram_Access_Level (Alias (Subp)); 24898 else 24899 return Scope_Depth (Enclosing_Dynamic_Scope (Subp)); 24900 end if; 24901 end Subprogram_Access_Level; 24902 24903 --------------------- 24904 -- Subprogram_Name -- 24905 --------------------- 24906 24907 function Subprogram_Name (N : Node_Id) return String is 24908 Buf : Bounded_String; 24909 Ent : Node_Id := N; 24910 Nod : Node_Id; 24911 24912 begin 24913 while Present (Ent) loop 24914 case Nkind (Ent) is 24915 when N_Subprogram_Body => 24916 Ent := Defining_Unit_Name (Specification (Ent)); 24917 exit; 24918 24919 when N_Subprogram_Declaration => 24920 Nod := Corresponding_Body (Ent); 24921 24922 if Present (Nod) then 24923 Ent := Nod; 24924 else 24925 Ent := Defining_Unit_Name (Specification (Ent)); 24926 end if; 24927 24928 exit; 24929 24930 when N_Subprogram_Instantiation 24931 | N_Package_Body 24932 | N_Package_Specification 24933 => 24934 Ent := Defining_Unit_Name (Ent); 24935 exit; 24936 24937 when N_Protected_Type_Declaration => 24938 Ent := Corresponding_Body (Ent); 24939 exit; 24940 24941 when N_Protected_Body 24942 | N_Task_Body 24943 => 24944 Ent := Defining_Identifier (Ent); 24945 exit; 24946 24947 when others => 24948 null; 24949 end case; 24950 24951 Ent := Parent (Ent); 24952 end loop; 24953 24954 if No (Ent) then 24955 return "unknown subprogram:unknown file:0:0"; 24956 end if; 24957 24958 -- If the subprogram is a child unit, use its simple name to start the 24959 -- construction of the fully qualified name. 24960 24961 if Nkind (Ent) = N_Defining_Program_Unit_Name then 24962 Ent := Defining_Identifier (Ent); 24963 end if; 24964 24965 Append_Entity_Name (Buf, Ent); 24966 24967 -- Append homonym number if needed 24968 24969 if Nkind (N) in N_Entity and then Has_Homonym (N) then 24970 declare 24971 H : Entity_Id := Homonym (N); 24972 Nr : Nat := 1; 24973 24974 begin 24975 while Present (H) loop 24976 if Scope (H) = Scope (N) then 24977 Nr := Nr + 1; 24978 end if; 24979 24980 H := Homonym (H); 24981 end loop; 24982 24983 if Nr > 1 then 24984 Append (Buf, '#'); 24985 Append (Buf, Nr); 24986 end if; 24987 end; 24988 end if; 24989 24990 -- Append source location of Ent to Buf so that the string will 24991 -- look like "subp:file:line:col". 24992 24993 declare 24994 Loc : constant Source_Ptr := Sloc (Ent); 24995 begin 24996 Append (Buf, ':'); 24997 Append (Buf, Reference_Name (Get_Source_File_Index (Loc))); 24998 Append (Buf, ':'); 24999 Append (Buf, Nat (Get_Logical_Line_Number (Loc))); 25000 Append (Buf, ':'); 25001 Append (Buf, Nat (Get_Column_Number (Loc))); 25002 end; 25003 25004 return +Buf; 25005 end Subprogram_Name; 25006 25007 ------------------------------- 25008 -- Support_Atomic_Primitives -- 25009 ------------------------------- 25010 25011 function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is 25012 Size : Int; 25013 25014 begin 25015 -- Verify the alignment of Typ is known 25016 25017 if not Known_Alignment (Typ) then 25018 return False; 25019 end if; 25020 25021 if Known_Static_Esize (Typ) then 25022 Size := UI_To_Int (Esize (Typ)); 25023 25024 -- If the Esize (Object_Size) is unknown at compile time, look at the 25025 -- RM_Size (Value_Size) which may have been set by an explicit rep item. 25026 25027 elsif Known_Static_RM_Size (Typ) then 25028 Size := UI_To_Int (RM_Size (Typ)); 25029 25030 -- Otherwise, the size is considered to be unknown. 25031 25032 else 25033 return False; 25034 end if; 25035 25036 -- Check that the size of the component is 8, 16, 32, or 64 bits and 25037 -- that Typ is properly aligned. 25038 25039 case Size is 25040 when 8 | 16 | 32 | 64 => 25041 return Size = UI_To_Int (Alignment (Typ)) * 8; 25042 25043 when others => 25044 return False; 25045 end case; 25046 end Support_Atomic_Primitives; 25047 25048 ----------------- 25049 -- Trace_Scope -- 25050 ----------------- 25051 25052 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is 25053 begin 25054 if Debug_Flag_W then 25055 for J in 0 .. Scope_Stack.Last loop 25056 Write_Str (" "); 25057 end loop; 25058 25059 Write_Str (Msg); 25060 Write_Name (Chars (E)); 25061 Write_Str (" from "); 25062 Write_Location (Sloc (N)); 25063 Write_Eol; 25064 end if; 25065 end Trace_Scope; 25066 25067 ----------------------- 25068 -- Transfer_Entities -- 25069 ----------------------- 25070 25071 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is 25072 procedure Set_Public_Status_Of (Id : Entity_Id); 25073 -- Set the Is_Public attribute of arbitrary entity Id by calling routine 25074 -- Set_Public_Status. If successful and Id denotes a record type, set 25075 -- the Is_Public attribute of its fields. 25076 25077 -------------------------- 25078 -- Set_Public_Status_Of -- 25079 -------------------------- 25080 25081 procedure Set_Public_Status_Of (Id : Entity_Id) is 25082 Field : Entity_Id; 25083 25084 begin 25085 if not Is_Public (Id) then 25086 Set_Public_Status (Id); 25087 25088 -- When the input entity is a public record type, ensure that all 25089 -- its internal fields are also exposed to the linker. The fields 25090 -- of a class-wide type are never made public. 25091 25092 if Is_Public (Id) 25093 and then Is_Record_Type (Id) 25094 and then not Is_Class_Wide_Type (Id) 25095 then 25096 Field := First_Entity (Id); 25097 while Present (Field) loop 25098 Set_Is_Public (Field); 25099 Next_Entity (Field); 25100 end loop; 25101 end if; 25102 end if; 25103 end Set_Public_Status_Of; 25104 25105 -- Local variables 25106 25107 Full_Id : Entity_Id; 25108 Id : Entity_Id; 25109 25110 -- Start of processing for Transfer_Entities 25111 25112 begin 25113 Id := First_Entity (From); 25114 25115 if Present (Id) then 25116 25117 -- Merge the entity chain of the source scope with that of the 25118 -- destination scope. 25119 25120 if Present (Last_Entity (To)) then 25121 Link_Entities (Last_Entity (To), Id); 25122 else 25123 Set_First_Entity (To, Id); 25124 end if; 25125 25126 Set_Last_Entity (To, Last_Entity (From)); 25127 25128 -- Inspect the entities of the source scope and update their Scope 25129 -- attribute. 25130 25131 while Present (Id) loop 25132 Set_Scope (Id, To); 25133 Set_Public_Status_Of (Id); 25134 25135 -- Handle an internally generated full view for a private type 25136 25137 if Is_Private_Type (Id) 25138 and then Present (Full_View (Id)) 25139 and then Is_Itype (Full_View (Id)) 25140 then 25141 Full_Id := Full_View (Id); 25142 25143 Set_Scope (Full_Id, To); 25144 Set_Public_Status_Of (Full_Id); 25145 end if; 25146 25147 Next_Entity (Id); 25148 end loop; 25149 25150 Set_First_Entity (From, Empty); 25151 Set_Last_Entity (From, Empty); 25152 end if; 25153 end Transfer_Entities; 25154 25155 ----------------------- 25156 -- Type_Access_Level -- 25157 ----------------------- 25158 25159 function Type_Access_Level (Typ : Entity_Id) return Uint is 25160 Btyp : Entity_Id; 25161 25162 begin 25163 Btyp := Base_Type (Typ); 25164 25165 -- Ada 2005 (AI-230): For most cases of anonymous access types, we 25166 -- simply use the level where the type is declared. This is true for 25167 -- stand-alone object declarations, and for anonymous access types 25168 -- associated with components the level is the same as that of the 25169 -- enclosing composite type. However, special treatment is needed for 25170 -- the cases of access parameters, return objects of an anonymous access 25171 -- type, and, in Ada 95, access discriminants of limited types. 25172 25173 if Is_Access_Type (Btyp) then 25174 if Ekind (Btyp) = E_Anonymous_Access_Type then 25175 25176 -- If the type is a nonlocal anonymous access type (such as for 25177 -- an access parameter) we treat it as being declared at the 25178 -- library level to ensure that names such as X.all'access don't 25179 -- fail static accessibility checks. 25180 25181 if not Is_Local_Anonymous_Access (Typ) then 25182 return Scope_Depth (Standard_Standard); 25183 25184 -- If this is a return object, the accessibility level is that of 25185 -- the result subtype of the enclosing function. The test here is 25186 -- little complicated, because we have to account for extended 25187 -- return statements that have been rewritten as blocks, in which 25188 -- case we have to find and the Is_Return_Object attribute of the 25189 -- itype's associated object. It would be nice to find a way to 25190 -- simplify this test, but it doesn't seem worthwhile to add a new 25191 -- flag just for purposes of this test. ??? 25192 25193 elsif Ekind (Scope (Btyp)) = E_Return_Statement 25194 or else 25195 (Is_Itype (Btyp) 25196 and then Nkind (Associated_Node_For_Itype (Btyp)) = 25197 N_Object_Declaration 25198 and then Is_Return_Object 25199 (Defining_Identifier 25200 (Associated_Node_For_Itype (Btyp)))) 25201 then 25202 declare 25203 Scop : Entity_Id; 25204 25205 begin 25206 Scop := Scope (Scope (Btyp)); 25207 while Present (Scop) loop 25208 exit when Ekind (Scop) = E_Function; 25209 Scop := Scope (Scop); 25210 end loop; 25211 25212 -- Treat the return object's type as having the level of the 25213 -- function's result subtype (as per RM05-6.5(5.3/2)). 25214 25215 return Type_Access_Level (Etype (Scop)); 25216 end; 25217 end if; 25218 end if; 25219 25220 Btyp := Root_Type (Btyp); 25221 25222 -- The accessibility level of anonymous access types associated with 25223 -- discriminants is that of the current instance of the type, and 25224 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)). 25225 25226 -- AI-402: access discriminants have accessibility based on the 25227 -- object rather than the type in Ada 2005, so the above paragraph 25228 -- doesn't apply. 25229 25230 -- ??? Needs completion with rules from AI-416 25231 25232 if Ada_Version <= Ada_95 25233 and then Ekind (Typ) = E_Anonymous_Access_Type 25234 and then Present (Associated_Node_For_Itype (Typ)) 25235 and then Nkind (Associated_Node_For_Itype (Typ)) = 25236 N_Discriminant_Specification 25237 then 25238 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1; 25239 end if; 25240 end if; 25241 25242 -- Return library level for a generic formal type. This is done because 25243 -- RM(10.3.2) says that "The statically deeper relationship does not 25244 -- apply to ... a descendant of a generic formal type". Rather than 25245 -- checking at each point where a static accessibility check is 25246 -- performed to see if we are dealing with a formal type, this rule is 25247 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level 25248 -- return extreme values for a formal type; Deepest_Type_Access_Level 25249 -- returns Int'Last. By calling the appropriate function from among the 25250 -- two, we ensure that the static accessibility check will pass if we 25251 -- happen to run into a formal type. More specifically, we should call 25252 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the 25253 -- call occurs as part of a static accessibility check and the error 25254 -- case is the case where the type's level is too shallow (as opposed 25255 -- to too deep). 25256 25257 if Is_Generic_Type (Root_Type (Btyp)) then 25258 return Scope_Depth (Standard_Standard); 25259 end if; 25260 25261 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); 25262 end Type_Access_Level; 25263 25264 ------------------------------------ 25265 -- Type_Without_Stream_Operation -- 25266 ------------------------------------ 25267 25268 function Type_Without_Stream_Operation 25269 (T : Entity_Id; 25270 Op : TSS_Name_Type := TSS_Null) return Entity_Id 25271 is 25272 BT : constant Entity_Id := Base_Type (T); 25273 Op_Missing : Boolean; 25274 25275 begin 25276 if not Restriction_Active (No_Default_Stream_Attributes) then 25277 return Empty; 25278 end if; 25279 25280 if Is_Elementary_Type (T) then 25281 if Op = TSS_Null then 25282 Op_Missing := 25283 No (TSS (BT, TSS_Stream_Read)) 25284 or else No (TSS (BT, TSS_Stream_Write)); 25285 25286 else 25287 Op_Missing := No (TSS (BT, Op)); 25288 end if; 25289 25290 if Op_Missing then 25291 return T; 25292 else 25293 return Empty; 25294 end if; 25295 25296 elsif Is_Array_Type (T) then 25297 return Type_Without_Stream_Operation (Component_Type (T), Op); 25298 25299 elsif Is_Record_Type (T) then 25300 declare 25301 Comp : Entity_Id; 25302 C_Typ : Entity_Id; 25303 25304 begin 25305 Comp := First_Component (T); 25306 while Present (Comp) loop 25307 C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op); 25308 25309 if Present (C_Typ) then 25310 return C_Typ; 25311 end if; 25312 25313 Next_Component (Comp); 25314 end loop; 25315 25316 return Empty; 25317 end; 25318 25319 elsif Is_Private_Type (T) and then Present (Full_View (T)) then 25320 return Type_Without_Stream_Operation (Full_View (T), Op); 25321 else 25322 return Empty; 25323 end if; 25324 end Type_Without_Stream_Operation; 25325 25326 --------------------- 25327 -- Ultimate_Prefix -- 25328 --------------------- 25329 25330 function Ultimate_Prefix (N : Node_Id) return Node_Id is 25331 Pref : Node_Id; 25332 25333 begin 25334 Pref := N; 25335 while Nkind_In (Pref, N_Explicit_Dereference, 25336 N_Indexed_Component, 25337 N_Selected_Component, 25338 N_Slice) 25339 loop 25340 Pref := Prefix (Pref); 25341 end loop; 25342 25343 return Pref; 25344 end Ultimate_Prefix; 25345 25346 ---------------------------- 25347 -- Unique_Defining_Entity -- 25348 ---------------------------- 25349 25350 function Unique_Defining_Entity (N : Node_Id) return Entity_Id is 25351 begin 25352 return Unique_Entity (Defining_Entity (N)); 25353 end Unique_Defining_Entity; 25354 25355 ------------------- 25356 -- Unique_Entity -- 25357 ------------------- 25358 25359 function Unique_Entity (E : Entity_Id) return Entity_Id is 25360 U : Entity_Id := E; 25361 P : Node_Id; 25362 25363 begin 25364 case Ekind (E) is 25365 when E_Constant => 25366 if Present (Full_View (E)) then 25367 U := Full_View (E); 25368 end if; 25369 25370 when Entry_Kind => 25371 if Nkind (Parent (E)) = N_Entry_Body then 25372 declare 25373 Prot_Item : Entity_Id; 25374 Prot_Type : Entity_Id; 25375 25376 begin 25377 if Ekind (E) = E_Entry then 25378 Prot_Type := Scope (E); 25379 25380 -- Bodies of entry families are nested within an extra scope 25381 -- that contains an entry index declaration. 25382 25383 else 25384 Prot_Type := Scope (Scope (E)); 25385 end if; 25386 25387 -- A protected type may be declared as a private type, in 25388 -- which case we need to get its full view. 25389 25390 if Is_Private_Type (Prot_Type) then 25391 Prot_Type := Full_View (Prot_Type); 25392 end if; 25393 25394 -- Full view may not be present on error, in which case 25395 -- return E by default. 25396 25397 if Present (Prot_Type) then 25398 pragma Assert (Ekind (Prot_Type) = E_Protected_Type); 25399 25400 -- Traverse the entity list of the protected type and 25401 -- locate an entry declaration which matches the entry 25402 -- body. 25403 25404 Prot_Item := First_Entity (Prot_Type); 25405 while Present (Prot_Item) loop 25406 if Ekind (Prot_Item) in Entry_Kind 25407 and then Corresponding_Body (Parent (Prot_Item)) = E 25408 then 25409 U := Prot_Item; 25410 exit; 25411 end if; 25412 25413 Next_Entity (Prot_Item); 25414 end loop; 25415 end if; 25416 end; 25417 end if; 25418 25419 when Formal_Kind => 25420 if Present (Spec_Entity (E)) then 25421 U := Spec_Entity (E); 25422 end if; 25423 25424 when E_Package_Body => 25425 P := Parent (E); 25426 25427 if Nkind (P) = N_Defining_Program_Unit_Name then 25428 P := Parent (P); 25429 end if; 25430 25431 if Nkind (P) = N_Package_Body 25432 and then Present (Corresponding_Spec (P)) 25433 then 25434 U := Corresponding_Spec (P); 25435 25436 elsif Nkind (P) = N_Package_Body_Stub 25437 and then Present (Corresponding_Spec_Of_Stub (P)) 25438 then 25439 U := Corresponding_Spec_Of_Stub (P); 25440 end if; 25441 25442 when E_Protected_Body => 25443 P := Parent (E); 25444 25445 if Nkind (P) = N_Protected_Body 25446 and then Present (Corresponding_Spec (P)) 25447 then 25448 U := Corresponding_Spec (P); 25449 25450 elsif Nkind (P) = N_Protected_Body_Stub 25451 and then Present (Corresponding_Spec_Of_Stub (P)) 25452 then 25453 U := Corresponding_Spec_Of_Stub (P); 25454 25455 if Is_Single_Protected_Object (U) then 25456 U := Etype (U); 25457 end if; 25458 end if; 25459 25460 if Is_Private_Type (U) then 25461 U := Full_View (U); 25462 end if; 25463 25464 when E_Subprogram_Body => 25465 P := Parent (E); 25466 25467 if Nkind (P) = N_Defining_Program_Unit_Name then 25468 P := Parent (P); 25469 end if; 25470 25471 P := Parent (P); 25472 25473 if Nkind (P) = N_Subprogram_Body 25474 and then Present (Corresponding_Spec (P)) 25475 then 25476 U := Corresponding_Spec (P); 25477 25478 elsif Nkind (P) = N_Subprogram_Body_Stub 25479 and then Present (Corresponding_Spec_Of_Stub (P)) 25480 then 25481 U := Corresponding_Spec_Of_Stub (P); 25482 25483 elsif Nkind (P) = N_Subprogram_Renaming_Declaration then 25484 U := Corresponding_Spec (P); 25485 end if; 25486 25487 when E_Task_Body => 25488 P := Parent (E); 25489 25490 if Nkind (P) = N_Task_Body 25491 and then Present (Corresponding_Spec (P)) 25492 then 25493 U := Corresponding_Spec (P); 25494 25495 elsif Nkind (P) = N_Task_Body_Stub 25496 and then Present (Corresponding_Spec_Of_Stub (P)) 25497 then 25498 U := Corresponding_Spec_Of_Stub (P); 25499 25500 if Is_Single_Task_Object (U) then 25501 U := Etype (U); 25502 end if; 25503 end if; 25504 25505 if Is_Private_Type (U) then 25506 U := Full_View (U); 25507 end if; 25508 25509 when Type_Kind => 25510 if Present (Full_View (E)) then 25511 U := Full_View (E); 25512 end if; 25513 25514 when others => 25515 null; 25516 end case; 25517 25518 return U; 25519 end Unique_Entity; 25520 25521 ----------------- 25522 -- Unique_Name -- 25523 ----------------- 25524 25525 function Unique_Name (E : Entity_Id) return String is 25526 25527 -- Names in E_Subprogram_Body or E_Package_Body entities are not 25528 -- reliable, as they may not include the overloading suffix. Instead, 25529 -- when looking for the name of E or one of its enclosing scope, we get 25530 -- the name of the corresponding Unique_Entity. 25531 25532 U : constant Entity_Id := Unique_Entity (E); 25533 25534 function This_Name return String; 25535 25536 --------------- 25537 -- This_Name -- 25538 --------------- 25539 25540 function This_Name return String is 25541 begin 25542 return Get_Name_String (Chars (U)); 25543 end This_Name; 25544 25545 -- Start of processing for Unique_Name 25546 25547 begin 25548 if E = Standard_Standard 25549 or else Has_Fully_Qualified_Name (E) 25550 then 25551 return This_Name; 25552 25553 elsif Ekind (E) = E_Enumeration_Literal then 25554 return Unique_Name (Etype (E)) & "__" & This_Name; 25555 25556 else 25557 declare 25558 S : constant Entity_Id := Scope (U); 25559 pragma Assert (Present (S)); 25560 25561 begin 25562 -- Prefix names of predefined types with standard__, but leave 25563 -- names of user-defined packages and subprograms without prefix 25564 -- (even if technically they are nested in the Standard package). 25565 25566 if S = Standard_Standard then 25567 if Ekind (U) = E_Package or else Is_Subprogram (U) then 25568 return This_Name; 25569 else 25570 return Unique_Name (S) & "__" & This_Name; 25571 end if; 25572 25573 -- For intances of generic subprograms use the name of the related 25574 -- instace and skip the scope of its wrapper package. 25575 25576 elsif Is_Wrapper_Package (S) then 25577 pragma Assert (Scope (S) = Scope (Related_Instance (S))); 25578 -- Wrapper package and the instantiation are in the same scope 25579 25580 declare 25581 Enclosing_Name : constant String := 25582 Unique_Name (Scope (S)) & "__" & 25583 Get_Name_String (Chars (Related_Instance (S))); 25584 25585 begin 25586 if Is_Subprogram (U) 25587 and then not Is_Generic_Actual_Subprogram (U) 25588 then 25589 return Enclosing_Name; 25590 else 25591 return Enclosing_Name & "__" & This_Name; 25592 end if; 25593 end; 25594 25595 else 25596 return Unique_Name (S) & "__" & This_Name; 25597 end if; 25598 end; 25599 end if; 25600 end Unique_Name; 25601 25602 --------------------- 25603 -- Unit_Is_Visible -- 25604 --------------------- 25605 25606 function Unit_Is_Visible (U : Entity_Id) return Boolean is 25607 Curr : constant Node_Id := Cunit (Current_Sem_Unit); 25608 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 25609 25610 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean; 25611 -- For a child unit, check whether unit appears in a with_clause 25612 -- of a parent. 25613 25614 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean; 25615 -- Scan the context clause of one compilation unit looking for a 25616 -- with_clause for the unit in question. 25617 25618 ---------------------------- 25619 -- Unit_In_Parent_Context -- 25620 ---------------------------- 25621 25622 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is 25623 begin 25624 if Unit_In_Context (Par_Unit) then 25625 return True; 25626 25627 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then 25628 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit))); 25629 25630 else 25631 return False; 25632 end if; 25633 end Unit_In_Parent_Context; 25634 25635 --------------------- 25636 -- Unit_In_Context -- 25637 --------------------- 25638 25639 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is 25640 Clause : Node_Id; 25641 25642 begin 25643 Clause := First (Context_Items (Comp_Unit)); 25644 while Present (Clause) loop 25645 if Nkind (Clause) = N_With_Clause then 25646 if Library_Unit (Clause) = U then 25647 return True; 25648 25649 -- The with_clause may denote a renaming of the unit we are 25650 -- looking for, eg. Text_IO which renames Ada.Text_IO. 25651 25652 elsif 25653 Renamed_Entity (Entity (Name (Clause))) = 25654 Defining_Entity (Unit (U)) 25655 then 25656 return True; 25657 end if; 25658 end if; 25659 25660 Next (Clause); 25661 end loop; 25662 25663 return False; 25664 end Unit_In_Context; 25665 25666 -- Start of processing for Unit_Is_Visible 25667 25668 begin 25669 -- The currrent unit is directly visible 25670 25671 if Curr = U then 25672 return True; 25673 25674 elsif Unit_In_Context (Curr) then 25675 return True; 25676 25677 -- If the current unit is a body, check the context of the spec 25678 25679 elsif Nkind (Unit (Curr)) = N_Package_Body 25680 or else 25681 (Nkind (Unit (Curr)) = N_Subprogram_Body 25682 and then not Acts_As_Spec (Unit (Curr))) 25683 then 25684 if Unit_In_Context (Library_Unit (Curr)) then 25685 return True; 25686 end if; 25687 end if; 25688 25689 -- If the spec is a child unit, examine the parents 25690 25691 if Is_Child_Unit (Curr_Entity) then 25692 if Nkind (Unit (Curr)) in N_Unit_Body then 25693 return 25694 Unit_In_Parent_Context 25695 (Parent_Spec (Unit (Library_Unit (Curr)))); 25696 else 25697 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr))); 25698 end if; 25699 25700 else 25701 return False; 25702 end if; 25703 end Unit_Is_Visible; 25704 25705 ------------------------------ 25706 -- Universal_Interpretation -- 25707 ------------------------------ 25708 25709 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is 25710 Index : Interp_Index; 25711 It : Interp; 25712 25713 begin 25714 -- The argument may be a formal parameter of an operator or subprogram 25715 -- with multiple interpretations, or else an expression for an actual. 25716 25717 if Nkind (Opnd) = N_Defining_Identifier 25718 or else not Is_Overloaded (Opnd) 25719 then 25720 if Etype (Opnd) = Universal_Integer 25721 or else Etype (Opnd) = Universal_Real 25722 then 25723 return Etype (Opnd); 25724 else 25725 return Empty; 25726 end if; 25727 25728 else 25729 Get_First_Interp (Opnd, Index, It); 25730 while Present (It.Typ) loop 25731 if It.Typ = Universal_Integer 25732 or else It.Typ = Universal_Real 25733 then 25734 return It.Typ; 25735 end if; 25736 25737 Get_Next_Interp (Index, It); 25738 end loop; 25739 25740 return Empty; 25741 end if; 25742 end Universal_Interpretation; 25743 25744 --------------- 25745 -- Unqualify -- 25746 --------------- 25747 25748 function Unqualify (Expr : Node_Id) return Node_Id is 25749 begin 25750 -- Recurse to handle unlikely case of multiple levels of qualification 25751 25752 if Nkind (Expr) = N_Qualified_Expression then 25753 return Unqualify (Expression (Expr)); 25754 25755 -- Normal case, not a qualified expression 25756 25757 else 25758 return Expr; 25759 end if; 25760 end Unqualify; 25761 25762 ----------------- 25763 -- Unqual_Conv -- 25764 ----------------- 25765 25766 function Unqual_Conv (Expr : Node_Id) return Node_Id is 25767 begin 25768 -- Recurse to handle unlikely case of multiple levels of qualification 25769 -- and/or conversion. 25770 25771 if Nkind_In (Expr, N_Qualified_Expression, 25772 N_Type_Conversion, 25773 N_Unchecked_Type_Conversion) 25774 then 25775 return Unqual_Conv (Expression (Expr)); 25776 25777 -- Normal case, not a qualified expression 25778 25779 else 25780 return Expr; 25781 end if; 25782 end Unqual_Conv; 25783 25784 -------------------- 25785 -- Validated_View -- 25786 -------------------- 25787 25788 function Validated_View (Typ : Entity_Id) return Entity_Id is 25789 Continue : Boolean; 25790 Val_Typ : Entity_Id; 25791 25792 begin 25793 Continue := True; 25794 Val_Typ := Base_Type (Typ); 25795 25796 -- Obtain the full view of the input type by stripping away concurrency, 25797 -- derivations, and privacy. 25798 25799 while Continue loop 25800 Continue := False; 25801 25802 if Is_Concurrent_Type (Val_Typ) then 25803 if Present (Corresponding_Record_Type (Val_Typ)) then 25804 Continue := True; 25805 Val_Typ := Corresponding_Record_Type (Val_Typ); 25806 end if; 25807 25808 elsif Is_Derived_Type (Val_Typ) then 25809 Continue := True; 25810 Val_Typ := Etype (Val_Typ); 25811 25812 elsif Is_Private_Type (Val_Typ) then 25813 if Present (Underlying_Full_View (Val_Typ)) then 25814 Continue := True; 25815 Val_Typ := Underlying_Full_View (Val_Typ); 25816 25817 elsif Present (Full_View (Val_Typ)) then 25818 Continue := True; 25819 Val_Typ := Full_View (Val_Typ); 25820 end if; 25821 end if; 25822 end loop; 25823 25824 return Val_Typ; 25825 end Validated_View; 25826 25827 ----------------------- 25828 -- Visible_Ancestors -- 25829 ----------------------- 25830 25831 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is 25832 List_1 : Elist_Id; 25833 List_2 : Elist_Id; 25834 Elmt : Elmt_Id; 25835 25836 begin 25837 pragma Assert (Is_Record_Type (Typ) and then Is_Tagged_Type (Typ)); 25838 25839 -- Collect all the parents and progenitors of Typ. If the full-view of 25840 -- private parents and progenitors is available then it is used to 25841 -- generate the list of visible ancestors; otherwise their partial 25842 -- view is added to the resulting list. 25843 25844 Collect_Parents 25845 (T => Typ, 25846 List => List_1, 25847 Use_Full_View => True); 25848 25849 Collect_Interfaces 25850 (T => Typ, 25851 Ifaces_List => List_2, 25852 Exclude_Parents => True, 25853 Use_Full_View => True); 25854 25855 -- Join the two lists. Avoid duplications because an interface may 25856 -- simultaneously be parent and progenitor of a type. 25857 25858 Elmt := First_Elmt (List_2); 25859 while Present (Elmt) loop 25860 Append_Unique_Elmt (Node (Elmt), List_1); 25861 Next_Elmt (Elmt); 25862 end loop; 25863 25864 return List_1; 25865 end Visible_Ancestors; 25866 25867 ---------------------- 25868 -- Within_Init_Proc -- 25869 ---------------------- 25870 25871 function Within_Init_Proc return Boolean is 25872 S : Entity_Id; 25873 25874 begin 25875 S := Current_Scope; 25876 while not Is_Overloadable (S) loop 25877 if S = Standard_Standard then 25878 return False; 25879 else 25880 S := Scope (S); 25881 end if; 25882 end loop; 25883 25884 return Is_Init_Proc (S); 25885 end Within_Init_Proc; 25886 25887 --------------------------- 25888 -- Within_Protected_Type -- 25889 --------------------------- 25890 25891 function Within_Protected_Type (E : Entity_Id) return Boolean is 25892 Scop : Entity_Id := Scope (E); 25893 25894 begin 25895 while Present (Scop) loop 25896 if Ekind (Scop) = E_Protected_Type then 25897 return True; 25898 end if; 25899 25900 Scop := Scope (Scop); 25901 end loop; 25902 25903 return False; 25904 end Within_Protected_Type; 25905 25906 ------------------ 25907 -- Within_Scope -- 25908 ------------------ 25909 25910 function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean is 25911 begin 25912 return Scope_Within_Or_Same (Scope (E), S); 25913 end Within_Scope; 25914 25915 ---------------------------- 25916 -- Within_Subprogram_Call -- 25917 ---------------------------- 25918 25919 function Within_Subprogram_Call (N : Node_Id) return Boolean is 25920 Par : Node_Id; 25921 25922 begin 25923 -- Climb the parent chain looking for a function or procedure call 25924 25925 Par := N; 25926 while Present (Par) loop 25927 if Nkind_In (Par, N_Entry_Call_Statement, 25928 N_Function_Call, 25929 N_Procedure_Call_Statement) 25930 then 25931 return True; 25932 25933 -- Prevent the search from going too far 25934 25935 elsif Is_Body_Or_Package_Declaration (Par) then 25936 exit; 25937 end if; 25938 25939 Par := Parent (Par); 25940 end loop; 25941 25942 return False; 25943 end Within_Subprogram_Call; 25944 25945 ---------------- 25946 -- Wrong_Type -- 25947 ---------------- 25948 25949 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is 25950 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr)); 25951 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type); 25952 25953 Matching_Field : Entity_Id; 25954 -- Entity to give a more precise suggestion on how to write a one- 25955 -- element positional aggregate. 25956 25957 function Has_One_Matching_Field return Boolean; 25958 -- Determines if Expec_Type is a record type with a single component or 25959 -- discriminant whose type matches the found type or is one dimensional 25960 -- array whose component type matches the found type. In the case of 25961 -- one discriminant, we ignore the variant parts. That's not accurate, 25962 -- but good enough for the warning. 25963 25964 ---------------------------- 25965 -- Has_One_Matching_Field -- 25966 ---------------------------- 25967 25968 function Has_One_Matching_Field return Boolean is 25969 E : Entity_Id; 25970 25971 begin 25972 Matching_Field := Empty; 25973 25974 if Is_Array_Type (Expec_Type) 25975 and then Number_Dimensions (Expec_Type) = 1 25976 and then Covers (Etype (Component_Type (Expec_Type)), Found_Type) 25977 then 25978 -- Use type name if available. This excludes multidimensional 25979 -- arrays and anonymous arrays. 25980 25981 if Comes_From_Source (Expec_Type) then 25982 Matching_Field := Expec_Type; 25983 25984 -- For an assignment, use name of target 25985 25986 elsif Nkind (Parent (Expr)) = N_Assignment_Statement 25987 and then Is_Entity_Name (Name (Parent (Expr))) 25988 then 25989 Matching_Field := Entity (Name (Parent (Expr))); 25990 end if; 25991 25992 return True; 25993 25994 elsif not Is_Record_Type (Expec_Type) then 25995 return False; 25996 25997 else 25998 E := First_Entity (Expec_Type); 25999 loop 26000 if No (E) then 26001 return False; 26002 26003 elsif not Ekind_In (E, E_Discriminant, E_Component) 26004 or else Nam_In (Chars (E), Name_uTag, Name_uParent) 26005 then 26006 Next_Entity (E); 26007 26008 else 26009 exit; 26010 end if; 26011 end loop; 26012 26013 if not Covers (Etype (E), Found_Type) then 26014 return False; 26015 26016 elsif Present (Next_Entity (E)) 26017 and then (Ekind (E) = E_Component 26018 or else Ekind (Next_Entity (E)) = E_Discriminant) 26019 then 26020 return False; 26021 26022 else 26023 Matching_Field := E; 26024 return True; 26025 end if; 26026 end if; 26027 end Has_One_Matching_Field; 26028 26029 -- Start of processing for Wrong_Type 26030 26031 begin 26032 -- Don't output message if either type is Any_Type, or if a message 26033 -- has already been posted for this node. We need to do the latter 26034 -- check explicitly (it is ordinarily done in Errout), because we 26035 -- are using ! to force the output of the error messages. 26036 26037 if Expec_Type = Any_Type 26038 or else Found_Type = Any_Type 26039 or else Error_Posted (Expr) 26040 then 26041 return; 26042 26043 -- If one of the types is a Taft-Amendment type and the other it its 26044 -- completion, it must be an illegal use of a TAT in the spec, for 26045 -- which an error was already emitted. Avoid cascaded errors. 26046 26047 elsif Is_Incomplete_Type (Expec_Type) 26048 and then Has_Completion_In_Body (Expec_Type) 26049 and then Full_View (Expec_Type) = Etype (Expr) 26050 then 26051 return; 26052 26053 elsif Is_Incomplete_Type (Etype (Expr)) 26054 and then Has_Completion_In_Body (Etype (Expr)) 26055 and then Full_View (Etype (Expr)) = Expec_Type 26056 then 26057 return; 26058 26059 -- In an instance, there is an ongoing problem with completion of 26060 -- type derived from private types. Their structure is what Gigi 26061 -- expects, but the Etype is the parent type rather than the 26062 -- derived private type itself. Do not flag error in this case. The 26063 -- private completion is an entity without a parent, like an Itype. 26064 -- Similarly, full and partial views may be incorrect in the instance. 26065 -- There is no simple way to insure that it is consistent ??? 26066 26067 -- A similar view discrepancy can happen in an inlined body, for the 26068 -- same reason: inserted body may be outside of the original package 26069 -- and only partial views are visible at the point of insertion. 26070 26071 elsif In_Instance or else In_Inlined_Body then 26072 if Etype (Etype (Expr)) = Etype (Expected_Type) 26073 and then 26074 (Has_Private_Declaration (Expected_Type) 26075 or else Has_Private_Declaration (Etype (Expr))) 26076 and then No (Parent (Expected_Type)) 26077 then 26078 return; 26079 26080 elsif Nkind (Parent (Expr)) = N_Qualified_Expression 26081 and then Entity (Subtype_Mark (Parent (Expr))) = Expected_Type 26082 then 26083 return; 26084 26085 elsif Is_Private_Type (Expected_Type) 26086 and then Present (Full_View (Expected_Type)) 26087 and then Covers (Full_View (Expected_Type), Etype (Expr)) 26088 then 26089 return; 26090 26091 -- Conversely, type of expression may be the private one 26092 26093 elsif Is_Private_Type (Base_Type (Etype (Expr))) 26094 and then Full_View (Base_Type (Etype (Expr))) = Expected_Type 26095 then 26096 return; 26097 end if; 26098 end if; 26099 26100 -- An interesting special check. If the expression is parenthesized 26101 -- and its type corresponds to the type of the sole component of the 26102 -- expected record type, or to the component type of the expected one 26103 -- dimensional array type, then assume we have a bad aggregate attempt. 26104 26105 if Nkind (Expr) in N_Subexpr 26106 and then Paren_Count (Expr) /= 0 26107 and then Has_One_Matching_Field 26108 then 26109 Error_Msg_N ("positional aggregate cannot have one component", Expr); 26110 26111 if Present (Matching_Field) then 26112 if Is_Array_Type (Expec_Type) then 26113 Error_Msg_NE 26114 ("\write instead `&''First ='> ...`", Expr, Matching_Field); 26115 else 26116 Error_Msg_NE 26117 ("\write instead `& ='> ...`", Expr, Matching_Field); 26118 end if; 26119 end if; 26120 26121 -- Another special check, if we are looking for a pool-specific access 26122 -- type and we found an E_Access_Attribute_Type, then we have the case 26123 -- of an Access attribute being used in a context which needs a pool- 26124 -- specific type, which is never allowed. The one extra check we make 26125 -- is that the expected designated type covers the Found_Type. 26126 26127 elsif Is_Access_Type (Expec_Type) 26128 and then Ekind (Found_Type) = E_Access_Attribute_Type 26129 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type 26130 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type 26131 and then Covers 26132 (Designated_Type (Expec_Type), Designated_Type (Found_Type)) 26133 then 26134 Error_Msg_N -- CODEFIX 26135 ("result must be general access type!", Expr); 26136 Error_Msg_NE -- CODEFIX 26137 ("add ALL to }!", Expr, Expec_Type); 26138 26139 -- Another special check, if the expected type is an integer type, 26140 -- but the expression is of type System.Address, and the parent is 26141 -- an addition or subtraction operation whose left operand is the 26142 -- expression in question and whose right operand is of an integral 26143 -- type, then this is an attempt at address arithmetic, so give 26144 -- appropriate message. 26145 26146 elsif Is_Integer_Type (Expec_Type) 26147 and then Is_RTE (Found_Type, RE_Address) 26148 and then Nkind_In (Parent (Expr), N_Op_Add, N_Op_Subtract) 26149 and then Expr = Left_Opnd (Parent (Expr)) 26150 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr)))) 26151 then 26152 Error_Msg_N 26153 ("address arithmetic not predefined in package System", 26154 Parent (Expr)); 26155 Error_Msg_N 26156 ("\possible missing with/use of System.Storage_Elements", 26157 Parent (Expr)); 26158 return; 26159 26160 -- If the expected type is an anonymous access type, as for access 26161 -- parameters and discriminants, the error is on the designated types. 26162 26163 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then 26164 if Comes_From_Source (Expec_Type) then 26165 Error_Msg_NE ("expected}!", Expr, Expec_Type); 26166 else 26167 Error_Msg_NE 26168 ("expected an access type with designated}", 26169 Expr, Designated_Type (Expec_Type)); 26170 end if; 26171 26172 if Is_Access_Type (Found_Type) 26173 and then not Comes_From_Source (Found_Type) 26174 then 26175 Error_Msg_NE 26176 ("\\found an access type with designated}!", 26177 Expr, Designated_Type (Found_Type)); 26178 else 26179 if From_Limited_With (Found_Type) then 26180 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); 26181 Error_Msg_Qual_Level := 99; 26182 Error_Msg_NE -- CODEFIX 26183 ("\\missing `WITH &;", Expr, Scope (Found_Type)); 26184 Error_Msg_Qual_Level := 0; 26185 else 26186 Error_Msg_NE ("found}!", Expr, Found_Type); 26187 end if; 26188 end if; 26189 26190 -- Normal case of one type found, some other type expected 26191 26192 else 26193 -- If the names of the two types are the same, see if some number 26194 -- of levels of qualification will help. Don't try more than three 26195 -- levels, and if we get to standard, it's no use (and probably 26196 -- represents an error in the compiler) Also do not bother with 26197 -- internal scope names. 26198 26199 declare 26200 Expec_Scope : Entity_Id; 26201 Found_Scope : Entity_Id; 26202 26203 begin 26204 Expec_Scope := Expec_Type; 26205 Found_Scope := Found_Type; 26206 26207 for Levels in Nat range 0 .. 3 loop 26208 if Chars (Expec_Scope) /= Chars (Found_Scope) then 26209 Error_Msg_Qual_Level := Levels; 26210 exit; 26211 end if; 26212 26213 Expec_Scope := Scope (Expec_Scope); 26214 Found_Scope := Scope (Found_Scope); 26215 26216 exit when Expec_Scope = Standard_Standard 26217 or else Found_Scope = Standard_Standard 26218 or else not Comes_From_Source (Expec_Scope) 26219 or else not Comes_From_Source (Found_Scope); 26220 end loop; 26221 end; 26222 26223 if Is_Record_Type (Expec_Type) 26224 and then Present (Corresponding_Remote_Type (Expec_Type)) 26225 then 26226 Error_Msg_NE ("expected}!", Expr, 26227 Corresponding_Remote_Type (Expec_Type)); 26228 else 26229 Error_Msg_NE ("expected}!", Expr, Expec_Type); 26230 end if; 26231 26232 if Is_Entity_Name (Expr) 26233 and then Is_Package_Or_Generic_Package (Entity (Expr)) 26234 then 26235 Error_Msg_N ("\\found package name!", Expr); 26236 26237 elsif Is_Entity_Name (Expr) 26238 and then Ekind_In (Entity (Expr), E_Procedure, E_Generic_Procedure) 26239 then 26240 if Ekind (Expec_Type) = E_Access_Subprogram_Type then 26241 Error_Msg_N 26242 ("found procedure name, possibly missing Access attribute!", 26243 Expr); 26244 else 26245 Error_Msg_N 26246 ("\\found procedure name instead of function!", Expr); 26247 end if; 26248 26249 elsif Nkind (Expr) = N_Function_Call 26250 and then Ekind (Expec_Type) = E_Access_Subprogram_Type 26251 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr) 26252 and then No (Parameter_Associations (Expr)) 26253 then 26254 Error_Msg_N 26255 ("found function name, possibly missing Access attribute!", 26256 Expr); 26257 26258 -- Catch common error: a prefix or infix operator which is not 26259 -- directly visible because the type isn't. 26260 26261 elsif Nkind (Expr) in N_Op 26262 and then Is_Overloaded (Expr) 26263 and then not Is_Immediately_Visible (Expec_Type) 26264 and then not Is_Potentially_Use_Visible (Expec_Type) 26265 and then not In_Use (Expec_Type) 26266 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type) 26267 then 26268 Error_Msg_N 26269 ("operator of the type is not directly visible!", Expr); 26270 26271 elsif Ekind (Found_Type) = E_Void 26272 and then Present (Parent (Found_Type)) 26273 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration 26274 then 26275 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type); 26276 26277 else 26278 Error_Msg_NE ("\\found}!", Expr, Found_Type); 26279 end if; 26280 26281 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are 26282 -- of the same modular type, and (M1 and M2) = 0 was intended. 26283 26284 if Expec_Type = Standard_Boolean 26285 and then Is_Modular_Integer_Type (Found_Type) 26286 and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor) 26287 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare 26288 then 26289 declare 26290 Op : constant Node_Id := Right_Opnd (Parent (Expr)); 26291 L : constant Node_Id := Left_Opnd (Op); 26292 R : constant Node_Id := Right_Opnd (Op); 26293 26294 begin 26295 -- The case for the message is when the left operand of the 26296 -- comparison is the same modular type, or when it is an 26297 -- integer literal (or other universal integer expression), 26298 -- which would have been typed as the modular type if the 26299 -- parens had been there. 26300 26301 if (Etype (L) = Found_Type 26302 or else 26303 Etype (L) = Universal_Integer) 26304 and then Is_Integer_Type (Etype (R)) 26305 then 26306 Error_Msg_N 26307 ("\\possible missing parens for modular operation", Expr); 26308 end if; 26309 end; 26310 end if; 26311 26312 -- Reset error message qualification indication 26313 26314 Error_Msg_Qual_Level := 0; 26315 end if; 26316 end Wrong_Type; 26317 26318 -------------------------------- 26319 -- Yields_Synchronized_Object -- 26320 -------------------------------- 26321 26322 function Yields_Synchronized_Object (Typ : Entity_Id) return Boolean is 26323 Has_Sync_Comp : Boolean := False; 26324 Id : Entity_Id; 26325 26326 begin 26327 -- An array type yields a synchronized object if its component type 26328 -- yields a synchronized object. 26329 26330 if Is_Array_Type (Typ) then 26331 return Yields_Synchronized_Object (Component_Type (Typ)); 26332 26333 -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object 26334 -- yields a synchronized object by default. 26335 26336 elsif Is_Descendant_Of_Suspension_Object (Typ) then 26337 return True; 26338 26339 -- A protected type yields a synchronized object by default 26340 26341 elsif Is_Protected_Type (Typ) then 26342 return True; 26343 26344 -- A record type or type extension yields a synchronized object when its 26345 -- discriminants (if any) lack default values and all components are of 26346 -- a type that yelds a synchronized object. 26347 26348 elsif Is_Record_Type (Typ) then 26349 26350 -- Inspect all entities defined in the scope of the type, looking for 26351 -- components of a type that does not yeld a synchronized object or 26352 -- for discriminants with default values. 26353 26354 Id := First_Entity (Typ); 26355 while Present (Id) loop 26356 if Comes_From_Source (Id) then 26357 if Ekind (Id) = E_Component then 26358 if Yields_Synchronized_Object (Etype (Id)) then 26359 Has_Sync_Comp := True; 26360 26361 -- The component does not yield a synchronized object 26362 26363 else 26364 return False; 26365 end if; 26366 26367 elsif Ekind (Id) = E_Discriminant 26368 and then Present (Expression (Parent (Id))) 26369 then 26370 return False; 26371 end if; 26372 end if; 26373 26374 Next_Entity (Id); 26375 end loop; 26376 26377 -- Ensure that the parent type of a type extension yields a 26378 -- synchronized object. 26379 26380 if Etype (Typ) /= Typ 26381 and then not Yields_Synchronized_Object (Etype (Typ)) 26382 then 26383 return False; 26384 end if; 26385 26386 -- If we get here, then all discriminants lack default values and all 26387 -- components are of a type that yields a synchronized object. 26388 26389 return Has_Sync_Comp; 26390 26391 -- A synchronized interface type yields a synchronized object by default 26392 26393 elsif Is_Synchronized_Interface (Typ) then 26394 return True; 26395 26396 -- A task type yelds a synchronized object by default 26397 26398 elsif Is_Task_Type (Typ) then 26399 return True; 26400 26401 -- Otherwise the type does not yield a synchronized object 26402 26403 else 26404 return False; 26405 end if; 26406 end Yields_Synchronized_Object; 26407 26408 --------------------------- 26409 -- Yields_Universal_Type -- 26410 --------------------------- 26411 26412 function Yields_Universal_Type (N : Node_Id) return Boolean is 26413 begin 26414 -- Integer and real literals are of a universal type 26415 26416 if Nkind_In (N, N_Integer_Literal, N_Real_Literal) then 26417 return True; 26418 26419 -- The values of certain attributes are of a universal type 26420 26421 elsif Nkind (N) = N_Attribute_Reference then 26422 return 26423 Universal_Type_Attribute (Get_Attribute_Id (Attribute_Name (N))); 26424 26425 -- ??? There are possibly other cases to consider 26426 26427 else 26428 return False; 26429 end if; 26430 end Yields_Universal_Type; 26431 26432begin 26433 Erroutc.Subprogram_Name_Ptr := Subprogram_Name'Access; 26434end Sem_Util; 26435