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 5831 (N : Node_Id; 5832 Empty_On_Errors : Boolean := False; 5833 Concurrent_Subunit : Boolean := False) return Entity_Id 5834 is 5835 begin 5836 case Nkind (N) is 5837 when N_Abstract_Subprogram_Declaration 5838 | N_Expression_Function 5839 | N_Formal_Subprogram_Declaration 5840 | N_Generic_Package_Declaration 5841 | N_Generic_Subprogram_Declaration 5842 | N_Package_Declaration 5843 | N_Subprogram_Body 5844 | N_Subprogram_Body_Stub 5845 | N_Subprogram_Declaration 5846 | N_Subprogram_Renaming_Declaration 5847 => 5848 return Defining_Entity (Specification (N)); 5849 5850 when N_Component_Declaration 5851 | N_Defining_Program_Unit_Name 5852 | N_Discriminant_Specification 5853 | N_Entry_Body 5854 | N_Entry_Declaration 5855 | N_Entry_Index_Specification 5856 | N_Exception_Declaration 5857 | N_Exception_Renaming_Declaration 5858 | N_Formal_Object_Declaration 5859 | N_Formal_Package_Declaration 5860 | N_Formal_Type_Declaration 5861 | N_Full_Type_Declaration 5862 | N_Implicit_Label_Declaration 5863 | N_Incomplete_Type_Declaration 5864 | N_Iterator_Specification 5865 | N_Loop_Parameter_Specification 5866 | N_Number_Declaration 5867 | N_Object_Declaration 5868 | N_Object_Renaming_Declaration 5869 | N_Package_Body_Stub 5870 | N_Parameter_Specification 5871 | N_Private_Extension_Declaration 5872 | N_Private_Type_Declaration 5873 | N_Protected_Body 5874 | N_Protected_Body_Stub 5875 | N_Protected_Type_Declaration 5876 | N_Single_Protected_Declaration 5877 | N_Single_Task_Declaration 5878 | N_Subtype_Declaration 5879 | N_Task_Body 5880 | N_Task_Body_Stub 5881 | N_Task_Type_Declaration 5882 => 5883 return Defining_Identifier (N); 5884 5885 when N_Subunit => 5886 declare 5887 Bod : constant Node_Id := Proper_Body (N); 5888 Orig_Bod : constant Node_Id := Original_Node (Bod); 5889 5890 begin 5891 -- Retrieve the entity of the original protected or task body 5892 -- if requested by the caller. 5893 5894 if Concurrent_Subunit 5895 and then Nkind (Bod) = N_Null_Statement 5896 and then Nkind_In (Orig_Bod, N_Protected_Body, N_Task_Body) 5897 then 5898 return Defining_Entity (Orig_Bod); 5899 else 5900 return Defining_Entity (Bod); 5901 end if; 5902 end; 5903 5904 when N_Function_Instantiation 5905 | N_Function_Specification 5906 | N_Generic_Function_Renaming_Declaration 5907 | N_Generic_Package_Renaming_Declaration 5908 | N_Generic_Procedure_Renaming_Declaration 5909 | N_Package_Body 5910 | N_Package_Instantiation 5911 | N_Package_Renaming_Declaration 5912 | N_Package_Specification 5913 | N_Procedure_Instantiation 5914 | N_Procedure_Specification 5915 => 5916 declare 5917 Nam : constant Node_Id := Defining_Unit_Name (N); 5918 Err : Entity_Id := Empty; 5919 5920 begin 5921 if Nkind (Nam) in N_Entity then 5922 return Nam; 5923 5924 -- For Error, make up a name and attach to declaration so we 5925 -- can continue semantic analysis. 5926 5927 elsif Nam = Error then 5928 if Empty_On_Errors then 5929 return Empty; 5930 else 5931 Err := Make_Temporary (Sloc (N), 'T'); 5932 Set_Defining_Unit_Name (N, Err); 5933 5934 return Err; 5935 end if; 5936 5937 -- If not an entity, get defining identifier 5938 5939 else 5940 return Defining_Identifier (Nam); 5941 end if; 5942 end; 5943 5944 when N_Block_Statement 5945 | N_Loop_Statement 5946 => 5947 return Entity (Identifier (N)); 5948 5949 when others => 5950 if Empty_On_Errors then 5951 return Empty; 5952 else 5953 raise Program_Error; 5954 end if; 5955 end case; 5956 end Defining_Entity; 5957 5958 -------------------------- 5959 -- Denotes_Discriminant -- 5960 -------------------------- 5961 5962 function Denotes_Discriminant 5963 (N : Node_Id; 5964 Check_Concurrent : Boolean := False) return Boolean 5965 is 5966 E : Entity_Id; 5967 5968 begin 5969 if not Is_Entity_Name (N) or else No (Entity (N)) then 5970 return False; 5971 else 5972 E := Entity (N); 5973 end if; 5974 5975 -- If we are checking for a protected type, the discriminant may have 5976 -- been rewritten as the corresponding discriminal of the original type 5977 -- or of the corresponding concurrent record, depending on whether we 5978 -- are in the spec or body of the protected type. 5979 5980 return Ekind (E) = E_Discriminant 5981 or else 5982 (Check_Concurrent 5983 and then Ekind (E) = E_In_Parameter 5984 and then Present (Discriminal_Link (E)) 5985 and then 5986 (Is_Concurrent_Type (Scope (Discriminal_Link (E))) 5987 or else 5988 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E))))); 5989 end Denotes_Discriminant; 5990 5991 ------------------------- 5992 -- Denotes_Same_Object -- 5993 ------------------------- 5994 5995 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is 5996 function Is_Renaming (N : Node_Id) return Boolean; 5997 -- Return true if N names a renaming entity 5998 5999 function Is_Valid_Renaming (N : Node_Id) return Boolean; 6000 -- For renamings, return False if the prefix of any dereference within 6001 -- the renamed object_name is a variable, or any expression within the 6002 -- renamed object_name contains references to variables or calls on 6003 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3)) 6004 6005 ----------------- 6006 -- Is_Renaming -- 6007 ----------------- 6008 6009 function Is_Renaming (N : Node_Id) return Boolean is 6010 begin 6011 return 6012 Is_Entity_Name (N) and then Present (Renamed_Entity (Entity (N))); 6013 end Is_Renaming; 6014 6015 ----------------------- 6016 -- Is_Valid_Renaming -- 6017 ----------------------- 6018 6019 function Is_Valid_Renaming (N : Node_Id) return Boolean is 6020 function Check_Renaming (N : Node_Id) return Boolean; 6021 -- Recursive function used to traverse all the prefixes of N 6022 6023 -------------------- 6024 -- Check_Renaming -- 6025 -------------------- 6026 6027 function Check_Renaming (N : Node_Id) return Boolean is 6028 begin 6029 if Is_Renaming (N) 6030 and then not Check_Renaming (Renamed_Entity (Entity (N))) 6031 then 6032 return False; 6033 end if; 6034 6035 if Nkind (N) = N_Indexed_Component then 6036 declare 6037 Indx : Node_Id; 6038 6039 begin 6040 Indx := First (Expressions (N)); 6041 while Present (Indx) loop 6042 if not Is_OK_Static_Expression (Indx) then 6043 return False; 6044 end if; 6045 6046 Next_Index (Indx); 6047 end loop; 6048 end; 6049 end if; 6050 6051 if Has_Prefix (N) then 6052 declare 6053 P : constant Node_Id := Prefix (N); 6054 6055 begin 6056 if Nkind (N) = N_Explicit_Dereference 6057 and then Is_Variable (P) 6058 then 6059 return False; 6060 6061 elsif Is_Entity_Name (P) 6062 and then Ekind (Entity (P)) = E_Function 6063 then 6064 return False; 6065 6066 elsif Nkind (P) = N_Function_Call then 6067 return False; 6068 end if; 6069 6070 -- Recursion to continue traversing the prefix of the 6071 -- renaming expression 6072 6073 return Check_Renaming (P); 6074 end; 6075 end if; 6076 6077 return True; 6078 end Check_Renaming; 6079 6080 -- Start of processing for Is_Valid_Renaming 6081 6082 begin 6083 return Check_Renaming (N); 6084 end Is_Valid_Renaming; 6085 6086 -- Local variables 6087 6088 Obj1 : Node_Id := A1; 6089 Obj2 : Node_Id := A2; 6090 6091 -- Start of processing for Denotes_Same_Object 6092 6093 begin 6094 -- Both names statically denote the same stand-alone object or parameter 6095 -- (RM 6.4.1(6.5/3)) 6096 6097 if Is_Entity_Name (Obj1) 6098 and then Is_Entity_Name (Obj2) 6099 and then Entity (Obj1) = Entity (Obj2) 6100 then 6101 return True; 6102 end if; 6103 6104 -- For renamings, the prefix of any dereference within the renamed 6105 -- object_name is not a variable, and any expression within the 6106 -- renamed object_name contains no references to variables nor 6107 -- calls on nonstatic functions (RM 6.4.1(6.10/3)). 6108 6109 if Is_Renaming (Obj1) then 6110 if Is_Valid_Renaming (Obj1) then 6111 Obj1 := Renamed_Entity (Entity (Obj1)); 6112 else 6113 return False; 6114 end if; 6115 end if; 6116 6117 if Is_Renaming (Obj2) then 6118 if Is_Valid_Renaming (Obj2) then 6119 Obj2 := Renamed_Entity (Entity (Obj2)); 6120 else 6121 return False; 6122 end if; 6123 end if; 6124 6125 -- No match if not same node kind (such cases are handled by 6126 -- Denotes_Same_Prefix) 6127 6128 if Nkind (Obj1) /= Nkind (Obj2) then 6129 return False; 6130 6131 -- After handling valid renamings, one of the two names statically 6132 -- denoted a renaming declaration whose renamed object_name is known 6133 -- to denote the same object as the other (RM 6.4.1(6.10/3)) 6134 6135 elsif Is_Entity_Name (Obj1) then 6136 if Is_Entity_Name (Obj2) then 6137 return Entity (Obj1) = Entity (Obj2); 6138 else 6139 return False; 6140 end if; 6141 6142 -- Both names are selected_components, their prefixes are known to 6143 -- denote the same object, and their selector_names denote the same 6144 -- component (RM 6.4.1(6.6/3)). 6145 6146 elsif Nkind (Obj1) = N_Selected_Component then 6147 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) 6148 and then 6149 Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2)); 6150 6151 -- Both names are dereferences and the dereferenced names are known to 6152 -- denote the same object (RM 6.4.1(6.7/3)) 6153 6154 elsif Nkind (Obj1) = N_Explicit_Dereference then 6155 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)); 6156 6157 -- Both names are indexed_components, their prefixes are known to denote 6158 -- the same object, and each of the pairs of corresponding index values 6159 -- are either both static expressions with the same static value or both 6160 -- names that are known to denote the same object (RM 6.4.1(6.8/3)) 6161 6162 elsif Nkind (Obj1) = N_Indexed_Component then 6163 if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then 6164 return False; 6165 else 6166 declare 6167 Indx1 : Node_Id; 6168 Indx2 : Node_Id; 6169 6170 begin 6171 Indx1 := First (Expressions (Obj1)); 6172 Indx2 := First (Expressions (Obj2)); 6173 while Present (Indx1) loop 6174 6175 -- Indexes must denote the same static value or same object 6176 6177 if Is_OK_Static_Expression (Indx1) then 6178 if not Is_OK_Static_Expression (Indx2) then 6179 return False; 6180 6181 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then 6182 return False; 6183 end if; 6184 6185 elsif not Denotes_Same_Object (Indx1, Indx2) then 6186 return False; 6187 end if; 6188 6189 Next (Indx1); 6190 Next (Indx2); 6191 end loop; 6192 6193 return True; 6194 end; 6195 end if; 6196 6197 -- Both names are slices, their prefixes are known to denote the same 6198 -- object, and the two slices have statically matching index constraints 6199 -- (RM 6.4.1(6.9/3)) 6200 6201 elsif Nkind (Obj1) = N_Slice 6202 and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) 6203 then 6204 declare 6205 Lo1, Lo2, Hi1, Hi2 : Node_Id; 6206 6207 begin 6208 Get_Index_Bounds (Etype (Obj1), Lo1, Hi1); 6209 Get_Index_Bounds (Etype (Obj2), Lo2, Hi2); 6210 6211 -- Check whether bounds are statically identical. There is no 6212 -- attempt to detect partial overlap of slices. 6213 6214 return Denotes_Same_Object (Lo1, Lo2) 6215 and then 6216 Denotes_Same_Object (Hi1, Hi2); 6217 end; 6218 6219 -- In the recursion, literals appear as indexes 6220 6221 elsif Nkind (Obj1) = N_Integer_Literal 6222 and then 6223 Nkind (Obj2) = N_Integer_Literal 6224 then 6225 return Intval (Obj1) = Intval (Obj2); 6226 6227 else 6228 return False; 6229 end if; 6230 end Denotes_Same_Object; 6231 6232 ------------------------- 6233 -- Denotes_Same_Prefix -- 6234 ------------------------- 6235 6236 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is 6237 begin 6238 if Is_Entity_Name (A1) then 6239 if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) 6240 and then not Is_Access_Type (Etype (A1)) 6241 then 6242 return Denotes_Same_Object (A1, Prefix (A2)) 6243 or else Denotes_Same_Prefix (A1, Prefix (A2)); 6244 else 6245 return False; 6246 end if; 6247 6248 elsif Is_Entity_Name (A2) then 6249 return Denotes_Same_Prefix (A1 => A2, A2 => A1); 6250 6251 elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice) 6252 and then 6253 Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice) 6254 then 6255 declare 6256 Root1, Root2 : Node_Id; 6257 Depth1, Depth2 : Nat := 0; 6258 6259 begin 6260 Root1 := Prefix (A1); 6261 while not Is_Entity_Name (Root1) loop 6262 if not Nkind_In 6263 (Root1, N_Selected_Component, N_Indexed_Component) 6264 then 6265 return False; 6266 else 6267 Root1 := Prefix (Root1); 6268 end if; 6269 6270 Depth1 := Depth1 + 1; 6271 end loop; 6272 6273 Root2 := Prefix (A2); 6274 while not Is_Entity_Name (Root2) loop 6275 if not Nkind_In (Root2, N_Selected_Component, 6276 N_Indexed_Component) 6277 then 6278 return False; 6279 else 6280 Root2 := Prefix (Root2); 6281 end if; 6282 6283 Depth2 := Depth2 + 1; 6284 end loop; 6285 6286 -- If both have the same depth and they do not denote the same 6287 -- object, they are disjoint and no warning is needed. 6288 6289 if Depth1 = Depth2 then 6290 return False; 6291 6292 elsif Depth1 > Depth2 then 6293 Root1 := Prefix (A1); 6294 for J in 1 .. Depth1 - Depth2 - 1 loop 6295 Root1 := Prefix (Root1); 6296 end loop; 6297 6298 return Denotes_Same_Object (Root1, A2); 6299 6300 else 6301 Root2 := Prefix (A2); 6302 for J in 1 .. Depth2 - Depth1 - 1 loop 6303 Root2 := Prefix (Root2); 6304 end loop; 6305 6306 return Denotes_Same_Object (A1, Root2); 6307 end if; 6308 end; 6309 6310 else 6311 return False; 6312 end if; 6313 end Denotes_Same_Prefix; 6314 6315 ---------------------- 6316 -- Denotes_Variable -- 6317 ---------------------- 6318 6319 function Denotes_Variable (N : Node_Id) return Boolean is 6320 begin 6321 return Is_Variable (N) and then Paren_Count (N) = 0; 6322 end Denotes_Variable; 6323 6324 ----------------------------- 6325 -- Depends_On_Discriminant -- 6326 ----------------------------- 6327 6328 function Depends_On_Discriminant (N : Node_Id) return Boolean is 6329 L : Node_Id; 6330 H : Node_Id; 6331 6332 begin 6333 Get_Index_Bounds (N, L, H); 6334 return Denotes_Discriminant (L) or else Denotes_Discriminant (H); 6335 end Depends_On_Discriminant; 6336 6337 ------------------------- 6338 -- Designate_Same_Unit -- 6339 ------------------------- 6340 6341 function Designate_Same_Unit 6342 (Name1 : Node_Id; 6343 Name2 : Node_Id) return Boolean 6344 is 6345 K1 : constant Node_Kind := Nkind (Name1); 6346 K2 : constant Node_Kind := Nkind (Name2); 6347 6348 function Prefix_Node (N : Node_Id) return Node_Id; 6349 -- Returns the parent unit name node of a defining program unit name 6350 -- or the prefix if N is a selected component or an expanded name. 6351 6352 function Select_Node (N : Node_Id) return Node_Id; 6353 -- Returns the defining identifier node of a defining program unit 6354 -- name or the selector node if N is a selected component or an 6355 -- expanded name. 6356 6357 ----------------- 6358 -- Prefix_Node -- 6359 ----------------- 6360 6361 function Prefix_Node (N : Node_Id) return Node_Id is 6362 begin 6363 if Nkind (N) = N_Defining_Program_Unit_Name then 6364 return Name (N); 6365 else 6366 return Prefix (N); 6367 end if; 6368 end Prefix_Node; 6369 6370 ----------------- 6371 -- Select_Node -- 6372 ----------------- 6373 6374 function Select_Node (N : Node_Id) return Node_Id is 6375 begin 6376 if Nkind (N) = N_Defining_Program_Unit_Name then 6377 return Defining_Identifier (N); 6378 else 6379 return Selector_Name (N); 6380 end if; 6381 end Select_Node; 6382 6383 -- Start of processing for Designate_Same_Unit 6384 6385 begin 6386 if Nkind_In (K1, N_Identifier, N_Defining_Identifier) 6387 and then 6388 Nkind_In (K2, N_Identifier, N_Defining_Identifier) 6389 then 6390 return Chars (Name1) = Chars (Name2); 6391 6392 elsif Nkind_In (K1, N_Expanded_Name, 6393 N_Selected_Component, 6394 N_Defining_Program_Unit_Name) 6395 and then 6396 Nkind_In (K2, N_Expanded_Name, 6397 N_Selected_Component, 6398 N_Defining_Program_Unit_Name) 6399 then 6400 return 6401 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2))) 6402 and then 6403 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2)); 6404 6405 else 6406 return False; 6407 end if; 6408 end Designate_Same_Unit; 6409 6410 --------------------------------------------- 6411 -- Diagnose_Iterated_Component_Association -- 6412 --------------------------------------------- 6413 6414 procedure Diagnose_Iterated_Component_Association (N : Node_Id) is 6415 Def_Id : constant Entity_Id := Defining_Identifier (N); 6416 Aggr : Node_Id; 6417 6418 begin 6419 -- Determine whether the iterated component association appears within 6420 -- an aggregate. If this is the case, raise Program_Error because the 6421 -- iterated component association cannot be left in the tree as is and 6422 -- must always be processed by the related aggregate. 6423 6424 Aggr := N; 6425 while Present (Aggr) loop 6426 if Nkind (Aggr) = N_Aggregate then 6427 raise Program_Error; 6428 6429 -- Prevent the search from going too far 6430 6431 elsif Is_Body_Or_Package_Declaration (Aggr) then 6432 exit; 6433 end if; 6434 6435 Aggr := Parent (Aggr); 6436 end loop; 6437 6438 -- At this point it is known that the iterated component association is 6439 -- not within an aggregate. This is really a quantified expression with 6440 -- a missing "all" or "some" quantifier. 6441 6442 Error_Msg_N ("missing quantifier", Def_Id); 6443 6444 -- Rewrite the iterated component association as True to prevent any 6445 -- cascaded errors. 6446 6447 Rewrite (N, New_Occurrence_Of (Standard_True, Sloc (N))); 6448 Analyze (N); 6449 end Diagnose_Iterated_Component_Association; 6450 6451 --------------------------------- 6452 -- Dynamic_Accessibility_Level -- 6453 --------------------------------- 6454 6455 function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is 6456 Loc : constant Source_Ptr := Sloc (Expr); 6457 6458 function Make_Level_Literal (Level : Uint) return Node_Id; 6459 -- Construct an integer literal representing an accessibility level 6460 -- with its type set to Natural. 6461 6462 ------------------------ 6463 -- Make_Level_Literal -- 6464 ------------------------ 6465 6466 function Make_Level_Literal (Level : Uint) return Node_Id is 6467 Result : constant Node_Id := Make_Integer_Literal (Loc, Level); 6468 6469 begin 6470 Set_Etype (Result, Standard_Natural); 6471 return Result; 6472 end Make_Level_Literal; 6473 6474 -- Local variables 6475 6476 E : Entity_Id; 6477 6478 -- Start of processing for Dynamic_Accessibility_Level 6479 6480 begin 6481 if Is_Entity_Name (Expr) then 6482 E := Entity (Expr); 6483 6484 if Present (Renamed_Object (E)) then 6485 return Dynamic_Accessibility_Level (Renamed_Object (E)); 6486 end if; 6487 6488 if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then 6489 if Present (Extra_Accessibility (E)) then 6490 return New_Occurrence_Of (Extra_Accessibility (E), Loc); 6491 end if; 6492 end if; 6493 end if; 6494 6495 -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ??? 6496 6497 case Nkind (Expr) is 6498 6499 -- For access discriminant, the level of the enclosing object 6500 6501 when N_Selected_Component => 6502 if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant 6503 and then Ekind (Etype (Entity (Selector_Name (Expr)))) = 6504 E_Anonymous_Access_Type 6505 then 6506 return Make_Level_Literal (Object_Access_Level (Expr)); 6507 end if; 6508 6509 when N_Attribute_Reference => 6510 case Get_Attribute_Id (Attribute_Name (Expr)) is 6511 6512 -- For X'Access, the level of the prefix X 6513 6514 when Attribute_Access => 6515 return Make_Level_Literal 6516 (Object_Access_Level (Prefix (Expr))); 6517 6518 -- Treat the unchecked attributes as library-level 6519 6520 when Attribute_Unchecked_Access 6521 | Attribute_Unrestricted_Access 6522 => 6523 return Make_Level_Literal (Scope_Depth (Standard_Standard)); 6524 6525 -- No other access-valued attributes 6526 6527 when others => 6528 raise Program_Error; 6529 end case; 6530 6531 when N_Allocator => 6532 6533 -- Unimplemented: depends on context. As an actual parameter where 6534 -- formal type is anonymous, use 6535 -- Scope_Depth (Current_Scope) + 1. 6536 -- For other cases, see 3.10.2(14/3) and following. ??? 6537 6538 null; 6539 6540 when N_Type_Conversion => 6541 if not Is_Local_Anonymous_Access (Etype (Expr)) then 6542 6543 -- Handle type conversions introduced for a rename of an 6544 -- Ada 2012 stand-alone object of an anonymous access type. 6545 6546 return Dynamic_Accessibility_Level (Expression (Expr)); 6547 end if; 6548 6549 when others => 6550 null; 6551 end case; 6552 6553 return Make_Level_Literal (Type_Access_Level (Etype (Expr))); 6554 end Dynamic_Accessibility_Level; 6555 6556 ------------------------ 6557 -- Discriminated_Size -- 6558 ------------------------ 6559 6560 function Discriminated_Size (Comp : Entity_Id) return Boolean is 6561 function Non_Static_Bound (Bound : Node_Id) return Boolean; 6562 -- Check whether the bound of an index is non-static and does denote 6563 -- a discriminant, in which case any object of the type (protected or 6564 -- otherwise) will have a non-static size. 6565 6566 ---------------------- 6567 -- Non_Static_Bound -- 6568 ---------------------- 6569 6570 function Non_Static_Bound (Bound : Node_Id) return Boolean is 6571 begin 6572 if Is_OK_Static_Expression (Bound) then 6573 return False; 6574 6575 -- If the bound is given by a discriminant it is non-static 6576 -- (A static constraint replaces the reference with the value). 6577 -- In an protected object the discriminant has been replaced by 6578 -- the corresponding discriminal within the protected operation. 6579 6580 elsif Is_Entity_Name (Bound) 6581 and then 6582 (Ekind (Entity (Bound)) = E_Discriminant 6583 or else Present (Discriminal_Link (Entity (Bound)))) 6584 then 6585 return False; 6586 6587 else 6588 return True; 6589 end if; 6590 end Non_Static_Bound; 6591 6592 -- Local variables 6593 6594 Typ : constant Entity_Id := Etype (Comp); 6595 Index : Node_Id; 6596 6597 -- Start of processing for Discriminated_Size 6598 6599 begin 6600 if not Is_Array_Type (Typ) then 6601 return False; 6602 end if; 6603 6604 if Ekind (Typ) = E_Array_Subtype then 6605 Index := First_Index (Typ); 6606 while Present (Index) loop 6607 if Non_Static_Bound (Low_Bound (Index)) 6608 or else Non_Static_Bound (High_Bound (Index)) 6609 then 6610 return False; 6611 end if; 6612 6613 Next_Index (Index); 6614 end loop; 6615 6616 return True; 6617 end if; 6618 6619 return False; 6620 end Discriminated_Size; 6621 6622 ----------------------------------- 6623 -- Effective_Extra_Accessibility -- 6624 ----------------------------------- 6625 6626 function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is 6627 begin 6628 if Present (Renamed_Object (Id)) 6629 and then Is_Entity_Name (Renamed_Object (Id)) 6630 then 6631 return Effective_Extra_Accessibility (Entity (Renamed_Object (Id))); 6632 else 6633 return Extra_Accessibility (Id); 6634 end if; 6635 end Effective_Extra_Accessibility; 6636 6637 ----------------------------- 6638 -- Effective_Reads_Enabled -- 6639 ----------------------------- 6640 6641 function Effective_Reads_Enabled (Id : Entity_Id) return Boolean is 6642 begin 6643 return Has_Enabled_Property (Id, Name_Effective_Reads); 6644 end Effective_Reads_Enabled; 6645 6646 ------------------------------ 6647 -- Effective_Writes_Enabled -- 6648 ------------------------------ 6649 6650 function Effective_Writes_Enabled (Id : Entity_Id) return Boolean is 6651 begin 6652 return Has_Enabled_Property (Id, Name_Effective_Writes); 6653 end Effective_Writes_Enabled; 6654 6655 ------------------------------ 6656 -- Enclosing_Comp_Unit_Node -- 6657 ------------------------------ 6658 6659 function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is 6660 Current_Node : Node_Id; 6661 6662 begin 6663 Current_Node := N; 6664 while Present (Current_Node) 6665 and then Nkind (Current_Node) /= N_Compilation_Unit 6666 loop 6667 Current_Node := Parent (Current_Node); 6668 end loop; 6669 6670 if Nkind (Current_Node) /= N_Compilation_Unit then 6671 return Empty; 6672 else 6673 return Current_Node; 6674 end if; 6675 end Enclosing_Comp_Unit_Node; 6676 6677 -------------------------- 6678 -- Enclosing_CPP_Parent -- 6679 -------------------------- 6680 6681 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is 6682 Parent_Typ : Entity_Id := Typ; 6683 6684 begin 6685 while not Is_CPP_Class (Parent_Typ) 6686 and then Etype (Parent_Typ) /= Parent_Typ 6687 loop 6688 Parent_Typ := Etype (Parent_Typ); 6689 6690 if Is_Private_Type (Parent_Typ) then 6691 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 6692 end if; 6693 end loop; 6694 6695 pragma Assert (Is_CPP_Class (Parent_Typ)); 6696 return Parent_Typ; 6697 end Enclosing_CPP_Parent; 6698 6699 --------------------------- 6700 -- Enclosing_Declaration -- 6701 --------------------------- 6702 6703 function Enclosing_Declaration (N : Node_Id) return Node_Id is 6704 Decl : Node_Id := N; 6705 6706 begin 6707 while Present (Decl) 6708 and then not (Nkind (Decl) in N_Declaration 6709 or else 6710 Nkind (Decl) in N_Later_Decl_Item 6711 or else 6712 Nkind (Decl) = N_Number_Declaration) 6713 loop 6714 Decl := Parent (Decl); 6715 end loop; 6716 6717 return Decl; 6718 end Enclosing_Declaration; 6719 6720 ---------------------------- 6721 -- Enclosing_Generic_Body -- 6722 ---------------------------- 6723 6724 function Enclosing_Generic_Body 6725 (N : Node_Id) return Node_Id 6726 is 6727 P : Node_Id; 6728 Decl : Node_Id; 6729 Spec : Node_Id; 6730 6731 begin 6732 P := Parent (N); 6733 while Present (P) loop 6734 if Nkind (P) = N_Package_Body 6735 or else Nkind (P) = N_Subprogram_Body 6736 then 6737 Spec := Corresponding_Spec (P); 6738 6739 if Present (Spec) then 6740 Decl := Unit_Declaration_Node (Spec); 6741 6742 if Nkind (Decl) = N_Generic_Package_Declaration 6743 or else Nkind (Decl) = N_Generic_Subprogram_Declaration 6744 then 6745 return P; 6746 end if; 6747 end if; 6748 end if; 6749 6750 P := Parent (P); 6751 end loop; 6752 6753 return Empty; 6754 end Enclosing_Generic_Body; 6755 6756 ---------------------------- 6757 -- Enclosing_Generic_Unit -- 6758 ---------------------------- 6759 6760 function Enclosing_Generic_Unit 6761 (N : Node_Id) return Node_Id 6762 is 6763 P : Node_Id; 6764 Decl : Node_Id; 6765 Spec : Node_Id; 6766 6767 begin 6768 P := Parent (N); 6769 while Present (P) loop 6770 if Nkind (P) = N_Generic_Package_Declaration 6771 or else Nkind (P) = N_Generic_Subprogram_Declaration 6772 then 6773 return P; 6774 6775 elsif Nkind (P) = N_Package_Body 6776 or else Nkind (P) = N_Subprogram_Body 6777 then 6778 Spec := Corresponding_Spec (P); 6779 6780 if Present (Spec) then 6781 Decl := Unit_Declaration_Node (Spec); 6782 6783 if Nkind (Decl) = N_Generic_Package_Declaration 6784 or else Nkind (Decl) = N_Generic_Subprogram_Declaration 6785 then 6786 return Decl; 6787 end if; 6788 end if; 6789 end if; 6790 6791 P := Parent (P); 6792 end loop; 6793 6794 return Empty; 6795 end Enclosing_Generic_Unit; 6796 6797 ------------------------------- 6798 -- Enclosing_Lib_Unit_Entity -- 6799 ------------------------------- 6800 6801 function Enclosing_Lib_Unit_Entity 6802 (E : Entity_Id := Current_Scope) return Entity_Id 6803 is 6804 Unit_Entity : Entity_Id; 6805 6806 begin 6807 -- Look for enclosing library unit entity by following scope links. 6808 -- Equivalent to, but faster than indexing through the scope stack. 6809 6810 Unit_Entity := E; 6811 while (Present (Scope (Unit_Entity)) 6812 and then Scope (Unit_Entity) /= Standard_Standard) 6813 and not Is_Child_Unit (Unit_Entity) 6814 loop 6815 Unit_Entity := Scope (Unit_Entity); 6816 end loop; 6817 6818 return Unit_Entity; 6819 end Enclosing_Lib_Unit_Entity; 6820 6821 ----------------------------- 6822 -- Enclosing_Lib_Unit_Node -- 6823 ----------------------------- 6824 6825 function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is 6826 Encl_Unit : Node_Id; 6827 6828 begin 6829 Encl_Unit := Enclosing_Comp_Unit_Node (N); 6830 while Present (Encl_Unit) 6831 and then Nkind (Unit (Encl_Unit)) = N_Subunit 6832 loop 6833 Encl_Unit := Library_Unit (Encl_Unit); 6834 end loop; 6835 6836 pragma Assert (Nkind (Encl_Unit) = N_Compilation_Unit); 6837 return Encl_Unit; 6838 end Enclosing_Lib_Unit_Node; 6839 6840 ----------------------- 6841 -- Enclosing_Package -- 6842 ----------------------- 6843 6844 function Enclosing_Package (E : Entity_Id) return Entity_Id is 6845 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E); 6846 6847 begin 6848 if Dynamic_Scope = Standard_Standard then 6849 return Standard_Standard; 6850 6851 elsif Dynamic_Scope = Empty then 6852 return Empty; 6853 6854 elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body, 6855 E_Generic_Package) 6856 then 6857 return Dynamic_Scope; 6858 6859 else 6860 return Enclosing_Package (Dynamic_Scope); 6861 end if; 6862 end Enclosing_Package; 6863 6864 ------------------------------------- 6865 -- Enclosing_Package_Or_Subprogram -- 6866 ------------------------------------- 6867 6868 function Enclosing_Package_Or_Subprogram (E : Entity_Id) return Entity_Id is 6869 S : Entity_Id; 6870 6871 begin 6872 S := Scope (E); 6873 while Present (S) loop 6874 if Is_Package_Or_Generic_Package (S) 6875 or else Ekind (S) = E_Package_Body 6876 then 6877 return S; 6878 6879 elsif Is_Subprogram_Or_Generic_Subprogram (S) 6880 or else Ekind (S) = E_Subprogram_Body 6881 then 6882 return S; 6883 6884 else 6885 S := Scope (S); 6886 end if; 6887 end loop; 6888 6889 return Empty; 6890 end Enclosing_Package_Or_Subprogram; 6891 6892 -------------------------- 6893 -- Enclosing_Subprogram -- 6894 -------------------------- 6895 6896 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is 6897 Dyn_Scop : constant Entity_Id := Enclosing_Dynamic_Scope (E); 6898 6899 begin 6900 if Dyn_Scop = Standard_Standard then 6901 return Empty; 6902 6903 elsif Dyn_Scop = Empty then 6904 return Empty; 6905 6906 elsif Ekind (Dyn_Scop) = E_Subprogram_Body then 6907 return Corresponding_Spec (Parent (Parent (Dyn_Scop))); 6908 6909 elsif Ekind_In (Dyn_Scop, E_Block, E_Return_Statement) then 6910 return Enclosing_Subprogram (Dyn_Scop); 6911 6912 elsif Ekind (Dyn_Scop) = E_Entry then 6913 6914 -- For a task entry, return the enclosing subprogram of the 6915 -- task itself. 6916 6917 if Ekind (Scope (Dyn_Scop)) = E_Task_Type then 6918 return Enclosing_Subprogram (Dyn_Scop); 6919 6920 -- A protected entry is rewritten as a protected procedure which is 6921 -- the desired enclosing subprogram. This is relevant when unnesting 6922 -- a procedure local to an entry body. 6923 6924 else 6925 return Protected_Body_Subprogram (Dyn_Scop); 6926 end if; 6927 6928 elsif Ekind (Dyn_Scop) = E_Task_Type then 6929 return Get_Task_Body_Procedure (Dyn_Scop); 6930 6931 -- The scope may appear as a private type or as a private extension 6932 -- whose completion is a task or protected type. 6933 6934 elsif Ekind_In (Dyn_Scop, E_Limited_Private_Type, 6935 E_Record_Type_With_Private) 6936 and then Present (Full_View (Dyn_Scop)) 6937 and then Ekind_In (Full_View (Dyn_Scop), E_Task_Type, E_Protected_Type) 6938 then 6939 return Get_Task_Body_Procedure (Full_View (Dyn_Scop)); 6940 6941 -- No body is generated if the protected operation is eliminated 6942 6943 elsif Convention (Dyn_Scop) = Convention_Protected 6944 and then not Is_Eliminated (Dyn_Scop) 6945 and then Present (Protected_Body_Subprogram (Dyn_Scop)) 6946 then 6947 return Protected_Body_Subprogram (Dyn_Scop); 6948 6949 else 6950 return Dyn_Scop; 6951 end if; 6952 end Enclosing_Subprogram; 6953 6954 -------------------------- 6955 -- End_Keyword_Location -- 6956 -------------------------- 6957 6958 function End_Keyword_Location (N : Node_Id) return Source_Ptr is 6959 function End_Label_Loc (Nod : Node_Id) return Source_Ptr; 6960 -- Return the source location of Nod's end label according to the 6961 -- following precedence rules: 6962 -- 6963 -- 1) If the end label exists, return its location 6964 -- 2) If Nod exists, return its location 6965 -- 3) Return the location of N 6966 6967 ------------------- 6968 -- End_Label_Loc -- 6969 ------------------- 6970 6971 function End_Label_Loc (Nod : Node_Id) return Source_Ptr is 6972 Label : Node_Id; 6973 6974 begin 6975 if Present (Nod) then 6976 Label := End_Label (Nod); 6977 6978 if Present (Label) then 6979 return Sloc (Label); 6980 else 6981 return Sloc (Nod); 6982 end if; 6983 6984 else 6985 return Sloc (N); 6986 end if; 6987 end End_Label_Loc; 6988 6989 -- Local variables 6990 6991 Owner : Node_Id; 6992 6993 -- Start of processing for End_Keyword_Location 6994 6995 begin 6996 if Nkind_In (N, N_Block_Statement, 6997 N_Entry_Body, 6998 N_Package_Body, 6999 N_Subprogram_Body, 7000 N_Task_Body) 7001 then 7002 Owner := Handled_Statement_Sequence (N); 7003 7004 elsif Nkind (N) = N_Package_Declaration then 7005 Owner := Specification (N); 7006 7007 elsif Nkind (N) = N_Protected_Body then 7008 Owner := N; 7009 7010 elsif Nkind_In (N, N_Protected_Type_Declaration, 7011 N_Single_Protected_Declaration) 7012 then 7013 Owner := Protected_Definition (N); 7014 7015 elsif Nkind_In (N, N_Single_Task_Declaration, 7016 N_Task_Type_Declaration) 7017 then 7018 Owner := Task_Definition (N); 7019 7020 -- This routine should not be called with other contexts 7021 7022 else 7023 pragma Assert (False); 7024 null; 7025 end if; 7026 7027 return End_Label_Loc (Owner); 7028 end End_Keyword_Location; 7029 7030 ------------------------ 7031 -- Ensure_Freeze_Node -- 7032 ------------------------ 7033 7034 procedure Ensure_Freeze_Node (E : Entity_Id) is 7035 FN : Node_Id; 7036 begin 7037 if No (Freeze_Node (E)) then 7038 FN := Make_Freeze_Entity (Sloc (E)); 7039 Set_Has_Delayed_Freeze (E); 7040 Set_Freeze_Node (E, FN); 7041 Set_Access_Types_To_Process (FN, No_Elist); 7042 Set_TSS_Elist (FN, No_Elist); 7043 Set_Entity (FN, E); 7044 end if; 7045 end Ensure_Freeze_Node; 7046 7047 ---------------- 7048 -- Enter_Name -- 7049 ---------------- 7050 7051 procedure Enter_Name (Def_Id : Entity_Id) is 7052 C : constant Entity_Id := Current_Entity (Def_Id); 7053 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); 7054 S : constant Entity_Id := Current_Scope; 7055 7056 begin 7057 Generate_Definition (Def_Id); 7058 7059 -- Add new name to current scope declarations. Check for duplicate 7060 -- declaration, which may or may not be a genuine error. 7061 7062 if Present (E) then 7063 7064 -- Case of previous entity entered because of a missing declaration 7065 -- or else a bad subtype indication. Best is to use the new entity, 7066 -- and make the previous one invisible. 7067 7068 if Etype (E) = Any_Type then 7069 Set_Is_Immediately_Visible (E, False); 7070 7071 -- Case of renaming declaration constructed for package instances. 7072 -- if there is an explicit declaration with the same identifier, 7073 -- the renaming is not immediately visible any longer, but remains 7074 -- visible through selected component notation. 7075 7076 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration 7077 and then not Comes_From_Source (E) 7078 then 7079 Set_Is_Immediately_Visible (E, False); 7080 7081 -- The new entity may be the package renaming, which has the same 7082 -- same name as a generic formal which has been seen already. 7083 7084 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration 7085 and then not Comes_From_Source (Def_Id) 7086 then 7087 Set_Is_Immediately_Visible (E, False); 7088 7089 -- For a fat pointer corresponding to a remote access to subprogram, 7090 -- we use the same identifier as the RAS type, so that the proper 7091 -- name appears in the stub. This type is only retrieved through 7092 -- the RAS type and never by visibility, and is not added to the 7093 -- visibility list (see below). 7094 7095 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration 7096 and then Ekind (Def_Id) = E_Record_Type 7097 and then Present (Corresponding_Remote_Type (Def_Id)) 7098 then 7099 null; 7100 7101 -- Case of an implicit operation or derived literal. The new entity 7102 -- hides the implicit one, which is removed from all visibility, 7103 -- i.e. the entity list of its scope, and homonym chain of its name. 7104 7105 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E)) 7106 or else Is_Internal (E) 7107 then 7108 declare 7109 Decl : constant Node_Id := Parent (E); 7110 Prev : Entity_Id; 7111 Prev_Vis : Entity_Id; 7112 7113 begin 7114 -- If E is an implicit declaration, it cannot be the first 7115 -- entity in the scope. 7116 7117 Prev := First_Entity (Current_Scope); 7118 while Present (Prev) and then Next_Entity (Prev) /= E loop 7119 Next_Entity (Prev); 7120 end loop; 7121 7122 if No (Prev) then 7123 7124 -- If E is not on the entity chain of the current scope, 7125 -- it is an implicit declaration in the generic formal 7126 -- part of a generic subprogram. When analyzing the body, 7127 -- the generic formals are visible but not on the entity 7128 -- chain of the subprogram. The new entity will become 7129 -- the visible one in the body. 7130 7131 pragma Assert 7132 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration); 7133 null; 7134 7135 else 7136 Link_Entities (Prev, Next_Entity (E)); 7137 7138 if No (Next_Entity (Prev)) then 7139 Set_Last_Entity (Current_Scope, Prev); 7140 end if; 7141 7142 if E = Current_Entity (E) then 7143 Prev_Vis := Empty; 7144 7145 else 7146 Prev_Vis := Current_Entity (E); 7147 while Homonym (Prev_Vis) /= E loop 7148 Prev_Vis := Homonym (Prev_Vis); 7149 end loop; 7150 end if; 7151 7152 if Present (Prev_Vis) then 7153 7154 -- Skip E in the visibility chain 7155 7156 Set_Homonym (Prev_Vis, Homonym (E)); 7157 7158 else 7159 Set_Name_Entity_Id (Chars (E), Homonym (E)); 7160 end if; 7161 end if; 7162 end; 7163 7164 -- This section of code could use a comment ??? 7165 7166 elsif Present (Etype (E)) 7167 and then Is_Concurrent_Type (Etype (E)) 7168 and then E = Def_Id 7169 then 7170 return; 7171 7172 -- If the homograph is a protected component renaming, it should not 7173 -- be hiding the current entity. Such renamings are treated as weak 7174 -- declarations. 7175 7176 elsif Is_Prival (E) then 7177 Set_Is_Immediately_Visible (E, False); 7178 7179 -- In this case the current entity is a protected component renaming. 7180 -- Perform minimal decoration by setting the scope and return since 7181 -- the prival should not be hiding other visible entities. 7182 7183 elsif Is_Prival (Def_Id) then 7184 Set_Scope (Def_Id, Current_Scope); 7185 return; 7186 7187 -- Analogous to privals, the discriminal generated for an entry index 7188 -- parameter acts as a weak declaration. Perform minimal decoration 7189 -- to avoid bogus errors. 7190 7191 elsif Is_Discriminal (Def_Id) 7192 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter 7193 then 7194 Set_Scope (Def_Id, Current_Scope); 7195 return; 7196 7197 -- In the body or private part of an instance, a type extension may 7198 -- introduce a component with the same name as that of an actual. The 7199 -- legality rule is not enforced, but the semantics of the full type 7200 -- with two components of same name are not clear at this point??? 7201 7202 elsif In_Instance_Not_Visible then 7203 null; 7204 7205 -- When compiling a package body, some child units may have become 7206 -- visible. They cannot conflict with local entities that hide them. 7207 7208 elsif Is_Child_Unit (E) 7209 and then In_Open_Scopes (Scope (E)) 7210 and then not Is_Immediately_Visible (E) 7211 then 7212 null; 7213 7214 -- Conversely, with front-end inlining we may compile the parent body 7215 -- first, and a child unit subsequently. The context is now the 7216 -- parent spec, and body entities are not visible. 7217 7218 elsif Is_Child_Unit (Def_Id) 7219 and then Is_Package_Body_Entity (E) 7220 and then not In_Package_Body (Current_Scope) 7221 then 7222 null; 7223 7224 -- Case of genuine duplicate declaration 7225 7226 else 7227 Error_Msg_Sloc := Sloc (E); 7228 7229 -- If the previous declaration is an incomplete type declaration 7230 -- this may be an attempt to complete it with a private type. The 7231 -- following avoids confusing cascaded errors. 7232 7233 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration 7234 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration 7235 then 7236 Error_Msg_N 7237 ("incomplete type cannot be completed with a private " & 7238 "declaration", Parent (Def_Id)); 7239 Set_Is_Immediately_Visible (E, False); 7240 Set_Full_View (E, Def_Id); 7241 7242 -- An inherited component of a record conflicts with a new 7243 -- discriminant. The discriminant is inserted first in the scope, 7244 -- but the error should be posted on it, not on the component. 7245 7246 elsif Ekind (E) = E_Discriminant 7247 and then Present (Scope (Def_Id)) 7248 and then Scope (Def_Id) /= Current_Scope 7249 then 7250 Error_Msg_Sloc := Sloc (Def_Id); 7251 Error_Msg_N ("& conflicts with declaration#", E); 7252 return; 7253 7254 -- If the name of the unit appears in its own context clause, a 7255 -- dummy package with the name has already been created, and the 7256 -- error emitted. Try to continue quietly. 7257 7258 elsif Error_Posted (E) 7259 and then Sloc (E) = No_Location 7260 and then Nkind (Parent (E)) = N_Package_Specification 7261 and then Current_Scope = Standard_Standard 7262 then 7263 Set_Scope (Def_Id, Current_Scope); 7264 return; 7265 7266 else 7267 Error_Msg_N ("& conflicts with declaration#", Def_Id); 7268 7269 -- Avoid cascaded messages with duplicate components in 7270 -- derived types. 7271 7272 if Ekind_In (E, E_Component, E_Discriminant) then 7273 return; 7274 end if; 7275 end if; 7276 7277 if Nkind (Parent (Parent (Def_Id))) = 7278 N_Generic_Subprogram_Declaration 7279 and then Def_Id = 7280 Defining_Entity (Specification (Parent (Parent (Def_Id)))) 7281 then 7282 Error_Msg_N ("\generic units cannot be overloaded", Def_Id); 7283 end if; 7284 7285 -- If entity is in standard, then we are in trouble, because it 7286 -- means that we have a library package with a duplicated name. 7287 -- That's hard to recover from, so abort. 7288 7289 if S = Standard_Standard then 7290 raise Unrecoverable_Error; 7291 7292 -- Otherwise we continue with the declaration. Having two 7293 -- identical declarations should not cause us too much trouble. 7294 7295 else 7296 null; 7297 end if; 7298 end if; 7299 end if; 7300 7301 -- If we fall through, declaration is OK, at least OK enough to continue 7302 7303 -- If Def_Id is a discriminant or a record component we are in the midst 7304 -- of inheriting components in a derived record definition. Preserve 7305 -- their Ekind and Etype. 7306 7307 if Ekind_In (Def_Id, E_Discriminant, E_Component) then 7308 null; 7309 7310 -- If a type is already set, leave it alone (happens when a type 7311 -- declaration is reanalyzed following a call to the optimizer). 7312 7313 elsif Present (Etype (Def_Id)) then 7314 null; 7315 7316 -- Otherwise, the kind E_Void insures that premature uses of the entity 7317 -- will be detected. Any_Type insures that no cascaded errors will occur 7318 7319 else 7320 Set_Ekind (Def_Id, E_Void); 7321 Set_Etype (Def_Id, Any_Type); 7322 end if; 7323 7324 -- Inherited discriminants and components in derived record types are 7325 -- immediately visible. Itypes are not. 7326 7327 -- Unless the Itype is for a record type with a corresponding remote 7328 -- type (what is that about, it was not commented ???) 7329 7330 if Ekind_In (Def_Id, E_Discriminant, E_Component) 7331 or else 7332 ((not Is_Record_Type (Def_Id) 7333 or else No (Corresponding_Remote_Type (Def_Id))) 7334 and then not Is_Itype (Def_Id)) 7335 then 7336 Set_Is_Immediately_Visible (Def_Id); 7337 Set_Current_Entity (Def_Id); 7338 end if; 7339 7340 Set_Homonym (Def_Id, C); 7341 Append_Entity (Def_Id, S); 7342 Set_Public_Status (Def_Id); 7343 7344 -- Declaring a homonym is not allowed in SPARK ... 7345 7346 if Present (C) and then Restriction_Check_Required (SPARK_05) then 7347 declare 7348 Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id); 7349 Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id); 7350 Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C); 7351 7352 begin 7353 -- ... unless the new declaration is in a subprogram, and the 7354 -- visible declaration is a variable declaration or a parameter 7355 -- specification outside that subprogram. 7356 7357 if Present (Enclosing_Subp) 7358 and then Nkind_In (Parent (C), N_Object_Declaration, 7359 N_Parameter_Specification) 7360 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp) 7361 then 7362 null; 7363 7364 -- ... or the new declaration is in a package, and the visible 7365 -- declaration occurs outside that package. 7366 7367 elsif Present (Enclosing_Pack) 7368 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack) 7369 then 7370 null; 7371 7372 -- ... or the new declaration is a component declaration in a 7373 -- record type definition. 7374 7375 elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then 7376 null; 7377 7378 -- Don't issue error for non-source entities 7379 7380 elsif Comes_From_Source (Def_Id) 7381 and then Comes_From_Source (C) 7382 then 7383 Error_Msg_Sloc := Sloc (C); 7384 Check_SPARK_05_Restriction 7385 ("redeclaration of identifier &#", Def_Id); 7386 end if; 7387 end; 7388 end if; 7389 7390 -- Warn if new entity hides an old one 7391 7392 if Warn_On_Hiding and then Present (C) 7393 7394 -- Don't warn for record components since they always have a well 7395 -- defined scope which does not confuse other uses. Note that in 7396 -- some cases, Ekind has not been set yet. 7397 7398 and then Ekind (C) /= E_Component 7399 and then Ekind (C) /= E_Discriminant 7400 and then Nkind (Parent (C)) /= N_Component_Declaration 7401 and then Ekind (Def_Id) /= E_Component 7402 and then Ekind (Def_Id) /= E_Discriminant 7403 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration 7404 7405 -- Don't warn for one character variables. It is too common to use 7406 -- such variables as locals and will just cause too many false hits. 7407 7408 and then Length_Of_Name (Chars (C)) /= 1 7409 7410 -- Don't warn for non-source entities 7411 7412 and then Comes_From_Source (C) 7413 and then Comes_From_Source (Def_Id) 7414 7415 -- Don't warn unless entity in question is in extended main source 7416 7417 and then In_Extended_Main_Source_Unit (Def_Id) 7418 7419 -- Finally, the hidden entity must be either immediately visible or 7420 -- use visible (i.e. from a used package). 7421 7422 and then 7423 (Is_Immediately_Visible (C) 7424 or else 7425 Is_Potentially_Use_Visible (C)) 7426 then 7427 Error_Msg_Sloc := Sloc (C); 7428 Error_Msg_N ("declaration hides &#?h?", Def_Id); 7429 end if; 7430 end Enter_Name; 7431 7432 --------------- 7433 -- Entity_Of -- 7434 --------------- 7435 7436 function Entity_Of (N : Node_Id) return Entity_Id is 7437 Id : Entity_Id; 7438 Ren : Node_Id; 7439 7440 begin 7441 -- Assume that the arbitrary node does not have an entity 7442 7443 Id := Empty; 7444 7445 if Is_Entity_Name (N) then 7446 Id := Entity (N); 7447 7448 -- Follow a possible chain of renamings to reach the earliest renamed 7449 -- source object. 7450 7451 while Present (Id) 7452 and then Is_Object (Id) 7453 and then Present (Renamed_Object (Id)) 7454 loop 7455 Ren := Renamed_Object (Id); 7456 7457 -- The reference renames an abstract state or a whole object 7458 7459 -- Obj : ...; 7460 -- Ren : ... renames Obj; 7461 7462 if Is_Entity_Name (Ren) then 7463 7464 -- Do not follow a renaming that goes through a generic formal, 7465 -- because these entities are hidden and must not be referenced 7466 -- from outside the generic. 7467 7468 if Is_Hidden (Entity (Ren)) then 7469 exit; 7470 7471 else 7472 Id := Entity (Ren); 7473 end if; 7474 7475 -- The reference renames a function result. Check the original 7476 -- node in case expansion relocates the function call. 7477 7478 -- Ren : ... renames Func_Call; 7479 7480 elsif Nkind (Original_Node (Ren)) = N_Function_Call then 7481 exit; 7482 7483 -- Otherwise the reference renames something which does not yield 7484 -- an abstract state or a whole object. Treat the reference as not 7485 -- having a proper entity for SPARK legality purposes. 7486 7487 else 7488 Id := Empty; 7489 exit; 7490 end if; 7491 end loop; 7492 end if; 7493 7494 return Id; 7495 end Entity_Of; 7496 7497 -------------------------- 7498 -- Examine_Array_Bounds -- 7499 -------------------------- 7500 7501 procedure Examine_Array_Bounds 7502 (Typ : Entity_Id; 7503 All_Static : out Boolean; 7504 Has_Empty : out Boolean) 7505 is 7506 function Is_OK_Static_Bound (Bound : Node_Id) return Boolean; 7507 -- Determine whether bound Bound is a suitable static bound 7508 7509 ------------------------ 7510 -- Is_OK_Static_Bound -- 7511 ------------------------ 7512 7513 function Is_OK_Static_Bound (Bound : Node_Id) return Boolean is 7514 begin 7515 return 7516 not Error_Posted (Bound) 7517 and then Is_OK_Static_Expression (Bound); 7518 end Is_OK_Static_Bound; 7519 7520 -- Local variables 7521 7522 Hi_Bound : Node_Id; 7523 Index : Node_Id; 7524 Lo_Bound : Node_Id; 7525 7526 -- Start of processing for Examine_Array_Bounds 7527 7528 begin 7529 -- An unconstrained array type does not have static bounds, and it is 7530 -- not known whether they are empty or not. 7531 7532 if not Is_Constrained (Typ) then 7533 All_Static := False; 7534 Has_Empty := False; 7535 7536 -- A string literal has static bounds, and is not empty as long as it 7537 -- contains at least one character. 7538 7539 elsif Ekind (Typ) = E_String_Literal_Subtype then 7540 All_Static := True; 7541 Has_Empty := String_Literal_Length (Typ) > 0; 7542 end if; 7543 7544 -- Assume that all bounds are static and not empty 7545 7546 All_Static := True; 7547 Has_Empty := False; 7548 7549 -- Examine each index 7550 7551 Index := First_Index (Typ); 7552 while Present (Index) loop 7553 if Is_Discrete_Type (Etype (Index)) then 7554 Get_Index_Bounds (Index, Lo_Bound, Hi_Bound); 7555 7556 if Is_OK_Static_Bound (Lo_Bound) 7557 and then 7558 Is_OK_Static_Bound (Hi_Bound) 7559 then 7560 -- The static bounds produce an empty range 7561 7562 if Is_Null_Range (Lo_Bound, Hi_Bound) then 7563 Has_Empty := True; 7564 end if; 7565 7566 -- Otherwise at least one of the bounds is not static 7567 7568 else 7569 All_Static := False; 7570 end if; 7571 7572 -- Otherwise the index is non-discrete, therefore not static 7573 7574 else 7575 All_Static := False; 7576 end if; 7577 7578 Next_Index (Index); 7579 end loop; 7580 end Examine_Array_Bounds; 7581 7582 -------------------------- 7583 -- Explain_Limited_Type -- 7584 -------------------------- 7585 7586 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is 7587 C : Entity_Id; 7588 7589 begin 7590 -- For array, component type must be limited 7591 7592 if Is_Array_Type (T) then 7593 Error_Msg_Node_2 := T; 7594 Error_Msg_NE 7595 ("\component type& of type& is limited", N, Component_Type (T)); 7596 Explain_Limited_Type (Component_Type (T), N); 7597 7598 elsif Is_Record_Type (T) then 7599 7600 -- No need for extra messages if explicit limited record 7601 7602 if Is_Limited_Record (Base_Type (T)) then 7603 return; 7604 end if; 7605 7606 -- Otherwise find a limited component. Check only components that 7607 -- come from source, or inherited components that appear in the 7608 -- source of the ancestor. 7609 7610 C := First_Component (T); 7611 while Present (C) loop 7612 if Is_Limited_Type (Etype (C)) 7613 and then 7614 (Comes_From_Source (C) 7615 or else 7616 (Present (Original_Record_Component (C)) 7617 and then 7618 Comes_From_Source (Original_Record_Component (C)))) 7619 then 7620 Error_Msg_Node_2 := T; 7621 Error_Msg_NE ("\component& of type& has limited type", N, C); 7622 Explain_Limited_Type (Etype (C), N); 7623 return; 7624 end if; 7625 7626 Next_Component (C); 7627 end loop; 7628 7629 -- The type may be declared explicitly limited, even if no component 7630 -- of it is limited, in which case we fall out of the loop. 7631 return; 7632 end if; 7633 end Explain_Limited_Type; 7634 7635 --------------------------------------- 7636 -- Expression_Of_Expression_Function -- 7637 --------------------------------------- 7638 7639 function Expression_Of_Expression_Function 7640 (Subp : Entity_Id) return Node_Id 7641 is 7642 Expr_Func : Node_Id; 7643 7644 begin 7645 pragma Assert (Is_Expression_Function_Or_Completion (Subp)); 7646 7647 if Nkind (Original_Node (Subprogram_Spec (Subp))) = 7648 N_Expression_Function 7649 then 7650 Expr_Func := Original_Node (Subprogram_Spec (Subp)); 7651 7652 elsif Nkind (Original_Node (Subprogram_Body (Subp))) = 7653 N_Expression_Function 7654 then 7655 Expr_Func := Original_Node (Subprogram_Body (Subp)); 7656 7657 else 7658 pragma Assert (False); 7659 null; 7660 end if; 7661 7662 return Original_Node (Expression (Expr_Func)); 7663 end Expression_Of_Expression_Function; 7664 7665 ------------------------------- 7666 -- Extensions_Visible_Status -- 7667 ------------------------------- 7668 7669 function Extensions_Visible_Status 7670 (Id : Entity_Id) return Extensions_Visible_Mode 7671 is 7672 Arg : Node_Id; 7673 Decl : Node_Id; 7674 Expr : Node_Id; 7675 Prag : Node_Id; 7676 Subp : Entity_Id; 7677 7678 begin 7679 -- When a formal parameter is subject to Extensions_Visible, the pragma 7680 -- is stored in the contract of related subprogram. 7681 7682 if Is_Formal (Id) then 7683 Subp := Scope (Id); 7684 7685 elsif Is_Subprogram_Or_Generic_Subprogram (Id) then 7686 Subp := Id; 7687 7688 -- No other construct carries this pragma 7689 7690 else 7691 return Extensions_Visible_None; 7692 end if; 7693 7694 Prag := Get_Pragma (Subp, Pragma_Extensions_Visible); 7695 7696 -- In certain cases analysis may request the Extensions_Visible status 7697 -- of an expression function before the pragma has been analyzed yet. 7698 -- Inspect the declarative items after the expression function looking 7699 -- for the pragma (if any). 7700 7701 if No (Prag) and then Is_Expression_Function (Subp) then 7702 Decl := Next (Unit_Declaration_Node (Subp)); 7703 while Present (Decl) loop 7704 if Nkind (Decl) = N_Pragma 7705 and then Pragma_Name (Decl) = Name_Extensions_Visible 7706 then 7707 Prag := Decl; 7708 exit; 7709 7710 -- A source construct ends the region where Extensions_Visible may 7711 -- appear, stop the traversal. An expanded expression function is 7712 -- no longer a source construct, but it must still be recognized. 7713 7714 elsif Comes_From_Source (Decl) 7715 or else 7716 (Nkind_In (Decl, N_Subprogram_Body, 7717 N_Subprogram_Declaration) 7718 and then Is_Expression_Function (Defining_Entity (Decl))) 7719 then 7720 exit; 7721 end if; 7722 7723 Next (Decl); 7724 end loop; 7725 end if; 7726 7727 -- Extract the value from the Boolean expression (if any) 7728 7729 if Present (Prag) then 7730 Arg := First (Pragma_Argument_Associations (Prag)); 7731 7732 if Present (Arg) then 7733 Expr := Get_Pragma_Arg (Arg); 7734 7735 -- When the associated subprogram is an expression function, the 7736 -- argument of the pragma may not have been analyzed. 7737 7738 if not Analyzed (Expr) then 7739 Preanalyze_And_Resolve (Expr, Standard_Boolean); 7740 end if; 7741 7742 -- Guard against cascading errors when the argument of pragma 7743 -- Extensions_Visible is not a valid static Boolean expression. 7744 7745 if Error_Posted (Expr) then 7746 return Extensions_Visible_None; 7747 7748 elsif Is_True (Expr_Value (Expr)) then 7749 return Extensions_Visible_True; 7750 7751 else 7752 return Extensions_Visible_False; 7753 end if; 7754 7755 -- Otherwise the aspect or pragma defaults to True 7756 7757 else 7758 return Extensions_Visible_True; 7759 end if; 7760 7761 -- Otherwise aspect or pragma Extensions_Visible is not inherited or 7762 -- directly specified. In SPARK code, its value defaults to "False". 7763 7764 elsif SPARK_Mode = On then 7765 return Extensions_Visible_False; 7766 7767 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to 7768 -- "True". 7769 7770 else 7771 return Extensions_Visible_True; 7772 end if; 7773 end Extensions_Visible_Status; 7774 7775 ----------------- 7776 -- Find_Actual -- 7777 ----------------- 7778 7779 procedure Find_Actual 7780 (N : Node_Id; 7781 Formal : out Entity_Id; 7782 Call : out Node_Id) 7783 is 7784 Context : constant Node_Id := Parent (N); 7785 Actual : Node_Id; 7786 Call_Nam : Node_Id; 7787 7788 begin 7789 if Nkind_In (Context, N_Indexed_Component, N_Selected_Component) 7790 and then N = Prefix (Context) 7791 then 7792 Find_Actual (Context, Formal, Call); 7793 return; 7794 7795 elsif Nkind (Context) = N_Parameter_Association 7796 and then N = Explicit_Actual_Parameter (Context) 7797 then 7798 Call := Parent (Context); 7799 7800 elsif Nkind_In (Context, N_Entry_Call_Statement, 7801 N_Function_Call, 7802 N_Procedure_Call_Statement) 7803 then 7804 Call := Context; 7805 7806 else 7807 Formal := Empty; 7808 Call := Empty; 7809 return; 7810 end if; 7811 7812 -- If we have a call to a subprogram look for the parameter. Note that 7813 -- we exclude overloaded calls, since we don't know enough to be sure 7814 -- of giving the right answer in this case. 7815 7816 if Nkind_In (Call, N_Entry_Call_Statement, 7817 N_Function_Call, 7818 N_Procedure_Call_Statement) 7819 then 7820 Call_Nam := Name (Call); 7821 7822 -- A call to a protected or task entry appears as a selected 7823 -- component rather than an expanded name. 7824 7825 if Nkind (Call_Nam) = N_Selected_Component then 7826 Call_Nam := Selector_Name (Call_Nam); 7827 end if; 7828 7829 if Is_Entity_Name (Call_Nam) 7830 and then Present (Entity (Call_Nam)) 7831 and then Is_Overloadable (Entity (Call_Nam)) 7832 and then not Is_Overloaded (Call_Nam) 7833 then 7834 -- If node is name in call it is not an actual 7835 7836 if N = Call_Nam then 7837 Formal := Empty; 7838 Call := Empty; 7839 return; 7840 end if; 7841 7842 -- Fall here if we are definitely a parameter 7843 7844 Actual := First_Actual (Call); 7845 Formal := First_Formal (Entity (Call_Nam)); 7846 while Present (Formal) and then Present (Actual) loop 7847 if Actual = N then 7848 return; 7849 7850 -- An actual that is the prefix in a prefixed call may have 7851 -- been rewritten in the call, after the deferred reference 7852 -- was collected. Check if sloc and kinds and names match. 7853 7854 elsif Sloc (Actual) = Sloc (N) 7855 and then Nkind (Actual) = N_Identifier 7856 and then Nkind (Actual) = Nkind (N) 7857 and then Chars (Actual) = Chars (N) 7858 then 7859 return; 7860 7861 else 7862 Actual := Next_Actual (Actual); 7863 Formal := Next_Formal (Formal); 7864 end if; 7865 end loop; 7866 end if; 7867 end if; 7868 7869 -- Fall through here if we did not find matching actual 7870 7871 Formal := Empty; 7872 Call := Empty; 7873 end Find_Actual; 7874 7875 --------------------------- 7876 -- Find_Body_Discriminal -- 7877 --------------------------- 7878 7879 function Find_Body_Discriminal 7880 (Spec_Discriminant : Entity_Id) return Entity_Id 7881 is 7882 Tsk : Entity_Id; 7883 Disc : Entity_Id; 7884 7885 begin 7886 -- If expansion is suppressed, then the scope can be the concurrent type 7887 -- itself rather than a corresponding concurrent record type. 7888 7889 if Is_Concurrent_Type (Scope (Spec_Discriminant)) then 7890 Tsk := Scope (Spec_Discriminant); 7891 7892 else 7893 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant))); 7894 7895 Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant)); 7896 end if; 7897 7898 -- Find discriminant of original concurrent type, and use its current 7899 -- discriminal, which is the renaming within the task/protected body. 7900 7901 Disc := First_Discriminant (Tsk); 7902 while Present (Disc) loop 7903 if Chars (Disc) = Chars (Spec_Discriminant) then 7904 return Discriminal (Disc); 7905 end if; 7906 7907 Next_Discriminant (Disc); 7908 end loop; 7909 7910 -- That loop should always succeed in finding a matching entry and 7911 -- returning. Fatal error if not. 7912 7913 raise Program_Error; 7914 end Find_Body_Discriminal; 7915 7916 ------------------------------------- 7917 -- Find_Corresponding_Discriminant -- 7918 ------------------------------------- 7919 7920 function Find_Corresponding_Discriminant 7921 (Id : Node_Id; 7922 Typ : Entity_Id) return Entity_Id 7923 is 7924 Par_Disc : Entity_Id; 7925 Old_Disc : Entity_Id; 7926 New_Disc : Entity_Id; 7927 7928 begin 7929 Par_Disc := Original_Record_Component (Original_Discriminant (Id)); 7930 7931 -- The original type may currently be private, and the discriminant 7932 -- only appear on its full view. 7933 7934 if Is_Private_Type (Scope (Par_Disc)) 7935 and then not Has_Discriminants (Scope (Par_Disc)) 7936 and then Present (Full_View (Scope (Par_Disc))) 7937 then 7938 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc))); 7939 else 7940 Old_Disc := First_Discriminant (Scope (Par_Disc)); 7941 end if; 7942 7943 if Is_Class_Wide_Type (Typ) then 7944 New_Disc := First_Discriminant (Root_Type (Typ)); 7945 else 7946 New_Disc := First_Discriminant (Typ); 7947 end if; 7948 7949 while Present (Old_Disc) and then Present (New_Disc) loop 7950 if Old_Disc = Par_Disc then 7951 return New_Disc; 7952 end if; 7953 7954 Next_Discriminant (Old_Disc); 7955 Next_Discriminant (New_Disc); 7956 end loop; 7957 7958 -- Should always find it 7959 7960 raise Program_Error; 7961 end Find_Corresponding_Discriminant; 7962 7963 ------------------- 7964 -- Find_DIC_Type -- 7965 ------------------- 7966 7967 function Find_DIC_Type (Typ : Entity_Id) return Entity_Id is 7968 Curr_Typ : Entity_Id; 7969 -- The current type being examined in the parent hierarchy traversal 7970 7971 DIC_Typ : Entity_Id; 7972 -- The type which carries the DIC pragma. This variable denotes the 7973 -- partial view when private types are involved. 7974 7975 Par_Typ : Entity_Id; 7976 -- The parent type of the current type. This variable denotes the full 7977 -- view when private types are involved. 7978 7979 begin 7980 -- The input type defines its own DIC pragma, therefore it is the owner 7981 7982 if Has_Own_DIC (Typ) then 7983 DIC_Typ := Typ; 7984 7985 -- Otherwise the DIC pragma is inherited from a parent type 7986 7987 else 7988 pragma Assert (Has_Inherited_DIC (Typ)); 7989 7990 -- Climb the parent chain 7991 7992 Curr_Typ := Typ; 7993 loop 7994 -- Inspect the parent type. Do not consider subtypes as they 7995 -- inherit the DIC attributes from their base types. 7996 7997 DIC_Typ := Base_Type (Etype (Curr_Typ)); 7998 7999 -- Look at the full view of a private type because the type may 8000 -- have a hidden parent introduced in the full view. 8001 8002 Par_Typ := DIC_Typ; 8003 8004 if Is_Private_Type (Par_Typ) 8005 and then Present (Full_View (Par_Typ)) 8006 then 8007 Par_Typ := Full_View (Par_Typ); 8008 end if; 8009 8010 -- Stop the climb once the nearest parent type which defines a DIC 8011 -- pragma of its own is encountered or when the root of the parent 8012 -- chain is reached. 8013 8014 exit when Has_Own_DIC (DIC_Typ) or else Curr_Typ = Par_Typ; 8015 8016 Curr_Typ := Par_Typ; 8017 end loop; 8018 end if; 8019 8020 return DIC_Typ; 8021 end Find_DIC_Type; 8022 8023 ---------------------------------- 8024 -- Find_Enclosing_Iterator_Loop -- 8025 ---------------------------------- 8026 8027 function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id is 8028 Constr : Node_Id; 8029 S : Entity_Id; 8030 8031 begin 8032 -- Traverse the scope chain looking for an iterator loop. Such loops are 8033 -- usually transformed into blocks, hence the use of Original_Node. 8034 8035 S := Id; 8036 while Present (S) and then S /= Standard_Standard loop 8037 if Ekind (S) = E_Loop 8038 and then Nkind (Parent (S)) = N_Implicit_Label_Declaration 8039 then 8040 Constr := Original_Node (Label_Construct (Parent (S))); 8041 8042 if Nkind (Constr) = N_Loop_Statement 8043 and then Present (Iteration_Scheme (Constr)) 8044 and then Nkind (Iterator_Specification 8045 (Iteration_Scheme (Constr))) = 8046 N_Iterator_Specification 8047 then 8048 return S; 8049 end if; 8050 end if; 8051 8052 S := Scope (S); 8053 end loop; 8054 8055 return Empty; 8056 end Find_Enclosing_Iterator_Loop; 8057 8058 -------------------------- 8059 -- Find_Enclosing_Scope -- 8060 -------------------------- 8061 8062 function Find_Enclosing_Scope (N : Node_Id) return Entity_Id is 8063 Par : Node_Id; 8064 8065 begin 8066 -- Examine the parent chain looking for a construct which defines a 8067 -- scope. 8068 8069 Par := Parent (N); 8070 while Present (Par) loop 8071 case Nkind (Par) is 8072 8073 -- The construct denotes a declaration, the proper scope is its 8074 -- entity. 8075 8076 when N_Entry_Declaration 8077 | N_Expression_Function 8078 | N_Full_Type_Declaration 8079 | N_Generic_Package_Declaration 8080 | N_Generic_Subprogram_Declaration 8081 | N_Package_Declaration 8082 | N_Private_Extension_Declaration 8083 | N_Protected_Type_Declaration 8084 | N_Single_Protected_Declaration 8085 | N_Single_Task_Declaration 8086 | N_Subprogram_Declaration 8087 | N_Task_Type_Declaration 8088 => 8089 return Defining_Entity (Par); 8090 8091 -- The construct denotes a body, the proper scope is the entity of 8092 -- the corresponding spec or that of the body if the body does not 8093 -- complete a previous declaration. 8094 8095 when N_Entry_Body 8096 | N_Package_Body 8097 | N_Protected_Body 8098 | N_Subprogram_Body 8099 | N_Task_Body 8100 => 8101 return Unique_Defining_Entity (Par); 8102 8103 -- Special cases 8104 8105 -- Blocks carry either a source or an internally-generated scope, 8106 -- unless the block is a byproduct of exception handling. 8107 8108 when N_Block_Statement => 8109 if not Exception_Junk (Par) then 8110 return Entity (Identifier (Par)); 8111 end if; 8112 8113 -- Loops carry an internally-generated scope 8114 8115 when N_Loop_Statement => 8116 return Entity (Identifier (Par)); 8117 8118 -- Extended return statements carry an internally-generated scope 8119 8120 when N_Extended_Return_Statement => 8121 return Return_Statement_Entity (Par); 8122 8123 -- A traversal from a subunit continues via the corresponding stub 8124 8125 when N_Subunit => 8126 Par := Corresponding_Stub (Par); 8127 8128 when others => 8129 null; 8130 end case; 8131 8132 Par := Parent (Par); 8133 end loop; 8134 8135 return Standard_Standard; 8136 end Find_Enclosing_Scope; 8137 8138 ------------------------------------ 8139 -- Find_Loop_In_Conditional_Block -- 8140 ------------------------------------ 8141 8142 function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is 8143 Stmt : Node_Id; 8144 8145 begin 8146 Stmt := N; 8147 8148 if Nkind (Stmt) = N_If_Statement then 8149 Stmt := First (Then_Statements (Stmt)); 8150 end if; 8151 8152 pragma Assert (Nkind (Stmt) = N_Block_Statement); 8153 8154 -- Inspect the statements of the conditional block. In general the loop 8155 -- should be the first statement in the statement sequence of the block, 8156 -- but the finalization machinery may have introduced extra object 8157 -- declarations. 8158 8159 Stmt := First (Statements (Handled_Statement_Sequence (Stmt))); 8160 while Present (Stmt) loop 8161 if Nkind (Stmt) = N_Loop_Statement then 8162 return Stmt; 8163 end if; 8164 8165 Next (Stmt); 8166 end loop; 8167 8168 -- The expansion of attribute 'Loop_Entry produced a malformed block 8169 8170 raise Program_Error; 8171 end Find_Loop_In_Conditional_Block; 8172 8173 -------------------------- 8174 -- Find_Overlaid_Entity -- 8175 -------------------------- 8176 8177 procedure Find_Overlaid_Entity 8178 (N : Node_Id; 8179 Ent : out Entity_Id; 8180 Off : out Boolean) 8181 is 8182 Expr : Node_Id; 8183 8184 begin 8185 -- We are looking for one of the two following forms: 8186 8187 -- for X'Address use Y'Address 8188 8189 -- or 8190 8191 -- Const : constant Address := expr; 8192 -- ... 8193 -- for X'Address use Const; 8194 8195 -- In the second case, the expr is either Y'Address, or recursively a 8196 -- constant that eventually references Y'Address. 8197 8198 Ent := Empty; 8199 Off := False; 8200 8201 if Nkind (N) = N_Attribute_Definition_Clause 8202 and then Chars (N) = Name_Address 8203 then 8204 Expr := Expression (N); 8205 8206 -- This loop checks the form of the expression for Y'Address, 8207 -- using recursion to deal with intermediate constants. 8208 8209 loop 8210 -- Check for Y'Address 8211 8212 if Nkind (Expr) = N_Attribute_Reference 8213 and then Attribute_Name (Expr) = Name_Address 8214 then 8215 Expr := Prefix (Expr); 8216 exit; 8217 8218 -- Check for Const where Const is a constant entity 8219 8220 elsif Is_Entity_Name (Expr) 8221 and then Ekind (Entity (Expr)) = E_Constant 8222 then 8223 Expr := Constant_Value (Entity (Expr)); 8224 8225 -- Anything else does not need checking 8226 8227 else 8228 return; 8229 end if; 8230 end loop; 8231 8232 -- This loop checks the form of the prefix for an entity, using 8233 -- recursion to deal with intermediate components. 8234 8235 loop 8236 -- Check for Y where Y is an entity 8237 8238 if Is_Entity_Name (Expr) then 8239 Ent := Entity (Expr); 8240 return; 8241 8242 -- Check for components 8243 8244 elsif 8245 Nkind_In (Expr, N_Selected_Component, N_Indexed_Component) 8246 then 8247 Expr := Prefix (Expr); 8248 Off := True; 8249 8250 -- Anything else does not need checking 8251 8252 else 8253 return; 8254 end if; 8255 end loop; 8256 end if; 8257 end Find_Overlaid_Entity; 8258 8259 ------------------------- 8260 -- Find_Parameter_Type -- 8261 ------------------------- 8262 8263 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is 8264 begin 8265 if Nkind (Param) /= N_Parameter_Specification then 8266 return Empty; 8267 8268 -- For an access parameter, obtain the type from the formal entity 8269 -- itself, because access to subprogram nodes do not carry a type. 8270 -- Shouldn't we always use the formal entity ??? 8271 8272 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then 8273 return Etype (Defining_Identifier (Param)); 8274 8275 else 8276 return Etype (Parameter_Type (Param)); 8277 end if; 8278 end Find_Parameter_Type; 8279 8280 ----------------------------------- 8281 -- Find_Placement_In_State_Space -- 8282 ----------------------------------- 8283 8284 procedure Find_Placement_In_State_Space 8285 (Item_Id : Entity_Id; 8286 Placement : out State_Space_Kind; 8287 Pack_Id : out Entity_Id) 8288 is 8289 Context : Entity_Id; 8290 8291 begin 8292 -- Assume that the item does not appear in the state space of a package 8293 8294 Placement := Not_In_Package; 8295 Pack_Id := Empty; 8296 8297 -- Climb the scope stack and examine the enclosing context 8298 8299 Context := Scope (Item_Id); 8300 while Present (Context) and then Context /= Standard_Standard loop 8301 if Is_Package_Or_Generic_Package (Context) then 8302 Pack_Id := Context; 8303 8304 -- A package body is a cut off point for the traversal as the item 8305 -- cannot be visible to the outside from this point on. Note that 8306 -- this test must be done first as a body is also classified as a 8307 -- private part. 8308 8309 if In_Package_Body (Context) then 8310 Placement := Body_State_Space; 8311 return; 8312 8313 -- The private part of a package is a cut off point for the 8314 -- traversal as the item cannot be visible to the outside from 8315 -- this point on. 8316 8317 elsif In_Private_Part (Context) then 8318 Placement := Private_State_Space; 8319 return; 8320 8321 -- When the item appears in the visible state space of a package, 8322 -- continue to climb the scope stack as this may not be the final 8323 -- state space. 8324 8325 else 8326 Placement := Visible_State_Space; 8327 8328 -- The visible state space of a child unit acts as the proper 8329 -- placement of an item. 8330 8331 if Is_Child_Unit (Context) then 8332 return; 8333 end if; 8334 end if; 8335 8336 -- The item or its enclosing package appear in a construct that has 8337 -- no state space. 8338 8339 else 8340 Placement := Not_In_Package; 8341 return; 8342 end if; 8343 8344 Context := Scope (Context); 8345 end loop; 8346 end Find_Placement_In_State_Space; 8347 8348 ----------------------- 8349 -- Find_Primitive_Eq -- 8350 ----------------------- 8351 8352 function Find_Primitive_Eq (Typ : Entity_Id) return Entity_Id is 8353 function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id; 8354 -- Search for the equality primitive; return Empty if the primitive is 8355 -- not found. 8356 8357 ------------------ 8358 -- Find_Eq_Prim -- 8359 ------------------ 8360 8361 function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id is 8362 Prim : Entity_Id; 8363 Prim_Elmt : Elmt_Id; 8364 8365 begin 8366 Prim_Elmt := First_Elmt (Prims_List); 8367 while Present (Prim_Elmt) loop 8368 Prim := Node (Prim_Elmt); 8369 8370 -- Locate primitive equality with the right signature 8371 8372 if Chars (Prim) = Name_Op_Eq 8373 and then Etype (First_Formal (Prim)) = 8374 Etype (Next_Formal (First_Formal (Prim))) 8375 and then Base_Type (Etype (Prim)) = Standard_Boolean 8376 then 8377 return Prim; 8378 end if; 8379 8380 Next_Elmt (Prim_Elmt); 8381 end loop; 8382 8383 return Empty; 8384 end Find_Eq_Prim; 8385 8386 -- Local Variables 8387 8388 Eq_Prim : Entity_Id; 8389 Full_Type : Entity_Id; 8390 8391 -- Start of processing for Find_Primitive_Eq 8392 8393 begin 8394 if Is_Private_Type (Typ) then 8395 Full_Type := Underlying_Type (Typ); 8396 else 8397 Full_Type := Typ; 8398 end if; 8399 8400 if No (Full_Type) then 8401 return Empty; 8402 end if; 8403 8404 Full_Type := Base_Type (Full_Type); 8405 8406 -- When the base type itself is private, use the full view 8407 8408 if Is_Private_Type (Full_Type) then 8409 Full_Type := Underlying_Type (Full_Type); 8410 end if; 8411 8412 if Is_Class_Wide_Type (Full_Type) then 8413 Full_Type := Root_Type (Full_Type); 8414 end if; 8415 8416 if not Is_Tagged_Type (Full_Type) then 8417 Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ)); 8418 8419 -- If this is an untagged private type completed with a derivation of 8420 -- an untagged private type whose full view is a tagged type, we use 8421 -- the primitive operations of the private parent type (since it does 8422 -- not have a full view, and also because its equality primitive may 8423 -- have been overridden in its untagged full view). If no equality was 8424 -- defined for it then take its dispatching equality primitive. 8425 8426 elsif Inherits_From_Tagged_Full_View (Typ) then 8427 Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ)); 8428 8429 if No (Eq_Prim) then 8430 Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type)); 8431 end if; 8432 8433 else 8434 Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type)); 8435 end if; 8436 8437 return Eq_Prim; 8438 end Find_Primitive_Eq; 8439 8440 ------------------------ 8441 -- Find_Specific_Type -- 8442 ------------------------ 8443 8444 function Find_Specific_Type (CW : Entity_Id) return Entity_Id is 8445 Typ : Entity_Id := Root_Type (CW); 8446 8447 begin 8448 if Ekind (Typ) = E_Incomplete_Type then 8449 if From_Limited_With (Typ) then 8450 Typ := Non_Limited_View (Typ); 8451 else 8452 Typ := Full_View (Typ); 8453 end if; 8454 end if; 8455 8456 if Is_Private_Type (Typ) 8457 and then not Is_Tagged_Type (Typ) 8458 and then Present (Full_View (Typ)) 8459 then 8460 return Full_View (Typ); 8461 else 8462 return Typ; 8463 end if; 8464 end Find_Specific_Type; 8465 8466 ----------------------------- 8467 -- Find_Static_Alternative -- 8468 ----------------------------- 8469 8470 function Find_Static_Alternative (N : Node_Id) return Node_Id is 8471 Expr : constant Node_Id := Expression (N); 8472 Val : constant Uint := Expr_Value (Expr); 8473 Alt : Node_Id; 8474 Choice : Node_Id; 8475 8476 begin 8477 Alt := First (Alternatives (N)); 8478 8479 Search : loop 8480 if Nkind (Alt) /= N_Pragma then 8481 Choice := First (Discrete_Choices (Alt)); 8482 while Present (Choice) loop 8483 8484 -- Others choice, always matches 8485 8486 if Nkind (Choice) = N_Others_Choice then 8487 exit Search; 8488 8489 -- Range, check if value is in the range 8490 8491 elsif Nkind (Choice) = N_Range then 8492 exit Search when 8493 Val >= Expr_Value (Low_Bound (Choice)) 8494 and then 8495 Val <= Expr_Value (High_Bound (Choice)); 8496 8497 -- Choice is a subtype name. Note that we know it must 8498 -- be a static subtype, since otherwise it would have 8499 -- been diagnosed as illegal. 8500 8501 elsif Is_Entity_Name (Choice) 8502 and then Is_Type (Entity (Choice)) 8503 then 8504 exit Search when Is_In_Range (Expr, Etype (Choice), 8505 Assume_Valid => False); 8506 8507 -- Choice is a subtype indication 8508 8509 elsif Nkind (Choice) = N_Subtype_Indication then 8510 declare 8511 C : constant Node_Id := Constraint (Choice); 8512 R : constant Node_Id := Range_Expression (C); 8513 8514 begin 8515 exit Search when 8516 Val >= Expr_Value (Low_Bound (R)) 8517 and then 8518 Val <= Expr_Value (High_Bound (R)); 8519 end; 8520 8521 -- Choice is a simple expression 8522 8523 else 8524 exit Search when Val = Expr_Value (Choice); 8525 end if; 8526 8527 Next (Choice); 8528 end loop; 8529 end if; 8530 8531 Next (Alt); 8532 pragma Assert (Present (Alt)); 8533 end loop Search; 8534 8535 -- The above loop *must* terminate by finding a match, since we know the 8536 -- case statement is valid, and the value of the expression is known at 8537 -- compile time. When we fall out of the loop, Alt points to the 8538 -- alternative that we know will be selected at run time. 8539 8540 return Alt; 8541 end Find_Static_Alternative; 8542 8543 ------------------ 8544 -- First_Actual -- 8545 ------------------ 8546 8547 function First_Actual (Node : Node_Id) return Node_Id is 8548 N : Node_Id; 8549 8550 begin 8551 if No (Parameter_Associations (Node)) then 8552 return Empty; 8553 end if; 8554 8555 N := First (Parameter_Associations (Node)); 8556 8557 if Nkind (N) = N_Parameter_Association then 8558 return First_Named_Actual (Node); 8559 else 8560 return N; 8561 end if; 8562 end First_Actual; 8563 8564 ------------------ 8565 -- First_Global -- 8566 ------------------ 8567 8568 function First_Global 8569 (Subp : Entity_Id; 8570 Global_Mode : Name_Id; 8571 Refined : Boolean := False) return Node_Id 8572 is 8573 function First_From_Global_List 8574 (List : Node_Id; 8575 Global_Mode : Name_Id := Name_Input) return Entity_Id; 8576 -- Get the first item with suitable mode from List 8577 8578 ---------------------------- 8579 -- First_From_Global_List -- 8580 ---------------------------- 8581 8582 function First_From_Global_List 8583 (List : Node_Id; 8584 Global_Mode : Name_Id := Name_Input) return Entity_Id 8585 is 8586 Assoc : Node_Id; 8587 8588 begin 8589 -- Empty list (no global items) 8590 8591 if Nkind (List) = N_Null then 8592 return Empty; 8593 8594 -- Single global item declaration (only input items) 8595 8596 elsif Nkind_In (List, N_Expanded_Name, N_Identifier) then 8597 if Global_Mode = Name_Input then 8598 return List; 8599 else 8600 return Empty; 8601 end if; 8602 8603 -- Simple global list (only input items) or moded global list 8604 -- declaration. 8605 8606 elsif Nkind (List) = N_Aggregate then 8607 if Present (Expressions (List)) then 8608 if Global_Mode = Name_Input then 8609 return First (Expressions (List)); 8610 else 8611 return Empty; 8612 end if; 8613 8614 else 8615 Assoc := First (Component_Associations (List)); 8616 while Present (Assoc) loop 8617 8618 -- When we find the desired mode in an association, call 8619 -- recursively First_From_Global_List as if the mode was 8620 -- Name_Input, in order to reuse the existing machinery 8621 -- for the other cases. 8622 8623 if Chars (First (Choices (Assoc))) = Global_Mode then 8624 return First_From_Global_List (Expression (Assoc)); 8625 end if; 8626 8627 Next (Assoc); 8628 end loop; 8629 8630 return Empty; 8631 end if; 8632 8633 -- To accommodate partial decoration of disabled SPARK features, 8634 -- this routine may be called with illegal input. If this is the 8635 -- case, do not raise Program_Error. 8636 8637 else 8638 return Empty; 8639 end if; 8640 end First_From_Global_List; 8641 8642 -- Local variables 8643 8644 Global : Node_Id := Empty; 8645 Body_Id : Entity_Id; 8646 8647 begin 8648 pragma Assert (Nam_In (Global_Mode, Name_In_Out, 8649 Name_Input, 8650 Name_Output, 8651 Name_Proof_In)); 8652 8653 -- Retrieve the suitable pragma Global or Refined_Global. In the second 8654 -- case, it can only be located on the body entity. 8655 8656 if Refined then 8657 Body_Id := Subprogram_Body_Entity (Subp); 8658 if Present (Body_Id) then 8659 Global := Get_Pragma (Body_Id, Pragma_Refined_Global); 8660 end if; 8661 else 8662 Global := Get_Pragma (Subp, Pragma_Global); 8663 end if; 8664 8665 -- No corresponding global if pragma is not present 8666 8667 if No (Global) then 8668 return Empty; 8669 8670 -- Otherwise retrieve the corresponding list of items depending on the 8671 -- Global_Mode. 8672 8673 else 8674 return First_From_Global_List 8675 (Expression (Get_Argument (Global, Subp)), Global_Mode); 8676 end if; 8677 end First_Global; 8678 8679 ------------- 8680 -- Fix_Msg -- 8681 ------------- 8682 8683 function Fix_Msg (Id : Entity_Id; Msg : String) return String is 8684 Is_Task : constant Boolean := 8685 Ekind_In (Id, E_Task_Body, E_Task_Type) 8686 or else Is_Single_Task_Object (Id); 8687 Msg_Last : constant Natural := Msg'Last; 8688 Msg_Index : Natural; 8689 Res : String (Msg'Range) := (others => ' '); 8690 Res_Index : Natural; 8691 8692 begin 8693 -- Copy all characters from the input message Msg to result Res with 8694 -- suitable replacements. 8695 8696 Msg_Index := Msg'First; 8697 Res_Index := Res'First; 8698 while Msg_Index <= Msg_Last loop 8699 8700 -- Replace "subprogram" with a different word 8701 8702 if Msg_Index <= Msg_Last - 10 8703 and then Msg (Msg_Index .. Msg_Index + 9) = "subprogram" 8704 then 8705 if Ekind_In (Id, E_Entry, E_Entry_Family) then 8706 Res (Res_Index .. Res_Index + 4) := "entry"; 8707 Res_Index := Res_Index + 5; 8708 8709 elsif Is_Task then 8710 Res (Res_Index .. Res_Index + 8) := "task type"; 8711 Res_Index := Res_Index + 9; 8712 8713 else 8714 Res (Res_Index .. Res_Index + 9) := "subprogram"; 8715 Res_Index := Res_Index + 10; 8716 end if; 8717 8718 Msg_Index := Msg_Index + 10; 8719 8720 -- Replace "protected" with a different word 8721 8722 elsif Msg_Index <= Msg_Last - 9 8723 and then Msg (Msg_Index .. Msg_Index + 8) = "protected" 8724 and then Is_Task 8725 then 8726 Res (Res_Index .. Res_Index + 3) := "task"; 8727 Res_Index := Res_Index + 4; 8728 Msg_Index := Msg_Index + 9; 8729 8730 -- Otherwise copy the character 8731 8732 else 8733 Res (Res_Index) := Msg (Msg_Index); 8734 Msg_Index := Msg_Index + 1; 8735 Res_Index := Res_Index + 1; 8736 end if; 8737 end loop; 8738 8739 return Res (Res'First .. Res_Index - 1); 8740 end Fix_Msg; 8741 8742 ------------------------- 8743 -- From_Nested_Package -- 8744 ------------------------- 8745 8746 function From_Nested_Package (T : Entity_Id) return Boolean is 8747 Pack : constant Entity_Id := Scope (T); 8748 8749 begin 8750 return 8751 Ekind (Pack) = E_Package 8752 and then not Is_Frozen (Pack) 8753 and then not Scope_Within_Or_Same (Current_Scope, Pack) 8754 and then In_Open_Scopes (Scope (Pack)); 8755 end From_Nested_Package; 8756 8757 ----------------------- 8758 -- Gather_Components -- 8759 ----------------------- 8760 8761 procedure Gather_Components 8762 (Typ : Entity_Id; 8763 Comp_List : Node_Id; 8764 Governed_By : List_Id; 8765 Into : Elist_Id; 8766 Report_Errors : out Boolean) 8767 is 8768 Assoc : Node_Id; 8769 Variant : Node_Id; 8770 Discrete_Choice : Node_Id; 8771 Comp_Item : Node_Id; 8772 8773 Discrim : Entity_Id; 8774 Discrim_Name : Node_Id; 8775 Discrim_Value : Node_Id; 8776 8777 begin 8778 Report_Errors := False; 8779 8780 if No (Comp_List) or else Null_Present (Comp_List) then 8781 return; 8782 8783 elsif Present (Component_Items (Comp_List)) then 8784 Comp_Item := First (Component_Items (Comp_List)); 8785 8786 else 8787 Comp_Item := Empty; 8788 end if; 8789 8790 while Present (Comp_Item) loop 8791 8792 -- Skip the tag of a tagged record, the interface tags, as well 8793 -- as all items that are not user components (anonymous types, 8794 -- rep clauses, Parent field, controller field). 8795 8796 if Nkind (Comp_Item) = N_Component_Declaration then 8797 declare 8798 Comp : constant Entity_Id := Defining_Identifier (Comp_Item); 8799 begin 8800 if not Is_Tag (Comp) and then Chars (Comp) /= Name_uParent then 8801 Append_Elmt (Comp, Into); 8802 end if; 8803 end; 8804 end if; 8805 8806 Next (Comp_Item); 8807 end loop; 8808 8809 if No (Variant_Part (Comp_List)) then 8810 return; 8811 else 8812 Discrim_Name := Name (Variant_Part (Comp_List)); 8813 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); 8814 end if; 8815 8816 -- Look for the discriminant that governs this variant part. 8817 -- The discriminant *must* be in the Governed_By List 8818 8819 Assoc := First (Governed_By); 8820 Find_Constraint : loop 8821 Discrim := First (Choices (Assoc)); 8822 exit Find_Constraint when 8823 Chars (Discrim_Name) = Chars (Discrim) 8824 or else 8825 (Present (Corresponding_Discriminant (Entity (Discrim))) 8826 and then Chars (Corresponding_Discriminant 8827 (Entity (Discrim))) = Chars (Discrim_Name)) 8828 or else 8829 Chars (Original_Record_Component (Entity (Discrim))) = 8830 Chars (Discrim_Name); 8831 8832 if No (Next (Assoc)) then 8833 if not Is_Constrained (Typ) and then Is_Derived_Type (Typ) then 8834 8835 -- If the type is a tagged type with inherited discriminants, 8836 -- use the stored constraint on the parent in order to find 8837 -- the values of discriminants that are otherwise hidden by an 8838 -- explicit constraint. Renamed discriminants are handled in 8839 -- the code above. 8840 8841 -- If several parent discriminants are renamed by a single 8842 -- discriminant of the derived type, the call to obtain the 8843 -- Corresponding_Discriminant field only retrieves the last 8844 -- of them. We recover the constraint on the others from the 8845 -- Stored_Constraint as well. 8846 8847 -- An inherited discriminant may have been constrained in a 8848 -- later ancestor (not the immediate parent) so we must examine 8849 -- the stored constraint of all of them to locate the inherited 8850 -- value. 8851 8852 declare 8853 C : Elmt_Id; 8854 D : Entity_Id; 8855 T : Entity_Id := Typ; 8856 8857 begin 8858 while Is_Derived_Type (T) loop 8859 if Present (Stored_Constraint (T)) then 8860 D := First_Discriminant (Etype (T)); 8861 C := First_Elmt (Stored_Constraint (T)); 8862 while Present (D) and then Present (C) loop 8863 if Chars (Discrim_Name) = Chars (D) then 8864 if Is_Entity_Name (Node (C)) 8865 and then Entity (Node (C)) = Entity (Discrim) 8866 then 8867 -- D is renamed by Discrim, whose value is 8868 -- given in Assoc. 8869 8870 null; 8871 8872 else 8873 Assoc := 8874 Make_Component_Association (Sloc (Typ), 8875 New_List 8876 (New_Occurrence_Of (D, Sloc (Typ))), 8877 Duplicate_Subexpr_No_Checks (Node (C))); 8878 end if; 8879 8880 exit Find_Constraint; 8881 end if; 8882 8883 Next_Discriminant (D); 8884 Next_Elmt (C); 8885 end loop; 8886 end if; 8887 8888 -- Discriminant may be inherited from ancestor 8889 8890 T := Etype (T); 8891 end loop; 8892 end; 8893 end if; 8894 end if; 8895 8896 if No (Next (Assoc)) then 8897 Error_Msg_NE 8898 (" missing value for discriminant&", 8899 First (Governed_By), Discrim_Name); 8900 8901 Report_Errors := True; 8902 return; 8903 end if; 8904 8905 Next (Assoc); 8906 end loop Find_Constraint; 8907 8908 Discrim_Value := Expression (Assoc); 8909 8910 if not Is_OK_Static_Expression (Discrim_Value) then 8911 8912 -- If the variant part is governed by a discriminant of the type 8913 -- this is an error. If the variant part and the discriminant are 8914 -- inherited from an ancestor this is legal (AI05-120) unless the 8915 -- components are being gathered for an aggregate, in which case 8916 -- the caller must check Report_Errors. 8917 8918 if Scope (Original_Record_Component 8919 ((Entity (First (Choices (Assoc)))))) = Typ 8920 then 8921 Error_Msg_FE 8922 ("value for discriminant & must be static!", 8923 Discrim_Value, Discrim); 8924 Why_Not_Static (Discrim_Value); 8925 end if; 8926 8927 Report_Errors := True; 8928 return; 8929 end if; 8930 8931 Search_For_Discriminant_Value : declare 8932 Low : Node_Id; 8933 High : Node_Id; 8934 8935 UI_High : Uint; 8936 UI_Low : Uint; 8937 UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value); 8938 8939 begin 8940 Find_Discrete_Value : while Present (Variant) loop 8941 Discrete_Choice := First (Discrete_Choices (Variant)); 8942 while Present (Discrete_Choice) loop 8943 exit Find_Discrete_Value when 8944 Nkind (Discrete_Choice) = N_Others_Choice; 8945 8946 Get_Index_Bounds (Discrete_Choice, Low, High); 8947 8948 UI_Low := Expr_Value (Low); 8949 UI_High := Expr_Value (High); 8950 8951 exit Find_Discrete_Value when 8952 UI_Low <= UI_Discrim_Value 8953 and then 8954 UI_High >= UI_Discrim_Value; 8955 8956 Next (Discrete_Choice); 8957 end loop; 8958 8959 Next_Non_Pragma (Variant); 8960 end loop Find_Discrete_Value; 8961 end Search_For_Discriminant_Value; 8962 8963 -- The case statement must include a variant that corresponds to the 8964 -- value of the discriminant, unless the discriminant type has a 8965 -- static predicate. In that case the absence of an others_choice that 8966 -- would cover this value becomes a run-time error (3.8,1 (21.1/2)). 8967 8968 if No (Variant) 8969 and then not Has_Static_Predicate (Etype (Discrim_Name)) 8970 then 8971 Error_Msg_NE 8972 ("value of discriminant & is out of range", Discrim_Value, Discrim); 8973 Report_Errors := True; 8974 return; 8975 end if; 8976 8977 -- If we have found the corresponding choice, recursively add its 8978 -- components to the Into list. The nested components are part of 8979 -- the same record type. 8980 8981 if Present (Variant) then 8982 Gather_Components 8983 (Typ, Component_List (Variant), Governed_By, Into, Report_Errors); 8984 end if; 8985 end Gather_Components; 8986 8987 ------------------------ 8988 -- Get_Actual_Subtype -- 8989 ------------------------ 8990 8991 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is 8992 Typ : constant Entity_Id := Etype (N); 8993 Utyp : Entity_Id := Underlying_Type (Typ); 8994 Decl : Node_Id; 8995 Atyp : Entity_Id; 8996 8997 begin 8998 if No (Utyp) then 8999 Utyp := Typ; 9000 end if; 9001 9002 -- If what we have is an identifier that references a subprogram 9003 -- formal, or a variable or constant object, then we get the actual 9004 -- subtype from the referenced entity if one has been built. 9005 9006 if Nkind (N) = N_Identifier 9007 and then 9008 (Is_Formal (Entity (N)) 9009 or else Ekind (Entity (N)) = E_Constant 9010 or else Ekind (Entity (N)) = E_Variable) 9011 and then Present (Actual_Subtype (Entity (N))) 9012 then 9013 return Actual_Subtype (Entity (N)); 9014 9015 -- Actual subtype of unchecked union is always itself. We never need 9016 -- the "real" actual subtype. If we did, we couldn't get it anyway 9017 -- because the discriminant is not available. The restrictions on 9018 -- Unchecked_Union are designed to make sure that this is OK. 9019 9020 elsif Is_Unchecked_Union (Base_Type (Utyp)) then 9021 return Typ; 9022 9023 -- Here for the unconstrained case, we must find actual subtype 9024 -- No actual subtype is available, so we must build it on the fly. 9025 9026 -- Checking the type, not the underlying type, for constrainedness 9027 -- seems to be necessary. Maybe all the tests should be on the type??? 9028 9029 elsif (not Is_Constrained (Typ)) 9030 and then (Is_Array_Type (Utyp) 9031 or else (Is_Record_Type (Utyp) 9032 and then Has_Discriminants (Utyp))) 9033 and then not Has_Unknown_Discriminants (Utyp) 9034 and then not (Ekind (Utyp) = E_String_Literal_Subtype) 9035 then 9036 -- Nothing to do if in spec expression (why not???) 9037 9038 if In_Spec_Expression then 9039 return Typ; 9040 9041 elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then 9042 9043 -- If the type has no discriminants, there is no subtype to 9044 -- build, even if the underlying type is discriminated. 9045 9046 return Typ; 9047 9048 -- Else build the actual subtype 9049 9050 else 9051 Decl := Build_Actual_Subtype (Typ, N); 9052 9053 -- The call may yield a declaration, or just return the entity 9054 9055 if Decl = Typ then 9056 return Typ; 9057 end if; 9058 9059 Atyp := Defining_Identifier (Decl); 9060 9061 -- If Build_Actual_Subtype generated a new declaration then use it 9062 9063 if Atyp /= Typ then 9064 9065 -- The actual subtype is an Itype, so analyze the declaration, 9066 -- but do not attach it to the tree, to get the type defined. 9067 9068 Set_Parent (Decl, N); 9069 Set_Is_Itype (Atyp); 9070 Analyze (Decl, Suppress => All_Checks); 9071 Set_Associated_Node_For_Itype (Atyp, N); 9072 Set_Has_Delayed_Freeze (Atyp, False); 9073 9074 -- We need to freeze the actual subtype immediately. This is 9075 -- needed, because otherwise this Itype will not get frozen 9076 -- at all, and it is always safe to freeze on creation because 9077 -- any associated types must be frozen at this point. 9078 9079 Freeze_Itype (Atyp, N); 9080 return Atyp; 9081 9082 -- Otherwise we did not build a declaration, so return original 9083 9084 else 9085 return Typ; 9086 end if; 9087 end if; 9088 9089 -- For all remaining cases, the actual subtype is the same as 9090 -- the nominal type. 9091 9092 else 9093 return Typ; 9094 end if; 9095 end Get_Actual_Subtype; 9096 9097 ------------------------------------- 9098 -- Get_Actual_Subtype_If_Available -- 9099 ------------------------------------- 9100 9101 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is 9102 Typ : constant Entity_Id := Etype (N); 9103 9104 begin 9105 -- If what we have is an identifier that references a subprogram 9106 -- formal, or a variable or constant object, then we get the actual 9107 -- subtype from the referenced entity if one has been built. 9108 9109 if Nkind (N) = N_Identifier 9110 and then 9111 (Is_Formal (Entity (N)) 9112 or else Ekind (Entity (N)) = E_Constant 9113 or else Ekind (Entity (N)) = E_Variable) 9114 and then Present (Actual_Subtype (Entity (N))) 9115 then 9116 return Actual_Subtype (Entity (N)); 9117 9118 -- Otherwise the Etype of N is returned unchanged 9119 9120 else 9121 return Typ; 9122 end if; 9123 end Get_Actual_Subtype_If_Available; 9124 9125 ------------------------ 9126 -- Get_Body_From_Stub -- 9127 ------------------------ 9128 9129 function Get_Body_From_Stub (N : Node_Id) return Node_Id is 9130 begin 9131 return Proper_Body (Unit (Library_Unit (N))); 9132 end Get_Body_From_Stub; 9133 9134 --------------------- 9135 -- Get_Cursor_Type -- 9136 --------------------- 9137 9138 function Get_Cursor_Type 9139 (Aspect : Node_Id; 9140 Typ : Entity_Id) return Entity_Id 9141 is 9142 Assoc : Node_Id; 9143 Func : Entity_Id; 9144 First_Op : Entity_Id; 9145 Cursor : Entity_Id; 9146 9147 begin 9148 -- If error already detected, return 9149 9150 if Error_Posted (Aspect) then 9151 return Any_Type; 9152 end if; 9153 9154 -- The cursor type for an Iterable aspect is the return type of a 9155 -- non-overloaded First primitive operation. Locate association for 9156 -- First. 9157 9158 Assoc := First (Component_Associations (Expression (Aspect))); 9159 First_Op := Any_Id; 9160 while Present (Assoc) loop 9161 if Chars (First (Choices (Assoc))) = Name_First then 9162 First_Op := Expression (Assoc); 9163 exit; 9164 end if; 9165 9166 Next (Assoc); 9167 end loop; 9168 9169 if First_Op = Any_Id then 9170 Error_Msg_N ("aspect Iterable must specify First operation", Aspect); 9171 return Any_Type; 9172 9173 elsif not Analyzed (First_Op) then 9174 Analyze (First_Op); 9175 end if; 9176 9177 Cursor := Any_Type; 9178 9179 -- Locate function with desired name and profile in scope of type 9180 -- In the rare case where the type is an integer type, a base type 9181 -- is created for it, check that the base type of the first formal 9182 -- of First matches the base type of the domain. 9183 9184 Func := First_Entity (Scope (Typ)); 9185 while Present (Func) loop 9186 if Chars (Func) = Chars (First_Op) 9187 and then Ekind (Func) = E_Function 9188 and then Present (First_Formal (Func)) 9189 and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ) 9190 and then No (Next_Formal (First_Formal (Func))) 9191 then 9192 if Cursor /= Any_Type then 9193 Error_Msg_N 9194 ("Operation First for iterable type must be unique", Aspect); 9195 return Any_Type; 9196 else 9197 Cursor := Etype (Func); 9198 end if; 9199 end if; 9200 9201 Next_Entity (Func); 9202 end loop; 9203 9204 -- If not found, no way to resolve remaining primitives. 9205 9206 if Cursor = Any_Type then 9207 Error_Msg_N 9208 ("primitive operation for Iterable type must appear " 9209 & "in the same list of declarations as the type", Aspect); 9210 end if; 9211 9212 return Cursor; 9213 end Get_Cursor_Type; 9214 9215 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is 9216 begin 9217 return Etype (Get_Iterable_Type_Primitive (Typ, Name_First)); 9218 end Get_Cursor_Type; 9219 9220 ------------------------------- 9221 -- Get_Default_External_Name -- 9222 ------------------------------- 9223 9224 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is 9225 begin 9226 Get_Decoded_Name_String (Chars (E)); 9227 9228 if Opt.External_Name_Imp_Casing = Uppercase then 9229 Set_Casing (All_Upper_Case); 9230 else 9231 Set_Casing (All_Lower_Case); 9232 end if; 9233 9234 return 9235 Make_String_Literal (Sloc (E), 9236 Strval => String_From_Name_Buffer); 9237 end Get_Default_External_Name; 9238 9239 -------------------------- 9240 -- Get_Enclosing_Object -- 9241 -------------------------- 9242 9243 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is 9244 begin 9245 if Is_Entity_Name (N) then 9246 return Entity (N); 9247 else 9248 case Nkind (N) is 9249 when N_Indexed_Component 9250 | N_Selected_Component 9251 | N_Slice 9252 => 9253 -- If not generating code, a dereference may be left implicit. 9254 -- In thoses cases, return Empty. 9255 9256 if Is_Access_Type (Etype (Prefix (N))) then 9257 return Empty; 9258 else 9259 return Get_Enclosing_Object (Prefix (N)); 9260 end if; 9261 9262 when N_Type_Conversion => 9263 return Get_Enclosing_Object (Expression (N)); 9264 9265 when others => 9266 return Empty; 9267 end case; 9268 end if; 9269 end Get_Enclosing_Object; 9270 9271 --------------------------- 9272 -- Get_Enum_Lit_From_Pos -- 9273 --------------------------- 9274 9275 function Get_Enum_Lit_From_Pos 9276 (T : Entity_Id; 9277 Pos : Uint; 9278 Loc : Source_Ptr) return Node_Id 9279 is 9280 Btyp : Entity_Id := Base_Type (T); 9281 Lit : Node_Id; 9282 LLoc : Source_Ptr; 9283 9284 begin 9285 -- In the case where the literal is of type Character, Wide_Character 9286 -- or Wide_Wide_Character or of a type derived from them, there needs 9287 -- to be some special handling since there is no explicit chain of 9288 -- literals to search. Instead, an N_Character_Literal node is created 9289 -- with the appropriate Char_Code and Chars fields. 9290 9291 if Is_Standard_Character_Type (T) then 9292 Set_Character_Literal_Name (UI_To_CC (Pos)); 9293 9294 return 9295 Make_Character_Literal (Loc, 9296 Chars => Name_Find, 9297 Char_Literal_Value => Pos); 9298 9299 -- For all other cases, we have a complete table of literals, and 9300 -- we simply iterate through the chain of literal until the one 9301 -- with the desired position value is found. 9302 9303 else 9304 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then 9305 Btyp := Full_View (Btyp); 9306 end if; 9307 9308 Lit := First_Literal (Btyp); 9309 9310 -- Position in the enumeration type starts at 0 9311 9312 if UI_To_Int (Pos) < 0 then 9313 raise Constraint_Error; 9314 end if; 9315 9316 for J in 1 .. UI_To_Int (Pos) loop 9317 Next_Literal (Lit); 9318 9319 -- If Lit is Empty, Pos is not in range, so raise Constraint_Error 9320 -- inside the loop to avoid calling Next_Literal on Empty. 9321 9322 if No (Lit) then 9323 raise Constraint_Error; 9324 end if; 9325 end loop; 9326 9327 -- Create a new node from Lit, with source location provided by Loc 9328 -- if not equal to No_Location, or by copying the source location of 9329 -- Lit otherwise. 9330 9331 LLoc := Loc; 9332 9333 if LLoc = No_Location then 9334 LLoc := Sloc (Lit); 9335 end if; 9336 9337 return New_Occurrence_Of (Lit, LLoc); 9338 end if; 9339 end Get_Enum_Lit_From_Pos; 9340 9341 ------------------------ 9342 -- Get_Generic_Entity -- 9343 ------------------------ 9344 9345 function Get_Generic_Entity (N : Node_Id) return Entity_Id is 9346 Ent : constant Entity_Id := Entity (Name (N)); 9347 begin 9348 if Present (Renamed_Object (Ent)) then 9349 return Renamed_Object (Ent); 9350 else 9351 return Ent; 9352 end if; 9353 end Get_Generic_Entity; 9354 9355 ------------------------------------- 9356 -- Get_Incomplete_View_Of_Ancestor -- 9357 ------------------------------------- 9358 9359 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is 9360 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 9361 Par_Scope : Entity_Id; 9362 Par_Type : Entity_Id; 9363 9364 begin 9365 -- The incomplete view of an ancestor is only relevant for private 9366 -- derived types in child units. 9367 9368 if not Is_Derived_Type (E) 9369 or else not Is_Child_Unit (Cur_Unit) 9370 then 9371 return Empty; 9372 9373 else 9374 Par_Scope := Scope (Cur_Unit); 9375 if No (Par_Scope) then 9376 return Empty; 9377 end if; 9378 9379 Par_Type := Etype (Base_Type (E)); 9380 9381 -- Traverse list of ancestor types until we find one declared in 9382 -- a parent or grandparent unit (two levels seem sufficient). 9383 9384 while Present (Par_Type) loop 9385 if Scope (Par_Type) = Par_Scope 9386 or else Scope (Par_Type) = Scope (Par_Scope) 9387 then 9388 return Par_Type; 9389 9390 elsif not Is_Derived_Type (Par_Type) then 9391 return Empty; 9392 9393 else 9394 Par_Type := Etype (Base_Type (Par_Type)); 9395 end if; 9396 end loop; 9397 9398 -- If none found, there is no relevant ancestor type. 9399 9400 return Empty; 9401 end if; 9402 end Get_Incomplete_View_Of_Ancestor; 9403 9404 ---------------------- 9405 -- Get_Index_Bounds -- 9406 ---------------------- 9407 9408 procedure Get_Index_Bounds 9409 (N : Node_Id; 9410 L : out Node_Id; 9411 H : out Node_Id; 9412 Use_Full_View : Boolean := False) 9413 is 9414 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id; 9415 -- Obtain the scalar range of type Typ. If flag Use_Full_View is set and 9416 -- Typ qualifies, the scalar range is obtained from the full view of the 9417 -- type. 9418 9419 -------------------------- 9420 -- Scalar_Range_Of_Type -- 9421 -------------------------- 9422 9423 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id is 9424 T : Entity_Id := Typ; 9425 9426 begin 9427 if Use_Full_View and then Present (Full_View (T)) then 9428 T := Full_View (T); 9429 end if; 9430 9431 return Scalar_Range (T); 9432 end Scalar_Range_Of_Type; 9433 9434 -- Local variables 9435 9436 Kind : constant Node_Kind := Nkind (N); 9437 Rng : Node_Id; 9438 9439 -- Start of processing for Get_Index_Bounds 9440 9441 begin 9442 if Kind = N_Range then 9443 L := Low_Bound (N); 9444 H := High_Bound (N); 9445 9446 elsif Kind = N_Subtype_Indication then 9447 Rng := Range_Expression (Constraint (N)); 9448 9449 if Rng = Error then 9450 L := Error; 9451 H := Error; 9452 return; 9453 9454 else 9455 L := Low_Bound (Range_Expression (Constraint (N))); 9456 H := High_Bound (Range_Expression (Constraint (N))); 9457 end if; 9458 9459 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then 9460 Rng := Scalar_Range_Of_Type (Entity (N)); 9461 9462 if Error_Posted (Rng) then 9463 L := Error; 9464 H := Error; 9465 9466 elsif Nkind (Rng) = N_Subtype_Indication then 9467 Get_Index_Bounds (Rng, L, H); 9468 9469 else 9470 L := Low_Bound (Rng); 9471 H := High_Bound (Rng); 9472 end if; 9473 9474 else 9475 -- N is an expression, indicating a range with one value 9476 9477 L := N; 9478 H := N; 9479 end if; 9480 end Get_Index_Bounds; 9481 9482 ----------------------------- 9483 -- Get_Interfacing_Aspects -- 9484 ----------------------------- 9485 9486 procedure Get_Interfacing_Aspects 9487 (Iface_Asp : Node_Id; 9488 Conv_Asp : out Node_Id; 9489 EN_Asp : out Node_Id; 9490 Expo_Asp : out Node_Id; 9491 Imp_Asp : out Node_Id; 9492 LN_Asp : out Node_Id; 9493 Do_Checks : Boolean := False) 9494 is 9495 procedure Save_Or_Duplication_Error 9496 (Asp : Node_Id; 9497 To : in out Node_Id); 9498 -- Save the value of aspect Asp in node To. If To already has a value, 9499 -- then this is considered a duplicate use of aspect. Emit an error if 9500 -- flag Do_Checks is set. 9501 9502 ------------------------------- 9503 -- Save_Or_Duplication_Error -- 9504 ------------------------------- 9505 9506 procedure Save_Or_Duplication_Error 9507 (Asp : Node_Id; 9508 To : in out Node_Id) 9509 is 9510 begin 9511 -- Detect an extra aspect and issue an error 9512 9513 if Present (To) then 9514 if Do_Checks then 9515 Error_Msg_Name_1 := Chars (Identifier (Asp)); 9516 Error_Msg_Sloc := Sloc (To); 9517 Error_Msg_N ("aspect % previously given #", Asp); 9518 end if; 9519 9520 -- Otherwise capture the aspect 9521 9522 else 9523 To := Asp; 9524 end if; 9525 end Save_Or_Duplication_Error; 9526 9527 -- Local variables 9528 9529 Asp : Node_Id; 9530 Asp_Id : Aspect_Id; 9531 9532 -- The following variables capture each individual aspect 9533 9534 Conv : Node_Id := Empty; 9535 EN : Node_Id := Empty; 9536 Expo : Node_Id := Empty; 9537 Imp : Node_Id := Empty; 9538 LN : Node_Id := Empty; 9539 9540 -- Start of processing for Get_Interfacing_Aspects 9541 9542 begin 9543 -- The input interfacing aspect should reside in an aspect specification 9544 -- list. 9545 9546 pragma Assert (Is_List_Member (Iface_Asp)); 9547 9548 -- Examine the aspect specifications of the related entity. Find and 9549 -- capture all interfacing aspects. Detect duplicates and emit errors 9550 -- if applicable. 9551 9552 Asp := First (List_Containing (Iface_Asp)); 9553 while Present (Asp) loop 9554 Asp_Id := Get_Aspect_Id (Asp); 9555 9556 if Asp_Id = Aspect_Convention then 9557 Save_Or_Duplication_Error (Asp, Conv); 9558 9559 elsif Asp_Id = Aspect_External_Name then 9560 Save_Or_Duplication_Error (Asp, EN); 9561 9562 elsif Asp_Id = Aspect_Export then 9563 Save_Or_Duplication_Error (Asp, Expo); 9564 9565 elsif Asp_Id = Aspect_Import then 9566 Save_Or_Duplication_Error (Asp, Imp); 9567 9568 elsif Asp_Id = Aspect_Link_Name then 9569 Save_Or_Duplication_Error (Asp, LN); 9570 end if; 9571 9572 Next (Asp); 9573 end loop; 9574 9575 Conv_Asp := Conv; 9576 EN_Asp := EN; 9577 Expo_Asp := Expo; 9578 Imp_Asp := Imp; 9579 LN_Asp := LN; 9580 end Get_Interfacing_Aspects; 9581 9582 --------------------------------- 9583 -- Get_Iterable_Type_Primitive -- 9584 --------------------------------- 9585 9586 function Get_Iterable_Type_Primitive 9587 (Typ : Entity_Id; 9588 Nam : Name_Id) return Entity_Id 9589 is 9590 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable); 9591 Assoc : Node_Id; 9592 9593 begin 9594 if No (Funcs) then 9595 return Empty; 9596 9597 else 9598 Assoc := First (Component_Associations (Funcs)); 9599 while Present (Assoc) loop 9600 if Chars (First (Choices (Assoc))) = Nam then 9601 return Entity (Expression (Assoc)); 9602 end if; 9603 9604 Assoc := Next (Assoc); 9605 end loop; 9606 9607 return Empty; 9608 end if; 9609 end Get_Iterable_Type_Primitive; 9610 9611 ---------------------------------- 9612 -- Get_Library_Unit_Name_String -- 9613 ---------------------------------- 9614 9615 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is 9616 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node); 9617 9618 begin 9619 Get_Unit_Name_String (Unit_Name_Id); 9620 9621 -- Remove seven last character (" (spec)" or " (body)") 9622 9623 Name_Len := Name_Len - 7; 9624 pragma Assert (Name_Buffer (Name_Len + 1) = ' '); 9625 end Get_Library_Unit_Name_String; 9626 9627 -------------------------- 9628 -- Get_Max_Queue_Length -- 9629 -------------------------- 9630 9631 function Get_Max_Queue_Length (Id : Entity_Id) return Uint is 9632 pragma Assert (Is_Entry (Id)); 9633 Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length); 9634 9635 begin 9636 -- A value of 0 represents no maximum specified, and entries and entry 9637 -- families with no Max_Queue_Length aspect or pragma default to it. 9638 9639 if not Present (Prag) then 9640 return Uint_0; 9641 end if; 9642 9643 return Intval (Expression (First (Pragma_Argument_Associations (Prag)))); 9644 end Get_Max_Queue_Length; 9645 9646 ------------------------ 9647 -- Get_Name_Entity_Id -- 9648 ------------------------ 9649 9650 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is 9651 begin 9652 return Entity_Id (Get_Name_Table_Int (Id)); 9653 end Get_Name_Entity_Id; 9654 9655 ------------------------------ 9656 -- Get_Name_From_CTC_Pragma -- 9657 ------------------------------ 9658 9659 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is 9660 Arg : constant Node_Id := 9661 Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 9662 begin 9663 return Strval (Expr_Value_S (Arg)); 9664 end Get_Name_From_CTC_Pragma; 9665 9666 ----------------------- 9667 -- Get_Parent_Entity -- 9668 ----------------------- 9669 9670 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is 9671 begin 9672 if Nkind (Unit) = N_Package_Body 9673 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation 9674 then 9675 return Defining_Entity 9676 (Specification (Instance_Spec (Original_Node (Unit)))); 9677 elsif Nkind (Unit) = N_Package_Instantiation then 9678 return Defining_Entity (Specification (Instance_Spec (Unit))); 9679 else 9680 return Defining_Entity (Unit); 9681 end if; 9682 end Get_Parent_Entity; 9683 9684 ------------------- 9685 -- Get_Pragma_Id -- 9686 ------------------- 9687 9688 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is 9689 begin 9690 return Get_Pragma_Id (Pragma_Name_Unmapped (N)); 9691 end Get_Pragma_Id; 9692 9693 ------------------------ 9694 -- Get_Qualified_Name -- 9695 ------------------------ 9696 9697 function Get_Qualified_Name 9698 (Id : Entity_Id; 9699 Suffix : Entity_Id := Empty) return Name_Id 9700 is 9701 Suffix_Nam : Name_Id := No_Name; 9702 9703 begin 9704 if Present (Suffix) then 9705 Suffix_Nam := Chars (Suffix); 9706 end if; 9707 9708 return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id)); 9709 end Get_Qualified_Name; 9710 9711 function Get_Qualified_Name 9712 (Nam : Name_Id; 9713 Suffix : Name_Id := No_Name; 9714 Scop : Entity_Id := Current_Scope) return Name_Id 9715 is 9716 procedure Add_Scope (S : Entity_Id); 9717 -- Add the fully qualified form of scope S to the name buffer. The 9718 -- format is: 9719 -- s-1__s__ 9720 9721 --------------- 9722 -- Add_Scope -- 9723 --------------- 9724 9725 procedure Add_Scope (S : Entity_Id) is 9726 begin 9727 if S = Empty then 9728 null; 9729 9730 elsif S = Standard_Standard then 9731 null; 9732 9733 else 9734 Add_Scope (Scope (S)); 9735 Get_Name_String_And_Append (Chars (S)); 9736 Add_Str_To_Name_Buffer ("__"); 9737 end if; 9738 end Add_Scope; 9739 9740 -- Start of processing for Get_Qualified_Name 9741 9742 begin 9743 Name_Len := 0; 9744 Add_Scope (Scop); 9745 9746 -- Append the base name after all scopes have been chained 9747 9748 Get_Name_String_And_Append (Nam); 9749 9750 -- Append the suffix (if present) 9751 9752 if Suffix /= No_Name then 9753 Add_Str_To_Name_Buffer ("__"); 9754 Get_Name_String_And_Append (Suffix); 9755 end if; 9756 9757 return Name_Find; 9758 end Get_Qualified_Name; 9759 9760 ----------------------- 9761 -- Get_Reason_String -- 9762 ----------------------- 9763 9764 procedure Get_Reason_String (N : Node_Id) is 9765 begin 9766 if Nkind (N) = N_String_Literal then 9767 Store_String_Chars (Strval (N)); 9768 9769 elsif Nkind (N) = N_Op_Concat then 9770 Get_Reason_String (Left_Opnd (N)); 9771 Get_Reason_String (Right_Opnd (N)); 9772 9773 -- If not of required form, error 9774 9775 else 9776 Error_Msg_N 9777 ("Reason for pragma Warnings has wrong form", N); 9778 Error_Msg_N 9779 ("\must be string literal or concatenation of string literals", N); 9780 return; 9781 end if; 9782 end Get_Reason_String; 9783 9784 -------------------------------- 9785 -- Get_Reference_Discriminant -- 9786 -------------------------------- 9787 9788 function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is 9789 D : Entity_Id; 9790 9791 begin 9792 D := First_Discriminant (Typ); 9793 while Present (D) loop 9794 if Has_Implicit_Dereference (D) then 9795 return D; 9796 end if; 9797 Next_Discriminant (D); 9798 end loop; 9799 9800 return Empty; 9801 end Get_Reference_Discriminant; 9802 9803 --------------------------- 9804 -- Get_Referenced_Object -- 9805 --------------------------- 9806 9807 function Get_Referenced_Object (N : Node_Id) return Node_Id is 9808 R : Node_Id; 9809 9810 begin 9811 R := N; 9812 while Is_Entity_Name (R) 9813 and then Present (Renamed_Object (Entity (R))) 9814 loop 9815 R := Renamed_Object (Entity (R)); 9816 end loop; 9817 9818 return R; 9819 end Get_Referenced_Object; 9820 9821 ------------------------ 9822 -- Get_Renamed_Entity -- 9823 ------------------------ 9824 9825 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is 9826 R : Entity_Id; 9827 9828 begin 9829 R := E; 9830 while Present (Renamed_Entity (R)) loop 9831 R := Renamed_Entity (R); 9832 end loop; 9833 9834 return R; 9835 end Get_Renamed_Entity; 9836 9837 ----------------------- 9838 -- Get_Return_Object -- 9839 ----------------------- 9840 9841 function Get_Return_Object (N : Node_Id) return Entity_Id is 9842 Decl : Node_Id; 9843 9844 begin 9845 Decl := First (Return_Object_Declarations (N)); 9846 while Present (Decl) loop 9847 exit when Nkind (Decl) = N_Object_Declaration 9848 and then Is_Return_Object (Defining_Identifier (Decl)); 9849 Next (Decl); 9850 end loop; 9851 9852 pragma Assert (Present (Decl)); 9853 return Defining_Identifier (Decl); 9854 end Get_Return_Object; 9855 9856 --------------------------- 9857 -- Get_Subprogram_Entity -- 9858 --------------------------- 9859 9860 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is 9861 Subp : Node_Id; 9862 Subp_Id : Entity_Id; 9863 9864 begin 9865 if Nkind (Nod) = N_Accept_Statement then 9866 Subp := Entry_Direct_Name (Nod); 9867 9868 elsif Nkind (Nod) = N_Slice then 9869 Subp := Prefix (Nod); 9870 9871 else 9872 Subp := Name (Nod); 9873 end if; 9874 9875 -- Strip the subprogram call 9876 9877 loop 9878 if Nkind_In (Subp, N_Explicit_Dereference, 9879 N_Indexed_Component, 9880 N_Selected_Component) 9881 then 9882 Subp := Prefix (Subp); 9883 9884 elsif Nkind_In (Subp, N_Type_Conversion, 9885 N_Unchecked_Type_Conversion) 9886 then 9887 Subp := Expression (Subp); 9888 9889 else 9890 exit; 9891 end if; 9892 end loop; 9893 9894 -- Extract the entity of the subprogram call 9895 9896 if Is_Entity_Name (Subp) then 9897 Subp_Id := Entity (Subp); 9898 9899 if Ekind (Subp_Id) = E_Access_Subprogram_Type then 9900 Subp_Id := Directly_Designated_Type (Subp_Id); 9901 end if; 9902 9903 if Is_Subprogram (Subp_Id) then 9904 return Subp_Id; 9905 else 9906 return Empty; 9907 end if; 9908 9909 -- The search did not find a construct that denotes a subprogram 9910 9911 else 9912 return Empty; 9913 end if; 9914 end Get_Subprogram_Entity; 9915 9916 ----------------------------- 9917 -- Get_Task_Body_Procedure -- 9918 ----------------------------- 9919 9920 function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is 9921 begin 9922 -- Note: A task type may be the completion of a private type with 9923 -- discriminants. When performing elaboration checks on a task 9924 -- declaration, the current view of the type may be the private one, 9925 -- and the procedure that holds the body of the task is held in its 9926 -- underlying type. 9927 9928 -- This is an odd function, why not have Task_Body_Procedure do 9929 -- the following digging??? 9930 9931 return Task_Body_Procedure (Underlying_Type (Root_Type (E))); 9932 end Get_Task_Body_Procedure; 9933 9934 ------------------------- 9935 -- Get_User_Defined_Eq -- 9936 ------------------------- 9937 9938 function Get_User_Defined_Eq (E : Entity_Id) return Entity_Id is 9939 Prim : Elmt_Id; 9940 Op : Entity_Id; 9941 9942 begin 9943 Prim := First_Elmt (Collect_Primitive_Operations (E)); 9944 while Present (Prim) loop 9945 Op := Node (Prim); 9946 9947 if Chars (Op) = Name_Op_Eq 9948 and then Etype (Op) = Standard_Boolean 9949 and then Etype (First_Formal (Op)) = E 9950 and then Etype (Next_Formal (First_Formal (Op))) = E 9951 then 9952 return Op; 9953 end if; 9954 9955 Next_Elmt (Prim); 9956 end loop; 9957 9958 return Empty; 9959 end Get_User_Defined_Eq; 9960 9961 --------------- 9962 -- Get_Views -- 9963 --------------- 9964 9965 procedure Get_Views 9966 (Typ : Entity_Id; 9967 Priv_Typ : out Entity_Id; 9968 Full_Typ : out Entity_Id; 9969 Full_Base : out Entity_Id; 9970 CRec_Typ : out Entity_Id) 9971 is 9972 IP_View : Entity_Id; 9973 9974 begin 9975 -- Assume that none of the views can be recovered 9976 9977 Priv_Typ := Empty; 9978 Full_Typ := Empty; 9979 Full_Base := Empty; 9980 CRec_Typ := Empty; 9981 9982 -- The input type is the corresponding record type of a protected or a 9983 -- task type. 9984 9985 if Ekind (Typ) = E_Record_Type 9986 and then Is_Concurrent_Record_Type (Typ) 9987 then 9988 CRec_Typ := Typ; 9989 Full_Typ := Corresponding_Concurrent_Type (CRec_Typ); 9990 Full_Base := Base_Type (Full_Typ); 9991 Priv_Typ := Incomplete_Or_Partial_View (Full_Typ); 9992 9993 -- Otherwise the input type denotes an arbitrary type 9994 9995 else 9996 IP_View := Incomplete_Or_Partial_View (Typ); 9997 9998 -- The input type denotes the full view of a private type 9999 10000 if Present (IP_View) then 10001 Priv_Typ := IP_View; 10002 Full_Typ := Typ; 10003 10004 -- The input type is a private type 10005 10006 elsif Is_Private_Type (Typ) then 10007 Priv_Typ := Typ; 10008 Full_Typ := Full_View (Priv_Typ); 10009 10010 -- Otherwise the input type does not have any views 10011 10012 else 10013 Full_Typ := Typ; 10014 end if; 10015 10016 if Present (Full_Typ) then 10017 Full_Base := Base_Type (Full_Typ); 10018 10019 if Ekind_In (Full_Typ, E_Protected_Type, E_Task_Type) then 10020 CRec_Typ := Corresponding_Record_Type (Full_Typ); 10021 end if; 10022 end if; 10023 end if; 10024 end Get_Views; 10025 10026 ----------------------- 10027 -- Has_Access_Values -- 10028 ----------------------- 10029 10030 function Has_Access_Values (T : Entity_Id) return Boolean is 10031 Typ : constant Entity_Id := Underlying_Type (T); 10032 10033 begin 10034 -- Case of a private type which is not completed yet. This can only 10035 -- happen in the case of a generic format type appearing directly, or 10036 -- as a component of the type to which this function is being applied 10037 -- at the top level. Return False in this case, since we certainly do 10038 -- not know that the type contains access types. 10039 10040 if No (Typ) then 10041 return False; 10042 10043 elsif Is_Access_Type (Typ) then 10044 return True; 10045 10046 elsif Is_Array_Type (Typ) then 10047 return Has_Access_Values (Component_Type (Typ)); 10048 10049 elsif Is_Record_Type (Typ) then 10050 declare 10051 Comp : Entity_Id; 10052 10053 begin 10054 -- Loop to Check components 10055 10056 Comp := First_Component_Or_Discriminant (Typ); 10057 while Present (Comp) loop 10058 10059 -- Check for access component, tag field does not count, even 10060 -- though it is implemented internally using an access type. 10061 10062 if Has_Access_Values (Etype (Comp)) 10063 and then Chars (Comp) /= Name_uTag 10064 then 10065 return True; 10066 end if; 10067 10068 Next_Component_Or_Discriminant (Comp); 10069 end loop; 10070 end; 10071 10072 return False; 10073 10074 else 10075 return False; 10076 end if; 10077 end Has_Access_Values; 10078 10079 ------------------------------ 10080 -- Has_Compatible_Alignment -- 10081 ------------------------------ 10082 10083 function Has_Compatible_Alignment 10084 (Obj : Entity_Id; 10085 Expr : Node_Id; 10086 Layout_Done : Boolean) return Alignment_Result 10087 is 10088 function Has_Compatible_Alignment_Internal 10089 (Obj : Entity_Id; 10090 Expr : Node_Id; 10091 Layout_Done : Boolean; 10092 Default : Alignment_Result) return Alignment_Result; 10093 -- This is the internal recursive function that actually does the work. 10094 -- There is one additional parameter, which says what the result should 10095 -- be if no alignment information is found, and there is no definite 10096 -- indication of compatible alignments. At the outer level, this is set 10097 -- to Unknown, but for internal recursive calls in the case where types 10098 -- are known to be correct, it is set to Known_Compatible. 10099 10100 --------------------------------------- 10101 -- Has_Compatible_Alignment_Internal -- 10102 --------------------------------------- 10103 10104 function Has_Compatible_Alignment_Internal 10105 (Obj : Entity_Id; 10106 Expr : Node_Id; 10107 Layout_Done : Boolean; 10108 Default : Alignment_Result) return Alignment_Result 10109 is 10110 Result : Alignment_Result := Known_Compatible; 10111 -- Holds the current status of the result. Note that once a value of 10112 -- Known_Incompatible is set, it is sticky and does not get changed 10113 -- to Unknown (the value in Result only gets worse as we go along, 10114 -- never better). 10115 10116 Offs : Uint := No_Uint; 10117 -- Set to a factor of the offset from the base object when Expr is a 10118 -- selected or indexed component, based on Component_Bit_Offset and 10119 -- Component_Size respectively. A negative value is used to represent 10120 -- a value which is not known at compile time. 10121 10122 procedure Check_Prefix; 10123 -- Checks the prefix recursively in the case where the expression 10124 -- is an indexed or selected component. 10125 10126 procedure Set_Result (R : Alignment_Result); 10127 -- If R represents a worse outcome (unknown instead of known 10128 -- compatible, or known incompatible), then set Result to R. 10129 10130 ------------------ 10131 -- Check_Prefix -- 10132 ------------------ 10133 10134 procedure Check_Prefix is 10135 begin 10136 -- The subtlety here is that in doing a recursive call to check 10137 -- the prefix, we have to decide what to do in the case where we 10138 -- don't find any specific indication of an alignment problem. 10139 10140 -- At the outer level, we normally set Unknown as the result in 10141 -- this case, since we can only set Known_Compatible if we really 10142 -- know that the alignment value is OK, but for the recursive 10143 -- call, in the case where the types match, and we have not 10144 -- specified a peculiar alignment for the object, we are only 10145 -- concerned about suspicious rep clauses, the default case does 10146 -- not affect us, since the compiler will, in the absence of such 10147 -- rep clauses, ensure that the alignment is correct. 10148 10149 if Default = Known_Compatible 10150 or else 10151 (Etype (Obj) = Etype (Expr) 10152 and then (Unknown_Alignment (Obj) 10153 or else 10154 Alignment (Obj) = Alignment (Etype (Obj)))) 10155 then 10156 Set_Result 10157 (Has_Compatible_Alignment_Internal 10158 (Obj, Prefix (Expr), Layout_Done, Known_Compatible)); 10159 10160 -- In all other cases, we need a full check on the prefix 10161 10162 else 10163 Set_Result 10164 (Has_Compatible_Alignment_Internal 10165 (Obj, Prefix (Expr), Layout_Done, Unknown)); 10166 end if; 10167 end Check_Prefix; 10168 10169 ---------------- 10170 -- Set_Result -- 10171 ---------------- 10172 10173 procedure Set_Result (R : Alignment_Result) is 10174 begin 10175 if R > Result then 10176 Result := R; 10177 end if; 10178 end Set_Result; 10179 10180 -- Start of processing for Has_Compatible_Alignment_Internal 10181 10182 begin 10183 -- If Expr is a selected component, we must make sure there is no 10184 -- potentially troublesome component clause and that the record is 10185 -- not packed if the layout is not done. 10186 10187 if Nkind (Expr) = N_Selected_Component then 10188 10189 -- Packing generates unknown alignment if layout is not done 10190 10191 if Is_Packed (Etype (Prefix (Expr))) and then not Layout_Done then 10192 Set_Result (Unknown); 10193 end if; 10194 10195 -- Check prefix and component offset 10196 10197 Check_Prefix; 10198 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr))); 10199 10200 -- If Expr is an indexed component, we must make sure there is no 10201 -- potentially troublesome Component_Size clause and that the array 10202 -- is not bit-packed if the layout is not done. 10203 10204 elsif Nkind (Expr) = N_Indexed_Component then 10205 declare 10206 Typ : constant Entity_Id := Etype (Prefix (Expr)); 10207 10208 begin 10209 -- Packing generates unknown alignment if layout is not done 10210 10211 if Is_Bit_Packed_Array (Typ) and then not Layout_Done then 10212 Set_Result (Unknown); 10213 end if; 10214 10215 -- Check prefix and component offset (or at least size) 10216 10217 Check_Prefix; 10218 Offs := Indexed_Component_Bit_Offset (Expr); 10219 if Offs = No_Uint then 10220 Offs := Component_Size (Typ); 10221 end if; 10222 end; 10223 end if; 10224 10225 -- If we have a null offset, the result is entirely determined by 10226 -- the base object and has already been computed recursively. 10227 10228 if Offs = Uint_0 then 10229 null; 10230 10231 -- Case where we know the alignment of the object 10232 10233 elsif Known_Alignment (Obj) then 10234 declare 10235 ObjA : constant Uint := Alignment (Obj); 10236 ExpA : Uint := No_Uint; 10237 SizA : Uint := No_Uint; 10238 10239 begin 10240 -- If alignment of Obj is 1, then we are always OK 10241 10242 if ObjA = 1 then 10243 Set_Result (Known_Compatible); 10244 10245 -- Alignment of Obj is greater than 1, so we need to check 10246 10247 else 10248 -- If we have an offset, see if it is compatible 10249 10250 if Offs /= No_Uint and Offs > Uint_0 then 10251 if Offs mod (System_Storage_Unit * ObjA) /= 0 then 10252 Set_Result (Known_Incompatible); 10253 end if; 10254 10255 -- See if Expr is an object with known alignment 10256 10257 elsif Is_Entity_Name (Expr) 10258 and then Known_Alignment (Entity (Expr)) 10259 then 10260 ExpA := Alignment (Entity (Expr)); 10261 10262 -- Otherwise, we can use the alignment of the type of 10263 -- Expr given that we already checked for 10264 -- discombobulating rep clauses for the cases of indexed 10265 -- and selected components above. 10266 10267 elsif Known_Alignment (Etype (Expr)) then 10268 ExpA := Alignment (Etype (Expr)); 10269 10270 -- Otherwise the alignment is unknown 10271 10272 else 10273 Set_Result (Default); 10274 end if; 10275 10276 -- If we got an alignment, see if it is acceptable 10277 10278 if ExpA /= No_Uint and then ExpA < ObjA then 10279 Set_Result (Known_Incompatible); 10280 end if; 10281 10282 -- If Expr is not a piece of a larger object, see if size 10283 -- is given. If so, check that it is not too small for the 10284 -- required alignment. 10285 10286 if Offs /= No_Uint then 10287 null; 10288 10289 -- See if Expr is an object with known size 10290 10291 elsif Is_Entity_Name (Expr) 10292 and then Known_Static_Esize (Entity (Expr)) 10293 then 10294 SizA := Esize (Entity (Expr)); 10295 10296 -- Otherwise, we check the object size of the Expr type 10297 10298 elsif Known_Static_Esize (Etype (Expr)) then 10299 SizA := Esize (Etype (Expr)); 10300 end if; 10301 10302 -- If we got a size, see if it is a multiple of the Obj 10303 -- alignment, if not, then the alignment cannot be 10304 -- acceptable, since the size is always a multiple of the 10305 -- alignment. 10306 10307 if SizA /= No_Uint then 10308 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then 10309 Set_Result (Known_Incompatible); 10310 end if; 10311 end if; 10312 end if; 10313 end; 10314 10315 -- If we do not know required alignment, any non-zero offset is a 10316 -- potential problem (but certainly may be OK, so result is unknown). 10317 10318 elsif Offs /= No_Uint then 10319 Set_Result (Unknown); 10320 10321 -- If we can't find the result by direct comparison of alignment 10322 -- values, then there is still one case that we can determine known 10323 -- result, and that is when we can determine that the types are the 10324 -- same, and no alignments are specified. Then we known that the 10325 -- alignments are compatible, even if we don't know the alignment 10326 -- value in the front end. 10327 10328 elsif Etype (Obj) = Etype (Expr) then 10329 10330 -- Types are the same, but we have to check for possible size 10331 -- and alignments on the Expr object that may make the alignment 10332 -- different, even though the types are the same. 10333 10334 if Is_Entity_Name (Expr) then 10335 10336 -- First check alignment of the Expr object. Any alignment less 10337 -- than Maximum_Alignment is worrisome since this is the case 10338 -- where we do not know the alignment of Obj. 10339 10340 if Known_Alignment (Entity (Expr)) 10341 and then UI_To_Int (Alignment (Entity (Expr))) < 10342 Ttypes.Maximum_Alignment 10343 then 10344 Set_Result (Unknown); 10345 10346 -- Now check size of Expr object. Any size that is not an 10347 -- even multiple of Maximum_Alignment is also worrisome 10348 -- since it may cause the alignment of the object to be less 10349 -- than the alignment of the type. 10350 10351 elsif Known_Static_Esize (Entity (Expr)) 10352 and then 10353 (UI_To_Int (Esize (Entity (Expr))) mod 10354 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)) 10355 /= 0 10356 then 10357 Set_Result (Unknown); 10358 10359 -- Otherwise same type is decisive 10360 10361 else 10362 Set_Result (Known_Compatible); 10363 end if; 10364 end if; 10365 10366 -- Another case to deal with is when there is an explicit size or 10367 -- alignment clause when the types are not the same. If so, then the 10368 -- result is Unknown. We don't need to do this test if the Default is 10369 -- Unknown, since that result will be set in any case. 10370 10371 elsif Default /= Unknown 10372 and then (Has_Size_Clause (Etype (Expr)) 10373 or else 10374 Has_Alignment_Clause (Etype (Expr))) 10375 then 10376 Set_Result (Unknown); 10377 10378 -- If no indication found, set default 10379 10380 else 10381 Set_Result (Default); 10382 end if; 10383 10384 -- Return worst result found 10385 10386 return Result; 10387 end Has_Compatible_Alignment_Internal; 10388 10389 -- Start of processing for Has_Compatible_Alignment 10390 10391 begin 10392 -- If Obj has no specified alignment, then set alignment from the type 10393 -- alignment. Perhaps we should always do this, but for sure we should 10394 -- do it when there is an address clause since we can do more if the 10395 -- alignment is known. 10396 10397 if Unknown_Alignment (Obj) then 10398 Set_Alignment (Obj, Alignment (Etype (Obj))); 10399 end if; 10400 10401 -- Now do the internal call that does all the work 10402 10403 return 10404 Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown); 10405 end Has_Compatible_Alignment; 10406 10407 ---------------------- 10408 -- Has_Declarations -- 10409 ---------------------- 10410 10411 function Has_Declarations (N : Node_Id) return Boolean is 10412 begin 10413 return Nkind_In (Nkind (N), N_Accept_Statement, 10414 N_Block_Statement, 10415 N_Compilation_Unit_Aux, 10416 N_Entry_Body, 10417 N_Package_Body, 10418 N_Protected_Body, 10419 N_Subprogram_Body, 10420 N_Task_Body, 10421 N_Package_Specification); 10422 end Has_Declarations; 10423 10424 --------------------------------- 10425 -- Has_Defaulted_Discriminants -- 10426 --------------------------------- 10427 10428 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is 10429 begin 10430 return Has_Discriminants (Typ) 10431 and then Present (First_Discriminant (Typ)) 10432 and then Present (Discriminant_Default_Value 10433 (First_Discriminant (Typ))); 10434 end Has_Defaulted_Discriminants; 10435 10436 ------------------- 10437 -- Has_Denormals -- 10438 ------------------- 10439 10440 function Has_Denormals (E : Entity_Id) return Boolean is 10441 begin 10442 return Is_Floating_Point_Type (E) and then Denorm_On_Target; 10443 end Has_Denormals; 10444 10445 ------------------------------------------- 10446 -- Has_Discriminant_Dependent_Constraint -- 10447 ------------------------------------------- 10448 10449 function Has_Discriminant_Dependent_Constraint 10450 (Comp : Entity_Id) return Boolean 10451 is 10452 Comp_Decl : constant Node_Id := Parent (Comp); 10453 Subt_Indic : Node_Id; 10454 Constr : Node_Id; 10455 Assn : Node_Id; 10456 10457 begin 10458 -- Discriminants can't depend on discriminants 10459 10460 if Ekind (Comp) = E_Discriminant then 10461 return False; 10462 10463 else 10464 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl)); 10465 10466 if Nkind (Subt_Indic) = N_Subtype_Indication then 10467 Constr := Constraint (Subt_Indic); 10468 10469 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then 10470 Assn := First (Constraints (Constr)); 10471 while Present (Assn) loop 10472 case Nkind (Assn) is 10473 when N_Identifier 10474 | N_Range 10475 | N_Subtype_Indication 10476 => 10477 if Depends_On_Discriminant (Assn) then 10478 return True; 10479 end if; 10480 10481 when N_Discriminant_Association => 10482 if Depends_On_Discriminant (Expression (Assn)) then 10483 return True; 10484 end if; 10485 10486 when others => 10487 null; 10488 end case; 10489 10490 Next (Assn); 10491 end loop; 10492 end if; 10493 end if; 10494 end if; 10495 10496 return False; 10497 end Has_Discriminant_Dependent_Constraint; 10498 10499 -------------------------------------- 10500 -- Has_Effectively_Volatile_Profile -- 10501 -------------------------------------- 10502 10503 function Has_Effectively_Volatile_Profile 10504 (Subp_Id : Entity_Id) return Boolean 10505 is 10506 Formal : Entity_Id; 10507 10508 begin 10509 -- Inspect the formal parameters looking for an effectively volatile 10510 -- type. 10511 10512 Formal := First_Formal (Subp_Id); 10513 while Present (Formal) loop 10514 if Is_Effectively_Volatile (Etype (Formal)) then 10515 return True; 10516 end if; 10517 10518 Next_Formal (Formal); 10519 end loop; 10520 10521 -- Inspect the return type of functions 10522 10523 if Ekind_In (Subp_Id, E_Function, E_Generic_Function) 10524 and then Is_Effectively_Volatile (Etype (Subp_Id)) 10525 then 10526 return True; 10527 end if; 10528 10529 return False; 10530 end Has_Effectively_Volatile_Profile; 10531 10532 -------------------------- 10533 -- Has_Enabled_Property -- 10534 -------------------------- 10535 10536 function Has_Enabled_Property 10537 (Item_Id : Entity_Id; 10538 Property : Name_Id) return Boolean 10539 is 10540 function Protected_Object_Has_Enabled_Property return Boolean; 10541 -- Determine whether a protected object denoted by Item_Id has the 10542 -- property enabled. 10543 10544 function State_Has_Enabled_Property return Boolean; 10545 -- Determine whether a state denoted by Item_Id has the property enabled 10546 10547 function Variable_Has_Enabled_Property return Boolean; 10548 -- Determine whether a variable denoted by Item_Id has the property 10549 -- enabled. 10550 10551 ------------------------------------------- 10552 -- Protected_Object_Has_Enabled_Property -- 10553 ------------------------------------------- 10554 10555 function Protected_Object_Has_Enabled_Property return Boolean is 10556 Constits : constant Elist_Id := Part_Of_Constituents (Item_Id); 10557 Constit_Elmt : Elmt_Id; 10558 Constit_Id : Entity_Id; 10559 10560 begin 10561 -- Protected objects always have the properties Async_Readers and 10562 -- Async_Writers (SPARK RM 7.1.2(16)). 10563 10564 if Property = Name_Async_Readers 10565 or else Property = Name_Async_Writers 10566 then 10567 return True; 10568 10569 -- Protected objects that have Part_Of components also inherit their 10570 -- properties Effective_Reads and Effective_Writes 10571 -- (SPARK RM 7.1.2(16)). 10572 10573 elsif Present (Constits) then 10574 Constit_Elmt := First_Elmt (Constits); 10575 while Present (Constit_Elmt) loop 10576 Constit_Id := Node (Constit_Elmt); 10577 10578 if Has_Enabled_Property (Constit_Id, Property) then 10579 return True; 10580 end if; 10581 10582 Next_Elmt (Constit_Elmt); 10583 end loop; 10584 end if; 10585 10586 return False; 10587 end Protected_Object_Has_Enabled_Property; 10588 10589 -------------------------------- 10590 -- State_Has_Enabled_Property -- 10591 -------------------------------- 10592 10593 function State_Has_Enabled_Property return Boolean is 10594 Decl : constant Node_Id := Parent (Item_Id); 10595 10596 procedure Find_Simple_Properties 10597 (Has_External : out Boolean; 10598 Has_Synchronous : out Boolean); 10599 -- Extract the simple properties associated with declaration Decl 10600 10601 function Is_Enabled_External_Property return Boolean; 10602 -- Determine whether property Property appears within the external 10603 -- property list of declaration Decl, and return its status. 10604 10605 ---------------------------- 10606 -- Find_Simple_Properties -- 10607 ---------------------------- 10608 10609 procedure Find_Simple_Properties 10610 (Has_External : out Boolean; 10611 Has_Synchronous : out Boolean) 10612 is 10613 Opt : Node_Id; 10614 10615 begin 10616 -- Assume that none of the properties are available 10617 10618 Has_External := False; 10619 Has_Synchronous := False; 10620 10621 Opt := First (Expressions (Decl)); 10622 while Present (Opt) loop 10623 if Nkind (Opt) = N_Identifier then 10624 if Chars (Opt) = Name_External then 10625 Has_External := True; 10626 10627 elsif Chars (Opt) = Name_Synchronous then 10628 Has_Synchronous := True; 10629 end if; 10630 end if; 10631 10632 Next (Opt); 10633 end loop; 10634 end Find_Simple_Properties; 10635 10636 ---------------------------------- 10637 -- Is_Enabled_External_Property -- 10638 ---------------------------------- 10639 10640 function Is_Enabled_External_Property return Boolean is 10641 Opt : Node_Id; 10642 Opt_Nam : Node_Id; 10643 Prop : Node_Id; 10644 Prop_Nam : Node_Id; 10645 Props : Node_Id; 10646 10647 begin 10648 Opt := First (Component_Associations (Decl)); 10649 while Present (Opt) loop 10650 Opt_Nam := First (Choices (Opt)); 10651 10652 if Nkind (Opt_Nam) = N_Identifier 10653 and then Chars (Opt_Nam) = Name_External 10654 then 10655 Props := Expression (Opt); 10656 10657 -- Multiple properties appear as an aggregate 10658 10659 if Nkind (Props) = N_Aggregate then 10660 10661 -- Simple property form 10662 10663 Prop := First (Expressions (Props)); 10664 while Present (Prop) loop 10665 if Chars (Prop) = Property then 10666 return True; 10667 end if; 10668 10669 Next (Prop); 10670 end loop; 10671 10672 -- Property with expression form 10673 10674 Prop := First (Component_Associations (Props)); 10675 while Present (Prop) loop 10676 Prop_Nam := First (Choices (Prop)); 10677 10678 -- The property can be represented in two ways: 10679 -- others => <value> 10680 -- <property> => <value> 10681 10682 if Nkind (Prop_Nam) = N_Others_Choice 10683 or else (Nkind (Prop_Nam) = N_Identifier 10684 and then Chars (Prop_Nam) = Property) 10685 then 10686 return Is_True (Expr_Value (Expression (Prop))); 10687 end if; 10688 10689 Next (Prop); 10690 end loop; 10691 10692 -- Single property 10693 10694 else 10695 return Chars (Props) = Property; 10696 end if; 10697 end if; 10698 10699 Next (Opt); 10700 end loop; 10701 10702 return False; 10703 end Is_Enabled_External_Property; 10704 10705 -- Local variables 10706 10707 Has_External : Boolean; 10708 Has_Synchronous : Boolean; 10709 10710 -- Start of processing for State_Has_Enabled_Property 10711 10712 begin 10713 -- The declaration of an external abstract state appears as an 10714 -- extension aggregate. If this is not the case, properties can 10715 -- never be set. 10716 10717 if Nkind (Decl) /= N_Extension_Aggregate then 10718 return False; 10719 end if; 10720 10721 Find_Simple_Properties (Has_External, Has_Synchronous); 10722 10723 -- Simple option External enables all properties (SPARK RM 7.1.2(2)) 10724 10725 if Has_External then 10726 return True; 10727 10728 -- Option External may enable or disable specific properties 10729 10730 elsif Is_Enabled_External_Property then 10731 return True; 10732 10733 -- Simple option Synchronous 10734 -- 10735 -- enables disables 10736 -- Asynch_Readers Effective_Reads 10737 -- Asynch_Writers Effective_Writes 10738 -- 10739 -- Note that both forms of External have higher precedence than 10740 -- Synchronous (SPARK RM 7.1.4(10)). 10741 10742 elsif Has_Synchronous then 10743 return Nam_In (Property, Name_Async_Readers, Name_Async_Writers); 10744 end if; 10745 10746 return False; 10747 end State_Has_Enabled_Property; 10748 10749 ----------------------------------- 10750 -- Variable_Has_Enabled_Property -- 10751 ----------------------------------- 10752 10753 function Variable_Has_Enabled_Property return Boolean is 10754 function Is_Enabled (Prag : Node_Id) return Boolean; 10755 -- Determine whether property pragma Prag (if present) denotes an 10756 -- enabled property. 10757 10758 ---------------- 10759 -- Is_Enabled -- 10760 ---------------- 10761 10762 function Is_Enabled (Prag : Node_Id) return Boolean is 10763 Arg1 : Node_Id; 10764 10765 begin 10766 if Present (Prag) then 10767 Arg1 := First (Pragma_Argument_Associations (Prag)); 10768 10769 -- The pragma has an optional Boolean expression, the related 10770 -- property is enabled only when the expression evaluates to 10771 -- True. 10772 10773 if Present (Arg1) then 10774 return Is_True (Expr_Value (Get_Pragma_Arg (Arg1))); 10775 10776 -- Otherwise the lack of expression enables the property by 10777 -- default. 10778 10779 else 10780 return True; 10781 end if; 10782 10783 -- The property was never set in the first place 10784 10785 else 10786 return False; 10787 end if; 10788 end Is_Enabled; 10789 10790 -- Local variables 10791 10792 AR : constant Node_Id := 10793 Get_Pragma (Item_Id, Pragma_Async_Readers); 10794 AW : constant Node_Id := 10795 Get_Pragma (Item_Id, Pragma_Async_Writers); 10796 ER : constant Node_Id := 10797 Get_Pragma (Item_Id, Pragma_Effective_Reads); 10798 EW : constant Node_Id := 10799 Get_Pragma (Item_Id, Pragma_Effective_Writes); 10800 10801 -- Start of processing for Variable_Has_Enabled_Property 10802 10803 begin 10804 -- A non-effectively volatile object can never possess external 10805 -- properties. 10806 10807 if not Is_Effectively_Volatile (Item_Id) then 10808 return False; 10809 10810 -- External properties related to variables come in two flavors - 10811 -- explicit and implicit. The explicit case is characterized by the 10812 -- presence of a property pragma with an optional Boolean flag. The 10813 -- property is enabled when the flag evaluates to True or the flag is 10814 -- missing altogether. 10815 10816 elsif Property = Name_Async_Readers and then Is_Enabled (AR) then 10817 return True; 10818 10819 elsif Property = Name_Async_Writers and then Is_Enabled (AW) then 10820 return True; 10821 10822 elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then 10823 return True; 10824 10825 elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then 10826 return True; 10827 10828 -- The implicit case lacks all property pragmas 10829 10830 elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then 10831 if Is_Protected_Type (Etype (Item_Id)) then 10832 return Protected_Object_Has_Enabled_Property; 10833 else 10834 return True; 10835 end if; 10836 10837 else 10838 return False; 10839 end if; 10840 end Variable_Has_Enabled_Property; 10841 10842 -- Start of processing for Has_Enabled_Property 10843 10844 begin 10845 -- Abstract states and variables have a flexible scheme of specifying 10846 -- external properties. 10847 10848 if Ekind (Item_Id) = E_Abstract_State then 10849 return State_Has_Enabled_Property; 10850 10851 elsif Ekind (Item_Id) = E_Variable then 10852 return Variable_Has_Enabled_Property; 10853 10854 -- By default, protected objects only have the properties Async_Readers 10855 -- and Async_Writers. If they have Part_Of components, they also inherit 10856 -- their properties Effective_Reads and Effective_Writes 10857 -- (SPARK RM 7.1.2(16)). 10858 10859 elsif Ekind (Item_Id) = E_Protected_Object then 10860 return Protected_Object_Has_Enabled_Property; 10861 10862 -- Otherwise a property is enabled when the related item is effectively 10863 -- volatile. 10864 10865 else 10866 return Is_Effectively_Volatile (Item_Id); 10867 end if; 10868 end Has_Enabled_Property; 10869 10870 ------------------------------------- 10871 -- Has_Full_Default_Initialization -- 10872 ------------------------------------- 10873 10874 function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is 10875 Comp : Entity_Id; 10876 10877 begin 10878 -- A type subject to pragma Default_Initial_Condition may be fully 10879 -- default initialized depending on inheritance and the argument of 10880 -- the pragma. Since any type may act as the full view of a private 10881 -- type, this check must be performed prior to the specialized tests 10882 -- below. 10883 10884 if Has_Fully_Default_Initializing_DIC_Pragma (Typ) then 10885 return True; 10886 end if; 10887 10888 -- A scalar type is fully default initialized if it is subject to aspect 10889 -- Default_Value. 10890 10891 if Is_Scalar_Type (Typ) then 10892 return Has_Default_Aspect (Typ); 10893 10894 -- An access type is fully default initialized by default 10895 10896 elsif Is_Access_Type (Typ) then 10897 return True; 10898 10899 -- An array type is fully default initialized if its element type is 10900 -- scalar and the array type carries aspect Default_Component_Value or 10901 -- the element type is fully default initialized. 10902 10903 elsif Is_Array_Type (Typ) then 10904 return 10905 Has_Default_Aspect (Typ) 10906 or else Has_Full_Default_Initialization (Component_Type (Typ)); 10907 10908 -- A protected type, record type, or type extension is fully default 10909 -- initialized if all its components either carry an initialization 10910 -- expression or have a type that is fully default initialized. The 10911 -- parent type of a type extension must be fully default initialized. 10912 10913 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then 10914 10915 -- Inspect all entities defined in the scope of the type, looking for 10916 -- uninitialized components. 10917 10918 Comp := First_Entity (Typ); 10919 while Present (Comp) loop 10920 if Ekind (Comp) = E_Component 10921 and then Comes_From_Source (Comp) 10922 and then No (Expression (Parent (Comp))) 10923 and then not Has_Full_Default_Initialization (Etype (Comp)) 10924 then 10925 return False; 10926 end if; 10927 10928 Next_Entity (Comp); 10929 end loop; 10930 10931 -- Ensure that the parent type of a type extension is fully default 10932 -- initialized. 10933 10934 if Etype (Typ) /= Typ 10935 and then not Has_Full_Default_Initialization (Etype (Typ)) 10936 then 10937 return False; 10938 end if; 10939 10940 -- If we get here, then all components and parent portion are fully 10941 -- default initialized. 10942 10943 return True; 10944 10945 -- A task type is fully default initialized by default 10946 10947 elsif Is_Task_Type (Typ) then 10948 return True; 10949 10950 -- Otherwise the type is not fully default initialized 10951 10952 else 10953 return False; 10954 end if; 10955 end Has_Full_Default_Initialization; 10956 10957 ----------------------------------------------- 10958 -- Has_Fully_Default_Initializing_DIC_Pragma -- 10959 ----------------------------------------------- 10960 10961 function Has_Fully_Default_Initializing_DIC_Pragma 10962 (Typ : Entity_Id) return Boolean 10963 is 10964 Args : List_Id; 10965 Prag : Node_Id; 10966 10967 begin 10968 -- A type that inherits pragma Default_Initial_Condition from a parent 10969 -- type is automatically fully default initialized. 10970 10971 if Has_Inherited_DIC (Typ) then 10972 return True; 10973 10974 -- Otherwise the type is fully default initialized only when the pragma 10975 -- appears without an argument, or the argument is non-null. 10976 10977 elsif Has_Own_DIC (Typ) then 10978 Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition); 10979 pragma Assert (Present (Prag)); 10980 Args := Pragma_Argument_Associations (Prag); 10981 10982 -- The pragma appears without an argument in which case it defaults 10983 -- to True. 10984 10985 if No (Args) then 10986 return True; 10987 10988 -- The pragma appears with a non-null expression 10989 10990 elsif Nkind (Get_Pragma_Arg (First (Args))) /= N_Null then 10991 return True; 10992 end if; 10993 end if; 10994 10995 return False; 10996 end Has_Fully_Default_Initializing_DIC_Pragma; 10997 10998 -------------------- 10999 -- Has_Infinities -- 11000 -------------------- 11001 11002 function Has_Infinities (E : Entity_Id) return Boolean is 11003 begin 11004 return 11005 Is_Floating_Point_Type (E) 11006 and then Nkind (Scalar_Range (E)) = N_Range 11007 and then Includes_Infinities (Scalar_Range (E)); 11008 end Has_Infinities; 11009 11010 -------------------- 11011 -- Has_Interfaces -- 11012 -------------------- 11013 11014 function Has_Interfaces 11015 (T : Entity_Id; 11016 Use_Full_View : Boolean := True) return Boolean 11017 is 11018 Typ : Entity_Id := Base_Type (T); 11019 11020 begin 11021 -- Handle concurrent types 11022 11023 if Is_Concurrent_Type (Typ) then 11024 Typ := Corresponding_Record_Type (Typ); 11025 end if; 11026 11027 if not Present (Typ) 11028 or else not Is_Record_Type (Typ) 11029 or else not Is_Tagged_Type (Typ) 11030 then 11031 return False; 11032 end if; 11033 11034 -- Handle private types 11035 11036 if Use_Full_View and then Present (Full_View (Typ)) then 11037 Typ := Full_View (Typ); 11038 end if; 11039 11040 -- Handle concurrent record types 11041 11042 if Is_Concurrent_Record_Type (Typ) 11043 and then Is_Non_Empty_List (Abstract_Interface_List (Typ)) 11044 then 11045 return True; 11046 end if; 11047 11048 loop 11049 if Is_Interface (Typ) 11050 or else 11051 (Is_Record_Type (Typ) 11052 and then Present (Interfaces (Typ)) 11053 and then not Is_Empty_Elmt_List (Interfaces (Typ))) 11054 then 11055 return True; 11056 end if; 11057 11058 exit when Etype (Typ) = Typ 11059 11060 -- Handle private types 11061 11062 or else (Present (Full_View (Etype (Typ))) 11063 and then Full_View (Etype (Typ)) = Typ) 11064 11065 -- Protect frontend against wrong sources with cyclic derivations 11066 11067 or else Etype (Typ) = T; 11068 11069 -- Climb to the ancestor type handling private types 11070 11071 if Present (Full_View (Etype (Typ))) then 11072 Typ := Full_View (Etype (Typ)); 11073 else 11074 Typ := Etype (Typ); 11075 end if; 11076 end loop; 11077 11078 return False; 11079 end Has_Interfaces; 11080 11081 -------------------------- 11082 -- Has_Max_Queue_Length -- 11083 -------------------------- 11084 11085 function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is 11086 begin 11087 return 11088 Ekind (Id) = E_Entry 11089 and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length)); 11090 end Has_Max_Queue_Length; 11091 11092 --------------------------------- 11093 -- Has_No_Obvious_Side_Effects -- 11094 --------------------------------- 11095 11096 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is 11097 begin 11098 -- For now handle literals, constants, and non-volatile variables and 11099 -- expressions combining these with operators or short circuit forms. 11100 11101 if Nkind (N) in N_Numeric_Or_String_Literal then 11102 return True; 11103 11104 elsif Nkind (N) = N_Character_Literal then 11105 return True; 11106 11107 elsif Nkind (N) in N_Unary_Op then 11108 return Has_No_Obvious_Side_Effects (Right_Opnd (N)); 11109 11110 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then 11111 return Has_No_Obvious_Side_Effects (Left_Opnd (N)) 11112 and then 11113 Has_No_Obvious_Side_Effects (Right_Opnd (N)); 11114 11115 elsif Nkind (N) = N_Expression_With_Actions 11116 and then Is_Empty_List (Actions (N)) 11117 then 11118 return Has_No_Obvious_Side_Effects (Expression (N)); 11119 11120 elsif Nkind (N) in N_Has_Entity then 11121 return Present (Entity (N)) 11122 and then Ekind_In (Entity (N), E_Variable, 11123 E_Constant, 11124 E_Enumeration_Literal, 11125 E_In_Parameter, 11126 E_Out_Parameter, 11127 E_In_Out_Parameter) 11128 and then not Is_Volatile (Entity (N)); 11129 11130 else 11131 return False; 11132 end if; 11133 end Has_No_Obvious_Side_Effects; 11134 11135 ----------------------------- 11136 -- Has_Non_Null_Refinement -- 11137 ----------------------------- 11138 11139 function Has_Non_Null_Refinement (Id : Entity_Id) return Boolean is 11140 Constits : Elist_Id; 11141 11142 begin 11143 pragma Assert (Ekind (Id) = E_Abstract_State); 11144 Constits := Refinement_Constituents (Id); 11145 11146 -- For a refinement to be non-null, the first constituent must be 11147 -- anything other than null. 11148 11149 return 11150 Present (Constits) 11151 and then Nkind (Node (First_Elmt (Constits))) /= N_Null; 11152 end Has_Non_Null_Refinement; 11153 11154 ----------------------------- 11155 -- Has_Non_Null_Statements -- 11156 ----------------------------- 11157 11158 function Has_Non_Null_Statements (L : List_Id) return Boolean is 11159 Node : Node_Id; 11160 11161 begin 11162 if Is_Non_Empty_List (L) then 11163 Node := First (L); 11164 11165 loop 11166 if Nkind (Node) /= N_Null_Statement then 11167 return True; 11168 end if; 11169 11170 Next (Node); 11171 exit when Node = Empty; 11172 end loop; 11173 end if; 11174 11175 return False; 11176 end Has_Non_Null_Statements; 11177 11178 ---------------------------------- 11179 -- Has_Non_Trivial_Precondition -- 11180 ---------------------------------- 11181 11182 function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is 11183 Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre); 11184 11185 begin 11186 return 11187 Present (Pre) 11188 and then Class_Present (Pre) 11189 and then not Is_Entity_Name (Expression (Pre)); 11190 end Has_Non_Trivial_Precondition; 11191 11192 ------------------- 11193 -- Has_Null_Body -- 11194 ------------------- 11195 11196 function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is 11197 Body_Id : Entity_Id; 11198 Decl : Node_Id; 11199 Spec : Node_Id; 11200 Stmt1 : Node_Id; 11201 Stmt2 : Node_Id; 11202 11203 begin 11204 Spec := Parent (Proc_Id); 11205 Decl := Parent (Spec); 11206 11207 -- Retrieve the entity of the procedure body (e.g. invariant proc). 11208 11209 if Nkind (Spec) = N_Procedure_Specification 11210 and then Nkind (Decl) = N_Subprogram_Declaration 11211 then 11212 Body_Id := Corresponding_Body (Decl); 11213 11214 -- The body acts as a spec 11215 11216 else 11217 Body_Id := Proc_Id; 11218 end if; 11219 11220 -- The body will be generated later 11221 11222 if No (Body_Id) then 11223 return False; 11224 end if; 11225 11226 Spec := Parent (Body_Id); 11227 Decl := Parent (Spec); 11228 11229 pragma Assert 11230 (Nkind (Spec) = N_Procedure_Specification 11231 and then Nkind (Decl) = N_Subprogram_Body); 11232 11233 Stmt1 := First (Statements (Handled_Statement_Sequence (Decl))); 11234 11235 -- Look for a null statement followed by an optional return 11236 -- statement. 11237 11238 if Nkind (Stmt1) = N_Null_Statement then 11239 Stmt2 := Next (Stmt1); 11240 11241 if Present (Stmt2) then 11242 return Nkind (Stmt2) = N_Simple_Return_Statement; 11243 else 11244 return True; 11245 end if; 11246 end if; 11247 11248 return False; 11249 end Has_Null_Body; 11250 11251 ------------------------ 11252 -- Has_Null_Exclusion -- 11253 ------------------------ 11254 11255 function Has_Null_Exclusion (N : Node_Id) return Boolean is 11256 begin 11257 case Nkind (N) is 11258 when N_Access_Definition 11259 | N_Access_Function_Definition 11260 | N_Access_Procedure_Definition 11261 | N_Access_To_Object_Definition 11262 | N_Allocator 11263 | N_Derived_Type_Definition 11264 | N_Function_Specification 11265 | N_Subtype_Declaration 11266 => 11267 return Null_Exclusion_Present (N); 11268 11269 when N_Component_Definition 11270 | N_Formal_Object_Declaration 11271 | N_Object_Renaming_Declaration 11272 => 11273 if Present (Subtype_Mark (N)) then 11274 return Null_Exclusion_Present (N); 11275 else pragma Assert (Present (Access_Definition (N))); 11276 return Null_Exclusion_Present (Access_Definition (N)); 11277 end if; 11278 11279 when N_Discriminant_Specification => 11280 if Nkind (Discriminant_Type (N)) = N_Access_Definition then 11281 return Null_Exclusion_Present (Discriminant_Type (N)); 11282 else 11283 return Null_Exclusion_Present (N); 11284 end if; 11285 11286 when N_Object_Declaration => 11287 if Nkind (Object_Definition (N)) = N_Access_Definition then 11288 return Null_Exclusion_Present (Object_Definition (N)); 11289 else 11290 return Null_Exclusion_Present (N); 11291 end if; 11292 11293 when N_Parameter_Specification => 11294 if Nkind (Parameter_Type (N)) = N_Access_Definition then 11295 return Null_Exclusion_Present (Parameter_Type (N)); 11296 else 11297 return Null_Exclusion_Present (N); 11298 end if; 11299 11300 when others => 11301 return False; 11302 end case; 11303 end Has_Null_Exclusion; 11304 11305 ------------------------ 11306 -- Has_Null_Extension -- 11307 ------------------------ 11308 11309 function Has_Null_Extension (T : Entity_Id) return Boolean is 11310 B : constant Entity_Id := Base_Type (T); 11311 Comps : Node_Id; 11312 Ext : Node_Id; 11313 11314 begin 11315 if Nkind (Parent (B)) = N_Full_Type_Declaration 11316 and then Present (Record_Extension_Part (Type_Definition (Parent (B)))) 11317 then 11318 Ext := Record_Extension_Part (Type_Definition (Parent (B))); 11319 11320 if Present (Ext) then 11321 if Null_Present (Ext) then 11322 return True; 11323 else 11324 Comps := Component_List (Ext); 11325 11326 -- The null component list is rewritten during analysis to 11327 -- include the parent component. Any other component indicates 11328 -- that the extension was not originally null. 11329 11330 return Null_Present (Comps) 11331 or else No (Next (First (Component_Items (Comps)))); 11332 end if; 11333 else 11334 return False; 11335 end if; 11336 11337 else 11338 return False; 11339 end if; 11340 end Has_Null_Extension; 11341 11342 ------------------------- 11343 -- Has_Null_Refinement -- 11344 ------------------------- 11345 11346 function Has_Null_Refinement (Id : Entity_Id) return Boolean is 11347 Constits : Elist_Id; 11348 11349 begin 11350 pragma Assert (Ekind (Id) = E_Abstract_State); 11351 Constits := Refinement_Constituents (Id); 11352 11353 -- For a refinement to be null, the state's sole constituent must be a 11354 -- null. 11355 11356 return 11357 Present (Constits) 11358 and then Nkind (Node (First_Elmt (Constits))) = N_Null; 11359 end Has_Null_Refinement; 11360 11361 ------------------------------- 11362 -- Has_Overriding_Initialize -- 11363 ------------------------------- 11364 11365 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is 11366 BT : constant Entity_Id := Base_Type (T); 11367 P : Elmt_Id; 11368 11369 begin 11370 if Is_Controlled (BT) then 11371 if Is_RTU (Scope (BT), Ada_Finalization) then 11372 return False; 11373 11374 elsif Present (Primitive_Operations (BT)) then 11375 P := First_Elmt (Primitive_Operations (BT)); 11376 while Present (P) loop 11377 declare 11378 Init : constant Entity_Id := Node (P); 11379 Formal : constant Entity_Id := First_Formal (Init); 11380 begin 11381 if Ekind (Init) = E_Procedure 11382 and then Chars (Init) = Name_Initialize 11383 and then Comes_From_Source (Init) 11384 and then Present (Formal) 11385 and then Etype (Formal) = BT 11386 and then No (Next_Formal (Formal)) 11387 and then (Ada_Version < Ada_2012 11388 or else not Null_Present (Parent (Init))) 11389 then 11390 return True; 11391 end if; 11392 end; 11393 11394 Next_Elmt (P); 11395 end loop; 11396 end if; 11397 11398 -- Here if type itself does not have a non-null Initialize operation: 11399 -- check immediate ancestor. 11400 11401 if Is_Derived_Type (BT) 11402 and then Has_Overriding_Initialize (Etype (BT)) 11403 then 11404 return True; 11405 end if; 11406 end if; 11407 11408 return False; 11409 end Has_Overriding_Initialize; 11410 11411 -------------------------------------- 11412 -- Has_Preelaborable_Initialization -- 11413 -------------------------------------- 11414 11415 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is 11416 Has_PE : Boolean; 11417 11418 procedure Check_Components (E : Entity_Id); 11419 -- Check component/discriminant chain, sets Has_PE False if a component 11420 -- or discriminant does not meet the preelaborable initialization rules. 11421 11422 ---------------------- 11423 -- Check_Components -- 11424 ---------------------- 11425 11426 procedure Check_Components (E : Entity_Id) is 11427 Ent : Entity_Id; 11428 Exp : Node_Id; 11429 11430 begin 11431 -- Loop through entities of record or protected type 11432 11433 Ent := E; 11434 while Present (Ent) loop 11435 11436 -- We are interested only in components and discriminants 11437 11438 Exp := Empty; 11439 11440 case Ekind (Ent) is 11441 when E_Component => 11442 11443 -- Get default expression if any. If there is no declaration 11444 -- node, it means we have an internal entity. The parent and 11445 -- tag fields are examples of such entities. For such cases, 11446 -- we just test the type of the entity. 11447 11448 if Present (Declaration_Node (Ent)) then 11449 Exp := Expression (Declaration_Node (Ent)); 11450 end if; 11451 11452 when E_Discriminant => 11453 11454 -- Note: for a renamed discriminant, the Declaration_Node 11455 -- may point to the one from the ancestor, and have a 11456 -- different expression, so use the proper attribute to 11457 -- retrieve the expression from the derived constraint. 11458 11459 Exp := Discriminant_Default_Value (Ent); 11460 11461 when others => 11462 goto Check_Next_Entity; 11463 end case; 11464 11465 -- A component has PI if it has no default expression and the 11466 -- component type has PI. 11467 11468 if No (Exp) then 11469 if not Has_Preelaborable_Initialization (Etype (Ent)) then 11470 Has_PE := False; 11471 exit; 11472 end if; 11473 11474 -- Require the default expression to be preelaborable 11475 11476 elsif not Is_Preelaborable_Construct (Exp) then 11477 Has_PE := False; 11478 exit; 11479 end if; 11480 11481 <<Check_Next_Entity>> 11482 Next_Entity (Ent); 11483 end loop; 11484 end Check_Components; 11485 11486 -- Start of processing for Has_Preelaborable_Initialization 11487 11488 begin 11489 -- Immediate return if already marked as known preelaborable init. This 11490 -- covers types for which this function has already been called once 11491 -- and returned True (in which case the result is cached), and also 11492 -- types to which a pragma Preelaborable_Initialization applies. 11493 11494 if Known_To_Have_Preelab_Init (E) then 11495 return True; 11496 end if; 11497 11498 -- If the type is a subtype representing a generic actual type, then 11499 -- test whether its base type has preelaborable initialization since 11500 -- the subtype representing the actual does not inherit this attribute 11501 -- from the actual or formal. (but maybe it should???) 11502 11503 if Is_Generic_Actual_Type (E) then 11504 return Has_Preelaborable_Initialization (Base_Type (E)); 11505 end if; 11506 11507 -- All elementary types have preelaborable initialization 11508 11509 if Is_Elementary_Type (E) then 11510 Has_PE := True; 11511 11512 -- Array types have PI if the component type has PI 11513 11514 elsif Is_Array_Type (E) then 11515 Has_PE := Has_Preelaborable_Initialization (Component_Type (E)); 11516 11517 -- A derived type has preelaborable initialization if its parent type 11518 -- has preelaborable initialization and (in the case of a derived record 11519 -- extension) if the non-inherited components all have preelaborable 11520 -- initialization. However, a user-defined controlled type with an 11521 -- overriding Initialize procedure does not have preelaborable 11522 -- initialization. 11523 11524 elsif Is_Derived_Type (E) then 11525 11526 -- If the derived type is a private extension then it doesn't have 11527 -- preelaborable initialization. 11528 11529 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then 11530 return False; 11531 end if; 11532 11533 -- First check whether ancestor type has preelaborable initialization 11534 11535 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E))); 11536 11537 -- If OK, check extension components (if any) 11538 11539 if Has_PE and then Is_Record_Type (E) then 11540 Check_Components (First_Entity (E)); 11541 end if; 11542 11543 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type 11544 -- with a user defined Initialize procedure does not have PI. If 11545 -- the type is untagged, the control primitives come from a component 11546 -- that has already been checked. 11547 11548 if Has_PE 11549 and then Is_Controlled (E) 11550 and then Is_Tagged_Type (E) 11551 and then Has_Overriding_Initialize (E) 11552 then 11553 Has_PE := False; 11554 end if; 11555 11556 -- Private types not derived from a type having preelaborable init and 11557 -- that are not marked with pragma Preelaborable_Initialization do not 11558 -- have preelaborable initialization. 11559 11560 elsif Is_Private_Type (E) then 11561 return False; 11562 11563 -- Record type has PI if it is non private and all components have PI 11564 11565 elsif Is_Record_Type (E) then 11566 Has_PE := True; 11567 Check_Components (First_Entity (E)); 11568 11569 -- Protected types must not have entries, and components must meet 11570 -- same set of rules as for record components. 11571 11572 elsif Is_Protected_Type (E) then 11573 if Has_Entries (E) then 11574 Has_PE := False; 11575 else 11576 Has_PE := True; 11577 Check_Components (First_Entity (E)); 11578 Check_Components (First_Private_Entity (E)); 11579 end if; 11580 11581 -- Type System.Address always has preelaborable initialization 11582 11583 elsif Is_RTE (E, RE_Address) then 11584 Has_PE := True; 11585 11586 -- In all other cases, type does not have preelaborable initialization 11587 11588 else 11589 return False; 11590 end if; 11591 11592 -- If type has preelaborable initialization, cache result 11593 11594 if Has_PE then 11595 Set_Known_To_Have_Preelab_Init (E); 11596 end if; 11597 11598 return Has_PE; 11599 end Has_Preelaborable_Initialization; 11600 11601 ---------------- 11602 -- Has_Prefix -- 11603 ---------------- 11604 11605 function Has_Prefix (N : Node_Id) return Boolean is 11606 begin 11607 return 11608 Nkind_In (N, N_Attribute_Reference, 11609 N_Expanded_Name, 11610 N_Explicit_Dereference, 11611 N_Indexed_Component, 11612 N_Reference, 11613 N_Selected_Component, 11614 N_Slice); 11615 end Has_Prefix; 11616 11617 --------------------------- 11618 -- Has_Private_Component -- 11619 --------------------------- 11620 11621 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is 11622 Btype : Entity_Id := Base_Type (Type_Id); 11623 Component : Entity_Id; 11624 11625 begin 11626 if Error_Posted (Type_Id) 11627 or else Error_Posted (Btype) 11628 then 11629 return False; 11630 end if; 11631 11632 if Is_Class_Wide_Type (Btype) then 11633 Btype := Root_Type (Btype); 11634 end if; 11635 11636 if Is_Private_Type (Btype) then 11637 declare 11638 UT : constant Entity_Id := Underlying_Type (Btype); 11639 begin 11640 if No (UT) then 11641 if No (Full_View (Btype)) then 11642 return not Is_Generic_Type (Btype) 11643 and then 11644 not Is_Generic_Type (Root_Type (Btype)); 11645 else 11646 return not Is_Generic_Type (Root_Type (Full_View (Btype))); 11647 end if; 11648 else 11649 return not Is_Frozen (UT) and then Has_Private_Component (UT); 11650 end if; 11651 end; 11652 11653 elsif Is_Array_Type (Btype) then 11654 return Has_Private_Component (Component_Type (Btype)); 11655 11656 elsif Is_Record_Type (Btype) then 11657 Component := First_Component (Btype); 11658 while Present (Component) loop 11659 if Has_Private_Component (Etype (Component)) then 11660 return True; 11661 end if; 11662 11663 Next_Component (Component); 11664 end loop; 11665 11666 return False; 11667 11668 elsif Is_Protected_Type (Btype) 11669 and then Present (Corresponding_Record_Type (Btype)) 11670 then 11671 return Has_Private_Component (Corresponding_Record_Type (Btype)); 11672 11673 else 11674 return False; 11675 end if; 11676 end Has_Private_Component; 11677 11678 ---------------------- 11679 -- Has_Signed_Zeros -- 11680 ---------------------- 11681 11682 function Has_Signed_Zeros (E : Entity_Id) return Boolean is 11683 begin 11684 return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target; 11685 end Has_Signed_Zeros; 11686 11687 ------------------------------ 11688 -- Has_Significant_Contract -- 11689 ------------------------------ 11690 11691 function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is 11692 Subp_Nam : constant Name_Id := Chars (Subp_Id); 11693 11694 begin 11695 -- _Finalizer procedure 11696 11697 if Subp_Nam = Name_uFinalizer then 11698 return False; 11699 11700 -- _Postconditions procedure 11701 11702 elsif Subp_Nam = Name_uPostconditions then 11703 return False; 11704 11705 -- Predicate function 11706 11707 elsif Ekind (Subp_Id) = E_Function 11708 and then Is_Predicate_Function (Subp_Id) 11709 then 11710 return False; 11711 11712 -- TSS subprogram 11713 11714 elsif Get_TSS_Name (Subp_Id) /= TSS_Null then 11715 return False; 11716 11717 else 11718 return True; 11719 end if; 11720 end Has_Significant_Contract; 11721 11722 ----------------------------- 11723 -- Has_Static_Array_Bounds -- 11724 ----------------------------- 11725 11726 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is 11727 All_Static : Boolean; 11728 Dummy : Boolean; 11729 11730 begin 11731 Examine_Array_Bounds (Typ, All_Static, Dummy); 11732 11733 return All_Static; 11734 end Has_Static_Array_Bounds; 11735 11736 --------------------------------------- 11737 -- Has_Static_Non_Empty_Array_Bounds -- 11738 --------------------------------------- 11739 11740 function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean is 11741 All_Static : Boolean; 11742 Has_Empty : Boolean; 11743 11744 begin 11745 Examine_Array_Bounds (Typ, All_Static, Has_Empty); 11746 11747 return All_Static and not Has_Empty; 11748 end Has_Static_Non_Empty_Array_Bounds; 11749 11750 ---------------- 11751 -- Has_Stream -- 11752 ---------------- 11753 11754 function Has_Stream (T : Entity_Id) return Boolean is 11755 E : Entity_Id; 11756 11757 begin 11758 if No (T) then 11759 return False; 11760 11761 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then 11762 return True; 11763 11764 elsif Is_Array_Type (T) then 11765 return Has_Stream (Component_Type (T)); 11766 11767 elsif Is_Record_Type (T) then 11768 E := First_Component (T); 11769 while Present (E) loop 11770 if Has_Stream (Etype (E)) then 11771 return True; 11772 else 11773 Next_Component (E); 11774 end if; 11775 end loop; 11776 11777 return False; 11778 11779 elsif Is_Private_Type (T) then 11780 return Has_Stream (Underlying_Type (T)); 11781 11782 else 11783 return False; 11784 end if; 11785 end Has_Stream; 11786 11787 ---------------- 11788 -- Has_Suffix -- 11789 ---------------- 11790 11791 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is 11792 begin 11793 Get_Name_String (Chars (E)); 11794 return Name_Buffer (Name_Len) = Suffix; 11795 end Has_Suffix; 11796 11797 ---------------- 11798 -- Add_Suffix -- 11799 ---------------- 11800 11801 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is 11802 begin 11803 Get_Name_String (Chars (E)); 11804 Add_Char_To_Name_Buffer (Suffix); 11805 return Name_Find; 11806 end Add_Suffix; 11807 11808 ------------------- 11809 -- Remove_Suffix -- 11810 ------------------- 11811 11812 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is 11813 begin 11814 pragma Assert (Has_Suffix (E, Suffix)); 11815 Get_Name_String (Chars (E)); 11816 Name_Len := Name_Len - 1; 11817 return Name_Find; 11818 end Remove_Suffix; 11819 11820 ---------------------------------- 11821 -- Replace_Null_By_Null_Address -- 11822 ---------------------------------- 11823 11824 procedure Replace_Null_By_Null_Address (N : Node_Id) is 11825 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id); 11826 -- Replace operand Op with a reference to Null_Address when the operand 11827 -- denotes a null Address. Other_Op denotes the other operand. 11828 11829 -------------------------- 11830 -- Replace_Null_Operand -- 11831 -------------------------- 11832 11833 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id) is 11834 begin 11835 -- Check the type of the complementary operand since the N_Null node 11836 -- has not been decorated yet. 11837 11838 if Nkind (Op) = N_Null 11839 and then Is_Descendant_Of_Address (Etype (Other_Op)) 11840 then 11841 Rewrite (Op, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (Op))); 11842 end if; 11843 end Replace_Null_Operand; 11844 11845 -- Start of processing for Replace_Null_By_Null_Address 11846 11847 begin 11848 pragma Assert (Relaxed_RM_Semantics); 11849 pragma Assert (Nkind_In (N, N_Null, 11850 N_Op_Eq, 11851 N_Op_Ge, 11852 N_Op_Gt, 11853 N_Op_Le, 11854 N_Op_Lt, 11855 N_Op_Ne)); 11856 11857 if Nkind (N) = N_Null then 11858 Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); 11859 11860 else 11861 declare 11862 L : constant Node_Id := Left_Opnd (N); 11863 R : constant Node_Id := Right_Opnd (N); 11864 11865 begin 11866 Replace_Null_Operand (L, Other_Op => R); 11867 Replace_Null_Operand (R, Other_Op => L); 11868 end; 11869 end if; 11870 end Replace_Null_By_Null_Address; 11871 11872 -------------------------- 11873 -- Has_Tagged_Component -- 11874 -------------------------- 11875 11876 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is 11877 Comp : Entity_Id; 11878 11879 begin 11880 if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then 11881 return Has_Tagged_Component (Underlying_Type (Typ)); 11882 11883 elsif Is_Array_Type (Typ) then 11884 return Has_Tagged_Component (Component_Type (Typ)); 11885 11886 elsif Is_Tagged_Type (Typ) then 11887 return True; 11888 11889 elsif Is_Record_Type (Typ) then 11890 Comp := First_Component (Typ); 11891 while Present (Comp) loop 11892 if Has_Tagged_Component (Etype (Comp)) then 11893 return True; 11894 end if; 11895 11896 Next_Component (Comp); 11897 end loop; 11898 11899 return False; 11900 11901 else 11902 return False; 11903 end if; 11904 end Has_Tagged_Component; 11905 11906 ----------------------------- 11907 -- Has_Undefined_Reference -- 11908 ----------------------------- 11909 11910 function Has_Undefined_Reference (Expr : Node_Id) return Boolean is 11911 Has_Undef_Ref : Boolean := False; 11912 -- Flag set when expression Expr contains at least one undefined 11913 -- reference. 11914 11915 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result; 11916 -- Determine whether N denotes a reference and if it does, whether it is 11917 -- undefined. 11918 11919 ---------------------------- 11920 -- Is_Undefined_Reference -- 11921 ---------------------------- 11922 11923 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result is 11924 begin 11925 if Is_Entity_Name (N) 11926 and then Present (Entity (N)) 11927 and then Entity (N) = Any_Id 11928 then 11929 Has_Undef_Ref := True; 11930 return Abandon; 11931 end if; 11932 11933 return OK; 11934 end Is_Undefined_Reference; 11935 11936 procedure Find_Undefined_References is 11937 new Traverse_Proc (Is_Undefined_Reference); 11938 11939 -- Start of processing for Has_Undefined_Reference 11940 11941 begin 11942 Find_Undefined_References (Expr); 11943 11944 return Has_Undef_Ref; 11945 end Has_Undefined_Reference; 11946 11947 ---------------------------- 11948 -- Has_Volatile_Component -- 11949 ---------------------------- 11950 11951 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is 11952 Comp : Entity_Id; 11953 11954 begin 11955 if Has_Volatile_Components (Typ) then 11956 return True; 11957 11958 elsif Is_Array_Type (Typ) then 11959 return Is_Volatile (Component_Type (Typ)); 11960 11961 elsif Is_Record_Type (Typ) then 11962 Comp := First_Component (Typ); 11963 while Present (Comp) loop 11964 if Is_Volatile_Object (Comp) then 11965 return True; 11966 end if; 11967 11968 Comp := Next_Component (Comp); 11969 end loop; 11970 end if; 11971 11972 return False; 11973 end Has_Volatile_Component; 11974 11975 ------------------------- 11976 -- Implementation_Kind -- 11977 ------------------------- 11978 11979 function Implementation_Kind (Subp : Entity_Id) return Name_Id is 11980 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented); 11981 Arg : Node_Id; 11982 begin 11983 pragma Assert (Present (Impl_Prag)); 11984 Arg := Last (Pragma_Argument_Associations (Impl_Prag)); 11985 return Chars (Get_Pragma_Arg (Arg)); 11986 end Implementation_Kind; 11987 11988 -------------------------- 11989 -- Implements_Interface -- 11990 -------------------------- 11991 11992 function Implements_Interface 11993 (Typ_Ent : Entity_Id; 11994 Iface_Ent : Entity_Id; 11995 Exclude_Parents : Boolean := False) return Boolean 11996 is 11997 Ifaces_List : Elist_Id; 11998 Elmt : Elmt_Id; 11999 Iface : Entity_Id := Base_Type (Iface_Ent); 12000 Typ : Entity_Id := Base_Type (Typ_Ent); 12001 12002 begin 12003 if Is_Class_Wide_Type (Typ) then 12004 Typ := Root_Type (Typ); 12005 end if; 12006 12007 if not Has_Interfaces (Typ) then 12008 return False; 12009 end if; 12010 12011 if Is_Class_Wide_Type (Iface) then 12012 Iface := Root_Type (Iface); 12013 end if; 12014 12015 Collect_Interfaces (Typ, Ifaces_List); 12016 12017 Elmt := First_Elmt (Ifaces_List); 12018 while Present (Elmt) loop 12019 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True) 12020 and then Exclude_Parents 12021 then 12022 null; 12023 12024 elsif Node (Elmt) = Iface then 12025 return True; 12026 end if; 12027 12028 Next_Elmt (Elmt); 12029 end loop; 12030 12031 return False; 12032 end Implements_Interface; 12033 12034 ------------------------------------ 12035 -- In_Assertion_Expression_Pragma -- 12036 ------------------------------------ 12037 12038 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is 12039 Par : Node_Id; 12040 Prag : Node_Id := Empty; 12041 12042 begin 12043 -- Climb the parent chain looking for an enclosing pragma 12044 12045 Par := N; 12046 while Present (Par) loop 12047 if Nkind (Par) = N_Pragma then 12048 Prag := Par; 12049 exit; 12050 12051 -- Precondition-like pragmas are expanded into if statements, check 12052 -- the original node instead. 12053 12054 elsif Nkind (Original_Node (Par)) = N_Pragma then 12055 Prag := Original_Node (Par); 12056 exit; 12057 12058 -- The expansion of attribute 'Old generates a constant to capture 12059 -- the result of the prefix. If the parent traversal reaches 12060 -- one of these constants, then the node technically came from a 12061 -- postcondition-like pragma. Note that the Ekind is not tested here 12062 -- because N may be the expression of an object declaration which is 12063 -- currently being analyzed. Such objects carry Ekind of E_Void. 12064 12065 elsif Nkind (Par) = N_Object_Declaration 12066 and then Constant_Present (Par) 12067 and then Stores_Attribute_Old_Prefix (Defining_Entity (Par)) 12068 then 12069 return True; 12070 12071 -- Prevent the search from going too far 12072 12073 elsif Is_Body_Or_Package_Declaration (Par) then 12074 return False; 12075 end if; 12076 12077 Par := Parent (Par); 12078 end loop; 12079 12080 return 12081 Present (Prag) 12082 and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag)); 12083 end In_Assertion_Expression_Pragma; 12084 12085 ---------------------- 12086 -- In_Generic_Scope -- 12087 ---------------------- 12088 12089 function In_Generic_Scope (E : Entity_Id) return Boolean is 12090 S : Entity_Id; 12091 12092 begin 12093 S := Scope (E); 12094 while Present (S) and then S /= Standard_Standard loop 12095 if Is_Generic_Unit (S) then 12096 return True; 12097 end if; 12098 12099 S := Scope (S); 12100 end loop; 12101 12102 return False; 12103 end In_Generic_Scope; 12104 12105 ----------------- 12106 -- In_Instance -- 12107 ----------------- 12108 12109 function In_Instance return Boolean is 12110 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 12111 S : Entity_Id; 12112 12113 begin 12114 S := Current_Scope; 12115 while Present (S) and then S /= Standard_Standard loop 12116 if Is_Generic_Instance (S) then 12117 12118 -- A child instance is always compiled in the context of a parent 12119 -- instance. Nevertheless, the actuals are not analyzed in an 12120 -- instance context. We detect this case by examining the current 12121 -- compilation unit, which must be a child instance, and checking 12122 -- that it is not currently on the scope stack. 12123 12124 if Is_Child_Unit (Curr_Unit) 12125 and then Nkind (Unit (Cunit (Current_Sem_Unit))) = 12126 N_Package_Instantiation 12127 and then not In_Open_Scopes (Curr_Unit) 12128 then 12129 return False; 12130 else 12131 return True; 12132 end if; 12133 end if; 12134 12135 S := Scope (S); 12136 end loop; 12137 12138 return False; 12139 end In_Instance; 12140 12141 ---------------------- 12142 -- In_Instance_Body -- 12143 ---------------------- 12144 12145 function In_Instance_Body return Boolean is 12146 S : Entity_Id; 12147 12148 begin 12149 S := Current_Scope; 12150 while Present (S) and then S /= Standard_Standard loop 12151 if Ekind_In (S, E_Function, E_Procedure) 12152 and then Is_Generic_Instance (S) 12153 then 12154 return True; 12155 12156 elsif Ekind (S) = E_Package 12157 and then In_Package_Body (S) 12158 and then Is_Generic_Instance (S) 12159 then 12160 return True; 12161 end if; 12162 12163 S := Scope (S); 12164 end loop; 12165 12166 return False; 12167 end In_Instance_Body; 12168 12169 ----------------------------- 12170 -- In_Instance_Not_Visible -- 12171 ----------------------------- 12172 12173 function In_Instance_Not_Visible return Boolean is 12174 S : Entity_Id; 12175 12176 begin 12177 S := Current_Scope; 12178 while Present (S) and then S /= Standard_Standard loop 12179 if Ekind_In (S, E_Function, E_Procedure) 12180 and then Is_Generic_Instance (S) 12181 then 12182 return True; 12183 12184 elsif Ekind (S) = E_Package 12185 and then (In_Package_Body (S) or else In_Private_Part (S)) 12186 and then Is_Generic_Instance (S) 12187 then 12188 return True; 12189 end if; 12190 12191 S := Scope (S); 12192 end loop; 12193 12194 return False; 12195 end In_Instance_Not_Visible; 12196 12197 ------------------------------ 12198 -- In_Instance_Visible_Part -- 12199 ------------------------------ 12200 12201 function In_Instance_Visible_Part 12202 (Id : Entity_Id := Current_Scope) return Boolean 12203 is 12204 Inst : Entity_Id; 12205 12206 begin 12207 Inst := Id; 12208 while Present (Inst) and then Inst /= Standard_Standard loop 12209 if Ekind (Inst) = E_Package 12210 and then Is_Generic_Instance (Inst) 12211 and then not In_Package_Body (Inst) 12212 and then not In_Private_Part (Inst) 12213 then 12214 return True; 12215 end if; 12216 12217 Inst := Scope (Inst); 12218 end loop; 12219 12220 return False; 12221 end In_Instance_Visible_Part; 12222 12223 --------------------- 12224 -- In_Package_Body -- 12225 --------------------- 12226 12227 function In_Package_Body return Boolean is 12228 S : Entity_Id; 12229 12230 begin 12231 S := Current_Scope; 12232 while Present (S) and then S /= Standard_Standard loop 12233 if Ekind (S) = E_Package and then In_Package_Body (S) then 12234 return True; 12235 else 12236 S := Scope (S); 12237 end if; 12238 end loop; 12239 12240 return False; 12241 end In_Package_Body; 12242 12243 -------------------------- 12244 -- In_Pragma_Expression -- 12245 -------------------------- 12246 12247 function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean is 12248 P : Node_Id; 12249 begin 12250 P := Parent (N); 12251 loop 12252 if No (P) then 12253 return False; 12254 elsif Nkind (P) = N_Pragma and then Pragma_Name (P) = Nam then 12255 return True; 12256 else 12257 P := Parent (P); 12258 end if; 12259 end loop; 12260 end In_Pragma_Expression; 12261 12262 --------------------------- 12263 -- In_Pre_Post_Condition -- 12264 --------------------------- 12265 12266 function In_Pre_Post_Condition (N : Node_Id) return Boolean is 12267 Par : Node_Id; 12268 Prag : Node_Id := Empty; 12269 Prag_Id : Pragma_Id; 12270 12271 begin 12272 -- Climb the parent chain looking for an enclosing pragma 12273 12274 Par := N; 12275 while Present (Par) loop 12276 if Nkind (Par) = N_Pragma then 12277 Prag := Par; 12278 exit; 12279 12280 -- Prevent the search from going too far 12281 12282 elsif Is_Body_Or_Package_Declaration (Par) then 12283 exit; 12284 end if; 12285 12286 Par := Parent (Par); 12287 end loop; 12288 12289 if Present (Prag) then 12290 Prag_Id := Get_Pragma_Id (Prag); 12291 12292 return 12293 Prag_Id = Pragma_Post 12294 or else Prag_Id = Pragma_Post_Class 12295 or else Prag_Id = Pragma_Postcondition 12296 or else Prag_Id = Pragma_Pre 12297 or else Prag_Id = Pragma_Pre_Class 12298 or else Prag_Id = Pragma_Precondition; 12299 12300 -- Otherwise the node is not enclosed by a pre/postcondition pragma 12301 12302 else 12303 return False; 12304 end if; 12305 end In_Pre_Post_Condition; 12306 12307 ------------------------------------- 12308 -- In_Reverse_Storage_Order_Object -- 12309 ------------------------------------- 12310 12311 function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is 12312 Pref : Node_Id; 12313 Btyp : Entity_Id := Empty; 12314 12315 begin 12316 -- Climb up indexed components 12317 12318 Pref := N; 12319 loop 12320 case Nkind (Pref) is 12321 when N_Selected_Component => 12322 Pref := Prefix (Pref); 12323 exit; 12324 12325 when N_Indexed_Component => 12326 Pref := Prefix (Pref); 12327 12328 when others => 12329 Pref := Empty; 12330 exit; 12331 end case; 12332 end loop; 12333 12334 if Present (Pref) then 12335 Btyp := Base_Type (Etype (Pref)); 12336 end if; 12337 12338 return Present (Btyp) 12339 and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp)) 12340 and then Reverse_Storage_Order (Btyp); 12341 end In_Reverse_Storage_Order_Object; 12342 12343 ------------------------------ 12344 -- In_Same_Declarative_Part -- 12345 ------------------------------ 12346 12347 function In_Same_Declarative_Part 12348 (Context : Node_Id; 12349 N : Node_Id) return Boolean 12350 is 12351 Cont : Node_Id := Context; 12352 Nod : Node_Id; 12353 12354 begin 12355 if Nkind (Cont) = N_Compilation_Unit_Aux then 12356 Cont := Parent (Cont); 12357 end if; 12358 12359 Nod := Parent (N); 12360 while Present (Nod) loop 12361 if Nod = Cont then 12362 return True; 12363 12364 elsif Nkind_In (Nod, N_Accept_Statement, 12365 N_Block_Statement, 12366 N_Compilation_Unit, 12367 N_Entry_Body, 12368 N_Package_Body, 12369 N_Package_Declaration, 12370 N_Protected_Body, 12371 N_Subprogram_Body, 12372 N_Task_Body) 12373 then 12374 return False; 12375 12376 elsif Nkind (Nod) = N_Subunit then 12377 Nod := Corresponding_Stub (Nod); 12378 12379 else 12380 Nod := Parent (Nod); 12381 end if; 12382 end loop; 12383 12384 return False; 12385 end In_Same_Declarative_Part; 12386 12387 -------------------------------------- 12388 -- In_Subprogram_Or_Concurrent_Unit -- 12389 -------------------------------------- 12390 12391 function In_Subprogram_Or_Concurrent_Unit return Boolean is 12392 E : Entity_Id; 12393 K : Entity_Kind; 12394 12395 begin 12396 -- Use scope chain to check successively outer scopes 12397 12398 E := Current_Scope; 12399 loop 12400 K := Ekind (E); 12401 12402 if K in Subprogram_Kind 12403 or else K in Concurrent_Kind 12404 or else K in Generic_Subprogram_Kind 12405 then 12406 return True; 12407 12408 elsif E = Standard_Standard then 12409 return False; 12410 end if; 12411 12412 E := Scope (E); 12413 end loop; 12414 end In_Subprogram_Or_Concurrent_Unit; 12415 12416 ---------------- 12417 -- In_Subtree -- 12418 ---------------- 12419 12420 function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is 12421 Curr : Node_Id; 12422 12423 begin 12424 Curr := N; 12425 while Present (Curr) loop 12426 if Curr = Root then 12427 return True; 12428 end if; 12429 12430 Curr := Parent (Curr); 12431 end loop; 12432 12433 return False; 12434 end In_Subtree; 12435 12436 ---------------- 12437 -- In_Subtree -- 12438 ---------------- 12439 12440 function In_Subtree 12441 (N : Node_Id; 12442 Root1 : Node_Id; 12443 Root2 : Node_Id) return Boolean 12444 is 12445 Curr : Node_Id; 12446 12447 begin 12448 Curr := N; 12449 while Present (Curr) loop 12450 if Curr = Root1 or else Curr = Root2 then 12451 return True; 12452 end if; 12453 12454 Curr := Parent (Curr); 12455 end loop; 12456 12457 return False; 12458 end In_Subtree; 12459 12460 --------------------- 12461 -- In_Visible_Part -- 12462 --------------------- 12463 12464 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is 12465 begin 12466 return Is_Package_Or_Generic_Package (Scope_Id) 12467 and then In_Open_Scopes (Scope_Id) 12468 and then not In_Package_Body (Scope_Id) 12469 and then not In_Private_Part (Scope_Id); 12470 end In_Visible_Part; 12471 12472 -------------------------------- 12473 -- Incomplete_Or_Partial_View -- 12474 -------------------------------- 12475 12476 function Incomplete_Or_Partial_View (Id : Entity_Id) return Entity_Id is 12477 function Inspect_Decls 12478 (Decls : List_Id; 12479 Taft : Boolean := False) return Entity_Id; 12480 -- Check whether a declarative region contains the incomplete or partial 12481 -- view of Id. 12482 12483 ------------------- 12484 -- Inspect_Decls -- 12485 ------------------- 12486 12487 function Inspect_Decls 12488 (Decls : List_Id; 12489 Taft : Boolean := False) return Entity_Id 12490 is 12491 Decl : Node_Id; 12492 Match : Node_Id; 12493 12494 begin 12495 Decl := First (Decls); 12496 while Present (Decl) loop 12497 Match := Empty; 12498 12499 -- The partial view of a Taft-amendment type is an incomplete 12500 -- type. 12501 12502 if Taft then 12503 if Nkind (Decl) = N_Incomplete_Type_Declaration then 12504 Match := Defining_Identifier (Decl); 12505 end if; 12506 12507 -- Otherwise look for a private type whose full view matches the 12508 -- input type. Note that this checks full_type_declaration nodes 12509 -- to account for derivations from a private type where the type 12510 -- declaration hold the partial view and the full view is an 12511 -- itype. 12512 12513 elsif Nkind_In (Decl, N_Full_Type_Declaration, 12514 N_Private_Extension_Declaration, 12515 N_Private_Type_Declaration) 12516 then 12517 Match := Defining_Identifier (Decl); 12518 end if; 12519 12520 -- Guard against unanalyzed entities 12521 12522 if Present (Match) 12523 and then Is_Type (Match) 12524 and then Present (Full_View (Match)) 12525 and then Full_View (Match) = Id 12526 then 12527 return Match; 12528 end if; 12529 12530 Next (Decl); 12531 end loop; 12532 12533 return Empty; 12534 end Inspect_Decls; 12535 12536 -- Local variables 12537 12538 Prev : Entity_Id; 12539 12540 -- Start of processing for Incomplete_Or_Partial_View 12541 12542 begin 12543 -- Deferred constant or incomplete type case 12544 12545 Prev := Current_Entity_In_Scope (Id); 12546 12547 if Present (Prev) 12548 and then (Is_Incomplete_Type (Prev) or else Ekind (Prev) = E_Constant) 12549 and then Present (Full_View (Prev)) 12550 and then Full_View (Prev) = Id 12551 then 12552 return Prev; 12553 end if; 12554 12555 -- Private or Taft amendment type case 12556 12557 declare 12558 Pkg : constant Entity_Id := Scope (Id); 12559 Pkg_Decl : Node_Id := Pkg; 12560 12561 begin 12562 if Present (Pkg) 12563 and then Ekind_In (Pkg, E_Generic_Package, E_Package) 12564 then 12565 while Nkind (Pkg_Decl) /= N_Package_Specification loop 12566 Pkg_Decl := Parent (Pkg_Decl); 12567 end loop; 12568 12569 -- It is knows that Typ has a private view, look for it in the 12570 -- visible declarations of the enclosing scope. A special case 12571 -- of this is when the two views have been exchanged - the full 12572 -- appears earlier than the private. 12573 12574 if Has_Private_Declaration (Id) then 12575 Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl)); 12576 12577 -- Exchanged view case, look in the private declarations 12578 12579 if No (Prev) then 12580 Prev := Inspect_Decls (Private_Declarations (Pkg_Decl)); 12581 end if; 12582 12583 return Prev; 12584 12585 -- Otherwise if this is the package body, then Typ is a potential 12586 -- Taft amendment type. The incomplete view should be located in 12587 -- the private declarations of the enclosing scope. 12588 12589 elsif In_Package_Body (Pkg) then 12590 return Inspect_Decls (Private_Declarations (Pkg_Decl), True); 12591 end if; 12592 end if; 12593 end; 12594 12595 -- The type has no incomplete or private view 12596 12597 return Empty; 12598 end Incomplete_Or_Partial_View; 12599 12600 --------------------------------------- 12601 -- Incomplete_View_From_Limited_With -- 12602 --------------------------------------- 12603 12604 function Incomplete_View_From_Limited_With 12605 (Typ : Entity_Id) return Entity_Id 12606 is 12607 begin 12608 -- It might make sense to make this an attribute in Einfo, and set it 12609 -- in Sem_Ch10 in Build_Shadow_Entity. However, we're running short on 12610 -- slots for new attributes, and it seems a bit simpler to just search 12611 -- the Limited_View (if it exists) for an incomplete type whose 12612 -- Non_Limited_View is Typ. 12613 12614 if Ekind (Scope (Typ)) = E_Package 12615 and then Present (Limited_View (Scope (Typ))) 12616 then 12617 declare 12618 Ent : Entity_Id := First_Entity (Limited_View (Scope (Typ))); 12619 begin 12620 while Present (Ent) loop 12621 if Ekind (Ent) in Incomplete_Kind 12622 and then Non_Limited_View (Ent) = Typ 12623 then 12624 return Ent; 12625 end if; 12626 12627 Ent := Next_Entity (Ent); 12628 end loop; 12629 end; 12630 end if; 12631 12632 return Typ; 12633 end Incomplete_View_From_Limited_With; 12634 12635 ---------------------------------- 12636 -- Indexed_Component_Bit_Offset -- 12637 ---------------------------------- 12638 12639 function Indexed_Component_Bit_Offset (N : Node_Id) return Uint is 12640 Exp : constant Node_Id := First (Expressions (N)); 12641 Typ : constant Entity_Id := Etype (Prefix (N)); 12642 Off : constant Uint := Component_Size (Typ); 12643 Ind : Node_Id; 12644 12645 begin 12646 -- Return early if the component size is not known or variable 12647 12648 if Off = No_Uint or else Off < Uint_0 then 12649 return No_Uint; 12650 end if; 12651 12652 -- Deal with the degenerate case of an empty component 12653 12654 if Off = Uint_0 then 12655 return Off; 12656 end if; 12657 12658 -- Check that both the index value and the low bound are known 12659 12660 if not Compile_Time_Known_Value (Exp) then 12661 return No_Uint; 12662 end if; 12663 12664 Ind := First_Index (Typ); 12665 if No (Ind) then 12666 return No_Uint; 12667 end if; 12668 12669 if Nkind (Ind) = N_Subtype_Indication then 12670 Ind := Constraint (Ind); 12671 12672 if Nkind (Ind) = N_Range_Constraint then 12673 Ind := Range_Expression (Ind); 12674 end if; 12675 end if; 12676 12677 if Nkind (Ind) /= N_Range 12678 or else not Compile_Time_Known_Value (Low_Bound (Ind)) 12679 then 12680 return No_Uint; 12681 end if; 12682 12683 -- Return the scaled offset 12684 12685 return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound ((Ind)))); 12686 end Indexed_Component_Bit_Offset; 12687 12688 ---------------------------- 12689 -- Inherit_Rep_Item_Chain -- 12690 ---------------------------- 12691 12692 procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is 12693 Item : Node_Id; 12694 Next_Item : Node_Id; 12695 12696 begin 12697 -- There are several inheritance scenarios to consider depending on 12698 -- whether both types have rep item chains and whether the destination 12699 -- type already inherits part of the source type's rep item chain. 12700 12701 -- 1) The source type lacks a rep item chain 12702 -- From_Typ ---> Empty 12703 -- 12704 -- Typ --------> Item (or Empty) 12705 12706 -- In this case inheritance cannot take place because there are no items 12707 -- to inherit. 12708 12709 -- 2) The destination type lacks a rep item chain 12710 -- From_Typ ---> Item ---> ... 12711 -- 12712 -- Typ --------> Empty 12713 12714 -- Inheritance takes place by setting the First_Rep_Item of the 12715 -- destination type to the First_Rep_Item of the source type. 12716 -- From_Typ ---> Item ---> ... 12717 -- ^ 12718 -- Typ -----------+ 12719 12720 -- 3.1) Both source and destination types have at least one rep item. 12721 -- The destination type does NOT inherit a rep item from the source 12722 -- type. 12723 -- From_Typ ---> Item ---> Item 12724 -- 12725 -- Typ --------> Item ---> Item 12726 12727 -- Inheritance takes place by setting the Next_Rep_Item of the last item 12728 -- of the destination type to the First_Rep_Item of the source type. 12729 -- From_Typ -------------------> Item ---> Item 12730 -- ^ 12731 -- Typ --------> Item ---> Item --+ 12732 12733 -- 3.2) Both source and destination types have at least one rep item. 12734 -- The destination type DOES inherit part of the rep item chain of the 12735 -- source type. 12736 -- From_Typ ---> Item ---> Item ---> Item 12737 -- ^ 12738 -- Typ --------> Item ------+ 12739 12740 -- This rare case arises when the full view of a private extension must 12741 -- inherit the rep item chain from the full view of its parent type and 12742 -- the full view of the parent type contains extra rep items. Currently 12743 -- only invariants may lead to such form of inheritance. 12744 12745 -- type From_Typ is tagged private 12746 -- with Type_Invariant'Class => Item_2; 12747 12748 -- type Typ is new From_Typ with private 12749 -- with Type_Invariant => Item_4; 12750 12751 -- At this point the rep item chains contain the following items 12752 12753 -- From_Typ -----------> Item_2 ---> Item_3 12754 -- ^ 12755 -- Typ --------> Item_4 --+ 12756 12757 -- The full views of both types may introduce extra invariants 12758 12759 -- type From_Typ is tagged null record 12760 -- with Type_Invariant => Item_1; 12761 12762 -- type Typ is new From_Typ with null record; 12763 12764 -- The full view of Typ would have to inherit any new rep items added to 12765 -- the full view of From_Typ. 12766 12767 -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3 12768 -- ^ 12769 -- Typ --------> Item_4 --+ 12770 12771 -- To achieve this form of inheritance, the destination type must first 12772 -- sever the link between its own rep chain and that of the source type, 12773 -- then inheritance 3.1 takes place. 12774 12775 -- Case 1: The source type lacks a rep item chain 12776 12777 if No (First_Rep_Item (From_Typ)) then 12778 return; 12779 12780 -- Case 2: The destination type lacks a rep item chain 12781 12782 elsif No (First_Rep_Item (Typ)) then 12783 Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ)); 12784 12785 -- Case 3: Both the source and destination types have at least one rep 12786 -- item. Traverse the rep item chain of the destination type to find the 12787 -- last rep item. 12788 12789 else 12790 Item := Empty; 12791 Next_Item := First_Rep_Item (Typ); 12792 while Present (Next_Item) loop 12793 12794 -- Detect a link between the destination type's rep chain and that 12795 -- of the source type. There are two possibilities: 12796 12797 -- Variant 1 12798 -- Next_Item 12799 -- V 12800 -- From_Typ ---> Item_1 ---> 12801 -- ^ 12802 -- Typ -----------+ 12803 -- 12804 -- Item is Empty 12805 12806 -- Variant 2 12807 -- Next_Item 12808 -- V 12809 -- From_Typ ---> Item_1 ---> Item_2 ---> 12810 -- ^ 12811 -- Typ --------> Item_3 ------+ 12812 -- ^ 12813 -- Item 12814 12815 if Has_Rep_Item (From_Typ, Next_Item) then 12816 exit; 12817 end if; 12818 12819 Item := Next_Item; 12820 Next_Item := Next_Rep_Item (Next_Item); 12821 end loop; 12822 12823 -- Inherit the source type's rep item chain 12824 12825 if Present (Item) then 12826 Set_Next_Rep_Item (Item, First_Rep_Item (From_Typ)); 12827 else 12828 Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ)); 12829 end if; 12830 end if; 12831 end Inherit_Rep_Item_Chain; 12832 12833 ------------------------------------ 12834 -- Inherits_From_Tagged_Full_View -- 12835 ------------------------------------ 12836 12837 function Inherits_From_Tagged_Full_View (Typ : Entity_Id) return Boolean is 12838 begin 12839 return Is_Private_Type (Typ) 12840 and then Present (Full_View (Typ)) 12841 and then Is_Private_Type (Full_View (Typ)) 12842 and then not Is_Tagged_Type (Full_View (Typ)) 12843 and then Present (Underlying_Type (Full_View (Typ))) 12844 and then Is_Tagged_Type (Underlying_Type (Full_View (Typ))); 12845 end Inherits_From_Tagged_Full_View; 12846 12847 --------------------------------- 12848 -- Insert_Explicit_Dereference -- 12849 --------------------------------- 12850 12851 procedure Insert_Explicit_Dereference (N : Node_Id) is 12852 New_Prefix : constant Node_Id := Relocate_Node (N); 12853 Ent : Entity_Id := Empty; 12854 Pref : Node_Id; 12855 I : Interp_Index; 12856 It : Interp; 12857 T : Entity_Id; 12858 12859 begin 12860 Save_Interps (N, New_Prefix); 12861 12862 Rewrite (N, 12863 Make_Explicit_Dereference (Sloc (Parent (N)), 12864 Prefix => New_Prefix)); 12865 12866 Set_Etype (N, Designated_Type (Etype (New_Prefix))); 12867 12868 if Is_Overloaded (New_Prefix) then 12869 12870 -- The dereference is also overloaded, and its interpretations are 12871 -- the designated types of the interpretations of the original node. 12872 12873 Set_Etype (N, Any_Type); 12874 12875 Get_First_Interp (New_Prefix, I, It); 12876 while Present (It.Nam) loop 12877 T := It.Typ; 12878 12879 if Is_Access_Type (T) then 12880 Add_One_Interp (N, Designated_Type (T), Designated_Type (T)); 12881 end if; 12882 12883 Get_Next_Interp (I, It); 12884 end loop; 12885 12886 End_Interp_List; 12887 12888 else 12889 -- Prefix is unambiguous: mark the original prefix (which might 12890 -- Come_From_Source) as a reference, since the new (relocated) one 12891 -- won't be taken into account. 12892 12893 if Is_Entity_Name (New_Prefix) then 12894 Ent := Entity (New_Prefix); 12895 Pref := New_Prefix; 12896 12897 -- For a retrieval of a subcomponent of some composite object, 12898 -- retrieve the ultimate entity if there is one. 12899 12900 elsif Nkind_In (New_Prefix, N_Selected_Component, 12901 N_Indexed_Component) 12902 then 12903 Pref := Prefix (New_Prefix); 12904 while Present (Pref) 12905 and then Nkind_In (Pref, N_Selected_Component, 12906 N_Indexed_Component) 12907 loop 12908 Pref := Prefix (Pref); 12909 end loop; 12910 12911 if Present (Pref) and then Is_Entity_Name (Pref) then 12912 Ent := Entity (Pref); 12913 end if; 12914 end if; 12915 12916 -- Place the reference on the entity node 12917 12918 if Present (Ent) then 12919 Generate_Reference (Ent, Pref); 12920 end if; 12921 end if; 12922 end Insert_Explicit_Dereference; 12923 12924 ------------------------------------------ 12925 -- Inspect_Deferred_Constant_Completion -- 12926 ------------------------------------------ 12927 12928 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is 12929 Decl : Node_Id; 12930 12931 begin 12932 Decl := First (Decls); 12933 while Present (Decl) loop 12934 12935 -- Deferred constant signature 12936 12937 if Nkind (Decl) = N_Object_Declaration 12938 and then Constant_Present (Decl) 12939 and then No (Expression (Decl)) 12940 12941 -- No need to check internally generated constants 12942 12943 and then Comes_From_Source (Decl) 12944 12945 -- The constant is not completed. A full object declaration or a 12946 -- pragma Import complete a deferred constant. 12947 12948 and then not Has_Completion (Defining_Identifier (Decl)) 12949 then 12950 Error_Msg_N 12951 ("constant declaration requires initialization expression", 12952 Defining_Identifier (Decl)); 12953 end if; 12954 12955 Decl := Next (Decl); 12956 end loop; 12957 end Inspect_Deferred_Constant_Completion; 12958 12959 ------------------------------- 12960 -- Install_Elaboration_Model -- 12961 ------------------------------- 12962 12963 procedure Install_Elaboration_Model (Unit_Id : Entity_Id) is 12964 function Find_Elaboration_Checks_Pragma (L : List_Id) return Node_Id; 12965 -- Try to find pragma Elaboration_Checks in arbitrary list L. Return 12966 -- Empty if there is no such pragma. 12967 12968 ------------------------------------ 12969 -- Find_Elaboration_Checks_Pragma -- 12970 ------------------------------------ 12971 12972 function Find_Elaboration_Checks_Pragma (L : List_Id) return Node_Id is 12973 Item : Node_Id; 12974 12975 begin 12976 Item := First (L); 12977 while Present (Item) loop 12978 if Nkind (Item) = N_Pragma 12979 and then Pragma_Name (Item) = Name_Elaboration_Checks 12980 then 12981 return Item; 12982 end if; 12983 12984 Next (Item); 12985 end loop; 12986 12987 return Empty; 12988 end Find_Elaboration_Checks_Pragma; 12989 12990 -- Local variables 12991 12992 Args : List_Id; 12993 Model : Node_Id; 12994 Prag : Node_Id; 12995 Unit : Node_Id; 12996 12997 -- Start of processing for Install_Elaboration_Model 12998 12999 begin 13000 -- Nothing to do when the unit does not exist 13001 13002 if No (Unit_Id) then 13003 return; 13004 end if; 13005 13006 Unit := Parent (Unit_Declaration_Node (Unit_Id)); 13007 13008 -- Nothing to do when the unit is not a library unit 13009 13010 if Nkind (Unit) /= N_Compilation_Unit then 13011 return; 13012 end if; 13013 13014 Prag := Find_Elaboration_Checks_Pragma (Context_Items (Unit)); 13015 13016 -- The compilation unit is subject to pragma Elaboration_Checks. Set the 13017 -- elaboration model as specified by the pragma. 13018 13019 if Present (Prag) then 13020 Args := Pragma_Argument_Associations (Prag); 13021 13022 -- Guard against an illegal pragma. The sole argument must be an 13023 -- identifier which specifies either Dynamic or Static model. 13024 13025 if Present (Args) then 13026 Model := Get_Pragma_Arg (First (Args)); 13027 13028 if Nkind (Model) = N_Identifier then 13029 Dynamic_Elaboration_Checks := Chars (Model) = Name_Dynamic; 13030 end if; 13031 end if; 13032 end if; 13033 end Install_Elaboration_Model; 13034 13035 ----------------------------- 13036 -- Install_Generic_Formals -- 13037 ----------------------------- 13038 13039 procedure Install_Generic_Formals (Subp_Id : Entity_Id) is 13040 E : Entity_Id; 13041 13042 begin 13043 pragma Assert (Is_Generic_Subprogram (Subp_Id)); 13044 13045 E := First_Entity (Subp_Id); 13046 while Present (E) loop 13047 Install_Entity (E); 13048 Next_Entity (E); 13049 end loop; 13050 end Install_Generic_Formals; 13051 13052 ------------------------ 13053 -- Install_SPARK_Mode -- 13054 ------------------------ 13055 13056 procedure Install_SPARK_Mode (Mode : SPARK_Mode_Type; Prag : Node_Id) is 13057 begin 13058 SPARK_Mode := Mode; 13059 SPARK_Mode_Pragma := Prag; 13060 end Install_SPARK_Mode; 13061 13062 -------------------------- 13063 -- Invalid_Scalar_Value -- 13064 -------------------------- 13065 13066 function Invalid_Scalar_Value 13067 (Loc : Source_Ptr; 13068 Scal_Typ : Scalar_Id) return Node_Id 13069 is 13070 function Invalid_Binder_Value return Node_Id; 13071 -- Return a reference to the corresponding invalid value for type 13072 -- Scal_Typ as defined in unit System.Scalar_Values. 13073 13074 function Invalid_Float_Value return Node_Id; 13075 -- Return the invalid value of float type Scal_Typ 13076 13077 function Invalid_Integer_Value return Node_Id; 13078 -- Return the invalid value of integer type Scal_Typ 13079 13080 procedure Set_Invalid_Binder_Values; 13081 -- Set the contents of collection Invalid_Binder_Values 13082 13083 -------------------------- 13084 -- Invalid_Binder_Value -- 13085 -------------------------- 13086 13087 function Invalid_Binder_Value return Node_Id is 13088 Val_Id : Entity_Id; 13089 13090 begin 13091 -- Initialize the collection of invalid binder values the first time 13092 -- around. 13093 13094 Set_Invalid_Binder_Values; 13095 13096 -- Obtain the corresponding variable from System.Scalar_Values which 13097 -- holds the invalid value for this type. 13098 13099 Val_Id := Invalid_Binder_Values (Scal_Typ); 13100 pragma Assert (Present (Val_Id)); 13101 13102 return New_Occurrence_Of (Val_Id, Loc); 13103 end Invalid_Binder_Value; 13104 13105 ------------------------- 13106 -- Invalid_Float_Value -- 13107 ------------------------- 13108 13109 function Invalid_Float_Value return Node_Id is 13110 Value : constant Ureal := Invalid_Floats (Scal_Typ); 13111 13112 begin 13113 -- Pragma Invalid_Scalars did not specify an invalid value for this 13114 -- type. Fall back to the value provided by the binder. 13115 13116 if Value = No_Ureal then 13117 return Invalid_Binder_Value; 13118 else 13119 return Make_Real_Literal (Loc, Realval => Value); 13120 end if; 13121 end Invalid_Float_Value; 13122 13123 --------------------------- 13124 -- Invalid_Integer_Value -- 13125 --------------------------- 13126 13127 function Invalid_Integer_Value return Node_Id is 13128 Value : constant Uint := Invalid_Integers (Scal_Typ); 13129 13130 begin 13131 -- Pragma Invalid_Scalars did not specify an invalid value for this 13132 -- type. Fall back to the value provided by the binder. 13133 13134 if Value = No_Uint then 13135 return Invalid_Binder_Value; 13136 else 13137 return Make_Integer_Literal (Loc, Intval => Value); 13138 end if; 13139 end Invalid_Integer_Value; 13140 13141 ------------------------------- 13142 -- Set_Invalid_Binder_Values -- 13143 ------------------------------- 13144 13145 procedure Set_Invalid_Binder_Values is 13146 begin 13147 if not Invalid_Binder_Values_Set then 13148 Invalid_Binder_Values_Set := True; 13149 13150 -- Initialize the contents of the collection once since RTE calls 13151 -- are not cheap. 13152 13153 Invalid_Binder_Values := 13154 (Name_Short_Float => RTE (RE_IS_Isf), 13155 Name_Float => RTE (RE_IS_Ifl), 13156 Name_Long_Float => RTE (RE_IS_Ilf), 13157 Name_Long_Long_Float => RTE (RE_IS_Ill), 13158 Name_Signed_8 => RTE (RE_IS_Is1), 13159 Name_Signed_16 => RTE (RE_IS_Is2), 13160 Name_Signed_32 => RTE (RE_IS_Is4), 13161 Name_Signed_64 => RTE (RE_IS_Is8), 13162 Name_Unsigned_8 => RTE (RE_IS_Iu1), 13163 Name_Unsigned_16 => RTE (RE_IS_Iu2), 13164 Name_Unsigned_32 => RTE (RE_IS_Iu4), 13165 Name_Unsigned_64 => RTE (RE_IS_Iu8)); 13166 end if; 13167 end Set_Invalid_Binder_Values; 13168 13169 -- Start of processing for Invalid_Scalar_Value 13170 13171 begin 13172 if Scal_Typ in Float_Scalar_Id then 13173 return Invalid_Float_Value; 13174 13175 else pragma Assert (Scal_Typ in Integer_Scalar_Id); 13176 return Invalid_Integer_Value; 13177 end if; 13178 end Invalid_Scalar_Value; 13179 13180 ----------------------------- 13181 -- Is_Actual_Out_Parameter -- 13182 ----------------------------- 13183 13184 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is 13185 Formal : Entity_Id; 13186 Call : Node_Id; 13187 begin 13188 Find_Actual (N, Formal, Call); 13189 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter; 13190 end Is_Actual_Out_Parameter; 13191 13192 ------------------------- 13193 -- Is_Actual_Parameter -- 13194 ------------------------- 13195 13196 function Is_Actual_Parameter (N : Node_Id) return Boolean is 13197 PK : constant Node_Kind := Nkind (Parent (N)); 13198 13199 begin 13200 case PK is 13201 when N_Parameter_Association => 13202 return N = Explicit_Actual_Parameter (Parent (N)); 13203 13204 when N_Subprogram_Call => 13205 return Is_List_Member (N) 13206 and then 13207 List_Containing (N) = Parameter_Associations (Parent (N)); 13208 13209 when others => 13210 return False; 13211 end case; 13212 end Is_Actual_Parameter; 13213 13214 -------------------------------- 13215 -- Is_Actual_Tagged_Parameter -- 13216 -------------------------------- 13217 13218 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is 13219 Formal : Entity_Id; 13220 Call : Node_Id; 13221 begin 13222 Find_Actual (N, Formal, Call); 13223 return Present (Formal) and then Is_Tagged_Type (Etype (Formal)); 13224 end Is_Actual_Tagged_Parameter; 13225 13226 --------------------- 13227 -- Is_Aliased_View -- 13228 --------------------- 13229 13230 function Is_Aliased_View (Obj : Node_Id) return Boolean is 13231 E : Entity_Id; 13232 13233 begin 13234 if Is_Entity_Name (Obj) then 13235 E := Entity (Obj); 13236 13237 return 13238 (Is_Object (E) 13239 and then 13240 (Is_Aliased (E) 13241 or else (Present (Renamed_Object (E)) 13242 and then Is_Aliased_View (Renamed_Object (E))))) 13243 13244 or else ((Is_Formal (E) or else Is_Formal_Object (E)) 13245 and then Is_Tagged_Type (Etype (E))) 13246 13247 or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E)) 13248 13249 -- Current instance of type, either directly or as rewritten 13250 -- reference to the current object. 13251 13252 or else (Is_Entity_Name (Original_Node (Obj)) 13253 and then Present (Entity (Original_Node (Obj))) 13254 and then Is_Type (Entity (Original_Node (Obj)))) 13255 13256 or else (Is_Type (E) and then E = Current_Scope) 13257 13258 or else (Is_Incomplete_Or_Private_Type (E) 13259 and then Full_View (E) = Current_Scope) 13260 13261 -- Ada 2012 AI05-0053: the return object of an extended return 13262 -- statement is aliased if its type is immutably limited. 13263 13264 or else (Is_Return_Object (E) 13265 and then Is_Limited_View (Etype (E))); 13266 13267 elsif Nkind (Obj) = N_Selected_Component then 13268 return Is_Aliased (Entity (Selector_Name (Obj))); 13269 13270 elsif Nkind (Obj) = N_Indexed_Component then 13271 return Has_Aliased_Components (Etype (Prefix (Obj))) 13272 or else 13273 (Is_Access_Type (Etype (Prefix (Obj))) 13274 and then Has_Aliased_Components 13275 (Designated_Type (Etype (Prefix (Obj))))); 13276 13277 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then 13278 return Is_Tagged_Type (Etype (Obj)) 13279 and then Is_Aliased_View (Expression (Obj)); 13280 13281 elsif Nkind (Obj) = N_Explicit_Dereference then 13282 return Nkind (Original_Node (Obj)) /= N_Function_Call; 13283 13284 else 13285 return False; 13286 end if; 13287 end Is_Aliased_View; 13288 13289 ------------------------- 13290 -- Is_Ancestor_Package -- 13291 ------------------------- 13292 13293 function Is_Ancestor_Package 13294 (E1 : Entity_Id; 13295 E2 : Entity_Id) return Boolean 13296 is 13297 Par : Entity_Id; 13298 13299 begin 13300 Par := E2; 13301 while Present (Par) and then Par /= Standard_Standard loop 13302 if Par = E1 then 13303 return True; 13304 end if; 13305 13306 Par := Scope (Par); 13307 end loop; 13308 13309 return False; 13310 end Is_Ancestor_Package; 13311 13312 ---------------------- 13313 -- Is_Atomic_Object -- 13314 ---------------------- 13315 13316 function Is_Atomic_Object (N : Node_Id) return Boolean is 13317 function Is_Atomic_Entity (Id : Entity_Id) return Boolean; 13318 pragma Inline (Is_Atomic_Entity); 13319 -- Determine whether arbitrary entity Id is either atomic or has atomic 13320 -- components. 13321 13322 function Is_Atomic_Prefix (Pref : Node_Id) return Boolean; 13323 -- Determine whether prefix Pref of an indexed or selected component is 13324 -- an atomic object. 13325 13326 ---------------------- 13327 -- Is_Atomic_Entity -- 13328 ---------------------- 13329 13330 function Is_Atomic_Entity (Id : Entity_Id) return Boolean is 13331 begin 13332 return Is_Atomic (Id) or else Has_Atomic_Components (Id); 13333 end Is_Atomic_Entity; 13334 13335 ---------------------- 13336 -- Is_Atomic_Prefix -- 13337 ---------------------- 13338 13339 function Is_Atomic_Prefix (Pref : Node_Id) return Boolean is 13340 Typ : constant Entity_Id := Etype (Pref); 13341 13342 begin 13343 if Is_Access_Type (Typ) then 13344 return Has_Atomic_Components (Designated_Type (Typ)); 13345 13346 elsif Is_Atomic_Entity (Typ) then 13347 return True; 13348 13349 elsif Is_Entity_Name (Pref) 13350 and then Is_Atomic_Entity (Entity (Pref)) 13351 then 13352 return True; 13353 13354 elsif Nkind (Pref) = N_Indexed_Component then 13355 return Is_Atomic_Prefix (Prefix (Pref)); 13356 13357 elsif Nkind (Pref) = N_Selected_Component then 13358 return 13359 Is_Atomic_Prefix (Prefix (Pref)) 13360 or else Is_Atomic (Entity (Selector_Name (Pref))); 13361 end if; 13362 13363 return False; 13364 end Is_Atomic_Prefix; 13365 13366 -- Start of processing for Is_Atomic_Object 13367 13368 begin 13369 if Is_Entity_Name (N) then 13370 return Is_Atomic_Object_Entity (Entity (N)); 13371 13372 elsif Nkind (N) = N_Indexed_Component then 13373 return Is_Atomic (Etype (N)) or else Is_Atomic_Prefix (Prefix (N)); 13374 13375 elsif Nkind (N) = N_Selected_Component then 13376 return 13377 Is_Atomic (Etype (N)) 13378 or else Is_Atomic_Prefix (Prefix (N)) 13379 or else Is_Atomic (Entity (Selector_Name (N))); 13380 end if; 13381 13382 return False; 13383 end Is_Atomic_Object; 13384 13385 ----------------------------- 13386 -- Is_Atomic_Object_Entity -- 13387 ----------------------------- 13388 13389 function Is_Atomic_Object_Entity (Id : Entity_Id) return Boolean is 13390 begin 13391 return 13392 Is_Object (Id) 13393 and then (Is_Atomic (Id) or else Is_Atomic (Etype (Id))); 13394 end Is_Atomic_Object_Entity; 13395 13396 ----------------------------- 13397 -- Is_Atomic_Or_VFA_Object -- 13398 ----------------------------- 13399 13400 function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean is 13401 begin 13402 return Is_Atomic_Object (N) 13403 or else (Is_Object_Reference (N) 13404 and then Is_Entity_Name (N) 13405 and then (Is_Volatile_Full_Access (Entity (N)) 13406 or else 13407 Is_Volatile_Full_Access (Etype (Entity (N))))); 13408 end Is_Atomic_Or_VFA_Object; 13409 13410 ------------------------- 13411 -- Is_Attribute_Result -- 13412 ------------------------- 13413 13414 function Is_Attribute_Result (N : Node_Id) return Boolean is 13415 begin 13416 return Nkind (N) = N_Attribute_Reference 13417 and then Attribute_Name (N) = Name_Result; 13418 end Is_Attribute_Result; 13419 13420 ------------------------- 13421 -- Is_Attribute_Update -- 13422 ------------------------- 13423 13424 function Is_Attribute_Update (N : Node_Id) return Boolean is 13425 begin 13426 return Nkind (N) = N_Attribute_Reference 13427 and then Attribute_Name (N) = Name_Update; 13428 end Is_Attribute_Update; 13429 13430 ------------------------------------ 13431 -- Is_Body_Or_Package_Declaration -- 13432 ------------------------------------ 13433 13434 function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is 13435 begin 13436 return Is_Body (N) or else Nkind (N) = N_Package_Declaration; 13437 end Is_Body_Or_Package_Declaration; 13438 13439 ----------------------- 13440 -- Is_Bounded_String -- 13441 ----------------------- 13442 13443 function Is_Bounded_String (T : Entity_Id) return Boolean is 13444 Under : constant Entity_Id := Underlying_Type (Root_Type (T)); 13445 13446 begin 13447 -- Check whether T is ultimately derived from Ada.Strings.Superbounded. 13448 -- Super_String, or one of the [Wide_]Wide_ versions. This will 13449 -- be True for all the Bounded_String types in instances of the 13450 -- Generic_Bounded_Length generics, and for types derived from those. 13451 13452 return Present (Under) 13453 and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else 13454 Is_RTE (Root_Type (Under), RO_WI_Super_String) or else 13455 Is_RTE (Root_Type (Under), RO_WW_Super_String)); 13456 end Is_Bounded_String; 13457 13458 --------------------- 13459 -- Is_CCT_Instance -- 13460 --------------------- 13461 13462 function Is_CCT_Instance 13463 (Ref_Id : Entity_Id; 13464 Context_Id : Entity_Id) return Boolean 13465 is 13466 begin 13467 pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type)); 13468 13469 if Is_Single_Task_Object (Context_Id) then 13470 return Scope_Within_Or_Same (Etype (Context_Id), Ref_Id); 13471 13472 else 13473 pragma Assert (Ekind_In (Context_Id, E_Entry, 13474 E_Entry_Family, 13475 E_Function, 13476 E_Package, 13477 E_Procedure, 13478 E_Protected_Type, 13479 E_Task_Type) 13480 or else 13481 Is_Record_Type (Context_Id)); 13482 return Scope_Within_Or_Same (Context_Id, Ref_Id); 13483 end if; 13484 end Is_CCT_Instance; 13485 13486 ------------------------- 13487 -- Is_Child_Or_Sibling -- 13488 ------------------------- 13489 13490 function Is_Child_Or_Sibling 13491 (Pack_1 : Entity_Id; 13492 Pack_2 : Entity_Id) return Boolean 13493 is 13494 function Distance_From_Standard (Pack : Entity_Id) return Nat; 13495 -- Given an arbitrary package, return the number of "climbs" necessary 13496 -- to reach scope Standard_Standard. 13497 13498 procedure Equalize_Depths 13499 (Pack : in out Entity_Id; 13500 Depth : in out Nat; 13501 Depth_To_Reach : Nat); 13502 -- Given an arbitrary package, its depth and a target depth to reach, 13503 -- climb the scope chain until the said depth is reached. The pointer 13504 -- to the package and its depth a modified during the climb. 13505 13506 ---------------------------- 13507 -- Distance_From_Standard -- 13508 ---------------------------- 13509 13510 function Distance_From_Standard (Pack : Entity_Id) return Nat is 13511 Dist : Nat; 13512 Scop : Entity_Id; 13513 13514 begin 13515 Dist := 0; 13516 Scop := Pack; 13517 while Present (Scop) and then Scop /= Standard_Standard loop 13518 Dist := Dist + 1; 13519 Scop := Scope (Scop); 13520 end loop; 13521 13522 return Dist; 13523 end Distance_From_Standard; 13524 13525 --------------------- 13526 -- Equalize_Depths -- 13527 --------------------- 13528 13529 procedure Equalize_Depths 13530 (Pack : in out Entity_Id; 13531 Depth : in out Nat; 13532 Depth_To_Reach : Nat) 13533 is 13534 begin 13535 -- The package must be at a greater or equal depth 13536 13537 if Depth < Depth_To_Reach then 13538 raise Program_Error; 13539 end if; 13540 13541 -- Climb the scope chain until the desired depth is reached 13542 13543 while Present (Pack) and then Depth /= Depth_To_Reach loop 13544 Pack := Scope (Pack); 13545 Depth := Depth - 1; 13546 end loop; 13547 end Equalize_Depths; 13548 13549 -- Local variables 13550 13551 P_1 : Entity_Id := Pack_1; 13552 P_1_Child : Boolean := False; 13553 P_1_Depth : Nat := Distance_From_Standard (P_1); 13554 P_2 : Entity_Id := Pack_2; 13555 P_2_Child : Boolean := False; 13556 P_2_Depth : Nat := Distance_From_Standard (P_2); 13557 13558 -- Start of processing for Is_Child_Or_Sibling 13559 13560 begin 13561 pragma Assert 13562 (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package); 13563 13564 -- Both packages denote the same entity, therefore they cannot be 13565 -- children or siblings. 13566 13567 if P_1 = P_2 then 13568 return False; 13569 13570 -- One of the packages is at a deeper level than the other. Note that 13571 -- both may still come from different hierarchies. 13572 13573 -- (root) P_2 13574 -- / \ : 13575 -- X P_2 or X 13576 -- : : 13577 -- P_1 P_1 13578 13579 elsif P_1_Depth > P_2_Depth then 13580 Equalize_Depths 13581 (Pack => P_1, 13582 Depth => P_1_Depth, 13583 Depth_To_Reach => P_2_Depth); 13584 P_1_Child := True; 13585 13586 -- (root) P_1 13587 -- / \ : 13588 -- P_1 X or X 13589 -- : : 13590 -- P_2 P_2 13591 13592 elsif P_2_Depth > P_1_Depth then 13593 Equalize_Depths 13594 (Pack => P_2, 13595 Depth => P_2_Depth, 13596 Depth_To_Reach => P_1_Depth); 13597 P_2_Child := True; 13598 end if; 13599 13600 -- At this stage the package pointers have been elevated to the same 13601 -- depth. If the related entities are the same, then one package is a 13602 -- potential child of the other: 13603 13604 -- P_1 13605 -- : 13606 -- X became P_1 P_2 or vice versa 13607 -- : 13608 -- P_2 13609 13610 if P_1 = P_2 then 13611 if P_1_Child then 13612 return Is_Child_Unit (Pack_1); 13613 13614 else pragma Assert (P_2_Child); 13615 return Is_Child_Unit (Pack_2); 13616 end if; 13617 13618 -- The packages may come from the same package chain or from entirely 13619 -- different hierarcies. To determine this, climb the scope stack until 13620 -- a common root is found. 13621 13622 -- (root) (root 1) (root 2) 13623 -- / \ | | 13624 -- P_1 P_2 P_1 P_2 13625 13626 else 13627 while Present (P_1) and then Present (P_2) loop 13628 13629 -- The two packages may be siblings 13630 13631 if P_1 = P_2 then 13632 return Is_Child_Unit (Pack_1) and then Is_Child_Unit (Pack_2); 13633 end if; 13634 13635 P_1 := Scope (P_1); 13636 P_2 := Scope (P_2); 13637 end loop; 13638 end if; 13639 13640 return False; 13641 end Is_Child_Or_Sibling; 13642 13643 ----------------------------- 13644 -- Is_Concurrent_Interface -- 13645 ----------------------------- 13646 13647 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is 13648 begin 13649 return Is_Interface (T) 13650 and then 13651 (Is_Protected_Interface (T) 13652 or else Is_Synchronized_Interface (T) 13653 or else Is_Task_Interface (T)); 13654 end Is_Concurrent_Interface; 13655 13656 ----------------------- 13657 -- Is_Constant_Bound -- 13658 ----------------------- 13659 13660 function Is_Constant_Bound (Exp : Node_Id) return Boolean is 13661 begin 13662 if Compile_Time_Known_Value (Exp) then 13663 return True; 13664 13665 elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then 13666 return Is_Constant_Object (Entity (Exp)) 13667 or else Ekind (Entity (Exp)) = E_Enumeration_Literal; 13668 13669 elsif Nkind (Exp) in N_Binary_Op then 13670 return Is_Constant_Bound (Left_Opnd (Exp)) 13671 and then Is_Constant_Bound (Right_Opnd (Exp)) 13672 and then Scope (Entity (Exp)) = Standard_Standard; 13673 13674 else 13675 return False; 13676 end if; 13677 end Is_Constant_Bound; 13678 13679 --------------------------- 13680 -- Is_Container_Element -- 13681 --------------------------- 13682 13683 function Is_Container_Element (Exp : Node_Id) return Boolean is 13684 Loc : constant Source_Ptr := Sloc (Exp); 13685 Pref : constant Node_Id := Prefix (Exp); 13686 13687 Call : Node_Id; 13688 -- Call to an indexing aspect 13689 13690 Cont_Typ : Entity_Id; 13691 -- The type of the container being accessed 13692 13693 Elem_Typ : Entity_Id; 13694 -- Its element type 13695 13696 Indexing : Entity_Id; 13697 Is_Const : Boolean; 13698 -- Indicates that constant indexing is used, and the element is thus 13699 -- a constant. 13700 13701 Ref_Typ : Entity_Id; 13702 -- The reference type returned by the indexing operation 13703 13704 begin 13705 -- If C is a container, in a context that imposes the element type of 13706 -- that container, the indexing notation C (X) is rewritten as: 13707 13708 -- Indexing (C, X).Discr.all 13709 13710 -- where Indexing is one of the indexing aspects of the container. 13711 -- If the context does not require a reference, the construct can be 13712 -- rewritten as 13713 13714 -- Element (C, X) 13715 13716 -- First, verify that the construct has the proper form 13717 13718 if not Expander_Active then 13719 return False; 13720 13721 elsif Nkind (Pref) /= N_Selected_Component then 13722 return False; 13723 13724 elsif Nkind (Prefix (Pref)) /= N_Function_Call then 13725 return False; 13726 13727 else 13728 Call := Prefix (Pref); 13729 Ref_Typ := Etype (Call); 13730 end if; 13731 13732 if not Has_Implicit_Dereference (Ref_Typ) 13733 or else No (First (Parameter_Associations (Call))) 13734 or else not Is_Entity_Name (Name (Call)) 13735 then 13736 return False; 13737 end if; 13738 13739 -- Retrieve type of container object, and its iterator aspects 13740 13741 Cont_Typ := Etype (First (Parameter_Associations (Call))); 13742 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Constant_Indexing); 13743 Is_Const := False; 13744 13745 if No (Indexing) then 13746 13747 -- Container should have at least one indexing operation 13748 13749 return False; 13750 13751 elsif Entity (Name (Call)) /= Entity (Indexing) then 13752 13753 -- This may be a variable indexing operation 13754 13755 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Variable_Indexing); 13756 13757 if No (Indexing) 13758 or else Entity (Name (Call)) /= Entity (Indexing) 13759 then 13760 return False; 13761 end if; 13762 13763 else 13764 Is_Const := True; 13765 end if; 13766 13767 Elem_Typ := Find_Value_Of_Aspect (Cont_Typ, Aspect_Iterator_Element); 13768 13769 if No (Elem_Typ) or else Entity (Elem_Typ) /= Etype (Exp) then 13770 return False; 13771 end if; 13772 13773 -- Check that the expression is not the target of an assignment, in 13774 -- which case the rewriting is not possible. 13775 13776 if not Is_Const then 13777 declare 13778 Par : Node_Id; 13779 13780 begin 13781 Par := Exp; 13782 while Present (Par) 13783 loop 13784 if Nkind (Parent (Par)) = N_Assignment_Statement 13785 and then Par = Name (Parent (Par)) 13786 then 13787 return False; 13788 13789 -- A renaming produces a reference, and the transformation 13790 -- does not apply. 13791 13792 elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then 13793 return False; 13794 13795 elsif Nkind_In 13796 (Nkind (Parent (Par)), N_Function_Call, 13797 N_Procedure_Call_Statement, 13798 N_Entry_Call_Statement) 13799 then 13800 -- Check that the element is not part of an actual for an 13801 -- in-out parameter. 13802 13803 declare 13804 F : Entity_Id; 13805 A : Node_Id; 13806 13807 begin 13808 F := First_Formal (Entity (Name (Parent (Par)))); 13809 A := First (Parameter_Associations (Parent (Par))); 13810 while Present (F) loop 13811 if A = Par and then Ekind (F) /= E_In_Parameter then 13812 return False; 13813 end if; 13814 13815 Next_Formal (F); 13816 Next (A); 13817 end loop; 13818 end; 13819 13820 -- E_In_Parameter in a call: element is not modified. 13821 13822 exit; 13823 end if; 13824 13825 Par := Parent (Par); 13826 end loop; 13827 end; 13828 end if; 13829 13830 -- The expression has the proper form and the context requires the 13831 -- element type. Retrieve the Element function of the container and 13832 -- rewrite the construct as a call to it. 13833 13834 declare 13835 Op : Elmt_Id; 13836 13837 begin 13838 Op := First_Elmt (Primitive_Operations (Cont_Typ)); 13839 while Present (Op) loop 13840 exit when Chars (Node (Op)) = Name_Element; 13841 Next_Elmt (Op); 13842 end loop; 13843 13844 if No (Op) then 13845 return False; 13846 13847 else 13848 Rewrite (Exp, 13849 Make_Function_Call (Loc, 13850 Name => New_Occurrence_Of (Node (Op), Loc), 13851 Parameter_Associations => Parameter_Associations (Call))); 13852 Analyze_And_Resolve (Exp, Entity (Elem_Typ)); 13853 return True; 13854 end if; 13855 end; 13856 end Is_Container_Element; 13857 13858 ---------------------------- 13859 -- Is_Contract_Annotation -- 13860 ---------------------------- 13861 13862 function Is_Contract_Annotation (Item : Node_Id) return Boolean is 13863 begin 13864 return Is_Package_Contract_Annotation (Item) 13865 or else 13866 Is_Subprogram_Contract_Annotation (Item); 13867 end Is_Contract_Annotation; 13868 13869 -------------------------------------- 13870 -- Is_Controlling_Limited_Procedure -- 13871 -------------------------------------- 13872 13873 function Is_Controlling_Limited_Procedure 13874 (Proc_Nam : Entity_Id) return Boolean 13875 is 13876 Param : Node_Id; 13877 Param_Typ : Entity_Id := Empty; 13878 13879 begin 13880 if Ekind (Proc_Nam) = E_Procedure 13881 and then Present (Parameter_Specifications (Parent (Proc_Nam))) 13882 then 13883 Param := 13884 Parameter_Type 13885 (First (Parameter_Specifications (Parent (Proc_Nam)))); 13886 13887 -- The formal may be an anonymous access type 13888 13889 if Nkind (Param) = N_Access_Definition then 13890 Param_Typ := Entity (Subtype_Mark (Param)); 13891 else 13892 Param_Typ := Etype (Param); 13893 end if; 13894 13895 -- In the case where an Itype was created for a dispatchin call, the 13896 -- procedure call has been rewritten. The actual may be an access to 13897 -- interface type in which case it is the designated type that is the 13898 -- controlling type. 13899 13900 elsif Present (Associated_Node_For_Itype (Proc_Nam)) 13901 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam))) 13902 and then 13903 Present (Parameter_Associations 13904 (Associated_Node_For_Itype (Proc_Nam))) 13905 then 13906 Param_Typ := 13907 Etype (First (Parameter_Associations 13908 (Associated_Node_For_Itype (Proc_Nam)))); 13909 13910 if Ekind (Param_Typ) = E_Anonymous_Access_Type then 13911 Param_Typ := Directly_Designated_Type (Param_Typ); 13912 end if; 13913 end if; 13914 13915 if Present (Param_Typ) then 13916 return 13917 Is_Interface (Param_Typ) 13918 and then Is_Limited_Record (Param_Typ); 13919 end if; 13920 13921 return False; 13922 end Is_Controlling_Limited_Procedure; 13923 13924 ----------------------------- 13925 -- Is_CPP_Constructor_Call -- 13926 ----------------------------- 13927 13928 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is 13929 begin 13930 return Nkind (N) = N_Function_Call 13931 and then Is_CPP_Class (Etype (Etype (N))) 13932 and then Is_Constructor (Entity (Name (N))) 13933 and then Is_Imported (Entity (Name (N))); 13934 end Is_CPP_Constructor_Call; 13935 13936 ------------------------- 13937 -- Is_Current_Instance -- 13938 ------------------------- 13939 13940 function Is_Current_Instance (N : Node_Id) return Boolean is 13941 Typ : constant Entity_Id := Entity (N); 13942 P : Node_Id; 13943 13944 begin 13945 -- Simplest case: entity is a concurrent type and we are currently 13946 -- inside the body. This will eventually be expanded into a call to 13947 -- Self (for tasks) or _object (for protected objects). 13948 13949 if Is_Concurrent_Type (Typ) and then In_Open_Scopes (Typ) then 13950 return True; 13951 13952 else 13953 -- Check whether the context is a (sub)type declaration for the 13954 -- type entity. 13955 13956 P := Parent (N); 13957 while Present (P) loop 13958 if Nkind_In (P, N_Full_Type_Declaration, 13959 N_Private_Type_Declaration, 13960 N_Subtype_Declaration) 13961 and then Comes_From_Source (P) 13962 and then Defining_Entity (P) = Typ 13963 then 13964 return True; 13965 13966 -- A subtype name may appear in an aspect specification for a 13967 -- Predicate_Failure aspect, for which we do not construct a 13968 -- wrapper procedure. The subtype will be replaced by the 13969 -- expression being tested when the corresponding predicate 13970 -- check is expanded. 13971 13972 elsif Nkind (P) = N_Aspect_Specification 13973 and then Nkind (Parent (P)) = N_Subtype_Declaration 13974 then 13975 return True; 13976 13977 elsif Nkind (P) = N_Pragma 13978 and then Get_Pragma_Id (P) = Pragma_Predicate_Failure 13979 then 13980 return True; 13981 end if; 13982 13983 P := Parent (P); 13984 end loop; 13985 end if; 13986 13987 -- In any other context this is not a current occurrence 13988 13989 return False; 13990 end Is_Current_Instance; 13991 13992 -------------------- 13993 -- Is_Declaration -- 13994 -------------------- 13995 13996 function Is_Declaration 13997 (N : Node_Id; 13998 Body_OK : Boolean := True; 13999 Concurrent_OK : Boolean := True; 14000 Formal_OK : Boolean := True; 14001 Generic_OK : Boolean := True; 14002 Instantiation_OK : Boolean := True; 14003 Renaming_OK : Boolean := True; 14004 Stub_OK : Boolean := True; 14005 Subprogram_OK : Boolean := True; 14006 Type_OK : Boolean := True) return Boolean 14007 is 14008 begin 14009 case Nkind (N) is 14010 14011 -- Body declarations 14012 14013 when N_Proper_Body => 14014 return Body_OK; 14015 14016 -- Concurrent type declarations 14017 14018 when N_Protected_Type_Declaration 14019 | N_Single_Protected_Declaration 14020 | N_Single_Task_Declaration 14021 | N_Task_Type_Declaration 14022 => 14023 return Concurrent_OK or Type_OK; 14024 14025 -- Formal declarations 14026 14027 when N_Formal_Abstract_Subprogram_Declaration 14028 | N_Formal_Concrete_Subprogram_Declaration 14029 | N_Formal_Object_Declaration 14030 | N_Formal_Package_Declaration 14031 | N_Formal_Type_Declaration 14032 => 14033 return Formal_OK; 14034 14035 -- Generic declarations 14036 14037 when N_Generic_Package_Declaration 14038 | N_Generic_Subprogram_Declaration 14039 => 14040 return Generic_OK; 14041 14042 -- Generic instantiations 14043 14044 when N_Function_Instantiation 14045 | N_Package_Instantiation 14046 | N_Procedure_Instantiation 14047 => 14048 return Instantiation_OK; 14049 14050 -- Generic renaming declarations 14051 14052 when N_Generic_Renaming_Declaration => 14053 return Generic_OK or Renaming_OK; 14054 14055 -- Renaming declarations 14056 14057 when N_Exception_Renaming_Declaration 14058 | N_Object_Renaming_Declaration 14059 | N_Package_Renaming_Declaration 14060 | N_Subprogram_Renaming_Declaration 14061 => 14062 return Renaming_OK; 14063 14064 -- Stub declarations 14065 14066 when N_Body_Stub => 14067 return Stub_OK; 14068 14069 -- Subprogram declarations 14070 14071 when N_Abstract_Subprogram_Declaration 14072 | N_Entry_Declaration 14073 | N_Expression_Function 14074 | N_Subprogram_Declaration 14075 => 14076 return Subprogram_OK; 14077 14078 -- Type declarations 14079 14080 when N_Full_Type_Declaration 14081 | N_Incomplete_Type_Declaration 14082 | N_Private_Extension_Declaration 14083 | N_Private_Type_Declaration 14084 | N_Subtype_Declaration 14085 => 14086 return Type_OK; 14087 14088 -- Miscellaneous 14089 14090 when N_Component_Declaration 14091 | N_Exception_Declaration 14092 | N_Implicit_Label_Declaration 14093 | N_Number_Declaration 14094 | N_Object_Declaration 14095 | N_Package_Declaration 14096 => 14097 return True; 14098 14099 when others => 14100 return False; 14101 end case; 14102 end Is_Declaration; 14103 14104 -------------------------------- 14105 -- Is_Declared_Within_Variant -- 14106 -------------------------------- 14107 14108 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is 14109 Comp_Decl : constant Node_Id := Parent (Comp); 14110 Comp_List : constant Node_Id := Parent (Comp_Decl); 14111 begin 14112 return Nkind (Parent (Comp_List)) = N_Variant; 14113 end Is_Declared_Within_Variant; 14114 14115 ---------------------------------------------- 14116 -- Is_Dependent_Component_Of_Mutable_Object -- 14117 ---------------------------------------------- 14118 14119 function Is_Dependent_Component_Of_Mutable_Object 14120 (Object : Node_Id) return Boolean 14121 is 14122 P : Node_Id; 14123 Prefix_Type : Entity_Id; 14124 P_Aliased : Boolean := False; 14125 Comp : Entity_Id; 14126 14127 Deref : Node_Id := Object; 14128 -- Dereference node, in something like X.all.Y(2) 14129 14130 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object 14131 14132 begin 14133 -- Find the dereference node if any 14134 14135 while Nkind_In (Deref, N_Indexed_Component, 14136 N_Selected_Component, 14137 N_Slice) 14138 loop 14139 Deref := Prefix (Deref); 14140 end loop; 14141 14142 -- If the prefix is a qualified expression of a variable, then function 14143 -- Is_Variable will return False for that because a qualified expression 14144 -- denotes a constant view, so we need to get the name being qualified 14145 -- so we can test below whether that's a variable (or a dereference). 14146 14147 if Nkind (Deref) = N_Qualified_Expression then 14148 Deref := Expression (Deref); 14149 end if; 14150 14151 -- Ada 2005: If we have a component or slice of a dereference, something 14152 -- like X.all.Y (2) and the type of X is access-to-constant, Is_Variable 14153 -- will return False, because it is indeed a constant view. But it might 14154 -- be a view of a variable object, so we want the following condition to 14155 -- be True in that case. 14156 14157 if Is_Variable (Object) 14158 or else Is_Variable (Deref) 14159 or else (Ada_Version >= Ada_2005 14160 and then (Nkind (Deref) = N_Explicit_Dereference 14161 or else Is_Access_Type (Etype (Deref)))) 14162 then 14163 if Nkind (Object) = N_Selected_Component then 14164 14165 -- If the selector is not a component, then we definitely return 14166 -- False (it could be a function selector in a prefix form call 14167 -- occurring in an iterator specification). 14168 14169 if not Ekind_In (Entity (Selector_Name (Object)), E_Component, 14170 E_Discriminant) 14171 then 14172 return False; 14173 end if; 14174 14175 -- Get the original node of the prefix in case it has been 14176 -- rewritten, which can occur, for example, in qualified 14177 -- expression cases. Also, a discriminant check on a selected 14178 -- component may be expanded into a dereference when removing 14179 -- side effects, and the subtype of the original node may be 14180 -- unconstrained. 14181 14182 P := Original_Node (Prefix (Object)); 14183 Prefix_Type := Etype (P); 14184 14185 -- If the prefix is a qualified expression, we want to look at its 14186 -- operand. 14187 14188 if Nkind (P) = N_Qualified_Expression then 14189 P := Expression (P); 14190 Prefix_Type := Etype (P); 14191 end if; 14192 14193 if Is_Entity_Name (P) then 14194 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then 14195 Prefix_Type := Base_Type (Prefix_Type); 14196 end if; 14197 14198 if Is_Aliased (Entity (P)) then 14199 P_Aliased := True; 14200 end if; 14201 14202 -- For explicit dereferences we get the access prefix so we can 14203 -- treat this similarly to implicit dereferences and examine the 14204 -- kind of the access type and its designated subtype further 14205 -- below. 14206 14207 elsif Nkind (P) = N_Explicit_Dereference then 14208 P := Prefix (P); 14209 Prefix_Type := Etype (P); 14210 14211 else 14212 -- Check for prefix being an aliased component??? 14213 14214 null; 14215 end if; 14216 14217 -- A heap object is constrained by its initial value 14218 14219 -- Ada 2005 (AI-363): Always assume the object could be mutable in 14220 -- the dereferenced case, since the access value might denote an 14221 -- unconstrained aliased object, whereas in Ada 95 the designated 14222 -- object is guaranteed to be constrained. A worst-case assumption 14223 -- has to apply in Ada 2005 because we can't tell at compile 14224 -- time whether the object is "constrained by its initial value", 14225 -- despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic 14226 -- rules (these rules are acknowledged to need fixing). We don't 14227 -- impose this more stringent checking for earlier Ada versions or 14228 -- when Relaxed_RM_Semantics applies (the latter for CodePeer's 14229 -- benefit, though it's unclear on why using -gnat95 would not be 14230 -- sufficient???). 14231 14232 if Ada_Version < Ada_2005 or else Relaxed_RM_Semantics then 14233 if Is_Access_Type (Prefix_Type) 14234 or else Nkind (P) = N_Explicit_Dereference 14235 then 14236 return False; 14237 end if; 14238 14239 else pragma Assert (Ada_Version >= Ada_2005); 14240 if Is_Access_Type (Prefix_Type) then 14241 -- We need to make sure we have the base subtype, in case 14242 -- this is actually an access subtype (whose Ekind will be 14243 -- E_Access_Subtype). 14244 14245 Prefix_Type := Etype (Prefix_Type); 14246 14247 -- If the access type is pool-specific, and there is no 14248 -- constrained partial view of the designated type, then the 14249 -- designated object is known to be constrained. If it's a 14250 -- formal access type and the renaming is in the generic 14251 -- spec, we also treat it as pool-specific (known to be 14252 -- constrained), but assume the worst if in the generic body 14253 -- (see RM 3.3(23.3/3)). 14254 14255 if Ekind (Prefix_Type) = E_Access_Type 14256 and then (not Is_Generic_Type (Prefix_Type) 14257 or else not In_Generic_Body (Current_Scope)) 14258 and then not Object_Type_Has_Constrained_Partial_View 14259 (Typ => Designated_Type (Prefix_Type), 14260 Scop => Current_Scope) 14261 then 14262 return False; 14263 14264 -- Otherwise (general access type, or there is a constrained 14265 -- partial view of the designated type), we need to check 14266 -- based on the designated type. 14267 14268 else 14269 Prefix_Type := Designated_Type (Prefix_Type); 14270 end if; 14271 end if; 14272 end if; 14273 14274 Comp := 14275 Original_Record_Component (Entity (Selector_Name (Object))); 14276 14277 -- As per AI-0017, the renaming is illegal in a generic body, even 14278 -- if the subtype is indefinite (only applies to prefixes of an 14279 -- untagged formal type, see RM 3.3 (23.11/3)). 14280 14281 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable 14282 14283 if not Is_Constrained (Prefix_Type) 14284 and then (Is_Definite_Subtype (Prefix_Type) 14285 or else 14286 (not Is_Tagged_Type (Prefix_Type) 14287 and then Is_Generic_Type (Prefix_Type) 14288 and then In_Generic_Body (Current_Scope))) 14289 14290 and then (Is_Declared_Within_Variant (Comp) 14291 or else Has_Discriminant_Dependent_Constraint (Comp)) 14292 and then (not P_Aliased or else Ada_Version >= Ada_2005) 14293 then 14294 return True; 14295 14296 -- If the prefix is of an access type at this point, then we want 14297 -- to return False, rather than calling this function recursively 14298 -- on the access object (which itself might be a discriminant- 14299 -- dependent component of some other object, but that isn't 14300 -- relevant to checking the object passed to us). This avoids 14301 -- issuing wrong errors when compiling with -gnatc, where there 14302 -- can be implicit dereferences that have not been expanded. 14303 14304 elsif Is_Access_Type (Etype (Prefix (Object))) then 14305 return False; 14306 14307 else 14308 return 14309 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 14310 end if; 14311 14312 elsif Nkind (Object) = N_Indexed_Component 14313 or else Nkind (Object) = N_Slice 14314 then 14315 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 14316 14317 -- A type conversion that Is_Variable is a view conversion: 14318 -- go back to the denoted object. 14319 14320 elsif Nkind (Object) = N_Type_Conversion then 14321 return 14322 Is_Dependent_Component_Of_Mutable_Object (Expression (Object)); 14323 end if; 14324 end if; 14325 14326 return False; 14327 end Is_Dependent_Component_Of_Mutable_Object; 14328 14329 --------------------- 14330 -- Is_Dereferenced -- 14331 --------------------- 14332 14333 function Is_Dereferenced (N : Node_Id) return Boolean is 14334 P : constant Node_Id := Parent (N); 14335 begin 14336 return Nkind_In (P, N_Selected_Component, 14337 N_Explicit_Dereference, 14338 N_Indexed_Component, 14339 N_Slice) 14340 and then Prefix (P) = N; 14341 end Is_Dereferenced; 14342 14343 ---------------------- 14344 -- Is_Descendant_Of -- 14345 ---------------------- 14346 14347 function Is_Descendant_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is 14348 T : Entity_Id; 14349 Etyp : Entity_Id; 14350 14351 begin 14352 pragma Assert (Nkind (T1) in N_Entity); 14353 pragma Assert (Nkind (T2) in N_Entity); 14354 14355 T := Base_Type (T1); 14356 14357 -- Immediate return if the types match 14358 14359 if T = T2 then 14360 return True; 14361 14362 -- Comment needed here ??? 14363 14364 elsif Ekind (T) = E_Class_Wide_Type then 14365 return Etype (T) = T2; 14366 14367 -- All other cases 14368 14369 else 14370 loop 14371 Etyp := Etype (T); 14372 14373 -- Done if we found the type we are looking for 14374 14375 if Etyp = T2 then 14376 return True; 14377 14378 -- Done if no more derivations to check 14379 14380 elsif T = T1 14381 or else T = Etyp 14382 then 14383 return False; 14384 14385 -- Following test catches error cases resulting from prev errors 14386 14387 elsif No (Etyp) then 14388 return False; 14389 14390 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then 14391 return False; 14392 14393 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then 14394 return False; 14395 end if; 14396 14397 T := Base_Type (Etyp); 14398 end loop; 14399 end if; 14400 end Is_Descendant_Of; 14401 14402 ---------------------------------------- 14403 -- Is_Descendant_Of_Suspension_Object -- 14404 ---------------------------------------- 14405 14406 function Is_Descendant_Of_Suspension_Object 14407 (Typ : Entity_Id) return Boolean 14408 is 14409 Cur_Typ : Entity_Id; 14410 Par_Typ : Entity_Id; 14411 14412 begin 14413 -- Climb the type derivation chain checking each parent type against 14414 -- Suspension_Object. 14415 14416 Cur_Typ := Base_Type (Typ); 14417 while Present (Cur_Typ) loop 14418 Par_Typ := Etype (Cur_Typ); 14419 14420 -- The current type is a match 14421 14422 if Is_Suspension_Object (Cur_Typ) then 14423 return True; 14424 14425 -- Stop the traversal once the root of the derivation chain has been 14426 -- reached. In that case the current type is its own base type. 14427 14428 elsif Cur_Typ = Par_Typ then 14429 exit; 14430 end if; 14431 14432 Cur_Typ := Base_Type (Par_Typ); 14433 end loop; 14434 14435 return False; 14436 end Is_Descendant_Of_Suspension_Object; 14437 14438 --------------------------------------------- 14439 -- Is_Double_Precision_Floating_Point_Type -- 14440 --------------------------------------------- 14441 14442 function Is_Double_Precision_Floating_Point_Type 14443 (E : Entity_Id) return Boolean is 14444 begin 14445 return Is_Floating_Point_Type (E) 14446 and then Machine_Radix_Value (E) = Uint_2 14447 and then Machine_Mantissa_Value (E) = UI_From_Int (53) 14448 and then Machine_Emax_Value (E) = Uint_2 ** Uint_10 14449 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_10); 14450 end Is_Double_Precision_Floating_Point_Type; 14451 14452 ----------------------------- 14453 -- Is_Effectively_Volatile -- 14454 ----------------------------- 14455 14456 function Is_Effectively_Volatile (Id : Entity_Id) return Boolean is 14457 begin 14458 if Is_Type (Id) then 14459 14460 -- An arbitrary type is effectively volatile when it is subject to 14461 -- pragma Atomic or Volatile. 14462 14463 if Is_Volatile (Id) then 14464 return True; 14465 14466 -- An array type is effectively volatile when it is subject to pragma 14467 -- Atomic_Components or Volatile_Components or its component type is 14468 -- effectively volatile. 14469 14470 elsif Is_Array_Type (Id) then 14471 declare 14472 Anc : Entity_Id := Base_Type (Id); 14473 begin 14474 if Is_Private_Type (Anc) then 14475 Anc := Full_View (Anc); 14476 end if; 14477 14478 -- Test for presence of ancestor, as the full view of a private 14479 -- type may be missing in case of error. 14480 14481 return 14482 Has_Volatile_Components (Id) 14483 or else 14484 (Present (Anc) 14485 and then Is_Effectively_Volatile (Component_Type (Anc))); 14486 end; 14487 14488 -- A protected type is always volatile 14489 14490 elsif Is_Protected_Type (Id) then 14491 return True; 14492 14493 -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is 14494 -- automatically volatile. 14495 14496 elsif Is_Descendant_Of_Suspension_Object (Id) then 14497 return True; 14498 14499 -- Otherwise the type is not effectively volatile 14500 14501 else 14502 return False; 14503 end if; 14504 14505 -- Otherwise Id denotes an object 14506 14507 else 14508 return 14509 Is_Volatile (Id) 14510 or else Has_Volatile_Components (Id) 14511 or else Is_Effectively_Volatile (Etype (Id)); 14512 end if; 14513 end Is_Effectively_Volatile; 14514 14515 ------------------------------------ 14516 -- Is_Effectively_Volatile_Object -- 14517 ------------------------------------ 14518 14519 function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean is 14520 begin 14521 if Is_Entity_Name (N) then 14522 return Is_Effectively_Volatile (Entity (N)); 14523 14524 elsif Nkind (N) = N_Indexed_Component then 14525 return Is_Effectively_Volatile_Object (Prefix (N)); 14526 14527 elsif Nkind (N) = N_Selected_Component then 14528 return 14529 Is_Effectively_Volatile_Object (Prefix (N)) 14530 or else 14531 Is_Effectively_Volatile_Object (Selector_Name (N)); 14532 14533 else 14534 return False; 14535 end if; 14536 end Is_Effectively_Volatile_Object; 14537 14538 ------------------- 14539 -- Is_Entry_Body -- 14540 ------------------- 14541 14542 function Is_Entry_Body (Id : Entity_Id) return Boolean is 14543 begin 14544 return 14545 Ekind_In (Id, E_Entry, E_Entry_Family) 14546 and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Body; 14547 end Is_Entry_Body; 14548 14549 -------------------------- 14550 -- Is_Entry_Declaration -- 14551 -------------------------- 14552 14553 function Is_Entry_Declaration (Id : Entity_Id) return Boolean is 14554 begin 14555 return 14556 Ekind_In (Id, E_Entry, E_Entry_Family) 14557 and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Declaration; 14558 end Is_Entry_Declaration; 14559 14560 ------------------------------------ 14561 -- Is_Expanded_Priority_Attribute -- 14562 ------------------------------------ 14563 14564 function Is_Expanded_Priority_Attribute (E : Entity_Id) return Boolean is 14565 begin 14566 return 14567 Nkind (E) = N_Function_Call 14568 and then not Configurable_Run_Time_Mode 14569 and then (Entity (Name (E)) = RTE (RE_Get_Ceiling) 14570 or else Entity (Name (E)) = RTE (RO_PE_Get_Ceiling)); 14571 end Is_Expanded_Priority_Attribute; 14572 14573 ---------------------------- 14574 -- Is_Expression_Function -- 14575 ---------------------------- 14576 14577 function Is_Expression_Function (Subp : Entity_Id) return Boolean is 14578 begin 14579 if Ekind_In (Subp, E_Function, E_Subprogram_Body) then 14580 return 14581 Nkind (Original_Node (Unit_Declaration_Node (Subp))) = 14582 N_Expression_Function; 14583 else 14584 return False; 14585 end if; 14586 end Is_Expression_Function; 14587 14588 ------------------------------------------ 14589 -- Is_Expression_Function_Or_Completion -- 14590 ------------------------------------------ 14591 14592 function Is_Expression_Function_Or_Completion 14593 (Subp : Entity_Id) return Boolean 14594 is 14595 Subp_Decl : Node_Id; 14596 14597 begin 14598 if Ekind (Subp) = E_Function then 14599 Subp_Decl := Unit_Declaration_Node (Subp); 14600 14601 -- The function declaration is either an expression function or is 14602 -- completed by an expression function body. 14603 14604 return 14605 Is_Expression_Function (Subp) 14606 or else (Nkind (Subp_Decl) = N_Subprogram_Declaration 14607 and then Present (Corresponding_Body (Subp_Decl)) 14608 and then Is_Expression_Function 14609 (Corresponding_Body (Subp_Decl))); 14610 14611 elsif Ekind (Subp) = E_Subprogram_Body then 14612 return Is_Expression_Function (Subp); 14613 14614 else 14615 return False; 14616 end if; 14617 end Is_Expression_Function_Or_Completion; 14618 14619 ----------------------- 14620 -- Is_EVF_Expression -- 14621 ----------------------- 14622 14623 function Is_EVF_Expression (N : Node_Id) return Boolean is 14624 Orig_N : constant Node_Id := Original_Node (N); 14625 Alt : Node_Id; 14626 Expr : Node_Id; 14627 Id : Entity_Id; 14628 14629 begin 14630 -- Detect a reference to a formal parameter of a specific tagged type 14631 -- whose related subprogram is subject to pragma Expresions_Visible with 14632 -- value "False". 14633 14634 if Is_Entity_Name (N) and then Present (Entity (N)) then 14635 Id := Entity (N); 14636 14637 return 14638 Is_Formal (Id) 14639 and then Is_Specific_Tagged_Type (Etype (Id)) 14640 and then Extensions_Visible_Status (Id) = 14641 Extensions_Visible_False; 14642 14643 -- A case expression is an EVF expression when it contains at least one 14644 -- EVF dependent_expression. Note that a case expression may have been 14645 -- expanded, hence the use of Original_Node. 14646 14647 elsif Nkind (Orig_N) = N_Case_Expression then 14648 Alt := First (Alternatives (Orig_N)); 14649 while Present (Alt) loop 14650 if Is_EVF_Expression (Expression (Alt)) then 14651 return True; 14652 end if; 14653 14654 Next (Alt); 14655 end loop; 14656 14657 -- An if expression is an EVF expression when it contains at least one 14658 -- EVF dependent_expression. Note that an if expression may have been 14659 -- expanded, hence the use of Original_Node. 14660 14661 elsif Nkind (Orig_N) = N_If_Expression then 14662 Expr := Next (First (Expressions (Orig_N))); 14663 while Present (Expr) loop 14664 if Is_EVF_Expression (Expr) then 14665 return True; 14666 end if; 14667 14668 Next (Expr); 14669 end loop; 14670 14671 -- A qualified expression or a type conversion is an EVF expression when 14672 -- its operand is an EVF expression. 14673 14674 elsif Nkind_In (N, N_Qualified_Expression, 14675 N_Unchecked_Type_Conversion, 14676 N_Type_Conversion) 14677 then 14678 return Is_EVF_Expression (Expression (N)); 14679 14680 -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when 14681 -- their prefix denotes an EVF expression. 14682 14683 elsif Nkind (N) = N_Attribute_Reference 14684 and then Nam_In (Attribute_Name (N), Name_Loop_Entry, 14685 Name_Old, 14686 Name_Update) 14687 then 14688 return Is_EVF_Expression (Prefix (N)); 14689 end if; 14690 14691 return False; 14692 end Is_EVF_Expression; 14693 14694 -------------- 14695 -- Is_False -- 14696 -------------- 14697 14698 function Is_False (U : Uint) return Boolean is 14699 begin 14700 return (U = 0); 14701 end Is_False; 14702 14703 --------------------------- 14704 -- Is_Fixed_Model_Number -- 14705 --------------------------- 14706 14707 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is 14708 S : constant Ureal := Small_Value (T); 14709 M : Urealp.Save_Mark; 14710 R : Boolean; 14711 14712 begin 14713 M := Urealp.Mark; 14714 R := (U = UR_Trunc (U / S) * S); 14715 Urealp.Release (M); 14716 return R; 14717 end Is_Fixed_Model_Number; 14718 14719 ------------------------------- 14720 -- Is_Fully_Initialized_Type -- 14721 ------------------------------- 14722 14723 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is 14724 begin 14725 -- Scalar types 14726 14727 if Is_Scalar_Type (Typ) then 14728 14729 -- A scalar type with an aspect Default_Value is fully initialized 14730 14731 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization 14732 -- of a scalar type, but we don't take that into account here, since 14733 -- we don't want these to affect warnings. 14734 14735 return Has_Default_Aspect (Typ); 14736 14737 elsif Is_Access_Type (Typ) then 14738 return True; 14739 14740 elsif Is_Array_Type (Typ) then 14741 if Is_Fully_Initialized_Type (Component_Type (Typ)) 14742 or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ)) 14743 then 14744 return True; 14745 end if; 14746 14747 -- An interesting case, if we have a constrained type one of whose 14748 -- bounds is known to be null, then there are no elements to be 14749 -- initialized, so all the elements are initialized. 14750 14751 if Is_Constrained (Typ) then 14752 declare 14753 Indx : Node_Id; 14754 Indx_Typ : Entity_Id; 14755 Lbd, Hbd : Node_Id; 14756 14757 begin 14758 Indx := First_Index (Typ); 14759 while Present (Indx) loop 14760 if Etype (Indx) = Any_Type then 14761 return False; 14762 14763 -- If index is a range, use directly 14764 14765 elsif Nkind (Indx) = N_Range then 14766 Lbd := Low_Bound (Indx); 14767 Hbd := High_Bound (Indx); 14768 14769 else 14770 Indx_Typ := Etype (Indx); 14771 14772 if Is_Private_Type (Indx_Typ) then 14773 Indx_Typ := Full_View (Indx_Typ); 14774 end if; 14775 14776 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then 14777 return False; 14778 else 14779 Lbd := Type_Low_Bound (Indx_Typ); 14780 Hbd := Type_High_Bound (Indx_Typ); 14781 end if; 14782 end if; 14783 14784 if Compile_Time_Known_Value (Lbd) 14785 and then 14786 Compile_Time_Known_Value (Hbd) 14787 then 14788 if Expr_Value (Hbd) < Expr_Value (Lbd) then 14789 return True; 14790 end if; 14791 end if; 14792 14793 Next_Index (Indx); 14794 end loop; 14795 end; 14796 end if; 14797 14798 -- If no null indexes, then type is not fully initialized 14799 14800 return False; 14801 14802 -- Record types 14803 14804 elsif Is_Record_Type (Typ) then 14805 if Has_Discriminants (Typ) 14806 and then 14807 Present (Discriminant_Default_Value (First_Discriminant (Typ))) 14808 and then Is_Fully_Initialized_Variant (Typ) 14809 then 14810 return True; 14811 end if; 14812 14813 -- We consider bounded string types to be fully initialized, because 14814 -- otherwise we get false alarms when the Data component is not 14815 -- default-initialized. 14816 14817 if Is_Bounded_String (Typ) then 14818 return True; 14819 end if; 14820 14821 -- Controlled records are considered to be fully initialized if 14822 -- there is a user defined Initialize routine. This may not be 14823 -- entirely correct, but as the spec notes, we are guessing here 14824 -- what is best from the point of view of issuing warnings. 14825 14826 if Is_Controlled (Typ) then 14827 declare 14828 Utyp : constant Entity_Id := Underlying_Type (Typ); 14829 14830 begin 14831 if Present (Utyp) then 14832 declare 14833 Init : constant Entity_Id := 14834 (Find_Optional_Prim_Op 14835 (Underlying_Type (Typ), Name_Initialize)); 14836 14837 begin 14838 if Present (Init) 14839 and then Comes_From_Source (Init) 14840 and then not In_Predefined_Unit (Init) 14841 then 14842 return True; 14843 14844 elsif Has_Null_Extension (Typ) 14845 and then 14846 Is_Fully_Initialized_Type 14847 (Etype (Base_Type (Typ))) 14848 then 14849 return True; 14850 end if; 14851 end; 14852 end if; 14853 end; 14854 end if; 14855 14856 -- Otherwise see if all record components are initialized 14857 14858 declare 14859 Ent : Entity_Id; 14860 14861 begin 14862 Ent := First_Entity (Typ); 14863 while Present (Ent) loop 14864 if Ekind (Ent) = E_Component 14865 and then (No (Parent (Ent)) 14866 or else No (Expression (Parent (Ent)))) 14867 and then not Is_Fully_Initialized_Type (Etype (Ent)) 14868 14869 -- Special VM case for tag components, which need to be 14870 -- defined in this case, but are never initialized as VMs 14871 -- are using other dispatching mechanisms. Ignore this 14872 -- uninitialized case. Note that this applies both to the 14873 -- uTag entry and the main vtable pointer (CPP_Class case). 14874 14875 and then (Tagged_Type_Expansion or else not Is_Tag (Ent)) 14876 then 14877 return False; 14878 end if; 14879 14880 Next_Entity (Ent); 14881 end loop; 14882 end; 14883 14884 -- No uninitialized components, so type is fully initialized. 14885 -- Note that this catches the case of no components as well. 14886 14887 return True; 14888 14889 elsif Is_Concurrent_Type (Typ) then 14890 return True; 14891 14892 elsif Is_Private_Type (Typ) then 14893 declare 14894 U : constant Entity_Id := Underlying_Type (Typ); 14895 14896 begin 14897 if No (U) then 14898 return False; 14899 else 14900 return Is_Fully_Initialized_Type (U); 14901 end if; 14902 end; 14903 14904 else 14905 return False; 14906 end if; 14907 end Is_Fully_Initialized_Type; 14908 14909 ---------------------------------- 14910 -- Is_Fully_Initialized_Variant -- 14911 ---------------------------------- 14912 14913 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is 14914 Loc : constant Source_Ptr := Sloc (Typ); 14915 Constraints : constant List_Id := New_List; 14916 Components : constant Elist_Id := New_Elmt_List; 14917 Comp_Elmt : Elmt_Id; 14918 Comp_Id : Node_Id; 14919 Comp_List : Node_Id; 14920 Discr : Entity_Id; 14921 Discr_Val : Node_Id; 14922 14923 Report_Errors : Boolean; 14924 pragma Warnings (Off, Report_Errors); 14925 14926 begin 14927 if Serious_Errors_Detected > 0 then 14928 return False; 14929 end if; 14930 14931 if Is_Record_Type (Typ) 14932 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration 14933 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition 14934 then 14935 Comp_List := Component_List (Type_Definition (Parent (Typ))); 14936 14937 Discr := First_Discriminant (Typ); 14938 while Present (Discr) loop 14939 if Nkind (Parent (Discr)) = N_Discriminant_Specification then 14940 Discr_Val := Expression (Parent (Discr)); 14941 14942 if Present (Discr_Val) 14943 and then Is_OK_Static_Expression (Discr_Val) 14944 then 14945 Append_To (Constraints, 14946 Make_Component_Association (Loc, 14947 Choices => New_List (New_Occurrence_Of (Discr, Loc)), 14948 Expression => New_Copy (Discr_Val))); 14949 else 14950 return False; 14951 end if; 14952 else 14953 return False; 14954 end if; 14955 14956 Next_Discriminant (Discr); 14957 end loop; 14958 14959 Gather_Components 14960 (Typ => Typ, 14961 Comp_List => Comp_List, 14962 Governed_By => Constraints, 14963 Into => Components, 14964 Report_Errors => Report_Errors); 14965 14966 -- Check that each component present is fully initialized 14967 14968 Comp_Elmt := First_Elmt (Components); 14969 while Present (Comp_Elmt) loop 14970 Comp_Id := Node (Comp_Elmt); 14971 14972 if Ekind (Comp_Id) = E_Component 14973 and then (No (Parent (Comp_Id)) 14974 or else No (Expression (Parent (Comp_Id)))) 14975 and then not Is_Fully_Initialized_Type (Etype (Comp_Id)) 14976 then 14977 return False; 14978 end if; 14979 14980 Next_Elmt (Comp_Elmt); 14981 end loop; 14982 14983 return True; 14984 14985 elsif Is_Private_Type (Typ) then 14986 declare 14987 U : constant Entity_Id := Underlying_Type (Typ); 14988 14989 begin 14990 if No (U) then 14991 return False; 14992 else 14993 return Is_Fully_Initialized_Variant (U); 14994 end if; 14995 end; 14996 14997 else 14998 return False; 14999 end if; 15000 end Is_Fully_Initialized_Variant; 15001 15002 ------------------------------------ 15003 -- Is_Generic_Declaration_Or_Body -- 15004 ------------------------------------ 15005 15006 function Is_Generic_Declaration_Or_Body (Decl : Node_Id) return Boolean is 15007 Spec_Decl : Node_Id; 15008 15009 begin 15010 -- Package/subprogram body 15011 15012 if Nkind_In (Decl, N_Package_Body, N_Subprogram_Body) 15013 and then Present (Corresponding_Spec (Decl)) 15014 then 15015 Spec_Decl := Unit_Declaration_Node (Corresponding_Spec (Decl)); 15016 15017 -- Package/subprogram body stub 15018 15019 elsif Nkind_In (Decl, N_Package_Body_Stub, N_Subprogram_Body_Stub) 15020 and then Present (Corresponding_Spec_Of_Stub (Decl)) 15021 then 15022 Spec_Decl := 15023 Unit_Declaration_Node (Corresponding_Spec_Of_Stub (Decl)); 15024 15025 -- All other cases 15026 15027 else 15028 Spec_Decl := Decl; 15029 end if; 15030 15031 -- Rather than inspecting the defining entity of the spec declaration, 15032 -- look at its Nkind. This takes care of the case where the analysis of 15033 -- a generic body modifies the Ekind of its spec to allow for recursive 15034 -- calls. 15035 15036 return 15037 Nkind_In (Spec_Decl, N_Generic_Package_Declaration, 15038 N_Generic_Subprogram_Declaration); 15039 end Is_Generic_Declaration_Or_Body; 15040 15041 ---------------------------- 15042 -- Is_Inherited_Operation -- 15043 ---------------------------- 15044 15045 function Is_Inherited_Operation (E : Entity_Id) return Boolean is 15046 pragma Assert (Is_Overloadable (E)); 15047 Kind : constant Node_Kind := Nkind (Parent (E)); 15048 begin 15049 return Kind = N_Full_Type_Declaration 15050 or else Kind = N_Private_Extension_Declaration 15051 or else Kind = N_Subtype_Declaration 15052 or else (Ekind (E) = E_Enumeration_Literal 15053 and then Is_Derived_Type (Etype (E))); 15054 end Is_Inherited_Operation; 15055 15056 ------------------------------------- 15057 -- Is_Inherited_Operation_For_Type -- 15058 ------------------------------------- 15059 15060 function Is_Inherited_Operation_For_Type 15061 (E : Entity_Id; 15062 Typ : Entity_Id) return Boolean 15063 is 15064 begin 15065 -- Check that the operation has been created by the type declaration 15066 15067 return Is_Inherited_Operation (E) 15068 and then Defining_Identifier (Parent (E)) = Typ; 15069 end Is_Inherited_Operation_For_Type; 15070 15071 -------------------------------------- 15072 -- Is_Inlinable_Expression_Function -- 15073 -------------------------------------- 15074 15075 function Is_Inlinable_Expression_Function 15076 (Subp : Entity_Id) return Boolean 15077 is 15078 Return_Expr : Node_Id; 15079 15080 begin 15081 if Is_Expression_Function_Or_Completion (Subp) 15082 and then Has_Pragma_Inline_Always (Subp) 15083 and then Needs_No_Actuals (Subp) 15084 and then No (Contract (Subp)) 15085 and then not Is_Dispatching_Operation (Subp) 15086 and then Needs_Finalization (Etype (Subp)) 15087 and then not Is_Class_Wide_Type (Etype (Subp)) 15088 and then not (Has_Invariants (Etype (Subp))) 15089 and then Present (Subprogram_Body (Subp)) 15090 and then Was_Expression_Function (Subprogram_Body (Subp)) 15091 then 15092 Return_Expr := Expression_Of_Expression_Function (Subp); 15093 15094 -- The returned object must not have a qualified expression and its 15095 -- nominal subtype must be statically compatible with the result 15096 -- subtype of the expression function. 15097 15098 return 15099 Nkind (Return_Expr) = N_Identifier 15100 and then Etype (Return_Expr) = Etype (Subp); 15101 end if; 15102 15103 return False; 15104 end Is_Inlinable_Expression_Function; 15105 15106 ----------------- 15107 -- Is_Iterator -- 15108 ----------------- 15109 15110 function Is_Iterator (Typ : Entity_Id) return Boolean is 15111 function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean; 15112 -- Determine whether type Iter_Typ is a predefined forward or reversible 15113 -- iterator. 15114 15115 ---------------------- 15116 -- Denotes_Iterator -- 15117 ---------------------- 15118 15119 function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean is 15120 begin 15121 -- Check that the name matches, and that the ultimate ancestor is in 15122 -- a predefined unit, i.e the one that declares iterator interfaces. 15123 15124 return 15125 Nam_In (Chars (Iter_Typ), Name_Forward_Iterator, 15126 Name_Reversible_Iterator) 15127 and then In_Predefined_Unit (Root_Type (Iter_Typ)); 15128 end Denotes_Iterator; 15129 15130 -- Local variables 15131 15132 Iface_Elmt : Elmt_Id; 15133 Ifaces : Elist_Id; 15134 15135 -- Start of processing for Is_Iterator 15136 15137 begin 15138 -- The type may be a subtype of a descendant of the proper instance of 15139 -- the predefined interface type, so we must use the root type of the 15140 -- given type. The same is done for Is_Reversible_Iterator. 15141 15142 if Is_Class_Wide_Type (Typ) 15143 and then Denotes_Iterator (Root_Type (Typ)) 15144 then 15145 return True; 15146 15147 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then 15148 return False; 15149 15150 elsif Present (Find_Value_Of_Aspect (Typ, Aspect_Iterable)) then 15151 return True; 15152 15153 else 15154 Collect_Interfaces (Typ, Ifaces); 15155 15156 Iface_Elmt := First_Elmt (Ifaces); 15157 while Present (Iface_Elmt) loop 15158 if Denotes_Iterator (Node (Iface_Elmt)) then 15159 return True; 15160 end if; 15161 15162 Next_Elmt (Iface_Elmt); 15163 end loop; 15164 15165 return False; 15166 end if; 15167 end Is_Iterator; 15168 15169 ---------------------------- 15170 -- Is_Iterator_Over_Array -- 15171 ---------------------------- 15172 15173 function Is_Iterator_Over_Array (N : Node_Id) return Boolean is 15174 Container : constant Node_Id := Name (N); 15175 Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); 15176 begin 15177 return Is_Array_Type (Container_Typ); 15178 end Is_Iterator_Over_Array; 15179 15180 ------------ 15181 -- Is_LHS -- 15182 ------------ 15183 15184 -- We seem to have a lot of overlapping functions that do similar things 15185 -- (testing for left hand sides or lvalues???). 15186 15187 function Is_LHS (N : Node_Id) return Is_LHS_Result is 15188 P : constant Node_Id := Parent (N); 15189 15190 begin 15191 -- Return True if we are the left hand side of an assignment statement 15192 15193 if Nkind (P) = N_Assignment_Statement then 15194 if Name (P) = N then 15195 return Yes; 15196 else 15197 return No; 15198 end if; 15199 15200 -- Case of prefix of indexed or selected component or slice 15201 15202 elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice) 15203 and then N = Prefix (P) 15204 then 15205 -- Here we have the case where the parent P is N.Q or N(Q .. R). 15206 -- If P is an LHS, then N is also effectively an LHS, but there 15207 -- is an important exception. If N is of an access type, then 15208 -- what we really have is N.all.Q (or N.all(Q .. R)). In either 15209 -- case this makes N.all a left hand side but not N itself. 15210 15211 -- If we don't know the type yet, this is the case where we return 15212 -- Unknown, since the answer depends on the type which is unknown. 15213 15214 if No (Etype (N)) then 15215 return Unknown; 15216 15217 -- We have an Etype set, so we can check it 15218 15219 elsif Is_Access_Type (Etype (N)) then 15220 return No; 15221 15222 -- OK, not access type case, so just test whole expression 15223 15224 else 15225 return Is_LHS (P); 15226 end if; 15227 15228 -- All other cases are not left hand sides 15229 15230 else 15231 return No; 15232 end if; 15233 end Is_LHS; 15234 15235 ----------------------------- 15236 -- Is_Library_Level_Entity -- 15237 ----------------------------- 15238 15239 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is 15240 begin 15241 -- The following is a small optimization, and it also properly handles 15242 -- discriminals, which in task bodies might appear in expressions before 15243 -- the corresponding procedure has been created, and which therefore do 15244 -- not have an assigned scope. 15245 15246 if Is_Formal (E) then 15247 return False; 15248 end if; 15249 15250 -- Normal test is simply that the enclosing dynamic scope is Standard 15251 15252 return Enclosing_Dynamic_Scope (E) = Standard_Standard; 15253 end Is_Library_Level_Entity; 15254 15255 -------------------------------- 15256 -- Is_Limited_Class_Wide_Type -- 15257 -------------------------------- 15258 15259 function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is 15260 begin 15261 return 15262 Is_Class_Wide_Type (Typ) 15263 and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ)); 15264 end Is_Limited_Class_Wide_Type; 15265 15266 --------------------------------- 15267 -- Is_Local_Variable_Reference -- 15268 --------------------------------- 15269 15270 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is 15271 begin 15272 if not Is_Entity_Name (Expr) then 15273 return False; 15274 15275 else 15276 declare 15277 Ent : constant Entity_Id := Entity (Expr); 15278 Sub : constant Entity_Id := Enclosing_Subprogram (Ent); 15279 begin 15280 if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then 15281 return False; 15282 else 15283 return Present (Sub) and then Sub = Current_Subprogram; 15284 end if; 15285 end; 15286 end if; 15287 end Is_Local_Variable_Reference; 15288 15289 ----------------------- 15290 -- Is_Name_Reference -- 15291 ----------------------- 15292 15293 function Is_Name_Reference (N : Node_Id) return Boolean is 15294 begin 15295 if Is_Entity_Name (N) then 15296 return Present (Entity (N)) and then Is_Object (Entity (N)); 15297 end if; 15298 15299 case Nkind (N) is 15300 when N_Indexed_Component 15301 | N_Slice 15302 => 15303 return 15304 Is_Name_Reference (Prefix (N)) 15305 or else Is_Access_Type (Etype (Prefix (N))); 15306 15307 -- Attributes 'Input, 'Old and 'Result produce objects 15308 15309 when N_Attribute_Reference => 15310 return 15311 Nam_In (Attribute_Name (N), Name_Input, Name_Old, Name_Result); 15312 15313 when N_Selected_Component => 15314 return 15315 Is_Name_Reference (Selector_Name (N)) 15316 and then 15317 (Is_Name_Reference (Prefix (N)) 15318 or else Is_Access_Type (Etype (Prefix (N)))); 15319 15320 when N_Explicit_Dereference => 15321 return True; 15322 15323 -- A view conversion of a tagged name is a name reference 15324 15325 when N_Type_Conversion => 15326 return 15327 Is_Tagged_Type (Etype (Subtype_Mark (N))) 15328 and then Is_Tagged_Type (Etype (Expression (N))) 15329 and then Is_Name_Reference (Expression (N)); 15330 15331 -- An unchecked type conversion is considered to be a name if the 15332 -- operand is a name (this construction arises only as a result of 15333 -- expansion activities). 15334 15335 when N_Unchecked_Type_Conversion => 15336 return Is_Name_Reference (Expression (N)); 15337 15338 when others => 15339 return False; 15340 end case; 15341 end Is_Name_Reference; 15342 15343 ------------------------------------ 15344 -- Is_Non_Preelaborable_Construct -- 15345 ------------------------------------ 15346 15347 function Is_Non_Preelaborable_Construct (N : Node_Id) return Boolean is 15348 15349 -- NOTE: the routines within Is_Non_Preelaborable_Construct are 15350 -- intentionally unnested to avoid deep indentation of code. 15351 15352 Non_Preelaborable : exception; 15353 -- This exception is raised when the construct violates preelaborability 15354 -- to terminate the recursion. 15355 15356 procedure Visit (Nod : Node_Id); 15357 -- Semantically inspect construct Nod to determine whether it violates 15358 -- preelaborability. This routine raises Non_Preelaborable. 15359 15360 procedure Visit_List (List : List_Id); 15361 pragma Inline (Visit_List); 15362 -- Invoke Visit on each element of list List. This routine raises 15363 -- Non_Preelaborable. 15364 15365 procedure Visit_Pragma (Prag : Node_Id); 15366 pragma Inline (Visit_Pragma); 15367 -- Semantically inspect pragma Prag to determine whether it violates 15368 -- preelaborability. This routine raises Non_Preelaborable. 15369 15370 procedure Visit_Subexpression (Expr : Node_Id); 15371 pragma Inline (Visit_Subexpression); 15372 -- Semantically inspect expression Expr to determine whether it violates 15373 -- preelaborability. This routine raises Non_Preelaborable. 15374 15375 ----------- 15376 -- Visit -- 15377 ----------- 15378 15379 procedure Visit (Nod : Node_Id) is 15380 begin 15381 case Nkind (Nod) is 15382 15383 -- Declarations 15384 15385 when N_Component_Declaration => 15386 15387 -- Defining_Identifier is left out because it is not relevant 15388 -- for preelaborability. 15389 15390 Visit (Component_Definition (Nod)); 15391 Visit (Expression (Nod)); 15392 15393 when N_Derived_Type_Definition => 15394 15395 -- Interface_List is left out because it is not relevant for 15396 -- preelaborability. 15397 15398 Visit (Record_Extension_Part (Nod)); 15399 Visit (Subtype_Indication (Nod)); 15400 15401 when N_Entry_Declaration => 15402 15403 -- A protected type with at leat one entry is not preelaborable 15404 -- while task types are never preelaborable. This renders entry 15405 -- declarations non-preelaborable. 15406 15407 raise Non_Preelaborable; 15408 15409 when N_Full_Type_Declaration => 15410 15411 -- Defining_Identifier and Discriminant_Specifications are left 15412 -- out because they are not relevant for preelaborability. 15413 15414 Visit (Type_Definition (Nod)); 15415 15416 when N_Function_Instantiation 15417 | N_Package_Instantiation 15418 | N_Procedure_Instantiation 15419 => 15420 -- Defining_Unit_Name and Name are left out because they are 15421 -- not relevant for preelaborability. 15422 15423 Visit_List (Generic_Associations (Nod)); 15424 15425 when N_Object_Declaration => 15426 15427 -- Defining_Identifier is left out because it is not relevant 15428 -- for preelaborability. 15429 15430 Visit (Object_Definition (Nod)); 15431 15432 if Has_Init_Expression (Nod) then 15433 Visit (Expression (Nod)); 15434 15435 elsif not Has_Preelaborable_Initialization 15436 (Etype (Defining_Entity (Nod))) 15437 then 15438 raise Non_Preelaborable; 15439 end if; 15440 15441 when N_Private_Extension_Declaration 15442 | N_Subtype_Declaration 15443 => 15444 -- Defining_Identifier, Discriminant_Specifications, and 15445 -- Interface_List are left out because they are not relevant 15446 -- for preelaborability. 15447 15448 Visit (Subtype_Indication (Nod)); 15449 15450 when N_Protected_Type_Declaration 15451 | N_Single_Protected_Declaration 15452 => 15453 -- Defining_Identifier, Discriminant_Specifications, and 15454 -- Interface_List are left out because they are not relevant 15455 -- for preelaborability. 15456 15457 Visit (Protected_Definition (Nod)); 15458 15459 -- A [single] task type is never preelaborable 15460 15461 when N_Single_Task_Declaration 15462 | N_Task_Type_Declaration 15463 => 15464 raise Non_Preelaborable; 15465 15466 -- Pragmas 15467 15468 when N_Pragma => 15469 Visit_Pragma (Nod); 15470 15471 -- Statements 15472 15473 when N_Statement_Other_Than_Procedure_Call => 15474 if Nkind (Nod) /= N_Null_Statement then 15475 raise Non_Preelaborable; 15476 end if; 15477 15478 -- Subexpressions 15479 15480 when N_Subexpr => 15481 Visit_Subexpression (Nod); 15482 15483 -- Special 15484 15485 when N_Access_To_Object_Definition => 15486 Visit (Subtype_Indication (Nod)); 15487 15488 when N_Case_Expression_Alternative => 15489 Visit (Expression (Nod)); 15490 Visit_List (Discrete_Choices (Nod)); 15491 15492 when N_Component_Definition => 15493 Visit (Access_Definition (Nod)); 15494 Visit (Subtype_Indication (Nod)); 15495 15496 when N_Component_List => 15497 Visit_List (Component_Items (Nod)); 15498 Visit (Variant_Part (Nod)); 15499 15500 when N_Constrained_Array_Definition => 15501 Visit_List (Discrete_Subtype_Definitions (Nod)); 15502 Visit (Component_Definition (Nod)); 15503 15504 when N_Delta_Constraint 15505 | N_Digits_Constraint 15506 => 15507 -- Delta_Expression and Digits_Expression are left out because 15508 -- they are not relevant for preelaborability. 15509 15510 Visit (Range_Constraint (Nod)); 15511 15512 when N_Discriminant_Specification => 15513 15514 -- Defining_Identifier and Expression are left out because they 15515 -- are not relevant for preelaborability. 15516 15517 Visit (Discriminant_Type (Nod)); 15518 15519 when N_Generic_Association => 15520 15521 -- Selector_Name is left out because it is not relevant for 15522 -- preelaborability. 15523 15524 Visit (Explicit_Generic_Actual_Parameter (Nod)); 15525 15526 when N_Index_Or_Discriminant_Constraint => 15527 Visit_List (Constraints (Nod)); 15528 15529 when N_Iterator_Specification => 15530 15531 -- Defining_Identifier is left out because it is not relevant 15532 -- for preelaborability. 15533 15534 Visit (Name (Nod)); 15535 Visit (Subtype_Indication (Nod)); 15536 15537 when N_Loop_Parameter_Specification => 15538 15539 -- Defining_Identifier is left out because it is not relevant 15540 -- for preelaborability. 15541 15542 Visit (Discrete_Subtype_Definition (Nod)); 15543 15544 when N_Protected_Definition => 15545 15546 -- End_Label is left out because it is not relevant for 15547 -- preelaborability. 15548 15549 Visit_List (Private_Declarations (Nod)); 15550 Visit_List (Visible_Declarations (Nod)); 15551 15552 when N_Range_Constraint => 15553 Visit (Range_Expression (Nod)); 15554 15555 when N_Record_Definition 15556 | N_Variant 15557 => 15558 -- End_Label, Discrete_Choices, and Interface_List are left out 15559 -- because they are not relevant for preelaborability. 15560 15561 Visit (Component_List (Nod)); 15562 15563 when N_Subtype_Indication => 15564 15565 -- Subtype_Mark is left out because it is not relevant for 15566 -- preelaborability. 15567 15568 Visit (Constraint (Nod)); 15569 15570 when N_Unconstrained_Array_Definition => 15571 15572 -- Subtype_Marks is left out because it is not relevant for 15573 -- preelaborability. 15574 15575 Visit (Component_Definition (Nod)); 15576 15577 when N_Variant_Part => 15578 15579 -- Name is left out because it is not relevant for 15580 -- preelaborability. 15581 15582 Visit_List (Variants (Nod)); 15583 15584 -- Default 15585 15586 when others => 15587 null; 15588 end case; 15589 end Visit; 15590 15591 ---------------- 15592 -- Visit_List -- 15593 ---------------- 15594 15595 procedure Visit_List (List : List_Id) is 15596 Nod : Node_Id; 15597 15598 begin 15599 if Present (List) then 15600 Nod := First (List); 15601 while Present (Nod) loop 15602 Visit (Nod); 15603 Next (Nod); 15604 end loop; 15605 end if; 15606 end Visit_List; 15607 15608 ------------------ 15609 -- Visit_Pragma -- 15610 ------------------ 15611 15612 procedure Visit_Pragma (Prag : Node_Id) is 15613 begin 15614 case Get_Pragma_Id (Prag) is 15615 when Pragma_Assert 15616 | Pragma_Assert_And_Cut 15617 | Pragma_Assume 15618 | Pragma_Async_Readers 15619 | Pragma_Async_Writers 15620 | Pragma_Attribute_Definition 15621 | Pragma_Check 15622 | Pragma_Constant_After_Elaboration 15623 | Pragma_CPU 15624 | Pragma_Deadline_Floor 15625 | Pragma_Dispatching_Domain 15626 | Pragma_Effective_Reads 15627 | Pragma_Effective_Writes 15628 | Pragma_Extensions_Visible 15629 | Pragma_Ghost 15630 | Pragma_Secondary_Stack_Size 15631 | Pragma_Task_Name 15632 | Pragma_Volatile_Function 15633 => 15634 Visit_List (Pragma_Argument_Associations (Prag)); 15635 15636 -- Default 15637 15638 when others => 15639 null; 15640 end case; 15641 end Visit_Pragma; 15642 15643 ------------------------- 15644 -- Visit_Subexpression -- 15645 ------------------------- 15646 15647 procedure Visit_Subexpression (Expr : Node_Id) is 15648 procedure Visit_Aggregate (Aggr : Node_Id); 15649 pragma Inline (Visit_Aggregate); 15650 -- Semantically inspect aggregate Aggr to determine whether it 15651 -- violates preelaborability. 15652 15653 --------------------- 15654 -- Visit_Aggregate -- 15655 --------------------- 15656 15657 procedure Visit_Aggregate (Aggr : Node_Id) is 15658 begin 15659 if not Is_Preelaborable_Aggregate (Aggr) then 15660 raise Non_Preelaborable; 15661 end if; 15662 end Visit_Aggregate; 15663 15664 -- Start of processing for Visit_Subexpression 15665 15666 begin 15667 case Nkind (Expr) is 15668 when N_Allocator 15669 | N_Qualified_Expression 15670 | N_Type_Conversion 15671 | N_Unchecked_Expression 15672 | N_Unchecked_Type_Conversion 15673 => 15674 -- Subpool_Handle_Name and Subtype_Mark are left out because 15675 -- they are not relevant for preelaborability. 15676 15677 Visit (Expression (Expr)); 15678 15679 when N_Aggregate 15680 | N_Extension_Aggregate 15681 => 15682 Visit_Aggregate (Expr); 15683 15684 when N_Attribute_Reference 15685 | N_Explicit_Dereference 15686 | N_Reference 15687 => 15688 -- Attribute_Name and Expressions are left out because they are 15689 -- not relevant for preelaborability. 15690 15691 Visit (Prefix (Expr)); 15692 15693 when N_Case_Expression => 15694 15695 -- End_Span is left out because it is not relevant for 15696 -- preelaborability. 15697 15698 Visit_List (Alternatives (Expr)); 15699 Visit (Expression (Expr)); 15700 15701 when N_Delta_Aggregate => 15702 Visit_Aggregate (Expr); 15703 Visit (Expression (Expr)); 15704 15705 when N_Expression_With_Actions => 15706 Visit_List (Actions (Expr)); 15707 Visit (Expression (Expr)); 15708 15709 when N_If_Expression => 15710 Visit_List (Expressions (Expr)); 15711 15712 when N_Quantified_Expression => 15713 Visit (Condition (Expr)); 15714 Visit (Iterator_Specification (Expr)); 15715 Visit (Loop_Parameter_Specification (Expr)); 15716 15717 when N_Range => 15718 Visit (High_Bound (Expr)); 15719 Visit (Low_Bound (Expr)); 15720 15721 when N_Slice => 15722 Visit (Discrete_Range (Expr)); 15723 Visit (Prefix (Expr)); 15724 15725 -- Default 15726 15727 when others => 15728 15729 -- The evaluation of an object name is not preelaborable, 15730 -- unless the name is a static expression (checked further 15731 -- below), or statically denotes a discriminant. 15732 15733 if Is_Entity_Name (Expr) then 15734 Object_Name : declare 15735 Id : constant Entity_Id := Entity (Expr); 15736 15737 begin 15738 if Is_Object (Id) then 15739 if Ekind (Id) = E_Discriminant then 15740 null; 15741 15742 elsif Ekind_In (Id, E_Constant, E_In_Parameter) 15743 and then Present (Discriminal_Link (Id)) 15744 then 15745 null; 15746 15747 else 15748 raise Non_Preelaborable; 15749 end if; 15750 end if; 15751 end Object_Name; 15752 15753 -- A non-static expression is not preelaborable 15754 15755 elsif not Is_OK_Static_Expression (Expr) then 15756 raise Non_Preelaborable; 15757 end if; 15758 end case; 15759 end Visit_Subexpression; 15760 15761 -- Start of processing for Is_Non_Preelaborable_Construct 15762 15763 begin 15764 Visit (N); 15765 15766 -- At this point it is known that the construct is preelaborable 15767 15768 return False; 15769 15770 exception 15771 15772 -- The elaboration of the construct performs an action which violates 15773 -- preelaborability. 15774 15775 when Non_Preelaborable => 15776 return True; 15777 end Is_Non_Preelaborable_Construct; 15778 15779 --------------------------------- 15780 -- Is_Nontrivial_DIC_Procedure -- 15781 --------------------------------- 15782 15783 function Is_Nontrivial_DIC_Procedure (Id : Entity_Id) return Boolean is 15784 Body_Decl : Node_Id; 15785 Stmt : Node_Id; 15786 15787 begin 15788 if Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id) then 15789 Body_Decl := 15790 Unit_Declaration_Node 15791 (Corresponding_Body (Unit_Declaration_Node (Id))); 15792 15793 -- The body of the Default_Initial_Condition procedure must contain 15794 -- at least one statement, otherwise the generation of the subprogram 15795 -- body failed. 15796 15797 pragma Assert (Present (Handled_Statement_Sequence (Body_Decl))); 15798 15799 -- To qualify as nontrivial, the first statement of the procedure 15800 -- must be a check in the form of an if statement. If the original 15801 -- Default_Initial_Condition expression was folded, then the first 15802 -- statement is not a check. 15803 15804 Stmt := First (Statements (Handled_Statement_Sequence (Body_Decl))); 15805 15806 return 15807 Nkind (Stmt) = N_If_Statement 15808 and then Nkind (Original_Node (Stmt)) = N_Pragma; 15809 end if; 15810 15811 return False; 15812 end Is_Nontrivial_DIC_Procedure; 15813 15814 ------------------------- 15815 -- Is_Null_Record_Type -- 15816 ------------------------- 15817 15818 function Is_Null_Record_Type (T : Entity_Id) return Boolean is 15819 Decl : constant Node_Id := Parent (T); 15820 begin 15821 return Nkind (Decl) = N_Full_Type_Declaration 15822 and then Nkind (Type_Definition (Decl)) = N_Record_Definition 15823 and then 15824 (No (Component_List (Type_Definition (Decl))) 15825 or else Null_Present (Component_List (Type_Definition (Decl)))); 15826 end Is_Null_Record_Type; 15827 15828 --------------------- 15829 -- Is_Object_Image -- 15830 --------------------- 15831 15832 function Is_Object_Image (Prefix : Node_Id) return Boolean is 15833 begin 15834 -- When the type of the prefix is not scalar, then the prefix is not 15835 -- valid in any scenario. 15836 15837 if not Is_Scalar_Type (Etype (Prefix)) then 15838 return False; 15839 end if; 15840 15841 -- Here we test for the case that the prefix is not a type and assume 15842 -- if it is not then it must be a named value or an object reference. 15843 -- This is because the parser always checks that prefixes of attributes 15844 -- are named. 15845 15846 return not (Is_Entity_Name (Prefix) and then Is_Type (Entity (Prefix))); 15847 end Is_Object_Image; 15848 15849 ------------------------- 15850 -- Is_Object_Reference -- 15851 ------------------------- 15852 15853 function Is_Object_Reference (N : Node_Id) return Boolean is 15854 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean; 15855 -- Determine whether N is the name of an internally-generated renaming 15856 15857 -------------------------------------- 15858 -- Is_Internally_Generated_Renaming -- 15859 -------------------------------------- 15860 15861 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is 15862 P : Node_Id; 15863 15864 begin 15865 P := N; 15866 while Present (P) loop 15867 if Nkind (P) = N_Object_Renaming_Declaration then 15868 return not Comes_From_Source (P); 15869 elsif Is_List_Member (P) then 15870 return False; 15871 end if; 15872 15873 P := Parent (P); 15874 end loop; 15875 15876 return False; 15877 end Is_Internally_Generated_Renaming; 15878 15879 -- Start of processing for Is_Object_Reference 15880 15881 begin 15882 if Is_Entity_Name (N) then 15883 return Present (Entity (N)) and then Is_Object (Entity (N)); 15884 15885 else 15886 case Nkind (N) is 15887 when N_Indexed_Component 15888 | N_Slice 15889 => 15890 return 15891 Is_Object_Reference (Prefix (N)) 15892 or else Is_Access_Type (Etype (Prefix (N))); 15893 15894 -- In Ada 95, a function call is a constant object; a procedure 15895 -- call is not. 15896 15897 -- Note that predefined operators are functions as well, and so 15898 -- are attributes that are (can be renamed as) functions. 15899 15900 when N_Binary_Op 15901 | N_Function_Call 15902 | N_Unary_Op 15903 => 15904 return Etype (N) /= Standard_Void_Type; 15905 15906 -- Attributes references 'Loop_Entry, 'Old, and 'Result yield 15907 -- objects, even though they are not functions. 15908 15909 when N_Attribute_Reference => 15910 return 15911 Nam_In (Attribute_Name (N), Name_Loop_Entry, 15912 Name_Old, 15913 Name_Result) 15914 or else Is_Function_Attribute_Name (Attribute_Name (N)); 15915 15916 when N_Selected_Component => 15917 return 15918 Is_Object_Reference (Selector_Name (N)) 15919 and then 15920 (Is_Object_Reference (Prefix (N)) 15921 or else Is_Access_Type (Etype (Prefix (N)))); 15922 15923 -- An explicit dereference denotes an object, except that a 15924 -- conditional expression gets turned into an explicit dereference 15925 -- in some cases, and conditional expressions are not object 15926 -- names. 15927 15928 when N_Explicit_Dereference => 15929 return not Nkind_In (Original_Node (N), N_Case_Expression, 15930 N_If_Expression); 15931 15932 -- A view conversion of a tagged object is an object reference 15933 15934 when N_Type_Conversion => 15935 return Is_Tagged_Type (Etype (Subtype_Mark (N))) 15936 and then Is_Tagged_Type (Etype (Expression (N))) 15937 and then Is_Object_Reference (Expression (N)); 15938 15939 -- An unchecked type conversion is considered to be an object if 15940 -- the operand is an object (this construction arises only as a 15941 -- result of expansion activities). 15942 15943 when N_Unchecked_Type_Conversion => 15944 return True; 15945 15946 -- Allow string literals to act as objects as long as they appear 15947 -- in internally-generated renamings. The expansion of iterators 15948 -- may generate such renamings when the range involves a string 15949 -- literal. 15950 15951 when N_String_Literal => 15952 return Is_Internally_Generated_Renaming (Parent (N)); 15953 15954 -- AI05-0003: In Ada 2012 a qualified expression is a name. 15955 -- This allows disambiguation of function calls and the use 15956 -- of aggregates in more contexts. 15957 15958 when N_Qualified_Expression => 15959 if Ada_Version < Ada_2012 then 15960 return False; 15961 else 15962 return Is_Object_Reference (Expression (N)) 15963 or else Nkind (Expression (N)) = N_Aggregate; 15964 end if; 15965 15966 when others => 15967 return False; 15968 end case; 15969 end if; 15970 end Is_Object_Reference; 15971 15972 ----------------------------------- 15973 -- Is_OK_Variable_For_Out_Formal -- 15974 ----------------------------------- 15975 15976 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is 15977 begin 15978 Note_Possible_Modification (AV, Sure => True); 15979 15980 -- We must reject parenthesized variable names. Comes_From_Source is 15981 -- checked because there are currently cases where the compiler violates 15982 -- this rule (e.g. passing a task object to its controlled Initialize 15983 -- routine). This should be properly documented in sinfo??? 15984 15985 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then 15986 return False; 15987 15988 -- A variable is always allowed 15989 15990 elsif Is_Variable (AV) then 15991 return True; 15992 15993 -- Generalized indexing operations are rewritten as explicit 15994 -- dereferences, and it is only during resolution that we can 15995 -- check whether the context requires an access_to_variable type. 15996 15997 elsif Nkind (AV) = N_Explicit_Dereference 15998 and then Ada_Version >= Ada_2012 15999 and then Nkind (Original_Node (AV)) = N_Indexed_Component 16000 and then Present (Etype (Original_Node (AV))) 16001 and then Has_Implicit_Dereference (Etype (Original_Node (AV))) 16002 then 16003 return not Is_Access_Constant (Etype (Prefix (AV))); 16004 16005 -- Unchecked conversions are allowed only if they come from the 16006 -- generated code, which sometimes uses unchecked conversions for out 16007 -- parameters in cases where code generation is unaffected. We tell 16008 -- source unchecked conversions by seeing if they are rewrites of 16009 -- an original Unchecked_Conversion function call, or of an explicit 16010 -- conversion of a function call or an aggregate (as may happen in the 16011 -- expansion of a packed array aggregate). 16012 16013 elsif Nkind (AV) = N_Unchecked_Type_Conversion then 16014 if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then 16015 return False; 16016 16017 elsif Comes_From_Source (AV) 16018 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call 16019 then 16020 return False; 16021 16022 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then 16023 return Is_OK_Variable_For_Out_Formal (Expression (AV)); 16024 16025 else 16026 return True; 16027 end if; 16028 16029 -- Normal type conversions are allowed if argument is a variable 16030 16031 elsif Nkind (AV) = N_Type_Conversion then 16032 if Is_Variable (Expression (AV)) 16033 and then Paren_Count (Expression (AV)) = 0 16034 then 16035 Note_Possible_Modification (Expression (AV), Sure => True); 16036 return True; 16037 16038 -- We also allow a non-parenthesized expression that raises 16039 -- constraint error if it rewrites what used to be a variable 16040 16041 elsif Raises_Constraint_Error (Expression (AV)) 16042 and then Paren_Count (Expression (AV)) = 0 16043 and then Is_Variable (Original_Node (Expression (AV))) 16044 then 16045 return True; 16046 16047 -- Type conversion of something other than a variable 16048 16049 else 16050 return False; 16051 end if; 16052 16053 -- If this node is rewritten, then test the original form, if that is 16054 -- OK, then we consider the rewritten node OK (for example, if the 16055 -- original node is a conversion, then Is_Variable will not be true 16056 -- but we still want to allow the conversion if it converts a variable). 16057 16058 elsif Is_Rewrite_Substitution (AV) then 16059 16060 -- In Ada 2012, the explicit dereference may be a rewritten call to a 16061 -- Reference function. 16062 16063 if Ada_Version >= Ada_2012 16064 and then Nkind (Original_Node (AV)) = N_Function_Call 16065 and then 16066 Has_Implicit_Dereference (Etype (Name (Original_Node (AV)))) 16067 then 16068 16069 -- Check that this is not a constant reference. 16070 16071 return not Is_Access_Constant (Etype (Prefix (AV))); 16072 16073 elsif Has_Implicit_Dereference (Etype (Original_Node (AV))) then 16074 return 16075 not Is_Access_Constant (Etype 16076 (Get_Reference_Discriminant (Etype (Original_Node (AV))))); 16077 16078 else 16079 return Is_OK_Variable_For_Out_Formal (Original_Node (AV)); 16080 end if; 16081 16082 -- All other non-variables are rejected 16083 16084 else 16085 return False; 16086 end if; 16087 end Is_OK_Variable_For_Out_Formal; 16088 16089 ---------------------------- 16090 -- Is_OK_Volatile_Context -- 16091 ---------------------------- 16092 16093 function Is_OK_Volatile_Context 16094 (Context : Node_Id; 16095 Obj_Ref : Node_Id) return Boolean 16096 is 16097 function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean; 16098 -- Determine whether an arbitrary node denotes a call to a protected 16099 -- entry, function, or procedure in prefixed form where the prefix is 16100 -- Obj_Ref. 16101 16102 function Within_Check (Nod : Node_Id) return Boolean; 16103 -- Determine whether an arbitrary node appears in a check node 16104 16105 function Within_Volatile_Function (Id : Entity_Id) return Boolean; 16106 -- Determine whether an arbitrary entity appears in a volatile function 16107 16108 --------------------------------- 16109 -- Is_Protected_Operation_Call -- 16110 --------------------------------- 16111 16112 function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean is 16113 Pref : Node_Id; 16114 Subp : Node_Id; 16115 16116 begin 16117 -- A call to a protected operations retains its selected component 16118 -- form as opposed to other prefixed calls that are transformed in 16119 -- expanded names. 16120 16121 if Nkind (Nod) = N_Selected_Component then 16122 Pref := Prefix (Nod); 16123 Subp := Selector_Name (Nod); 16124 16125 return 16126 Pref = Obj_Ref 16127 and then Present (Etype (Pref)) 16128 and then Is_Protected_Type (Etype (Pref)) 16129 and then Is_Entity_Name (Subp) 16130 and then Present (Entity (Subp)) 16131 and then Ekind_In (Entity (Subp), E_Entry, 16132 E_Entry_Family, 16133 E_Function, 16134 E_Procedure); 16135 else 16136 return False; 16137 end if; 16138 end Is_Protected_Operation_Call; 16139 16140 ------------------ 16141 -- Within_Check -- 16142 ------------------ 16143 16144 function Within_Check (Nod : Node_Id) return Boolean is 16145 Par : Node_Id; 16146 16147 begin 16148 -- Climb the parent chain looking for a check node 16149 16150 Par := Nod; 16151 while Present (Par) loop 16152 if Nkind (Par) in N_Raise_xxx_Error then 16153 return True; 16154 16155 -- Prevent the search from going too far 16156 16157 elsif Is_Body_Or_Package_Declaration (Par) then 16158 exit; 16159 end if; 16160 16161 Par := Parent (Par); 16162 end loop; 16163 16164 return False; 16165 end Within_Check; 16166 16167 ------------------------------ 16168 -- Within_Volatile_Function -- 16169 ------------------------------ 16170 16171 function Within_Volatile_Function (Id : Entity_Id) return Boolean is 16172 Func_Id : Entity_Id; 16173 16174 begin 16175 -- Traverse the scope stack looking for a [generic] function 16176 16177 Func_Id := Id; 16178 while Present (Func_Id) and then Func_Id /= Standard_Standard loop 16179 if Ekind_In (Func_Id, E_Function, E_Generic_Function) then 16180 return Is_Volatile_Function (Func_Id); 16181 end if; 16182 16183 Func_Id := Scope (Func_Id); 16184 end loop; 16185 16186 return False; 16187 end Within_Volatile_Function; 16188 16189 -- Local variables 16190 16191 Obj_Id : Entity_Id; 16192 16193 -- Start of processing for Is_OK_Volatile_Context 16194 16195 begin 16196 -- The volatile object appears on either side of an assignment 16197 16198 if Nkind (Context) = N_Assignment_Statement then 16199 return True; 16200 16201 -- The volatile object is part of the initialization expression of 16202 -- another object. 16203 16204 elsif Nkind (Context) = N_Object_Declaration 16205 and then Present (Expression (Context)) 16206 and then Expression (Context) = Obj_Ref 16207 then 16208 Obj_Id := Defining_Entity (Context); 16209 16210 -- The volatile object acts as the initialization expression of an 16211 -- extended return statement. This is valid context as long as the 16212 -- function is volatile. 16213 16214 if Is_Return_Object (Obj_Id) then 16215 return Within_Volatile_Function (Obj_Id); 16216 16217 -- Otherwise this is a normal object initialization 16218 16219 else 16220 return True; 16221 end if; 16222 16223 -- The volatile object acts as the name of a renaming declaration 16224 16225 elsif Nkind (Context) = N_Object_Renaming_Declaration 16226 and then Name (Context) = Obj_Ref 16227 then 16228 return True; 16229 16230 -- The volatile object appears as an actual parameter in a call to an 16231 -- instance of Unchecked_Conversion whose result is renamed. 16232 16233 elsif Nkind (Context) = N_Function_Call 16234 and then Is_Entity_Name (Name (Context)) 16235 and then Is_Unchecked_Conversion_Instance (Entity (Name (Context))) 16236 and then Nkind (Parent (Context)) = N_Object_Renaming_Declaration 16237 then 16238 return True; 16239 16240 -- The volatile object is actually the prefix in a protected entry, 16241 -- function, or procedure call. 16242 16243 elsif Is_Protected_Operation_Call (Context) then 16244 return True; 16245 16246 -- The volatile object appears as the expression of a simple return 16247 -- statement that applies to a volatile function. 16248 16249 elsif Nkind (Context) = N_Simple_Return_Statement 16250 and then Expression (Context) = Obj_Ref 16251 then 16252 return 16253 Within_Volatile_Function (Return_Statement_Entity (Context)); 16254 16255 -- The volatile object appears as the prefix of a name occurring in a 16256 -- non-interfering context. 16257 16258 elsif Nkind_In (Context, N_Attribute_Reference, 16259 N_Explicit_Dereference, 16260 N_Indexed_Component, 16261 N_Selected_Component, 16262 N_Slice) 16263 and then Prefix (Context) = Obj_Ref 16264 and then Is_OK_Volatile_Context 16265 (Context => Parent (Context), 16266 Obj_Ref => Context) 16267 then 16268 return True; 16269 16270 -- The volatile object appears as the prefix of attributes Address, 16271 -- Alignment, Component_Size, First, First_Bit, Last, Last_Bit, Length, 16272 -- Position, Size, Storage_Size. 16273 16274 elsif Nkind (Context) = N_Attribute_Reference 16275 and then Prefix (Context) = Obj_Ref 16276 and then Nam_In (Attribute_Name (Context), Name_Address, 16277 Name_Alignment, 16278 Name_Component_Size, 16279 Name_First, 16280 Name_First_Bit, 16281 Name_Last, 16282 Name_Last_Bit, 16283 Name_Length, 16284 Name_Position, 16285 Name_Size, 16286 Name_Storage_Size) 16287 then 16288 return True; 16289 16290 -- The volatile object appears as the expression of a type conversion 16291 -- occurring in a non-interfering context. 16292 16293 elsif Nkind_In (Context, N_Type_Conversion, 16294 N_Unchecked_Type_Conversion) 16295 and then Expression (Context) = Obj_Ref 16296 and then Is_OK_Volatile_Context 16297 (Context => Parent (Context), 16298 Obj_Ref => Context) 16299 then 16300 return True; 16301 16302 -- The volatile object appears as the expression in a delay statement 16303 16304 elsif Nkind (Context) in N_Delay_Statement then 16305 return True; 16306 16307 -- Allow references to volatile objects in various checks. This is not a 16308 -- direct SPARK 2014 requirement. 16309 16310 elsif Within_Check (Context) then 16311 return True; 16312 16313 -- Assume that references to effectively volatile objects that appear 16314 -- as actual parameters in a subprogram call are always legal. A full 16315 -- legality check is done when the actuals are resolved (see routine 16316 -- Resolve_Actuals). 16317 16318 elsif Within_Subprogram_Call (Context) then 16319 return True; 16320 16321 -- Otherwise the context is not suitable for an effectively volatile 16322 -- object. 16323 16324 else 16325 return False; 16326 end if; 16327 end Is_OK_Volatile_Context; 16328 16329 ------------------------------------ 16330 -- Is_Package_Contract_Annotation -- 16331 ------------------------------------ 16332 16333 function Is_Package_Contract_Annotation (Item : Node_Id) return Boolean is 16334 Nam : Name_Id; 16335 16336 begin 16337 if Nkind (Item) = N_Aspect_Specification then 16338 Nam := Chars (Identifier (Item)); 16339 16340 else pragma Assert (Nkind (Item) = N_Pragma); 16341 Nam := Pragma_Name (Item); 16342 end if; 16343 16344 return Nam = Name_Abstract_State 16345 or else Nam = Name_Initial_Condition 16346 or else Nam = Name_Initializes 16347 or else Nam = Name_Refined_State; 16348 end Is_Package_Contract_Annotation; 16349 16350 ----------------------------------- 16351 -- Is_Partially_Initialized_Type -- 16352 ----------------------------------- 16353 16354 function Is_Partially_Initialized_Type 16355 (Typ : Entity_Id; 16356 Include_Implicit : Boolean := True) return Boolean 16357 is 16358 begin 16359 if Is_Scalar_Type (Typ) then 16360 return False; 16361 16362 elsif Is_Access_Type (Typ) then 16363 return Include_Implicit; 16364 16365 elsif Is_Array_Type (Typ) then 16366 16367 -- If component type is partially initialized, so is array type 16368 16369 if Is_Partially_Initialized_Type 16370 (Component_Type (Typ), Include_Implicit) 16371 then 16372 return True; 16373 16374 -- Otherwise we are only partially initialized if we are fully 16375 -- initialized (this is the empty array case, no point in us 16376 -- duplicating that code here). 16377 16378 else 16379 return Is_Fully_Initialized_Type (Typ); 16380 end if; 16381 16382 elsif Is_Record_Type (Typ) then 16383 16384 -- A discriminated type is always partially initialized if in 16385 -- all mode 16386 16387 if Has_Discriminants (Typ) and then Include_Implicit then 16388 return True; 16389 16390 -- A tagged type is always partially initialized 16391 16392 elsif Is_Tagged_Type (Typ) then 16393 return True; 16394 16395 -- Case of non-discriminated record 16396 16397 else 16398 declare 16399 Ent : Entity_Id; 16400 16401 Component_Present : Boolean := False; 16402 -- Set True if at least one component is present. If no 16403 -- components are present, then record type is fully 16404 -- initialized (another odd case, like the null array). 16405 16406 begin 16407 -- Loop through components 16408 16409 Ent := First_Entity (Typ); 16410 while Present (Ent) loop 16411 if Ekind (Ent) = E_Component then 16412 Component_Present := True; 16413 16414 -- If a component has an initialization expression then 16415 -- the enclosing record type is partially initialized 16416 16417 if Present (Parent (Ent)) 16418 and then Present (Expression (Parent (Ent))) 16419 then 16420 return True; 16421 16422 -- If a component is of a type which is itself partially 16423 -- initialized, then the enclosing record type is also. 16424 16425 elsif Is_Partially_Initialized_Type 16426 (Etype (Ent), Include_Implicit) 16427 then 16428 return True; 16429 end if; 16430 end if; 16431 16432 Next_Entity (Ent); 16433 end loop; 16434 16435 -- No initialized components found. If we found any components 16436 -- they were all uninitialized so the result is false. 16437 16438 if Component_Present then 16439 return False; 16440 16441 -- But if we found no components, then all the components are 16442 -- initialized so we consider the type to be initialized. 16443 16444 else 16445 return True; 16446 end if; 16447 end; 16448 end if; 16449 16450 -- Concurrent types are always fully initialized 16451 16452 elsif Is_Concurrent_Type (Typ) then 16453 return True; 16454 16455 -- For a private type, go to underlying type. If there is no underlying 16456 -- type then just assume this partially initialized. Not clear if this 16457 -- can happen in a non-error case, but no harm in testing for this. 16458 16459 elsif Is_Private_Type (Typ) then 16460 declare 16461 U : constant Entity_Id := Underlying_Type (Typ); 16462 begin 16463 if No (U) then 16464 return True; 16465 else 16466 return Is_Partially_Initialized_Type (U, Include_Implicit); 16467 end if; 16468 end; 16469 16470 -- For any other type (are there any?) assume partially initialized 16471 16472 else 16473 return True; 16474 end if; 16475 end Is_Partially_Initialized_Type; 16476 16477 ------------------------------------ 16478 -- Is_Potentially_Persistent_Type -- 16479 ------------------------------------ 16480 16481 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is 16482 Comp : Entity_Id; 16483 Indx : Node_Id; 16484 16485 begin 16486 -- For private type, test corresponding full type 16487 16488 if Is_Private_Type (T) then 16489 return Is_Potentially_Persistent_Type (Full_View (T)); 16490 16491 -- Scalar types are potentially persistent 16492 16493 elsif Is_Scalar_Type (T) then 16494 return True; 16495 16496 -- Record type is potentially persistent if not tagged and the types of 16497 -- all it components are potentially persistent, and no component has 16498 -- an initialization expression. 16499 16500 elsif Is_Record_Type (T) 16501 and then not Is_Tagged_Type (T) 16502 and then not Is_Partially_Initialized_Type (T) 16503 then 16504 Comp := First_Component (T); 16505 while Present (Comp) loop 16506 if not Is_Potentially_Persistent_Type (Etype (Comp)) then 16507 return False; 16508 else 16509 Next_Entity (Comp); 16510 end if; 16511 end loop; 16512 16513 return True; 16514 16515 -- Array type is potentially persistent if its component type is 16516 -- potentially persistent and if all its constraints are static. 16517 16518 elsif Is_Array_Type (T) then 16519 if not Is_Potentially_Persistent_Type (Component_Type (T)) then 16520 return False; 16521 end if; 16522 16523 Indx := First_Index (T); 16524 while Present (Indx) loop 16525 if not Is_OK_Static_Subtype (Etype (Indx)) then 16526 return False; 16527 else 16528 Next_Index (Indx); 16529 end if; 16530 end loop; 16531 16532 return True; 16533 16534 -- All other types are not potentially persistent 16535 16536 else 16537 return False; 16538 end if; 16539 end Is_Potentially_Persistent_Type; 16540 16541 -------------------------------- 16542 -- Is_Potentially_Unevaluated -- 16543 -------------------------------- 16544 16545 function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is 16546 Par : Node_Id; 16547 Expr : Node_Id; 16548 16549 begin 16550 Expr := N; 16551 Par := N; 16552 16553 -- A postcondition whose expression is a short-circuit is broken down 16554 -- into individual aspects for better exception reporting. The original 16555 -- short-circuit expression is rewritten as the second operand, and an 16556 -- occurrence of 'Old in that operand is potentially unevaluated. 16557 -- See sem_ch13.adb for details of this transformation. The reference 16558 -- to 'Old may appear within an expression, so we must look for the 16559 -- enclosing pragma argument in the tree that contains the reference. 16560 16561 while Present (Par) 16562 and then Nkind (Par) /= N_Pragma_Argument_Association 16563 loop 16564 if Is_Rewrite_Substitution (Par) 16565 and then Nkind (Original_Node (Par)) = N_And_Then 16566 then 16567 return True; 16568 end if; 16569 16570 Par := Parent (Par); 16571 end loop; 16572 16573 -- Other cases; 'Old appears within other expression (not the top-level 16574 -- conjunct in a postcondition) with a potentially unevaluated operand. 16575 16576 Par := Parent (Expr); 16577 while not Nkind_In (Par, N_And_Then, 16578 N_Case_Expression, 16579 N_If_Expression, 16580 N_In, 16581 N_Not_In, 16582 N_Or_Else, 16583 N_Quantified_Expression) 16584 loop 16585 Expr := Par; 16586 Par := Parent (Par); 16587 16588 -- If the context is not an expression, or if is the result of 16589 -- expansion of an enclosing construct (such as another attribute) 16590 -- the predicate does not apply. 16591 16592 if Nkind (Par) = N_Case_Expression_Alternative then 16593 null; 16594 16595 elsif Nkind (Par) not in N_Subexpr 16596 or else not Comes_From_Source (Par) 16597 then 16598 return False; 16599 end if; 16600 end loop; 16601 16602 if Nkind (Par) = N_If_Expression then 16603 return Is_Elsif (Par) or else Expr /= First (Expressions (Par)); 16604 16605 elsif Nkind (Par) = N_Case_Expression then 16606 return Expr /= Expression (Par); 16607 16608 elsif Nkind_In (Par, N_And_Then, N_Or_Else) then 16609 return Expr = Right_Opnd (Par); 16610 16611 elsif Nkind_In (Par, N_In, N_Not_In) then 16612 16613 -- If the membership includes several alternatives, only the first is 16614 -- definitely evaluated. 16615 16616 if Present (Alternatives (Par)) then 16617 return Expr /= First (Alternatives (Par)); 16618 16619 -- If this is a range membership both bounds are evaluated 16620 16621 else 16622 return False; 16623 end if; 16624 16625 elsif Nkind (Par) = N_Quantified_Expression then 16626 return Expr = Condition (Par); 16627 16628 else 16629 return False; 16630 end if; 16631 end Is_Potentially_Unevaluated; 16632 16633 ----------------------------------------- 16634 -- Is_Predefined_Dispatching_Operation -- 16635 ----------------------------------------- 16636 16637 function Is_Predefined_Dispatching_Operation 16638 (E : Entity_Id) return Boolean 16639 is 16640 TSS_Name : TSS_Name_Type; 16641 16642 begin 16643 if not Is_Dispatching_Operation (E) then 16644 return False; 16645 end if; 16646 16647 Get_Name_String (Chars (E)); 16648 16649 -- Most predefined primitives have internally generated names. Equality 16650 -- must be treated differently; the predefined operation is recognized 16651 -- as a homogeneous binary operator that returns Boolean. 16652 16653 if Name_Len > TSS_Name_Type'Last then 16654 TSS_Name := 16655 TSS_Name_Type 16656 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); 16657 16658 if Nam_In (Chars (E), Name_uAssign, Name_uSize) 16659 or else 16660 (Chars (E) = Name_Op_Eq 16661 and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) 16662 or else TSS_Name = TSS_Deep_Adjust 16663 or else TSS_Name = TSS_Deep_Finalize 16664 or else TSS_Name = TSS_Stream_Input 16665 or else TSS_Name = TSS_Stream_Output 16666 or else TSS_Name = TSS_Stream_Read 16667 or else TSS_Name = TSS_Stream_Write 16668 or else Is_Predefined_Interface_Primitive (E) 16669 then 16670 return True; 16671 end if; 16672 end if; 16673 16674 return False; 16675 end Is_Predefined_Dispatching_Operation; 16676 16677 --------------------------------------- 16678 -- Is_Predefined_Interface_Primitive -- 16679 --------------------------------------- 16680 16681 function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is 16682 begin 16683 -- In VM targets we don't restrict the functionality of this test to 16684 -- compiling in Ada 2005 mode since in VM targets any tagged type has 16685 -- these primitives. 16686 16687 return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion) 16688 and then Nam_In (Chars (E), Name_uDisp_Asynchronous_Select, 16689 Name_uDisp_Conditional_Select, 16690 Name_uDisp_Get_Prim_Op_Kind, 16691 Name_uDisp_Get_Task_Id, 16692 Name_uDisp_Requeue, 16693 Name_uDisp_Timed_Select); 16694 end Is_Predefined_Interface_Primitive; 16695 16696 --------------------------------------- 16697 -- Is_Predefined_Internal_Operation -- 16698 --------------------------------------- 16699 16700 function Is_Predefined_Internal_Operation 16701 (E : Entity_Id) return Boolean 16702 is 16703 TSS_Name : TSS_Name_Type; 16704 16705 begin 16706 if not Is_Dispatching_Operation (E) then 16707 return False; 16708 end if; 16709 16710 Get_Name_String (Chars (E)); 16711 16712 -- Most predefined primitives have internally generated names. Equality 16713 -- must be treated differently; the predefined operation is recognized 16714 -- as a homogeneous binary operator that returns Boolean. 16715 16716 if Name_Len > TSS_Name_Type'Last then 16717 TSS_Name := 16718 TSS_Name_Type 16719 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); 16720 16721 if Nam_In (Chars (E), Name_uSize, Name_uAssign) 16722 or else 16723 (Chars (E) = Name_Op_Eq 16724 and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) 16725 or else TSS_Name = TSS_Deep_Adjust 16726 or else TSS_Name = TSS_Deep_Finalize 16727 or else Is_Predefined_Interface_Primitive (E) 16728 then 16729 return True; 16730 end if; 16731 end if; 16732 16733 return False; 16734 end Is_Predefined_Internal_Operation; 16735 16736 -------------------------------- 16737 -- Is_Preelaborable_Aggregate -- 16738 -------------------------------- 16739 16740 function Is_Preelaborable_Aggregate (Aggr : Node_Id) return Boolean is 16741 Aggr_Typ : constant Entity_Id := Etype (Aggr); 16742 Array_Aggr : constant Boolean := Is_Array_Type (Aggr_Typ); 16743 16744 Anc_Part : Node_Id; 16745 Assoc : Node_Id; 16746 Choice : Node_Id; 16747 Comp_Typ : Entity_Id := Empty; -- init to avoid warning 16748 Expr : Node_Id; 16749 16750 begin 16751 if Array_Aggr then 16752 Comp_Typ := Component_Type (Aggr_Typ); 16753 end if; 16754 16755 -- Inspect the ancestor part 16756 16757 if Nkind (Aggr) = N_Extension_Aggregate then 16758 Anc_Part := Ancestor_Part (Aggr); 16759 16760 -- The ancestor denotes a subtype mark 16761 16762 if Is_Entity_Name (Anc_Part) 16763 and then Is_Type (Entity (Anc_Part)) 16764 then 16765 if not Has_Preelaborable_Initialization (Entity (Anc_Part)) then 16766 return False; 16767 end if; 16768 16769 -- Otherwise the ancestor denotes an expression 16770 16771 elsif not Is_Preelaborable_Construct (Anc_Part) then 16772 return False; 16773 end if; 16774 end if; 16775 16776 -- Inspect the positional associations 16777 16778 Expr := First (Expressions (Aggr)); 16779 while Present (Expr) loop 16780 if not Is_Preelaborable_Construct (Expr) then 16781 return False; 16782 end if; 16783 16784 Next (Expr); 16785 end loop; 16786 16787 -- Inspect the named associations 16788 16789 Assoc := First (Component_Associations (Aggr)); 16790 while Present (Assoc) loop 16791 16792 -- Inspect the choices of the current named association 16793 16794 Choice := First (Choices (Assoc)); 16795 while Present (Choice) loop 16796 if Array_Aggr then 16797 16798 -- For a choice to be preelaborable, it must denote either a 16799 -- static range or a static expression. 16800 16801 if Nkind (Choice) = N_Others_Choice then 16802 null; 16803 16804 elsif Nkind (Choice) = N_Range then 16805 if not Is_OK_Static_Range (Choice) then 16806 return False; 16807 end if; 16808 16809 elsif not Is_OK_Static_Expression (Choice) then 16810 return False; 16811 end if; 16812 16813 else 16814 Comp_Typ := Etype (Choice); 16815 end if; 16816 16817 Next (Choice); 16818 end loop; 16819 16820 -- The type of the choice must have preelaborable initialization if 16821 -- the association carries a <>. 16822 16823 pragma Assert (Present (Comp_Typ)); 16824 if Box_Present (Assoc) then 16825 if not Has_Preelaborable_Initialization (Comp_Typ) then 16826 return False; 16827 end if; 16828 16829 -- The type of the expression must have preelaborable initialization 16830 16831 elsif not Is_Preelaborable_Construct (Expression (Assoc)) then 16832 return False; 16833 end if; 16834 16835 Next (Assoc); 16836 end loop; 16837 16838 -- At this point the aggregate is preelaborable 16839 16840 return True; 16841 end Is_Preelaborable_Aggregate; 16842 16843 -------------------------------- 16844 -- Is_Preelaborable_Construct -- 16845 -------------------------------- 16846 16847 function Is_Preelaborable_Construct (N : Node_Id) return Boolean is 16848 begin 16849 -- Aggregates 16850 16851 if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then 16852 return Is_Preelaborable_Aggregate (N); 16853 16854 -- Attributes are allowed in general, even if their prefix is a formal 16855 -- type. It seems that certain attributes known not to be static might 16856 -- not be allowed, but there are no rules to prevent them. 16857 16858 elsif Nkind (N) = N_Attribute_Reference then 16859 return True; 16860 16861 -- Expressions 16862 16863 elsif Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then 16864 return True; 16865 16866 elsif Nkind (N) = N_Qualified_Expression then 16867 return Is_Preelaborable_Construct (Expression (N)); 16868 16869 -- Names are preelaborable when they denote a discriminant of an 16870 -- enclosing type. Discriminals are also considered for this check. 16871 16872 elsif Is_Entity_Name (N) 16873 and then Present (Entity (N)) 16874 and then 16875 (Ekind (Entity (N)) = E_Discriminant 16876 or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter) 16877 and then Present (Discriminal_Link (Entity (N))))) 16878 then 16879 return True; 16880 16881 -- Statements 16882 16883 elsif Nkind (N) = N_Null then 16884 return True; 16885 16886 -- Otherwise the construct is not preelaborable 16887 16888 else 16889 return False; 16890 end if; 16891 end Is_Preelaborable_Construct; 16892 16893 --------------------------------- 16894 -- Is_Protected_Self_Reference -- 16895 --------------------------------- 16896 16897 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is 16898 16899 function In_Access_Definition (N : Node_Id) return Boolean; 16900 -- Returns true if N belongs to an access definition 16901 16902 -------------------------- 16903 -- In_Access_Definition -- 16904 -------------------------- 16905 16906 function In_Access_Definition (N : Node_Id) return Boolean is 16907 P : Node_Id; 16908 16909 begin 16910 P := Parent (N); 16911 while Present (P) loop 16912 if Nkind (P) = N_Access_Definition then 16913 return True; 16914 end if; 16915 16916 P := Parent (P); 16917 end loop; 16918 16919 return False; 16920 end In_Access_Definition; 16921 16922 -- Start of processing for Is_Protected_Self_Reference 16923 16924 begin 16925 -- Verify that prefix is analyzed and has the proper form. Note that 16926 -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also 16927 -- produce the address of an entity, do not analyze their prefix 16928 -- because they denote entities that are not necessarily visible. 16929 -- Neither of them can apply to a protected type. 16930 16931 return Ada_Version >= Ada_2005 16932 and then Is_Entity_Name (N) 16933 and then Present (Entity (N)) 16934 and then Is_Protected_Type (Entity (N)) 16935 and then In_Open_Scopes (Entity (N)) 16936 and then not In_Access_Definition (N); 16937 end Is_Protected_Self_Reference; 16938 16939 ----------------------------- 16940 -- Is_RCI_Pkg_Spec_Or_Body -- 16941 ----------------------------- 16942 16943 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is 16944 16945 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean; 16946 -- Return True if the unit of Cunit is an RCI package declaration 16947 16948 --------------------------- 16949 -- Is_RCI_Pkg_Decl_Cunit -- 16950 --------------------------- 16951 16952 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is 16953 The_Unit : constant Node_Id := Unit (Cunit); 16954 16955 begin 16956 if Nkind (The_Unit) /= N_Package_Declaration then 16957 return False; 16958 end if; 16959 16960 return Is_Remote_Call_Interface (Defining_Entity (The_Unit)); 16961 end Is_RCI_Pkg_Decl_Cunit; 16962 16963 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body 16964 16965 begin 16966 return Is_RCI_Pkg_Decl_Cunit (Cunit) 16967 or else 16968 (Nkind (Unit (Cunit)) = N_Package_Body 16969 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit))); 16970 end Is_RCI_Pkg_Spec_Or_Body; 16971 16972 ----------------------------------------- 16973 -- Is_Remote_Access_To_Class_Wide_Type -- 16974 ----------------------------------------- 16975 16976 function Is_Remote_Access_To_Class_Wide_Type 16977 (E : Entity_Id) return Boolean 16978 is 16979 begin 16980 -- A remote access to class-wide type is a general access to object type 16981 -- declared in the visible part of a Remote_Types or Remote_Call_ 16982 -- Interface unit. 16983 16984 return Ekind (E) = E_General_Access_Type 16985 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); 16986 end Is_Remote_Access_To_Class_Wide_Type; 16987 16988 ----------------------------------------- 16989 -- Is_Remote_Access_To_Subprogram_Type -- 16990 ----------------------------------------- 16991 16992 function Is_Remote_Access_To_Subprogram_Type 16993 (E : Entity_Id) return Boolean 16994 is 16995 begin 16996 return (Ekind (E) = E_Access_Subprogram_Type 16997 or else (Ekind (E) = E_Record_Type 16998 and then Present (Corresponding_Remote_Type (E)))) 16999 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); 17000 end Is_Remote_Access_To_Subprogram_Type; 17001 17002 -------------------- 17003 -- Is_Remote_Call -- 17004 -------------------- 17005 17006 function Is_Remote_Call (N : Node_Id) return Boolean is 17007 begin 17008 if Nkind (N) not in N_Subprogram_Call then 17009 17010 -- An entry call cannot be remote 17011 17012 return False; 17013 17014 elsif Nkind (Name (N)) in N_Has_Entity 17015 and then Is_Remote_Call_Interface (Entity (Name (N))) 17016 then 17017 -- A subprogram declared in the spec of a RCI package is remote 17018 17019 return True; 17020 17021 elsif Nkind (Name (N)) = N_Explicit_Dereference 17022 and then Is_Remote_Access_To_Subprogram_Type 17023 (Etype (Prefix (Name (N)))) 17024 then 17025 -- The dereference of a RAS is a remote call 17026 17027 return True; 17028 17029 elsif Present (Controlling_Argument (N)) 17030 and then Is_Remote_Access_To_Class_Wide_Type 17031 (Etype (Controlling_Argument (N))) 17032 then 17033 -- Any primitive operation call with a controlling argument of 17034 -- a RACW type is a remote call. 17035 17036 return True; 17037 end if; 17038 17039 -- All other calls are local calls 17040 17041 return False; 17042 end Is_Remote_Call; 17043 17044 ---------------------- 17045 -- Is_Renamed_Entry -- 17046 ---------------------- 17047 17048 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is 17049 Orig_Node : Node_Id := Empty; 17050 Subp_Decl : Node_Id := Parent (Parent (Proc_Nam)); 17051 17052 function Is_Entry (Nam : Node_Id) return Boolean; 17053 -- Determine whether Nam is an entry. Traverse selectors if there are 17054 -- nested selected components. 17055 17056 -------------- 17057 -- Is_Entry -- 17058 -------------- 17059 17060 function Is_Entry (Nam : Node_Id) return Boolean is 17061 begin 17062 if Nkind (Nam) = N_Selected_Component then 17063 return Is_Entry (Selector_Name (Nam)); 17064 end if; 17065 17066 return Ekind (Entity (Nam)) = E_Entry; 17067 end Is_Entry; 17068 17069 -- Start of processing for Is_Renamed_Entry 17070 17071 begin 17072 if Present (Alias (Proc_Nam)) then 17073 Subp_Decl := Parent (Parent (Alias (Proc_Nam))); 17074 end if; 17075 17076 -- Look for a rewritten subprogram renaming declaration 17077 17078 if Nkind (Subp_Decl) = N_Subprogram_Declaration 17079 and then Present (Original_Node (Subp_Decl)) 17080 then 17081 Orig_Node := Original_Node (Subp_Decl); 17082 end if; 17083 17084 -- The rewritten subprogram is actually an entry 17085 17086 if Present (Orig_Node) 17087 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration 17088 and then Is_Entry (Name (Orig_Node)) 17089 then 17090 return True; 17091 end if; 17092 17093 return False; 17094 end Is_Renamed_Entry; 17095 17096 ----------------------------- 17097 -- Is_Renaming_Declaration -- 17098 ----------------------------- 17099 17100 function Is_Renaming_Declaration (N : Node_Id) return Boolean is 17101 begin 17102 case Nkind (N) is 17103 when N_Exception_Renaming_Declaration 17104 | N_Generic_Function_Renaming_Declaration 17105 | N_Generic_Package_Renaming_Declaration 17106 | N_Generic_Procedure_Renaming_Declaration 17107 | N_Object_Renaming_Declaration 17108 | N_Package_Renaming_Declaration 17109 | N_Subprogram_Renaming_Declaration 17110 => 17111 return True; 17112 17113 when others => 17114 return False; 17115 end case; 17116 end Is_Renaming_Declaration; 17117 17118 ---------------------------- 17119 -- Is_Reversible_Iterator -- 17120 ---------------------------- 17121 17122 function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is 17123 Ifaces_List : Elist_Id; 17124 Iface_Elmt : Elmt_Id; 17125 Iface : Entity_Id; 17126 17127 begin 17128 if Is_Class_Wide_Type (Typ) 17129 and then Chars (Root_Type (Typ)) = Name_Reversible_Iterator 17130 and then In_Predefined_Unit (Root_Type (Typ)) 17131 then 17132 return True; 17133 17134 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then 17135 return False; 17136 17137 else 17138 Collect_Interfaces (Typ, Ifaces_List); 17139 17140 Iface_Elmt := First_Elmt (Ifaces_List); 17141 while Present (Iface_Elmt) loop 17142 Iface := Node (Iface_Elmt); 17143 if Chars (Iface) = Name_Reversible_Iterator 17144 and then In_Predefined_Unit (Iface) 17145 then 17146 return True; 17147 end if; 17148 17149 Next_Elmt (Iface_Elmt); 17150 end loop; 17151 end if; 17152 17153 return False; 17154 end Is_Reversible_Iterator; 17155 17156 ---------------------- 17157 -- Is_Selector_Name -- 17158 ---------------------- 17159 17160 function Is_Selector_Name (N : Node_Id) return Boolean is 17161 begin 17162 if not Is_List_Member (N) then 17163 declare 17164 P : constant Node_Id := Parent (N); 17165 begin 17166 return Nkind_In (P, N_Expanded_Name, 17167 N_Generic_Association, 17168 N_Parameter_Association, 17169 N_Selected_Component) 17170 and then Selector_Name (P) = N; 17171 end; 17172 17173 else 17174 declare 17175 L : constant List_Id := List_Containing (N); 17176 P : constant Node_Id := Parent (L); 17177 begin 17178 return (Nkind (P) = N_Discriminant_Association 17179 and then Selector_Names (P) = L) 17180 or else 17181 (Nkind (P) = N_Component_Association 17182 and then Choices (P) = L); 17183 end; 17184 end if; 17185 end Is_Selector_Name; 17186 17187 --------------------------------- 17188 -- Is_Single_Concurrent_Object -- 17189 --------------------------------- 17190 17191 function Is_Single_Concurrent_Object (Id : Entity_Id) return Boolean is 17192 begin 17193 return 17194 Is_Single_Protected_Object (Id) or else Is_Single_Task_Object (Id); 17195 end Is_Single_Concurrent_Object; 17196 17197 ------------------------------- 17198 -- Is_Single_Concurrent_Type -- 17199 ------------------------------- 17200 17201 function Is_Single_Concurrent_Type (Id : Entity_Id) return Boolean is 17202 begin 17203 return 17204 Ekind_In (Id, E_Protected_Type, E_Task_Type) 17205 and then Is_Single_Concurrent_Type_Declaration 17206 (Declaration_Node (Id)); 17207 end Is_Single_Concurrent_Type; 17208 17209 ------------------------------------------- 17210 -- Is_Single_Concurrent_Type_Declaration -- 17211 ------------------------------------------- 17212 17213 function Is_Single_Concurrent_Type_Declaration 17214 (N : Node_Id) return Boolean 17215 is 17216 begin 17217 return Nkind_In (Original_Node (N), N_Single_Protected_Declaration, 17218 N_Single_Task_Declaration); 17219 end Is_Single_Concurrent_Type_Declaration; 17220 17221 --------------------------------------------- 17222 -- Is_Single_Precision_Floating_Point_Type -- 17223 --------------------------------------------- 17224 17225 function Is_Single_Precision_Floating_Point_Type 17226 (E : Entity_Id) return Boolean is 17227 begin 17228 return Is_Floating_Point_Type (E) 17229 and then Machine_Radix_Value (E) = Uint_2 17230 and then Machine_Mantissa_Value (E) = Uint_24 17231 and then Machine_Emax_Value (E) = Uint_2 ** Uint_7 17232 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_7); 17233 end Is_Single_Precision_Floating_Point_Type; 17234 17235 -------------------------------- 17236 -- Is_Single_Protected_Object -- 17237 -------------------------------- 17238 17239 function Is_Single_Protected_Object (Id : Entity_Id) return Boolean is 17240 begin 17241 return 17242 Ekind (Id) = E_Variable 17243 and then Ekind (Etype (Id)) = E_Protected_Type 17244 and then Is_Single_Concurrent_Type (Etype (Id)); 17245 end Is_Single_Protected_Object; 17246 17247 --------------------------- 17248 -- Is_Single_Task_Object -- 17249 --------------------------- 17250 17251 function Is_Single_Task_Object (Id : Entity_Id) return Boolean is 17252 begin 17253 return 17254 Ekind (Id) = E_Variable 17255 and then Ekind (Etype (Id)) = E_Task_Type 17256 and then Is_Single_Concurrent_Type (Etype (Id)); 17257 end Is_Single_Task_Object; 17258 17259 ------------------------------------- 17260 -- Is_SPARK_05_Initialization_Expr -- 17261 ------------------------------------- 17262 17263 function Is_SPARK_05_Initialization_Expr (N : Node_Id) return Boolean is 17264 Is_Ok : Boolean; 17265 Expr : Node_Id; 17266 Comp_Assn : Node_Id; 17267 Orig_N : constant Node_Id := Original_Node (N); 17268 17269 begin 17270 Is_Ok := True; 17271 17272 if not Comes_From_Source (Orig_N) then 17273 goto Done; 17274 end if; 17275 17276 pragma Assert (Nkind (Orig_N) in N_Subexpr); 17277 17278 case Nkind (Orig_N) is 17279 when N_Character_Literal 17280 | N_Integer_Literal 17281 | N_Real_Literal 17282 | N_String_Literal 17283 => 17284 null; 17285 17286 when N_Expanded_Name 17287 | N_Identifier 17288 => 17289 if Is_Entity_Name (Orig_N) 17290 and then Present (Entity (Orig_N)) -- needed in some cases 17291 then 17292 case Ekind (Entity (Orig_N)) is 17293 when E_Constant 17294 | E_Enumeration_Literal 17295 | E_Named_Integer 17296 | E_Named_Real 17297 => 17298 null; 17299 17300 when others => 17301 if Is_Type (Entity (Orig_N)) then 17302 null; 17303 else 17304 Is_Ok := False; 17305 end if; 17306 end case; 17307 end if; 17308 17309 when N_Qualified_Expression 17310 | N_Type_Conversion 17311 => 17312 Is_Ok := Is_SPARK_05_Initialization_Expr (Expression (Orig_N)); 17313 17314 when N_Unary_Op => 17315 Is_Ok := Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N)); 17316 17317 when N_Binary_Op 17318 | N_Membership_Test 17319 | N_Short_Circuit 17320 => 17321 Is_Ok := Is_SPARK_05_Initialization_Expr (Left_Opnd (Orig_N)) 17322 and then 17323 Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N)); 17324 17325 when N_Aggregate 17326 | N_Extension_Aggregate 17327 => 17328 if Nkind (Orig_N) = N_Extension_Aggregate then 17329 Is_Ok := 17330 Is_SPARK_05_Initialization_Expr (Ancestor_Part (Orig_N)); 17331 end if; 17332 17333 Expr := First (Expressions (Orig_N)); 17334 while Present (Expr) loop 17335 if not Is_SPARK_05_Initialization_Expr (Expr) then 17336 Is_Ok := False; 17337 goto Done; 17338 end if; 17339 17340 Next (Expr); 17341 end loop; 17342 17343 Comp_Assn := First (Component_Associations (Orig_N)); 17344 while Present (Comp_Assn) loop 17345 Expr := Expression (Comp_Assn); 17346 17347 -- Note: test for Present here needed for box assocation 17348 17349 if Present (Expr) 17350 and then not Is_SPARK_05_Initialization_Expr (Expr) 17351 then 17352 Is_Ok := False; 17353 goto Done; 17354 end if; 17355 17356 Next (Comp_Assn); 17357 end loop; 17358 17359 when N_Attribute_Reference => 17360 if Nkind (Prefix (Orig_N)) in N_Subexpr then 17361 Is_Ok := Is_SPARK_05_Initialization_Expr (Prefix (Orig_N)); 17362 end if; 17363 17364 Expr := First (Expressions (Orig_N)); 17365 while Present (Expr) loop 17366 if not Is_SPARK_05_Initialization_Expr (Expr) then 17367 Is_Ok := False; 17368 goto Done; 17369 end if; 17370 17371 Next (Expr); 17372 end loop; 17373 17374 -- Selected components might be expanded named not yet resolved, so 17375 -- default on the safe side. (Eg on sparklex.ads) 17376 17377 when N_Selected_Component => 17378 null; 17379 17380 when others => 17381 Is_Ok := False; 17382 end case; 17383 17384 <<Done>> 17385 return Is_Ok; 17386 end Is_SPARK_05_Initialization_Expr; 17387 17388 ---------------------------------- 17389 -- Is_SPARK_05_Object_Reference -- 17390 ---------------------------------- 17391 17392 function Is_SPARK_05_Object_Reference (N : Node_Id) return Boolean is 17393 begin 17394 if Is_Entity_Name (N) then 17395 return Present (Entity (N)) 17396 and then 17397 (Ekind_In (Entity (N), E_Constant, E_Variable) 17398 or else Ekind (Entity (N)) in Formal_Kind); 17399 17400 else 17401 case Nkind (N) is 17402 when N_Selected_Component => 17403 return Is_SPARK_05_Object_Reference (Prefix (N)); 17404 17405 when others => 17406 return False; 17407 end case; 17408 end if; 17409 end Is_SPARK_05_Object_Reference; 17410 17411 ----------------------------- 17412 -- Is_Specific_Tagged_Type -- 17413 ----------------------------- 17414 17415 function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean is 17416 Full_Typ : Entity_Id; 17417 17418 begin 17419 -- Handle private types 17420 17421 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 17422 Full_Typ := Full_View (Typ); 17423 else 17424 Full_Typ := Typ; 17425 end if; 17426 17427 -- A specific tagged type is a non-class-wide tagged type 17428 17429 return Is_Tagged_Type (Full_Typ) and not Is_Class_Wide_Type (Full_Typ); 17430 end Is_Specific_Tagged_Type; 17431 17432 ------------------ 17433 -- Is_Statement -- 17434 ------------------ 17435 17436 function Is_Statement (N : Node_Id) return Boolean is 17437 begin 17438 return 17439 Nkind (N) in N_Statement_Other_Than_Procedure_Call 17440 or else Nkind (N) = N_Procedure_Call_Statement; 17441 end Is_Statement; 17442 17443 --------------------------------------- 17444 -- Is_Subprogram_Contract_Annotation -- 17445 --------------------------------------- 17446 17447 function Is_Subprogram_Contract_Annotation 17448 (Item : Node_Id) return Boolean 17449 is 17450 Nam : Name_Id; 17451 17452 begin 17453 if Nkind (Item) = N_Aspect_Specification then 17454 Nam := Chars (Identifier (Item)); 17455 17456 else pragma Assert (Nkind (Item) = N_Pragma); 17457 Nam := Pragma_Name (Item); 17458 end if; 17459 17460 return Nam = Name_Contract_Cases 17461 or else Nam = Name_Depends 17462 or else Nam = Name_Extensions_Visible 17463 or else Nam = Name_Global 17464 or else Nam = Name_Post 17465 or else Nam = Name_Post_Class 17466 or else Nam = Name_Postcondition 17467 or else Nam = Name_Pre 17468 or else Nam = Name_Pre_Class 17469 or else Nam = Name_Precondition 17470 or else Nam = Name_Refined_Depends 17471 or else Nam = Name_Refined_Global 17472 or else Nam = Name_Refined_Post 17473 or else Nam = Name_Test_Case; 17474 end Is_Subprogram_Contract_Annotation; 17475 17476 -------------------------------------------------- 17477 -- Is_Subprogram_Stub_Without_Prior_Declaration -- 17478 -------------------------------------------------- 17479 17480 function Is_Subprogram_Stub_Without_Prior_Declaration 17481 (N : Node_Id) return Boolean 17482 is 17483 begin 17484 pragma Assert (Nkind (N) = N_Subprogram_Body_Stub); 17485 17486 case Ekind (Defining_Entity (N)) is 17487 17488 -- A subprogram stub without prior declaration serves as declaration 17489 -- for the actual subprogram body. As such, it has an attached 17490 -- defining entity of E_Function or E_Procedure. 17491 17492 when E_Function 17493 | E_Procedure 17494 => 17495 return True; 17496 17497 -- Otherwise, it is completes a [generic] subprogram declaration 17498 17499 when E_Generic_Function 17500 | E_Generic_Procedure 17501 | E_Subprogram_Body 17502 => 17503 return False; 17504 17505 when others => 17506 raise Program_Error; 17507 end case; 17508 end Is_Subprogram_Stub_Without_Prior_Declaration; 17509 17510 --------------------------- 17511 -- Is_Suitable_Primitive -- 17512 --------------------------- 17513 17514 function Is_Suitable_Primitive (Subp_Id : Entity_Id) return Boolean is 17515 begin 17516 -- The Default_Initial_Condition and invariant procedures must not be 17517 -- treated as primitive operations even when they apply to a tagged 17518 -- type. These routines must not act as targets of dispatching calls 17519 -- because they already utilize class-wide-precondition semantics to 17520 -- handle inheritance and overriding. 17521 17522 if Ekind (Subp_Id) = E_Procedure 17523 and then (Is_DIC_Procedure (Subp_Id) 17524 or else 17525 Is_Invariant_Procedure (Subp_Id)) 17526 then 17527 return False; 17528 end if; 17529 17530 return True; 17531 end Is_Suitable_Primitive; 17532 17533 -------------------------- 17534 -- Is_Suspension_Object -- 17535 -------------------------- 17536 17537 function Is_Suspension_Object (Id : Entity_Id) return Boolean is 17538 begin 17539 -- This approach does an exact name match rather than to rely on 17540 -- RTSfind. Routine Is_Effectively_Volatile is used by clients of the 17541 -- front end at point where all auxiliary tables are locked and any 17542 -- modifications to them are treated as violations. Do not tamper with 17543 -- the tables, instead examine the Chars fields of all the scopes of Id. 17544 17545 return 17546 Chars (Id) = Name_Suspension_Object 17547 and then Present (Scope (Id)) 17548 and then Chars (Scope (Id)) = Name_Synchronous_Task_Control 17549 and then Present (Scope (Scope (Id))) 17550 and then Chars (Scope (Scope (Id))) = Name_Ada 17551 and then Present (Scope (Scope (Scope (Id)))) 17552 and then Scope (Scope (Scope (Id))) = Standard_Standard; 17553 end Is_Suspension_Object; 17554 17555 ---------------------------- 17556 -- Is_Synchronized_Object -- 17557 ---------------------------- 17558 17559 function Is_Synchronized_Object (Id : Entity_Id) return Boolean is 17560 Prag : Node_Id; 17561 17562 begin 17563 if Is_Object (Id) then 17564 17565 -- The object is synchronized if it is of a type that yields a 17566 -- synchronized object. 17567 17568 if Yields_Synchronized_Object (Etype (Id)) then 17569 return True; 17570 17571 -- The object is synchronized if it is atomic and Async_Writers is 17572 -- enabled. 17573 17574 elsif Is_Atomic_Object_Entity (Id) 17575 and then Async_Writers_Enabled (Id) 17576 then 17577 return True; 17578 17579 -- A constant is a synchronized object by default 17580 17581 elsif Ekind (Id) = E_Constant then 17582 return True; 17583 17584 -- A variable is a synchronized object if it is subject to pragma 17585 -- Constant_After_Elaboration. 17586 17587 elsif Ekind (Id) = E_Variable then 17588 Prag := Get_Pragma (Id, Pragma_Constant_After_Elaboration); 17589 17590 return Present (Prag) and then Is_Enabled_Pragma (Prag); 17591 end if; 17592 end if; 17593 17594 -- Otherwise the input is not an object or it does not qualify as a 17595 -- synchronized object. 17596 17597 return False; 17598 end Is_Synchronized_Object; 17599 17600 --------------------------------- 17601 -- Is_Synchronized_Tagged_Type -- 17602 --------------------------------- 17603 17604 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is 17605 Kind : constant Entity_Kind := Ekind (Base_Type (E)); 17606 17607 begin 17608 -- A task or protected type derived from an interface is a tagged type. 17609 -- Such a tagged type is called a synchronized tagged type, as are 17610 -- synchronized interfaces and private extensions whose declaration 17611 -- includes the reserved word synchronized. 17612 17613 return (Is_Tagged_Type (E) 17614 and then (Kind = E_Task_Type 17615 or else 17616 Kind = E_Protected_Type)) 17617 or else 17618 (Is_Interface (E) 17619 and then Is_Synchronized_Interface (E)) 17620 or else 17621 (Ekind (E) = E_Record_Type_With_Private 17622 and then Nkind (Parent (E)) = N_Private_Extension_Declaration 17623 and then (Synchronized_Present (Parent (E)) 17624 or else Is_Synchronized_Interface (Etype (E)))); 17625 end Is_Synchronized_Tagged_Type; 17626 17627 ----------------- 17628 -- Is_Transfer -- 17629 ----------------- 17630 17631 function Is_Transfer (N : Node_Id) return Boolean is 17632 Kind : constant Node_Kind := Nkind (N); 17633 17634 begin 17635 if Kind = N_Simple_Return_Statement 17636 or else 17637 Kind = N_Extended_Return_Statement 17638 or else 17639 Kind = N_Goto_Statement 17640 or else 17641 Kind = N_Raise_Statement 17642 or else 17643 Kind = N_Requeue_Statement 17644 then 17645 return True; 17646 17647 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error) 17648 and then No (Condition (N)) 17649 then 17650 return True; 17651 17652 elsif Kind = N_Procedure_Call_Statement 17653 and then Is_Entity_Name (Name (N)) 17654 and then Present (Entity (Name (N))) 17655 and then No_Return (Entity (Name (N))) 17656 then 17657 return True; 17658 17659 elsif Nkind (Original_Node (N)) = N_Raise_Statement then 17660 return True; 17661 17662 else 17663 return False; 17664 end if; 17665 end Is_Transfer; 17666 17667 ------------- 17668 -- Is_True -- 17669 ------------- 17670 17671 function Is_True (U : Uint) return Boolean is 17672 begin 17673 return (U /= 0); 17674 end Is_True; 17675 17676 -------------------------------------- 17677 -- Is_Unchecked_Conversion_Instance -- 17678 -------------------------------------- 17679 17680 function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean is 17681 Par : Node_Id; 17682 17683 begin 17684 -- Look for a function whose generic parent is the predefined intrinsic 17685 -- function Unchecked_Conversion, or for one that renames such an 17686 -- instance. 17687 17688 if Ekind (Id) = E_Function then 17689 Par := Parent (Id); 17690 17691 if Nkind (Par) = N_Function_Specification then 17692 Par := Generic_Parent (Par); 17693 17694 if Present (Par) then 17695 return 17696 Chars (Par) = Name_Unchecked_Conversion 17697 and then Is_Intrinsic_Subprogram (Par) 17698 and then In_Predefined_Unit (Par); 17699 else 17700 return 17701 Present (Alias (Id)) 17702 and then Is_Unchecked_Conversion_Instance (Alias (Id)); 17703 end if; 17704 end if; 17705 end if; 17706 17707 return False; 17708 end Is_Unchecked_Conversion_Instance; 17709 17710 ------------------------------- 17711 -- Is_Universal_Numeric_Type -- 17712 ------------------------------- 17713 17714 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is 17715 begin 17716 return T = Universal_Integer or else T = Universal_Real; 17717 end Is_Universal_Numeric_Type; 17718 17719 ------------------------------ 17720 -- Is_User_Defined_Equality -- 17721 ------------------------------ 17722 17723 function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is 17724 begin 17725 return Ekind (Id) = E_Function 17726 and then Chars (Id) = Name_Op_Eq 17727 and then Comes_From_Source (Id) 17728 17729 -- Internally generated equalities have a full type declaration 17730 -- as their parent. 17731 17732 and then Nkind (Parent (Id)) = N_Function_Specification; 17733 end Is_User_Defined_Equality; 17734 17735 -------------------------------------- 17736 -- Is_Validation_Variable_Reference -- 17737 -------------------------------------- 17738 17739 function Is_Validation_Variable_Reference (N : Node_Id) return Boolean is 17740 Var : constant Node_Id := Unqual_Conv (N); 17741 Var_Id : Entity_Id; 17742 17743 begin 17744 Var_Id := Empty; 17745 17746 if Is_Entity_Name (Var) then 17747 Var_Id := Entity (Var); 17748 end if; 17749 17750 return 17751 Present (Var_Id) 17752 and then Ekind (Var_Id) = E_Variable 17753 and then Present (Validated_Object (Var_Id)); 17754 end Is_Validation_Variable_Reference; 17755 17756 ---------------------------- 17757 -- Is_Variable_Size_Array -- 17758 ---------------------------- 17759 17760 function Is_Variable_Size_Array (E : Entity_Id) return Boolean is 17761 Idx : Node_Id; 17762 17763 begin 17764 pragma Assert (Is_Array_Type (E)); 17765 17766 -- Check if some index is initialized with a non-constant value 17767 17768 Idx := First_Index (E); 17769 while Present (Idx) loop 17770 if Nkind (Idx) = N_Range then 17771 if not Is_Constant_Bound (Low_Bound (Idx)) 17772 or else not Is_Constant_Bound (High_Bound (Idx)) 17773 then 17774 return True; 17775 end if; 17776 end if; 17777 17778 Idx := Next_Index (Idx); 17779 end loop; 17780 17781 return False; 17782 end Is_Variable_Size_Array; 17783 17784 ----------------------------- 17785 -- Is_Variable_Size_Record -- 17786 ----------------------------- 17787 17788 function Is_Variable_Size_Record (E : Entity_Id) return Boolean is 17789 Comp : Entity_Id; 17790 Comp_Typ : Entity_Id; 17791 17792 begin 17793 pragma Assert (Is_Record_Type (E)); 17794 17795 Comp := First_Component (E); 17796 while Present (Comp) loop 17797 Comp_Typ := Underlying_Type (Etype (Comp)); 17798 17799 -- Recursive call if the record type has discriminants 17800 17801 if Is_Record_Type (Comp_Typ) 17802 and then Has_Discriminants (Comp_Typ) 17803 and then Is_Variable_Size_Record (Comp_Typ) 17804 then 17805 return True; 17806 17807 elsif Is_Array_Type (Comp_Typ) 17808 and then Is_Variable_Size_Array (Comp_Typ) 17809 then 17810 return True; 17811 end if; 17812 17813 Next_Component (Comp); 17814 end loop; 17815 17816 return False; 17817 end Is_Variable_Size_Record; 17818 17819 ----------------- 17820 -- Is_Variable -- 17821 ----------------- 17822 17823 function Is_Variable 17824 (N : Node_Id; 17825 Use_Original_Node : Boolean := True) return Boolean 17826 is 17827 Orig_Node : Node_Id; 17828 17829 function In_Protected_Function (E : Entity_Id) return Boolean; 17830 -- Within a protected function, the private components of the enclosing 17831 -- protected type are constants. A function nested within a (protected) 17832 -- procedure is not itself protected. Within the body of a protected 17833 -- function the current instance of the protected type is a constant. 17834 17835 function Is_Variable_Prefix (P : Node_Id) return Boolean; 17836 -- Prefixes can involve implicit dereferences, in which case we must 17837 -- test for the case of a reference of a constant access type, which can 17838 -- can never be a variable. 17839 17840 --------------------------- 17841 -- In_Protected_Function -- 17842 --------------------------- 17843 17844 function In_Protected_Function (E : Entity_Id) return Boolean is 17845 Prot : Entity_Id; 17846 S : Entity_Id; 17847 17848 begin 17849 -- E is the current instance of a type 17850 17851 if Is_Type (E) then 17852 Prot := E; 17853 17854 -- E is an object 17855 17856 else 17857 Prot := Scope (E); 17858 end if; 17859 17860 if not Is_Protected_Type (Prot) then 17861 return False; 17862 17863 else 17864 S := Current_Scope; 17865 while Present (S) and then S /= Prot loop 17866 if Ekind (S) = E_Function and then Scope (S) = Prot then 17867 return True; 17868 end if; 17869 17870 S := Scope (S); 17871 end loop; 17872 17873 return False; 17874 end if; 17875 end In_Protected_Function; 17876 17877 ------------------------ 17878 -- Is_Variable_Prefix -- 17879 ------------------------ 17880 17881 function Is_Variable_Prefix (P : Node_Id) return Boolean is 17882 begin 17883 if Is_Access_Type (Etype (P)) then 17884 return not Is_Access_Constant (Root_Type (Etype (P))); 17885 17886 -- For the case of an indexed component whose prefix has a packed 17887 -- array type, the prefix has been rewritten into a type conversion. 17888 -- Determine variable-ness from the converted expression. 17889 17890 elsif Nkind (P) = N_Type_Conversion 17891 and then not Comes_From_Source (P) 17892 and then Is_Array_Type (Etype (P)) 17893 and then Is_Packed (Etype (P)) 17894 then 17895 return Is_Variable (Expression (P)); 17896 17897 else 17898 return Is_Variable (P); 17899 end if; 17900 end Is_Variable_Prefix; 17901 17902 -- Start of processing for Is_Variable 17903 17904 begin 17905 -- Special check, allow x'Deref(expr) as a variable 17906 17907 if Nkind (N) = N_Attribute_Reference 17908 and then Attribute_Name (N) = Name_Deref 17909 then 17910 return True; 17911 end if; 17912 17913 -- Check if we perform the test on the original node since this may be a 17914 -- test of syntactic categories which must not be disturbed by whatever 17915 -- rewriting might have occurred. For example, an aggregate, which is 17916 -- certainly NOT a variable, could be turned into a variable by 17917 -- expansion. 17918 17919 if Use_Original_Node then 17920 Orig_Node := Original_Node (N); 17921 else 17922 Orig_Node := N; 17923 end if; 17924 17925 -- Definitely OK if Assignment_OK is set. Since this is something that 17926 -- only gets set for expanded nodes, the test is on N, not Orig_Node. 17927 17928 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then 17929 return True; 17930 17931 -- Normally we go to the original node, but there is one exception where 17932 -- we use the rewritten node, namely when it is an explicit dereference. 17933 -- The generated code may rewrite a prefix which is an access type with 17934 -- an explicit dereference. The dereference is a variable, even though 17935 -- the original node may not be (since it could be a constant of the 17936 -- access type). 17937 17938 -- In Ada 2005 we have a further case to consider: the prefix may be a 17939 -- function call given in prefix notation. The original node appears to 17940 -- be a selected component, but we need to examine the call. 17941 17942 elsif Nkind (N) = N_Explicit_Dereference 17943 and then Nkind (Orig_Node) /= N_Explicit_Dereference 17944 and then Present (Etype (Orig_Node)) 17945 and then Is_Access_Type (Etype (Orig_Node)) 17946 then 17947 -- Note that if the prefix is an explicit dereference that does not 17948 -- come from source, we must check for a rewritten function call in 17949 -- prefixed notation before other forms of rewriting, to prevent a 17950 -- compiler crash. 17951 17952 return 17953 (Nkind (Orig_Node) = N_Function_Call 17954 and then not Is_Access_Constant (Etype (Prefix (N)))) 17955 or else 17956 Is_Variable_Prefix (Original_Node (Prefix (N))); 17957 17958 -- in Ada 2012, the dereference may have been added for a type with 17959 -- a declared implicit dereference aspect. Check that it is not an 17960 -- access to constant. 17961 17962 elsif Nkind (N) = N_Explicit_Dereference 17963 and then Present (Etype (Orig_Node)) 17964 and then Ada_Version >= Ada_2012 17965 and then Has_Implicit_Dereference (Etype (Orig_Node)) 17966 then 17967 return not Is_Access_Constant (Etype (Prefix (N))); 17968 17969 -- A function call is never a variable 17970 17971 elsif Nkind (N) = N_Function_Call then 17972 return False; 17973 17974 -- All remaining checks use the original node 17975 17976 elsif Is_Entity_Name (Orig_Node) 17977 and then Present (Entity (Orig_Node)) 17978 then 17979 declare 17980 E : constant Entity_Id := Entity (Orig_Node); 17981 K : constant Entity_Kind := Ekind (E); 17982 17983 begin 17984 if Is_Loop_Parameter (E) then 17985 return False; 17986 end if; 17987 17988 return (K = E_Variable 17989 and then Nkind (Parent (E)) /= N_Exception_Handler) 17990 or else (K = E_Component 17991 and then not In_Protected_Function (E)) 17992 or else K = E_Out_Parameter 17993 or else K = E_In_Out_Parameter 17994 or else K = E_Generic_In_Out_Parameter 17995 17996 -- Current instance of type. If this is a protected type, check 17997 -- we are not within the body of one of its protected functions. 17998 17999 or else (Is_Type (E) 18000 and then In_Open_Scopes (E) 18001 and then not In_Protected_Function (E)) 18002 18003 or else (Is_Incomplete_Or_Private_Type (E) 18004 and then In_Open_Scopes (Full_View (E))); 18005 end; 18006 18007 else 18008 case Nkind (Orig_Node) is 18009 when N_Indexed_Component 18010 | N_Slice 18011 => 18012 return Is_Variable_Prefix (Prefix (Orig_Node)); 18013 18014 when N_Selected_Component => 18015 return (Is_Variable (Selector_Name (Orig_Node)) 18016 and then Is_Variable_Prefix (Prefix (Orig_Node))) 18017 or else 18018 (Nkind (N) = N_Expanded_Name 18019 and then Scope (Entity (N)) = Entity (Prefix (N))); 18020 18021 -- For an explicit dereference, the type of the prefix cannot 18022 -- be an access to constant or an access to subprogram. 18023 18024 when N_Explicit_Dereference => 18025 declare 18026 Typ : constant Entity_Id := Etype (Prefix (Orig_Node)); 18027 begin 18028 return Is_Access_Type (Typ) 18029 and then not Is_Access_Constant (Root_Type (Typ)) 18030 and then Ekind (Typ) /= E_Access_Subprogram_Type; 18031 end; 18032 18033 -- The type conversion is the case where we do not deal with the 18034 -- context dependent special case of an actual parameter. Thus 18035 -- the type conversion is only considered a variable for the 18036 -- purposes of this routine if the target type is tagged. However, 18037 -- a type conversion is considered to be a variable if it does not 18038 -- come from source (this deals for example with the conversions 18039 -- of expressions to their actual subtypes). 18040 18041 when N_Type_Conversion => 18042 return Is_Variable (Expression (Orig_Node)) 18043 and then 18044 (not Comes_From_Source (Orig_Node) 18045 or else 18046 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node))) 18047 and then 18048 Is_Tagged_Type (Etype (Expression (Orig_Node))))); 18049 18050 -- GNAT allows an unchecked type conversion as a variable. This 18051 -- only affects the generation of internal expanded code, since 18052 -- calls to instantiations of Unchecked_Conversion are never 18053 -- considered variables (since they are function calls). 18054 18055 when N_Unchecked_Type_Conversion => 18056 return Is_Variable (Expression (Orig_Node)); 18057 18058 when others => 18059 return False; 18060 end case; 18061 end if; 18062 end Is_Variable; 18063 18064 --------------------------- 18065 -- Is_Visibly_Controlled -- 18066 --------------------------- 18067 18068 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is 18069 Root : constant Entity_Id := Root_Type (T); 18070 begin 18071 return Chars (Scope (Root)) = Name_Finalization 18072 and then Chars (Scope (Scope (Root))) = Name_Ada 18073 and then Scope (Scope (Scope (Root))) = Standard_Standard; 18074 end Is_Visibly_Controlled; 18075 18076 -------------------------- 18077 -- Is_Volatile_Function -- 18078 -------------------------- 18079 18080 function Is_Volatile_Function (Func_Id : Entity_Id) return Boolean is 18081 begin 18082 pragma Assert (Ekind_In (Func_Id, E_Function, E_Generic_Function)); 18083 18084 -- A function declared within a protected type is volatile 18085 18086 if Is_Protected_Type (Scope (Func_Id)) then 18087 return True; 18088 18089 -- An instance of Ada.Unchecked_Conversion is a volatile function if 18090 -- either the source or the target are effectively volatile. 18091 18092 elsif Is_Unchecked_Conversion_Instance (Func_Id) 18093 and then Has_Effectively_Volatile_Profile (Func_Id) 18094 then 18095 return True; 18096 18097 -- Otherwise the function is treated as volatile if it is subject to 18098 -- enabled pragma Volatile_Function. 18099 18100 else 18101 return 18102 Is_Enabled_Pragma (Get_Pragma (Func_Id, Pragma_Volatile_Function)); 18103 end if; 18104 end Is_Volatile_Function; 18105 18106 ------------------------ 18107 -- Is_Volatile_Object -- 18108 ------------------------ 18109 18110 function Is_Volatile_Object (N : Node_Id) return Boolean is 18111 function Is_Volatile_Prefix (N : Node_Id) return Boolean; 18112 -- If prefix is an implicit dereference, examine designated type 18113 18114 function Object_Has_Volatile_Components (N : Node_Id) return Boolean; 18115 -- Determines if given object has volatile components 18116 18117 ------------------------ 18118 -- Is_Volatile_Prefix -- 18119 ------------------------ 18120 18121 function Is_Volatile_Prefix (N : Node_Id) return Boolean is 18122 Typ : constant Entity_Id := Etype (N); 18123 18124 begin 18125 if Is_Access_Type (Typ) then 18126 declare 18127 Dtyp : constant Entity_Id := Designated_Type (Typ); 18128 18129 begin 18130 return Is_Volatile (Dtyp) 18131 or else Has_Volatile_Components (Dtyp); 18132 end; 18133 18134 else 18135 return Object_Has_Volatile_Components (N); 18136 end if; 18137 end Is_Volatile_Prefix; 18138 18139 ------------------------------------ 18140 -- Object_Has_Volatile_Components -- 18141 ------------------------------------ 18142 18143 function Object_Has_Volatile_Components (N : Node_Id) return Boolean is 18144 Typ : constant Entity_Id := Etype (N); 18145 18146 begin 18147 if Is_Volatile (Typ) 18148 or else Has_Volatile_Components (Typ) 18149 then 18150 return True; 18151 18152 elsif Is_Entity_Name (N) 18153 and then (Has_Volatile_Components (Entity (N)) 18154 or else Is_Volatile (Entity (N))) 18155 then 18156 return True; 18157 18158 elsif Nkind (N) = N_Indexed_Component 18159 or else Nkind (N) = N_Selected_Component 18160 then 18161 return Is_Volatile_Prefix (Prefix (N)); 18162 18163 else 18164 return False; 18165 end if; 18166 end Object_Has_Volatile_Components; 18167 18168 -- Start of processing for Is_Volatile_Object 18169 18170 begin 18171 if Nkind (N) = N_Defining_Identifier then 18172 return Is_Volatile (N) or else Is_Volatile (Etype (N)); 18173 18174 elsif Nkind (N) = N_Expanded_Name then 18175 return Is_Volatile_Object (Entity (N)); 18176 18177 elsif Is_Volatile (Etype (N)) 18178 or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N))) 18179 then 18180 return True; 18181 18182 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) 18183 and then Is_Volatile_Prefix (Prefix (N)) 18184 then 18185 return True; 18186 18187 elsif Nkind (N) = N_Selected_Component 18188 and then Is_Volatile (Entity (Selector_Name (N))) 18189 then 18190 return True; 18191 18192 else 18193 return False; 18194 end if; 18195 end Is_Volatile_Object; 18196 18197 ----------------------------- 18198 -- Iterate_Call_Parameters -- 18199 ----------------------------- 18200 18201 procedure Iterate_Call_Parameters (Call : Node_Id) is 18202 Actual : Node_Id := First_Actual (Call); 18203 Formal : Entity_Id := First_Formal (Get_Called_Entity (Call)); 18204 18205 begin 18206 while Present (Formal) and then Present (Actual) loop 18207 Handle_Parameter (Formal, Actual); 18208 18209 Next_Formal (Formal); 18210 Next_Actual (Actual); 18211 end loop; 18212 18213 pragma Assert (No (Formal)); 18214 pragma Assert (No (Actual)); 18215 end Iterate_Call_Parameters; 18216 18217 --------------------------- 18218 -- Itype_Has_Declaration -- 18219 --------------------------- 18220 18221 function Itype_Has_Declaration (Id : Entity_Id) return Boolean is 18222 begin 18223 pragma Assert (Is_Itype (Id)); 18224 return Present (Parent (Id)) 18225 and then Nkind_In (Parent (Id), N_Full_Type_Declaration, 18226 N_Subtype_Declaration) 18227 and then Defining_Entity (Parent (Id)) = Id; 18228 end Itype_Has_Declaration; 18229 18230 ------------------------- 18231 -- Kill_Current_Values -- 18232 ------------------------- 18233 18234 procedure Kill_Current_Values 18235 (Ent : Entity_Id; 18236 Last_Assignment_Only : Boolean := False) 18237 is 18238 begin 18239 if Is_Assignable (Ent) then 18240 Set_Last_Assignment (Ent, Empty); 18241 end if; 18242 18243 if Is_Object (Ent) then 18244 if not Last_Assignment_Only then 18245 Kill_Checks (Ent); 18246 Set_Current_Value (Ent, Empty); 18247 18248 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags 18249 -- for a constant. Once the constant is elaborated, its value is 18250 -- not changed, therefore the associated flags that describe the 18251 -- value should not be modified either. 18252 18253 if Ekind (Ent) = E_Constant then 18254 null; 18255 18256 -- Non-constant entities 18257 18258 else 18259 if not Can_Never_Be_Null (Ent) then 18260 Set_Is_Known_Non_Null (Ent, False); 18261 end if; 18262 18263 Set_Is_Known_Null (Ent, False); 18264 18265 -- Reset the Is_Known_Valid flag unless the type is always 18266 -- valid. This does not apply to a loop parameter because its 18267 -- bounds are defined by the loop header and therefore always 18268 -- valid. 18269 18270 if not Is_Known_Valid (Etype (Ent)) 18271 and then Ekind (Ent) /= E_Loop_Parameter 18272 then 18273 Set_Is_Known_Valid (Ent, False); 18274 end if; 18275 end if; 18276 end if; 18277 end if; 18278 end Kill_Current_Values; 18279 18280 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is 18281 S : Entity_Id; 18282 18283 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id); 18284 -- Clear current value for entity E and all entities chained to E 18285 18286 ------------------------------------------ 18287 -- Kill_Current_Values_For_Entity_Chain -- 18288 ------------------------------------------ 18289 18290 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is 18291 Ent : Entity_Id; 18292 begin 18293 Ent := E; 18294 while Present (Ent) loop 18295 Kill_Current_Values (Ent, Last_Assignment_Only); 18296 Next_Entity (Ent); 18297 end loop; 18298 end Kill_Current_Values_For_Entity_Chain; 18299 18300 -- Start of processing for Kill_Current_Values 18301 18302 begin 18303 -- Kill all saved checks, a special case of killing saved values 18304 18305 if not Last_Assignment_Only then 18306 Kill_All_Checks; 18307 end if; 18308 18309 -- Loop through relevant scopes, which includes the current scope and 18310 -- any parent scopes if the current scope is a block or a package. 18311 18312 S := Current_Scope; 18313 Scope_Loop : loop 18314 18315 -- Clear current values of all entities in current scope 18316 18317 Kill_Current_Values_For_Entity_Chain (First_Entity (S)); 18318 18319 -- If scope is a package, also clear current values of all private 18320 -- entities in the scope. 18321 18322 if Is_Package_Or_Generic_Package (S) 18323 or else Is_Concurrent_Type (S) 18324 then 18325 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S)); 18326 end if; 18327 18328 -- If this is a not a subprogram, deal with parents 18329 18330 if not Is_Subprogram (S) then 18331 S := Scope (S); 18332 exit Scope_Loop when S = Standard_Standard; 18333 else 18334 exit Scope_Loop; 18335 end if; 18336 end loop Scope_Loop; 18337 end Kill_Current_Values; 18338 18339 -------------------------- 18340 -- Kill_Size_Check_Code -- 18341 -------------------------- 18342 18343 procedure Kill_Size_Check_Code (E : Entity_Id) is 18344 begin 18345 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 18346 and then Present (Size_Check_Code (E)) 18347 then 18348 Remove (Size_Check_Code (E)); 18349 Set_Size_Check_Code (E, Empty); 18350 end if; 18351 end Kill_Size_Check_Code; 18352 18353 -------------------- 18354 -- Known_Non_Null -- 18355 -------------------- 18356 18357 function Known_Non_Null (N : Node_Id) return Boolean is 18358 Status : constant Null_Status_Kind := Null_Status (N); 18359 18360 Id : Entity_Id; 18361 Op : Node_Kind; 18362 Val : Node_Id; 18363 18364 begin 18365 -- The expression yields a non-null value ignoring simple flow analysis 18366 18367 if Status = Is_Non_Null then 18368 return True; 18369 18370 -- Otherwise check whether N is a reference to an entity that appears 18371 -- within a conditional construct. 18372 18373 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 18374 18375 -- First check if we are in decisive conditional 18376 18377 Get_Current_Value_Condition (N, Op, Val); 18378 18379 if Known_Null (Val) then 18380 if Op = N_Op_Eq then 18381 return False; 18382 elsif Op = N_Op_Ne then 18383 return True; 18384 end if; 18385 end if; 18386 18387 -- If OK to do replacement, test Is_Known_Non_Null flag 18388 18389 Id := Entity (N); 18390 18391 if OK_To_Do_Constant_Replacement (Id) then 18392 return Is_Known_Non_Null (Id); 18393 end if; 18394 end if; 18395 18396 -- Otherwise it is not possible to determine whether N yields a non-null 18397 -- value. 18398 18399 return False; 18400 end Known_Non_Null; 18401 18402 ---------------- 18403 -- Known_Null -- 18404 ---------------- 18405 18406 function Known_Null (N : Node_Id) return Boolean is 18407 Status : constant Null_Status_Kind := Null_Status (N); 18408 18409 Id : Entity_Id; 18410 Op : Node_Kind; 18411 Val : Node_Id; 18412 18413 begin 18414 -- The expression yields a null value ignoring simple flow analysis 18415 18416 if Status = Is_Null then 18417 return True; 18418 18419 -- Otherwise check whether N is a reference to an entity that appears 18420 -- within a conditional construct. 18421 18422 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 18423 18424 -- First check if we are in decisive conditional 18425 18426 Get_Current_Value_Condition (N, Op, Val); 18427 18428 if Known_Null (Val) then 18429 if Op = N_Op_Eq then 18430 return True; 18431 elsif Op = N_Op_Ne then 18432 return False; 18433 end if; 18434 end if; 18435 18436 -- If OK to do replacement, test Is_Known_Null flag 18437 18438 Id := Entity (N); 18439 18440 if OK_To_Do_Constant_Replacement (Id) then 18441 return Is_Known_Null (Id); 18442 end if; 18443 end if; 18444 18445 -- Otherwise it is not possible to determine whether N yields a null 18446 -- value. 18447 18448 return False; 18449 end Known_Null; 18450 18451 -------------------------- 18452 -- Known_To_Be_Assigned -- 18453 -------------------------- 18454 18455 function Known_To_Be_Assigned (N : Node_Id) return Boolean is 18456 P : constant Node_Id := Parent (N); 18457 18458 begin 18459 case Nkind (P) is 18460 18461 -- Test left side of assignment 18462 18463 when N_Assignment_Statement => 18464 return N = Name (P); 18465 18466 -- Function call arguments are never lvalues 18467 18468 when N_Function_Call => 18469 return False; 18470 18471 -- Positional parameter for procedure or accept call 18472 18473 when N_Accept_Statement 18474 | N_Procedure_Call_Statement 18475 => 18476 declare 18477 Proc : Entity_Id; 18478 Form : Entity_Id; 18479 Act : Node_Id; 18480 18481 begin 18482 Proc := Get_Subprogram_Entity (P); 18483 18484 if No (Proc) then 18485 return False; 18486 end if; 18487 18488 -- If we are not a list member, something is strange, so 18489 -- be conservative and return False. 18490 18491 if not Is_List_Member (N) then 18492 return False; 18493 end if; 18494 18495 -- We are going to find the right formal by stepping forward 18496 -- through the formals, as we step backwards in the actuals. 18497 18498 Form := First_Formal (Proc); 18499 Act := N; 18500 loop 18501 -- If no formal, something is weird, so be conservative 18502 -- and return False. 18503 18504 if No (Form) then 18505 return False; 18506 end if; 18507 18508 Prev (Act); 18509 exit when No (Act); 18510 Next_Formal (Form); 18511 end loop; 18512 18513 return Ekind (Form) /= E_In_Parameter; 18514 end; 18515 18516 -- Named parameter for procedure or accept call 18517 18518 when N_Parameter_Association => 18519 declare 18520 Proc : Entity_Id; 18521 Form : Entity_Id; 18522 18523 begin 18524 Proc := Get_Subprogram_Entity (Parent (P)); 18525 18526 if No (Proc) then 18527 return False; 18528 end if; 18529 18530 -- Loop through formals to find the one that matches 18531 18532 Form := First_Formal (Proc); 18533 loop 18534 -- If no matching formal, that's peculiar, some kind of 18535 -- previous error, so return False to be conservative. 18536 -- Actually this also happens in legal code in the case 18537 -- where P is a parameter association for an Extra_Formal??? 18538 18539 if No (Form) then 18540 return False; 18541 end if; 18542 18543 -- Else test for match 18544 18545 if Chars (Form) = Chars (Selector_Name (P)) then 18546 return Ekind (Form) /= E_In_Parameter; 18547 end if; 18548 18549 Next_Formal (Form); 18550 end loop; 18551 end; 18552 18553 -- Test for appearing in a conversion that itself appears 18554 -- in an lvalue context, since this should be an lvalue. 18555 18556 when N_Type_Conversion => 18557 return Known_To_Be_Assigned (P); 18558 18559 -- All other references are definitely not known to be modifications 18560 18561 when others => 18562 return False; 18563 end case; 18564 end Known_To_Be_Assigned; 18565 18566 --------------------------- 18567 -- Last_Source_Statement -- 18568 --------------------------- 18569 18570 function Last_Source_Statement (HSS : Node_Id) return Node_Id is 18571 N : Node_Id; 18572 18573 begin 18574 N := Last (Statements (HSS)); 18575 while Present (N) loop 18576 exit when Comes_From_Source (N); 18577 Prev (N); 18578 end loop; 18579 18580 return N; 18581 end Last_Source_Statement; 18582 18583 ----------------------- 18584 -- Mark_Coextensions -- 18585 ----------------------- 18586 18587 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is 18588 Is_Dynamic : Boolean; 18589 -- Indicates whether the context causes nested coextensions to be 18590 -- dynamic or static 18591 18592 function Mark_Allocator (N : Node_Id) return Traverse_Result; 18593 -- Recognize an allocator node and label it as a dynamic coextension 18594 18595 -------------------- 18596 -- Mark_Allocator -- 18597 -------------------- 18598 18599 function Mark_Allocator (N : Node_Id) return Traverse_Result is 18600 begin 18601 if Nkind (N) = N_Allocator then 18602 if Is_Dynamic then 18603 Set_Is_Static_Coextension (N, False); 18604 Set_Is_Dynamic_Coextension (N); 18605 18606 -- If the allocator expression is potentially dynamic, it may 18607 -- be expanded out of order and require dynamic allocation 18608 -- anyway, so we treat the coextension itself as dynamic. 18609 -- Potential optimization ??? 18610 18611 elsif Nkind (Expression (N)) = N_Qualified_Expression 18612 and then Nkind (Expression (Expression (N))) = N_Op_Concat 18613 then 18614 Set_Is_Static_Coextension (N, False); 18615 Set_Is_Dynamic_Coextension (N); 18616 else 18617 Set_Is_Dynamic_Coextension (N, False); 18618 Set_Is_Static_Coextension (N); 18619 end if; 18620 end if; 18621 18622 return OK; 18623 end Mark_Allocator; 18624 18625 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator); 18626 18627 -- Start of processing for Mark_Coextensions 18628 18629 begin 18630 -- An allocator that appears on the right-hand side of an assignment is 18631 -- treated as a potentially dynamic coextension when the right-hand side 18632 -- is an allocator or a qualified expression. 18633 18634 -- Obj := new ...'(new Coextension ...); 18635 18636 if Nkind (Context_Nod) = N_Assignment_Statement then 18637 Is_Dynamic := 18638 Nkind_In (Expression (Context_Nod), N_Allocator, 18639 N_Qualified_Expression); 18640 18641 -- An allocator that appears within the expression of a simple return 18642 -- statement is treated as a potentially dynamic coextension when the 18643 -- expression is either aggregate, allocator, or qualified expression. 18644 18645 -- return (new Coextension ...); 18646 -- return new ...'(new Coextension ...); 18647 18648 elsif Nkind (Context_Nod) = N_Simple_Return_Statement then 18649 Is_Dynamic := 18650 Nkind_In (Expression (Context_Nod), N_Aggregate, 18651 N_Allocator, 18652 N_Qualified_Expression); 18653 18654 -- An alloctor that appears within the initialization expression of an 18655 -- object declaration is considered a potentially dynamic coextension 18656 -- when the initialization expression is an allocator or a qualified 18657 -- expression. 18658 18659 -- Obj : ... := new ...'(new Coextension ...); 18660 18661 -- A similar case arises when the object declaration is part of an 18662 -- extended return statement. 18663 18664 -- return Obj : ... := new ...'(new Coextension ...); 18665 -- return Obj : ... := (new Coextension ...); 18666 18667 elsif Nkind (Context_Nod) = N_Object_Declaration then 18668 Is_Dynamic := 18669 Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression) 18670 or else 18671 Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement; 18672 18673 -- This routine should not be called with constructs that cannot contain 18674 -- coextensions. 18675 18676 else 18677 raise Program_Error; 18678 end if; 18679 18680 Mark_Allocators (Root_Nod); 18681 end Mark_Coextensions; 18682 18683 --------------------------------- 18684 -- Mark_Elaboration_Attributes -- 18685 --------------------------------- 18686 18687 procedure Mark_Elaboration_Attributes 18688 (N_Id : Node_Or_Entity_Id; 18689 Checks : Boolean := False; 18690 Level : Boolean := False; 18691 Modes : Boolean := False; 18692 Warnings : Boolean := False) 18693 is 18694 function Elaboration_Checks_OK 18695 (Target_Id : Entity_Id; 18696 Context_Id : Entity_Id) return Boolean; 18697 -- Determine whether elaboration checks are enabled for target Target_Id 18698 -- which resides within context Context_Id. 18699 18700 procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id); 18701 -- Preserve relevant attributes of the context in arbitrary entity Id 18702 18703 procedure Mark_Elaboration_Attributes_Node (N : Node_Id); 18704 -- Preserve relevant attributes of the context in arbitrary node N 18705 18706 --------------------------- 18707 -- Elaboration_Checks_OK -- 18708 --------------------------- 18709 18710 function Elaboration_Checks_OK 18711 (Target_Id : Entity_Id; 18712 Context_Id : Entity_Id) return Boolean 18713 is 18714 Encl_Scop : Entity_Id; 18715 18716 begin 18717 -- Elaboration checks are suppressed for the target 18718 18719 if Elaboration_Checks_Suppressed (Target_Id) then 18720 return False; 18721 end if; 18722 18723 -- Otherwise elaboration checks are OK for the target, but may be 18724 -- suppressed for the context where the target is declared. 18725 18726 Encl_Scop := Context_Id; 18727 while Present (Encl_Scop) and then Encl_Scop /= Standard_Standard loop 18728 if Elaboration_Checks_Suppressed (Encl_Scop) then 18729 return False; 18730 end if; 18731 18732 Encl_Scop := Scope (Encl_Scop); 18733 end loop; 18734 18735 -- Neither the target nor its declarative context have elaboration 18736 -- checks suppressed. 18737 18738 return True; 18739 end Elaboration_Checks_OK; 18740 18741 ------------------------------------ 18742 -- Mark_Elaboration_Attributes_Id -- 18743 ------------------------------------ 18744 18745 procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id) is 18746 begin 18747 -- Mark the status of elaboration checks in effect. Do not reset the 18748 -- status in case the entity is reanalyzed with checks suppressed. 18749 18750 if Checks and then not Is_Elaboration_Checks_OK_Id (Id) then 18751 Set_Is_Elaboration_Checks_OK_Id (Id, 18752 Elaboration_Checks_OK 18753 (Target_Id => Id, 18754 Context_Id => Scope (Id))); 18755 end if; 18756 18757 -- Mark the status of elaboration warnings in effect. Do not reset 18758 -- the status in case the entity is reanalyzed with warnings off. 18759 18760 if Warnings and then not Is_Elaboration_Warnings_OK_Id (Id) then 18761 Set_Is_Elaboration_Warnings_OK_Id (Id, Elab_Warnings); 18762 end if; 18763 end Mark_Elaboration_Attributes_Id; 18764 18765 -------------------------------------- 18766 -- Mark_Elaboration_Attributes_Node -- 18767 -------------------------------------- 18768 18769 procedure Mark_Elaboration_Attributes_Node (N : Node_Id) is 18770 function Extract_Name (N : Node_Id) return Node_Id; 18771 -- Obtain the Name attribute of call or instantiation N 18772 18773 ------------------ 18774 -- Extract_Name -- 18775 ------------------ 18776 18777 function Extract_Name (N : Node_Id) return Node_Id is 18778 Nam : Node_Id; 18779 18780 begin 18781 Nam := Name (N); 18782 18783 -- A call to an entry family appears in indexed form 18784 18785 if Nkind (Nam) = N_Indexed_Component then 18786 Nam := Prefix (Nam); 18787 end if; 18788 18789 -- The name may also appear in qualified form 18790 18791 if Nkind (Nam) = N_Selected_Component then 18792 Nam := Selector_Name (Nam); 18793 end if; 18794 18795 return Nam; 18796 end Extract_Name; 18797 18798 -- Local variables 18799 18800 Context_Id : Entity_Id; 18801 Nam : Node_Id; 18802 18803 -- Start of processing for Mark_Elaboration_Attributes_Node 18804 18805 begin 18806 -- Mark the status of elaboration checks in effect. Do not reset the 18807 -- status in case the node is reanalyzed with checks suppressed. 18808 18809 if Checks and then not Is_Elaboration_Checks_OK_Node (N) then 18810 18811 -- Assignments, attribute references, and variable references do 18812 -- not have a "declarative" context. 18813 18814 Context_Id := Empty; 18815 18816 -- The status of elaboration checks for calls and instantiations 18817 -- depends on the most recent pragma Suppress/Unsuppress, as well 18818 -- as the suppression status of the context where the target is 18819 -- defined. 18820 18821 -- package Pack is 18822 -- function Func ...; 18823 -- end Pack; 18824 18825 -- with Pack; 18826 -- procedure Main is 18827 -- pragma Suppress (Elaboration_Checks, Pack); 18828 -- X : ... := Pack.Func; 18829 -- ... 18830 18831 -- In the example above, the call to Func has elaboration checks 18832 -- enabled because there is no active general purpose suppression 18833 -- pragma, however the elaboration checks of Pack are explicitly 18834 -- suppressed. As a result the elaboration checks of the call must 18835 -- be disabled in order to preserve this dependency. 18836 18837 if Nkind_In (N, N_Entry_Call_Statement, 18838 N_Function_Call, 18839 N_Function_Instantiation, 18840 N_Package_Instantiation, 18841 N_Procedure_Call_Statement, 18842 N_Procedure_Instantiation) 18843 then 18844 Nam := Extract_Name (N); 18845 18846 if Is_Entity_Name (Nam) and then Present (Entity (Nam)) then 18847 Context_Id := Scope (Entity (Nam)); 18848 end if; 18849 end if; 18850 18851 Set_Is_Elaboration_Checks_OK_Node (N, 18852 Elaboration_Checks_OK 18853 (Target_Id => Empty, 18854 Context_Id => Context_Id)); 18855 end if; 18856 18857 -- Mark the enclosing level of the node. Do not reset the status in 18858 -- case the node is relocated and reanalyzed. 18859 18860 if Level and then not Is_Declaration_Level_Node (N) then 18861 Set_Is_Declaration_Level_Node (N, 18862 Find_Enclosing_Level (N) = Declaration_Level); 18863 end if; 18864 18865 -- Mark the Ghost and SPARK mode in effect 18866 18867 if Modes then 18868 if Ghost_Mode = Ignore then 18869 Set_Is_Ignored_Ghost_Node (N); 18870 end if; 18871 18872 if SPARK_Mode = On then 18873 Set_Is_SPARK_Mode_On_Node (N); 18874 end if; 18875 end if; 18876 18877 -- Mark the status of elaboration warnings in effect. Do not reset 18878 -- the status in case the node is reanalyzed with warnings off. 18879 18880 if Warnings and then not Is_Elaboration_Warnings_OK_Node (N) then 18881 Set_Is_Elaboration_Warnings_OK_Node (N, Elab_Warnings); 18882 end if; 18883 end Mark_Elaboration_Attributes_Node; 18884 18885 -- Start of processing for Mark_Elaboration_Attributes 18886 18887 begin 18888 -- Do not capture any elaboration-related attributes when switch -gnatH 18889 -- (legacy elaboration checking mode enabled) is in effect because the 18890 -- attributes are useless to the legacy model. 18891 18892 if Legacy_Elaboration_Checks then 18893 return; 18894 end if; 18895 18896 if Nkind (N_Id) in N_Entity then 18897 Mark_Elaboration_Attributes_Id (N_Id); 18898 else 18899 Mark_Elaboration_Attributes_Node (N_Id); 18900 end if; 18901 end Mark_Elaboration_Attributes; 18902 18903 ---------------------------------- 18904 -- Matching_Static_Array_Bounds -- 18905 ---------------------------------- 18906 18907 function Matching_Static_Array_Bounds 18908 (L_Typ : Node_Id; 18909 R_Typ : Node_Id) return Boolean 18910 is 18911 L_Ndims : constant Nat := Number_Dimensions (L_Typ); 18912 R_Ndims : constant Nat := Number_Dimensions (R_Typ); 18913 18914 L_Index : Node_Id := Empty; -- init to ... 18915 R_Index : Node_Id := Empty; -- ...avoid warnings 18916 L_Low : Node_Id; 18917 L_High : Node_Id; 18918 L_Len : Uint; 18919 R_Low : Node_Id; 18920 R_High : Node_Id; 18921 R_Len : Uint; 18922 18923 begin 18924 if L_Ndims /= R_Ndims then 18925 return False; 18926 end if; 18927 18928 -- Unconstrained types do not have static bounds 18929 18930 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then 18931 return False; 18932 end if; 18933 18934 -- First treat specially the first dimension, as the lower bound and 18935 -- length of string literals are not stored like those of arrays. 18936 18937 if Ekind (L_Typ) = E_String_Literal_Subtype then 18938 L_Low := String_Literal_Low_Bound (L_Typ); 18939 L_Len := String_Literal_Length (L_Typ); 18940 else 18941 L_Index := First_Index (L_Typ); 18942 Get_Index_Bounds (L_Index, L_Low, L_High); 18943 18944 if Is_OK_Static_Expression (L_Low) 18945 and then 18946 Is_OK_Static_Expression (L_High) 18947 then 18948 if Expr_Value (L_High) < Expr_Value (L_Low) then 18949 L_Len := Uint_0; 18950 else 18951 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1; 18952 end if; 18953 else 18954 return False; 18955 end if; 18956 end if; 18957 18958 if Ekind (R_Typ) = E_String_Literal_Subtype then 18959 R_Low := String_Literal_Low_Bound (R_Typ); 18960 R_Len := String_Literal_Length (R_Typ); 18961 else 18962 R_Index := First_Index (R_Typ); 18963 Get_Index_Bounds (R_Index, R_Low, R_High); 18964 18965 if Is_OK_Static_Expression (R_Low) 18966 and then 18967 Is_OK_Static_Expression (R_High) 18968 then 18969 if Expr_Value (R_High) < Expr_Value (R_Low) then 18970 R_Len := Uint_0; 18971 else 18972 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1; 18973 end if; 18974 else 18975 return False; 18976 end if; 18977 end if; 18978 18979 if (Is_OK_Static_Expression (L_Low) 18980 and then 18981 Is_OK_Static_Expression (R_Low)) 18982 and then Expr_Value (L_Low) = Expr_Value (R_Low) 18983 and then L_Len = R_Len 18984 then 18985 null; 18986 else 18987 return False; 18988 end if; 18989 18990 -- Then treat all other dimensions 18991 18992 for Indx in 2 .. L_Ndims loop 18993 Next (L_Index); 18994 Next (R_Index); 18995 18996 Get_Index_Bounds (L_Index, L_Low, L_High); 18997 Get_Index_Bounds (R_Index, R_Low, R_High); 18998 18999 if (Is_OK_Static_Expression (L_Low) and then 19000 Is_OK_Static_Expression (L_High) and then 19001 Is_OK_Static_Expression (R_Low) and then 19002 Is_OK_Static_Expression (R_High)) 19003 and then (Expr_Value (L_Low) = Expr_Value (R_Low) 19004 and then 19005 Expr_Value (L_High) = Expr_Value (R_High)) 19006 then 19007 null; 19008 else 19009 return False; 19010 end if; 19011 end loop; 19012 19013 -- If we fall through the loop, all indexes matched 19014 19015 return True; 19016 end Matching_Static_Array_Bounds; 19017 19018 ------------------- 19019 -- May_Be_Lvalue -- 19020 ------------------- 19021 19022 function May_Be_Lvalue (N : Node_Id) return Boolean is 19023 P : constant Node_Id := Parent (N); 19024 19025 begin 19026 case Nkind (P) is 19027 19028 -- Test left side of assignment 19029 19030 when N_Assignment_Statement => 19031 return N = Name (P); 19032 19033 -- Test prefix of component or attribute. Note that the prefix of an 19034 -- explicit or implicit dereference cannot be an l-value. In the case 19035 -- of a 'Read attribute, the reference can be an actual in the 19036 -- argument list of the attribute. 19037 19038 when N_Attribute_Reference => 19039 return (N = Prefix (P) 19040 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P))) 19041 or else 19042 Attribute_Name (P) = Name_Read; 19043 19044 -- For an expanded name, the name is an lvalue if the expanded name 19045 -- is an lvalue, but the prefix is never an lvalue, since it is just 19046 -- the scope where the name is found. 19047 19048 when N_Expanded_Name => 19049 if N = Prefix (P) then 19050 return May_Be_Lvalue (P); 19051 else 19052 return False; 19053 end if; 19054 19055 -- For a selected component A.B, A is certainly an lvalue if A.B is. 19056 -- B is a little interesting, if we have A.B := 3, there is some 19057 -- discussion as to whether B is an lvalue or not, we choose to say 19058 -- it is. Note however that A is not an lvalue if it is of an access 19059 -- type since this is an implicit dereference. 19060 19061 when N_Selected_Component => 19062 if N = Prefix (P) 19063 and then Present (Etype (N)) 19064 and then Is_Access_Type (Etype (N)) 19065 then 19066 return False; 19067 else 19068 return May_Be_Lvalue (P); 19069 end if; 19070 19071 -- For an indexed component or slice, the index or slice bounds is 19072 -- never an lvalue. The prefix is an lvalue if the indexed component 19073 -- or slice is an lvalue, except if it is an access type, where we 19074 -- have an implicit dereference. 19075 19076 when N_Indexed_Component 19077 | N_Slice 19078 => 19079 if N /= Prefix (P) 19080 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N))) 19081 then 19082 return False; 19083 else 19084 return May_Be_Lvalue (P); 19085 end if; 19086 19087 -- Prefix of a reference is an lvalue if the reference is an lvalue 19088 19089 when N_Reference => 19090 return May_Be_Lvalue (P); 19091 19092 -- Prefix of explicit dereference is never an lvalue 19093 19094 when N_Explicit_Dereference => 19095 return False; 19096 19097 -- Positional parameter for subprogram, entry, or accept call. 19098 -- In older versions of Ada function call arguments are never 19099 -- lvalues. In Ada 2012 functions can have in-out parameters. 19100 19101 when N_Accept_Statement 19102 | N_Entry_Call_Statement 19103 | N_Subprogram_Call 19104 => 19105 if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then 19106 return False; 19107 end if; 19108 19109 -- The following mechanism is clumsy and fragile. A single flag 19110 -- set in Resolve_Actuals would be preferable ??? 19111 19112 declare 19113 Proc : Entity_Id; 19114 Form : Entity_Id; 19115 Act : Node_Id; 19116 19117 begin 19118 Proc := Get_Subprogram_Entity (P); 19119 19120 if No (Proc) then 19121 return True; 19122 end if; 19123 19124 -- If we are not a list member, something is strange, so be 19125 -- conservative and return True. 19126 19127 if not Is_List_Member (N) then 19128 return True; 19129 end if; 19130 19131 -- We are going to find the right formal by stepping forward 19132 -- through the formals, as we step backwards in the actuals. 19133 19134 Form := First_Formal (Proc); 19135 Act := N; 19136 loop 19137 -- If no formal, something is weird, so be conservative and 19138 -- return True. 19139 19140 if No (Form) then 19141 return True; 19142 end if; 19143 19144 Prev (Act); 19145 exit when No (Act); 19146 Next_Formal (Form); 19147 end loop; 19148 19149 return Ekind (Form) /= E_In_Parameter; 19150 end; 19151 19152 -- Named parameter for procedure or accept call 19153 19154 when N_Parameter_Association => 19155 declare 19156 Proc : Entity_Id; 19157 Form : Entity_Id; 19158 19159 begin 19160 Proc := Get_Subprogram_Entity (Parent (P)); 19161 19162 if No (Proc) then 19163 return True; 19164 end if; 19165 19166 -- Loop through formals to find the one that matches 19167 19168 Form := First_Formal (Proc); 19169 loop 19170 -- If no matching formal, that's peculiar, some kind of 19171 -- previous error, so return True to be conservative. 19172 -- Actually happens with legal code for an unresolved call 19173 -- where we may get the wrong homonym??? 19174 19175 if No (Form) then 19176 return True; 19177 end if; 19178 19179 -- Else test for match 19180 19181 if Chars (Form) = Chars (Selector_Name (P)) then 19182 return Ekind (Form) /= E_In_Parameter; 19183 end if; 19184 19185 Next_Formal (Form); 19186 end loop; 19187 end; 19188 19189 -- Test for appearing in a conversion that itself appears in an 19190 -- lvalue context, since this should be an lvalue. 19191 19192 when N_Type_Conversion => 19193 return May_Be_Lvalue (P); 19194 19195 -- Test for appearance in object renaming declaration 19196 19197 when N_Object_Renaming_Declaration => 19198 return True; 19199 19200 -- All other references are definitely not lvalues 19201 19202 when others => 19203 return False; 19204 end case; 19205 end May_Be_Lvalue; 19206 19207 ----------------- 19208 -- Might_Raise -- 19209 ----------------- 19210 19211 function Might_Raise (N : Node_Id) return Boolean is 19212 Result : Boolean := False; 19213 19214 function Process (N : Node_Id) return Traverse_Result; 19215 -- Set Result to True if we find something that could raise an exception 19216 19217 ------------- 19218 -- Process -- 19219 ------------- 19220 19221 function Process (N : Node_Id) return Traverse_Result is 19222 begin 19223 if Nkind_In (N, N_Procedure_Call_Statement, 19224 N_Function_Call, 19225 N_Raise_Statement, 19226 N_Raise_Constraint_Error, 19227 N_Raise_Program_Error, 19228 N_Raise_Storage_Error) 19229 then 19230 Result := True; 19231 return Abandon; 19232 else 19233 return OK; 19234 end if; 19235 end Process; 19236 19237 procedure Set_Result is new Traverse_Proc (Process); 19238 19239 -- Start of processing for Might_Raise 19240 19241 begin 19242 -- False if exceptions can't be propagated 19243 19244 if No_Exception_Handlers_Set then 19245 return False; 19246 end if; 19247 19248 -- If the checks handled by the back end are not disabled, we cannot 19249 -- ensure that no exception will be raised. 19250 19251 if not Access_Checks_Suppressed (Empty) 19252 or else not Discriminant_Checks_Suppressed (Empty) 19253 or else not Range_Checks_Suppressed (Empty) 19254 or else not Index_Checks_Suppressed (Empty) 19255 or else Opt.Stack_Checking_Enabled 19256 then 19257 return True; 19258 end if; 19259 19260 Set_Result (N); 19261 return Result; 19262 end Might_Raise; 19263 19264 -------------------------------- 19265 -- Nearest_Enclosing_Instance -- 19266 -------------------------------- 19267 19268 function Nearest_Enclosing_Instance (E : Entity_Id) return Entity_Id is 19269 Inst : Entity_Id; 19270 19271 begin 19272 Inst := Scope (E); 19273 while Present (Inst) and then Inst /= Standard_Standard loop 19274 if Is_Generic_Instance (Inst) then 19275 return Inst; 19276 end if; 19277 19278 Inst := Scope (Inst); 19279 end loop; 19280 19281 return Empty; 19282 end Nearest_Enclosing_Instance; 19283 19284 ---------------------- 19285 -- Needs_One_Actual -- 19286 ---------------------- 19287 19288 function Needs_One_Actual (E : Entity_Id) return Boolean is 19289 Formal : Entity_Id; 19290 19291 begin 19292 -- Ada 2005 or later, and formals present. The first formal must be 19293 -- of a type that supports prefix notation: a controlling argument, 19294 -- a class-wide type, or an access to such. 19295 19296 if Ada_Version >= Ada_2005 19297 and then Present (First_Formal (E)) 19298 and then No (Default_Value (First_Formal (E))) 19299 and then 19300 (Is_Controlling_Formal (First_Formal (E)) 19301 or else Is_Class_Wide_Type (Etype (First_Formal (E))) 19302 or else Is_Anonymous_Access_Type (Etype (First_Formal (E)))) 19303 then 19304 Formal := Next_Formal (First_Formal (E)); 19305 while Present (Formal) loop 19306 if No (Default_Value (Formal)) then 19307 return False; 19308 end if; 19309 19310 Next_Formal (Formal); 19311 end loop; 19312 19313 return True; 19314 19315 -- Ada 83/95 or no formals 19316 19317 else 19318 return False; 19319 end if; 19320 end Needs_One_Actual; 19321 19322 --------------------------------- 19323 -- Needs_Simple_Initialization -- 19324 --------------------------------- 19325 19326 function Needs_Simple_Initialization 19327 (Typ : Entity_Id; 19328 Consider_IS : Boolean := True) return Boolean 19329 is 19330 Consider_IS_NS : constant Boolean := 19331 Normalize_Scalars or (Initialize_Scalars and Consider_IS); 19332 19333 begin 19334 -- Never need initialization if it is suppressed 19335 19336 if Initialization_Suppressed (Typ) then 19337 return False; 19338 end if; 19339 19340 -- Check for private type, in which case test applies to the underlying 19341 -- type of the private type. 19342 19343 if Is_Private_Type (Typ) then 19344 declare 19345 RT : constant Entity_Id := Underlying_Type (Typ); 19346 begin 19347 if Present (RT) then 19348 return Needs_Simple_Initialization (RT); 19349 else 19350 return False; 19351 end if; 19352 end; 19353 19354 -- Scalar type with Default_Value aspect requires initialization 19355 19356 elsif Is_Scalar_Type (Typ) and then Has_Default_Aspect (Typ) then 19357 return True; 19358 19359 -- Cases needing simple initialization are access types, and, if pragma 19360 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar 19361 -- types. 19362 19363 elsif Is_Access_Type (Typ) 19364 or else (Consider_IS_NS and then (Is_Scalar_Type (Typ))) 19365 then 19366 return True; 19367 19368 -- If Initialize/Normalize_Scalars is in effect, string objects also 19369 -- need initialization, unless they are created in the course of 19370 -- expanding an aggregate (since in the latter case they will be 19371 -- filled with appropriate initializing values before they are used). 19372 19373 elsif Consider_IS_NS 19374 and then Is_Standard_String_Type (Typ) 19375 and then 19376 (not Is_Itype (Typ) 19377 or else Nkind (Associated_Node_For_Itype (Typ)) /= N_Aggregate) 19378 then 19379 return True; 19380 19381 else 19382 return False; 19383 end if; 19384 end Needs_Simple_Initialization; 19385 19386 ------------------------------------- 19387 -- Needs_Variable_Reference_Marker -- 19388 ------------------------------------- 19389 19390 function Needs_Variable_Reference_Marker 19391 (N : Node_Id; 19392 Calls_OK : Boolean) return Boolean 19393 is 19394 function Within_Suitable_Context (Ref : Node_Id) return Boolean; 19395 -- Deteremine whether variable reference Ref appears within a suitable 19396 -- context that allows the creation of a marker. 19397 19398 ----------------------------- 19399 -- Within_Suitable_Context -- 19400 ----------------------------- 19401 19402 function Within_Suitable_Context (Ref : Node_Id) return Boolean is 19403 Par : Node_Id; 19404 19405 begin 19406 Par := Ref; 19407 while Present (Par) loop 19408 19409 -- The context is not suitable when the reference appears within 19410 -- the formal part of an instantiation which acts as compilation 19411 -- unit because there is no proper list for the insertion of the 19412 -- marker. 19413 19414 if Nkind (Par) = N_Generic_Association 19415 and then Nkind (Parent (Par)) in N_Generic_Instantiation 19416 and then Nkind (Parent (Parent (Par))) = N_Compilation_Unit 19417 then 19418 return False; 19419 19420 -- The context is not suitable when the reference appears within 19421 -- a pragma. If the pragma has run-time semantics, the reference 19422 -- will be reconsidered once the pragma is expanded. 19423 19424 elsif Nkind (Par) = N_Pragma then 19425 return False; 19426 19427 -- The context is not suitable when the reference appears within a 19428 -- subprogram call, and the caller requests this behavior. 19429 19430 elsif not Calls_OK 19431 and then Nkind_In (Par, N_Entry_Call_Statement, 19432 N_Function_Call, 19433 N_Procedure_Call_Statement) 19434 then 19435 return False; 19436 19437 -- Prevent the search from going too far 19438 19439 elsif Is_Body_Or_Package_Declaration (Par) then 19440 exit; 19441 end if; 19442 19443 Par := Parent (Par); 19444 end loop; 19445 19446 return True; 19447 end Within_Suitable_Context; 19448 19449 -- Local variables 19450 19451 Prag : Node_Id; 19452 Var_Id : Entity_Id; 19453 19454 -- Start of processing for Needs_Variable_Reference_Marker 19455 19456 begin 19457 -- No marker needs to be created when switch -gnatH (legacy elaboration 19458 -- checking mode enabled) is in effect because the legacy ABE mechanism 19459 -- does not use markers. 19460 19461 if Legacy_Elaboration_Checks then 19462 return False; 19463 19464 -- No marker needs to be created for ASIS because ABE diagnostics and 19465 -- checks are not performed in this mode. 19466 19467 elsif ASIS_Mode then 19468 return False; 19469 19470 -- No marker needs to be created when the reference is preanalyzed 19471 -- because the marker will be inserted in the wrong place. 19472 19473 elsif Preanalysis_Active then 19474 return False; 19475 19476 -- Only references warrant a marker 19477 19478 elsif not Nkind_In (N, N_Expanded_Name, N_Identifier) then 19479 return False; 19480 19481 -- Only source references warrant a marker 19482 19483 elsif not Comes_From_Source (N) then 19484 return False; 19485 19486 -- No marker needs to be created when the reference is erroneous, left 19487 -- in a bad state, or does not denote a variable. 19488 19489 elsif not (Present (Entity (N)) 19490 and then Ekind (Entity (N)) = E_Variable 19491 and then Entity (N) /= Any_Id) 19492 then 19493 return False; 19494 end if; 19495 19496 Var_Id := Entity (N); 19497 Prag := SPARK_Pragma (Var_Id); 19498 19499 -- Both the variable and reference must appear in SPARK_Mode On regions 19500 -- because this elaboration scenario falls under the SPARK rules. 19501 19502 if not (Comes_From_Source (Var_Id) 19503 and then Present (Prag) 19504 and then Get_SPARK_Mode_From_Annotation (Prag) = On 19505 and then Is_SPARK_Mode_On_Node (N)) 19506 then 19507 return False; 19508 19509 -- No marker needs to be created when the reference does not appear 19510 -- within a suitable context (see body for details). 19511 19512 -- Performance note: parent traversal 19513 19514 elsif not Within_Suitable_Context (N) then 19515 return False; 19516 end if; 19517 19518 -- At this point it is known that the variable reference will play a 19519 -- role in ABE diagnostics and requires a marker. 19520 19521 return True; 19522 end Needs_Variable_Reference_Marker; 19523 19524 ------------------------ 19525 -- New_Copy_List_Tree -- 19526 ------------------------ 19527 19528 function New_Copy_List_Tree (List : List_Id) return List_Id is 19529 NL : List_Id; 19530 E : Node_Id; 19531 19532 begin 19533 if List = No_List then 19534 return No_List; 19535 19536 else 19537 NL := New_List; 19538 E := First (List); 19539 19540 while Present (E) loop 19541 Append (New_Copy_Tree (E), NL); 19542 E := Next (E); 19543 end loop; 19544 19545 return NL; 19546 end if; 19547 end New_Copy_List_Tree; 19548 19549 ------------------- 19550 -- New_Copy_Tree -- 19551 ------------------- 19552 19553 -- The following tables play a key role in replicating entities and Itypes. 19554 -- They are intentionally declared at the library level rather than within 19555 -- New_Copy_Tree to avoid elaborating them on each call. This performance 19556 -- optimization saves up to 2% of the entire compilation time spent in the 19557 -- front end. Care should be taken to reset the tables on each new call to 19558 -- New_Copy_Tree. 19559 19560 NCT_Table_Max : constant := 511; 19561 19562 subtype NCT_Table_Index is Nat range 0 .. NCT_Table_Max - 1; 19563 19564 function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index; 19565 -- Obtain the hash value of node or entity Key 19566 19567 -------------------- 19568 -- NCT_Table_Hash -- 19569 -------------------- 19570 19571 function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index is 19572 begin 19573 return NCT_Table_Index (Key mod NCT_Table_Max); 19574 end NCT_Table_Hash; 19575 19576 ---------------------- 19577 -- NCT_New_Entities -- 19578 ---------------------- 19579 19580 -- The following table maps old entities and Itypes to their corresponding 19581 -- new entities and Itypes. 19582 19583 -- Aaa -> Xxx 19584 19585 package NCT_New_Entities is new Simple_HTable ( 19586 Header_Num => NCT_Table_Index, 19587 Element => Entity_Id, 19588 No_Element => Empty, 19589 Key => Entity_Id, 19590 Hash => NCT_Table_Hash, 19591 Equal => "="); 19592 19593 ------------------------ 19594 -- NCT_Pending_Itypes -- 19595 ------------------------ 19596 19597 -- The following table maps old Associated_Node_For_Itype nodes to a set of 19598 -- new itypes. Given a set of old Itypes Aaa, Bbb, and Ccc, where all three 19599 -- have the same Associated_Node_For_Itype Ppp, and their corresponding new 19600 -- Itypes Xxx, Yyy, Zzz, the table contains the following mapping: 19601 19602 -- Ppp -> (Xxx, Yyy, Zzz) 19603 19604 -- The set is expressed as an Elist 19605 19606 package NCT_Pending_Itypes is new Simple_HTable ( 19607 Header_Num => NCT_Table_Index, 19608 Element => Elist_Id, 19609 No_Element => No_Elist, 19610 Key => Node_Id, 19611 Hash => NCT_Table_Hash, 19612 Equal => "="); 19613 19614 NCT_Tables_In_Use : Boolean := False; 19615 -- This flag keeps track of whether the two tables NCT_New_Entities and 19616 -- NCT_Pending_Itypes are in use. The flag is part of an optimization 19617 -- where certain operations are not performed if the tables are not in 19618 -- use. This saves up to 8% of the entire compilation time spent in the 19619 -- front end. 19620 19621 ------------------- 19622 -- New_Copy_Tree -- 19623 ------------------- 19624 19625 function New_Copy_Tree 19626 (Source : Node_Id; 19627 Map : Elist_Id := No_Elist; 19628 New_Sloc : Source_Ptr := No_Location; 19629 New_Scope : Entity_Id := Empty; 19630 Scopes_In_EWA_OK : Boolean := False) return Node_Id 19631 is 19632 -- This routine performs low-level tree manipulations and needs access 19633 -- to the internals of the tree. 19634 19635 use Atree.Unchecked_Access; 19636 use Atree_Private_Part; 19637 19638 EWA_Level : Nat := 0; 19639 -- This counter keeps track of how many N_Expression_With_Actions nodes 19640 -- are encountered during a depth-first traversal of the subtree. These 19641 -- nodes may define new entities in their Actions lists and thus require 19642 -- special processing. 19643 19644 EWA_Inner_Scope_Level : Nat := 0; 19645 -- This counter keeps track of how many scoping constructs appear within 19646 -- an N_Expression_With_Actions node. 19647 19648 procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id); 19649 pragma Inline (Add_New_Entity); 19650 -- Add an entry in the NCT_New_Entities table which maps key Old_Id to 19651 -- value New_Id. Old_Id is an entity which appears within the Actions 19652 -- list of an N_Expression_With_Actions node, or within an entity map. 19653 -- New_Id is the corresponding new entity generated during Phase 1. 19654 19655 procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id); 19656 pragma Inline (Add_New_Entity); 19657 -- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to 19658 -- value Itype. Assoc_Nod is the associated node of an itype. Itype is 19659 -- an itype. 19660 19661 procedure Build_NCT_Tables (Entity_Map : Elist_Id); 19662 pragma Inline (Build_NCT_Tables); 19663 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with the 19664 -- information supplied in entity map Entity_Map. The format of the 19665 -- entity map must be as follows: 19666 -- 19667 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN 19668 19669 function Copy_Any_Node_With_Replacement 19670 (N : Node_Or_Entity_Id) return Node_Or_Entity_Id; 19671 pragma Inline (Copy_Any_Node_With_Replacement); 19672 -- Replicate entity or node N by invoking one of the following routines: 19673 -- 19674 -- Copy_Node_With_Replacement 19675 -- Corresponding_Entity 19676 19677 function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id; 19678 -- Replicate the elements of entity list List 19679 19680 function Copy_Field_With_Replacement 19681 (Field : Union_Id; 19682 Old_Par : Node_Id := Empty; 19683 New_Par : Node_Id := Empty; 19684 Semantic : Boolean := False) return Union_Id; 19685 -- Replicate field Field by invoking one of the following routines: 19686 -- 19687 -- Copy_Elist_With_Replacement 19688 -- Copy_List_With_Replacement 19689 -- Copy_Node_With_Replacement 19690 -- Corresponding_Entity 19691 -- 19692 -- If the field is not an entity list, entity, itype, syntactic list, 19693 -- or node, then the field is returned unchanged. The routine always 19694 -- replicates entities, itypes, and valid syntactic fields. Old_Par is 19695 -- the expected parent of a syntactic field. New_Par is the new parent 19696 -- associated with a replicated syntactic field. Flag Semantic should 19697 -- be set when the input is a semantic field. 19698 19699 function Copy_List_With_Replacement (List : List_Id) return List_Id; 19700 -- Replicate the elements of syntactic list List 19701 19702 function Copy_Node_With_Replacement (N : Node_Id) return Node_Id; 19703 -- Replicate node N 19704 19705 function Corresponding_Entity (Id : Entity_Id) return Entity_Id; 19706 pragma Inline (Corresponding_Entity); 19707 -- Return the corresponding new entity of Id generated during Phase 1. 19708 -- If there is no such entity, return Id. 19709 19710 function In_Entity_Map 19711 (Id : Entity_Id; 19712 Entity_Map : Elist_Id) return Boolean; 19713 pragma Inline (In_Entity_Map); 19714 -- Determine whether entity Id is one of the old ids specified in entity 19715 -- map Entity_Map. The format of the entity map must be as follows: 19716 -- 19717 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN 19718 19719 procedure Update_CFS_Sloc (N : Node_Or_Entity_Id); 19720 pragma Inline (Update_CFS_Sloc); 19721 -- Update the Comes_From_Source and Sloc attributes of node or entity N 19722 19723 procedure Update_First_Real_Statement 19724 (Old_HSS : Node_Id; 19725 New_HSS : Node_Id); 19726 pragma Inline (Update_First_Real_Statement); 19727 -- Update semantic attribute First_Real_Statement of handled sequence of 19728 -- statements New_HSS based on handled sequence of statements Old_HSS. 19729 19730 procedure Update_Named_Associations 19731 (Old_Call : Node_Id; 19732 New_Call : Node_Id); 19733 pragma Inline (Update_Named_Associations); 19734 -- Update semantic chain First/Next_Named_Association of call New_call 19735 -- based on call Old_Call. 19736 19737 procedure Update_New_Entities (Entity_Map : Elist_Id); 19738 pragma Inline (Update_New_Entities); 19739 -- Update the semantic attributes of all new entities generated during 19740 -- Phase 1 that do not appear in entity map Entity_Map. The format of 19741 -- the entity map must be as follows: 19742 -- 19743 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN 19744 19745 procedure Update_Pending_Itypes 19746 (Old_Assoc : Node_Id; 19747 New_Assoc : Node_Id); 19748 pragma Inline (Update_Pending_Itypes); 19749 -- Update semantic attribute Associated_Node_For_Itype to refer to node 19750 -- New_Assoc for all itypes whose associated node is Old_Assoc. 19751 19752 procedure Update_Semantic_Fields (Id : Entity_Id); 19753 pragma Inline (Update_Semantic_Fields); 19754 -- Subsidiary to Update_New_Entities. Update semantic fields of entity 19755 -- or itype Id. 19756 19757 procedure Visit_Any_Node (N : Node_Or_Entity_Id); 19758 pragma Inline (Visit_Any_Node); 19759 -- Visit entity of node N by invoking one of the following routines: 19760 -- 19761 -- Visit_Entity 19762 -- Visit_Itype 19763 -- Visit_Node 19764 19765 procedure Visit_Elist (List : Elist_Id); 19766 -- Visit the elements of entity list List 19767 19768 procedure Visit_Entity (Id : Entity_Id); 19769 -- Visit entity Id. This action may create a new entity of Id and save 19770 -- it in table NCT_New_Entities. 19771 19772 procedure Visit_Field 19773 (Field : Union_Id; 19774 Par_Nod : Node_Id := Empty; 19775 Semantic : Boolean := False); 19776 -- Visit field Field by invoking one of the following routines: 19777 -- 19778 -- Visit_Elist 19779 -- Visit_Entity 19780 -- Visit_Itype 19781 -- Visit_List 19782 -- Visit_Node 19783 -- 19784 -- If the field is not an entity list, entity, itype, syntactic list, 19785 -- or node, then the field is not visited. The routine always visits 19786 -- valid syntactic fields. Par_Nod is the expected parent of the 19787 -- syntactic field. Flag Semantic should be set when the input is a 19788 -- semantic field. 19789 19790 procedure Visit_Itype (Itype : Entity_Id); 19791 -- Visit itype Itype. This action may create a new entity for Itype and 19792 -- save it in table NCT_New_Entities. In addition, the routine may map 19793 -- the associated node of Itype to the new itype in NCT_Pending_Itypes. 19794 19795 procedure Visit_List (List : List_Id); 19796 -- Visit the elements of syntactic list List 19797 19798 procedure Visit_Node (N : Node_Id); 19799 -- Visit node N 19800 19801 procedure Visit_Semantic_Fields (Id : Entity_Id); 19802 pragma Inline (Visit_Semantic_Fields); 19803 -- Subsidiary to Visit_Entity and Visit_Itype. Visit common semantic 19804 -- fields of entity or itype Id. 19805 19806 -------------------- 19807 -- Add_New_Entity -- 19808 -------------------- 19809 19810 procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id) is 19811 begin 19812 pragma Assert (Present (Old_Id)); 19813 pragma Assert (Present (New_Id)); 19814 pragma Assert (Nkind (Old_Id) in N_Entity); 19815 pragma Assert (Nkind (New_Id) in N_Entity); 19816 19817 NCT_Tables_In_Use := True; 19818 19819 -- Sanity check the NCT_New_Entities table. No previous mapping with 19820 -- key Old_Id should exist. 19821 19822 pragma Assert (No (NCT_New_Entities.Get (Old_Id))); 19823 19824 -- Establish the mapping 19825 19826 -- Old_Id -> New_Id 19827 19828 NCT_New_Entities.Set (Old_Id, New_Id); 19829 end Add_New_Entity; 19830 19831 ----------------------- 19832 -- Add_Pending_Itype -- 19833 ----------------------- 19834 19835 procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id) is 19836 Itypes : Elist_Id; 19837 19838 begin 19839 pragma Assert (Present (Assoc_Nod)); 19840 pragma Assert (Present (Itype)); 19841 pragma Assert (Nkind (Itype) in N_Entity); 19842 pragma Assert (Is_Itype (Itype)); 19843 19844 NCT_Tables_In_Use := True; 19845 19846 -- It is not possible to sanity check the NCT_Pendint_Itypes table 19847 -- directly because a single node may act as the associated node for 19848 -- multiple itypes. 19849 19850 Itypes := NCT_Pending_Itypes.Get (Assoc_Nod); 19851 19852 if No (Itypes) then 19853 Itypes := New_Elmt_List; 19854 NCT_Pending_Itypes.Set (Assoc_Nod, Itypes); 19855 end if; 19856 19857 -- Establish the mapping 19858 19859 -- Assoc_Nod -> (Itype, ...) 19860 19861 -- Avoid inserting the same itype multiple times. This involves a 19862 -- linear search, however the set of itypes with the same associated 19863 -- node is very small. 19864 19865 Append_Unique_Elmt (Itype, Itypes); 19866 end Add_Pending_Itype; 19867 19868 ---------------------- 19869 -- Build_NCT_Tables -- 19870 ---------------------- 19871 19872 procedure Build_NCT_Tables (Entity_Map : Elist_Id) is 19873 Elmt : Elmt_Id; 19874 Old_Id : Entity_Id; 19875 New_Id : Entity_Id; 19876 19877 begin 19878 -- Nothing to do when there is no entity map 19879 19880 if No (Entity_Map) then 19881 return; 19882 end if; 19883 19884 Elmt := First_Elmt (Entity_Map); 19885 while Present (Elmt) loop 19886 19887 -- Extract the (Old_Id, New_Id) pair from the entity map 19888 19889 Old_Id := Node (Elmt); 19890 Next_Elmt (Elmt); 19891 19892 New_Id := Node (Elmt); 19893 Next_Elmt (Elmt); 19894 19895 -- Establish the following mapping within table NCT_New_Entities 19896 19897 -- Old_Id -> New_Id 19898 19899 Add_New_Entity (Old_Id, New_Id); 19900 19901 -- Establish the following mapping within table NCT_Pending_Itypes 19902 -- when the new entity is an itype. 19903 19904 -- Assoc_Nod -> (New_Id, ...) 19905 19906 -- IMPORTANT: the associated node is that of the old itype because 19907 -- the node will be replicated in Phase 2. 19908 19909 if Is_Itype (Old_Id) then 19910 Add_Pending_Itype 19911 (Assoc_Nod => Associated_Node_For_Itype (Old_Id), 19912 Itype => New_Id); 19913 end if; 19914 end loop; 19915 end Build_NCT_Tables; 19916 19917 ------------------------------------ 19918 -- Copy_Any_Node_With_Replacement -- 19919 ------------------------------------ 19920 19921 function Copy_Any_Node_With_Replacement 19922 (N : Node_Or_Entity_Id) return Node_Or_Entity_Id 19923 is 19924 begin 19925 if Nkind (N) in N_Entity then 19926 return Corresponding_Entity (N); 19927 else 19928 return Copy_Node_With_Replacement (N); 19929 end if; 19930 end Copy_Any_Node_With_Replacement; 19931 19932 --------------------------------- 19933 -- Copy_Elist_With_Replacement -- 19934 --------------------------------- 19935 19936 function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id is 19937 Elmt : Elmt_Id; 19938 Result : Elist_Id; 19939 19940 begin 19941 -- Copy the contents of the old list. Note that the list itself may 19942 -- be empty, in which case the routine returns a new empty list. This 19943 -- avoids sharing lists between subtrees. The element of an entity 19944 -- list could be an entity or a node, hence the invocation of routine 19945 -- Copy_Any_Node_With_Replacement. 19946 19947 if Present (List) then 19948 Result := New_Elmt_List; 19949 19950 Elmt := First_Elmt (List); 19951 while Present (Elmt) loop 19952 Append_Elmt 19953 (Copy_Any_Node_With_Replacement (Node (Elmt)), Result); 19954 19955 Next_Elmt (Elmt); 19956 end loop; 19957 19958 -- Otherwise the list does not exist 19959 19960 else 19961 Result := No_Elist; 19962 end if; 19963 19964 return Result; 19965 end Copy_Elist_With_Replacement; 19966 19967 --------------------------------- 19968 -- Copy_Field_With_Replacement -- 19969 --------------------------------- 19970 19971 function Copy_Field_With_Replacement 19972 (Field : Union_Id; 19973 Old_Par : Node_Id := Empty; 19974 New_Par : Node_Id := Empty; 19975 Semantic : Boolean := False) return Union_Id 19976 is 19977 begin 19978 -- The field is empty 19979 19980 if Field = Union_Id (Empty) then 19981 return Field; 19982 19983 -- The field is an entity/itype/node 19984 19985 elsif Field in Node_Range then 19986 declare 19987 Old_N : constant Node_Id := Node_Id (Field); 19988 Syntactic : constant Boolean := Parent (Old_N) = Old_Par; 19989 19990 New_N : Node_Id; 19991 19992 begin 19993 -- The field is an entity/itype 19994 19995 if Nkind (Old_N) in N_Entity then 19996 19997 -- An entity/itype is always replicated 19998 19999 New_N := Corresponding_Entity (Old_N); 20000 20001 -- Update the parent pointer when the entity is a syntactic 20002 -- field. Note that itypes do not have parent pointers. 20003 20004 if Syntactic and then New_N /= Old_N then 20005 Set_Parent (New_N, New_Par); 20006 end if; 20007 20008 -- The field is a node 20009 20010 else 20011 -- A node is replicated when it is either a syntactic field 20012 -- or when the caller treats it as a semantic attribute. 20013 20014 if Syntactic or else Semantic then 20015 New_N := Copy_Node_With_Replacement (Old_N); 20016 20017 -- Update the parent pointer when the node is a syntactic 20018 -- field. 20019 20020 if Syntactic and then New_N /= Old_N then 20021 Set_Parent (New_N, New_Par); 20022 end if; 20023 20024 -- Otherwise the node is returned unchanged 20025 20026 else 20027 New_N := Old_N; 20028 end if; 20029 end if; 20030 20031 return Union_Id (New_N); 20032 end; 20033 20034 -- The field is an entity list 20035 20036 elsif Field in Elist_Range then 20037 return Union_Id (Copy_Elist_With_Replacement (Elist_Id (Field))); 20038 20039 -- The field is a syntactic list 20040 20041 elsif Field in List_Range then 20042 declare 20043 Old_List : constant List_Id := List_Id (Field); 20044 Syntactic : constant Boolean := Parent (Old_List) = Old_Par; 20045 20046 New_List : List_Id; 20047 20048 begin 20049 -- A list is replicated when it is either a syntactic field or 20050 -- when the caller treats it as a semantic attribute. 20051 20052 if Syntactic or else Semantic then 20053 New_List := Copy_List_With_Replacement (Old_List); 20054 20055 -- Update the parent pointer when the list is a syntactic 20056 -- field. 20057 20058 if Syntactic and then New_List /= Old_List then 20059 Set_Parent (New_List, New_Par); 20060 end if; 20061 20062 -- Otherwise the list is returned unchanged 20063 20064 else 20065 New_List := Old_List; 20066 end if; 20067 20068 return Union_Id (New_List); 20069 end; 20070 20071 -- Otherwise the field denotes an attribute that does not need to be 20072 -- replicated (Chars, literals, etc). 20073 20074 else 20075 return Field; 20076 end if; 20077 end Copy_Field_With_Replacement; 20078 20079 -------------------------------- 20080 -- Copy_List_With_Replacement -- 20081 -------------------------------- 20082 20083 function Copy_List_With_Replacement (List : List_Id) return List_Id is 20084 Elmt : Node_Id; 20085 Result : List_Id; 20086 20087 begin 20088 -- Copy the contents of the old list. Note that the list itself may 20089 -- be empty, in which case the routine returns a new empty list. This 20090 -- avoids sharing lists between subtrees. The element of a syntactic 20091 -- list is always a node, never an entity or itype, hence the call to 20092 -- routine Copy_Node_With_Replacement. 20093 20094 if Present (List) then 20095 Result := New_List; 20096 20097 Elmt := First (List); 20098 while Present (Elmt) loop 20099 Append (Copy_Node_With_Replacement (Elmt), Result); 20100 20101 Next (Elmt); 20102 end loop; 20103 20104 -- Otherwise the list does not exist 20105 20106 else 20107 Result := No_List; 20108 end if; 20109 20110 return Result; 20111 end Copy_List_With_Replacement; 20112 20113 -------------------------------- 20114 -- Copy_Node_With_Replacement -- 20115 -------------------------------- 20116 20117 function Copy_Node_With_Replacement (N : Node_Id) return Node_Id is 20118 Result : Node_Id; 20119 20120 begin 20121 -- Assume that the node must be returned unchanged 20122 20123 Result := N; 20124 20125 if N > Empty_Or_Error then 20126 pragma Assert (Nkind (N) not in N_Entity); 20127 20128 Result := New_Copy (N); 20129 20130 Set_Field1 (Result, 20131 Copy_Field_With_Replacement 20132 (Field => Field1 (Result), 20133 Old_Par => N, 20134 New_Par => Result)); 20135 20136 Set_Field2 (Result, 20137 Copy_Field_With_Replacement 20138 (Field => Field2 (Result), 20139 Old_Par => N, 20140 New_Par => Result)); 20141 20142 Set_Field3 (Result, 20143 Copy_Field_With_Replacement 20144 (Field => Field3 (Result), 20145 Old_Par => N, 20146 New_Par => Result)); 20147 20148 Set_Field4 (Result, 20149 Copy_Field_With_Replacement 20150 (Field => Field4 (Result), 20151 Old_Par => N, 20152 New_Par => Result)); 20153 20154 Set_Field5 (Result, 20155 Copy_Field_With_Replacement 20156 (Field => Field5 (Result), 20157 Old_Par => N, 20158 New_Par => Result)); 20159 20160 -- Update the Comes_From_Source and Sloc attributes of the node 20161 -- in case the caller has supplied new values. 20162 20163 Update_CFS_Sloc (Result); 20164 20165 -- Update the Associated_Node_For_Itype attribute of all itypes 20166 -- created during Phase 1 whose associated node is N. As a result 20167 -- the Associated_Node_For_Itype refers to the replicated node. 20168 -- No action needs to be taken when the Associated_Node_For_Itype 20169 -- refers to an entity because this was already handled during 20170 -- Phase 1, in Visit_Itype. 20171 20172 Update_Pending_Itypes 20173 (Old_Assoc => N, 20174 New_Assoc => Result); 20175 20176 -- Update the First/Next_Named_Association chain for a replicated 20177 -- call. 20178 20179 if Nkind_In (N, N_Entry_Call_Statement, 20180 N_Function_Call, 20181 N_Procedure_Call_Statement) 20182 then 20183 Update_Named_Associations 20184 (Old_Call => N, 20185 New_Call => Result); 20186 20187 -- Update the Renamed_Object attribute of a replicated object 20188 -- declaration. 20189 20190 elsif Nkind (N) = N_Object_Renaming_Declaration then 20191 Set_Renamed_Object (Defining_Entity (Result), Name (Result)); 20192 20193 -- Update the First_Real_Statement attribute of a replicated 20194 -- handled sequence of statements. 20195 20196 elsif Nkind (N) = N_Handled_Sequence_Of_Statements then 20197 Update_First_Real_Statement 20198 (Old_HSS => N, 20199 New_HSS => Result); 20200 end if; 20201 end if; 20202 20203 return Result; 20204 end Copy_Node_With_Replacement; 20205 20206 -------------------------- 20207 -- Corresponding_Entity -- 20208 -------------------------- 20209 20210 function Corresponding_Entity (Id : Entity_Id) return Entity_Id is 20211 New_Id : Entity_Id; 20212 Result : Entity_Id; 20213 20214 begin 20215 -- Assume that the entity must be returned unchanged 20216 20217 Result := Id; 20218 20219 if Id > Empty_Or_Error then 20220 pragma Assert (Nkind (Id) in N_Entity); 20221 20222 -- Determine whether the entity has a corresponding new entity 20223 -- generated during Phase 1 and if it does, use it. 20224 20225 if NCT_Tables_In_Use then 20226 New_Id := NCT_New_Entities.Get (Id); 20227 20228 if Present (New_Id) then 20229 Result := New_Id; 20230 end if; 20231 end if; 20232 end if; 20233 20234 return Result; 20235 end Corresponding_Entity; 20236 20237 ------------------- 20238 -- In_Entity_Map -- 20239 ------------------- 20240 20241 function In_Entity_Map 20242 (Id : Entity_Id; 20243 Entity_Map : Elist_Id) return Boolean 20244 is 20245 Elmt : Elmt_Id; 20246 Old_Id : Entity_Id; 20247 20248 begin 20249 -- The entity map contains pairs (Old_Id, New_Id). The advancement 20250 -- step always skips the New_Id portion of the pair. 20251 20252 if Present (Entity_Map) then 20253 Elmt := First_Elmt (Entity_Map); 20254 while Present (Elmt) loop 20255 Old_Id := Node (Elmt); 20256 20257 if Old_Id = Id then 20258 return True; 20259 end if; 20260 20261 Next_Elmt (Elmt); 20262 Next_Elmt (Elmt); 20263 end loop; 20264 end if; 20265 20266 return False; 20267 end In_Entity_Map; 20268 20269 --------------------- 20270 -- Update_CFS_Sloc -- 20271 --------------------- 20272 20273 procedure Update_CFS_Sloc (N : Node_Or_Entity_Id) is 20274 begin 20275 -- A new source location defaults the Comes_From_Source attribute 20276 20277 if New_Sloc /= No_Location then 20278 Set_Comes_From_Source (N, Default_Node.Comes_From_Source); 20279 Set_Sloc (N, New_Sloc); 20280 end if; 20281 end Update_CFS_Sloc; 20282 20283 --------------------------------- 20284 -- Update_First_Real_Statement -- 20285 --------------------------------- 20286 20287 procedure Update_First_Real_Statement 20288 (Old_HSS : Node_Id; 20289 New_HSS : Node_Id) 20290 is 20291 Old_First_Stmt : constant Node_Id := First_Real_Statement (Old_HSS); 20292 20293 New_Stmt : Node_Id; 20294 Old_Stmt : Node_Id; 20295 20296 begin 20297 -- Recreate the First_Real_Statement attribute of a handled sequence 20298 -- of statements by traversing the statement lists of both sequences 20299 -- in parallel. 20300 20301 if Present (Old_First_Stmt) then 20302 New_Stmt := First (Statements (New_HSS)); 20303 Old_Stmt := First (Statements (Old_HSS)); 20304 while Present (Old_Stmt) and then Old_Stmt /= Old_First_Stmt loop 20305 Next (New_Stmt); 20306 Next (Old_Stmt); 20307 end loop; 20308 20309 pragma Assert (Present (New_Stmt)); 20310 pragma Assert (Present (Old_Stmt)); 20311 20312 Set_First_Real_Statement (New_HSS, New_Stmt); 20313 end if; 20314 end Update_First_Real_Statement; 20315 20316 ------------------------------- 20317 -- Update_Named_Associations -- 20318 ------------------------------- 20319 20320 procedure Update_Named_Associations 20321 (Old_Call : Node_Id; 20322 New_Call : Node_Id) 20323 is 20324 New_Act : Node_Id; 20325 New_Next : Node_Id; 20326 Old_Act : Node_Id; 20327 Old_Next : Node_Id; 20328 20329 begin 20330 -- Recreate the First/Next_Named_Actual chain of a call by traversing 20331 -- the chains of both the old and new calls in parallel. 20332 20333 New_Act := First (Parameter_Associations (New_Call)); 20334 Old_Act := First (Parameter_Associations (Old_Call)); 20335 while Present (Old_Act) loop 20336 if Nkind (Old_Act) = N_Parameter_Association 20337 and then Present (Next_Named_Actual (Old_Act)) 20338 then 20339 if First_Named_Actual (Old_Call) = 20340 Explicit_Actual_Parameter (Old_Act) 20341 then 20342 Set_First_Named_Actual (New_Call, 20343 Explicit_Actual_Parameter (New_Act)); 20344 end if; 20345 20346 -- Scan the actual parameter list to find the next suitable 20347 -- named actual. Note that the list may be out of order. 20348 20349 New_Next := First (Parameter_Associations (New_Call)); 20350 Old_Next := First (Parameter_Associations (Old_Call)); 20351 while Nkind (Old_Next) /= N_Parameter_Association 20352 or else Explicit_Actual_Parameter (Old_Next) /= 20353 Next_Named_Actual (Old_Act) 20354 loop 20355 Next (New_Next); 20356 Next (Old_Next); 20357 end loop; 20358 20359 Set_Next_Named_Actual (New_Act, 20360 Explicit_Actual_Parameter (New_Next)); 20361 end if; 20362 20363 Next (New_Act); 20364 Next (Old_Act); 20365 end loop; 20366 end Update_Named_Associations; 20367 20368 ------------------------- 20369 -- Update_New_Entities -- 20370 ------------------------- 20371 20372 procedure Update_New_Entities (Entity_Map : Elist_Id) is 20373 New_Id : Entity_Id := Empty; 20374 Old_Id : Entity_Id := Empty; 20375 20376 begin 20377 if NCT_Tables_In_Use then 20378 NCT_New_Entities.Get_First (Old_Id, New_Id); 20379 20380 -- Update the semantic fields of all new entities created during 20381 -- Phase 1 which were not supplied via an entity map. 20382 -- ??? Is there a better way of distinguishing those? 20383 20384 while Present (Old_Id) and then Present (New_Id) loop 20385 if not (Present (Entity_Map) 20386 and then In_Entity_Map (Old_Id, Entity_Map)) 20387 then 20388 Update_Semantic_Fields (New_Id); 20389 end if; 20390 20391 NCT_New_Entities.Get_Next (Old_Id, New_Id); 20392 end loop; 20393 end if; 20394 end Update_New_Entities; 20395 20396 --------------------------- 20397 -- Update_Pending_Itypes -- 20398 --------------------------- 20399 20400 procedure Update_Pending_Itypes 20401 (Old_Assoc : Node_Id; 20402 New_Assoc : Node_Id) 20403 is 20404 Item : Elmt_Id; 20405 Itypes : Elist_Id; 20406 20407 begin 20408 if NCT_Tables_In_Use then 20409 Itypes := NCT_Pending_Itypes.Get (Old_Assoc); 20410 20411 -- Update the Associated_Node_For_Itype attribute for all itypes 20412 -- which originally refer to Old_Assoc to designate New_Assoc. 20413 20414 if Present (Itypes) then 20415 Item := First_Elmt (Itypes); 20416 while Present (Item) loop 20417 Set_Associated_Node_For_Itype (Node (Item), New_Assoc); 20418 20419 Next_Elmt (Item); 20420 end loop; 20421 end if; 20422 end if; 20423 end Update_Pending_Itypes; 20424 20425 ---------------------------- 20426 -- Update_Semantic_Fields -- 20427 ---------------------------- 20428 20429 procedure Update_Semantic_Fields (Id : Entity_Id) is 20430 begin 20431 -- Discriminant_Constraint 20432 20433 if Is_Type (Id) and then Has_Discriminants (Base_Type (Id)) then 20434 Set_Discriminant_Constraint (Id, Elist_Id ( 20435 Copy_Field_With_Replacement 20436 (Field => Union_Id (Discriminant_Constraint (Id)), 20437 Semantic => True))); 20438 end if; 20439 20440 -- Etype 20441 20442 Set_Etype (Id, Node_Id ( 20443 Copy_Field_With_Replacement 20444 (Field => Union_Id (Etype (Id)), 20445 Semantic => True))); 20446 20447 -- First_Index 20448 -- Packed_Array_Impl_Type 20449 20450 if Is_Array_Type (Id) then 20451 if Present (First_Index (Id)) then 20452 Set_First_Index (Id, First (List_Id ( 20453 Copy_Field_With_Replacement 20454 (Field => Union_Id (List_Containing (First_Index (Id))), 20455 Semantic => True)))); 20456 end if; 20457 20458 if Is_Packed (Id) then 20459 Set_Packed_Array_Impl_Type (Id, Node_Id ( 20460 Copy_Field_With_Replacement 20461 (Field => Union_Id (Packed_Array_Impl_Type (Id)), 20462 Semantic => True))); 20463 end if; 20464 end if; 20465 20466 -- Prev_Entity 20467 20468 Set_Prev_Entity (Id, Node_Id ( 20469 Copy_Field_With_Replacement 20470 (Field => Union_Id (Prev_Entity (Id)), 20471 Semantic => True))); 20472 20473 -- Next_Entity 20474 20475 Set_Next_Entity (Id, Node_Id ( 20476 Copy_Field_With_Replacement 20477 (Field => Union_Id (Next_Entity (Id)), 20478 Semantic => True))); 20479 20480 -- Scalar_Range 20481 20482 if Is_Discrete_Type (Id) then 20483 Set_Scalar_Range (Id, Node_Id ( 20484 Copy_Field_With_Replacement 20485 (Field => Union_Id (Scalar_Range (Id)), 20486 Semantic => True))); 20487 end if; 20488 20489 -- Scope 20490 20491 -- Update the scope when the caller specified an explicit one 20492 20493 if Present (New_Scope) then 20494 Set_Scope (Id, New_Scope); 20495 else 20496 Set_Scope (Id, Node_Id ( 20497 Copy_Field_With_Replacement 20498 (Field => Union_Id (Scope (Id)), 20499 Semantic => True))); 20500 end if; 20501 end Update_Semantic_Fields; 20502 20503 -------------------- 20504 -- Visit_Any_Node -- 20505 -------------------- 20506 20507 procedure Visit_Any_Node (N : Node_Or_Entity_Id) is 20508 begin 20509 if Nkind (N) in N_Entity then 20510 if Is_Itype (N) then 20511 Visit_Itype (N); 20512 else 20513 Visit_Entity (N); 20514 end if; 20515 else 20516 Visit_Node (N); 20517 end if; 20518 end Visit_Any_Node; 20519 20520 ----------------- 20521 -- Visit_Elist -- 20522 ----------------- 20523 20524 procedure Visit_Elist (List : Elist_Id) is 20525 Elmt : Elmt_Id; 20526 20527 begin 20528 -- The element of an entity list could be an entity, itype, or a 20529 -- node, hence the call to Visit_Any_Node. 20530 20531 if Present (List) then 20532 Elmt := First_Elmt (List); 20533 while Present (Elmt) loop 20534 Visit_Any_Node (Node (Elmt)); 20535 20536 Next_Elmt (Elmt); 20537 end loop; 20538 end if; 20539 end Visit_Elist; 20540 20541 ------------------ 20542 -- Visit_Entity -- 20543 ------------------ 20544 20545 procedure Visit_Entity (Id : Entity_Id) is 20546 New_Id : Entity_Id; 20547 20548 begin 20549 pragma Assert (Nkind (Id) in N_Entity); 20550 pragma Assert (not Is_Itype (Id)); 20551 20552 -- Nothing to do when the entity is not defined in the Actions list 20553 -- of an N_Expression_With_Actions node. 20554 20555 if EWA_Level = 0 then 20556 return; 20557 20558 -- Nothing to do when the entity is defined in a scoping construct 20559 -- within an N_Expression_With_Actions node, unless the caller has 20560 -- requested their replication. 20561 20562 -- ??? should this restriction be eliminated? 20563 20564 elsif EWA_Inner_Scope_Level > 0 and then not Scopes_In_EWA_OK then 20565 return; 20566 20567 -- Nothing to do when the entity does not denote a construct that 20568 -- may appear within an N_Expression_With_Actions node. Relaxing 20569 -- this restriction leads to a performance penalty. 20570 20571 -- ??? this list is flaky, and may hide dormant bugs 20572 20573 elsif not Ekind_In (Id, E_Block, 20574 E_Constant, 20575 E_Label, 20576 E_Procedure, 20577 E_Variable) 20578 and then not Is_Type (Id) 20579 then 20580 return; 20581 20582 -- Nothing to do when the entity was already visited 20583 20584 elsif NCT_Tables_In_Use 20585 and then Present (NCT_New_Entities.Get (Id)) 20586 then 20587 return; 20588 20589 -- Nothing to do when the declaration node of the entity is not in 20590 -- the subtree being replicated. 20591 20592 elsif not In_Subtree 20593 (N => Declaration_Node (Id), 20594 Root => Source) 20595 then 20596 return; 20597 end if; 20598 20599 -- Create a new entity by directly copying the old entity. This 20600 -- action causes all attributes of the old entity to be inherited. 20601 20602 New_Id := New_Copy (Id); 20603 20604 -- Create a new name for the new entity because the back end needs 20605 -- distinct names for debugging purposes. 20606 20607 Set_Chars (New_Id, New_Internal_Name ('T')); 20608 20609 -- Update the Comes_From_Source and Sloc attributes of the entity in 20610 -- case the caller has supplied new values. 20611 20612 Update_CFS_Sloc (New_Id); 20613 20614 -- Establish the following mapping within table NCT_New_Entities: 20615 20616 -- Id -> New_Id 20617 20618 Add_New_Entity (Id, New_Id); 20619 20620 -- Deal with the semantic fields of entities. The fields are visited 20621 -- because they may mention entities which reside within the subtree 20622 -- being copied. 20623 20624 Visit_Semantic_Fields (Id); 20625 end Visit_Entity; 20626 20627 ----------------- 20628 -- Visit_Field -- 20629 ----------------- 20630 20631 procedure Visit_Field 20632 (Field : Union_Id; 20633 Par_Nod : Node_Id := Empty; 20634 Semantic : Boolean := False) 20635 is 20636 begin 20637 -- The field is empty 20638 20639 if Field = Union_Id (Empty) then 20640 return; 20641 20642 -- The field is an entity/itype/node 20643 20644 elsif Field in Node_Range then 20645 declare 20646 N : constant Node_Id := Node_Id (Field); 20647 20648 begin 20649 -- The field is an entity/itype 20650 20651 if Nkind (N) in N_Entity then 20652 20653 -- Itypes are always visited 20654 20655 if Is_Itype (N) then 20656 Visit_Itype (N); 20657 20658 -- An entity is visited when it is either a syntactic field 20659 -- or when the caller treats it as a semantic attribute. 20660 20661 elsif Parent (N) = Par_Nod or else Semantic then 20662 Visit_Entity (N); 20663 end if; 20664 20665 -- The field is a node 20666 20667 else 20668 -- A node is visited when it is either a syntactic field or 20669 -- when the caller treats it as a semantic attribute. 20670 20671 if Parent (N) = Par_Nod or else Semantic then 20672 Visit_Node (N); 20673 end if; 20674 end if; 20675 end; 20676 20677 -- The field is an entity list 20678 20679 elsif Field in Elist_Range then 20680 Visit_Elist (Elist_Id (Field)); 20681 20682 -- The field is a syntax list 20683 20684 elsif Field in List_Range then 20685 declare 20686 List : constant List_Id := List_Id (Field); 20687 20688 begin 20689 -- A syntax list is visited when it is either a syntactic field 20690 -- or when the caller treats it as a semantic attribute. 20691 20692 if Parent (List) = Par_Nod or else Semantic then 20693 Visit_List (List); 20694 end if; 20695 end; 20696 20697 -- Otherwise the field denotes information which does not need to be 20698 -- visited (chars, literals, etc.). 20699 20700 else 20701 null; 20702 end if; 20703 end Visit_Field; 20704 20705 ----------------- 20706 -- Visit_Itype -- 20707 ----------------- 20708 20709 procedure Visit_Itype (Itype : Entity_Id) is 20710 New_Assoc : Node_Id; 20711 New_Itype : Entity_Id; 20712 Old_Assoc : Node_Id; 20713 20714 begin 20715 pragma Assert (Nkind (Itype) in N_Entity); 20716 pragma Assert (Is_Itype (Itype)); 20717 20718 -- Itypes that describe the designated type of access to subprograms 20719 -- have the structure of subprogram declarations, with signatures, 20720 -- etc. Either we duplicate the signatures completely, or choose to 20721 -- share such itypes, which is fine because their elaboration will 20722 -- have no side effects. 20723 20724 if Ekind (Itype) = E_Subprogram_Type then 20725 return; 20726 20727 -- Nothing to do if the itype was already visited 20728 20729 elsif NCT_Tables_In_Use 20730 and then Present (NCT_New_Entities.Get (Itype)) 20731 then 20732 return; 20733 20734 -- Nothing to do if the associated node of the itype is not within 20735 -- the subtree being replicated. 20736 20737 elsif not In_Subtree 20738 (N => Associated_Node_For_Itype (Itype), 20739 Root => Source) 20740 then 20741 return; 20742 end if; 20743 20744 -- Create a new itype by directly copying the old itype. This action 20745 -- causes all attributes of the old itype to be inherited. 20746 20747 New_Itype := New_Copy (Itype); 20748 20749 -- Create a new name for the new itype because the back end requires 20750 -- distinct names for debugging purposes. 20751 20752 Set_Chars (New_Itype, New_Internal_Name ('T')); 20753 20754 -- Update the Comes_From_Source and Sloc attributes of the itype in 20755 -- case the caller has supplied new values. 20756 20757 Update_CFS_Sloc (New_Itype); 20758 20759 -- Establish the following mapping within table NCT_New_Entities: 20760 20761 -- Itype -> New_Itype 20762 20763 Add_New_Entity (Itype, New_Itype); 20764 20765 -- The new itype must be unfrozen because the resulting subtree may 20766 -- be inserted anywhere and cause an earlier or later freezing. 20767 20768 if Present (Freeze_Node (New_Itype)) then 20769 Set_Freeze_Node (New_Itype, Empty); 20770 Set_Is_Frozen (New_Itype, False); 20771 end if; 20772 20773 -- If a record subtype is simply copied, the entity list will be 20774 -- shared. Thus cloned_Subtype must be set to indicate the sharing. 20775 -- ??? What does this do? 20776 20777 if Ekind_In (Itype, E_Class_Wide_Subtype, E_Record_Subtype) then 20778 Set_Cloned_Subtype (New_Itype, Itype); 20779 end if; 20780 20781 -- The associated node may denote an entity, in which case it may 20782 -- already have a new corresponding entity created during a prior 20783 -- call to Visit_Entity or Visit_Itype for the same subtree. 20784 20785 -- Given 20786 -- Old_Assoc ---------> New_Assoc 20787 20788 -- Created by Visit_Itype 20789 -- Itype -------------> New_Itype 20790 -- ANFI = Old_Assoc ANFI = Old_Assoc < must be updated 20791 20792 -- In the example above, Old_Assoc is an arbitrary entity that was 20793 -- already visited for the same subtree and has a corresponding new 20794 -- entity New_Assoc. Old_Assoc was inherited by New_Itype by virtue 20795 -- of copying entities, however it must be updated to New_Assoc. 20796 20797 Old_Assoc := Associated_Node_For_Itype (Itype); 20798 20799 if Nkind (Old_Assoc) in N_Entity then 20800 if NCT_Tables_In_Use then 20801 New_Assoc := NCT_New_Entities.Get (Old_Assoc); 20802 20803 if Present (New_Assoc) then 20804 Set_Associated_Node_For_Itype (New_Itype, New_Assoc); 20805 end if; 20806 end if; 20807 20808 -- Otherwise the associated node denotes a node. Postpone the update 20809 -- until Phase 2 when the node is replicated. Establish the following 20810 -- mapping within table NCT_Pending_Itypes: 20811 20812 -- Old_Assoc -> (New_Type, ...) 20813 20814 else 20815 Add_Pending_Itype (Old_Assoc, New_Itype); 20816 end if; 20817 20818 -- Deal with the semantic fields of itypes. The fields are visited 20819 -- because they may mention entities that reside within the subtree 20820 -- being copied. 20821 20822 Visit_Semantic_Fields (Itype); 20823 end Visit_Itype; 20824 20825 ---------------- 20826 -- Visit_List -- 20827 ---------------- 20828 20829 procedure Visit_List (List : List_Id) is 20830 Elmt : Node_Id; 20831 20832 begin 20833 -- Note that the element of a syntactic list is always a node, never 20834 -- an entity or itype, hence the call to Visit_Node. 20835 20836 if Present (List) then 20837 Elmt := First (List); 20838 while Present (Elmt) loop 20839 Visit_Node (Elmt); 20840 20841 Next (Elmt); 20842 end loop; 20843 end if; 20844 end Visit_List; 20845 20846 ---------------- 20847 -- Visit_Node -- 20848 ---------------- 20849 20850 procedure Visit_Node (N : Node_Or_Entity_Id) is 20851 begin 20852 pragma Assert (Nkind (N) not in N_Entity); 20853 20854 if Nkind (N) = N_Expression_With_Actions then 20855 EWA_Level := EWA_Level + 1; 20856 20857 elsif EWA_Level > 0 20858 and then Nkind_In (N, N_Block_Statement, 20859 N_Subprogram_Body, 20860 N_Subprogram_Declaration) 20861 then 20862 EWA_Inner_Scope_Level := EWA_Inner_Scope_Level + 1; 20863 end if; 20864 20865 Visit_Field 20866 (Field => Field1 (N), 20867 Par_Nod => N); 20868 20869 Visit_Field 20870 (Field => Field2 (N), 20871 Par_Nod => N); 20872 20873 Visit_Field 20874 (Field => Field3 (N), 20875 Par_Nod => N); 20876 20877 Visit_Field 20878 (Field => Field4 (N), 20879 Par_Nod => N); 20880 20881 Visit_Field 20882 (Field => Field5 (N), 20883 Par_Nod => N); 20884 20885 if EWA_Level > 0 20886 and then Nkind_In (N, N_Block_Statement, 20887 N_Subprogram_Body, 20888 N_Subprogram_Declaration) 20889 then 20890 EWA_Inner_Scope_Level := EWA_Inner_Scope_Level - 1; 20891 20892 elsif Nkind (N) = N_Expression_With_Actions then 20893 EWA_Level := EWA_Level - 1; 20894 end if; 20895 end Visit_Node; 20896 20897 --------------------------- 20898 -- Visit_Semantic_Fields -- 20899 --------------------------- 20900 20901 procedure Visit_Semantic_Fields (Id : Entity_Id) is 20902 begin 20903 pragma Assert (Nkind (Id) in N_Entity); 20904 20905 -- Discriminant_Constraint 20906 20907 if Is_Type (Id) and then Has_Discriminants (Base_Type (Id)) then 20908 Visit_Field 20909 (Field => Union_Id (Discriminant_Constraint (Id)), 20910 Semantic => True); 20911 end if; 20912 20913 -- Etype 20914 20915 Visit_Field 20916 (Field => Union_Id (Etype (Id)), 20917 Semantic => True); 20918 20919 -- First_Index 20920 -- Packed_Array_Impl_Type 20921 20922 if Is_Array_Type (Id) then 20923 if Present (First_Index (Id)) then 20924 Visit_Field 20925 (Field => Union_Id (List_Containing (First_Index (Id))), 20926 Semantic => True); 20927 end if; 20928 20929 if Is_Packed (Id) then 20930 Visit_Field 20931 (Field => Union_Id (Packed_Array_Impl_Type (Id)), 20932 Semantic => True); 20933 end if; 20934 end if; 20935 20936 -- Scalar_Range 20937 20938 if Is_Discrete_Type (Id) then 20939 Visit_Field 20940 (Field => Union_Id (Scalar_Range (Id)), 20941 Semantic => True); 20942 end if; 20943 end Visit_Semantic_Fields; 20944 20945 -- Start of processing for New_Copy_Tree 20946 20947 begin 20948 -- Routine New_Copy_Tree performs a deep copy of a subtree by creating 20949 -- shallow copies for each node within, and then updating the child and 20950 -- parent pointers accordingly. This process is straightforward, however 20951 -- the routine must deal with the following complications: 20952 20953 -- * Entities defined within N_Expression_With_Actions nodes must be 20954 -- replicated rather than shared to avoid introducing two identical 20955 -- symbols within the same scope. Note that no other expression can 20956 -- currently define entities. 20957 20958 -- do 20959 -- Source_Low : ...; 20960 -- Source_High : ...; 20961 20962 -- <reference to Source_Low> 20963 -- <reference to Source_High> 20964 -- in ... end; 20965 20966 -- New_Copy_Tree handles this case by first creating new entities 20967 -- and then updating all existing references to point to these new 20968 -- entities. 20969 20970 -- do 20971 -- New_Low : ...; 20972 -- New_High : ...; 20973 20974 -- <reference to New_Low> 20975 -- <reference to New_High> 20976 -- in ... end; 20977 20978 -- * Itypes defined within the subtree must be replicated to avoid any 20979 -- dependencies on invalid or inaccessible data. 20980 20981 -- subtype Source_Itype is ... range Source_Low .. Source_High; 20982 20983 -- New_Copy_Tree handles this case by first creating a new itype in 20984 -- the same fashion as entities, and then updating various relevant 20985 -- constraints. 20986 20987 -- subtype New_Itype is ... range New_Low .. New_High; 20988 20989 -- * The Associated_Node_For_Itype field of itypes must be updated to 20990 -- reference the proper replicated entity or node. 20991 20992 -- * Semantic fields of entities such as Etype and Scope must be 20993 -- updated to reference the proper replicated entities. 20994 20995 -- * Semantic fields of nodes such as First_Real_Statement must be 20996 -- updated to reference the proper replicated nodes. 20997 20998 -- To meet all these demands, routine New_Copy_Tree is split into two 20999 -- phases. 21000 21001 -- Phase 1 traverses the tree in order to locate entities and itypes 21002 -- defined within the subtree. New entities are generated and saved in 21003 -- table NCT_New_Entities. The semantic fields of all new entities and 21004 -- itypes are then updated accordingly. 21005 21006 -- Phase 2 traverses the tree in order to replicate each node. Various 21007 -- semantic fields of nodes and entities are updated accordingly. 21008 21009 -- Preparatory phase. Clear the contents of tables NCT_New_Entities and 21010 -- NCT_Pending_Itypes in case a previous call to New_Copy_Tree left some 21011 -- data inside. 21012 21013 if NCT_Tables_In_Use then 21014 NCT_Tables_In_Use := False; 21015 21016 NCT_New_Entities.Reset; 21017 NCT_Pending_Itypes.Reset; 21018 end if; 21019 21020 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with data 21021 -- supplied by a linear entity map. The tables offer faster access to 21022 -- the same data. 21023 21024 Build_NCT_Tables (Map); 21025 21026 -- Execute Phase 1. Traverse the subtree and generate new entities for 21027 -- the following cases: 21028 21029 -- * An entity defined within an N_Expression_With_Actions node 21030 21031 -- * An itype referenced within the subtree where the associated node 21032 -- is also in the subtree. 21033 21034 -- All new entities are accessible via table NCT_New_Entities, which 21035 -- contains mappings of the form: 21036 21037 -- Old_Entity -> New_Entity 21038 -- Old_Itype -> New_Itype 21039 21040 -- In addition, the associated nodes of all new itypes are mapped in 21041 -- table NCT_Pending_Itypes: 21042 21043 -- Assoc_Nod -> (New_Itype1, New_Itype2, .., New_ItypeN) 21044 21045 Visit_Any_Node (Source); 21046 21047 -- Update the semantic attributes of all new entities generated during 21048 -- Phase 1 before starting Phase 2. The updates could be performed in 21049 -- routine Corresponding_Entity, however this may cause the same entity 21050 -- to be updated multiple times, effectively generating useless nodes. 21051 -- Keeping the updates separates from Phase 2 ensures that only one set 21052 -- of attributes is generated for an entity at any one time. 21053 21054 Update_New_Entities (Map); 21055 21056 -- Execute Phase 2. Replicate the source subtree one node at a time. 21057 -- The following transformations take place: 21058 21059 -- * References to entities and itypes are updated to refer to the 21060 -- new entities and itypes generated during Phase 1. 21061 21062 -- * All Associated_Node_For_Itype attributes of itypes are updated 21063 -- to refer to the new replicated Associated_Node_For_Itype. 21064 21065 return Copy_Node_With_Replacement (Source); 21066 end New_Copy_Tree; 21067 21068 ------------------------- 21069 -- New_External_Entity -- 21070 ------------------------- 21071 21072 function New_External_Entity 21073 (Kind : Entity_Kind; 21074 Scope_Id : Entity_Id; 21075 Sloc_Value : Source_Ptr; 21076 Related_Id : Entity_Id; 21077 Suffix : Character; 21078 Suffix_Index : Int := 0; 21079 Prefix : Character := ' ') return Entity_Id 21080 is 21081 N : constant Entity_Id := 21082 Make_Defining_Identifier (Sloc_Value, 21083 New_External_Name 21084 (Chars (Related_Id), Suffix, Suffix_Index, Prefix)); 21085 21086 begin 21087 Set_Ekind (N, Kind); 21088 Set_Is_Internal (N, True); 21089 Append_Entity (N, Scope_Id); 21090 Set_Public_Status (N); 21091 21092 if Kind in Type_Kind then 21093 Init_Size_Align (N); 21094 end if; 21095 21096 return N; 21097 end New_External_Entity; 21098 21099 ------------------------- 21100 -- New_Internal_Entity -- 21101 ------------------------- 21102 21103 function New_Internal_Entity 21104 (Kind : Entity_Kind; 21105 Scope_Id : Entity_Id; 21106 Sloc_Value : Source_Ptr; 21107 Id_Char : Character) return Entity_Id 21108 is 21109 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); 21110 21111 begin 21112 Set_Ekind (N, Kind); 21113 Set_Is_Internal (N, True); 21114 Append_Entity (N, Scope_Id); 21115 21116 if Kind in Type_Kind then 21117 Init_Size_Align (N); 21118 end if; 21119 21120 return N; 21121 end New_Internal_Entity; 21122 21123 ----------------- 21124 -- Next_Actual -- 21125 ----------------- 21126 21127 function Next_Actual (Actual_Id : Node_Id) return Node_Id is 21128 Par : constant Node_Id := Parent (Actual_Id); 21129 N : Node_Id; 21130 21131 begin 21132 -- If we are pointing at a positional parameter, it is a member of a 21133 -- node list (the list of parameters), and the next parameter is the 21134 -- next node on the list, unless we hit a parameter association, then 21135 -- we shift to using the chain whose head is the First_Named_Actual in 21136 -- the parent, and then is threaded using the Next_Named_Actual of the 21137 -- Parameter_Association. All this fiddling is because the original node 21138 -- list is in the textual call order, and what we need is the 21139 -- declaration order. 21140 21141 if Is_List_Member (Actual_Id) then 21142 N := Next (Actual_Id); 21143 21144 if Nkind (N) = N_Parameter_Association then 21145 21146 -- In case of a build-in-place call, the call will no longer be a 21147 -- call; it will have been rewritten. 21148 21149 if Nkind_In (Par, N_Entry_Call_Statement, 21150 N_Function_Call, 21151 N_Procedure_Call_Statement) 21152 then 21153 return First_Named_Actual (Par); 21154 21155 -- In case of a call rewritten in GNATprove mode while "inlining 21156 -- for proof" go to the original call. 21157 21158 elsif Nkind (Par) = N_Null_Statement then 21159 pragma Assert 21160 (GNATprove_Mode 21161 and then 21162 Nkind (Original_Node (Par)) in N_Subprogram_Call); 21163 21164 return First_Named_Actual (Original_Node (Par)); 21165 else 21166 return Empty; 21167 end if; 21168 else 21169 return N; 21170 end if; 21171 21172 else 21173 return Next_Named_Actual (Parent (Actual_Id)); 21174 end if; 21175 end Next_Actual; 21176 21177 procedure Next_Actual (Actual_Id : in out Node_Id) is 21178 begin 21179 Actual_Id := Next_Actual (Actual_Id); 21180 end Next_Actual; 21181 21182 ----------------- 21183 -- Next_Global -- 21184 ----------------- 21185 21186 function Next_Global (Node : Node_Id) return Node_Id is 21187 begin 21188 -- The global item may either be in a list, or by itself, in which case 21189 -- there is no next global item with the same mode. 21190 21191 if Is_List_Member (Node) then 21192 return Next (Node); 21193 else 21194 return Empty; 21195 end if; 21196 end Next_Global; 21197 21198 procedure Next_Global (Node : in out Node_Id) is 21199 begin 21200 Node := Next_Global (Node); 21201 end Next_Global; 21202 21203 ---------------------------------- 21204 -- New_Requires_Transient_Scope -- 21205 ---------------------------------- 21206 21207 function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean is 21208 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean; 21209 -- This is called for untagged records and protected types, with 21210 -- nondefaulted discriminants. Returns True if the size of function 21211 -- results is known at the call site, False otherwise. Returns False 21212 -- if there is a variant part that depends on the discriminants of 21213 -- this type, or if there is an array constrained by the discriminants 21214 -- of this type. ???Currently, this is overly conservative (the array 21215 -- could be nested inside some other record that is constrained by 21216 -- nondiscriminants). That is, the recursive calls are too conservative. 21217 21218 function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean; 21219 -- Returns True if Typ is a nonlimited record with defaulted 21220 -- discriminants whose max size makes it unsuitable for allocating on 21221 -- the primary stack. 21222 21223 ------------------------------ 21224 -- Caller_Known_Size_Record -- 21225 ------------------------------ 21226 21227 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is 21228 pragma Assert (Typ = Underlying_Type (Typ)); 21229 21230 begin 21231 if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then 21232 return False; 21233 end if; 21234 21235 declare 21236 Comp : Entity_Id; 21237 21238 begin 21239 Comp := First_Entity (Typ); 21240 while Present (Comp) loop 21241 21242 -- Only look at E_Component entities. No need to look at 21243 -- E_Discriminant entities, and we must ignore internal 21244 -- subtypes generated for constrained components. 21245 21246 if Ekind (Comp) = E_Component then 21247 declare 21248 Comp_Type : constant Entity_Id := 21249 Underlying_Type (Etype (Comp)); 21250 21251 begin 21252 if Is_Record_Type (Comp_Type) 21253 or else 21254 Is_Protected_Type (Comp_Type) 21255 then 21256 if not Caller_Known_Size_Record (Comp_Type) then 21257 return False; 21258 end if; 21259 21260 elsif Is_Array_Type (Comp_Type) then 21261 if Size_Depends_On_Discriminant (Comp_Type) then 21262 return False; 21263 end if; 21264 end if; 21265 end; 21266 end if; 21267 21268 Next_Entity (Comp); 21269 end loop; 21270 end; 21271 21272 return True; 21273 end Caller_Known_Size_Record; 21274 21275 ------------------------------ 21276 -- Large_Max_Size_Mutable -- 21277 ------------------------------ 21278 21279 function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is 21280 pragma Assert (Typ = Underlying_Type (Typ)); 21281 21282 function Is_Large_Discrete_Type (T : Entity_Id) return Boolean; 21283 -- Returns true if the discrete type T has a large range 21284 21285 ---------------------------- 21286 -- Is_Large_Discrete_Type -- 21287 ---------------------------- 21288 21289 function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is 21290 Threshold : constant Int := 16; 21291 -- Arbitrary threshold above which we consider it "large". We want 21292 -- a fairly large threshold, because these large types really 21293 -- shouldn't have default discriminants in the first place, in 21294 -- most cases. 21295 21296 begin 21297 return UI_To_Int (RM_Size (T)) > Threshold; 21298 end Is_Large_Discrete_Type; 21299 21300 -- Start of processing for Large_Max_Size_Mutable 21301 21302 begin 21303 if Is_Record_Type (Typ) 21304 and then not Is_Limited_View (Typ) 21305 and then Has_Defaulted_Discriminants (Typ) 21306 then 21307 -- Loop through the components, looking for an array whose upper 21308 -- bound(s) depends on discriminants, where both the subtype of 21309 -- the discriminant and the index subtype are too large. 21310 21311 declare 21312 Comp : Entity_Id; 21313 21314 begin 21315 Comp := First_Entity (Typ); 21316 while Present (Comp) loop 21317 if Ekind (Comp) = E_Component then 21318 declare 21319 Comp_Type : constant Entity_Id := 21320 Underlying_Type (Etype (Comp)); 21321 21322 Hi : Node_Id; 21323 Indx : Node_Id; 21324 Ityp : Entity_Id; 21325 21326 begin 21327 if Is_Array_Type (Comp_Type) then 21328 Indx := First_Index (Comp_Type); 21329 21330 while Present (Indx) loop 21331 Ityp := Etype (Indx); 21332 Hi := Type_High_Bound (Ityp); 21333 21334 if Nkind (Hi) = N_Identifier 21335 and then Ekind (Entity (Hi)) = E_Discriminant 21336 and then Is_Large_Discrete_Type (Ityp) 21337 and then Is_Large_Discrete_Type 21338 (Etype (Entity (Hi))) 21339 then 21340 return True; 21341 end if; 21342 21343 Next_Index (Indx); 21344 end loop; 21345 end if; 21346 end; 21347 end if; 21348 21349 Next_Entity (Comp); 21350 end loop; 21351 end; 21352 end if; 21353 21354 return False; 21355 end Large_Max_Size_Mutable; 21356 21357 -- Local declarations 21358 21359 Typ : constant Entity_Id := Underlying_Type (Id); 21360 21361 -- Start of processing for New_Requires_Transient_Scope 21362 21363 begin 21364 -- This is a private type which is not completed yet. This can only 21365 -- happen in a default expression (of a formal parameter or of a 21366 -- record component). Do not expand transient scope in this case. 21367 21368 if No (Typ) then 21369 return False; 21370 21371 -- Do not expand transient scope for non-existent procedure return or 21372 -- string literal types. 21373 21374 elsif Typ = Standard_Void_Type 21375 or else Ekind (Typ) = E_String_Literal_Subtype 21376 then 21377 return False; 21378 21379 -- If Typ is a generic formal incomplete type, then we want to look at 21380 -- the actual type. 21381 21382 elsif Ekind (Typ) = E_Record_Subtype 21383 and then Present (Cloned_Subtype (Typ)) 21384 then 21385 return New_Requires_Transient_Scope (Cloned_Subtype (Typ)); 21386 21387 -- Functions returning specific tagged types may dispatch on result, so 21388 -- their returned value is allocated on the secondary stack, even in the 21389 -- definite case. We must treat nondispatching functions the same way, 21390 -- because access-to-function types can point at both, so the calling 21391 -- conventions must be compatible. Is_Tagged_Type includes controlled 21392 -- types and class-wide types. Controlled type temporaries need 21393 -- finalization. 21394 21395 -- ???It's not clear why we need to return noncontrolled types with 21396 -- controlled components on the secondary stack. 21397 21398 elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then 21399 return True; 21400 21401 -- Untagged definite subtypes are known size. This includes all 21402 -- elementary [sub]types. Tasks are known size even if they have 21403 -- discriminants. So we return False here, with one exception: 21404 -- For a type like: 21405 -- type T (Last : Natural := 0) is 21406 -- X : String (1 .. Last); 21407 -- end record; 21408 -- we return True. That's because for "P(F(...));", where F returns T, 21409 -- we don't know the size of the result at the call site, so if we 21410 -- allocated it on the primary stack, we would have to allocate the 21411 -- maximum size, which is way too big. 21412 21413 elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then 21414 return Large_Max_Size_Mutable (Typ); 21415 21416 -- Indefinite (discriminated) untagged record or protected type 21417 21418 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then 21419 return not Caller_Known_Size_Record (Typ); 21420 21421 -- Unconstrained array 21422 21423 else 21424 pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ)); 21425 return True; 21426 end if; 21427 end New_Requires_Transient_Scope; 21428 21429 -------------------------- 21430 -- No_Heap_Finalization -- 21431 -------------------------- 21432 21433 function No_Heap_Finalization (Typ : Entity_Id) return Boolean is 21434 begin 21435 if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) 21436 and then Is_Library_Level_Entity (Typ) 21437 then 21438 -- A global No_Heap_Finalization pragma applies to all library-level 21439 -- named access-to-object types. 21440 21441 if Present (No_Heap_Finalization_Pragma) then 21442 return True; 21443 21444 -- The library-level named access-to-object type itself is subject to 21445 -- pragma No_Heap_Finalization. 21446 21447 elsif Present (Get_Pragma (Typ, Pragma_No_Heap_Finalization)) then 21448 return True; 21449 end if; 21450 end if; 21451 21452 return False; 21453 end No_Heap_Finalization; 21454 21455 ----------------------- 21456 -- Normalize_Actuals -- 21457 ----------------------- 21458 21459 -- Chain actuals according to formals of subprogram. If there are no named 21460 -- associations, the chain is simply the list of Parameter Associations, 21461 -- since the order is the same as the declaration order. If there are named 21462 -- associations, then the First_Named_Actual field in the N_Function_Call 21463 -- or N_Procedure_Call_Statement node points to the Parameter_Association 21464 -- node for the parameter that comes first in declaration order. The 21465 -- remaining named parameters are then chained in declaration order using 21466 -- Next_Named_Actual. 21467 21468 -- This routine also verifies that the number of actuals is compatible with 21469 -- the number and default values of formals, but performs no type checking 21470 -- (type checking is done by the caller). 21471 21472 -- If the matching succeeds, Success is set to True and the caller proceeds 21473 -- with type-checking. If the match is unsuccessful, then Success is set to 21474 -- False, and the caller attempts a different interpretation, if there is 21475 -- one. 21476 21477 -- If the flag Report is on, the call is not overloaded, and a failure to 21478 -- match can be reported here, rather than in the caller. 21479 21480 procedure Normalize_Actuals 21481 (N : Node_Id; 21482 S : Entity_Id; 21483 Report : Boolean; 21484 Success : out Boolean) 21485 is 21486 Actuals : constant List_Id := Parameter_Associations (N); 21487 Actual : Node_Id := Empty; 21488 Formal : Entity_Id; 21489 Last : Node_Id := Empty; 21490 First_Named : Node_Id := Empty; 21491 Found : Boolean; 21492 21493 Formals_To_Match : Integer := 0; 21494 Actuals_To_Match : Integer := 0; 21495 21496 procedure Chain (A : Node_Id); 21497 -- Add named actual at the proper place in the list, using the 21498 -- Next_Named_Actual link. 21499 21500 function Reporting return Boolean; 21501 -- Determines if an error is to be reported. To report an error, we 21502 -- need Report to be True, and also we do not report errors caused 21503 -- by calls to init procs that occur within other init procs. Such 21504 -- errors must always be cascaded errors, since if all the types are 21505 -- declared correctly, the compiler will certainly build decent calls. 21506 21507 ----------- 21508 -- Chain -- 21509 ----------- 21510 21511 procedure Chain (A : Node_Id) is 21512 begin 21513 if No (Last) then 21514 21515 -- Call node points to first actual in list 21516 21517 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A)); 21518 21519 else 21520 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A)); 21521 end if; 21522 21523 Last := A; 21524 Set_Next_Named_Actual (Last, Empty); 21525 end Chain; 21526 21527 --------------- 21528 -- Reporting -- 21529 --------------- 21530 21531 function Reporting return Boolean is 21532 begin 21533 if not Report then 21534 return False; 21535 21536 elsif not Within_Init_Proc then 21537 return True; 21538 21539 elsif Is_Init_Proc (Entity (Name (N))) then 21540 return False; 21541 21542 else 21543 return True; 21544 end if; 21545 end Reporting; 21546 21547 -- Start of processing for Normalize_Actuals 21548 21549 begin 21550 if Is_Access_Type (S) then 21551 21552 -- The name in the call is a function call that returns an access 21553 -- to subprogram. The designated type has the list of formals. 21554 21555 Formal := First_Formal (Designated_Type (S)); 21556 else 21557 Formal := First_Formal (S); 21558 end if; 21559 21560 while Present (Formal) loop 21561 Formals_To_Match := Formals_To_Match + 1; 21562 Next_Formal (Formal); 21563 end loop; 21564 21565 -- Find if there is a named association, and verify that no positional 21566 -- associations appear after named ones. 21567 21568 if Present (Actuals) then 21569 Actual := First (Actuals); 21570 end if; 21571 21572 while Present (Actual) 21573 and then Nkind (Actual) /= N_Parameter_Association 21574 loop 21575 Actuals_To_Match := Actuals_To_Match + 1; 21576 Next (Actual); 21577 end loop; 21578 21579 if No (Actual) and Actuals_To_Match = Formals_To_Match then 21580 21581 -- Most common case: positional notation, no defaults 21582 21583 Success := True; 21584 return; 21585 21586 elsif Actuals_To_Match > Formals_To_Match then 21587 21588 -- Too many actuals: will not work 21589 21590 if Reporting then 21591 if Is_Entity_Name (Name (N)) then 21592 Error_Msg_N ("too many arguments in call to&", Name (N)); 21593 else 21594 Error_Msg_N ("too many arguments in call", N); 21595 end if; 21596 end if; 21597 21598 Success := False; 21599 return; 21600 end if; 21601 21602 First_Named := Actual; 21603 21604 while Present (Actual) loop 21605 if Nkind (Actual) /= N_Parameter_Association then 21606 Error_Msg_N 21607 ("positional parameters not allowed after named ones", Actual); 21608 Success := False; 21609 return; 21610 21611 else 21612 Actuals_To_Match := Actuals_To_Match + 1; 21613 end if; 21614 21615 Next (Actual); 21616 end loop; 21617 21618 if Present (Actuals) then 21619 Actual := First (Actuals); 21620 end if; 21621 21622 Formal := First_Formal (S); 21623 while Present (Formal) loop 21624 21625 -- Match the formals in order. If the corresponding actual is 21626 -- positional, nothing to do. Else scan the list of named actuals 21627 -- to find the one with the right name. 21628 21629 if Present (Actual) 21630 and then Nkind (Actual) /= N_Parameter_Association 21631 then 21632 Next (Actual); 21633 Actuals_To_Match := Actuals_To_Match - 1; 21634 Formals_To_Match := Formals_To_Match - 1; 21635 21636 else 21637 -- For named parameters, search the list of actuals to find 21638 -- one that matches the next formal name. 21639 21640 Actual := First_Named; 21641 Found := False; 21642 while Present (Actual) loop 21643 if Chars (Selector_Name (Actual)) = Chars (Formal) then 21644 Found := True; 21645 Chain (Actual); 21646 Actuals_To_Match := Actuals_To_Match - 1; 21647 Formals_To_Match := Formals_To_Match - 1; 21648 exit; 21649 end if; 21650 21651 Next (Actual); 21652 end loop; 21653 21654 if not Found then 21655 if Ekind (Formal) /= E_In_Parameter 21656 or else No (Default_Value (Formal)) 21657 then 21658 if Reporting then 21659 if (Comes_From_Source (S) 21660 or else Sloc (S) = Standard_Location) 21661 and then Is_Overloadable (S) 21662 then 21663 if No (Actuals) 21664 and then 21665 Nkind_In (Parent (N), N_Procedure_Call_Statement, 21666 N_Function_Call, 21667 N_Parameter_Association) 21668 and then Ekind (S) /= E_Function 21669 then 21670 Set_Etype (N, Etype (S)); 21671 21672 else 21673 Error_Msg_Name_1 := Chars (S); 21674 Error_Msg_Sloc := Sloc (S); 21675 Error_Msg_NE 21676 ("missing argument for parameter & " 21677 & "in call to % declared #", N, Formal); 21678 end if; 21679 21680 elsif Is_Overloadable (S) then 21681 Error_Msg_Name_1 := Chars (S); 21682 21683 -- Point to type derivation that generated the 21684 -- operation. 21685 21686 Error_Msg_Sloc := Sloc (Parent (S)); 21687 21688 Error_Msg_NE 21689 ("missing argument for parameter & " 21690 & "in call to % (inherited) #", N, Formal); 21691 21692 else 21693 Error_Msg_NE 21694 ("missing argument for parameter &", N, Formal); 21695 end if; 21696 end if; 21697 21698 Success := False; 21699 return; 21700 21701 else 21702 Formals_To_Match := Formals_To_Match - 1; 21703 end if; 21704 end if; 21705 end if; 21706 21707 Next_Formal (Formal); 21708 end loop; 21709 21710 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then 21711 Success := True; 21712 return; 21713 21714 else 21715 if Reporting then 21716 21717 -- Find some superfluous named actual that did not get 21718 -- attached to the list of associations. 21719 21720 Actual := First (Actuals); 21721 while Present (Actual) loop 21722 if Nkind (Actual) = N_Parameter_Association 21723 and then Actual /= Last 21724 and then No (Next_Named_Actual (Actual)) 21725 then 21726 -- A validity check may introduce a copy of a call that 21727 -- includes an extra actual (for example for an unrelated 21728 -- accessibility check). Check that the extra actual matches 21729 -- some extra formal, which must exist already because 21730 -- subprogram must be frozen at this point. 21731 21732 if Present (Extra_Formals (S)) 21733 and then not Comes_From_Source (Actual) 21734 and then Nkind (Actual) = N_Parameter_Association 21735 and then Chars (Extra_Formals (S)) = 21736 Chars (Selector_Name (Actual)) 21737 then 21738 null; 21739 else 21740 Error_Msg_N 21741 ("unmatched actual & in call", Selector_Name (Actual)); 21742 exit; 21743 end if; 21744 end if; 21745 21746 Next (Actual); 21747 end loop; 21748 end if; 21749 21750 Success := False; 21751 return; 21752 end if; 21753 end Normalize_Actuals; 21754 21755 -------------------------------- 21756 -- Note_Possible_Modification -- 21757 -------------------------------- 21758 21759 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is 21760 Modification_Comes_From_Source : constant Boolean := 21761 Comes_From_Source (Parent (N)); 21762 21763 Ent : Entity_Id; 21764 Exp : Node_Id; 21765 21766 begin 21767 -- Loop to find referenced entity, if there is one 21768 21769 Exp := N; 21770 loop 21771 Ent := Empty; 21772 21773 if Is_Entity_Name (Exp) then 21774 Ent := Entity (Exp); 21775 21776 -- If the entity is missing, it is an undeclared identifier, 21777 -- and there is nothing to annotate. 21778 21779 if No (Ent) then 21780 return; 21781 end if; 21782 21783 elsif Nkind (Exp) = N_Explicit_Dereference then 21784 declare 21785 P : constant Node_Id := Prefix (Exp); 21786 21787 begin 21788 -- In formal verification mode, keep track of all reads and 21789 -- writes through explicit dereferences. 21790 21791 if GNATprove_Mode then 21792 SPARK_Specific.Generate_Dereference (N, 'm'); 21793 end if; 21794 21795 if Nkind (P) = N_Selected_Component 21796 and then Present (Entry_Formal (Entity (Selector_Name (P)))) 21797 then 21798 -- Case of a reference to an entry formal 21799 21800 Ent := Entry_Formal (Entity (Selector_Name (P))); 21801 21802 elsif Nkind (P) = N_Identifier 21803 and then Nkind (Parent (Entity (P))) = N_Object_Declaration 21804 and then Present (Expression (Parent (Entity (P)))) 21805 and then Nkind (Expression (Parent (Entity (P)))) = 21806 N_Reference 21807 then 21808 -- Case of a reference to a value on which side effects have 21809 -- been removed. 21810 21811 Exp := Prefix (Expression (Parent (Entity (P)))); 21812 goto Continue; 21813 21814 else 21815 return; 21816 end if; 21817 end; 21818 21819 elsif Nkind_In (Exp, N_Type_Conversion, 21820 N_Unchecked_Type_Conversion) 21821 then 21822 Exp := Expression (Exp); 21823 goto Continue; 21824 21825 elsif Nkind_In (Exp, N_Slice, 21826 N_Indexed_Component, 21827 N_Selected_Component) 21828 then 21829 -- Special check, if the prefix is an access type, then return 21830 -- since we are modifying the thing pointed to, not the prefix. 21831 -- When we are expanding, most usually the prefix is replaced 21832 -- by an explicit dereference, and this test is not needed, but 21833 -- in some cases (notably -gnatc mode and generics) when we do 21834 -- not do full expansion, we need this special test. 21835 21836 if Is_Access_Type (Etype (Prefix (Exp))) then 21837 return; 21838 21839 -- Otherwise go to prefix and keep going 21840 21841 else 21842 Exp := Prefix (Exp); 21843 goto Continue; 21844 end if; 21845 21846 -- All other cases, not a modification 21847 21848 else 21849 return; 21850 end if; 21851 21852 -- Now look for entity being referenced 21853 21854 if Present (Ent) then 21855 if Is_Object (Ent) then 21856 if Comes_From_Source (Exp) 21857 or else Modification_Comes_From_Source 21858 then 21859 -- Give warning if pragma unmodified is given and we are 21860 -- sure this is a modification. 21861 21862 if Has_Pragma_Unmodified (Ent) and then Sure then 21863 21864 -- Note that the entity may be present only as a result 21865 -- of pragma Unused. 21866 21867 if Has_Pragma_Unused (Ent) then 21868 Error_Msg_NE ("??pragma Unused given for &!", N, Ent); 21869 else 21870 Error_Msg_NE 21871 ("??pragma Unmodified given for &!", N, Ent); 21872 end if; 21873 end if; 21874 21875 Set_Never_Set_In_Source (Ent, False); 21876 end if; 21877 21878 Set_Is_True_Constant (Ent, False); 21879 Set_Current_Value (Ent, Empty); 21880 Set_Is_Known_Null (Ent, False); 21881 21882 if not Can_Never_Be_Null (Ent) then 21883 Set_Is_Known_Non_Null (Ent, False); 21884 end if; 21885 21886 -- Follow renaming chain 21887 21888 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant) 21889 and then Present (Renamed_Object (Ent)) 21890 then 21891 Exp := Renamed_Object (Ent); 21892 21893 -- If the entity is the loop variable in an iteration over 21894 -- a container, retrieve container expression to indicate 21895 -- possible modification. 21896 21897 if Present (Related_Expression (Ent)) 21898 and then Nkind (Parent (Related_Expression (Ent))) = 21899 N_Iterator_Specification 21900 then 21901 Exp := Original_Node (Related_Expression (Ent)); 21902 end if; 21903 21904 goto Continue; 21905 21906 -- The expression may be the renaming of a subcomponent of an 21907 -- array or container. The assignment to the subcomponent is 21908 -- a modification of the container. 21909 21910 elsif Comes_From_Source (Original_Node (Exp)) 21911 and then Nkind_In (Original_Node (Exp), N_Selected_Component, 21912 N_Indexed_Component) 21913 then 21914 Exp := Prefix (Original_Node (Exp)); 21915 goto Continue; 21916 end if; 21917 21918 -- Generate a reference only if the assignment comes from 21919 -- source. This excludes, for example, calls to a dispatching 21920 -- assignment operation when the left-hand side is tagged. In 21921 -- GNATprove mode, we need those references also on generated 21922 -- code, as these are used to compute the local effects of 21923 -- subprograms. 21924 21925 if Modification_Comes_From_Source or GNATprove_Mode then 21926 Generate_Reference (Ent, Exp, 'm'); 21927 21928 -- If the target of the assignment is the bound variable 21929 -- in an iterator, indicate that the corresponding array 21930 -- or container is also modified. 21931 21932 if Ada_Version >= Ada_2012 21933 and then Nkind (Parent (Ent)) = N_Iterator_Specification 21934 then 21935 declare 21936 Domain : constant Node_Id := Name (Parent (Ent)); 21937 21938 begin 21939 -- TBD : in the full version of the construct, the 21940 -- domain of iteration can be given by an expression. 21941 21942 if Is_Entity_Name (Domain) then 21943 Generate_Reference (Entity (Domain), Exp, 'm'); 21944 Set_Is_True_Constant (Entity (Domain), False); 21945 Set_Never_Set_In_Source (Entity (Domain), False); 21946 end if; 21947 end; 21948 end if; 21949 end if; 21950 end if; 21951 21952 Kill_Checks (Ent); 21953 21954 -- If we are sure this is a modification from source, and we know 21955 -- this modifies a constant, then give an appropriate warning. 21956 21957 if Sure 21958 and then Modification_Comes_From_Source 21959 and then Overlays_Constant (Ent) 21960 and then Address_Clause_Overlay_Warnings 21961 then 21962 declare 21963 Addr : constant Node_Id := Address_Clause (Ent); 21964 O_Ent : Entity_Id; 21965 Off : Boolean; 21966 21967 begin 21968 Find_Overlaid_Entity (Addr, O_Ent, Off); 21969 21970 Error_Msg_Sloc := Sloc (Addr); 21971 Error_Msg_NE 21972 ("??constant& may be modified via address clause#", 21973 N, O_Ent); 21974 end; 21975 end if; 21976 21977 return; 21978 end if; 21979 21980 <<Continue>> 21981 null; 21982 end loop; 21983 end Note_Possible_Modification; 21984 21985 ----------------- 21986 -- Null_Status -- 21987 ----------------- 21988 21989 function Null_Status (N : Node_Id) return Null_Status_Kind is 21990 function Is_Null_Excluding_Def (Def : Node_Id) return Boolean; 21991 -- Determine whether definition Def carries a null exclusion 21992 21993 function Null_Status_Of_Entity (Id : Entity_Id) return Null_Status_Kind; 21994 -- Determine the null status of arbitrary entity Id 21995 21996 function Null_Status_Of_Type (Typ : Entity_Id) return Null_Status_Kind; 21997 -- Determine the null status of type Typ 21998 21999 --------------------------- 22000 -- Is_Null_Excluding_Def -- 22001 --------------------------- 22002 22003 function Is_Null_Excluding_Def (Def : Node_Id) return Boolean is 22004 begin 22005 return 22006 Nkind_In (Def, N_Access_Definition, 22007 N_Access_Function_Definition, 22008 N_Access_Procedure_Definition, 22009 N_Access_To_Object_Definition, 22010 N_Component_Definition, 22011 N_Derived_Type_Definition) 22012 and then Null_Exclusion_Present (Def); 22013 end Is_Null_Excluding_Def; 22014 22015 --------------------------- 22016 -- Null_Status_Of_Entity -- 22017 --------------------------- 22018 22019 function Null_Status_Of_Entity 22020 (Id : Entity_Id) return Null_Status_Kind 22021 is 22022 Decl : constant Node_Id := Declaration_Node (Id); 22023 Def : Node_Id; 22024 22025 begin 22026 -- The value of an imported or exported entity may be set externally 22027 -- regardless of a null exclusion. As a result, the value cannot be 22028 -- determined statically. 22029 22030 if Is_Imported (Id) or else Is_Exported (Id) then 22031 return Unknown; 22032 22033 elsif Nkind_In (Decl, N_Component_Declaration, 22034 N_Discriminant_Specification, 22035 N_Formal_Object_Declaration, 22036 N_Object_Declaration, 22037 N_Object_Renaming_Declaration, 22038 N_Parameter_Specification) 22039 then 22040 -- A component declaration yields a non-null value when either 22041 -- its component definition or access definition carries a null 22042 -- exclusion. 22043 22044 if Nkind (Decl) = N_Component_Declaration then 22045 Def := Component_Definition (Decl); 22046 22047 if Is_Null_Excluding_Def (Def) then 22048 return Is_Non_Null; 22049 end if; 22050 22051 Def := Access_Definition (Def); 22052 22053 if Present (Def) and then Is_Null_Excluding_Def (Def) then 22054 return Is_Non_Null; 22055 end if; 22056 22057 -- A formal object declaration yields a non-null value if its 22058 -- access definition carries a null exclusion. If the object is 22059 -- default initialized, then the value depends on the expression. 22060 22061 elsif Nkind (Decl) = N_Formal_Object_Declaration then 22062 Def := Access_Definition (Decl); 22063 22064 if Present (Def) and then Is_Null_Excluding_Def (Def) then 22065 return Is_Non_Null; 22066 end if; 22067 22068 -- A constant may yield a null or non-null value depending on its 22069 -- initialization expression. 22070 22071 elsif Ekind (Id) = E_Constant then 22072 return Null_Status (Constant_Value (Id)); 22073 22074 -- The construct yields a non-null value when it has a null 22075 -- exclusion. 22076 22077 elsif Null_Exclusion_Present (Decl) then 22078 return Is_Non_Null; 22079 22080 -- An object renaming declaration yields a non-null value if its 22081 -- access definition carries a null exclusion. Otherwise the value 22082 -- depends on the renamed name. 22083 22084 elsif Nkind (Decl) = N_Object_Renaming_Declaration then 22085 Def := Access_Definition (Decl); 22086 22087 if Present (Def) and then Is_Null_Excluding_Def (Def) then 22088 return Is_Non_Null; 22089 22090 else 22091 return Null_Status (Name (Decl)); 22092 end if; 22093 end if; 22094 end if; 22095 22096 -- At this point the declaration of the entity does not carry a null 22097 -- exclusion and lacks an initialization expression. Check the status 22098 -- of its type. 22099 22100 return Null_Status_Of_Type (Etype (Id)); 22101 end Null_Status_Of_Entity; 22102 22103 ------------------------- 22104 -- Null_Status_Of_Type -- 22105 ------------------------- 22106 22107 function Null_Status_Of_Type (Typ : Entity_Id) return Null_Status_Kind is 22108 Curr : Entity_Id; 22109 Decl : Node_Id; 22110 22111 begin 22112 -- Traverse the type chain looking for types with null exclusion 22113 22114 Curr := Typ; 22115 while Present (Curr) and then Etype (Curr) /= Curr loop 22116 Decl := Parent (Curr); 22117 22118 -- Guard against itypes which do not always have declarations. A 22119 -- type yields a non-null value if it carries a null exclusion. 22120 22121 if Present (Decl) then 22122 if Nkind (Decl) = N_Full_Type_Declaration 22123 and then Is_Null_Excluding_Def (Type_Definition (Decl)) 22124 then 22125 return Is_Non_Null; 22126 22127 elsif Nkind (Decl) = N_Subtype_Declaration 22128 and then Null_Exclusion_Present (Decl) 22129 then 22130 return Is_Non_Null; 22131 end if; 22132 end if; 22133 22134 Curr := Etype (Curr); 22135 end loop; 22136 22137 -- The type chain does not contain any null excluding types 22138 22139 return Unknown; 22140 end Null_Status_Of_Type; 22141 22142 -- Start of processing for Null_Status 22143 22144 begin 22145 -- An allocator always creates a non-null value 22146 22147 if Nkind (N) = N_Allocator then 22148 return Is_Non_Null; 22149 22150 -- Taking the 'Access of something yields a non-null value 22151 22152 elsif Nkind (N) = N_Attribute_Reference 22153 and then Nam_In (Attribute_Name (N), Name_Access, 22154 Name_Unchecked_Access, 22155 Name_Unrestricted_Access) 22156 then 22157 return Is_Non_Null; 22158 22159 -- "null" yields null 22160 22161 elsif Nkind (N) = N_Null then 22162 return Is_Null; 22163 22164 -- Check the status of the operand of a type conversion 22165 22166 elsif Nkind (N) = N_Type_Conversion then 22167 return Null_Status (Expression (N)); 22168 22169 -- The input denotes a reference to an entity. Determine whether the 22170 -- entity or its type yields a null or non-null value. 22171 22172 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 22173 return Null_Status_Of_Entity (Entity (N)); 22174 end if; 22175 22176 -- Otherwise it is not possible to determine the null status of the 22177 -- subexpression at compile time without resorting to simple flow 22178 -- analysis. 22179 22180 return Unknown; 22181 end Null_Status; 22182 22183 -------------------------------------- 22184 -- Null_To_Null_Address_Convert_OK -- 22185 -------------------------------------- 22186 22187 function Null_To_Null_Address_Convert_OK 22188 (N : Node_Id; 22189 Typ : Entity_Id := Empty) return Boolean 22190 is 22191 begin 22192 if not Relaxed_RM_Semantics then 22193 return False; 22194 end if; 22195 22196 if Nkind (N) = N_Null then 22197 return Present (Typ) and then Is_Descendant_Of_Address (Typ); 22198 22199 elsif Nkind_In (N, N_Op_Eq, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt, N_Op_Ne) 22200 then 22201 declare 22202 L : constant Node_Id := Left_Opnd (N); 22203 R : constant Node_Id := Right_Opnd (N); 22204 22205 begin 22206 -- We check the Etype of the complementary operand since the 22207 -- N_Null node is not decorated at this stage. 22208 22209 return 22210 ((Nkind (L) = N_Null 22211 and then Is_Descendant_Of_Address (Etype (R))) 22212 or else 22213 (Nkind (R) = N_Null 22214 and then Is_Descendant_Of_Address (Etype (L)))); 22215 end; 22216 end if; 22217 22218 return False; 22219 end Null_To_Null_Address_Convert_OK; 22220 22221 --------------------------------- 22222 -- Number_Of_Elements_In_Array -- 22223 --------------------------------- 22224 22225 function Number_Of_Elements_In_Array (T : Entity_Id) return Int is 22226 Indx : Node_Id; 22227 Typ : Entity_Id; 22228 Low : Node_Id; 22229 High : Node_Id; 22230 Num : Int := 1; 22231 22232 begin 22233 pragma Assert (Is_Array_Type (T)); 22234 22235 Indx := First_Index (T); 22236 while Present (Indx) loop 22237 Typ := Underlying_Type (Etype (Indx)); 22238 22239 -- Never look at junk bounds of a generic type 22240 22241 if Is_Generic_Type (Typ) then 22242 return 0; 22243 end if; 22244 22245 -- Check the array bounds are known at compile time and return zero 22246 -- if they are not. 22247 22248 Low := Type_Low_Bound (Typ); 22249 High := Type_High_Bound (Typ); 22250 22251 if not Compile_Time_Known_Value (Low) then 22252 return 0; 22253 elsif not Compile_Time_Known_Value (High) then 22254 return 0; 22255 else 22256 Num := 22257 Num * UI_To_Int ((Expr_Value (High) - Expr_Value (Low) + 1)); 22258 end if; 22259 22260 Next_Index (Indx); 22261 end loop; 22262 22263 return Num; 22264 end Number_Of_Elements_In_Array; 22265 22266 ------------------------- 22267 -- Object_Access_Level -- 22268 ------------------------- 22269 22270 -- Returns the static accessibility level of the view denoted by Obj. Note 22271 -- that the value returned is the result of a call to Scope_Depth. Only 22272 -- scope depths associated with dynamic scopes can actually be returned. 22273 -- Since only relative levels matter for accessibility checking, the fact 22274 -- that the distance between successive levels of accessibility is not 22275 -- always one is immaterial (invariant: if level(E2) is deeper than 22276 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)). 22277 22278 function Object_Access_Level (Obj : Node_Id) return Uint is 22279 function Is_Interface_Conversion (N : Node_Id) return Boolean; 22280 -- Determine whether N is a construct of the form 22281 -- Some_Type (Operand._tag'Address) 22282 -- This construct appears in the context of dispatching calls. 22283 22284 function Reference_To (Obj : Node_Id) return Node_Id; 22285 -- An explicit dereference is created when removing side effects from 22286 -- expressions for constraint checking purposes. In this case a local 22287 -- access type is created for it. The correct access level is that of 22288 -- the original source node. We detect this case by noting that the 22289 -- prefix of the dereference is created by an object declaration whose 22290 -- initial expression is a reference. 22291 22292 ----------------------------- 22293 -- Is_Interface_Conversion -- 22294 ----------------------------- 22295 22296 function Is_Interface_Conversion (N : Node_Id) return Boolean is 22297 begin 22298 return Nkind (N) = N_Unchecked_Type_Conversion 22299 and then Nkind (Expression (N)) = N_Attribute_Reference 22300 and then Attribute_Name (Expression (N)) = Name_Address; 22301 end Is_Interface_Conversion; 22302 22303 ------------------ 22304 -- Reference_To -- 22305 ------------------ 22306 22307 function Reference_To (Obj : Node_Id) return Node_Id is 22308 Pref : constant Node_Id := Prefix (Obj); 22309 begin 22310 if Is_Entity_Name (Pref) 22311 and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration 22312 and then Present (Expression (Parent (Entity (Pref)))) 22313 and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference 22314 then 22315 return (Prefix (Expression (Parent (Entity (Pref))))); 22316 else 22317 return Empty; 22318 end if; 22319 end Reference_To; 22320 22321 -- Local variables 22322 22323 E : Entity_Id; 22324 22325 -- Start of processing for Object_Access_Level 22326 22327 begin 22328 if Nkind (Obj) = N_Defining_Identifier 22329 or else Is_Entity_Name (Obj) 22330 then 22331 if Nkind (Obj) = N_Defining_Identifier then 22332 E := Obj; 22333 else 22334 E := Entity (Obj); 22335 end if; 22336 22337 if Is_Prival (E) then 22338 E := Prival_Link (E); 22339 end if; 22340 22341 -- If E is a type then it denotes a current instance. For this case 22342 -- we add one to the normal accessibility level of the type to ensure 22343 -- that current instances are treated as always being deeper than 22344 -- than the level of any visible named access type (see 3.10.2(21)). 22345 22346 if Is_Type (E) then 22347 return Type_Access_Level (E) + 1; 22348 22349 elsif Present (Renamed_Object (E)) then 22350 return Object_Access_Level (Renamed_Object (E)); 22351 22352 -- Similarly, if E is a component of the current instance of a 22353 -- protected type, any instance of it is assumed to be at a deeper 22354 -- level than the type. For a protected object (whose type is an 22355 -- anonymous protected type) its components are at the same level 22356 -- as the type itself. 22357 22358 elsif not Is_Overloadable (E) 22359 and then Ekind (Scope (E)) = E_Protected_Type 22360 and then Comes_From_Source (Scope (E)) 22361 then 22362 return Type_Access_Level (Scope (E)) + 1; 22363 22364 else 22365 -- Aliased formals of functions take their access level from the 22366 -- point of call, i.e. require a dynamic check. For static check 22367 -- purposes, this is smaller than the level of the subprogram 22368 -- itself. For procedures the aliased makes no difference. 22369 22370 if Is_Formal (E) 22371 and then Is_Aliased (E) 22372 and then Ekind (Scope (E)) = E_Function 22373 then 22374 return Type_Access_Level (Etype (E)); 22375 22376 else 22377 return Scope_Depth (Enclosing_Dynamic_Scope (E)); 22378 end if; 22379 end if; 22380 22381 elsif Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then 22382 if Is_Access_Type (Etype (Prefix (Obj))) then 22383 return Type_Access_Level (Etype (Prefix (Obj))); 22384 else 22385 return Object_Access_Level (Prefix (Obj)); 22386 end if; 22387 22388 elsif Nkind (Obj) = N_Explicit_Dereference then 22389 22390 -- If the prefix is a selected access discriminant then we make a 22391 -- recursive call on the prefix, which will in turn check the level 22392 -- of the prefix object of the selected discriminant. 22393 22394 -- In Ada 2012, if the discriminant has implicit dereference and 22395 -- the context is a selected component, treat this as an object of 22396 -- unknown scope (see below). This is necessary in compile-only mode; 22397 -- otherwise expansion will already have transformed the prefix into 22398 -- a temporary. 22399 22400 if Nkind (Prefix (Obj)) = N_Selected_Component 22401 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type 22402 and then 22403 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant 22404 and then 22405 (not Has_Implicit_Dereference 22406 (Entity (Selector_Name (Prefix (Obj)))) 22407 or else Nkind (Parent (Obj)) /= N_Selected_Component) 22408 then 22409 return Object_Access_Level (Prefix (Obj)); 22410 22411 -- Detect an interface conversion in the context of a dispatching 22412 -- call. Use the original form of the conversion to find the access 22413 -- level of the operand. 22414 22415 elsif Is_Interface (Etype (Obj)) 22416 and then Is_Interface_Conversion (Prefix (Obj)) 22417 and then Nkind (Original_Node (Obj)) = N_Type_Conversion 22418 then 22419 return Object_Access_Level (Original_Node (Obj)); 22420 22421 elsif not Comes_From_Source (Obj) then 22422 declare 22423 Ref : constant Node_Id := Reference_To (Obj); 22424 begin 22425 if Present (Ref) then 22426 return Object_Access_Level (Ref); 22427 else 22428 return Type_Access_Level (Etype (Prefix (Obj))); 22429 end if; 22430 end; 22431 22432 else 22433 return Type_Access_Level (Etype (Prefix (Obj))); 22434 end if; 22435 22436 elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then 22437 return Object_Access_Level (Expression (Obj)); 22438 22439 elsif Nkind (Obj) = N_Function_Call then 22440 22441 -- Function results are objects, so we get either the access level of 22442 -- the function or, in the case of an indirect call, the level of the 22443 -- access-to-subprogram type. (This code is used for Ada 95, but it 22444 -- looks wrong, because it seems that we should be checking the level 22445 -- of the call itself, even for Ada 95. However, using the Ada 2005 22446 -- version of the code causes regressions in several tests that are 22447 -- compiled with -gnat95. ???) 22448 22449 if Ada_Version < Ada_2005 then 22450 if Is_Entity_Name (Name (Obj)) then 22451 return Subprogram_Access_Level (Entity (Name (Obj))); 22452 else 22453 return Type_Access_Level (Etype (Prefix (Name (Obj)))); 22454 end if; 22455 22456 -- For Ada 2005, the level of the result object of a function call is 22457 -- defined to be the level of the call's innermost enclosing master. 22458 -- We determine that by querying the depth of the innermost enclosing 22459 -- dynamic scope. 22460 22461 else 22462 Return_Master_Scope_Depth_Of_Call : declare 22463 function Innermost_Master_Scope_Depth 22464 (N : Node_Id) return Uint; 22465 -- Returns the scope depth of the given node's innermost 22466 -- enclosing dynamic scope (effectively the accessibility 22467 -- level of the innermost enclosing master). 22468 22469 ---------------------------------- 22470 -- Innermost_Master_Scope_Depth -- 22471 ---------------------------------- 22472 22473 function Innermost_Master_Scope_Depth 22474 (N : Node_Id) return Uint 22475 is 22476 Node_Par : Node_Id := Parent (N); 22477 22478 begin 22479 -- Locate the nearest enclosing node (by traversing Parents) 22480 -- that Defining_Entity can be applied to, and return the 22481 -- depth of that entity's nearest enclosing dynamic scope. 22482 22483 while Present (Node_Par) loop 22484 case Nkind (Node_Par) is 22485 when N_Abstract_Subprogram_Declaration 22486 | N_Block_Statement 22487 | N_Body_Stub 22488 | N_Component_Declaration 22489 | N_Entry_Body 22490 | N_Entry_Declaration 22491 | N_Exception_Declaration 22492 | N_Formal_Object_Declaration 22493 | N_Formal_Package_Declaration 22494 | N_Formal_Subprogram_Declaration 22495 | N_Formal_Type_Declaration 22496 | N_Full_Type_Declaration 22497 | N_Function_Specification 22498 | N_Generic_Declaration 22499 | N_Generic_Instantiation 22500 | N_Implicit_Label_Declaration 22501 | N_Incomplete_Type_Declaration 22502 | N_Loop_Parameter_Specification 22503 | N_Number_Declaration 22504 | N_Object_Declaration 22505 | N_Package_Declaration 22506 | N_Package_Specification 22507 | N_Parameter_Specification 22508 | N_Private_Extension_Declaration 22509 | N_Private_Type_Declaration 22510 | N_Procedure_Specification 22511 | N_Proper_Body 22512 | N_Protected_Type_Declaration 22513 | N_Renaming_Declaration 22514 | N_Single_Protected_Declaration 22515 | N_Single_Task_Declaration 22516 | N_Subprogram_Declaration 22517 | N_Subtype_Declaration 22518 | N_Subunit 22519 | N_Task_Type_Declaration 22520 => 22521 return Scope_Depth 22522 (Nearest_Dynamic_Scope 22523 (Defining_Entity (Node_Par))); 22524 22525 -- For a return statement within a function, return 22526 -- the depth of the function itself. This is not just 22527 -- a small optimization, but matters when analyzing 22528 -- the expression in an expression function before 22529 -- the body is created. 22530 22531 when N_Simple_Return_Statement => 22532 if Ekind (Current_Scope) = E_Function then 22533 return Scope_Depth (Current_Scope); 22534 end if; 22535 22536 when others => 22537 null; 22538 end case; 22539 22540 Node_Par := Parent (Node_Par); 22541 end loop; 22542 22543 pragma Assert (False); 22544 22545 -- Should never reach the following return 22546 22547 return Scope_Depth (Current_Scope) + 1; 22548 end Innermost_Master_Scope_Depth; 22549 22550 -- Start of processing for Return_Master_Scope_Depth_Of_Call 22551 22552 begin 22553 return Innermost_Master_Scope_Depth (Obj); 22554 end Return_Master_Scope_Depth_Of_Call; 22555 end if; 22556 22557 -- For convenience we handle qualified expressions, even though they 22558 -- aren't technically object names. 22559 22560 elsif Nkind (Obj) = N_Qualified_Expression then 22561 return Object_Access_Level (Expression (Obj)); 22562 22563 -- Ditto for aggregates. They have the level of the temporary that 22564 -- will hold their value. 22565 22566 elsif Nkind (Obj) = N_Aggregate then 22567 return Object_Access_Level (Current_Scope); 22568 22569 -- Otherwise return the scope level of Standard. (If there are cases 22570 -- that fall through to this point they will be treated as having 22571 -- global accessibility for now. ???) 22572 22573 else 22574 return Scope_Depth (Standard_Standard); 22575 end if; 22576 end Object_Access_Level; 22577 22578 ---------------------------------- 22579 -- Old_Requires_Transient_Scope -- 22580 ---------------------------------- 22581 22582 function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean is 22583 Typ : constant Entity_Id := Underlying_Type (Id); 22584 22585 begin 22586 -- This is a private type which is not completed yet. This can only 22587 -- happen in a default expression (of a formal parameter or of a 22588 -- record component). Do not expand transient scope in this case. 22589 22590 if No (Typ) then 22591 return False; 22592 22593 -- Do not expand transient scope for non-existent procedure return 22594 22595 elsif Typ = Standard_Void_Type then 22596 return False; 22597 22598 -- Elementary types do not require a transient scope 22599 22600 elsif Is_Elementary_Type (Typ) then 22601 return False; 22602 22603 -- Generally, indefinite subtypes require a transient scope, since the 22604 -- back end cannot generate temporaries, since this is not a valid type 22605 -- for declaring an object. It might be possible to relax this in the 22606 -- future, e.g. by declaring the maximum possible space for the type. 22607 22608 elsif not Is_Definite_Subtype (Typ) then 22609 return True; 22610 22611 -- Functions returning tagged types may dispatch on result so their 22612 -- returned value is allocated on the secondary stack. Controlled 22613 -- type temporaries need finalization. 22614 22615 elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then 22616 return True; 22617 22618 -- Record type 22619 22620 elsif Is_Record_Type (Typ) then 22621 declare 22622 Comp : Entity_Id; 22623 22624 begin 22625 Comp := First_Entity (Typ); 22626 while Present (Comp) loop 22627 if Ekind (Comp) = E_Component then 22628 22629 -- ???It's not clear we need a full recursive call to 22630 -- Old_Requires_Transient_Scope here. Note that the 22631 -- following can't happen. 22632 22633 pragma Assert (Is_Definite_Subtype (Etype (Comp))); 22634 pragma Assert (not Has_Controlled_Component (Etype (Comp))); 22635 22636 if Old_Requires_Transient_Scope (Etype (Comp)) then 22637 return True; 22638 end if; 22639 end if; 22640 22641 Next_Entity (Comp); 22642 end loop; 22643 end; 22644 22645 return False; 22646 22647 -- String literal types never require transient scope 22648 22649 elsif Ekind (Typ) = E_String_Literal_Subtype then 22650 return False; 22651 22652 -- Array type. Note that we already know that this is a constrained 22653 -- array, since unconstrained arrays will fail the indefinite test. 22654 22655 elsif Is_Array_Type (Typ) then 22656 22657 -- If component type requires a transient scope, the array does too 22658 22659 if Old_Requires_Transient_Scope (Component_Type (Typ)) then 22660 return True; 22661 22662 -- Otherwise, we only need a transient scope if the size depends on 22663 -- the value of one or more discriminants. 22664 22665 else 22666 return Size_Depends_On_Discriminant (Typ); 22667 end if; 22668 22669 -- All other cases do not require a transient scope 22670 22671 else 22672 pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ)); 22673 return False; 22674 end if; 22675 end Old_Requires_Transient_Scope; 22676 22677 --------------------------------- 22678 -- Original_Aspect_Pragma_Name -- 22679 --------------------------------- 22680 22681 function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id is 22682 Item : Node_Id; 22683 Item_Nam : Name_Id; 22684 22685 begin 22686 pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma)); 22687 22688 Item := N; 22689 22690 -- The pragma was generated to emulate an aspect, use the original 22691 -- aspect specification. 22692 22693 if Nkind (Item) = N_Pragma and then From_Aspect_Specification (Item) then 22694 Item := Corresponding_Aspect (Item); 22695 end if; 22696 22697 -- Retrieve the name of the aspect/pragma. Note that Pre, Pre_Class, 22698 -- Post and Post_Class rewrite their pragma identifier to preserve the 22699 -- original name. 22700 -- ??? this is kludgey 22701 22702 if Nkind (Item) = N_Pragma then 22703 Item_Nam := Chars (Original_Node (Pragma_Identifier (Item))); 22704 22705 else 22706 pragma Assert (Nkind (Item) = N_Aspect_Specification); 22707 Item_Nam := Chars (Identifier (Item)); 22708 end if; 22709 22710 -- Deal with 'Class by converting the name to its _XXX form 22711 22712 if Class_Present (Item) then 22713 if Item_Nam = Name_Invariant then 22714 Item_Nam := Name_uInvariant; 22715 22716 elsif Item_Nam = Name_Post then 22717 Item_Nam := Name_uPost; 22718 22719 elsif Item_Nam = Name_Pre then 22720 Item_Nam := Name_uPre; 22721 22722 elsif Nam_In (Item_Nam, Name_Type_Invariant, 22723 Name_Type_Invariant_Class) 22724 then 22725 Item_Nam := Name_uType_Invariant; 22726 22727 -- Nothing to do for other cases (e.g. a Check that derived from 22728 -- Pre_Class and has the flag set). Also we do nothing if the name 22729 -- is already in special _xxx form. 22730 22731 end if; 22732 end if; 22733 22734 return Item_Nam; 22735 end Original_Aspect_Pragma_Name; 22736 22737 -------------------------------------- 22738 -- Original_Corresponding_Operation -- 22739 -------------------------------------- 22740 22741 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id 22742 is 22743 Typ : constant Entity_Id := Find_Dispatching_Type (S); 22744 22745 begin 22746 -- If S is an inherited primitive S2 the original corresponding 22747 -- operation of S is the original corresponding operation of S2 22748 22749 if Present (Alias (S)) 22750 and then Find_Dispatching_Type (Alias (S)) /= Typ 22751 then 22752 return Original_Corresponding_Operation (Alias (S)); 22753 22754 -- If S overrides an inherited subprogram S2 the original corresponding 22755 -- operation of S is the original corresponding operation of S2 22756 22757 elsif Present (Overridden_Operation (S)) then 22758 return Original_Corresponding_Operation (Overridden_Operation (S)); 22759 22760 -- otherwise it is S itself 22761 22762 else 22763 return S; 22764 end if; 22765 end Original_Corresponding_Operation; 22766 22767 ------------------- 22768 -- Output_Entity -- 22769 ------------------- 22770 22771 procedure Output_Entity (Id : Entity_Id) is 22772 Scop : Entity_Id; 22773 22774 begin 22775 Scop := Scope (Id); 22776 22777 -- The entity may lack a scope when it is in the process of being 22778 -- analyzed. Use the current scope as an approximation. 22779 22780 if No (Scop) then 22781 Scop := Current_Scope; 22782 end if; 22783 22784 Output_Name (Chars (Id), Scop); 22785 end Output_Entity; 22786 22787 ----------------- 22788 -- Output_Name -- 22789 ----------------- 22790 22791 procedure Output_Name (Nam : Name_Id; Scop : Entity_Id := Current_Scope) is 22792 begin 22793 Write_Str 22794 (Get_Name_String 22795 (Get_Qualified_Name 22796 (Nam => Nam, 22797 Suffix => No_Name, 22798 Scop => Scop))); 22799 Write_Eol; 22800 end Output_Name; 22801 22802 ---------------------- 22803 -- Policy_In_Effect -- 22804 ---------------------- 22805 22806 function Policy_In_Effect (Policy : Name_Id) return Name_Id is 22807 function Policy_In_List (List : Node_Id) return Name_Id; 22808 -- Determine the mode of a policy in a N_Pragma list 22809 22810 -------------------- 22811 -- Policy_In_List -- 22812 -------------------- 22813 22814 function Policy_In_List (List : Node_Id) return Name_Id is 22815 Arg1 : Node_Id; 22816 Arg2 : Node_Id; 22817 Prag : Node_Id; 22818 22819 begin 22820 Prag := List; 22821 while Present (Prag) loop 22822 Arg1 := First (Pragma_Argument_Associations (Prag)); 22823 Arg2 := Next (Arg1); 22824 22825 Arg1 := Get_Pragma_Arg (Arg1); 22826 Arg2 := Get_Pragma_Arg (Arg2); 22827 22828 -- The current Check_Policy pragma matches the requested policy or 22829 -- appears in the single argument form (Assertion, policy_id). 22830 22831 if Nam_In (Chars (Arg1), Name_Assertion, Policy) then 22832 return Chars (Arg2); 22833 end if; 22834 22835 Prag := Next_Pragma (Prag); 22836 end loop; 22837 22838 return No_Name; 22839 end Policy_In_List; 22840 22841 -- Local variables 22842 22843 Kind : Name_Id; 22844 22845 -- Start of processing for Policy_In_Effect 22846 22847 begin 22848 if not Is_Valid_Assertion_Kind (Policy) then 22849 raise Program_Error; 22850 end if; 22851 22852 -- Inspect all policy pragmas that appear within scopes (if any) 22853 22854 Kind := Policy_In_List (Check_Policy_List); 22855 22856 -- Inspect all configuration policy pragmas (if any) 22857 22858 if Kind = No_Name then 22859 Kind := Policy_In_List (Check_Policy_List_Config); 22860 end if; 22861 22862 -- The context lacks policy pragmas, determine the mode based on whether 22863 -- assertions are enabled at the configuration level. This ensures that 22864 -- the policy is preserved when analyzing generics. 22865 22866 if Kind = No_Name then 22867 if Assertions_Enabled_Config then 22868 Kind := Name_Check; 22869 else 22870 Kind := Name_Ignore; 22871 end if; 22872 end if; 22873 22874 -- In CodePeer mode and GNATprove mode, we need to consider all 22875 -- assertions, unless they are disabled. Force Name_Check on 22876 -- ignored assertions. 22877 22878 if Nam_In (Kind, Name_Ignore, Name_Off) 22879 and then (CodePeer_Mode or GNATprove_Mode) 22880 then 22881 Kind := Name_Check; 22882 end if; 22883 22884 return Kind; 22885 end Policy_In_Effect; 22886 22887 ---------------------------------- 22888 -- Predicate_Tests_On_Arguments -- 22889 ---------------------------------- 22890 22891 function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean is 22892 begin 22893 -- Always test predicates on indirect call 22894 22895 if Ekind (Subp) = E_Subprogram_Type then 22896 return True; 22897 22898 -- Do not test predicates on call to generated default Finalize, since 22899 -- we are not interested in whether something we are finalizing (and 22900 -- typically destroying) satisfies its predicates. 22901 22902 elsif Chars (Subp) = Name_Finalize 22903 and then not Comes_From_Source (Subp) 22904 then 22905 return False; 22906 22907 -- Do not test predicates on any internally generated routines 22908 22909 elsif Is_Internal_Name (Chars (Subp)) then 22910 return False; 22911 22912 -- Do not test predicates on call to Init_Proc, since if needed the 22913 -- predicate test will occur at some other point. 22914 22915 elsif Is_Init_Proc (Subp) then 22916 return False; 22917 22918 -- Do not test predicates on call to predicate function, since this 22919 -- would cause infinite recursion. 22920 22921 elsif Ekind (Subp) = E_Function 22922 and then (Is_Predicate_Function (Subp) 22923 or else 22924 Is_Predicate_Function_M (Subp)) 22925 then 22926 return False; 22927 22928 -- For now, no other exceptions 22929 22930 else 22931 return True; 22932 end if; 22933 end Predicate_Tests_On_Arguments; 22934 22935 ----------------------- 22936 -- Private_Component -- 22937 ----------------------- 22938 22939 function Private_Component (Type_Id : Entity_Id) return Entity_Id is 22940 Ancestor : constant Entity_Id := Base_Type (Type_Id); 22941 22942 function Trace_Components 22943 (T : Entity_Id; 22944 Check : Boolean) return Entity_Id; 22945 -- Recursive function that does the work, and checks against circular 22946 -- definition for each subcomponent type. 22947 22948 ---------------------- 22949 -- Trace_Components -- 22950 ---------------------- 22951 22952 function Trace_Components 22953 (T : Entity_Id; 22954 Check : Boolean) return Entity_Id 22955 is 22956 Btype : constant Entity_Id := Base_Type (T); 22957 Component : Entity_Id; 22958 P : Entity_Id; 22959 Candidate : Entity_Id := Empty; 22960 22961 begin 22962 if Check and then Btype = Ancestor then 22963 Error_Msg_N ("circular type definition", Type_Id); 22964 return Any_Type; 22965 end if; 22966 22967 if Is_Private_Type (Btype) and then not Is_Generic_Type (Btype) then 22968 if Present (Full_View (Btype)) 22969 and then Is_Record_Type (Full_View (Btype)) 22970 and then not Is_Frozen (Btype) 22971 then 22972 -- To indicate that the ancestor depends on a private type, the 22973 -- current Btype is sufficient. However, to check for circular 22974 -- definition we must recurse on the full view. 22975 22976 Candidate := Trace_Components (Full_View (Btype), True); 22977 22978 if Candidate = Any_Type then 22979 return Any_Type; 22980 else 22981 return Btype; 22982 end if; 22983 22984 else 22985 return Btype; 22986 end if; 22987 22988 elsif Is_Array_Type (Btype) then 22989 return Trace_Components (Component_Type (Btype), True); 22990 22991 elsif Is_Record_Type (Btype) then 22992 Component := First_Entity (Btype); 22993 while Present (Component) 22994 and then Comes_From_Source (Component) 22995 loop 22996 -- Skip anonymous types generated by constrained components 22997 22998 if not Is_Type (Component) then 22999 P := Trace_Components (Etype (Component), True); 23000 23001 if Present (P) then 23002 if P = Any_Type then 23003 return P; 23004 else 23005 Candidate := P; 23006 end if; 23007 end if; 23008 end if; 23009 23010 Next_Entity (Component); 23011 end loop; 23012 23013 return Candidate; 23014 23015 else 23016 return Empty; 23017 end if; 23018 end Trace_Components; 23019 23020 -- Start of processing for Private_Component 23021 23022 begin 23023 return Trace_Components (Type_Id, False); 23024 end Private_Component; 23025 23026 --------------------------- 23027 -- Primitive_Names_Match -- 23028 --------------------------- 23029 23030 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is 23031 function Non_Internal_Name (E : Entity_Id) return Name_Id; 23032 -- Given an internal name, returns the corresponding non-internal name 23033 23034 ------------------------ 23035 -- Non_Internal_Name -- 23036 ------------------------ 23037 23038 function Non_Internal_Name (E : Entity_Id) return Name_Id is 23039 begin 23040 Get_Name_String (Chars (E)); 23041 Name_Len := Name_Len - 1; 23042 return Name_Find; 23043 end Non_Internal_Name; 23044 23045 -- Start of processing for Primitive_Names_Match 23046 23047 begin 23048 pragma Assert (Present (E1) and then Present (E2)); 23049 23050 return Chars (E1) = Chars (E2) 23051 or else 23052 (not Is_Internal_Name (Chars (E1)) 23053 and then Is_Internal_Name (Chars (E2)) 23054 and then Non_Internal_Name (E2) = Chars (E1)) 23055 or else 23056 (not Is_Internal_Name (Chars (E2)) 23057 and then Is_Internal_Name (Chars (E1)) 23058 and then Non_Internal_Name (E1) = Chars (E2)) 23059 or else 23060 (Is_Predefined_Dispatching_Operation (E1) 23061 and then Is_Predefined_Dispatching_Operation (E2) 23062 and then Same_TSS (E1, E2)) 23063 or else 23064 (Is_Init_Proc (E1) and then Is_Init_Proc (E2)); 23065 end Primitive_Names_Match; 23066 23067 ----------------------- 23068 -- Process_End_Label -- 23069 ----------------------- 23070 23071 procedure Process_End_Label 23072 (N : Node_Id; 23073 Typ : Character; 23074 Ent : Entity_Id) 23075 is 23076 Loc : Source_Ptr; 23077 Nam : Node_Id; 23078 Scop : Entity_Id; 23079 23080 Label_Ref : Boolean; 23081 -- Set True if reference to end label itself is required 23082 23083 Endl : Node_Id; 23084 -- Gets set to the operator symbol or identifier that references the 23085 -- entity Ent. For the child unit case, this is the identifier from the 23086 -- designator. For other cases, this is simply Endl. 23087 23088 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id); 23089 -- N is an identifier node that appears as a parent unit reference in 23090 -- the case where Ent is a child unit. This procedure generates an 23091 -- appropriate cross-reference entry. E is the corresponding entity. 23092 23093 ------------------------- 23094 -- Generate_Parent_Ref -- 23095 ------------------------- 23096 23097 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is 23098 begin 23099 -- If names do not match, something weird, skip reference 23100 23101 if Chars (E) = Chars (N) then 23102 23103 -- Generate the reference. We do NOT consider this as a reference 23104 -- for unreferenced symbol purposes. 23105 23106 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True); 23107 23108 if Style_Check then 23109 Style.Check_Identifier (N, E); 23110 end if; 23111 end if; 23112 end Generate_Parent_Ref; 23113 23114 -- Start of processing for Process_End_Label 23115 23116 begin 23117 -- If no node, ignore. This happens in some error situations, and 23118 -- also for some internally generated structures where no end label 23119 -- references are required in any case. 23120 23121 if No (N) then 23122 return; 23123 end if; 23124 23125 -- Nothing to do if no End_Label, happens for internally generated 23126 -- constructs where we don't want an end label reference anyway. Also 23127 -- nothing to do if Endl is a string literal, which means there was 23128 -- some prior error (bad operator symbol) 23129 23130 Endl := End_Label (N); 23131 23132 if No (Endl) or else Nkind (Endl) = N_String_Literal then 23133 return; 23134 end if; 23135 23136 -- Reference node is not in extended main source unit 23137 23138 if not In_Extended_Main_Source_Unit (N) then 23139 23140 -- Generally we do not collect references except for the extended 23141 -- main source unit. The one exception is the 'e' entry for a 23142 -- package spec, where it is useful for a client to have the 23143 -- ending information to define scopes. 23144 23145 if Typ /= 'e' then 23146 return; 23147 23148 else 23149 Label_Ref := False; 23150 23151 -- For this case, we can ignore any parent references, but we 23152 -- need the package name itself for the 'e' entry. 23153 23154 if Nkind (Endl) = N_Designator then 23155 Endl := Identifier (Endl); 23156 end if; 23157 end if; 23158 23159 -- Reference is in extended main source unit 23160 23161 else 23162 Label_Ref := True; 23163 23164 -- For designator, generate references for the parent entries 23165 23166 if Nkind (Endl) = N_Designator then 23167 23168 -- Generate references for the prefix if the END line comes from 23169 -- source (otherwise we do not need these references) We climb the 23170 -- scope stack to find the expected entities. 23171 23172 if Comes_From_Source (Endl) then 23173 Nam := Name (Endl); 23174 Scop := Current_Scope; 23175 while Nkind (Nam) = N_Selected_Component loop 23176 Scop := Scope (Scop); 23177 exit when No (Scop); 23178 Generate_Parent_Ref (Selector_Name (Nam), Scop); 23179 Nam := Prefix (Nam); 23180 end loop; 23181 23182 if Present (Scop) then 23183 Generate_Parent_Ref (Nam, Scope (Scop)); 23184 end if; 23185 end if; 23186 23187 Endl := Identifier (Endl); 23188 end if; 23189 end if; 23190 23191 -- If the end label is not for the given entity, then either we have 23192 -- some previous error, or this is a generic instantiation for which 23193 -- we do not need to make a cross-reference in this case anyway. In 23194 -- either case we simply ignore the call. 23195 23196 if Chars (Ent) /= Chars (Endl) then 23197 return; 23198 end if; 23199 23200 -- If label was really there, then generate a normal reference and then 23201 -- adjust the location in the end label to point past the name (which 23202 -- should almost always be the semicolon). 23203 23204 Loc := Sloc (Endl); 23205 23206 if Comes_From_Source (Endl) then 23207 23208 -- If a label reference is required, then do the style check and 23209 -- generate an l-type cross-reference entry for the label 23210 23211 if Label_Ref then 23212 if Style_Check then 23213 Style.Check_Identifier (Endl, Ent); 23214 end if; 23215 23216 Generate_Reference (Ent, Endl, 'l', Set_Ref => False); 23217 end if; 23218 23219 -- Set the location to point past the label (normally this will 23220 -- mean the semicolon immediately following the label). This is 23221 -- done for the sake of the 'e' or 't' entry generated below. 23222 23223 Get_Decoded_Name_String (Chars (Endl)); 23224 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len)); 23225 23226 else 23227 -- In SPARK mode, no missing label is allowed for packages and 23228 -- subprogram bodies. Detect those cases by testing whether 23229 -- Process_End_Label was called for a body (Typ = 't') or a package. 23230 23231 if Restriction_Check_Required (SPARK_05) 23232 and then (Typ = 't' or else Ekind (Ent) = E_Package) 23233 then 23234 Error_Msg_Node_1 := Endl; 23235 Check_SPARK_05_Restriction 23236 ("`END &` required", Endl, Force => True); 23237 end if; 23238 end if; 23239 23240 -- Now generate the e/t reference 23241 23242 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True); 23243 23244 -- Restore Sloc, in case modified above, since we have an identifier 23245 -- and the normal Sloc should be left set in the tree. 23246 23247 Set_Sloc (Endl, Loc); 23248 end Process_End_Label; 23249 23250 -------------------------------- 23251 -- Propagate_Concurrent_Flags -- 23252 -------------------------------- 23253 23254 procedure Propagate_Concurrent_Flags 23255 (Typ : Entity_Id; 23256 Comp_Typ : Entity_Id) 23257 is 23258 begin 23259 if Has_Task (Comp_Typ) then 23260 Set_Has_Task (Typ); 23261 end if; 23262 23263 if Has_Protected (Comp_Typ) then 23264 Set_Has_Protected (Typ); 23265 end if; 23266 23267 if Has_Timing_Event (Comp_Typ) then 23268 Set_Has_Timing_Event (Typ); 23269 end if; 23270 end Propagate_Concurrent_Flags; 23271 23272 ------------------------------ 23273 -- Propagate_DIC_Attributes -- 23274 ------------------------------ 23275 23276 procedure Propagate_DIC_Attributes 23277 (Typ : Entity_Id; 23278 From_Typ : Entity_Id) 23279 is 23280 DIC_Proc : Entity_Id; 23281 23282 begin 23283 if Present (Typ) and then Present (From_Typ) then 23284 pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ)); 23285 23286 -- Nothing to do if both the source and the destination denote the 23287 -- same type. 23288 23289 if From_Typ = Typ then 23290 return; 23291 end if; 23292 23293 DIC_Proc := DIC_Procedure (From_Typ); 23294 23295 -- The setting of the attributes is intentionally conservative. This 23296 -- prevents accidental clobbering of enabled attributes. 23297 23298 if Has_Inherited_DIC (From_Typ) 23299 and then not Has_Inherited_DIC (Typ) 23300 then 23301 Set_Has_Inherited_DIC (Typ); 23302 end if; 23303 23304 if Has_Own_DIC (From_Typ) and then not Has_Own_DIC (Typ) then 23305 Set_Has_Own_DIC (Typ); 23306 end if; 23307 23308 if Present (DIC_Proc) and then No (DIC_Procedure (Typ)) then 23309 Set_DIC_Procedure (Typ, DIC_Proc); 23310 end if; 23311 end if; 23312 end Propagate_DIC_Attributes; 23313 23314 ------------------------------------ 23315 -- Propagate_Invariant_Attributes -- 23316 ------------------------------------ 23317 23318 procedure Propagate_Invariant_Attributes 23319 (Typ : Entity_Id; 23320 From_Typ : Entity_Id) 23321 is 23322 Full_IP : Entity_Id; 23323 Part_IP : Entity_Id; 23324 23325 begin 23326 if Present (Typ) and then Present (From_Typ) then 23327 pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ)); 23328 23329 -- Nothing to do if both the source and the destination denote the 23330 -- same type. 23331 23332 if From_Typ = Typ then 23333 return; 23334 end if; 23335 23336 Full_IP := Invariant_Procedure (From_Typ); 23337 Part_IP := Partial_Invariant_Procedure (From_Typ); 23338 23339 -- The setting of the attributes is intentionally conservative. This 23340 -- prevents accidental clobbering of enabled attributes. 23341 23342 if Has_Inheritable_Invariants (From_Typ) 23343 and then not Has_Inheritable_Invariants (Typ) 23344 then 23345 Set_Has_Inheritable_Invariants (Typ); 23346 end if; 23347 23348 if Has_Inherited_Invariants (From_Typ) 23349 and then not Has_Inherited_Invariants (Typ) 23350 then 23351 Set_Has_Inherited_Invariants (Typ); 23352 end if; 23353 23354 if Has_Own_Invariants (From_Typ) 23355 and then not Has_Own_Invariants (Typ) 23356 then 23357 Set_Has_Own_Invariants (Typ); 23358 end if; 23359 23360 if Present (Full_IP) and then No (Invariant_Procedure (Typ)) then 23361 Set_Invariant_Procedure (Typ, Full_IP); 23362 end if; 23363 23364 if Present (Part_IP) and then No (Partial_Invariant_Procedure (Typ)) 23365 then 23366 Set_Partial_Invariant_Procedure (Typ, Part_IP); 23367 end if; 23368 end if; 23369 end Propagate_Invariant_Attributes; 23370 23371 --------------------------------------- 23372 -- Record_Possible_Part_Of_Reference -- 23373 --------------------------------------- 23374 23375 procedure Record_Possible_Part_Of_Reference 23376 (Var_Id : Entity_Id; 23377 Ref : Node_Id) 23378 is 23379 Encap : constant Entity_Id := Encapsulating_State (Var_Id); 23380 Refs : Elist_Id; 23381 23382 begin 23383 -- The variable is a constituent of a single protected/task type. Such 23384 -- a variable acts as a component of the type and must appear within a 23385 -- specific region (SPARK RM 9(3)). Instead of recording the reference, 23386 -- verify its legality now. 23387 23388 if Present (Encap) and then Is_Single_Concurrent_Object (Encap) then 23389 Check_Part_Of_Reference (Var_Id, Ref); 23390 23391 -- The variable is subject to pragma Part_Of and may eventually become a 23392 -- constituent of a single protected/task type. Record the reference to 23393 -- verify its placement when the contract of the variable is analyzed. 23394 23395 elsif Present (Get_Pragma (Var_Id, Pragma_Part_Of)) then 23396 Refs := Part_Of_References (Var_Id); 23397 23398 if No (Refs) then 23399 Refs := New_Elmt_List; 23400 Set_Part_Of_References (Var_Id, Refs); 23401 end if; 23402 23403 Append_Elmt (Ref, Refs); 23404 end if; 23405 end Record_Possible_Part_Of_Reference; 23406 23407 ---------------- 23408 -- Referenced -- 23409 ---------------- 23410 23411 function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is 23412 Seen : Boolean := False; 23413 23414 function Is_Reference (N : Node_Id) return Traverse_Result; 23415 -- Determine whether node N denotes a reference to Id. If this is the 23416 -- case, set global flag Seen to True and stop the traversal. 23417 23418 ------------------ 23419 -- Is_Reference -- 23420 ------------------ 23421 23422 function Is_Reference (N : Node_Id) return Traverse_Result is 23423 begin 23424 if Is_Entity_Name (N) 23425 and then Present (Entity (N)) 23426 and then Entity (N) = Id 23427 then 23428 Seen := True; 23429 return Abandon; 23430 else 23431 return OK; 23432 end if; 23433 end Is_Reference; 23434 23435 procedure Inspect_Expression is new Traverse_Proc (Is_Reference); 23436 23437 -- Start of processing for Referenced 23438 23439 begin 23440 Inspect_Expression (Expr); 23441 return Seen; 23442 end Referenced; 23443 23444 ------------------------------------ 23445 -- References_Generic_Formal_Type -- 23446 ------------------------------------ 23447 23448 function References_Generic_Formal_Type (N : Node_Id) return Boolean is 23449 23450 function Process (N : Node_Id) return Traverse_Result; 23451 -- Process one node in search for generic formal type 23452 23453 ------------- 23454 -- Process -- 23455 ------------- 23456 23457 function Process (N : Node_Id) return Traverse_Result is 23458 begin 23459 if Nkind (N) in N_Has_Entity then 23460 declare 23461 E : constant Entity_Id := Entity (N); 23462 begin 23463 if Present (E) then 23464 if Is_Generic_Type (E) then 23465 return Abandon; 23466 elsif Present (Etype (E)) 23467 and then Is_Generic_Type (Etype (E)) 23468 then 23469 return Abandon; 23470 end if; 23471 end if; 23472 end; 23473 end if; 23474 23475 return Atree.OK; 23476 end Process; 23477 23478 function Traverse is new Traverse_Func (Process); 23479 -- Traverse tree to look for generic type 23480 23481 begin 23482 if Inside_A_Generic then 23483 return Traverse (N) = Abandon; 23484 else 23485 return False; 23486 end if; 23487 end References_Generic_Formal_Type; 23488 23489 ------------------------------- 23490 -- Remove_Entity_And_Homonym -- 23491 ------------------------------- 23492 23493 procedure Remove_Entity_And_Homonym (Id : Entity_Id) is 23494 begin 23495 Remove_Entity (Id); 23496 Remove_Homonym (Id); 23497 end Remove_Entity_And_Homonym; 23498 23499 -------------------- 23500 -- Remove_Homonym -- 23501 -------------------- 23502 23503 procedure Remove_Homonym (Id : Entity_Id) is 23504 Hom : Entity_Id; 23505 Prev : Entity_Id := Empty; 23506 23507 begin 23508 if Id = Current_Entity (Id) then 23509 if Present (Homonym (Id)) then 23510 Set_Current_Entity (Homonym (Id)); 23511 else 23512 Set_Name_Entity_Id (Chars (Id), Empty); 23513 end if; 23514 23515 else 23516 Hom := Current_Entity (Id); 23517 while Present (Hom) and then Hom /= Id loop 23518 Prev := Hom; 23519 Hom := Homonym (Hom); 23520 end loop; 23521 23522 -- If Id is not on the homonym chain, nothing to do 23523 23524 if Present (Hom) then 23525 Set_Homonym (Prev, Homonym (Id)); 23526 end if; 23527 end if; 23528 end Remove_Homonym; 23529 23530 ------------------------------ 23531 -- Remove_Overloaded_Entity -- 23532 ------------------------------ 23533 23534 procedure Remove_Overloaded_Entity (Id : Entity_Id) is 23535 procedure Remove_Primitive_Of (Typ : Entity_Id); 23536 -- Remove primitive subprogram Id from the list of primitives that 23537 -- belong to type Typ. 23538 23539 ------------------------- 23540 -- Remove_Primitive_Of -- 23541 ------------------------- 23542 23543 procedure Remove_Primitive_Of (Typ : Entity_Id) is 23544 Prims : Elist_Id; 23545 23546 begin 23547 if Is_Tagged_Type (Typ) then 23548 Prims := Direct_Primitive_Operations (Typ); 23549 23550 if Present (Prims) then 23551 Remove (Prims, Id); 23552 end if; 23553 end if; 23554 end Remove_Primitive_Of; 23555 23556 -- Local variables 23557 23558 Formal : Entity_Id; 23559 23560 -- Start of processing for Remove_Overloaded_Entity 23561 23562 begin 23563 Remove_Entity_And_Homonym (Id); 23564 23565 -- The entity denotes a primitive subprogram. Remove it from the list of 23566 -- primitives of the associated controlling type. 23567 23568 if Ekind_In (Id, E_Function, E_Procedure) and then Is_Primitive (Id) then 23569 Formal := First_Formal (Id); 23570 while Present (Formal) loop 23571 if Is_Controlling_Formal (Formal) then 23572 Remove_Primitive_Of (Etype (Formal)); 23573 exit; 23574 end if; 23575 23576 Next_Formal (Formal); 23577 end loop; 23578 23579 if Ekind (Id) = E_Function and then Has_Controlling_Result (Id) then 23580 Remove_Primitive_Of (Etype (Id)); 23581 end if; 23582 end if; 23583 end Remove_Overloaded_Entity; 23584 23585 --------------------- 23586 -- Rep_To_Pos_Flag -- 23587 --------------------- 23588 23589 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is 23590 begin 23591 return New_Occurrence_Of 23592 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc); 23593 end Rep_To_Pos_Flag; 23594 23595 -------------------- 23596 -- Require_Entity -- 23597 -------------------- 23598 23599 procedure Require_Entity (N : Node_Id) is 23600 begin 23601 if Is_Entity_Name (N) and then No (Entity (N)) then 23602 if Total_Errors_Detected /= 0 then 23603 Set_Entity (N, Any_Id); 23604 else 23605 raise Program_Error; 23606 end if; 23607 end if; 23608 end Require_Entity; 23609 23610 ------------------------------ 23611 -- Requires_Transient_Scope -- 23612 ------------------------------ 23613 23614 -- A transient scope is required when variable-sized temporaries are 23615 -- allocated on the secondary stack, or when finalization actions must be 23616 -- generated before the next instruction. 23617 23618 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is 23619 Old_Result : constant Boolean := Old_Requires_Transient_Scope (Id); 23620 23621 begin 23622 if Debug_Flag_QQ then 23623 return Old_Result; 23624 end if; 23625 23626 declare 23627 New_Result : constant Boolean := New_Requires_Transient_Scope (Id); 23628 23629 begin 23630 -- Assert that we're not putting things on the secondary stack if we 23631 -- didn't before; we are trying to AVOID secondary stack when 23632 -- possible. 23633 23634 if not Old_Result then 23635 pragma Assert (not New_Result); 23636 null; 23637 end if; 23638 23639 if New_Result /= Old_Result then 23640 Results_Differ (Id, Old_Result, New_Result); 23641 end if; 23642 23643 return New_Result; 23644 end; 23645 end Requires_Transient_Scope; 23646 23647 -------------------- 23648 -- Results_Differ -- 23649 -------------------- 23650 23651 procedure Results_Differ 23652 (Id : Entity_Id; 23653 Old_Val : Boolean; 23654 New_Val : Boolean) 23655 is 23656 begin 23657 if False then -- False to disable; True for debugging 23658 Treepr.Print_Tree_Node (Id); 23659 23660 if Old_Val = New_Val then 23661 raise Program_Error; 23662 end if; 23663 end if; 23664 end Results_Differ; 23665 23666 -------------------------- 23667 -- Reset_Analyzed_Flags -- 23668 -------------------------- 23669 23670 procedure Reset_Analyzed_Flags (N : Node_Id) is 23671 function Clear_Analyzed (N : Node_Id) return Traverse_Result; 23672 -- Function used to reset Analyzed flags in tree. Note that we do 23673 -- not reset Analyzed flags in entities, since there is no need to 23674 -- reanalyze entities, and indeed, it is wrong to do so, since it 23675 -- can result in generating auxiliary stuff more than once. 23676 23677 -------------------- 23678 -- Clear_Analyzed -- 23679 -------------------- 23680 23681 function Clear_Analyzed (N : Node_Id) return Traverse_Result is 23682 begin 23683 if Nkind (N) not in N_Entity then 23684 Set_Analyzed (N, False); 23685 end if; 23686 23687 return OK; 23688 end Clear_Analyzed; 23689 23690 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed); 23691 23692 -- Start of processing for Reset_Analyzed_Flags 23693 23694 begin 23695 Reset_Analyzed (N); 23696 end Reset_Analyzed_Flags; 23697 23698 ------------------------ 23699 -- Restore_SPARK_Mode -- 23700 ------------------------ 23701 23702 procedure Restore_SPARK_Mode 23703 (Mode : SPARK_Mode_Type; 23704 Prag : Node_Id) 23705 is 23706 begin 23707 SPARK_Mode := Mode; 23708 SPARK_Mode_Pragma := Prag; 23709 end Restore_SPARK_Mode; 23710 23711 -------------------------------- 23712 -- Returns_Unconstrained_Type -- 23713 -------------------------------- 23714 23715 function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is 23716 begin 23717 return Ekind (Subp) = E_Function 23718 and then not Is_Scalar_Type (Etype (Subp)) 23719 and then not Is_Access_Type (Etype (Subp)) 23720 and then not Is_Constrained (Etype (Subp)); 23721 end Returns_Unconstrained_Type; 23722 23723 ---------------------------- 23724 -- Root_Type_Of_Full_View -- 23725 ---------------------------- 23726 23727 function Root_Type_Of_Full_View (T : Entity_Id) return Entity_Id is 23728 Rtyp : constant Entity_Id := Root_Type (T); 23729 23730 begin 23731 -- The root type of the full view may itself be a private type. Keep 23732 -- looking for the ultimate derivation parent. 23733 23734 if Is_Private_Type (Rtyp) and then Present (Full_View (Rtyp)) then 23735 return Root_Type_Of_Full_View (Full_View (Rtyp)); 23736 else 23737 return Rtyp; 23738 end if; 23739 end Root_Type_Of_Full_View; 23740 23741 --------------------------- 23742 -- Safe_To_Capture_Value -- 23743 --------------------------- 23744 23745 function Safe_To_Capture_Value 23746 (N : Node_Id; 23747 Ent : Entity_Id; 23748 Cond : Boolean := False) return Boolean 23749 is 23750 begin 23751 -- The only entities for which we track constant values are variables 23752 -- which are not renamings, constants, out parameters, and in out 23753 -- parameters, so check if we have this case. 23754 23755 -- Note: it may seem odd to track constant values for constants, but in 23756 -- fact this routine is used for other purposes than simply capturing 23757 -- the value. In particular, the setting of Known[_Non]_Null. 23758 23759 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent))) 23760 or else 23761 Ekind_In (Ent, E_Constant, E_Out_Parameter, E_In_Out_Parameter) 23762 then 23763 null; 23764 23765 -- For conditionals, we also allow loop parameters and all formals, 23766 -- including in parameters. 23767 23768 elsif Cond and then Ekind_In (Ent, E_Loop_Parameter, E_In_Parameter) then 23769 null; 23770 23771 -- For all other cases, not just unsafe, but impossible to capture 23772 -- Current_Value, since the above are the only entities which have 23773 -- Current_Value fields. 23774 23775 else 23776 return False; 23777 end if; 23778 23779 -- Skip if volatile or aliased, since funny things might be going on in 23780 -- these cases which we cannot necessarily track. Also skip any variable 23781 -- for which an address clause is given, or whose address is taken. Also 23782 -- never capture value of library level variables (an attempt to do so 23783 -- can occur in the case of package elaboration code). 23784 23785 if Treat_As_Volatile (Ent) 23786 or else Is_Aliased (Ent) 23787 or else Present (Address_Clause (Ent)) 23788 or else Address_Taken (Ent) 23789 or else (Is_Library_Level_Entity (Ent) 23790 and then Ekind (Ent) = E_Variable) 23791 then 23792 return False; 23793 end if; 23794 23795 -- OK, all above conditions are met. We also require that the scope of 23796 -- the reference be the same as the scope of the entity, not counting 23797 -- packages and blocks and loops. 23798 23799 declare 23800 E_Scope : constant Entity_Id := Scope (Ent); 23801 R_Scope : Entity_Id; 23802 23803 begin 23804 R_Scope := Current_Scope; 23805 while R_Scope /= Standard_Standard loop 23806 exit when R_Scope = E_Scope; 23807 23808 if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then 23809 return False; 23810 else 23811 R_Scope := Scope (R_Scope); 23812 end if; 23813 end loop; 23814 end; 23815 23816 -- We also require that the reference does not appear in a context 23817 -- where it is not sure to be executed (i.e. a conditional context 23818 -- or an exception handler). We skip this if Cond is True, since the 23819 -- capturing of values from conditional tests handles this ok. 23820 23821 if Cond then 23822 return True; 23823 end if; 23824 23825 declare 23826 Desc : Node_Id; 23827 P : Node_Id; 23828 23829 begin 23830 Desc := N; 23831 23832 -- Seems dubious that case expressions are not handled here ??? 23833 23834 P := Parent (N); 23835 while Present (P) loop 23836 if Nkind (P) = N_If_Statement 23837 or else Nkind (P) = N_Case_Statement 23838 or else (Nkind (P) in N_Short_Circuit 23839 and then Desc = Right_Opnd (P)) 23840 or else (Nkind (P) = N_If_Expression 23841 and then Desc /= First (Expressions (P))) 23842 or else Nkind (P) = N_Exception_Handler 23843 or else Nkind (P) = N_Selective_Accept 23844 or else Nkind (P) = N_Conditional_Entry_Call 23845 or else Nkind (P) = N_Timed_Entry_Call 23846 or else Nkind (P) = N_Asynchronous_Select 23847 then 23848 return False; 23849 23850 else 23851 Desc := P; 23852 P := Parent (P); 23853 23854 -- A special Ada 2012 case: the original node may be part 23855 -- of the else_actions of a conditional expression, in which 23856 -- case it might not have been expanded yet, and appears in 23857 -- a non-syntactic list of actions. In that case it is clearly 23858 -- not safe to save a value. 23859 23860 if No (P) 23861 and then Is_List_Member (Desc) 23862 and then No (Parent (List_Containing (Desc))) 23863 then 23864 return False; 23865 end if; 23866 end if; 23867 end loop; 23868 end; 23869 23870 -- OK, looks safe to set value 23871 23872 return True; 23873 end Safe_To_Capture_Value; 23874 23875 --------------- 23876 -- Same_Name -- 23877 --------------- 23878 23879 function Same_Name (N1, N2 : Node_Id) return Boolean is 23880 K1 : constant Node_Kind := Nkind (N1); 23881 K2 : constant Node_Kind := Nkind (N2); 23882 23883 begin 23884 if (K1 = N_Identifier or else K1 = N_Defining_Identifier) 23885 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier) 23886 then 23887 return Chars (N1) = Chars (N2); 23888 23889 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name) 23890 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name) 23891 then 23892 return Same_Name (Selector_Name (N1), Selector_Name (N2)) 23893 and then Same_Name (Prefix (N1), Prefix (N2)); 23894 23895 else 23896 return False; 23897 end if; 23898 end Same_Name; 23899 23900 ----------------- 23901 -- Same_Object -- 23902 ----------------- 23903 23904 function Same_Object (Node1, Node2 : Node_Id) return Boolean is 23905 N1 : constant Node_Id := Original_Node (Node1); 23906 N2 : constant Node_Id := Original_Node (Node2); 23907 -- We do the tests on original nodes, since we are most interested 23908 -- in the original source, not any expansion that got in the way. 23909 23910 K1 : constant Node_Kind := Nkind (N1); 23911 K2 : constant Node_Kind := Nkind (N2); 23912 23913 begin 23914 -- First case, both are entities with same entity 23915 23916 if K1 in N_Has_Entity and then K2 in N_Has_Entity then 23917 declare 23918 EN1 : constant Entity_Id := Entity (N1); 23919 EN2 : constant Entity_Id := Entity (N2); 23920 begin 23921 if Present (EN1) and then Present (EN2) 23922 and then (Ekind_In (EN1, E_Variable, E_Constant) 23923 or else Is_Formal (EN1)) 23924 and then EN1 = EN2 23925 then 23926 return True; 23927 end if; 23928 end; 23929 end if; 23930 23931 -- Second case, selected component with same selector, same record 23932 23933 if K1 = N_Selected_Component 23934 and then K2 = N_Selected_Component 23935 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2)) 23936 then 23937 return Same_Object (Prefix (N1), Prefix (N2)); 23938 23939 -- Third case, indexed component with same subscripts, same array 23940 23941 elsif K1 = N_Indexed_Component 23942 and then K2 = N_Indexed_Component 23943 and then Same_Object (Prefix (N1), Prefix (N2)) 23944 then 23945 declare 23946 E1, E2 : Node_Id; 23947 begin 23948 E1 := First (Expressions (N1)); 23949 E2 := First (Expressions (N2)); 23950 while Present (E1) loop 23951 if not Same_Value (E1, E2) then 23952 return False; 23953 else 23954 Next (E1); 23955 Next (E2); 23956 end if; 23957 end loop; 23958 23959 return True; 23960 end; 23961 23962 -- Fourth case, slice of same array with same bounds 23963 23964 elsif K1 = N_Slice 23965 and then K2 = N_Slice 23966 and then Nkind (Discrete_Range (N1)) = N_Range 23967 and then Nkind (Discrete_Range (N2)) = N_Range 23968 and then Same_Value (Low_Bound (Discrete_Range (N1)), 23969 Low_Bound (Discrete_Range (N2))) 23970 and then Same_Value (High_Bound (Discrete_Range (N1)), 23971 High_Bound (Discrete_Range (N2))) 23972 then 23973 return Same_Name (Prefix (N1), Prefix (N2)); 23974 23975 -- All other cases, not clearly the same object 23976 23977 else 23978 return False; 23979 end if; 23980 end Same_Object; 23981 23982 --------------- 23983 -- Same_Type -- 23984 --------------- 23985 23986 function Same_Type (T1, T2 : Entity_Id) return Boolean is 23987 begin 23988 if T1 = T2 then 23989 return True; 23990 23991 elsif not Is_Constrained (T1) 23992 and then not Is_Constrained (T2) 23993 and then Base_Type (T1) = Base_Type (T2) 23994 then 23995 return True; 23996 23997 -- For now don't bother with case of identical constraints, to be 23998 -- fiddled with later on perhaps (this is only used for optimization 23999 -- purposes, so it is not critical to do a best possible job) 24000 24001 else 24002 return False; 24003 end if; 24004 end Same_Type; 24005 24006 ---------------- 24007 -- Same_Value -- 24008 ---------------- 24009 24010 function Same_Value (Node1, Node2 : Node_Id) return Boolean is 24011 begin 24012 if Compile_Time_Known_Value (Node1) 24013 and then Compile_Time_Known_Value (Node2) 24014 then 24015 -- Handle properly compile-time expressions that are not 24016 -- scalar. 24017 24018 if Is_String_Type (Etype (Node1)) then 24019 return Expr_Value_S (Node1) = Expr_Value_S (Node2); 24020 24021 else 24022 return Expr_Value (Node1) = Expr_Value (Node2); 24023 end if; 24024 24025 elsif Same_Object (Node1, Node2) then 24026 return True; 24027 else 24028 return False; 24029 end if; 24030 end Same_Value; 24031 24032 -------------------- 24033 -- Set_SPARK_Mode -- 24034 -------------------- 24035 24036 procedure Set_SPARK_Mode (Context : Entity_Id) is 24037 begin 24038 -- Do not consider illegal or partially decorated constructs 24039 24040 if Ekind (Context) = E_Void or else Error_Posted (Context) then 24041 null; 24042 24043 elsif Present (SPARK_Pragma (Context)) then 24044 Install_SPARK_Mode 24045 (Mode => Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Context)), 24046 Prag => SPARK_Pragma (Context)); 24047 end if; 24048 end Set_SPARK_Mode; 24049 24050 ------------------------- 24051 -- Scalar_Part_Present -- 24052 ------------------------- 24053 24054 function Scalar_Part_Present (Typ : Entity_Id) return Boolean is 24055 Val_Typ : constant Entity_Id := Validated_View (Typ); 24056 Field : Entity_Id; 24057 24058 begin 24059 if Is_Scalar_Type (Val_Typ) then 24060 return True; 24061 24062 elsif Is_Array_Type (Val_Typ) then 24063 return Scalar_Part_Present (Component_Type (Val_Typ)); 24064 24065 elsif Is_Record_Type (Val_Typ) then 24066 Field := First_Component_Or_Discriminant (Val_Typ); 24067 while Present (Field) loop 24068 if Scalar_Part_Present (Etype (Field)) then 24069 return True; 24070 end if; 24071 24072 Next_Component_Or_Discriminant (Field); 24073 end loop; 24074 end if; 24075 24076 return False; 24077 end Scalar_Part_Present; 24078 24079 ------------------------ 24080 -- Scope_Is_Transient -- 24081 ------------------------ 24082 24083 function Scope_Is_Transient return Boolean is 24084 begin 24085 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient; 24086 end Scope_Is_Transient; 24087 24088 ------------------ 24089 -- Scope_Within -- 24090 ------------------ 24091 24092 function Scope_Within 24093 (Inner : Entity_Id; 24094 Outer : Entity_Id) return Boolean 24095 is 24096 Curr : Entity_Id; 24097 24098 begin 24099 Curr := Inner; 24100 while Present (Curr) and then Curr /= Standard_Standard loop 24101 Curr := Scope (Curr); 24102 24103 if Curr = Outer then 24104 return True; 24105 24106 -- A selective accept body appears within a task type, but the 24107 -- enclosing subprogram is the procedure of the task body. 24108 24109 elsif Ekind (Curr) = E_Task_Type 24110 and then Outer = Task_Body_Procedure (Curr) 24111 then 24112 return True; 24113 24114 -- Ditto for the body of a protected operation 24115 24116 elsif Is_Subprogram (Curr) 24117 and then Outer = Protected_Body_Subprogram (Curr) 24118 then 24119 return True; 24120 24121 -- Outside of its scope, a synchronized type may just be private 24122 24123 elsif Is_Private_Type (Curr) 24124 and then Present (Full_View (Curr)) 24125 and then Is_Concurrent_Type (Full_View (Curr)) 24126 then 24127 return Scope_Within (Full_View (Curr), Outer); 24128 end if; 24129 end loop; 24130 24131 return False; 24132 end Scope_Within; 24133 24134 -------------------------- 24135 -- Scope_Within_Or_Same -- 24136 -------------------------- 24137 24138 function Scope_Within_Or_Same 24139 (Inner : Entity_Id; 24140 Outer : Entity_Id) return Boolean 24141 is 24142 Curr : Entity_Id; 24143 24144 begin 24145 Curr := Inner; 24146 while Present (Curr) and then Curr /= Standard_Standard loop 24147 if Curr = Outer then 24148 return True; 24149 end if; 24150 24151 Curr := Scope (Curr); 24152 end loop; 24153 24154 return False; 24155 end Scope_Within_Or_Same; 24156 24157 -------------------- 24158 -- Set_Convention -- 24159 -------------------- 24160 24161 procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is 24162 begin 24163 Basic_Set_Convention (E, Val); 24164 24165 if Is_Type (E) 24166 and then Is_Access_Subprogram_Type (Base_Type (E)) 24167 and then Has_Foreign_Convention (E) 24168 then 24169 Set_Can_Use_Internal_Rep (E, False); 24170 end if; 24171 24172 -- If E is an object, including a component, and the type of E is an 24173 -- anonymous access type with no convention set, then also set the 24174 -- convention of the anonymous access type. We do not do this for 24175 -- anonymous protected types, since protected types always have the 24176 -- default convention. 24177 24178 if Present (Etype (E)) 24179 and then (Is_Object (E) 24180 24181 -- Allow E_Void (happens for pragma Convention appearing 24182 -- in the middle of a record applying to a component) 24183 24184 or else Ekind (E) = E_Void) 24185 then 24186 declare 24187 Typ : constant Entity_Id := Etype (E); 24188 24189 begin 24190 if Ekind_In (Typ, E_Anonymous_Access_Type, 24191 E_Anonymous_Access_Subprogram_Type) 24192 and then not Has_Convention_Pragma (Typ) 24193 then 24194 Basic_Set_Convention (Typ, Val); 24195 Set_Has_Convention_Pragma (Typ); 24196 24197 -- And for the access subprogram type, deal similarly with the 24198 -- designated E_Subprogram_Type, which is always internal. 24199 24200 if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then 24201 declare 24202 Dtype : constant Entity_Id := Designated_Type (Typ); 24203 begin 24204 if Ekind (Dtype) = E_Subprogram_Type 24205 and then not Has_Convention_Pragma (Dtype) 24206 then 24207 Basic_Set_Convention (Dtype, Val); 24208 Set_Has_Convention_Pragma (Dtype); 24209 end if; 24210 end; 24211 end if; 24212 end if; 24213 end; 24214 end if; 24215 end Set_Convention; 24216 24217 ------------------------ 24218 -- Set_Current_Entity -- 24219 ------------------------ 24220 24221 -- The given entity is to be set as the currently visible definition of its 24222 -- associated name (i.e. the Node_Id associated with its name). All we have 24223 -- to do is to get the name from the identifier, and then set the 24224 -- associated Node_Id to point to the given entity. 24225 24226 procedure Set_Current_Entity (E : Entity_Id) is 24227 begin 24228 Set_Name_Entity_Id (Chars (E), E); 24229 end Set_Current_Entity; 24230 24231 --------------------------- 24232 -- Set_Debug_Info_Needed -- 24233 --------------------------- 24234 24235 procedure Set_Debug_Info_Needed (T : Entity_Id) is 24236 24237 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id); 24238 pragma Inline (Set_Debug_Info_Needed_If_Not_Set); 24239 -- Used to set debug info in a related node if not set already 24240 24241 -------------------------------------- 24242 -- Set_Debug_Info_Needed_If_Not_Set -- 24243 -------------------------------------- 24244 24245 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is 24246 begin 24247 if Present (E) and then not Needs_Debug_Info (E) then 24248 Set_Debug_Info_Needed (E); 24249 24250 -- For a private type, indicate that the full view also needs 24251 -- debug information. 24252 24253 if Is_Type (E) 24254 and then Is_Private_Type (E) 24255 and then Present (Full_View (E)) 24256 then 24257 Set_Debug_Info_Needed (Full_View (E)); 24258 end if; 24259 end if; 24260 end Set_Debug_Info_Needed_If_Not_Set; 24261 24262 -- Start of processing for Set_Debug_Info_Needed 24263 24264 begin 24265 -- Nothing to do if there is no available entity 24266 24267 if No (T) then 24268 return; 24269 24270 -- Nothing to do for an entity with suppressed debug information 24271 24272 elsif Debug_Info_Off (T) then 24273 return; 24274 24275 -- Nothing to do for an ignored Ghost entity because the entity will be 24276 -- eliminated from the tree. 24277 24278 elsif Is_Ignored_Ghost_Entity (T) then 24279 return; 24280 24281 -- Nothing to do if entity comes from a predefined file. Library files 24282 -- are compiled without debug information, but inlined bodies of these 24283 -- routines may appear in user code, and debug information on them ends 24284 -- up complicating debugging the user code. 24285 24286 elsif In_Inlined_Body and then In_Predefined_Unit (T) then 24287 Set_Needs_Debug_Info (T, False); 24288 end if; 24289 24290 -- Set flag in entity itself. Note that we will go through the following 24291 -- circuitry even if the flag is already set on T. That's intentional, 24292 -- it makes sure that the flag will be set in subsidiary entities. 24293 24294 Set_Needs_Debug_Info (T); 24295 24296 -- Set flag on subsidiary entities if not set already 24297 24298 if Is_Object (T) then 24299 Set_Debug_Info_Needed_If_Not_Set (Etype (T)); 24300 24301 elsif Is_Type (T) then 24302 Set_Debug_Info_Needed_If_Not_Set (Etype (T)); 24303 24304 if Is_Record_Type (T) then 24305 declare 24306 Ent : Entity_Id := First_Entity (T); 24307 begin 24308 while Present (Ent) loop 24309 Set_Debug_Info_Needed_If_Not_Set (Ent); 24310 Next_Entity (Ent); 24311 end loop; 24312 end; 24313 24314 -- For a class wide subtype, we also need debug information 24315 -- for the equivalent type. 24316 24317 if Ekind (T) = E_Class_Wide_Subtype then 24318 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T)); 24319 end if; 24320 24321 elsif Is_Array_Type (T) then 24322 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T)); 24323 24324 declare 24325 Indx : Node_Id := First_Index (T); 24326 begin 24327 while Present (Indx) loop 24328 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx)); 24329 Indx := Next_Index (Indx); 24330 end loop; 24331 end; 24332 24333 -- For a packed array type, we also need debug information for 24334 -- the type used to represent the packed array. Conversely, we 24335 -- also need it for the former if we need it for the latter. 24336 24337 if Is_Packed (T) then 24338 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Impl_Type (T)); 24339 end if; 24340 24341 if Is_Packed_Array_Impl_Type (T) then 24342 Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T)); 24343 end if; 24344 24345 elsif Is_Access_Type (T) then 24346 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T)); 24347 24348 elsif Is_Private_Type (T) then 24349 declare 24350 FV : constant Entity_Id := Full_View (T); 24351 24352 begin 24353 Set_Debug_Info_Needed_If_Not_Set (FV); 24354 24355 -- If the full view is itself a derived private type, we need 24356 -- debug information on its underlying type. 24357 24358 if Present (FV) 24359 and then Is_Private_Type (FV) 24360 and then Present (Underlying_Full_View (FV)) 24361 then 24362 Set_Needs_Debug_Info (Underlying_Full_View (FV)); 24363 end if; 24364 end; 24365 24366 elsif Is_Protected_Type (T) then 24367 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T)); 24368 24369 elsif Is_Scalar_Type (T) then 24370 24371 -- If the subrange bounds are materialized by dedicated constant 24372 -- objects, also include them in the debug info to make sure the 24373 -- debugger can properly use them. 24374 24375 if Present (Scalar_Range (T)) 24376 and then Nkind (Scalar_Range (T)) = N_Range 24377 then 24378 declare 24379 Low_Bnd : constant Node_Id := Type_Low_Bound (T); 24380 High_Bnd : constant Node_Id := Type_High_Bound (T); 24381 24382 begin 24383 if Is_Entity_Name (Low_Bnd) then 24384 Set_Debug_Info_Needed_If_Not_Set (Entity (Low_Bnd)); 24385 end if; 24386 24387 if Is_Entity_Name (High_Bnd) then 24388 Set_Debug_Info_Needed_If_Not_Set (Entity (High_Bnd)); 24389 end if; 24390 end; 24391 end if; 24392 end if; 24393 end if; 24394 end Set_Debug_Info_Needed; 24395 24396 ---------------------------- 24397 -- Set_Entity_With_Checks -- 24398 ---------------------------- 24399 24400 procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id) is 24401 Val_Actual : Entity_Id; 24402 Nod : Node_Id; 24403 Post_Node : Node_Id; 24404 24405 begin 24406 -- Unconditionally set the entity 24407 24408 Set_Entity (N, Val); 24409 24410 -- The node to post on is the selector in the case of an expanded name, 24411 -- and otherwise the node itself. 24412 24413 if Nkind (N) = N_Expanded_Name then 24414 Post_Node := Selector_Name (N); 24415 else 24416 Post_Node := N; 24417 end if; 24418 24419 -- Check for violation of No_Fixed_IO 24420 24421 if Restriction_Check_Required (No_Fixed_IO) 24422 and then 24423 ((RTU_Loaded (Ada_Text_IO) 24424 and then (Is_RTE (Val, RE_Decimal_IO) 24425 or else 24426 Is_RTE (Val, RE_Fixed_IO))) 24427 24428 or else 24429 (RTU_Loaded (Ada_Wide_Text_IO) 24430 and then (Is_RTE (Val, RO_WT_Decimal_IO) 24431 or else 24432 Is_RTE (Val, RO_WT_Fixed_IO))) 24433 24434 or else 24435 (RTU_Loaded (Ada_Wide_Wide_Text_IO) 24436 and then (Is_RTE (Val, RO_WW_Decimal_IO) 24437 or else 24438 Is_RTE (Val, RO_WW_Fixed_IO)))) 24439 24440 -- A special extra check, don't complain about a reference from within 24441 -- the Ada.Interrupts package itself! 24442 24443 and then not In_Same_Extended_Unit (N, Val) 24444 then 24445 Check_Restriction (No_Fixed_IO, Post_Node); 24446 end if; 24447 24448 -- Remaining checks are only done on source nodes. Note that we test 24449 -- for violation of No_Fixed_IO even on non-source nodes, because the 24450 -- cases for checking violations of this restriction are instantiations 24451 -- where the reference in the instance has Comes_From_Source False. 24452 24453 if not Comes_From_Source (N) then 24454 return; 24455 end if; 24456 24457 -- Check for violation of No_Abort_Statements, which is triggered by 24458 -- call to Ada.Task_Identification.Abort_Task. 24459 24460 if Restriction_Check_Required (No_Abort_Statements) 24461 and then (Is_RTE (Val, RE_Abort_Task)) 24462 24463 -- A special extra check, don't complain about a reference from within 24464 -- the Ada.Task_Identification package itself! 24465 24466 and then not In_Same_Extended_Unit (N, Val) 24467 then 24468 Check_Restriction (No_Abort_Statements, Post_Node); 24469 end if; 24470 24471 if Val = Standard_Long_Long_Integer then 24472 Check_Restriction (No_Long_Long_Integers, Post_Node); 24473 end if; 24474 24475 -- Check for violation of No_Dynamic_Attachment 24476 24477 if Restriction_Check_Required (No_Dynamic_Attachment) 24478 and then RTU_Loaded (Ada_Interrupts) 24479 and then (Is_RTE (Val, RE_Is_Reserved) or else 24480 Is_RTE (Val, RE_Is_Attached) or else 24481 Is_RTE (Val, RE_Current_Handler) or else 24482 Is_RTE (Val, RE_Attach_Handler) or else 24483 Is_RTE (Val, RE_Exchange_Handler) or else 24484 Is_RTE (Val, RE_Detach_Handler) or else 24485 Is_RTE (Val, RE_Reference)) 24486 24487 -- A special extra check, don't complain about a reference from within 24488 -- the Ada.Interrupts package itself! 24489 24490 and then not In_Same_Extended_Unit (N, Val) 24491 then 24492 Check_Restriction (No_Dynamic_Attachment, Post_Node); 24493 end if; 24494 24495 -- Check for No_Implementation_Identifiers 24496 24497 if Restriction_Check_Required (No_Implementation_Identifiers) then 24498 24499 -- We have an implementation defined entity if it is marked as 24500 -- implementation defined, or is defined in a package marked as 24501 -- implementation defined. However, library packages themselves 24502 -- are excluded (we don't want to flag Interfaces itself, just 24503 -- the entities within it). 24504 24505 if (Is_Implementation_Defined (Val) 24506 or else 24507 (Present (Scope (Val)) 24508 and then Is_Implementation_Defined (Scope (Val)))) 24509 and then not (Ekind_In (Val, E_Package, E_Generic_Package) 24510 and then Is_Library_Level_Entity (Val)) 24511 then 24512 Check_Restriction (No_Implementation_Identifiers, Post_Node); 24513 end if; 24514 end if; 24515 24516 -- Do the style check 24517 24518 if Style_Check 24519 and then not Suppress_Style_Checks (Val) 24520 and then not In_Instance 24521 then 24522 if Nkind (N) = N_Identifier then 24523 Nod := N; 24524 elsif Nkind (N) = N_Expanded_Name then 24525 Nod := Selector_Name (N); 24526 else 24527 return; 24528 end if; 24529 24530 -- A special situation arises for derived operations, where we want 24531 -- to do the check against the parent (since the Sloc of the derived 24532 -- operation points to the derived type declaration itself). 24533 24534 Val_Actual := Val; 24535 while not Comes_From_Source (Val_Actual) 24536 and then Nkind (Val_Actual) in N_Entity 24537 and then (Ekind (Val_Actual) = E_Enumeration_Literal 24538 or else Is_Subprogram_Or_Generic_Subprogram (Val_Actual)) 24539 and then Present (Alias (Val_Actual)) 24540 loop 24541 Val_Actual := Alias (Val_Actual); 24542 end loop; 24543 24544 -- Renaming declarations for generic actuals do not come from source, 24545 -- and have a different name from that of the entity they rename, so 24546 -- there is no style check to perform here. 24547 24548 if Chars (Nod) = Chars (Val_Actual) then 24549 Style.Check_Identifier (Nod, Val_Actual); 24550 end if; 24551 end if; 24552 24553 Set_Entity (N, Val); 24554 end Set_Entity_With_Checks; 24555 24556 ------------------------------ 24557 -- Set_Invalid_Scalar_Value -- 24558 ------------------------------ 24559 24560 procedure Set_Invalid_Scalar_Value 24561 (Scal_Typ : Float_Scalar_Id; 24562 Value : Ureal) 24563 is 24564 Slot : Ureal renames Invalid_Floats (Scal_Typ); 24565 24566 begin 24567 -- Detect an attempt to set a different value for the same scalar type 24568 24569 pragma Assert (Slot = No_Ureal); 24570 Slot := Value; 24571 end Set_Invalid_Scalar_Value; 24572 24573 ------------------------------ 24574 -- Set_Invalid_Scalar_Value -- 24575 ------------------------------ 24576 24577 procedure Set_Invalid_Scalar_Value 24578 (Scal_Typ : Integer_Scalar_Id; 24579 Value : Uint) 24580 is 24581 Slot : Uint renames Invalid_Integers (Scal_Typ); 24582 24583 begin 24584 -- Detect an attempt to set a different value for the same scalar type 24585 24586 pragma Assert (Slot = No_Uint); 24587 Slot := Value; 24588 end Set_Invalid_Scalar_Value; 24589 24590 ------------------------ 24591 -- Set_Name_Entity_Id -- 24592 ------------------------ 24593 24594 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is 24595 begin 24596 Set_Name_Table_Int (Id, Int (Val)); 24597 end Set_Name_Entity_Id; 24598 24599 --------------------- 24600 -- Set_Next_Actual -- 24601 --------------------- 24602 24603 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is 24604 begin 24605 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then 24606 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id); 24607 end if; 24608 end Set_Next_Actual; 24609 24610 ---------------------------------- 24611 -- Set_Optimize_Alignment_Flags -- 24612 ---------------------------------- 24613 24614 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is 24615 begin 24616 if Optimize_Alignment = 'S' then 24617 Set_Optimize_Alignment_Space (E); 24618 elsif Optimize_Alignment = 'T' then 24619 Set_Optimize_Alignment_Time (E); 24620 end if; 24621 end Set_Optimize_Alignment_Flags; 24622 24623 ----------------------- 24624 -- Set_Public_Status -- 24625 ----------------------- 24626 24627 procedure Set_Public_Status (Id : Entity_Id) is 24628 S : constant Entity_Id := Current_Scope; 24629 24630 function Within_HSS_Or_If (E : Entity_Id) return Boolean; 24631 -- Determines if E is defined within handled statement sequence or 24632 -- an if statement, returns True if so, False otherwise. 24633 24634 ---------------------- 24635 -- Within_HSS_Or_If -- 24636 ---------------------- 24637 24638 function Within_HSS_Or_If (E : Entity_Id) return Boolean is 24639 N : Node_Id; 24640 begin 24641 N := Declaration_Node (E); 24642 loop 24643 N := Parent (N); 24644 24645 if No (N) then 24646 return False; 24647 24648 elsif Nkind_In (N, N_Handled_Sequence_Of_Statements, 24649 N_If_Statement) 24650 then 24651 return True; 24652 end if; 24653 end loop; 24654 end Within_HSS_Or_If; 24655 24656 -- Start of processing for Set_Public_Status 24657 24658 begin 24659 -- Everything in the scope of Standard is public 24660 24661 if S = Standard_Standard then 24662 Set_Is_Public (Id); 24663 24664 -- Entity is definitely not public if enclosing scope is not public 24665 24666 elsif not Is_Public (S) then 24667 return; 24668 24669 -- An object or function declaration that occurs in a handled sequence 24670 -- of statements or within an if statement is the declaration for a 24671 -- temporary object or local subprogram generated by the expander. It 24672 -- never needs to be made public and furthermore, making it public can 24673 -- cause back end problems. 24674 24675 elsif Nkind_In (Parent (Id), N_Object_Declaration, 24676 N_Function_Specification) 24677 and then Within_HSS_Or_If (Id) 24678 then 24679 return; 24680 24681 -- Entities in public packages or records are public 24682 24683 elsif Ekind (S) = E_Package or Is_Record_Type (S) then 24684 Set_Is_Public (Id); 24685 24686 -- The bounds of an entry family declaration can generate object 24687 -- declarations that are visible to the back-end, e.g. in the 24688 -- the declaration of a composite type that contains tasks. 24689 24690 elsif Is_Concurrent_Type (S) 24691 and then not Has_Completion (S) 24692 and then Nkind (Parent (Id)) = N_Object_Declaration 24693 then 24694 Set_Is_Public (Id); 24695 end if; 24696 end Set_Public_Status; 24697 24698 ----------------------------- 24699 -- Set_Referenced_Modified -- 24700 ----------------------------- 24701 24702 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is 24703 Pref : Node_Id; 24704 24705 begin 24706 -- Deal with indexed or selected component where prefix is modified 24707 24708 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then 24709 Pref := Prefix (N); 24710 24711 -- If prefix is access type, then it is the designated object that is 24712 -- being modified, which means we have no entity to set the flag on. 24713 24714 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then 24715 return; 24716 24717 -- Otherwise chase the prefix 24718 24719 else 24720 Set_Referenced_Modified (Pref, Out_Param); 24721 end if; 24722 24723 -- Otherwise see if we have an entity name (only other case to process) 24724 24725 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 24726 Set_Referenced_As_LHS (Entity (N), not Out_Param); 24727 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param); 24728 end if; 24729 end Set_Referenced_Modified; 24730 24731 ------------------ 24732 -- Set_Rep_Info -- 24733 ------------------ 24734 24735 procedure Set_Rep_Info (T1 : Entity_Id; T2 : Entity_Id) is 24736 begin 24737 Set_Is_Atomic (T1, Is_Atomic (T2)); 24738 Set_Is_Independent (T1, Is_Independent (T2)); 24739 Set_Is_Volatile_Full_Access (T1, Is_Volatile_Full_Access (T2)); 24740 24741 if Is_Base_Type (T1) then 24742 Set_Is_Volatile (T1, Is_Volatile (T2)); 24743 end if; 24744 end Set_Rep_Info; 24745 24746 ---------------------------- 24747 -- Set_Scope_Is_Transient -- 24748 ---------------------------- 24749 24750 procedure Set_Scope_Is_Transient (V : Boolean := True) is 24751 begin 24752 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V; 24753 end Set_Scope_Is_Transient; 24754 24755 ------------------- 24756 -- Set_Size_Info -- 24757 ------------------- 24758 24759 procedure Set_Size_Info (T1, T2 : Entity_Id) is 24760 begin 24761 -- We copy Esize, but not RM_Size, since in general RM_Size is 24762 -- subtype specific and does not get inherited by all subtypes. 24763 24764 Set_Esize (T1, Esize (T2)); 24765 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2)); 24766 24767 if Is_Discrete_Or_Fixed_Point_Type (T1) 24768 and then 24769 Is_Discrete_Or_Fixed_Point_Type (T2) 24770 then 24771 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2)); 24772 end if; 24773 24774 Set_Alignment (T1, Alignment (T2)); 24775 end Set_Size_Info; 24776 24777 ------------------------------ 24778 -- Should_Ignore_Pragma_Par -- 24779 ------------------------------ 24780 24781 function Should_Ignore_Pragma_Par (Prag_Name : Name_Id) return Boolean is 24782 pragma Assert (Compiler_State = Parsing); 24783 -- This one can't work during semantic analysis, because we don't have a 24784 -- correct Current_Source_File. 24785 24786 Result : constant Boolean := 24787 Get_Name_Table_Boolean3 (Prag_Name) 24788 and then not Is_Internal_File_Name 24789 (File_Name (Current_Source_File)); 24790 begin 24791 return Result; 24792 end Should_Ignore_Pragma_Par; 24793 24794 ------------------------------ 24795 -- Should_Ignore_Pragma_Sem -- 24796 ------------------------------ 24797 24798 function Should_Ignore_Pragma_Sem (N : Node_Id) return Boolean is 24799 pragma Assert (Compiler_State = Analyzing); 24800 Prag_Name : constant Name_Id := Pragma_Name (N); 24801 Result : constant Boolean := 24802 Get_Name_Table_Boolean3 (Prag_Name) 24803 and then not In_Internal_Unit (N); 24804 24805 begin 24806 return Result; 24807 end Should_Ignore_Pragma_Sem; 24808 24809 -------------------- 24810 -- Static_Boolean -- 24811 -------------------- 24812 24813 function Static_Boolean (N : Node_Id) return Uint is 24814 begin 24815 Analyze_And_Resolve (N, Standard_Boolean); 24816 24817 if N = Error 24818 or else Error_Posted (N) 24819 or else Etype (N) = Any_Type 24820 then 24821 return No_Uint; 24822 end if; 24823 24824 if Is_OK_Static_Expression (N) then 24825 if not Raises_Constraint_Error (N) then 24826 return Expr_Value (N); 24827 else 24828 return No_Uint; 24829 end if; 24830 24831 elsif Etype (N) = Any_Type then 24832 return No_Uint; 24833 24834 else 24835 Flag_Non_Static_Expr 24836 ("static boolean expression required here", N); 24837 return No_Uint; 24838 end if; 24839 end Static_Boolean; 24840 24841 -------------------- 24842 -- Static_Integer -- 24843 -------------------- 24844 24845 function Static_Integer (N : Node_Id) return Uint is 24846 begin 24847 Analyze_And_Resolve (N, Any_Integer); 24848 24849 if N = Error 24850 or else Error_Posted (N) 24851 or else Etype (N) = Any_Type 24852 then 24853 return No_Uint; 24854 end if; 24855 24856 if Is_OK_Static_Expression (N) then 24857 if not Raises_Constraint_Error (N) then 24858 return Expr_Value (N); 24859 else 24860 return No_Uint; 24861 end if; 24862 24863 elsif Etype (N) = Any_Type then 24864 return No_Uint; 24865 24866 else 24867 Flag_Non_Static_Expr 24868 ("static integer expression required here", N); 24869 return No_Uint; 24870 end if; 24871 end Static_Integer; 24872 24873 -------------------------- 24874 -- Statically_Different -- 24875 -------------------------- 24876 24877 function Statically_Different (E1, E2 : Node_Id) return Boolean is 24878 R1 : constant Node_Id := Get_Referenced_Object (E1); 24879 R2 : constant Node_Id := Get_Referenced_Object (E2); 24880 begin 24881 return Is_Entity_Name (R1) 24882 and then Is_Entity_Name (R2) 24883 and then Entity (R1) /= Entity (R2) 24884 and then not Is_Formal (Entity (R1)) 24885 and then not Is_Formal (Entity (R2)); 24886 end Statically_Different; 24887 24888 -------------------------------------- 24889 -- Subject_To_Loop_Entry_Attributes -- 24890 -------------------------------------- 24891 24892 function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is 24893 Stmt : Node_Id; 24894 24895 begin 24896 Stmt := N; 24897 24898 -- The expansion mechanism transform a loop subject to at least one 24899 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack 24900 -- the conditional part. 24901 24902 if Nkind_In (Stmt, N_Block_Statement, N_If_Statement) 24903 and then Nkind (Original_Node (N)) = N_Loop_Statement 24904 then 24905 Stmt := Original_Node (N); 24906 end if; 24907 24908 return 24909 Nkind (Stmt) = N_Loop_Statement 24910 and then Present (Identifier (Stmt)) 24911 and then Present (Entity (Identifier (Stmt))) 24912 and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt))); 24913 end Subject_To_Loop_Entry_Attributes; 24914 24915 ----------------------------- 24916 -- Subprogram_Access_Level -- 24917 ----------------------------- 24918 24919 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is 24920 begin 24921 if Present (Alias (Subp)) then 24922 return Subprogram_Access_Level (Alias (Subp)); 24923 else 24924 return Scope_Depth (Enclosing_Dynamic_Scope (Subp)); 24925 end if; 24926 end Subprogram_Access_Level; 24927 24928 --------------------- 24929 -- Subprogram_Name -- 24930 --------------------- 24931 24932 function Subprogram_Name (N : Node_Id) return String is 24933 Buf : Bounded_String; 24934 Ent : Node_Id := N; 24935 Nod : Node_Id; 24936 24937 begin 24938 while Present (Ent) loop 24939 case Nkind (Ent) is 24940 when N_Subprogram_Body => 24941 Ent := Defining_Unit_Name (Specification (Ent)); 24942 exit; 24943 24944 when N_Subprogram_Declaration => 24945 Nod := Corresponding_Body (Ent); 24946 24947 if Present (Nod) then 24948 Ent := Nod; 24949 else 24950 Ent := Defining_Unit_Name (Specification (Ent)); 24951 end if; 24952 24953 exit; 24954 24955 when N_Subprogram_Instantiation 24956 | N_Package_Body 24957 | N_Package_Specification 24958 => 24959 Ent := Defining_Unit_Name (Ent); 24960 exit; 24961 24962 when N_Protected_Type_Declaration => 24963 Ent := Corresponding_Body (Ent); 24964 exit; 24965 24966 when N_Protected_Body 24967 | N_Task_Body 24968 => 24969 Ent := Defining_Identifier (Ent); 24970 exit; 24971 24972 when others => 24973 null; 24974 end case; 24975 24976 Ent := Parent (Ent); 24977 end loop; 24978 24979 if No (Ent) then 24980 return "unknown subprogram:unknown file:0:0"; 24981 end if; 24982 24983 -- If the subprogram is a child unit, use its simple name to start the 24984 -- construction of the fully qualified name. 24985 24986 if Nkind (Ent) = N_Defining_Program_Unit_Name then 24987 Ent := Defining_Identifier (Ent); 24988 end if; 24989 24990 Append_Entity_Name (Buf, Ent); 24991 24992 -- Append homonym number if needed 24993 24994 if Nkind (N) in N_Entity and then Has_Homonym (N) then 24995 declare 24996 H : Entity_Id := Homonym (N); 24997 Nr : Nat := 1; 24998 24999 begin 25000 while Present (H) loop 25001 if Scope (H) = Scope (N) then 25002 Nr := Nr + 1; 25003 end if; 25004 25005 H := Homonym (H); 25006 end loop; 25007 25008 if Nr > 1 then 25009 Append (Buf, '#'); 25010 Append (Buf, Nr); 25011 end if; 25012 end; 25013 end if; 25014 25015 -- Append source location of Ent to Buf so that the string will 25016 -- look like "subp:file:line:col". 25017 25018 declare 25019 Loc : constant Source_Ptr := Sloc (Ent); 25020 begin 25021 Append (Buf, ':'); 25022 Append (Buf, Reference_Name (Get_Source_File_Index (Loc))); 25023 Append (Buf, ':'); 25024 Append (Buf, Nat (Get_Logical_Line_Number (Loc))); 25025 Append (Buf, ':'); 25026 Append (Buf, Nat (Get_Column_Number (Loc))); 25027 end; 25028 25029 return +Buf; 25030 end Subprogram_Name; 25031 25032 ------------------------------- 25033 -- Support_Atomic_Primitives -- 25034 ------------------------------- 25035 25036 function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is 25037 Size : Int; 25038 25039 begin 25040 -- Verify the alignment of Typ is known 25041 25042 if not Known_Alignment (Typ) then 25043 return False; 25044 end if; 25045 25046 if Known_Static_Esize (Typ) then 25047 Size := UI_To_Int (Esize (Typ)); 25048 25049 -- If the Esize (Object_Size) is unknown at compile time, look at the 25050 -- RM_Size (Value_Size) which may have been set by an explicit rep item. 25051 25052 elsif Known_Static_RM_Size (Typ) then 25053 Size := UI_To_Int (RM_Size (Typ)); 25054 25055 -- Otherwise, the size is considered to be unknown. 25056 25057 else 25058 return False; 25059 end if; 25060 25061 -- Check that the size of the component is 8, 16, 32, or 64 bits and 25062 -- that Typ is properly aligned. 25063 25064 case Size is 25065 when 8 | 16 | 32 | 64 => 25066 return Size = UI_To_Int (Alignment (Typ)) * 8; 25067 25068 when others => 25069 return False; 25070 end case; 25071 end Support_Atomic_Primitives; 25072 25073 ----------------- 25074 -- Trace_Scope -- 25075 ----------------- 25076 25077 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is 25078 begin 25079 if Debug_Flag_W then 25080 for J in 0 .. Scope_Stack.Last loop 25081 Write_Str (" "); 25082 end loop; 25083 25084 Write_Str (Msg); 25085 Write_Name (Chars (E)); 25086 Write_Str (" from "); 25087 Write_Location (Sloc (N)); 25088 Write_Eol; 25089 end if; 25090 end Trace_Scope; 25091 25092 ----------------------- 25093 -- Transfer_Entities -- 25094 ----------------------- 25095 25096 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is 25097 procedure Set_Public_Status_Of (Id : Entity_Id); 25098 -- Set the Is_Public attribute of arbitrary entity Id by calling routine 25099 -- Set_Public_Status. If successful and Id denotes a record type, set 25100 -- the Is_Public attribute of its fields. 25101 25102 -------------------------- 25103 -- Set_Public_Status_Of -- 25104 -------------------------- 25105 25106 procedure Set_Public_Status_Of (Id : Entity_Id) is 25107 Field : Entity_Id; 25108 25109 begin 25110 if not Is_Public (Id) then 25111 Set_Public_Status (Id); 25112 25113 -- When the input entity is a public record type, ensure that all 25114 -- its internal fields are also exposed to the linker. The fields 25115 -- of a class-wide type are never made public. 25116 25117 if Is_Public (Id) 25118 and then Is_Record_Type (Id) 25119 and then not Is_Class_Wide_Type (Id) 25120 then 25121 Field := First_Entity (Id); 25122 while Present (Field) loop 25123 Set_Is_Public (Field); 25124 Next_Entity (Field); 25125 end loop; 25126 end if; 25127 end if; 25128 end Set_Public_Status_Of; 25129 25130 -- Local variables 25131 25132 Full_Id : Entity_Id; 25133 Id : Entity_Id; 25134 25135 -- Start of processing for Transfer_Entities 25136 25137 begin 25138 Id := First_Entity (From); 25139 25140 if Present (Id) then 25141 25142 -- Merge the entity chain of the source scope with that of the 25143 -- destination scope. 25144 25145 if Present (Last_Entity (To)) then 25146 Link_Entities (Last_Entity (To), Id); 25147 else 25148 Set_First_Entity (To, Id); 25149 end if; 25150 25151 Set_Last_Entity (To, Last_Entity (From)); 25152 25153 -- Inspect the entities of the source scope and update their Scope 25154 -- attribute. 25155 25156 while Present (Id) loop 25157 Set_Scope (Id, To); 25158 Set_Public_Status_Of (Id); 25159 25160 -- Handle an internally generated full view for a private type 25161 25162 if Is_Private_Type (Id) 25163 and then Present (Full_View (Id)) 25164 and then Is_Itype (Full_View (Id)) 25165 then 25166 Full_Id := Full_View (Id); 25167 25168 Set_Scope (Full_Id, To); 25169 Set_Public_Status_Of (Full_Id); 25170 end if; 25171 25172 Next_Entity (Id); 25173 end loop; 25174 25175 Set_First_Entity (From, Empty); 25176 Set_Last_Entity (From, Empty); 25177 end if; 25178 end Transfer_Entities; 25179 25180 ----------------------- 25181 -- Type_Access_Level -- 25182 ----------------------- 25183 25184 function Type_Access_Level (Typ : Entity_Id) return Uint is 25185 Btyp : Entity_Id; 25186 25187 begin 25188 Btyp := Base_Type (Typ); 25189 25190 -- Ada 2005 (AI-230): For most cases of anonymous access types, we 25191 -- simply use the level where the type is declared. This is true for 25192 -- stand-alone object declarations, and for anonymous access types 25193 -- associated with components the level is the same as that of the 25194 -- enclosing composite type. However, special treatment is needed for 25195 -- the cases of access parameters, return objects of an anonymous access 25196 -- type, and, in Ada 95, access discriminants of limited types. 25197 25198 if Is_Access_Type (Btyp) then 25199 if Ekind (Btyp) = E_Anonymous_Access_Type then 25200 25201 -- If the type is a nonlocal anonymous access type (such as for 25202 -- an access parameter) we treat it as being declared at the 25203 -- library level to ensure that names such as X.all'access don't 25204 -- fail static accessibility checks. 25205 25206 if not Is_Local_Anonymous_Access (Typ) then 25207 return Scope_Depth (Standard_Standard); 25208 25209 -- If this is a return object, the accessibility level is that of 25210 -- the result subtype of the enclosing function. The test here is 25211 -- little complicated, because we have to account for extended 25212 -- return statements that have been rewritten as blocks, in which 25213 -- case we have to find and the Is_Return_Object attribute of the 25214 -- itype's associated object. It would be nice to find a way to 25215 -- simplify this test, but it doesn't seem worthwhile to add a new 25216 -- flag just for purposes of this test. ??? 25217 25218 elsif Ekind (Scope (Btyp)) = E_Return_Statement 25219 or else 25220 (Is_Itype (Btyp) 25221 and then Nkind (Associated_Node_For_Itype (Btyp)) = 25222 N_Object_Declaration 25223 and then Is_Return_Object 25224 (Defining_Identifier 25225 (Associated_Node_For_Itype (Btyp)))) 25226 then 25227 declare 25228 Scop : Entity_Id; 25229 25230 begin 25231 Scop := Scope (Scope (Btyp)); 25232 while Present (Scop) loop 25233 exit when Ekind (Scop) = E_Function; 25234 Scop := Scope (Scop); 25235 end loop; 25236 25237 -- Treat the return object's type as having the level of the 25238 -- function's result subtype (as per RM05-6.5(5.3/2)). 25239 25240 return Type_Access_Level (Etype (Scop)); 25241 end; 25242 end if; 25243 end if; 25244 25245 Btyp := Root_Type (Btyp); 25246 25247 -- The accessibility level of anonymous access types associated with 25248 -- discriminants is that of the current instance of the type, and 25249 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)). 25250 25251 -- AI-402: access discriminants have accessibility based on the 25252 -- object rather than the type in Ada 2005, so the above paragraph 25253 -- doesn't apply. 25254 25255 -- ??? Needs completion with rules from AI-416 25256 25257 if Ada_Version <= Ada_95 25258 and then Ekind (Typ) = E_Anonymous_Access_Type 25259 and then Present (Associated_Node_For_Itype (Typ)) 25260 and then Nkind (Associated_Node_For_Itype (Typ)) = 25261 N_Discriminant_Specification 25262 then 25263 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1; 25264 end if; 25265 end if; 25266 25267 -- Return library level for a generic formal type. This is done because 25268 -- RM(10.3.2) says that "The statically deeper relationship does not 25269 -- apply to ... a descendant of a generic formal type". Rather than 25270 -- checking at each point where a static accessibility check is 25271 -- performed to see if we are dealing with a formal type, this rule is 25272 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level 25273 -- return extreme values for a formal type; Deepest_Type_Access_Level 25274 -- returns Int'Last. By calling the appropriate function from among the 25275 -- two, we ensure that the static accessibility check will pass if we 25276 -- happen to run into a formal type. More specifically, we should call 25277 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the 25278 -- call occurs as part of a static accessibility check and the error 25279 -- case is the case where the type's level is too shallow (as opposed 25280 -- to too deep). 25281 25282 if Is_Generic_Type (Root_Type (Btyp)) then 25283 return Scope_Depth (Standard_Standard); 25284 end if; 25285 25286 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); 25287 end Type_Access_Level; 25288 25289 ------------------------------------ 25290 -- Type_Without_Stream_Operation -- 25291 ------------------------------------ 25292 25293 function Type_Without_Stream_Operation 25294 (T : Entity_Id; 25295 Op : TSS_Name_Type := TSS_Null) return Entity_Id 25296 is 25297 BT : constant Entity_Id := Base_Type (T); 25298 Op_Missing : Boolean; 25299 25300 begin 25301 if not Restriction_Active (No_Default_Stream_Attributes) then 25302 return Empty; 25303 end if; 25304 25305 if Is_Elementary_Type (T) then 25306 if Op = TSS_Null then 25307 Op_Missing := 25308 No (TSS (BT, TSS_Stream_Read)) 25309 or else No (TSS (BT, TSS_Stream_Write)); 25310 25311 else 25312 Op_Missing := No (TSS (BT, Op)); 25313 end if; 25314 25315 if Op_Missing then 25316 return T; 25317 else 25318 return Empty; 25319 end if; 25320 25321 elsif Is_Array_Type (T) then 25322 return Type_Without_Stream_Operation (Component_Type (T), Op); 25323 25324 elsif Is_Record_Type (T) then 25325 declare 25326 Comp : Entity_Id; 25327 C_Typ : Entity_Id; 25328 25329 begin 25330 Comp := First_Component (T); 25331 while Present (Comp) loop 25332 C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op); 25333 25334 if Present (C_Typ) then 25335 return C_Typ; 25336 end if; 25337 25338 Next_Component (Comp); 25339 end loop; 25340 25341 return Empty; 25342 end; 25343 25344 elsif Is_Private_Type (T) and then Present (Full_View (T)) then 25345 return Type_Without_Stream_Operation (Full_View (T), Op); 25346 else 25347 return Empty; 25348 end if; 25349 end Type_Without_Stream_Operation; 25350 25351 --------------------- 25352 -- Ultimate_Prefix -- 25353 --------------------- 25354 25355 function Ultimate_Prefix (N : Node_Id) return Node_Id is 25356 Pref : Node_Id; 25357 25358 begin 25359 Pref := N; 25360 while Nkind_In (Pref, N_Explicit_Dereference, 25361 N_Indexed_Component, 25362 N_Selected_Component, 25363 N_Slice) 25364 loop 25365 Pref := Prefix (Pref); 25366 end loop; 25367 25368 return Pref; 25369 end Ultimate_Prefix; 25370 25371 ---------------------------- 25372 -- Unique_Defining_Entity -- 25373 ---------------------------- 25374 25375 function Unique_Defining_Entity (N : Node_Id) return Entity_Id is 25376 begin 25377 return Unique_Entity (Defining_Entity (N)); 25378 end Unique_Defining_Entity; 25379 25380 ------------------- 25381 -- Unique_Entity -- 25382 ------------------- 25383 25384 function Unique_Entity (E : Entity_Id) return Entity_Id is 25385 U : Entity_Id := E; 25386 P : Node_Id; 25387 25388 begin 25389 case Ekind (E) is 25390 when E_Constant => 25391 if Present (Full_View (E)) then 25392 U := Full_View (E); 25393 end if; 25394 25395 when Entry_Kind => 25396 if Nkind (Parent (E)) = N_Entry_Body then 25397 declare 25398 Prot_Item : Entity_Id; 25399 Prot_Type : Entity_Id; 25400 25401 begin 25402 if Ekind (E) = E_Entry then 25403 Prot_Type := Scope (E); 25404 25405 -- Bodies of entry families are nested within an extra scope 25406 -- that contains an entry index declaration. 25407 25408 else 25409 Prot_Type := Scope (Scope (E)); 25410 end if; 25411 25412 -- A protected type may be declared as a private type, in 25413 -- which case we need to get its full view. 25414 25415 if Is_Private_Type (Prot_Type) then 25416 Prot_Type := Full_View (Prot_Type); 25417 end if; 25418 25419 -- Full view may not be present on error, in which case 25420 -- return E by default. 25421 25422 if Present (Prot_Type) then 25423 pragma Assert (Ekind (Prot_Type) = E_Protected_Type); 25424 25425 -- Traverse the entity list of the protected type and 25426 -- locate an entry declaration which matches the entry 25427 -- body. 25428 25429 Prot_Item := First_Entity (Prot_Type); 25430 while Present (Prot_Item) loop 25431 if Ekind (Prot_Item) in Entry_Kind 25432 and then Corresponding_Body (Parent (Prot_Item)) = E 25433 then 25434 U := Prot_Item; 25435 exit; 25436 end if; 25437 25438 Next_Entity (Prot_Item); 25439 end loop; 25440 end if; 25441 end; 25442 end if; 25443 25444 when Formal_Kind => 25445 if Present (Spec_Entity (E)) then 25446 U := Spec_Entity (E); 25447 end if; 25448 25449 when E_Package_Body => 25450 P := Parent (E); 25451 25452 if Nkind (P) = N_Defining_Program_Unit_Name then 25453 P := Parent (P); 25454 end if; 25455 25456 if Nkind (P) = N_Package_Body 25457 and then Present (Corresponding_Spec (P)) 25458 then 25459 U := Corresponding_Spec (P); 25460 25461 elsif Nkind (P) = N_Package_Body_Stub 25462 and then Present (Corresponding_Spec_Of_Stub (P)) 25463 then 25464 U := Corresponding_Spec_Of_Stub (P); 25465 end if; 25466 25467 when E_Protected_Body => 25468 P := Parent (E); 25469 25470 if Nkind (P) = N_Protected_Body 25471 and then Present (Corresponding_Spec (P)) 25472 then 25473 U := Corresponding_Spec (P); 25474 25475 elsif Nkind (P) = N_Protected_Body_Stub 25476 and then Present (Corresponding_Spec_Of_Stub (P)) 25477 then 25478 U := Corresponding_Spec_Of_Stub (P); 25479 25480 if Is_Single_Protected_Object (U) then 25481 U := Etype (U); 25482 end if; 25483 end if; 25484 25485 if Is_Private_Type (U) then 25486 U := Full_View (U); 25487 end if; 25488 25489 when E_Subprogram_Body => 25490 P := Parent (E); 25491 25492 if Nkind (P) = N_Defining_Program_Unit_Name then 25493 P := Parent (P); 25494 end if; 25495 25496 P := Parent (P); 25497 25498 if Nkind (P) = N_Subprogram_Body 25499 and then Present (Corresponding_Spec (P)) 25500 then 25501 U := Corresponding_Spec (P); 25502 25503 elsif Nkind (P) = N_Subprogram_Body_Stub 25504 and then Present (Corresponding_Spec_Of_Stub (P)) 25505 then 25506 U := Corresponding_Spec_Of_Stub (P); 25507 25508 elsif Nkind (P) = N_Subprogram_Renaming_Declaration then 25509 U := Corresponding_Spec (P); 25510 end if; 25511 25512 when E_Task_Body => 25513 P := Parent (E); 25514 25515 if Nkind (P) = N_Task_Body 25516 and then Present (Corresponding_Spec (P)) 25517 then 25518 U := Corresponding_Spec (P); 25519 25520 elsif Nkind (P) = N_Task_Body_Stub 25521 and then Present (Corresponding_Spec_Of_Stub (P)) 25522 then 25523 U := Corresponding_Spec_Of_Stub (P); 25524 25525 if Is_Single_Task_Object (U) then 25526 U := Etype (U); 25527 end if; 25528 end if; 25529 25530 if Is_Private_Type (U) then 25531 U := Full_View (U); 25532 end if; 25533 25534 when Type_Kind => 25535 if Present (Full_View (E)) then 25536 U := Full_View (E); 25537 end if; 25538 25539 when others => 25540 null; 25541 end case; 25542 25543 return U; 25544 end Unique_Entity; 25545 25546 ----------------- 25547 -- Unique_Name -- 25548 ----------------- 25549 25550 function Unique_Name (E : Entity_Id) return String is 25551 25552 -- Names in E_Subprogram_Body or E_Package_Body entities are not 25553 -- reliable, as they may not include the overloading suffix. Instead, 25554 -- when looking for the name of E or one of its enclosing scope, we get 25555 -- the name of the corresponding Unique_Entity. 25556 25557 U : constant Entity_Id := Unique_Entity (E); 25558 25559 function This_Name return String; 25560 25561 --------------- 25562 -- This_Name -- 25563 --------------- 25564 25565 function This_Name return String is 25566 begin 25567 return Get_Name_String (Chars (U)); 25568 end This_Name; 25569 25570 -- Start of processing for Unique_Name 25571 25572 begin 25573 if E = Standard_Standard 25574 or else Has_Fully_Qualified_Name (E) 25575 then 25576 return This_Name; 25577 25578 elsif Ekind (E) = E_Enumeration_Literal then 25579 return Unique_Name (Etype (E)) & "__" & This_Name; 25580 25581 else 25582 declare 25583 S : constant Entity_Id := Scope (U); 25584 pragma Assert (Present (S)); 25585 25586 begin 25587 -- Prefix names of predefined types with standard__, but leave 25588 -- names of user-defined packages and subprograms without prefix 25589 -- (even if technically they are nested in the Standard package). 25590 25591 if S = Standard_Standard then 25592 if Ekind (U) = E_Package or else Is_Subprogram (U) then 25593 return This_Name; 25594 else 25595 return Unique_Name (S) & "__" & This_Name; 25596 end if; 25597 25598 -- For intances of generic subprograms use the name of the related 25599 -- instace and skip the scope of its wrapper package. 25600 25601 elsif Is_Wrapper_Package (S) then 25602 pragma Assert (Scope (S) = Scope (Related_Instance (S))); 25603 -- Wrapper package and the instantiation are in the same scope 25604 25605 declare 25606 Enclosing_Name : constant String := 25607 Unique_Name (Scope (S)) & "__" & 25608 Get_Name_String (Chars (Related_Instance (S))); 25609 25610 begin 25611 if Is_Subprogram (U) 25612 and then not Is_Generic_Actual_Subprogram (U) 25613 then 25614 return Enclosing_Name; 25615 else 25616 return Enclosing_Name & "__" & This_Name; 25617 end if; 25618 end; 25619 25620 else 25621 return Unique_Name (S) & "__" & This_Name; 25622 end if; 25623 end; 25624 end if; 25625 end Unique_Name; 25626 25627 --------------------- 25628 -- Unit_Is_Visible -- 25629 --------------------- 25630 25631 function Unit_Is_Visible (U : Entity_Id) return Boolean is 25632 Curr : constant Node_Id := Cunit (Current_Sem_Unit); 25633 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 25634 25635 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean; 25636 -- For a child unit, check whether unit appears in a with_clause 25637 -- of a parent. 25638 25639 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean; 25640 -- Scan the context clause of one compilation unit looking for a 25641 -- with_clause for the unit in question. 25642 25643 ---------------------------- 25644 -- Unit_In_Parent_Context -- 25645 ---------------------------- 25646 25647 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is 25648 begin 25649 if Unit_In_Context (Par_Unit) then 25650 return True; 25651 25652 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then 25653 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit))); 25654 25655 else 25656 return False; 25657 end if; 25658 end Unit_In_Parent_Context; 25659 25660 --------------------- 25661 -- Unit_In_Context -- 25662 --------------------- 25663 25664 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is 25665 Clause : Node_Id; 25666 25667 begin 25668 Clause := First (Context_Items (Comp_Unit)); 25669 while Present (Clause) loop 25670 if Nkind (Clause) = N_With_Clause then 25671 if Library_Unit (Clause) = U then 25672 return True; 25673 25674 -- The with_clause may denote a renaming of the unit we are 25675 -- looking for, eg. Text_IO which renames Ada.Text_IO. 25676 25677 elsif 25678 Renamed_Entity (Entity (Name (Clause))) = 25679 Defining_Entity (Unit (U)) 25680 then 25681 return True; 25682 end if; 25683 end if; 25684 25685 Next (Clause); 25686 end loop; 25687 25688 return False; 25689 end Unit_In_Context; 25690 25691 -- Start of processing for Unit_Is_Visible 25692 25693 begin 25694 -- The currrent unit is directly visible 25695 25696 if Curr = U then 25697 return True; 25698 25699 elsif Unit_In_Context (Curr) then 25700 return True; 25701 25702 -- If the current unit is a body, check the context of the spec 25703 25704 elsif Nkind (Unit (Curr)) = N_Package_Body 25705 or else 25706 (Nkind (Unit (Curr)) = N_Subprogram_Body 25707 and then not Acts_As_Spec (Unit (Curr))) 25708 then 25709 if Unit_In_Context (Library_Unit (Curr)) then 25710 return True; 25711 end if; 25712 end if; 25713 25714 -- If the spec is a child unit, examine the parents 25715 25716 if Is_Child_Unit (Curr_Entity) then 25717 if Nkind (Unit (Curr)) in N_Unit_Body then 25718 return 25719 Unit_In_Parent_Context 25720 (Parent_Spec (Unit (Library_Unit (Curr)))); 25721 else 25722 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr))); 25723 end if; 25724 25725 else 25726 return False; 25727 end if; 25728 end Unit_Is_Visible; 25729 25730 ------------------------------ 25731 -- Universal_Interpretation -- 25732 ------------------------------ 25733 25734 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is 25735 Index : Interp_Index; 25736 It : Interp; 25737 25738 begin 25739 -- The argument may be a formal parameter of an operator or subprogram 25740 -- with multiple interpretations, or else an expression for an actual. 25741 25742 if Nkind (Opnd) = N_Defining_Identifier 25743 or else not Is_Overloaded (Opnd) 25744 then 25745 if Etype (Opnd) = Universal_Integer 25746 or else Etype (Opnd) = Universal_Real 25747 then 25748 return Etype (Opnd); 25749 else 25750 return Empty; 25751 end if; 25752 25753 else 25754 Get_First_Interp (Opnd, Index, It); 25755 while Present (It.Typ) loop 25756 if It.Typ = Universal_Integer 25757 or else It.Typ = Universal_Real 25758 then 25759 return It.Typ; 25760 end if; 25761 25762 Get_Next_Interp (Index, It); 25763 end loop; 25764 25765 return Empty; 25766 end if; 25767 end Universal_Interpretation; 25768 25769 --------------- 25770 -- Unqualify -- 25771 --------------- 25772 25773 function Unqualify (Expr : Node_Id) return Node_Id is 25774 begin 25775 -- Recurse to handle unlikely case of multiple levels of qualification 25776 25777 if Nkind (Expr) = N_Qualified_Expression then 25778 return Unqualify (Expression (Expr)); 25779 25780 -- Normal case, not a qualified expression 25781 25782 else 25783 return Expr; 25784 end if; 25785 end Unqualify; 25786 25787 ----------------- 25788 -- Unqual_Conv -- 25789 ----------------- 25790 25791 function Unqual_Conv (Expr : Node_Id) return Node_Id is 25792 begin 25793 -- Recurse to handle unlikely case of multiple levels of qualification 25794 -- and/or conversion. 25795 25796 if Nkind_In (Expr, N_Qualified_Expression, 25797 N_Type_Conversion, 25798 N_Unchecked_Type_Conversion) 25799 then 25800 return Unqual_Conv (Expression (Expr)); 25801 25802 -- Normal case, not a qualified expression 25803 25804 else 25805 return Expr; 25806 end if; 25807 end Unqual_Conv; 25808 25809 -------------------- 25810 -- Validated_View -- 25811 -------------------- 25812 25813 function Validated_View (Typ : Entity_Id) return Entity_Id is 25814 Continue : Boolean; 25815 Val_Typ : Entity_Id; 25816 25817 begin 25818 Continue := True; 25819 Val_Typ := Base_Type (Typ); 25820 25821 -- Obtain the full view of the input type by stripping away concurrency, 25822 -- derivations, and privacy. 25823 25824 while Continue loop 25825 Continue := False; 25826 25827 if Is_Concurrent_Type (Val_Typ) then 25828 if Present (Corresponding_Record_Type (Val_Typ)) then 25829 Continue := True; 25830 Val_Typ := Corresponding_Record_Type (Val_Typ); 25831 end if; 25832 25833 elsif Is_Derived_Type (Val_Typ) then 25834 Continue := True; 25835 Val_Typ := Etype (Val_Typ); 25836 25837 elsif Is_Private_Type (Val_Typ) then 25838 if Present (Underlying_Full_View (Val_Typ)) then 25839 Continue := True; 25840 Val_Typ := Underlying_Full_View (Val_Typ); 25841 25842 elsif Present (Full_View (Val_Typ)) then 25843 Continue := True; 25844 Val_Typ := Full_View (Val_Typ); 25845 end if; 25846 end if; 25847 end loop; 25848 25849 return Val_Typ; 25850 end Validated_View; 25851 25852 ----------------------- 25853 -- Visible_Ancestors -- 25854 ----------------------- 25855 25856 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is 25857 List_1 : Elist_Id; 25858 List_2 : Elist_Id; 25859 Elmt : Elmt_Id; 25860 25861 begin 25862 pragma Assert (Is_Record_Type (Typ) and then Is_Tagged_Type (Typ)); 25863 25864 -- Collect all the parents and progenitors of Typ. If the full-view of 25865 -- private parents and progenitors is available then it is used to 25866 -- generate the list of visible ancestors; otherwise their partial 25867 -- view is added to the resulting list. 25868 25869 Collect_Parents 25870 (T => Typ, 25871 List => List_1, 25872 Use_Full_View => True); 25873 25874 Collect_Interfaces 25875 (T => Typ, 25876 Ifaces_List => List_2, 25877 Exclude_Parents => True, 25878 Use_Full_View => True); 25879 25880 -- Join the two lists. Avoid duplications because an interface may 25881 -- simultaneously be parent and progenitor of a type. 25882 25883 Elmt := First_Elmt (List_2); 25884 while Present (Elmt) loop 25885 Append_Unique_Elmt (Node (Elmt), List_1); 25886 Next_Elmt (Elmt); 25887 end loop; 25888 25889 return List_1; 25890 end Visible_Ancestors; 25891 25892 ---------------------- 25893 -- Within_Init_Proc -- 25894 ---------------------- 25895 25896 function Within_Init_Proc return Boolean is 25897 S : Entity_Id; 25898 25899 begin 25900 S := Current_Scope; 25901 while not Is_Overloadable (S) loop 25902 if S = Standard_Standard then 25903 return False; 25904 else 25905 S := Scope (S); 25906 end if; 25907 end loop; 25908 25909 return Is_Init_Proc (S); 25910 end Within_Init_Proc; 25911 25912 --------------------------- 25913 -- Within_Protected_Type -- 25914 --------------------------- 25915 25916 function Within_Protected_Type (E : Entity_Id) return Boolean is 25917 Scop : Entity_Id := Scope (E); 25918 25919 begin 25920 while Present (Scop) loop 25921 if Ekind (Scop) = E_Protected_Type then 25922 return True; 25923 end if; 25924 25925 Scop := Scope (Scop); 25926 end loop; 25927 25928 return False; 25929 end Within_Protected_Type; 25930 25931 ------------------ 25932 -- Within_Scope -- 25933 ------------------ 25934 25935 function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean is 25936 begin 25937 return Scope_Within_Or_Same (Scope (E), S); 25938 end Within_Scope; 25939 25940 ---------------------------- 25941 -- Within_Subprogram_Call -- 25942 ---------------------------- 25943 25944 function Within_Subprogram_Call (N : Node_Id) return Boolean is 25945 Par : Node_Id; 25946 25947 begin 25948 -- Climb the parent chain looking for a function or procedure call 25949 25950 Par := N; 25951 while Present (Par) loop 25952 if Nkind_In (Par, N_Entry_Call_Statement, 25953 N_Function_Call, 25954 N_Procedure_Call_Statement) 25955 then 25956 return True; 25957 25958 -- Prevent the search from going too far 25959 25960 elsif Is_Body_Or_Package_Declaration (Par) then 25961 exit; 25962 end if; 25963 25964 Par := Parent (Par); 25965 end loop; 25966 25967 return False; 25968 end Within_Subprogram_Call; 25969 25970 ---------------- 25971 -- Wrong_Type -- 25972 ---------------- 25973 25974 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is 25975 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr)); 25976 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type); 25977 25978 Matching_Field : Entity_Id; 25979 -- Entity to give a more precise suggestion on how to write a one- 25980 -- element positional aggregate. 25981 25982 function Has_One_Matching_Field return Boolean; 25983 -- Determines if Expec_Type is a record type with a single component or 25984 -- discriminant whose type matches the found type or is one dimensional 25985 -- array whose component type matches the found type. In the case of 25986 -- one discriminant, we ignore the variant parts. That's not accurate, 25987 -- but good enough for the warning. 25988 25989 ---------------------------- 25990 -- Has_One_Matching_Field -- 25991 ---------------------------- 25992 25993 function Has_One_Matching_Field return Boolean is 25994 E : Entity_Id; 25995 25996 begin 25997 Matching_Field := Empty; 25998 25999 if Is_Array_Type (Expec_Type) 26000 and then Number_Dimensions (Expec_Type) = 1 26001 and then Covers (Etype (Component_Type (Expec_Type)), Found_Type) 26002 then 26003 -- Use type name if available. This excludes multidimensional 26004 -- arrays and anonymous arrays. 26005 26006 if Comes_From_Source (Expec_Type) then 26007 Matching_Field := Expec_Type; 26008 26009 -- For an assignment, use name of target 26010 26011 elsif Nkind (Parent (Expr)) = N_Assignment_Statement 26012 and then Is_Entity_Name (Name (Parent (Expr))) 26013 then 26014 Matching_Field := Entity (Name (Parent (Expr))); 26015 end if; 26016 26017 return True; 26018 26019 elsif not Is_Record_Type (Expec_Type) then 26020 return False; 26021 26022 else 26023 E := First_Entity (Expec_Type); 26024 loop 26025 if No (E) then 26026 return False; 26027 26028 elsif not Ekind_In (E, E_Discriminant, E_Component) 26029 or else Nam_In (Chars (E), Name_uTag, Name_uParent) 26030 then 26031 Next_Entity (E); 26032 26033 else 26034 exit; 26035 end if; 26036 end loop; 26037 26038 if not Covers (Etype (E), Found_Type) then 26039 return False; 26040 26041 elsif Present (Next_Entity (E)) 26042 and then (Ekind (E) = E_Component 26043 or else Ekind (Next_Entity (E)) = E_Discriminant) 26044 then 26045 return False; 26046 26047 else 26048 Matching_Field := E; 26049 return True; 26050 end if; 26051 end if; 26052 end Has_One_Matching_Field; 26053 26054 -- Start of processing for Wrong_Type 26055 26056 begin 26057 -- Don't output message if either type is Any_Type, or if a message 26058 -- has already been posted for this node. We need to do the latter 26059 -- check explicitly (it is ordinarily done in Errout), because we 26060 -- are using ! to force the output of the error messages. 26061 26062 if Expec_Type = Any_Type 26063 or else Found_Type = Any_Type 26064 or else Error_Posted (Expr) 26065 then 26066 return; 26067 26068 -- If one of the types is a Taft-Amendment type and the other it its 26069 -- completion, it must be an illegal use of a TAT in the spec, for 26070 -- which an error was already emitted. Avoid cascaded errors. 26071 26072 elsif Is_Incomplete_Type (Expec_Type) 26073 and then Has_Completion_In_Body (Expec_Type) 26074 and then Full_View (Expec_Type) = Etype (Expr) 26075 then 26076 return; 26077 26078 elsif Is_Incomplete_Type (Etype (Expr)) 26079 and then Has_Completion_In_Body (Etype (Expr)) 26080 and then Full_View (Etype (Expr)) = Expec_Type 26081 then 26082 return; 26083 26084 -- In an instance, there is an ongoing problem with completion of 26085 -- type derived from private types. Their structure is what Gigi 26086 -- expects, but the Etype is the parent type rather than the 26087 -- derived private type itself. Do not flag error in this case. The 26088 -- private completion is an entity without a parent, like an Itype. 26089 -- Similarly, full and partial views may be incorrect in the instance. 26090 -- There is no simple way to insure that it is consistent ??? 26091 26092 -- A similar view discrepancy can happen in an inlined body, for the 26093 -- same reason: inserted body may be outside of the original package 26094 -- and only partial views are visible at the point of insertion. 26095 26096 elsif In_Instance or else In_Inlined_Body then 26097 if Etype (Etype (Expr)) = Etype (Expected_Type) 26098 and then 26099 (Has_Private_Declaration (Expected_Type) 26100 or else Has_Private_Declaration (Etype (Expr))) 26101 and then No (Parent (Expected_Type)) 26102 then 26103 return; 26104 26105 elsif Nkind (Parent (Expr)) = N_Qualified_Expression 26106 and then Entity (Subtype_Mark (Parent (Expr))) = Expected_Type 26107 then 26108 return; 26109 26110 elsif Is_Private_Type (Expected_Type) 26111 and then Present (Full_View (Expected_Type)) 26112 and then Covers (Full_View (Expected_Type), Etype (Expr)) 26113 then 26114 return; 26115 26116 -- Conversely, type of expression may be the private one 26117 26118 elsif Is_Private_Type (Base_Type (Etype (Expr))) 26119 and then Full_View (Base_Type (Etype (Expr))) = Expected_Type 26120 then 26121 return; 26122 end if; 26123 end if; 26124 26125 -- An interesting special check. If the expression is parenthesized 26126 -- and its type corresponds to the type of the sole component of the 26127 -- expected record type, or to the component type of the expected one 26128 -- dimensional array type, then assume we have a bad aggregate attempt. 26129 26130 if Nkind (Expr) in N_Subexpr 26131 and then Paren_Count (Expr) /= 0 26132 and then Has_One_Matching_Field 26133 then 26134 Error_Msg_N ("positional aggregate cannot have one component", Expr); 26135 26136 if Present (Matching_Field) then 26137 if Is_Array_Type (Expec_Type) then 26138 Error_Msg_NE 26139 ("\write instead `&''First ='> ...`", Expr, Matching_Field); 26140 else 26141 Error_Msg_NE 26142 ("\write instead `& ='> ...`", Expr, Matching_Field); 26143 end if; 26144 end if; 26145 26146 -- Another special check, if we are looking for a pool-specific access 26147 -- type and we found an E_Access_Attribute_Type, then we have the case 26148 -- of an Access attribute being used in a context which needs a pool- 26149 -- specific type, which is never allowed. The one extra check we make 26150 -- is that the expected designated type covers the Found_Type. 26151 26152 elsif Is_Access_Type (Expec_Type) 26153 and then Ekind (Found_Type) = E_Access_Attribute_Type 26154 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type 26155 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type 26156 and then Covers 26157 (Designated_Type (Expec_Type), Designated_Type (Found_Type)) 26158 then 26159 Error_Msg_N -- CODEFIX 26160 ("result must be general access type!", Expr); 26161 Error_Msg_NE -- CODEFIX 26162 ("add ALL to }!", Expr, Expec_Type); 26163 26164 -- Another special check, if the expected type is an integer type, 26165 -- but the expression is of type System.Address, and the parent is 26166 -- an addition or subtraction operation whose left operand is the 26167 -- expression in question and whose right operand is of an integral 26168 -- type, then this is an attempt at address arithmetic, so give 26169 -- appropriate message. 26170 26171 elsif Is_Integer_Type (Expec_Type) 26172 and then Is_RTE (Found_Type, RE_Address) 26173 and then Nkind_In (Parent (Expr), N_Op_Add, N_Op_Subtract) 26174 and then Expr = Left_Opnd (Parent (Expr)) 26175 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr)))) 26176 then 26177 Error_Msg_N 26178 ("address arithmetic not predefined in package System", 26179 Parent (Expr)); 26180 Error_Msg_N 26181 ("\possible missing with/use of System.Storage_Elements", 26182 Parent (Expr)); 26183 return; 26184 26185 -- If the expected type is an anonymous access type, as for access 26186 -- parameters and discriminants, the error is on the designated types. 26187 26188 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then 26189 if Comes_From_Source (Expec_Type) then 26190 Error_Msg_NE ("expected}!", Expr, Expec_Type); 26191 else 26192 Error_Msg_NE 26193 ("expected an access type with designated}", 26194 Expr, Designated_Type (Expec_Type)); 26195 end if; 26196 26197 if Is_Access_Type (Found_Type) 26198 and then not Comes_From_Source (Found_Type) 26199 then 26200 Error_Msg_NE 26201 ("\\found an access type with designated}!", 26202 Expr, Designated_Type (Found_Type)); 26203 else 26204 if From_Limited_With (Found_Type) then 26205 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); 26206 Error_Msg_Qual_Level := 99; 26207 Error_Msg_NE -- CODEFIX 26208 ("\\missing `WITH &;", Expr, Scope (Found_Type)); 26209 Error_Msg_Qual_Level := 0; 26210 else 26211 Error_Msg_NE ("found}!", Expr, Found_Type); 26212 end if; 26213 end if; 26214 26215 -- Normal case of one type found, some other type expected 26216 26217 else 26218 -- If the names of the two types are the same, see if some number 26219 -- of levels of qualification will help. Don't try more than three 26220 -- levels, and if we get to standard, it's no use (and probably 26221 -- represents an error in the compiler) Also do not bother with 26222 -- internal scope names. 26223 26224 declare 26225 Expec_Scope : Entity_Id; 26226 Found_Scope : Entity_Id; 26227 26228 begin 26229 Expec_Scope := Expec_Type; 26230 Found_Scope := Found_Type; 26231 26232 for Levels in Nat range 0 .. 3 loop 26233 if Chars (Expec_Scope) /= Chars (Found_Scope) then 26234 Error_Msg_Qual_Level := Levels; 26235 exit; 26236 end if; 26237 26238 Expec_Scope := Scope (Expec_Scope); 26239 Found_Scope := Scope (Found_Scope); 26240 26241 exit when Expec_Scope = Standard_Standard 26242 or else Found_Scope = Standard_Standard 26243 or else not Comes_From_Source (Expec_Scope) 26244 or else not Comes_From_Source (Found_Scope); 26245 end loop; 26246 end; 26247 26248 if Is_Record_Type (Expec_Type) 26249 and then Present (Corresponding_Remote_Type (Expec_Type)) 26250 then 26251 Error_Msg_NE ("expected}!", Expr, 26252 Corresponding_Remote_Type (Expec_Type)); 26253 else 26254 Error_Msg_NE ("expected}!", Expr, Expec_Type); 26255 end if; 26256 26257 if Is_Entity_Name (Expr) 26258 and then Is_Package_Or_Generic_Package (Entity (Expr)) 26259 then 26260 Error_Msg_N ("\\found package name!", Expr); 26261 26262 elsif Is_Entity_Name (Expr) 26263 and then Ekind_In (Entity (Expr), E_Procedure, E_Generic_Procedure) 26264 then 26265 if Ekind (Expec_Type) = E_Access_Subprogram_Type then 26266 Error_Msg_N 26267 ("found procedure name, possibly missing Access attribute!", 26268 Expr); 26269 else 26270 Error_Msg_N 26271 ("\\found procedure name instead of function!", Expr); 26272 end if; 26273 26274 elsif Nkind (Expr) = N_Function_Call 26275 and then Ekind (Expec_Type) = E_Access_Subprogram_Type 26276 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr) 26277 and then No (Parameter_Associations (Expr)) 26278 then 26279 Error_Msg_N 26280 ("found function name, possibly missing Access attribute!", 26281 Expr); 26282 26283 -- Catch common error: a prefix or infix operator which is not 26284 -- directly visible because the type isn't. 26285 26286 elsif Nkind (Expr) in N_Op 26287 and then Is_Overloaded (Expr) 26288 and then not Is_Immediately_Visible (Expec_Type) 26289 and then not Is_Potentially_Use_Visible (Expec_Type) 26290 and then not In_Use (Expec_Type) 26291 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type) 26292 then 26293 Error_Msg_N 26294 ("operator of the type is not directly visible!", Expr); 26295 26296 elsif Ekind (Found_Type) = E_Void 26297 and then Present (Parent (Found_Type)) 26298 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration 26299 then 26300 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type); 26301 26302 else 26303 Error_Msg_NE ("\\found}!", Expr, Found_Type); 26304 end if; 26305 26306 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are 26307 -- of the same modular type, and (M1 and M2) = 0 was intended. 26308 26309 if Expec_Type = Standard_Boolean 26310 and then Is_Modular_Integer_Type (Found_Type) 26311 and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor) 26312 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare 26313 then 26314 declare 26315 Op : constant Node_Id := Right_Opnd (Parent (Expr)); 26316 L : constant Node_Id := Left_Opnd (Op); 26317 R : constant Node_Id := Right_Opnd (Op); 26318 26319 begin 26320 -- The case for the message is when the left operand of the 26321 -- comparison is the same modular type, or when it is an 26322 -- integer literal (or other universal integer expression), 26323 -- which would have been typed as the modular type if the 26324 -- parens had been there. 26325 26326 if (Etype (L) = Found_Type 26327 or else 26328 Etype (L) = Universal_Integer) 26329 and then Is_Integer_Type (Etype (R)) 26330 then 26331 Error_Msg_N 26332 ("\\possible missing parens for modular operation", Expr); 26333 end if; 26334 end; 26335 end if; 26336 26337 -- Reset error message qualification indication 26338 26339 Error_Msg_Qual_Level := 0; 26340 end if; 26341 end Wrong_Type; 26342 26343 -------------------------------- 26344 -- Yields_Synchronized_Object -- 26345 -------------------------------- 26346 26347 function Yields_Synchronized_Object (Typ : Entity_Id) return Boolean is 26348 Has_Sync_Comp : Boolean := False; 26349 Id : Entity_Id; 26350 26351 begin 26352 -- An array type yields a synchronized object if its component type 26353 -- yields a synchronized object. 26354 26355 if Is_Array_Type (Typ) then 26356 return Yields_Synchronized_Object (Component_Type (Typ)); 26357 26358 -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object 26359 -- yields a synchronized object by default. 26360 26361 elsif Is_Descendant_Of_Suspension_Object (Typ) then 26362 return True; 26363 26364 -- A protected type yields a synchronized object by default 26365 26366 elsif Is_Protected_Type (Typ) then 26367 return True; 26368 26369 -- A record type or type extension yields a synchronized object when its 26370 -- discriminants (if any) lack default values and all components are of 26371 -- a type that yelds a synchronized object. 26372 26373 elsif Is_Record_Type (Typ) then 26374 26375 -- Inspect all entities defined in the scope of the type, looking for 26376 -- components of a type that does not yeld a synchronized object or 26377 -- for discriminants with default values. 26378 26379 Id := First_Entity (Typ); 26380 while Present (Id) loop 26381 if Comes_From_Source (Id) then 26382 if Ekind (Id) = E_Component then 26383 if Yields_Synchronized_Object (Etype (Id)) then 26384 Has_Sync_Comp := True; 26385 26386 -- The component does not yield a synchronized object 26387 26388 else 26389 return False; 26390 end if; 26391 26392 elsif Ekind (Id) = E_Discriminant 26393 and then Present (Expression (Parent (Id))) 26394 then 26395 return False; 26396 end if; 26397 end if; 26398 26399 Next_Entity (Id); 26400 end loop; 26401 26402 -- Ensure that the parent type of a type extension yields a 26403 -- synchronized object. 26404 26405 if Etype (Typ) /= Typ 26406 and then not Yields_Synchronized_Object (Etype (Typ)) 26407 then 26408 return False; 26409 end if; 26410 26411 -- If we get here, then all discriminants lack default values and all 26412 -- components are of a type that yields a synchronized object. 26413 26414 return Has_Sync_Comp; 26415 26416 -- A synchronized interface type yields a synchronized object by default 26417 26418 elsif Is_Synchronized_Interface (Typ) then 26419 return True; 26420 26421 -- A task type yelds a synchronized object by default 26422 26423 elsif Is_Task_Type (Typ) then 26424 return True; 26425 26426 -- Otherwise the type does not yield a synchronized object 26427 26428 else 26429 return False; 26430 end if; 26431 end Yields_Synchronized_Object; 26432 26433 --------------------------- 26434 -- Yields_Universal_Type -- 26435 --------------------------- 26436 26437 function Yields_Universal_Type (N : Node_Id) return Boolean is 26438 begin 26439 -- Integer and real literals are of a universal type 26440 26441 if Nkind_In (N, N_Integer_Literal, N_Real_Literal) then 26442 return True; 26443 26444 -- The values of certain attributes are of a universal type 26445 26446 elsif Nkind (N) = N_Attribute_Reference then 26447 return 26448 Universal_Type_Attribute (Get_Attribute_Id (Attribute_Name (N))); 26449 26450 -- ??? There are possibly other cases to consider 26451 26452 else 26453 return False; 26454 end if; 26455 end Yields_Universal_Type; 26456 26457begin 26458 Erroutc.Subprogram_Name_Ptr := Subprogram_Name'Access; 26459end Sem_Util; 26460