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-2018, 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_Disp; use Exp_Disp; 38with Exp_Util; use Exp_Util; 39with Fname; use Fname; 40with Freeze; use Freeze; 41with Lib; use Lib; 42with Lib.Xref; use Lib.Xref; 43with Namet.Sp; use Namet.Sp; 44with Nlists; use Nlists; 45with Nmake; use Nmake; 46with Output; use Output; 47with Restrict; use Restrict; 48with Rident; use Rident; 49with Rtsfind; use Rtsfind; 50with Sem; use Sem; 51with Sem_Aux; use Sem_Aux; 52with Sem_Attr; use Sem_Attr; 53with Sem_Ch6; use Sem_Ch6; 54with Sem_Ch8; use Sem_Ch8; 55with Sem_Disp; use Sem_Disp; 56with Sem_Elab; use Sem_Elab; 57with Sem_Eval; use Sem_Eval; 58with Sem_Prag; use Sem_Prag; 59with Sem_Res; use Sem_Res; 60with Sem_Warn; use Sem_Warn; 61with Sem_Type; use Sem_Type; 62with Sinfo; use Sinfo; 63with Sinput; use Sinput; 64with Stand; use Stand; 65with Style; 66with Stringt; use Stringt; 67with Targparm; use Targparm; 68with Tbuild; use Tbuild; 69with Ttypes; use Ttypes; 70with Uname; use Uname; 71 72with GNAT.HTable; use GNAT.HTable; 73 74package body Sem_Util is 75 76 ----------------------- 77 -- Local Subprograms -- 78 ----------------------- 79 80 function Build_Component_Subtype 81 (C : List_Id; 82 Loc : Source_Ptr; 83 T : Entity_Id) return Node_Id; 84 -- This function builds the subtype for Build_Actual_Subtype_Of_Component 85 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints, 86 -- Loc is the source location, T is the original subtype. 87 88 function Has_Enabled_Property 89 (Item_Id : Entity_Id; 90 Property : Name_Id) return Boolean; 91 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled. 92 -- Determine whether an abstract state or a variable denoted by entity 93 -- Item_Id has enabled property Property. 94 95 function Has_Null_Extension (T : Entity_Id) return Boolean; 96 -- T is a derived tagged type. Check whether the type extension is null. 97 -- If the parent type is fully initialized, T can be treated as such. 98 99 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean; 100 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type 101 -- with discriminants whose default values are static, examine only the 102 -- components in the selected variant to determine whether all of them 103 -- have a default. 104 105 type Null_Status_Kind is 106 (Is_Null, 107 -- This value indicates that a subexpression is known to have a null 108 -- value at compile time. 109 110 Is_Non_Null, 111 -- This value indicates that a subexpression is known to have a non-null 112 -- value at compile time. 113 114 Unknown); 115 -- This value indicates that it cannot be determined at compile time 116 -- whether a subexpression yields a null or non-null value. 117 118 function Null_Status (N : Node_Id) return Null_Status_Kind; 119 -- Determine whether subexpression N of an access type yields a null value, 120 -- a non-null value, or the value cannot be determined at compile time. The 121 -- routine does not take simple flow diagnostics into account, it relies on 122 -- static facts such as the presence of null exclusions. 123 124 function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean; 125 function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean; 126 -- ???We retain the old and new algorithms for Requires_Transient_Scope for 127 -- the time being. New_Requires_Transient_Scope is used by default; the 128 -- debug switch -gnatdQ can be used to do Old_Requires_Transient_Scope 129 -- instead. The intent is to use this temporarily to measure before/after 130 -- efficiency. Note: when this temporary code is removed, the documentation 131 -- of dQ in debug.adb should be removed. 132 133 procedure Results_Differ 134 (Id : Entity_Id; 135 Old_Val : Boolean; 136 New_Val : Boolean); 137 -- ???Debugging code. Called when the Old_Val and New_Val differ. This 138 -- routine will be removed eventially when New_Requires_Transient_Scope 139 -- becomes Requires_Transient_Scope and Old_Requires_Transient_Scope is 140 -- eliminated. 141 142 function Subprogram_Name (N : Node_Id) return String; 143 -- Return the fully qualified name of the enclosing subprogram for the 144 -- given node N, with file:line:col information appended, e.g. 145 -- "subp:file:line:col", corresponding to the source location of the 146 -- body of the subprogram. 147 148 ------------------------------ 149 -- Abstract_Interface_List -- 150 ------------------------------ 151 152 function Abstract_Interface_List (Typ : Entity_Id) return List_Id is 153 Nod : Node_Id; 154 155 begin 156 if Is_Concurrent_Type (Typ) then 157 158 -- If we are dealing with a synchronized subtype, go to the base 159 -- type, whose declaration has the interface list. 160 161 -- Shouldn't this be Declaration_Node??? 162 163 Nod := Parent (Base_Type (Typ)); 164 165 if Nkind (Nod) = N_Full_Type_Declaration then 166 return Empty_List; 167 end if; 168 169 elsif Ekind (Typ) = E_Record_Type_With_Private then 170 if Nkind (Parent (Typ)) = N_Full_Type_Declaration then 171 Nod := Type_Definition (Parent (Typ)); 172 173 elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then 174 if Present (Full_View (Typ)) 175 and then 176 Nkind (Parent (Full_View (Typ))) = N_Full_Type_Declaration 177 then 178 Nod := Type_Definition (Parent (Full_View (Typ))); 179 180 -- If the full-view is not available we cannot do anything else 181 -- here (the source has errors). 182 183 else 184 return Empty_List; 185 end if; 186 187 -- Support for generic formals with interfaces is still missing ??? 188 189 elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then 190 return Empty_List; 191 192 else 193 pragma Assert 194 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration); 195 Nod := Parent (Typ); 196 end if; 197 198 elsif Ekind (Typ) = E_Record_Subtype then 199 Nod := Type_Definition (Parent (Etype (Typ))); 200 201 elsif Ekind (Typ) = E_Record_Subtype_With_Private then 202 203 -- Recurse, because parent may still be a private extension. Also 204 -- note that the full view of the subtype or the full view of its 205 -- base type may (both) be unavailable. 206 207 return Abstract_Interface_List (Etype (Typ)); 208 209 elsif Ekind (Typ) = E_Record_Type then 210 if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then 211 Nod := Formal_Type_Definition (Parent (Typ)); 212 else 213 Nod := Type_Definition (Parent (Typ)); 214 end if; 215 216 -- Otherwise the type is of a kind which does not implement interfaces 217 218 else 219 return Empty_List; 220 end if; 221 222 return Interface_List (Nod); 223 end Abstract_Interface_List; 224 225 -------------------------------- 226 -- Add_Access_Type_To_Process -- 227 -------------------------------- 228 229 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is 230 L : Elist_Id; 231 232 begin 233 Ensure_Freeze_Node (E); 234 L := Access_Types_To_Process (Freeze_Node (E)); 235 236 if No (L) then 237 L := New_Elmt_List; 238 Set_Access_Types_To_Process (Freeze_Node (E), L); 239 end if; 240 241 Append_Elmt (A, L); 242 end Add_Access_Type_To_Process; 243 244 -------------------------- 245 -- Add_Block_Identifier -- 246 -------------------------- 247 248 procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is 249 Loc : constant Source_Ptr := Sloc (N); 250 251 begin 252 pragma Assert (Nkind (N) = N_Block_Statement); 253 254 -- The block already has a label, return its entity 255 256 if Present (Identifier (N)) then 257 Id := Entity (Identifier (N)); 258 259 -- Create a new block label and set its attributes 260 261 else 262 Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); 263 Set_Etype (Id, Standard_Void_Type); 264 Set_Parent (Id, N); 265 266 Set_Identifier (N, New_Occurrence_Of (Id, Loc)); 267 Set_Block_Node (Id, Identifier (N)); 268 end if; 269 end Add_Block_Identifier; 270 271 ---------------------------- 272 -- Add_Global_Declaration -- 273 ---------------------------- 274 275 procedure Add_Global_Declaration (N : Node_Id) is 276 Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit)); 277 278 begin 279 if No (Declarations (Aux_Node)) then 280 Set_Declarations (Aux_Node, New_List); 281 end if; 282 283 Append_To (Declarations (Aux_Node), N); 284 Analyze (N); 285 end Add_Global_Declaration; 286 287 -------------------------------- 288 -- Address_Integer_Convert_OK -- 289 -------------------------------- 290 291 function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is 292 begin 293 if Allow_Integer_Address 294 and then ((Is_Descendant_Of_Address (T1) 295 and then Is_Private_Type (T1) 296 and then Is_Integer_Type (T2)) 297 or else 298 (Is_Descendant_Of_Address (T2) 299 and then Is_Private_Type (T2) 300 and then Is_Integer_Type (T1))) 301 then 302 return True; 303 else 304 return False; 305 end if; 306 end Address_Integer_Convert_OK; 307 308 ------------------- 309 -- Address_Value -- 310 ------------------- 311 312 function Address_Value (N : Node_Id) return Node_Id is 313 Expr : Node_Id := N; 314 315 begin 316 loop 317 -- For constant, get constant expression 318 319 if Is_Entity_Name (Expr) 320 and then Ekind (Entity (Expr)) = E_Constant 321 then 322 Expr := Constant_Value (Entity (Expr)); 323 324 -- For unchecked conversion, get result to convert 325 326 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then 327 Expr := Expression (Expr); 328 329 -- For (common case) of To_Address call, get argument 330 331 elsif Nkind (Expr) = N_Function_Call 332 and then Is_Entity_Name (Name (Expr)) 333 and then Is_RTE (Entity (Name (Expr)), RE_To_Address) 334 then 335 Expr := First (Parameter_Associations (Expr)); 336 337 if Nkind (Expr) = N_Parameter_Association then 338 Expr := Explicit_Actual_Parameter (Expr); 339 end if; 340 341 -- We finally have the real expression 342 343 else 344 exit; 345 end if; 346 end loop; 347 348 return Expr; 349 end Address_Value; 350 351 ----------------- 352 -- Addressable -- 353 ----------------- 354 355 -- For now, just 8/16/32/64 356 357 function Addressable (V : Uint) return Boolean is 358 begin 359 return V = Uint_8 or else 360 V = Uint_16 or else 361 V = Uint_32 or else 362 V = Uint_64; 363 end Addressable; 364 365 function Addressable (V : Int) return Boolean is 366 begin 367 return V = 8 or else 368 V = 16 or else 369 V = 32 or else 370 V = 64; 371 end Addressable; 372 373 --------------------------------- 374 -- Aggregate_Constraint_Checks -- 375 --------------------------------- 376 377 procedure Aggregate_Constraint_Checks 378 (Exp : Node_Id; 379 Check_Typ : Entity_Id) 380 is 381 Exp_Typ : constant Entity_Id := Etype (Exp); 382 383 begin 384 if Raises_Constraint_Error (Exp) then 385 return; 386 end if; 387 388 -- Ada 2005 (AI-230): Generate a conversion to an anonymous access 389 -- component's type to force the appropriate accessibility checks. 390 391 -- Ada 2005 (AI-231): Generate conversion to the null-excluding type to 392 -- force the corresponding run-time check 393 394 if Is_Access_Type (Check_Typ) 395 and then Is_Local_Anonymous_Access (Check_Typ) 396 then 397 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); 398 Analyze_And_Resolve (Exp, Check_Typ); 399 Check_Unset_Reference (Exp); 400 end if; 401 402 -- What follows is really expansion activity, so check that expansion 403 -- is on and is allowed. In GNATprove mode, we also want check flags to 404 -- be added in the tree, so that the formal verification can rely on 405 -- those to be present. In GNATprove mode for formal verification, some 406 -- treatment typically only done during expansion needs to be performed 407 -- on the tree, but it should not be applied inside generics. Otherwise, 408 -- this breaks the name resolution mechanism for generic instances. 409 410 if not Expander_Active 411 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode) 412 then 413 return; 414 end if; 415 416 if Is_Access_Type (Check_Typ) 417 and then Can_Never_Be_Null (Check_Typ) 418 and then not Can_Never_Be_Null (Exp_Typ) 419 then 420 Install_Null_Excluding_Check (Exp); 421 end if; 422 423 -- First check if we have to insert discriminant checks 424 425 if Has_Discriminants (Exp_Typ) then 426 Apply_Discriminant_Check (Exp, Check_Typ); 427 428 -- Next emit length checks for array aggregates 429 430 elsif Is_Array_Type (Exp_Typ) then 431 Apply_Length_Check (Exp, Check_Typ); 432 433 -- Finally emit scalar and string checks. If we are dealing with a 434 -- scalar literal we need to check by hand because the Etype of 435 -- literals is not necessarily correct. 436 437 elsif Is_Scalar_Type (Exp_Typ) 438 and then Compile_Time_Known_Value (Exp) 439 then 440 if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then 441 Apply_Compile_Time_Constraint_Error 442 (Exp, "value not in range of}??", CE_Range_Check_Failed, 443 Ent => Base_Type (Check_Typ), 444 Typ => Base_Type (Check_Typ)); 445 446 elsif Is_Out_Of_Range (Exp, Check_Typ) then 447 Apply_Compile_Time_Constraint_Error 448 (Exp, "value not in range of}??", CE_Range_Check_Failed, 449 Ent => Check_Typ, 450 Typ => Check_Typ); 451 452 elsif not Range_Checks_Suppressed (Check_Typ) then 453 Apply_Scalar_Range_Check (Exp, Check_Typ); 454 end if; 455 456 -- Verify that target type is also scalar, to prevent view anomalies 457 -- in instantiations. 458 459 elsif (Is_Scalar_Type (Exp_Typ) 460 or else Nkind (Exp) = N_String_Literal) 461 and then Is_Scalar_Type (Check_Typ) 462 and then Exp_Typ /= Check_Typ 463 then 464 if Is_Entity_Name (Exp) 465 and then Ekind (Entity (Exp)) = E_Constant 466 then 467 -- If expression is a constant, it is worthwhile checking whether 468 -- it is a bound of the type. 469 470 if (Is_Entity_Name (Type_Low_Bound (Check_Typ)) 471 and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ))) 472 or else 473 (Is_Entity_Name (Type_High_Bound (Check_Typ)) 474 and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ))) 475 then 476 return; 477 478 else 479 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); 480 Analyze_And_Resolve (Exp, Check_Typ); 481 Check_Unset_Reference (Exp); 482 end if; 483 484 -- Could use a comment on this case ??? 485 486 else 487 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); 488 Analyze_And_Resolve (Exp, Check_Typ); 489 Check_Unset_Reference (Exp); 490 end if; 491 492 end if; 493 end Aggregate_Constraint_Checks; 494 495 ----------------------- 496 -- Alignment_In_Bits -- 497 ----------------------- 498 499 function Alignment_In_Bits (E : Entity_Id) return Uint is 500 begin 501 return Alignment (E) * System_Storage_Unit; 502 end Alignment_In_Bits; 503 504 -------------------------------------- 505 -- All_Composite_Constraints_Static -- 506 -------------------------------------- 507 508 function All_Composite_Constraints_Static 509 (Constr : Node_Id) return Boolean 510 is 511 begin 512 if No (Constr) or else Error_Posted (Constr) then 513 return True; 514 end if; 515 516 case Nkind (Constr) is 517 when N_Subexpr => 518 if Nkind (Constr) in N_Has_Entity 519 and then Present (Entity (Constr)) 520 then 521 if Is_Type (Entity (Constr)) then 522 return 523 not Is_Discrete_Type (Entity (Constr)) 524 or else Is_OK_Static_Subtype (Entity (Constr)); 525 end if; 526 527 elsif Nkind (Constr) = N_Range then 528 return 529 Is_OK_Static_Expression (Low_Bound (Constr)) 530 and then 531 Is_OK_Static_Expression (High_Bound (Constr)); 532 533 elsif Nkind (Constr) = N_Attribute_Reference 534 and then Attribute_Name (Constr) = Name_Range 535 then 536 return 537 Is_OK_Static_Expression 538 (Type_Low_Bound (Etype (Prefix (Constr)))) 539 and then 540 Is_OK_Static_Expression 541 (Type_High_Bound (Etype (Prefix (Constr)))); 542 end if; 543 544 return 545 not Present (Etype (Constr)) -- previous error 546 or else not Is_Discrete_Type (Etype (Constr)) 547 or else Is_OK_Static_Expression (Constr); 548 549 when N_Discriminant_Association => 550 return All_Composite_Constraints_Static (Expression (Constr)); 551 552 when N_Range_Constraint => 553 return 554 All_Composite_Constraints_Static (Range_Expression (Constr)); 555 556 when N_Index_Or_Discriminant_Constraint => 557 declare 558 One_Cstr : Entity_Id; 559 begin 560 One_Cstr := First (Constraints (Constr)); 561 while Present (One_Cstr) loop 562 if not All_Composite_Constraints_Static (One_Cstr) then 563 return False; 564 end if; 565 566 Next (One_Cstr); 567 end loop; 568 end; 569 570 return True; 571 572 when N_Subtype_Indication => 573 return 574 All_Composite_Constraints_Static (Subtype_Mark (Constr)) 575 and then 576 All_Composite_Constraints_Static (Constraint (Constr)); 577 578 when others => 579 raise Program_Error; 580 end case; 581 end All_Composite_Constraints_Static; 582 583 ------------------------ 584 -- Append_Entity_Name -- 585 ------------------------ 586 587 procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is 588 Temp : Bounded_String; 589 590 procedure Inner (E : Entity_Id); 591 -- Inner recursive routine, keep outer routine nonrecursive to ease 592 -- debugging when we get strange results from this routine. 593 594 ----------- 595 -- Inner -- 596 ----------- 597 598 procedure Inner (E : Entity_Id) is 599 Scop : Node_Id; 600 601 begin 602 -- If entity has an internal name, skip by it, and print its scope. 603 -- Note that we strip a final R from the name before the test; this 604 -- is needed for some cases of instantiations. 605 606 declare 607 E_Name : Bounded_String; 608 609 begin 610 Append (E_Name, Chars (E)); 611 612 if E_Name.Chars (E_Name.Length) = 'R' then 613 E_Name.Length := E_Name.Length - 1; 614 end if; 615 616 if Is_Internal_Name (E_Name) then 617 Inner (Scope (E)); 618 return; 619 end if; 620 end; 621 622 Scop := Scope (E); 623 624 -- Just print entity name if its scope is at the outer level 625 626 if Scop = Standard_Standard then 627 null; 628 629 -- If scope comes from source, write scope and entity 630 631 elsif Comes_From_Source (Scop) then 632 Append_Entity_Name (Temp, Scop); 633 Append (Temp, '.'); 634 635 -- If in wrapper package skip past it 636 637 elsif Present (Scop) and then Is_Wrapper_Package (Scop) then 638 Append_Entity_Name (Temp, Scope (Scop)); 639 Append (Temp, '.'); 640 641 -- Otherwise nothing to output (happens in unnamed block statements) 642 643 else 644 null; 645 end if; 646 647 -- Output the name 648 649 declare 650 E_Name : Bounded_String; 651 652 begin 653 Append_Unqualified_Decoded (E_Name, Chars (E)); 654 655 -- Remove trailing upper-case letters from the name (useful for 656 -- dealing with some cases of internal names generated in the case 657 -- of references from within a generic). 658 659 while E_Name.Length > 1 660 and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z' 661 loop 662 E_Name.Length := E_Name.Length - 1; 663 end loop; 664 665 -- Adjust casing appropriately (gets name from source if possible) 666 667 Adjust_Name_Case (E_Name, Sloc (E)); 668 Append (Temp, E_Name); 669 end; 670 end Inner; 671 672 -- Start of processing for Append_Entity_Name 673 674 begin 675 Inner (E); 676 Append (Buf, Temp); 677 end Append_Entity_Name; 678 679 --------------------------------- 680 -- Append_Inherited_Subprogram -- 681 --------------------------------- 682 683 procedure Append_Inherited_Subprogram (S : Entity_Id) is 684 Par : constant Entity_Id := Alias (S); 685 -- The parent subprogram 686 687 Scop : constant Entity_Id := Scope (Par); 688 -- The scope of definition of the parent subprogram 689 690 Typ : constant Entity_Id := Defining_Entity (Parent (S)); 691 -- The derived type of which S is a primitive operation 692 693 Decl : Node_Id; 694 Next_E : Entity_Id; 695 696 begin 697 if Ekind (Current_Scope) = E_Package 698 and then In_Private_Part (Current_Scope) 699 and then Has_Private_Declaration (Typ) 700 and then Is_Tagged_Type (Typ) 701 and then Scop = Current_Scope 702 then 703 -- The inherited operation is available at the earliest place after 704 -- the derived type declaration ( RM 7.3.1 (6/1)). This is only 705 -- relevant for type extensions. If the parent operation appears 706 -- after the type extension, the operation is not visible. 707 708 Decl := First 709 (Visible_Declarations 710 (Package_Specification (Current_Scope))); 711 while Present (Decl) loop 712 if Nkind (Decl) = N_Private_Extension_Declaration 713 and then Defining_Entity (Decl) = Typ 714 then 715 if Sloc (Decl) > Sloc (Par) then 716 Next_E := Next_Entity (Par); 717 Set_Next_Entity (Par, S); 718 Set_Next_Entity (S, Next_E); 719 return; 720 721 else 722 exit; 723 end if; 724 end if; 725 726 Next (Decl); 727 end loop; 728 end if; 729 730 -- If partial view is not a type extension, or it appears before the 731 -- subprogram declaration, insert normally at end of entity list. 732 733 Append_Entity (S, Current_Scope); 734 end Append_Inherited_Subprogram; 735 736 ----------------------------------------- 737 -- Apply_Compile_Time_Constraint_Error -- 738 ----------------------------------------- 739 740 procedure Apply_Compile_Time_Constraint_Error 741 (N : Node_Id; 742 Msg : String; 743 Reason : RT_Exception_Code; 744 Ent : Entity_Id := Empty; 745 Typ : Entity_Id := Empty; 746 Loc : Source_Ptr := No_Location; 747 Rep : Boolean := True; 748 Warn : Boolean := False) 749 is 750 Stat : constant Boolean := Is_Static_Expression (N); 751 R_Stat : constant Node_Id := 752 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason); 753 Rtyp : Entity_Id; 754 755 begin 756 if No (Typ) then 757 Rtyp := Etype (N); 758 else 759 Rtyp := Typ; 760 end if; 761 762 Discard_Node 763 (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn)); 764 765 -- In GNATprove mode, do not replace the node with an exception raised. 766 -- In such a case, either the call to Compile_Time_Constraint_Error 767 -- issues an error which stops analysis, or it issues a warning in 768 -- a few cases where a suitable check flag is set for GNATprove to 769 -- generate a check message. 770 771 if not Rep or GNATprove_Mode then 772 return; 773 end if; 774 775 -- Now we replace the node by an N_Raise_Constraint_Error node 776 -- This does not need reanalyzing, so set it as analyzed now. 777 778 Rewrite (N, R_Stat); 779 Set_Analyzed (N, True); 780 781 Set_Etype (N, Rtyp); 782 Set_Raises_Constraint_Error (N); 783 784 -- Now deal with possible local raise handling 785 786 Possible_Local_Raise (N, Standard_Constraint_Error); 787 788 -- If the original expression was marked as static, the result is 789 -- still marked as static, but the Raises_Constraint_Error flag is 790 -- always set so that further static evaluation is not attempted. 791 792 if Stat then 793 Set_Is_Static_Expression (N); 794 end if; 795 end Apply_Compile_Time_Constraint_Error; 796 797 --------------------------- 798 -- Async_Readers_Enabled -- 799 --------------------------- 800 801 function Async_Readers_Enabled (Id : Entity_Id) return Boolean is 802 begin 803 return Has_Enabled_Property (Id, Name_Async_Readers); 804 end Async_Readers_Enabled; 805 806 --------------------------- 807 -- Async_Writers_Enabled -- 808 --------------------------- 809 810 function Async_Writers_Enabled (Id : Entity_Id) return Boolean is 811 begin 812 return Has_Enabled_Property (Id, Name_Async_Writers); 813 end Async_Writers_Enabled; 814 815 -------------------------------------- 816 -- Available_Full_View_Of_Component -- 817 -------------------------------------- 818 819 function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is 820 ST : constant Entity_Id := Scope (T); 821 SCT : constant Entity_Id := Scope (Component_Type (T)); 822 begin 823 return In_Open_Scopes (ST) 824 and then In_Open_Scopes (SCT) 825 and then Scope_Depth (ST) >= Scope_Depth (SCT); 826 end Available_Full_View_Of_Component; 827 828 ------------------- 829 -- Bad_Attribute -- 830 ------------------- 831 832 procedure Bad_Attribute 833 (N : Node_Id; 834 Nam : Name_Id; 835 Warn : Boolean := False) 836 is 837 begin 838 Error_Msg_Warn := Warn; 839 Error_Msg_N ("unrecognized attribute&<<", N); 840 841 -- Check for possible misspelling 842 843 Error_Msg_Name_1 := First_Attribute_Name; 844 while Error_Msg_Name_1 <= Last_Attribute_Name loop 845 if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then 846 Error_Msg_N -- CODEFIX 847 ("\possible misspelling of %<<", N); 848 exit; 849 end if; 850 851 Error_Msg_Name_1 := Error_Msg_Name_1 + 1; 852 end loop; 853 end Bad_Attribute; 854 855 -------------------------------- 856 -- Bad_Predicated_Subtype_Use -- 857 -------------------------------- 858 859 procedure Bad_Predicated_Subtype_Use 860 (Msg : String; 861 N : Node_Id; 862 Typ : Entity_Id; 863 Suggest_Static : Boolean := False) 864 is 865 Gen : Entity_Id; 866 867 begin 868 -- Avoid cascaded errors 869 870 if Error_Posted (N) then 871 return; 872 end if; 873 874 if Inside_A_Generic then 875 Gen := Current_Scope; 876 while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop 877 Gen := Scope (Gen); 878 end loop; 879 880 if No (Gen) then 881 return; 882 end if; 883 884 if Is_Generic_Formal (Typ) and then Is_Discrete_Type (Typ) then 885 Set_No_Predicate_On_Actual (Typ); 886 end if; 887 888 elsif Has_Predicates (Typ) then 889 if Is_Generic_Actual_Type (Typ) then 890 891 -- The restriction on loop parameters is only that the type 892 -- should have no dynamic predicates. 893 894 if Nkind (Parent (N)) = N_Loop_Parameter_Specification 895 and then not Has_Dynamic_Predicate_Aspect (Typ) 896 and then Is_OK_Static_Subtype (Typ) 897 then 898 return; 899 end if; 900 901 Gen := Current_Scope; 902 while not Is_Generic_Instance (Gen) loop 903 Gen := Scope (Gen); 904 end loop; 905 906 pragma Assert (Present (Gen)); 907 908 if Ekind (Gen) = E_Package and then In_Package_Body (Gen) then 909 Error_Msg_Warn := SPARK_Mode /= On; 910 Error_Msg_FE (Msg & "<<", N, Typ); 911 Error_Msg_F ("\Program_Error [<<", N); 912 913 Insert_Action (N, 914 Make_Raise_Program_Error (Sloc (N), 915 Reason => PE_Bad_Predicated_Generic_Type)); 916 917 else 918 Error_Msg_FE (Msg & "<<", N, Typ); 919 end if; 920 921 else 922 Error_Msg_FE (Msg, N, Typ); 923 end if; 924 925 -- Emit an optional suggestion on how to remedy the error if the 926 -- context warrants it. 927 928 if Suggest_Static and then Has_Static_Predicate (Typ) then 929 Error_Msg_FE ("\predicate of & should be marked static", N, Typ); 930 end if; 931 end if; 932 end Bad_Predicated_Subtype_Use; 933 934 ----------------------------------------- 935 -- Bad_Unordered_Enumeration_Reference -- 936 ----------------------------------------- 937 938 function Bad_Unordered_Enumeration_Reference 939 (N : Node_Id; 940 T : Entity_Id) return Boolean 941 is 942 begin 943 return Is_Enumeration_Type (T) 944 and then Warn_On_Unordered_Enumeration_Type 945 and then not Is_Generic_Type (T) 946 and then Comes_From_Source (N) 947 and then not Has_Pragma_Ordered (T) 948 and then not In_Same_Extended_Unit (N, T); 949 end Bad_Unordered_Enumeration_Reference; 950 951 ---------------------------- 952 -- Begin_Keyword_Location -- 953 ---------------------------- 954 955 function Begin_Keyword_Location (N : Node_Id) return Source_Ptr is 956 HSS : Node_Id; 957 958 begin 959 pragma Assert (Nkind_In (N, N_Block_Statement, 960 N_Entry_Body, 961 N_Package_Body, 962 N_Subprogram_Body, 963 N_Task_Body)); 964 965 HSS := Handled_Statement_Sequence (N); 966 967 -- When the handled sequence of statements comes from source, the 968 -- location of the "begin" keyword is that of the sequence itself. 969 -- Note that an internal construct may inherit a source sequence. 970 971 if Comes_From_Source (HSS) then 972 return Sloc (HSS); 973 974 -- The parser generates an internal handled sequence of statements to 975 -- capture the location of the "begin" keyword if present in the source. 976 -- Since there are no source statements, the location of the "begin" 977 -- keyword is effectively that of the "end" keyword. 978 979 elsif Comes_From_Source (N) then 980 return Sloc (HSS); 981 982 -- Otherwise the construct is internal and should carry the location of 983 -- the original construct which prompted its creation. 984 985 else 986 return Sloc (N); 987 end if; 988 end Begin_Keyword_Location; 989 990 -------------------------- 991 -- Build_Actual_Subtype -- 992 -------------------------- 993 994 function Build_Actual_Subtype 995 (T : Entity_Id; 996 N : Node_Or_Entity_Id) return Node_Id 997 is 998 Loc : Source_Ptr; 999 -- Normally Sloc (N), but may point to corresponding body in some cases 1000 1001 Constraints : List_Id; 1002 Decl : Node_Id; 1003 Discr : Entity_Id; 1004 Hi : Node_Id; 1005 Lo : Node_Id; 1006 Subt : Entity_Id; 1007 Disc_Type : Entity_Id; 1008 Obj : Node_Id; 1009 1010 begin 1011 Loc := Sloc (N); 1012 1013 if Nkind (N) = N_Defining_Identifier then 1014 Obj := New_Occurrence_Of (N, Loc); 1015 1016 -- If this is a formal parameter of a subprogram declaration, and 1017 -- we are compiling the body, we want the declaration for the 1018 -- actual subtype to carry the source position of the body, to 1019 -- prevent anomalies in gdb when stepping through the code. 1020 1021 if Is_Formal (N) then 1022 declare 1023 Decl : constant Node_Id := Unit_Declaration_Node (Scope (N)); 1024 begin 1025 if Nkind (Decl) = N_Subprogram_Declaration 1026 and then Present (Corresponding_Body (Decl)) 1027 then 1028 Loc := Sloc (Corresponding_Body (Decl)); 1029 end if; 1030 end; 1031 end if; 1032 1033 else 1034 Obj := N; 1035 end if; 1036 1037 if Is_Array_Type (T) then 1038 Constraints := New_List; 1039 for J in 1 .. Number_Dimensions (T) loop 1040 1041 -- Build an array subtype declaration with the nominal subtype and 1042 -- the bounds of the actual. Add the declaration in front of the 1043 -- local declarations for the subprogram, for analysis before any 1044 -- reference to the formal in the body. 1045 1046 Lo := 1047 Make_Attribute_Reference (Loc, 1048 Prefix => 1049 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), 1050 Attribute_Name => Name_First, 1051 Expressions => New_List ( 1052 Make_Integer_Literal (Loc, J))); 1053 1054 Hi := 1055 Make_Attribute_Reference (Loc, 1056 Prefix => 1057 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), 1058 Attribute_Name => Name_Last, 1059 Expressions => New_List ( 1060 Make_Integer_Literal (Loc, J))); 1061 1062 Append (Make_Range (Loc, Lo, Hi), Constraints); 1063 end loop; 1064 1065 -- If the type has unknown discriminants there is no constrained 1066 -- subtype to build. This is never called for a formal or for a 1067 -- lhs, so returning the type is ok ??? 1068 1069 elsif Has_Unknown_Discriminants (T) then 1070 return T; 1071 1072 else 1073 Constraints := New_List; 1074 1075 -- Type T is a generic derived type, inherit the discriminants from 1076 -- the parent type. 1077 1078 if Is_Private_Type (T) 1079 and then No (Full_View (T)) 1080 1081 -- T was flagged as an error if it was declared as a formal 1082 -- derived type with known discriminants. In this case there 1083 -- is no need to look at the parent type since T already carries 1084 -- its own discriminants. 1085 1086 and then not Error_Posted (T) 1087 then 1088 Disc_Type := Etype (Base_Type (T)); 1089 else 1090 Disc_Type := T; 1091 end if; 1092 1093 Discr := First_Discriminant (Disc_Type); 1094 while Present (Discr) loop 1095 Append_To (Constraints, 1096 Make_Selected_Component (Loc, 1097 Prefix => 1098 Duplicate_Subexpr_No_Checks (Obj), 1099 Selector_Name => New_Occurrence_Of (Discr, Loc))); 1100 Next_Discriminant (Discr); 1101 end loop; 1102 end if; 1103 1104 Subt := Make_Temporary (Loc, 'S', Related_Node => N); 1105 Set_Is_Internal (Subt); 1106 1107 Decl := 1108 Make_Subtype_Declaration (Loc, 1109 Defining_Identifier => Subt, 1110 Subtype_Indication => 1111 Make_Subtype_Indication (Loc, 1112 Subtype_Mark => New_Occurrence_Of (T, Loc), 1113 Constraint => 1114 Make_Index_Or_Discriminant_Constraint (Loc, 1115 Constraints => Constraints))); 1116 1117 Mark_Rewrite_Insertion (Decl); 1118 return Decl; 1119 end Build_Actual_Subtype; 1120 1121 --------------------------------------- 1122 -- Build_Actual_Subtype_Of_Component -- 1123 --------------------------------------- 1124 1125 function Build_Actual_Subtype_Of_Component 1126 (T : Entity_Id; 1127 N : Node_Id) return Node_Id 1128 is 1129 Loc : constant Source_Ptr := Sloc (N); 1130 P : constant Node_Id := Prefix (N); 1131 D : Elmt_Id; 1132 Id : Node_Id; 1133 Index_Typ : Entity_Id; 1134 1135 Desig_Typ : Entity_Id; 1136 -- This is either a copy of T, or if T is an access type, then it is 1137 -- the directly designated type of this access type. 1138 1139 function Build_Actual_Array_Constraint return List_Id; 1140 -- If one or more of the bounds of the component depends on 1141 -- discriminants, build actual constraint using the discriminants 1142 -- of the prefix. 1143 1144 function Build_Actual_Record_Constraint return List_Id; 1145 -- Similar to previous one, for discriminated components constrained 1146 -- by the discriminant of the enclosing object. 1147 1148 ----------------------------------- 1149 -- Build_Actual_Array_Constraint -- 1150 ----------------------------------- 1151 1152 function Build_Actual_Array_Constraint return List_Id is 1153 Constraints : constant List_Id := New_List; 1154 Indx : Node_Id; 1155 Hi : Node_Id; 1156 Lo : Node_Id; 1157 Old_Hi : Node_Id; 1158 Old_Lo : Node_Id; 1159 1160 begin 1161 Indx := First_Index (Desig_Typ); 1162 while Present (Indx) loop 1163 Old_Lo := Type_Low_Bound (Etype (Indx)); 1164 Old_Hi := Type_High_Bound (Etype (Indx)); 1165 1166 if Denotes_Discriminant (Old_Lo) then 1167 Lo := 1168 Make_Selected_Component (Loc, 1169 Prefix => New_Copy_Tree (P), 1170 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc)); 1171 1172 else 1173 Lo := New_Copy_Tree (Old_Lo); 1174 1175 -- The new bound will be reanalyzed in the enclosing 1176 -- declaration. For literal bounds that come from a type 1177 -- declaration, the type of the context must be imposed, so 1178 -- insure that analysis will take place. For non-universal 1179 -- types this is not strictly necessary. 1180 1181 Set_Analyzed (Lo, False); 1182 end if; 1183 1184 if Denotes_Discriminant (Old_Hi) then 1185 Hi := 1186 Make_Selected_Component (Loc, 1187 Prefix => New_Copy_Tree (P), 1188 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc)); 1189 1190 else 1191 Hi := New_Copy_Tree (Old_Hi); 1192 Set_Analyzed (Hi, False); 1193 end if; 1194 1195 Append (Make_Range (Loc, Lo, Hi), Constraints); 1196 Next_Index (Indx); 1197 end loop; 1198 1199 return Constraints; 1200 end Build_Actual_Array_Constraint; 1201 1202 ------------------------------------ 1203 -- Build_Actual_Record_Constraint -- 1204 ------------------------------------ 1205 1206 function Build_Actual_Record_Constraint return List_Id is 1207 Constraints : constant List_Id := New_List; 1208 D : Elmt_Id; 1209 D_Val : Node_Id; 1210 1211 begin 1212 D := First_Elmt (Discriminant_Constraint (Desig_Typ)); 1213 while Present (D) loop 1214 if Denotes_Discriminant (Node (D)) then 1215 D_Val := Make_Selected_Component (Loc, 1216 Prefix => New_Copy_Tree (P), 1217 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc)); 1218 1219 else 1220 D_Val := New_Copy_Tree (Node (D)); 1221 end if; 1222 1223 Append (D_Val, Constraints); 1224 Next_Elmt (D); 1225 end loop; 1226 1227 return Constraints; 1228 end Build_Actual_Record_Constraint; 1229 1230 -- Start of processing for Build_Actual_Subtype_Of_Component 1231 1232 begin 1233 -- Why the test for Spec_Expression mode here??? 1234 1235 if In_Spec_Expression then 1236 return Empty; 1237 1238 -- More comments for the rest of this body would be good ??? 1239 1240 elsif Nkind (N) = N_Explicit_Dereference then 1241 if Is_Composite_Type (T) 1242 and then not Is_Constrained (T) 1243 and then not (Is_Class_Wide_Type (T) 1244 and then Is_Constrained (Root_Type (T))) 1245 and then not Has_Unknown_Discriminants (T) 1246 then 1247 -- If the type of the dereference is already constrained, it is an 1248 -- actual subtype. 1249 1250 if Is_Array_Type (Etype (N)) 1251 and then Is_Constrained (Etype (N)) 1252 then 1253 return Empty; 1254 else 1255 Remove_Side_Effects (P); 1256 return Build_Actual_Subtype (T, N); 1257 end if; 1258 else 1259 return Empty; 1260 end if; 1261 end if; 1262 1263 if Ekind (T) = E_Access_Subtype then 1264 Desig_Typ := Designated_Type (T); 1265 else 1266 Desig_Typ := T; 1267 end if; 1268 1269 if Ekind (Desig_Typ) = E_Array_Subtype then 1270 Id := First_Index (Desig_Typ); 1271 while Present (Id) loop 1272 Index_Typ := Underlying_Type (Etype (Id)); 1273 1274 if Denotes_Discriminant (Type_Low_Bound (Index_Typ)) 1275 or else 1276 Denotes_Discriminant (Type_High_Bound (Index_Typ)) 1277 then 1278 Remove_Side_Effects (P); 1279 return 1280 Build_Component_Subtype 1281 (Build_Actual_Array_Constraint, Loc, Base_Type (T)); 1282 end if; 1283 1284 Next_Index (Id); 1285 end loop; 1286 1287 elsif Is_Composite_Type (Desig_Typ) 1288 and then Has_Discriminants (Desig_Typ) 1289 and then not Has_Unknown_Discriminants (Desig_Typ) 1290 then 1291 if Is_Private_Type (Desig_Typ) 1292 and then No (Discriminant_Constraint (Desig_Typ)) 1293 then 1294 Desig_Typ := Full_View (Desig_Typ); 1295 end if; 1296 1297 D := First_Elmt (Discriminant_Constraint (Desig_Typ)); 1298 while Present (D) loop 1299 if Denotes_Discriminant (Node (D)) then 1300 Remove_Side_Effects (P); 1301 return 1302 Build_Component_Subtype ( 1303 Build_Actual_Record_Constraint, Loc, Base_Type (T)); 1304 end if; 1305 1306 Next_Elmt (D); 1307 end loop; 1308 end if; 1309 1310 -- If none of the above, the actual and nominal subtypes are the same 1311 1312 return Empty; 1313 end Build_Actual_Subtype_Of_Component; 1314 1315 --------------------------------- 1316 -- Build_Class_Wide_Clone_Body -- 1317 --------------------------------- 1318 1319 procedure Build_Class_Wide_Clone_Body 1320 (Spec_Id : Entity_Id; 1321 Bod : Node_Id) 1322 is 1323 Loc : constant Source_Ptr := Sloc (Bod); 1324 Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id); 1325 Clone_Body : Node_Id; 1326 1327 begin 1328 -- The declaration of the class-wide clone was created when the 1329 -- corresponding class-wide condition was analyzed. 1330 1331 Clone_Body := 1332 Make_Subprogram_Body (Loc, 1333 Specification => 1334 Copy_Subprogram_Spec (Parent (Clone_Id)), 1335 Declarations => Declarations (Bod), 1336 Handled_Statement_Sequence => Handled_Statement_Sequence (Bod)); 1337 1338 -- The new operation is internal and overriding indicators do not apply 1339 -- (the original primitive may have carried one). 1340 1341 Set_Must_Override (Specification (Clone_Body), False); 1342 Insert_Before (Bod, Clone_Body); 1343 Analyze (Clone_Body); 1344 end Build_Class_Wide_Clone_Body; 1345 1346 --------------------------------- 1347 -- Build_Class_Wide_Clone_Call -- 1348 --------------------------------- 1349 1350 function Build_Class_Wide_Clone_Call 1351 (Loc : Source_Ptr; 1352 Decls : List_Id; 1353 Spec_Id : Entity_Id; 1354 Spec : Node_Id) return Node_Id 1355 is 1356 Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id); 1357 Par_Type : constant Entity_Id := Find_Dispatching_Type (Spec_Id); 1358 1359 Actuals : List_Id; 1360 Call : Node_Id; 1361 Formal : Entity_Id; 1362 New_Body : Node_Id; 1363 New_F_Spec : Entity_Id; 1364 New_Formal : Entity_Id; 1365 1366 begin 1367 Actuals := Empty_List; 1368 Formal := First_Formal (Spec_Id); 1369 New_F_Spec := First (Parameter_Specifications (Spec)); 1370 1371 -- Build parameter association for call to class-wide clone. 1372 1373 while Present (Formal) loop 1374 New_Formal := Defining_Identifier (New_F_Spec); 1375 1376 -- If controlling argument and operation is inherited, add conversion 1377 -- to parent type for the call. 1378 1379 if Etype (Formal) = Par_Type 1380 and then not Is_Empty_List (Decls) 1381 then 1382 Append_To (Actuals, 1383 Make_Type_Conversion (Loc, 1384 New_Occurrence_Of (Par_Type, Loc), 1385 New_Occurrence_Of (New_Formal, Loc))); 1386 1387 else 1388 Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc)); 1389 end if; 1390 1391 Next_Formal (Formal); 1392 Next (New_F_Spec); 1393 end loop; 1394 1395 if Ekind (Spec_Id) = E_Procedure then 1396 Call := 1397 Make_Procedure_Call_Statement (Loc, 1398 Name => New_Occurrence_Of (Clone_Id, Loc), 1399 Parameter_Associations => Actuals); 1400 else 1401 Call := 1402 Make_Simple_Return_Statement (Loc, 1403 Expression => 1404 Make_Function_Call (Loc, 1405 Name => New_Occurrence_Of (Clone_Id, Loc), 1406 Parameter_Associations => Actuals)); 1407 end if; 1408 1409 New_Body := 1410 Make_Subprogram_Body (Loc, 1411 Specification => 1412 Copy_Subprogram_Spec (Spec), 1413 Declarations => Decls, 1414 Handled_Statement_Sequence => 1415 Make_Handled_Sequence_Of_Statements (Loc, 1416 Statements => New_List (Call), 1417 End_Label => Make_Identifier (Loc, Chars (Spec_Id)))); 1418 1419 return New_Body; 1420 end Build_Class_Wide_Clone_Call; 1421 1422 --------------------------------- 1423 -- Build_Class_Wide_Clone_Decl -- 1424 --------------------------------- 1425 1426 procedure Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id) is 1427 Loc : constant Source_Ptr := Sloc (Spec_Id); 1428 Clone_Id : constant Entity_Id := 1429 Make_Defining_Identifier (Loc, 1430 New_External_Name (Chars (Spec_Id), Suffix => "CL")); 1431 1432 Decl : Node_Id; 1433 Spec : Node_Id; 1434 1435 begin 1436 Spec := Copy_Subprogram_Spec (Parent (Spec_Id)); 1437 Set_Must_Override (Spec, False); 1438 Set_Must_Not_Override (Spec, False); 1439 Set_Defining_Unit_Name (Spec, Clone_Id); 1440 1441 Decl := Make_Subprogram_Declaration (Loc, Spec); 1442 Append (Decl, List_Containing (Unit_Declaration_Node (Spec_Id))); 1443 1444 -- Link clone to original subprogram, for use when building body and 1445 -- wrapper call to inherited operation. 1446 1447 Set_Class_Wide_Clone (Spec_Id, Clone_Id); 1448 end Build_Class_Wide_Clone_Decl; 1449 1450 ----------------------------- 1451 -- Build_Component_Subtype -- 1452 ----------------------------- 1453 1454 function Build_Component_Subtype 1455 (C : List_Id; 1456 Loc : Source_Ptr; 1457 T : Entity_Id) return Node_Id 1458 is 1459 Subt : Entity_Id; 1460 Decl : Node_Id; 1461 1462 begin 1463 -- Unchecked_Union components do not require component subtypes 1464 1465 if Is_Unchecked_Union (T) then 1466 return Empty; 1467 end if; 1468 1469 Subt := Make_Temporary (Loc, 'S'); 1470 Set_Is_Internal (Subt); 1471 1472 Decl := 1473 Make_Subtype_Declaration (Loc, 1474 Defining_Identifier => Subt, 1475 Subtype_Indication => 1476 Make_Subtype_Indication (Loc, 1477 Subtype_Mark => New_Occurrence_Of (Base_Type (T), Loc), 1478 Constraint => 1479 Make_Index_Or_Discriminant_Constraint (Loc, 1480 Constraints => C))); 1481 1482 Mark_Rewrite_Insertion (Decl); 1483 return Decl; 1484 end Build_Component_Subtype; 1485 1486 --------------------------- 1487 -- Build_Default_Subtype -- 1488 --------------------------- 1489 1490 function Build_Default_Subtype 1491 (T : Entity_Id; 1492 N : Node_Id) return Entity_Id 1493 is 1494 Loc : constant Source_Ptr := Sloc (N); 1495 Disc : Entity_Id; 1496 1497 Bas : Entity_Id; 1498 -- The base type that is to be constrained by the defaults 1499 1500 begin 1501 if not Has_Discriminants (T) or else Is_Constrained (T) then 1502 return T; 1503 end if; 1504 1505 Bas := Base_Type (T); 1506 1507 -- If T is non-private but its base type is private, this is the 1508 -- completion of a subtype declaration whose parent type is private 1509 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants 1510 -- are to be found in the full view of the base. Check that the private 1511 -- status of T and its base differ. 1512 1513 if Is_Private_Type (Bas) 1514 and then not Is_Private_Type (T) 1515 and then Present (Full_View (Bas)) 1516 then 1517 Bas := Full_View (Bas); 1518 end if; 1519 1520 Disc := First_Discriminant (T); 1521 1522 if No (Discriminant_Default_Value (Disc)) then 1523 return T; 1524 end if; 1525 1526 declare 1527 Act : constant Entity_Id := Make_Temporary (Loc, 'S'); 1528 Constraints : constant List_Id := New_List; 1529 Decl : Node_Id; 1530 1531 begin 1532 while Present (Disc) loop 1533 Append_To (Constraints, 1534 New_Copy_Tree (Discriminant_Default_Value (Disc))); 1535 Next_Discriminant (Disc); 1536 end loop; 1537 1538 Decl := 1539 Make_Subtype_Declaration (Loc, 1540 Defining_Identifier => Act, 1541 Subtype_Indication => 1542 Make_Subtype_Indication (Loc, 1543 Subtype_Mark => New_Occurrence_Of (Bas, Loc), 1544 Constraint => 1545 Make_Index_Or_Discriminant_Constraint (Loc, 1546 Constraints => Constraints))); 1547 1548 Insert_Action (N, Decl); 1549 1550 -- If the context is a component declaration the subtype declaration 1551 -- will be analyzed when the enclosing type is frozen, otherwise do 1552 -- it now. 1553 1554 if Ekind (Current_Scope) /= E_Record_Type then 1555 Analyze (Decl); 1556 end if; 1557 1558 return Act; 1559 end; 1560 end Build_Default_Subtype; 1561 1562 -------------------------------------------- 1563 -- Build_Discriminal_Subtype_Of_Component -- 1564 -------------------------------------------- 1565 1566 function Build_Discriminal_Subtype_Of_Component 1567 (T : Entity_Id) return Node_Id 1568 is 1569 Loc : constant Source_Ptr := Sloc (T); 1570 D : Elmt_Id; 1571 Id : Node_Id; 1572 1573 function Build_Discriminal_Array_Constraint return List_Id; 1574 -- If one or more of the bounds of the component depends on 1575 -- discriminants, build actual constraint using the discriminants 1576 -- of the prefix. 1577 1578 function Build_Discriminal_Record_Constraint return List_Id; 1579 -- Similar to previous one, for discriminated components constrained by 1580 -- the discriminant of the enclosing object. 1581 1582 ---------------------------------------- 1583 -- Build_Discriminal_Array_Constraint -- 1584 ---------------------------------------- 1585 1586 function Build_Discriminal_Array_Constraint return List_Id is 1587 Constraints : constant List_Id := New_List; 1588 Indx : Node_Id; 1589 Hi : Node_Id; 1590 Lo : Node_Id; 1591 Old_Hi : Node_Id; 1592 Old_Lo : Node_Id; 1593 1594 begin 1595 Indx := First_Index (T); 1596 while Present (Indx) loop 1597 Old_Lo := Type_Low_Bound (Etype (Indx)); 1598 Old_Hi := Type_High_Bound (Etype (Indx)); 1599 1600 if Denotes_Discriminant (Old_Lo) then 1601 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc); 1602 1603 else 1604 Lo := New_Copy_Tree (Old_Lo); 1605 end if; 1606 1607 if Denotes_Discriminant (Old_Hi) then 1608 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc); 1609 1610 else 1611 Hi := New_Copy_Tree (Old_Hi); 1612 end if; 1613 1614 Append (Make_Range (Loc, Lo, Hi), Constraints); 1615 Next_Index (Indx); 1616 end loop; 1617 1618 return Constraints; 1619 end Build_Discriminal_Array_Constraint; 1620 1621 ----------------------------------------- 1622 -- Build_Discriminal_Record_Constraint -- 1623 ----------------------------------------- 1624 1625 function Build_Discriminal_Record_Constraint return List_Id is 1626 Constraints : constant List_Id := New_List; 1627 D : Elmt_Id; 1628 D_Val : Node_Id; 1629 1630 begin 1631 D := First_Elmt (Discriminant_Constraint (T)); 1632 while Present (D) loop 1633 if Denotes_Discriminant (Node (D)) then 1634 D_Val := 1635 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc); 1636 else 1637 D_Val := New_Copy_Tree (Node (D)); 1638 end if; 1639 1640 Append (D_Val, Constraints); 1641 Next_Elmt (D); 1642 end loop; 1643 1644 return Constraints; 1645 end Build_Discriminal_Record_Constraint; 1646 1647 -- Start of processing for Build_Discriminal_Subtype_Of_Component 1648 1649 begin 1650 if Ekind (T) = E_Array_Subtype then 1651 Id := First_Index (T); 1652 while Present (Id) loop 1653 if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) 1654 or else 1655 Denotes_Discriminant (Type_High_Bound (Etype (Id))) 1656 then 1657 return Build_Component_Subtype 1658 (Build_Discriminal_Array_Constraint, Loc, T); 1659 end if; 1660 1661 Next_Index (Id); 1662 end loop; 1663 1664 elsif Ekind (T) = E_Record_Subtype 1665 and then Has_Discriminants (T) 1666 and then not Has_Unknown_Discriminants (T) 1667 then 1668 D := First_Elmt (Discriminant_Constraint (T)); 1669 while Present (D) loop 1670 if Denotes_Discriminant (Node (D)) then 1671 return Build_Component_Subtype 1672 (Build_Discriminal_Record_Constraint, Loc, T); 1673 end if; 1674 1675 Next_Elmt (D); 1676 end loop; 1677 end if; 1678 1679 -- If none of the above, the actual and nominal subtypes are the same 1680 1681 return Empty; 1682 end Build_Discriminal_Subtype_Of_Component; 1683 1684 ------------------------------ 1685 -- Build_Elaboration_Entity -- 1686 ------------------------------ 1687 1688 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is 1689 Loc : constant Source_Ptr := Sloc (N); 1690 Decl : Node_Id; 1691 Elab_Ent : Entity_Id; 1692 1693 procedure Set_Package_Name (Ent : Entity_Id); 1694 -- Given an entity, sets the fully qualified name of the entity in 1695 -- Name_Buffer, with components separated by double underscores. This 1696 -- is a recursive routine that climbs the scope chain to Standard. 1697 1698 ---------------------- 1699 -- Set_Package_Name -- 1700 ---------------------- 1701 1702 procedure Set_Package_Name (Ent : Entity_Id) is 1703 begin 1704 if Scope (Ent) /= Standard_Standard then 1705 Set_Package_Name (Scope (Ent)); 1706 1707 declare 1708 Nam : constant String := Get_Name_String (Chars (Ent)); 1709 begin 1710 Name_Buffer (Name_Len + 1) := '_'; 1711 Name_Buffer (Name_Len + 2) := '_'; 1712 Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam; 1713 Name_Len := Name_Len + Nam'Length + 2; 1714 end; 1715 1716 else 1717 Get_Name_String (Chars (Ent)); 1718 end if; 1719 end Set_Package_Name; 1720 1721 -- Start of processing for Build_Elaboration_Entity 1722 1723 begin 1724 -- Ignore call if already constructed 1725 1726 if Present (Elaboration_Entity (Spec_Id)) then 1727 return; 1728 1729 -- Ignore in ASIS mode, elaboration entity is not in source and plays 1730 -- no role in analysis. 1731 1732 elsif ASIS_Mode then 1733 return; 1734 1735 -- Do not generate an elaboration entity in GNATprove move because the 1736 -- elaboration counter is a form of expansion. 1737 1738 elsif GNATprove_Mode then 1739 return; 1740 1741 -- See if we need elaboration entity 1742 1743 -- We always need an elaboration entity when preserving control flow, as 1744 -- we want to remain explicit about the unit's elaboration order. 1745 1746 elsif Opt.Suppress_Control_Flow_Optimizations then 1747 null; 1748 1749 -- We always need an elaboration entity for the dynamic elaboration 1750 -- model, since it is needed to properly generate the PE exception for 1751 -- access before elaboration. 1752 1753 elsif Dynamic_Elaboration_Checks then 1754 null; 1755 1756 -- For the static model, we don't need the elaboration counter if this 1757 -- unit is sure to have no elaboration code, since that means there 1758 -- is no elaboration unit to be called. Note that we can't just decide 1759 -- after the fact by looking to see whether there was elaboration code, 1760 -- because that's too late to make this decision. 1761 1762 elsif Restriction_Active (No_Elaboration_Code) then 1763 return; 1764 1765 -- Similarly, for the static model, we can skip the elaboration counter 1766 -- if we have the No_Multiple_Elaboration restriction, since for the 1767 -- static model, that's the only purpose of the counter (to avoid 1768 -- multiple elaboration). 1769 1770 elsif Restriction_Active (No_Multiple_Elaboration) then 1771 return; 1772 end if; 1773 1774 -- Here we need the elaboration entity 1775 1776 -- Construct name of elaboration entity as xxx_E, where xxx is the unit 1777 -- name with dots replaced by double underscore. We have to manually 1778 -- construct this name, since it will be elaborated in the outer scope, 1779 -- and thus will not have the unit name automatically prepended. 1780 1781 Set_Package_Name (Spec_Id); 1782 Add_Str_To_Name_Buffer ("_E"); 1783 1784 -- Create elaboration counter 1785 1786 Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find); 1787 Set_Elaboration_Entity (Spec_Id, Elab_Ent); 1788 1789 Decl := 1790 Make_Object_Declaration (Loc, 1791 Defining_Identifier => Elab_Ent, 1792 Object_Definition => 1793 New_Occurrence_Of (Standard_Short_Integer, Loc), 1794 Expression => Make_Integer_Literal (Loc, Uint_0)); 1795 1796 Push_Scope (Standard_Standard); 1797 Add_Global_Declaration (Decl); 1798 Pop_Scope; 1799 1800 -- Reset True_Constant indication, since we will indeed assign a value 1801 -- to the variable in the binder main. We also kill the Current_Value 1802 -- and Last_Assignment fields for the same reason. 1803 1804 Set_Is_True_Constant (Elab_Ent, False); 1805 Set_Current_Value (Elab_Ent, Empty); 1806 Set_Last_Assignment (Elab_Ent, Empty); 1807 1808 -- We do not want any further qualification of the name (if we did not 1809 -- do this, we would pick up the name of the generic package in the case 1810 -- of a library level generic instantiation). 1811 1812 Set_Has_Qualified_Name (Elab_Ent); 1813 Set_Has_Fully_Qualified_Name (Elab_Ent); 1814 end Build_Elaboration_Entity; 1815 1816 -------------------------------- 1817 -- Build_Explicit_Dereference -- 1818 -------------------------------- 1819 1820 procedure Build_Explicit_Dereference 1821 (Expr : Node_Id; 1822 Disc : Entity_Id) 1823 is 1824 Loc : constant Source_Ptr := Sloc (Expr); 1825 I : Interp_Index; 1826 It : Interp; 1827 1828 begin 1829 -- An entity of a type with a reference aspect is overloaded with 1830 -- both interpretations: with and without the dereference. Now that 1831 -- the dereference is made explicit, set the type of the node properly, 1832 -- to prevent anomalies in the backend. Same if the expression is an 1833 -- overloaded function call whose return type has a reference aspect. 1834 1835 if Is_Entity_Name (Expr) then 1836 Set_Etype (Expr, Etype (Entity (Expr))); 1837 1838 -- The designated entity will not be examined again when resolving 1839 -- the dereference, so generate a reference to it now. 1840 1841 Generate_Reference (Entity (Expr), Expr); 1842 1843 elsif Nkind (Expr) = N_Function_Call then 1844 1845 -- If the name of the indexing function is overloaded, locate the one 1846 -- whose return type has an implicit dereference on the desired 1847 -- discriminant, and set entity and type of function call. 1848 1849 if Is_Overloaded (Name (Expr)) then 1850 Get_First_Interp (Name (Expr), I, It); 1851 1852 while Present (It.Nam) loop 1853 if Ekind ((It.Typ)) = E_Record_Type 1854 and then First_Entity ((It.Typ)) = Disc 1855 then 1856 Set_Entity (Name (Expr), It.Nam); 1857 Set_Etype (Name (Expr), Etype (It.Nam)); 1858 exit; 1859 end if; 1860 1861 Get_Next_Interp (I, It); 1862 end loop; 1863 end if; 1864 1865 -- Set type of call from resolved function name. 1866 1867 Set_Etype (Expr, Etype (Name (Expr))); 1868 end if; 1869 1870 Set_Is_Overloaded (Expr, False); 1871 1872 -- The expression will often be a generalized indexing that yields a 1873 -- container element that is then dereferenced, in which case the 1874 -- generalized indexing call is also non-overloaded. 1875 1876 if Nkind (Expr) = N_Indexed_Component 1877 and then Present (Generalized_Indexing (Expr)) 1878 then 1879 Set_Is_Overloaded (Generalized_Indexing (Expr), False); 1880 end if; 1881 1882 Rewrite (Expr, 1883 Make_Explicit_Dereference (Loc, 1884 Prefix => 1885 Make_Selected_Component (Loc, 1886 Prefix => Relocate_Node (Expr), 1887 Selector_Name => New_Occurrence_Of (Disc, Loc)))); 1888 Set_Etype (Prefix (Expr), Etype (Disc)); 1889 Set_Etype (Expr, Designated_Type (Etype (Disc))); 1890 end Build_Explicit_Dereference; 1891 1892 --------------------------- 1893 -- Build_Overriding_Spec -- 1894 --------------------------- 1895 1896 function Build_Overriding_Spec 1897 (Op : Entity_Id; 1898 Typ : Entity_Id) return Node_Id 1899 is 1900 Loc : constant Source_Ptr := Sloc (Typ); 1901 Par_Typ : constant Entity_Id := Find_Dispatching_Type (Op); 1902 Spec : constant Node_Id := Specification (Unit_Declaration_Node (Op)); 1903 1904 Formal_Spec : Node_Id; 1905 Formal_Type : Node_Id; 1906 New_Spec : Node_Id; 1907 1908 begin 1909 New_Spec := Copy_Subprogram_Spec (Spec); 1910 1911 Formal_Spec := First (Parameter_Specifications (New_Spec)); 1912 while Present (Formal_Spec) loop 1913 Formal_Type := Parameter_Type (Formal_Spec); 1914 1915 if Is_Entity_Name (Formal_Type) 1916 and then Entity (Formal_Type) = Par_Typ 1917 then 1918 Rewrite (Formal_Type, New_Occurrence_Of (Typ, Loc)); 1919 end if; 1920 1921 -- Nothing needs to be done for access parameters 1922 1923 Next (Formal_Spec); 1924 end loop; 1925 1926 return New_Spec; 1927 end Build_Overriding_Spec; 1928 1929 ----------------------------------- 1930 -- Cannot_Raise_Constraint_Error -- 1931 ----------------------------------- 1932 1933 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is 1934 begin 1935 if Compile_Time_Known_Value (Expr) then 1936 return True; 1937 1938 elsif Do_Range_Check (Expr) then 1939 return False; 1940 1941 elsif Raises_Constraint_Error (Expr) then 1942 return False; 1943 1944 else 1945 case Nkind (Expr) is 1946 when N_Identifier => 1947 return True; 1948 1949 when N_Expanded_Name => 1950 return True; 1951 1952 when N_Selected_Component => 1953 return not Do_Discriminant_Check (Expr); 1954 1955 when N_Attribute_Reference => 1956 if Do_Overflow_Check (Expr) then 1957 return False; 1958 1959 elsif No (Expressions (Expr)) then 1960 return True; 1961 1962 else 1963 declare 1964 N : Node_Id; 1965 1966 begin 1967 N := First (Expressions (Expr)); 1968 while Present (N) loop 1969 if Cannot_Raise_Constraint_Error (N) then 1970 Next (N); 1971 else 1972 return False; 1973 end if; 1974 end loop; 1975 1976 return True; 1977 end; 1978 end if; 1979 1980 when N_Type_Conversion => 1981 if Do_Overflow_Check (Expr) 1982 or else Do_Length_Check (Expr) 1983 or else Do_Tag_Check (Expr) 1984 then 1985 return False; 1986 else 1987 return Cannot_Raise_Constraint_Error (Expression (Expr)); 1988 end if; 1989 1990 when N_Unchecked_Type_Conversion => 1991 return Cannot_Raise_Constraint_Error (Expression (Expr)); 1992 1993 when N_Unary_Op => 1994 if Do_Overflow_Check (Expr) then 1995 return False; 1996 else 1997 return Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 1998 end if; 1999 2000 when N_Op_Divide 2001 | N_Op_Mod 2002 | N_Op_Rem 2003 => 2004 if Do_Division_Check (Expr) 2005 or else 2006 Do_Overflow_Check (Expr) 2007 then 2008 return False; 2009 else 2010 return 2011 Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) 2012 and then 2013 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 2014 end if; 2015 2016 when N_Op_Add 2017 | N_Op_And 2018 | N_Op_Concat 2019 | N_Op_Eq 2020 | N_Op_Expon 2021 | N_Op_Ge 2022 | N_Op_Gt 2023 | N_Op_Le 2024 | N_Op_Lt 2025 | N_Op_Multiply 2026 | N_Op_Ne 2027 | N_Op_Or 2028 | N_Op_Rotate_Left 2029 | N_Op_Rotate_Right 2030 | N_Op_Shift_Left 2031 | N_Op_Shift_Right 2032 | N_Op_Shift_Right_Arithmetic 2033 | N_Op_Subtract 2034 | N_Op_Xor 2035 => 2036 if Do_Overflow_Check (Expr) then 2037 return False; 2038 else 2039 return 2040 Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) 2041 and then 2042 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 2043 end if; 2044 2045 when others => 2046 return False; 2047 end case; 2048 end if; 2049 end Cannot_Raise_Constraint_Error; 2050 2051 ----------------------------------------- 2052 -- Check_Dynamically_Tagged_Expression -- 2053 ----------------------------------------- 2054 2055 procedure Check_Dynamically_Tagged_Expression 2056 (Expr : Node_Id; 2057 Typ : Entity_Id; 2058 Related_Nod : Node_Id) 2059 is 2060 begin 2061 pragma Assert (Is_Tagged_Type (Typ)); 2062 2063 -- In order to avoid spurious errors when analyzing the expanded code, 2064 -- this check is done only for nodes that come from source and for 2065 -- actuals of generic instantiations. 2066 2067 if (Comes_From_Source (Related_Nod) 2068 or else In_Generic_Actual (Expr)) 2069 and then (Is_Class_Wide_Type (Etype (Expr)) 2070 or else Is_Dynamically_Tagged (Expr)) 2071 and then not Is_Class_Wide_Type (Typ) 2072 then 2073 Error_Msg_N ("dynamically tagged expression not allowed!", Expr); 2074 end if; 2075 end Check_Dynamically_Tagged_Expression; 2076 2077 -------------------------- 2078 -- Check_Fully_Declared -- 2079 -------------------------- 2080 2081 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is 2082 begin 2083 if Ekind (T) = E_Incomplete_Type then 2084 2085 -- Ada 2005 (AI-50217): If the type is available through a limited 2086 -- with_clause, verify that its full view has been analyzed. 2087 2088 if From_Limited_With (T) 2089 and then Present (Non_Limited_View (T)) 2090 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type 2091 then 2092 -- The non-limited view is fully declared 2093 2094 null; 2095 2096 else 2097 Error_Msg_NE 2098 ("premature usage of incomplete}", N, First_Subtype (T)); 2099 end if; 2100 2101 -- Need comments for these tests ??? 2102 2103 elsif Has_Private_Component (T) 2104 and then not Is_Generic_Type (Root_Type (T)) 2105 and then not In_Spec_Expression 2106 then 2107 -- Special case: if T is the anonymous type created for a single 2108 -- task or protected object, use the name of the source object. 2109 2110 if Is_Concurrent_Type (T) 2111 and then not Comes_From_Source (T) 2112 and then Nkind (N) = N_Object_Declaration 2113 then 2114 Error_Msg_NE 2115 ("type of& has incomplete component", 2116 N, Defining_Identifier (N)); 2117 else 2118 Error_Msg_NE 2119 ("premature usage of incomplete}", 2120 N, First_Subtype (T)); 2121 end if; 2122 end if; 2123 end Check_Fully_Declared; 2124 2125 ------------------------------------------- 2126 -- Check_Function_With_Address_Parameter -- 2127 ------------------------------------------- 2128 2129 procedure Check_Function_With_Address_Parameter (Subp_Id : Entity_Id) is 2130 F : Entity_Id; 2131 T : Entity_Id; 2132 2133 begin 2134 F := First_Formal (Subp_Id); 2135 while Present (F) loop 2136 T := Etype (F); 2137 2138 if Is_Private_Type (T) and then Present (Full_View (T)) then 2139 T := Full_View (T); 2140 end if; 2141 2142 if Is_Descendant_Of_Address (T) or else Is_Limited_Type (T) then 2143 Set_Is_Pure (Subp_Id, False); 2144 exit; 2145 end if; 2146 2147 Next_Formal (F); 2148 end loop; 2149 end Check_Function_With_Address_Parameter; 2150 2151 ------------------------------------- 2152 -- Check_Function_Writable_Actuals -- 2153 ------------------------------------- 2154 2155 procedure Check_Function_Writable_Actuals (N : Node_Id) is 2156 Writable_Actuals_List : Elist_Id := No_Elist; 2157 Identifiers_List : Elist_Id := No_Elist; 2158 Aggr_Error_Node : Node_Id := Empty; 2159 Error_Node : Node_Id := Empty; 2160 2161 procedure Collect_Identifiers (N : Node_Id); 2162 -- In a single traversal of subtree N collect in Writable_Actuals_List 2163 -- all the actuals of functions with writable actuals, and in the list 2164 -- Identifiers_List collect all the identifiers that are not actuals of 2165 -- functions with writable actuals. If a writable actual is referenced 2166 -- twice as writable actual then Error_Node is set to reference its 2167 -- second occurrence, the error is reported, and the tree traversal 2168 -- is abandoned. 2169 2170 procedure Preanalyze_Without_Errors (N : Node_Id); 2171 -- Preanalyze N without reporting errors. Very dubious, you can't just 2172 -- go analyzing things more than once??? 2173 2174 ------------------------- 2175 -- Collect_Identifiers -- 2176 ------------------------- 2177 2178 procedure Collect_Identifiers (N : Node_Id) is 2179 2180 function Check_Node (N : Node_Id) return Traverse_Result; 2181 -- Process a single node during the tree traversal to collect the 2182 -- writable actuals of functions and all the identifiers which are 2183 -- not writable actuals of functions. 2184 2185 function Contains (List : Elist_Id; N : Node_Id) return Boolean; 2186 -- Returns True if List has a node whose Entity is Entity (N) 2187 2188 ---------------- 2189 -- Check_Node -- 2190 ---------------- 2191 2192 function Check_Node (N : Node_Id) return Traverse_Result is 2193 Is_Writable_Actual : Boolean := False; 2194 Id : Entity_Id; 2195 2196 begin 2197 if Nkind (N) = N_Identifier then 2198 2199 -- No analysis possible if the entity is not decorated 2200 2201 if No (Entity (N)) then 2202 return Skip; 2203 2204 -- Don't collect identifiers of packages, called functions, etc 2205 2206 elsif Ekind_In (Entity (N), E_Package, 2207 E_Function, 2208 E_Procedure, 2209 E_Entry) 2210 then 2211 return Skip; 2212 2213 -- For rewritten nodes, continue the traversal in the original 2214 -- subtree. Needed to handle aggregates in original expressions 2215 -- extracted from the tree by Remove_Side_Effects. 2216 2217 elsif Is_Rewrite_Substitution (N) then 2218 Collect_Identifiers (Original_Node (N)); 2219 return Skip; 2220 2221 -- For now we skip aggregate discriminants, since they require 2222 -- performing the analysis in two phases to identify conflicts: 2223 -- first one analyzing discriminants and second one analyzing 2224 -- the rest of components (since at run time, discriminants are 2225 -- evaluated prior to components): too much computation cost 2226 -- to identify a corner case??? 2227 2228 elsif Nkind (Parent (N)) = N_Component_Association 2229 and then Nkind_In (Parent (Parent (N)), 2230 N_Aggregate, 2231 N_Extension_Aggregate) 2232 then 2233 declare 2234 Choice : constant Node_Id := First (Choices (Parent (N))); 2235 2236 begin 2237 if Ekind (Entity (N)) = E_Discriminant then 2238 return Skip; 2239 2240 elsif Expression (Parent (N)) = N 2241 and then Nkind (Choice) = N_Identifier 2242 and then Ekind (Entity (Choice)) = E_Discriminant 2243 then 2244 return Skip; 2245 end if; 2246 end; 2247 2248 -- Analyze if N is a writable actual of a function 2249 2250 elsif Nkind (Parent (N)) = N_Function_Call then 2251 declare 2252 Call : constant Node_Id := Parent (N); 2253 Actual : Node_Id; 2254 Formal : Node_Id; 2255 2256 begin 2257 Id := Get_Called_Entity (Call); 2258 2259 -- In case of previous error, no check is possible 2260 2261 if No (Id) then 2262 return Abandon; 2263 end if; 2264 2265 if Ekind_In (Id, E_Function, E_Generic_Function) 2266 and then Has_Out_Or_In_Out_Parameter (Id) 2267 then 2268 Formal := First_Formal (Id); 2269 Actual := First_Actual (Call); 2270 while Present (Actual) and then Present (Formal) loop 2271 if Actual = N then 2272 if Ekind_In (Formal, E_Out_Parameter, 2273 E_In_Out_Parameter) 2274 then 2275 Is_Writable_Actual := True; 2276 end if; 2277 2278 exit; 2279 end if; 2280 2281 Next_Formal (Formal); 2282 Next_Actual (Actual); 2283 end loop; 2284 end if; 2285 end; 2286 end if; 2287 2288 if Is_Writable_Actual then 2289 2290 -- Skip checking the error in non-elementary types since 2291 -- RM 6.4.1(6.15/3) is restricted to elementary types, but 2292 -- store this actual in Writable_Actuals_List since it is 2293 -- needed to perform checks on other constructs that have 2294 -- arbitrary order of evaluation (for example, aggregates). 2295 2296 if not Is_Elementary_Type (Etype (N)) then 2297 if not Contains (Writable_Actuals_List, N) then 2298 Append_New_Elmt (N, To => Writable_Actuals_List); 2299 end if; 2300 2301 -- Second occurrence of an elementary type writable actual 2302 2303 elsif Contains (Writable_Actuals_List, N) then 2304 2305 -- Report the error on the second occurrence of the 2306 -- identifier. We cannot assume that N is the second 2307 -- occurrence (according to their location in the 2308 -- sources), since Traverse_Func walks through Field2 2309 -- last (see comment in the body of Traverse_Func). 2310 2311 declare 2312 Elmt : Elmt_Id; 2313 2314 begin 2315 Elmt := First_Elmt (Writable_Actuals_List); 2316 while Present (Elmt) 2317 and then Entity (Node (Elmt)) /= Entity (N) 2318 loop 2319 Next_Elmt (Elmt); 2320 end loop; 2321 2322 if Sloc (N) > Sloc (Node (Elmt)) then 2323 Error_Node := N; 2324 else 2325 Error_Node := Node (Elmt); 2326 end if; 2327 2328 Error_Msg_NE 2329 ("value may be affected by call to & " 2330 & "because order of evaluation is arbitrary", 2331 Error_Node, Id); 2332 return Abandon; 2333 end; 2334 2335 -- First occurrence of a elementary type writable actual 2336 2337 else 2338 Append_New_Elmt (N, To => Writable_Actuals_List); 2339 end if; 2340 2341 else 2342 if Identifiers_List = No_Elist then 2343 Identifiers_List := New_Elmt_List; 2344 end if; 2345 2346 Append_Unique_Elmt (N, Identifiers_List); 2347 end if; 2348 end if; 2349 2350 return OK; 2351 end Check_Node; 2352 2353 -------------- 2354 -- Contains -- 2355 -------------- 2356 2357 function Contains 2358 (List : Elist_Id; 2359 N : Node_Id) return Boolean 2360 is 2361 pragma Assert (Nkind (N) in N_Has_Entity); 2362 2363 Elmt : Elmt_Id; 2364 2365 begin 2366 if List = No_Elist then 2367 return False; 2368 end if; 2369 2370 Elmt := First_Elmt (List); 2371 while Present (Elmt) loop 2372 if Entity (Node (Elmt)) = Entity (N) then 2373 return True; 2374 else 2375 Next_Elmt (Elmt); 2376 end if; 2377 end loop; 2378 2379 return False; 2380 end Contains; 2381 2382 ------------------ 2383 -- Do_Traversal -- 2384 ------------------ 2385 2386 procedure Do_Traversal is new Traverse_Proc (Check_Node); 2387 -- The traversal procedure 2388 2389 -- Start of processing for Collect_Identifiers 2390 2391 begin 2392 if Present (Error_Node) then 2393 return; 2394 end if; 2395 2396 if Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then 2397 return; 2398 end if; 2399 2400 Do_Traversal (N); 2401 end Collect_Identifiers; 2402 2403 ------------------------------- 2404 -- Preanalyze_Without_Errors -- 2405 ------------------------------- 2406 2407 procedure Preanalyze_Without_Errors (N : Node_Id) is 2408 Status : constant Boolean := Get_Ignore_Errors; 2409 begin 2410 Set_Ignore_Errors (True); 2411 Preanalyze (N); 2412 Set_Ignore_Errors (Status); 2413 end Preanalyze_Without_Errors; 2414 2415 -- Start of processing for Check_Function_Writable_Actuals 2416 2417 begin 2418 -- The check only applies to Ada 2012 code on which Check_Actuals has 2419 -- been set, and only to constructs that have multiple constituents 2420 -- whose order of evaluation is not specified by the language. 2421 2422 if Ada_Version < Ada_2012 2423 or else not Check_Actuals (N) 2424 or else (not (Nkind (N) in N_Op) 2425 and then not (Nkind (N) in N_Membership_Test) 2426 and then not Nkind_In (N, N_Range, 2427 N_Aggregate, 2428 N_Extension_Aggregate, 2429 N_Full_Type_Declaration, 2430 N_Function_Call, 2431 N_Procedure_Call_Statement, 2432 N_Entry_Call_Statement)) 2433 or else (Nkind (N) = N_Full_Type_Declaration 2434 and then not Is_Record_Type (Defining_Identifier (N))) 2435 2436 -- In addition, this check only applies to source code, not to code 2437 -- generated by constraint checks. 2438 2439 or else not Comes_From_Source (N) 2440 then 2441 return; 2442 end if; 2443 2444 -- If a construct C has two or more direct constituents that are names 2445 -- or expressions whose evaluation may occur in an arbitrary order, at 2446 -- least one of which contains a function call with an in out or out 2447 -- parameter, then the construct is legal only if: for each name N that 2448 -- is passed as a parameter of mode in out or out to some inner function 2449 -- call C2 (not including the construct C itself), there is no other 2450 -- name anywhere within a direct constituent of the construct C other 2451 -- than the one containing C2, that is known to refer to the same 2452 -- object (RM 6.4.1(6.17/3)). 2453 2454 case Nkind (N) is 2455 when N_Range => 2456 Collect_Identifiers (Low_Bound (N)); 2457 Collect_Identifiers (High_Bound (N)); 2458 2459 when N_Membership_Test 2460 | N_Op 2461 => 2462 declare 2463 Expr : Node_Id; 2464 2465 begin 2466 Collect_Identifiers (Left_Opnd (N)); 2467 2468 if Present (Right_Opnd (N)) then 2469 Collect_Identifiers (Right_Opnd (N)); 2470 end if; 2471 2472 if Nkind_In (N, N_In, N_Not_In) 2473 and then Present (Alternatives (N)) 2474 then 2475 Expr := First (Alternatives (N)); 2476 while Present (Expr) loop 2477 Collect_Identifiers (Expr); 2478 2479 Next (Expr); 2480 end loop; 2481 end if; 2482 end; 2483 2484 when N_Full_Type_Declaration => 2485 declare 2486 function Get_Record_Part (N : Node_Id) return Node_Id; 2487 -- Return the record part of this record type definition 2488 2489 function Get_Record_Part (N : Node_Id) return Node_Id is 2490 Type_Def : constant Node_Id := Type_Definition (N); 2491 begin 2492 if Nkind (Type_Def) = N_Derived_Type_Definition then 2493 return Record_Extension_Part (Type_Def); 2494 else 2495 return Type_Def; 2496 end if; 2497 end Get_Record_Part; 2498 2499 Comp : Node_Id; 2500 Def_Id : Entity_Id := Defining_Identifier (N); 2501 Rec : Node_Id := Get_Record_Part (N); 2502 2503 begin 2504 -- No need to perform any analysis if the record has no 2505 -- components 2506 2507 if No (Rec) or else No (Component_List (Rec)) then 2508 return; 2509 end if; 2510 2511 -- Collect the identifiers starting from the deepest 2512 -- derivation. Done to report the error in the deepest 2513 -- derivation. 2514 2515 loop 2516 if Present (Component_List (Rec)) then 2517 Comp := First (Component_Items (Component_List (Rec))); 2518 while Present (Comp) loop 2519 if Nkind (Comp) = N_Component_Declaration 2520 and then Present (Expression (Comp)) 2521 then 2522 Collect_Identifiers (Expression (Comp)); 2523 end if; 2524 2525 Next (Comp); 2526 end loop; 2527 end if; 2528 2529 exit when No (Underlying_Type (Etype (Def_Id))) 2530 or else Base_Type (Underlying_Type (Etype (Def_Id))) 2531 = Def_Id; 2532 2533 Def_Id := Base_Type (Underlying_Type (Etype (Def_Id))); 2534 Rec := Get_Record_Part (Parent (Def_Id)); 2535 end loop; 2536 end; 2537 2538 when N_Entry_Call_Statement 2539 | N_Subprogram_Call 2540 => 2541 declare 2542 Id : constant Entity_Id := Get_Called_Entity (N); 2543 Formal : Node_Id; 2544 Actual : Node_Id; 2545 2546 begin 2547 Formal := First_Formal (Id); 2548 Actual := First_Actual (N); 2549 while Present (Actual) and then Present (Formal) loop 2550 if Ekind_In (Formal, E_Out_Parameter, 2551 E_In_Out_Parameter) 2552 then 2553 Collect_Identifiers (Actual); 2554 end if; 2555 2556 Next_Formal (Formal); 2557 Next_Actual (Actual); 2558 end loop; 2559 end; 2560 2561 when N_Aggregate 2562 | N_Extension_Aggregate 2563 => 2564 declare 2565 Assoc : Node_Id; 2566 Choice : Node_Id; 2567 Comp_Expr : Node_Id; 2568 2569 begin 2570 -- Handle the N_Others_Choice of array aggregates with static 2571 -- bounds. There is no need to perform this analysis in 2572 -- aggregates without static bounds since we cannot evaluate 2573 -- if the N_Others_Choice covers several elements. There is 2574 -- no need to handle the N_Others choice of record aggregates 2575 -- since at this stage it has been already expanded by 2576 -- Resolve_Record_Aggregate. 2577 2578 if Is_Array_Type (Etype (N)) 2579 and then Nkind (N) = N_Aggregate 2580 and then Present (Aggregate_Bounds (N)) 2581 and then Compile_Time_Known_Bounds (Etype (N)) 2582 and then Expr_Value (High_Bound (Aggregate_Bounds (N))) 2583 > 2584 Expr_Value (Low_Bound (Aggregate_Bounds (N))) 2585 then 2586 declare 2587 Count_Components : Uint := Uint_0; 2588 Num_Components : Uint; 2589 Others_Assoc : Node_Id; 2590 Others_Choice : Node_Id := Empty; 2591 Others_Box_Present : Boolean := False; 2592 2593 begin 2594 -- Count positional associations 2595 2596 if Present (Expressions (N)) then 2597 Comp_Expr := First (Expressions (N)); 2598 while Present (Comp_Expr) loop 2599 Count_Components := Count_Components + 1; 2600 Next (Comp_Expr); 2601 end loop; 2602 end if; 2603 2604 -- Count the rest of elements and locate the N_Others 2605 -- choice (if any) 2606 2607 Assoc := First (Component_Associations (N)); 2608 while Present (Assoc) loop 2609 Choice := First (Choices (Assoc)); 2610 while Present (Choice) loop 2611 if Nkind (Choice) = N_Others_Choice then 2612 Others_Assoc := Assoc; 2613 Others_Choice := Choice; 2614 Others_Box_Present := Box_Present (Assoc); 2615 2616 -- Count several components 2617 2618 elsif Nkind_In (Choice, N_Range, 2619 N_Subtype_Indication) 2620 or else (Is_Entity_Name (Choice) 2621 and then Is_Type (Entity (Choice))) 2622 then 2623 declare 2624 L, H : Node_Id; 2625 begin 2626 Get_Index_Bounds (Choice, L, H); 2627 pragma Assert 2628 (Compile_Time_Known_Value (L) 2629 and then Compile_Time_Known_Value (H)); 2630 Count_Components := 2631 Count_Components 2632 + Expr_Value (H) - Expr_Value (L) + 1; 2633 end; 2634 2635 -- Count single component. No other case available 2636 -- since we are handling an aggregate with static 2637 -- bounds. 2638 2639 else 2640 pragma Assert (Is_OK_Static_Expression (Choice) 2641 or else Nkind (Choice) = N_Identifier 2642 or else Nkind (Choice) = N_Integer_Literal); 2643 2644 Count_Components := Count_Components + 1; 2645 end if; 2646 2647 Next (Choice); 2648 end loop; 2649 2650 Next (Assoc); 2651 end loop; 2652 2653 Num_Components := 2654 Expr_Value (High_Bound (Aggregate_Bounds (N))) - 2655 Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1; 2656 2657 pragma Assert (Count_Components <= Num_Components); 2658 2659 -- Handle the N_Others choice if it covers several 2660 -- components 2661 2662 if Present (Others_Choice) 2663 and then (Num_Components - Count_Components) > 1 2664 then 2665 if not Others_Box_Present then 2666 2667 -- At this stage, if expansion is active, the 2668 -- expression of the others choice has not been 2669 -- analyzed. Hence we generate a duplicate and 2670 -- we analyze it silently to have available the 2671 -- minimum decoration required to collect the 2672 -- identifiers. 2673 2674 if not Expander_Active then 2675 Comp_Expr := Expression (Others_Assoc); 2676 else 2677 Comp_Expr := 2678 New_Copy_Tree (Expression (Others_Assoc)); 2679 Preanalyze_Without_Errors (Comp_Expr); 2680 end if; 2681 2682 Collect_Identifiers (Comp_Expr); 2683 2684 if Writable_Actuals_List /= No_Elist then 2685 2686 -- As suggested by Robert, at current stage we 2687 -- report occurrences of this case as warnings. 2688 2689 Error_Msg_N 2690 ("writable function parameter may affect " 2691 & "value in other component because order " 2692 & "of evaluation is unspecified??", 2693 Node (First_Elmt (Writable_Actuals_List))); 2694 end if; 2695 end if; 2696 end if; 2697 end; 2698 2699 -- For an array aggregate, a discrete_choice_list that has 2700 -- a nonstatic range is considered as two or more separate 2701 -- occurrences of the expression (RM 6.4.1(20/3)). 2702 2703 elsif Is_Array_Type (Etype (N)) 2704 and then Nkind (N) = N_Aggregate 2705 and then Present (Aggregate_Bounds (N)) 2706 and then not Compile_Time_Known_Bounds (Etype (N)) 2707 then 2708 -- Collect identifiers found in the dynamic bounds 2709 2710 declare 2711 Count_Components : Natural := 0; 2712 Low, High : Node_Id; 2713 2714 begin 2715 Assoc := First (Component_Associations (N)); 2716 while Present (Assoc) loop 2717 Choice := First (Choices (Assoc)); 2718 while Present (Choice) loop 2719 if Nkind_In (Choice, N_Range, 2720 N_Subtype_Indication) 2721 or else (Is_Entity_Name (Choice) 2722 and then Is_Type (Entity (Choice))) 2723 then 2724 Get_Index_Bounds (Choice, Low, High); 2725 2726 if not Compile_Time_Known_Value (Low) then 2727 Collect_Identifiers (Low); 2728 2729 if No (Aggr_Error_Node) then 2730 Aggr_Error_Node := Low; 2731 end if; 2732 end if; 2733 2734 if not Compile_Time_Known_Value (High) then 2735 Collect_Identifiers (High); 2736 2737 if No (Aggr_Error_Node) then 2738 Aggr_Error_Node := High; 2739 end if; 2740 end if; 2741 2742 -- The RM rule is violated if there is more than 2743 -- a single choice in a component association. 2744 2745 else 2746 Count_Components := Count_Components + 1; 2747 2748 if No (Aggr_Error_Node) 2749 and then Count_Components > 1 2750 then 2751 Aggr_Error_Node := Choice; 2752 end if; 2753 2754 if not Compile_Time_Known_Value (Choice) then 2755 Collect_Identifiers (Choice); 2756 end if; 2757 end if; 2758 2759 Next (Choice); 2760 end loop; 2761 2762 Next (Assoc); 2763 end loop; 2764 end; 2765 end if; 2766 2767 -- Handle ancestor part of extension aggregates 2768 2769 if Nkind (N) = N_Extension_Aggregate then 2770 Collect_Identifiers (Ancestor_Part (N)); 2771 end if; 2772 2773 -- Handle positional associations 2774 2775 if Present (Expressions (N)) then 2776 Comp_Expr := First (Expressions (N)); 2777 while Present (Comp_Expr) loop 2778 if not Is_OK_Static_Expression (Comp_Expr) then 2779 Collect_Identifiers (Comp_Expr); 2780 end if; 2781 2782 Next (Comp_Expr); 2783 end loop; 2784 end if; 2785 2786 -- Handle discrete associations 2787 2788 if Present (Component_Associations (N)) then 2789 Assoc := First (Component_Associations (N)); 2790 while Present (Assoc) loop 2791 2792 if not Box_Present (Assoc) then 2793 Choice := First (Choices (Assoc)); 2794 while Present (Choice) loop 2795 2796 -- For now we skip discriminants since it requires 2797 -- performing the analysis in two phases: first one 2798 -- analyzing discriminants and second one analyzing 2799 -- the rest of components since discriminants are 2800 -- evaluated prior to components: too much extra 2801 -- work to detect a corner case??? 2802 2803 if Nkind (Choice) in N_Has_Entity 2804 and then Present (Entity (Choice)) 2805 and then Ekind (Entity (Choice)) = E_Discriminant 2806 then 2807 null; 2808 2809 elsif Box_Present (Assoc) then 2810 null; 2811 2812 else 2813 if not Analyzed (Expression (Assoc)) then 2814 Comp_Expr := 2815 New_Copy_Tree (Expression (Assoc)); 2816 Set_Parent (Comp_Expr, Parent (N)); 2817 Preanalyze_Without_Errors (Comp_Expr); 2818 else 2819 Comp_Expr := Expression (Assoc); 2820 end if; 2821 2822 Collect_Identifiers (Comp_Expr); 2823 end if; 2824 2825 Next (Choice); 2826 end loop; 2827 end if; 2828 2829 Next (Assoc); 2830 end loop; 2831 end if; 2832 end; 2833 2834 when others => 2835 return; 2836 end case; 2837 2838 -- No further action needed if we already reported an error 2839 2840 if Present (Error_Node) then 2841 return; 2842 end if; 2843 2844 -- Check violation of RM 6.20/3 in aggregates 2845 2846 if Present (Aggr_Error_Node) 2847 and then Writable_Actuals_List /= No_Elist 2848 then 2849 Error_Msg_N 2850 ("value may be affected by call in other component because they " 2851 & "are evaluated in unspecified order", 2852 Node (First_Elmt (Writable_Actuals_List))); 2853 return; 2854 end if; 2855 2856 -- Check if some writable argument of a function is referenced 2857 2858 if Writable_Actuals_List /= No_Elist 2859 and then Identifiers_List /= No_Elist 2860 then 2861 declare 2862 Elmt_1 : Elmt_Id; 2863 Elmt_2 : Elmt_Id; 2864 2865 begin 2866 Elmt_1 := First_Elmt (Writable_Actuals_List); 2867 while Present (Elmt_1) loop 2868 Elmt_2 := First_Elmt (Identifiers_List); 2869 while Present (Elmt_2) loop 2870 if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then 2871 case Nkind (Parent (Node (Elmt_2))) is 2872 when N_Aggregate 2873 | N_Component_Association 2874 | N_Component_Declaration 2875 => 2876 Error_Msg_N 2877 ("value may be affected by call in other " 2878 & "component because they are evaluated " 2879 & "in unspecified order", 2880 Node (Elmt_2)); 2881 2882 when N_In 2883 | N_Not_In 2884 => 2885 Error_Msg_N 2886 ("value may be affected by call in other " 2887 & "alternative because they are evaluated " 2888 & "in unspecified order", 2889 Node (Elmt_2)); 2890 2891 when others => 2892 Error_Msg_N 2893 ("value of actual may be affected by call in " 2894 & "other actual because they are evaluated " 2895 & "in unspecified order", 2896 Node (Elmt_2)); 2897 end case; 2898 end if; 2899 2900 Next_Elmt (Elmt_2); 2901 end loop; 2902 2903 Next_Elmt (Elmt_1); 2904 end loop; 2905 end; 2906 end if; 2907 end Check_Function_Writable_Actuals; 2908 2909 -------------------------------- 2910 -- Check_Implicit_Dereference -- 2911 -------------------------------- 2912 2913 procedure Check_Implicit_Dereference (N : Node_Id; Typ : Entity_Id) is 2914 Disc : Entity_Id; 2915 Desig : Entity_Id; 2916 Nam : Node_Id; 2917 2918 begin 2919 if Nkind (N) = N_Indexed_Component 2920 and then Present (Generalized_Indexing (N)) 2921 then 2922 Nam := Generalized_Indexing (N); 2923 else 2924 Nam := N; 2925 end if; 2926 2927 if Ada_Version < Ada_2012 2928 or else not Has_Implicit_Dereference (Base_Type (Typ)) 2929 then 2930 return; 2931 2932 elsif not Comes_From_Source (N) 2933 and then Nkind (N) /= N_Indexed_Component 2934 then 2935 return; 2936 2937 elsif Is_Entity_Name (Nam) and then Is_Type (Entity (Nam)) then 2938 null; 2939 2940 else 2941 Disc := First_Discriminant (Typ); 2942 while Present (Disc) loop 2943 if Has_Implicit_Dereference (Disc) then 2944 Desig := Designated_Type (Etype (Disc)); 2945 Add_One_Interp (Nam, Disc, Desig); 2946 2947 -- If the node is a generalized indexing, add interpretation 2948 -- to that node as well, for subsequent resolution. 2949 2950 if Nkind (N) = N_Indexed_Component then 2951 Add_One_Interp (N, Disc, Desig); 2952 end if; 2953 2954 -- If the operation comes from a generic unit and the context 2955 -- is a selected component, the selector name may be global 2956 -- and set in the instance already. Remove the entity to 2957 -- force resolution of the selected component, and the 2958 -- generation of an explicit dereference if needed. 2959 2960 if In_Instance 2961 and then Nkind (Parent (Nam)) = N_Selected_Component 2962 then 2963 Set_Entity (Selector_Name (Parent (Nam)), Empty); 2964 end if; 2965 2966 exit; 2967 end if; 2968 2969 Next_Discriminant (Disc); 2970 end loop; 2971 end if; 2972 end Check_Implicit_Dereference; 2973 2974 ---------------------------------- 2975 -- Check_Internal_Protected_Use -- 2976 ---------------------------------- 2977 2978 procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is 2979 S : Entity_Id; 2980 Prot : Entity_Id; 2981 2982 begin 2983 Prot := Empty; 2984 2985 S := Current_Scope; 2986 while Present (S) loop 2987 if S = Standard_Standard then 2988 exit; 2989 2990 elsif Ekind (S) = E_Function 2991 and then Ekind (Scope (S)) = E_Protected_Type 2992 then 2993 Prot := Scope (S); 2994 exit; 2995 end if; 2996 2997 S := Scope (S); 2998 end loop; 2999 3000 if Present (Prot) 3001 and then Scope (Nam) = Prot 3002 and then Ekind (Nam) /= E_Function 3003 then 3004 -- An indirect function call (e.g. a callback within a protected 3005 -- function body) is not statically illegal. If the access type is 3006 -- anonymous and is the type of an access parameter, the scope of Nam 3007 -- will be the protected type, but it is not a protected operation. 3008 3009 if Ekind (Nam) = E_Subprogram_Type 3010 and then Nkind (Associated_Node_For_Itype (Nam)) = 3011 N_Function_Specification 3012 then 3013 null; 3014 3015 elsif Nkind (N) = N_Subprogram_Renaming_Declaration then 3016 Error_Msg_N 3017 ("within protected function cannot use protected procedure in " 3018 & "renaming or as generic actual", N); 3019 3020 elsif Nkind (N) = N_Attribute_Reference then 3021 Error_Msg_N 3022 ("within protected function cannot take access of protected " 3023 & "procedure", N); 3024 3025 else 3026 Error_Msg_N 3027 ("within protected function, protected object is constant", N); 3028 Error_Msg_N 3029 ("\cannot call operation that may modify it", N); 3030 end if; 3031 end if; 3032 3033 -- Verify that an internal call does not appear within a precondition 3034 -- of a protected operation. This implements AI12-0166. 3035 -- The precondition aspect has been rewritten as a pragma Precondition 3036 -- and we check whether the scope of the called subprogram is the same 3037 -- as that of the entity to which the aspect applies. 3038 3039 if Convention (Nam) = Convention_Protected then 3040 declare 3041 P : Node_Id; 3042 3043 begin 3044 P := Parent (N); 3045 while Present (P) loop 3046 if Nkind (P) = N_Pragma 3047 and then Chars (Pragma_Identifier (P)) = Name_Precondition 3048 and then From_Aspect_Specification (P) 3049 and then 3050 Scope (Entity (Corresponding_Aspect (P))) = Scope (Nam) 3051 then 3052 Error_Msg_N 3053 ("internal call cannot appear in precondition of " 3054 & "protected operation", N); 3055 return; 3056 3057 elsif Nkind (P) = N_Pragma 3058 and then Chars (Pragma_Identifier (P)) = Name_Contract_Cases 3059 then 3060 -- Check whether call is in a case guard. It is legal in a 3061 -- consequence. 3062 3063 P := N; 3064 while Present (P) loop 3065 if Nkind (Parent (P)) = N_Component_Association 3066 and then P /= Expression (Parent (P)) 3067 then 3068 Error_Msg_N 3069 ("internal call cannot appear in case guard in a " 3070 & "contract case", N); 3071 end if; 3072 3073 P := Parent (P); 3074 end loop; 3075 3076 return; 3077 3078 elsif Nkind (P) = N_Parameter_Specification 3079 and then Scope (Current_Scope) = Scope (Nam) 3080 and then Nkind_In (Parent (P), N_Entry_Declaration, 3081 N_Subprogram_Declaration) 3082 then 3083 Error_Msg_N 3084 ("internal call cannot appear in default for formal of " 3085 & "protected operation", N); 3086 return; 3087 end if; 3088 3089 P := Parent (P); 3090 end loop; 3091 end; 3092 end if; 3093 end Check_Internal_Protected_Use; 3094 3095 --------------------------------------- 3096 -- Check_Later_Vs_Basic_Declarations -- 3097 --------------------------------------- 3098 3099 procedure Check_Later_Vs_Basic_Declarations 3100 (Decls : List_Id; 3101 During_Parsing : Boolean) 3102 is 3103 Body_Sloc : Source_Ptr; 3104 Decl : Node_Id; 3105 3106 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean; 3107 -- Return whether Decl is considered as a declarative item. 3108 -- When During_Parsing is True, the semantics of Ada 83 is followed. 3109 -- When During_Parsing is False, the semantics of SPARK is followed. 3110 3111 ------------------------------- 3112 -- Is_Later_Declarative_Item -- 3113 ------------------------------- 3114 3115 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is 3116 begin 3117 if Nkind (Decl) in N_Later_Decl_Item then 3118 return True; 3119 3120 elsif Nkind (Decl) = N_Pragma then 3121 return True; 3122 3123 elsif During_Parsing then 3124 return False; 3125 3126 -- In SPARK, a package declaration is not considered as a later 3127 -- declarative item. 3128 3129 elsif Nkind (Decl) = N_Package_Declaration then 3130 return False; 3131 3132 -- In SPARK, a renaming is considered as a later declarative item 3133 3134 elsif Nkind (Decl) in N_Renaming_Declaration then 3135 return True; 3136 3137 else 3138 return False; 3139 end if; 3140 end Is_Later_Declarative_Item; 3141 3142 -- Start of processing for Check_Later_Vs_Basic_Declarations 3143 3144 begin 3145 Decl := First (Decls); 3146 3147 -- Loop through sequence of basic declarative items 3148 3149 Outer : while Present (Decl) loop 3150 if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body) 3151 and then Nkind (Decl) not in N_Body_Stub 3152 then 3153 Next (Decl); 3154 3155 -- Once a body is encountered, we only allow later declarative 3156 -- items. The inner loop checks the rest of the list. 3157 3158 else 3159 Body_Sloc := Sloc (Decl); 3160 3161 Inner : while Present (Decl) loop 3162 if not Is_Later_Declarative_Item (Decl) then 3163 if During_Parsing then 3164 if Ada_Version = Ada_83 then 3165 Error_Msg_Sloc := Body_Sloc; 3166 Error_Msg_N 3167 ("(Ada 83) decl cannot appear after body#", Decl); 3168 end if; 3169 else 3170 Error_Msg_Sloc := Body_Sloc; 3171 Check_SPARK_05_Restriction 3172 ("decl cannot appear after body#", Decl); 3173 end if; 3174 end if; 3175 3176 Next (Decl); 3177 end loop Inner; 3178 end if; 3179 end loop Outer; 3180 end Check_Later_Vs_Basic_Declarations; 3181 3182 --------------------------- 3183 -- Check_No_Hidden_State -- 3184 --------------------------- 3185 3186 procedure Check_No_Hidden_State (Id : Entity_Id) is 3187 Context : Entity_Id := Empty; 3188 Not_Visible : Boolean := False; 3189 Scop : Entity_Id; 3190 3191 begin 3192 pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable)); 3193 3194 -- Find the proper context where the object or state appears 3195 3196 Scop := Scope (Id); 3197 while Present (Scop) loop 3198 Context := Scop; 3199 3200 -- Keep track of the context's visibility 3201 3202 Not_Visible := Not_Visible or else In_Private_Part (Context); 3203 3204 -- Prevent the search from going too far 3205 3206 if Context = Standard_Standard then 3207 return; 3208 3209 -- Objects and states that appear immediately within a subprogram or 3210 -- inside a construct nested within a subprogram do not introduce a 3211 -- hidden state. They behave as local variable declarations. 3212 3213 elsif Is_Subprogram (Context) then 3214 return; 3215 3216 -- When examining a package body, use the entity of the spec as it 3217 -- carries the abstract state declarations. 3218 3219 elsif Ekind (Context) = E_Package_Body then 3220 Context := Spec_Entity (Context); 3221 end if; 3222 3223 -- Stop the traversal when a package subject to a null abstract state 3224 -- has been found. 3225 3226 if Ekind_In (Context, E_Generic_Package, E_Package) 3227 and then Has_Null_Abstract_State (Context) 3228 then 3229 exit; 3230 end if; 3231 3232 Scop := Scope (Scop); 3233 end loop; 3234 3235 -- At this point we know that there is at least one package with a null 3236 -- abstract state in visibility. Emit an error message unconditionally 3237 -- if the entity being processed is a state because the placement of the 3238 -- related package is irrelevant. This is not the case for objects as 3239 -- the intermediate context matters. 3240 3241 if Present (Context) 3242 and then (Ekind (Id) = E_Abstract_State or else Not_Visible) 3243 then 3244 Error_Msg_N ("cannot introduce hidden state &", Id); 3245 Error_Msg_NE ("\package & has null abstract state", Id, Context); 3246 end if; 3247 end Check_No_Hidden_State; 3248 3249 ---------------------------------------- 3250 -- Check_Nonvolatile_Function_Profile -- 3251 ---------------------------------------- 3252 3253 procedure Check_Nonvolatile_Function_Profile (Func_Id : Entity_Id) is 3254 Formal : Entity_Id; 3255 3256 begin 3257 -- Inspect all formal parameters 3258 3259 Formal := First_Formal (Func_Id); 3260 while Present (Formal) loop 3261 if Is_Effectively_Volatile (Etype (Formal)) then 3262 Error_Msg_NE 3263 ("nonvolatile function & cannot have a volatile parameter", 3264 Formal, Func_Id); 3265 end if; 3266 3267 Next_Formal (Formal); 3268 end loop; 3269 3270 -- Inspect the return type 3271 3272 if Is_Effectively_Volatile (Etype (Func_Id)) then 3273 Error_Msg_NE 3274 ("nonvolatile function & cannot have a volatile return type", 3275 Result_Definition (Parent (Func_Id)), Func_Id); 3276 end if; 3277 end Check_Nonvolatile_Function_Profile; 3278 3279 ----------------------------- 3280 -- Check_Part_Of_Reference -- 3281 ----------------------------- 3282 3283 procedure Check_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id) is 3284 function Is_Enclosing_Package_Body 3285 (Body_Decl : Node_Id; 3286 Obj_Id : Entity_Id) return Boolean; 3287 pragma Inline (Is_Enclosing_Package_Body); 3288 -- Determine whether package body Body_Decl or its corresponding spec 3289 -- immediately encloses the declaration of object Obj_Id. 3290 3291 function Is_Internal_Declaration_Or_Body 3292 (Decl : Node_Id) return Boolean; 3293 pragma Inline (Is_Internal_Declaration_Or_Body); 3294 -- Determine whether declaration or body denoted by Decl is internal 3295 3296 function Is_Single_Declaration_Or_Body 3297 (Decl : Node_Id; 3298 Conc_Typ : Entity_Id) return Boolean; 3299 pragma Inline (Is_Single_Declaration_Or_Body); 3300 -- Determine whether protected/task declaration or body denoted by Decl 3301 -- belongs to single concurrent type Conc_Typ. 3302 3303 function Is_Single_Task_Pragma 3304 (Prag : Node_Id; 3305 Task_Typ : Entity_Id) return Boolean; 3306 pragma Inline (Is_Single_Task_Pragma); 3307 -- Determine whether pragma Prag belongs to single task type Task_Typ 3308 3309 ------------------------------- 3310 -- Is_Enclosing_Package_Body -- 3311 ------------------------------- 3312 3313 function Is_Enclosing_Package_Body 3314 (Body_Decl : Node_Id; 3315 Obj_Id : Entity_Id) return Boolean 3316 is 3317 Obj_Context : Node_Id; 3318 3319 begin 3320 -- Find the context of the object declaration 3321 3322 Obj_Context := Parent (Declaration_Node (Obj_Id)); 3323 3324 if Nkind (Obj_Context) = N_Package_Specification then 3325 Obj_Context := Parent (Obj_Context); 3326 end if; 3327 3328 -- The object appears immediately within the package body 3329 3330 if Obj_Context = Body_Decl then 3331 return True; 3332 3333 -- The object appears immediately within the corresponding spec 3334 3335 elsif Nkind (Obj_Context) = N_Package_Declaration 3336 and then Unit_Declaration_Node (Corresponding_Spec (Body_Decl)) = 3337 Obj_Context 3338 then 3339 return True; 3340 end if; 3341 3342 return False; 3343 end Is_Enclosing_Package_Body; 3344 3345 ------------------------------------- 3346 -- Is_Internal_Declaration_Or_Body -- 3347 ------------------------------------- 3348 3349 function Is_Internal_Declaration_Or_Body 3350 (Decl : Node_Id) return Boolean 3351 is 3352 begin 3353 if Comes_From_Source (Decl) then 3354 return False; 3355 3356 -- A body generated for an expression function which has not been 3357 -- inserted into the tree yet (In_Spec_Expression is True) is not 3358 -- considered internal. 3359 3360 elsif Nkind (Decl) = N_Subprogram_Body 3361 and then Was_Expression_Function (Decl) 3362 and then not In_Spec_Expression 3363 then 3364 return False; 3365 end if; 3366 3367 return True; 3368 end Is_Internal_Declaration_Or_Body; 3369 3370 ----------------------------------- 3371 -- Is_Single_Declaration_Or_Body -- 3372 ----------------------------------- 3373 3374 function Is_Single_Declaration_Or_Body 3375 (Decl : Node_Id; 3376 Conc_Typ : Entity_Id) return Boolean 3377 is 3378 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl); 3379 3380 begin 3381 return 3382 Present (Anonymous_Object (Spec_Id)) 3383 and then Anonymous_Object (Spec_Id) = Conc_Typ; 3384 end Is_Single_Declaration_Or_Body; 3385 3386 --------------------------- 3387 -- Is_Single_Task_Pragma -- 3388 --------------------------- 3389 3390 function Is_Single_Task_Pragma 3391 (Prag : Node_Id; 3392 Task_Typ : Entity_Id) return Boolean 3393 is 3394 Decl : constant Node_Id := Find_Related_Declaration_Or_Body (Prag); 3395 3396 begin 3397 -- To qualify, the pragma must be associated with single task type 3398 -- Task_Typ. 3399 3400 return 3401 Is_Single_Task_Object (Task_Typ) 3402 and then Nkind (Decl) = N_Object_Declaration 3403 and then Defining_Entity (Decl) = Task_Typ; 3404 end Is_Single_Task_Pragma; 3405 3406 -- Local variables 3407 3408 Conc_Obj : constant Entity_Id := Encapsulating_State (Var_Id); 3409 Par : Node_Id; 3410 Prag_Nam : Name_Id; 3411 Prev : Node_Id; 3412 3413 -- Start of processing for Check_Part_Of_Reference 3414 3415 begin 3416 -- Nothing to do when the variable was recorded, but did not become a 3417 -- constituent of a single concurrent type. 3418 3419 if No (Conc_Obj) then 3420 return; 3421 end if; 3422 3423 -- Traverse the parent chain looking for a suitable context for the 3424 -- reference to the concurrent constituent. 3425 3426 Prev := Ref; 3427 Par := Parent (Prev); 3428 while Present (Par) loop 3429 if Nkind (Par) = N_Pragma then 3430 Prag_Nam := Pragma_Name (Par); 3431 3432 -- A concurrent constituent is allowed to appear in pragmas 3433 -- Initial_Condition and Initializes as this is part of the 3434 -- elaboration checks for the constituent (SPARK RM 9(3)). 3435 3436 if Nam_In (Prag_Nam, Name_Initial_Condition, Name_Initializes) then 3437 return; 3438 3439 -- When the reference appears within pragma Depends or Global, 3440 -- check whether the pragma applies to a single task type. Note 3441 -- that the pragma may not encapsulated by the type definition, 3442 -- but this is still a valid context. 3443 3444 elsif Nam_In (Prag_Nam, Name_Depends, Name_Global) 3445 and then Is_Single_Task_Pragma (Par, Conc_Obj) 3446 then 3447 return; 3448 end if; 3449 3450 -- The reference appears somewhere in the definition of a single 3451 -- concurrent type (SPARK RM 9(3)). 3452 3453 elsif Nkind_In (Par, N_Single_Protected_Declaration, 3454 N_Single_Task_Declaration) 3455 and then Defining_Entity (Par) = Conc_Obj 3456 then 3457 return; 3458 3459 -- The reference appears within the declaration or body of a single 3460 -- concurrent type (SPARK RM 9(3)). 3461 3462 elsif Nkind_In (Par, N_Protected_Body, 3463 N_Protected_Type_Declaration, 3464 N_Task_Body, 3465 N_Task_Type_Declaration) 3466 and then Is_Single_Declaration_Or_Body (Par, Conc_Obj) 3467 then 3468 return; 3469 3470 -- The reference appears within the statement list of the object's 3471 -- immediately enclosing package (SPARK RM 9(3)). 3472 3473 elsif Nkind (Par) = N_Package_Body 3474 and then Nkind (Prev) = N_Handled_Sequence_Of_Statements 3475 and then Is_Enclosing_Package_Body (Par, Var_Id) 3476 then 3477 return; 3478 3479 -- The reference has been relocated within an internally generated 3480 -- package or subprogram. Assume that the reference is legal as the 3481 -- real check was already performed in the original context of the 3482 -- reference. 3483 3484 elsif Nkind_In (Par, N_Package_Body, 3485 N_Package_Declaration, 3486 N_Subprogram_Body, 3487 N_Subprogram_Declaration) 3488 and then Is_Internal_Declaration_Or_Body (Par) 3489 then 3490 return; 3491 3492 -- The reference has been relocated to an inlined body for GNATprove. 3493 -- Assume that the reference is legal as the real check was already 3494 -- performed in the original context of the reference. 3495 3496 elsif GNATprove_Mode 3497 and then Nkind (Par) = N_Subprogram_Body 3498 and then Chars (Defining_Entity (Par)) = Name_uParent 3499 then 3500 return; 3501 end if; 3502 3503 Prev := Par; 3504 Par := Parent (Prev); 3505 end loop; 3506 3507 -- At this point it is known that the reference does not appear within a 3508 -- legal context. 3509 3510 Error_Msg_NE 3511 ("reference to variable & cannot appear in this context", Ref, Var_Id); 3512 Error_Msg_Name_1 := Chars (Var_Id); 3513 3514 if Is_Single_Protected_Object (Conc_Obj) then 3515 Error_Msg_NE 3516 ("\% is constituent of single protected type &", Ref, Conc_Obj); 3517 3518 else 3519 Error_Msg_NE 3520 ("\% is constituent of single task type &", Ref, Conc_Obj); 3521 end if; 3522 end Check_Part_Of_Reference; 3523 3524 ------------------------------------------ 3525 -- Check_Potentially_Blocking_Operation -- 3526 ------------------------------------------ 3527 3528 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is 3529 S : Entity_Id; 3530 3531 begin 3532 -- N is one of the potentially blocking operations listed in 9.5.1(8). 3533 -- When pragma Detect_Blocking is active, the run time will raise 3534 -- Program_Error. Here we only issue a warning, since we generally 3535 -- support the use of potentially blocking operations in the absence 3536 -- of the pragma. 3537 3538 -- Indirect blocking through a subprogram call cannot be diagnosed 3539 -- statically without interprocedural analysis, so we do not attempt 3540 -- to do it here. 3541 3542 S := Scope (Current_Scope); 3543 while Present (S) and then S /= Standard_Standard loop 3544 if Is_Protected_Type (S) then 3545 Error_Msg_N 3546 ("potentially blocking operation in protected operation??", N); 3547 return; 3548 end if; 3549 3550 S := Scope (S); 3551 end loop; 3552 end Check_Potentially_Blocking_Operation; 3553 3554 ------------------------------------ 3555 -- Check_Previous_Null_Procedure -- 3556 ------------------------------------ 3557 3558 procedure Check_Previous_Null_Procedure 3559 (Decl : Node_Id; 3560 Prev : Entity_Id) 3561 is 3562 begin 3563 if Ekind (Prev) = E_Procedure 3564 and then Nkind (Parent (Prev)) = N_Procedure_Specification 3565 and then Null_Present (Parent (Prev)) 3566 then 3567 Error_Msg_Sloc := Sloc (Prev); 3568 Error_Msg_N 3569 ("declaration cannot complete previous null procedure#", Decl); 3570 end if; 3571 end Check_Previous_Null_Procedure; 3572 3573 --------------------------------- 3574 -- Check_Result_And_Post_State -- 3575 --------------------------------- 3576 3577 procedure Check_Result_And_Post_State (Subp_Id : Entity_Id) is 3578 procedure Check_Result_And_Post_State_In_Pragma 3579 (Prag : Node_Id; 3580 Result_Seen : in out Boolean); 3581 -- Determine whether pragma Prag mentions attribute 'Result and whether 3582 -- the pragma contains an expression that evaluates differently in pre- 3583 -- and post-state. Prag is a [refined] postcondition or a contract-cases 3584 -- pragma. Result_Seen is set when the pragma mentions attribute 'Result 3585 3586 function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean; 3587 -- Determine whether subprogram Subp_Id contains at least one IN OUT 3588 -- formal parameter. 3589 3590 ------------------------------------------- 3591 -- Check_Result_And_Post_State_In_Pragma -- 3592 ------------------------------------------- 3593 3594 procedure Check_Result_And_Post_State_In_Pragma 3595 (Prag : Node_Id; 3596 Result_Seen : in out Boolean) 3597 is 3598 procedure Check_Conjunct (Expr : Node_Id); 3599 -- Check an individual conjunct in a conjunction of Boolean 3600 -- expressions, connected by "and" or "and then" operators. 3601 3602 procedure Check_Conjuncts (Expr : Node_Id); 3603 -- Apply the post-state check to every conjunct in an expression, in 3604 -- case this is a conjunction of Boolean expressions. Otherwise apply 3605 -- it to the expression as a whole. 3606 3607 procedure Check_Expression (Expr : Node_Id); 3608 -- Perform the 'Result and post-state checks on a given expression 3609 3610 function Is_Function_Result (N : Node_Id) return Traverse_Result; 3611 -- Attempt to find attribute 'Result in a subtree denoted by N 3612 3613 function Is_Trivial_Boolean (N : Node_Id) return Boolean; 3614 -- Determine whether source node N denotes "True" or "False" 3615 3616 function Mentions_Post_State (N : Node_Id) return Boolean; 3617 -- Determine whether a subtree denoted by N mentions any construct 3618 -- that denotes a post-state. 3619 3620 procedure Check_Function_Result is 3621 new Traverse_Proc (Is_Function_Result); 3622 3623 -------------------- 3624 -- Check_Conjunct -- 3625 -------------------- 3626 3627 procedure Check_Conjunct (Expr : Node_Id) is 3628 function Adjust_Message (Msg : String) return String; 3629 -- Prepend a prefix to the input message Msg denoting that the 3630 -- message applies to a conjunct in the expression, when this 3631 -- is the case. 3632 3633 function Applied_On_Conjunct return Boolean; 3634 -- Returns True if the message applies to a conjunct in the 3635 -- expression, instead of the whole expression. 3636 3637 function Has_Global_Output (Subp : Entity_Id) return Boolean; 3638 -- Returns True if Subp has an output in its Global contract 3639 3640 function Has_No_Output (Subp : Entity_Id) return Boolean; 3641 -- Returns True if Subp has no declared output: no function 3642 -- result, no output parameter, and no output in its Global 3643 -- contract. 3644 3645 -------------------- 3646 -- Adjust_Message -- 3647 -------------------- 3648 3649 function Adjust_Message (Msg : String) return String is 3650 begin 3651 if Applied_On_Conjunct then 3652 return "conjunct in " & Msg; 3653 else 3654 return Msg; 3655 end if; 3656 end Adjust_Message; 3657 3658 ------------------------- 3659 -- Applied_On_Conjunct -- 3660 ------------------------- 3661 3662 function Applied_On_Conjunct return Boolean is 3663 begin 3664 -- Expr is the conjunct of an enclosing "and" expression 3665 3666 return Nkind (Parent (Expr)) in N_Subexpr 3667 3668 -- or Expr is a conjunct of an enclosing "and then" 3669 -- expression in a postcondition aspect that was split into 3670 -- multiple pragmas. The first conjunct has the "and then" 3671 -- expression as Original_Node, and other conjuncts have 3672 -- Split_PCC set to True. 3673 3674 or else Nkind (Original_Node (Expr)) = N_And_Then 3675 or else Split_PPC (Prag); 3676 end Applied_On_Conjunct; 3677 3678 ----------------------- 3679 -- Has_Global_Output -- 3680 ----------------------- 3681 3682 function Has_Global_Output (Subp : Entity_Id) return Boolean is 3683 Global : constant Node_Id := Get_Pragma (Subp, Pragma_Global); 3684 List : Node_Id; 3685 Assoc : Node_Id; 3686 3687 begin 3688 if No (Global) then 3689 return False; 3690 end if; 3691 3692 List := Expression (Get_Argument (Global, Subp)); 3693 3694 -- Empty list (no global items) or single global item 3695 -- declaration (only input items). 3696 3697 if Nkind_In (List, N_Null, 3698 N_Expanded_Name, 3699 N_Identifier, 3700 N_Selected_Component) 3701 then 3702 return False; 3703 3704 -- Simple global list (only input items) or moded global list 3705 -- declaration. 3706 3707 elsif Nkind (List) = N_Aggregate then 3708 if Present (Expressions (List)) then 3709 return False; 3710 3711 else 3712 Assoc := First (Component_Associations (List)); 3713 while Present (Assoc) loop 3714 if Chars (First (Choices (Assoc))) /= Name_Input then 3715 return True; 3716 end if; 3717 3718 Next (Assoc); 3719 end loop; 3720 3721 return False; 3722 end if; 3723 3724 -- To accommodate partial decoration of disabled SPARK 3725 -- features, this routine may be called with illegal input. 3726 -- If this is the case, do not raise Program_Error. 3727 3728 else 3729 return False; 3730 end if; 3731 end Has_Global_Output; 3732 3733 ------------------- 3734 -- Has_No_Output -- 3735 ------------------- 3736 3737 function Has_No_Output (Subp : Entity_Id) return Boolean is 3738 Param : Node_Id; 3739 3740 begin 3741 -- A function has its result as output 3742 3743 if Ekind (Subp) = E_Function then 3744 return False; 3745 end if; 3746 3747 -- An OUT or IN OUT parameter is an output 3748 3749 Param := First_Formal (Subp); 3750 while Present (Param) loop 3751 if Ekind_In (Param, E_Out_Parameter, E_In_Out_Parameter) then 3752 return False; 3753 end if; 3754 3755 Next_Formal (Param); 3756 end loop; 3757 3758 -- An item of mode Output or In_Out in the Global contract is 3759 -- an output. 3760 3761 if Has_Global_Output (Subp) then 3762 return False; 3763 end if; 3764 3765 return True; 3766 end Has_No_Output; 3767 3768 -- Local variables 3769 3770 Err_Node : Node_Id; 3771 -- Error node when reporting a warning on a (refined) 3772 -- postcondition. 3773 3774 -- Start of processing for Check_Conjunct 3775 3776 begin 3777 if Applied_On_Conjunct then 3778 Err_Node := Expr; 3779 else 3780 Err_Node := Prag; 3781 end if; 3782 3783 -- Do not report missing reference to outcome in postcondition if 3784 -- either the postcondition is trivially True or False, or if the 3785 -- subprogram is ghost and has no declared output. 3786 3787 if not Is_Trivial_Boolean (Expr) 3788 and then not Mentions_Post_State (Expr) 3789 and then not (Is_Ghost_Entity (Subp_Id) 3790 and then Has_No_Output (Subp_Id)) 3791 then 3792 if Pragma_Name (Prag) = Name_Contract_Cases then 3793 Error_Msg_NE (Adjust_Message 3794 ("contract case does not check the outcome of calling " 3795 & "&?T?"), Expr, Subp_Id); 3796 3797 elsif Pragma_Name (Prag) = Name_Refined_Post then 3798 Error_Msg_NE (Adjust_Message 3799 ("refined postcondition does not check the outcome of " 3800 & "calling &?T?"), Err_Node, Subp_Id); 3801 3802 else 3803 Error_Msg_NE (Adjust_Message 3804 ("postcondition does not check the outcome of calling " 3805 & "&?T?"), Err_Node, Subp_Id); 3806 end if; 3807 end if; 3808 end Check_Conjunct; 3809 3810 --------------------- 3811 -- Check_Conjuncts -- 3812 --------------------- 3813 3814 procedure Check_Conjuncts (Expr : Node_Id) is 3815 begin 3816 if Nkind_In (Expr, N_Op_And, N_And_Then) then 3817 Check_Conjuncts (Left_Opnd (Expr)); 3818 Check_Conjuncts (Right_Opnd (Expr)); 3819 else 3820 Check_Conjunct (Expr); 3821 end if; 3822 end Check_Conjuncts; 3823 3824 ---------------------- 3825 -- Check_Expression -- 3826 ---------------------- 3827 3828 procedure Check_Expression (Expr : Node_Id) is 3829 begin 3830 if not Is_Trivial_Boolean (Expr) then 3831 Check_Function_Result (Expr); 3832 Check_Conjuncts (Expr); 3833 end if; 3834 end Check_Expression; 3835 3836 ------------------------ 3837 -- Is_Function_Result -- 3838 ------------------------ 3839 3840 function Is_Function_Result (N : Node_Id) return Traverse_Result is 3841 begin 3842 if Is_Attribute_Result (N) then 3843 Result_Seen := True; 3844 return Abandon; 3845 3846 -- Continue the traversal 3847 3848 else 3849 return OK; 3850 end if; 3851 end Is_Function_Result; 3852 3853 ------------------------ 3854 -- Is_Trivial_Boolean -- 3855 ------------------------ 3856 3857 function Is_Trivial_Boolean (N : Node_Id) return Boolean is 3858 begin 3859 return 3860 Comes_From_Source (N) 3861 and then Is_Entity_Name (N) 3862 and then (Entity (N) = Standard_True 3863 or else 3864 Entity (N) = Standard_False); 3865 end Is_Trivial_Boolean; 3866 3867 ------------------------- 3868 -- Mentions_Post_State -- 3869 ------------------------- 3870 3871 function Mentions_Post_State (N : Node_Id) return Boolean is 3872 Post_State_Seen : Boolean := False; 3873 3874 function Is_Post_State (N : Node_Id) return Traverse_Result; 3875 -- Attempt to find a construct that denotes a post-state. If this 3876 -- is the case, set flag Post_State_Seen. 3877 3878 ------------------- 3879 -- Is_Post_State -- 3880 ------------------- 3881 3882 function Is_Post_State (N : Node_Id) return Traverse_Result is 3883 Ent : Entity_Id; 3884 3885 begin 3886 if Nkind_In (N, N_Explicit_Dereference, N_Function_Call) then 3887 Post_State_Seen := True; 3888 return Abandon; 3889 3890 elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then 3891 Ent := Entity (N); 3892 3893 -- Treat an undecorated reference as OK 3894 3895 if No (Ent) 3896 3897 -- A reference to an assignable entity is considered a 3898 -- change in the post-state of a subprogram. 3899 3900 or else Ekind_In (Ent, E_Generic_In_Out_Parameter, 3901 E_In_Out_Parameter, 3902 E_Out_Parameter, 3903 E_Variable) 3904 3905 -- The reference may be modified through a dereference 3906 3907 or else (Is_Access_Type (Etype (Ent)) 3908 and then Nkind (Parent (N)) = 3909 N_Selected_Component) 3910 then 3911 Post_State_Seen := True; 3912 return Abandon; 3913 end if; 3914 3915 elsif Nkind (N) = N_Attribute_Reference then 3916 if Attribute_Name (N) = Name_Old then 3917 return Skip; 3918 3919 elsif Attribute_Name (N) = Name_Result then 3920 Post_State_Seen := True; 3921 return Abandon; 3922 end if; 3923 end if; 3924 3925 return OK; 3926 end Is_Post_State; 3927 3928 procedure Find_Post_State is new Traverse_Proc (Is_Post_State); 3929 3930 -- Start of processing for Mentions_Post_State 3931 3932 begin 3933 Find_Post_State (N); 3934 3935 return Post_State_Seen; 3936 end Mentions_Post_State; 3937 3938 -- Local variables 3939 3940 Expr : constant Node_Id := 3941 Get_Pragma_Arg 3942 (First (Pragma_Argument_Associations (Prag))); 3943 Nam : constant Name_Id := Pragma_Name (Prag); 3944 CCase : Node_Id; 3945 3946 -- Start of processing for Check_Result_And_Post_State_In_Pragma 3947 3948 begin 3949 -- Examine all consequences 3950 3951 if Nam = Name_Contract_Cases then 3952 CCase := First (Component_Associations (Expr)); 3953 while Present (CCase) loop 3954 Check_Expression (Expression (CCase)); 3955 3956 Next (CCase); 3957 end loop; 3958 3959 -- Examine the expression of a postcondition 3960 3961 else pragma Assert (Nam_In (Nam, Name_Postcondition, 3962 Name_Refined_Post)); 3963 Check_Expression (Expr); 3964 end if; 3965 end Check_Result_And_Post_State_In_Pragma; 3966 3967 -------------------------- 3968 -- Has_In_Out_Parameter -- 3969 -------------------------- 3970 3971 function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean is 3972 Formal : Entity_Id; 3973 3974 begin 3975 -- Traverse the formals looking for an IN OUT parameter 3976 3977 Formal := First_Formal (Subp_Id); 3978 while Present (Formal) loop 3979 if Ekind (Formal) = E_In_Out_Parameter then 3980 return True; 3981 end if; 3982 3983 Next_Formal (Formal); 3984 end loop; 3985 3986 return False; 3987 end Has_In_Out_Parameter; 3988 3989 -- Local variables 3990 3991 Items : constant Node_Id := Contract (Subp_Id); 3992 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); 3993 Case_Prag : Node_Id := Empty; 3994 Post_Prag : Node_Id := Empty; 3995 Prag : Node_Id; 3996 Seen_In_Case : Boolean := False; 3997 Seen_In_Post : Boolean := False; 3998 Spec_Id : Entity_Id; 3999 4000 -- Start of processing for Check_Result_And_Post_State 4001 4002 begin 4003 -- The lack of attribute 'Result or a post-state is classified as a 4004 -- suspicious contract. Do not perform the check if the corresponding 4005 -- swich is not set. 4006 4007 if not Warn_On_Suspicious_Contract then 4008 return; 4009 4010 -- Nothing to do if there is no contract 4011 4012 elsif No (Items) then 4013 return; 4014 end if; 4015 4016 -- Retrieve the entity of the subprogram spec (if any) 4017 4018 if Nkind (Subp_Decl) = N_Subprogram_Body 4019 and then Present (Corresponding_Spec (Subp_Decl)) 4020 then 4021 Spec_Id := Corresponding_Spec (Subp_Decl); 4022 4023 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 4024 and then Present (Corresponding_Spec_Of_Stub (Subp_Decl)) 4025 then 4026 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl); 4027 4028 else 4029 Spec_Id := Subp_Id; 4030 end if; 4031 4032 -- Examine all postconditions for attribute 'Result and a post-state 4033 4034 Prag := Pre_Post_Conditions (Items); 4035 while Present (Prag) loop 4036 if Nam_In (Pragma_Name_Unmapped (Prag), 4037 Name_Postcondition, Name_Refined_Post) 4038 and then not Error_Posted (Prag) 4039 then 4040 Post_Prag := Prag; 4041 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Post); 4042 end if; 4043 4044 Prag := Next_Pragma (Prag); 4045 end loop; 4046 4047 -- Examine the contract cases of the subprogram for attribute 'Result 4048 -- and a post-state. 4049 4050 Prag := Contract_Test_Cases (Items); 4051 while Present (Prag) loop 4052 if Pragma_Name (Prag) = Name_Contract_Cases 4053 and then not Error_Posted (Prag) 4054 then 4055 Case_Prag := Prag; 4056 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Case); 4057 end if; 4058 4059 Prag := Next_Pragma (Prag); 4060 end loop; 4061 4062 -- Do not emit any errors if the subprogram is not a function 4063 4064 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then 4065 null; 4066 4067 -- Regardless of whether the function has postconditions or contract 4068 -- cases, or whether they mention attribute 'Result, an IN OUT formal 4069 -- parameter is always treated as a result. 4070 4071 elsif Has_In_Out_Parameter (Spec_Id) then 4072 null; 4073 4074 -- The function has both a postcondition and contract cases and they do 4075 -- not mention attribute 'Result. 4076 4077 elsif Present (Case_Prag) 4078 and then not Seen_In_Case 4079 and then Present (Post_Prag) 4080 and then not Seen_In_Post 4081 then 4082 Error_Msg_N 4083 ("neither postcondition nor contract cases mention function " 4084 & "result?T?", Post_Prag); 4085 4086 -- The function has contract cases only and they do not mention 4087 -- attribute 'Result. 4088 4089 elsif Present (Case_Prag) and then not Seen_In_Case then 4090 Error_Msg_N ("contract cases do not mention result?T?", Case_Prag); 4091 4092 -- The function has postconditions only and they do not mention 4093 -- attribute 'Result. 4094 4095 elsif Present (Post_Prag) and then not Seen_In_Post then 4096 Error_Msg_N 4097 ("postcondition does not mention function result?T?", Post_Prag); 4098 end if; 4099 end Check_Result_And_Post_State; 4100 4101 ----------------------------- 4102 -- Check_State_Refinements -- 4103 ----------------------------- 4104 4105 procedure Check_State_Refinements 4106 (Context : Node_Id; 4107 Is_Main_Unit : Boolean := False) 4108 is 4109 procedure Check_Package (Pack : Node_Id); 4110 -- Verify that all abstract states of a [generic] package denoted by its 4111 -- declarative node Pack have proper refinement. Recursively verify the 4112 -- visible and private declarations of the [generic] package for other 4113 -- nested packages. 4114 4115 procedure Check_Packages_In (Decls : List_Id); 4116 -- Seek out [generic] package declarations within declarative list Decls 4117 -- and verify the status of their abstract state refinement. 4118 4119 function SPARK_Mode_Is_Off (N : Node_Id) return Boolean; 4120 -- Determine whether construct N is subject to pragma SPARK_Mode Off 4121 4122 ------------------- 4123 -- Check_Package -- 4124 ------------------- 4125 4126 procedure Check_Package (Pack : Node_Id) is 4127 Body_Id : constant Entity_Id := Corresponding_Body (Pack); 4128 Spec : constant Node_Id := Specification (Pack); 4129 States : constant Elist_Id := 4130 Abstract_States (Defining_Entity (Pack)); 4131 4132 State_Elmt : Elmt_Id; 4133 State_Id : Entity_Id; 4134 4135 begin 4136 -- Do not verify proper state refinement when the package is subject 4137 -- to pragma SPARK_Mode Off because this disables the requirement for 4138 -- state refinement. 4139 4140 if SPARK_Mode_Is_Off (Pack) then 4141 null; 4142 4143 -- State refinement can only occur in a completing package body. Do 4144 -- not verify proper state refinement when the body is subject to 4145 -- pragma SPARK_Mode Off because this disables the requirement for 4146 -- state refinement. 4147 4148 elsif Present (Body_Id) 4149 and then SPARK_Mode_Is_Off (Unit_Declaration_Node (Body_Id)) 4150 then 4151 null; 4152 4153 -- Do not verify proper state refinement when the package is an 4154 -- instance as this check was already performed in the generic. 4155 4156 elsif Present (Generic_Parent (Spec)) then 4157 null; 4158 4159 -- Otherwise examine the contents of the package 4160 4161 else 4162 if Present (States) then 4163 State_Elmt := First_Elmt (States); 4164 while Present (State_Elmt) loop 4165 State_Id := Node (State_Elmt); 4166 4167 -- Emit an error when a non-null state lacks any form of 4168 -- refinement. 4169 4170 if not Is_Null_State (State_Id) 4171 and then not Has_Null_Refinement (State_Id) 4172 and then not Has_Non_Null_Refinement (State_Id) 4173 then 4174 Error_Msg_N ("state & requires refinement", State_Id); 4175 end if; 4176 4177 Next_Elmt (State_Elmt); 4178 end loop; 4179 end if; 4180 4181 Check_Packages_In (Visible_Declarations (Spec)); 4182 Check_Packages_In (Private_Declarations (Spec)); 4183 end if; 4184 end Check_Package; 4185 4186 ----------------------- 4187 -- Check_Packages_In -- 4188 ----------------------- 4189 4190 procedure Check_Packages_In (Decls : List_Id) is 4191 Decl : Node_Id; 4192 4193 begin 4194 if Present (Decls) then 4195 Decl := First (Decls); 4196 while Present (Decl) loop 4197 if Nkind_In (Decl, N_Generic_Package_Declaration, 4198 N_Package_Declaration) 4199 then 4200 Check_Package (Decl); 4201 end if; 4202 4203 Next (Decl); 4204 end loop; 4205 end if; 4206 end Check_Packages_In; 4207 4208 ----------------------- 4209 -- SPARK_Mode_Is_Off -- 4210 ----------------------- 4211 4212 function SPARK_Mode_Is_Off (N : Node_Id) return Boolean is 4213 Id : constant Entity_Id := Defining_Entity (N); 4214 Prag : constant Node_Id := SPARK_Pragma (Id); 4215 4216 begin 4217 -- Default the mode to "off" when the context is an instance and all 4218 -- SPARK_Mode pragmas found within are to be ignored. 4219 4220 if Ignore_SPARK_Mode_Pragmas (Id) then 4221 return True; 4222 4223 else 4224 return 4225 Present (Prag) 4226 and then Get_SPARK_Mode_From_Annotation (Prag) = Off; 4227 end if; 4228 end SPARK_Mode_Is_Off; 4229 4230 -- Start of processing for Check_State_Refinements 4231 4232 begin 4233 -- A block may declare a nested package 4234 4235 if Nkind (Context) = N_Block_Statement then 4236 Check_Packages_In (Declarations (Context)); 4237 4238 -- An entry, protected, subprogram, or task body may declare a nested 4239 -- package. 4240 4241 elsif Nkind_In (Context, N_Entry_Body, 4242 N_Protected_Body, 4243 N_Subprogram_Body, 4244 N_Task_Body) 4245 then 4246 -- Do not verify proper state refinement when the body is subject to 4247 -- pragma SPARK_Mode Off because this disables the requirement for 4248 -- state refinement. 4249 4250 if not SPARK_Mode_Is_Off (Context) then 4251 Check_Packages_In (Declarations (Context)); 4252 end if; 4253 4254 -- A package body may declare a nested package 4255 4256 elsif Nkind (Context) = N_Package_Body then 4257 Check_Package (Unit_Declaration_Node (Corresponding_Spec (Context))); 4258 4259 -- Do not verify proper state refinement when the body is subject to 4260 -- pragma SPARK_Mode Off because this disables the requirement for 4261 -- state refinement. 4262 4263 if not SPARK_Mode_Is_Off (Context) then 4264 Check_Packages_In (Declarations (Context)); 4265 end if; 4266 4267 -- A library level [generic] package may declare a nested package 4268 4269 elsif Nkind_In (Context, N_Generic_Package_Declaration, 4270 N_Package_Declaration) 4271 and then Is_Main_Unit 4272 then 4273 Check_Package (Context); 4274 end if; 4275 end Check_State_Refinements; 4276 4277 ------------------------------ 4278 -- Check_Unprotected_Access -- 4279 ------------------------------ 4280 4281 procedure Check_Unprotected_Access 4282 (Context : Node_Id; 4283 Expr : Node_Id) 4284 is 4285 Cont_Encl_Typ : Entity_Id; 4286 Pref_Encl_Typ : Entity_Id; 4287 4288 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id; 4289 -- Check whether Obj is a private component of a protected object. 4290 -- Return the protected type where the component resides, Empty 4291 -- otherwise. 4292 4293 function Is_Public_Operation return Boolean; 4294 -- Verify that the enclosing operation is callable from outside the 4295 -- protected object, to minimize false positives. 4296 4297 ------------------------------ 4298 -- Enclosing_Protected_Type -- 4299 ------------------------------ 4300 4301 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is 4302 begin 4303 if Is_Entity_Name (Obj) then 4304 declare 4305 Ent : Entity_Id := Entity (Obj); 4306 4307 begin 4308 -- The object can be a renaming of a private component, use 4309 -- the original record component. 4310 4311 if Is_Prival (Ent) then 4312 Ent := Prival_Link (Ent); 4313 end if; 4314 4315 if Is_Protected_Type (Scope (Ent)) then 4316 return Scope (Ent); 4317 end if; 4318 end; 4319 end if; 4320 4321 -- For indexed and selected components, recursively check the prefix 4322 4323 if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then 4324 return Enclosing_Protected_Type (Prefix (Obj)); 4325 4326 -- The object does not denote a protected component 4327 4328 else 4329 return Empty; 4330 end if; 4331 end Enclosing_Protected_Type; 4332 4333 ------------------------- 4334 -- Is_Public_Operation -- 4335 ------------------------- 4336 4337 function Is_Public_Operation return Boolean is 4338 S : Entity_Id; 4339 E : Entity_Id; 4340 4341 begin 4342 S := Current_Scope; 4343 while Present (S) and then S /= Pref_Encl_Typ loop 4344 if Scope (S) = Pref_Encl_Typ then 4345 E := First_Entity (Pref_Encl_Typ); 4346 while Present (E) 4347 and then E /= First_Private_Entity (Pref_Encl_Typ) 4348 loop 4349 if E = S then 4350 return True; 4351 end if; 4352 4353 Next_Entity (E); 4354 end loop; 4355 end if; 4356 4357 S := Scope (S); 4358 end loop; 4359 4360 return False; 4361 end Is_Public_Operation; 4362 4363 -- Start of processing for Check_Unprotected_Access 4364 4365 begin 4366 if Nkind (Expr) = N_Attribute_Reference 4367 and then Attribute_Name (Expr) = Name_Unchecked_Access 4368 then 4369 Cont_Encl_Typ := Enclosing_Protected_Type (Context); 4370 Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr)); 4371 4372 -- Check whether we are trying to export a protected component to a 4373 -- context with an equal or lower access level. 4374 4375 if Present (Pref_Encl_Typ) 4376 and then No (Cont_Encl_Typ) 4377 and then Is_Public_Operation 4378 and then Scope_Depth (Pref_Encl_Typ) >= 4379 Object_Access_Level (Context) 4380 then 4381 Error_Msg_N 4382 ("??possible unprotected access to protected data", Expr); 4383 end if; 4384 end if; 4385 end Check_Unprotected_Access; 4386 4387 ------------------------------ 4388 -- Check_Unused_Body_States -- 4389 ------------------------------ 4390 4391 procedure Check_Unused_Body_States (Body_Id : Entity_Id) is 4392 procedure Process_Refinement_Clause 4393 (Clause : Node_Id; 4394 States : Elist_Id); 4395 -- Inspect all constituents of refinement clause Clause and remove any 4396 -- matches from body state list States. 4397 4398 procedure Report_Unused_Body_States (States : Elist_Id); 4399 -- Emit errors for each abstract state or object found in list States 4400 4401 ------------------------------- 4402 -- Process_Refinement_Clause -- 4403 ------------------------------- 4404 4405 procedure Process_Refinement_Clause 4406 (Clause : Node_Id; 4407 States : Elist_Id) 4408 is 4409 procedure Process_Constituent (Constit : Node_Id); 4410 -- Remove constituent Constit from body state list States 4411 4412 ------------------------- 4413 -- Process_Constituent -- 4414 ------------------------- 4415 4416 procedure Process_Constituent (Constit : Node_Id) is 4417 Constit_Id : Entity_Id; 4418 4419 begin 4420 -- Guard against illegal constituents. Only abstract states and 4421 -- objects can appear on the right hand side of a refinement. 4422 4423 if Is_Entity_Name (Constit) then 4424 Constit_Id := Entity_Of (Constit); 4425 4426 if Present (Constit_Id) 4427 and then Ekind_In (Constit_Id, E_Abstract_State, 4428 E_Constant, 4429 E_Variable) 4430 then 4431 Remove (States, Constit_Id); 4432 end if; 4433 end if; 4434 end Process_Constituent; 4435 4436 -- Local variables 4437 4438 Constit : Node_Id; 4439 4440 -- Start of processing for Process_Refinement_Clause 4441 4442 begin 4443 if Nkind (Clause) = N_Component_Association then 4444 Constit := Expression (Clause); 4445 4446 -- Multiple constituents appear as an aggregate 4447 4448 if Nkind (Constit) = N_Aggregate then 4449 Constit := First (Expressions (Constit)); 4450 while Present (Constit) loop 4451 Process_Constituent (Constit); 4452 Next (Constit); 4453 end loop; 4454 4455 -- Various forms of a single constituent 4456 4457 else 4458 Process_Constituent (Constit); 4459 end if; 4460 end if; 4461 end Process_Refinement_Clause; 4462 4463 ------------------------------- 4464 -- Report_Unused_Body_States -- 4465 ------------------------------- 4466 4467 procedure Report_Unused_Body_States (States : Elist_Id) is 4468 Posted : Boolean := False; 4469 State_Elmt : Elmt_Id; 4470 State_Id : Entity_Id; 4471 4472 begin 4473 if Present (States) then 4474 State_Elmt := First_Elmt (States); 4475 while Present (State_Elmt) loop 4476 State_Id := Node (State_Elmt); 4477 4478 -- Constants are part of the hidden state of a package, but the 4479 -- compiler cannot determine whether they have variable input 4480 -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a 4481 -- hidden state. Do not emit an error when a constant does not 4482 -- participate in a state refinement, even though it acts as a 4483 -- hidden state. 4484 4485 if Ekind (State_Id) = E_Constant then 4486 null; 4487 4488 -- Generate an error message of the form: 4489 4490 -- body of package ... has unused hidden states 4491 -- abstract state ... defined at ... 4492 -- variable ... defined at ... 4493 4494 else 4495 if not Posted then 4496 Posted := True; 4497 SPARK_Msg_N 4498 ("body of package & has unused hidden states", Body_Id); 4499 end if; 4500 4501 Error_Msg_Sloc := Sloc (State_Id); 4502 4503 if Ekind (State_Id) = E_Abstract_State then 4504 SPARK_Msg_NE 4505 ("\abstract state & defined #", Body_Id, State_Id); 4506 4507 else 4508 SPARK_Msg_NE ("\variable & defined #", Body_Id, State_Id); 4509 end if; 4510 end if; 4511 4512 Next_Elmt (State_Elmt); 4513 end loop; 4514 end if; 4515 end Report_Unused_Body_States; 4516 4517 -- Local variables 4518 4519 Prag : constant Node_Id := Get_Pragma (Body_Id, Pragma_Refined_State); 4520 Spec_Id : constant Entity_Id := Spec_Entity (Body_Id); 4521 Clause : Node_Id; 4522 States : Elist_Id; 4523 4524 -- Start of processing for Check_Unused_Body_States 4525 4526 begin 4527 -- Inspect the clauses of pragma Refined_State and determine whether all 4528 -- visible states declared within the package body participate in the 4529 -- refinement. 4530 4531 if Present (Prag) then 4532 Clause := Expression (Get_Argument (Prag, Spec_Id)); 4533 States := Collect_Body_States (Body_Id); 4534 4535 -- Multiple non-null state refinements appear as an aggregate 4536 4537 if Nkind (Clause) = N_Aggregate then 4538 Clause := First (Component_Associations (Clause)); 4539 while Present (Clause) loop 4540 Process_Refinement_Clause (Clause, States); 4541 Next (Clause); 4542 end loop; 4543 4544 -- Various forms of a single state refinement 4545 4546 else 4547 Process_Refinement_Clause (Clause, States); 4548 end if; 4549 4550 -- Ensure that all abstract states and objects declared in the 4551 -- package body state space are utilized as constituents. 4552 4553 Report_Unused_Body_States (States); 4554 end if; 4555 end Check_Unused_Body_States; 4556 4557 ----------------- 4558 -- Choice_List -- 4559 ----------------- 4560 4561 function Choice_List (N : Node_Id) return List_Id is 4562 begin 4563 if Nkind (N) = N_Iterated_Component_Association then 4564 return Discrete_Choices (N); 4565 else 4566 return Choices (N); 4567 end if; 4568 end Choice_List; 4569 4570 ------------------------- 4571 -- Collect_Body_States -- 4572 ------------------------- 4573 4574 function Collect_Body_States (Body_Id : Entity_Id) return Elist_Id is 4575 function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean; 4576 -- Determine whether object Obj_Id is a suitable visible state of a 4577 -- package body. 4578 4579 procedure Collect_Visible_States 4580 (Pack_Id : Entity_Id; 4581 States : in out Elist_Id); 4582 -- Gather the entities of all abstract states and objects declared in 4583 -- the visible state space of package Pack_Id. 4584 4585 ---------------------------- 4586 -- Collect_Visible_States -- 4587 ---------------------------- 4588 4589 procedure Collect_Visible_States 4590 (Pack_Id : Entity_Id; 4591 States : in out Elist_Id) 4592 is 4593 Item_Id : Entity_Id; 4594 4595 begin 4596 -- Traverse the entity chain of the package and inspect all visible 4597 -- items. 4598 4599 Item_Id := First_Entity (Pack_Id); 4600 while Present (Item_Id) and then not In_Private_Part (Item_Id) loop 4601 4602 -- Do not consider internally generated items as those cannot be 4603 -- named and participate in refinement. 4604 4605 if not Comes_From_Source (Item_Id) then 4606 null; 4607 4608 elsif Ekind (Item_Id) = E_Abstract_State then 4609 Append_New_Elmt (Item_Id, States); 4610 4611 elsif Ekind_In (Item_Id, E_Constant, E_Variable) 4612 and then Is_Visible_Object (Item_Id) 4613 then 4614 Append_New_Elmt (Item_Id, States); 4615 4616 -- Recursively gather the visible states of a nested package 4617 4618 elsif Ekind (Item_Id) = E_Package then 4619 Collect_Visible_States (Item_Id, States); 4620 end if; 4621 4622 Next_Entity (Item_Id); 4623 end loop; 4624 end Collect_Visible_States; 4625 4626 ----------------------- 4627 -- Is_Visible_Object -- 4628 ----------------------- 4629 4630 function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean is 4631 begin 4632 -- Objects that map generic formals to their actuals are not visible 4633 -- from outside the generic instantiation. 4634 4635 if Present (Corresponding_Generic_Association 4636 (Declaration_Node (Obj_Id))) 4637 then 4638 return False; 4639 4640 -- Constituents of a single protected/task type act as components of 4641 -- the type and are not visible from outside the type. 4642 4643 elsif Ekind (Obj_Id) = E_Variable 4644 and then Present (Encapsulating_State (Obj_Id)) 4645 and then Is_Single_Concurrent_Object (Encapsulating_State (Obj_Id)) 4646 then 4647 return False; 4648 4649 else 4650 return True; 4651 end if; 4652 end Is_Visible_Object; 4653 4654 -- Local variables 4655 4656 Body_Decl : constant Node_Id := Unit_Declaration_Node (Body_Id); 4657 Decl : Node_Id; 4658 Item_Id : Entity_Id; 4659 States : Elist_Id := No_Elist; 4660 4661 -- Start of processing for Collect_Body_States 4662 4663 begin 4664 -- Inspect the declarations of the body looking for source objects, 4665 -- packages and package instantiations. Note that even though this 4666 -- processing is very similar to Collect_Visible_States, a package 4667 -- body does not have a First/Next_Entity list. 4668 4669 Decl := First (Declarations (Body_Decl)); 4670 while Present (Decl) loop 4671 4672 -- Capture source objects as internally generated temporaries cannot 4673 -- be named and participate in refinement. 4674 4675 if Nkind (Decl) = N_Object_Declaration then 4676 Item_Id := Defining_Entity (Decl); 4677 4678 if Comes_From_Source (Item_Id) 4679 and then Is_Visible_Object (Item_Id) 4680 then 4681 Append_New_Elmt (Item_Id, States); 4682 end if; 4683 4684 -- Capture the visible abstract states and objects of a source 4685 -- package [instantiation]. 4686 4687 elsif Nkind (Decl) = N_Package_Declaration then 4688 Item_Id := Defining_Entity (Decl); 4689 4690 if Comes_From_Source (Item_Id) then 4691 Collect_Visible_States (Item_Id, States); 4692 end if; 4693 end if; 4694 4695 Next (Decl); 4696 end loop; 4697 4698 return States; 4699 end Collect_Body_States; 4700 4701 ------------------------ 4702 -- Collect_Interfaces -- 4703 ------------------------ 4704 4705 procedure Collect_Interfaces 4706 (T : Entity_Id; 4707 Ifaces_List : out Elist_Id; 4708 Exclude_Parents : Boolean := False; 4709 Use_Full_View : Boolean := True) 4710 is 4711 procedure Collect (Typ : Entity_Id); 4712 -- Subsidiary subprogram used to traverse the whole list 4713 -- of directly and indirectly implemented interfaces 4714 4715 ------------- 4716 -- Collect -- 4717 ------------- 4718 4719 procedure Collect (Typ : Entity_Id) is 4720 Ancestor : Entity_Id; 4721 Full_T : Entity_Id; 4722 Id : Node_Id; 4723 Iface : Entity_Id; 4724 4725 begin 4726 Full_T := Typ; 4727 4728 -- Handle private types and subtypes 4729 4730 if Use_Full_View 4731 and then Is_Private_Type (Typ) 4732 and then Present (Full_View (Typ)) 4733 then 4734 Full_T := Full_View (Typ); 4735 4736 if Ekind (Full_T) = E_Record_Subtype then 4737 Full_T := Etype (Typ); 4738 4739 if Present (Full_View (Full_T)) then 4740 Full_T := Full_View (Full_T); 4741 end if; 4742 end if; 4743 end if; 4744 4745 -- Include the ancestor if we are generating the whole list of 4746 -- abstract interfaces. 4747 4748 if Etype (Full_T) /= Typ 4749 4750 -- Protect the frontend against wrong sources. For example: 4751 4752 -- package P is 4753 -- type A is tagged null record; 4754 -- type B is new A with private; 4755 -- type C is new A with private; 4756 -- private 4757 -- type B is new C with null record; 4758 -- type C is new B with null record; 4759 -- end P; 4760 4761 and then Etype (Full_T) /= T 4762 then 4763 Ancestor := Etype (Full_T); 4764 Collect (Ancestor); 4765 4766 if Is_Interface (Ancestor) and then not Exclude_Parents then 4767 Append_Unique_Elmt (Ancestor, Ifaces_List); 4768 end if; 4769 end if; 4770 4771 -- Traverse the graph of ancestor interfaces 4772 4773 if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then 4774 Id := First (Abstract_Interface_List (Full_T)); 4775 while Present (Id) loop 4776 Iface := Etype (Id); 4777 4778 -- Protect against wrong uses. For example: 4779 -- type I is interface; 4780 -- type O is tagged null record; 4781 -- type Wrong is new I and O with null record; -- ERROR 4782 4783 if Is_Interface (Iface) then 4784 if Exclude_Parents 4785 and then Etype (T) /= T 4786 and then Interface_Present_In_Ancestor (Etype (T), Iface) 4787 then 4788 null; 4789 else 4790 Collect (Iface); 4791 Append_Unique_Elmt (Iface, Ifaces_List); 4792 end if; 4793 end if; 4794 4795 Next (Id); 4796 end loop; 4797 end if; 4798 end Collect; 4799 4800 -- Start of processing for Collect_Interfaces 4801 4802 begin 4803 pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T)); 4804 Ifaces_List := New_Elmt_List; 4805 Collect (T); 4806 end Collect_Interfaces; 4807 4808 ---------------------------------- 4809 -- Collect_Interface_Components -- 4810 ---------------------------------- 4811 4812 procedure Collect_Interface_Components 4813 (Tagged_Type : Entity_Id; 4814 Components_List : out Elist_Id) 4815 is 4816 procedure Collect (Typ : Entity_Id); 4817 -- Subsidiary subprogram used to climb to the parents 4818 4819 ------------- 4820 -- Collect -- 4821 ------------- 4822 4823 procedure Collect (Typ : Entity_Id) is 4824 Tag_Comp : Entity_Id; 4825 Parent_Typ : Entity_Id; 4826 4827 begin 4828 -- Handle private types 4829 4830 if Present (Full_View (Etype (Typ))) then 4831 Parent_Typ := Full_View (Etype (Typ)); 4832 else 4833 Parent_Typ := Etype (Typ); 4834 end if; 4835 4836 if Parent_Typ /= Typ 4837 4838 -- Protect the frontend against wrong sources. For example: 4839 4840 -- package P is 4841 -- type A is tagged null record; 4842 -- type B is new A with private; 4843 -- type C is new A with private; 4844 -- private 4845 -- type B is new C with null record; 4846 -- type C is new B with null record; 4847 -- end P; 4848 4849 and then Parent_Typ /= Tagged_Type 4850 then 4851 Collect (Parent_Typ); 4852 end if; 4853 4854 -- Collect the components containing tags of secondary dispatch 4855 -- tables. 4856 4857 Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ)); 4858 while Present (Tag_Comp) loop 4859 pragma Assert (Present (Related_Type (Tag_Comp))); 4860 Append_Elmt (Tag_Comp, Components_List); 4861 4862 Tag_Comp := Next_Tag_Component (Tag_Comp); 4863 end loop; 4864 end Collect; 4865 4866 -- Start of processing for Collect_Interface_Components 4867 4868 begin 4869 pragma Assert (Ekind (Tagged_Type) = E_Record_Type 4870 and then Is_Tagged_Type (Tagged_Type)); 4871 4872 Components_List := New_Elmt_List; 4873 Collect (Tagged_Type); 4874 end Collect_Interface_Components; 4875 4876 ----------------------------- 4877 -- Collect_Interfaces_Info -- 4878 ----------------------------- 4879 4880 procedure Collect_Interfaces_Info 4881 (T : Entity_Id; 4882 Ifaces_List : out Elist_Id; 4883 Components_List : out Elist_Id; 4884 Tags_List : out Elist_Id) 4885 is 4886 Comps_List : Elist_Id; 4887 Comp_Elmt : Elmt_Id; 4888 Comp_Iface : Entity_Id; 4889 Iface_Elmt : Elmt_Id; 4890 Iface : Entity_Id; 4891 4892 function Search_Tag (Iface : Entity_Id) return Entity_Id; 4893 -- Search for the secondary tag associated with the interface type 4894 -- Iface that is implemented by T. 4895 4896 ---------------- 4897 -- Search_Tag -- 4898 ---------------- 4899 4900 function Search_Tag (Iface : Entity_Id) return Entity_Id is 4901 ADT : Elmt_Id; 4902 begin 4903 if not Is_CPP_Class (T) then 4904 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T)))); 4905 else 4906 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T))); 4907 end if; 4908 4909 while Present (ADT) 4910 and then Is_Tag (Node (ADT)) 4911 and then Related_Type (Node (ADT)) /= Iface 4912 loop 4913 -- Skip secondary dispatch table referencing thunks to user 4914 -- defined primitives covered by this interface. 4915 4916 pragma Assert (Has_Suffix (Node (ADT), 'P')); 4917 Next_Elmt (ADT); 4918 4919 -- Skip secondary dispatch tables of Ada types 4920 4921 if not Is_CPP_Class (T) then 4922 4923 -- Skip secondary dispatch table referencing thunks to 4924 -- predefined primitives. 4925 4926 pragma Assert (Has_Suffix (Node (ADT), 'Y')); 4927 Next_Elmt (ADT); 4928 4929 -- Skip secondary dispatch table referencing user-defined 4930 -- primitives covered by this interface. 4931 4932 pragma Assert (Has_Suffix (Node (ADT), 'D')); 4933 Next_Elmt (ADT); 4934 4935 -- Skip secondary dispatch table referencing predefined 4936 -- primitives. 4937 4938 pragma Assert (Has_Suffix (Node (ADT), 'Z')); 4939 Next_Elmt (ADT); 4940 end if; 4941 end loop; 4942 4943 pragma Assert (Is_Tag (Node (ADT))); 4944 return Node (ADT); 4945 end Search_Tag; 4946 4947 -- Start of processing for Collect_Interfaces_Info 4948 4949 begin 4950 Collect_Interfaces (T, Ifaces_List); 4951 Collect_Interface_Components (T, Comps_List); 4952 4953 -- Search for the record component and tag associated with each 4954 -- interface type of T. 4955 4956 Components_List := New_Elmt_List; 4957 Tags_List := New_Elmt_List; 4958 4959 Iface_Elmt := First_Elmt (Ifaces_List); 4960 while Present (Iface_Elmt) loop 4961 Iface := Node (Iface_Elmt); 4962 4963 -- Associate the primary tag component and the primary dispatch table 4964 -- with all the interfaces that are parents of T 4965 4966 if Is_Ancestor (Iface, T, Use_Full_View => True) then 4967 Append_Elmt (First_Tag_Component (T), Components_List); 4968 Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List); 4969 4970 -- Otherwise search for the tag component and secondary dispatch 4971 -- table of Iface 4972 4973 else 4974 Comp_Elmt := First_Elmt (Comps_List); 4975 while Present (Comp_Elmt) loop 4976 Comp_Iface := Related_Type (Node (Comp_Elmt)); 4977 4978 if Comp_Iface = Iface 4979 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True) 4980 then 4981 Append_Elmt (Node (Comp_Elmt), Components_List); 4982 Append_Elmt (Search_Tag (Comp_Iface), Tags_List); 4983 exit; 4984 end if; 4985 4986 Next_Elmt (Comp_Elmt); 4987 end loop; 4988 pragma Assert (Present (Comp_Elmt)); 4989 end if; 4990 4991 Next_Elmt (Iface_Elmt); 4992 end loop; 4993 end Collect_Interfaces_Info; 4994 4995 --------------------- 4996 -- Collect_Parents -- 4997 --------------------- 4998 4999 procedure Collect_Parents 5000 (T : Entity_Id; 5001 List : out Elist_Id; 5002 Use_Full_View : Boolean := True) 5003 is 5004 Current_Typ : Entity_Id := T; 5005 Parent_Typ : Entity_Id; 5006 5007 begin 5008 List := New_Elmt_List; 5009 5010 -- No action if the if the type has no parents 5011 5012 if T = Etype (T) then 5013 return; 5014 end if; 5015 5016 loop 5017 Parent_Typ := Etype (Current_Typ); 5018 5019 if Is_Private_Type (Parent_Typ) 5020 and then Present (Full_View (Parent_Typ)) 5021 and then Use_Full_View 5022 then 5023 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 5024 end if; 5025 5026 Append_Elmt (Parent_Typ, List); 5027 5028 exit when Parent_Typ = Current_Typ; 5029 Current_Typ := Parent_Typ; 5030 end loop; 5031 end Collect_Parents; 5032 5033 ---------------------------------- 5034 -- Collect_Primitive_Operations -- 5035 ---------------------------------- 5036 5037 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is 5038 B_Type : constant Entity_Id := Base_Type (T); 5039 B_Decl : constant Node_Id := Original_Node (Parent (B_Type)); 5040 B_Scope : Entity_Id := Scope (B_Type); 5041 Op_List : Elist_Id; 5042 Formal : Entity_Id; 5043 Is_Prim : Boolean; 5044 Is_Type_In_Pkg : Boolean; 5045 Formal_Derived : Boolean := False; 5046 Id : Entity_Id; 5047 5048 function Match (E : Entity_Id) return Boolean; 5049 -- True if E's base type is B_Type, or E is of an anonymous access type 5050 -- and the base type of its designated type is B_Type. 5051 5052 ----------- 5053 -- Match -- 5054 ----------- 5055 5056 function Match (E : Entity_Id) return Boolean is 5057 Etyp : Entity_Id := Etype (E); 5058 5059 begin 5060 if Ekind (Etyp) = E_Anonymous_Access_Type then 5061 Etyp := Designated_Type (Etyp); 5062 end if; 5063 5064 -- In Ada 2012 a primitive operation may have a formal of an 5065 -- incomplete view of the parent type. 5066 5067 return Base_Type (Etyp) = B_Type 5068 or else 5069 (Ada_Version >= Ada_2012 5070 and then Ekind (Etyp) = E_Incomplete_Type 5071 and then Full_View (Etyp) = B_Type); 5072 end Match; 5073 5074 -- Start of processing for Collect_Primitive_Operations 5075 5076 begin 5077 -- For tagged types, the primitive operations are collected as they 5078 -- are declared, and held in an explicit list which is simply returned. 5079 5080 if Is_Tagged_Type (B_Type) then 5081 return Primitive_Operations (B_Type); 5082 5083 -- An untagged generic type that is a derived type inherits the 5084 -- primitive operations of its parent type. Other formal types only 5085 -- have predefined operators, which are not explicitly represented. 5086 5087 elsif Is_Generic_Type (B_Type) then 5088 if Nkind (B_Decl) = N_Formal_Type_Declaration 5089 and then Nkind (Formal_Type_Definition (B_Decl)) = 5090 N_Formal_Derived_Type_Definition 5091 then 5092 Formal_Derived := True; 5093 else 5094 return New_Elmt_List; 5095 end if; 5096 end if; 5097 5098 Op_List := New_Elmt_List; 5099 5100 if B_Scope = Standard_Standard then 5101 if B_Type = Standard_String then 5102 Append_Elmt (Standard_Op_Concat, Op_List); 5103 5104 elsif B_Type = Standard_Wide_String then 5105 Append_Elmt (Standard_Op_Concatw, Op_List); 5106 5107 else 5108 null; 5109 end if; 5110 5111 -- Locate the primitive subprograms of the type 5112 5113 else 5114 -- The primitive operations appear after the base type, except 5115 -- if the derivation happens within the private part of B_Scope 5116 -- and the type is a private type, in which case both the type 5117 -- and some primitive operations may appear before the base 5118 -- type, and the list of candidates starts after the type. 5119 5120 if In_Open_Scopes (B_Scope) 5121 and then Scope (T) = B_Scope 5122 and then In_Private_Part (B_Scope) 5123 then 5124 Id := Next_Entity (T); 5125 5126 -- In Ada 2012, If the type has an incomplete partial view, there 5127 -- may be primitive operations declared before the full view, so 5128 -- we need to start scanning from the incomplete view, which is 5129 -- earlier on the entity chain. 5130 5131 elsif Nkind (Parent (B_Type)) = N_Full_Type_Declaration 5132 and then Present (Incomplete_View (Parent (B_Type))) 5133 then 5134 Id := Defining_Entity (Incomplete_View (Parent (B_Type))); 5135 5136 -- If T is a derived from a type with an incomplete view declared 5137 -- elsewhere, that incomplete view is irrelevant, we want the 5138 -- operations in the scope of T. 5139 5140 if Scope (Id) /= Scope (B_Type) then 5141 Id := Next_Entity (B_Type); 5142 end if; 5143 5144 else 5145 Id := Next_Entity (B_Type); 5146 end if; 5147 5148 -- Set flag if this is a type in a package spec 5149 5150 Is_Type_In_Pkg := 5151 Is_Package_Or_Generic_Package (B_Scope) 5152 and then 5153 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /= 5154 N_Package_Body; 5155 5156 while Present (Id) loop 5157 5158 -- Test whether the result type or any of the parameter types of 5159 -- each subprogram following the type match that type when the 5160 -- type is declared in a package spec, is a derived type, or the 5161 -- subprogram is marked as primitive. (The Is_Primitive test is 5162 -- needed to find primitives of nonderived types in declarative 5163 -- parts that happen to override the predefined "=" operator.) 5164 5165 -- Note that generic formal subprograms are not considered to be 5166 -- primitive operations and thus are never inherited. 5167 5168 if Is_Overloadable (Id) 5169 and then (Is_Type_In_Pkg 5170 or else Is_Derived_Type (B_Type) 5171 or else Is_Primitive (Id)) 5172 and then Nkind (Parent (Parent (Id))) 5173 not in N_Formal_Subprogram_Declaration 5174 then 5175 Is_Prim := False; 5176 5177 if Match (Id) then 5178 Is_Prim := True; 5179 5180 else 5181 Formal := First_Formal (Id); 5182 while Present (Formal) loop 5183 if Match (Formal) then 5184 Is_Prim := True; 5185 exit; 5186 end if; 5187 5188 Next_Formal (Formal); 5189 end loop; 5190 end if; 5191 5192 -- For a formal derived type, the only primitives are the ones 5193 -- inherited from the parent type. Operations appearing in the 5194 -- package declaration are not primitive for it. 5195 5196 if Is_Prim 5197 and then (not Formal_Derived or else Present (Alias (Id))) 5198 then 5199 -- In the special case of an equality operator aliased to 5200 -- an overriding dispatching equality belonging to the same 5201 -- type, we don't include it in the list of primitives. 5202 -- This avoids inheriting multiple equality operators when 5203 -- deriving from untagged private types whose full type is 5204 -- tagged, which can otherwise cause ambiguities. Note that 5205 -- this should only happen for this kind of untagged parent 5206 -- type, since normally dispatching operations are inherited 5207 -- using the type's Primitive_Operations list. 5208 5209 if Chars (Id) = Name_Op_Eq 5210 and then Is_Dispatching_Operation (Id) 5211 and then Present (Alias (Id)) 5212 and then Present (Overridden_Operation (Alias (Id))) 5213 and then Base_Type (Etype (First_Entity (Id))) = 5214 Base_Type (Etype (First_Entity (Alias (Id)))) 5215 then 5216 null; 5217 5218 -- Include the subprogram in the list of primitives 5219 5220 else 5221 Append_Elmt (Id, Op_List); 5222 end if; 5223 end if; 5224 end if; 5225 5226 Next_Entity (Id); 5227 5228 -- For a type declared in System, some of its operations may 5229 -- appear in the target-specific extension to System. 5230 5231 if No (Id) 5232 and then B_Scope = RTU_Entity (System) 5233 and then Present_System_Aux 5234 then 5235 B_Scope := System_Aux_Id; 5236 Id := First_Entity (System_Aux_Id); 5237 end if; 5238 end loop; 5239 end if; 5240 5241 return Op_List; 5242 end Collect_Primitive_Operations; 5243 5244 ----------------------------------- 5245 -- Compile_Time_Constraint_Error -- 5246 ----------------------------------- 5247 5248 function Compile_Time_Constraint_Error 5249 (N : Node_Id; 5250 Msg : String; 5251 Ent : Entity_Id := Empty; 5252 Loc : Source_Ptr := No_Location; 5253 Warn : Boolean := False) return Node_Id 5254 is 5255 Msgc : String (1 .. Msg'Length + 3); 5256 -- Copy of message, with room for possible ?? or << and ! at end 5257 5258 Msgl : Natural; 5259 Wmsg : Boolean; 5260 Eloc : Source_Ptr; 5261 5262 -- Start of processing for Compile_Time_Constraint_Error 5263 5264 begin 5265 -- If this is a warning, convert it into an error if we are in code 5266 -- subject to SPARK_Mode being set On, unless Warn is True to force a 5267 -- warning. The rationale is that a compile-time constraint error should 5268 -- lead to an error instead of a warning when SPARK_Mode is On, but in 5269 -- a few cases we prefer to issue a warning and generate both a suitable 5270 -- run-time error in GNAT and a suitable check message in GNATprove. 5271 -- Those cases are those that likely correspond to deactivated SPARK 5272 -- code, so that this kind of code can be compiled and analyzed instead 5273 -- of being rejected. 5274 5275 Error_Msg_Warn := Warn or SPARK_Mode /= On; 5276 5277 -- A static constraint error in an instance body is not a fatal error. 5278 -- we choose to inhibit the message altogether, because there is no 5279 -- obvious node (for now) on which to post it. On the other hand the 5280 -- offending node must be replaced with a constraint_error in any case. 5281 5282 -- No messages are generated if we already posted an error on this node 5283 5284 if not Error_Posted (N) then 5285 if Loc /= No_Location then 5286 Eloc := Loc; 5287 else 5288 Eloc := Sloc (N); 5289 end if; 5290 5291 -- Copy message to Msgc, converting any ? in the message into < 5292 -- instead, so that we have an error in GNATprove mode. 5293 5294 Msgl := Msg'Length; 5295 5296 for J in 1 .. Msgl loop 5297 if Msg (J) = '?' and then (J = 1 or else Msg (J - 1) /= ''') then 5298 Msgc (J) := '<'; 5299 else 5300 Msgc (J) := Msg (J); 5301 end if; 5302 end loop; 5303 5304 -- Message is a warning, even in Ada 95 case 5305 5306 if Msg (Msg'Last) = '?' or else Msg (Msg'Last) = '<' then 5307 Wmsg := True; 5308 5309 -- In Ada 83, all messages are warnings. In the private part and the 5310 -- body of an instance, constraint_checks are only warnings. We also 5311 -- make this a warning if the Warn parameter is set. 5312 5313 elsif Warn 5314 or else (Ada_Version = Ada_83 and then Comes_From_Source (N)) 5315 or else In_Instance_Not_Visible 5316 then 5317 Msgl := Msgl + 1; 5318 Msgc (Msgl) := '<'; 5319 Msgl := Msgl + 1; 5320 Msgc (Msgl) := '<'; 5321 Wmsg := True; 5322 5323 -- Otherwise we have a real error message (Ada 95 static case) and we 5324 -- make this an unconditional message. Note that in the warning case 5325 -- we do not make the message unconditional, it seems reasonable to 5326 -- delete messages like this (about exceptions that will be raised) 5327 -- in dead code. 5328 5329 else 5330 Wmsg := False; 5331 Msgl := Msgl + 1; 5332 Msgc (Msgl) := '!'; 5333 end if; 5334 5335 -- One more test, skip the warning if the related expression is 5336 -- statically unevaluated, since we don't want to warn about what 5337 -- will happen when something is evaluated if it never will be 5338 -- evaluated. 5339 5340 if not Is_Statically_Unevaluated (N) then 5341 if Present (Ent) then 5342 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc); 5343 else 5344 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc); 5345 end if; 5346 5347 if Wmsg then 5348 5349 -- Check whether the context is an Init_Proc 5350 5351 if Inside_Init_Proc then 5352 declare 5353 Conc_Typ : constant Entity_Id := 5354 Corresponding_Concurrent_Type 5355 (Entity (Parameter_Type (First 5356 (Parameter_Specifications 5357 (Parent (Current_Scope)))))); 5358 5359 begin 5360 -- Don't complain if the corresponding concurrent type 5361 -- doesn't come from source (i.e. a single task/protected 5362 -- object). 5363 5364 if Present (Conc_Typ) 5365 and then not Comes_From_Source (Conc_Typ) 5366 then 5367 Error_Msg_NEL 5368 ("\& [<<", N, Standard_Constraint_Error, Eloc); 5369 5370 else 5371 if GNATprove_Mode then 5372 Error_Msg_NEL 5373 ("\& would have been raised for objects of this " 5374 & "type", N, Standard_Constraint_Error, Eloc); 5375 else 5376 Error_Msg_NEL 5377 ("\& will be raised for objects of this type??", 5378 N, Standard_Constraint_Error, Eloc); 5379 end if; 5380 end if; 5381 end; 5382 5383 else 5384 Error_Msg_NEL ("\& [<<", N, Standard_Constraint_Error, Eloc); 5385 end if; 5386 5387 else 5388 Error_Msg ("\static expression fails Constraint_Check", Eloc); 5389 Set_Error_Posted (N); 5390 end if; 5391 end if; 5392 end if; 5393 5394 return N; 5395 end Compile_Time_Constraint_Error; 5396 5397 ----------------------- 5398 -- Conditional_Delay -- 5399 ----------------------- 5400 5401 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is 5402 begin 5403 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then 5404 Set_Has_Delayed_Freeze (New_Ent); 5405 end if; 5406 end Conditional_Delay; 5407 5408 ------------------------- 5409 -- Copy_Component_List -- 5410 ------------------------- 5411 5412 function Copy_Component_List 5413 (R_Typ : Entity_Id; 5414 Loc : Source_Ptr) return List_Id 5415 is 5416 Comp : Node_Id; 5417 Comps : constant List_Id := New_List; 5418 5419 begin 5420 Comp := First_Component (Underlying_Type (R_Typ)); 5421 while Present (Comp) loop 5422 if Comes_From_Source (Comp) then 5423 declare 5424 Comp_Decl : constant Node_Id := Declaration_Node (Comp); 5425 begin 5426 Append_To (Comps, 5427 Make_Component_Declaration (Loc, 5428 Defining_Identifier => 5429 Make_Defining_Identifier (Loc, Chars (Comp)), 5430 Component_Definition => 5431 New_Copy_Tree 5432 (Component_Definition (Comp_Decl), New_Sloc => Loc))); 5433 end; 5434 end if; 5435 5436 Next_Component (Comp); 5437 end loop; 5438 5439 return Comps; 5440 end Copy_Component_List; 5441 5442 ------------------------- 5443 -- Copy_Parameter_List -- 5444 ------------------------- 5445 5446 function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is 5447 Loc : constant Source_Ptr := Sloc (Subp_Id); 5448 Plist : List_Id; 5449 Formal : Entity_Id; 5450 5451 begin 5452 if No (First_Formal (Subp_Id)) then 5453 return No_List; 5454 else 5455 Plist := New_List; 5456 Formal := First_Formal (Subp_Id); 5457 while Present (Formal) loop 5458 Append_To (Plist, 5459 Make_Parameter_Specification (Loc, 5460 Defining_Identifier => 5461 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), 5462 In_Present => In_Present (Parent (Formal)), 5463 Out_Present => Out_Present (Parent (Formal)), 5464 Parameter_Type => 5465 New_Occurrence_Of (Etype (Formal), Loc), 5466 Expression => 5467 New_Copy_Tree (Expression (Parent (Formal))))); 5468 5469 Next_Formal (Formal); 5470 end loop; 5471 end if; 5472 5473 return Plist; 5474 end Copy_Parameter_List; 5475 5476 ---------------------------- 5477 -- Copy_SPARK_Mode_Aspect -- 5478 ---------------------------- 5479 5480 procedure Copy_SPARK_Mode_Aspect (From : Node_Id; To : Node_Id) is 5481 pragma Assert (not Has_Aspects (To)); 5482 Asp : Node_Id; 5483 5484 begin 5485 if Has_Aspects (From) then 5486 Asp := Find_Aspect (Defining_Entity (From), Aspect_SPARK_Mode); 5487 5488 if Present (Asp) then 5489 Set_Aspect_Specifications (To, New_List (New_Copy_Tree (Asp))); 5490 Set_Has_Aspects (To, True); 5491 end if; 5492 end if; 5493 end Copy_SPARK_Mode_Aspect; 5494 5495 -------------------------- 5496 -- Copy_Subprogram_Spec -- 5497 -------------------------- 5498 5499 function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id is 5500 Def_Id : Node_Id; 5501 Formal_Spec : Node_Id; 5502 Result : Node_Id; 5503 5504 begin 5505 -- The structure of the original tree must be replicated without any 5506 -- alterations. Use New_Copy_Tree for this purpose. 5507 5508 Result := New_Copy_Tree (Spec); 5509 5510 -- However, the spec of a null procedure carries the corresponding null 5511 -- statement of the body (created by the parser), and this cannot be 5512 -- shared with the new subprogram spec. 5513 5514 if Nkind (Result) = N_Procedure_Specification then 5515 Set_Null_Statement (Result, Empty); 5516 end if; 5517 5518 -- Create a new entity for the defining unit name 5519 5520 Def_Id := Defining_Unit_Name (Result); 5521 Set_Defining_Unit_Name (Result, 5522 Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id))); 5523 5524 -- Create new entities for the formal parameters 5525 5526 if Present (Parameter_Specifications (Result)) then 5527 Formal_Spec := First (Parameter_Specifications (Result)); 5528 while Present (Formal_Spec) loop 5529 Def_Id := Defining_Identifier (Formal_Spec); 5530 Set_Defining_Identifier (Formal_Spec, 5531 Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id))); 5532 5533 Next (Formal_Spec); 5534 end loop; 5535 end if; 5536 5537 return Result; 5538 end Copy_Subprogram_Spec; 5539 5540 -------------------------------- 5541 -- Corresponding_Generic_Type -- 5542 -------------------------------- 5543 5544 function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is 5545 Inst : Entity_Id; 5546 Gen : Entity_Id; 5547 Typ : Entity_Id; 5548 5549 begin 5550 if not Is_Generic_Actual_Type (T) then 5551 return Any_Type; 5552 5553 -- If the actual is the actual of an enclosing instance, resolution 5554 -- was correct in the generic. 5555 5556 elsif Nkind (Parent (T)) = N_Subtype_Declaration 5557 and then Is_Entity_Name (Subtype_Indication (Parent (T))) 5558 and then 5559 Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T)))) 5560 then 5561 return Any_Type; 5562 5563 else 5564 Inst := Scope (T); 5565 5566 if Is_Wrapper_Package (Inst) then 5567 Inst := Related_Instance (Inst); 5568 end if; 5569 5570 Gen := 5571 Generic_Parent 5572 (Specification (Unit_Declaration_Node (Inst))); 5573 5574 -- Generic actual has the same name as the corresponding formal 5575 5576 Typ := First_Entity (Gen); 5577 while Present (Typ) loop 5578 if Chars (Typ) = Chars (T) then 5579 return Typ; 5580 end if; 5581 5582 Next_Entity (Typ); 5583 end loop; 5584 5585 return Any_Type; 5586 end if; 5587 end Corresponding_Generic_Type; 5588 5589 -------------------- 5590 -- Current_Entity -- 5591 -------------------- 5592 5593 -- The currently visible definition for a given identifier is the 5594 -- one most chained at the start of the visibility chain, i.e. the 5595 -- one that is referenced by the Node_Id value of the name of the 5596 -- given identifier. 5597 5598 function Current_Entity (N : Node_Id) return Entity_Id is 5599 begin 5600 return Get_Name_Entity_Id (Chars (N)); 5601 end Current_Entity; 5602 5603 ----------------------------- 5604 -- Current_Entity_In_Scope -- 5605 ----------------------------- 5606 5607 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is 5608 E : Entity_Id; 5609 CS : constant Entity_Id := Current_Scope; 5610 5611 Transient_Case : constant Boolean := Scope_Is_Transient; 5612 5613 begin 5614 E := Get_Name_Entity_Id (Chars (N)); 5615 while Present (E) 5616 and then Scope (E) /= CS 5617 and then (not Transient_Case or else Scope (E) /= Scope (CS)) 5618 loop 5619 E := Homonym (E); 5620 end loop; 5621 5622 return E; 5623 end Current_Entity_In_Scope; 5624 5625 ------------------- 5626 -- Current_Scope -- 5627 ------------------- 5628 5629 function Current_Scope return Entity_Id is 5630 begin 5631 if Scope_Stack.Last = -1 then 5632 return Standard_Standard; 5633 else 5634 declare 5635 C : constant Entity_Id := 5636 Scope_Stack.Table (Scope_Stack.Last).Entity; 5637 begin 5638 if Present (C) then 5639 return C; 5640 else 5641 return Standard_Standard; 5642 end if; 5643 end; 5644 end if; 5645 end Current_Scope; 5646 5647 ---------------------------- 5648 -- Current_Scope_No_Loops -- 5649 ---------------------------- 5650 5651 function Current_Scope_No_Loops return Entity_Id is 5652 S : Entity_Id; 5653 5654 begin 5655 -- Examine the scope stack starting from the current scope and skip any 5656 -- internally generated loops. 5657 5658 S := Current_Scope; 5659 while Present (S) and then S /= Standard_Standard loop 5660 if Ekind (S) = E_Loop and then not Comes_From_Source (S) then 5661 S := Scope (S); 5662 else 5663 exit; 5664 end if; 5665 end loop; 5666 5667 return S; 5668 end Current_Scope_No_Loops; 5669 5670 ------------------------ 5671 -- Current_Subprogram -- 5672 ------------------------ 5673 5674 function Current_Subprogram return Entity_Id is 5675 Scop : constant Entity_Id := Current_Scope; 5676 begin 5677 if Is_Subprogram_Or_Generic_Subprogram (Scop) then 5678 return Scop; 5679 else 5680 return Enclosing_Subprogram (Scop); 5681 end if; 5682 end Current_Subprogram; 5683 5684 ---------------------------------- 5685 -- Deepest_Type_Access_Level -- 5686 ---------------------------------- 5687 5688 function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is 5689 begin 5690 if Ekind (Typ) = E_Anonymous_Access_Type 5691 and then not Is_Local_Anonymous_Access (Typ) 5692 and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration 5693 then 5694 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous 5695 -- access type. 5696 5697 return 5698 Scope_Depth (Enclosing_Dynamic_Scope 5699 (Defining_Identifier 5700 (Associated_Node_For_Itype (Typ)))); 5701 5702 -- For generic formal type, return Int'Last (infinite). 5703 -- See comment preceding Is_Generic_Type call in Type_Access_Level. 5704 5705 elsif Is_Generic_Type (Root_Type (Typ)) then 5706 return UI_From_Int (Int'Last); 5707 5708 else 5709 return Type_Access_Level (Typ); 5710 end if; 5711 end Deepest_Type_Access_Level; 5712 5713 --------------------- 5714 -- Defining_Entity -- 5715 --------------------- 5716 5717 function Defining_Entity (N : Node_Id) return Entity_Id is 5718 begin 5719 case Nkind (N) is 5720 when N_Abstract_Subprogram_Declaration 5721 | N_Expression_Function 5722 | N_Formal_Subprogram_Declaration 5723 | N_Generic_Package_Declaration 5724 | N_Generic_Subprogram_Declaration 5725 | N_Package_Declaration 5726 | N_Subprogram_Body 5727 | N_Subprogram_Body_Stub 5728 | N_Subprogram_Declaration 5729 | N_Subprogram_Renaming_Declaration 5730 => 5731 return Defining_Entity (Specification (N)); 5732 5733 when N_Component_Declaration 5734 | N_Defining_Program_Unit_Name 5735 | N_Discriminant_Specification 5736 | N_Entry_Body 5737 | N_Entry_Declaration 5738 | N_Entry_Index_Specification 5739 | N_Exception_Declaration 5740 | N_Exception_Renaming_Declaration 5741 | N_Formal_Object_Declaration 5742 | N_Formal_Package_Declaration 5743 | N_Formal_Type_Declaration 5744 | N_Full_Type_Declaration 5745 | N_Implicit_Label_Declaration 5746 | N_Incomplete_Type_Declaration 5747 | N_Iterator_Specification 5748 | N_Loop_Parameter_Specification 5749 | N_Number_Declaration 5750 | N_Object_Declaration 5751 | N_Object_Renaming_Declaration 5752 | N_Package_Body_Stub 5753 | N_Parameter_Specification 5754 | N_Private_Extension_Declaration 5755 | N_Private_Type_Declaration 5756 | N_Protected_Body 5757 | N_Protected_Body_Stub 5758 | N_Protected_Type_Declaration 5759 | N_Single_Protected_Declaration 5760 | N_Single_Task_Declaration 5761 | N_Subtype_Declaration 5762 | N_Task_Body 5763 | N_Task_Body_Stub 5764 | N_Task_Type_Declaration 5765 => 5766 return Defining_Identifier (N); 5767 5768 when N_Compilation_Unit => 5769 return Defining_Entity (Unit (N)); 5770 5771 when N_Subunit => 5772 return Defining_Entity (Proper_Body (N)); 5773 5774 when N_Function_Instantiation 5775 | N_Function_Specification 5776 | N_Generic_Function_Renaming_Declaration 5777 | N_Generic_Package_Renaming_Declaration 5778 | N_Generic_Procedure_Renaming_Declaration 5779 | N_Package_Body 5780 | N_Package_Instantiation 5781 | N_Package_Renaming_Declaration 5782 | N_Package_Specification 5783 | N_Procedure_Instantiation 5784 | N_Procedure_Specification 5785 => 5786 declare 5787 Nam : constant Node_Id := Defining_Unit_Name (N); 5788 Err : Entity_Id := Empty; 5789 5790 begin 5791 if Nkind (Nam) in N_Entity then 5792 return Nam; 5793 5794 -- For Error, make up a name and attach to declaration so we 5795 -- can continue semantic analysis. 5796 5797 elsif Nam = Error then 5798 Err := Make_Temporary (Sloc (N), 'T'); 5799 Set_Defining_Unit_Name (N, Err); 5800 5801 return Err; 5802 5803 -- If not an entity, get defining identifier 5804 5805 else 5806 return Defining_Identifier (Nam); 5807 end if; 5808 end; 5809 5810 when N_Block_Statement 5811 | N_Loop_Statement 5812 => 5813 return Entity (Identifier (N)); 5814 5815 when others => 5816 raise Program_Error; 5817 end case; 5818 end Defining_Entity; 5819 5820 -------------------------- 5821 -- Denotes_Discriminant -- 5822 -------------------------- 5823 5824 function Denotes_Discriminant 5825 (N : Node_Id; 5826 Check_Concurrent : Boolean := False) return Boolean 5827 is 5828 E : Entity_Id; 5829 5830 begin 5831 if not Is_Entity_Name (N) or else No (Entity (N)) then 5832 return False; 5833 else 5834 E := Entity (N); 5835 end if; 5836 5837 -- If we are checking for a protected type, the discriminant may have 5838 -- been rewritten as the corresponding discriminal of the original type 5839 -- or of the corresponding concurrent record, depending on whether we 5840 -- are in the spec or body of the protected type. 5841 5842 return Ekind (E) = E_Discriminant 5843 or else 5844 (Check_Concurrent 5845 and then Ekind (E) = E_In_Parameter 5846 and then Present (Discriminal_Link (E)) 5847 and then 5848 (Is_Concurrent_Type (Scope (Discriminal_Link (E))) 5849 or else 5850 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E))))); 5851 end Denotes_Discriminant; 5852 5853 ------------------------- 5854 -- Denotes_Same_Object -- 5855 ------------------------- 5856 5857 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is 5858 Obj1 : Node_Id := A1; 5859 Obj2 : Node_Id := A2; 5860 5861 function Has_Prefix (N : Node_Id) return Boolean; 5862 -- Return True if N has attribute Prefix 5863 5864 function Is_Renaming (N : Node_Id) return Boolean; 5865 -- Return true if N names a renaming entity 5866 5867 function Is_Valid_Renaming (N : Node_Id) return Boolean; 5868 -- For renamings, return False if the prefix of any dereference within 5869 -- the renamed object_name is a variable, or any expression within the 5870 -- renamed object_name contains references to variables or calls on 5871 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3)) 5872 5873 ---------------- 5874 -- Has_Prefix -- 5875 ---------------- 5876 5877 function Has_Prefix (N : Node_Id) return Boolean is 5878 begin 5879 return 5880 Nkind_In (N, 5881 N_Attribute_Reference, 5882 N_Expanded_Name, 5883 N_Explicit_Dereference, 5884 N_Indexed_Component, 5885 N_Reference, 5886 N_Selected_Component, 5887 N_Slice); 5888 end Has_Prefix; 5889 5890 ----------------- 5891 -- Is_Renaming -- 5892 ----------------- 5893 5894 function Is_Renaming (N : Node_Id) return Boolean is 5895 begin 5896 return Is_Entity_Name (N) 5897 and then Present (Renamed_Entity (Entity (N))); 5898 end Is_Renaming; 5899 5900 ----------------------- 5901 -- Is_Valid_Renaming -- 5902 ----------------------- 5903 5904 function Is_Valid_Renaming (N : Node_Id) return Boolean is 5905 5906 function Check_Renaming (N : Node_Id) return Boolean; 5907 -- Recursive function used to traverse all the prefixes of N 5908 5909 function Check_Renaming (N : Node_Id) return Boolean is 5910 begin 5911 if Is_Renaming (N) 5912 and then not Check_Renaming (Renamed_Entity (Entity (N))) 5913 then 5914 return False; 5915 end if; 5916 5917 if Nkind (N) = N_Indexed_Component then 5918 declare 5919 Indx : Node_Id; 5920 5921 begin 5922 Indx := First (Expressions (N)); 5923 while Present (Indx) loop 5924 if not Is_OK_Static_Expression (Indx) then 5925 return False; 5926 end if; 5927 5928 Next_Index (Indx); 5929 end loop; 5930 end; 5931 end if; 5932 5933 if Has_Prefix (N) then 5934 declare 5935 P : constant Node_Id := Prefix (N); 5936 5937 begin 5938 if Nkind (N) = N_Explicit_Dereference 5939 and then Is_Variable (P) 5940 then 5941 return False; 5942 5943 elsif Is_Entity_Name (P) 5944 and then Ekind (Entity (P)) = E_Function 5945 then 5946 return False; 5947 5948 elsif Nkind (P) = N_Function_Call then 5949 return False; 5950 end if; 5951 5952 -- Recursion to continue traversing the prefix of the 5953 -- renaming expression 5954 5955 return Check_Renaming (P); 5956 end; 5957 end if; 5958 5959 return True; 5960 end Check_Renaming; 5961 5962 -- Start of processing for Is_Valid_Renaming 5963 5964 begin 5965 return Check_Renaming (N); 5966 end Is_Valid_Renaming; 5967 5968 -- Start of processing for Denotes_Same_Object 5969 5970 begin 5971 -- Both names statically denote the same stand-alone object or parameter 5972 -- (RM 6.4.1(6.5/3)) 5973 5974 if Is_Entity_Name (Obj1) 5975 and then Is_Entity_Name (Obj2) 5976 and then Entity (Obj1) = Entity (Obj2) 5977 then 5978 return True; 5979 end if; 5980 5981 -- For renamings, the prefix of any dereference within the renamed 5982 -- object_name is not a variable, and any expression within the 5983 -- renamed object_name contains no references to variables nor 5984 -- calls on nonstatic functions (RM 6.4.1(6.10/3)). 5985 5986 if Is_Renaming (Obj1) then 5987 if Is_Valid_Renaming (Obj1) then 5988 Obj1 := Renamed_Entity (Entity (Obj1)); 5989 else 5990 return False; 5991 end if; 5992 end if; 5993 5994 if Is_Renaming (Obj2) then 5995 if Is_Valid_Renaming (Obj2) then 5996 Obj2 := Renamed_Entity (Entity (Obj2)); 5997 else 5998 return False; 5999 end if; 6000 end if; 6001 6002 -- No match if not same node kind (such cases are handled by 6003 -- Denotes_Same_Prefix) 6004 6005 if Nkind (Obj1) /= Nkind (Obj2) then 6006 return False; 6007 6008 -- After handling valid renamings, one of the two names statically 6009 -- denoted a renaming declaration whose renamed object_name is known 6010 -- to denote the same object as the other (RM 6.4.1(6.10/3)) 6011 6012 elsif Is_Entity_Name (Obj1) then 6013 if Is_Entity_Name (Obj2) then 6014 return Entity (Obj1) = Entity (Obj2); 6015 else 6016 return False; 6017 end if; 6018 6019 -- Both names are selected_components, their prefixes are known to 6020 -- denote the same object, and their selector_names denote the same 6021 -- component (RM 6.4.1(6.6/3)). 6022 6023 elsif Nkind (Obj1) = N_Selected_Component then 6024 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) 6025 and then 6026 Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2)); 6027 6028 -- Both names are dereferences and the dereferenced names are known to 6029 -- denote the same object (RM 6.4.1(6.7/3)) 6030 6031 elsif Nkind (Obj1) = N_Explicit_Dereference then 6032 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)); 6033 6034 -- Both names are indexed_components, their prefixes are known to denote 6035 -- the same object, and each of the pairs of corresponding index values 6036 -- are either both static expressions with the same static value or both 6037 -- names that are known to denote the same object (RM 6.4.1(6.8/3)) 6038 6039 elsif Nkind (Obj1) = N_Indexed_Component then 6040 if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then 6041 return False; 6042 else 6043 declare 6044 Indx1 : Node_Id; 6045 Indx2 : Node_Id; 6046 6047 begin 6048 Indx1 := First (Expressions (Obj1)); 6049 Indx2 := First (Expressions (Obj2)); 6050 while Present (Indx1) loop 6051 6052 -- Indexes must denote the same static value or same object 6053 6054 if Is_OK_Static_Expression (Indx1) then 6055 if not Is_OK_Static_Expression (Indx2) then 6056 return False; 6057 6058 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then 6059 return False; 6060 end if; 6061 6062 elsif not Denotes_Same_Object (Indx1, Indx2) then 6063 return False; 6064 end if; 6065 6066 Next (Indx1); 6067 Next (Indx2); 6068 end loop; 6069 6070 return True; 6071 end; 6072 end if; 6073 6074 -- Both names are slices, their prefixes are known to denote the same 6075 -- object, and the two slices have statically matching index constraints 6076 -- (RM 6.4.1(6.9/3)) 6077 6078 elsif Nkind (Obj1) = N_Slice 6079 and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) 6080 then 6081 declare 6082 Lo1, Lo2, Hi1, Hi2 : Node_Id; 6083 6084 begin 6085 Get_Index_Bounds (Etype (Obj1), Lo1, Hi1); 6086 Get_Index_Bounds (Etype (Obj2), Lo2, Hi2); 6087 6088 -- Check whether bounds are statically identical. There is no 6089 -- attempt to detect partial overlap of slices. 6090 6091 return Denotes_Same_Object (Lo1, Lo2) 6092 and then 6093 Denotes_Same_Object (Hi1, Hi2); 6094 end; 6095 6096 -- In the recursion, literals appear as indexes 6097 6098 elsif Nkind (Obj1) = N_Integer_Literal 6099 and then 6100 Nkind (Obj2) = N_Integer_Literal 6101 then 6102 return Intval (Obj1) = Intval (Obj2); 6103 6104 else 6105 return False; 6106 end if; 6107 end Denotes_Same_Object; 6108 6109 ------------------------- 6110 -- Denotes_Same_Prefix -- 6111 ------------------------- 6112 6113 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is 6114 begin 6115 if Is_Entity_Name (A1) then 6116 if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) 6117 and then not Is_Access_Type (Etype (A1)) 6118 then 6119 return Denotes_Same_Object (A1, Prefix (A2)) 6120 or else Denotes_Same_Prefix (A1, Prefix (A2)); 6121 else 6122 return False; 6123 end if; 6124 6125 elsif Is_Entity_Name (A2) then 6126 return Denotes_Same_Prefix (A1 => A2, A2 => A1); 6127 6128 elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice) 6129 and then 6130 Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice) 6131 then 6132 declare 6133 Root1, Root2 : Node_Id; 6134 Depth1, Depth2 : Nat := 0; 6135 6136 begin 6137 Root1 := Prefix (A1); 6138 while not Is_Entity_Name (Root1) loop 6139 if not Nkind_In 6140 (Root1, N_Selected_Component, N_Indexed_Component) 6141 then 6142 return False; 6143 else 6144 Root1 := Prefix (Root1); 6145 end if; 6146 6147 Depth1 := Depth1 + 1; 6148 end loop; 6149 6150 Root2 := Prefix (A2); 6151 while not Is_Entity_Name (Root2) loop 6152 if not Nkind_In (Root2, N_Selected_Component, 6153 N_Indexed_Component) 6154 then 6155 return False; 6156 else 6157 Root2 := Prefix (Root2); 6158 end if; 6159 6160 Depth2 := Depth2 + 1; 6161 end loop; 6162 6163 -- If both have the same depth and they do not denote the same 6164 -- object, they are disjoint and no warning is needed. 6165 6166 if Depth1 = Depth2 then 6167 return False; 6168 6169 elsif Depth1 > Depth2 then 6170 Root1 := Prefix (A1); 6171 for J in 1 .. Depth1 - Depth2 - 1 loop 6172 Root1 := Prefix (Root1); 6173 end loop; 6174 6175 return Denotes_Same_Object (Root1, A2); 6176 6177 else 6178 Root2 := Prefix (A2); 6179 for J in 1 .. Depth2 - Depth1 - 1 loop 6180 Root2 := Prefix (Root2); 6181 end loop; 6182 6183 return Denotes_Same_Object (A1, Root2); 6184 end if; 6185 end; 6186 6187 else 6188 return False; 6189 end if; 6190 end Denotes_Same_Prefix; 6191 6192 ---------------------- 6193 -- Denotes_Variable -- 6194 ---------------------- 6195 6196 function Denotes_Variable (N : Node_Id) return Boolean is 6197 begin 6198 return Is_Variable (N) and then Paren_Count (N) = 0; 6199 end Denotes_Variable; 6200 6201 ----------------------------- 6202 -- Depends_On_Discriminant -- 6203 ----------------------------- 6204 6205 function Depends_On_Discriminant (N : Node_Id) return Boolean is 6206 L : Node_Id; 6207 H : Node_Id; 6208 6209 begin 6210 Get_Index_Bounds (N, L, H); 6211 return Denotes_Discriminant (L) or else Denotes_Discriminant (H); 6212 end Depends_On_Discriminant; 6213 6214 ------------------------- 6215 -- Designate_Same_Unit -- 6216 ------------------------- 6217 6218 function Designate_Same_Unit 6219 (Name1 : Node_Id; 6220 Name2 : Node_Id) return Boolean 6221 is 6222 K1 : constant Node_Kind := Nkind (Name1); 6223 K2 : constant Node_Kind := Nkind (Name2); 6224 6225 function Prefix_Node (N : Node_Id) return Node_Id; 6226 -- Returns the parent unit name node of a defining program unit name 6227 -- or the prefix if N is a selected component or an expanded name. 6228 6229 function Select_Node (N : Node_Id) return Node_Id; 6230 -- Returns the defining identifier node of a defining program unit 6231 -- name or the selector node if N is a selected component or an 6232 -- expanded name. 6233 6234 ----------------- 6235 -- Prefix_Node -- 6236 ----------------- 6237 6238 function Prefix_Node (N : Node_Id) return Node_Id is 6239 begin 6240 if Nkind (N) = N_Defining_Program_Unit_Name then 6241 return Name (N); 6242 else 6243 return Prefix (N); 6244 end if; 6245 end Prefix_Node; 6246 6247 ----------------- 6248 -- Select_Node -- 6249 ----------------- 6250 6251 function Select_Node (N : Node_Id) return Node_Id is 6252 begin 6253 if Nkind (N) = N_Defining_Program_Unit_Name then 6254 return Defining_Identifier (N); 6255 else 6256 return Selector_Name (N); 6257 end if; 6258 end Select_Node; 6259 6260 -- Start of processing for Designate_Same_Unit 6261 6262 begin 6263 if Nkind_In (K1, N_Identifier, N_Defining_Identifier) 6264 and then 6265 Nkind_In (K2, N_Identifier, N_Defining_Identifier) 6266 then 6267 return Chars (Name1) = Chars (Name2); 6268 6269 elsif Nkind_In (K1, N_Expanded_Name, 6270 N_Selected_Component, 6271 N_Defining_Program_Unit_Name) 6272 and then 6273 Nkind_In (K2, N_Expanded_Name, 6274 N_Selected_Component, 6275 N_Defining_Program_Unit_Name) 6276 then 6277 return 6278 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2))) 6279 and then 6280 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2)); 6281 6282 else 6283 return False; 6284 end if; 6285 end Designate_Same_Unit; 6286 6287 --------------------------------------------- 6288 -- Diagnose_Iterated_Component_Association -- 6289 --------------------------------------------- 6290 6291 procedure Diagnose_Iterated_Component_Association (N : Node_Id) is 6292 Def_Id : constant Entity_Id := Defining_Identifier (N); 6293 Aggr : Node_Id; 6294 6295 begin 6296 -- Determine whether the iterated component association appears within 6297 -- an aggregate. If this is the case, raise Program_Error because the 6298 -- iterated component association cannot be left in the tree as is and 6299 -- must always be processed by the related aggregate. 6300 6301 Aggr := N; 6302 while Present (Aggr) loop 6303 if Nkind (Aggr) = N_Aggregate then 6304 raise Program_Error; 6305 6306 -- Prevent the search from going too far 6307 6308 elsif Is_Body_Or_Package_Declaration (Aggr) then 6309 exit; 6310 end if; 6311 6312 Aggr := Parent (Aggr); 6313 end loop; 6314 6315 -- At this point it is known that the iterated component association is 6316 -- not within an aggregate. This is really a quantified expression with 6317 -- a missing "all" or "some" quantifier. 6318 6319 Error_Msg_N ("missing quantifier", Def_Id); 6320 6321 -- Rewrite the iterated component association as True to prevent any 6322 -- cascaded errors. 6323 6324 Rewrite (N, New_Occurrence_Of (Standard_True, Sloc (N))); 6325 Analyze (N); 6326 end Diagnose_Iterated_Component_Association; 6327 6328 --------------------------------- 6329 -- Dynamic_Accessibility_Level -- 6330 --------------------------------- 6331 6332 function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is 6333 Loc : constant Source_Ptr := Sloc (Expr); 6334 6335 function Make_Level_Literal (Level : Uint) return Node_Id; 6336 -- Construct an integer literal representing an accessibility level 6337 -- with its type set to Natural. 6338 6339 ------------------------ 6340 -- Make_Level_Literal -- 6341 ------------------------ 6342 6343 function Make_Level_Literal (Level : Uint) return Node_Id is 6344 Result : constant Node_Id := Make_Integer_Literal (Loc, Level); 6345 6346 begin 6347 Set_Etype (Result, Standard_Natural); 6348 return Result; 6349 end Make_Level_Literal; 6350 6351 -- Local variables 6352 6353 E : Entity_Id; 6354 6355 -- Start of processing for Dynamic_Accessibility_Level 6356 6357 begin 6358 if Is_Entity_Name (Expr) then 6359 E := Entity (Expr); 6360 6361 if Present (Renamed_Object (E)) then 6362 return Dynamic_Accessibility_Level (Renamed_Object (E)); 6363 end if; 6364 6365 if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then 6366 if Present (Extra_Accessibility (E)) then 6367 return New_Occurrence_Of (Extra_Accessibility (E), Loc); 6368 end if; 6369 end if; 6370 end if; 6371 6372 -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ??? 6373 6374 case Nkind (Expr) is 6375 6376 -- For access discriminant, the level of the enclosing object 6377 6378 when N_Selected_Component => 6379 if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant 6380 and then Ekind (Etype (Entity (Selector_Name (Expr)))) = 6381 E_Anonymous_Access_Type 6382 then 6383 return Make_Level_Literal (Object_Access_Level (Expr)); 6384 end if; 6385 6386 when N_Attribute_Reference => 6387 case Get_Attribute_Id (Attribute_Name (Expr)) is 6388 6389 -- For X'Access, the level of the prefix X 6390 6391 when Attribute_Access => 6392 return Make_Level_Literal 6393 (Object_Access_Level (Prefix (Expr))); 6394 6395 -- Treat the unchecked attributes as library-level 6396 6397 when Attribute_Unchecked_Access 6398 | Attribute_Unrestricted_Access 6399 => 6400 return Make_Level_Literal (Scope_Depth (Standard_Standard)); 6401 6402 -- No other access-valued attributes 6403 6404 when others => 6405 raise Program_Error; 6406 end case; 6407 6408 when N_Allocator => 6409 6410 -- Unimplemented: depends on context. As an actual parameter where 6411 -- formal type is anonymous, use 6412 -- Scope_Depth (Current_Scope) + 1. 6413 -- For other cases, see 3.10.2(14/3) and following. ??? 6414 6415 null; 6416 6417 when N_Type_Conversion => 6418 if not Is_Local_Anonymous_Access (Etype (Expr)) then 6419 6420 -- Handle type conversions introduced for a rename of an 6421 -- Ada 2012 stand-alone object of an anonymous access type. 6422 6423 return Dynamic_Accessibility_Level (Expression (Expr)); 6424 end if; 6425 6426 when others => 6427 null; 6428 end case; 6429 6430 return Make_Level_Literal (Type_Access_Level (Etype (Expr))); 6431 end Dynamic_Accessibility_Level; 6432 6433 ------------------------ 6434 -- Discriminated_Size -- 6435 ------------------------ 6436 6437 function Discriminated_Size (Comp : Entity_Id) return Boolean is 6438 function Non_Static_Bound (Bound : Node_Id) return Boolean; 6439 -- Check whether the bound of an index is non-static and does denote 6440 -- a discriminant, in which case any object of the type (protected or 6441 -- otherwise) will have a non-static size. 6442 6443 ---------------------- 6444 -- Non_Static_Bound -- 6445 ---------------------- 6446 6447 function Non_Static_Bound (Bound : Node_Id) return Boolean is 6448 begin 6449 if Is_OK_Static_Expression (Bound) then 6450 return False; 6451 6452 -- If the bound is given by a discriminant it is non-static 6453 -- (A static constraint replaces the reference with the value). 6454 -- In an protected object the discriminant has been replaced by 6455 -- the corresponding discriminal within the protected operation. 6456 6457 elsif Is_Entity_Name (Bound) 6458 and then 6459 (Ekind (Entity (Bound)) = E_Discriminant 6460 or else Present (Discriminal_Link (Entity (Bound)))) 6461 then 6462 return False; 6463 6464 else 6465 return True; 6466 end if; 6467 end Non_Static_Bound; 6468 6469 -- Local variables 6470 6471 Typ : constant Entity_Id := Etype (Comp); 6472 Index : Node_Id; 6473 6474 -- Start of processing for Discriminated_Size 6475 6476 begin 6477 if not Is_Array_Type (Typ) then 6478 return False; 6479 end if; 6480 6481 if Ekind (Typ) = E_Array_Subtype then 6482 Index := First_Index (Typ); 6483 while Present (Index) loop 6484 if Non_Static_Bound (Low_Bound (Index)) 6485 or else Non_Static_Bound (High_Bound (Index)) 6486 then 6487 return False; 6488 end if; 6489 6490 Next_Index (Index); 6491 end loop; 6492 6493 return True; 6494 end if; 6495 6496 return False; 6497 end Discriminated_Size; 6498 6499 ----------------------------------- 6500 -- Effective_Extra_Accessibility -- 6501 ----------------------------------- 6502 6503 function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is 6504 begin 6505 if Present (Renamed_Object (Id)) 6506 and then Is_Entity_Name (Renamed_Object (Id)) 6507 then 6508 return Effective_Extra_Accessibility (Entity (Renamed_Object (Id))); 6509 else 6510 return Extra_Accessibility (Id); 6511 end if; 6512 end Effective_Extra_Accessibility; 6513 6514 ----------------------------- 6515 -- Effective_Reads_Enabled -- 6516 ----------------------------- 6517 6518 function Effective_Reads_Enabled (Id : Entity_Id) return Boolean is 6519 begin 6520 return Has_Enabled_Property (Id, Name_Effective_Reads); 6521 end Effective_Reads_Enabled; 6522 6523 ------------------------------ 6524 -- Effective_Writes_Enabled -- 6525 ------------------------------ 6526 6527 function Effective_Writes_Enabled (Id : Entity_Id) return Boolean is 6528 begin 6529 return Has_Enabled_Property (Id, Name_Effective_Writes); 6530 end Effective_Writes_Enabled; 6531 6532 ------------------------------ 6533 -- Enclosing_Comp_Unit_Node -- 6534 ------------------------------ 6535 6536 function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is 6537 Current_Node : Node_Id; 6538 6539 begin 6540 Current_Node := N; 6541 while Present (Current_Node) 6542 and then Nkind (Current_Node) /= N_Compilation_Unit 6543 loop 6544 Current_Node := Parent (Current_Node); 6545 end loop; 6546 6547 if Nkind (Current_Node) /= N_Compilation_Unit then 6548 return Empty; 6549 else 6550 return Current_Node; 6551 end if; 6552 end Enclosing_Comp_Unit_Node; 6553 6554 -------------------------- 6555 -- Enclosing_CPP_Parent -- 6556 -------------------------- 6557 6558 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is 6559 Parent_Typ : Entity_Id := Typ; 6560 6561 begin 6562 while not Is_CPP_Class (Parent_Typ) 6563 and then Etype (Parent_Typ) /= Parent_Typ 6564 loop 6565 Parent_Typ := Etype (Parent_Typ); 6566 6567 if Is_Private_Type (Parent_Typ) then 6568 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 6569 end if; 6570 end loop; 6571 6572 pragma Assert (Is_CPP_Class (Parent_Typ)); 6573 return Parent_Typ; 6574 end Enclosing_CPP_Parent; 6575 6576 --------------------------- 6577 -- Enclosing_Declaration -- 6578 --------------------------- 6579 6580 function Enclosing_Declaration (N : Node_Id) return Node_Id is 6581 Decl : Node_Id := N; 6582 6583 begin 6584 while Present (Decl) 6585 and then not (Nkind (Decl) in N_Declaration 6586 or else 6587 Nkind (Decl) in N_Later_Decl_Item) 6588 loop 6589 Decl := Parent (Decl); 6590 end loop; 6591 6592 return Decl; 6593 end Enclosing_Declaration; 6594 6595 ---------------------------- 6596 -- Enclosing_Generic_Body -- 6597 ---------------------------- 6598 6599 function Enclosing_Generic_Body 6600 (N : Node_Id) return Node_Id 6601 is 6602 P : Node_Id; 6603 Decl : Node_Id; 6604 Spec : Node_Id; 6605 6606 begin 6607 P := Parent (N); 6608 while Present (P) loop 6609 if Nkind (P) = N_Package_Body 6610 or else Nkind (P) = N_Subprogram_Body 6611 then 6612 Spec := Corresponding_Spec (P); 6613 6614 if Present (Spec) then 6615 Decl := Unit_Declaration_Node (Spec); 6616 6617 if Nkind (Decl) = N_Generic_Package_Declaration 6618 or else Nkind (Decl) = N_Generic_Subprogram_Declaration 6619 then 6620 return P; 6621 end if; 6622 end if; 6623 end if; 6624 6625 P := Parent (P); 6626 end loop; 6627 6628 return Empty; 6629 end Enclosing_Generic_Body; 6630 6631 ---------------------------- 6632 -- Enclosing_Generic_Unit -- 6633 ---------------------------- 6634 6635 function Enclosing_Generic_Unit 6636 (N : Node_Id) return Node_Id 6637 is 6638 P : Node_Id; 6639 Decl : Node_Id; 6640 Spec : Node_Id; 6641 6642 begin 6643 P := Parent (N); 6644 while Present (P) loop 6645 if Nkind (P) = N_Generic_Package_Declaration 6646 or else Nkind (P) = N_Generic_Subprogram_Declaration 6647 then 6648 return P; 6649 6650 elsif Nkind (P) = N_Package_Body 6651 or else Nkind (P) = N_Subprogram_Body 6652 then 6653 Spec := Corresponding_Spec (P); 6654 6655 if Present (Spec) then 6656 Decl := Unit_Declaration_Node (Spec); 6657 6658 if Nkind (Decl) = N_Generic_Package_Declaration 6659 or else Nkind (Decl) = N_Generic_Subprogram_Declaration 6660 then 6661 return Decl; 6662 end if; 6663 end if; 6664 end if; 6665 6666 P := Parent (P); 6667 end loop; 6668 6669 return Empty; 6670 end Enclosing_Generic_Unit; 6671 6672 ------------------------------- 6673 -- Enclosing_Lib_Unit_Entity -- 6674 ------------------------------- 6675 6676 function Enclosing_Lib_Unit_Entity 6677 (E : Entity_Id := Current_Scope) return Entity_Id 6678 is 6679 Unit_Entity : Entity_Id; 6680 6681 begin 6682 -- Look for enclosing library unit entity by following scope links. 6683 -- Equivalent to, but faster than indexing through the scope stack. 6684 6685 Unit_Entity := E; 6686 while (Present (Scope (Unit_Entity)) 6687 and then Scope (Unit_Entity) /= Standard_Standard) 6688 and not Is_Child_Unit (Unit_Entity) 6689 loop 6690 Unit_Entity := Scope (Unit_Entity); 6691 end loop; 6692 6693 return Unit_Entity; 6694 end Enclosing_Lib_Unit_Entity; 6695 6696 ----------------------------- 6697 -- Enclosing_Lib_Unit_Node -- 6698 ----------------------------- 6699 6700 function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is 6701 Encl_Unit : Node_Id; 6702 6703 begin 6704 Encl_Unit := Enclosing_Comp_Unit_Node (N); 6705 while Present (Encl_Unit) 6706 and then Nkind (Unit (Encl_Unit)) = N_Subunit 6707 loop 6708 Encl_Unit := Library_Unit (Encl_Unit); 6709 end loop; 6710 6711 pragma Assert (Nkind (Encl_Unit) = N_Compilation_Unit); 6712 return Encl_Unit; 6713 end Enclosing_Lib_Unit_Node; 6714 6715 ----------------------- 6716 -- Enclosing_Package -- 6717 ----------------------- 6718 6719 function Enclosing_Package (E : Entity_Id) return Entity_Id is 6720 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E); 6721 6722 begin 6723 if Dynamic_Scope = Standard_Standard then 6724 return Standard_Standard; 6725 6726 elsif Dynamic_Scope = Empty then 6727 return Empty; 6728 6729 elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body, 6730 E_Generic_Package) 6731 then 6732 return Dynamic_Scope; 6733 6734 else 6735 return Enclosing_Package (Dynamic_Scope); 6736 end if; 6737 end Enclosing_Package; 6738 6739 ------------------------------------- 6740 -- Enclosing_Package_Or_Subprogram -- 6741 ------------------------------------- 6742 6743 function Enclosing_Package_Or_Subprogram (E : Entity_Id) return Entity_Id is 6744 S : Entity_Id; 6745 6746 begin 6747 S := Scope (E); 6748 while Present (S) loop 6749 if Is_Package_Or_Generic_Package (S) 6750 or else Ekind (S) = E_Package_Body 6751 then 6752 return S; 6753 6754 elsif Is_Subprogram_Or_Generic_Subprogram (S) 6755 or else Ekind (S) = E_Subprogram_Body 6756 then 6757 return S; 6758 6759 else 6760 S := Scope (S); 6761 end if; 6762 end loop; 6763 6764 return Empty; 6765 end Enclosing_Package_Or_Subprogram; 6766 6767 -------------------------- 6768 -- Enclosing_Subprogram -- 6769 -------------------------- 6770 6771 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is 6772 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E); 6773 6774 begin 6775 if Dynamic_Scope = Standard_Standard then 6776 return Empty; 6777 6778 elsif Dynamic_Scope = Empty then 6779 return Empty; 6780 6781 elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then 6782 return Corresponding_Spec (Parent (Parent (Dynamic_Scope))); 6783 6784 elsif Ekind (Dynamic_Scope) = E_Block 6785 or else Ekind (Dynamic_Scope) = E_Return_Statement 6786 then 6787 return Enclosing_Subprogram (Dynamic_Scope); 6788 6789 elsif Ekind (Dynamic_Scope) = E_Task_Type then 6790 return Get_Task_Body_Procedure (Dynamic_Scope); 6791 6792 elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type 6793 and then Present (Full_View (Dynamic_Scope)) 6794 and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type 6795 then 6796 return Get_Task_Body_Procedure (Full_View (Dynamic_Scope)); 6797 6798 -- No body is generated if the protected operation is eliminated 6799 6800 elsif Convention (Dynamic_Scope) = Convention_Protected 6801 and then not Is_Eliminated (Dynamic_Scope) 6802 and then Present (Protected_Body_Subprogram (Dynamic_Scope)) 6803 then 6804 return Protected_Body_Subprogram (Dynamic_Scope); 6805 6806 else 6807 return Dynamic_Scope; 6808 end if; 6809 end Enclosing_Subprogram; 6810 6811 -------------------------- 6812 -- End_Keyword_Location -- 6813 -------------------------- 6814 6815 function End_Keyword_Location (N : Node_Id) return Source_Ptr is 6816 function End_Label_Loc (Nod : Node_Id) return Source_Ptr; 6817 -- Return the source location of Nod's end label according to the 6818 -- following precedence rules: 6819 -- 6820 -- 1) If the end label exists, return its location 6821 -- 2) If Nod exists, return its location 6822 -- 3) Return the location of N 6823 6824 ------------------- 6825 -- End_Label_Loc -- 6826 ------------------- 6827 6828 function End_Label_Loc (Nod : Node_Id) return Source_Ptr is 6829 Label : Node_Id; 6830 6831 begin 6832 if Present (Nod) then 6833 Label := End_Label (Nod); 6834 6835 if Present (Label) then 6836 return Sloc (Label); 6837 else 6838 return Sloc (Nod); 6839 end if; 6840 6841 else 6842 return Sloc (N); 6843 end if; 6844 end End_Label_Loc; 6845 6846 -- Local variables 6847 6848 Owner : Node_Id; 6849 6850 -- Start of processing for End_Keyword_Location 6851 6852 begin 6853 if Nkind_In (N, N_Block_Statement, 6854 N_Entry_Body, 6855 N_Package_Body, 6856 N_Subprogram_Body, 6857 N_Task_Body) 6858 then 6859 Owner := Handled_Statement_Sequence (N); 6860 6861 elsif Nkind (N) = N_Package_Declaration then 6862 Owner := Specification (N); 6863 6864 elsif Nkind (N) = N_Protected_Body then 6865 Owner := N; 6866 6867 elsif Nkind_In (N, N_Protected_Type_Declaration, 6868 N_Single_Protected_Declaration) 6869 then 6870 Owner := Protected_Definition (N); 6871 6872 elsif Nkind_In (N, N_Single_Task_Declaration, 6873 N_Task_Type_Declaration) 6874 then 6875 Owner := Task_Definition (N); 6876 6877 -- This routine should not be called with other contexts 6878 6879 else 6880 pragma Assert (False); 6881 null; 6882 end if; 6883 6884 return End_Label_Loc (Owner); 6885 end End_Keyword_Location; 6886 6887 ------------------------ 6888 -- Ensure_Freeze_Node -- 6889 ------------------------ 6890 6891 procedure Ensure_Freeze_Node (E : Entity_Id) is 6892 FN : Node_Id; 6893 begin 6894 if No (Freeze_Node (E)) then 6895 FN := Make_Freeze_Entity (Sloc (E)); 6896 Set_Has_Delayed_Freeze (E); 6897 Set_Freeze_Node (E, FN); 6898 Set_Access_Types_To_Process (FN, No_Elist); 6899 Set_TSS_Elist (FN, No_Elist); 6900 Set_Entity (FN, E); 6901 end if; 6902 end Ensure_Freeze_Node; 6903 6904 ---------------- 6905 -- Enter_Name -- 6906 ---------------- 6907 6908 procedure Enter_Name (Def_Id : Entity_Id) is 6909 C : constant Entity_Id := Current_Entity (Def_Id); 6910 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); 6911 S : constant Entity_Id := Current_Scope; 6912 6913 begin 6914 Generate_Definition (Def_Id); 6915 6916 -- Add new name to current scope declarations. Check for duplicate 6917 -- declaration, which may or may not be a genuine error. 6918 6919 if Present (E) then 6920 6921 -- Case of previous entity entered because of a missing declaration 6922 -- or else a bad subtype indication. Best is to use the new entity, 6923 -- and make the previous one invisible. 6924 6925 if Etype (E) = Any_Type then 6926 Set_Is_Immediately_Visible (E, False); 6927 6928 -- Case of renaming declaration constructed for package instances. 6929 -- if there is an explicit declaration with the same identifier, 6930 -- the renaming is not immediately visible any longer, but remains 6931 -- visible through selected component notation. 6932 6933 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration 6934 and then not Comes_From_Source (E) 6935 then 6936 Set_Is_Immediately_Visible (E, False); 6937 6938 -- The new entity may be the package renaming, which has the same 6939 -- same name as a generic formal which has been seen already. 6940 6941 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration 6942 and then not Comes_From_Source (Def_Id) 6943 then 6944 Set_Is_Immediately_Visible (E, False); 6945 6946 -- For a fat pointer corresponding to a remote access to subprogram, 6947 -- we use the same identifier as the RAS type, so that the proper 6948 -- name appears in the stub. This type is only retrieved through 6949 -- the RAS type and never by visibility, and is not added to the 6950 -- visibility list (see below). 6951 6952 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration 6953 and then Ekind (Def_Id) = E_Record_Type 6954 and then Present (Corresponding_Remote_Type (Def_Id)) 6955 then 6956 null; 6957 6958 -- Case of an implicit operation or derived literal. The new entity 6959 -- hides the implicit one, which is removed from all visibility, 6960 -- i.e. the entity list of its scope, and homonym chain of its name. 6961 6962 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E)) 6963 or else Is_Internal (E) 6964 then 6965 declare 6966 Decl : constant Node_Id := Parent (E); 6967 Prev : Entity_Id; 6968 Prev_Vis : Entity_Id; 6969 6970 begin 6971 -- If E is an implicit declaration, it cannot be the first 6972 -- entity in the scope. 6973 6974 Prev := First_Entity (Current_Scope); 6975 while Present (Prev) and then Next_Entity (Prev) /= E loop 6976 Next_Entity (Prev); 6977 end loop; 6978 6979 if No (Prev) then 6980 6981 -- If E is not on the entity chain of the current scope, 6982 -- it is an implicit declaration in the generic formal 6983 -- part of a generic subprogram. When analyzing the body, 6984 -- the generic formals are visible but not on the entity 6985 -- chain of the subprogram. The new entity will become 6986 -- the visible one in the body. 6987 6988 pragma Assert 6989 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration); 6990 null; 6991 6992 else 6993 Set_Next_Entity (Prev, Next_Entity (E)); 6994 6995 if No (Next_Entity (Prev)) then 6996 Set_Last_Entity (Current_Scope, Prev); 6997 end if; 6998 6999 if E = Current_Entity (E) then 7000 Prev_Vis := Empty; 7001 7002 else 7003 Prev_Vis := Current_Entity (E); 7004 while Homonym (Prev_Vis) /= E loop 7005 Prev_Vis := Homonym (Prev_Vis); 7006 end loop; 7007 end if; 7008 7009 if Present (Prev_Vis) then 7010 7011 -- Skip E in the visibility chain 7012 7013 Set_Homonym (Prev_Vis, Homonym (E)); 7014 7015 else 7016 Set_Name_Entity_Id (Chars (E), Homonym (E)); 7017 end if; 7018 end if; 7019 end; 7020 7021 -- This section of code could use a comment ??? 7022 7023 elsif Present (Etype (E)) 7024 and then Is_Concurrent_Type (Etype (E)) 7025 and then E = Def_Id 7026 then 7027 return; 7028 7029 -- If the homograph is a protected component renaming, it should not 7030 -- be hiding the current entity. Such renamings are treated as weak 7031 -- declarations. 7032 7033 elsif Is_Prival (E) then 7034 Set_Is_Immediately_Visible (E, False); 7035 7036 -- In this case the current entity is a protected component renaming. 7037 -- Perform minimal decoration by setting the scope and return since 7038 -- the prival should not be hiding other visible entities. 7039 7040 elsif Is_Prival (Def_Id) then 7041 Set_Scope (Def_Id, Current_Scope); 7042 return; 7043 7044 -- Analogous to privals, the discriminal generated for an entry index 7045 -- parameter acts as a weak declaration. Perform minimal decoration 7046 -- to avoid bogus errors. 7047 7048 elsif Is_Discriminal (Def_Id) 7049 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter 7050 then 7051 Set_Scope (Def_Id, Current_Scope); 7052 return; 7053 7054 -- In the body or private part of an instance, a type extension may 7055 -- introduce a component with the same name as that of an actual. The 7056 -- legality rule is not enforced, but the semantics of the full type 7057 -- with two components of same name are not clear at this point??? 7058 7059 elsif In_Instance_Not_Visible then 7060 null; 7061 7062 -- When compiling a package body, some child units may have become 7063 -- visible. They cannot conflict with local entities that hide them. 7064 7065 elsif Is_Child_Unit (E) 7066 and then In_Open_Scopes (Scope (E)) 7067 and then not Is_Immediately_Visible (E) 7068 then 7069 null; 7070 7071 -- Conversely, with front-end inlining we may compile the parent body 7072 -- first, and a child unit subsequently. The context is now the 7073 -- parent spec, and body entities are not visible. 7074 7075 elsif Is_Child_Unit (Def_Id) 7076 and then Is_Package_Body_Entity (E) 7077 and then not In_Package_Body (Current_Scope) 7078 then 7079 null; 7080 7081 -- Case of genuine duplicate declaration 7082 7083 else 7084 Error_Msg_Sloc := Sloc (E); 7085 7086 -- If the previous declaration is an incomplete type declaration 7087 -- this may be an attempt to complete it with a private type. The 7088 -- following avoids confusing cascaded errors. 7089 7090 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration 7091 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration 7092 then 7093 Error_Msg_N 7094 ("incomplete type cannot be completed with a private " & 7095 "declaration", Parent (Def_Id)); 7096 Set_Is_Immediately_Visible (E, False); 7097 Set_Full_View (E, Def_Id); 7098 7099 -- An inherited component of a record conflicts with a new 7100 -- discriminant. The discriminant is inserted first in the scope, 7101 -- but the error should be posted on it, not on the component. 7102 7103 elsif Ekind (E) = E_Discriminant 7104 and then Present (Scope (Def_Id)) 7105 and then Scope (Def_Id) /= Current_Scope 7106 then 7107 Error_Msg_Sloc := Sloc (Def_Id); 7108 Error_Msg_N ("& conflicts with declaration#", E); 7109 return; 7110 7111 -- If the name of the unit appears in its own context clause, a 7112 -- dummy package with the name has already been created, and the 7113 -- error emitted. Try to continue quietly. 7114 7115 elsif Error_Posted (E) 7116 and then Sloc (E) = No_Location 7117 and then Nkind (Parent (E)) = N_Package_Specification 7118 and then Current_Scope = Standard_Standard 7119 then 7120 Set_Scope (Def_Id, Current_Scope); 7121 return; 7122 7123 else 7124 Error_Msg_N ("& conflicts with declaration#", Def_Id); 7125 7126 -- Avoid cascaded messages with duplicate components in 7127 -- derived types. 7128 7129 if Ekind_In (E, E_Component, E_Discriminant) then 7130 return; 7131 end if; 7132 end if; 7133 7134 if Nkind (Parent (Parent (Def_Id))) = 7135 N_Generic_Subprogram_Declaration 7136 and then Def_Id = 7137 Defining_Entity (Specification (Parent (Parent (Def_Id)))) 7138 then 7139 Error_Msg_N ("\generic units cannot be overloaded", Def_Id); 7140 end if; 7141 7142 -- If entity is in standard, then we are in trouble, because it 7143 -- means that we have a library package with a duplicated name. 7144 -- That's hard to recover from, so abort. 7145 7146 if S = Standard_Standard then 7147 raise Unrecoverable_Error; 7148 7149 -- Otherwise we continue with the declaration. Having two 7150 -- identical declarations should not cause us too much trouble. 7151 7152 else 7153 null; 7154 end if; 7155 end if; 7156 end if; 7157 7158 -- If we fall through, declaration is OK, at least OK enough to continue 7159 7160 -- If Def_Id is a discriminant or a record component we are in the midst 7161 -- of inheriting components in a derived record definition. Preserve 7162 -- their Ekind and Etype. 7163 7164 if Ekind_In (Def_Id, E_Discriminant, E_Component) then 7165 null; 7166 7167 -- If a type is already set, leave it alone (happens when a type 7168 -- declaration is reanalyzed following a call to the optimizer). 7169 7170 elsif Present (Etype (Def_Id)) then 7171 null; 7172 7173 -- Otherwise, the kind E_Void insures that premature uses of the entity 7174 -- will be detected. Any_Type insures that no cascaded errors will occur 7175 7176 else 7177 Set_Ekind (Def_Id, E_Void); 7178 Set_Etype (Def_Id, Any_Type); 7179 end if; 7180 7181 -- Inherited discriminants and components in derived record types are 7182 -- immediately visible. Itypes are not. 7183 7184 -- Unless the Itype is for a record type with a corresponding remote 7185 -- type (what is that about, it was not commented ???) 7186 7187 if Ekind_In (Def_Id, E_Discriminant, E_Component) 7188 or else 7189 ((not Is_Record_Type (Def_Id) 7190 or else No (Corresponding_Remote_Type (Def_Id))) 7191 and then not Is_Itype (Def_Id)) 7192 then 7193 Set_Is_Immediately_Visible (Def_Id); 7194 Set_Current_Entity (Def_Id); 7195 end if; 7196 7197 Set_Homonym (Def_Id, C); 7198 Append_Entity (Def_Id, S); 7199 Set_Public_Status (Def_Id); 7200 7201 -- Declaring a homonym is not allowed in SPARK ... 7202 7203 if Present (C) and then Restriction_Check_Required (SPARK_05) then 7204 declare 7205 Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id); 7206 Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id); 7207 Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C); 7208 7209 begin 7210 -- ... unless the new declaration is in a subprogram, and the 7211 -- visible declaration is a variable declaration or a parameter 7212 -- specification outside that subprogram. 7213 7214 if Present (Enclosing_Subp) 7215 and then Nkind_In (Parent (C), N_Object_Declaration, 7216 N_Parameter_Specification) 7217 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp) 7218 then 7219 null; 7220 7221 -- ... or the new declaration is in a package, and the visible 7222 -- declaration occurs outside that package. 7223 7224 elsif Present (Enclosing_Pack) 7225 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack) 7226 then 7227 null; 7228 7229 -- ... or the new declaration is a component declaration in a 7230 -- record type definition. 7231 7232 elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then 7233 null; 7234 7235 -- Don't issue error for non-source entities 7236 7237 elsif Comes_From_Source (Def_Id) 7238 and then Comes_From_Source (C) 7239 then 7240 Error_Msg_Sloc := Sloc (C); 7241 Check_SPARK_05_Restriction 7242 ("redeclaration of identifier &#", Def_Id); 7243 end if; 7244 end; 7245 end if; 7246 7247 -- Warn if new entity hides an old one 7248 7249 if Warn_On_Hiding and then Present (C) 7250 7251 -- Don't warn for record components since they always have a well 7252 -- defined scope which does not confuse other uses. Note that in 7253 -- some cases, Ekind has not been set yet. 7254 7255 and then Ekind (C) /= E_Component 7256 and then Ekind (C) /= E_Discriminant 7257 and then Nkind (Parent (C)) /= N_Component_Declaration 7258 and then Ekind (Def_Id) /= E_Component 7259 and then Ekind (Def_Id) /= E_Discriminant 7260 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration 7261 7262 -- Don't warn for one character variables. It is too common to use 7263 -- such variables as locals and will just cause too many false hits. 7264 7265 and then Length_Of_Name (Chars (C)) /= 1 7266 7267 -- Don't warn for non-source entities 7268 7269 and then Comes_From_Source (C) 7270 and then Comes_From_Source (Def_Id) 7271 7272 -- Don't warn unless entity in question is in extended main source 7273 7274 and then In_Extended_Main_Source_Unit (Def_Id) 7275 7276 -- Finally, the hidden entity must be either immediately visible or 7277 -- use visible (i.e. from a used package). 7278 7279 and then 7280 (Is_Immediately_Visible (C) 7281 or else 7282 Is_Potentially_Use_Visible (C)) 7283 then 7284 Error_Msg_Sloc := Sloc (C); 7285 Error_Msg_N ("declaration hides &#?h?", Def_Id); 7286 end if; 7287 end Enter_Name; 7288 7289 --------------- 7290 -- Entity_Of -- 7291 --------------- 7292 7293 function Entity_Of (N : Node_Id) return Entity_Id is 7294 Id : Entity_Id; 7295 Ren : Node_Id; 7296 7297 begin 7298 -- Assume that the arbitrary node does not have an entity 7299 7300 Id := Empty; 7301 7302 if Is_Entity_Name (N) then 7303 Id := Entity (N); 7304 7305 -- Follow a possible chain of renamings to reach the earliest renamed 7306 -- source object. 7307 7308 while Present (Id) 7309 and then Is_Object (Id) 7310 and then Present (Renamed_Object (Id)) 7311 loop 7312 Ren := Renamed_Object (Id); 7313 7314 -- The reference renames an abstract state or a whole object 7315 7316 -- Obj : ...; 7317 -- Ren : ... renames Obj; 7318 7319 if Is_Entity_Name (Ren) then 7320 Id := Entity (Ren); 7321 7322 -- The reference renames a function result. Check the original 7323 -- node in case expansion relocates the function call. 7324 7325 -- Ren : ... renames Func_Call; 7326 7327 elsif Nkind (Original_Node (Ren)) = N_Function_Call then 7328 exit; 7329 7330 -- Otherwise the reference renames something which does not yield 7331 -- an abstract state or a whole object. Treat the reference as not 7332 -- having a proper entity for SPARK legality purposes. 7333 7334 else 7335 Id := Empty; 7336 exit; 7337 end if; 7338 end loop; 7339 end if; 7340 7341 return Id; 7342 end Entity_Of; 7343 7344 -------------------------- 7345 -- Explain_Limited_Type -- 7346 -------------------------- 7347 7348 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is 7349 C : Entity_Id; 7350 7351 begin 7352 -- For array, component type must be limited 7353 7354 if Is_Array_Type (T) then 7355 Error_Msg_Node_2 := T; 7356 Error_Msg_NE 7357 ("\component type& of type& is limited", N, Component_Type (T)); 7358 Explain_Limited_Type (Component_Type (T), N); 7359 7360 elsif Is_Record_Type (T) then 7361 7362 -- No need for extra messages if explicit limited record 7363 7364 if Is_Limited_Record (Base_Type (T)) then 7365 return; 7366 end if; 7367 7368 -- Otherwise find a limited component. Check only components that 7369 -- come from source, or inherited components that appear in the 7370 -- source of the ancestor. 7371 7372 C := First_Component (T); 7373 while Present (C) loop 7374 if Is_Limited_Type (Etype (C)) 7375 and then 7376 (Comes_From_Source (C) 7377 or else 7378 (Present (Original_Record_Component (C)) 7379 and then 7380 Comes_From_Source (Original_Record_Component (C)))) 7381 then 7382 Error_Msg_Node_2 := T; 7383 Error_Msg_NE ("\component& of type& has limited type", N, C); 7384 Explain_Limited_Type (Etype (C), N); 7385 return; 7386 end if; 7387 7388 Next_Component (C); 7389 end loop; 7390 7391 -- The type may be declared explicitly limited, even if no component 7392 -- of it is limited, in which case we fall out of the loop. 7393 return; 7394 end if; 7395 end Explain_Limited_Type; 7396 7397 --------------------------------------- 7398 -- Expression_Of_Expression_Function -- 7399 --------------------------------------- 7400 7401 function Expression_Of_Expression_Function 7402 (Subp : Entity_Id) return Node_Id 7403 is 7404 Expr_Func : Node_Id; 7405 7406 begin 7407 pragma Assert (Is_Expression_Function_Or_Completion (Subp)); 7408 7409 if Nkind (Original_Node (Subprogram_Spec (Subp))) = 7410 N_Expression_Function 7411 then 7412 Expr_Func := Original_Node (Subprogram_Spec (Subp)); 7413 7414 elsif Nkind (Original_Node (Subprogram_Body (Subp))) = 7415 N_Expression_Function 7416 then 7417 Expr_Func := Original_Node (Subprogram_Body (Subp)); 7418 7419 else 7420 pragma Assert (False); 7421 null; 7422 end if; 7423 7424 return Original_Node (Expression (Expr_Func)); 7425 end Expression_Of_Expression_Function; 7426 7427 ------------------------------- 7428 -- Extensions_Visible_Status -- 7429 ------------------------------- 7430 7431 function Extensions_Visible_Status 7432 (Id : Entity_Id) return Extensions_Visible_Mode 7433 is 7434 Arg : Node_Id; 7435 Decl : Node_Id; 7436 Expr : Node_Id; 7437 Prag : Node_Id; 7438 Subp : Entity_Id; 7439 7440 begin 7441 -- When a formal parameter is subject to Extensions_Visible, the pragma 7442 -- is stored in the contract of related subprogram. 7443 7444 if Is_Formal (Id) then 7445 Subp := Scope (Id); 7446 7447 elsif Is_Subprogram_Or_Generic_Subprogram (Id) then 7448 Subp := Id; 7449 7450 -- No other construct carries this pragma 7451 7452 else 7453 return Extensions_Visible_None; 7454 end if; 7455 7456 Prag := Get_Pragma (Subp, Pragma_Extensions_Visible); 7457 7458 -- In certain cases analysis may request the Extensions_Visible status 7459 -- of an expression function before the pragma has been analyzed yet. 7460 -- Inspect the declarative items after the expression function looking 7461 -- for the pragma (if any). 7462 7463 if No (Prag) and then Is_Expression_Function (Subp) then 7464 Decl := Next (Unit_Declaration_Node (Subp)); 7465 while Present (Decl) loop 7466 if Nkind (Decl) = N_Pragma 7467 and then Pragma_Name (Decl) = Name_Extensions_Visible 7468 then 7469 Prag := Decl; 7470 exit; 7471 7472 -- A source construct ends the region where Extensions_Visible may 7473 -- appear, stop the traversal. An expanded expression function is 7474 -- no longer a source construct, but it must still be recognized. 7475 7476 elsif Comes_From_Source (Decl) 7477 or else 7478 (Nkind_In (Decl, N_Subprogram_Body, 7479 N_Subprogram_Declaration) 7480 and then Is_Expression_Function (Defining_Entity (Decl))) 7481 then 7482 exit; 7483 end if; 7484 7485 Next (Decl); 7486 end loop; 7487 end if; 7488 7489 -- Extract the value from the Boolean expression (if any) 7490 7491 if Present (Prag) then 7492 Arg := First (Pragma_Argument_Associations (Prag)); 7493 7494 if Present (Arg) then 7495 Expr := Get_Pragma_Arg (Arg); 7496 7497 -- When the associated subprogram is an expression function, the 7498 -- argument of the pragma may not have been analyzed. 7499 7500 if not Analyzed (Expr) then 7501 Preanalyze_And_Resolve (Expr, Standard_Boolean); 7502 end if; 7503 7504 -- Guard against cascading errors when the argument of pragma 7505 -- Extensions_Visible is not a valid static Boolean expression. 7506 7507 if Error_Posted (Expr) then 7508 return Extensions_Visible_None; 7509 7510 elsif Is_True (Expr_Value (Expr)) then 7511 return Extensions_Visible_True; 7512 7513 else 7514 return Extensions_Visible_False; 7515 end if; 7516 7517 -- Otherwise the aspect or pragma defaults to True 7518 7519 else 7520 return Extensions_Visible_True; 7521 end if; 7522 7523 -- Otherwise aspect or pragma Extensions_Visible is not inherited or 7524 -- directly specified. In SPARK code, its value defaults to "False". 7525 7526 elsif SPARK_Mode = On then 7527 return Extensions_Visible_False; 7528 7529 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to 7530 -- "True". 7531 7532 else 7533 return Extensions_Visible_True; 7534 end if; 7535 end Extensions_Visible_Status; 7536 7537 ----------------- 7538 -- Find_Actual -- 7539 ----------------- 7540 7541 procedure Find_Actual 7542 (N : Node_Id; 7543 Formal : out Entity_Id; 7544 Call : out Node_Id) 7545 is 7546 Context : constant Node_Id := Parent (N); 7547 Actual : Node_Id; 7548 Call_Nam : Node_Id; 7549 7550 begin 7551 if Nkind_In (Context, N_Indexed_Component, N_Selected_Component) 7552 and then N = Prefix (Context) 7553 then 7554 Find_Actual (Context, Formal, Call); 7555 return; 7556 7557 elsif Nkind (Context) = N_Parameter_Association 7558 and then N = Explicit_Actual_Parameter (Context) 7559 then 7560 Call := Parent (Context); 7561 7562 elsif Nkind_In (Context, N_Entry_Call_Statement, 7563 N_Function_Call, 7564 N_Procedure_Call_Statement) 7565 then 7566 Call := Context; 7567 7568 else 7569 Formal := Empty; 7570 Call := Empty; 7571 return; 7572 end if; 7573 7574 -- If we have a call to a subprogram look for the parameter. Note that 7575 -- we exclude overloaded calls, since we don't know enough to be sure 7576 -- of giving the right answer in this case. 7577 7578 if Nkind_In (Call, N_Entry_Call_Statement, 7579 N_Function_Call, 7580 N_Procedure_Call_Statement) 7581 then 7582 Call_Nam := Name (Call); 7583 7584 -- A call to a protected or task entry appears as a selected 7585 -- component rather than an expanded name. 7586 7587 if Nkind (Call_Nam) = N_Selected_Component then 7588 Call_Nam := Selector_Name (Call_Nam); 7589 end if; 7590 7591 if Is_Entity_Name (Call_Nam) 7592 and then Present (Entity (Call_Nam)) 7593 and then Is_Overloadable (Entity (Call_Nam)) 7594 and then not Is_Overloaded (Call_Nam) 7595 then 7596 -- If node is name in call it is not an actual 7597 7598 if N = Call_Nam then 7599 Formal := Empty; 7600 Call := Empty; 7601 return; 7602 end if; 7603 7604 -- Fall here if we are definitely a parameter 7605 7606 Actual := First_Actual (Call); 7607 Formal := First_Formal (Entity (Call_Nam)); 7608 while Present (Formal) and then Present (Actual) loop 7609 if Actual = N then 7610 return; 7611 7612 -- An actual that is the prefix in a prefixed call may have 7613 -- been rewritten in the call, after the deferred reference 7614 -- was collected. Check if sloc and kinds and names match. 7615 7616 elsif Sloc (Actual) = Sloc (N) 7617 and then Nkind (Actual) = N_Identifier 7618 and then Nkind (Actual) = Nkind (N) 7619 and then Chars (Actual) = Chars (N) 7620 then 7621 return; 7622 7623 else 7624 Actual := Next_Actual (Actual); 7625 Formal := Next_Formal (Formal); 7626 end if; 7627 end loop; 7628 end if; 7629 end if; 7630 7631 -- Fall through here if we did not find matching actual 7632 7633 Formal := Empty; 7634 Call := Empty; 7635 end Find_Actual; 7636 7637 --------------------------- 7638 -- Find_Body_Discriminal -- 7639 --------------------------- 7640 7641 function Find_Body_Discriminal 7642 (Spec_Discriminant : Entity_Id) return Entity_Id 7643 is 7644 Tsk : Entity_Id; 7645 Disc : Entity_Id; 7646 7647 begin 7648 -- If expansion is suppressed, then the scope can be the concurrent type 7649 -- itself rather than a corresponding concurrent record type. 7650 7651 if Is_Concurrent_Type (Scope (Spec_Discriminant)) then 7652 Tsk := Scope (Spec_Discriminant); 7653 7654 else 7655 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant))); 7656 7657 Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant)); 7658 end if; 7659 7660 -- Find discriminant of original concurrent type, and use its current 7661 -- discriminal, which is the renaming within the task/protected body. 7662 7663 Disc := First_Discriminant (Tsk); 7664 while Present (Disc) loop 7665 if Chars (Disc) = Chars (Spec_Discriminant) then 7666 return Discriminal (Disc); 7667 end if; 7668 7669 Next_Discriminant (Disc); 7670 end loop; 7671 7672 -- That loop should always succeed in finding a matching entry and 7673 -- returning. Fatal error if not. 7674 7675 raise Program_Error; 7676 end Find_Body_Discriminal; 7677 7678 ------------------------------------- 7679 -- Find_Corresponding_Discriminant -- 7680 ------------------------------------- 7681 7682 function Find_Corresponding_Discriminant 7683 (Id : Node_Id; 7684 Typ : Entity_Id) return Entity_Id 7685 is 7686 Par_Disc : Entity_Id; 7687 Old_Disc : Entity_Id; 7688 New_Disc : Entity_Id; 7689 7690 begin 7691 Par_Disc := Original_Record_Component (Original_Discriminant (Id)); 7692 7693 -- The original type may currently be private, and the discriminant 7694 -- only appear on its full view. 7695 7696 if Is_Private_Type (Scope (Par_Disc)) 7697 and then not Has_Discriminants (Scope (Par_Disc)) 7698 and then Present (Full_View (Scope (Par_Disc))) 7699 then 7700 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc))); 7701 else 7702 Old_Disc := First_Discriminant (Scope (Par_Disc)); 7703 end if; 7704 7705 if Is_Class_Wide_Type (Typ) then 7706 New_Disc := First_Discriminant (Root_Type (Typ)); 7707 else 7708 New_Disc := First_Discriminant (Typ); 7709 end if; 7710 7711 while Present (Old_Disc) and then Present (New_Disc) loop 7712 if Old_Disc = Par_Disc then 7713 return New_Disc; 7714 end if; 7715 7716 Next_Discriminant (Old_Disc); 7717 Next_Discriminant (New_Disc); 7718 end loop; 7719 7720 -- Should always find it 7721 7722 raise Program_Error; 7723 end Find_Corresponding_Discriminant; 7724 7725 ------------------- 7726 -- Find_DIC_Type -- 7727 ------------------- 7728 7729 function Find_DIC_Type (Typ : Entity_Id) return Entity_Id is 7730 Curr_Typ : Entity_Id; 7731 -- The current type being examined in the parent hierarchy traversal 7732 7733 DIC_Typ : Entity_Id; 7734 -- The type which carries the DIC pragma. This variable denotes the 7735 -- partial view when private types are involved. 7736 7737 Par_Typ : Entity_Id; 7738 -- The parent type of the current type. This variable denotes the full 7739 -- view when private types are involved. 7740 7741 begin 7742 -- The input type defines its own DIC pragma, therefore it is the owner 7743 7744 if Has_Own_DIC (Typ) then 7745 DIC_Typ := Typ; 7746 7747 -- Otherwise the DIC pragma is inherited from a parent type 7748 7749 else 7750 pragma Assert (Has_Inherited_DIC (Typ)); 7751 7752 -- Climb the parent chain 7753 7754 Curr_Typ := Typ; 7755 loop 7756 -- Inspect the parent type. Do not consider subtypes as they 7757 -- inherit the DIC attributes from their base types. 7758 7759 DIC_Typ := Base_Type (Etype (Curr_Typ)); 7760 7761 -- Look at the full view of a private type because the type may 7762 -- have a hidden parent introduced in the full view. 7763 7764 Par_Typ := DIC_Typ; 7765 7766 if Is_Private_Type (Par_Typ) 7767 and then Present (Full_View (Par_Typ)) 7768 then 7769 Par_Typ := Full_View (Par_Typ); 7770 end if; 7771 7772 -- Stop the climb once the nearest parent type which defines a DIC 7773 -- pragma of its own is encountered or when the root of the parent 7774 -- chain is reached. 7775 7776 exit when Has_Own_DIC (DIC_Typ) or else Curr_Typ = Par_Typ; 7777 7778 Curr_Typ := Par_Typ; 7779 end loop; 7780 end if; 7781 7782 return DIC_Typ; 7783 end Find_DIC_Type; 7784 7785 ---------------------------------- 7786 -- Find_Enclosing_Iterator_Loop -- 7787 ---------------------------------- 7788 7789 function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id is 7790 Constr : Node_Id; 7791 S : Entity_Id; 7792 7793 begin 7794 -- Traverse the scope chain looking for an iterator loop. Such loops are 7795 -- usually transformed into blocks, hence the use of Original_Node. 7796 7797 S := Id; 7798 while Present (S) and then S /= Standard_Standard loop 7799 if Ekind (S) = E_Loop 7800 and then Nkind (Parent (S)) = N_Implicit_Label_Declaration 7801 then 7802 Constr := Original_Node (Label_Construct (Parent (S))); 7803 7804 if Nkind (Constr) = N_Loop_Statement 7805 and then Present (Iteration_Scheme (Constr)) 7806 and then Nkind (Iterator_Specification 7807 (Iteration_Scheme (Constr))) = 7808 N_Iterator_Specification 7809 then 7810 return S; 7811 end if; 7812 end if; 7813 7814 S := Scope (S); 7815 end loop; 7816 7817 return Empty; 7818 end Find_Enclosing_Iterator_Loop; 7819 7820 -------------------------- 7821 -- Find_Enclosing_Scope -- 7822 -------------------------- 7823 7824 function Find_Enclosing_Scope (N : Node_Id) return Entity_Id is 7825 Par : Node_Id; 7826 7827 begin 7828 -- Examine the parent chain looking for a construct which defines a 7829 -- scope. 7830 7831 Par := Parent (N); 7832 while Present (Par) loop 7833 case Nkind (Par) is 7834 7835 -- The construct denotes a declaration, the proper scope is its 7836 -- entity. 7837 7838 when N_Entry_Declaration 7839 | N_Expression_Function 7840 | N_Full_Type_Declaration 7841 | N_Generic_Package_Declaration 7842 | N_Generic_Subprogram_Declaration 7843 | N_Package_Declaration 7844 | N_Private_Extension_Declaration 7845 | N_Protected_Type_Declaration 7846 | N_Single_Protected_Declaration 7847 | N_Single_Task_Declaration 7848 | N_Subprogram_Declaration 7849 | N_Task_Type_Declaration 7850 => 7851 return Defining_Entity (Par); 7852 7853 -- The construct denotes a body, the proper scope is the entity of 7854 -- the corresponding spec or that of the body if the body does not 7855 -- complete a previous declaration. 7856 7857 when N_Entry_Body 7858 | N_Package_Body 7859 | N_Protected_Body 7860 | N_Subprogram_Body 7861 | N_Task_Body 7862 => 7863 return Unique_Defining_Entity (Par); 7864 7865 -- Special cases 7866 7867 -- Blocks carry either a source or an internally-generated scope, 7868 -- unless the block is a byproduct of exception handling. 7869 7870 when N_Block_Statement => 7871 if not Exception_Junk (Par) then 7872 return Entity (Identifier (Par)); 7873 end if; 7874 7875 -- Loops carry an internally-generated scope 7876 7877 when N_Loop_Statement => 7878 return Entity (Identifier (Par)); 7879 7880 -- Extended return statements carry an internally-generated scope 7881 7882 when N_Extended_Return_Statement => 7883 return Return_Statement_Entity (Par); 7884 7885 -- A traversal from a subunit continues via the corresponding stub 7886 7887 when N_Subunit => 7888 Par := Corresponding_Stub (Par); 7889 7890 when others => 7891 null; 7892 end case; 7893 7894 Par := Parent (Par); 7895 end loop; 7896 7897 return Standard_Standard; 7898 end Find_Enclosing_Scope; 7899 7900 ------------------------------------ 7901 -- Find_Loop_In_Conditional_Block -- 7902 ------------------------------------ 7903 7904 function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is 7905 Stmt : Node_Id; 7906 7907 begin 7908 Stmt := N; 7909 7910 if Nkind (Stmt) = N_If_Statement then 7911 Stmt := First (Then_Statements (Stmt)); 7912 end if; 7913 7914 pragma Assert (Nkind (Stmt) = N_Block_Statement); 7915 7916 -- Inspect the statements of the conditional block. In general the loop 7917 -- should be the first statement in the statement sequence of the block, 7918 -- but the finalization machinery may have introduced extra object 7919 -- declarations. 7920 7921 Stmt := First (Statements (Handled_Statement_Sequence (Stmt))); 7922 while Present (Stmt) loop 7923 if Nkind (Stmt) = N_Loop_Statement then 7924 return Stmt; 7925 end if; 7926 7927 Next (Stmt); 7928 end loop; 7929 7930 -- The expansion of attribute 'Loop_Entry produced a malformed block 7931 7932 raise Program_Error; 7933 end Find_Loop_In_Conditional_Block; 7934 7935 -------------------------- 7936 -- Find_Overlaid_Entity -- 7937 -------------------------- 7938 7939 procedure Find_Overlaid_Entity 7940 (N : Node_Id; 7941 Ent : out Entity_Id; 7942 Off : out Boolean) 7943 is 7944 Expr : Node_Id; 7945 7946 begin 7947 -- We are looking for one of the two following forms: 7948 7949 -- for X'Address use Y'Address 7950 7951 -- or 7952 7953 -- Const : constant Address := expr; 7954 -- ... 7955 -- for X'Address use Const; 7956 7957 -- In the second case, the expr is either Y'Address, or recursively a 7958 -- constant that eventually references Y'Address. 7959 7960 Ent := Empty; 7961 Off := False; 7962 7963 if Nkind (N) = N_Attribute_Definition_Clause 7964 and then Chars (N) = Name_Address 7965 then 7966 Expr := Expression (N); 7967 7968 -- This loop checks the form of the expression for Y'Address, 7969 -- using recursion to deal with intermediate constants. 7970 7971 loop 7972 -- Check for Y'Address 7973 7974 if Nkind (Expr) = N_Attribute_Reference 7975 and then Attribute_Name (Expr) = Name_Address 7976 then 7977 Expr := Prefix (Expr); 7978 exit; 7979 7980 -- Check for Const where Const is a constant entity 7981 7982 elsif Is_Entity_Name (Expr) 7983 and then Ekind (Entity (Expr)) = E_Constant 7984 then 7985 Expr := Constant_Value (Entity (Expr)); 7986 7987 -- Anything else does not need checking 7988 7989 else 7990 return; 7991 end if; 7992 end loop; 7993 7994 -- This loop checks the form of the prefix for an entity, using 7995 -- recursion to deal with intermediate components. 7996 7997 loop 7998 -- Check for Y where Y is an entity 7999 8000 if Is_Entity_Name (Expr) then 8001 Ent := Entity (Expr); 8002 return; 8003 8004 -- Check for components 8005 8006 elsif 8007 Nkind_In (Expr, N_Selected_Component, N_Indexed_Component) 8008 then 8009 Expr := Prefix (Expr); 8010 Off := True; 8011 8012 -- Anything else does not need checking 8013 8014 else 8015 return; 8016 end if; 8017 end loop; 8018 end if; 8019 end Find_Overlaid_Entity; 8020 8021 ------------------------- 8022 -- Find_Parameter_Type -- 8023 ------------------------- 8024 8025 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is 8026 begin 8027 if Nkind (Param) /= N_Parameter_Specification then 8028 return Empty; 8029 8030 -- For an access parameter, obtain the type from the formal entity 8031 -- itself, because access to subprogram nodes do not carry a type. 8032 -- Shouldn't we always use the formal entity ??? 8033 8034 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then 8035 return Etype (Defining_Identifier (Param)); 8036 8037 else 8038 return Etype (Parameter_Type (Param)); 8039 end if; 8040 end Find_Parameter_Type; 8041 8042 ----------------------------------- 8043 -- Find_Placement_In_State_Space -- 8044 ----------------------------------- 8045 8046 procedure Find_Placement_In_State_Space 8047 (Item_Id : Entity_Id; 8048 Placement : out State_Space_Kind; 8049 Pack_Id : out Entity_Id) 8050 is 8051 Context : Entity_Id; 8052 8053 begin 8054 -- Assume that the item does not appear in the state space of a package 8055 8056 Placement := Not_In_Package; 8057 Pack_Id := Empty; 8058 8059 -- Climb the scope stack and examine the enclosing context 8060 8061 Context := Scope (Item_Id); 8062 while Present (Context) and then Context /= Standard_Standard loop 8063 if Is_Package_Or_Generic_Package (Context) then 8064 Pack_Id := Context; 8065 8066 -- A package body is a cut off point for the traversal as the item 8067 -- cannot be visible to the outside from this point on. Note that 8068 -- this test must be done first as a body is also classified as a 8069 -- private part. 8070 8071 if In_Package_Body (Context) then 8072 Placement := Body_State_Space; 8073 return; 8074 8075 -- The private part of a package is a cut off point for the 8076 -- traversal as the item cannot be visible to the outside from 8077 -- this point on. 8078 8079 elsif In_Private_Part (Context) then 8080 Placement := Private_State_Space; 8081 return; 8082 8083 -- When the item appears in the visible state space of a package, 8084 -- continue to climb the scope stack as this may not be the final 8085 -- state space. 8086 8087 else 8088 Placement := Visible_State_Space; 8089 8090 -- The visible state space of a child unit acts as the proper 8091 -- placement of an item. 8092 8093 if Is_Child_Unit (Context) then 8094 return; 8095 end if; 8096 end if; 8097 8098 -- The item or its enclosing package appear in a construct that has 8099 -- no state space. 8100 8101 else 8102 Placement := Not_In_Package; 8103 return; 8104 end if; 8105 8106 Context := Scope (Context); 8107 end loop; 8108 end Find_Placement_In_State_Space; 8109 8110 ------------------------ 8111 -- Find_Specific_Type -- 8112 ------------------------ 8113 8114 function Find_Specific_Type (CW : Entity_Id) return Entity_Id is 8115 Typ : Entity_Id := Root_Type (CW); 8116 8117 begin 8118 if Ekind (Typ) = E_Incomplete_Type then 8119 if From_Limited_With (Typ) then 8120 Typ := Non_Limited_View (Typ); 8121 else 8122 Typ := Full_View (Typ); 8123 end if; 8124 end if; 8125 8126 if Is_Private_Type (Typ) 8127 and then not Is_Tagged_Type (Typ) 8128 and then Present (Full_View (Typ)) 8129 then 8130 return Full_View (Typ); 8131 else 8132 return Typ; 8133 end if; 8134 end Find_Specific_Type; 8135 8136 ----------------------------- 8137 -- Find_Static_Alternative -- 8138 ----------------------------- 8139 8140 function Find_Static_Alternative (N : Node_Id) return Node_Id is 8141 Expr : constant Node_Id := Expression (N); 8142 Val : constant Uint := Expr_Value (Expr); 8143 Alt : Node_Id; 8144 Choice : Node_Id; 8145 8146 begin 8147 Alt := First (Alternatives (N)); 8148 8149 Search : loop 8150 if Nkind (Alt) /= N_Pragma then 8151 Choice := First (Discrete_Choices (Alt)); 8152 while Present (Choice) loop 8153 8154 -- Others choice, always matches 8155 8156 if Nkind (Choice) = N_Others_Choice then 8157 exit Search; 8158 8159 -- Range, check if value is in the range 8160 8161 elsif Nkind (Choice) = N_Range then 8162 exit Search when 8163 Val >= Expr_Value (Low_Bound (Choice)) 8164 and then 8165 Val <= Expr_Value (High_Bound (Choice)); 8166 8167 -- Choice is a subtype name. Note that we know it must 8168 -- be a static subtype, since otherwise it would have 8169 -- been diagnosed as illegal. 8170 8171 elsif Is_Entity_Name (Choice) 8172 and then Is_Type (Entity (Choice)) 8173 then 8174 exit Search when Is_In_Range (Expr, Etype (Choice), 8175 Assume_Valid => False); 8176 8177 -- Choice is a subtype indication 8178 8179 elsif Nkind (Choice) = N_Subtype_Indication then 8180 declare 8181 C : constant Node_Id := Constraint (Choice); 8182 R : constant Node_Id := Range_Expression (C); 8183 8184 begin 8185 exit Search when 8186 Val >= Expr_Value (Low_Bound (R)) 8187 and then 8188 Val <= Expr_Value (High_Bound (R)); 8189 end; 8190 8191 -- Choice is a simple expression 8192 8193 else 8194 exit Search when Val = Expr_Value (Choice); 8195 end if; 8196 8197 Next (Choice); 8198 end loop; 8199 end if; 8200 8201 Next (Alt); 8202 pragma Assert (Present (Alt)); 8203 end loop Search; 8204 8205 -- The above loop *must* terminate by finding a match, since we know the 8206 -- case statement is valid, and the value of the expression is known at 8207 -- compile time. When we fall out of the loop, Alt points to the 8208 -- alternative that we know will be selected at run time. 8209 8210 return Alt; 8211 end Find_Static_Alternative; 8212 8213 ------------------ 8214 -- First_Actual -- 8215 ------------------ 8216 8217 function First_Actual (Node : Node_Id) return Node_Id is 8218 N : Node_Id; 8219 8220 begin 8221 if No (Parameter_Associations (Node)) then 8222 return Empty; 8223 end if; 8224 8225 N := First (Parameter_Associations (Node)); 8226 8227 if Nkind (N) = N_Parameter_Association then 8228 return First_Named_Actual (Node); 8229 else 8230 return N; 8231 end if; 8232 end First_Actual; 8233 8234 ------------------ 8235 -- First_Global -- 8236 ------------------ 8237 8238 function First_Global 8239 (Subp : Entity_Id; 8240 Global_Mode : Name_Id; 8241 Refined : Boolean := False) return Node_Id 8242 is 8243 function First_From_Global_List 8244 (List : Node_Id; 8245 Global_Mode : Name_Id := Name_Input) return Entity_Id; 8246 -- Get the first item with suitable mode from List 8247 8248 ---------------------------- 8249 -- First_From_Global_List -- 8250 ---------------------------- 8251 8252 function First_From_Global_List 8253 (List : Node_Id; 8254 Global_Mode : Name_Id := Name_Input) return Entity_Id 8255 is 8256 Assoc : Node_Id; 8257 8258 begin 8259 -- Empty list (no global items) 8260 8261 if Nkind (List) = N_Null then 8262 return Empty; 8263 8264 -- Single global item declaration (only input items) 8265 8266 elsif Nkind_In (List, N_Expanded_Name, 8267 N_Identifier, 8268 N_Selected_Component) 8269 then 8270 if Global_Mode = Name_Input then 8271 return List; 8272 else 8273 return Empty; 8274 end if; 8275 8276 -- Simple global list (only input items) or moded global list 8277 -- declaration. 8278 8279 elsif Nkind (List) = N_Aggregate then 8280 if Present (Expressions (List)) then 8281 if Global_Mode = Name_Input then 8282 return First (Expressions (List)); 8283 else 8284 return Empty; 8285 end if; 8286 8287 else 8288 Assoc := First (Component_Associations (List)); 8289 while Present (Assoc) loop 8290 8291 -- When we find the desired mode in an association, call 8292 -- recursively First_From_Global_List as if the mode was 8293 -- Name_Input, in order to reuse the existing machinery 8294 -- for the other cases. 8295 8296 if Chars (First (Choices (Assoc))) = Global_Mode then 8297 return First_From_Global_List (Expression (Assoc)); 8298 end if; 8299 8300 Next (Assoc); 8301 end loop; 8302 8303 return Empty; 8304 end if; 8305 8306 -- To accommodate partial decoration of disabled SPARK features, 8307 -- this routine may be called with illegal input. If this is the 8308 -- case, do not raise Program_Error. 8309 8310 else 8311 return Empty; 8312 end if; 8313 end First_From_Global_List; 8314 8315 -- Local variables 8316 8317 Global : Node_Id := Empty; 8318 Body_Id : Entity_Id; 8319 8320 begin 8321 pragma Assert (Global_Mode = Name_Input 8322 or else Global_Mode = Name_Output 8323 or else Global_Mode = Name_In_Out 8324 or else Global_Mode = Name_Proof_In); 8325 8326 -- Retrieve the suitable pragma Global or Refined_Global. In the second 8327 -- case, it can only be located on the body entity. 8328 8329 if Refined then 8330 Body_Id := Subprogram_Body_Entity (Subp); 8331 if Present (Body_Id) then 8332 Global := Get_Pragma (Body_Id, Pragma_Refined_Global); 8333 end if; 8334 else 8335 Global := Get_Pragma (Subp, Pragma_Global); 8336 end if; 8337 8338 -- No corresponding global if pragma is not present 8339 8340 if No (Global) then 8341 return Empty; 8342 8343 -- Otherwise retrieve the corresponding list of items depending on the 8344 -- Global_Mode. 8345 8346 else 8347 return First_From_Global_List 8348 (Expression (Get_Argument (Global, Subp)), Global_Mode); 8349 end if; 8350 end First_Global; 8351 8352 ------------- 8353 -- Fix_Msg -- 8354 ------------- 8355 8356 function Fix_Msg (Id : Entity_Id; Msg : String) return String is 8357 Is_Task : constant Boolean := 8358 Ekind_In (Id, E_Task_Body, E_Task_Type) 8359 or else Is_Single_Task_Object (Id); 8360 Msg_Last : constant Natural := Msg'Last; 8361 Msg_Index : Natural; 8362 Res : String (Msg'Range) := (others => ' '); 8363 Res_Index : Natural; 8364 8365 begin 8366 -- Copy all characters from the input message Msg to result Res with 8367 -- suitable replacements. 8368 8369 Msg_Index := Msg'First; 8370 Res_Index := Res'First; 8371 while Msg_Index <= Msg_Last loop 8372 8373 -- Replace "subprogram" with a different word 8374 8375 if Msg_Index <= Msg_Last - 10 8376 and then Msg (Msg_Index .. Msg_Index + 9) = "subprogram" 8377 then 8378 if Ekind_In (Id, E_Entry, E_Entry_Family) then 8379 Res (Res_Index .. Res_Index + 4) := "entry"; 8380 Res_Index := Res_Index + 5; 8381 8382 elsif Is_Task then 8383 Res (Res_Index .. Res_Index + 8) := "task type"; 8384 Res_Index := Res_Index + 9; 8385 8386 else 8387 Res (Res_Index .. Res_Index + 9) := "subprogram"; 8388 Res_Index := Res_Index + 10; 8389 end if; 8390 8391 Msg_Index := Msg_Index + 10; 8392 8393 -- Replace "protected" with a different word 8394 8395 elsif Msg_Index <= Msg_Last - 9 8396 and then Msg (Msg_Index .. Msg_Index + 8) = "protected" 8397 and then Is_Task 8398 then 8399 Res (Res_Index .. Res_Index + 3) := "task"; 8400 Res_Index := Res_Index + 4; 8401 Msg_Index := Msg_Index + 9; 8402 8403 -- Otherwise copy the character 8404 8405 else 8406 Res (Res_Index) := Msg (Msg_Index); 8407 Msg_Index := Msg_Index + 1; 8408 Res_Index := Res_Index + 1; 8409 end if; 8410 end loop; 8411 8412 return Res (Res'First .. Res_Index - 1); 8413 end Fix_Msg; 8414 8415 ------------------------- 8416 -- From_Nested_Package -- 8417 ------------------------- 8418 8419 function From_Nested_Package (T : Entity_Id) return Boolean is 8420 Pack : constant Entity_Id := Scope (T); 8421 8422 begin 8423 return 8424 Ekind (Pack) = E_Package 8425 and then not Is_Frozen (Pack) 8426 and then not Scope_Within_Or_Same (Current_Scope, Pack) 8427 and then In_Open_Scopes (Scope (Pack)); 8428 end From_Nested_Package; 8429 8430 ----------------------- 8431 -- Gather_Components -- 8432 ----------------------- 8433 8434 procedure Gather_Components 8435 (Typ : Entity_Id; 8436 Comp_List : Node_Id; 8437 Governed_By : List_Id; 8438 Into : Elist_Id; 8439 Report_Errors : out Boolean) 8440 is 8441 Assoc : Node_Id; 8442 Variant : Node_Id; 8443 Discrete_Choice : Node_Id; 8444 Comp_Item : Node_Id; 8445 8446 Discrim : Entity_Id; 8447 Discrim_Name : Node_Id; 8448 Discrim_Value : Node_Id; 8449 8450 begin 8451 Report_Errors := False; 8452 8453 if No (Comp_List) or else Null_Present (Comp_List) then 8454 return; 8455 8456 elsif Present (Component_Items (Comp_List)) then 8457 Comp_Item := First (Component_Items (Comp_List)); 8458 8459 else 8460 Comp_Item := Empty; 8461 end if; 8462 8463 while Present (Comp_Item) loop 8464 8465 -- Skip the tag of a tagged record, the interface tags, as well 8466 -- as all items that are not user components (anonymous types, 8467 -- rep clauses, Parent field, controller field). 8468 8469 if Nkind (Comp_Item) = N_Component_Declaration then 8470 declare 8471 Comp : constant Entity_Id := Defining_Identifier (Comp_Item); 8472 begin 8473 if not Is_Tag (Comp) and then Chars (Comp) /= Name_uParent then 8474 Append_Elmt (Comp, Into); 8475 end if; 8476 end; 8477 end if; 8478 8479 Next (Comp_Item); 8480 end loop; 8481 8482 if No (Variant_Part (Comp_List)) then 8483 return; 8484 else 8485 Discrim_Name := Name (Variant_Part (Comp_List)); 8486 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); 8487 end if; 8488 8489 -- Look for the discriminant that governs this variant part. 8490 -- The discriminant *must* be in the Governed_By List 8491 8492 Assoc := First (Governed_By); 8493 Find_Constraint : loop 8494 Discrim := First (Choices (Assoc)); 8495 exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim) 8496 or else (Present (Corresponding_Discriminant (Entity (Discrim))) 8497 and then 8498 Chars (Corresponding_Discriminant (Entity (Discrim))) = 8499 Chars (Discrim_Name)) 8500 or else Chars (Original_Record_Component (Entity (Discrim))) 8501 = Chars (Discrim_Name); 8502 8503 if No (Next (Assoc)) then 8504 if not Is_Constrained (Typ) 8505 and then Is_Derived_Type (Typ) 8506 and then Present (Stored_Constraint (Typ)) 8507 then 8508 -- If the type is a tagged type with inherited discriminants, 8509 -- use the stored constraint on the parent in order to find 8510 -- the values of discriminants that are otherwise hidden by an 8511 -- explicit constraint. Renamed discriminants are handled in 8512 -- the code above. 8513 8514 -- If several parent discriminants are renamed by a single 8515 -- discriminant of the derived type, the call to obtain the 8516 -- Corresponding_Discriminant field only retrieves the last 8517 -- of them. We recover the constraint on the others from the 8518 -- Stored_Constraint as well. 8519 8520 declare 8521 D : Entity_Id; 8522 C : Elmt_Id; 8523 8524 begin 8525 D := First_Discriminant (Etype (Typ)); 8526 C := First_Elmt (Stored_Constraint (Typ)); 8527 while Present (D) and then Present (C) loop 8528 if Chars (Discrim_Name) = Chars (D) then 8529 if Is_Entity_Name (Node (C)) 8530 and then Entity (Node (C)) = Entity (Discrim) 8531 then 8532 -- D is renamed by Discrim, whose value is given in 8533 -- Assoc. 8534 8535 null; 8536 8537 else 8538 Assoc := 8539 Make_Component_Association (Sloc (Typ), 8540 New_List 8541 (New_Occurrence_Of (D, Sloc (Typ))), 8542 Duplicate_Subexpr_No_Checks (Node (C))); 8543 end if; 8544 exit Find_Constraint; 8545 end if; 8546 8547 Next_Discriminant (D); 8548 Next_Elmt (C); 8549 end loop; 8550 end; 8551 end if; 8552 end if; 8553 8554 if No (Next (Assoc)) then 8555 Error_Msg_NE (" missing value for discriminant&", 8556 First (Governed_By), Discrim_Name); 8557 Report_Errors := True; 8558 return; 8559 end if; 8560 8561 Next (Assoc); 8562 end loop Find_Constraint; 8563 8564 Discrim_Value := Expression (Assoc); 8565 8566 if not Is_OK_Static_Expression (Discrim_Value) then 8567 8568 -- If the variant part is governed by a discriminant of the type 8569 -- this is an error. If the variant part and the discriminant are 8570 -- inherited from an ancestor this is legal (AI05-120) unless the 8571 -- components are being gathered for an aggregate, in which case 8572 -- the caller must check Report_Errors. 8573 8574 if Scope (Original_Record_Component 8575 ((Entity (First (Choices (Assoc)))))) = Typ 8576 then 8577 Error_Msg_FE 8578 ("value for discriminant & must be static!", 8579 Discrim_Value, Discrim); 8580 Why_Not_Static (Discrim_Value); 8581 end if; 8582 8583 Report_Errors := True; 8584 return; 8585 end if; 8586 8587 Search_For_Discriminant_Value : declare 8588 Low : Node_Id; 8589 High : Node_Id; 8590 8591 UI_High : Uint; 8592 UI_Low : Uint; 8593 UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value); 8594 8595 begin 8596 Find_Discrete_Value : while Present (Variant) loop 8597 Discrete_Choice := First (Discrete_Choices (Variant)); 8598 while Present (Discrete_Choice) loop 8599 exit Find_Discrete_Value when 8600 Nkind (Discrete_Choice) = N_Others_Choice; 8601 8602 Get_Index_Bounds (Discrete_Choice, Low, High); 8603 8604 UI_Low := Expr_Value (Low); 8605 UI_High := Expr_Value (High); 8606 8607 exit Find_Discrete_Value when 8608 UI_Low <= UI_Discrim_Value 8609 and then 8610 UI_High >= UI_Discrim_Value; 8611 8612 Next (Discrete_Choice); 8613 end loop; 8614 8615 Next_Non_Pragma (Variant); 8616 end loop Find_Discrete_Value; 8617 end Search_For_Discriminant_Value; 8618 8619 -- The case statement must include a variant that corresponds to the 8620 -- value of the discriminant, unless the discriminant type has a 8621 -- static predicate. In that case the absence of an others_choice that 8622 -- would cover this value becomes a run-time error (3.8,1 (21.1/2)). 8623 8624 if No (Variant) 8625 and then not Has_Static_Predicate (Etype (Discrim_Name)) 8626 then 8627 Error_Msg_NE 8628 ("value of discriminant & is out of range", Discrim_Value, Discrim); 8629 Report_Errors := True; 8630 return; 8631 end if; 8632 8633 -- If we have found the corresponding choice, recursively add its 8634 -- components to the Into list. The nested components are part of 8635 -- the same record type. 8636 8637 if Present (Variant) then 8638 Gather_Components 8639 (Typ, Component_List (Variant), Governed_By, Into, Report_Errors); 8640 end if; 8641 end Gather_Components; 8642 8643 ------------------------ 8644 -- Get_Actual_Subtype -- 8645 ------------------------ 8646 8647 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is 8648 Typ : constant Entity_Id := Etype (N); 8649 Utyp : Entity_Id := Underlying_Type (Typ); 8650 Decl : Node_Id; 8651 Atyp : Entity_Id; 8652 8653 begin 8654 if No (Utyp) then 8655 Utyp := Typ; 8656 end if; 8657 8658 -- If what we have is an identifier that references a subprogram 8659 -- formal, or a variable or constant object, then we get the actual 8660 -- subtype from the referenced entity if one has been built. 8661 8662 if Nkind (N) = N_Identifier 8663 and then 8664 (Is_Formal (Entity (N)) 8665 or else Ekind (Entity (N)) = E_Constant 8666 or else Ekind (Entity (N)) = E_Variable) 8667 and then Present (Actual_Subtype (Entity (N))) 8668 then 8669 return Actual_Subtype (Entity (N)); 8670 8671 -- Actual subtype of unchecked union is always itself. We never need 8672 -- the "real" actual subtype. If we did, we couldn't get it anyway 8673 -- because the discriminant is not available. The restrictions on 8674 -- Unchecked_Union are designed to make sure that this is OK. 8675 8676 elsif Is_Unchecked_Union (Base_Type (Utyp)) then 8677 return Typ; 8678 8679 -- Here for the unconstrained case, we must find actual subtype 8680 -- No actual subtype is available, so we must build it on the fly. 8681 8682 -- Checking the type, not the underlying type, for constrainedness 8683 -- seems to be necessary. Maybe all the tests should be on the type??? 8684 8685 elsif (not Is_Constrained (Typ)) 8686 and then (Is_Array_Type (Utyp) 8687 or else (Is_Record_Type (Utyp) 8688 and then Has_Discriminants (Utyp))) 8689 and then not Has_Unknown_Discriminants (Utyp) 8690 and then not (Ekind (Utyp) = E_String_Literal_Subtype) 8691 then 8692 -- Nothing to do if in spec expression (why not???) 8693 8694 if In_Spec_Expression then 8695 return Typ; 8696 8697 elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then 8698 8699 -- If the type has no discriminants, there is no subtype to 8700 -- build, even if the underlying type is discriminated. 8701 8702 return Typ; 8703 8704 -- Else build the actual subtype 8705 8706 else 8707 Decl := Build_Actual_Subtype (Typ, N); 8708 Atyp := Defining_Identifier (Decl); 8709 8710 -- If Build_Actual_Subtype generated a new declaration then use it 8711 8712 if Atyp /= Typ then 8713 8714 -- The actual subtype is an Itype, so analyze the declaration, 8715 -- but do not attach it to the tree, to get the type defined. 8716 8717 Set_Parent (Decl, N); 8718 Set_Is_Itype (Atyp); 8719 Analyze (Decl, Suppress => All_Checks); 8720 Set_Associated_Node_For_Itype (Atyp, N); 8721 Set_Has_Delayed_Freeze (Atyp, False); 8722 8723 -- We need to freeze the actual subtype immediately. This is 8724 -- needed, because otherwise this Itype will not get frozen 8725 -- at all, and it is always safe to freeze on creation because 8726 -- any associated types must be frozen at this point. 8727 8728 Freeze_Itype (Atyp, N); 8729 return Atyp; 8730 8731 -- Otherwise we did not build a declaration, so return original 8732 8733 else 8734 return Typ; 8735 end if; 8736 end if; 8737 8738 -- For all remaining cases, the actual subtype is the same as 8739 -- the nominal type. 8740 8741 else 8742 return Typ; 8743 end if; 8744 end Get_Actual_Subtype; 8745 8746 ------------------------------------- 8747 -- Get_Actual_Subtype_If_Available -- 8748 ------------------------------------- 8749 8750 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is 8751 Typ : constant Entity_Id := Etype (N); 8752 8753 begin 8754 -- If what we have is an identifier that references a subprogram 8755 -- formal, or a variable or constant object, then we get the actual 8756 -- subtype from the referenced entity if one has been built. 8757 8758 if Nkind (N) = N_Identifier 8759 and then 8760 (Is_Formal (Entity (N)) 8761 or else Ekind (Entity (N)) = E_Constant 8762 or else Ekind (Entity (N)) = E_Variable) 8763 and then Present (Actual_Subtype (Entity (N))) 8764 then 8765 return Actual_Subtype (Entity (N)); 8766 8767 -- Otherwise the Etype of N is returned unchanged 8768 8769 else 8770 return Typ; 8771 end if; 8772 end Get_Actual_Subtype_If_Available; 8773 8774 ------------------------ 8775 -- Get_Body_From_Stub -- 8776 ------------------------ 8777 8778 function Get_Body_From_Stub (N : Node_Id) return Node_Id is 8779 begin 8780 return Proper_Body (Unit (Library_Unit (N))); 8781 end Get_Body_From_Stub; 8782 8783 --------------------- 8784 -- Get_Cursor_Type -- 8785 --------------------- 8786 8787 function Get_Cursor_Type 8788 (Aspect : Node_Id; 8789 Typ : Entity_Id) return Entity_Id 8790 is 8791 Assoc : Node_Id; 8792 Func : Entity_Id; 8793 First_Op : Entity_Id; 8794 Cursor : Entity_Id; 8795 8796 begin 8797 -- If error already detected, return 8798 8799 if Error_Posted (Aspect) then 8800 return Any_Type; 8801 end if; 8802 8803 -- The cursor type for an Iterable aspect is the return type of a 8804 -- non-overloaded First primitive operation. Locate association for 8805 -- First. 8806 8807 Assoc := First (Component_Associations (Expression (Aspect))); 8808 First_Op := Any_Id; 8809 while Present (Assoc) loop 8810 if Chars (First (Choices (Assoc))) = Name_First then 8811 First_Op := Expression (Assoc); 8812 exit; 8813 end if; 8814 8815 Next (Assoc); 8816 end loop; 8817 8818 if First_Op = Any_Id then 8819 Error_Msg_N ("aspect Iterable must specify First operation", Aspect); 8820 return Any_Type; 8821 end if; 8822 8823 Cursor := Any_Type; 8824 8825 -- Locate function with desired name and profile in scope of type 8826 -- In the rare case where the type is an integer type, a base type 8827 -- is created for it, check that the base type of the first formal 8828 -- of First matches the base type of the domain. 8829 8830 Func := First_Entity (Scope (Typ)); 8831 while Present (Func) loop 8832 if Chars (Func) = Chars (First_Op) 8833 and then Ekind (Func) = E_Function 8834 and then Present (First_Formal (Func)) 8835 and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ) 8836 and then No (Next_Formal (First_Formal (Func))) 8837 then 8838 if Cursor /= Any_Type then 8839 Error_Msg_N 8840 ("Operation First for iterable type must be unique", Aspect); 8841 return Any_Type; 8842 else 8843 Cursor := Etype (Func); 8844 end if; 8845 end if; 8846 8847 Next_Entity (Func); 8848 end loop; 8849 8850 -- If not found, no way to resolve remaining primitives. 8851 8852 if Cursor = Any_Type then 8853 Error_Msg_N 8854 ("No legal primitive operation First for Iterable type", Aspect); 8855 end if; 8856 8857 return Cursor; 8858 end Get_Cursor_Type; 8859 8860 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is 8861 begin 8862 return Etype (Get_Iterable_Type_Primitive (Typ, Name_First)); 8863 end Get_Cursor_Type; 8864 8865 ------------------------------- 8866 -- Get_Default_External_Name -- 8867 ------------------------------- 8868 8869 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is 8870 begin 8871 Get_Decoded_Name_String (Chars (E)); 8872 8873 if Opt.External_Name_Imp_Casing = Uppercase then 8874 Set_Casing (All_Upper_Case); 8875 else 8876 Set_Casing (All_Lower_Case); 8877 end if; 8878 8879 return 8880 Make_String_Literal (Sloc (E), 8881 Strval => String_From_Name_Buffer); 8882 end Get_Default_External_Name; 8883 8884 -------------------------- 8885 -- Get_Enclosing_Object -- 8886 -------------------------- 8887 8888 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is 8889 begin 8890 if Is_Entity_Name (N) then 8891 return Entity (N); 8892 else 8893 case Nkind (N) is 8894 when N_Indexed_Component 8895 | N_Selected_Component 8896 | N_Slice 8897 => 8898 -- If not generating code, a dereference may be left implicit. 8899 -- In thoses cases, return Empty. 8900 8901 if Is_Access_Type (Etype (Prefix (N))) then 8902 return Empty; 8903 else 8904 return Get_Enclosing_Object (Prefix (N)); 8905 end if; 8906 8907 when N_Type_Conversion => 8908 return Get_Enclosing_Object (Expression (N)); 8909 8910 when others => 8911 return Empty; 8912 end case; 8913 end if; 8914 end Get_Enclosing_Object; 8915 8916 --------------------------- 8917 -- Get_Enum_Lit_From_Pos -- 8918 --------------------------- 8919 8920 function Get_Enum_Lit_From_Pos 8921 (T : Entity_Id; 8922 Pos : Uint; 8923 Loc : Source_Ptr) return Node_Id 8924 is 8925 Btyp : Entity_Id := Base_Type (T); 8926 Lit : Node_Id; 8927 LLoc : Source_Ptr; 8928 8929 begin 8930 -- In the case where the literal is of type Character, Wide_Character 8931 -- or Wide_Wide_Character or of a type derived from them, there needs 8932 -- to be some special handling since there is no explicit chain of 8933 -- literals to search. Instead, an N_Character_Literal node is created 8934 -- with the appropriate Char_Code and Chars fields. 8935 8936 if Is_Standard_Character_Type (T) then 8937 Set_Character_Literal_Name (UI_To_CC (Pos)); 8938 8939 return 8940 Make_Character_Literal (Loc, 8941 Chars => Name_Find, 8942 Char_Literal_Value => Pos); 8943 8944 -- For all other cases, we have a complete table of literals, and 8945 -- we simply iterate through the chain of literal until the one 8946 -- with the desired position value is found. 8947 8948 else 8949 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then 8950 Btyp := Full_View (Btyp); 8951 end if; 8952 8953 Lit := First_Literal (Btyp); 8954 8955 -- Position in the enumeration type starts at 0 8956 8957 if UI_To_Int (Pos) < 0 then 8958 raise Constraint_Error; 8959 end if; 8960 8961 for J in 1 .. UI_To_Int (Pos) loop 8962 Next_Literal (Lit); 8963 8964 -- If Lit is Empty, Pos is not in range, so raise Constraint_Error 8965 -- inside the loop to avoid calling Next_Literal on Empty. 8966 8967 if No (Lit) then 8968 raise Constraint_Error; 8969 end if; 8970 end loop; 8971 8972 -- Create a new node from Lit, with source location provided by Loc 8973 -- if not equal to No_Location, or by copying the source location of 8974 -- Lit otherwise. 8975 8976 LLoc := Loc; 8977 8978 if LLoc = No_Location then 8979 LLoc := Sloc (Lit); 8980 end if; 8981 8982 return New_Occurrence_Of (Lit, LLoc); 8983 end if; 8984 end Get_Enum_Lit_From_Pos; 8985 8986 ------------------------ 8987 -- Get_Generic_Entity -- 8988 ------------------------ 8989 8990 function Get_Generic_Entity (N : Node_Id) return Entity_Id is 8991 Ent : constant Entity_Id := Entity (Name (N)); 8992 begin 8993 if Present (Renamed_Object (Ent)) then 8994 return Renamed_Object (Ent); 8995 else 8996 return Ent; 8997 end if; 8998 end Get_Generic_Entity; 8999 9000 ------------------------------------- 9001 -- Get_Incomplete_View_Of_Ancestor -- 9002 ------------------------------------- 9003 9004 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is 9005 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 9006 Par_Scope : Entity_Id; 9007 Par_Type : Entity_Id; 9008 9009 begin 9010 -- The incomplete view of an ancestor is only relevant for private 9011 -- derived types in child units. 9012 9013 if not Is_Derived_Type (E) 9014 or else not Is_Child_Unit (Cur_Unit) 9015 then 9016 return Empty; 9017 9018 else 9019 Par_Scope := Scope (Cur_Unit); 9020 if No (Par_Scope) then 9021 return Empty; 9022 end if; 9023 9024 Par_Type := Etype (Base_Type (E)); 9025 9026 -- Traverse list of ancestor types until we find one declared in 9027 -- a parent or grandparent unit (two levels seem sufficient). 9028 9029 while Present (Par_Type) loop 9030 if Scope (Par_Type) = Par_Scope 9031 or else Scope (Par_Type) = Scope (Par_Scope) 9032 then 9033 return Par_Type; 9034 9035 elsif not Is_Derived_Type (Par_Type) then 9036 return Empty; 9037 9038 else 9039 Par_Type := Etype (Base_Type (Par_Type)); 9040 end if; 9041 end loop; 9042 9043 -- If none found, there is no relevant ancestor type. 9044 9045 return Empty; 9046 end if; 9047 end Get_Incomplete_View_Of_Ancestor; 9048 9049 ---------------------- 9050 -- Get_Index_Bounds -- 9051 ---------------------- 9052 9053 procedure Get_Index_Bounds 9054 (N : Node_Id; 9055 L : out Node_Id; 9056 H : out Node_Id; 9057 Use_Full_View : Boolean := False) 9058 is 9059 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id; 9060 -- Obtain the scalar range of type Typ. If flag Use_Full_View is set and 9061 -- Typ qualifies, the scalar range is obtained from the full view of the 9062 -- type. 9063 9064 -------------------------- 9065 -- Scalar_Range_Of_Type -- 9066 -------------------------- 9067 9068 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id is 9069 T : Entity_Id := Typ; 9070 9071 begin 9072 if Use_Full_View and then Present (Full_View (T)) then 9073 T := Full_View (T); 9074 end if; 9075 9076 return Scalar_Range (T); 9077 end Scalar_Range_Of_Type; 9078 9079 -- Local variables 9080 9081 Kind : constant Node_Kind := Nkind (N); 9082 Rng : Node_Id; 9083 9084 -- Start of processing for Get_Index_Bounds 9085 9086 begin 9087 if Kind = N_Range then 9088 L := Low_Bound (N); 9089 H := High_Bound (N); 9090 9091 elsif Kind = N_Subtype_Indication then 9092 Rng := Range_Expression (Constraint (N)); 9093 9094 if Rng = Error then 9095 L := Error; 9096 H := Error; 9097 return; 9098 9099 else 9100 L := Low_Bound (Range_Expression (Constraint (N))); 9101 H := High_Bound (Range_Expression (Constraint (N))); 9102 end if; 9103 9104 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then 9105 Rng := Scalar_Range_Of_Type (Entity (N)); 9106 9107 if Error_Posted (Rng) then 9108 L := Error; 9109 H := Error; 9110 9111 elsif Nkind (Rng) = N_Subtype_Indication then 9112 Get_Index_Bounds (Rng, L, H); 9113 9114 else 9115 L := Low_Bound (Rng); 9116 H := High_Bound (Rng); 9117 end if; 9118 9119 else 9120 -- N is an expression, indicating a range with one value 9121 9122 L := N; 9123 H := N; 9124 end if; 9125 end Get_Index_Bounds; 9126 9127 ----------------------------- 9128 -- Get_Interfacing_Aspects -- 9129 ----------------------------- 9130 9131 procedure Get_Interfacing_Aspects 9132 (Iface_Asp : Node_Id; 9133 Conv_Asp : out Node_Id; 9134 EN_Asp : out Node_Id; 9135 Expo_Asp : out Node_Id; 9136 Imp_Asp : out Node_Id; 9137 LN_Asp : out Node_Id; 9138 Do_Checks : Boolean := False) 9139 is 9140 procedure Save_Or_Duplication_Error 9141 (Asp : Node_Id; 9142 To : in out Node_Id); 9143 -- Save the value of aspect Asp in node To. If To already has a value, 9144 -- then this is considered a duplicate use of aspect. Emit an error if 9145 -- flag Do_Checks is set. 9146 9147 ------------------------------- 9148 -- Save_Or_Duplication_Error -- 9149 ------------------------------- 9150 9151 procedure Save_Or_Duplication_Error 9152 (Asp : Node_Id; 9153 To : in out Node_Id) 9154 is 9155 begin 9156 -- Detect an extra aspect and issue an error 9157 9158 if Present (To) then 9159 if Do_Checks then 9160 Error_Msg_Name_1 := Chars (Identifier (Asp)); 9161 Error_Msg_Sloc := Sloc (To); 9162 Error_Msg_N ("aspect % previously given #", Asp); 9163 end if; 9164 9165 -- Otherwise capture the aspect 9166 9167 else 9168 To := Asp; 9169 end if; 9170 end Save_Or_Duplication_Error; 9171 9172 -- Local variables 9173 9174 Asp : Node_Id; 9175 Asp_Id : Aspect_Id; 9176 9177 -- The following variables capture each individual aspect 9178 9179 Conv : Node_Id := Empty; 9180 EN : Node_Id := Empty; 9181 Expo : Node_Id := Empty; 9182 Imp : Node_Id := Empty; 9183 LN : Node_Id := Empty; 9184 9185 -- Start of processing for Get_Interfacing_Aspects 9186 9187 begin 9188 -- The input interfacing aspect should reside in an aspect specification 9189 -- list. 9190 9191 pragma Assert (Is_List_Member (Iface_Asp)); 9192 9193 -- Examine the aspect specifications of the related entity. Find and 9194 -- capture all interfacing aspects. Detect duplicates and emit errors 9195 -- if applicable. 9196 9197 Asp := First (List_Containing (Iface_Asp)); 9198 while Present (Asp) loop 9199 Asp_Id := Get_Aspect_Id (Asp); 9200 9201 if Asp_Id = Aspect_Convention then 9202 Save_Or_Duplication_Error (Asp, Conv); 9203 9204 elsif Asp_Id = Aspect_External_Name then 9205 Save_Or_Duplication_Error (Asp, EN); 9206 9207 elsif Asp_Id = Aspect_Export then 9208 Save_Or_Duplication_Error (Asp, Expo); 9209 9210 elsif Asp_Id = Aspect_Import then 9211 Save_Or_Duplication_Error (Asp, Imp); 9212 9213 elsif Asp_Id = Aspect_Link_Name then 9214 Save_Or_Duplication_Error (Asp, LN); 9215 end if; 9216 9217 Next (Asp); 9218 end loop; 9219 9220 Conv_Asp := Conv; 9221 EN_Asp := EN; 9222 Expo_Asp := Expo; 9223 Imp_Asp := Imp; 9224 LN_Asp := LN; 9225 end Get_Interfacing_Aspects; 9226 9227 --------------------------------- 9228 -- Get_Iterable_Type_Primitive -- 9229 --------------------------------- 9230 9231 function Get_Iterable_Type_Primitive 9232 (Typ : Entity_Id; 9233 Nam : Name_Id) return Entity_Id 9234 is 9235 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable); 9236 Assoc : Node_Id; 9237 9238 begin 9239 if No (Funcs) then 9240 return Empty; 9241 9242 else 9243 Assoc := First (Component_Associations (Funcs)); 9244 while Present (Assoc) loop 9245 if Chars (First (Choices (Assoc))) = Nam then 9246 return Entity (Expression (Assoc)); 9247 end if; 9248 9249 Assoc := Next (Assoc); 9250 end loop; 9251 9252 return Empty; 9253 end if; 9254 end Get_Iterable_Type_Primitive; 9255 9256 ---------------------------------- 9257 -- Get_Library_Unit_Name_string -- 9258 ---------------------------------- 9259 9260 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is 9261 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node); 9262 9263 begin 9264 Get_Unit_Name_String (Unit_Name_Id); 9265 9266 -- Remove seven last character (" (spec)" or " (body)") 9267 9268 Name_Len := Name_Len - 7; 9269 pragma Assert (Name_Buffer (Name_Len + 1) = ' '); 9270 end Get_Library_Unit_Name_String; 9271 9272 -------------------------- 9273 -- Get_Max_Queue_Length -- 9274 -------------------------- 9275 9276 function Get_Max_Queue_Length (Id : Entity_Id) return Uint is 9277 pragma Assert (Is_Entry (Id)); 9278 Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length); 9279 9280 begin 9281 -- A value of 0 represents no maximum specified, and entries and entry 9282 -- families with no Max_Queue_Length aspect or pragma default to it. 9283 9284 if not Present (Prag) then 9285 return Uint_0; 9286 end if; 9287 9288 return Intval (Expression (First (Pragma_Argument_Associations (Prag)))); 9289 end Get_Max_Queue_Length; 9290 9291 ------------------------ 9292 -- Get_Name_Entity_Id -- 9293 ------------------------ 9294 9295 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is 9296 begin 9297 return Entity_Id (Get_Name_Table_Int (Id)); 9298 end Get_Name_Entity_Id; 9299 9300 ------------------------------ 9301 -- Get_Name_From_CTC_Pragma -- 9302 ------------------------------ 9303 9304 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is 9305 Arg : constant Node_Id := 9306 Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 9307 begin 9308 return Strval (Expr_Value_S (Arg)); 9309 end Get_Name_From_CTC_Pragma; 9310 9311 ----------------------- 9312 -- Get_Parent_Entity -- 9313 ----------------------- 9314 9315 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is 9316 begin 9317 if Nkind (Unit) = N_Package_Body 9318 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation 9319 then 9320 return Defining_Entity 9321 (Specification (Instance_Spec (Original_Node (Unit)))); 9322 elsif Nkind (Unit) = N_Package_Instantiation then 9323 return Defining_Entity (Specification (Instance_Spec (Unit))); 9324 else 9325 return Defining_Entity (Unit); 9326 end if; 9327 end Get_Parent_Entity; 9328 9329 ------------------- 9330 -- Get_Pragma_Id -- 9331 ------------------- 9332 9333 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is 9334 begin 9335 return Get_Pragma_Id (Pragma_Name_Unmapped (N)); 9336 end Get_Pragma_Id; 9337 9338 ------------------------ 9339 -- Get_Qualified_Name -- 9340 ------------------------ 9341 9342 function Get_Qualified_Name 9343 (Id : Entity_Id; 9344 Suffix : Entity_Id := Empty) return Name_Id 9345 is 9346 Suffix_Nam : Name_Id := No_Name; 9347 9348 begin 9349 if Present (Suffix) then 9350 Suffix_Nam := Chars (Suffix); 9351 end if; 9352 9353 return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id)); 9354 end Get_Qualified_Name; 9355 9356 function Get_Qualified_Name 9357 (Nam : Name_Id; 9358 Suffix : Name_Id := No_Name; 9359 Scop : Entity_Id := Current_Scope) return Name_Id 9360 is 9361 procedure Add_Scope (S : Entity_Id); 9362 -- Add the fully qualified form of scope S to the name buffer. The 9363 -- format is: 9364 -- s-1__s__ 9365 9366 --------------- 9367 -- Add_Scope -- 9368 --------------- 9369 9370 procedure Add_Scope (S : Entity_Id) is 9371 begin 9372 if S = Empty then 9373 null; 9374 9375 elsif S = Standard_Standard then 9376 null; 9377 9378 else 9379 Add_Scope (Scope (S)); 9380 Get_Name_String_And_Append (Chars (S)); 9381 Add_Str_To_Name_Buffer ("__"); 9382 end if; 9383 end Add_Scope; 9384 9385 -- Start of processing for Get_Qualified_Name 9386 9387 begin 9388 Name_Len := 0; 9389 Add_Scope (Scop); 9390 9391 -- Append the base name after all scopes have been chained 9392 9393 Get_Name_String_And_Append (Nam); 9394 9395 -- Append the suffix (if present) 9396 9397 if Suffix /= No_Name then 9398 Add_Str_To_Name_Buffer ("__"); 9399 Get_Name_String_And_Append (Suffix); 9400 end if; 9401 9402 return Name_Find; 9403 end Get_Qualified_Name; 9404 9405 ----------------------- 9406 -- Get_Reason_String -- 9407 ----------------------- 9408 9409 procedure Get_Reason_String (N : Node_Id) is 9410 begin 9411 if Nkind (N) = N_String_Literal then 9412 Store_String_Chars (Strval (N)); 9413 9414 elsif Nkind (N) = N_Op_Concat then 9415 Get_Reason_String (Left_Opnd (N)); 9416 Get_Reason_String (Right_Opnd (N)); 9417 9418 -- If not of required form, error 9419 9420 else 9421 Error_Msg_N 9422 ("Reason for pragma Warnings has wrong form", N); 9423 Error_Msg_N 9424 ("\must be string literal or concatenation of string literals", N); 9425 return; 9426 end if; 9427 end Get_Reason_String; 9428 9429 -------------------------------- 9430 -- Get_Reference_Discriminant -- 9431 -------------------------------- 9432 9433 function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is 9434 D : Entity_Id; 9435 9436 begin 9437 D := First_Discriminant (Typ); 9438 while Present (D) loop 9439 if Has_Implicit_Dereference (D) then 9440 return D; 9441 end if; 9442 Next_Discriminant (D); 9443 end loop; 9444 9445 return Empty; 9446 end Get_Reference_Discriminant; 9447 9448 --------------------------- 9449 -- Get_Referenced_Object -- 9450 --------------------------- 9451 9452 function Get_Referenced_Object (N : Node_Id) return Node_Id is 9453 R : Node_Id; 9454 9455 begin 9456 R := N; 9457 while Is_Entity_Name (R) 9458 and then Present (Renamed_Object (Entity (R))) 9459 loop 9460 R := Renamed_Object (Entity (R)); 9461 end loop; 9462 9463 return R; 9464 end Get_Referenced_Object; 9465 9466 ------------------------ 9467 -- Get_Renamed_Entity -- 9468 ------------------------ 9469 9470 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is 9471 R : Entity_Id; 9472 9473 begin 9474 R := E; 9475 while Present (Renamed_Entity (R)) loop 9476 R := Renamed_Entity (R); 9477 end loop; 9478 9479 return R; 9480 end Get_Renamed_Entity; 9481 9482 ----------------------- 9483 -- Get_Return_Object -- 9484 ----------------------- 9485 9486 function Get_Return_Object (N : Node_Id) return Entity_Id is 9487 Decl : Node_Id; 9488 9489 begin 9490 Decl := First (Return_Object_Declarations (N)); 9491 while Present (Decl) loop 9492 exit when Nkind (Decl) = N_Object_Declaration 9493 and then Is_Return_Object (Defining_Identifier (Decl)); 9494 Next (Decl); 9495 end loop; 9496 9497 pragma Assert (Present (Decl)); 9498 return Defining_Identifier (Decl); 9499 end Get_Return_Object; 9500 9501 --------------------------- 9502 -- Get_Subprogram_Entity -- 9503 --------------------------- 9504 9505 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is 9506 Subp : Node_Id; 9507 Subp_Id : Entity_Id; 9508 9509 begin 9510 if Nkind (Nod) = N_Accept_Statement then 9511 Subp := Entry_Direct_Name (Nod); 9512 9513 elsif Nkind (Nod) = N_Slice then 9514 Subp := Prefix (Nod); 9515 9516 else 9517 Subp := Name (Nod); 9518 end if; 9519 9520 -- Strip the subprogram call 9521 9522 loop 9523 if Nkind_In (Subp, N_Explicit_Dereference, 9524 N_Indexed_Component, 9525 N_Selected_Component) 9526 then 9527 Subp := Prefix (Subp); 9528 9529 elsif Nkind_In (Subp, N_Type_Conversion, 9530 N_Unchecked_Type_Conversion) 9531 then 9532 Subp := Expression (Subp); 9533 9534 else 9535 exit; 9536 end if; 9537 end loop; 9538 9539 -- Extract the entity of the subprogram call 9540 9541 if Is_Entity_Name (Subp) then 9542 Subp_Id := Entity (Subp); 9543 9544 if Ekind (Subp_Id) = E_Access_Subprogram_Type then 9545 Subp_Id := Directly_Designated_Type (Subp_Id); 9546 end if; 9547 9548 if Is_Subprogram (Subp_Id) then 9549 return Subp_Id; 9550 else 9551 return Empty; 9552 end if; 9553 9554 -- The search did not find a construct that denotes a subprogram 9555 9556 else 9557 return Empty; 9558 end if; 9559 end Get_Subprogram_Entity; 9560 9561 ----------------------------- 9562 -- Get_Task_Body_Procedure -- 9563 ----------------------------- 9564 9565 function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is 9566 begin 9567 -- Note: A task type may be the completion of a private type with 9568 -- discriminants. When performing elaboration checks on a task 9569 -- declaration, the current view of the type may be the private one, 9570 -- and the procedure that holds the body of the task is held in its 9571 -- underlying type. 9572 9573 -- This is an odd function, why not have Task_Body_Procedure do 9574 -- the following digging??? 9575 9576 return Task_Body_Procedure (Underlying_Type (Root_Type (E))); 9577 end Get_Task_Body_Procedure; 9578 9579 ------------------------- 9580 -- Get_User_Defined_Eq -- 9581 ------------------------- 9582 9583 function Get_User_Defined_Eq (E : Entity_Id) return Entity_Id is 9584 Prim : Elmt_Id; 9585 Op : Entity_Id; 9586 9587 begin 9588 Prim := First_Elmt (Collect_Primitive_Operations (E)); 9589 while Present (Prim) loop 9590 Op := Node (Prim); 9591 9592 if Chars (Op) = Name_Op_Eq 9593 and then Etype (Op) = Standard_Boolean 9594 and then Etype (First_Formal (Op)) = E 9595 and then Etype (Next_Formal (First_Formal (Op))) = E 9596 then 9597 return Op; 9598 end if; 9599 9600 Next_Elmt (Prim); 9601 end loop; 9602 9603 return Empty; 9604 end Get_User_Defined_Eq; 9605 9606 --------------- 9607 -- Get_Views -- 9608 --------------- 9609 9610 procedure Get_Views 9611 (Typ : Entity_Id; 9612 Priv_Typ : out Entity_Id; 9613 Full_Typ : out Entity_Id; 9614 Full_Base : out Entity_Id; 9615 CRec_Typ : out Entity_Id) 9616 is 9617 IP_View : Entity_Id; 9618 9619 begin 9620 -- Assume that none of the views can be recovered 9621 9622 Priv_Typ := Empty; 9623 Full_Typ := Empty; 9624 Full_Base := Empty; 9625 CRec_Typ := Empty; 9626 9627 -- The input type is the corresponding record type of a protected or a 9628 -- task type. 9629 9630 if Ekind (Typ) = E_Record_Type 9631 and then Is_Concurrent_Record_Type (Typ) 9632 then 9633 CRec_Typ := Typ; 9634 Full_Typ := Corresponding_Concurrent_Type (CRec_Typ); 9635 Full_Base := Base_Type (Full_Typ); 9636 Priv_Typ := Incomplete_Or_Partial_View (Full_Typ); 9637 9638 -- Otherwise the input type denotes an arbitrary type 9639 9640 else 9641 IP_View := Incomplete_Or_Partial_View (Typ); 9642 9643 -- The input type denotes the full view of a private type 9644 9645 if Present (IP_View) then 9646 Priv_Typ := IP_View; 9647 Full_Typ := Typ; 9648 9649 -- The input type is a private type 9650 9651 elsif Is_Private_Type (Typ) then 9652 Priv_Typ := Typ; 9653 Full_Typ := Full_View (Priv_Typ); 9654 9655 -- Otherwise the input type does not have any views 9656 9657 else 9658 Full_Typ := Typ; 9659 end if; 9660 9661 if Present (Full_Typ) then 9662 Full_Base := Base_Type (Full_Typ); 9663 9664 if Ekind_In (Full_Typ, E_Protected_Type, E_Task_Type) then 9665 CRec_Typ := Corresponding_Record_Type (Full_Typ); 9666 end if; 9667 end if; 9668 end if; 9669 end Get_Views; 9670 9671 ----------------------- 9672 -- Has_Access_Values -- 9673 ----------------------- 9674 9675 function Has_Access_Values (T : Entity_Id) return Boolean is 9676 Typ : constant Entity_Id := Underlying_Type (T); 9677 9678 begin 9679 -- Case of a private type which is not completed yet. This can only 9680 -- happen in the case of a generic format type appearing directly, or 9681 -- as a component of the type to which this function is being applied 9682 -- at the top level. Return False in this case, since we certainly do 9683 -- not know that the type contains access types. 9684 9685 if No (Typ) then 9686 return False; 9687 9688 elsif Is_Access_Type (Typ) then 9689 return True; 9690 9691 elsif Is_Array_Type (Typ) then 9692 return Has_Access_Values (Component_Type (Typ)); 9693 9694 elsif Is_Record_Type (Typ) then 9695 declare 9696 Comp : Entity_Id; 9697 9698 begin 9699 -- Loop to Check components 9700 9701 Comp := First_Component_Or_Discriminant (Typ); 9702 while Present (Comp) loop 9703 9704 -- Check for access component, tag field does not count, even 9705 -- though it is implemented internally using an access type. 9706 9707 if Has_Access_Values (Etype (Comp)) 9708 and then Chars (Comp) /= Name_uTag 9709 then 9710 return True; 9711 end if; 9712 9713 Next_Component_Or_Discriminant (Comp); 9714 end loop; 9715 end; 9716 9717 return False; 9718 9719 else 9720 return False; 9721 end if; 9722 end Has_Access_Values; 9723 9724 ------------------------------ 9725 -- Has_Compatible_Alignment -- 9726 ------------------------------ 9727 9728 function Has_Compatible_Alignment 9729 (Obj : Entity_Id; 9730 Expr : Node_Id; 9731 Layout_Done : Boolean) return Alignment_Result 9732 is 9733 function Has_Compatible_Alignment_Internal 9734 (Obj : Entity_Id; 9735 Expr : Node_Id; 9736 Layout_Done : Boolean; 9737 Default : Alignment_Result) return Alignment_Result; 9738 -- This is the internal recursive function that actually does the work. 9739 -- There is one additional parameter, which says what the result should 9740 -- be if no alignment information is found, and there is no definite 9741 -- indication of compatible alignments. At the outer level, this is set 9742 -- to Unknown, but for internal recursive calls in the case where types 9743 -- are known to be correct, it is set to Known_Compatible. 9744 9745 --------------------------------------- 9746 -- Has_Compatible_Alignment_Internal -- 9747 --------------------------------------- 9748 9749 function Has_Compatible_Alignment_Internal 9750 (Obj : Entity_Id; 9751 Expr : Node_Id; 9752 Layout_Done : Boolean; 9753 Default : Alignment_Result) return Alignment_Result 9754 is 9755 Result : Alignment_Result := Known_Compatible; 9756 -- Holds the current status of the result. Note that once a value of 9757 -- Known_Incompatible is set, it is sticky and does not get changed 9758 -- to Unknown (the value in Result only gets worse as we go along, 9759 -- never better). 9760 9761 Offs : Uint := No_Uint; 9762 -- Set to a factor of the offset from the base object when Expr is a 9763 -- selected or indexed component, based on Component_Bit_Offset and 9764 -- Component_Size respectively. A negative value is used to represent 9765 -- a value which is not known at compile time. 9766 9767 procedure Check_Prefix; 9768 -- Checks the prefix recursively in the case where the expression 9769 -- is an indexed or selected component. 9770 9771 procedure Set_Result (R : Alignment_Result); 9772 -- If R represents a worse outcome (unknown instead of known 9773 -- compatible, or known incompatible), then set Result to R. 9774 9775 ------------------ 9776 -- Check_Prefix -- 9777 ------------------ 9778 9779 procedure Check_Prefix is 9780 begin 9781 -- The subtlety here is that in doing a recursive call to check 9782 -- the prefix, we have to decide what to do in the case where we 9783 -- don't find any specific indication of an alignment problem. 9784 9785 -- At the outer level, we normally set Unknown as the result in 9786 -- this case, since we can only set Known_Compatible if we really 9787 -- know that the alignment value is OK, but for the recursive 9788 -- call, in the case where the types match, and we have not 9789 -- specified a peculiar alignment for the object, we are only 9790 -- concerned about suspicious rep clauses, the default case does 9791 -- not affect us, since the compiler will, in the absence of such 9792 -- rep clauses, ensure that the alignment is correct. 9793 9794 if Default = Known_Compatible 9795 or else 9796 (Etype (Obj) = Etype (Expr) 9797 and then (Unknown_Alignment (Obj) 9798 or else 9799 Alignment (Obj) = Alignment (Etype (Obj)))) 9800 then 9801 Set_Result 9802 (Has_Compatible_Alignment_Internal 9803 (Obj, Prefix (Expr), Layout_Done, Known_Compatible)); 9804 9805 -- In all other cases, we need a full check on the prefix 9806 9807 else 9808 Set_Result 9809 (Has_Compatible_Alignment_Internal 9810 (Obj, Prefix (Expr), Layout_Done, Unknown)); 9811 end if; 9812 end Check_Prefix; 9813 9814 ---------------- 9815 -- Set_Result -- 9816 ---------------- 9817 9818 procedure Set_Result (R : Alignment_Result) is 9819 begin 9820 if R > Result then 9821 Result := R; 9822 end if; 9823 end Set_Result; 9824 9825 -- Start of processing for Has_Compatible_Alignment_Internal 9826 9827 begin 9828 -- If Expr is a selected component, we must make sure there is no 9829 -- potentially troublesome component clause and that the record is 9830 -- not packed if the layout is not done. 9831 9832 if Nkind (Expr) = N_Selected_Component then 9833 9834 -- Packing generates unknown alignment if layout is not done 9835 9836 if Is_Packed (Etype (Prefix (Expr))) and then not Layout_Done then 9837 Set_Result (Unknown); 9838 end if; 9839 9840 -- Check prefix and component offset 9841 9842 Check_Prefix; 9843 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr))); 9844 9845 -- If Expr is an indexed component, we must make sure there is no 9846 -- potentially troublesome Component_Size clause and that the array 9847 -- is not bit-packed if the layout is not done. 9848 9849 elsif Nkind (Expr) = N_Indexed_Component then 9850 declare 9851 Typ : constant Entity_Id := Etype (Prefix (Expr)); 9852 9853 begin 9854 -- Packing generates unknown alignment if layout is not done 9855 9856 if Is_Bit_Packed_Array (Typ) and then not Layout_Done then 9857 Set_Result (Unknown); 9858 end if; 9859 9860 -- Check prefix and component offset (or at least size) 9861 9862 Check_Prefix; 9863 Offs := Indexed_Component_Bit_Offset (Expr); 9864 if Offs = No_Uint then 9865 Offs := Component_Size (Typ); 9866 end if; 9867 end; 9868 end if; 9869 9870 -- If we have a null offset, the result is entirely determined by 9871 -- the base object and has already been computed recursively. 9872 9873 if Offs = Uint_0 then 9874 null; 9875 9876 -- Case where we know the alignment of the object 9877 9878 elsif Known_Alignment (Obj) then 9879 declare 9880 ObjA : constant Uint := Alignment (Obj); 9881 ExpA : Uint := No_Uint; 9882 SizA : Uint := No_Uint; 9883 9884 begin 9885 -- If alignment of Obj is 1, then we are always OK 9886 9887 if ObjA = 1 then 9888 Set_Result (Known_Compatible); 9889 9890 -- Alignment of Obj is greater than 1, so we need to check 9891 9892 else 9893 -- If we have an offset, see if it is compatible 9894 9895 if Offs /= No_Uint and Offs > Uint_0 then 9896 if Offs mod (System_Storage_Unit * ObjA) /= 0 then 9897 Set_Result (Known_Incompatible); 9898 end if; 9899 9900 -- See if Expr is an object with known alignment 9901 9902 elsif Is_Entity_Name (Expr) 9903 and then Known_Alignment (Entity (Expr)) 9904 then 9905 ExpA := Alignment (Entity (Expr)); 9906 9907 -- Otherwise, we can use the alignment of the type of 9908 -- Expr given that we already checked for 9909 -- discombobulating rep clauses for the cases of indexed 9910 -- and selected components above. 9911 9912 elsif Known_Alignment (Etype (Expr)) then 9913 ExpA := Alignment (Etype (Expr)); 9914 9915 -- Otherwise the alignment is unknown 9916 9917 else 9918 Set_Result (Default); 9919 end if; 9920 9921 -- If we got an alignment, see if it is acceptable 9922 9923 if ExpA /= No_Uint and then ExpA < ObjA then 9924 Set_Result (Known_Incompatible); 9925 end if; 9926 9927 -- If Expr is not a piece of a larger object, see if size 9928 -- is given. If so, check that it is not too small for the 9929 -- required alignment. 9930 9931 if Offs /= No_Uint then 9932 null; 9933 9934 -- See if Expr is an object with known size 9935 9936 elsif Is_Entity_Name (Expr) 9937 and then Known_Static_Esize (Entity (Expr)) 9938 then 9939 SizA := Esize (Entity (Expr)); 9940 9941 -- Otherwise, we check the object size of the Expr type 9942 9943 elsif Known_Static_Esize (Etype (Expr)) then 9944 SizA := Esize (Etype (Expr)); 9945 end if; 9946 9947 -- If we got a size, see if it is a multiple of the Obj 9948 -- alignment, if not, then the alignment cannot be 9949 -- acceptable, since the size is always a multiple of the 9950 -- alignment. 9951 9952 if SizA /= No_Uint then 9953 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then 9954 Set_Result (Known_Incompatible); 9955 end if; 9956 end if; 9957 end if; 9958 end; 9959 9960 -- If we do not know required alignment, any non-zero offset is a 9961 -- potential problem (but certainly may be OK, so result is unknown). 9962 9963 elsif Offs /= No_Uint then 9964 Set_Result (Unknown); 9965 9966 -- If we can't find the result by direct comparison of alignment 9967 -- values, then there is still one case that we can determine known 9968 -- result, and that is when we can determine that the types are the 9969 -- same, and no alignments are specified. Then we known that the 9970 -- alignments are compatible, even if we don't know the alignment 9971 -- value in the front end. 9972 9973 elsif Etype (Obj) = Etype (Expr) then 9974 9975 -- Types are the same, but we have to check for possible size 9976 -- and alignments on the Expr object that may make the alignment 9977 -- different, even though the types are the same. 9978 9979 if Is_Entity_Name (Expr) then 9980 9981 -- First check alignment of the Expr object. Any alignment less 9982 -- than Maximum_Alignment is worrisome since this is the case 9983 -- where we do not know the alignment of Obj. 9984 9985 if Known_Alignment (Entity (Expr)) 9986 and then UI_To_Int (Alignment (Entity (Expr))) < 9987 Ttypes.Maximum_Alignment 9988 then 9989 Set_Result (Unknown); 9990 9991 -- Now check size of Expr object. Any size that is not an 9992 -- even multiple of Maximum_Alignment is also worrisome 9993 -- since it may cause the alignment of the object to be less 9994 -- than the alignment of the type. 9995 9996 elsif Known_Static_Esize (Entity (Expr)) 9997 and then 9998 (UI_To_Int (Esize (Entity (Expr))) mod 9999 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)) 10000 /= 0 10001 then 10002 Set_Result (Unknown); 10003 10004 -- Otherwise same type is decisive 10005 10006 else 10007 Set_Result (Known_Compatible); 10008 end if; 10009 end if; 10010 10011 -- Another case to deal with is when there is an explicit size or 10012 -- alignment clause when the types are not the same. If so, then the 10013 -- result is Unknown. We don't need to do this test if the Default is 10014 -- Unknown, since that result will be set in any case. 10015 10016 elsif Default /= Unknown 10017 and then (Has_Size_Clause (Etype (Expr)) 10018 or else 10019 Has_Alignment_Clause (Etype (Expr))) 10020 then 10021 Set_Result (Unknown); 10022 10023 -- If no indication found, set default 10024 10025 else 10026 Set_Result (Default); 10027 end if; 10028 10029 -- Return worst result found 10030 10031 return Result; 10032 end Has_Compatible_Alignment_Internal; 10033 10034 -- Start of processing for Has_Compatible_Alignment 10035 10036 begin 10037 -- If Obj has no specified alignment, then set alignment from the type 10038 -- alignment. Perhaps we should always do this, but for sure we should 10039 -- do it when there is an address clause since we can do more if the 10040 -- alignment is known. 10041 10042 if Unknown_Alignment (Obj) then 10043 Set_Alignment (Obj, Alignment (Etype (Obj))); 10044 end if; 10045 10046 -- Now do the internal call that does all the work 10047 10048 return 10049 Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown); 10050 end Has_Compatible_Alignment; 10051 10052 ---------------------- 10053 -- Has_Declarations -- 10054 ---------------------- 10055 10056 function Has_Declarations (N : Node_Id) return Boolean is 10057 begin 10058 return Nkind_In (Nkind (N), N_Accept_Statement, 10059 N_Block_Statement, 10060 N_Compilation_Unit_Aux, 10061 N_Entry_Body, 10062 N_Package_Body, 10063 N_Protected_Body, 10064 N_Subprogram_Body, 10065 N_Task_Body, 10066 N_Package_Specification); 10067 end Has_Declarations; 10068 10069 --------------------------------- 10070 -- Has_Defaulted_Discriminants -- 10071 --------------------------------- 10072 10073 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is 10074 begin 10075 return Has_Discriminants (Typ) 10076 and then Present (First_Discriminant (Typ)) 10077 and then Present (Discriminant_Default_Value 10078 (First_Discriminant (Typ))); 10079 end Has_Defaulted_Discriminants; 10080 10081 ------------------- 10082 -- Has_Denormals -- 10083 ------------------- 10084 10085 function Has_Denormals (E : Entity_Id) return Boolean is 10086 begin 10087 return Is_Floating_Point_Type (E) and then Denorm_On_Target; 10088 end Has_Denormals; 10089 10090 ------------------------------------------- 10091 -- Has_Discriminant_Dependent_Constraint -- 10092 ------------------------------------------- 10093 10094 function Has_Discriminant_Dependent_Constraint 10095 (Comp : Entity_Id) return Boolean 10096 is 10097 Comp_Decl : constant Node_Id := Parent (Comp); 10098 Subt_Indic : Node_Id; 10099 Constr : Node_Id; 10100 Assn : Node_Id; 10101 10102 begin 10103 -- Discriminants can't depend on discriminants 10104 10105 if Ekind (Comp) = E_Discriminant then 10106 return False; 10107 10108 else 10109 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl)); 10110 10111 if Nkind (Subt_Indic) = N_Subtype_Indication then 10112 Constr := Constraint (Subt_Indic); 10113 10114 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then 10115 Assn := First (Constraints (Constr)); 10116 while Present (Assn) loop 10117 case Nkind (Assn) is 10118 when N_Identifier 10119 | N_Range 10120 | N_Subtype_Indication 10121 => 10122 if Depends_On_Discriminant (Assn) then 10123 return True; 10124 end if; 10125 10126 when N_Discriminant_Association => 10127 if Depends_On_Discriminant (Expression (Assn)) then 10128 return True; 10129 end if; 10130 10131 when others => 10132 null; 10133 end case; 10134 10135 Next (Assn); 10136 end loop; 10137 end if; 10138 end if; 10139 end if; 10140 10141 return False; 10142 end Has_Discriminant_Dependent_Constraint; 10143 10144 -------------------------------------- 10145 -- Has_Effectively_Volatile_Profile -- 10146 -------------------------------------- 10147 10148 function Has_Effectively_Volatile_Profile 10149 (Subp_Id : Entity_Id) return Boolean 10150 is 10151 Formal : Entity_Id; 10152 10153 begin 10154 -- Inspect the formal parameters looking for an effectively volatile 10155 -- type. 10156 10157 Formal := First_Formal (Subp_Id); 10158 while Present (Formal) loop 10159 if Is_Effectively_Volatile (Etype (Formal)) then 10160 return True; 10161 end if; 10162 10163 Next_Formal (Formal); 10164 end loop; 10165 10166 -- Inspect the return type of functions 10167 10168 if Ekind_In (Subp_Id, E_Function, E_Generic_Function) 10169 and then Is_Effectively_Volatile (Etype (Subp_Id)) 10170 then 10171 return True; 10172 end if; 10173 10174 return False; 10175 end Has_Effectively_Volatile_Profile; 10176 10177 -------------------------- 10178 -- Has_Enabled_Property -- 10179 -------------------------- 10180 10181 function Has_Enabled_Property 10182 (Item_Id : Entity_Id; 10183 Property : Name_Id) return Boolean 10184 is 10185 function Protected_Object_Has_Enabled_Property return Boolean; 10186 -- Determine whether a protected object denoted by Item_Id has the 10187 -- property enabled. 10188 10189 function State_Has_Enabled_Property return Boolean; 10190 -- Determine whether a state denoted by Item_Id has the property enabled 10191 10192 function Variable_Has_Enabled_Property return Boolean; 10193 -- Determine whether a variable denoted by Item_Id has the property 10194 -- enabled. 10195 10196 ------------------------------------------- 10197 -- Protected_Object_Has_Enabled_Property -- 10198 ------------------------------------------- 10199 10200 function Protected_Object_Has_Enabled_Property return Boolean is 10201 Constits : constant Elist_Id := Part_Of_Constituents (Item_Id); 10202 Constit_Elmt : Elmt_Id; 10203 Constit_Id : Entity_Id; 10204 10205 begin 10206 -- Protected objects always have the properties Async_Readers and 10207 -- Async_Writers (SPARK RM 7.1.2(16)). 10208 10209 if Property = Name_Async_Readers 10210 or else Property = Name_Async_Writers 10211 then 10212 return True; 10213 10214 -- Protected objects that have Part_Of components also inherit their 10215 -- properties Effective_Reads and Effective_Writes 10216 -- (SPARK RM 7.1.2(16)). 10217 10218 elsif Present (Constits) then 10219 Constit_Elmt := First_Elmt (Constits); 10220 while Present (Constit_Elmt) loop 10221 Constit_Id := Node (Constit_Elmt); 10222 10223 if Has_Enabled_Property (Constit_Id, Property) then 10224 return True; 10225 end if; 10226 10227 Next_Elmt (Constit_Elmt); 10228 end loop; 10229 end if; 10230 10231 return False; 10232 end Protected_Object_Has_Enabled_Property; 10233 10234 -------------------------------- 10235 -- State_Has_Enabled_Property -- 10236 -------------------------------- 10237 10238 function State_Has_Enabled_Property return Boolean is 10239 Decl : constant Node_Id := Parent (Item_Id); 10240 Opt : Node_Id; 10241 Opt_Nam : Node_Id; 10242 Prop : Node_Id; 10243 Prop_Nam : Node_Id; 10244 Props : Node_Id; 10245 10246 begin 10247 -- The declaration of an external abstract state appears as an 10248 -- extension aggregate. If this is not the case, properties can never 10249 -- be set. 10250 10251 if Nkind (Decl) /= N_Extension_Aggregate then 10252 return False; 10253 end if; 10254 10255 -- When External appears as a simple option, it automatically enables 10256 -- all properties. 10257 10258 Opt := First (Expressions (Decl)); 10259 while Present (Opt) loop 10260 if Nkind (Opt) = N_Identifier 10261 and then Chars (Opt) = Name_External 10262 then 10263 return True; 10264 end if; 10265 10266 Next (Opt); 10267 end loop; 10268 10269 -- When External specifies particular properties, inspect those and 10270 -- find the desired one (if any). 10271 10272 Opt := First (Component_Associations (Decl)); 10273 while Present (Opt) loop 10274 Opt_Nam := First (Choices (Opt)); 10275 10276 if Nkind (Opt_Nam) = N_Identifier 10277 and then Chars (Opt_Nam) = Name_External 10278 then 10279 Props := Expression (Opt); 10280 10281 -- Multiple properties appear as an aggregate 10282 10283 if Nkind (Props) = N_Aggregate then 10284 10285 -- Simple property form 10286 10287 Prop := First (Expressions (Props)); 10288 while Present (Prop) loop 10289 if Chars (Prop) = Property then 10290 return True; 10291 end if; 10292 10293 Next (Prop); 10294 end loop; 10295 10296 -- Property with expression form 10297 10298 Prop := First (Component_Associations (Props)); 10299 while Present (Prop) loop 10300 Prop_Nam := First (Choices (Prop)); 10301 10302 -- The property can be represented in two ways: 10303 -- others => <value> 10304 -- <property> => <value> 10305 10306 if Nkind (Prop_Nam) = N_Others_Choice 10307 or else (Nkind (Prop_Nam) = N_Identifier 10308 and then Chars (Prop_Nam) = Property) 10309 then 10310 return Is_True (Expr_Value (Expression (Prop))); 10311 end if; 10312 10313 Next (Prop); 10314 end loop; 10315 10316 -- Single property 10317 10318 else 10319 return Chars (Props) = Property; 10320 end if; 10321 end if; 10322 10323 Next (Opt); 10324 end loop; 10325 10326 return False; 10327 end State_Has_Enabled_Property; 10328 10329 ----------------------------------- 10330 -- Variable_Has_Enabled_Property -- 10331 ----------------------------------- 10332 10333 function Variable_Has_Enabled_Property return Boolean is 10334 function Is_Enabled (Prag : Node_Id) return Boolean; 10335 -- Determine whether property pragma Prag (if present) denotes an 10336 -- enabled property. 10337 10338 ---------------- 10339 -- Is_Enabled -- 10340 ---------------- 10341 10342 function Is_Enabled (Prag : Node_Id) return Boolean is 10343 Arg1 : Node_Id; 10344 10345 begin 10346 if Present (Prag) then 10347 Arg1 := First (Pragma_Argument_Associations (Prag)); 10348 10349 -- The pragma has an optional Boolean expression, the related 10350 -- property is enabled only when the expression evaluates to 10351 -- True. 10352 10353 if Present (Arg1) then 10354 return Is_True (Expr_Value (Get_Pragma_Arg (Arg1))); 10355 10356 -- Otherwise the lack of expression enables the property by 10357 -- default. 10358 10359 else 10360 return True; 10361 end if; 10362 10363 -- The property was never set in the first place 10364 10365 else 10366 return False; 10367 end if; 10368 end Is_Enabled; 10369 10370 -- Local variables 10371 10372 AR : constant Node_Id := 10373 Get_Pragma (Item_Id, Pragma_Async_Readers); 10374 AW : constant Node_Id := 10375 Get_Pragma (Item_Id, Pragma_Async_Writers); 10376 ER : constant Node_Id := 10377 Get_Pragma (Item_Id, Pragma_Effective_Reads); 10378 EW : constant Node_Id := 10379 Get_Pragma (Item_Id, Pragma_Effective_Writes); 10380 10381 -- Start of processing for Variable_Has_Enabled_Property 10382 10383 begin 10384 -- A non-effectively volatile object can never possess external 10385 -- properties. 10386 10387 if not Is_Effectively_Volatile (Item_Id) then 10388 return False; 10389 10390 -- External properties related to variables come in two flavors - 10391 -- explicit and implicit. The explicit case is characterized by the 10392 -- presence of a property pragma with an optional Boolean flag. The 10393 -- property is enabled when the flag evaluates to True or the flag is 10394 -- missing altogether. 10395 10396 elsif Property = Name_Async_Readers and then Is_Enabled (AR) then 10397 return True; 10398 10399 elsif Property = Name_Async_Writers and then Is_Enabled (AW) then 10400 return True; 10401 10402 elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then 10403 return True; 10404 10405 elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then 10406 return True; 10407 10408 -- The implicit case lacks all property pragmas 10409 10410 elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then 10411 if Is_Protected_Type (Etype (Item_Id)) then 10412 return Protected_Object_Has_Enabled_Property; 10413 else 10414 return True; 10415 end if; 10416 10417 else 10418 return False; 10419 end if; 10420 end Variable_Has_Enabled_Property; 10421 10422 -- Start of processing for Has_Enabled_Property 10423 10424 begin 10425 -- Abstract states and variables have a flexible scheme of specifying 10426 -- external properties. 10427 10428 if Ekind (Item_Id) = E_Abstract_State then 10429 return State_Has_Enabled_Property; 10430 10431 elsif Ekind (Item_Id) = E_Variable then 10432 return Variable_Has_Enabled_Property; 10433 10434 -- By default, protected objects only have the properties Async_Readers 10435 -- and Async_Writers. If they have Part_Of components, they also inherit 10436 -- their properties Effective_Reads and Effective_Writes 10437 -- (SPARK RM 7.1.2(16)). 10438 10439 elsif Ekind (Item_Id) = E_Protected_Object then 10440 return Protected_Object_Has_Enabled_Property; 10441 10442 -- Otherwise a property is enabled when the related item is effectively 10443 -- volatile. 10444 10445 else 10446 return Is_Effectively_Volatile (Item_Id); 10447 end if; 10448 end Has_Enabled_Property; 10449 10450 ------------------------------------- 10451 -- Has_Full_Default_Initialization -- 10452 ------------------------------------- 10453 10454 function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is 10455 Comp : Entity_Id; 10456 10457 begin 10458 -- A type subject to pragma Default_Initial_Condition may be fully 10459 -- default initialized depending on inheritance and the argument of 10460 -- the pragma. Since any type may act as the full view of a private 10461 -- type, this check must be performed prior to the specialized tests 10462 -- below. 10463 10464 if Has_Fully_Default_Initializing_DIC_Pragma (Typ) then 10465 return True; 10466 end if; 10467 10468 -- A scalar type is fully default initialized if it is subject to aspect 10469 -- Default_Value. 10470 10471 if Is_Scalar_Type (Typ) then 10472 return Has_Default_Aspect (Typ); 10473 10474 -- An array type is fully default initialized if its element type is 10475 -- scalar and the array type carries aspect Default_Component_Value or 10476 -- the element type is fully default initialized. 10477 10478 elsif Is_Array_Type (Typ) then 10479 return 10480 Has_Default_Aspect (Typ) 10481 or else Has_Full_Default_Initialization (Component_Type (Typ)); 10482 10483 -- A protected type, record type, or type extension is fully default 10484 -- initialized if all its components either carry an initialization 10485 -- expression or have a type that is fully default initialized. The 10486 -- parent type of a type extension must be fully default initialized. 10487 10488 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then 10489 10490 -- Inspect all entities defined in the scope of the type, looking for 10491 -- uninitialized components. 10492 10493 Comp := First_Entity (Typ); 10494 while Present (Comp) loop 10495 if Ekind (Comp) = E_Component 10496 and then Comes_From_Source (Comp) 10497 and then No (Expression (Parent (Comp))) 10498 and then not Has_Full_Default_Initialization (Etype (Comp)) 10499 then 10500 return False; 10501 end if; 10502 10503 Next_Entity (Comp); 10504 end loop; 10505 10506 -- Ensure that the parent type of a type extension is fully default 10507 -- initialized. 10508 10509 if Etype (Typ) /= Typ 10510 and then not Has_Full_Default_Initialization (Etype (Typ)) 10511 then 10512 return False; 10513 end if; 10514 10515 -- If we get here, then all components and parent portion are fully 10516 -- default initialized. 10517 10518 return True; 10519 10520 -- A task type is fully default initialized by default 10521 10522 elsif Is_Task_Type (Typ) then 10523 return True; 10524 10525 -- Otherwise the type is not fully default initialized 10526 10527 else 10528 return False; 10529 end if; 10530 end Has_Full_Default_Initialization; 10531 10532 ----------------------------------------------- 10533 -- Has_Fully_Default_Initializing_DIC_Pragma -- 10534 ----------------------------------------------- 10535 10536 function Has_Fully_Default_Initializing_DIC_Pragma 10537 (Typ : Entity_Id) return Boolean 10538 is 10539 Args : List_Id; 10540 Prag : Node_Id; 10541 10542 begin 10543 -- A type that inherits pragma Default_Initial_Condition from a parent 10544 -- type is automatically fully default initialized. 10545 10546 if Has_Inherited_DIC (Typ) then 10547 return True; 10548 10549 -- Otherwise the type is fully default initialized only when the pragma 10550 -- appears without an argument, or the argument is non-null. 10551 10552 elsif Has_Own_DIC (Typ) then 10553 Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition); 10554 pragma Assert (Present (Prag)); 10555 Args := Pragma_Argument_Associations (Prag); 10556 10557 -- The pragma appears without an argument in which case it defaults 10558 -- to True. 10559 10560 if No (Args) then 10561 return True; 10562 10563 -- The pragma appears with a non-null expression 10564 10565 elsif Nkind (Get_Pragma_Arg (First (Args))) /= N_Null then 10566 return True; 10567 end if; 10568 end if; 10569 10570 return False; 10571 end Has_Fully_Default_Initializing_DIC_Pragma; 10572 10573 -------------------- 10574 -- Has_Infinities -- 10575 -------------------- 10576 10577 function Has_Infinities (E : Entity_Id) return Boolean is 10578 begin 10579 return 10580 Is_Floating_Point_Type (E) 10581 and then Nkind (Scalar_Range (E)) = N_Range 10582 and then Includes_Infinities (Scalar_Range (E)); 10583 end Has_Infinities; 10584 10585 -------------------- 10586 -- Has_Interfaces -- 10587 -------------------- 10588 10589 function Has_Interfaces 10590 (T : Entity_Id; 10591 Use_Full_View : Boolean := True) return Boolean 10592 is 10593 Typ : Entity_Id := Base_Type (T); 10594 10595 begin 10596 -- Handle concurrent types 10597 10598 if Is_Concurrent_Type (Typ) then 10599 Typ := Corresponding_Record_Type (Typ); 10600 end if; 10601 10602 if not Present (Typ) 10603 or else not Is_Record_Type (Typ) 10604 or else not Is_Tagged_Type (Typ) 10605 then 10606 return False; 10607 end if; 10608 10609 -- Handle private types 10610 10611 if Use_Full_View and then Present (Full_View (Typ)) then 10612 Typ := Full_View (Typ); 10613 end if; 10614 10615 -- Handle concurrent record types 10616 10617 if Is_Concurrent_Record_Type (Typ) 10618 and then Is_Non_Empty_List (Abstract_Interface_List (Typ)) 10619 then 10620 return True; 10621 end if; 10622 10623 loop 10624 if Is_Interface (Typ) 10625 or else 10626 (Is_Record_Type (Typ) 10627 and then Present (Interfaces (Typ)) 10628 and then not Is_Empty_Elmt_List (Interfaces (Typ))) 10629 then 10630 return True; 10631 end if; 10632 10633 exit when Etype (Typ) = Typ 10634 10635 -- Handle private types 10636 10637 or else (Present (Full_View (Etype (Typ))) 10638 and then Full_View (Etype (Typ)) = Typ) 10639 10640 -- Protect frontend against wrong sources with cyclic derivations 10641 10642 or else Etype (Typ) = T; 10643 10644 -- Climb to the ancestor type handling private types 10645 10646 if Present (Full_View (Etype (Typ))) then 10647 Typ := Full_View (Etype (Typ)); 10648 else 10649 Typ := Etype (Typ); 10650 end if; 10651 end loop; 10652 10653 return False; 10654 end Has_Interfaces; 10655 10656 -------------------------- 10657 -- Has_Max_Queue_Length -- 10658 -------------------------- 10659 10660 function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is 10661 begin 10662 return 10663 Ekind (Id) = E_Entry 10664 and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length)); 10665 end Has_Max_Queue_Length; 10666 10667 --------------------------------- 10668 -- Has_No_Obvious_Side_Effects -- 10669 --------------------------------- 10670 10671 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is 10672 begin 10673 -- For now handle literals, constants, and non-volatile variables and 10674 -- expressions combining these with operators or short circuit forms. 10675 10676 if Nkind (N) in N_Numeric_Or_String_Literal then 10677 return True; 10678 10679 elsif Nkind (N) = N_Character_Literal then 10680 return True; 10681 10682 elsif Nkind (N) in N_Unary_Op then 10683 return Has_No_Obvious_Side_Effects (Right_Opnd (N)); 10684 10685 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then 10686 return Has_No_Obvious_Side_Effects (Left_Opnd (N)) 10687 and then 10688 Has_No_Obvious_Side_Effects (Right_Opnd (N)); 10689 10690 elsif Nkind (N) = N_Expression_With_Actions 10691 and then Is_Empty_List (Actions (N)) 10692 then 10693 return Has_No_Obvious_Side_Effects (Expression (N)); 10694 10695 elsif Nkind (N) in N_Has_Entity then 10696 return Present (Entity (N)) 10697 and then Ekind_In (Entity (N), E_Variable, 10698 E_Constant, 10699 E_Enumeration_Literal, 10700 E_In_Parameter, 10701 E_Out_Parameter, 10702 E_In_Out_Parameter) 10703 and then not Is_Volatile (Entity (N)); 10704 10705 else 10706 return False; 10707 end if; 10708 end Has_No_Obvious_Side_Effects; 10709 10710 ----------------------------- 10711 -- Has_Non_Null_Refinement -- 10712 ----------------------------- 10713 10714 function Has_Non_Null_Refinement (Id : Entity_Id) return Boolean is 10715 Constits : Elist_Id; 10716 10717 begin 10718 pragma Assert (Ekind (Id) = E_Abstract_State); 10719 Constits := Refinement_Constituents (Id); 10720 10721 -- For a refinement to be non-null, the first constituent must be 10722 -- anything other than null. 10723 10724 return 10725 Present (Constits) 10726 and then Nkind (Node (First_Elmt (Constits))) /= N_Null; 10727 end Has_Non_Null_Refinement; 10728 10729 ----------------------------- 10730 -- Has_Non_Null_Statements -- 10731 ----------------------------- 10732 10733 function Has_Non_Null_Statements (L : List_Id) return Boolean is 10734 Node : Node_Id; 10735 10736 begin 10737 if Is_Non_Empty_List (L) then 10738 Node := First (L); 10739 10740 loop 10741 if Nkind (Node) /= N_Null_Statement then 10742 return True; 10743 end if; 10744 10745 Next (Node); 10746 exit when Node = Empty; 10747 end loop; 10748 end if; 10749 10750 return False; 10751 end Has_Non_Null_Statements; 10752 10753 ---------------------------------- 10754 -- Has_Non_Trivial_Precondition -- 10755 ---------------------------------- 10756 10757 function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is 10758 Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre); 10759 10760 begin 10761 return 10762 Present (Pre) 10763 and then Class_Present (Pre) 10764 and then not Is_Entity_Name (Expression (Pre)); 10765 end Has_Non_Trivial_Precondition; 10766 10767 ------------------- 10768 -- Has_Null_Body -- 10769 ------------------- 10770 10771 function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is 10772 Body_Id : Entity_Id; 10773 Decl : Node_Id; 10774 Spec : Node_Id; 10775 Stmt1 : Node_Id; 10776 Stmt2 : Node_Id; 10777 10778 begin 10779 Spec := Parent (Proc_Id); 10780 Decl := Parent (Spec); 10781 10782 -- Retrieve the entity of the procedure body (e.g. invariant proc). 10783 10784 if Nkind (Spec) = N_Procedure_Specification 10785 and then Nkind (Decl) = N_Subprogram_Declaration 10786 then 10787 Body_Id := Corresponding_Body (Decl); 10788 10789 -- The body acts as a spec 10790 10791 else 10792 Body_Id := Proc_Id; 10793 end if; 10794 10795 -- The body will be generated later 10796 10797 if No (Body_Id) then 10798 return False; 10799 end if; 10800 10801 Spec := Parent (Body_Id); 10802 Decl := Parent (Spec); 10803 10804 pragma Assert 10805 (Nkind (Spec) = N_Procedure_Specification 10806 and then Nkind (Decl) = N_Subprogram_Body); 10807 10808 Stmt1 := First (Statements (Handled_Statement_Sequence (Decl))); 10809 10810 -- Look for a null statement followed by an optional return 10811 -- statement. 10812 10813 if Nkind (Stmt1) = N_Null_Statement then 10814 Stmt2 := Next (Stmt1); 10815 10816 if Present (Stmt2) then 10817 return Nkind (Stmt2) = N_Simple_Return_Statement; 10818 else 10819 return True; 10820 end if; 10821 end if; 10822 10823 return False; 10824 end Has_Null_Body; 10825 10826 ------------------------ 10827 -- Has_Null_Exclusion -- 10828 ------------------------ 10829 10830 function Has_Null_Exclusion (N : Node_Id) return Boolean is 10831 begin 10832 case Nkind (N) is 10833 when N_Access_Definition 10834 | N_Access_Function_Definition 10835 | N_Access_Procedure_Definition 10836 | N_Access_To_Object_Definition 10837 | N_Allocator 10838 | N_Derived_Type_Definition 10839 | N_Function_Specification 10840 | N_Subtype_Declaration 10841 => 10842 return Null_Exclusion_Present (N); 10843 10844 when N_Component_Definition 10845 | N_Formal_Object_Declaration 10846 | N_Object_Renaming_Declaration 10847 => 10848 if Present (Subtype_Mark (N)) then 10849 return Null_Exclusion_Present (N); 10850 else pragma Assert (Present (Access_Definition (N))); 10851 return Null_Exclusion_Present (Access_Definition (N)); 10852 end if; 10853 10854 when N_Discriminant_Specification => 10855 if Nkind (Discriminant_Type (N)) = N_Access_Definition then 10856 return Null_Exclusion_Present (Discriminant_Type (N)); 10857 else 10858 return Null_Exclusion_Present (N); 10859 end if; 10860 10861 when N_Object_Declaration => 10862 if Nkind (Object_Definition (N)) = N_Access_Definition then 10863 return Null_Exclusion_Present (Object_Definition (N)); 10864 else 10865 return Null_Exclusion_Present (N); 10866 end if; 10867 10868 when N_Parameter_Specification => 10869 if Nkind (Parameter_Type (N)) = N_Access_Definition then 10870 return Null_Exclusion_Present (Parameter_Type (N)); 10871 else 10872 return Null_Exclusion_Present (N); 10873 end if; 10874 10875 when others => 10876 return False; 10877 end case; 10878 end Has_Null_Exclusion; 10879 10880 ------------------------ 10881 -- Has_Null_Extension -- 10882 ------------------------ 10883 10884 function Has_Null_Extension (T : Entity_Id) return Boolean is 10885 B : constant Entity_Id := Base_Type (T); 10886 Comps : Node_Id; 10887 Ext : Node_Id; 10888 10889 begin 10890 if Nkind (Parent (B)) = N_Full_Type_Declaration 10891 and then Present (Record_Extension_Part (Type_Definition (Parent (B)))) 10892 then 10893 Ext := Record_Extension_Part (Type_Definition (Parent (B))); 10894 10895 if Present (Ext) then 10896 if Null_Present (Ext) then 10897 return True; 10898 else 10899 Comps := Component_List (Ext); 10900 10901 -- The null component list is rewritten during analysis to 10902 -- include the parent component. Any other component indicates 10903 -- that the extension was not originally null. 10904 10905 return Null_Present (Comps) 10906 or else No (Next (First (Component_Items (Comps)))); 10907 end if; 10908 else 10909 return False; 10910 end if; 10911 10912 else 10913 return False; 10914 end if; 10915 end Has_Null_Extension; 10916 10917 ------------------------- 10918 -- Has_Null_Refinement -- 10919 ------------------------- 10920 10921 function Has_Null_Refinement (Id : Entity_Id) return Boolean is 10922 Constits : Elist_Id; 10923 10924 begin 10925 pragma Assert (Ekind (Id) = E_Abstract_State); 10926 Constits := Refinement_Constituents (Id); 10927 10928 -- For a refinement to be null, the state's sole constituent must be a 10929 -- null. 10930 10931 return 10932 Present (Constits) 10933 and then Nkind (Node (First_Elmt (Constits))) = N_Null; 10934 end Has_Null_Refinement; 10935 10936 ------------------------------- 10937 -- Has_Overriding_Initialize -- 10938 ------------------------------- 10939 10940 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is 10941 BT : constant Entity_Id := Base_Type (T); 10942 P : Elmt_Id; 10943 10944 begin 10945 if Is_Controlled (BT) then 10946 if Is_RTU (Scope (BT), Ada_Finalization) then 10947 return False; 10948 10949 elsif Present (Primitive_Operations (BT)) then 10950 P := First_Elmt (Primitive_Operations (BT)); 10951 while Present (P) loop 10952 declare 10953 Init : constant Entity_Id := Node (P); 10954 Formal : constant Entity_Id := First_Formal (Init); 10955 begin 10956 if Ekind (Init) = E_Procedure 10957 and then Chars (Init) = Name_Initialize 10958 and then Comes_From_Source (Init) 10959 and then Present (Formal) 10960 and then Etype (Formal) = BT 10961 and then No (Next_Formal (Formal)) 10962 and then (Ada_Version < Ada_2012 10963 or else not Null_Present (Parent (Init))) 10964 then 10965 return True; 10966 end if; 10967 end; 10968 10969 Next_Elmt (P); 10970 end loop; 10971 end if; 10972 10973 -- Here if type itself does not have a non-null Initialize operation: 10974 -- check immediate ancestor. 10975 10976 if Is_Derived_Type (BT) 10977 and then Has_Overriding_Initialize (Etype (BT)) 10978 then 10979 return True; 10980 end if; 10981 end if; 10982 10983 return False; 10984 end Has_Overriding_Initialize; 10985 10986 -------------------------------------- 10987 -- Has_Preelaborable_Initialization -- 10988 -------------------------------------- 10989 10990 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is 10991 Has_PE : Boolean; 10992 10993 procedure Check_Components (E : Entity_Id); 10994 -- Check component/discriminant chain, sets Has_PE False if a component 10995 -- or discriminant does not meet the preelaborable initialization rules. 10996 10997 ---------------------- 10998 -- Check_Components -- 10999 ---------------------- 11000 11001 procedure Check_Components (E : Entity_Id) is 11002 Ent : Entity_Id; 11003 Exp : Node_Id; 11004 11005 begin 11006 -- Loop through entities of record or protected type 11007 11008 Ent := E; 11009 while Present (Ent) loop 11010 11011 -- We are interested only in components and discriminants 11012 11013 Exp := Empty; 11014 11015 case Ekind (Ent) is 11016 when E_Component => 11017 11018 -- Get default expression if any. If there is no declaration 11019 -- node, it means we have an internal entity. The parent and 11020 -- tag fields are examples of such entities. For such cases, 11021 -- we just test the type of the entity. 11022 11023 if Present (Declaration_Node (Ent)) then 11024 Exp := Expression (Declaration_Node (Ent)); 11025 end if; 11026 11027 when E_Discriminant => 11028 11029 -- Note: for a renamed discriminant, the Declaration_Node 11030 -- may point to the one from the ancestor, and have a 11031 -- different expression, so use the proper attribute to 11032 -- retrieve the expression from the derived constraint. 11033 11034 Exp := Discriminant_Default_Value (Ent); 11035 11036 when others => 11037 goto Check_Next_Entity; 11038 end case; 11039 11040 -- A component has PI if it has no default expression and the 11041 -- component type has PI. 11042 11043 if No (Exp) then 11044 if not Has_Preelaborable_Initialization (Etype (Ent)) then 11045 Has_PE := False; 11046 exit; 11047 end if; 11048 11049 -- Require the default expression to be preelaborable 11050 11051 elsif not Is_Preelaborable_Construct (Exp) then 11052 Has_PE := False; 11053 exit; 11054 end if; 11055 11056 <<Check_Next_Entity>> 11057 Next_Entity (Ent); 11058 end loop; 11059 end Check_Components; 11060 11061 -- Start of processing for Has_Preelaborable_Initialization 11062 11063 begin 11064 -- Immediate return if already marked as known preelaborable init. This 11065 -- covers types for which this function has already been called once 11066 -- and returned True (in which case the result is cached), and also 11067 -- types to which a pragma Preelaborable_Initialization applies. 11068 11069 if Known_To_Have_Preelab_Init (E) then 11070 return True; 11071 end if; 11072 11073 -- If the type is a subtype representing a generic actual type, then 11074 -- test whether its base type has preelaborable initialization since 11075 -- the subtype representing the actual does not inherit this attribute 11076 -- from the actual or formal. (but maybe it should???) 11077 11078 if Is_Generic_Actual_Type (E) then 11079 return Has_Preelaborable_Initialization (Base_Type (E)); 11080 end if; 11081 11082 -- All elementary types have preelaborable initialization 11083 11084 if Is_Elementary_Type (E) then 11085 Has_PE := True; 11086 11087 -- Array types have PI if the component type has PI 11088 11089 elsif Is_Array_Type (E) then 11090 Has_PE := Has_Preelaborable_Initialization (Component_Type (E)); 11091 11092 -- A derived type has preelaborable initialization if its parent type 11093 -- has preelaborable initialization and (in the case of a derived record 11094 -- extension) if the non-inherited components all have preelaborable 11095 -- initialization. However, a user-defined controlled type with an 11096 -- overriding Initialize procedure does not have preelaborable 11097 -- initialization. 11098 11099 elsif Is_Derived_Type (E) then 11100 11101 -- If the derived type is a private extension then it doesn't have 11102 -- preelaborable initialization. 11103 11104 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then 11105 return False; 11106 end if; 11107 11108 -- First check whether ancestor type has preelaborable initialization 11109 11110 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E))); 11111 11112 -- If OK, check extension components (if any) 11113 11114 if Has_PE and then Is_Record_Type (E) then 11115 Check_Components (First_Entity (E)); 11116 end if; 11117 11118 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type 11119 -- with a user defined Initialize procedure does not have PI. If 11120 -- the type is untagged, the control primitives come from a component 11121 -- that has already been checked. 11122 11123 if Has_PE 11124 and then Is_Controlled (E) 11125 and then Is_Tagged_Type (E) 11126 and then Has_Overriding_Initialize (E) 11127 then 11128 Has_PE := False; 11129 end if; 11130 11131 -- Private types not derived from a type having preelaborable init and 11132 -- that are not marked with pragma Preelaborable_Initialization do not 11133 -- have preelaborable initialization. 11134 11135 elsif Is_Private_Type (E) then 11136 return False; 11137 11138 -- Record type has PI if it is non private and all components have PI 11139 11140 elsif Is_Record_Type (E) then 11141 Has_PE := True; 11142 Check_Components (First_Entity (E)); 11143 11144 -- Protected types must not have entries, and components must meet 11145 -- same set of rules as for record components. 11146 11147 elsif Is_Protected_Type (E) then 11148 if Has_Entries (E) then 11149 Has_PE := False; 11150 else 11151 Has_PE := True; 11152 Check_Components (First_Entity (E)); 11153 Check_Components (First_Private_Entity (E)); 11154 end if; 11155 11156 -- Type System.Address always has preelaborable initialization 11157 11158 elsif Is_RTE (E, RE_Address) then 11159 Has_PE := True; 11160 11161 -- In all other cases, type does not have preelaborable initialization 11162 11163 else 11164 return False; 11165 end if; 11166 11167 -- If type has preelaborable initialization, cache result 11168 11169 if Has_PE then 11170 Set_Known_To_Have_Preelab_Init (E); 11171 end if; 11172 11173 return Has_PE; 11174 end Has_Preelaborable_Initialization; 11175 11176 --------------------------- 11177 -- Has_Private_Component -- 11178 --------------------------- 11179 11180 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is 11181 Btype : Entity_Id := Base_Type (Type_Id); 11182 Component : Entity_Id; 11183 11184 begin 11185 if Error_Posted (Type_Id) 11186 or else Error_Posted (Btype) 11187 then 11188 return False; 11189 end if; 11190 11191 if Is_Class_Wide_Type (Btype) then 11192 Btype := Root_Type (Btype); 11193 end if; 11194 11195 if Is_Private_Type (Btype) then 11196 declare 11197 UT : constant Entity_Id := Underlying_Type (Btype); 11198 begin 11199 if No (UT) then 11200 if No (Full_View (Btype)) then 11201 return not Is_Generic_Type (Btype) 11202 and then 11203 not Is_Generic_Type (Root_Type (Btype)); 11204 else 11205 return not Is_Generic_Type (Root_Type (Full_View (Btype))); 11206 end if; 11207 else 11208 return not Is_Frozen (UT) and then Has_Private_Component (UT); 11209 end if; 11210 end; 11211 11212 elsif Is_Array_Type (Btype) then 11213 return Has_Private_Component (Component_Type (Btype)); 11214 11215 elsif Is_Record_Type (Btype) then 11216 Component := First_Component (Btype); 11217 while Present (Component) loop 11218 if Has_Private_Component (Etype (Component)) then 11219 return True; 11220 end if; 11221 11222 Next_Component (Component); 11223 end loop; 11224 11225 return False; 11226 11227 elsif Is_Protected_Type (Btype) 11228 and then Present (Corresponding_Record_Type (Btype)) 11229 then 11230 return Has_Private_Component (Corresponding_Record_Type (Btype)); 11231 11232 else 11233 return False; 11234 end if; 11235 end Has_Private_Component; 11236 11237 ---------------------- 11238 -- Has_Signed_Zeros -- 11239 ---------------------- 11240 11241 function Has_Signed_Zeros (E : Entity_Id) return Boolean is 11242 begin 11243 return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target; 11244 end Has_Signed_Zeros; 11245 11246 ------------------------------ 11247 -- Has_Significant_Contract -- 11248 ------------------------------ 11249 11250 function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is 11251 Subp_Nam : constant Name_Id := Chars (Subp_Id); 11252 11253 begin 11254 -- _Finalizer procedure 11255 11256 if Subp_Nam = Name_uFinalizer then 11257 return False; 11258 11259 -- _Postconditions procedure 11260 11261 elsif Subp_Nam = Name_uPostconditions then 11262 return False; 11263 11264 -- Predicate function 11265 11266 elsif Ekind (Subp_Id) = E_Function 11267 and then Is_Predicate_Function (Subp_Id) 11268 then 11269 return False; 11270 11271 -- TSS subprogram 11272 11273 elsif Get_TSS_Name (Subp_Id) /= TSS_Null then 11274 return False; 11275 11276 else 11277 return True; 11278 end if; 11279 end Has_Significant_Contract; 11280 11281 ----------------------------- 11282 -- Has_Static_Array_Bounds -- 11283 ----------------------------- 11284 11285 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is 11286 Ndims : constant Nat := Number_Dimensions (Typ); 11287 11288 Index : Node_Id; 11289 Low : Node_Id; 11290 High : Node_Id; 11291 11292 begin 11293 -- Unconstrained types do not have static bounds 11294 11295 if not Is_Constrained (Typ) then 11296 return False; 11297 end if; 11298 11299 -- First treat string literals specially, as the lower bound and length 11300 -- of string literals are not stored like those of arrays. 11301 11302 -- A string literal always has static bounds 11303 11304 if Ekind (Typ) = E_String_Literal_Subtype then 11305 return True; 11306 end if; 11307 11308 -- Treat all dimensions in turn 11309 11310 Index := First_Index (Typ); 11311 for Indx in 1 .. Ndims loop 11312 11313 -- In case of an illegal index which is not a discrete type, return 11314 -- that the type is not static. 11315 11316 if not Is_Discrete_Type (Etype (Index)) 11317 or else Etype (Index) = Any_Type 11318 then 11319 return False; 11320 end if; 11321 11322 Get_Index_Bounds (Index, Low, High); 11323 11324 if Error_Posted (Low) or else Error_Posted (High) then 11325 return False; 11326 end if; 11327 11328 if Is_OK_Static_Expression (Low) 11329 and then 11330 Is_OK_Static_Expression (High) 11331 then 11332 null; 11333 else 11334 return False; 11335 end if; 11336 11337 Next (Index); 11338 end loop; 11339 11340 -- If we fall through the loop, all indexes matched 11341 11342 return True; 11343 end Has_Static_Array_Bounds; 11344 11345 ---------------- 11346 -- Has_Stream -- 11347 ---------------- 11348 11349 function Has_Stream (T : Entity_Id) return Boolean is 11350 E : Entity_Id; 11351 11352 begin 11353 if No (T) then 11354 return False; 11355 11356 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then 11357 return True; 11358 11359 elsif Is_Array_Type (T) then 11360 return Has_Stream (Component_Type (T)); 11361 11362 elsif Is_Record_Type (T) then 11363 E := First_Component (T); 11364 while Present (E) loop 11365 if Has_Stream (Etype (E)) then 11366 return True; 11367 else 11368 Next_Component (E); 11369 end if; 11370 end loop; 11371 11372 return False; 11373 11374 elsif Is_Private_Type (T) then 11375 return Has_Stream (Underlying_Type (T)); 11376 11377 else 11378 return False; 11379 end if; 11380 end Has_Stream; 11381 11382 ---------------- 11383 -- Has_Suffix -- 11384 ---------------- 11385 11386 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is 11387 begin 11388 Get_Name_String (Chars (E)); 11389 return Name_Buffer (Name_Len) = Suffix; 11390 end Has_Suffix; 11391 11392 ---------------- 11393 -- Add_Suffix -- 11394 ---------------- 11395 11396 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is 11397 begin 11398 Get_Name_String (Chars (E)); 11399 Add_Char_To_Name_Buffer (Suffix); 11400 return Name_Find; 11401 end Add_Suffix; 11402 11403 ------------------- 11404 -- Remove_Suffix -- 11405 ------------------- 11406 11407 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is 11408 begin 11409 pragma Assert (Has_Suffix (E, Suffix)); 11410 Get_Name_String (Chars (E)); 11411 Name_Len := Name_Len - 1; 11412 return Name_Find; 11413 end Remove_Suffix; 11414 11415 ---------------------------------- 11416 -- Replace_Null_By_Null_Address -- 11417 ---------------------------------- 11418 11419 procedure Replace_Null_By_Null_Address (N : Node_Id) is 11420 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id); 11421 -- Replace operand Op with a reference to Null_Address when the operand 11422 -- denotes a null Address. Other_Op denotes the other operand. 11423 11424 -------------------------- 11425 -- Replace_Null_Operand -- 11426 -------------------------- 11427 11428 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id) is 11429 begin 11430 -- Check the type of the complementary operand since the N_Null node 11431 -- has not been decorated yet. 11432 11433 if Nkind (Op) = N_Null 11434 and then Is_Descendant_Of_Address (Etype (Other_Op)) 11435 then 11436 Rewrite (Op, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (Op))); 11437 end if; 11438 end Replace_Null_Operand; 11439 11440 -- Start of processing for Replace_Null_By_Null_Address 11441 11442 begin 11443 pragma Assert (Relaxed_RM_Semantics); 11444 pragma Assert (Nkind_In (N, N_Null, 11445 N_Op_Eq, 11446 N_Op_Ge, 11447 N_Op_Gt, 11448 N_Op_Le, 11449 N_Op_Lt, 11450 N_Op_Ne)); 11451 11452 if Nkind (N) = N_Null then 11453 Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); 11454 11455 else 11456 declare 11457 L : constant Node_Id := Left_Opnd (N); 11458 R : constant Node_Id := Right_Opnd (N); 11459 11460 begin 11461 Replace_Null_Operand (L, Other_Op => R); 11462 Replace_Null_Operand (R, Other_Op => L); 11463 end; 11464 end if; 11465 end Replace_Null_By_Null_Address; 11466 11467 -------------------------- 11468 -- Has_Tagged_Component -- 11469 -------------------------- 11470 11471 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is 11472 Comp : Entity_Id; 11473 11474 begin 11475 if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then 11476 return Has_Tagged_Component (Underlying_Type (Typ)); 11477 11478 elsif Is_Array_Type (Typ) then 11479 return Has_Tagged_Component (Component_Type (Typ)); 11480 11481 elsif Is_Tagged_Type (Typ) then 11482 return True; 11483 11484 elsif Is_Record_Type (Typ) then 11485 Comp := First_Component (Typ); 11486 while Present (Comp) loop 11487 if Has_Tagged_Component (Etype (Comp)) then 11488 return True; 11489 end if; 11490 11491 Next_Component (Comp); 11492 end loop; 11493 11494 return False; 11495 11496 else 11497 return False; 11498 end if; 11499 end Has_Tagged_Component; 11500 11501 ----------------------------- 11502 -- Has_Undefined_Reference -- 11503 ----------------------------- 11504 11505 function Has_Undefined_Reference (Expr : Node_Id) return Boolean is 11506 Has_Undef_Ref : Boolean := False; 11507 -- Flag set when expression Expr contains at least one undefined 11508 -- reference. 11509 11510 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result; 11511 -- Determine whether N denotes a reference and if it does, whether it is 11512 -- undefined. 11513 11514 ---------------------------- 11515 -- Is_Undefined_Reference -- 11516 ---------------------------- 11517 11518 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result is 11519 begin 11520 if Is_Entity_Name (N) 11521 and then Present (Entity (N)) 11522 and then Entity (N) = Any_Id 11523 then 11524 Has_Undef_Ref := True; 11525 return Abandon; 11526 end if; 11527 11528 return OK; 11529 end Is_Undefined_Reference; 11530 11531 procedure Find_Undefined_References is 11532 new Traverse_Proc (Is_Undefined_Reference); 11533 11534 -- Start of processing for Has_Undefined_Reference 11535 11536 begin 11537 Find_Undefined_References (Expr); 11538 11539 return Has_Undef_Ref; 11540 end Has_Undefined_Reference; 11541 11542 ---------------------------- 11543 -- Has_Volatile_Component -- 11544 ---------------------------- 11545 11546 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is 11547 Comp : Entity_Id; 11548 11549 begin 11550 if Has_Volatile_Components (Typ) then 11551 return True; 11552 11553 elsif Is_Array_Type (Typ) then 11554 return Is_Volatile (Component_Type (Typ)); 11555 11556 elsif Is_Record_Type (Typ) then 11557 Comp := First_Component (Typ); 11558 while Present (Comp) loop 11559 if Is_Volatile_Object (Comp) then 11560 return True; 11561 end if; 11562 11563 Comp := Next_Component (Comp); 11564 end loop; 11565 end if; 11566 11567 return False; 11568 end Has_Volatile_Component; 11569 11570 ------------------------- 11571 -- Implementation_Kind -- 11572 ------------------------- 11573 11574 function Implementation_Kind (Subp : Entity_Id) return Name_Id is 11575 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented); 11576 Arg : Node_Id; 11577 begin 11578 pragma Assert (Present (Impl_Prag)); 11579 Arg := Last (Pragma_Argument_Associations (Impl_Prag)); 11580 return Chars (Get_Pragma_Arg (Arg)); 11581 end Implementation_Kind; 11582 11583 -------------------------- 11584 -- Implements_Interface -- 11585 -------------------------- 11586 11587 function Implements_Interface 11588 (Typ_Ent : Entity_Id; 11589 Iface_Ent : Entity_Id; 11590 Exclude_Parents : Boolean := False) return Boolean 11591 is 11592 Ifaces_List : Elist_Id; 11593 Elmt : Elmt_Id; 11594 Iface : Entity_Id := Base_Type (Iface_Ent); 11595 Typ : Entity_Id := Base_Type (Typ_Ent); 11596 11597 begin 11598 if Is_Class_Wide_Type (Typ) then 11599 Typ := Root_Type (Typ); 11600 end if; 11601 11602 if not Has_Interfaces (Typ) then 11603 return False; 11604 end if; 11605 11606 if Is_Class_Wide_Type (Iface) then 11607 Iface := Root_Type (Iface); 11608 end if; 11609 11610 Collect_Interfaces (Typ, Ifaces_List); 11611 11612 Elmt := First_Elmt (Ifaces_List); 11613 while Present (Elmt) loop 11614 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True) 11615 and then Exclude_Parents 11616 then 11617 null; 11618 11619 elsif Node (Elmt) = Iface then 11620 return True; 11621 end if; 11622 11623 Next_Elmt (Elmt); 11624 end loop; 11625 11626 return False; 11627 end Implements_Interface; 11628 11629 ------------------------------------ 11630 -- In_Assertion_Expression_Pragma -- 11631 ------------------------------------ 11632 11633 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is 11634 Par : Node_Id; 11635 Prag : Node_Id := Empty; 11636 11637 begin 11638 -- Climb the parent chain looking for an enclosing pragma 11639 11640 Par := N; 11641 while Present (Par) loop 11642 if Nkind (Par) = N_Pragma then 11643 Prag := Par; 11644 exit; 11645 11646 -- Precondition-like pragmas are expanded into if statements, check 11647 -- the original node instead. 11648 11649 elsif Nkind (Original_Node (Par)) = N_Pragma then 11650 Prag := Original_Node (Par); 11651 exit; 11652 11653 -- The expansion of attribute 'Old generates a constant to capture 11654 -- the result of the prefix. If the parent traversal reaches 11655 -- one of these constants, then the node technically came from a 11656 -- postcondition-like pragma. Note that the Ekind is not tested here 11657 -- because N may be the expression of an object declaration which is 11658 -- currently being analyzed. Such objects carry Ekind of E_Void. 11659 11660 elsif Nkind (Par) = N_Object_Declaration 11661 and then Constant_Present (Par) 11662 and then Stores_Attribute_Old_Prefix (Defining_Entity (Par)) 11663 then 11664 return True; 11665 11666 -- Prevent the search from going too far 11667 11668 elsif Is_Body_Or_Package_Declaration (Par) then 11669 return False; 11670 end if; 11671 11672 Par := Parent (Par); 11673 end loop; 11674 11675 return 11676 Present (Prag) 11677 and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag)); 11678 end In_Assertion_Expression_Pragma; 11679 11680 ---------------------- 11681 -- In_Generic_Scope -- 11682 ---------------------- 11683 11684 function In_Generic_Scope (E : Entity_Id) return Boolean is 11685 S : Entity_Id; 11686 11687 begin 11688 S := Scope (E); 11689 while Present (S) and then S /= Standard_Standard loop 11690 if Is_Generic_Unit (S) then 11691 return True; 11692 end if; 11693 11694 S := Scope (S); 11695 end loop; 11696 11697 return False; 11698 end In_Generic_Scope; 11699 11700 ----------------- 11701 -- In_Instance -- 11702 ----------------- 11703 11704 function In_Instance return Boolean is 11705 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 11706 S : Entity_Id; 11707 11708 begin 11709 S := Current_Scope; 11710 while Present (S) and then S /= Standard_Standard loop 11711 if Is_Generic_Instance (S) then 11712 11713 -- A child instance is always compiled in the context of a parent 11714 -- instance. Nevertheless, the actuals are not analyzed in an 11715 -- instance context. We detect this case by examining the current 11716 -- compilation unit, which must be a child instance, and checking 11717 -- that it is not currently on the scope stack. 11718 11719 if Is_Child_Unit (Curr_Unit) 11720 and then Nkind (Unit (Cunit (Current_Sem_Unit))) = 11721 N_Package_Instantiation 11722 and then not In_Open_Scopes (Curr_Unit) 11723 then 11724 return False; 11725 else 11726 return True; 11727 end if; 11728 end if; 11729 11730 S := Scope (S); 11731 end loop; 11732 11733 return False; 11734 end In_Instance; 11735 11736 ---------------------- 11737 -- In_Instance_Body -- 11738 ---------------------- 11739 11740 function In_Instance_Body return Boolean is 11741 S : Entity_Id; 11742 11743 begin 11744 S := Current_Scope; 11745 while Present (S) and then S /= Standard_Standard loop 11746 if Ekind_In (S, E_Function, E_Procedure) 11747 and then Is_Generic_Instance (S) 11748 then 11749 return True; 11750 11751 elsif Ekind (S) = E_Package 11752 and then In_Package_Body (S) 11753 and then Is_Generic_Instance (S) 11754 then 11755 return True; 11756 end if; 11757 11758 S := Scope (S); 11759 end loop; 11760 11761 return False; 11762 end In_Instance_Body; 11763 11764 ----------------------------- 11765 -- In_Instance_Not_Visible -- 11766 ----------------------------- 11767 11768 function In_Instance_Not_Visible return Boolean is 11769 S : Entity_Id; 11770 11771 begin 11772 S := Current_Scope; 11773 while Present (S) and then S /= Standard_Standard loop 11774 if Ekind_In (S, E_Function, E_Procedure) 11775 and then Is_Generic_Instance (S) 11776 then 11777 return True; 11778 11779 elsif Ekind (S) = E_Package 11780 and then (In_Package_Body (S) or else In_Private_Part (S)) 11781 and then Is_Generic_Instance (S) 11782 then 11783 return True; 11784 end if; 11785 11786 S := Scope (S); 11787 end loop; 11788 11789 return False; 11790 end In_Instance_Not_Visible; 11791 11792 ------------------------------ 11793 -- In_Instance_Visible_Part -- 11794 ------------------------------ 11795 11796 function In_Instance_Visible_Part 11797 (Id : Entity_Id := Current_Scope) return Boolean 11798 is 11799 Inst : Entity_Id; 11800 11801 begin 11802 Inst := Id; 11803 while Present (Inst) and then Inst /= Standard_Standard loop 11804 if Ekind (Inst) = E_Package 11805 and then Is_Generic_Instance (Inst) 11806 and then not In_Package_Body (Inst) 11807 and then not In_Private_Part (Inst) 11808 then 11809 return True; 11810 end if; 11811 11812 Inst := Scope (Inst); 11813 end loop; 11814 11815 return False; 11816 end In_Instance_Visible_Part; 11817 11818 --------------------- 11819 -- In_Package_Body -- 11820 --------------------- 11821 11822 function In_Package_Body return Boolean is 11823 S : Entity_Id; 11824 11825 begin 11826 S := Current_Scope; 11827 while Present (S) and then S /= Standard_Standard loop 11828 if Ekind (S) = E_Package and then In_Package_Body (S) then 11829 return True; 11830 else 11831 S := Scope (S); 11832 end if; 11833 end loop; 11834 11835 return False; 11836 end In_Package_Body; 11837 11838 -------------------------- 11839 -- In_Pragma_Expression -- 11840 -------------------------- 11841 11842 function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean is 11843 P : Node_Id; 11844 begin 11845 P := Parent (N); 11846 loop 11847 if No (P) then 11848 return False; 11849 elsif Nkind (P) = N_Pragma and then Pragma_Name (P) = Nam then 11850 return True; 11851 else 11852 P := Parent (P); 11853 end if; 11854 end loop; 11855 end In_Pragma_Expression; 11856 11857 --------------------------- 11858 -- In_Pre_Post_Condition -- 11859 --------------------------- 11860 11861 function In_Pre_Post_Condition (N : Node_Id) return Boolean is 11862 Par : Node_Id; 11863 Prag : Node_Id := Empty; 11864 Prag_Id : Pragma_Id; 11865 11866 begin 11867 -- Climb the parent chain looking for an enclosing pragma 11868 11869 Par := N; 11870 while Present (Par) loop 11871 if Nkind (Par) = N_Pragma then 11872 Prag := Par; 11873 exit; 11874 11875 -- Prevent the search from going too far 11876 11877 elsif Is_Body_Or_Package_Declaration (Par) then 11878 exit; 11879 end if; 11880 11881 Par := Parent (Par); 11882 end loop; 11883 11884 if Present (Prag) then 11885 Prag_Id := Get_Pragma_Id (Prag); 11886 11887 return 11888 Prag_Id = Pragma_Post 11889 or else Prag_Id = Pragma_Post_Class 11890 or else Prag_Id = Pragma_Postcondition 11891 or else Prag_Id = Pragma_Pre 11892 or else Prag_Id = Pragma_Pre_Class 11893 or else Prag_Id = Pragma_Precondition; 11894 11895 -- Otherwise the node is not enclosed by a pre/postcondition pragma 11896 11897 else 11898 return False; 11899 end if; 11900 end In_Pre_Post_Condition; 11901 11902 ------------------------------------- 11903 -- In_Reverse_Storage_Order_Object -- 11904 ------------------------------------- 11905 11906 function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is 11907 Pref : Node_Id; 11908 Btyp : Entity_Id := Empty; 11909 11910 begin 11911 -- Climb up indexed components 11912 11913 Pref := N; 11914 loop 11915 case Nkind (Pref) is 11916 when N_Selected_Component => 11917 Pref := Prefix (Pref); 11918 exit; 11919 11920 when N_Indexed_Component => 11921 Pref := Prefix (Pref); 11922 11923 when others => 11924 Pref := Empty; 11925 exit; 11926 end case; 11927 end loop; 11928 11929 if Present (Pref) then 11930 Btyp := Base_Type (Etype (Pref)); 11931 end if; 11932 11933 return Present (Btyp) 11934 and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp)) 11935 and then Reverse_Storage_Order (Btyp); 11936 end In_Reverse_Storage_Order_Object; 11937 11938 -------------------------------------- 11939 -- In_Subprogram_Or_Concurrent_Unit -- 11940 -------------------------------------- 11941 11942 function In_Subprogram_Or_Concurrent_Unit return Boolean is 11943 E : Entity_Id; 11944 K : Entity_Kind; 11945 11946 begin 11947 -- Use scope chain to check successively outer scopes 11948 11949 E := Current_Scope; 11950 loop 11951 K := Ekind (E); 11952 11953 if K in Subprogram_Kind 11954 or else K in Concurrent_Kind 11955 or else K in Generic_Subprogram_Kind 11956 then 11957 return True; 11958 11959 elsif E = Standard_Standard then 11960 return False; 11961 end if; 11962 11963 E := Scope (E); 11964 end loop; 11965 end In_Subprogram_Or_Concurrent_Unit; 11966 11967 ---------------- 11968 -- In_Subtree -- 11969 ---------------- 11970 11971 function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is 11972 Curr : Node_Id; 11973 11974 begin 11975 Curr := N; 11976 while Present (Curr) loop 11977 if Curr = Root then 11978 return True; 11979 end if; 11980 11981 Curr := Parent (Curr); 11982 end loop; 11983 11984 return False; 11985 end In_Subtree; 11986 11987 ---------------- 11988 -- In_Subtree -- 11989 ---------------- 11990 11991 function In_Subtree 11992 (N : Node_Id; 11993 Root1 : Node_Id; 11994 Root2 : Node_Id) return Boolean 11995 is 11996 Curr : Node_Id; 11997 11998 begin 11999 Curr := N; 12000 while Present (Curr) loop 12001 if Curr = Root1 or else Curr = Root2 then 12002 return True; 12003 end if; 12004 12005 Curr := Parent (Curr); 12006 end loop; 12007 12008 return False; 12009 end In_Subtree; 12010 12011 --------------------- 12012 -- In_Visible_Part -- 12013 --------------------- 12014 12015 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is 12016 begin 12017 return Is_Package_Or_Generic_Package (Scope_Id) 12018 and then In_Open_Scopes (Scope_Id) 12019 and then not In_Package_Body (Scope_Id) 12020 and then not In_Private_Part (Scope_Id); 12021 end In_Visible_Part; 12022 12023 -------------------------------- 12024 -- Incomplete_Or_Partial_View -- 12025 -------------------------------- 12026 12027 function Incomplete_Or_Partial_View (Id : Entity_Id) return Entity_Id is 12028 function Inspect_Decls 12029 (Decls : List_Id; 12030 Taft : Boolean := False) return Entity_Id; 12031 -- Check whether a declarative region contains the incomplete or partial 12032 -- view of Id. 12033 12034 ------------------- 12035 -- Inspect_Decls -- 12036 ------------------- 12037 12038 function Inspect_Decls 12039 (Decls : List_Id; 12040 Taft : Boolean := False) return Entity_Id 12041 is 12042 Decl : Node_Id; 12043 Match : Node_Id; 12044 12045 begin 12046 Decl := First (Decls); 12047 while Present (Decl) loop 12048 Match := Empty; 12049 12050 -- The partial view of a Taft-amendment type is an incomplete 12051 -- type. 12052 12053 if Taft then 12054 if Nkind (Decl) = N_Incomplete_Type_Declaration then 12055 Match := Defining_Identifier (Decl); 12056 end if; 12057 12058 -- Otherwise look for a private type whose full view matches the 12059 -- input type. Note that this checks full_type_declaration nodes 12060 -- to account for derivations from a private type where the type 12061 -- declaration hold the partial view and the full view is an 12062 -- itype. 12063 12064 elsif Nkind_In (Decl, N_Full_Type_Declaration, 12065 N_Private_Extension_Declaration, 12066 N_Private_Type_Declaration) 12067 then 12068 Match := Defining_Identifier (Decl); 12069 end if; 12070 12071 -- Guard against unanalyzed entities 12072 12073 if Present (Match) 12074 and then Is_Type (Match) 12075 and then Present (Full_View (Match)) 12076 and then Full_View (Match) = Id 12077 then 12078 return Match; 12079 end if; 12080 12081 Next (Decl); 12082 end loop; 12083 12084 return Empty; 12085 end Inspect_Decls; 12086 12087 -- Local variables 12088 12089 Prev : Entity_Id; 12090 12091 -- Start of processing for Incomplete_Or_Partial_View 12092 12093 begin 12094 -- Deferred constant or incomplete type case 12095 12096 Prev := Current_Entity_In_Scope (Id); 12097 12098 if Present (Prev) 12099 and then (Is_Incomplete_Type (Prev) or else Ekind (Prev) = E_Constant) 12100 and then Present (Full_View (Prev)) 12101 and then Full_View (Prev) = Id 12102 then 12103 return Prev; 12104 end if; 12105 12106 -- Private or Taft amendment type case 12107 12108 declare 12109 Pkg : constant Entity_Id := Scope (Id); 12110 Pkg_Decl : Node_Id := Pkg; 12111 12112 begin 12113 if Present (Pkg) 12114 and then Ekind_In (Pkg, E_Generic_Package, E_Package) 12115 then 12116 while Nkind (Pkg_Decl) /= N_Package_Specification loop 12117 Pkg_Decl := Parent (Pkg_Decl); 12118 end loop; 12119 12120 -- It is knows that Typ has a private view, look for it in the 12121 -- visible declarations of the enclosing scope. A special case 12122 -- of this is when the two views have been exchanged - the full 12123 -- appears earlier than the private. 12124 12125 if Has_Private_Declaration (Id) then 12126 Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl)); 12127 12128 -- Exchanged view case, look in the private declarations 12129 12130 if No (Prev) then 12131 Prev := Inspect_Decls (Private_Declarations (Pkg_Decl)); 12132 end if; 12133 12134 return Prev; 12135 12136 -- Otherwise if this is the package body, then Typ is a potential 12137 -- Taft amendment type. The incomplete view should be located in 12138 -- the private declarations of the enclosing scope. 12139 12140 elsif In_Package_Body (Pkg) then 12141 return Inspect_Decls (Private_Declarations (Pkg_Decl), True); 12142 end if; 12143 end if; 12144 end; 12145 12146 -- The type has no incomplete or private view 12147 12148 return Empty; 12149 end Incomplete_Or_Partial_View; 12150 12151 --------------------------------------- 12152 -- Incomplete_View_From_Limited_With -- 12153 --------------------------------------- 12154 12155 function Incomplete_View_From_Limited_With 12156 (Typ : Entity_Id) return Entity_Id 12157 is 12158 begin 12159 -- It might make sense to make this an attribute in Einfo, and set it 12160 -- in Sem_Ch10 in Build_Shadow_Entity. However, we're running short on 12161 -- slots for new attributes, and it seems a bit simpler to just search 12162 -- the Limited_View (if it exists) for an incomplete type whose 12163 -- Non_Limited_View is Typ. 12164 12165 if Ekind (Scope (Typ)) = E_Package 12166 and then Present (Limited_View (Scope (Typ))) 12167 then 12168 declare 12169 Ent : Entity_Id := First_Entity (Limited_View (Scope (Typ))); 12170 begin 12171 while Present (Ent) loop 12172 if Ekind (Ent) in Incomplete_Kind 12173 and then Non_Limited_View (Ent) = Typ 12174 then 12175 return Ent; 12176 end if; 12177 12178 Ent := Next_Entity (Ent); 12179 end loop; 12180 end; 12181 end if; 12182 12183 return Typ; 12184 end Incomplete_View_From_Limited_With; 12185 12186 ---------------------------------- 12187 -- Indexed_Component_Bit_Offset -- 12188 ---------------------------------- 12189 12190 function Indexed_Component_Bit_Offset (N : Node_Id) return Uint is 12191 Exp : constant Node_Id := First (Expressions (N)); 12192 Typ : constant Entity_Id := Etype (Prefix (N)); 12193 Off : constant Uint := Component_Size (Typ); 12194 Ind : Node_Id; 12195 12196 begin 12197 -- Return early if the component size is not known or variable 12198 12199 if Off = No_Uint or else Off < Uint_0 then 12200 return No_Uint; 12201 end if; 12202 12203 -- Deal with the degenerate case of an empty component 12204 12205 if Off = Uint_0 then 12206 return Off; 12207 end if; 12208 12209 -- Check that both the index value and the low bound are known 12210 12211 if not Compile_Time_Known_Value (Exp) then 12212 return No_Uint; 12213 end if; 12214 12215 Ind := First_Index (Typ); 12216 if No (Ind) then 12217 return No_Uint; 12218 end if; 12219 12220 if Nkind (Ind) = N_Subtype_Indication then 12221 Ind := Constraint (Ind); 12222 12223 if Nkind (Ind) = N_Range_Constraint then 12224 Ind := Range_Expression (Ind); 12225 end if; 12226 end if; 12227 12228 if Nkind (Ind) /= N_Range 12229 or else not Compile_Time_Known_Value (Low_Bound (Ind)) 12230 then 12231 return No_Uint; 12232 end if; 12233 12234 -- Return the scaled offset 12235 12236 return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound ((Ind)))); 12237 end Indexed_Component_Bit_Offset; 12238 12239 ---------------------------- 12240 -- Inherit_Rep_Item_Chain -- 12241 ---------------------------- 12242 12243 procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is 12244 Item : Node_Id; 12245 Next_Item : Node_Id; 12246 12247 begin 12248 -- There are several inheritance scenarios to consider depending on 12249 -- whether both types have rep item chains and whether the destination 12250 -- type already inherits part of the source type's rep item chain. 12251 12252 -- 1) The source type lacks a rep item chain 12253 -- From_Typ ---> Empty 12254 -- 12255 -- Typ --------> Item (or Empty) 12256 12257 -- In this case inheritance cannot take place because there are no items 12258 -- to inherit. 12259 12260 -- 2) The destination type lacks a rep item chain 12261 -- From_Typ ---> Item ---> ... 12262 -- 12263 -- Typ --------> Empty 12264 12265 -- Inheritance takes place by setting the First_Rep_Item of the 12266 -- destination type to the First_Rep_Item of the source type. 12267 -- From_Typ ---> Item ---> ... 12268 -- ^ 12269 -- Typ -----------+ 12270 12271 -- 3.1) Both source and destination types have at least one rep item. 12272 -- The destination type does NOT inherit a rep item from the source 12273 -- type. 12274 -- From_Typ ---> Item ---> Item 12275 -- 12276 -- Typ --------> Item ---> Item 12277 12278 -- Inheritance takes place by setting the Next_Rep_Item of the last item 12279 -- of the destination type to the First_Rep_Item of the source type. 12280 -- From_Typ -------------------> Item ---> Item 12281 -- ^ 12282 -- Typ --------> Item ---> Item --+ 12283 12284 -- 3.2) Both source and destination types have at least one rep item. 12285 -- The destination type DOES inherit part of the rep item chain of the 12286 -- source type. 12287 -- From_Typ ---> Item ---> Item ---> Item 12288 -- ^ 12289 -- Typ --------> Item ------+ 12290 12291 -- This rare case arises when the full view of a private extension must 12292 -- inherit the rep item chain from the full view of its parent type and 12293 -- the full view of the parent type contains extra rep items. Currently 12294 -- only invariants may lead to such form of inheritance. 12295 12296 -- type From_Typ is tagged private 12297 -- with Type_Invariant'Class => Item_2; 12298 12299 -- type Typ is new From_Typ with private 12300 -- with Type_Invariant => Item_4; 12301 12302 -- At this point the rep item chains contain the following items 12303 12304 -- From_Typ -----------> Item_2 ---> Item_3 12305 -- ^ 12306 -- Typ --------> Item_4 --+ 12307 12308 -- The full views of both types may introduce extra invariants 12309 12310 -- type From_Typ is tagged null record 12311 -- with Type_Invariant => Item_1; 12312 12313 -- type Typ is new From_Typ with null record; 12314 12315 -- The full view of Typ would have to inherit any new rep items added to 12316 -- the full view of From_Typ. 12317 12318 -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3 12319 -- ^ 12320 -- Typ --------> Item_4 --+ 12321 12322 -- To achieve this form of inheritance, the destination type must first 12323 -- sever the link between its own rep chain and that of the source type, 12324 -- then inheritance 3.1 takes place. 12325 12326 -- Case 1: The source type lacks a rep item chain 12327 12328 if No (First_Rep_Item (From_Typ)) then 12329 return; 12330 12331 -- Case 2: The destination type lacks a rep item chain 12332 12333 elsif No (First_Rep_Item (Typ)) then 12334 Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ)); 12335 12336 -- Case 3: Both the source and destination types have at least one rep 12337 -- item. Traverse the rep item chain of the destination type to find the 12338 -- last rep item. 12339 12340 else 12341 Item := Empty; 12342 Next_Item := First_Rep_Item (Typ); 12343 while Present (Next_Item) loop 12344 12345 -- Detect a link between the destination type's rep chain and that 12346 -- of the source type. There are two possibilities: 12347 12348 -- Variant 1 12349 -- Next_Item 12350 -- V 12351 -- From_Typ ---> Item_1 ---> 12352 -- ^ 12353 -- Typ -----------+ 12354 -- 12355 -- Item is Empty 12356 12357 -- Variant 2 12358 -- Next_Item 12359 -- V 12360 -- From_Typ ---> Item_1 ---> Item_2 ---> 12361 -- ^ 12362 -- Typ --------> Item_3 ------+ 12363 -- ^ 12364 -- Item 12365 12366 if Has_Rep_Item (From_Typ, Next_Item) then 12367 exit; 12368 end if; 12369 12370 Item := Next_Item; 12371 Next_Item := Next_Rep_Item (Next_Item); 12372 end loop; 12373 12374 -- Inherit the source type's rep item chain 12375 12376 if Present (Item) then 12377 Set_Next_Rep_Item (Item, First_Rep_Item (From_Typ)); 12378 else 12379 Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ)); 12380 end if; 12381 end if; 12382 end Inherit_Rep_Item_Chain; 12383 12384 --------------------------------- 12385 -- Insert_Explicit_Dereference -- 12386 --------------------------------- 12387 12388 procedure Insert_Explicit_Dereference (N : Node_Id) is 12389 New_Prefix : constant Node_Id := Relocate_Node (N); 12390 Ent : Entity_Id := Empty; 12391 Pref : Node_Id; 12392 I : Interp_Index; 12393 It : Interp; 12394 T : Entity_Id; 12395 12396 begin 12397 Save_Interps (N, New_Prefix); 12398 12399 Rewrite (N, 12400 Make_Explicit_Dereference (Sloc (Parent (N)), 12401 Prefix => New_Prefix)); 12402 12403 Set_Etype (N, Designated_Type (Etype (New_Prefix))); 12404 12405 if Is_Overloaded (New_Prefix) then 12406 12407 -- The dereference is also overloaded, and its interpretations are 12408 -- the designated types of the interpretations of the original node. 12409 12410 Set_Etype (N, Any_Type); 12411 12412 Get_First_Interp (New_Prefix, I, It); 12413 while Present (It.Nam) loop 12414 T := It.Typ; 12415 12416 if Is_Access_Type (T) then 12417 Add_One_Interp (N, Designated_Type (T), Designated_Type (T)); 12418 end if; 12419 12420 Get_Next_Interp (I, It); 12421 end loop; 12422 12423 End_Interp_List; 12424 12425 else 12426 -- Prefix is unambiguous: mark the original prefix (which might 12427 -- Come_From_Source) as a reference, since the new (relocated) one 12428 -- won't be taken into account. 12429 12430 if Is_Entity_Name (New_Prefix) then 12431 Ent := Entity (New_Prefix); 12432 Pref := New_Prefix; 12433 12434 -- For a retrieval of a subcomponent of some composite object, 12435 -- retrieve the ultimate entity if there is one. 12436 12437 elsif Nkind_In (New_Prefix, N_Selected_Component, 12438 N_Indexed_Component) 12439 then 12440 Pref := Prefix (New_Prefix); 12441 while Present (Pref) 12442 and then Nkind_In (Pref, N_Selected_Component, 12443 N_Indexed_Component) 12444 loop 12445 Pref := Prefix (Pref); 12446 end loop; 12447 12448 if Present (Pref) and then Is_Entity_Name (Pref) then 12449 Ent := Entity (Pref); 12450 end if; 12451 end if; 12452 12453 -- Place the reference on the entity node 12454 12455 if Present (Ent) then 12456 Generate_Reference (Ent, Pref); 12457 end if; 12458 end if; 12459 end Insert_Explicit_Dereference; 12460 12461 ------------------------------------------ 12462 -- Inspect_Deferred_Constant_Completion -- 12463 ------------------------------------------ 12464 12465 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is 12466 Decl : Node_Id; 12467 12468 begin 12469 Decl := First (Decls); 12470 while Present (Decl) loop 12471 12472 -- Deferred constant signature 12473 12474 if Nkind (Decl) = N_Object_Declaration 12475 and then Constant_Present (Decl) 12476 and then No (Expression (Decl)) 12477 12478 -- No need to check internally generated constants 12479 12480 and then Comes_From_Source (Decl) 12481 12482 -- The constant is not completed. A full object declaration or a 12483 -- pragma Import complete a deferred constant. 12484 12485 and then not Has_Completion (Defining_Identifier (Decl)) 12486 then 12487 Error_Msg_N 12488 ("constant declaration requires initialization expression", 12489 Defining_Identifier (Decl)); 12490 end if; 12491 12492 Decl := Next (Decl); 12493 end loop; 12494 end Inspect_Deferred_Constant_Completion; 12495 12496 ----------------------------- 12497 -- Install_Generic_Formals -- 12498 ----------------------------- 12499 12500 procedure Install_Generic_Formals (Subp_Id : Entity_Id) is 12501 E : Entity_Id; 12502 12503 begin 12504 pragma Assert (Is_Generic_Subprogram (Subp_Id)); 12505 12506 E := First_Entity (Subp_Id); 12507 while Present (E) loop 12508 Install_Entity (E); 12509 Next_Entity (E); 12510 end loop; 12511 end Install_Generic_Formals; 12512 12513 ------------------------ 12514 -- Install_SPARK_Mode -- 12515 ------------------------ 12516 12517 procedure Install_SPARK_Mode (Mode : SPARK_Mode_Type; Prag : Node_Id) is 12518 begin 12519 SPARK_Mode := Mode; 12520 SPARK_Mode_Pragma := Prag; 12521 end Install_SPARK_Mode; 12522 12523 ----------------------------- 12524 -- Is_Actual_Out_Parameter -- 12525 ----------------------------- 12526 12527 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is 12528 Formal : Entity_Id; 12529 Call : Node_Id; 12530 begin 12531 Find_Actual (N, Formal, Call); 12532 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter; 12533 end Is_Actual_Out_Parameter; 12534 12535 ------------------------- 12536 -- Is_Actual_Parameter -- 12537 ------------------------- 12538 12539 function Is_Actual_Parameter (N : Node_Id) return Boolean is 12540 PK : constant Node_Kind := Nkind (Parent (N)); 12541 12542 begin 12543 case PK is 12544 when N_Parameter_Association => 12545 return N = Explicit_Actual_Parameter (Parent (N)); 12546 12547 when N_Subprogram_Call => 12548 return Is_List_Member (N) 12549 and then 12550 List_Containing (N) = Parameter_Associations (Parent (N)); 12551 12552 when others => 12553 return False; 12554 end case; 12555 end Is_Actual_Parameter; 12556 12557 -------------------------------- 12558 -- Is_Actual_Tagged_Parameter -- 12559 -------------------------------- 12560 12561 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is 12562 Formal : Entity_Id; 12563 Call : Node_Id; 12564 begin 12565 Find_Actual (N, Formal, Call); 12566 return Present (Formal) and then Is_Tagged_Type (Etype (Formal)); 12567 end Is_Actual_Tagged_Parameter; 12568 12569 --------------------- 12570 -- Is_Aliased_View -- 12571 --------------------- 12572 12573 function Is_Aliased_View (Obj : Node_Id) return Boolean is 12574 E : Entity_Id; 12575 12576 begin 12577 if Is_Entity_Name (Obj) then 12578 E := Entity (Obj); 12579 12580 return 12581 (Is_Object (E) 12582 and then 12583 (Is_Aliased (E) 12584 or else (Present (Renamed_Object (E)) 12585 and then Is_Aliased_View (Renamed_Object (E))))) 12586 12587 or else ((Is_Formal (E) or else Is_Formal_Object (E)) 12588 and then Is_Tagged_Type (Etype (E))) 12589 12590 or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E)) 12591 12592 -- Current instance of type, either directly or as rewritten 12593 -- reference to the current object. 12594 12595 or else (Is_Entity_Name (Original_Node (Obj)) 12596 and then Present (Entity (Original_Node (Obj))) 12597 and then Is_Type (Entity (Original_Node (Obj)))) 12598 12599 or else (Is_Type (E) and then E = Current_Scope) 12600 12601 or else (Is_Incomplete_Or_Private_Type (E) 12602 and then Full_View (E) = Current_Scope) 12603 12604 -- Ada 2012 AI05-0053: the return object of an extended return 12605 -- statement is aliased if its type is immutably limited. 12606 12607 or else (Is_Return_Object (E) 12608 and then Is_Limited_View (Etype (E))); 12609 12610 elsif Nkind (Obj) = N_Selected_Component then 12611 return Is_Aliased (Entity (Selector_Name (Obj))); 12612 12613 elsif Nkind (Obj) = N_Indexed_Component then 12614 return Has_Aliased_Components (Etype (Prefix (Obj))) 12615 or else 12616 (Is_Access_Type (Etype (Prefix (Obj))) 12617 and then Has_Aliased_Components 12618 (Designated_Type (Etype (Prefix (Obj))))); 12619 12620 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then 12621 return Is_Tagged_Type (Etype (Obj)) 12622 and then Is_Aliased_View (Expression (Obj)); 12623 12624 elsif Nkind (Obj) = N_Explicit_Dereference then 12625 return Nkind (Original_Node (Obj)) /= N_Function_Call; 12626 12627 else 12628 return False; 12629 end if; 12630 end Is_Aliased_View; 12631 12632 ------------------------- 12633 -- Is_Ancestor_Package -- 12634 ------------------------- 12635 12636 function Is_Ancestor_Package 12637 (E1 : Entity_Id; 12638 E2 : Entity_Id) return Boolean 12639 is 12640 Par : Entity_Id; 12641 12642 begin 12643 Par := E2; 12644 while Present (Par) and then Par /= Standard_Standard loop 12645 if Par = E1 then 12646 return True; 12647 end if; 12648 12649 Par := Scope (Par); 12650 end loop; 12651 12652 return False; 12653 end Is_Ancestor_Package; 12654 12655 ---------------------- 12656 -- Is_Atomic_Object -- 12657 ---------------------- 12658 12659 function Is_Atomic_Object (N : Node_Id) return Boolean is 12660 12661 function Object_Has_Atomic_Components (N : Node_Id) return Boolean; 12662 -- Determines if given object has atomic components 12663 12664 function Is_Atomic_Prefix (N : Node_Id) return Boolean; 12665 -- If prefix is an implicit dereference, examine designated type 12666 12667 ---------------------- 12668 -- Is_Atomic_Prefix -- 12669 ---------------------- 12670 12671 function Is_Atomic_Prefix (N : Node_Id) return Boolean is 12672 begin 12673 if Is_Access_Type (Etype (N)) then 12674 return 12675 Has_Atomic_Components (Designated_Type (Etype (N))); 12676 else 12677 return Object_Has_Atomic_Components (N); 12678 end if; 12679 end Is_Atomic_Prefix; 12680 12681 ---------------------------------- 12682 -- Object_Has_Atomic_Components -- 12683 ---------------------------------- 12684 12685 function Object_Has_Atomic_Components (N : Node_Id) return Boolean is 12686 begin 12687 if Has_Atomic_Components (Etype (N)) 12688 or else Is_Atomic (Etype (N)) 12689 then 12690 return True; 12691 12692 elsif Is_Entity_Name (N) 12693 and then (Has_Atomic_Components (Entity (N)) 12694 or else Is_Atomic (Entity (N))) 12695 then 12696 return True; 12697 12698 elsif Nkind (N) = N_Selected_Component 12699 and then Is_Atomic (Entity (Selector_Name (N))) 12700 then 12701 return True; 12702 12703 elsif Nkind (N) = N_Indexed_Component 12704 or else Nkind (N) = N_Selected_Component 12705 then 12706 return Is_Atomic_Prefix (Prefix (N)); 12707 12708 else 12709 return False; 12710 end if; 12711 end Object_Has_Atomic_Components; 12712 12713 -- Start of processing for Is_Atomic_Object 12714 12715 begin 12716 -- Predicate is not relevant to subprograms 12717 12718 if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then 12719 return False; 12720 12721 elsif Is_Atomic (Etype (N)) 12722 or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N))) 12723 then 12724 return True; 12725 12726 elsif Nkind (N) = N_Selected_Component 12727 and then Is_Atomic (Entity (Selector_Name (N))) 12728 then 12729 return True; 12730 12731 elsif Nkind (N) = N_Indexed_Component 12732 or else Nkind (N) = N_Selected_Component 12733 then 12734 return Is_Atomic_Prefix (Prefix (N)); 12735 12736 else 12737 return False; 12738 end if; 12739 end Is_Atomic_Object; 12740 12741 ----------------------------- 12742 -- Is_Atomic_Or_VFA_Object -- 12743 ----------------------------- 12744 12745 function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean is 12746 begin 12747 return Is_Atomic_Object (N) 12748 or else (Is_Object_Reference (N) 12749 and then Is_Entity_Name (N) 12750 and then (Is_Volatile_Full_Access (Entity (N)) 12751 or else 12752 Is_Volatile_Full_Access (Etype (Entity (N))))); 12753 end Is_Atomic_Or_VFA_Object; 12754 12755 ------------------------- 12756 -- Is_Attribute_Result -- 12757 ------------------------- 12758 12759 function Is_Attribute_Result (N : Node_Id) return Boolean is 12760 begin 12761 return Nkind (N) = N_Attribute_Reference 12762 and then Attribute_Name (N) = Name_Result; 12763 end Is_Attribute_Result; 12764 12765 ------------------------- 12766 -- Is_Attribute_Update -- 12767 ------------------------- 12768 12769 function Is_Attribute_Update (N : Node_Id) return Boolean is 12770 begin 12771 return Nkind (N) = N_Attribute_Reference 12772 and then Attribute_Name (N) = Name_Update; 12773 end Is_Attribute_Update; 12774 12775 ------------------------------------ 12776 -- Is_Body_Or_Package_Declaration -- 12777 ------------------------------------ 12778 12779 function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is 12780 begin 12781 return Nkind_In (N, N_Entry_Body, 12782 N_Package_Body, 12783 N_Package_Declaration, 12784 N_Protected_Body, 12785 N_Subprogram_Body, 12786 N_Task_Body); 12787 end Is_Body_Or_Package_Declaration; 12788 12789 ----------------------- 12790 -- Is_Bounded_String -- 12791 ----------------------- 12792 12793 function Is_Bounded_String (T : Entity_Id) return Boolean is 12794 Under : constant Entity_Id := Underlying_Type (Root_Type (T)); 12795 12796 begin 12797 -- Check whether T is ultimately derived from Ada.Strings.Superbounded. 12798 -- Super_String, or one of the [Wide_]Wide_ versions. This will 12799 -- be True for all the Bounded_String types in instances of the 12800 -- Generic_Bounded_Length generics, and for types derived from those. 12801 12802 return Present (Under) 12803 and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else 12804 Is_RTE (Root_Type (Under), RO_WI_Super_String) or else 12805 Is_RTE (Root_Type (Under), RO_WW_Super_String)); 12806 end Is_Bounded_String; 12807 12808 --------------------- 12809 -- Is_CCT_Instance -- 12810 --------------------- 12811 12812 function Is_CCT_Instance 12813 (Ref_Id : Entity_Id; 12814 Context_Id : Entity_Id) return Boolean 12815 is 12816 begin 12817 pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type)); 12818 12819 if Is_Single_Task_Object (Context_Id) then 12820 return Scope_Within_Or_Same (Etype (Context_Id), Ref_Id); 12821 12822 else 12823 pragma Assert (Ekind_In (Context_Id, E_Entry, 12824 E_Entry_Family, 12825 E_Function, 12826 E_Package, 12827 E_Procedure, 12828 E_Protected_Type, 12829 E_Task_Type) 12830 or else 12831 Is_Record_Type (Context_Id)); 12832 return Scope_Within_Or_Same (Context_Id, Ref_Id); 12833 end if; 12834 end Is_CCT_Instance; 12835 12836 ------------------------- 12837 -- Is_Child_Or_Sibling -- 12838 ------------------------- 12839 12840 function Is_Child_Or_Sibling 12841 (Pack_1 : Entity_Id; 12842 Pack_2 : Entity_Id) return Boolean 12843 is 12844 function Distance_From_Standard (Pack : Entity_Id) return Nat; 12845 -- Given an arbitrary package, return the number of "climbs" necessary 12846 -- to reach scope Standard_Standard. 12847 12848 procedure Equalize_Depths 12849 (Pack : in out Entity_Id; 12850 Depth : in out Nat; 12851 Depth_To_Reach : Nat); 12852 -- Given an arbitrary package, its depth and a target depth to reach, 12853 -- climb the scope chain until the said depth is reached. The pointer 12854 -- to the package and its depth a modified during the climb. 12855 12856 ---------------------------- 12857 -- Distance_From_Standard -- 12858 ---------------------------- 12859 12860 function Distance_From_Standard (Pack : Entity_Id) return Nat is 12861 Dist : Nat; 12862 Scop : Entity_Id; 12863 12864 begin 12865 Dist := 0; 12866 Scop := Pack; 12867 while Present (Scop) and then Scop /= Standard_Standard loop 12868 Dist := Dist + 1; 12869 Scop := Scope (Scop); 12870 end loop; 12871 12872 return Dist; 12873 end Distance_From_Standard; 12874 12875 --------------------- 12876 -- Equalize_Depths -- 12877 --------------------- 12878 12879 procedure Equalize_Depths 12880 (Pack : in out Entity_Id; 12881 Depth : in out Nat; 12882 Depth_To_Reach : Nat) 12883 is 12884 begin 12885 -- The package must be at a greater or equal depth 12886 12887 if Depth < Depth_To_Reach then 12888 raise Program_Error; 12889 end if; 12890 12891 -- Climb the scope chain until the desired depth is reached 12892 12893 while Present (Pack) and then Depth /= Depth_To_Reach loop 12894 Pack := Scope (Pack); 12895 Depth := Depth - 1; 12896 end loop; 12897 end Equalize_Depths; 12898 12899 -- Local variables 12900 12901 P_1 : Entity_Id := Pack_1; 12902 P_1_Child : Boolean := False; 12903 P_1_Depth : Nat := Distance_From_Standard (P_1); 12904 P_2 : Entity_Id := Pack_2; 12905 P_2_Child : Boolean := False; 12906 P_2_Depth : Nat := Distance_From_Standard (P_2); 12907 12908 -- Start of processing for Is_Child_Or_Sibling 12909 12910 begin 12911 pragma Assert 12912 (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package); 12913 12914 -- Both packages denote the same entity, therefore they cannot be 12915 -- children or siblings. 12916 12917 if P_1 = P_2 then 12918 return False; 12919 12920 -- One of the packages is at a deeper level than the other. Note that 12921 -- both may still come from different hierarchies. 12922 12923 -- (root) P_2 12924 -- / \ : 12925 -- X P_2 or X 12926 -- : : 12927 -- P_1 P_1 12928 12929 elsif P_1_Depth > P_2_Depth then 12930 Equalize_Depths 12931 (Pack => P_1, 12932 Depth => P_1_Depth, 12933 Depth_To_Reach => P_2_Depth); 12934 P_1_Child := True; 12935 12936 -- (root) P_1 12937 -- / \ : 12938 -- P_1 X or X 12939 -- : : 12940 -- P_2 P_2 12941 12942 elsif P_2_Depth > P_1_Depth then 12943 Equalize_Depths 12944 (Pack => P_2, 12945 Depth => P_2_Depth, 12946 Depth_To_Reach => P_1_Depth); 12947 P_2_Child := True; 12948 end if; 12949 12950 -- At this stage the package pointers have been elevated to the same 12951 -- depth. If the related entities are the same, then one package is a 12952 -- potential child of the other: 12953 12954 -- P_1 12955 -- : 12956 -- X became P_1 P_2 or vice versa 12957 -- : 12958 -- P_2 12959 12960 if P_1 = P_2 then 12961 if P_1_Child then 12962 return Is_Child_Unit (Pack_1); 12963 12964 else pragma Assert (P_2_Child); 12965 return Is_Child_Unit (Pack_2); 12966 end if; 12967 12968 -- The packages may come from the same package chain or from entirely 12969 -- different hierarcies. To determine this, climb the scope stack until 12970 -- a common root is found. 12971 12972 -- (root) (root 1) (root 2) 12973 -- / \ | | 12974 -- P_1 P_2 P_1 P_2 12975 12976 else 12977 while Present (P_1) and then Present (P_2) loop 12978 12979 -- The two packages may be siblings 12980 12981 if P_1 = P_2 then 12982 return Is_Child_Unit (Pack_1) and then Is_Child_Unit (Pack_2); 12983 end if; 12984 12985 P_1 := Scope (P_1); 12986 P_2 := Scope (P_2); 12987 end loop; 12988 end if; 12989 12990 return False; 12991 end Is_Child_Or_Sibling; 12992 12993 ----------------------------- 12994 -- Is_Concurrent_Interface -- 12995 ----------------------------- 12996 12997 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is 12998 begin 12999 return Is_Interface (T) 13000 and then 13001 (Is_Protected_Interface (T) 13002 or else Is_Synchronized_Interface (T) 13003 or else Is_Task_Interface (T)); 13004 end Is_Concurrent_Interface; 13005 13006 ----------------------- 13007 -- Is_Constant_Bound -- 13008 ----------------------- 13009 13010 function Is_Constant_Bound (Exp : Node_Id) return Boolean is 13011 begin 13012 if Compile_Time_Known_Value (Exp) then 13013 return True; 13014 13015 elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then 13016 return Is_Constant_Object (Entity (Exp)) 13017 or else Ekind (Entity (Exp)) = E_Enumeration_Literal; 13018 13019 elsif Nkind (Exp) in N_Binary_Op then 13020 return Is_Constant_Bound (Left_Opnd (Exp)) 13021 and then Is_Constant_Bound (Right_Opnd (Exp)) 13022 and then Scope (Entity (Exp)) = Standard_Standard; 13023 13024 else 13025 return False; 13026 end if; 13027 end Is_Constant_Bound; 13028 13029 --------------------------- 13030 -- Is_Container_Element -- 13031 --------------------------- 13032 13033 function Is_Container_Element (Exp : Node_Id) return Boolean is 13034 Loc : constant Source_Ptr := Sloc (Exp); 13035 Pref : constant Node_Id := Prefix (Exp); 13036 13037 Call : Node_Id; 13038 -- Call to an indexing aspect 13039 13040 Cont_Typ : Entity_Id; 13041 -- The type of the container being accessed 13042 13043 Elem_Typ : Entity_Id; 13044 -- Its element type 13045 13046 Indexing : Entity_Id; 13047 Is_Const : Boolean; 13048 -- Indicates that constant indexing is used, and the element is thus 13049 -- a constant. 13050 13051 Ref_Typ : Entity_Id; 13052 -- The reference type returned by the indexing operation 13053 13054 begin 13055 -- If C is a container, in a context that imposes the element type of 13056 -- that container, the indexing notation C (X) is rewritten as: 13057 13058 -- Indexing (C, X).Discr.all 13059 13060 -- where Indexing is one of the indexing aspects of the container. 13061 -- If the context does not require a reference, the construct can be 13062 -- rewritten as 13063 13064 -- Element (C, X) 13065 13066 -- First, verify that the construct has the proper form 13067 13068 if not Expander_Active then 13069 return False; 13070 13071 elsif Nkind (Pref) /= N_Selected_Component then 13072 return False; 13073 13074 elsif Nkind (Prefix (Pref)) /= N_Function_Call then 13075 return False; 13076 13077 else 13078 Call := Prefix (Pref); 13079 Ref_Typ := Etype (Call); 13080 end if; 13081 13082 if not Has_Implicit_Dereference (Ref_Typ) 13083 or else No (First (Parameter_Associations (Call))) 13084 or else not Is_Entity_Name (Name (Call)) 13085 then 13086 return False; 13087 end if; 13088 13089 -- Retrieve type of container object, and its iterator aspects 13090 13091 Cont_Typ := Etype (First (Parameter_Associations (Call))); 13092 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Constant_Indexing); 13093 Is_Const := False; 13094 13095 if No (Indexing) then 13096 13097 -- Container should have at least one indexing operation 13098 13099 return False; 13100 13101 elsif Entity (Name (Call)) /= Entity (Indexing) then 13102 13103 -- This may be a variable indexing operation 13104 13105 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Variable_Indexing); 13106 13107 if No (Indexing) 13108 or else Entity (Name (Call)) /= Entity (Indexing) 13109 then 13110 return False; 13111 end if; 13112 13113 else 13114 Is_Const := True; 13115 end if; 13116 13117 Elem_Typ := Find_Value_Of_Aspect (Cont_Typ, Aspect_Iterator_Element); 13118 13119 if No (Elem_Typ) or else Entity (Elem_Typ) /= Etype (Exp) then 13120 return False; 13121 end if; 13122 13123 -- Check that the expression is not the target of an assignment, in 13124 -- which case the rewriting is not possible. 13125 13126 if not Is_Const then 13127 declare 13128 Par : Node_Id; 13129 13130 begin 13131 Par := Exp; 13132 while Present (Par) 13133 loop 13134 if Nkind (Parent (Par)) = N_Assignment_Statement 13135 and then Par = Name (Parent (Par)) 13136 then 13137 return False; 13138 13139 -- A renaming produces a reference, and the transformation 13140 -- does not apply. 13141 13142 elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then 13143 return False; 13144 13145 elsif Nkind_In 13146 (Nkind (Parent (Par)), N_Function_Call, 13147 N_Procedure_Call_Statement, 13148 N_Entry_Call_Statement) 13149 then 13150 -- Check that the element is not part of an actual for an 13151 -- in-out parameter. 13152 13153 declare 13154 F : Entity_Id; 13155 A : Node_Id; 13156 13157 begin 13158 F := First_Formal (Entity (Name (Parent (Par)))); 13159 A := First (Parameter_Associations (Parent (Par))); 13160 while Present (F) loop 13161 if A = Par and then Ekind (F) /= E_In_Parameter then 13162 return False; 13163 end if; 13164 13165 Next_Formal (F); 13166 Next (A); 13167 end loop; 13168 end; 13169 13170 -- E_In_Parameter in a call: element is not modified. 13171 13172 exit; 13173 end if; 13174 13175 Par := Parent (Par); 13176 end loop; 13177 end; 13178 end if; 13179 13180 -- The expression has the proper form and the context requires the 13181 -- element type. Retrieve the Element function of the container and 13182 -- rewrite the construct as a call to it. 13183 13184 declare 13185 Op : Elmt_Id; 13186 13187 begin 13188 Op := First_Elmt (Primitive_Operations (Cont_Typ)); 13189 while Present (Op) loop 13190 exit when Chars (Node (Op)) = Name_Element; 13191 Next_Elmt (Op); 13192 end loop; 13193 13194 if No (Op) then 13195 return False; 13196 13197 else 13198 Rewrite (Exp, 13199 Make_Function_Call (Loc, 13200 Name => New_Occurrence_Of (Node (Op), Loc), 13201 Parameter_Associations => Parameter_Associations (Call))); 13202 Analyze_And_Resolve (Exp, Entity (Elem_Typ)); 13203 return True; 13204 end if; 13205 end; 13206 end Is_Container_Element; 13207 13208 ---------------------------- 13209 -- Is_Contract_Annotation -- 13210 ---------------------------- 13211 13212 function Is_Contract_Annotation (Item : Node_Id) return Boolean is 13213 begin 13214 return Is_Package_Contract_Annotation (Item) 13215 or else 13216 Is_Subprogram_Contract_Annotation (Item); 13217 end Is_Contract_Annotation; 13218 13219 -------------------------------------- 13220 -- Is_Controlling_Limited_Procedure -- 13221 -------------------------------------- 13222 13223 function Is_Controlling_Limited_Procedure 13224 (Proc_Nam : Entity_Id) return Boolean 13225 is 13226 Param : Node_Id; 13227 Param_Typ : Entity_Id := Empty; 13228 13229 begin 13230 if Ekind (Proc_Nam) = E_Procedure 13231 and then Present (Parameter_Specifications (Parent (Proc_Nam))) 13232 then 13233 Param := 13234 Parameter_Type 13235 (First (Parameter_Specifications (Parent (Proc_Nam)))); 13236 13237 -- The formal may be an anonymous access type 13238 13239 if Nkind (Param) = N_Access_Definition then 13240 Param_Typ := Entity (Subtype_Mark (Param)); 13241 else 13242 Param_Typ := Etype (Param); 13243 end if; 13244 13245 -- In the case where an Itype was created for a dispatchin call, the 13246 -- procedure call has been rewritten. The actual may be an access to 13247 -- interface type in which case it is the designated type that is the 13248 -- controlling type. 13249 13250 elsif Present (Associated_Node_For_Itype (Proc_Nam)) 13251 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam))) 13252 and then 13253 Present (Parameter_Associations 13254 (Associated_Node_For_Itype (Proc_Nam))) 13255 then 13256 Param_Typ := 13257 Etype (First (Parameter_Associations 13258 (Associated_Node_For_Itype (Proc_Nam)))); 13259 13260 if Ekind (Param_Typ) = E_Anonymous_Access_Type then 13261 Param_Typ := Directly_Designated_Type (Param_Typ); 13262 end if; 13263 end if; 13264 13265 if Present (Param_Typ) then 13266 return 13267 Is_Interface (Param_Typ) 13268 and then Is_Limited_Record (Param_Typ); 13269 end if; 13270 13271 return False; 13272 end Is_Controlling_Limited_Procedure; 13273 13274 ----------------------------- 13275 -- Is_CPP_Constructor_Call -- 13276 ----------------------------- 13277 13278 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is 13279 begin 13280 return Nkind (N) = N_Function_Call 13281 and then Is_CPP_Class (Etype (Etype (N))) 13282 and then Is_Constructor (Entity (Name (N))) 13283 and then Is_Imported (Entity (Name (N))); 13284 end Is_CPP_Constructor_Call; 13285 13286 ------------------------- 13287 -- Is_Current_Instance -- 13288 ------------------------- 13289 13290 function Is_Current_Instance (N : Node_Id) return Boolean is 13291 Typ : constant Entity_Id := Entity (N); 13292 P : Node_Id; 13293 13294 begin 13295 -- Simplest case: entity is a concurrent type and we are currently 13296 -- inside the body. This will eventually be expanded into a call to 13297 -- Self (for tasks) or _object (for protected objects). 13298 13299 if Is_Concurrent_Type (Typ) and then In_Open_Scopes (Typ) then 13300 return True; 13301 13302 else 13303 -- Check whether the context is a (sub)type declaration for the 13304 -- type entity. 13305 13306 P := Parent (N); 13307 while Present (P) loop 13308 if Nkind_In (P, N_Full_Type_Declaration, 13309 N_Private_Type_Declaration, 13310 N_Subtype_Declaration) 13311 and then Comes_From_Source (P) 13312 and then Defining_Entity (P) = Typ 13313 then 13314 return True; 13315 13316 -- A subtype name may appear in an aspect specification for a 13317 -- Predicate_Failure aspect, for which we do not construct a 13318 -- wrapper procedure. The subtype will be replaced by the 13319 -- expression being tested when the corresponding predicate 13320 -- check is expanded. 13321 13322 elsif Nkind (P) = N_Aspect_Specification 13323 and then Nkind (Parent (P)) = N_Subtype_Declaration 13324 then 13325 return True; 13326 13327 elsif Nkind (P) = N_Pragma 13328 and then Get_Pragma_Id (P) = Pragma_Predicate_Failure 13329 then 13330 return True; 13331 end if; 13332 13333 P := Parent (P); 13334 end loop; 13335 end if; 13336 13337 -- In any other context this is not a current occurrence 13338 13339 return False; 13340 end Is_Current_Instance; 13341 13342 -------------------- 13343 -- Is_Declaration -- 13344 -------------------- 13345 13346 function Is_Declaration 13347 (N : Node_Id; 13348 Body_OK : Boolean := True; 13349 Concurrent_OK : Boolean := True; 13350 Formal_OK : Boolean := True; 13351 Generic_OK : Boolean := True; 13352 Instantiation_OK : Boolean := True; 13353 Renaming_OK : Boolean := True; 13354 Stub_OK : Boolean := True; 13355 Subprogram_OK : Boolean := True; 13356 Type_OK : Boolean := True) return Boolean 13357 is 13358 begin 13359 case Nkind (N) is 13360 13361 -- Body declarations 13362 13363 when N_Proper_Body => 13364 return Body_OK; 13365 13366 -- Concurrent type declarations 13367 13368 when N_Protected_Type_Declaration 13369 | N_Single_Protected_Declaration 13370 | N_Single_Task_Declaration 13371 | N_Task_Type_Declaration 13372 => 13373 return Concurrent_OK or Type_OK; 13374 13375 -- Formal declarations 13376 13377 when N_Formal_Abstract_Subprogram_Declaration 13378 | N_Formal_Concrete_Subprogram_Declaration 13379 | N_Formal_Object_Declaration 13380 | N_Formal_Package_Declaration 13381 | N_Formal_Type_Declaration 13382 => 13383 return Formal_OK; 13384 13385 -- Generic declarations 13386 13387 when N_Generic_Package_Declaration 13388 | N_Generic_Subprogram_Declaration 13389 => 13390 return Generic_OK; 13391 13392 -- Generic instantiations 13393 13394 when N_Function_Instantiation 13395 | N_Package_Instantiation 13396 | N_Procedure_Instantiation 13397 => 13398 return Instantiation_OK; 13399 13400 -- Generic renaming declarations 13401 13402 when N_Generic_Renaming_Declaration => 13403 return Generic_OK or Renaming_OK; 13404 13405 -- Renaming declarations 13406 13407 when N_Exception_Renaming_Declaration 13408 | N_Object_Renaming_Declaration 13409 | N_Package_Renaming_Declaration 13410 | N_Subprogram_Renaming_Declaration 13411 => 13412 return Renaming_OK; 13413 13414 -- Stub declarations 13415 13416 when N_Body_Stub => 13417 return Stub_OK; 13418 13419 -- Subprogram declarations 13420 13421 when N_Abstract_Subprogram_Declaration 13422 | N_Entry_Declaration 13423 | N_Expression_Function 13424 | N_Subprogram_Declaration 13425 => 13426 return Subprogram_OK; 13427 13428 -- Type declarations 13429 13430 when N_Full_Type_Declaration 13431 | N_Incomplete_Type_Declaration 13432 | N_Private_Extension_Declaration 13433 | N_Private_Type_Declaration 13434 | N_Subtype_Declaration 13435 => 13436 return Type_OK; 13437 13438 -- Miscellaneous 13439 13440 when N_Component_Declaration 13441 | N_Exception_Declaration 13442 | N_Implicit_Label_Declaration 13443 | N_Number_Declaration 13444 | N_Object_Declaration 13445 | N_Package_Declaration 13446 => 13447 return True; 13448 13449 when others => 13450 return False; 13451 end case; 13452 end Is_Declaration; 13453 13454 -------------------------------- 13455 -- Is_Declared_Within_Variant -- 13456 -------------------------------- 13457 13458 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is 13459 Comp_Decl : constant Node_Id := Parent (Comp); 13460 Comp_List : constant Node_Id := Parent (Comp_Decl); 13461 begin 13462 return Nkind (Parent (Comp_List)) = N_Variant; 13463 end Is_Declared_Within_Variant; 13464 13465 ---------------------------------------------- 13466 -- Is_Dependent_Component_Of_Mutable_Object -- 13467 ---------------------------------------------- 13468 13469 function Is_Dependent_Component_Of_Mutable_Object 13470 (Object : Node_Id) return Boolean 13471 is 13472 P : Node_Id; 13473 Prefix_Type : Entity_Id; 13474 P_Aliased : Boolean := False; 13475 Comp : Entity_Id; 13476 13477 Deref : Node_Id := Object; 13478 -- Dereference node, in something like X.all.Y(2) 13479 13480 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object 13481 13482 begin 13483 -- Find the dereference node if any 13484 13485 while Nkind_In (Deref, N_Indexed_Component, 13486 N_Selected_Component, 13487 N_Slice) 13488 loop 13489 Deref := Prefix (Deref); 13490 end loop; 13491 13492 -- Ada 2005: If we have a component or slice of a dereference, 13493 -- something like X.all.Y (2), and the type of X is access-to-constant, 13494 -- Is_Variable will return False, because it is indeed a constant 13495 -- view. But it might be a view of a variable object, so we want the 13496 -- following condition to be True in that case. 13497 13498 if Is_Variable (Object) 13499 or else (Ada_Version >= Ada_2005 13500 and then Nkind (Deref) = N_Explicit_Dereference) 13501 then 13502 if Nkind (Object) = N_Selected_Component then 13503 P := Prefix (Object); 13504 Prefix_Type := Etype (P); 13505 13506 if Is_Entity_Name (P) then 13507 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then 13508 Prefix_Type := Base_Type (Prefix_Type); 13509 end if; 13510 13511 if Is_Aliased (Entity (P)) then 13512 P_Aliased := True; 13513 end if; 13514 13515 -- A discriminant check on a selected component may be expanded 13516 -- into a dereference when removing side effects. Recover the 13517 -- original node and its type, which may be unconstrained. 13518 13519 elsif Nkind (P) = N_Explicit_Dereference 13520 and then not (Comes_From_Source (P)) 13521 then 13522 P := Original_Node (P); 13523 Prefix_Type := Etype (P); 13524 13525 else 13526 -- Check for prefix being an aliased component??? 13527 13528 null; 13529 13530 end if; 13531 13532 -- A heap object is constrained by its initial value 13533 13534 -- Ada 2005 (AI-363): Always assume the object could be mutable in 13535 -- the dereferenced case, since the access value might denote an 13536 -- unconstrained aliased object, whereas in Ada 95 the designated 13537 -- object is guaranteed to be constrained. A worst-case assumption 13538 -- has to apply in Ada 2005 because we can't tell at compile 13539 -- time whether the object is "constrained by its initial value", 13540 -- despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic 13541 -- rules (these rules are acknowledged to need fixing). We don't 13542 -- impose this more stringent checking for earlier Ada versions or 13543 -- when Relaxed_RM_Semantics applies (the latter for CodePeer's 13544 -- benefit, though it's unclear on why using -gnat95 would not be 13545 -- sufficient???). 13546 13547 if Ada_Version < Ada_2005 or else Relaxed_RM_Semantics then 13548 if Is_Access_Type (Prefix_Type) 13549 or else Nkind (P) = N_Explicit_Dereference 13550 then 13551 return False; 13552 end if; 13553 13554 else pragma Assert (Ada_Version >= Ada_2005); 13555 if Is_Access_Type (Prefix_Type) then 13556 13557 -- If the access type is pool-specific, and there is no 13558 -- constrained partial view of the designated type, then the 13559 -- designated object is known to be constrained. 13560 13561 if Ekind (Prefix_Type) = E_Access_Type 13562 and then not Object_Type_Has_Constrained_Partial_View 13563 (Typ => Designated_Type (Prefix_Type), 13564 Scop => Current_Scope) 13565 then 13566 return False; 13567 13568 -- Otherwise (general access type, or there is a constrained 13569 -- partial view of the designated type), we need to check 13570 -- based on the designated type. 13571 13572 else 13573 Prefix_Type := Designated_Type (Prefix_Type); 13574 end if; 13575 end if; 13576 end if; 13577 13578 Comp := 13579 Original_Record_Component (Entity (Selector_Name (Object))); 13580 13581 -- As per AI-0017, the renaming is illegal in a generic body, even 13582 -- if the subtype is indefinite. 13583 13584 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable 13585 13586 if not Is_Constrained (Prefix_Type) 13587 and then (Is_Definite_Subtype (Prefix_Type) 13588 or else 13589 (Is_Generic_Type (Prefix_Type) 13590 and then Ekind (Current_Scope) = E_Generic_Package 13591 and then In_Package_Body (Current_Scope))) 13592 13593 and then (Is_Declared_Within_Variant (Comp) 13594 or else Has_Discriminant_Dependent_Constraint (Comp)) 13595 and then (not P_Aliased or else Ada_Version >= Ada_2005) 13596 then 13597 return True; 13598 13599 -- If the prefix is of an access type at this point, then we want 13600 -- to return False, rather than calling this function recursively 13601 -- on the access object (which itself might be a discriminant- 13602 -- dependent component of some other object, but that isn't 13603 -- relevant to checking the object passed to us). This avoids 13604 -- issuing wrong errors when compiling with -gnatc, where there 13605 -- can be implicit dereferences that have not been expanded. 13606 13607 elsif Is_Access_Type (Etype (Prefix (Object))) then 13608 return False; 13609 13610 else 13611 return 13612 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 13613 end if; 13614 13615 elsif Nkind (Object) = N_Indexed_Component 13616 or else Nkind (Object) = N_Slice 13617 then 13618 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 13619 13620 -- A type conversion that Is_Variable is a view conversion: 13621 -- go back to the denoted object. 13622 13623 elsif Nkind (Object) = N_Type_Conversion then 13624 return 13625 Is_Dependent_Component_Of_Mutable_Object (Expression (Object)); 13626 end if; 13627 end if; 13628 13629 return False; 13630 end Is_Dependent_Component_Of_Mutable_Object; 13631 13632 --------------------- 13633 -- Is_Dereferenced -- 13634 --------------------- 13635 13636 function Is_Dereferenced (N : Node_Id) return Boolean is 13637 P : constant Node_Id := Parent (N); 13638 begin 13639 return Nkind_In (P, N_Selected_Component, 13640 N_Explicit_Dereference, 13641 N_Indexed_Component, 13642 N_Slice) 13643 and then Prefix (P) = N; 13644 end Is_Dereferenced; 13645 13646 ---------------------- 13647 -- Is_Descendant_Of -- 13648 ---------------------- 13649 13650 function Is_Descendant_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is 13651 T : Entity_Id; 13652 Etyp : Entity_Id; 13653 13654 begin 13655 pragma Assert (Nkind (T1) in N_Entity); 13656 pragma Assert (Nkind (T2) in N_Entity); 13657 13658 T := Base_Type (T1); 13659 13660 -- Immediate return if the types match 13661 13662 if T = T2 then 13663 return True; 13664 13665 -- Comment needed here ??? 13666 13667 elsif Ekind (T) = E_Class_Wide_Type then 13668 return Etype (T) = T2; 13669 13670 -- All other cases 13671 13672 else 13673 loop 13674 Etyp := Etype (T); 13675 13676 -- Done if we found the type we are looking for 13677 13678 if Etyp = T2 then 13679 return True; 13680 13681 -- Done if no more derivations to check 13682 13683 elsif T = T1 13684 or else T = Etyp 13685 then 13686 return False; 13687 13688 -- Following test catches error cases resulting from prev errors 13689 13690 elsif No (Etyp) then 13691 return False; 13692 13693 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then 13694 return False; 13695 13696 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then 13697 return False; 13698 end if; 13699 13700 T := Base_Type (Etyp); 13701 end loop; 13702 end if; 13703 end Is_Descendant_Of; 13704 13705 ---------------------------------------- 13706 -- Is_Descendant_Of_Suspension_Object -- 13707 ---------------------------------------- 13708 13709 function Is_Descendant_Of_Suspension_Object 13710 (Typ : Entity_Id) return Boolean 13711 is 13712 Cur_Typ : Entity_Id; 13713 Par_Typ : Entity_Id; 13714 13715 begin 13716 -- Climb the type derivation chain checking each parent type against 13717 -- Suspension_Object. 13718 13719 Cur_Typ := Base_Type (Typ); 13720 while Present (Cur_Typ) loop 13721 Par_Typ := Etype (Cur_Typ); 13722 13723 -- The current type is a match 13724 13725 if Is_Suspension_Object (Cur_Typ) then 13726 return True; 13727 13728 -- Stop the traversal once the root of the derivation chain has been 13729 -- reached. In that case the current type is its own base type. 13730 13731 elsif Cur_Typ = Par_Typ then 13732 exit; 13733 end if; 13734 13735 Cur_Typ := Base_Type (Par_Typ); 13736 end loop; 13737 13738 return False; 13739 end Is_Descendant_Of_Suspension_Object; 13740 13741 --------------------------------------------- 13742 -- Is_Double_Precision_Floating_Point_Type -- 13743 --------------------------------------------- 13744 13745 function Is_Double_Precision_Floating_Point_Type 13746 (E : Entity_Id) return Boolean is 13747 begin 13748 return Is_Floating_Point_Type (E) 13749 and then Machine_Radix_Value (E) = Uint_2 13750 and then Machine_Mantissa_Value (E) = UI_From_Int (53) 13751 and then Machine_Emax_Value (E) = Uint_2 ** Uint_10 13752 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_10); 13753 end Is_Double_Precision_Floating_Point_Type; 13754 13755 ----------------------------- 13756 -- Is_Effectively_Volatile -- 13757 ----------------------------- 13758 13759 function Is_Effectively_Volatile (Id : Entity_Id) return Boolean is 13760 begin 13761 if Is_Type (Id) then 13762 13763 -- An arbitrary type is effectively volatile when it is subject to 13764 -- pragma Atomic or Volatile. 13765 13766 if Is_Volatile (Id) then 13767 return True; 13768 13769 -- An array type is effectively volatile when it is subject to pragma 13770 -- Atomic_Components or Volatile_Components or its component type is 13771 -- effectively volatile. 13772 13773 elsif Is_Array_Type (Id) then 13774 declare 13775 Anc : Entity_Id := Base_Type (Id); 13776 begin 13777 if Is_Private_Type (Anc) then 13778 Anc := Full_View (Anc); 13779 end if; 13780 13781 -- Test for presence of ancestor, as the full view of a private 13782 -- type may be missing in case of error. 13783 13784 return 13785 Has_Volatile_Components (Id) 13786 or else 13787 (Present (Anc) 13788 and then Is_Effectively_Volatile (Component_Type (Anc))); 13789 end; 13790 13791 -- A protected type is always volatile 13792 13793 elsif Is_Protected_Type (Id) then 13794 return True; 13795 13796 -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is 13797 -- automatically volatile. 13798 13799 elsif Is_Descendant_Of_Suspension_Object (Id) then 13800 return True; 13801 13802 -- Otherwise the type is not effectively volatile 13803 13804 else 13805 return False; 13806 end if; 13807 13808 -- Otherwise Id denotes an object 13809 13810 else 13811 return 13812 Is_Volatile (Id) 13813 or else Has_Volatile_Components (Id) 13814 or else Is_Effectively_Volatile (Etype (Id)); 13815 end if; 13816 end Is_Effectively_Volatile; 13817 13818 ------------------------------------ 13819 -- Is_Effectively_Volatile_Object -- 13820 ------------------------------------ 13821 13822 function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean is 13823 begin 13824 if Is_Entity_Name (N) then 13825 return Is_Effectively_Volatile (Entity (N)); 13826 13827 elsif Nkind (N) = N_Indexed_Component then 13828 return Is_Effectively_Volatile_Object (Prefix (N)); 13829 13830 elsif Nkind (N) = N_Selected_Component then 13831 return 13832 Is_Effectively_Volatile_Object (Prefix (N)) 13833 or else 13834 Is_Effectively_Volatile_Object (Selector_Name (N)); 13835 13836 else 13837 return False; 13838 end if; 13839 end Is_Effectively_Volatile_Object; 13840 13841 ------------------- 13842 -- Is_Entry_Body -- 13843 ------------------- 13844 13845 function Is_Entry_Body (Id : Entity_Id) return Boolean is 13846 begin 13847 return 13848 Ekind_In (Id, E_Entry, E_Entry_Family) 13849 and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Body; 13850 end Is_Entry_Body; 13851 13852 -------------------------- 13853 -- Is_Entry_Declaration -- 13854 -------------------------- 13855 13856 function Is_Entry_Declaration (Id : Entity_Id) return Boolean is 13857 begin 13858 return 13859 Ekind_In (Id, E_Entry, E_Entry_Family) 13860 and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Declaration; 13861 end Is_Entry_Declaration; 13862 13863 ------------------------------------ 13864 -- Is_Expanded_Priority_Attribute -- 13865 ------------------------------------ 13866 13867 function Is_Expanded_Priority_Attribute (E : Entity_Id) return Boolean is 13868 begin 13869 return 13870 Nkind (E) = N_Function_Call 13871 and then not Configurable_Run_Time_Mode 13872 and then (Entity (Name (E)) = RTE (RE_Get_Ceiling) 13873 or else Entity (Name (E)) = RTE (RO_PE_Get_Ceiling)); 13874 end Is_Expanded_Priority_Attribute; 13875 13876 ---------------------------- 13877 -- Is_Expression_Function -- 13878 ---------------------------- 13879 13880 function Is_Expression_Function (Subp : Entity_Id) return Boolean is 13881 begin 13882 if Ekind_In (Subp, E_Function, E_Subprogram_Body) then 13883 return 13884 Nkind (Original_Node (Unit_Declaration_Node (Subp))) = 13885 N_Expression_Function; 13886 else 13887 return False; 13888 end if; 13889 end Is_Expression_Function; 13890 13891 ------------------------------------------ 13892 -- Is_Expression_Function_Or_Completion -- 13893 ------------------------------------------ 13894 13895 function Is_Expression_Function_Or_Completion 13896 (Subp : Entity_Id) return Boolean 13897 is 13898 Subp_Decl : Node_Id; 13899 13900 begin 13901 if Ekind (Subp) = E_Function then 13902 Subp_Decl := Unit_Declaration_Node (Subp); 13903 13904 -- The function declaration is either an expression function or is 13905 -- completed by an expression function body. 13906 13907 return 13908 Is_Expression_Function (Subp) 13909 or else (Nkind (Subp_Decl) = N_Subprogram_Declaration 13910 and then Present (Corresponding_Body (Subp_Decl)) 13911 and then Is_Expression_Function 13912 (Corresponding_Body (Subp_Decl))); 13913 13914 elsif Ekind (Subp) = E_Subprogram_Body then 13915 return Is_Expression_Function (Subp); 13916 13917 else 13918 return False; 13919 end if; 13920 end Is_Expression_Function_Or_Completion; 13921 13922 ----------------------- 13923 -- Is_EVF_Expression -- 13924 ----------------------- 13925 13926 function Is_EVF_Expression (N : Node_Id) return Boolean is 13927 Orig_N : constant Node_Id := Original_Node (N); 13928 Alt : Node_Id; 13929 Expr : Node_Id; 13930 Id : Entity_Id; 13931 13932 begin 13933 -- Detect a reference to a formal parameter of a specific tagged type 13934 -- whose related subprogram is subject to pragma Expresions_Visible with 13935 -- value "False". 13936 13937 if Is_Entity_Name (N) and then Present (Entity (N)) then 13938 Id := Entity (N); 13939 13940 return 13941 Is_Formal (Id) 13942 and then Is_Specific_Tagged_Type (Etype (Id)) 13943 and then Extensions_Visible_Status (Id) = 13944 Extensions_Visible_False; 13945 13946 -- A case expression is an EVF expression when it contains at least one 13947 -- EVF dependent_expression. Note that a case expression may have been 13948 -- expanded, hence the use of Original_Node. 13949 13950 elsif Nkind (Orig_N) = N_Case_Expression then 13951 Alt := First (Alternatives (Orig_N)); 13952 while Present (Alt) loop 13953 if Is_EVF_Expression (Expression (Alt)) then 13954 return True; 13955 end if; 13956 13957 Next (Alt); 13958 end loop; 13959 13960 -- An if expression is an EVF expression when it contains at least one 13961 -- EVF dependent_expression. Note that an if expression may have been 13962 -- expanded, hence the use of Original_Node. 13963 13964 elsif Nkind (Orig_N) = N_If_Expression then 13965 Expr := Next (First (Expressions (Orig_N))); 13966 while Present (Expr) loop 13967 if Is_EVF_Expression (Expr) then 13968 return True; 13969 end if; 13970 13971 Next (Expr); 13972 end loop; 13973 13974 -- A qualified expression or a type conversion is an EVF expression when 13975 -- its operand is an EVF expression. 13976 13977 elsif Nkind_In (N, N_Qualified_Expression, 13978 N_Unchecked_Type_Conversion, 13979 N_Type_Conversion) 13980 then 13981 return Is_EVF_Expression (Expression (N)); 13982 13983 -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when 13984 -- their prefix denotes an EVF expression. 13985 13986 elsif Nkind (N) = N_Attribute_Reference 13987 and then Nam_In (Attribute_Name (N), Name_Loop_Entry, 13988 Name_Old, 13989 Name_Update) 13990 then 13991 return Is_EVF_Expression (Prefix (N)); 13992 end if; 13993 13994 return False; 13995 end Is_EVF_Expression; 13996 13997 -------------- 13998 -- Is_False -- 13999 -------------- 14000 14001 function Is_False (U : Uint) return Boolean is 14002 begin 14003 return (U = 0); 14004 end Is_False; 14005 14006 --------------------------- 14007 -- Is_Fixed_Model_Number -- 14008 --------------------------- 14009 14010 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is 14011 S : constant Ureal := Small_Value (T); 14012 M : Urealp.Save_Mark; 14013 R : Boolean; 14014 14015 begin 14016 M := Urealp.Mark; 14017 R := (U = UR_Trunc (U / S) * S); 14018 Urealp.Release (M); 14019 return R; 14020 end Is_Fixed_Model_Number; 14021 14022 ------------------------------- 14023 -- Is_Fully_Initialized_Type -- 14024 ------------------------------- 14025 14026 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is 14027 begin 14028 -- Scalar types 14029 14030 if Is_Scalar_Type (Typ) then 14031 14032 -- A scalar type with an aspect Default_Value is fully initialized 14033 14034 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization 14035 -- of a scalar type, but we don't take that into account here, since 14036 -- we don't want these to affect warnings. 14037 14038 return Has_Default_Aspect (Typ); 14039 14040 elsif Is_Access_Type (Typ) then 14041 return True; 14042 14043 elsif Is_Array_Type (Typ) then 14044 if Is_Fully_Initialized_Type (Component_Type (Typ)) 14045 or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ)) 14046 then 14047 return True; 14048 end if; 14049 14050 -- An interesting case, if we have a constrained type one of whose 14051 -- bounds is known to be null, then there are no elements to be 14052 -- initialized, so all the elements are initialized. 14053 14054 if Is_Constrained (Typ) then 14055 declare 14056 Indx : Node_Id; 14057 Indx_Typ : Entity_Id; 14058 Lbd, Hbd : Node_Id; 14059 14060 begin 14061 Indx := First_Index (Typ); 14062 while Present (Indx) loop 14063 if Etype (Indx) = Any_Type then 14064 return False; 14065 14066 -- If index is a range, use directly 14067 14068 elsif Nkind (Indx) = N_Range then 14069 Lbd := Low_Bound (Indx); 14070 Hbd := High_Bound (Indx); 14071 14072 else 14073 Indx_Typ := Etype (Indx); 14074 14075 if Is_Private_Type (Indx_Typ) then 14076 Indx_Typ := Full_View (Indx_Typ); 14077 end if; 14078 14079 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then 14080 return False; 14081 else 14082 Lbd := Type_Low_Bound (Indx_Typ); 14083 Hbd := Type_High_Bound (Indx_Typ); 14084 end if; 14085 end if; 14086 14087 if Compile_Time_Known_Value (Lbd) 14088 and then 14089 Compile_Time_Known_Value (Hbd) 14090 then 14091 if Expr_Value (Hbd) < Expr_Value (Lbd) then 14092 return True; 14093 end if; 14094 end if; 14095 14096 Next_Index (Indx); 14097 end loop; 14098 end; 14099 end if; 14100 14101 -- If no null indexes, then type is not fully initialized 14102 14103 return False; 14104 14105 -- Record types 14106 14107 elsif Is_Record_Type (Typ) then 14108 if Has_Discriminants (Typ) 14109 and then 14110 Present (Discriminant_Default_Value (First_Discriminant (Typ))) 14111 and then Is_Fully_Initialized_Variant (Typ) 14112 then 14113 return True; 14114 end if; 14115 14116 -- We consider bounded string types to be fully initialized, because 14117 -- otherwise we get false alarms when the Data component is not 14118 -- default-initialized. 14119 14120 if Is_Bounded_String (Typ) then 14121 return True; 14122 end if; 14123 14124 -- Controlled records are considered to be fully initialized if 14125 -- there is a user defined Initialize routine. This may not be 14126 -- entirely correct, but as the spec notes, we are guessing here 14127 -- what is best from the point of view of issuing warnings. 14128 14129 if Is_Controlled (Typ) then 14130 declare 14131 Utyp : constant Entity_Id := Underlying_Type (Typ); 14132 14133 begin 14134 if Present (Utyp) then 14135 declare 14136 Init : constant Entity_Id := 14137 (Find_Optional_Prim_Op 14138 (Underlying_Type (Typ), Name_Initialize)); 14139 14140 begin 14141 if Present (Init) 14142 and then Comes_From_Source (Init) 14143 and then not In_Predefined_Unit (Init) 14144 then 14145 return True; 14146 14147 elsif Has_Null_Extension (Typ) 14148 and then 14149 Is_Fully_Initialized_Type 14150 (Etype (Base_Type (Typ))) 14151 then 14152 return True; 14153 end if; 14154 end; 14155 end if; 14156 end; 14157 end if; 14158 14159 -- Otherwise see if all record components are initialized 14160 14161 declare 14162 Ent : Entity_Id; 14163 14164 begin 14165 Ent := First_Entity (Typ); 14166 while Present (Ent) loop 14167 if Ekind (Ent) = E_Component 14168 and then (No (Parent (Ent)) 14169 or else No (Expression (Parent (Ent)))) 14170 and then not Is_Fully_Initialized_Type (Etype (Ent)) 14171 14172 -- Special VM case for tag components, which need to be 14173 -- defined in this case, but are never initialized as VMs 14174 -- are using other dispatching mechanisms. Ignore this 14175 -- uninitialized case. Note that this applies both to the 14176 -- uTag entry and the main vtable pointer (CPP_Class case). 14177 14178 and then (Tagged_Type_Expansion or else not Is_Tag (Ent)) 14179 then 14180 return False; 14181 end if; 14182 14183 Next_Entity (Ent); 14184 end loop; 14185 end; 14186 14187 -- No uninitialized components, so type is fully initialized. 14188 -- Note that this catches the case of no components as well. 14189 14190 return True; 14191 14192 elsif Is_Concurrent_Type (Typ) then 14193 return True; 14194 14195 elsif Is_Private_Type (Typ) then 14196 declare 14197 U : constant Entity_Id := Underlying_Type (Typ); 14198 14199 begin 14200 if No (U) then 14201 return False; 14202 else 14203 return Is_Fully_Initialized_Type (U); 14204 end if; 14205 end; 14206 14207 else 14208 return False; 14209 end if; 14210 end Is_Fully_Initialized_Type; 14211 14212 ---------------------------------- 14213 -- Is_Fully_Initialized_Variant -- 14214 ---------------------------------- 14215 14216 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is 14217 Loc : constant Source_Ptr := Sloc (Typ); 14218 Constraints : constant List_Id := New_List; 14219 Components : constant Elist_Id := New_Elmt_List; 14220 Comp_Elmt : Elmt_Id; 14221 Comp_Id : Node_Id; 14222 Comp_List : Node_Id; 14223 Discr : Entity_Id; 14224 Discr_Val : Node_Id; 14225 14226 Report_Errors : Boolean; 14227 pragma Warnings (Off, Report_Errors); 14228 14229 begin 14230 if Serious_Errors_Detected > 0 then 14231 return False; 14232 end if; 14233 14234 if Is_Record_Type (Typ) 14235 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration 14236 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition 14237 then 14238 Comp_List := Component_List (Type_Definition (Parent (Typ))); 14239 14240 Discr := First_Discriminant (Typ); 14241 while Present (Discr) loop 14242 if Nkind (Parent (Discr)) = N_Discriminant_Specification then 14243 Discr_Val := Expression (Parent (Discr)); 14244 14245 if Present (Discr_Val) 14246 and then Is_OK_Static_Expression (Discr_Val) 14247 then 14248 Append_To (Constraints, 14249 Make_Component_Association (Loc, 14250 Choices => New_List (New_Occurrence_Of (Discr, Loc)), 14251 Expression => New_Copy (Discr_Val))); 14252 else 14253 return False; 14254 end if; 14255 else 14256 return False; 14257 end if; 14258 14259 Next_Discriminant (Discr); 14260 end loop; 14261 14262 Gather_Components 14263 (Typ => Typ, 14264 Comp_List => Comp_List, 14265 Governed_By => Constraints, 14266 Into => Components, 14267 Report_Errors => Report_Errors); 14268 14269 -- Check that each component present is fully initialized 14270 14271 Comp_Elmt := First_Elmt (Components); 14272 while Present (Comp_Elmt) loop 14273 Comp_Id := Node (Comp_Elmt); 14274 14275 if Ekind (Comp_Id) = E_Component 14276 and then (No (Parent (Comp_Id)) 14277 or else No (Expression (Parent (Comp_Id)))) 14278 and then not Is_Fully_Initialized_Type (Etype (Comp_Id)) 14279 then 14280 return False; 14281 end if; 14282 14283 Next_Elmt (Comp_Elmt); 14284 end loop; 14285 14286 return True; 14287 14288 elsif Is_Private_Type (Typ) then 14289 declare 14290 U : constant Entity_Id := Underlying_Type (Typ); 14291 14292 begin 14293 if No (U) then 14294 return False; 14295 else 14296 return Is_Fully_Initialized_Variant (U); 14297 end if; 14298 end; 14299 14300 else 14301 return False; 14302 end if; 14303 end Is_Fully_Initialized_Variant; 14304 14305 ------------------------------------ 14306 -- Is_Generic_Declaration_Or_Body -- 14307 ------------------------------------ 14308 14309 function Is_Generic_Declaration_Or_Body (Decl : Node_Id) return Boolean is 14310 Spec_Decl : Node_Id; 14311 14312 begin 14313 -- Package/subprogram body 14314 14315 if Nkind_In (Decl, N_Package_Body, N_Subprogram_Body) 14316 and then Present (Corresponding_Spec (Decl)) 14317 then 14318 Spec_Decl := Unit_Declaration_Node (Corresponding_Spec (Decl)); 14319 14320 -- Package/subprogram body stub 14321 14322 elsif Nkind_In (Decl, N_Package_Body_Stub, N_Subprogram_Body_Stub) 14323 and then Present (Corresponding_Spec_Of_Stub (Decl)) 14324 then 14325 Spec_Decl := 14326 Unit_Declaration_Node (Corresponding_Spec_Of_Stub (Decl)); 14327 14328 -- All other cases 14329 14330 else 14331 Spec_Decl := Decl; 14332 end if; 14333 14334 -- Rather than inspecting the defining entity of the spec declaration, 14335 -- look at its Nkind. This takes care of the case where the analysis of 14336 -- a generic body modifies the Ekind of its spec to allow for recursive 14337 -- calls. 14338 14339 return 14340 Nkind_In (Spec_Decl, N_Generic_Package_Declaration, 14341 N_Generic_Subprogram_Declaration); 14342 end Is_Generic_Declaration_Or_Body; 14343 14344 ---------------------------- 14345 -- Is_Inherited_Operation -- 14346 ---------------------------- 14347 14348 function Is_Inherited_Operation (E : Entity_Id) return Boolean is 14349 pragma Assert (Is_Overloadable (E)); 14350 Kind : constant Node_Kind := Nkind (Parent (E)); 14351 begin 14352 return Kind = N_Full_Type_Declaration 14353 or else Kind = N_Private_Extension_Declaration 14354 or else Kind = N_Subtype_Declaration 14355 or else (Ekind (E) = E_Enumeration_Literal 14356 and then Is_Derived_Type (Etype (E))); 14357 end Is_Inherited_Operation; 14358 14359 ------------------------------------- 14360 -- Is_Inherited_Operation_For_Type -- 14361 ------------------------------------- 14362 14363 function Is_Inherited_Operation_For_Type 14364 (E : Entity_Id; 14365 Typ : Entity_Id) return Boolean 14366 is 14367 begin 14368 -- Check that the operation has been created by the type declaration 14369 14370 return Is_Inherited_Operation (E) 14371 and then Defining_Identifier (Parent (E)) = Typ; 14372 end Is_Inherited_Operation_For_Type; 14373 14374 -------------------------------------- 14375 -- Is_Inlinable_Expression_Function -- 14376 -------------------------------------- 14377 14378 function Is_Inlinable_Expression_Function 14379 (Subp : Entity_Id) return Boolean 14380 is 14381 Return_Expr : Node_Id; 14382 14383 begin 14384 if Is_Expression_Function_Or_Completion (Subp) 14385 and then Has_Pragma_Inline_Always (Subp) 14386 and then Needs_No_Actuals (Subp) 14387 and then No (Contract (Subp)) 14388 and then not Is_Dispatching_Operation (Subp) 14389 and then Needs_Finalization (Etype (Subp)) 14390 and then not Is_Class_Wide_Type (Etype (Subp)) 14391 and then not (Has_Invariants (Etype (Subp))) 14392 and then Present (Subprogram_Body (Subp)) 14393 and then Was_Expression_Function (Subprogram_Body (Subp)) 14394 then 14395 Return_Expr := Expression_Of_Expression_Function (Subp); 14396 14397 -- The returned object must not have a qualified expression and its 14398 -- nominal subtype must be statically compatible with the result 14399 -- subtype of the expression function. 14400 14401 return 14402 Nkind (Return_Expr) = N_Identifier 14403 and then Etype (Return_Expr) = Etype (Subp); 14404 end if; 14405 14406 return False; 14407 end Is_Inlinable_Expression_Function; 14408 14409 ----------------- 14410 -- Is_Iterator -- 14411 ----------------- 14412 14413 function Is_Iterator (Typ : Entity_Id) return Boolean is 14414 function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean; 14415 -- Determine whether type Iter_Typ is a predefined forward or reversible 14416 -- iterator. 14417 14418 ---------------------- 14419 -- Denotes_Iterator -- 14420 ---------------------- 14421 14422 function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean is 14423 begin 14424 -- Check that the name matches, and that the ultimate ancestor is in 14425 -- a predefined unit, i.e the one that declares iterator interfaces. 14426 14427 return 14428 Nam_In (Chars (Iter_Typ), Name_Forward_Iterator, 14429 Name_Reversible_Iterator) 14430 and then In_Predefined_Unit (Root_Type (Iter_Typ)); 14431 end Denotes_Iterator; 14432 14433 -- Local variables 14434 14435 Iface_Elmt : Elmt_Id; 14436 Ifaces : Elist_Id; 14437 14438 -- Start of processing for Is_Iterator 14439 14440 begin 14441 -- The type may be a subtype of a descendant of the proper instance of 14442 -- the predefined interface type, so we must use the root type of the 14443 -- given type. The same is done for Is_Reversible_Iterator. 14444 14445 if Is_Class_Wide_Type (Typ) 14446 and then Denotes_Iterator (Root_Type (Typ)) 14447 then 14448 return True; 14449 14450 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then 14451 return False; 14452 14453 elsif Present (Find_Value_Of_Aspect (Typ, Aspect_Iterable)) then 14454 return True; 14455 14456 else 14457 Collect_Interfaces (Typ, Ifaces); 14458 14459 Iface_Elmt := First_Elmt (Ifaces); 14460 while Present (Iface_Elmt) loop 14461 if Denotes_Iterator (Node (Iface_Elmt)) then 14462 return True; 14463 end if; 14464 14465 Next_Elmt (Iface_Elmt); 14466 end loop; 14467 14468 return False; 14469 end if; 14470 end Is_Iterator; 14471 14472 ---------------------------- 14473 -- Is_Iterator_Over_Array -- 14474 ---------------------------- 14475 14476 function Is_Iterator_Over_Array (N : Node_Id) return Boolean is 14477 Container : constant Node_Id := Name (N); 14478 Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); 14479 begin 14480 return Is_Array_Type (Container_Typ); 14481 end Is_Iterator_Over_Array; 14482 14483 ------------ 14484 -- Is_LHS -- 14485 ------------ 14486 14487 -- We seem to have a lot of overlapping functions that do similar things 14488 -- (testing for left hand sides or lvalues???). 14489 14490 function Is_LHS (N : Node_Id) return Is_LHS_Result is 14491 P : constant Node_Id := Parent (N); 14492 14493 begin 14494 -- Return True if we are the left hand side of an assignment statement 14495 14496 if Nkind (P) = N_Assignment_Statement then 14497 if Name (P) = N then 14498 return Yes; 14499 else 14500 return No; 14501 end if; 14502 14503 -- Case of prefix of indexed or selected component or slice 14504 14505 elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice) 14506 and then N = Prefix (P) 14507 then 14508 -- Here we have the case where the parent P is N.Q or N(Q .. R). 14509 -- If P is an LHS, then N is also effectively an LHS, but there 14510 -- is an important exception. If N is of an access type, then 14511 -- what we really have is N.all.Q (or N.all(Q .. R)). In either 14512 -- case this makes N.all a left hand side but not N itself. 14513 14514 -- If we don't know the type yet, this is the case where we return 14515 -- Unknown, since the answer depends on the type which is unknown. 14516 14517 if No (Etype (N)) then 14518 return Unknown; 14519 14520 -- We have an Etype set, so we can check it 14521 14522 elsif Is_Access_Type (Etype (N)) then 14523 return No; 14524 14525 -- OK, not access type case, so just test whole expression 14526 14527 else 14528 return Is_LHS (P); 14529 end if; 14530 14531 -- All other cases are not left hand sides 14532 14533 else 14534 return No; 14535 end if; 14536 end Is_LHS; 14537 14538 ----------------------------- 14539 -- Is_Library_Level_Entity -- 14540 ----------------------------- 14541 14542 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is 14543 begin 14544 -- The following is a small optimization, and it also properly handles 14545 -- discriminals, which in task bodies might appear in expressions before 14546 -- the corresponding procedure has been created, and which therefore do 14547 -- not have an assigned scope. 14548 14549 if Is_Formal (E) then 14550 return False; 14551 end if; 14552 14553 -- Normal test is simply that the enclosing dynamic scope is Standard 14554 14555 return Enclosing_Dynamic_Scope (E) = Standard_Standard; 14556 end Is_Library_Level_Entity; 14557 14558 -------------------------------- 14559 -- Is_Limited_Class_Wide_Type -- 14560 -------------------------------- 14561 14562 function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is 14563 begin 14564 return 14565 Is_Class_Wide_Type (Typ) 14566 and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ)); 14567 end Is_Limited_Class_Wide_Type; 14568 14569 --------------------------------- 14570 -- Is_Local_Variable_Reference -- 14571 --------------------------------- 14572 14573 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is 14574 begin 14575 if not Is_Entity_Name (Expr) then 14576 return False; 14577 14578 else 14579 declare 14580 Ent : constant Entity_Id := Entity (Expr); 14581 Sub : constant Entity_Id := Enclosing_Subprogram (Ent); 14582 begin 14583 if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then 14584 return False; 14585 else 14586 return Present (Sub) and then Sub = Current_Subprogram; 14587 end if; 14588 end; 14589 end if; 14590 end Is_Local_Variable_Reference; 14591 14592 ----------------------- 14593 -- Is_Name_Reference -- 14594 ----------------------- 14595 14596 function Is_Name_Reference (N : Node_Id) return Boolean is 14597 begin 14598 if Is_Entity_Name (N) then 14599 return Present (Entity (N)) and then Is_Object (Entity (N)); 14600 end if; 14601 14602 case Nkind (N) is 14603 when N_Indexed_Component 14604 | N_Slice 14605 => 14606 return 14607 Is_Name_Reference (Prefix (N)) 14608 or else Is_Access_Type (Etype (Prefix (N))); 14609 14610 -- Attributes 'Input, 'Old and 'Result produce objects 14611 14612 when N_Attribute_Reference => 14613 return 14614 Nam_In (Attribute_Name (N), Name_Input, Name_Old, Name_Result); 14615 14616 when N_Selected_Component => 14617 return 14618 Is_Name_Reference (Selector_Name (N)) 14619 and then 14620 (Is_Name_Reference (Prefix (N)) 14621 or else Is_Access_Type (Etype (Prefix (N)))); 14622 14623 when N_Explicit_Dereference => 14624 return True; 14625 14626 -- A view conversion of a tagged name is a name reference 14627 14628 when N_Type_Conversion => 14629 return 14630 Is_Tagged_Type (Etype (Subtype_Mark (N))) 14631 and then Is_Tagged_Type (Etype (Expression (N))) 14632 and then Is_Name_Reference (Expression (N)); 14633 14634 -- An unchecked type conversion is considered to be a name if the 14635 -- operand is a name (this construction arises only as a result of 14636 -- expansion activities). 14637 14638 when N_Unchecked_Type_Conversion => 14639 return Is_Name_Reference (Expression (N)); 14640 14641 when others => 14642 return False; 14643 end case; 14644 end Is_Name_Reference; 14645 14646 ------------------------------------ 14647 -- Is_Non_Preelaborable_Construct -- 14648 ------------------------------------ 14649 14650 function Is_Non_Preelaborable_Construct (N : Node_Id) return Boolean is 14651 14652 -- NOTE: the routines within Is_Non_Preelaborable_Construct are 14653 -- intentionally unnested to avoid deep indentation of code. 14654 14655 Non_Preelaborable : exception; 14656 -- This exception is raised when the construct violates preelaborability 14657 -- to terminate the recursion. 14658 14659 procedure Visit (Nod : Node_Id); 14660 -- Semantically inspect construct Nod to determine whether it violates 14661 -- preelaborability. This routine raises Non_Preelaborable. 14662 14663 procedure Visit_List (List : List_Id); 14664 pragma Inline (Visit_List); 14665 -- Invoke Visit on each element of list List. This routine raises 14666 -- Non_Preelaborable. 14667 14668 procedure Visit_Pragma (Prag : Node_Id); 14669 pragma Inline (Visit_Pragma); 14670 -- Semantically inspect pragma Prag to determine whether it violates 14671 -- preelaborability. This routine raises Non_Preelaborable. 14672 14673 procedure Visit_Subexpression (Expr : Node_Id); 14674 pragma Inline (Visit_Subexpression); 14675 -- Semantically inspect expression Expr to determine whether it violates 14676 -- preelaborability. This routine raises Non_Preelaborable. 14677 14678 ----------- 14679 -- Visit -- 14680 ----------- 14681 14682 procedure Visit (Nod : Node_Id) is 14683 begin 14684 case Nkind (Nod) is 14685 14686 -- Declarations 14687 14688 when N_Component_Declaration => 14689 14690 -- Defining_Identifier is left out because it is not relevant 14691 -- for preelaborability. 14692 14693 Visit (Component_Definition (Nod)); 14694 Visit (Expression (Nod)); 14695 14696 when N_Derived_Type_Definition => 14697 14698 -- Interface_List is left out because it is not relevant for 14699 -- preelaborability. 14700 14701 Visit (Record_Extension_Part (Nod)); 14702 Visit (Subtype_Indication (Nod)); 14703 14704 when N_Entry_Declaration => 14705 14706 -- A protected type with at leat one entry is not preelaborable 14707 -- while task types are never preelaborable. This renders entry 14708 -- declarations non-preelaborable. 14709 14710 raise Non_Preelaborable; 14711 14712 when N_Full_Type_Declaration => 14713 14714 -- Defining_Identifier and Discriminant_Specifications are left 14715 -- out because they are not relevant for preelaborability. 14716 14717 Visit (Type_Definition (Nod)); 14718 14719 when N_Function_Instantiation 14720 | N_Package_Instantiation 14721 | N_Procedure_Instantiation 14722 => 14723 -- Defining_Unit_Name and Name are left out because they are 14724 -- not relevant for preelaborability. 14725 14726 Visit_List (Generic_Associations (Nod)); 14727 14728 when N_Object_Declaration => 14729 14730 -- Defining_Identifier is left out because it is not relevant 14731 -- for preelaborability. 14732 14733 Visit (Object_Definition (Nod)); 14734 14735 if Has_Init_Expression (Nod) then 14736 Visit (Expression (Nod)); 14737 14738 elsif not Has_Preelaborable_Initialization 14739 (Etype (Defining_Entity (Nod))) 14740 then 14741 raise Non_Preelaborable; 14742 end if; 14743 14744 when N_Private_Extension_Declaration 14745 | N_Subtype_Declaration 14746 => 14747 -- Defining_Identifier, Discriminant_Specifications, and 14748 -- Interface_List are left out because they are not relevant 14749 -- for preelaborability. 14750 14751 Visit (Subtype_Indication (Nod)); 14752 14753 when N_Protected_Type_Declaration 14754 | N_Single_Protected_Declaration 14755 => 14756 -- Defining_Identifier, Discriminant_Specifications, and 14757 -- Interface_List are left out because they are not relevant 14758 -- for preelaborability. 14759 14760 Visit (Protected_Definition (Nod)); 14761 14762 -- A [single] task type is never preelaborable 14763 14764 when N_Single_Task_Declaration 14765 | N_Task_Type_Declaration 14766 => 14767 raise Non_Preelaborable; 14768 14769 -- Pragmas 14770 14771 when N_Pragma => 14772 Visit_Pragma (Nod); 14773 14774 -- Statements 14775 14776 when N_Statement_Other_Than_Procedure_Call => 14777 if Nkind (Nod) /= N_Null_Statement then 14778 raise Non_Preelaborable; 14779 end if; 14780 14781 -- Subexpressions 14782 14783 when N_Subexpr => 14784 Visit_Subexpression (Nod); 14785 14786 -- Special 14787 14788 when N_Access_To_Object_Definition => 14789 Visit (Subtype_Indication (Nod)); 14790 14791 when N_Case_Expression_Alternative => 14792 Visit (Expression (Nod)); 14793 Visit_List (Discrete_Choices (Nod)); 14794 14795 when N_Component_Definition => 14796 Visit (Access_Definition (Nod)); 14797 Visit (Subtype_Indication (Nod)); 14798 14799 when N_Component_List => 14800 Visit_List (Component_Items (Nod)); 14801 Visit (Variant_Part (Nod)); 14802 14803 when N_Constrained_Array_Definition => 14804 Visit_List (Discrete_Subtype_Definitions (Nod)); 14805 Visit (Component_Definition (Nod)); 14806 14807 when N_Delta_Constraint 14808 | N_Digits_Constraint 14809 => 14810 -- Delta_Expression and Digits_Expression are left out because 14811 -- they are not relevant for preelaborability. 14812 14813 Visit (Range_Constraint (Nod)); 14814 14815 when N_Discriminant_Specification => 14816 14817 -- Defining_Identifier and Expression are left out because they 14818 -- are not relevant for preelaborability. 14819 14820 Visit (Discriminant_Type (Nod)); 14821 14822 when N_Generic_Association => 14823 14824 -- Selector_Name is left out because it is not relevant for 14825 -- preelaborability. 14826 14827 Visit (Explicit_Generic_Actual_Parameter (Nod)); 14828 14829 when N_Index_Or_Discriminant_Constraint => 14830 Visit_List (Constraints (Nod)); 14831 14832 when N_Iterator_Specification => 14833 14834 -- Defining_Identifier is left out because it is not relevant 14835 -- for preelaborability. 14836 14837 Visit (Name (Nod)); 14838 Visit (Subtype_Indication (Nod)); 14839 14840 when N_Loop_Parameter_Specification => 14841 14842 -- Defining_Identifier is left out because it is not relevant 14843 -- for preelaborability. 14844 14845 Visit (Discrete_Subtype_Definition (Nod)); 14846 14847 when N_Protected_Definition => 14848 14849 -- End_Label is left out because it is not relevant for 14850 -- preelaborability. 14851 14852 Visit_List (Private_Declarations (Nod)); 14853 Visit_List (Visible_Declarations (Nod)); 14854 14855 when N_Range_Constraint => 14856 Visit (Range_Expression (Nod)); 14857 14858 when N_Record_Definition 14859 | N_Variant 14860 => 14861 -- End_Label, Discrete_Choices, and Interface_List are left out 14862 -- because they are not relevant for preelaborability. 14863 14864 Visit (Component_List (Nod)); 14865 14866 when N_Subtype_Indication => 14867 14868 -- Subtype_Mark is left out because it is not relevant for 14869 -- preelaborability. 14870 14871 Visit (Constraint (Nod)); 14872 14873 when N_Unconstrained_Array_Definition => 14874 14875 -- Subtype_Marks is left out because it is not relevant for 14876 -- preelaborability. 14877 14878 Visit (Component_Definition (Nod)); 14879 14880 when N_Variant_Part => 14881 14882 -- Name is left out because it is not relevant for 14883 -- preelaborability. 14884 14885 Visit_List (Variants (Nod)); 14886 14887 -- Default 14888 14889 when others => 14890 null; 14891 end case; 14892 end Visit; 14893 14894 ---------------- 14895 -- Visit_List -- 14896 ---------------- 14897 14898 procedure Visit_List (List : List_Id) is 14899 Nod : Node_Id; 14900 14901 begin 14902 if Present (List) then 14903 Nod := First (List); 14904 while Present (Nod) loop 14905 Visit (Nod); 14906 Next (Nod); 14907 end loop; 14908 end if; 14909 end Visit_List; 14910 14911 ------------------ 14912 -- Visit_Pragma -- 14913 ------------------ 14914 14915 procedure Visit_Pragma (Prag : Node_Id) is 14916 begin 14917 case Get_Pragma_Id (Prag) is 14918 when Pragma_Assert 14919 | Pragma_Assert_And_Cut 14920 | Pragma_Assume 14921 | Pragma_Async_Readers 14922 | Pragma_Async_Writers 14923 | Pragma_Attribute_Definition 14924 | Pragma_Check 14925 | Pragma_Constant_After_Elaboration 14926 | Pragma_CPU 14927 | Pragma_Deadline_Floor 14928 | Pragma_Dispatching_Domain 14929 | Pragma_Effective_Reads 14930 | Pragma_Effective_Writes 14931 | Pragma_Extensions_Visible 14932 | Pragma_Ghost 14933 | Pragma_Secondary_Stack_Size 14934 | Pragma_Task_Name 14935 | Pragma_Volatile_Function 14936 => 14937 Visit_List (Pragma_Argument_Associations (Prag)); 14938 14939 -- Default 14940 14941 when others => 14942 null; 14943 end case; 14944 end Visit_Pragma; 14945 14946 ------------------------- 14947 -- Visit_Subexpression -- 14948 ------------------------- 14949 14950 procedure Visit_Subexpression (Expr : Node_Id) is 14951 procedure Visit_Aggregate (Aggr : Node_Id); 14952 pragma Inline (Visit_Aggregate); 14953 -- Semantically inspect aggregate Aggr to determine whether it 14954 -- violates preelaborability. 14955 14956 --------------------- 14957 -- Visit_Aggregate -- 14958 --------------------- 14959 14960 procedure Visit_Aggregate (Aggr : Node_Id) is 14961 begin 14962 if not Is_Preelaborable_Aggregate (Aggr) then 14963 raise Non_Preelaborable; 14964 end if; 14965 end Visit_Aggregate; 14966 14967 -- Start of processing for Visit_Subexpression 14968 14969 begin 14970 case Nkind (Expr) is 14971 when N_Allocator 14972 | N_Qualified_Expression 14973 | N_Type_Conversion 14974 | N_Unchecked_Expression 14975 | N_Unchecked_Type_Conversion 14976 => 14977 -- Subpool_Handle_Name and Subtype_Mark are left out because 14978 -- they are not relevant for preelaborability. 14979 14980 Visit (Expression (Expr)); 14981 14982 when N_Aggregate 14983 | N_Extension_Aggregate 14984 => 14985 Visit_Aggregate (Expr); 14986 14987 when N_Attribute_Reference 14988 | N_Explicit_Dereference 14989 | N_Reference 14990 => 14991 -- Attribute_Name and Expressions are left out because they are 14992 -- not relevant for preelaborability. 14993 14994 Visit (Prefix (Expr)); 14995 14996 when N_Case_Expression => 14997 14998 -- End_Span is left out because it is not relevant for 14999 -- preelaborability. 15000 15001 Visit_List (Alternatives (Expr)); 15002 Visit (Expression (Expr)); 15003 15004 when N_Delta_Aggregate => 15005 Visit_Aggregate (Expr); 15006 Visit (Expression (Expr)); 15007 15008 when N_Expression_With_Actions => 15009 Visit_List (Actions (Expr)); 15010 Visit (Expression (Expr)); 15011 15012 when N_If_Expression => 15013 Visit_List (Expressions (Expr)); 15014 15015 when N_Quantified_Expression => 15016 Visit (Condition (Expr)); 15017 Visit (Iterator_Specification (Expr)); 15018 Visit (Loop_Parameter_Specification (Expr)); 15019 15020 when N_Range => 15021 Visit (High_Bound (Expr)); 15022 Visit (Low_Bound (Expr)); 15023 15024 when N_Slice => 15025 Visit (Discrete_Range (Expr)); 15026 Visit (Prefix (Expr)); 15027 15028 -- Default 15029 15030 when others => 15031 15032 -- The evaluation of an object name is not preelaborable, 15033 -- unless the name is a static expression (checked further 15034 -- below), or statically denotes a discriminant. 15035 15036 if Is_Entity_Name (Expr) then 15037 Object_Name : declare 15038 Id : constant Entity_Id := Entity (Expr); 15039 15040 begin 15041 if Is_Object (Id) then 15042 if Ekind (Id) = E_Discriminant then 15043 null; 15044 15045 elsif Ekind_In (Id, E_Constant, E_In_Parameter) 15046 and then Present (Discriminal_Link (Id)) 15047 then 15048 null; 15049 15050 else 15051 raise Non_Preelaborable; 15052 end if; 15053 end if; 15054 end Object_Name; 15055 15056 -- A non-static expression is not preelaborable 15057 15058 elsif not Is_OK_Static_Expression (Expr) then 15059 raise Non_Preelaborable; 15060 end if; 15061 end case; 15062 end Visit_Subexpression; 15063 15064 -- Start of processing for Is_Non_Preelaborable_Construct 15065 15066 begin 15067 Visit (N); 15068 15069 -- At this point it is known that the construct is preelaborable 15070 15071 return False; 15072 15073 exception 15074 15075 -- The elaboration of the construct performs an action which violates 15076 -- preelaborability. 15077 15078 when Non_Preelaborable => 15079 return True; 15080 end Is_Non_Preelaborable_Construct; 15081 15082 --------------------------------- 15083 -- Is_Nontrivial_DIC_Procedure -- 15084 --------------------------------- 15085 15086 function Is_Nontrivial_DIC_Procedure (Id : Entity_Id) return Boolean is 15087 Body_Decl : Node_Id; 15088 Stmt : Node_Id; 15089 15090 begin 15091 if Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id) then 15092 Body_Decl := 15093 Unit_Declaration_Node 15094 (Corresponding_Body (Unit_Declaration_Node (Id))); 15095 15096 -- The body of the Default_Initial_Condition procedure must contain 15097 -- at least one statement, otherwise the generation of the subprogram 15098 -- body failed. 15099 15100 pragma Assert (Present (Handled_Statement_Sequence (Body_Decl))); 15101 15102 -- To qualify as nontrivial, the first statement of the procedure 15103 -- must be a check in the form of an if statement. If the original 15104 -- Default_Initial_Condition expression was folded, then the first 15105 -- statement is not a check. 15106 15107 Stmt := First (Statements (Handled_Statement_Sequence (Body_Decl))); 15108 15109 return 15110 Nkind (Stmt) = N_If_Statement 15111 and then Nkind (Original_Node (Stmt)) = N_Pragma; 15112 end if; 15113 15114 return False; 15115 end Is_Nontrivial_DIC_Procedure; 15116 15117 ------------------------- 15118 -- Is_Null_Record_Type -- 15119 ------------------------- 15120 15121 function Is_Null_Record_Type (T : Entity_Id) return Boolean is 15122 Decl : constant Node_Id := Parent (T); 15123 begin 15124 return Nkind (Decl) = N_Full_Type_Declaration 15125 and then Nkind (Type_Definition (Decl)) = N_Record_Definition 15126 and then 15127 (No (Component_List (Type_Definition (Decl))) 15128 or else Null_Present (Component_List (Type_Definition (Decl)))); 15129 end Is_Null_Record_Type; 15130 15131 --------------------- 15132 -- Is_Object_Image -- 15133 --------------------- 15134 15135 function Is_Object_Image (Prefix : Node_Id) return Boolean is 15136 begin 15137 -- When the type of the prefix is not scalar, then the prefix is not 15138 -- valid in any scenario. 15139 15140 if not Is_Scalar_Type (Etype (Prefix)) then 15141 return False; 15142 end if; 15143 15144 -- Here we test for the case that the prefix is not a type and assume 15145 -- if it is not then it must be a named value or an object reference. 15146 -- This is because the parser always checks that prefixes of attributes 15147 -- are named. 15148 15149 return not (Is_Entity_Name (Prefix) and then Is_Type (Entity (Prefix))); 15150 end Is_Object_Image; 15151 15152 ------------------------- 15153 -- Is_Object_Reference -- 15154 ------------------------- 15155 15156 function Is_Object_Reference (N : Node_Id) return Boolean is 15157 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean; 15158 -- Determine whether N is the name of an internally-generated renaming 15159 15160 -------------------------------------- 15161 -- Is_Internally_Generated_Renaming -- 15162 -------------------------------------- 15163 15164 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is 15165 P : Node_Id; 15166 15167 begin 15168 P := N; 15169 while Present (P) loop 15170 if Nkind (P) = N_Object_Renaming_Declaration then 15171 return not Comes_From_Source (P); 15172 elsif Is_List_Member (P) then 15173 return False; 15174 end if; 15175 15176 P := Parent (P); 15177 end loop; 15178 15179 return False; 15180 end Is_Internally_Generated_Renaming; 15181 15182 -- Start of processing for Is_Object_Reference 15183 15184 begin 15185 if Is_Entity_Name (N) then 15186 return Present (Entity (N)) and then Is_Object (Entity (N)); 15187 15188 else 15189 case Nkind (N) is 15190 when N_Indexed_Component 15191 | N_Slice 15192 => 15193 return 15194 Is_Object_Reference (Prefix (N)) 15195 or else Is_Access_Type (Etype (Prefix (N))); 15196 15197 -- In Ada 95, a function call is a constant object; a procedure 15198 -- call is not. 15199 15200 -- Note that predefined operators are functions as well, and so 15201 -- are attributes that are (can be renamed as) functions. 15202 15203 when N_Binary_Op 15204 | N_Function_Call 15205 | N_Unary_Op 15206 => 15207 return Etype (N) /= Standard_Void_Type; 15208 15209 -- Attributes references 'Loop_Entry, 'Old, and 'Result yield 15210 -- objects, even though they are not functions. 15211 15212 when N_Attribute_Reference => 15213 return 15214 Nam_In (Attribute_Name (N), Name_Loop_Entry, 15215 Name_Old, 15216 Name_Result) 15217 or else Is_Function_Attribute_Name (Attribute_Name (N)); 15218 15219 when N_Selected_Component => 15220 return 15221 Is_Object_Reference (Selector_Name (N)) 15222 and then 15223 (Is_Object_Reference (Prefix (N)) 15224 or else Is_Access_Type (Etype (Prefix (N)))); 15225 15226 -- An explicit dereference denotes an object, except that a 15227 -- conditional expression gets turned into an explicit dereference 15228 -- in some cases, and conditional expressions are not object 15229 -- names. 15230 15231 when N_Explicit_Dereference => 15232 return not Nkind_In (Original_Node (N), N_Case_Expression, 15233 N_If_Expression); 15234 15235 -- A view conversion of a tagged object is an object reference 15236 15237 when N_Type_Conversion => 15238 return Is_Tagged_Type (Etype (Subtype_Mark (N))) 15239 and then Is_Tagged_Type (Etype (Expression (N))) 15240 and then Is_Object_Reference (Expression (N)); 15241 15242 -- An unchecked type conversion is considered to be an object if 15243 -- the operand is an object (this construction arises only as a 15244 -- result of expansion activities). 15245 15246 when N_Unchecked_Type_Conversion => 15247 return True; 15248 15249 -- Allow string literals to act as objects as long as they appear 15250 -- in internally-generated renamings. The expansion of iterators 15251 -- may generate such renamings when the range involves a string 15252 -- literal. 15253 15254 when N_String_Literal => 15255 return Is_Internally_Generated_Renaming (Parent (N)); 15256 15257 -- AI05-0003: In Ada 2012 a qualified expression is a name. 15258 -- This allows disambiguation of function calls and the use 15259 -- of aggregates in more contexts. 15260 15261 when N_Qualified_Expression => 15262 if Ada_Version < Ada_2012 then 15263 return False; 15264 else 15265 return Is_Object_Reference (Expression (N)) 15266 or else Nkind (Expression (N)) = N_Aggregate; 15267 end if; 15268 15269 when others => 15270 return False; 15271 end case; 15272 end if; 15273 end Is_Object_Reference; 15274 15275 ----------------------------------- 15276 -- Is_OK_Variable_For_Out_Formal -- 15277 ----------------------------------- 15278 15279 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is 15280 begin 15281 Note_Possible_Modification (AV, Sure => True); 15282 15283 -- We must reject parenthesized variable names. Comes_From_Source is 15284 -- checked because there are currently cases where the compiler violates 15285 -- this rule (e.g. passing a task object to its controlled Initialize 15286 -- routine). This should be properly documented in sinfo??? 15287 15288 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then 15289 return False; 15290 15291 -- A variable is always allowed 15292 15293 elsif Is_Variable (AV) then 15294 return True; 15295 15296 -- Generalized indexing operations are rewritten as explicit 15297 -- dereferences, and it is only during resolution that we can 15298 -- check whether the context requires an access_to_variable type. 15299 15300 elsif Nkind (AV) = N_Explicit_Dereference 15301 and then Ada_Version >= Ada_2012 15302 and then Nkind (Original_Node (AV)) = N_Indexed_Component 15303 and then Present (Etype (Original_Node (AV))) 15304 and then Has_Implicit_Dereference (Etype (Original_Node (AV))) 15305 then 15306 return not Is_Access_Constant (Etype (Prefix (AV))); 15307 15308 -- Unchecked conversions are allowed only if they come from the 15309 -- generated code, which sometimes uses unchecked conversions for out 15310 -- parameters in cases where code generation is unaffected. We tell 15311 -- source unchecked conversions by seeing if they are rewrites of 15312 -- an original Unchecked_Conversion function call, or of an explicit 15313 -- conversion of a function call or an aggregate (as may happen in the 15314 -- expansion of a packed array aggregate). 15315 15316 elsif Nkind (AV) = N_Unchecked_Type_Conversion then 15317 if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then 15318 return False; 15319 15320 elsif Comes_From_Source (AV) 15321 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call 15322 then 15323 return False; 15324 15325 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then 15326 return Is_OK_Variable_For_Out_Formal (Expression (AV)); 15327 15328 else 15329 return True; 15330 end if; 15331 15332 -- Normal type conversions are allowed if argument is a variable 15333 15334 elsif Nkind (AV) = N_Type_Conversion then 15335 if Is_Variable (Expression (AV)) 15336 and then Paren_Count (Expression (AV)) = 0 15337 then 15338 Note_Possible_Modification (Expression (AV), Sure => True); 15339 return True; 15340 15341 -- We also allow a non-parenthesized expression that raises 15342 -- constraint error if it rewrites what used to be a variable 15343 15344 elsif Raises_Constraint_Error (Expression (AV)) 15345 and then Paren_Count (Expression (AV)) = 0 15346 and then Is_Variable (Original_Node (Expression (AV))) 15347 then 15348 return True; 15349 15350 -- Type conversion of something other than a variable 15351 15352 else 15353 return False; 15354 end if; 15355 15356 -- If this node is rewritten, then test the original form, if that is 15357 -- OK, then we consider the rewritten node OK (for example, if the 15358 -- original node is a conversion, then Is_Variable will not be true 15359 -- but we still want to allow the conversion if it converts a variable). 15360 15361 elsif Original_Node (AV) /= AV then 15362 15363 -- In Ada 2012, the explicit dereference may be a rewritten call to a 15364 -- Reference function. 15365 15366 if Ada_Version >= Ada_2012 15367 and then Nkind (Original_Node (AV)) = N_Function_Call 15368 and then 15369 Has_Implicit_Dereference (Etype (Name (Original_Node (AV)))) 15370 then 15371 15372 -- Check that this is not a constant reference. 15373 15374 return not Is_Access_Constant (Etype (Prefix (AV))); 15375 15376 elsif Has_Implicit_Dereference (Etype (Original_Node (AV))) then 15377 return 15378 not Is_Access_Constant (Etype 15379 (Get_Reference_Discriminant (Etype (Original_Node (AV))))); 15380 15381 else 15382 return Is_OK_Variable_For_Out_Formal (Original_Node (AV)); 15383 end if; 15384 15385 -- All other non-variables are rejected 15386 15387 else 15388 return False; 15389 end if; 15390 end Is_OK_Variable_For_Out_Formal; 15391 15392 ---------------------------- 15393 -- Is_OK_Volatile_Context -- 15394 ---------------------------- 15395 15396 function Is_OK_Volatile_Context 15397 (Context : Node_Id; 15398 Obj_Ref : Node_Id) return Boolean 15399 is 15400 function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean; 15401 -- Determine whether an arbitrary node denotes a call to a protected 15402 -- entry, function, or procedure in prefixed form where the prefix is 15403 -- Obj_Ref. 15404 15405 function Within_Check (Nod : Node_Id) return Boolean; 15406 -- Determine whether an arbitrary node appears in a check node 15407 15408 function Within_Volatile_Function (Id : Entity_Id) return Boolean; 15409 -- Determine whether an arbitrary entity appears in a volatile function 15410 15411 --------------------------------- 15412 -- Is_Protected_Operation_Call -- 15413 --------------------------------- 15414 15415 function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean is 15416 Pref : Node_Id; 15417 Subp : Node_Id; 15418 15419 begin 15420 -- A call to a protected operations retains its selected component 15421 -- form as opposed to other prefixed calls that are transformed in 15422 -- expanded names. 15423 15424 if Nkind (Nod) = N_Selected_Component then 15425 Pref := Prefix (Nod); 15426 Subp := Selector_Name (Nod); 15427 15428 return 15429 Pref = Obj_Ref 15430 and then Present (Etype (Pref)) 15431 and then Is_Protected_Type (Etype (Pref)) 15432 and then Is_Entity_Name (Subp) 15433 and then Present (Entity (Subp)) 15434 and then Ekind_In (Entity (Subp), E_Entry, 15435 E_Entry_Family, 15436 E_Function, 15437 E_Procedure); 15438 else 15439 return False; 15440 end if; 15441 end Is_Protected_Operation_Call; 15442 15443 ------------------ 15444 -- Within_Check -- 15445 ------------------ 15446 15447 function Within_Check (Nod : Node_Id) return Boolean is 15448 Par : Node_Id; 15449 15450 begin 15451 -- Climb the parent chain looking for a check node 15452 15453 Par := Nod; 15454 while Present (Par) loop 15455 if Nkind (Par) in N_Raise_xxx_Error then 15456 return True; 15457 15458 -- Prevent the search from going too far 15459 15460 elsif Is_Body_Or_Package_Declaration (Par) then 15461 exit; 15462 end if; 15463 15464 Par := Parent (Par); 15465 end loop; 15466 15467 return False; 15468 end Within_Check; 15469 15470 ------------------------------ 15471 -- Within_Volatile_Function -- 15472 ------------------------------ 15473 15474 function Within_Volatile_Function (Id : Entity_Id) return Boolean is 15475 Func_Id : Entity_Id; 15476 15477 begin 15478 -- Traverse the scope stack looking for a [generic] function 15479 15480 Func_Id := Id; 15481 while Present (Func_Id) and then Func_Id /= Standard_Standard loop 15482 if Ekind_In (Func_Id, E_Function, E_Generic_Function) then 15483 return Is_Volatile_Function (Func_Id); 15484 end if; 15485 15486 Func_Id := Scope (Func_Id); 15487 end loop; 15488 15489 return False; 15490 end Within_Volatile_Function; 15491 15492 -- Local variables 15493 15494 Obj_Id : Entity_Id; 15495 15496 -- Start of processing for Is_OK_Volatile_Context 15497 15498 begin 15499 -- The volatile object appears on either side of an assignment 15500 15501 if Nkind (Context) = N_Assignment_Statement then 15502 return True; 15503 15504 -- The volatile object is part of the initialization expression of 15505 -- another object. 15506 15507 elsif Nkind (Context) = N_Object_Declaration 15508 and then Present (Expression (Context)) 15509 and then Expression (Context) = Obj_Ref 15510 then 15511 Obj_Id := Defining_Entity (Context); 15512 15513 -- The volatile object acts as the initialization expression of an 15514 -- extended return statement. This is valid context as long as the 15515 -- function is volatile. 15516 15517 if Is_Return_Object (Obj_Id) then 15518 return Within_Volatile_Function (Obj_Id); 15519 15520 -- Otherwise this is a normal object initialization 15521 15522 else 15523 return True; 15524 end if; 15525 15526 -- The volatile object acts as the name of a renaming declaration 15527 15528 elsif Nkind (Context) = N_Object_Renaming_Declaration 15529 and then Name (Context) = Obj_Ref 15530 then 15531 return True; 15532 15533 -- The volatile object appears as an actual parameter in a call to an 15534 -- instance of Unchecked_Conversion whose result is renamed. 15535 15536 elsif Nkind (Context) = N_Function_Call 15537 and then Is_Entity_Name (Name (Context)) 15538 and then Is_Unchecked_Conversion_Instance (Entity (Name (Context))) 15539 and then Nkind (Parent (Context)) = N_Object_Renaming_Declaration 15540 then 15541 return True; 15542 15543 -- The volatile object is actually the prefix in a protected entry, 15544 -- function, or procedure call. 15545 15546 elsif Is_Protected_Operation_Call (Context) then 15547 return True; 15548 15549 -- The volatile object appears as the expression of a simple return 15550 -- statement that applies to a volatile function. 15551 15552 elsif Nkind (Context) = N_Simple_Return_Statement 15553 and then Expression (Context) = Obj_Ref 15554 then 15555 return 15556 Within_Volatile_Function (Return_Statement_Entity (Context)); 15557 15558 -- The volatile object appears as the prefix of a name occurring in a 15559 -- non-interfering context. 15560 15561 elsif Nkind_In (Context, N_Attribute_Reference, 15562 N_Explicit_Dereference, 15563 N_Indexed_Component, 15564 N_Selected_Component, 15565 N_Slice) 15566 and then Prefix (Context) = Obj_Ref 15567 and then Is_OK_Volatile_Context 15568 (Context => Parent (Context), 15569 Obj_Ref => Context) 15570 then 15571 return True; 15572 15573 -- The volatile object appears as the prefix of attributes Address, 15574 -- Alignment, Component_Size, First_Bit, Last_Bit, Position, Size, 15575 -- Storage_Size. 15576 15577 elsif Nkind (Context) = N_Attribute_Reference 15578 and then Prefix (Context) = Obj_Ref 15579 and then Nam_In (Attribute_Name (Context), Name_Address, 15580 Name_Alignment, 15581 Name_Component_Size, 15582 Name_First_Bit, 15583 Name_Last_Bit, 15584 Name_Position, 15585 Name_Size, 15586 Name_Storage_Size) 15587 then 15588 return True; 15589 15590 -- The volatile object appears as the expression of a type conversion 15591 -- occurring in a non-interfering context. 15592 15593 elsif Nkind_In (Context, N_Type_Conversion, 15594 N_Unchecked_Type_Conversion) 15595 and then Expression (Context) = Obj_Ref 15596 and then Is_OK_Volatile_Context 15597 (Context => Parent (Context), 15598 Obj_Ref => Context) 15599 then 15600 return True; 15601 15602 -- The volatile object appears as the expression in a delay statement 15603 15604 elsif Nkind (Context) in N_Delay_Statement then 15605 return True; 15606 15607 -- Allow references to volatile objects in various checks. This is not a 15608 -- direct SPARK 2014 requirement. 15609 15610 elsif Within_Check (Context) then 15611 return True; 15612 15613 -- Assume that references to effectively volatile objects that appear 15614 -- as actual parameters in a subprogram call are always legal. A full 15615 -- legality check is done when the actuals are resolved (see routine 15616 -- Resolve_Actuals). 15617 15618 elsif Within_Subprogram_Call (Context) then 15619 return True; 15620 15621 -- Otherwise the context is not suitable for an effectively volatile 15622 -- object. 15623 15624 else 15625 return False; 15626 end if; 15627 end Is_OK_Volatile_Context; 15628 15629 ------------------------------------ 15630 -- Is_Package_Contract_Annotation -- 15631 ------------------------------------ 15632 15633 function Is_Package_Contract_Annotation (Item : Node_Id) return Boolean is 15634 Nam : Name_Id; 15635 15636 begin 15637 if Nkind (Item) = N_Aspect_Specification then 15638 Nam := Chars (Identifier (Item)); 15639 15640 else pragma Assert (Nkind (Item) = N_Pragma); 15641 Nam := Pragma_Name (Item); 15642 end if; 15643 15644 return Nam = Name_Abstract_State 15645 or else Nam = Name_Initial_Condition 15646 or else Nam = Name_Initializes 15647 or else Nam = Name_Refined_State; 15648 end Is_Package_Contract_Annotation; 15649 15650 ----------------------------------- 15651 -- Is_Partially_Initialized_Type -- 15652 ----------------------------------- 15653 15654 function Is_Partially_Initialized_Type 15655 (Typ : Entity_Id; 15656 Include_Implicit : Boolean := True) return Boolean 15657 is 15658 begin 15659 if Is_Scalar_Type (Typ) then 15660 return False; 15661 15662 elsif Is_Access_Type (Typ) then 15663 return Include_Implicit; 15664 15665 elsif Is_Array_Type (Typ) then 15666 15667 -- If component type is partially initialized, so is array type 15668 15669 if Is_Partially_Initialized_Type 15670 (Component_Type (Typ), Include_Implicit) 15671 then 15672 return True; 15673 15674 -- Otherwise we are only partially initialized if we are fully 15675 -- initialized (this is the empty array case, no point in us 15676 -- duplicating that code here). 15677 15678 else 15679 return Is_Fully_Initialized_Type (Typ); 15680 end if; 15681 15682 elsif Is_Record_Type (Typ) then 15683 15684 -- A discriminated type is always partially initialized if in 15685 -- all mode 15686 15687 if Has_Discriminants (Typ) and then Include_Implicit then 15688 return True; 15689 15690 -- A tagged type is always partially initialized 15691 15692 elsif Is_Tagged_Type (Typ) then 15693 return True; 15694 15695 -- Case of non-discriminated record 15696 15697 else 15698 declare 15699 Ent : Entity_Id; 15700 15701 Component_Present : Boolean := False; 15702 -- Set True if at least one component is present. If no 15703 -- components are present, then record type is fully 15704 -- initialized (another odd case, like the null array). 15705 15706 begin 15707 -- Loop through components 15708 15709 Ent := First_Entity (Typ); 15710 while Present (Ent) loop 15711 if Ekind (Ent) = E_Component then 15712 Component_Present := True; 15713 15714 -- If a component has an initialization expression then 15715 -- the enclosing record type is partially initialized 15716 15717 if Present (Parent (Ent)) 15718 and then Present (Expression (Parent (Ent))) 15719 then 15720 return True; 15721 15722 -- If a component is of a type which is itself partially 15723 -- initialized, then the enclosing record type is also. 15724 15725 elsif Is_Partially_Initialized_Type 15726 (Etype (Ent), Include_Implicit) 15727 then 15728 return True; 15729 end if; 15730 end if; 15731 15732 Next_Entity (Ent); 15733 end loop; 15734 15735 -- No initialized components found. If we found any components 15736 -- they were all uninitialized so the result is false. 15737 15738 if Component_Present then 15739 return False; 15740 15741 -- But if we found no components, then all the components are 15742 -- initialized so we consider the type to be initialized. 15743 15744 else 15745 return True; 15746 end if; 15747 end; 15748 end if; 15749 15750 -- Concurrent types are always fully initialized 15751 15752 elsif Is_Concurrent_Type (Typ) then 15753 return True; 15754 15755 -- For a private type, go to underlying type. If there is no underlying 15756 -- type then just assume this partially initialized. Not clear if this 15757 -- can happen in a non-error case, but no harm in testing for this. 15758 15759 elsif Is_Private_Type (Typ) then 15760 declare 15761 U : constant Entity_Id := Underlying_Type (Typ); 15762 begin 15763 if No (U) then 15764 return True; 15765 else 15766 return Is_Partially_Initialized_Type (U, Include_Implicit); 15767 end if; 15768 end; 15769 15770 -- For any other type (are there any?) assume partially initialized 15771 15772 else 15773 return True; 15774 end if; 15775 end Is_Partially_Initialized_Type; 15776 15777 ------------------------------------ 15778 -- Is_Potentially_Persistent_Type -- 15779 ------------------------------------ 15780 15781 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is 15782 Comp : Entity_Id; 15783 Indx : Node_Id; 15784 15785 begin 15786 -- For private type, test corresponding full type 15787 15788 if Is_Private_Type (T) then 15789 return Is_Potentially_Persistent_Type (Full_View (T)); 15790 15791 -- Scalar types are potentially persistent 15792 15793 elsif Is_Scalar_Type (T) then 15794 return True; 15795 15796 -- Record type is potentially persistent if not tagged and the types of 15797 -- all it components are potentially persistent, and no component has 15798 -- an initialization expression. 15799 15800 elsif Is_Record_Type (T) 15801 and then not Is_Tagged_Type (T) 15802 and then not Is_Partially_Initialized_Type (T) 15803 then 15804 Comp := First_Component (T); 15805 while Present (Comp) loop 15806 if not Is_Potentially_Persistent_Type (Etype (Comp)) then 15807 return False; 15808 else 15809 Next_Entity (Comp); 15810 end if; 15811 end loop; 15812 15813 return True; 15814 15815 -- Array type is potentially persistent if its component type is 15816 -- potentially persistent and if all its constraints are static. 15817 15818 elsif Is_Array_Type (T) then 15819 if not Is_Potentially_Persistent_Type (Component_Type (T)) then 15820 return False; 15821 end if; 15822 15823 Indx := First_Index (T); 15824 while Present (Indx) loop 15825 if not Is_OK_Static_Subtype (Etype (Indx)) then 15826 return False; 15827 else 15828 Next_Index (Indx); 15829 end if; 15830 end loop; 15831 15832 return True; 15833 15834 -- All other types are not potentially persistent 15835 15836 else 15837 return False; 15838 end if; 15839 end Is_Potentially_Persistent_Type; 15840 15841 -------------------------------- 15842 -- Is_Potentially_Unevaluated -- 15843 -------------------------------- 15844 15845 function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is 15846 Par : Node_Id; 15847 Expr : Node_Id; 15848 15849 begin 15850 Expr := N; 15851 Par := N; 15852 15853 -- A postcondition whose expression is a short-circuit is broken down 15854 -- into individual aspects for better exception reporting. The original 15855 -- short-circuit expression is rewritten as the second operand, and an 15856 -- occurrence of 'Old in that operand is potentially unevaluated. 15857 -- See sem_ch13.adb for details of this transformation. The reference 15858 -- to 'Old may appear within an expression, so we must look for the 15859 -- enclosing pragma argument in the tree that contains the reference. 15860 15861 while Present (Par) 15862 and then Nkind (Par) /= N_Pragma_Argument_Association 15863 loop 15864 if Nkind (Original_Node (Par)) = N_And_Then then 15865 return True; 15866 end if; 15867 15868 Par := Parent (Par); 15869 end loop; 15870 15871 -- Other cases; 'Old appears within other expression (not the top-level 15872 -- conjunct in a postcondition) with a potentially unevaluated operand. 15873 15874 Par := Parent (Expr); 15875 while not Nkind_In (Par, N_And_Then, 15876 N_Case_Expression, 15877 N_If_Expression, 15878 N_In, 15879 N_Not_In, 15880 N_Or_Else, 15881 N_Quantified_Expression) 15882 loop 15883 Expr := Par; 15884 Par := Parent (Par); 15885 15886 -- If the context is not an expression, or if is the result of 15887 -- expansion of an enclosing construct (such as another attribute) 15888 -- the predicate does not apply. 15889 15890 if Nkind (Par) = N_Case_Expression_Alternative then 15891 null; 15892 15893 elsif Nkind (Par) not in N_Subexpr 15894 or else not Comes_From_Source (Par) 15895 then 15896 return False; 15897 end if; 15898 end loop; 15899 15900 if Nkind (Par) = N_If_Expression then 15901 return Is_Elsif (Par) or else Expr /= First (Expressions (Par)); 15902 15903 elsif Nkind (Par) = N_Case_Expression then 15904 return Expr /= Expression (Par); 15905 15906 elsif Nkind_In (Par, N_And_Then, N_Or_Else) then 15907 return Expr = Right_Opnd (Par); 15908 15909 elsif Nkind_In (Par, N_In, N_Not_In) then 15910 15911 -- If the membership includes several alternatives, only the first is 15912 -- definitely evaluated. 15913 15914 if Present (Alternatives (Par)) then 15915 return Expr /= First (Alternatives (Par)); 15916 15917 -- If this is a range membership both bounds are evaluated 15918 15919 else 15920 return False; 15921 end if; 15922 15923 elsif Nkind (Par) = N_Quantified_Expression then 15924 return Expr = Condition (Par); 15925 15926 else 15927 return False; 15928 end if; 15929 end Is_Potentially_Unevaluated; 15930 15931 -------------------------------- 15932 -- Is_Preelaborable_Aggregate -- 15933 -------------------------------- 15934 15935 function Is_Preelaborable_Aggregate (Aggr : Node_Id) return Boolean is 15936 Aggr_Typ : constant Entity_Id := Etype (Aggr); 15937 Array_Aggr : constant Boolean := Is_Array_Type (Aggr_Typ); 15938 15939 Anc_Part : Node_Id; 15940 Assoc : Node_Id; 15941 Choice : Node_Id; 15942 Comp_Typ : Entity_Id := Empty; -- init to avoid warning 15943 Expr : Node_Id; 15944 15945 begin 15946 if Array_Aggr then 15947 Comp_Typ := Component_Type (Aggr_Typ); 15948 end if; 15949 15950 -- Inspect the ancestor part 15951 15952 if Nkind (Aggr) = N_Extension_Aggregate then 15953 Anc_Part := Ancestor_Part (Aggr); 15954 15955 -- The ancestor denotes a subtype mark 15956 15957 if Is_Entity_Name (Anc_Part) 15958 and then Is_Type (Entity (Anc_Part)) 15959 then 15960 if not Has_Preelaborable_Initialization (Entity (Anc_Part)) then 15961 return False; 15962 end if; 15963 15964 -- Otherwise the ancestor denotes an expression 15965 15966 elsif not Is_Preelaborable_Construct (Anc_Part) then 15967 return False; 15968 end if; 15969 end if; 15970 15971 -- Inspect the positional associations 15972 15973 Expr := First (Expressions (Aggr)); 15974 while Present (Expr) loop 15975 if not Is_Preelaborable_Construct (Expr) then 15976 return False; 15977 end if; 15978 15979 Next (Expr); 15980 end loop; 15981 15982 -- Inspect the named associations 15983 15984 Assoc := First (Component_Associations (Aggr)); 15985 while Present (Assoc) loop 15986 15987 -- Inspect the choices of the current named association 15988 15989 Choice := First (Choices (Assoc)); 15990 while Present (Choice) loop 15991 if Array_Aggr then 15992 15993 -- For a choice to be preelaborable, it must denote either a 15994 -- static range or a static expression. 15995 15996 if Nkind (Choice) = N_Others_Choice then 15997 null; 15998 15999 elsif Nkind (Choice) = N_Range then 16000 if not Is_OK_Static_Range (Choice) then 16001 return False; 16002 end if; 16003 16004 elsif not Is_OK_Static_Expression (Choice) then 16005 return False; 16006 end if; 16007 16008 else 16009 Comp_Typ := Etype (Choice); 16010 end if; 16011 16012 Next (Choice); 16013 end loop; 16014 16015 -- The type of the choice must have preelaborable initialization if 16016 -- the association carries a <>. 16017 16018 pragma Assert (Present (Comp_Typ)); 16019 if Box_Present (Assoc) then 16020 if not Has_Preelaborable_Initialization (Comp_Typ) then 16021 return False; 16022 end if; 16023 16024 -- The type of the expression must have preelaborable initialization 16025 16026 elsif not Is_Preelaborable_Construct (Expression (Assoc)) then 16027 return False; 16028 end if; 16029 16030 Next (Assoc); 16031 end loop; 16032 16033 -- At this point the aggregate is preelaborable 16034 16035 return True; 16036 end Is_Preelaborable_Aggregate; 16037 16038 -------------------------------- 16039 -- Is_Preelaborable_Construct -- 16040 -------------------------------- 16041 16042 function Is_Preelaborable_Construct (N : Node_Id) return Boolean is 16043 begin 16044 -- Aggregates 16045 16046 if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then 16047 return Is_Preelaborable_Aggregate (N); 16048 16049 -- Attributes are allowed in general, even if their prefix is a formal 16050 -- type. It seems that certain attributes known not to be static might 16051 -- not be allowed, but there are no rules to prevent them. 16052 16053 elsif Nkind (N) = N_Attribute_Reference then 16054 return True; 16055 16056 -- Expressions 16057 16058 elsif Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then 16059 return True; 16060 16061 elsif Nkind (N) = N_Qualified_Expression then 16062 return Is_Preelaborable_Construct (Expression (N)); 16063 16064 -- Names are preelaborable when they denote a discriminant of an 16065 -- enclosing type. Discriminals are also considered for this check. 16066 16067 elsif Is_Entity_Name (N) 16068 and then Present (Entity (N)) 16069 and then 16070 (Ekind (Entity (N)) = E_Discriminant 16071 or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter) 16072 and then Present (Discriminal_Link (Entity (N))))) 16073 then 16074 return True; 16075 16076 -- Statements 16077 16078 elsif Nkind (N) = N_Null then 16079 return True; 16080 16081 -- Otherwise the construct is not preelaborable 16082 16083 else 16084 return False; 16085 end if; 16086 end Is_Preelaborable_Construct; 16087 16088 --------------------------------- 16089 -- Is_Protected_Self_Reference -- 16090 --------------------------------- 16091 16092 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is 16093 16094 function In_Access_Definition (N : Node_Id) return Boolean; 16095 -- Returns true if N belongs to an access definition 16096 16097 -------------------------- 16098 -- In_Access_Definition -- 16099 -------------------------- 16100 16101 function In_Access_Definition (N : Node_Id) return Boolean is 16102 P : Node_Id; 16103 16104 begin 16105 P := Parent (N); 16106 while Present (P) loop 16107 if Nkind (P) = N_Access_Definition then 16108 return True; 16109 end if; 16110 16111 P := Parent (P); 16112 end loop; 16113 16114 return False; 16115 end In_Access_Definition; 16116 16117 -- Start of processing for Is_Protected_Self_Reference 16118 16119 begin 16120 -- Verify that prefix is analyzed and has the proper form. Note that 16121 -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also 16122 -- produce the address of an entity, do not analyze their prefix 16123 -- because they denote entities that are not necessarily visible. 16124 -- Neither of them can apply to a protected type. 16125 16126 return Ada_Version >= Ada_2005 16127 and then Is_Entity_Name (N) 16128 and then Present (Entity (N)) 16129 and then Is_Protected_Type (Entity (N)) 16130 and then In_Open_Scopes (Entity (N)) 16131 and then not In_Access_Definition (N); 16132 end Is_Protected_Self_Reference; 16133 16134 ----------------------------- 16135 -- Is_RCI_Pkg_Spec_Or_Body -- 16136 ----------------------------- 16137 16138 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is 16139 16140 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean; 16141 -- Return True if the unit of Cunit is an RCI package declaration 16142 16143 --------------------------- 16144 -- Is_RCI_Pkg_Decl_Cunit -- 16145 --------------------------- 16146 16147 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is 16148 The_Unit : constant Node_Id := Unit (Cunit); 16149 16150 begin 16151 if Nkind (The_Unit) /= N_Package_Declaration then 16152 return False; 16153 end if; 16154 16155 return Is_Remote_Call_Interface (Defining_Entity (The_Unit)); 16156 end Is_RCI_Pkg_Decl_Cunit; 16157 16158 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body 16159 16160 begin 16161 return Is_RCI_Pkg_Decl_Cunit (Cunit) 16162 or else 16163 (Nkind (Unit (Cunit)) = N_Package_Body 16164 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit))); 16165 end Is_RCI_Pkg_Spec_Or_Body; 16166 16167 ----------------------------------------- 16168 -- Is_Remote_Access_To_Class_Wide_Type -- 16169 ----------------------------------------- 16170 16171 function Is_Remote_Access_To_Class_Wide_Type 16172 (E : Entity_Id) return Boolean 16173 is 16174 begin 16175 -- A remote access to class-wide type is a general access to object type 16176 -- declared in the visible part of a Remote_Types or Remote_Call_ 16177 -- Interface unit. 16178 16179 return Ekind (E) = E_General_Access_Type 16180 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); 16181 end Is_Remote_Access_To_Class_Wide_Type; 16182 16183 ----------------------------------------- 16184 -- Is_Remote_Access_To_Subprogram_Type -- 16185 ----------------------------------------- 16186 16187 function Is_Remote_Access_To_Subprogram_Type 16188 (E : Entity_Id) return Boolean 16189 is 16190 begin 16191 return (Ekind (E) = E_Access_Subprogram_Type 16192 or else (Ekind (E) = E_Record_Type 16193 and then Present (Corresponding_Remote_Type (E)))) 16194 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); 16195 end Is_Remote_Access_To_Subprogram_Type; 16196 16197 -------------------- 16198 -- Is_Remote_Call -- 16199 -------------------- 16200 16201 function Is_Remote_Call (N : Node_Id) return Boolean is 16202 begin 16203 if Nkind (N) not in N_Subprogram_Call then 16204 16205 -- An entry call cannot be remote 16206 16207 return False; 16208 16209 elsif Nkind (Name (N)) in N_Has_Entity 16210 and then Is_Remote_Call_Interface (Entity (Name (N))) 16211 then 16212 -- A subprogram declared in the spec of a RCI package is remote 16213 16214 return True; 16215 16216 elsif Nkind (Name (N)) = N_Explicit_Dereference 16217 and then Is_Remote_Access_To_Subprogram_Type 16218 (Etype (Prefix (Name (N)))) 16219 then 16220 -- The dereference of a RAS is a remote call 16221 16222 return True; 16223 16224 elsif Present (Controlling_Argument (N)) 16225 and then Is_Remote_Access_To_Class_Wide_Type 16226 (Etype (Controlling_Argument (N))) 16227 then 16228 -- Any primitive operation call with a controlling argument of 16229 -- a RACW type is a remote call. 16230 16231 return True; 16232 end if; 16233 16234 -- All other calls are local calls 16235 16236 return False; 16237 end Is_Remote_Call; 16238 16239 ---------------------- 16240 -- Is_Renamed_Entry -- 16241 ---------------------- 16242 16243 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is 16244 Orig_Node : Node_Id := Empty; 16245 Subp_Decl : Node_Id := Parent (Parent (Proc_Nam)); 16246 16247 function Is_Entry (Nam : Node_Id) return Boolean; 16248 -- Determine whether Nam is an entry. Traverse selectors if there are 16249 -- nested selected components. 16250 16251 -------------- 16252 -- Is_Entry -- 16253 -------------- 16254 16255 function Is_Entry (Nam : Node_Id) return Boolean is 16256 begin 16257 if Nkind (Nam) = N_Selected_Component then 16258 return Is_Entry (Selector_Name (Nam)); 16259 end if; 16260 16261 return Ekind (Entity (Nam)) = E_Entry; 16262 end Is_Entry; 16263 16264 -- Start of processing for Is_Renamed_Entry 16265 16266 begin 16267 if Present (Alias (Proc_Nam)) then 16268 Subp_Decl := Parent (Parent (Alias (Proc_Nam))); 16269 end if; 16270 16271 -- Look for a rewritten subprogram renaming declaration 16272 16273 if Nkind (Subp_Decl) = N_Subprogram_Declaration 16274 and then Present (Original_Node (Subp_Decl)) 16275 then 16276 Orig_Node := Original_Node (Subp_Decl); 16277 end if; 16278 16279 -- The rewritten subprogram is actually an entry 16280 16281 if Present (Orig_Node) 16282 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration 16283 and then Is_Entry (Name (Orig_Node)) 16284 then 16285 return True; 16286 end if; 16287 16288 return False; 16289 end Is_Renamed_Entry; 16290 16291 ----------------------------- 16292 -- Is_Renaming_Declaration -- 16293 ----------------------------- 16294 16295 function Is_Renaming_Declaration (N : Node_Id) return Boolean is 16296 begin 16297 case Nkind (N) is 16298 when N_Exception_Renaming_Declaration 16299 | N_Generic_Function_Renaming_Declaration 16300 | N_Generic_Package_Renaming_Declaration 16301 | N_Generic_Procedure_Renaming_Declaration 16302 | N_Object_Renaming_Declaration 16303 | N_Package_Renaming_Declaration 16304 | N_Subprogram_Renaming_Declaration 16305 => 16306 return True; 16307 16308 when others => 16309 return False; 16310 end case; 16311 end Is_Renaming_Declaration; 16312 16313 ---------------------------- 16314 -- Is_Reversible_Iterator -- 16315 ---------------------------- 16316 16317 function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is 16318 Ifaces_List : Elist_Id; 16319 Iface_Elmt : Elmt_Id; 16320 Iface : Entity_Id; 16321 16322 begin 16323 if Is_Class_Wide_Type (Typ) 16324 and then Chars (Root_Type (Typ)) = Name_Reversible_Iterator 16325 and then In_Predefined_Unit (Root_Type (Typ)) 16326 then 16327 return True; 16328 16329 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then 16330 return False; 16331 16332 else 16333 Collect_Interfaces (Typ, Ifaces_List); 16334 16335 Iface_Elmt := First_Elmt (Ifaces_List); 16336 while Present (Iface_Elmt) loop 16337 Iface := Node (Iface_Elmt); 16338 if Chars (Iface) = Name_Reversible_Iterator 16339 and then In_Predefined_Unit (Iface) 16340 then 16341 return True; 16342 end if; 16343 16344 Next_Elmt (Iface_Elmt); 16345 end loop; 16346 end if; 16347 16348 return False; 16349 end Is_Reversible_Iterator; 16350 16351 ---------------------- 16352 -- Is_Selector_Name -- 16353 ---------------------- 16354 16355 function Is_Selector_Name (N : Node_Id) return Boolean is 16356 begin 16357 if not Is_List_Member (N) then 16358 declare 16359 P : constant Node_Id := Parent (N); 16360 begin 16361 return Nkind_In (P, N_Expanded_Name, 16362 N_Generic_Association, 16363 N_Parameter_Association, 16364 N_Selected_Component) 16365 and then Selector_Name (P) = N; 16366 end; 16367 16368 else 16369 declare 16370 L : constant List_Id := List_Containing (N); 16371 P : constant Node_Id := Parent (L); 16372 begin 16373 return (Nkind (P) = N_Discriminant_Association 16374 and then Selector_Names (P) = L) 16375 or else 16376 (Nkind (P) = N_Component_Association 16377 and then Choices (P) = L); 16378 end; 16379 end if; 16380 end Is_Selector_Name; 16381 16382 --------------------------------- 16383 -- Is_Single_Concurrent_Object -- 16384 --------------------------------- 16385 16386 function Is_Single_Concurrent_Object (Id : Entity_Id) return Boolean is 16387 begin 16388 return 16389 Is_Single_Protected_Object (Id) or else Is_Single_Task_Object (Id); 16390 end Is_Single_Concurrent_Object; 16391 16392 ------------------------------- 16393 -- Is_Single_Concurrent_Type -- 16394 ------------------------------- 16395 16396 function Is_Single_Concurrent_Type (Id : Entity_Id) return Boolean is 16397 begin 16398 return 16399 Ekind_In (Id, E_Protected_Type, E_Task_Type) 16400 and then Is_Single_Concurrent_Type_Declaration 16401 (Declaration_Node (Id)); 16402 end Is_Single_Concurrent_Type; 16403 16404 ------------------------------------------- 16405 -- Is_Single_Concurrent_Type_Declaration -- 16406 ------------------------------------------- 16407 16408 function Is_Single_Concurrent_Type_Declaration 16409 (N : Node_Id) return Boolean 16410 is 16411 begin 16412 return Nkind_In (Original_Node (N), N_Single_Protected_Declaration, 16413 N_Single_Task_Declaration); 16414 end Is_Single_Concurrent_Type_Declaration; 16415 16416 --------------------------------------------- 16417 -- Is_Single_Precision_Floating_Point_Type -- 16418 --------------------------------------------- 16419 16420 function Is_Single_Precision_Floating_Point_Type 16421 (E : Entity_Id) return Boolean is 16422 begin 16423 return Is_Floating_Point_Type (E) 16424 and then Machine_Radix_Value (E) = Uint_2 16425 and then Machine_Mantissa_Value (E) = Uint_24 16426 and then Machine_Emax_Value (E) = Uint_2 ** Uint_7 16427 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_7); 16428 end Is_Single_Precision_Floating_Point_Type; 16429 16430 -------------------------------- 16431 -- Is_Single_Protected_Object -- 16432 -------------------------------- 16433 16434 function Is_Single_Protected_Object (Id : Entity_Id) return Boolean is 16435 begin 16436 return 16437 Ekind (Id) = E_Variable 16438 and then Ekind (Etype (Id)) = E_Protected_Type 16439 and then Is_Single_Concurrent_Type (Etype (Id)); 16440 end Is_Single_Protected_Object; 16441 16442 --------------------------- 16443 -- Is_Single_Task_Object -- 16444 --------------------------- 16445 16446 function Is_Single_Task_Object (Id : Entity_Id) return Boolean is 16447 begin 16448 return 16449 Ekind (Id) = E_Variable 16450 and then Ekind (Etype (Id)) = E_Task_Type 16451 and then Is_Single_Concurrent_Type (Etype (Id)); 16452 end Is_Single_Task_Object; 16453 16454 ------------------------------------- 16455 -- Is_SPARK_05_Initialization_Expr -- 16456 ------------------------------------- 16457 16458 function Is_SPARK_05_Initialization_Expr (N : Node_Id) return Boolean is 16459 Is_Ok : Boolean; 16460 Expr : Node_Id; 16461 Comp_Assn : Node_Id; 16462 Orig_N : constant Node_Id := Original_Node (N); 16463 16464 begin 16465 Is_Ok := True; 16466 16467 if not Comes_From_Source (Orig_N) then 16468 goto Done; 16469 end if; 16470 16471 pragma Assert (Nkind (Orig_N) in N_Subexpr); 16472 16473 case Nkind (Orig_N) is 16474 when N_Character_Literal 16475 | N_Integer_Literal 16476 | N_Real_Literal 16477 | N_String_Literal 16478 => 16479 null; 16480 16481 when N_Expanded_Name 16482 | N_Identifier 16483 => 16484 if Is_Entity_Name (Orig_N) 16485 and then Present (Entity (Orig_N)) -- needed in some cases 16486 then 16487 case Ekind (Entity (Orig_N)) is 16488 when E_Constant 16489 | E_Enumeration_Literal 16490 | E_Named_Integer 16491 | E_Named_Real 16492 => 16493 null; 16494 16495 when others => 16496 if Is_Type (Entity (Orig_N)) then 16497 null; 16498 else 16499 Is_Ok := False; 16500 end if; 16501 end case; 16502 end if; 16503 16504 when N_Qualified_Expression 16505 | N_Type_Conversion 16506 => 16507 Is_Ok := Is_SPARK_05_Initialization_Expr (Expression (Orig_N)); 16508 16509 when N_Unary_Op => 16510 Is_Ok := Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N)); 16511 16512 when N_Binary_Op 16513 | N_Membership_Test 16514 | N_Short_Circuit 16515 => 16516 Is_Ok := Is_SPARK_05_Initialization_Expr (Left_Opnd (Orig_N)) 16517 and then 16518 Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N)); 16519 16520 when N_Aggregate 16521 | N_Extension_Aggregate 16522 => 16523 if Nkind (Orig_N) = N_Extension_Aggregate then 16524 Is_Ok := 16525 Is_SPARK_05_Initialization_Expr (Ancestor_Part (Orig_N)); 16526 end if; 16527 16528 Expr := First (Expressions (Orig_N)); 16529 while Present (Expr) loop 16530 if not Is_SPARK_05_Initialization_Expr (Expr) then 16531 Is_Ok := False; 16532 goto Done; 16533 end if; 16534 16535 Next (Expr); 16536 end loop; 16537 16538 Comp_Assn := First (Component_Associations (Orig_N)); 16539 while Present (Comp_Assn) loop 16540 Expr := Expression (Comp_Assn); 16541 16542 -- Note: test for Present here needed for box assocation 16543 16544 if Present (Expr) 16545 and then not Is_SPARK_05_Initialization_Expr (Expr) 16546 then 16547 Is_Ok := False; 16548 goto Done; 16549 end if; 16550 16551 Next (Comp_Assn); 16552 end loop; 16553 16554 when N_Attribute_Reference => 16555 if Nkind (Prefix (Orig_N)) in N_Subexpr then 16556 Is_Ok := Is_SPARK_05_Initialization_Expr (Prefix (Orig_N)); 16557 end if; 16558 16559 Expr := First (Expressions (Orig_N)); 16560 while Present (Expr) loop 16561 if not Is_SPARK_05_Initialization_Expr (Expr) then 16562 Is_Ok := False; 16563 goto Done; 16564 end if; 16565 16566 Next (Expr); 16567 end loop; 16568 16569 -- Selected components might be expanded named not yet resolved, so 16570 -- default on the safe side. (Eg on sparklex.ads) 16571 16572 when N_Selected_Component => 16573 null; 16574 16575 when others => 16576 Is_Ok := False; 16577 end case; 16578 16579 <<Done>> 16580 return Is_Ok; 16581 end Is_SPARK_05_Initialization_Expr; 16582 16583 ---------------------------------- 16584 -- Is_SPARK_05_Object_Reference -- 16585 ---------------------------------- 16586 16587 function Is_SPARK_05_Object_Reference (N : Node_Id) return Boolean is 16588 begin 16589 if Is_Entity_Name (N) then 16590 return Present (Entity (N)) 16591 and then 16592 (Ekind_In (Entity (N), E_Constant, E_Variable) 16593 or else Ekind (Entity (N)) in Formal_Kind); 16594 16595 else 16596 case Nkind (N) is 16597 when N_Selected_Component => 16598 return Is_SPARK_05_Object_Reference (Prefix (N)); 16599 16600 when others => 16601 return False; 16602 end case; 16603 end if; 16604 end Is_SPARK_05_Object_Reference; 16605 16606 ----------------------------- 16607 -- Is_Specific_Tagged_Type -- 16608 ----------------------------- 16609 16610 function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean is 16611 Full_Typ : Entity_Id; 16612 16613 begin 16614 -- Handle private types 16615 16616 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 16617 Full_Typ := Full_View (Typ); 16618 else 16619 Full_Typ := Typ; 16620 end if; 16621 16622 -- A specific tagged type is a non-class-wide tagged type 16623 16624 return Is_Tagged_Type (Full_Typ) and not Is_Class_Wide_Type (Full_Typ); 16625 end Is_Specific_Tagged_Type; 16626 16627 ------------------ 16628 -- Is_Statement -- 16629 ------------------ 16630 16631 function Is_Statement (N : Node_Id) return Boolean is 16632 begin 16633 return 16634 Nkind (N) in N_Statement_Other_Than_Procedure_Call 16635 or else Nkind (N) = N_Procedure_Call_Statement; 16636 end Is_Statement; 16637 16638 --------------------------------------- 16639 -- Is_Subprogram_Contract_Annotation -- 16640 --------------------------------------- 16641 16642 function Is_Subprogram_Contract_Annotation 16643 (Item : Node_Id) return Boolean 16644 is 16645 Nam : Name_Id; 16646 16647 begin 16648 if Nkind (Item) = N_Aspect_Specification then 16649 Nam := Chars (Identifier (Item)); 16650 16651 else pragma Assert (Nkind (Item) = N_Pragma); 16652 Nam := Pragma_Name (Item); 16653 end if; 16654 16655 return Nam = Name_Contract_Cases 16656 or else Nam = Name_Depends 16657 or else Nam = Name_Extensions_Visible 16658 or else Nam = Name_Global 16659 or else Nam = Name_Post 16660 or else Nam = Name_Post_Class 16661 or else Nam = Name_Postcondition 16662 or else Nam = Name_Pre 16663 or else Nam = Name_Pre_Class 16664 or else Nam = Name_Precondition 16665 or else Nam = Name_Refined_Depends 16666 or else Nam = Name_Refined_Global 16667 or else Nam = Name_Refined_Post 16668 or else Nam = Name_Test_Case; 16669 end Is_Subprogram_Contract_Annotation; 16670 16671 -------------------------------------------------- 16672 -- Is_Subprogram_Stub_Without_Prior_Declaration -- 16673 -------------------------------------------------- 16674 16675 function Is_Subprogram_Stub_Without_Prior_Declaration 16676 (N : Node_Id) return Boolean 16677 is 16678 begin 16679 -- A subprogram stub without prior declaration serves as declaration for 16680 -- the actual subprogram body. As such, it has an attached defining 16681 -- entity of E_[Generic_]Function or E_[Generic_]Procedure. 16682 16683 return Nkind (N) = N_Subprogram_Body_Stub 16684 and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body; 16685 end Is_Subprogram_Stub_Without_Prior_Declaration; 16686 16687 -------------------------- 16688 -- Is_Suspension_Object -- 16689 -------------------------- 16690 16691 function Is_Suspension_Object (Id : Entity_Id) return Boolean is 16692 begin 16693 -- This approach does an exact name match rather than to rely on 16694 -- RTSfind. Routine Is_Effectively_Volatile is used by clients of the 16695 -- front end at point where all auxiliary tables are locked and any 16696 -- modifications to them are treated as violations. Do not tamper with 16697 -- the tables, instead examine the Chars fields of all the scopes of Id. 16698 16699 return 16700 Chars (Id) = Name_Suspension_Object 16701 and then Present (Scope (Id)) 16702 and then Chars (Scope (Id)) = Name_Synchronous_Task_Control 16703 and then Present (Scope (Scope (Id))) 16704 and then Chars (Scope (Scope (Id))) = Name_Ada 16705 and then Present (Scope (Scope (Scope (Id)))) 16706 and then Scope (Scope (Scope (Id))) = Standard_Standard; 16707 end Is_Suspension_Object; 16708 16709 ---------------------------- 16710 -- Is_Synchronized_Object -- 16711 ---------------------------- 16712 16713 function Is_Synchronized_Object (Id : Entity_Id) return Boolean is 16714 Prag : Node_Id; 16715 16716 begin 16717 if Is_Object (Id) then 16718 16719 -- The object is synchronized if it is of a type that yields a 16720 -- synchronized object. 16721 16722 if Yields_Synchronized_Object (Etype (Id)) then 16723 return True; 16724 16725 -- The object is synchronized if it is atomic and Async_Writers is 16726 -- enabled. 16727 16728 elsif Is_Atomic (Id) and then Async_Writers_Enabled (Id) then 16729 return True; 16730 16731 -- A constant is a synchronized object by default 16732 16733 elsif Ekind (Id) = E_Constant then 16734 return True; 16735 16736 -- A variable is a synchronized object if it is subject to pragma 16737 -- Constant_After_Elaboration. 16738 16739 elsif Ekind (Id) = E_Variable then 16740 Prag := Get_Pragma (Id, Pragma_Constant_After_Elaboration); 16741 16742 return Present (Prag) and then Is_Enabled_Pragma (Prag); 16743 end if; 16744 end if; 16745 16746 -- Otherwise the input is not an object or it does not qualify as a 16747 -- synchronized object. 16748 16749 return False; 16750 end Is_Synchronized_Object; 16751 16752 --------------------------------- 16753 -- Is_Synchronized_Tagged_Type -- 16754 --------------------------------- 16755 16756 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is 16757 Kind : constant Entity_Kind := Ekind (Base_Type (E)); 16758 16759 begin 16760 -- A task or protected type derived from an interface is a tagged type. 16761 -- Such a tagged type is called a synchronized tagged type, as are 16762 -- synchronized interfaces and private extensions whose declaration 16763 -- includes the reserved word synchronized. 16764 16765 return (Is_Tagged_Type (E) 16766 and then (Kind = E_Task_Type 16767 or else 16768 Kind = E_Protected_Type)) 16769 or else 16770 (Is_Interface (E) 16771 and then Is_Synchronized_Interface (E)) 16772 or else 16773 (Ekind (E) = E_Record_Type_With_Private 16774 and then Nkind (Parent (E)) = N_Private_Extension_Declaration 16775 and then (Synchronized_Present (Parent (E)) 16776 or else Is_Synchronized_Interface (Etype (E)))); 16777 end Is_Synchronized_Tagged_Type; 16778 16779 ----------------- 16780 -- Is_Transfer -- 16781 ----------------- 16782 16783 function Is_Transfer (N : Node_Id) return Boolean is 16784 Kind : constant Node_Kind := Nkind (N); 16785 16786 begin 16787 if Kind = N_Simple_Return_Statement 16788 or else 16789 Kind = N_Extended_Return_Statement 16790 or else 16791 Kind = N_Goto_Statement 16792 or else 16793 Kind = N_Raise_Statement 16794 or else 16795 Kind = N_Requeue_Statement 16796 then 16797 return True; 16798 16799 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error) 16800 and then No (Condition (N)) 16801 then 16802 return True; 16803 16804 elsif Kind = N_Procedure_Call_Statement 16805 and then Is_Entity_Name (Name (N)) 16806 and then Present (Entity (Name (N))) 16807 and then No_Return (Entity (Name (N))) 16808 then 16809 return True; 16810 16811 elsif Nkind (Original_Node (N)) = N_Raise_Statement then 16812 return True; 16813 16814 else 16815 return False; 16816 end if; 16817 end Is_Transfer; 16818 16819 ------------- 16820 -- Is_True -- 16821 ------------- 16822 16823 function Is_True (U : Uint) return Boolean is 16824 begin 16825 return (U /= 0); 16826 end Is_True; 16827 16828 -------------------------------------- 16829 -- Is_Unchecked_Conversion_Instance -- 16830 -------------------------------------- 16831 16832 function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean is 16833 Par : Node_Id; 16834 16835 begin 16836 -- Look for a function whose generic parent is the predefined intrinsic 16837 -- function Unchecked_Conversion, or for one that renames such an 16838 -- instance. 16839 16840 if Ekind (Id) = E_Function then 16841 Par := Parent (Id); 16842 16843 if Nkind (Par) = N_Function_Specification then 16844 Par := Generic_Parent (Par); 16845 16846 if Present (Par) then 16847 return 16848 Chars (Par) = Name_Unchecked_Conversion 16849 and then Is_Intrinsic_Subprogram (Par) 16850 and then In_Predefined_Unit (Par); 16851 else 16852 return 16853 Present (Alias (Id)) 16854 and then Is_Unchecked_Conversion_Instance (Alias (Id)); 16855 end if; 16856 end if; 16857 end if; 16858 16859 return False; 16860 end Is_Unchecked_Conversion_Instance; 16861 16862 ------------------------------- 16863 -- Is_Universal_Numeric_Type -- 16864 ------------------------------- 16865 16866 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is 16867 begin 16868 return T = Universal_Integer or else T = Universal_Real; 16869 end Is_Universal_Numeric_Type; 16870 16871 ------------------------------ 16872 -- Is_User_Defined_Equality -- 16873 ------------------------------ 16874 16875 function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is 16876 begin 16877 return Ekind (Id) = E_Function 16878 and then Chars (Id) = Name_Op_Eq 16879 and then Comes_From_Source (Id) 16880 16881 -- Internally generated equalities have a full type declaration 16882 -- as their parent. 16883 16884 and then Nkind (Parent (Id)) = N_Function_Specification; 16885 end Is_User_Defined_Equality; 16886 16887 -------------------------------------- 16888 -- Is_Validation_Variable_Reference -- 16889 -------------------------------------- 16890 16891 function Is_Validation_Variable_Reference (N : Node_Id) return Boolean is 16892 Var : constant Node_Id := Unqual_Conv (N); 16893 Var_Id : Entity_Id; 16894 16895 begin 16896 Var_Id := Empty; 16897 16898 if Is_Entity_Name (Var) then 16899 Var_Id := Entity (Var); 16900 end if; 16901 16902 return 16903 Present (Var_Id) 16904 and then Ekind (Var_Id) = E_Variable 16905 and then Present (Validated_Object (Var_Id)); 16906 end Is_Validation_Variable_Reference; 16907 16908 ---------------------------- 16909 -- Is_Variable_Size_Array -- 16910 ---------------------------- 16911 16912 function Is_Variable_Size_Array (E : Entity_Id) return Boolean is 16913 Idx : Node_Id; 16914 16915 begin 16916 pragma Assert (Is_Array_Type (E)); 16917 16918 -- Check if some index is initialized with a non-constant value 16919 16920 Idx := First_Index (E); 16921 while Present (Idx) loop 16922 if Nkind (Idx) = N_Range then 16923 if not Is_Constant_Bound (Low_Bound (Idx)) 16924 or else not Is_Constant_Bound (High_Bound (Idx)) 16925 then 16926 return True; 16927 end if; 16928 end if; 16929 16930 Idx := Next_Index (Idx); 16931 end loop; 16932 16933 return False; 16934 end Is_Variable_Size_Array; 16935 16936 ----------------------------- 16937 -- Is_Variable_Size_Record -- 16938 ----------------------------- 16939 16940 function Is_Variable_Size_Record (E : Entity_Id) return Boolean is 16941 Comp : Entity_Id; 16942 Comp_Typ : Entity_Id; 16943 16944 begin 16945 pragma Assert (Is_Record_Type (E)); 16946 16947 Comp := First_Entity (E); 16948 while Present (Comp) loop 16949 Comp_Typ := Etype (Comp); 16950 16951 -- Recursive call if the record type has discriminants 16952 16953 if Is_Record_Type (Comp_Typ) 16954 and then Has_Discriminants (Comp_Typ) 16955 and then Is_Variable_Size_Record (Comp_Typ) 16956 then 16957 return True; 16958 16959 elsif Is_Array_Type (Comp_Typ) 16960 and then Is_Variable_Size_Array (Comp_Typ) 16961 then 16962 return True; 16963 end if; 16964 16965 Next_Entity (Comp); 16966 end loop; 16967 16968 return False; 16969 end Is_Variable_Size_Record; 16970 16971 ----------------- 16972 -- Is_Variable -- 16973 ----------------- 16974 16975 function Is_Variable 16976 (N : Node_Id; 16977 Use_Original_Node : Boolean := True) return Boolean 16978 is 16979 Orig_Node : Node_Id; 16980 16981 function In_Protected_Function (E : Entity_Id) return Boolean; 16982 -- Within a protected function, the private components of the enclosing 16983 -- protected type are constants. A function nested within a (protected) 16984 -- procedure is not itself protected. Within the body of a protected 16985 -- function the current instance of the protected type is a constant. 16986 16987 function Is_Variable_Prefix (P : Node_Id) return Boolean; 16988 -- Prefixes can involve implicit dereferences, in which case we must 16989 -- test for the case of a reference of a constant access type, which can 16990 -- can never be a variable. 16991 16992 --------------------------- 16993 -- In_Protected_Function -- 16994 --------------------------- 16995 16996 function In_Protected_Function (E : Entity_Id) return Boolean is 16997 Prot : Entity_Id; 16998 S : Entity_Id; 16999 17000 begin 17001 -- E is the current instance of a type 17002 17003 if Is_Type (E) then 17004 Prot := E; 17005 17006 -- E is an object 17007 17008 else 17009 Prot := Scope (E); 17010 end if; 17011 17012 if not Is_Protected_Type (Prot) then 17013 return False; 17014 17015 else 17016 S := Current_Scope; 17017 while Present (S) and then S /= Prot loop 17018 if Ekind (S) = E_Function and then Scope (S) = Prot then 17019 return True; 17020 end if; 17021 17022 S := Scope (S); 17023 end loop; 17024 17025 return False; 17026 end if; 17027 end In_Protected_Function; 17028 17029 ------------------------ 17030 -- Is_Variable_Prefix -- 17031 ------------------------ 17032 17033 function Is_Variable_Prefix (P : Node_Id) return Boolean is 17034 begin 17035 if Is_Access_Type (Etype (P)) then 17036 return not Is_Access_Constant (Root_Type (Etype (P))); 17037 17038 -- For the case of an indexed component whose prefix has a packed 17039 -- array type, the prefix has been rewritten into a type conversion. 17040 -- Determine variable-ness from the converted expression. 17041 17042 elsif Nkind (P) = N_Type_Conversion 17043 and then not Comes_From_Source (P) 17044 and then Is_Array_Type (Etype (P)) 17045 and then Is_Packed (Etype (P)) 17046 then 17047 return Is_Variable (Expression (P)); 17048 17049 else 17050 return Is_Variable (P); 17051 end if; 17052 end Is_Variable_Prefix; 17053 17054 -- Start of processing for Is_Variable 17055 17056 begin 17057 -- Special check, allow x'Deref(expr) as a variable 17058 17059 if Nkind (N) = N_Attribute_Reference 17060 and then Attribute_Name (N) = Name_Deref 17061 then 17062 return True; 17063 end if; 17064 17065 -- Check if we perform the test on the original node since this may be a 17066 -- test of syntactic categories which must not be disturbed by whatever 17067 -- rewriting might have occurred. For example, an aggregate, which is 17068 -- certainly NOT a variable, could be turned into a variable by 17069 -- expansion. 17070 17071 if Use_Original_Node then 17072 Orig_Node := Original_Node (N); 17073 else 17074 Orig_Node := N; 17075 end if; 17076 17077 -- Definitely OK if Assignment_OK is set. Since this is something that 17078 -- only gets set for expanded nodes, the test is on N, not Orig_Node. 17079 17080 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then 17081 return True; 17082 17083 -- Normally we go to the original node, but there is one exception where 17084 -- we use the rewritten node, namely when it is an explicit dereference. 17085 -- The generated code may rewrite a prefix which is an access type with 17086 -- an explicit dereference. The dereference is a variable, even though 17087 -- the original node may not be (since it could be a constant of the 17088 -- access type). 17089 17090 -- In Ada 2005 we have a further case to consider: the prefix may be a 17091 -- function call given in prefix notation. The original node appears to 17092 -- be a selected component, but we need to examine the call. 17093 17094 elsif Nkind (N) = N_Explicit_Dereference 17095 and then Nkind (Orig_Node) /= N_Explicit_Dereference 17096 and then Present (Etype (Orig_Node)) 17097 and then Is_Access_Type (Etype (Orig_Node)) 17098 then 17099 -- Note that if the prefix is an explicit dereference that does not 17100 -- come from source, we must check for a rewritten function call in 17101 -- prefixed notation before other forms of rewriting, to prevent a 17102 -- compiler crash. 17103 17104 return 17105 (Nkind (Orig_Node) = N_Function_Call 17106 and then not Is_Access_Constant (Etype (Prefix (N)))) 17107 or else 17108 Is_Variable_Prefix (Original_Node (Prefix (N))); 17109 17110 -- in Ada 2012, the dereference may have been added for a type with 17111 -- a declared implicit dereference aspect. Check that it is not an 17112 -- access to constant. 17113 17114 elsif Nkind (N) = N_Explicit_Dereference 17115 and then Present (Etype (Orig_Node)) 17116 and then Ada_Version >= Ada_2012 17117 and then Has_Implicit_Dereference (Etype (Orig_Node)) 17118 then 17119 return not Is_Access_Constant (Etype (Prefix (N))); 17120 17121 -- A function call is never a variable 17122 17123 elsif Nkind (N) = N_Function_Call then 17124 return False; 17125 17126 -- All remaining checks use the original node 17127 17128 elsif Is_Entity_Name (Orig_Node) 17129 and then Present (Entity (Orig_Node)) 17130 then 17131 declare 17132 E : constant Entity_Id := Entity (Orig_Node); 17133 K : constant Entity_Kind := Ekind (E); 17134 17135 begin 17136 return (K = E_Variable 17137 and then Nkind (Parent (E)) /= N_Exception_Handler) 17138 or else (K = E_Component 17139 and then not In_Protected_Function (E)) 17140 or else K = E_Out_Parameter 17141 or else K = E_In_Out_Parameter 17142 or else K = E_Generic_In_Out_Parameter 17143 17144 -- Current instance of type. If this is a protected type, check 17145 -- we are not within the body of one of its protected functions. 17146 17147 or else (Is_Type (E) 17148 and then In_Open_Scopes (E) 17149 and then not In_Protected_Function (E)) 17150 17151 or else (Is_Incomplete_Or_Private_Type (E) 17152 and then In_Open_Scopes (Full_View (E))); 17153 end; 17154 17155 else 17156 case Nkind (Orig_Node) is 17157 when N_Indexed_Component 17158 | N_Slice 17159 => 17160 return Is_Variable_Prefix (Prefix (Orig_Node)); 17161 17162 when N_Selected_Component => 17163 return (Is_Variable (Selector_Name (Orig_Node)) 17164 and then Is_Variable_Prefix (Prefix (Orig_Node))) 17165 or else 17166 (Nkind (N) = N_Expanded_Name 17167 and then Scope (Entity (N)) = Entity (Prefix (N))); 17168 17169 -- For an explicit dereference, the type of the prefix cannot 17170 -- be an access to constant or an access to subprogram. 17171 17172 when N_Explicit_Dereference => 17173 declare 17174 Typ : constant Entity_Id := Etype (Prefix (Orig_Node)); 17175 begin 17176 return Is_Access_Type (Typ) 17177 and then not Is_Access_Constant (Root_Type (Typ)) 17178 and then Ekind (Typ) /= E_Access_Subprogram_Type; 17179 end; 17180 17181 -- The type conversion is the case where we do not deal with the 17182 -- context dependent special case of an actual parameter. Thus 17183 -- the type conversion is only considered a variable for the 17184 -- purposes of this routine if the target type is tagged. However, 17185 -- a type conversion is considered to be a variable if it does not 17186 -- come from source (this deals for example with the conversions 17187 -- of expressions to their actual subtypes). 17188 17189 when N_Type_Conversion => 17190 return Is_Variable (Expression (Orig_Node)) 17191 and then 17192 (not Comes_From_Source (Orig_Node) 17193 or else 17194 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node))) 17195 and then 17196 Is_Tagged_Type (Etype (Expression (Orig_Node))))); 17197 17198 -- GNAT allows an unchecked type conversion as a variable. This 17199 -- only affects the generation of internal expanded code, since 17200 -- calls to instantiations of Unchecked_Conversion are never 17201 -- considered variables (since they are function calls). 17202 17203 when N_Unchecked_Type_Conversion => 17204 return Is_Variable (Expression (Orig_Node)); 17205 17206 when others => 17207 return False; 17208 end case; 17209 end if; 17210 end Is_Variable; 17211 17212 --------------------------- 17213 -- Is_Visibly_Controlled -- 17214 --------------------------- 17215 17216 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is 17217 Root : constant Entity_Id := Root_Type (T); 17218 begin 17219 return Chars (Scope (Root)) = Name_Finalization 17220 and then Chars (Scope (Scope (Root))) = Name_Ada 17221 and then Scope (Scope (Scope (Root))) = Standard_Standard; 17222 end Is_Visibly_Controlled; 17223 17224 -------------------------- 17225 -- Is_Volatile_Function -- 17226 -------------------------- 17227 17228 function Is_Volatile_Function (Func_Id : Entity_Id) return Boolean is 17229 begin 17230 pragma Assert (Ekind_In (Func_Id, E_Function, E_Generic_Function)); 17231 17232 -- A function declared within a protected type is volatile 17233 17234 if Is_Protected_Type (Scope (Func_Id)) then 17235 return True; 17236 17237 -- An instance of Ada.Unchecked_Conversion is a volatile function if 17238 -- either the source or the target are effectively volatile. 17239 17240 elsif Is_Unchecked_Conversion_Instance (Func_Id) 17241 and then Has_Effectively_Volatile_Profile (Func_Id) 17242 then 17243 return True; 17244 17245 -- Otherwise the function is treated as volatile if it is subject to 17246 -- enabled pragma Volatile_Function. 17247 17248 else 17249 return 17250 Is_Enabled_Pragma (Get_Pragma (Func_Id, Pragma_Volatile_Function)); 17251 end if; 17252 end Is_Volatile_Function; 17253 17254 ------------------------ 17255 -- Is_Volatile_Object -- 17256 ------------------------ 17257 17258 function Is_Volatile_Object (N : Node_Id) return Boolean is 17259 function Is_Volatile_Prefix (N : Node_Id) return Boolean; 17260 -- If prefix is an implicit dereference, examine designated type 17261 17262 function Object_Has_Volatile_Components (N : Node_Id) return Boolean; 17263 -- Determines if given object has volatile components 17264 17265 ------------------------ 17266 -- Is_Volatile_Prefix -- 17267 ------------------------ 17268 17269 function Is_Volatile_Prefix (N : Node_Id) return Boolean is 17270 Typ : constant Entity_Id := Etype (N); 17271 17272 begin 17273 if Is_Access_Type (Typ) then 17274 declare 17275 Dtyp : constant Entity_Id := Designated_Type (Typ); 17276 17277 begin 17278 return Is_Volatile (Dtyp) 17279 or else Has_Volatile_Components (Dtyp); 17280 end; 17281 17282 else 17283 return Object_Has_Volatile_Components (N); 17284 end if; 17285 end Is_Volatile_Prefix; 17286 17287 ------------------------------------ 17288 -- Object_Has_Volatile_Components -- 17289 ------------------------------------ 17290 17291 function Object_Has_Volatile_Components (N : Node_Id) return Boolean is 17292 Typ : constant Entity_Id := Etype (N); 17293 17294 begin 17295 if Is_Volatile (Typ) 17296 or else Has_Volatile_Components (Typ) 17297 then 17298 return True; 17299 17300 elsif Is_Entity_Name (N) 17301 and then (Has_Volatile_Components (Entity (N)) 17302 or else Is_Volatile (Entity (N))) 17303 then 17304 return True; 17305 17306 elsif Nkind (N) = N_Indexed_Component 17307 or else Nkind (N) = N_Selected_Component 17308 then 17309 return Is_Volatile_Prefix (Prefix (N)); 17310 17311 else 17312 return False; 17313 end if; 17314 end Object_Has_Volatile_Components; 17315 17316 -- Start of processing for Is_Volatile_Object 17317 17318 begin 17319 if Nkind (N) = N_Defining_Identifier then 17320 return Is_Volatile (N) or else Is_Volatile (Etype (N)); 17321 17322 elsif Nkind (N) = N_Expanded_Name then 17323 return Is_Volatile_Object (Entity (N)); 17324 17325 elsif Is_Volatile (Etype (N)) 17326 or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N))) 17327 then 17328 return True; 17329 17330 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) 17331 and then Is_Volatile_Prefix (Prefix (N)) 17332 then 17333 return True; 17334 17335 elsif Nkind (N) = N_Selected_Component 17336 and then Is_Volatile (Entity (Selector_Name (N))) 17337 then 17338 return True; 17339 17340 else 17341 return False; 17342 end if; 17343 end Is_Volatile_Object; 17344 17345 ----------------------------- 17346 -- Iterate_Call_Parameters -- 17347 ----------------------------- 17348 17349 procedure Iterate_Call_Parameters (Call : Node_Id) is 17350 Formal : Entity_Id := First_Formal (Get_Called_Entity (Call)); 17351 Actual : Node_Id := First_Actual (Call); 17352 17353 begin 17354 while Present (Formal) and then Present (Actual) loop 17355 Handle_Parameter (Formal, Actual); 17356 Formal := Next_Formal (Formal); 17357 Actual := Next_Actual (Actual); 17358 end loop; 17359 end Iterate_Call_Parameters; 17360 17361 --------------------------- 17362 -- Itype_Has_Declaration -- 17363 --------------------------- 17364 17365 function Itype_Has_Declaration (Id : Entity_Id) return Boolean is 17366 begin 17367 pragma Assert (Is_Itype (Id)); 17368 return Present (Parent (Id)) 17369 and then Nkind_In (Parent (Id), N_Full_Type_Declaration, 17370 N_Subtype_Declaration) 17371 and then Defining_Entity (Parent (Id)) = Id; 17372 end Itype_Has_Declaration; 17373 17374 ------------------------- 17375 -- Kill_Current_Values -- 17376 ------------------------- 17377 17378 procedure Kill_Current_Values 17379 (Ent : Entity_Id; 17380 Last_Assignment_Only : Boolean := False) 17381 is 17382 begin 17383 if Is_Assignable (Ent) then 17384 Set_Last_Assignment (Ent, Empty); 17385 end if; 17386 17387 if Is_Object (Ent) then 17388 if not Last_Assignment_Only then 17389 Kill_Checks (Ent); 17390 Set_Current_Value (Ent, Empty); 17391 17392 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags 17393 -- for a constant. Once the constant is elaborated, its value is 17394 -- not changed, therefore the associated flags that describe the 17395 -- value should not be modified either. 17396 17397 if Ekind (Ent) = E_Constant then 17398 null; 17399 17400 -- Non-constant entities 17401 17402 else 17403 if not Can_Never_Be_Null (Ent) then 17404 Set_Is_Known_Non_Null (Ent, False); 17405 end if; 17406 17407 Set_Is_Known_Null (Ent, False); 17408 17409 -- Reset the Is_Known_Valid flag unless the type is always 17410 -- valid. This does not apply to a loop parameter because its 17411 -- bounds are defined by the loop header and therefore always 17412 -- valid. 17413 17414 if not Is_Known_Valid (Etype (Ent)) 17415 and then Ekind (Ent) /= E_Loop_Parameter 17416 then 17417 Set_Is_Known_Valid (Ent, False); 17418 end if; 17419 end if; 17420 end if; 17421 end if; 17422 end Kill_Current_Values; 17423 17424 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is 17425 S : Entity_Id; 17426 17427 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id); 17428 -- Clear current value for entity E and all entities chained to E 17429 17430 ------------------------------------------ 17431 -- Kill_Current_Values_For_Entity_Chain -- 17432 ------------------------------------------ 17433 17434 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is 17435 Ent : Entity_Id; 17436 begin 17437 Ent := E; 17438 while Present (Ent) loop 17439 Kill_Current_Values (Ent, Last_Assignment_Only); 17440 Next_Entity (Ent); 17441 end loop; 17442 end Kill_Current_Values_For_Entity_Chain; 17443 17444 -- Start of processing for Kill_Current_Values 17445 17446 begin 17447 -- Kill all saved checks, a special case of killing saved values 17448 17449 if not Last_Assignment_Only then 17450 Kill_All_Checks; 17451 end if; 17452 17453 -- Loop through relevant scopes, which includes the current scope and 17454 -- any parent scopes if the current scope is a block or a package. 17455 17456 S := Current_Scope; 17457 Scope_Loop : loop 17458 17459 -- Clear current values of all entities in current scope 17460 17461 Kill_Current_Values_For_Entity_Chain (First_Entity (S)); 17462 17463 -- If scope is a package, also clear current values of all private 17464 -- entities in the scope. 17465 17466 if Is_Package_Or_Generic_Package (S) 17467 or else Is_Concurrent_Type (S) 17468 then 17469 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S)); 17470 end if; 17471 17472 -- If this is a not a subprogram, deal with parents 17473 17474 if not Is_Subprogram (S) then 17475 S := Scope (S); 17476 exit Scope_Loop when S = Standard_Standard; 17477 else 17478 exit Scope_Loop; 17479 end if; 17480 end loop Scope_Loop; 17481 end Kill_Current_Values; 17482 17483 -------------------------- 17484 -- Kill_Size_Check_Code -- 17485 -------------------------- 17486 17487 procedure Kill_Size_Check_Code (E : Entity_Id) is 17488 begin 17489 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 17490 and then Present (Size_Check_Code (E)) 17491 then 17492 Remove (Size_Check_Code (E)); 17493 Set_Size_Check_Code (E, Empty); 17494 end if; 17495 end Kill_Size_Check_Code; 17496 17497 -------------------- 17498 -- Known_Non_Null -- 17499 -------------------- 17500 17501 function Known_Non_Null (N : Node_Id) return Boolean is 17502 Status : constant Null_Status_Kind := Null_Status (N); 17503 17504 Id : Entity_Id; 17505 Op : Node_Kind; 17506 Val : Node_Id; 17507 17508 begin 17509 -- The expression yields a non-null value ignoring simple flow analysis 17510 17511 if Status = Is_Non_Null then 17512 return True; 17513 17514 -- Otherwise check whether N is a reference to an entity that appears 17515 -- within a conditional construct. 17516 17517 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 17518 17519 -- First check if we are in decisive conditional 17520 17521 Get_Current_Value_Condition (N, Op, Val); 17522 17523 if Known_Null (Val) then 17524 if Op = N_Op_Eq then 17525 return False; 17526 elsif Op = N_Op_Ne then 17527 return True; 17528 end if; 17529 end if; 17530 17531 -- If OK to do replacement, test Is_Known_Non_Null flag 17532 17533 Id := Entity (N); 17534 17535 if OK_To_Do_Constant_Replacement (Id) then 17536 return Is_Known_Non_Null (Id); 17537 end if; 17538 end if; 17539 17540 -- Otherwise it is not possible to determine whether N yields a non-null 17541 -- value. 17542 17543 return False; 17544 end Known_Non_Null; 17545 17546 ---------------- 17547 -- Known_Null -- 17548 ---------------- 17549 17550 function Known_Null (N : Node_Id) return Boolean is 17551 Status : constant Null_Status_Kind := Null_Status (N); 17552 17553 Id : Entity_Id; 17554 Op : Node_Kind; 17555 Val : Node_Id; 17556 17557 begin 17558 -- The expression yields a null value ignoring simple flow analysis 17559 17560 if Status = Is_Null then 17561 return True; 17562 17563 -- Otherwise check whether N is a reference to an entity that appears 17564 -- within a conditional construct. 17565 17566 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 17567 17568 -- First check if we are in decisive conditional 17569 17570 Get_Current_Value_Condition (N, Op, Val); 17571 17572 if Known_Null (Val) then 17573 if Op = N_Op_Eq then 17574 return True; 17575 elsif Op = N_Op_Ne then 17576 return False; 17577 end if; 17578 end if; 17579 17580 -- If OK to do replacement, test Is_Known_Null flag 17581 17582 Id := Entity (N); 17583 17584 if OK_To_Do_Constant_Replacement (Id) then 17585 return Is_Known_Null (Id); 17586 end if; 17587 end if; 17588 17589 -- Otherwise it is not possible to determine whether N yields a null 17590 -- value. 17591 17592 return False; 17593 end Known_Null; 17594 17595 -------------------------- 17596 -- Known_To_Be_Assigned -- 17597 -------------------------- 17598 17599 function Known_To_Be_Assigned (N : Node_Id) return Boolean is 17600 P : constant Node_Id := Parent (N); 17601 17602 begin 17603 case Nkind (P) is 17604 17605 -- Test left side of assignment 17606 17607 when N_Assignment_Statement => 17608 return N = Name (P); 17609 17610 -- Function call arguments are never lvalues 17611 17612 when N_Function_Call => 17613 return False; 17614 17615 -- Positional parameter for procedure or accept call 17616 17617 when N_Accept_Statement 17618 | N_Procedure_Call_Statement 17619 => 17620 declare 17621 Proc : Entity_Id; 17622 Form : Entity_Id; 17623 Act : Node_Id; 17624 17625 begin 17626 Proc := Get_Subprogram_Entity (P); 17627 17628 if No (Proc) then 17629 return False; 17630 end if; 17631 17632 -- If we are not a list member, something is strange, so 17633 -- be conservative and return False. 17634 17635 if not Is_List_Member (N) then 17636 return False; 17637 end if; 17638 17639 -- We are going to find the right formal by stepping forward 17640 -- through the formals, as we step backwards in the actuals. 17641 17642 Form := First_Formal (Proc); 17643 Act := N; 17644 loop 17645 -- If no formal, something is weird, so be conservative 17646 -- and return False. 17647 17648 if No (Form) then 17649 return False; 17650 end if; 17651 17652 Prev (Act); 17653 exit when No (Act); 17654 Next_Formal (Form); 17655 end loop; 17656 17657 return Ekind (Form) /= E_In_Parameter; 17658 end; 17659 17660 -- Named parameter for procedure or accept call 17661 17662 when N_Parameter_Association => 17663 declare 17664 Proc : Entity_Id; 17665 Form : Entity_Id; 17666 17667 begin 17668 Proc := Get_Subprogram_Entity (Parent (P)); 17669 17670 if No (Proc) then 17671 return False; 17672 end if; 17673 17674 -- Loop through formals to find the one that matches 17675 17676 Form := First_Formal (Proc); 17677 loop 17678 -- If no matching formal, that's peculiar, some kind of 17679 -- previous error, so return False to be conservative. 17680 -- Actually this also happens in legal code in the case 17681 -- where P is a parameter association for an Extra_Formal??? 17682 17683 if No (Form) then 17684 return False; 17685 end if; 17686 17687 -- Else test for match 17688 17689 if Chars (Form) = Chars (Selector_Name (P)) then 17690 return Ekind (Form) /= E_In_Parameter; 17691 end if; 17692 17693 Next_Formal (Form); 17694 end loop; 17695 end; 17696 17697 -- Test for appearing in a conversion that itself appears 17698 -- in an lvalue context, since this should be an lvalue. 17699 17700 when N_Type_Conversion => 17701 return Known_To_Be_Assigned (P); 17702 17703 -- All other references are definitely not known to be modifications 17704 17705 when others => 17706 return False; 17707 end case; 17708 end Known_To_Be_Assigned; 17709 17710 --------------------------- 17711 -- Last_Source_Statement -- 17712 --------------------------- 17713 17714 function Last_Source_Statement (HSS : Node_Id) return Node_Id is 17715 N : Node_Id; 17716 17717 begin 17718 N := Last (Statements (HSS)); 17719 while Present (N) loop 17720 exit when Comes_From_Source (N); 17721 Prev (N); 17722 end loop; 17723 17724 return N; 17725 end Last_Source_Statement; 17726 17727 ----------------------- 17728 -- Mark_Coextensions -- 17729 ----------------------- 17730 17731 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is 17732 Is_Dynamic : Boolean; 17733 -- Indicates whether the context causes nested coextensions to be 17734 -- dynamic or static 17735 17736 function Mark_Allocator (N : Node_Id) return Traverse_Result; 17737 -- Recognize an allocator node and label it as a dynamic coextension 17738 17739 -------------------- 17740 -- Mark_Allocator -- 17741 -------------------- 17742 17743 function Mark_Allocator (N : Node_Id) return Traverse_Result is 17744 begin 17745 if Nkind (N) = N_Allocator then 17746 if Is_Dynamic then 17747 Set_Is_Dynamic_Coextension (N); 17748 17749 -- If the allocator expression is potentially dynamic, it may 17750 -- be expanded out of order and require dynamic allocation 17751 -- anyway, so we treat the coextension itself as dynamic. 17752 -- Potential optimization ??? 17753 17754 elsif Nkind (Expression (N)) = N_Qualified_Expression 17755 and then Nkind (Expression (Expression (N))) = N_Op_Concat 17756 then 17757 Set_Is_Dynamic_Coextension (N); 17758 else 17759 Set_Is_Static_Coextension (N); 17760 end if; 17761 end if; 17762 17763 return OK; 17764 end Mark_Allocator; 17765 17766 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator); 17767 17768 -- Start of processing for Mark_Coextensions 17769 17770 begin 17771 -- An allocator that appears on the right-hand side of an assignment is 17772 -- treated as a potentially dynamic coextension when the right-hand side 17773 -- is an allocator or a qualified expression. 17774 17775 -- Obj := new ...'(new Coextension ...); 17776 17777 if Nkind (Context_Nod) = N_Assignment_Statement then 17778 Is_Dynamic := 17779 Nkind_In (Expression (Context_Nod), N_Allocator, 17780 N_Qualified_Expression); 17781 17782 -- An allocator that appears within the expression of a simple return 17783 -- statement is treated as a potentially dynamic coextension when the 17784 -- expression is either aggregate, allocator, or qualified expression. 17785 17786 -- return (new Coextension ...); 17787 -- return new ...'(new Coextension ...); 17788 17789 elsif Nkind (Context_Nod) = N_Simple_Return_Statement then 17790 Is_Dynamic := 17791 Nkind_In (Expression (Context_Nod), N_Aggregate, 17792 N_Allocator, 17793 N_Qualified_Expression); 17794 17795 -- An alloctor that appears within the initialization expression of an 17796 -- object declaration is considered a potentially dynamic coextension 17797 -- when the initialization expression is an allocator or a qualified 17798 -- expression. 17799 17800 -- Obj : ... := new ...'(new Coextension ...); 17801 17802 -- A similar case arises when the object declaration is part of an 17803 -- extended return statement. 17804 17805 -- return Obj : ... := new ...'(new Coextension ...); 17806 -- return Obj : ... := (new Coextension ...); 17807 17808 elsif Nkind (Context_Nod) = N_Object_Declaration then 17809 Is_Dynamic := 17810 Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression) 17811 or else 17812 Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement; 17813 17814 -- This routine should not be called with constructs that cannot contain 17815 -- coextensions. 17816 17817 else 17818 raise Program_Error; 17819 end if; 17820 17821 Mark_Allocators (Root_Nod); 17822 end Mark_Coextensions; 17823 17824 --------------------------------- 17825 -- Mark_Elaboration_Attributes -- 17826 --------------------------------- 17827 17828 procedure Mark_Elaboration_Attributes 17829 (N_Id : Node_Or_Entity_Id; 17830 Checks : Boolean := False; 17831 Level : Boolean := False; 17832 Modes : Boolean := False; 17833 Warnings : Boolean := False) 17834 is 17835 function Elaboration_Checks_OK 17836 (Target_Id : Entity_Id; 17837 Context_Id : Entity_Id) return Boolean; 17838 -- Determine whether elaboration checks are enabled for target Target_Id 17839 -- which resides within context Context_Id. 17840 17841 procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id); 17842 -- Preserve relevant attributes of the context in arbitrary entity Id 17843 17844 procedure Mark_Elaboration_Attributes_Node (N : Node_Id); 17845 -- Preserve relevant attributes of the context in arbitrary node N 17846 17847 --------------------------- 17848 -- Elaboration_Checks_OK -- 17849 --------------------------- 17850 17851 function Elaboration_Checks_OK 17852 (Target_Id : Entity_Id; 17853 Context_Id : Entity_Id) return Boolean 17854 is 17855 Encl_Scop : Entity_Id; 17856 17857 begin 17858 -- Elaboration checks are suppressed for the target 17859 17860 if Elaboration_Checks_Suppressed (Target_Id) then 17861 return False; 17862 end if; 17863 17864 -- Otherwise elaboration checks are OK for the target, but may be 17865 -- suppressed for the context where the target is declared. 17866 17867 Encl_Scop := Context_Id; 17868 while Present (Encl_Scop) and then Encl_Scop /= Standard_Standard loop 17869 if Elaboration_Checks_Suppressed (Encl_Scop) then 17870 return False; 17871 end if; 17872 17873 Encl_Scop := Scope (Encl_Scop); 17874 end loop; 17875 17876 -- Neither the target nor its declarative context have elaboration 17877 -- checks suppressed. 17878 17879 return True; 17880 end Elaboration_Checks_OK; 17881 17882 ------------------------------------ 17883 -- Mark_Elaboration_Attributes_Id -- 17884 ------------------------------------ 17885 17886 procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id) is 17887 begin 17888 -- Mark the status of elaboration checks in effect. Do not reset the 17889 -- status in case the entity is reanalyzed with checks suppressed. 17890 17891 if Checks and then not Is_Elaboration_Checks_OK_Id (Id) then 17892 Set_Is_Elaboration_Checks_OK_Id (Id, 17893 Elaboration_Checks_OK 17894 (Target_Id => Id, 17895 Context_Id => Scope (Id))); 17896 17897 -- Entities do not need to capture their enclosing level. The Ghost 17898 -- and SPARK modes in effect are already marked during analysis. 17899 17900 else 17901 null; 17902 end if; 17903 end Mark_Elaboration_Attributes_Id; 17904 17905 -------------------------------------- 17906 -- Mark_Elaboration_Attributes_Node -- 17907 -------------------------------------- 17908 17909 procedure Mark_Elaboration_Attributes_Node (N : Node_Id) is 17910 function Extract_Name (N : Node_Id) return Node_Id; 17911 -- Obtain the Name attribute of call or instantiation N 17912 17913 ------------------ 17914 -- Extract_Name -- 17915 ------------------ 17916 17917 function Extract_Name (N : Node_Id) return Node_Id is 17918 Nam : Node_Id; 17919 17920 begin 17921 Nam := Name (N); 17922 17923 -- A call to an entry family appears in indexed form 17924 17925 if Nkind (Nam) = N_Indexed_Component then 17926 Nam := Prefix (Nam); 17927 end if; 17928 17929 -- The name may also appear in qualified form 17930 17931 if Nkind (Nam) = N_Selected_Component then 17932 Nam := Selector_Name (Nam); 17933 end if; 17934 17935 return Nam; 17936 end Extract_Name; 17937 17938 -- Local variables 17939 17940 Context_Id : Entity_Id; 17941 Nam : Node_Id; 17942 17943 -- Start of processing for Mark_Elaboration_Attributes_Node 17944 17945 begin 17946 -- Mark the status of elaboration checks in effect. Do not reset the 17947 -- status in case the node is reanalyzed with checks suppressed. 17948 17949 if Checks and then not Is_Elaboration_Checks_OK_Node (N) then 17950 17951 -- Assignments, attribute references, and variable references do 17952 -- not have a "declarative" context. 17953 17954 Context_Id := Empty; 17955 17956 -- The status of elaboration checks for calls and instantiations 17957 -- depends on the most recent pragma Suppress/Unsuppress, as well 17958 -- as the suppression status of the context where the target is 17959 -- defined. 17960 17961 -- package Pack is 17962 -- function Func ...; 17963 -- end Pack; 17964 17965 -- with Pack; 17966 -- procedure Main is 17967 -- pragma Suppress (Elaboration_Checks, Pack); 17968 -- X : ... := Pack.Func; 17969 -- ... 17970 17971 -- In the example above, the call to Func has elaboration checks 17972 -- enabled because there is no active general purpose suppression 17973 -- pragma, however the elaboration checks of Pack are explicitly 17974 -- suppressed. As a result the elaboration checks of the call must 17975 -- be disabled in order to preserve this dependency. 17976 17977 if Nkind_In (N, N_Entry_Call_Statement, 17978 N_Function_Call, 17979 N_Function_Instantiation, 17980 N_Package_Instantiation, 17981 N_Procedure_Call_Statement, 17982 N_Procedure_Instantiation) 17983 then 17984 Nam := Extract_Name (N); 17985 17986 if Is_Entity_Name (Nam) and then Present (Entity (Nam)) then 17987 Context_Id := Scope (Entity (Nam)); 17988 end if; 17989 end if; 17990 17991 Set_Is_Elaboration_Checks_OK_Node (N, 17992 Elaboration_Checks_OK 17993 (Target_Id => Empty, 17994 Context_Id => Context_Id)); 17995 end if; 17996 17997 -- Mark the enclosing level of the node. Do not reset the status in 17998 -- case the node is relocated and reanalyzed. 17999 18000 if Level and then not Is_Declaration_Level_Node (N) then 18001 Set_Is_Declaration_Level_Node (N, 18002 Find_Enclosing_Level (N) = Declaration_Level); 18003 end if; 18004 18005 -- Mark the Ghost and SPARK mode in effect 18006 18007 if Modes then 18008 if Ghost_Mode = Ignore then 18009 Set_Is_Ignored_Ghost_Node (N); 18010 end if; 18011 18012 if SPARK_Mode = On then 18013 Set_Is_SPARK_Mode_On_Node (N); 18014 end if; 18015 end if; 18016 18017 -- Mark the status of elaboration warnings in effect. Do not reset 18018 -- the status in case the node is reanalyzed with warnings off. 18019 18020 if Warnings and then not Is_Elaboration_Warnings_OK_Node (N) then 18021 Set_Is_Elaboration_Warnings_OK_Node (N, Elab_Warnings); 18022 end if; 18023 end Mark_Elaboration_Attributes_Node; 18024 18025 -- Start of processing for Mark_Elaboration_Attributes 18026 18027 begin 18028 -- Do not capture any elaboration-related attributes when switch -gnatH 18029 -- (legacy elaboration checking mode enabled) is in effect because the 18030 -- attributes are useless to the legacy model. 18031 18032 if Legacy_Elaboration_Checks then 18033 return; 18034 end if; 18035 18036 if Nkind (N_Id) in N_Entity then 18037 Mark_Elaboration_Attributes_Id (N_Id); 18038 else 18039 Mark_Elaboration_Attributes_Node (N_Id); 18040 end if; 18041 end Mark_Elaboration_Attributes; 18042 18043 ---------------------------------- 18044 -- Matching_Static_Array_Bounds -- 18045 ---------------------------------- 18046 18047 function Matching_Static_Array_Bounds 18048 (L_Typ : Node_Id; 18049 R_Typ : Node_Id) return Boolean 18050 is 18051 L_Ndims : constant Nat := Number_Dimensions (L_Typ); 18052 R_Ndims : constant Nat := Number_Dimensions (R_Typ); 18053 18054 L_Index : Node_Id := Empty; -- init to ... 18055 R_Index : Node_Id := Empty; -- ...avoid warnings 18056 L_Low : Node_Id; 18057 L_High : Node_Id; 18058 L_Len : Uint; 18059 R_Low : Node_Id; 18060 R_High : Node_Id; 18061 R_Len : Uint; 18062 18063 begin 18064 if L_Ndims /= R_Ndims then 18065 return False; 18066 end if; 18067 18068 -- Unconstrained types do not have static bounds 18069 18070 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then 18071 return False; 18072 end if; 18073 18074 -- First treat specially the first dimension, as the lower bound and 18075 -- length of string literals are not stored like those of arrays. 18076 18077 if Ekind (L_Typ) = E_String_Literal_Subtype then 18078 L_Low := String_Literal_Low_Bound (L_Typ); 18079 L_Len := String_Literal_Length (L_Typ); 18080 else 18081 L_Index := First_Index (L_Typ); 18082 Get_Index_Bounds (L_Index, L_Low, L_High); 18083 18084 if Is_OK_Static_Expression (L_Low) 18085 and then 18086 Is_OK_Static_Expression (L_High) 18087 then 18088 if Expr_Value (L_High) < Expr_Value (L_Low) then 18089 L_Len := Uint_0; 18090 else 18091 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1; 18092 end if; 18093 else 18094 return False; 18095 end if; 18096 end if; 18097 18098 if Ekind (R_Typ) = E_String_Literal_Subtype then 18099 R_Low := String_Literal_Low_Bound (R_Typ); 18100 R_Len := String_Literal_Length (R_Typ); 18101 else 18102 R_Index := First_Index (R_Typ); 18103 Get_Index_Bounds (R_Index, R_Low, R_High); 18104 18105 if Is_OK_Static_Expression (R_Low) 18106 and then 18107 Is_OK_Static_Expression (R_High) 18108 then 18109 if Expr_Value (R_High) < Expr_Value (R_Low) then 18110 R_Len := Uint_0; 18111 else 18112 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1; 18113 end if; 18114 else 18115 return False; 18116 end if; 18117 end if; 18118 18119 if (Is_OK_Static_Expression (L_Low) 18120 and then 18121 Is_OK_Static_Expression (R_Low)) 18122 and then Expr_Value (L_Low) = Expr_Value (R_Low) 18123 and then L_Len = R_Len 18124 then 18125 null; 18126 else 18127 return False; 18128 end if; 18129 18130 -- Then treat all other dimensions 18131 18132 for Indx in 2 .. L_Ndims loop 18133 Next (L_Index); 18134 Next (R_Index); 18135 18136 Get_Index_Bounds (L_Index, L_Low, L_High); 18137 Get_Index_Bounds (R_Index, R_Low, R_High); 18138 18139 if (Is_OK_Static_Expression (L_Low) and then 18140 Is_OK_Static_Expression (L_High) and then 18141 Is_OK_Static_Expression (R_Low) and then 18142 Is_OK_Static_Expression (R_High)) 18143 and then (Expr_Value (L_Low) = Expr_Value (R_Low) 18144 and then 18145 Expr_Value (L_High) = Expr_Value (R_High)) 18146 then 18147 null; 18148 else 18149 return False; 18150 end if; 18151 end loop; 18152 18153 -- If we fall through the loop, all indexes matched 18154 18155 return True; 18156 end Matching_Static_Array_Bounds; 18157 18158 ------------------- 18159 -- May_Be_Lvalue -- 18160 ------------------- 18161 18162 function May_Be_Lvalue (N : Node_Id) return Boolean is 18163 P : constant Node_Id := Parent (N); 18164 18165 begin 18166 case Nkind (P) is 18167 18168 -- Test left side of assignment 18169 18170 when N_Assignment_Statement => 18171 return N = Name (P); 18172 18173 -- Test prefix of component or attribute. Note that the prefix of an 18174 -- explicit or implicit dereference cannot be an l-value. In the case 18175 -- of a 'Read attribute, the reference can be an actual in the 18176 -- argument list of the attribute. 18177 18178 when N_Attribute_Reference => 18179 return (N = Prefix (P) 18180 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P))) 18181 or else 18182 Attribute_Name (P) = Name_Read; 18183 18184 -- For an expanded name, the name is an lvalue if the expanded name 18185 -- is an lvalue, but the prefix is never an lvalue, since it is just 18186 -- the scope where the name is found. 18187 18188 when N_Expanded_Name => 18189 if N = Prefix (P) then 18190 return May_Be_Lvalue (P); 18191 else 18192 return False; 18193 end if; 18194 18195 -- For a selected component A.B, A is certainly an lvalue if A.B is. 18196 -- B is a little interesting, if we have A.B := 3, there is some 18197 -- discussion as to whether B is an lvalue or not, we choose to say 18198 -- it is. Note however that A is not an lvalue if it is of an access 18199 -- type since this is an implicit dereference. 18200 18201 when N_Selected_Component => 18202 if N = Prefix (P) 18203 and then Present (Etype (N)) 18204 and then Is_Access_Type (Etype (N)) 18205 then 18206 return False; 18207 else 18208 return May_Be_Lvalue (P); 18209 end if; 18210 18211 -- For an indexed component or slice, the index or slice bounds is 18212 -- never an lvalue. The prefix is an lvalue if the indexed component 18213 -- or slice is an lvalue, except if it is an access type, where we 18214 -- have an implicit dereference. 18215 18216 when N_Indexed_Component 18217 | N_Slice 18218 => 18219 if N /= Prefix (P) 18220 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N))) 18221 then 18222 return False; 18223 else 18224 return May_Be_Lvalue (P); 18225 end if; 18226 18227 -- Prefix of a reference is an lvalue if the reference is an lvalue 18228 18229 when N_Reference => 18230 return May_Be_Lvalue (P); 18231 18232 -- Prefix of explicit dereference is never an lvalue 18233 18234 when N_Explicit_Dereference => 18235 return False; 18236 18237 -- Positional parameter for subprogram, entry, or accept call. 18238 -- In older versions of Ada function call arguments are never 18239 -- lvalues. In Ada 2012 functions can have in-out parameters. 18240 18241 when N_Accept_Statement 18242 | N_Entry_Call_Statement 18243 | N_Subprogram_Call 18244 => 18245 if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then 18246 return False; 18247 end if; 18248 18249 -- The following mechanism is clumsy and fragile. A single flag 18250 -- set in Resolve_Actuals would be preferable ??? 18251 18252 declare 18253 Proc : Entity_Id; 18254 Form : Entity_Id; 18255 Act : Node_Id; 18256 18257 begin 18258 Proc := Get_Subprogram_Entity (P); 18259 18260 if No (Proc) then 18261 return True; 18262 end if; 18263 18264 -- If we are not a list member, something is strange, so be 18265 -- conservative and return True. 18266 18267 if not Is_List_Member (N) then 18268 return True; 18269 end if; 18270 18271 -- We are going to find the right formal by stepping forward 18272 -- through the formals, as we step backwards in the actuals. 18273 18274 Form := First_Formal (Proc); 18275 Act := N; 18276 loop 18277 -- If no formal, something is weird, so be conservative and 18278 -- return True. 18279 18280 if No (Form) then 18281 return True; 18282 end if; 18283 18284 Prev (Act); 18285 exit when No (Act); 18286 Next_Formal (Form); 18287 end loop; 18288 18289 return Ekind (Form) /= E_In_Parameter; 18290 end; 18291 18292 -- Named parameter for procedure or accept call 18293 18294 when N_Parameter_Association => 18295 declare 18296 Proc : Entity_Id; 18297 Form : Entity_Id; 18298 18299 begin 18300 Proc := Get_Subprogram_Entity (Parent (P)); 18301 18302 if No (Proc) then 18303 return True; 18304 end if; 18305 18306 -- Loop through formals to find the one that matches 18307 18308 Form := First_Formal (Proc); 18309 loop 18310 -- If no matching formal, that's peculiar, some kind of 18311 -- previous error, so return True to be conservative. 18312 -- Actually happens with legal code for an unresolved call 18313 -- where we may get the wrong homonym??? 18314 18315 if No (Form) then 18316 return True; 18317 end if; 18318 18319 -- Else test for match 18320 18321 if Chars (Form) = Chars (Selector_Name (P)) then 18322 return Ekind (Form) /= E_In_Parameter; 18323 end if; 18324 18325 Next_Formal (Form); 18326 end loop; 18327 end; 18328 18329 -- Test for appearing in a conversion that itself appears in an 18330 -- lvalue context, since this should be an lvalue. 18331 18332 when N_Type_Conversion => 18333 return May_Be_Lvalue (P); 18334 18335 -- Test for appearance in object renaming declaration 18336 18337 when N_Object_Renaming_Declaration => 18338 return True; 18339 18340 -- All other references are definitely not lvalues 18341 18342 when others => 18343 return False; 18344 end case; 18345 end May_Be_Lvalue; 18346 18347 ----------------- 18348 -- Might_Raise -- 18349 ----------------- 18350 18351 function Might_Raise (N : Node_Id) return Boolean is 18352 Result : Boolean := False; 18353 18354 function Process (N : Node_Id) return Traverse_Result; 18355 -- Set Result to True if we find something that could raise an exception 18356 18357 ------------- 18358 -- Process -- 18359 ------------- 18360 18361 function Process (N : Node_Id) return Traverse_Result is 18362 begin 18363 if Nkind_In (N, N_Procedure_Call_Statement, 18364 N_Function_Call, 18365 N_Raise_Statement, 18366 N_Raise_Constraint_Error, 18367 N_Raise_Program_Error, 18368 N_Raise_Storage_Error) 18369 then 18370 Result := True; 18371 return Abandon; 18372 else 18373 return OK; 18374 end if; 18375 end Process; 18376 18377 procedure Set_Result is new Traverse_Proc (Process); 18378 18379 -- Start of processing for Might_Raise 18380 18381 begin 18382 -- False if exceptions can't be propagated 18383 18384 if No_Exception_Handlers_Set then 18385 return False; 18386 end if; 18387 18388 -- If the checks handled by the back end are not disabled, we cannot 18389 -- ensure that no exception will be raised. 18390 18391 if not Access_Checks_Suppressed (Empty) 18392 or else not Discriminant_Checks_Suppressed (Empty) 18393 or else not Range_Checks_Suppressed (Empty) 18394 or else not Index_Checks_Suppressed (Empty) 18395 or else Opt.Stack_Checking_Enabled 18396 then 18397 return True; 18398 end if; 18399 18400 Set_Result (N); 18401 return Result; 18402 end Might_Raise; 18403 18404 -------------------------------- 18405 -- Nearest_Enclosing_Instance -- 18406 -------------------------------- 18407 18408 function Nearest_Enclosing_Instance (E : Entity_Id) return Entity_Id is 18409 Inst : Entity_Id; 18410 18411 begin 18412 Inst := Scope (E); 18413 while Present (Inst) and then Inst /= Standard_Standard loop 18414 if Is_Generic_Instance (Inst) then 18415 return Inst; 18416 end if; 18417 18418 Inst := Scope (Inst); 18419 end loop; 18420 18421 return Empty; 18422 end Nearest_Enclosing_Instance; 18423 18424 ---------------------- 18425 -- Needs_One_Actual -- 18426 ---------------------- 18427 18428 function Needs_One_Actual (E : Entity_Id) return Boolean is 18429 Formal : Entity_Id; 18430 18431 begin 18432 -- Ada 2005 or later, and formals present. The first formal must be 18433 -- of a type that supports prefix notation: a controlling argument, 18434 -- a class-wide type, or an access to such. 18435 18436 if Ada_Version >= Ada_2005 18437 and then Present (First_Formal (E)) 18438 and then No (Default_Value (First_Formal (E))) 18439 and then 18440 (Is_Controlling_Formal (First_Formal (E)) 18441 or else Is_Class_Wide_Type (Etype (First_Formal (E))) 18442 or else Is_Anonymous_Access_Type (Etype (First_Formal (E)))) 18443 then 18444 Formal := Next_Formal (First_Formal (E)); 18445 while Present (Formal) loop 18446 if No (Default_Value (Formal)) then 18447 return False; 18448 end if; 18449 18450 Next_Formal (Formal); 18451 end loop; 18452 18453 return True; 18454 18455 -- Ada 83/95 or no formals 18456 18457 else 18458 return False; 18459 end if; 18460 end Needs_One_Actual; 18461 18462 ------------------------ 18463 -- New_Copy_List_Tree -- 18464 ------------------------ 18465 18466 function New_Copy_List_Tree (List : List_Id) return List_Id is 18467 NL : List_Id; 18468 E : Node_Id; 18469 18470 begin 18471 if List = No_List then 18472 return No_List; 18473 18474 else 18475 NL := New_List; 18476 E := First (List); 18477 18478 while Present (E) loop 18479 Append (New_Copy_Tree (E), NL); 18480 E := Next (E); 18481 end loop; 18482 18483 return NL; 18484 end if; 18485 end New_Copy_List_Tree; 18486 18487 ------------------- 18488 -- New_Copy_Tree -- 18489 ------------------- 18490 18491 -- The following tables play a key role in replicating entities and Itypes. 18492 -- They are intentionally declared at the library level rather than within 18493 -- New_Copy_Tree to avoid elaborating them on each call. This performance 18494 -- optimization saves up to 2% of the entire compilation time spent in the 18495 -- front end. Care should be taken to reset the tables on each new call to 18496 -- New_Copy_Tree. 18497 18498 NCT_Table_Max : constant := 511; 18499 18500 subtype NCT_Table_Index is Nat range 0 .. NCT_Table_Max - 1; 18501 18502 function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index; 18503 -- Obtain the hash value of node or entity Key 18504 18505 -------------------- 18506 -- NCT_Table_Hash -- 18507 -------------------- 18508 18509 function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index is 18510 begin 18511 return NCT_Table_Index (Key mod NCT_Table_Max); 18512 end NCT_Table_Hash; 18513 18514 ---------------------- 18515 -- NCT_New_Entities -- 18516 ---------------------- 18517 18518 -- The following table maps old entities and Itypes to their corresponding 18519 -- new entities and Itypes. 18520 18521 -- Aaa -> Xxx 18522 18523 package NCT_New_Entities is new Simple_HTable ( 18524 Header_Num => NCT_Table_Index, 18525 Element => Entity_Id, 18526 No_Element => Empty, 18527 Key => Entity_Id, 18528 Hash => NCT_Table_Hash, 18529 Equal => "="); 18530 18531 ------------------------ 18532 -- NCT_Pending_Itypes -- 18533 ------------------------ 18534 18535 -- The following table maps old Associated_Node_For_Itype nodes to a set of 18536 -- new itypes. Given a set of old Itypes Aaa, Bbb, and Ccc, where all three 18537 -- have the same Associated_Node_For_Itype Ppp, and their corresponding new 18538 -- Itypes Xxx, Yyy, Zzz, the table contains the following mapping: 18539 18540 -- Ppp -> (Xxx, Yyy, Zzz) 18541 18542 -- The set is expressed as an Elist 18543 18544 package NCT_Pending_Itypes is new Simple_HTable ( 18545 Header_Num => NCT_Table_Index, 18546 Element => Elist_Id, 18547 No_Element => No_Elist, 18548 Key => Node_Id, 18549 Hash => NCT_Table_Hash, 18550 Equal => "="); 18551 18552 NCT_Tables_In_Use : Boolean := False; 18553 -- This flag keeps track of whether the two tables NCT_New_Entities and 18554 -- NCT_Pending_Itypes are in use. The flag is part of an optimization 18555 -- where certain operations are not performed if the tables are not in 18556 -- use. This saves up to 8% of the entire compilation time spent in the 18557 -- front end. 18558 18559 ------------------- 18560 -- New_Copy_Tree -- 18561 ------------------- 18562 18563 function New_Copy_Tree 18564 (Source : Node_Id; 18565 Map : Elist_Id := No_Elist; 18566 New_Sloc : Source_Ptr := No_Location; 18567 New_Scope : Entity_Id := Empty) return Node_Id 18568 is 18569 -- This routine performs low-level tree manipulations and needs access 18570 -- to the internals of the tree. 18571 18572 use Atree.Unchecked_Access; 18573 use Atree_Private_Part; 18574 18575 EWA_Level : Nat := 0; 18576 -- This counter keeps track of how many N_Expression_With_Actions nodes 18577 -- are encountered during a depth-first traversal of the subtree. These 18578 -- nodes may define new entities in their Actions lists and thus require 18579 -- special processing. 18580 18581 EWA_Inner_Scope_Level : Nat := 0; 18582 -- This counter keeps track of how many scoping constructs appear within 18583 -- an N_Expression_With_Actions node. 18584 18585 procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id); 18586 pragma Inline (Add_New_Entity); 18587 -- Add an entry in the NCT_New_Entities table which maps key Old_Id to 18588 -- value New_Id. Old_Id is an entity which appears within the Actions 18589 -- list of an N_Expression_With_Actions node, or within an entity map. 18590 -- New_Id is the corresponding new entity generated during Phase 1. 18591 18592 procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id); 18593 pragma Inline (Add_New_Entity); 18594 -- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to 18595 -- value Itype. Assoc_Nod is the associated node of an itype. Itype is 18596 -- an itype. 18597 18598 procedure Build_NCT_Tables (Entity_Map : Elist_Id); 18599 pragma Inline (Build_NCT_Tables); 18600 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with the 18601 -- information supplied in entity map Entity_Map. The format of the 18602 -- entity map must be as follows: 18603 -- 18604 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN 18605 18606 function Copy_Any_Node_With_Replacement 18607 (N : Node_Or_Entity_Id) return Node_Or_Entity_Id; 18608 pragma Inline (Copy_Any_Node_With_Replacement); 18609 -- Replicate entity or node N by invoking one of the following routines: 18610 -- 18611 -- Copy_Node_With_Replacement 18612 -- Corresponding_Entity 18613 18614 function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id; 18615 -- Replicate the elements of entity list List 18616 18617 function Copy_Field_With_Replacement 18618 (Field : Union_Id; 18619 Old_Par : Node_Id := Empty; 18620 New_Par : Node_Id := Empty; 18621 Semantic : Boolean := False) return Union_Id; 18622 -- Replicate field Field by invoking one of the following routines: 18623 -- 18624 -- Copy_Elist_With_Replacement 18625 -- Copy_List_With_Replacement 18626 -- Copy_Node_With_Replacement 18627 -- Corresponding_Entity 18628 -- 18629 -- If the field is not an entity list, entity, itype, syntactic list, 18630 -- or node, then the field is returned unchanged. The routine always 18631 -- replicates entities, itypes, and valid syntactic fields. Old_Par is 18632 -- the expected parent of a syntactic field. New_Par is the new parent 18633 -- associated with a replicated syntactic field. Flag Semantic should 18634 -- be set when the input is a semantic field. 18635 18636 function Copy_List_With_Replacement (List : List_Id) return List_Id; 18637 -- Replicate the elements of syntactic list List 18638 18639 function Copy_Node_With_Replacement (N : Node_Id) return Node_Id; 18640 -- Replicate node N 18641 18642 function Corresponding_Entity (Id : Entity_Id) return Entity_Id; 18643 pragma Inline (Corresponding_Entity); 18644 -- Return the corresponding new entity of Id generated during Phase 1. 18645 -- If there is no such entity, return Id. 18646 18647 function In_Entity_Map 18648 (Id : Entity_Id; 18649 Entity_Map : Elist_Id) return Boolean; 18650 pragma Inline (In_Entity_Map); 18651 -- Determine whether entity Id is one of the old ids specified in entity 18652 -- map Entity_Map. The format of the entity map must be as follows: 18653 -- 18654 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN 18655 18656 procedure Update_CFS_Sloc (N : Node_Or_Entity_Id); 18657 pragma Inline (Update_CFS_Sloc); 18658 -- Update the Comes_From_Source and Sloc attributes of node or entity N 18659 18660 procedure Update_First_Real_Statement 18661 (Old_HSS : Node_Id; 18662 New_HSS : Node_Id); 18663 pragma Inline (Update_First_Real_Statement); 18664 -- Update semantic attribute First_Real_Statement of handled sequence of 18665 -- statements New_HSS based on handled sequence of statements Old_HSS. 18666 18667 procedure Update_Named_Associations 18668 (Old_Call : Node_Id; 18669 New_Call : Node_Id); 18670 pragma Inline (Update_Named_Associations); 18671 -- Update semantic chain First/Next_Named_Association of call New_call 18672 -- based on call Old_Call. 18673 18674 procedure Update_New_Entities (Entity_Map : Elist_Id); 18675 pragma Inline (Update_New_Entities); 18676 -- Update the semantic attributes of all new entities generated during 18677 -- Phase 1 that do not appear in entity map Entity_Map. The format of 18678 -- the entity map must be as follows: 18679 -- 18680 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN 18681 18682 procedure Update_Pending_Itypes 18683 (Old_Assoc : Node_Id; 18684 New_Assoc : Node_Id); 18685 pragma Inline (Update_Pending_Itypes); 18686 -- Update semantic attribute Associated_Node_For_Itype to refer to node 18687 -- New_Assoc for all itypes whose associated node is Old_Assoc. 18688 18689 procedure Update_Semantic_Fields (Id : Entity_Id); 18690 pragma Inline (Update_Semantic_Fields); 18691 -- Subsidiary to Update_New_Entities. Update semantic fields of entity 18692 -- or itype Id. 18693 18694 procedure Visit_Any_Node (N : Node_Or_Entity_Id); 18695 pragma Inline (Visit_Any_Node); 18696 -- Visit entity of node N by invoking one of the following routines: 18697 -- 18698 -- Visit_Entity 18699 -- Visit_Itype 18700 -- Visit_Node 18701 18702 procedure Visit_Elist (List : Elist_Id); 18703 -- Visit the elements of entity list List 18704 18705 procedure Visit_Entity (Id : Entity_Id); 18706 -- Visit entity Id. This action may create a new entity of Id and save 18707 -- it in table NCT_New_Entities. 18708 18709 procedure Visit_Field 18710 (Field : Union_Id; 18711 Par_Nod : Node_Id := Empty; 18712 Semantic : Boolean := False); 18713 -- Visit field Field by invoking one of the following routines: 18714 -- 18715 -- Visit_Elist 18716 -- Visit_Entity 18717 -- Visit_Itype 18718 -- Visit_List 18719 -- Visit_Node 18720 -- 18721 -- If the field is not an entity list, entity, itype, syntactic list, 18722 -- or node, then the field is not visited. The routine always visits 18723 -- valid syntactic fields. Par_Nod is the expected parent of the 18724 -- syntactic field. Flag Semantic should be set when the input is a 18725 -- semantic field. 18726 18727 procedure Visit_Itype (Itype : Entity_Id); 18728 -- Visit itype Itype. This action may create a new entity for Itype and 18729 -- save it in table NCT_New_Entities. In addition, the routine may map 18730 -- the associated node of Itype to the new itype in NCT_Pending_Itypes. 18731 18732 procedure Visit_List (List : List_Id); 18733 -- Visit the elements of syntactic list List 18734 18735 procedure Visit_Node (N : Node_Id); 18736 -- Visit node N 18737 18738 procedure Visit_Semantic_Fields (Id : Entity_Id); 18739 pragma Inline (Visit_Semantic_Fields); 18740 -- Subsidiary to Visit_Entity and Visit_Itype. Visit common semantic 18741 -- fields of entity or itype Id. 18742 18743 -------------------- 18744 -- Add_New_Entity -- 18745 -------------------- 18746 18747 procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id) is 18748 begin 18749 pragma Assert (Present (Old_Id)); 18750 pragma Assert (Present (New_Id)); 18751 pragma Assert (Nkind (Old_Id) in N_Entity); 18752 pragma Assert (Nkind (New_Id) in N_Entity); 18753 18754 NCT_Tables_In_Use := True; 18755 18756 -- Sanity check the NCT_New_Entities table. No previous mapping with 18757 -- key Old_Id should exist. 18758 18759 pragma Assert (No (NCT_New_Entities.Get (Old_Id))); 18760 18761 -- Establish the mapping 18762 18763 -- Old_Id -> New_Id 18764 18765 NCT_New_Entities.Set (Old_Id, New_Id); 18766 end Add_New_Entity; 18767 18768 ----------------------- 18769 -- Add_Pending_Itype -- 18770 ----------------------- 18771 18772 procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id) is 18773 Itypes : Elist_Id; 18774 18775 begin 18776 pragma Assert (Present (Assoc_Nod)); 18777 pragma Assert (Present (Itype)); 18778 pragma Assert (Nkind (Itype) in N_Entity); 18779 pragma Assert (Is_Itype (Itype)); 18780 18781 NCT_Tables_In_Use := True; 18782 18783 -- It is not possible to sanity check the NCT_Pendint_Itypes table 18784 -- directly because a single node may act as the associated node for 18785 -- multiple itypes. 18786 18787 Itypes := NCT_Pending_Itypes.Get (Assoc_Nod); 18788 18789 if No (Itypes) then 18790 Itypes := New_Elmt_List; 18791 NCT_Pending_Itypes.Set (Assoc_Nod, Itypes); 18792 end if; 18793 18794 -- Establish the mapping 18795 18796 -- Assoc_Nod -> (Itype, ...) 18797 18798 -- Avoid inserting the same itype multiple times. This involves a 18799 -- linear search, however the set of itypes with the same associated 18800 -- node is very small. 18801 18802 Append_Unique_Elmt (Itype, Itypes); 18803 end Add_Pending_Itype; 18804 18805 ---------------------- 18806 -- Build_NCT_Tables -- 18807 ---------------------- 18808 18809 procedure Build_NCT_Tables (Entity_Map : Elist_Id) is 18810 Elmt : Elmt_Id; 18811 Old_Id : Entity_Id; 18812 New_Id : Entity_Id; 18813 18814 begin 18815 -- Nothing to do when there is no entity map 18816 18817 if No (Entity_Map) then 18818 return; 18819 end if; 18820 18821 Elmt := First_Elmt (Entity_Map); 18822 while Present (Elmt) loop 18823 18824 -- Extract the (Old_Id, New_Id) pair from the entity map 18825 18826 Old_Id := Node (Elmt); 18827 Next_Elmt (Elmt); 18828 18829 New_Id := Node (Elmt); 18830 Next_Elmt (Elmt); 18831 18832 -- Establish the following mapping within table NCT_New_Entities 18833 18834 -- Old_Id -> New_Id 18835 18836 Add_New_Entity (Old_Id, New_Id); 18837 18838 -- Establish the following mapping within table NCT_Pending_Itypes 18839 -- when the new entity is an itype. 18840 18841 -- Assoc_Nod -> (New_Id, ...) 18842 18843 -- IMPORTANT: the associated node is that of the old itype because 18844 -- the node will be replicated in Phase 2. 18845 18846 if Is_Itype (Old_Id) then 18847 Add_Pending_Itype 18848 (Assoc_Nod => Associated_Node_For_Itype (Old_Id), 18849 Itype => New_Id); 18850 end if; 18851 end loop; 18852 end Build_NCT_Tables; 18853 18854 ------------------------------------ 18855 -- Copy_Any_Node_With_Replacement -- 18856 ------------------------------------ 18857 18858 function Copy_Any_Node_With_Replacement 18859 (N : Node_Or_Entity_Id) return Node_Or_Entity_Id 18860 is 18861 begin 18862 if Nkind (N) in N_Entity then 18863 return Corresponding_Entity (N); 18864 else 18865 return Copy_Node_With_Replacement (N); 18866 end if; 18867 end Copy_Any_Node_With_Replacement; 18868 18869 --------------------------------- 18870 -- Copy_Elist_With_Replacement -- 18871 --------------------------------- 18872 18873 function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id is 18874 Elmt : Elmt_Id; 18875 Result : Elist_Id; 18876 18877 begin 18878 -- Copy the contents of the old list. Note that the list itself may 18879 -- be empty, in which case the routine returns a new empty list. This 18880 -- avoids sharing lists between subtrees. The element of an entity 18881 -- list could be an entity or a node, hence the invocation of routine 18882 -- Copy_Any_Node_With_Replacement. 18883 18884 if Present (List) then 18885 Result := New_Elmt_List; 18886 18887 Elmt := First_Elmt (List); 18888 while Present (Elmt) loop 18889 Append_Elmt 18890 (Copy_Any_Node_With_Replacement (Node (Elmt)), Result); 18891 18892 Next_Elmt (Elmt); 18893 end loop; 18894 18895 -- Otherwise the list does not exist 18896 18897 else 18898 Result := No_Elist; 18899 end if; 18900 18901 return Result; 18902 end Copy_Elist_With_Replacement; 18903 18904 --------------------------------- 18905 -- Copy_Field_With_Replacement -- 18906 --------------------------------- 18907 18908 function Copy_Field_With_Replacement 18909 (Field : Union_Id; 18910 Old_Par : Node_Id := Empty; 18911 New_Par : Node_Id := Empty; 18912 Semantic : Boolean := False) return Union_Id 18913 is 18914 begin 18915 -- The field is empty 18916 18917 if Field = Union_Id (Empty) then 18918 return Field; 18919 18920 -- The field is an entity/itype/node 18921 18922 elsif Field in Node_Range then 18923 declare 18924 Old_N : constant Node_Id := Node_Id (Field); 18925 Syntactic : constant Boolean := Parent (Old_N) = Old_Par; 18926 18927 New_N : Node_Id; 18928 18929 begin 18930 -- The field is an entity/itype 18931 18932 if Nkind (Old_N) in N_Entity then 18933 18934 -- An entity/itype is always replicated 18935 18936 New_N := Corresponding_Entity (Old_N); 18937 18938 -- Update the parent pointer when the entity is a syntactic 18939 -- field. Note that itypes do not have parent pointers. 18940 18941 if Syntactic and then New_N /= Old_N then 18942 Set_Parent (New_N, New_Par); 18943 end if; 18944 18945 -- The field is a node 18946 18947 else 18948 -- A node is replicated when it is either a syntactic field 18949 -- or when the caller treats it as a semantic attribute. 18950 18951 if Syntactic or else Semantic then 18952 New_N := Copy_Node_With_Replacement (Old_N); 18953 18954 -- Update the parent pointer when the node is a syntactic 18955 -- field. 18956 18957 if Syntactic and then New_N /= Old_N then 18958 Set_Parent (New_N, New_Par); 18959 end if; 18960 18961 -- Otherwise the node is returned unchanged 18962 18963 else 18964 New_N := Old_N; 18965 end if; 18966 end if; 18967 18968 return Union_Id (New_N); 18969 end; 18970 18971 -- The field is an entity list 18972 18973 elsif Field in Elist_Range then 18974 return Union_Id (Copy_Elist_With_Replacement (Elist_Id (Field))); 18975 18976 -- The field is a syntactic list 18977 18978 elsif Field in List_Range then 18979 declare 18980 Old_List : constant List_Id := List_Id (Field); 18981 Syntactic : constant Boolean := Parent (Old_List) = Old_Par; 18982 18983 New_List : List_Id; 18984 18985 begin 18986 -- A list is replicated when it is either a syntactic field or 18987 -- when the caller treats it as a semantic attribute. 18988 18989 if Syntactic or else Semantic then 18990 New_List := Copy_List_With_Replacement (Old_List); 18991 18992 -- Update the parent pointer when the list is a syntactic 18993 -- field. 18994 18995 if Syntactic and then New_List /= Old_List then 18996 Set_Parent (New_List, New_Par); 18997 end if; 18998 18999 -- Otherwise the list is returned unchanged 19000 19001 else 19002 New_List := Old_List; 19003 end if; 19004 19005 return Union_Id (New_List); 19006 end; 19007 19008 -- Otherwise the field denotes an attribute that does not need to be 19009 -- replicated (Chars, literals, etc). 19010 19011 else 19012 return Field; 19013 end if; 19014 end Copy_Field_With_Replacement; 19015 19016 -------------------------------- 19017 -- Copy_List_With_Replacement -- 19018 -------------------------------- 19019 19020 function Copy_List_With_Replacement (List : List_Id) return List_Id is 19021 Elmt : Node_Id; 19022 Result : List_Id; 19023 19024 begin 19025 -- Copy the contents of the old list. Note that the list itself may 19026 -- be empty, in which case the routine returns a new empty list. This 19027 -- avoids sharing lists between subtrees. The element of a syntactic 19028 -- list is always a node, never an entity or itype, hence the call to 19029 -- routine Copy_Node_With_Replacement. 19030 19031 if Present (List) then 19032 Result := New_List; 19033 19034 Elmt := First (List); 19035 while Present (Elmt) loop 19036 Append (Copy_Node_With_Replacement (Elmt), Result); 19037 19038 Next (Elmt); 19039 end loop; 19040 19041 -- Otherwise the list does not exist 19042 19043 else 19044 Result := No_List; 19045 end if; 19046 19047 return Result; 19048 end Copy_List_With_Replacement; 19049 19050 -------------------------------- 19051 -- Copy_Node_With_Replacement -- 19052 -------------------------------- 19053 19054 function Copy_Node_With_Replacement (N : Node_Id) return Node_Id is 19055 Result : Node_Id; 19056 19057 begin 19058 -- Assume that the node must be returned unchanged 19059 19060 Result := N; 19061 19062 if N > Empty_Or_Error then 19063 pragma Assert (Nkind (N) not in N_Entity); 19064 19065 Result := New_Copy (N); 19066 19067 Set_Field1 (Result, 19068 Copy_Field_With_Replacement 19069 (Field => Field1 (Result), 19070 Old_Par => N, 19071 New_Par => Result)); 19072 19073 Set_Field2 (Result, 19074 Copy_Field_With_Replacement 19075 (Field => Field2 (Result), 19076 Old_Par => N, 19077 New_Par => Result)); 19078 19079 Set_Field3 (Result, 19080 Copy_Field_With_Replacement 19081 (Field => Field3 (Result), 19082 Old_Par => N, 19083 New_Par => Result)); 19084 19085 Set_Field4 (Result, 19086 Copy_Field_With_Replacement 19087 (Field => Field4 (Result), 19088 Old_Par => N, 19089 New_Par => Result)); 19090 19091 Set_Field5 (Result, 19092 Copy_Field_With_Replacement 19093 (Field => Field5 (Result), 19094 Old_Par => N, 19095 New_Par => Result)); 19096 19097 -- Update the Comes_From_Source and Sloc attributes of the node 19098 -- in case the caller has supplied new values. 19099 19100 Update_CFS_Sloc (Result); 19101 19102 -- Update the Associated_Node_For_Itype attribute of all itypes 19103 -- created during Phase 1 whose associated node is N. As a result 19104 -- the Associated_Node_For_Itype refers to the replicated node. 19105 -- No action needs to be taken when the Associated_Node_For_Itype 19106 -- refers to an entity because this was already handled during 19107 -- Phase 1, in Visit_Itype. 19108 19109 Update_Pending_Itypes 19110 (Old_Assoc => N, 19111 New_Assoc => Result); 19112 19113 -- Update the First/Next_Named_Association chain for a replicated 19114 -- call. 19115 19116 if Nkind_In (N, N_Entry_Call_Statement, 19117 N_Function_Call, 19118 N_Procedure_Call_Statement) 19119 then 19120 Update_Named_Associations 19121 (Old_Call => N, 19122 New_Call => Result); 19123 19124 -- Update the Renamed_Object attribute of a replicated object 19125 -- declaration. 19126 19127 elsif Nkind (N) = N_Object_Renaming_Declaration then 19128 Set_Renamed_Object (Defining_Entity (Result), Name (Result)); 19129 19130 -- Update the First_Real_Statement attribute of a replicated 19131 -- handled sequence of statements. 19132 19133 elsif Nkind (N) = N_Handled_Sequence_Of_Statements then 19134 Update_First_Real_Statement 19135 (Old_HSS => N, 19136 New_HSS => Result); 19137 end if; 19138 end if; 19139 19140 return Result; 19141 end Copy_Node_With_Replacement; 19142 19143 -------------------------- 19144 -- Corresponding_Entity -- 19145 -------------------------- 19146 19147 function Corresponding_Entity (Id : Entity_Id) return Entity_Id is 19148 New_Id : Entity_Id; 19149 Result : Entity_Id; 19150 19151 begin 19152 -- Assume that the entity must be returned unchanged 19153 19154 Result := Id; 19155 19156 if Id > Empty_Or_Error then 19157 pragma Assert (Nkind (Id) in N_Entity); 19158 19159 -- Determine whether the entity has a corresponding new entity 19160 -- generated during Phase 1 and if it does, use it. 19161 19162 if NCT_Tables_In_Use then 19163 New_Id := NCT_New_Entities.Get (Id); 19164 19165 if Present (New_Id) then 19166 Result := New_Id; 19167 end if; 19168 end if; 19169 end if; 19170 19171 return Result; 19172 end Corresponding_Entity; 19173 19174 ------------------- 19175 -- In_Entity_Map -- 19176 ------------------- 19177 19178 function In_Entity_Map 19179 (Id : Entity_Id; 19180 Entity_Map : Elist_Id) return Boolean 19181 is 19182 Elmt : Elmt_Id; 19183 Old_Id : Entity_Id; 19184 19185 begin 19186 -- The entity map contains pairs (Old_Id, New_Id). The advancement 19187 -- step always skips the New_Id portion of the pair. 19188 19189 if Present (Entity_Map) then 19190 Elmt := First_Elmt (Entity_Map); 19191 while Present (Elmt) loop 19192 Old_Id := Node (Elmt); 19193 19194 if Old_Id = Id then 19195 return True; 19196 end if; 19197 19198 Next_Elmt (Elmt); 19199 Next_Elmt (Elmt); 19200 end loop; 19201 end if; 19202 19203 return False; 19204 end In_Entity_Map; 19205 19206 --------------------- 19207 -- Update_CFS_Sloc -- 19208 --------------------- 19209 19210 procedure Update_CFS_Sloc (N : Node_Or_Entity_Id) is 19211 begin 19212 -- A new source location defaults the Comes_From_Source attribute 19213 19214 if New_Sloc /= No_Location then 19215 Set_Comes_From_Source (N, Default_Node.Comes_From_Source); 19216 Set_Sloc (N, New_Sloc); 19217 end if; 19218 end Update_CFS_Sloc; 19219 19220 --------------------------------- 19221 -- Update_First_Real_Statement -- 19222 --------------------------------- 19223 19224 procedure Update_First_Real_Statement 19225 (Old_HSS : Node_Id; 19226 New_HSS : Node_Id) 19227 is 19228 Old_First_Stmt : constant Node_Id := First_Real_Statement (Old_HSS); 19229 19230 New_Stmt : Node_Id; 19231 Old_Stmt : Node_Id; 19232 19233 begin 19234 -- Recreate the First_Real_Statement attribute of a handled sequence 19235 -- of statements by traversing the statement lists of both sequences 19236 -- in parallel. 19237 19238 if Present (Old_First_Stmt) then 19239 New_Stmt := First (Statements (New_HSS)); 19240 Old_Stmt := First (Statements (Old_HSS)); 19241 while Present (Old_Stmt) and then Old_Stmt /= Old_First_Stmt loop 19242 Next (New_Stmt); 19243 Next (Old_Stmt); 19244 end loop; 19245 19246 pragma Assert (Present (New_Stmt)); 19247 pragma Assert (Present (Old_Stmt)); 19248 19249 Set_First_Real_Statement (New_HSS, New_Stmt); 19250 end if; 19251 end Update_First_Real_Statement; 19252 19253 ------------------------------- 19254 -- Update_Named_Associations -- 19255 ------------------------------- 19256 19257 procedure Update_Named_Associations 19258 (Old_Call : Node_Id; 19259 New_Call : Node_Id) 19260 is 19261 New_Act : Node_Id; 19262 New_Next : Node_Id; 19263 Old_Act : Node_Id; 19264 Old_Next : Node_Id; 19265 19266 begin 19267 -- Recreate the First/Next_Named_Actual chain of a call by traversing 19268 -- the chains of both the old and new calls in parallel. 19269 19270 New_Act := First (Parameter_Associations (New_Call)); 19271 Old_Act := First (Parameter_Associations (Old_Call)); 19272 while Present (Old_Act) loop 19273 if Nkind (Old_Act) = N_Parameter_Association 19274 and then Present (Next_Named_Actual (Old_Act)) 19275 then 19276 if First_Named_Actual (Old_Call) = 19277 Explicit_Actual_Parameter (Old_Act) 19278 then 19279 Set_First_Named_Actual (New_Call, 19280 Explicit_Actual_Parameter (New_Act)); 19281 end if; 19282 19283 -- Scan the actual parameter list to find the next suitable 19284 -- named actual. Note that the list may be out of order. 19285 19286 New_Next := First (Parameter_Associations (New_Call)); 19287 Old_Next := First (Parameter_Associations (Old_Call)); 19288 while Nkind (Old_Next) /= N_Parameter_Association 19289 or else Explicit_Actual_Parameter (Old_Next) /= 19290 Next_Named_Actual (Old_Act) 19291 loop 19292 Next (New_Next); 19293 Next (Old_Next); 19294 end loop; 19295 19296 Set_Next_Named_Actual (New_Act, 19297 Explicit_Actual_Parameter (New_Next)); 19298 end if; 19299 19300 Next (New_Act); 19301 Next (Old_Act); 19302 end loop; 19303 end Update_Named_Associations; 19304 19305 ------------------------- 19306 -- Update_New_Entities -- 19307 ------------------------- 19308 19309 procedure Update_New_Entities (Entity_Map : Elist_Id) is 19310 New_Id : Entity_Id := Empty; 19311 Old_Id : Entity_Id := Empty; 19312 19313 begin 19314 if NCT_Tables_In_Use then 19315 NCT_New_Entities.Get_First (Old_Id, New_Id); 19316 19317 -- Update the semantic fields of all new entities created during 19318 -- Phase 1 which were not supplied via an entity map. 19319 -- ??? Is there a better way of distinguishing those? 19320 19321 while Present (Old_Id) and then Present (New_Id) loop 19322 if not (Present (Entity_Map) 19323 and then In_Entity_Map (Old_Id, Entity_Map)) 19324 then 19325 Update_Semantic_Fields (New_Id); 19326 end if; 19327 19328 NCT_New_Entities.Get_Next (Old_Id, New_Id); 19329 end loop; 19330 end if; 19331 end Update_New_Entities; 19332 19333 --------------------------- 19334 -- Update_Pending_Itypes -- 19335 --------------------------- 19336 19337 procedure Update_Pending_Itypes 19338 (Old_Assoc : Node_Id; 19339 New_Assoc : Node_Id) 19340 is 19341 Item : Elmt_Id; 19342 Itypes : Elist_Id; 19343 19344 begin 19345 if NCT_Tables_In_Use then 19346 Itypes := NCT_Pending_Itypes.Get (Old_Assoc); 19347 19348 -- Update the Associated_Node_For_Itype attribute for all itypes 19349 -- which originally refer to Old_Assoc to designate New_Assoc. 19350 19351 if Present (Itypes) then 19352 Item := First_Elmt (Itypes); 19353 while Present (Item) loop 19354 Set_Associated_Node_For_Itype (Node (Item), New_Assoc); 19355 19356 Next_Elmt (Item); 19357 end loop; 19358 end if; 19359 end if; 19360 end Update_Pending_Itypes; 19361 19362 ---------------------------- 19363 -- Update_Semantic_Fields -- 19364 ---------------------------- 19365 19366 procedure Update_Semantic_Fields (Id : Entity_Id) is 19367 begin 19368 -- Discriminant_Constraint 19369 19370 if Has_Discriminants (Base_Type (Id)) then 19371 Set_Discriminant_Constraint (Id, Elist_Id ( 19372 Copy_Field_With_Replacement 19373 (Field => Union_Id (Discriminant_Constraint (Id)), 19374 Semantic => True))); 19375 end if; 19376 19377 -- Etype 19378 19379 Set_Etype (Id, Node_Id ( 19380 Copy_Field_With_Replacement 19381 (Field => Union_Id (Etype (Id)), 19382 Semantic => True))); 19383 19384 -- First_Index 19385 -- Packed_Array_Impl_Type 19386 19387 if Is_Array_Type (Id) then 19388 if Present (First_Index (Id)) then 19389 Set_First_Index (Id, First (List_Id ( 19390 Copy_Field_With_Replacement 19391 (Field => Union_Id (List_Containing (First_Index (Id))), 19392 Semantic => True)))); 19393 end if; 19394 19395 if Is_Packed (Id) then 19396 Set_Packed_Array_Impl_Type (Id, Node_Id ( 19397 Copy_Field_With_Replacement 19398 (Field => Union_Id (Packed_Array_Impl_Type (Id)), 19399 Semantic => True))); 19400 end if; 19401 end if; 19402 19403 -- Next_Entity 19404 19405 Set_Next_Entity (Id, Node_Id ( 19406 Copy_Field_With_Replacement 19407 (Field => Union_Id (Next_Entity (Id)), 19408 Semantic => True))); 19409 19410 -- Scalar_Range 19411 19412 if Is_Discrete_Type (Id) then 19413 Set_Scalar_Range (Id, Node_Id ( 19414 Copy_Field_With_Replacement 19415 (Field => Union_Id (Scalar_Range (Id)), 19416 Semantic => True))); 19417 end if; 19418 19419 -- Scope 19420 19421 -- Update the scope when the caller specified an explicit one 19422 19423 if Present (New_Scope) then 19424 Set_Scope (Id, New_Scope); 19425 else 19426 Set_Scope (Id, Node_Id ( 19427 Copy_Field_With_Replacement 19428 (Field => Union_Id (Scope (Id)), 19429 Semantic => True))); 19430 end if; 19431 end Update_Semantic_Fields; 19432 19433 -------------------- 19434 -- Visit_Any_Node -- 19435 -------------------- 19436 19437 procedure Visit_Any_Node (N : Node_Or_Entity_Id) is 19438 begin 19439 if Nkind (N) in N_Entity then 19440 if Is_Itype (N) then 19441 Visit_Itype (N); 19442 else 19443 Visit_Entity (N); 19444 end if; 19445 else 19446 Visit_Node (N); 19447 end if; 19448 end Visit_Any_Node; 19449 19450 ----------------- 19451 -- Visit_Elist -- 19452 ----------------- 19453 19454 procedure Visit_Elist (List : Elist_Id) is 19455 Elmt : Elmt_Id; 19456 19457 begin 19458 -- The element of an entity list could be an entity, itype, or a 19459 -- node, hence the call to Visit_Any_Node. 19460 19461 if Present (List) then 19462 Elmt := First_Elmt (List); 19463 while Present (Elmt) loop 19464 Visit_Any_Node (Node (Elmt)); 19465 19466 Next_Elmt (Elmt); 19467 end loop; 19468 end if; 19469 end Visit_Elist; 19470 19471 ------------------ 19472 -- Visit_Entity -- 19473 ------------------ 19474 19475 procedure Visit_Entity (Id : Entity_Id) is 19476 New_Id : Entity_Id; 19477 19478 begin 19479 pragma Assert (Nkind (Id) in N_Entity); 19480 pragma Assert (not Is_Itype (Id)); 19481 19482 -- Nothing to do if the entity is not defined in the Actions list of 19483 -- an N_Expression_With_Actions node. 19484 19485 if EWA_Level = 0 then 19486 return; 19487 19488 -- Nothing to do if the entity is defined within a scoping construct 19489 -- of an N_Expression_With_Actions node. 19490 19491 elsif EWA_Inner_Scope_Level > 0 then 19492 return; 19493 19494 -- Nothing to do if the entity is not an object or a type. Relaxing 19495 -- this restriction leads to a performance penalty. 19496 19497 elsif not Ekind_In (Id, E_Constant, E_Variable) 19498 and then not Is_Type (Id) 19499 then 19500 return; 19501 19502 -- Nothing to do if the entity was already visited 19503 19504 elsif NCT_Tables_In_Use 19505 and then Present (NCT_New_Entities.Get (Id)) 19506 then 19507 return; 19508 19509 -- Nothing to do if the declaration node of the entity is not within 19510 -- the subtree being replicated. 19511 19512 elsif not In_Subtree 19513 (N => Declaration_Node (Id), 19514 Root => Source) 19515 then 19516 return; 19517 end if; 19518 19519 -- Create a new entity by directly copying the old entity. This 19520 -- action causes all attributes of the old entity to be inherited. 19521 19522 New_Id := New_Copy (Id); 19523 19524 -- Create a new name for the new entity because the back end needs 19525 -- distinct names for debugging purposes. 19526 19527 Set_Chars (New_Id, New_Internal_Name ('T')); 19528 19529 -- Update the Comes_From_Source and Sloc attributes of the entity in 19530 -- case the caller has supplied new values. 19531 19532 Update_CFS_Sloc (New_Id); 19533 19534 -- Establish the following mapping within table NCT_New_Entities: 19535 19536 -- Id -> New_Id 19537 19538 Add_New_Entity (Id, New_Id); 19539 19540 -- Deal with the semantic fields of entities. The fields are visited 19541 -- because they may mention entities which reside within the subtree 19542 -- being copied. 19543 19544 Visit_Semantic_Fields (Id); 19545 end Visit_Entity; 19546 19547 ----------------- 19548 -- Visit_Field -- 19549 ----------------- 19550 19551 procedure Visit_Field 19552 (Field : Union_Id; 19553 Par_Nod : Node_Id := Empty; 19554 Semantic : Boolean := False) 19555 is 19556 begin 19557 -- The field is empty 19558 19559 if Field = Union_Id (Empty) then 19560 return; 19561 19562 -- The field is an entity/itype/node 19563 19564 elsif Field in Node_Range then 19565 declare 19566 N : constant Node_Id := Node_Id (Field); 19567 19568 begin 19569 -- The field is an entity/itype 19570 19571 if Nkind (N) in N_Entity then 19572 19573 -- Itypes are always visited 19574 19575 if Is_Itype (N) then 19576 Visit_Itype (N); 19577 19578 -- An entity is visited when it is either a syntactic field 19579 -- or when the caller treats it as a semantic attribute. 19580 19581 elsif Parent (N) = Par_Nod or else Semantic then 19582 Visit_Entity (N); 19583 end if; 19584 19585 -- The field is a node 19586 19587 else 19588 -- A node is visited when it is either a syntactic field or 19589 -- when the caller treats it as a semantic attribute. 19590 19591 if Parent (N) = Par_Nod or else Semantic then 19592 Visit_Node (N); 19593 end if; 19594 end if; 19595 end; 19596 19597 -- The field is an entity list 19598 19599 elsif Field in Elist_Range then 19600 Visit_Elist (Elist_Id (Field)); 19601 19602 -- The field is a syntax list 19603 19604 elsif Field in List_Range then 19605 declare 19606 List : constant List_Id := List_Id (Field); 19607 19608 begin 19609 -- A syntax list is visited when it is either a syntactic field 19610 -- or when the caller treats it as a semantic attribute. 19611 19612 if Parent (List) = Par_Nod or else Semantic then 19613 Visit_List (List); 19614 end if; 19615 end; 19616 19617 -- Otherwise the field denotes information which does not need to be 19618 -- visited (chars, literals, etc.). 19619 19620 else 19621 null; 19622 end if; 19623 end Visit_Field; 19624 19625 ----------------- 19626 -- Visit_Itype -- 19627 ----------------- 19628 19629 procedure Visit_Itype (Itype : Entity_Id) is 19630 New_Assoc : Node_Id; 19631 New_Itype : Entity_Id; 19632 Old_Assoc : Node_Id; 19633 19634 begin 19635 pragma Assert (Nkind (Itype) in N_Entity); 19636 pragma Assert (Is_Itype (Itype)); 19637 19638 -- Itypes that describe the designated type of access to subprograms 19639 -- have the structure of subprogram declarations, with signatures, 19640 -- etc. Either we duplicate the signatures completely, or choose to 19641 -- share such itypes, which is fine because their elaboration will 19642 -- have no side effects. 19643 19644 if Ekind (Itype) = E_Subprogram_Type then 19645 return; 19646 19647 -- Nothing to do if the itype was already visited 19648 19649 elsif NCT_Tables_In_Use 19650 and then Present (NCT_New_Entities.Get (Itype)) 19651 then 19652 return; 19653 19654 -- Nothing to do if the associated node of the itype is not within 19655 -- the subtree being replicated. 19656 19657 elsif not In_Subtree 19658 (N => Associated_Node_For_Itype (Itype), 19659 Root => Source) 19660 then 19661 return; 19662 end if; 19663 19664 -- Create a new itype by directly copying the old itype. This action 19665 -- causes all attributes of the old itype to be inherited. 19666 19667 New_Itype := New_Copy (Itype); 19668 19669 -- Create a new name for the new itype because the back end requires 19670 -- distinct names for debugging purposes. 19671 19672 Set_Chars (New_Itype, New_Internal_Name ('T')); 19673 19674 -- Update the Comes_From_Source and Sloc attributes of the itype in 19675 -- case the caller has supplied new values. 19676 19677 Update_CFS_Sloc (New_Itype); 19678 19679 -- Establish the following mapping within table NCT_New_Entities: 19680 19681 -- Itype -> New_Itype 19682 19683 Add_New_Entity (Itype, New_Itype); 19684 19685 -- The new itype must be unfrozen because the resulting subtree may 19686 -- be inserted anywhere and cause an earlier or later freezing. 19687 19688 if Present (Freeze_Node (New_Itype)) then 19689 Set_Freeze_Node (New_Itype, Empty); 19690 Set_Is_Frozen (New_Itype, False); 19691 end if; 19692 19693 -- If a record subtype is simply copied, the entity list will be 19694 -- shared. Thus cloned_Subtype must be set to indicate the sharing. 19695 -- ??? What does this do? 19696 19697 if Ekind_In (Itype, E_Class_Wide_Subtype, E_Record_Subtype) then 19698 Set_Cloned_Subtype (New_Itype, Itype); 19699 end if; 19700 19701 -- The associated node may denote an entity, in which case it may 19702 -- already have a new corresponding entity created during a prior 19703 -- call to Visit_Entity or Visit_Itype for the same subtree. 19704 19705 -- Given 19706 -- Old_Assoc ---------> New_Assoc 19707 19708 -- Created by Visit_Itype 19709 -- Itype -------------> New_Itype 19710 -- ANFI = Old_Assoc ANFI = Old_Assoc < must be updated 19711 19712 -- In the example above, Old_Assoc is an arbitrary entity that was 19713 -- already visited for the same subtree and has a corresponding new 19714 -- entity New_Assoc. Old_Assoc was inherited by New_Itype by virtue 19715 -- of copying entities, however it must be updated to New_Assoc. 19716 19717 Old_Assoc := Associated_Node_For_Itype (Itype); 19718 19719 if Nkind (Old_Assoc) in N_Entity then 19720 if NCT_Tables_In_Use then 19721 New_Assoc := NCT_New_Entities.Get (Old_Assoc); 19722 19723 if Present (New_Assoc) then 19724 Set_Associated_Node_For_Itype (New_Itype, New_Assoc); 19725 end if; 19726 end if; 19727 19728 -- Otherwise the associated node denotes a node. Postpone the update 19729 -- until Phase 2 when the node is replicated. Establish the following 19730 -- mapping within table NCT_Pending_Itypes: 19731 19732 -- Old_Assoc -> (New_Type, ...) 19733 19734 else 19735 Add_Pending_Itype (Old_Assoc, New_Itype); 19736 end if; 19737 19738 -- Deal with the semantic fields of itypes. The fields are visited 19739 -- because they may mention entities that reside within the subtree 19740 -- being copied. 19741 19742 Visit_Semantic_Fields (Itype); 19743 end Visit_Itype; 19744 19745 ---------------- 19746 -- Visit_List -- 19747 ---------------- 19748 19749 procedure Visit_List (List : List_Id) is 19750 Elmt : Node_Id; 19751 19752 begin 19753 -- Note that the element of a syntactic list is always a node, never 19754 -- an entity or itype, hence the call to Visit_Node. 19755 19756 if Present (List) then 19757 Elmt := First (List); 19758 while Present (Elmt) loop 19759 Visit_Node (Elmt); 19760 19761 Next (Elmt); 19762 end loop; 19763 end if; 19764 end Visit_List; 19765 19766 ---------------- 19767 -- Visit_Node -- 19768 ---------------- 19769 19770 procedure Visit_Node (N : Node_Or_Entity_Id) is 19771 begin 19772 pragma Assert (Nkind (N) not in N_Entity); 19773 19774 if Nkind (N) = N_Expression_With_Actions then 19775 EWA_Level := EWA_Level + 1; 19776 19777 elsif EWA_Level > 0 19778 and then Nkind_In (N, N_Block_Statement, 19779 N_Subprogram_Body, 19780 N_Subprogram_Declaration) 19781 then 19782 EWA_Inner_Scope_Level := EWA_Inner_Scope_Level + 1; 19783 end if; 19784 19785 Visit_Field 19786 (Field => Field1 (N), 19787 Par_Nod => N); 19788 19789 Visit_Field 19790 (Field => Field2 (N), 19791 Par_Nod => N); 19792 19793 Visit_Field 19794 (Field => Field3 (N), 19795 Par_Nod => N); 19796 19797 Visit_Field 19798 (Field => Field4 (N), 19799 Par_Nod => N); 19800 19801 Visit_Field 19802 (Field => Field5 (N), 19803 Par_Nod => N); 19804 19805 if EWA_Level > 0 19806 and then Nkind_In (N, N_Block_Statement, 19807 N_Subprogram_Body, 19808 N_Subprogram_Declaration) 19809 then 19810 EWA_Inner_Scope_Level := EWA_Inner_Scope_Level - 1; 19811 19812 elsif Nkind (N) = N_Expression_With_Actions then 19813 EWA_Level := EWA_Level - 1; 19814 end if; 19815 end Visit_Node; 19816 19817 --------------------------- 19818 -- Visit_Semantic_Fields -- 19819 --------------------------- 19820 19821 procedure Visit_Semantic_Fields (Id : Entity_Id) is 19822 begin 19823 pragma Assert (Nkind (Id) in N_Entity); 19824 19825 -- Discriminant_Constraint 19826 19827 if Has_Discriminants (Base_Type (Id)) then 19828 Visit_Field 19829 (Field => Union_Id (Discriminant_Constraint (Id)), 19830 Semantic => True); 19831 end if; 19832 19833 -- Etype 19834 19835 Visit_Field 19836 (Field => Union_Id (Etype (Id)), 19837 Semantic => True); 19838 19839 -- First_Index 19840 -- Packed_Array_Impl_Type 19841 19842 if Is_Array_Type (Id) then 19843 if Present (First_Index (Id)) then 19844 Visit_Field 19845 (Field => Union_Id (List_Containing (First_Index (Id))), 19846 Semantic => True); 19847 end if; 19848 19849 if Is_Packed (Id) then 19850 Visit_Field 19851 (Field => Union_Id (Packed_Array_Impl_Type (Id)), 19852 Semantic => True); 19853 end if; 19854 end if; 19855 19856 -- Scalar_Range 19857 19858 if Is_Discrete_Type (Id) then 19859 Visit_Field 19860 (Field => Union_Id (Scalar_Range (Id)), 19861 Semantic => True); 19862 end if; 19863 end Visit_Semantic_Fields; 19864 19865 -- Start of processing for New_Copy_Tree 19866 19867 begin 19868 -- Routine New_Copy_Tree performs a deep copy of a subtree by creating 19869 -- shallow copies for each node within, and then updating the child and 19870 -- parent pointers accordingly. This process is straightforward, however 19871 -- the routine must deal with the following complications: 19872 19873 -- * Entities defined within N_Expression_With_Actions nodes must be 19874 -- replicated rather than shared to avoid introducing two identical 19875 -- symbols within the same scope. Note that no other expression can 19876 -- currently define entities. 19877 19878 -- do 19879 -- Source_Low : ...; 19880 -- Source_High : ...; 19881 19882 -- <reference to Source_Low> 19883 -- <reference to Source_High> 19884 -- in ... end; 19885 19886 -- New_Copy_Tree handles this case by first creating new entities 19887 -- and then updating all existing references to point to these new 19888 -- entities. 19889 19890 -- do 19891 -- New_Low : ...; 19892 -- New_High : ...; 19893 19894 -- <reference to New_Low> 19895 -- <reference to New_High> 19896 -- in ... end; 19897 19898 -- * Itypes defined within the subtree must be replicated to avoid any 19899 -- dependencies on invalid or inaccessible data. 19900 19901 -- subtype Source_Itype is ... range Source_Low .. Source_High; 19902 19903 -- New_Copy_Tree handles this case by first creating a new itype in 19904 -- the same fashion as entities, and then updating various relevant 19905 -- constraints. 19906 19907 -- subtype New_Itype is ... range New_Low .. New_High; 19908 19909 -- * The Associated_Node_For_Itype field of itypes must be updated to 19910 -- reference the proper replicated entity or node. 19911 19912 -- * Semantic fields of entities such as Etype and Scope must be 19913 -- updated to reference the proper replicated entities. 19914 19915 -- * Semantic fields of nodes such as First_Real_Statement must be 19916 -- updated to reference the proper replicated nodes. 19917 19918 -- To meet all these demands, routine New_Copy_Tree is split into two 19919 -- phases. 19920 19921 -- Phase 1 traverses the tree in order to locate entities and itypes 19922 -- defined within the subtree. New entities are generated and saved in 19923 -- table NCT_New_Entities. The semantic fields of all new entities and 19924 -- itypes are then updated accordingly. 19925 19926 -- Phase 2 traverses the tree in order to replicate each node. Various 19927 -- semantic fields of nodes and entities are updated accordingly. 19928 19929 -- Preparatory phase. Clear the contents of tables NCT_New_Entities and 19930 -- NCT_Pending_Itypes in case a previous call to New_Copy_Tree left some 19931 -- data inside. 19932 19933 if NCT_Tables_In_Use then 19934 NCT_Tables_In_Use := False; 19935 19936 NCT_New_Entities.Reset; 19937 NCT_Pending_Itypes.Reset; 19938 end if; 19939 19940 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with data 19941 -- supplied by a linear entity map. The tables offer faster access to 19942 -- the same data. 19943 19944 Build_NCT_Tables (Map); 19945 19946 -- Execute Phase 1. Traverse the subtree and generate new entities for 19947 -- the following cases: 19948 19949 -- * An entity defined within an N_Expression_With_Actions node 19950 19951 -- * An itype referenced within the subtree where the associated node 19952 -- is also in the subtree. 19953 19954 -- All new entities are accessible via table NCT_New_Entities, which 19955 -- contains mappings of the form: 19956 19957 -- Old_Entity -> New_Entity 19958 -- Old_Itype -> New_Itype 19959 19960 -- In addition, the associated nodes of all new itypes are mapped in 19961 -- table NCT_Pending_Itypes: 19962 19963 -- Assoc_Nod -> (New_Itype1, New_Itype2, .., New_ItypeN) 19964 19965 Visit_Any_Node (Source); 19966 19967 -- Update the semantic attributes of all new entities generated during 19968 -- Phase 1 before starting Phase 2. The updates could be performed in 19969 -- routine Corresponding_Entity, however this may cause the same entity 19970 -- to be updated multiple times, effectively generating useless nodes. 19971 -- Keeping the updates separates from Phase 2 ensures that only one set 19972 -- of attributes is generated for an entity at any one time. 19973 19974 Update_New_Entities (Map); 19975 19976 -- Execute Phase 2. Replicate the source subtree one node at a time. 19977 -- The following transformations take place: 19978 19979 -- * References to entities and itypes are updated to refer to the 19980 -- new entities and itypes generated during Phase 1. 19981 19982 -- * All Associated_Node_For_Itype attributes of itypes are updated 19983 -- to refer to the new replicated Associated_Node_For_Itype. 19984 19985 return Copy_Node_With_Replacement (Source); 19986 end New_Copy_Tree; 19987 19988 ------------------------- 19989 -- New_External_Entity -- 19990 ------------------------- 19991 19992 function New_External_Entity 19993 (Kind : Entity_Kind; 19994 Scope_Id : Entity_Id; 19995 Sloc_Value : Source_Ptr; 19996 Related_Id : Entity_Id; 19997 Suffix : Character; 19998 Suffix_Index : Nat := 0; 19999 Prefix : Character := ' ') return Entity_Id 20000 is 20001 N : constant Entity_Id := 20002 Make_Defining_Identifier (Sloc_Value, 20003 New_External_Name 20004 (Chars (Related_Id), Suffix, Suffix_Index, Prefix)); 20005 20006 begin 20007 Set_Ekind (N, Kind); 20008 Set_Is_Internal (N, True); 20009 Append_Entity (N, Scope_Id); 20010 Set_Public_Status (N); 20011 20012 if Kind in Type_Kind then 20013 Init_Size_Align (N); 20014 end if; 20015 20016 return N; 20017 end New_External_Entity; 20018 20019 ------------------------- 20020 -- New_Internal_Entity -- 20021 ------------------------- 20022 20023 function New_Internal_Entity 20024 (Kind : Entity_Kind; 20025 Scope_Id : Entity_Id; 20026 Sloc_Value : Source_Ptr; 20027 Id_Char : Character) return Entity_Id 20028 is 20029 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); 20030 20031 begin 20032 Set_Ekind (N, Kind); 20033 Set_Is_Internal (N, True); 20034 Append_Entity (N, Scope_Id); 20035 20036 if Kind in Type_Kind then 20037 Init_Size_Align (N); 20038 end if; 20039 20040 return N; 20041 end New_Internal_Entity; 20042 20043 ----------------- 20044 -- Next_Actual -- 20045 ----------------- 20046 20047 function Next_Actual (Actual_Id : Node_Id) return Node_Id is 20048 N : Node_Id; 20049 20050 begin 20051 -- If we are pointing at a positional parameter, it is a member of a 20052 -- node list (the list of parameters), and the next parameter is the 20053 -- next node on the list, unless we hit a parameter association, then 20054 -- we shift to using the chain whose head is the First_Named_Actual in 20055 -- the parent, and then is threaded using the Next_Named_Actual of the 20056 -- Parameter_Association. All this fiddling is because the original node 20057 -- list is in the textual call order, and what we need is the 20058 -- declaration order. 20059 20060 if Is_List_Member (Actual_Id) then 20061 N := Next (Actual_Id); 20062 20063 if Nkind (N) = N_Parameter_Association then 20064 20065 -- In case of a build-in-place call, the call will no longer be a 20066 -- call; it will have been rewritten. 20067 20068 if Nkind_In (Parent (Actual_Id), N_Entry_Call_Statement, 20069 N_Function_Call, 20070 N_Procedure_Call_Statement) 20071 then 20072 return First_Named_Actual (Parent (Actual_Id)); 20073 else 20074 return Empty; 20075 end if; 20076 else 20077 return N; 20078 end if; 20079 20080 else 20081 return Next_Named_Actual (Parent (Actual_Id)); 20082 end if; 20083 end Next_Actual; 20084 20085 procedure Next_Actual (Actual_Id : in out Node_Id) is 20086 begin 20087 Actual_Id := Next_Actual (Actual_Id); 20088 end Next_Actual; 20089 20090 ----------------- 20091 -- Next_Global -- 20092 ----------------- 20093 20094 function Next_Global (Node : Node_Id) return Node_Id is 20095 begin 20096 -- The global item may either be in a list, or by itself, in which case 20097 -- there is no next global item with the same mode. 20098 20099 if Is_List_Member (Node) then 20100 return Next (Node); 20101 else 20102 return Empty; 20103 end if; 20104 end Next_Global; 20105 20106 procedure Next_Global (Node : in out Node_Id) is 20107 begin 20108 Node := Next_Global (Node); 20109 end Next_Global; 20110 20111 ---------------------------------- 20112 -- New_Requires_Transient_Scope -- 20113 ---------------------------------- 20114 20115 function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean is 20116 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean; 20117 -- This is called for untagged records and protected types, with 20118 -- nondefaulted discriminants. Returns True if the size of function 20119 -- results is known at the call site, False otherwise. Returns False 20120 -- if there is a variant part that depends on the discriminants of 20121 -- this type, or if there is an array constrained by the discriminants 20122 -- of this type. ???Currently, this is overly conservative (the array 20123 -- could be nested inside some other record that is constrained by 20124 -- nondiscriminants). That is, the recursive calls are too conservative. 20125 20126 function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean; 20127 -- Returns True if Typ is a nonlimited record with defaulted 20128 -- discriminants whose max size makes it unsuitable for allocating on 20129 -- the primary stack. 20130 20131 ------------------------------ 20132 -- Caller_Known_Size_Record -- 20133 ------------------------------ 20134 20135 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is 20136 pragma Assert (Typ = Underlying_Type (Typ)); 20137 20138 begin 20139 if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then 20140 return False; 20141 end if; 20142 20143 declare 20144 Comp : Entity_Id; 20145 20146 begin 20147 Comp := First_Entity (Typ); 20148 while Present (Comp) loop 20149 20150 -- Only look at E_Component entities. No need to look at 20151 -- E_Discriminant entities, and we must ignore internal 20152 -- subtypes generated for constrained components. 20153 20154 if Ekind (Comp) = E_Component then 20155 declare 20156 Comp_Type : constant Entity_Id := 20157 Underlying_Type (Etype (Comp)); 20158 20159 begin 20160 if Is_Record_Type (Comp_Type) 20161 or else 20162 Is_Protected_Type (Comp_Type) 20163 then 20164 if not Caller_Known_Size_Record (Comp_Type) then 20165 return False; 20166 end if; 20167 20168 elsif Is_Array_Type (Comp_Type) then 20169 if Size_Depends_On_Discriminant (Comp_Type) then 20170 return False; 20171 end if; 20172 end if; 20173 end; 20174 end if; 20175 20176 Next_Entity (Comp); 20177 end loop; 20178 end; 20179 20180 return True; 20181 end Caller_Known_Size_Record; 20182 20183 ------------------------------ 20184 -- Large_Max_Size_Mutable -- 20185 ------------------------------ 20186 20187 function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is 20188 pragma Assert (Typ = Underlying_Type (Typ)); 20189 20190 function Is_Large_Discrete_Type (T : Entity_Id) return Boolean; 20191 -- Returns true if the discrete type T has a large range 20192 20193 ---------------------------- 20194 -- Is_Large_Discrete_Type -- 20195 ---------------------------- 20196 20197 function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is 20198 Threshold : constant Int := 16; 20199 -- Arbitrary threshold above which we consider it "large". We want 20200 -- a fairly large threshold, because these large types really 20201 -- shouldn't have default discriminants in the first place, in 20202 -- most cases. 20203 20204 begin 20205 return UI_To_Int (RM_Size (T)) > Threshold; 20206 end Is_Large_Discrete_Type; 20207 20208 -- Start of processing for Large_Max_Size_Mutable 20209 20210 begin 20211 if Is_Record_Type (Typ) 20212 and then not Is_Limited_View (Typ) 20213 and then Has_Defaulted_Discriminants (Typ) 20214 then 20215 -- Loop through the components, looking for an array whose upper 20216 -- bound(s) depends on discriminants, where both the subtype of 20217 -- the discriminant and the index subtype are too large. 20218 20219 declare 20220 Comp : Entity_Id; 20221 20222 begin 20223 Comp := First_Entity (Typ); 20224 while Present (Comp) loop 20225 if Ekind (Comp) = E_Component then 20226 declare 20227 Comp_Type : constant Entity_Id := 20228 Underlying_Type (Etype (Comp)); 20229 20230 Hi : Node_Id; 20231 Indx : Node_Id; 20232 Ityp : Entity_Id; 20233 20234 begin 20235 if Is_Array_Type (Comp_Type) then 20236 Indx := First_Index (Comp_Type); 20237 20238 while Present (Indx) loop 20239 Ityp := Etype (Indx); 20240 Hi := Type_High_Bound (Ityp); 20241 20242 if Nkind (Hi) = N_Identifier 20243 and then Ekind (Entity (Hi)) = E_Discriminant 20244 and then Is_Large_Discrete_Type (Ityp) 20245 and then Is_Large_Discrete_Type 20246 (Etype (Entity (Hi))) 20247 then 20248 return True; 20249 end if; 20250 20251 Next_Index (Indx); 20252 end loop; 20253 end if; 20254 end; 20255 end if; 20256 20257 Next_Entity (Comp); 20258 end loop; 20259 end; 20260 end if; 20261 20262 return False; 20263 end Large_Max_Size_Mutable; 20264 20265 -- Local declarations 20266 20267 Typ : constant Entity_Id := Underlying_Type (Id); 20268 20269 -- Start of processing for New_Requires_Transient_Scope 20270 20271 begin 20272 -- This is a private type which is not completed yet. This can only 20273 -- happen in a default expression (of a formal parameter or of a 20274 -- record component). Do not expand transient scope in this case. 20275 20276 if No (Typ) then 20277 return False; 20278 20279 -- Do not expand transient scope for non-existent procedure return or 20280 -- string literal types. 20281 20282 elsif Typ = Standard_Void_Type 20283 or else Ekind (Typ) = E_String_Literal_Subtype 20284 then 20285 return False; 20286 20287 -- If Typ is a generic formal incomplete type, then we want to look at 20288 -- the actual type. 20289 20290 elsif Ekind (Typ) = E_Record_Subtype 20291 and then Present (Cloned_Subtype (Typ)) 20292 then 20293 return New_Requires_Transient_Scope (Cloned_Subtype (Typ)); 20294 20295 -- Functions returning specific tagged types may dispatch on result, so 20296 -- their returned value is allocated on the secondary stack, even in the 20297 -- definite case. We must treat nondispatching functions the same way, 20298 -- because access-to-function types can point at both, so the calling 20299 -- conventions must be compatible. Is_Tagged_Type includes controlled 20300 -- types and class-wide types. Controlled type temporaries need 20301 -- finalization. 20302 20303 -- ???It's not clear why we need to return noncontrolled types with 20304 -- controlled components on the secondary stack. 20305 20306 elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then 20307 return True; 20308 20309 -- Untagged definite subtypes are known size. This includes all 20310 -- elementary [sub]types. Tasks are known size even if they have 20311 -- discriminants. So we return False here, with one exception: 20312 -- For a type like: 20313 -- type T (Last : Natural := 0) is 20314 -- X : String (1 .. Last); 20315 -- end record; 20316 -- we return True. That's because for "P(F(...));", where F returns T, 20317 -- we don't know the size of the result at the call site, so if we 20318 -- allocated it on the primary stack, we would have to allocate the 20319 -- maximum size, which is way too big. 20320 20321 elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then 20322 return Large_Max_Size_Mutable (Typ); 20323 20324 -- Indefinite (discriminated) untagged record or protected type 20325 20326 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then 20327 return not Caller_Known_Size_Record (Typ); 20328 20329 -- Unconstrained array 20330 20331 else 20332 pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ)); 20333 return True; 20334 end if; 20335 end New_Requires_Transient_Scope; 20336 20337 -------------------------- 20338 -- No_Heap_Finalization -- 20339 -------------------------- 20340 20341 function No_Heap_Finalization (Typ : Entity_Id) return Boolean is 20342 begin 20343 if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) 20344 and then Is_Library_Level_Entity (Typ) 20345 then 20346 -- A global No_Heap_Finalization pragma applies to all library-level 20347 -- named access-to-object types. 20348 20349 if Present (No_Heap_Finalization_Pragma) then 20350 return True; 20351 20352 -- The library-level named access-to-object type itself is subject to 20353 -- pragma No_Heap_Finalization. 20354 20355 elsif Present (Get_Pragma (Typ, Pragma_No_Heap_Finalization)) then 20356 return True; 20357 end if; 20358 end if; 20359 20360 return False; 20361 end No_Heap_Finalization; 20362 20363 ----------------------- 20364 -- Normalize_Actuals -- 20365 ----------------------- 20366 20367 -- Chain actuals according to formals of subprogram. If there are no named 20368 -- associations, the chain is simply the list of Parameter Associations, 20369 -- since the order is the same as the declaration order. If there are named 20370 -- associations, then the First_Named_Actual field in the N_Function_Call 20371 -- or N_Procedure_Call_Statement node points to the Parameter_Association 20372 -- node for the parameter that comes first in declaration order. The 20373 -- remaining named parameters are then chained in declaration order using 20374 -- Next_Named_Actual. 20375 20376 -- This routine also verifies that the number of actuals is compatible with 20377 -- the number and default values of formals, but performs no type checking 20378 -- (type checking is done by the caller). 20379 20380 -- If the matching succeeds, Success is set to True and the caller proceeds 20381 -- with type-checking. If the match is unsuccessful, then Success is set to 20382 -- False, and the caller attempts a different interpretation, if there is 20383 -- one. 20384 20385 -- If the flag Report is on, the call is not overloaded, and a failure to 20386 -- match can be reported here, rather than in the caller. 20387 20388 procedure Normalize_Actuals 20389 (N : Node_Id; 20390 S : Entity_Id; 20391 Report : Boolean; 20392 Success : out Boolean) 20393 is 20394 Actuals : constant List_Id := Parameter_Associations (N); 20395 Actual : Node_Id := Empty; 20396 Formal : Entity_Id; 20397 Last : Node_Id := Empty; 20398 First_Named : Node_Id := Empty; 20399 Found : Boolean; 20400 20401 Formals_To_Match : Integer := 0; 20402 Actuals_To_Match : Integer := 0; 20403 20404 procedure Chain (A : Node_Id); 20405 -- Add named actual at the proper place in the list, using the 20406 -- Next_Named_Actual link. 20407 20408 function Reporting return Boolean; 20409 -- Determines if an error is to be reported. To report an error, we 20410 -- need Report to be True, and also we do not report errors caused 20411 -- by calls to init procs that occur within other init procs. Such 20412 -- errors must always be cascaded errors, since if all the types are 20413 -- declared correctly, the compiler will certainly build decent calls. 20414 20415 ----------- 20416 -- Chain -- 20417 ----------- 20418 20419 procedure Chain (A : Node_Id) is 20420 begin 20421 if No (Last) then 20422 20423 -- Call node points to first actual in list 20424 20425 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A)); 20426 20427 else 20428 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A)); 20429 end if; 20430 20431 Last := A; 20432 Set_Next_Named_Actual (Last, Empty); 20433 end Chain; 20434 20435 --------------- 20436 -- Reporting -- 20437 --------------- 20438 20439 function Reporting return Boolean is 20440 begin 20441 if not Report then 20442 return False; 20443 20444 elsif not Within_Init_Proc then 20445 return True; 20446 20447 elsif Is_Init_Proc (Entity (Name (N))) then 20448 return False; 20449 20450 else 20451 return True; 20452 end if; 20453 end Reporting; 20454 20455 -- Start of processing for Normalize_Actuals 20456 20457 begin 20458 if Is_Access_Type (S) then 20459 20460 -- The name in the call is a function call that returns an access 20461 -- to subprogram. The designated type has the list of formals. 20462 20463 Formal := First_Formal (Designated_Type (S)); 20464 else 20465 Formal := First_Formal (S); 20466 end if; 20467 20468 while Present (Formal) loop 20469 Formals_To_Match := Formals_To_Match + 1; 20470 Next_Formal (Formal); 20471 end loop; 20472 20473 -- Find if there is a named association, and verify that no positional 20474 -- associations appear after named ones. 20475 20476 if Present (Actuals) then 20477 Actual := First (Actuals); 20478 end if; 20479 20480 while Present (Actual) 20481 and then Nkind (Actual) /= N_Parameter_Association 20482 loop 20483 Actuals_To_Match := Actuals_To_Match + 1; 20484 Next (Actual); 20485 end loop; 20486 20487 if No (Actual) and Actuals_To_Match = Formals_To_Match then 20488 20489 -- Most common case: positional notation, no defaults 20490 20491 Success := True; 20492 return; 20493 20494 elsif Actuals_To_Match > Formals_To_Match then 20495 20496 -- Too many actuals: will not work 20497 20498 if Reporting then 20499 if Is_Entity_Name (Name (N)) then 20500 Error_Msg_N ("too many arguments in call to&", Name (N)); 20501 else 20502 Error_Msg_N ("too many arguments in call", N); 20503 end if; 20504 end if; 20505 20506 Success := False; 20507 return; 20508 end if; 20509 20510 First_Named := Actual; 20511 20512 while Present (Actual) loop 20513 if Nkind (Actual) /= N_Parameter_Association then 20514 Error_Msg_N 20515 ("positional parameters not allowed after named ones", Actual); 20516 Success := False; 20517 return; 20518 20519 else 20520 Actuals_To_Match := Actuals_To_Match + 1; 20521 end if; 20522 20523 Next (Actual); 20524 end loop; 20525 20526 if Present (Actuals) then 20527 Actual := First (Actuals); 20528 end if; 20529 20530 Formal := First_Formal (S); 20531 while Present (Formal) loop 20532 20533 -- Match the formals in order. If the corresponding actual is 20534 -- positional, nothing to do. Else scan the list of named actuals 20535 -- to find the one with the right name. 20536 20537 if Present (Actual) 20538 and then Nkind (Actual) /= N_Parameter_Association 20539 then 20540 Next (Actual); 20541 Actuals_To_Match := Actuals_To_Match - 1; 20542 Formals_To_Match := Formals_To_Match - 1; 20543 20544 else 20545 -- For named parameters, search the list of actuals to find 20546 -- one that matches the next formal name. 20547 20548 Actual := First_Named; 20549 Found := False; 20550 while Present (Actual) loop 20551 if Chars (Selector_Name (Actual)) = Chars (Formal) then 20552 Found := True; 20553 Chain (Actual); 20554 Actuals_To_Match := Actuals_To_Match - 1; 20555 Formals_To_Match := Formals_To_Match - 1; 20556 exit; 20557 end if; 20558 20559 Next (Actual); 20560 end loop; 20561 20562 if not Found then 20563 if Ekind (Formal) /= E_In_Parameter 20564 or else No (Default_Value (Formal)) 20565 then 20566 if Reporting then 20567 if (Comes_From_Source (S) 20568 or else Sloc (S) = Standard_Location) 20569 and then Is_Overloadable (S) 20570 then 20571 if No (Actuals) 20572 and then 20573 Nkind_In (Parent (N), N_Procedure_Call_Statement, 20574 N_Function_Call, 20575 N_Parameter_Association) 20576 and then Ekind (S) /= E_Function 20577 then 20578 Set_Etype (N, Etype (S)); 20579 20580 else 20581 Error_Msg_Name_1 := Chars (S); 20582 Error_Msg_Sloc := Sloc (S); 20583 Error_Msg_NE 20584 ("missing argument for parameter & " 20585 & "in call to % declared #", N, Formal); 20586 end if; 20587 20588 elsif Is_Overloadable (S) then 20589 Error_Msg_Name_1 := Chars (S); 20590 20591 -- Point to type derivation that generated the 20592 -- operation. 20593 20594 Error_Msg_Sloc := Sloc (Parent (S)); 20595 20596 Error_Msg_NE 20597 ("missing argument for parameter & " 20598 & "in call to % (inherited) #", N, Formal); 20599 20600 else 20601 Error_Msg_NE 20602 ("missing argument for parameter &", N, Formal); 20603 end if; 20604 end if; 20605 20606 Success := False; 20607 return; 20608 20609 else 20610 Formals_To_Match := Formals_To_Match - 1; 20611 end if; 20612 end if; 20613 end if; 20614 20615 Next_Formal (Formal); 20616 end loop; 20617 20618 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then 20619 Success := True; 20620 return; 20621 20622 else 20623 if Reporting then 20624 20625 -- Find some superfluous named actual that did not get 20626 -- attached to the list of associations. 20627 20628 Actual := First (Actuals); 20629 while Present (Actual) loop 20630 if Nkind (Actual) = N_Parameter_Association 20631 and then Actual /= Last 20632 and then No (Next_Named_Actual (Actual)) 20633 then 20634 -- A validity check may introduce a copy of a call that 20635 -- includes an extra actual (for example for an unrelated 20636 -- accessibility check). Check that the extra actual matches 20637 -- some extra formal, which must exist already because 20638 -- subprogram must be frozen at this point. 20639 20640 if Present (Extra_Formals (S)) 20641 and then not Comes_From_Source (Actual) 20642 and then Nkind (Actual) = N_Parameter_Association 20643 and then Chars (Extra_Formals (S)) = 20644 Chars (Selector_Name (Actual)) 20645 then 20646 null; 20647 else 20648 Error_Msg_N 20649 ("unmatched actual & in call", Selector_Name (Actual)); 20650 exit; 20651 end if; 20652 end if; 20653 20654 Next (Actual); 20655 end loop; 20656 end if; 20657 20658 Success := False; 20659 return; 20660 end if; 20661 end Normalize_Actuals; 20662 20663 -------------------------------- 20664 -- Note_Possible_Modification -- 20665 -------------------------------- 20666 20667 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is 20668 Modification_Comes_From_Source : constant Boolean := 20669 Comes_From_Source (Parent (N)); 20670 20671 Ent : Entity_Id; 20672 Exp : Node_Id; 20673 20674 begin 20675 -- Loop to find referenced entity, if there is one 20676 20677 Exp := N; 20678 loop 20679 Ent := Empty; 20680 20681 if Is_Entity_Name (Exp) then 20682 Ent := Entity (Exp); 20683 20684 -- If the entity is missing, it is an undeclared identifier, 20685 -- and there is nothing to annotate. 20686 20687 if No (Ent) then 20688 return; 20689 end if; 20690 20691 elsif Nkind (Exp) = N_Explicit_Dereference then 20692 declare 20693 P : constant Node_Id := Prefix (Exp); 20694 20695 begin 20696 -- In formal verification mode, keep track of all reads and 20697 -- writes through explicit dereferences. 20698 20699 if GNATprove_Mode then 20700 SPARK_Specific.Generate_Dereference (N, 'm'); 20701 end if; 20702 20703 if Nkind (P) = N_Selected_Component 20704 and then Present (Entry_Formal (Entity (Selector_Name (P)))) 20705 then 20706 -- Case of a reference to an entry formal 20707 20708 Ent := Entry_Formal (Entity (Selector_Name (P))); 20709 20710 elsif Nkind (P) = N_Identifier 20711 and then Nkind (Parent (Entity (P))) = N_Object_Declaration 20712 and then Present (Expression (Parent (Entity (P)))) 20713 and then Nkind (Expression (Parent (Entity (P)))) = 20714 N_Reference 20715 then 20716 -- Case of a reference to a value on which side effects have 20717 -- been removed. 20718 20719 Exp := Prefix (Expression (Parent (Entity (P)))); 20720 goto Continue; 20721 20722 else 20723 return; 20724 end if; 20725 end; 20726 20727 elsif Nkind_In (Exp, N_Type_Conversion, 20728 N_Unchecked_Type_Conversion) 20729 then 20730 Exp := Expression (Exp); 20731 goto Continue; 20732 20733 elsif Nkind_In (Exp, N_Slice, 20734 N_Indexed_Component, 20735 N_Selected_Component) 20736 then 20737 -- Special check, if the prefix is an access type, then return 20738 -- since we are modifying the thing pointed to, not the prefix. 20739 -- When we are expanding, most usually the prefix is replaced 20740 -- by an explicit dereference, and this test is not needed, but 20741 -- in some cases (notably -gnatc mode and generics) when we do 20742 -- not do full expansion, we need this special test. 20743 20744 if Is_Access_Type (Etype (Prefix (Exp))) then 20745 return; 20746 20747 -- Otherwise go to prefix and keep going 20748 20749 else 20750 Exp := Prefix (Exp); 20751 goto Continue; 20752 end if; 20753 20754 -- All other cases, not a modification 20755 20756 else 20757 return; 20758 end if; 20759 20760 -- Now look for entity being referenced 20761 20762 if Present (Ent) then 20763 if Is_Object (Ent) then 20764 if Comes_From_Source (Exp) 20765 or else Modification_Comes_From_Source 20766 then 20767 -- Give warning if pragma unmodified is given and we are 20768 -- sure this is a modification. 20769 20770 if Has_Pragma_Unmodified (Ent) and then Sure then 20771 20772 -- Note that the entity may be present only as a result 20773 -- of pragma Unused. 20774 20775 if Has_Pragma_Unused (Ent) then 20776 Error_Msg_NE ("??pragma Unused given for &!", N, Ent); 20777 else 20778 Error_Msg_NE 20779 ("??pragma Unmodified given for &!", N, Ent); 20780 end if; 20781 end if; 20782 20783 Set_Never_Set_In_Source (Ent, False); 20784 end if; 20785 20786 Set_Is_True_Constant (Ent, False); 20787 Set_Current_Value (Ent, Empty); 20788 Set_Is_Known_Null (Ent, False); 20789 20790 if not Can_Never_Be_Null (Ent) then 20791 Set_Is_Known_Non_Null (Ent, False); 20792 end if; 20793 20794 -- Follow renaming chain 20795 20796 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant) 20797 and then Present (Renamed_Object (Ent)) 20798 then 20799 Exp := Renamed_Object (Ent); 20800 20801 -- If the entity is the loop variable in an iteration over 20802 -- a container, retrieve container expression to indicate 20803 -- possible modification. 20804 20805 if Present (Related_Expression (Ent)) 20806 and then Nkind (Parent (Related_Expression (Ent))) = 20807 N_Iterator_Specification 20808 then 20809 Exp := Original_Node (Related_Expression (Ent)); 20810 end if; 20811 20812 goto Continue; 20813 20814 -- The expression may be the renaming of a subcomponent of an 20815 -- array or container. The assignment to the subcomponent is 20816 -- a modification of the container. 20817 20818 elsif Comes_From_Source (Original_Node (Exp)) 20819 and then Nkind_In (Original_Node (Exp), N_Selected_Component, 20820 N_Indexed_Component) 20821 then 20822 Exp := Prefix (Original_Node (Exp)); 20823 goto Continue; 20824 end if; 20825 20826 -- Generate a reference only if the assignment comes from 20827 -- source. This excludes, for example, calls to a dispatching 20828 -- assignment operation when the left-hand side is tagged. In 20829 -- GNATprove mode, we need those references also on generated 20830 -- code, as these are used to compute the local effects of 20831 -- subprograms. 20832 20833 if Modification_Comes_From_Source or GNATprove_Mode then 20834 Generate_Reference (Ent, Exp, 'm'); 20835 20836 -- If the target of the assignment is the bound variable 20837 -- in an iterator, indicate that the corresponding array 20838 -- or container is also modified. 20839 20840 if Ada_Version >= Ada_2012 20841 and then Nkind (Parent (Ent)) = N_Iterator_Specification 20842 then 20843 declare 20844 Domain : constant Node_Id := Name (Parent (Ent)); 20845 20846 begin 20847 -- TBD : in the full version of the construct, the 20848 -- domain of iteration can be given by an expression. 20849 20850 if Is_Entity_Name (Domain) then 20851 Generate_Reference (Entity (Domain), Exp, 'm'); 20852 Set_Is_True_Constant (Entity (Domain), False); 20853 Set_Never_Set_In_Source (Entity (Domain), False); 20854 end if; 20855 end; 20856 end if; 20857 end if; 20858 end if; 20859 20860 Kill_Checks (Ent); 20861 20862 -- If we are sure this is a modification from source, and we know 20863 -- this modifies a constant, then give an appropriate warning. 20864 20865 if Sure 20866 and then Modification_Comes_From_Source 20867 and then Overlays_Constant (Ent) 20868 and then Address_Clause_Overlay_Warnings 20869 then 20870 declare 20871 Addr : constant Node_Id := Address_Clause (Ent); 20872 O_Ent : Entity_Id; 20873 Off : Boolean; 20874 20875 begin 20876 Find_Overlaid_Entity (Addr, O_Ent, Off); 20877 20878 Error_Msg_Sloc := Sloc (Addr); 20879 Error_Msg_NE 20880 ("??constant& may be modified via address clause#", 20881 N, O_Ent); 20882 end; 20883 end if; 20884 20885 return; 20886 end if; 20887 20888 <<Continue>> 20889 null; 20890 end loop; 20891 end Note_Possible_Modification; 20892 20893 ----------------- 20894 -- Null_Status -- 20895 ----------------- 20896 20897 function Null_Status (N : Node_Id) return Null_Status_Kind is 20898 function Is_Null_Excluding_Def (Def : Node_Id) return Boolean; 20899 -- Determine whether definition Def carries a null exclusion 20900 20901 function Null_Status_Of_Entity (Id : Entity_Id) return Null_Status_Kind; 20902 -- Determine the null status of arbitrary entity Id 20903 20904 function Null_Status_Of_Type (Typ : Entity_Id) return Null_Status_Kind; 20905 -- Determine the null status of type Typ 20906 20907 --------------------------- 20908 -- Is_Null_Excluding_Def -- 20909 --------------------------- 20910 20911 function Is_Null_Excluding_Def (Def : Node_Id) return Boolean is 20912 begin 20913 return 20914 Nkind_In (Def, N_Access_Definition, 20915 N_Access_Function_Definition, 20916 N_Access_Procedure_Definition, 20917 N_Access_To_Object_Definition, 20918 N_Component_Definition, 20919 N_Derived_Type_Definition) 20920 and then Null_Exclusion_Present (Def); 20921 end Is_Null_Excluding_Def; 20922 20923 --------------------------- 20924 -- Null_Status_Of_Entity -- 20925 --------------------------- 20926 20927 function Null_Status_Of_Entity 20928 (Id : Entity_Id) return Null_Status_Kind 20929 is 20930 Decl : constant Node_Id := Declaration_Node (Id); 20931 Def : Node_Id; 20932 20933 begin 20934 -- The value of an imported or exported entity may be set externally 20935 -- regardless of a null exclusion. As a result, the value cannot be 20936 -- determined statically. 20937 20938 if Is_Imported (Id) or else Is_Exported (Id) then 20939 return Unknown; 20940 20941 elsif Nkind_In (Decl, N_Component_Declaration, 20942 N_Discriminant_Specification, 20943 N_Formal_Object_Declaration, 20944 N_Object_Declaration, 20945 N_Object_Renaming_Declaration, 20946 N_Parameter_Specification) 20947 then 20948 -- A component declaration yields a non-null value when either 20949 -- its component definition or access definition carries a null 20950 -- exclusion. 20951 20952 if Nkind (Decl) = N_Component_Declaration then 20953 Def := Component_Definition (Decl); 20954 20955 if Is_Null_Excluding_Def (Def) then 20956 return Is_Non_Null; 20957 end if; 20958 20959 Def := Access_Definition (Def); 20960 20961 if Present (Def) and then Is_Null_Excluding_Def (Def) then 20962 return Is_Non_Null; 20963 end if; 20964 20965 -- A formal object declaration yields a non-null value if its 20966 -- access definition carries a null exclusion. If the object is 20967 -- default initialized, then the value depends on the expression. 20968 20969 elsif Nkind (Decl) = N_Formal_Object_Declaration then 20970 Def := Access_Definition (Decl); 20971 20972 if Present (Def) and then Is_Null_Excluding_Def (Def) then 20973 return Is_Non_Null; 20974 end if; 20975 20976 -- A constant may yield a null or non-null value depending on its 20977 -- initialization expression. 20978 20979 elsif Ekind (Id) = E_Constant then 20980 return Null_Status (Constant_Value (Id)); 20981 20982 -- The construct yields a non-null value when it has a null 20983 -- exclusion. 20984 20985 elsif Null_Exclusion_Present (Decl) then 20986 return Is_Non_Null; 20987 20988 -- An object renaming declaration yields a non-null value if its 20989 -- access definition carries a null exclusion. Otherwise the value 20990 -- depends on the renamed name. 20991 20992 elsif Nkind (Decl) = N_Object_Renaming_Declaration then 20993 Def := Access_Definition (Decl); 20994 20995 if Present (Def) and then Is_Null_Excluding_Def (Def) then 20996 return Is_Non_Null; 20997 20998 else 20999 return Null_Status (Name (Decl)); 21000 end if; 21001 end if; 21002 end if; 21003 21004 -- At this point the declaration of the entity does not carry a null 21005 -- exclusion and lacks an initialization expression. Check the status 21006 -- of its type. 21007 21008 return Null_Status_Of_Type (Etype (Id)); 21009 end Null_Status_Of_Entity; 21010 21011 ------------------------- 21012 -- Null_Status_Of_Type -- 21013 ------------------------- 21014 21015 function Null_Status_Of_Type (Typ : Entity_Id) return Null_Status_Kind is 21016 Curr : Entity_Id; 21017 Decl : Node_Id; 21018 21019 begin 21020 -- Traverse the type chain looking for types with null exclusion 21021 21022 Curr := Typ; 21023 while Present (Curr) and then Etype (Curr) /= Curr loop 21024 Decl := Parent (Curr); 21025 21026 -- Guard against itypes which do not always have declarations. A 21027 -- type yields a non-null value if it carries a null exclusion. 21028 21029 if Present (Decl) then 21030 if Nkind (Decl) = N_Full_Type_Declaration 21031 and then Is_Null_Excluding_Def (Type_Definition (Decl)) 21032 then 21033 return Is_Non_Null; 21034 21035 elsif Nkind (Decl) = N_Subtype_Declaration 21036 and then Null_Exclusion_Present (Decl) 21037 then 21038 return Is_Non_Null; 21039 end if; 21040 end if; 21041 21042 Curr := Etype (Curr); 21043 end loop; 21044 21045 -- The type chain does not contain any null excluding types 21046 21047 return Unknown; 21048 end Null_Status_Of_Type; 21049 21050 -- Start of processing for Null_Status 21051 21052 begin 21053 -- An allocator always creates a non-null value 21054 21055 if Nkind (N) = N_Allocator then 21056 return Is_Non_Null; 21057 21058 -- Taking the 'Access of something yields a non-null value 21059 21060 elsif Nkind (N) = N_Attribute_Reference 21061 and then Nam_In (Attribute_Name (N), Name_Access, 21062 Name_Unchecked_Access, 21063 Name_Unrestricted_Access) 21064 then 21065 return Is_Non_Null; 21066 21067 -- "null" yields null 21068 21069 elsif Nkind (N) = N_Null then 21070 return Is_Null; 21071 21072 -- Check the status of the operand of a type conversion 21073 21074 elsif Nkind (N) = N_Type_Conversion then 21075 return Null_Status (Expression (N)); 21076 21077 -- The input denotes a reference to an entity. Determine whether the 21078 -- entity or its type yields a null or non-null value. 21079 21080 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 21081 return Null_Status_Of_Entity (Entity (N)); 21082 end if; 21083 21084 -- Otherwise it is not possible to determine the null status of the 21085 -- subexpression at compile time without resorting to simple flow 21086 -- analysis. 21087 21088 return Unknown; 21089 end Null_Status; 21090 21091 -------------------------------------- 21092 -- Null_To_Null_Address_Convert_OK -- 21093 -------------------------------------- 21094 21095 function Null_To_Null_Address_Convert_OK 21096 (N : Node_Id; 21097 Typ : Entity_Id := Empty) return Boolean 21098 is 21099 begin 21100 if not Relaxed_RM_Semantics then 21101 return False; 21102 end if; 21103 21104 if Nkind (N) = N_Null then 21105 return Present (Typ) and then Is_Descendant_Of_Address (Typ); 21106 21107 elsif Nkind_In (N, N_Op_Eq, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt, N_Op_Ne) 21108 then 21109 declare 21110 L : constant Node_Id := Left_Opnd (N); 21111 R : constant Node_Id := Right_Opnd (N); 21112 21113 begin 21114 -- We check the Etype of the complementary operand since the 21115 -- N_Null node is not decorated at this stage. 21116 21117 return 21118 ((Nkind (L) = N_Null 21119 and then Is_Descendant_Of_Address (Etype (R))) 21120 or else 21121 (Nkind (R) = N_Null 21122 and then Is_Descendant_Of_Address (Etype (L)))); 21123 end; 21124 end if; 21125 21126 return False; 21127 end Null_To_Null_Address_Convert_OK; 21128 21129 --------------------------------- 21130 -- Number_Of_Elements_In_Array -- 21131 --------------------------------- 21132 21133 function Number_Of_Elements_In_Array (T : Entity_Id) return Int is 21134 Indx : Node_Id; 21135 Typ : Entity_Id; 21136 Low : Node_Id; 21137 High : Node_Id; 21138 Num : Int := 1; 21139 21140 begin 21141 pragma Assert (Is_Array_Type (T)); 21142 21143 Indx := First_Index (T); 21144 while Present (Indx) loop 21145 Typ := Underlying_Type (Etype (Indx)); 21146 21147 -- Never look at junk bounds of a generic type 21148 21149 if Is_Generic_Type (Typ) then 21150 return 0; 21151 end if; 21152 21153 -- Check the array bounds are known at compile time and return zero 21154 -- if they are not. 21155 21156 Low := Type_Low_Bound (Typ); 21157 High := Type_High_Bound (Typ); 21158 21159 if not Compile_Time_Known_Value (Low) then 21160 return 0; 21161 elsif not Compile_Time_Known_Value (High) then 21162 return 0; 21163 else 21164 Num := 21165 Num * UI_To_Int ((Expr_Value (High) - Expr_Value (Low) + 1)); 21166 end if; 21167 21168 Next_Index (Indx); 21169 end loop; 21170 21171 return Num; 21172 end Number_Of_Elements_In_Array; 21173 21174 ------------------------- 21175 -- Object_Access_Level -- 21176 ------------------------- 21177 21178 -- Returns the static accessibility level of the view denoted by Obj. Note 21179 -- that the value returned is the result of a call to Scope_Depth. Only 21180 -- scope depths associated with dynamic scopes can actually be returned. 21181 -- Since only relative levels matter for accessibility checking, the fact 21182 -- that the distance between successive levels of accessibility is not 21183 -- always one is immaterial (invariant: if level(E2) is deeper than 21184 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)). 21185 21186 function Object_Access_Level (Obj : Node_Id) return Uint is 21187 function Is_Interface_Conversion (N : Node_Id) return Boolean; 21188 -- Determine whether N is a construct of the form 21189 -- Some_Type (Operand._tag'Address) 21190 -- This construct appears in the context of dispatching calls. 21191 21192 function Reference_To (Obj : Node_Id) return Node_Id; 21193 -- An explicit dereference is created when removing side effects from 21194 -- expressions for constraint checking purposes. In this case a local 21195 -- access type is created for it. The correct access level is that of 21196 -- the original source node. We detect this case by noting that the 21197 -- prefix of the dereference is created by an object declaration whose 21198 -- initial expression is a reference. 21199 21200 ----------------------------- 21201 -- Is_Interface_Conversion -- 21202 ----------------------------- 21203 21204 function Is_Interface_Conversion (N : Node_Id) return Boolean is 21205 begin 21206 return Nkind (N) = N_Unchecked_Type_Conversion 21207 and then Nkind (Expression (N)) = N_Attribute_Reference 21208 and then Attribute_Name (Expression (N)) = Name_Address; 21209 end Is_Interface_Conversion; 21210 21211 ------------------ 21212 -- Reference_To -- 21213 ------------------ 21214 21215 function Reference_To (Obj : Node_Id) return Node_Id is 21216 Pref : constant Node_Id := Prefix (Obj); 21217 begin 21218 if Is_Entity_Name (Pref) 21219 and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration 21220 and then Present (Expression (Parent (Entity (Pref)))) 21221 and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference 21222 then 21223 return (Prefix (Expression (Parent (Entity (Pref))))); 21224 else 21225 return Empty; 21226 end if; 21227 end Reference_To; 21228 21229 -- Local variables 21230 21231 E : Entity_Id; 21232 21233 -- Start of processing for Object_Access_Level 21234 21235 begin 21236 if Nkind (Obj) = N_Defining_Identifier 21237 or else Is_Entity_Name (Obj) 21238 then 21239 if Nkind (Obj) = N_Defining_Identifier then 21240 E := Obj; 21241 else 21242 E := Entity (Obj); 21243 end if; 21244 21245 if Is_Prival (E) then 21246 E := Prival_Link (E); 21247 end if; 21248 21249 -- If E is a type then it denotes a current instance. For this case 21250 -- we add one to the normal accessibility level of the type to ensure 21251 -- that current instances are treated as always being deeper than 21252 -- than the level of any visible named access type (see 3.10.2(21)). 21253 21254 if Is_Type (E) then 21255 return Type_Access_Level (E) + 1; 21256 21257 elsif Present (Renamed_Object (E)) then 21258 return Object_Access_Level (Renamed_Object (E)); 21259 21260 -- Similarly, if E is a component of the current instance of a 21261 -- protected type, any instance of it is assumed to be at a deeper 21262 -- level than the type. For a protected object (whose type is an 21263 -- anonymous protected type) its components are at the same level 21264 -- as the type itself. 21265 21266 elsif not Is_Overloadable (E) 21267 and then Ekind (Scope (E)) = E_Protected_Type 21268 and then Comes_From_Source (Scope (E)) 21269 then 21270 return Type_Access_Level (Scope (E)) + 1; 21271 21272 else 21273 -- Aliased formals of functions take their access level from the 21274 -- point of call, i.e. require a dynamic check. For static check 21275 -- purposes, this is smaller than the level of the subprogram 21276 -- itself. For procedures the aliased makes no difference. 21277 21278 if Is_Formal (E) 21279 and then Is_Aliased (E) 21280 and then Ekind (Scope (E)) = E_Function 21281 then 21282 return Type_Access_Level (Etype (E)); 21283 21284 else 21285 return Scope_Depth (Enclosing_Dynamic_Scope (E)); 21286 end if; 21287 end if; 21288 21289 elsif Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then 21290 if Is_Access_Type (Etype (Prefix (Obj))) then 21291 return Type_Access_Level (Etype (Prefix (Obj))); 21292 else 21293 return Object_Access_Level (Prefix (Obj)); 21294 end if; 21295 21296 elsif Nkind (Obj) = N_Explicit_Dereference then 21297 21298 -- If the prefix is a selected access discriminant then we make a 21299 -- recursive call on the prefix, which will in turn check the level 21300 -- of the prefix object of the selected discriminant. 21301 21302 -- In Ada 2012, if the discriminant has implicit dereference and 21303 -- the context is a selected component, treat this as an object of 21304 -- unknown scope (see below). This is necessary in compile-only mode; 21305 -- otherwise expansion will already have transformed the prefix into 21306 -- a temporary. 21307 21308 if Nkind (Prefix (Obj)) = N_Selected_Component 21309 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type 21310 and then 21311 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant 21312 and then 21313 (not Has_Implicit_Dereference 21314 (Entity (Selector_Name (Prefix (Obj)))) 21315 or else Nkind (Parent (Obj)) /= N_Selected_Component) 21316 then 21317 return Object_Access_Level (Prefix (Obj)); 21318 21319 -- Detect an interface conversion in the context of a dispatching 21320 -- call. Use the original form of the conversion to find the access 21321 -- level of the operand. 21322 21323 elsif Is_Interface (Etype (Obj)) 21324 and then Is_Interface_Conversion (Prefix (Obj)) 21325 and then Nkind (Original_Node (Obj)) = N_Type_Conversion 21326 then 21327 return Object_Access_Level (Original_Node (Obj)); 21328 21329 elsif not Comes_From_Source (Obj) then 21330 declare 21331 Ref : constant Node_Id := Reference_To (Obj); 21332 begin 21333 if Present (Ref) then 21334 return Object_Access_Level (Ref); 21335 else 21336 return Type_Access_Level (Etype (Prefix (Obj))); 21337 end if; 21338 end; 21339 21340 else 21341 return Type_Access_Level (Etype (Prefix (Obj))); 21342 end if; 21343 21344 elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then 21345 return Object_Access_Level (Expression (Obj)); 21346 21347 elsif Nkind (Obj) = N_Function_Call then 21348 21349 -- Function results are objects, so we get either the access level of 21350 -- the function or, in the case of an indirect call, the level of the 21351 -- access-to-subprogram type. (This code is used for Ada 95, but it 21352 -- looks wrong, because it seems that we should be checking the level 21353 -- of the call itself, even for Ada 95. However, using the Ada 2005 21354 -- version of the code causes regressions in several tests that are 21355 -- compiled with -gnat95. ???) 21356 21357 if Ada_Version < Ada_2005 then 21358 if Is_Entity_Name (Name (Obj)) then 21359 return Subprogram_Access_Level (Entity (Name (Obj))); 21360 else 21361 return Type_Access_Level (Etype (Prefix (Name (Obj)))); 21362 end if; 21363 21364 -- For Ada 2005, the level of the result object of a function call is 21365 -- defined to be the level of the call's innermost enclosing master. 21366 -- We determine that by querying the depth of the innermost enclosing 21367 -- dynamic scope. 21368 21369 else 21370 Return_Master_Scope_Depth_Of_Call : declare 21371 function Innermost_Master_Scope_Depth 21372 (N : Node_Id) return Uint; 21373 -- Returns the scope depth of the given node's innermost 21374 -- enclosing dynamic scope (effectively the accessibility 21375 -- level of the innermost enclosing master). 21376 21377 ---------------------------------- 21378 -- Innermost_Master_Scope_Depth -- 21379 ---------------------------------- 21380 21381 function Innermost_Master_Scope_Depth 21382 (N : Node_Id) return Uint 21383 is 21384 Node_Par : Node_Id := Parent (N); 21385 21386 begin 21387 -- Locate the nearest enclosing node (by traversing Parents) 21388 -- that Defining_Entity can be applied to, and return the 21389 -- depth of that entity's nearest enclosing dynamic scope. 21390 21391 while Present (Node_Par) loop 21392 case Nkind (Node_Par) is 21393 when N_Abstract_Subprogram_Declaration 21394 | N_Block_Statement 21395 | N_Body_Stub 21396 | N_Component_Declaration 21397 | N_Entry_Body 21398 | N_Entry_Declaration 21399 | N_Exception_Declaration 21400 | N_Formal_Object_Declaration 21401 | N_Formal_Package_Declaration 21402 | N_Formal_Subprogram_Declaration 21403 | N_Formal_Type_Declaration 21404 | N_Full_Type_Declaration 21405 | N_Function_Specification 21406 | N_Generic_Declaration 21407 | N_Generic_Instantiation 21408 | N_Implicit_Label_Declaration 21409 | N_Incomplete_Type_Declaration 21410 | N_Loop_Parameter_Specification 21411 | N_Number_Declaration 21412 | N_Object_Declaration 21413 | N_Package_Declaration 21414 | N_Package_Specification 21415 | N_Parameter_Specification 21416 | N_Private_Extension_Declaration 21417 | N_Private_Type_Declaration 21418 | N_Procedure_Specification 21419 | N_Proper_Body 21420 | N_Protected_Type_Declaration 21421 | N_Renaming_Declaration 21422 | N_Single_Protected_Declaration 21423 | N_Single_Task_Declaration 21424 | N_Subprogram_Declaration 21425 | N_Subtype_Declaration 21426 | N_Subunit 21427 | N_Task_Type_Declaration 21428 => 21429 return Scope_Depth 21430 (Nearest_Dynamic_Scope 21431 (Defining_Entity (Node_Par))); 21432 21433 -- For a return statement within a function, return 21434 -- the depth of the function itself. This is not just 21435 -- a small optimization, but matters when analyzing 21436 -- the expression in an expression function before 21437 -- the body is created. 21438 21439 when N_Simple_Return_Statement => 21440 if Ekind (Current_Scope) = E_Function then 21441 return Scope_Depth (Current_Scope); 21442 end if; 21443 21444 when others => 21445 null; 21446 end case; 21447 21448 Node_Par := Parent (Node_Par); 21449 end loop; 21450 21451 pragma Assert (False); 21452 21453 -- Should never reach the following return 21454 21455 return Scope_Depth (Current_Scope) + 1; 21456 end Innermost_Master_Scope_Depth; 21457 21458 -- Start of processing for Return_Master_Scope_Depth_Of_Call 21459 21460 begin 21461 return Innermost_Master_Scope_Depth (Obj); 21462 end Return_Master_Scope_Depth_Of_Call; 21463 end if; 21464 21465 -- For convenience we handle qualified expressions, even though they 21466 -- aren't technically object names. 21467 21468 elsif Nkind (Obj) = N_Qualified_Expression then 21469 return Object_Access_Level (Expression (Obj)); 21470 21471 -- Ditto for aggregates. They have the level of the temporary that 21472 -- will hold their value. 21473 21474 elsif Nkind (Obj) = N_Aggregate then 21475 return Object_Access_Level (Current_Scope); 21476 21477 -- Otherwise return the scope level of Standard. (If there are cases 21478 -- that fall through to this point they will be treated as having 21479 -- global accessibility for now. ???) 21480 21481 else 21482 return Scope_Depth (Standard_Standard); 21483 end if; 21484 end Object_Access_Level; 21485 21486 ---------------------------------- 21487 -- Old_Requires_Transient_Scope -- 21488 ---------------------------------- 21489 21490 function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean is 21491 Typ : constant Entity_Id := Underlying_Type (Id); 21492 21493 begin 21494 -- This is a private type which is not completed yet. This can only 21495 -- happen in a default expression (of a formal parameter or of a 21496 -- record component). Do not expand transient scope in this case. 21497 21498 if No (Typ) then 21499 return False; 21500 21501 -- Do not expand transient scope for non-existent procedure return 21502 21503 elsif Typ = Standard_Void_Type then 21504 return False; 21505 21506 -- Elementary types do not require a transient scope 21507 21508 elsif Is_Elementary_Type (Typ) then 21509 return False; 21510 21511 -- Generally, indefinite subtypes require a transient scope, since the 21512 -- back end cannot generate temporaries, since this is not a valid type 21513 -- for declaring an object. It might be possible to relax this in the 21514 -- future, e.g. by declaring the maximum possible space for the type. 21515 21516 elsif not Is_Definite_Subtype (Typ) then 21517 return True; 21518 21519 -- Functions returning tagged types may dispatch on result so their 21520 -- returned value is allocated on the secondary stack. Controlled 21521 -- type temporaries need finalization. 21522 21523 elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then 21524 return True; 21525 21526 -- Record type 21527 21528 elsif Is_Record_Type (Typ) then 21529 declare 21530 Comp : Entity_Id; 21531 21532 begin 21533 Comp := First_Entity (Typ); 21534 while Present (Comp) loop 21535 if Ekind (Comp) = E_Component then 21536 21537 -- ???It's not clear we need a full recursive call to 21538 -- Old_Requires_Transient_Scope here. Note that the 21539 -- following can't happen. 21540 21541 pragma Assert (Is_Definite_Subtype (Etype (Comp))); 21542 pragma Assert (not Has_Controlled_Component (Etype (Comp))); 21543 21544 if Old_Requires_Transient_Scope (Etype (Comp)) then 21545 return True; 21546 end if; 21547 end if; 21548 21549 Next_Entity (Comp); 21550 end loop; 21551 end; 21552 21553 return False; 21554 21555 -- String literal types never require transient scope 21556 21557 elsif Ekind (Typ) = E_String_Literal_Subtype then 21558 return False; 21559 21560 -- Array type. Note that we already know that this is a constrained 21561 -- array, since unconstrained arrays will fail the indefinite test. 21562 21563 elsif Is_Array_Type (Typ) then 21564 21565 -- If component type requires a transient scope, the array does too 21566 21567 if Old_Requires_Transient_Scope (Component_Type (Typ)) then 21568 return True; 21569 21570 -- Otherwise, we only need a transient scope if the size depends on 21571 -- the value of one or more discriminants. 21572 21573 else 21574 return Size_Depends_On_Discriminant (Typ); 21575 end if; 21576 21577 -- All other cases do not require a transient scope 21578 21579 else 21580 pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ)); 21581 return False; 21582 end if; 21583 end Old_Requires_Transient_Scope; 21584 21585 --------------------------------- 21586 -- Original_Aspect_Pragma_Name -- 21587 --------------------------------- 21588 21589 function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id is 21590 Item : Node_Id; 21591 Item_Nam : Name_Id; 21592 21593 begin 21594 pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma)); 21595 21596 Item := N; 21597 21598 -- The pragma was generated to emulate an aspect, use the original 21599 -- aspect specification. 21600 21601 if Nkind (Item) = N_Pragma and then From_Aspect_Specification (Item) then 21602 Item := Corresponding_Aspect (Item); 21603 end if; 21604 21605 -- Retrieve the name of the aspect/pragma. Note that Pre, Pre_Class, 21606 -- Post and Post_Class rewrite their pragma identifier to preserve the 21607 -- original name. 21608 -- ??? this is kludgey 21609 21610 if Nkind (Item) = N_Pragma then 21611 Item_Nam := Chars (Original_Node (Pragma_Identifier (Item))); 21612 21613 else 21614 pragma Assert (Nkind (Item) = N_Aspect_Specification); 21615 Item_Nam := Chars (Identifier (Item)); 21616 end if; 21617 21618 -- Deal with 'Class by converting the name to its _XXX form 21619 21620 if Class_Present (Item) then 21621 if Item_Nam = Name_Invariant then 21622 Item_Nam := Name_uInvariant; 21623 21624 elsif Item_Nam = Name_Post then 21625 Item_Nam := Name_uPost; 21626 21627 elsif Item_Nam = Name_Pre then 21628 Item_Nam := Name_uPre; 21629 21630 elsif Nam_In (Item_Nam, Name_Type_Invariant, 21631 Name_Type_Invariant_Class) 21632 then 21633 Item_Nam := Name_uType_Invariant; 21634 21635 -- Nothing to do for other cases (e.g. a Check that derived from 21636 -- Pre_Class and has the flag set). Also we do nothing if the name 21637 -- is already in special _xxx form. 21638 21639 end if; 21640 end if; 21641 21642 return Item_Nam; 21643 end Original_Aspect_Pragma_Name; 21644 21645 -------------------------------------- 21646 -- Original_Corresponding_Operation -- 21647 -------------------------------------- 21648 21649 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id 21650 is 21651 Typ : constant Entity_Id := Find_Dispatching_Type (S); 21652 21653 begin 21654 -- If S is an inherited primitive S2 the original corresponding 21655 -- operation of S is the original corresponding operation of S2 21656 21657 if Present (Alias (S)) 21658 and then Find_Dispatching_Type (Alias (S)) /= Typ 21659 then 21660 return Original_Corresponding_Operation (Alias (S)); 21661 21662 -- If S overrides an inherited subprogram S2 the original corresponding 21663 -- operation of S is the original corresponding operation of S2 21664 21665 elsif Present (Overridden_Operation (S)) then 21666 return Original_Corresponding_Operation (Overridden_Operation (S)); 21667 21668 -- otherwise it is S itself 21669 21670 else 21671 return S; 21672 end if; 21673 end Original_Corresponding_Operation; 21674 21675 ------------------- 21676 -- Output_Entity -- 21677 ------------------- 21678 21679 procedure Output_Entity (Id : Entity_Id) is 21680 Scop : Entity_Id; 21681 21682 begin 21683 Scop := Scope (Id); 21684 21685 -- The entity may lack a scope when it is in the process of being 21686 -- analyzed. Use the current scope as an approximation. 21687 21688 if No (Scop) then 21689 Scop := Current_Scope; 21690 end if; 21691 21692 Output_Name (Chars (Id), Scop); 21693 end Output_Entity; 21694 21695 ----------------- 21696 -- Output_Name -- 21697 ----------------- 21698 21699 procedure Output_Name (Nam : Name_Id; Scop : Entity_Id := Current_Scope) is 21700 begin 21701 Write_Str 21702 (Get_Name_String 21703 (Get_Qualified_Name 21704 (Nam => Nam, 21705 Suffix => No_Name, 21706 Scop => Scop))); 21707 Write_Eol; 21708 end Output_Name; 21709 21710 ---------------------- 21711 -- Policy_In_Effect -- 21712 ---------------------- 21713 21714 function Policy_In_Effect (Policy : Name_Id) return Name_Id is 21715 function Policy_In_List (List : Node_Id) return Name_Id; 21716 -- Determine the mode of a policy in a N_Pragma list 21717 21718 -------------------- 21719 -- Policy_In_List -- 21720 -------------------- 21721 21722 function Policy_In_List (List : Node_Id) return Name_Id is 21723 Arg1 : Node_Id; 21724 Arg2 : Node_Id; 21725 Prag : Node_Id; 21726 21727 begin 21728 Prag := List; 21729 while Present (Prag) loop 21730 Arg1 := First (Pragma_Argument_Associations (Prag)); 21731 Arg2 := Next (Arg1); 21732 21733 Arg1 := Get_Pragma_Arg (Arg1); 21734 Arg2 := Get_Pragma_Arg (Arg2); 21735 21736 -- The current Check_Policy pragma matches the requested policy or 21737 -- appears in the single argument form (Assertion, policy_id). 21738 21739 if Nam_In (Chars (Arg1), Name_Assertion, Policy) then 21740 return Chars (Arg2); 21741 end if; 21742 21743 Prag := Next_Pragma (Prag); 21744 end loop; 21745 21746 return No_Name; 21747 end Policy_In_List; 21748 21749 -- Local variables 21750 21751 Kind : Name_Id; 21752 21753 -- Start of processing for Policy_In_Effect 21754 21755 begin 21756 if not Is_Valid_Assertion_Kind (Policy) then 21757 raise Program_Error; 21758 end if; 21759 21760 -- Inspect all policy pragmas that appear within scopes (if any) 21761 21762 Kind := Policy_In_List (Check_Policy_List); 21763 21764 -- Inspect all configuration policy pragmas (if any) 21765 21766 if Kind = No_Name then 21767 Kind := Policy_In_List (Check_Policy_List_Config); 21768 end if; 21769 21770 -- The context lacks policy pragmas, determine the mode based on whether 21771 -- assertions are enabled at the configuration level. This ensures that 21772 -- the policy is preserved when analyzing generics. 21773 21774 if Kind = No_Name then 21775 if Assertions_Enabled_Config then 21776 Kind := Name_Check; 21777 else 21778 Kind := Name_Ignore; 21779 end if; 21780 end if; 21781 21782 return Kind; 21783 end Policy_In_Effect; 21784 21785 ---------------------------------- 21786 -- Predicate_Tests_On_Arguments -- 21787 ---------------------------------- 21788 21789 function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean is 21790 begin 21791 -- Always test predicates on indirect call 21792 21793 if Ekind (Subp) = E_Subprogram_Type then 21794 return True; 21795 21796 -- Do not test predicates on call to generated default Finalize, since 21797 -- we are not interested in whether something we are finalizing (and 21798 -- typically destroying) satisfies its predicates. 21799 21800 elsif Chars (Subp) = Name_Finalize 21801 and then not Comes_From_Source (Subp) 21802 then 21803 return False; 21804 21805 -- Do not test predicates on any internally generated routines 21806 21807 elsif Is_Internal_Name (Chars (Subp)) then 21808 return False; 21809 21810 -- Do not test predicates on call to Init_Proc, since if needed the 21811 -- predicate test will occur at some other point. 21812 21813 elsif Is_Init_Proc (Subp) then 21814 return False; 21815 21816 -- Do not test predicates on call to predicate function, since this 21817 -- would cause infinite recursion. 21818 21819 elsif Ekind (Subp) = E_Function 21820 and then (Is_Predicate_Function (Subp) 21821 or else 21822 Is_Predicate_Function_M (Subp)) 21823 then 21824 return False; 21825 21826 -- For now, no other exceptions 21827 21828 else 21829 return True; 21830 end if; 21831 end Predicate_Tests_On_Arguments; 21832 21833 ----------------------- 21834 -- Private_Component -- 21835 ----------------------- 21836 21837 function Private_Component (Type_Id : Entity_Id) return Entity_Id is 21838 Ancestor : constant Entity_Id := Base_Type (Type_Id); 21839 21840 function Trace_Components 21841 (T : Entity_Id; 21842 Check : Boolean) return Entity_Id; 21843 -- Recursive function that does the work, and checks against circular 21844 -- definition for each subcomponent type. 21845 21846 ---------------------- 21847 -- Trace_Components -- 21848 ---------------------- 21849 21850 function Trace_Components 21851 (T : Entity_Id; 21852 Check : Boolean) return Entity_Id 21853 is 21854 Btype : constant Entity_Id := Base_Type (T); 21855 Component : Entity_Id; 21856 P : Entity_Id; 21857 Candidate : Entity_Id := Empty; 21858 21859 begin 21860 if Check and then Btype = Ancestor then 21861 Error_Msg_N ("circular type definition", Type_Id); 21862 return Any_Type; 21863 end if; 21864 21865 if Is_Private_Type (Btype) and then not Is_Generic_Type (Btype) then 21866 if Present (Full_View (Btype)) 21867 and then Is_Record_Type (Full_View (Btype)) 21868 and then not Is_Frozen (Btype) 21869 then 21870 -- To indicate that the ancestor depends on a private type, the 21871 -- current Btype is sufficient. However, to check for circular 21872 -- definition we must recurse on the full view. 21873 21874 Candidate := Trace_Components (Full_View (Btype), True); 21875 21876 if Candidate = Any_Type then 21877 return Any_Type; 21878 else 21879 return Btype; 21880 end if; 21881 21882 else 21883 return Btype; 21884 end if; 21885 21886 elsif Is_Array_Type (Btype) then 21887 return Trace_Components (Component_Type (Btype), True); 21888 21889 elsif Is_Record_Type (Btype) then 21890 Component := First_Entity (Btype); 21891 while Present (Component) 21892 and then Comes_From_Source (Component) 21893 loop 21894 -- Skip anonymous types generated by constrained components 21895 21896 if not Is_Type (Component) then 21897 P := Trace_Components (Etype (Component), True); 21898 21899 if Present (P) then 21900 if P = Any_Type then 21901 return P; 21902 else 21903 Candidate := P; 21904 end if; 21905 end if; 21906 end if; 21907 21908 Next_Entity (Component); 21909 end loop; 21910 21911 return Candidate; 21912 21913 else 21914 return Empty; 21915 end if; 21916 end Trace_Components; 21917 21918 -- Start of processing for Private_Component 21919 21920 begin 21921 return Trace_Components (Type_Id, False); 21922 end Private_Component; 21923 21924 --------------------------- 21925 -- Primitive_Names_Match -- 21926 --------------------------- 21927 21928 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is 21929 function Non_Internal_Name (E : Entity_Id) return Name_Id; 21930 -- Given an internal name, returns the corresponding non-internal name 21931 21932 ------------------------ 21933 -- Non_Internal_Name -- 21934 ------------------------ 21935 21936 function Non_Internal_Name (E : Entity_Id) return Name_Id is 21937 begin 21938 Get_Name_String (Chars (E)); 21939 Name_Len := Name_Len - 1; 21940 return Name_Find; 21941 end Non_Internal_Name; 21942 21943 -- Start of processing for Primitive_Names_Match 21944 21945 begin 21946 pragma Assert (Present (E1) and then Present (E2)); 21947 21948 return Chars (E1) = Chars (E2) 21949 or else 21950 (not Is_Internal_Name (Chars (E1)) 21951 and then Is_Internal_Name (Chars (E2)) 21952 and then Non_Internal_Name (E2) = Chars (E1)) 21953 or else 21954 (not Is_Internal_Name (Chars (E2)) 21955 and then Is_Internal_Name (Chars (E1)) 21956 and then Non_Internal_Name (E1) = Chars (E2)) 21957 or else 21958 (Is_Predefined_Dispatching_Operation (E1) 21959 and then Is_Predefined_Dispatching_Operation (E2) 21960 and then Same_TSS (E1, E2)) 21961 or else 21962 (Is_Init_Proc (E1) and then Is_Init_Proc (E2)); 21963 end Primitive_Names_Match; 21964 21965 ----------------------- 21966 -- Process_End_Label -- 21967 ----------------------- 21968 21969 procedure Process_End_Label 21970 (N : Node_Id; 21971 Typ : Character; 21972 Ent : Entity_Id) 21973 is 21974 Loc : Source_Ptr; 21975 Nam : Node_Id; 21976 Scop : Entity_Id; 21977 21978 Label_Ref : Boolean; 21979 -- Set True if reference to end label itself is required 21980 21981 Endl : Node_Id; 21982 -- Gets set to the operator symbol or identifier that references the 21983 -- entity Ent. For the child unit case, this is the identifier from the 21984 -- designator. For other cases, this is simply Endl. 21985 21986 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id); 21987 -- N is an identifier node that appears as a parent unit reference in 21988 -- the case where Ent is a child unit. This procedure generates an 21989 -- appropriate cross-reference entry. E is the corresponding entity. 21990 21991 ------------------------- 21992 -- Generate_Parent_Ref -- 21993 ------------------------- 21994 21995 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is 21996 begin 21997 -- If names do not match, something weird, skip reference 21998 21999 if Chars (E) = Chars (N) then 22000 22001 -- Generate the reference. We do NOT consider this as a reference 22002 -- for unreferenced symbol purposes. 22003 22004 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True); 22005 22006 if Style_Check then 22007 Style.Check_Identifier (N, E); 22008 end if; 22009 end if; 22010 end Generate_Parent_Ref; 22011 22012 -- Start of processing for Process_End_Label 22013 22014 begin 22015 -- If no node, ignore. This happens in some error situations, and 22016 -- also for some internally generated structures where no end label 22017 -- references are required in any case. 22018 22019 if No (N) then 22020 return; 22021 end if; 22022 22023 -- Nothing to do if no End_Label, happens for internally generated 22024 -- constructs where we don't want an end label reference anyway. Also 22025 -- nothing to do if Endl is a string literal, which means there was 22026 -- some prior error (bad operator symbol) 22027 22028 Endl := End_Label (N); 22029 22030 if No (Endl) or else Nkind (Endl) = N_String_Literal then 22031 return; 22032 end if; 22033 22034 -- Reference node is not in extended main source unit 22035 22036 if not In_Extended_Main_Source_Unit (N) then 22037 22038 -- Generally we do not collect references except for the extended 22039 -- main source unit. The one exception is the 'e' entry for a 22040 -- package spec, where it is useful for a client to have the 22041 -- ending information to define scopes. 22042 22043 if Typ /= 'e' then 22044 return; 22045 22046 else 22047 Label_Ref := False; 22048 22049 -- For this case, we can ignore any parent references, but we 22050 -- need the package name itself for the 'e' entry. 22051 22052 if Nkind (Endl) = N_Designator then 22053 Endl := Identifier (Endl); 22054 end if; 22055 end if; 22056 22057 -- Reference is in extended main source unit 22058 22059 else 22060 Label_Ref := True; 22061 22062 -- For designator, generate references for the parent entries 22063 22064 if Nkind (Endl) = N_Designator then 22065 22066 -- Generate references for the prefix if the END line comes from 22067 -- source (otherwise we do not need these references) We climb the 22068 -- scope stack to find the expected entities. 22069 22070 if Comes_From_Source (Endl) then 22071 Nam := Name (Endl); 22072 Scop := Current_Scope; 22073 while Nkind (Nam) = N_Selected_Component loop 22074 Scop := Scope (Scop); 22075 exit when No (Scop); 22076 Generate_Parent_Ref (Selector_Name (Nam), Scop); 22077 Nam := Prefix (Nam); 22078 end loop; 22079 22080 if Present (Scop) then 22081 Generate_Parent_Ref (Nam, Scope (Scop)); 22082 end if; 22083 end if; 22084 22085 Endl := Identifier (Endl); 22086 end if; 22087 end if; 22088 22089 -- If the end label is not for the given entity, then either we have 22090 -- some previous error, or this is a generic instantiation for which 22091 -- we do not need to make a cross-reference in this case anyway. In 22092 -- either case we simply ignore the call. 22093 22094 if Chars (Ent) /= Chars (Endl) then 22095 return; 22096 end if; 22097 22098 -- If label was really there, then generate a normal reference and then 22099 -- adjust the location in the end label to point past the name (which 22100 -- should almost always be the semicolon). 22101 22102 Loc := Sloc (Endl); 22103 22104 if Comes_From_Source (Endl) then 22105 22106 -- If a label reference is required, then do the style check and 22107 -- generate an l-type cross-reference entry for the label 22108 22109 if Label_Ref then 22110 if Style_Check then 22111 Style.Check_Identifier (Endl, Ent); 22112 end if; 22113 22114 Generate_Reference (Ent, Endl, 'l', Set_Ref => False); 22115 end if; 22116 22117 -- Set the location to point past the label (normally this will 22118 -- mean the semicolon immediately following the label). This is 22119 -- done for the sake of the 'e' or 't' entry generated below. 22120 22121 Get_Decoded_Name_String (Chars (Endl)); 22122 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len)); 22123 22124 else 22125 -- In SPARK mode, no missing label is allowed for packages and 22126 -- subprogram bodies. Detect those cases by testing whether 22127 -- Process_End_Label was called for a body (Typ = 't') or a package. 22128 22129 if Restriction_Check_Required (SPARK_05) 22130 and then (Typ = 't' or else Ekind (Ent) = E_Package) 22131 then 22132 Error_Msg_Node_1 := Endl; 22133 Check_SPARK_05_Restriction 22134 ("`END &` required", Endl, Force => True); 22135 end if; 22136 end if; 22137 22138 -- Now generate the e/t reference 22139 22140 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True); 22141 22142 -- Restore Sloc, in case modified above, since we have an identifier 22143 -- and the normal Sloc should be left set in the tree. 22144 22145 Set_Sloc (Endl, Loc); 22146 end Process_End_Label; 22147 22148 -------------------------------- 22149 -- Propagate_Concurrent_Flags -- 22150 -------------------------------- 22151 22152 procedure Propagate_Concurrent_Flags 22153 (Typ : Entity_Id; 22154 Comp_Typ : Entity_Id) 22155 is 22156 begin 22157 if Has_Task (Comp_Typ) then 22158 Set_Has_Task (Typ); 22159 end if; 22160 22161 if Has_Protected (Comp_Typ) then 22162 Set_Has_Protected (Typ); 22163 end if; 22164 22165 if Has_Timing_Event (Comp_Typ) then 22166 Set_Has_Timing_Event (Typ); 22167 end if; 22168 end Propagate_Concurrent_Flags; 22169 22170 ------------------------------ 22171 -- Propagate_DIC_Attributes -- 22172 ------------------------------ 22173 22174 procedure Propagate_DIC_Attributes 22175 (Typ : Entity_Id; 22176 From_Typ : Entity_Id) 22177 is 22178 DIC_Proc : Entity_Id; 22179 22180 begin 22181 if Present (Typ) and then Present (From_Typ) then 22182 pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ)); 22183 22184 -- Nothing to do if both the source and the destination denote the 22185 -- same type. 22186 22187 if From_Typ = Typ then 22188 return; 22189 end if; 22190 22191 DIC_Proc := DIC_Procedure (From_Typ); 22192 22193 -- The setting of the attributes is intentionally conservative. This 22194 -- prevents accidental clobbering of enabled attributes. 22195 22196 if Has_Inherited_DIC (From_Typ) 22197 and then not Has_Inherited_DIC (Typ) 22198 then 22199 Set_Has_Inherited_DIC (Typ); 22200 end if; 22201 22202 if Has_Own_DIC (From_Typ) and then not Has_Own_DIC (Typ) then 22203 Set_Has_Own_DIC (Typ); 22204 end if; 22205 22206 if Present (DIC_Proc) and then No (DIC_Procedure (Typ)) then 22207 Set_DIC_Procedure (Typ, DIC_Proc); 22208 end if; 22209 end if; 22210 end Propagate_DIC_Attributes; 22211 22212 ------------------------------------ 22213 -- Propagate_Invariant_Attributes -- 22214 ------------------------------------ 22215 22216 procedure Propagate_Invariant_Attributes 22217 (Typ : Entity_Id; 22218 From_Typ : Entity_Id) 22219 is 22220 Full_IP : Entity_Id; 22221 Part_IP : Entity_Id; 22222 22223 begin 22224 if Present (Typ) and then Present (From_Typ) then 22225 pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ)); 22226 22227 -- Nothing to do if both the source and the destination denote the 22228 -- same type. 22229 22230 if From_Typ = Typ then 22231 return; 22232 end if; 22233 22234 Full_IP := Invariant_Procedure (From_Typ); 22235 Part_IP := Partial_Invariant_Procedure (From_Typ); 22236 22237 -- The setting of the attributes is intentionally conservative. This 22238 -- prevents accidental clobbering of enabled attributes. 22239 22240 if Has_Inheritable_Invariants (From_Typ) 22241 and then not Has_Inheritable_Invariants (Typ) 22242 then 22243 Set_Has_Inheritable_Invariants (Typ, True); 22244 end if; 22245 22246 if Has_Inherited_Invariants (From_Typ) 22247 and then not Has_Inherited_Invariants (Typ) 22248 then 22249 Set_Has_Inherited_Invariants (Typ, True); 22250 end if; 22251 22252 if Has_Own_Invariants (From_Typ) 22253 and then not Has_Own_Invariants (Typ) 22254 then 22255 Set_Has_Own_Invariants (Typ, True); 22256 end if; 22257 22258 if Present (Full_IP) and then No (Invariant_Procedure (Typ)) then 22259 Set_Invariant_Procedure (Typ, Full_IP); 22260 end if; 22261 22262 if Present (Part_IP) and then No (Partial_Invariant_Procedure (Typ)) 22263 then 22264 Set_Partial_Invariant_Procedure (Typ, Part_IP); 22265 end if; 22266 end if; 22267 end Propagate_Invariant_Attributes; 22268 22269 --------------------------------------- 22270 -- Record_Possible_Part_Of_Reference -- 22271 --------------------------------------- 22272 22273 procedure Record_Possible_Part_Of_Reference 22274 (Var_Id : Entity_Id; 22275 Ref : Node_Id) 22276 is 22277 Encap : constant Entity_Id := Encapsulating_State (Var_Id); 22278 Refs : Elist_Id; 22279 22280 begin 22281 -- The variable is a constituent of a single protected/task type. Such 22282 -- a variable acts as a component of the type and must appear within a 22283 -- specific region (SPARK RM 9(3)). Instead of recording the reference, 22284 -- verify its legality now. 22285 22286 if Present (Encap) and then Is_Single_Concurrent_Object (Encap) then 22287 Check_Part_Of_Reference (Var_Id, Ref); 22288 22289 -- The variable is subject to pragma Part_Of and may eventually become a 22290 -- constituent of a single protected/task type. Record the reference to 22291 -- verify its placement when the contract of the variable is analyzed. 22292 22293 elsif Present (Get_Pragma (Var_Id, Pragma_Part_Of)) then 22294 Refs := Part_Of_References (Var_Id); 22295 22296 if No (Refs) then 22297 Refs := New_Elmt_List; 22298 Set_Part_Of_References (Var_Id, Refs); 22299 end if; 22300 22301 Append_Elmt (Ref, Refs); 22302 end if; 22303 end Record_Possible_Part_Of_Reference; 22304 22305 ---------------- 22306 -- Referenced -- 22307 ---------------- 22308 22309 function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is 22310 Seen : Boolean := False; 22311 22312 function Is_Reference (N : Node_Id) return Traverse_Result; 22313 -- Determine whether node N denotes a reference to Id. If this is the 22314 -- case, set global flag Seen to True and stop the traversal. 22315 22316 ------------------ 22317 -- Is_Reference -- 22318 ------------------ 22319 22320 function Is_Reference (N : Node_Id) return Traverse_Result is 22321 begin 22322 if Is_Entity_Name (N) 22323 and then Present (Entity (N)) 22324 and then Entity (N) = Id 22325 then 22326 Seen := True; 22327 return Abandon; 22328 else 22329 return OK; 22330 end if; 22331 end Is_Reference; 22332 22333 procedure Inspect_Expression is new Traverse_Proc (Is_Reference); 22334 22335 -- Start of processing for Referenced 22336 22337 begin 22338 Inspect_Expression (Expr); 22339 return Seen; 22340 end Referenced; 22341 22342 ------------------------------------ 22343 -- References_Generic_Formal_Type -- 22344 ------------------------------------ 22345 22346 function References_Generic_Formal_Type (N : Node_Id) return Boolean is 22347 22348 function Process (N : Node_Id) return Traverse_Result; 22349 -- Process one node in search for generic formal type 22350 22351 ------------- 22352 -- Process -- 22353 ------------- 22354 22355 function Process (N : Node_Id) return Traverse_Result is 22356 begin 22357 if Nkind (N) in N_Has_Entity then 22358 declare 22359 E : constant Entity_Id := Entity (N); 22360 begin 22361 if Present (E) then 22362 if Is_Generic_Type (E) then 22363 return Abandon; 22364 elsif Present (Etype (E)) 22365 and then Is_Generic_Type (Etype (E)) 22366 then 22367 return Abandon; 22368 end if; 22369 end if; 22370 end; 22371 end if; 22372 22373 return Atree.OK; 22374 end Process; 22375 22376 function Traverse is new Traverse_Func (Process); 22377 -- Traverse tree to look for generic type 22378 22379 begin 22380 if Inside_A_Generic then 22381 return Traverse (N) = Abandon; 22382 else 22383 return False; 22384 end if; 22385 end References_Generic_Formal_Type; 22386 22387 ------------------- 22388 -- Remove_Entity -- 22389 ------------------- 22390 22391 procedure Remove_Entity (Id : Entity_Id) is 22392 Scop : constant Entity_Id := Scope (Id); 22393 Prev_Id : Entity_Id; 22394 22395 begin 22396 -- Remove the entity from the homonym chain. When the entity is the 22397 -- head of the chain, associate the entry in the name table with its 22398 -- homonym effectively making it the new head of the chain. 22399 22400 if Current_Entity (Id) = Id then 22401 Set_Name_Entity_Id (Chars (Id), Homonym (Id)); 22402 22403 -- Otherwise link the previous and next homonyms 22404 22405 else 22406 Prev_Id := Current_Entity (Id); 22407 if Present (Prev_Id) then 22408 while Present (Prev_Id) and then Homonym (Prev_Id) /= Id loop 22409 Prev_Id := Homonym (Prev_Id); 22410 end loop; 22411 22412 Set_Homonym (Prev_Id, Homonym (Id)); 22413 end if; 22414 end if; 22415 22416 -- Remove the entity from the scope entity chain. When the entity is 22417 -- the head of the chain, set the next entity as the new head of the 22418 -- chain. 22419 22420 if First_Entity (Scop) = Id then 22421 Prev_Id := Empty; 22422 Set_First_Entity (Scop, Next_Entity (Id)); 22423 22424 -- Otherwise the entity is either in the middle of the chain or it acts 22425 -- as its tail. Traverse and link the previous and next entities. 22426 22427 else 22428 Prev_Id := First_Entity (Scop); 22429 while Present (Prev_Id) and then Next_Entity (Prev_Id) /= Id loop 22430 Next_Entity (Prev_Id); 22431 end loop; 22432 22433 if Present (Prev_Id) then 22434 Set_Next_Entity (Prev_Id, Next_Entity (Id)); 22435 end if; 22436 end if; 22437 22438 -- Handle the case where the entity acts as the tail of the scope entity 22439 -- chain. 22440 22441 if Last_Entity (Scop) = Id then 22442 Set_Last_Entity (Scop, Prev_Id); 22443 end if; 22444 end Remove_Entity; 22445 22446 -------------------- 22447 -- Remove_Homonym -- 22448 -------------------- 22449 22450 procedure Remove_Homonym (E : Entity_Id) is 22451 Prev : Entity_Id := Empty; 22452 H : Entity_Id; 22453 22454 begin 22455 if E = Current_Entity (E) then 22456 if Present (Homonym (E)) then 22457 Set_Current_Entity (Homonym (E)); 22458 else 22459 Set_Name_Entity_Id (Chars (E), Empty); 22460 end if; 22461 22462 else 22463 H := Current_Entity (E); 22464 while Present (H) and then H /= E loop 22465 Prev := H; 22466 H := Homonym (H); 22467 end loop; 22468 22469 -- If E is not on the homonym chain, nothing to do 22470 22471 if Present (H) then 22472 Set_Homonym (Prev, Homonym (E)); 22473 end if; 22474 end if; 22475 end Remove_Homonym; 22476 22477 ------------------------------ 22478 -- Remove_Overloaded_Entity -- 22479 ------------------------------ 22480 22481 procedure Remove_Overloaded_Entity (Id : Entity_Id) is 22482 procedure Remove_Primitive_Of (Typ : Entity_Id); 22483 -- Remove primitive subprogram Id from the list of primitives that 22484 -- belong to type Typ. 22485 22486 ------------------------- 22487 -- Remove_Primitive_Of -- 22488 ------------------------- 22489 22490 procedure Remove_Primitive_Of (Typ : Entity_Id) is 22491 Prims : Elist_Id; 22492 22493 begin 22494 if Is_Tagged_Type (Typ) then 22495 Prims := Direct_Primitive_Operations (Typ); 22496 22497 if Present (Prims) then 22498 Remove (Prims, Id); 22499 end if; 22500 end if; 22501 end Remove_Primitive_Of; 22502 22503 -- Local variables 22504 22505 Formal : Entity_Id; 22506 22507 -- Start of processing for Remove_Overloaded_Entity 22508 22509 begin 22510 -- Remove the entity from both the homonym and scope chains 22511 22512 Remove_Entity (Id); 22513 22514 -- The entity denotes a primitive subprogram. Remove it from the list of 22515 -- primitives of the associated controlling type. 22516 22517 if Ekind_In (Id, E_Function, E_Procedure) and then Is_Primitive (Id) then 22518 Formal := First_Formal (Id); 22519 while Present (Formal) loop 22520 if Is_Controlling_Formal (Formal) then 22521 Remove_Primitive_Of (Etype (Formal)); 22522 exit; 22523 end if; 22524 22525 Next_Formal (Formal); 22526 end loop; 22527 22528 if Ekind (Id) = E_Function and then Has_Controlling_Result (Id) then 22529 Remove_Primitive_Of (Etype (Id)); 22530 end if; 22531 end if; 22532 end Remove_Overloaded_Entity; 22533 22534 --------------------- 22535 -- Rep_To_Pos_Flag -- 22536 --------------------- 22537 22538 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is 22539 begin 22540 return New_Occurrence_Of 22541 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc); 22542 end Rep_To_Pos_Flag; 22543 22544 -------------------- 22545 -- Require_Entity -- 22546 -------------------- 22547 22548 procedure Require_Entity (N : Node_Id) is 22549 begin 22550 if Is_Entity_Name (N) and then No (Entity (N)) then 22551 if Total_Errors_Detected /= 0 then 22552 Set_Entity (N, Any_Id); 22553 else 22554 raise Program_Error; 22555 end if; 22556 end if; 22557 end Require_Entity; 22558 22559 ------------------------------ 22560 -- Requires_Transient_Scope -- 22561 ------------------------------ 22562 22563 -- A transient scope is required when variable-sized temporaries are 22564 -- allocated on the secondary stack, or when finalization actions must be 22565 -- generated before the next instruction. 22566 22567 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is 22568 Old_Result : constant Boolean := Old_Requires_Transient_Scope (Id); 22569 22570 begin 22571 if Debug_Flag_QQ then 22572 return Old_Result; 22573 end if; 22574 22575 declare 22576 New_Result : constant Boolean := New_Requires_Transient_Scope (Id); 22577 22578 begin 22579 -- Assert that we're not putting things on the secondary stack if we 22580 -- didn't before; we are trying to AVOID secondary stack when 22581 -- possible. 22582 22583 if not Old_Result then 22584 pragma Assert (not New_Result); 22585 null; 22586 end if; 22587 22588 if New_Result /= Old_Result then 22589 Results_Differ (Id, Old_Result, New_Result); 22590 end if; 22591 22592 return New_Result; 22593 end; 22594 end Requires_Transient_Scope; 22595 22596 -------------------- 22597 -- Results_Differ -- 22598 -------------------- 22599 22600 procedure Results_Differ 22601 (Id : Entity_Id; 22602 Old_Val : Boolean; 22603 New_Val : Boolean) 22604 is 22605 begin 22606 if False then -- False to disable; True for debugging 22607 Treepr.Print_Tree_Node (Id); 22608 22609 if Old_Val = New_Val then 22610 raise Program_Error; 22611 end if; 22612 end if; 22613 end Results_Differ; 22614 22615 -------------------------- 22616 -- Reset_Analyzed_Flags -- 22617 -------------------------- 22618 22619 procedure Reset_Analyzed_Flags (N : Node_Id) is 22620 function Clear_Analyzed (N : Node_Id) return Traverse_Result; 22621 -- Function used to reset Analyzed flags in tree. Note that we do 22622 -- not reset Analyzed flags in entities, since there is no need to 22623 -- reanalyze entities, and indeed, it is wrong to do so, since it 22624 -- can result in generating auxiliary stuff more than once. 22625 22626 -------------------- 22627 -- Clear_Analyzed -- 22628 -------------------- 22629 22630 function Clear_Analyzed (N : Node_Id) return Traverse_Result is 22631 begin 22632 if Nkind (N) not in N_Entity then 22633 Set_Analyzed (N, False); 22634 end if; 22635 22636 return OK; 22637 end Clear_Analyzed; 22638 22639 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed); 22640 22641 -- Start of processing for Reset_Analyzed_Flags 22642 22643 begin 22644 Reset_Analyzed (N); 22645 end Reset_Analyzed_Flags; 22646 22647 ------------------------ 22648 -- Restore_SPARK_Mode -- 22649 ------------------------ 22650 22651 procedure Restore_SPARK_Mode 22652 (Mode : SPARK_Mode_Type; 22653 Prag : Node_Id) 22654 is 22655 begin 22656 SPARK_Mode := Mode; 22657 SPARK_Mode_Pragma := Prag; 22658 end Restore_SPARK_Mode; 22659 22660 -------------------------------- 22661 -- Returns_Unconstrained_Type -- 22662 -------------------------------- 22663 22664 function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is 22665 begin 22666 return Ekind (Subp) = E_Function 22667 and then not Is_Scalar_Type (Etype (Subp)) 22668 and then not Is_Access_Type (Etype (Subp)) 22669 and then not Is_Constrained (Etype (Subp)); 22670 end Returns_Unconstrained_Type; 22671 22672 ---------------------------- 22673 -- Root_Type_Of_Full_View -- 22674 ---------------------------- 22675 22676 function Root_Type_Of_Full_View (T : Entity_Id) return Entity_Id is 22677 Rtyp : constant Entity_Id := Root_Type (T); 22678 22679 begin 22680 -- The root type of the full view may itself be a private type. Keep 22681 -- looking for the ultimate derivation parent. 22682 22683 if Is_Private_Type (Rtyp) and then Present (Full_View (Rtyp)) then 22684 return Root_Type_Of_Full_View (Full_View (Rtyp)); 22685 else 22686 return Rtyp; 22687 end if; 22688 end Root_Type_Of_Full_View; 22689 22690 --------------------------- 22691 -- Safe_To_Capture_Value -- 22692 --------------------------- 22693 22694 function Safe_To_Capture_Value 22695 (N : Node_Id; 22696 Ent : Entity_Id; 22697 Cond : Boolean := False) return Boolean 22698 is 22699 begin 22700 -- The only entities for which we track constant values are variables 22701 -- which are not renamings, constants, out parameters, and in out 22702 -- parameters, so check if we have this case. 22703 22704 -- Note: it may seem odd to track constant values for constants, but in 22705 -- fact this routine is used for other purposes than simply capturing 22706 -- the value. In particular, the setting of Known[_Non]_Null. 22707 22708 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent))) 22709 or else 22710 Ekind_In (Ent, E_Constant, E_Out_Parameter, E_In_Out_Parameter) 22711 then 22712 null; 22713 22714 -- For conditionals, we also allow loop parameters and all formals, 22715 -- including in parameters. 22716 22717 elsif Cond and then Ekind_In (Ent, E_Loop_Parameter, E_In_Parameter) then 22718 null; 22719 22720 -- For all other cases, not just unsafe, but impossible to capture 22721 -- Current_Value, since the above are the only entities which have 22722 -- Current_Value fields. 22723 22724 else 22725 return False; 22726 end if; 22727 22728 -- Skip if volatile or aliased, since funny things might be going on in 22729 -- these cases which we cannot necessarily track. Also skip any variable 22730 -- for which an address clause is given, or whose address is taken. Also 22731 -- never capture value of library level variables (an attempt to do so 22732 -- can occur in the case of package elaboration code). 22733 22734 if Treat_As_Volatile (Ent) 22735 or else Is_Aliased (Ent) 22736 or else Present (Address_Clause (Ent)) 22737 or else Address_Taken (Ent) 22738 or else (Is_Library_Level_Entity (Ent) 22739 and then Ekind (Ent) = E_Variable) 22740 then 22741 return False; 22742 end if; 22743 22744 -- OK, all above conditions are met. We also require that the scope of 22745 -- the reference be the same as the scope of the entity, not counting 22746 -- packages and blocks and loops. 22747 22748 declare 22749 E_Scope : constant Entity_Id := Scope (Ent); 22750 R_Scope : Entity_Id; 22751 22752 begin 22753 R_Scope := Current_Scope; 22754 while R_Scope /= Standard_Standard loop 22755 exit when R_Scope = E_Scope; 22756 22757 if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then 22758 return False; 22759 else 22760 R_Scope := Scope (R_Scope); 22761 end if; 22762 end loop; 22763 end; 22764 22765 -- We also require that the reference does not appear in a context 22766 -- where it is not sure to be executed (i.e. a conditional context 22767 -- or an exception handler). We skip this if Cond is True, since the 22768 -- capturing of values from conditional tests handles this ok. 22769 22770 if Cond then 22771 return True; 22772 end if; 22773 22774 declare 22775 Desc : Node_Id; 22776 P : Node_Id; 22777 22778 begin 22779 Desc := N; 22780 22781 -- Seems dubious that case expressions are not handled here ??? 22782 22783 P := Parent (N); 22784 while Present (P) loop 22785 if Nkind (P) = N_If_Statement 22786 or else Nkind (P) = N_Case_Statement 22787 or else (Nkind (P) in N_Short_Circuit 22788 and then Desc = Right_Opnd (P)) 22789 or else (Nkind (P) = N_If_Expression 22790 and then Desc /= First (Expressions (P))) 22791 or else Nkind (P) = N_Exception_Handler 22792 or else Nkind (P) = N_Selective_Accept 22793 or else Nkind (P) = N_Conditional_Entry_Call 22794 or else Nkind (P) = N_Timed_Entry_Call 22795 or else Nkind (P) = N_Asynchronous_Select 22796 then 22797 return False; 22798 22799 else 22800 Desc := P; 22801 P := Parent (P); 22802 22803 -- A special Ada 2012 case: the original node may be part 22804 -- of the else_actions of a conditional expression, in which 22805 -- case it might not have been expanded yet, and appears in 22806 -- a non-syntactic list of actions. In that case it is clearly 22807 -- not safe to save a value. 22808 22809 if No (P) 22810 and then Is_List_Member (Desc) 22811 and then No (Parent (List_Containing (Desc))) 22812 then 22813 return False; 22814 end if; 22815 end if; 22816 end loop; 22817 end; 22818 22819 -- OK, looks safe to set value 22820 22821 return True; 22822 end Safe_To_Capture_Value; 22823 22824 --------------- 22825 -- Same_Name -- 22826 --------------- 22827 22828 function Same_Name (N1, N2 : Node_Id) return Boolean is 22829 K1 : constant Node_Kind := Nkind (N1); 22830 K2 : constant Node_Kind := Nkind (N2); 22831 22832 begin 22833 if (K1 = N_Identifier or else K1 = N_Defining_Identifier) 22834 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier) 22835 then 22836 return Chars (N1) = Chars (N2); 22837 22838 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name) 22839 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name) 22840 then 22841 return Same_Name (Selector_Name (N1), Selector_Name (N2)) 22842 and then Same_Name (Prefix (N1), Prefix (N2)); 22843 22844 else 22845 return False; 22846 end if; 22847 end Same_Name; 22848 22849 ----------------- 22850 -- Same_Object -- 22851 ----------------- 22852 22853 function Same_Object (Node1, Node2 : Node_Id) return Boolean is 22854 N1 : constant Node_Id := Original_Node (Node1); 22855 N2 : constant Node_Id := Original_Node (Node2); 22856 -- We do the tests on original nodes, since we are most interested 22857 -- in the original source, not any expansion that got in the way. 22858 22859 K1 : constant Node_Kind := Nkind (N1); 22860 K2 : constant Node_Kind := Nkind (N2); 22861 22862 begin 22863 -- First case, both are entities with same entity 22864 22865 if K1 in N_Has_Entity and then K2 in N_Has_Entity then 22866 declare 22867 EN1 : constant Entity_Id := Entity (N1); 22868 EN2 : constant Entity_Id := Entity (N2); 22869 begin 22870 if Present (EN1) and then Present (EN2) 22871 and then (Ekind_In (EN1, E_Variable, E_Constant) 22872 or else Is_Formal (EN1)) 22873 and then EN1 = EN2 22874 then 22875 return True; 22876 end if; 22877 end; 22878 end if; 22879 22880 -- Second case, selected component with same selector, same record 22881 22882 if K1 = N_Selected_Component 22883 and then K2 = N_Selected_Component 22884 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2)) 22885 then 22886 return Same_Object (Prefix (N1), Prefix (N2)); 22887 22888 -- Third case, indexed component with same subscripts, same array 22889 22890 elsif K1 = N_Indexed_Component 22891 and then K2 = N_Indexed_Component 22892 and then Same_Object (Prefix (N1), Prefix (N2)) 22893 then 22894 declare 22895 E1, E2 : Node_Id; 22896 begin 22897 E1 := First (Expressions (N1)); 22898 E2 := First (Expressions (N2)); 22899 while Present (E1) loop 22900 if not Same_Value (E1, E2) then 22901 return False; 22902 else 22903 Next (E1); 22904 Next (E2); 22905 end if; 22906 end loop; 22907 22908 return True; 22909 end; 22910 22911 -- Fourth case, slice of same array with same bounds 22912 22913 elsif K1 = N_Slice 22914 and then K2 = N_Slice 22915 and then Nkind (Discrete_Range (N1)) = N_Range 22916 and then Nkind (Discrete_Range (N2)) = N_Range 22917 and then Same_Value (Low_Bound (Discrete_Range (N1)), 22918 Low_Bound (Discrete_Range (N2))) 22919 and then Same_Value (High_Bound (Discrete_Range (N1)), 22920 High_Bound (Discrete_Range (N2))) 22921 then 22922 return Same_Name (Prefix (N1), Prefix (N2)); 22923 22924 -- All other cases, not clearly the same object 22925 22926 else 22927 return False; 22928 end if; 22929 end Same_Object; 22930 22931 --------------- 22932 -- Same_Type -- 22933 --------------- 22934 22935 function Same_Type (T1, T2 : Entity_Id) return Boolean is 22936 begin 22937 if T1 = T2 then 22938 return True; 22939 22940 elsif not Is_Constrained (T1) 22941 and then not Is_Constrained (T2) 22942 and then Base_Type (T1) = Base_Type (T2) 22943 then 22944 return True; 22945 22946 -- For now don't bother with case of identical constraints, to be 22947 -- fiddled with later on perhaps (this is only used for optimization 22948 -- purposes, so it is not critical to do a best possible job) 22949 22950 else 22951 return False; 22952 end if; 22953 end Same_Type; 22954 22955 ---------------- 22956 -- Same_Value -- 22957 ---------------- 22958 22959 function Same_Value (Node1, Node2 : Node_Id) return Boolean is 22960 begin 22961 if Compile_Time_Known_Value (Node1) 22962 and then Compile_Time_Known_Value (Node2) 22963 then 22964 -- Handle properly compile-time expressions that are not 22965 -- scalar. 22966 22967 if Is_String_Type (Etype (Node1)) then 22968 return Expr_Value_S (Node1) = Expr_Value_S (Node2); 22969 22970 else 22971 return Expr_Value (Node1) = Expr_Value (Node2); 22972 end if; 22973 22974 elsif Same_Object (Node1, Node2) then 22975 return True; 22976 else 22977 return False; 22978 end if; 22979 end Same_Value; 22980 22981 -------------------- 22982 -- Set_SPARK_Mode -- 22983 -------------------- 22984 22985 procedure Set_SPARK_Mode (Context : Entity_Id) is 22986 begin 22987 -- Do not consider illegal or partially decorated constructs 22988 22989 if Ekind (Context) = E_Void or else Error_Posted (Context) then 22990 null; 22991 22992 elsif Present (SPARK_Pragma (Context)) then 22993 Install_SPARK_Mode 22994 (Mode => Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Context)), 22995 Prag => SPARK_Pragma (Context)); 22996 end if; 22997 end Set_SPARK_Mode; 22998 22999 ------------------------- 23000 -- Scalar_Part_Present -- 23001 ------------------------- 23002 23003 function Scalar_Part_Present (T : Entity_Id) return Boolean is 23004 C : Entity_Id; 23005 23006 begin 23007 if Is_Scalar_Type (T) then 23008 return True; 23009 23010 elsif Is_Array_Type (T) then 23011 return Scalar_Part_Present (Component_Type (T)); 23012 23013 elsif Is_Record_Type (T) or else Has_Discriminants (T) then 23014 C := First_Component_Or_Discriminant (T); 23015 while Present (C) loop 23016 if Scalar_Part_Present (Etype (C)) then 23017 return True; 23018 else 23019 Next_Component_Or_Discriminant (C); 23020 end if; 23021 end loop; 23022 end if; 23023 23024 return False; 23025 end Scalar_Part_Present; 23026 23027 ------------------------ 23028 -- Scope_Is_Transient -- 23029 ------------------------ 23030 23031 function Scope_Is_Transient return Boolean is 23032 begin 23033 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient; 23034 end Scope_Is_Transient; 23035 23036 ------------------ 23037 -- Scope_Within -- 23038 ------------------ 23039 23040 function Scope_Within 23041 (Inner : Entity_Id; 23042 Outer : Entity_Id) return Boolean 23043 is 23044 Curr : Entity_Id; 23045 23046 begin 23047 Curr := Inner; 23048 while Present (Curr) and then Curr /= Standard_Standard loop 23049 Curr := Scope (Curr); 23050 23051 if Curr = Outer then 23052 return True; 23053 end if; 23054 end loop; 23055 23056 return False; 23057 end Scope_Within; 23058 23059 -------------------------- 23060 -- Scope_Within_Or_Same -- 23061 -------------------------- 23062 23063 function Scope_Within_Or_Same 23064 (Inner : Entity_Id; 23065 Outer : Entity_Id) return Boolean 23066 is 23067 Curr : Entity_Id; 23068 23069 begin 23070 Curr := Inner; 23071 while Present (Curr) and then Curr /= Standard_Standard loop 23072 if Curr = Outer then 23073 return True; 23074 end if; 23075 23076 Curr := Scope (Curr); 23077 end loop; 23078 23079 return False; 23080 end Scope_Within_Or_Same; 23081 23082 -------------------- 23083 -- Set_Convention -- 23084 -------------------- 23085 23086 procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is 23087 begin 23088 Basic_Set_Convention (E, Val); 23089 23090 if Is_Type (E) 23091 and then Is_Access_Subprogram_Type (Base_Type (E)) 23092 and then Has_Foreign_Convention (E) 23093 then 23094 Set_Can_Use_Internal_Rep (E, False); 23095 end if; 23096 23097 -- If E is an object, including a component, and the type of E is an 23098 -- anonymous access type with no convention set, then also set the 23099 -- convention of the anonymous access type. We do not do this for 23100 -- anonymous protected types, since protected types always have the 23101 -- default convention. 23102 23103 if Present (Etype (E)) 23104 and then (Is_Object (E) 23105 23106 -- Allow E_Void (happens for pragma Convention appearing 23107 -- in the middle of a record applying to a component) 23108 23109 or else Ekind (E) = E_Void) 23110 then 23111 declare 23112 Typ : constant Entity_Id := Etype (E); 23113 23114 begin 23115 if Ekind_In (Typ, E_Anonymous_Access_Type, 23116 E_Anonymous_Access_Subprogram_Type) 23117 and then not Has_Convention_Pragma (Typ) 23118 then 23119 Basic_Set_Convention (Typ, Val); 23120 Set_Has_Convention_Pragma (Typ); 23121 23122 -- And for the access subprogram type, deal similarly with the 23123 -- designated E_Subprogram_Type, which is always internal. 23124 23125 if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then 23126 declare 23127 Dtype : constant Entity_Id := Designated_Type (Typ); 23128 begin 23129 if Ekind (Dtype) = E_Subprogram_Type 23130 and then not Has_Convention_Pragma (Dtype) 23131 then 23132 Basic_Set_Convention (Dtype, Val); 23133 Set_Has_Convention_Pragma (Dtype); 23134 end if; 23135 end; 23136 end if; 23137 end if; 23138 end; 23139 end if; 23140 end Set_Convention; 23141 23142 ------------------------ 23143 -- Set_Current_Entity -- 23144 ------------------------ 23145 23146 -- The given entity is to be set as the currently visible definition of its 23147 -- associated name (i.e. the Node_Id associated with its name). All we have 23148 -- to do is to get the name from the identifier, and then set the 23149 -- associated Node_Id to point to the given entity. 23150 23151 procedure Set_Current_Entity (E : Entity_Id) is 23152 begin 23153 Set_Name_Entity_Id (Chars (E), E); 23154 end Set_Current_Entity; 23155 23156 --------------------------- 23157 -- Set_Debug_Info_Needed -- 23158 --------------------------- 23159 23160 procedure Set_Debug_Info_Needed (T : Entity_Id) is 23161 23162 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id); 23163 pragma Inline (Set_Debug_Info_Needed_If_Not_Set); 23164 -- Used to set debug info in a related node if not set already 23165 23166 -------------------------------------- 23167 -- Set_Debug_Info_Needed_If_Not_Set -- 23168 -------------------------------------- 23169 23170 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is 23171 begin 23172 if Present (E) and then not Needs_Debug_Info (E) then 23173 Set_Debug_Info_Needed (E); 23174 23175 -- For a private type, indicate that the full view also needs 23176 -- debug information. 23177 23178 if Is_Type (E) 23179 and then Is_Private_Type (E) 23180 and then Present (Full_View (E)) 23181 then 23182 Set_Debug_Info_Needed (Full_View (E)); 23183 end if; 23184 end if; 23185 end Set_Debug_Info_Needed_If_Not_Set; 23186 23187 -- Start of processing for Set_Debug_Info_Needed 23188 23189 begin 23190 -- Nothing to do if argument is Empty or has Debug_Info_Off set, which 23191 -- indicates that Debug_Info_Needed is never required for the entity. 23192 -- Nothing to do if entity comes from a predefined file. Library files 23193 -- are compiled without debug information, but inlined bodies of these 23194 -- routines may appear in user code, and debug information on them ends 23195 -- up complicating debugging the user code. 23196 23197 if No (T) 23198 or else Debug_Info_Off (T) 23199 then 23200 return; 23201 23202 elsif In_Inlined_Body and then In_Predefined_Unit (T) then 23203 Set_Needs_Debug_Info (T, False); 23204 end if; 23205 23206 -- Set flag in entity itself. Note that we will go through the following 23207 -- circuitry even if the flag is already set on T. That's intentional, 23208 -- it makes sure that the flag will be set in subsidiary entities. 23209 23210 Set_Needs_Debug_Info (T); 23211 23212 -- Set flag on subsidiary entities if not set already 23213 23214 if Is_Object (T) then 23215 Set_Debug_Info_Needed_If_Not_Set (Etype (T)); 23216 23217 elsif Is_Type (T) then 23218 Set_Debug_Info_Needed_If_Not_Set (Etype (T)); 23219 23220 if Is_Record_Type (T) then 23221 declare 23222 Ent : Entity_Id := First_Entity (T); 23223 begin 23224 while Present (Ent) loop 23225 Set_Debug_Info_Needed_If_Not_Set (Ent); 23226 Next_Entity (Ent); 23227 end loop; 23228 end; 23229 23230 -- For a class wide subtype, we also need debug information 23231 -- for the equivalent type. 23232 23233 if Ekind (T) = E_Class_Wide_Subtype then 23234 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T)); 23235 end if; 23236 23237 elsif Is_Array_Type (T) then 23238 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T)); 23239 23240 declare 23241 Indx : Node_Id := First_Index (T); 23242 begin 23243 while Present (Indx) loop 23244 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx)); 23245 Indx := Next_Index (Indx); 23246 end loop; 23247 end; 23248 23249 -- For a packed array type, we also need debug information for 23250 -- the type used to represent the packed array. Conversely, we 23251 -- also need it for the former if we need it for the latter. 23252 23253 if Is_Packed (T) then 23254 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Impl_Type (T)); 23255 end if; 23256 23257 if Is_Packed_Array_Impl_Type (T) then 23258 Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T)); 23259 end if; 23260 23261 elsif Is_Access_Type (T) then 23262 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T)); 23263 23264 elsif Is_Private_Type (T) then 23265 declare 23266 FV : constant Entity_Id := Full_View (T); 23267 23268 begin 23269 Set_Debug_Info_Needed_If_Not_Set (FV); 23270 23271 -- If the full view is itself a derived private type, we need 23272 -- debug information on its underlying type. 23273 23274 if Present (FV) 23275 and then Is_Private_Type (FV) 23276 and then Present (Underlying_Full_View (FV)) 23277 then 23278 Set_Needs_Debug_Info (Underlying_Full_View (FV)); 23279 end if; 23280 end; 23281 23282 elsif Is_Protected_Type (T) then 23283 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T)); 23284 23285 elsif Is_Scalar_Type (T) then 23286 23287 -- If the subrange bounds are materialized by dedicated constant 23288 -- objects, also include them in the debug info to make sure the 23289 -- debugger can properly use them. 23290 23291 if Present (Scalar_Range (T)) 23292 and then Nkind (Scalar_Range (T)) = N_Range 23293 then 23294 declare 23295 Low_Bnd : constant Node_Id := Type_Low_Bound (T); 23296 High_Bnd : constant Node_Id := Type_High_Bound (T); 23297 23298 begin 23299 if Is_Entity_Name (Low_Bnd) then 23300 Set_Debug_Info_Needed_If_Not_Set (Entity (Low_Bnd)); 23301 end if; 23302 23303 if Is_Entity_Name (High_Bnd) then 23304 Set_Debug_Info_Needed_If_Not_Set (Entity (High_Bnd)); 23305 end if; 23306 end; 23307 end if; 23308 end if; 23309 end if; 23310 end Set_Debug_Info_Needed; 23311 23312 ---------------------------- 23313 -- Set_Entity_With_Checks -- 23314 ---------------------------- 23315 23316 procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id) is 23317 Val_Actual : Entity_Id; 23318 Nod : Node_Id; 23319 Post_Node : Node_Id; 23320 23321 begin 23322 -- Unconditionally set the entity 23323 23324 Set_Entity (N, Val); 23325 23326 -- The node to post on is the selector in the case of an expanded name, 23327 -- and otherwise the node itself. 23328 23329 if Nkind (N) = N_Expanded_Name then 23330 Post_Node := Selector_Name (N); 23331 else 23332 Post_Node := N; 23333 end if; 23334 23335 -- Check for violation of No_Fixed_IO 23336 23337 if Restriction_Check_Required (No_Fixed_IO) 23338 and then 23339 ((RTU_Loaded (Ada_Text_IO) 23340 and then (Is_RTE (Val, RE_Decimal_IO) 23341 or else 23342 Is_RTE (Val, RE_Fixed_IO))) 23343 23344 or else 23345 (RTU_Loaded (Ada_Wide_Text_IO) 23346 and then (Is_RTE (Val, RO_WT_Decimal_IO) 23347 or else 23348 Is_RTE (Val, RO_WT_Fixed_IO))) 23349 23350 or else 23351 (RTU_Loaded (Ada_Wide_Wide_Text_IO) 23352 and then (Is_RTE (Val, RO_WW_Decimal_IO) 23353 or else 23354 Is_RTE (Val, RO_WW_Fixed_IO)))) 23355 23356 -- A special extra check, don't complain about a reference from within 23357 -- the Ada.Interrupts package itself! 23358 23359 and then not In_Same_Extended_Unit (N, Val) 23360 then 23361 Check_Restriction (No_Fixed_IO, Post_Node); 23362 end if; 23363 23364 -- Remaining checks are only done on source nodes. Note that we test 23365 -- for violation of No_Fixed_IO even on non-source nodes, because the 23366 -- cases for checking violations of this restriction are instantiations 23367 -- where the reference in the instance has Comes_From_Source False. 23368 23369 if not Comes_From_Source (N) then 23370 return; 23371 end if; 23372 23373 -- Check for violation of No_Abort_Statements, which is triggered by 23374 -- call to Ada.Task_Identification.Abort_Task. 23375 23376 if Restriction_Check_Required (No_Abort_Statements) 23377 and then (Is_RTE (Val, RE_Abort_Task)) 23378 23379 -- A special extra check, don't complain about a reference from within 23380 -- the Ada.Task_Identification package itself! 23381 23382 and then not In_Same_Extended_Unit (N, Val) 23383 then 23384 Check_Restriction (No_Abort_Statements, Post_Node); 23385 end if; 23386 23387 if Val = Standard_Long_Long_Integer then 23388 Check_Restriction (No_Long_Long_Integers, Post_Node); 23389 end if; 23390 23391 -- Check for violation of No_Dynamic_Attachment 23392 23393 if Restriction_Check_Required (No_Dynamic_Attachment) 23394 and then RTU_Loaded (Ada_Interrupts) 23395 and then (Is_RTE (Val, RE_Is_Reserved) or else 23396 Is_RTE (Val, RE_Is_Attached) or else 23397 Is_RTE (Val, RE_Current_Handler) or else 23398 Is_RTE (Val, RE_Attach_Handler) or else 23399 Is_RTE (Val, RE_Exchange_Handler) or else 23400 Is_RTE (Val, RE_Detach_Handler) or else 23401 Is_RTE (Val, RE_Reference)) 23402 23403 -- A special extra check, don't complain about a reference from within 23404 -- the Ada.Interrupts package itself! 23405 23406 and then not In_Same_Extended_Unit (N, Val) 23407 then 23408 Check_Restriction (No_Dynamic_Attachment, Post_Node); 23409 end if; 23410 23411 -- Check for No_Implementation_Identifiers 23412 23413 if Restriction_Check_Required (No_Implementation_Identifiers) then 23414 23415 -- We have an implementation defined entity if it is marked as 23416 -- implementation defined, or is defined in a package marked as 23417 -- implementation defined. However, library packages themselves 23418 -- are excluded (we don't want to flag Interfaces itself, just 23419 -- the entities within it). 23420 23421 if (Is_Implementation_Defined (Val) 23422 or else 23423 (Present (Scope (Val)) 23424 and then Is_Implementation_Defined (Scope (Val)))) 23425 and then not (Ekind_In (Val, E_Package, E_Generic_Package) 23426 and then Is_Library_Level_Entity (Val)) 23427 then 23428 Check_Restriction (No_Implementation_Identifiers, Post_Node); 23429 end if; 23430 end if; 23431 23432 -- Do the style check 23433 23434 if Style_Check 23435 and then not Suppress_Style_Checks (Val) 23436 and then not In_Instance 23437 then 23438 if Nkind (N) = N_Identifier then 23439 Nod := N; 23440 elsif Nkind (N) = N_Expanded_Name then 23441 Nod := Selector_Name (N); 23442 else 23443 return; 23444 end if; 23445 23446 -- A special situation arises for derived operations, where we want 23447 -- to do the check against the parent (since the Sloc of the derived 23448 -- operation points to the derived type declaration itself). 23449 23450 Val_Actual := Val; 23451 while not Comes_From_Source (Val_Actual) 23452 and then Nkind (Val_Actual) in N_Entity 23453 and then (Ekind (Val_Actual) = E_Enumeration_Literal 23454 or else Is_Subprogram_Or_Generic_Subprogram (Val_Actual)) 23455 and then Present (Alias (Val_Actual)) 23456 loop 23457 Val_Actual := Alias (Val_Actual); 23458 end loop; 23459 23460 -- Renaming declarations for generic actuals do not come from source, 23461 -- and have a different name from that of the entity they rename, so 23462 -- there is no style check to perform here. 23463 23464 if Chars (Nod) = Chars (Val_Actual) then 23465 Style.Check_Identifier (Nod, Val_Actual); 23466 end if; 23467 end if; 23468 23469 Set_Entity (N, Val); 23470 end Set_Entity_With_Checks; 23471 23472 ------------------------ 23473 -- Set_Name_Entity_Id -- 23474 ------------------------ 23475 23476 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is 23477 begin 23478 Set_Name_Table_Int (Id, Int (Val)); 23479 end Set_Name_Entity_Id; 23480 23481 --------------------- 23482 -- Set_Next_Actual -- 23483 --------------------- 23484 23485 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is 23486 begin 23487 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then 23488 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id); 23489 end if; 23490 end Set_Next_Actual; 23491 23492 ---------------------------------- 23493 -- Set_Optimize_Alignment_Flags -- 23494 ---------------------------------- 23495 23496 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is 23497 begin 23498 if Optimize_Alignment = 'S' then 23499 Set_Optimize_Alignment_Space (E); 23500 elsif Optimize_Alignment = 'T' then 23501 Set_Optimize_Alignment_Time (E); 23502 end if; 23503 end Set_Optimize_Alignment_Flags; 23504 23505 ----------------------- 23506 -- Set_Public_Status -- 23507 ----------------------- 23508 23509 procedure Set_Public_Status (Id : Entity_Id) is 23510 S : constant Entity_Id := Current_Scope; 23511 23512 function Within_HSS_Or_If (E : Entity_Id) return Boolean; 23513 -- Determines if E is defined within handled statement sequence or 23514 -- an if statement, returns True if so, False otherwise. 23515 23516 ---------------------- 23517 -- Within_HSS_Or_If -- 23518 ---------------------- 23519 23520 function Within_HSS_Or_If (E : Entity_Id) return Boolean is 23521 N : Node_Id; 23522 begin 23523 N := Declaration_Node (E); 23524 loop 23525 N := Parent (N); 23526 23527 if No (N) then 23528 return False; 23529 23530 elsif Nkind_In (N, N_Handled_Sequence_Of_Statements, 23531 N_If_Statement) 23532 then 23533 return True; 23534 end if; 23535 end loop; 23536 end Within_HSS_Or_If; 23537 23538 -- Start of processing for Set_Public_Status 23539 23540 begin 23541 -- Everything in the scope of Standard is public 23542 23543 if S = Standard_Standard then 23544 Set_Is_Public (Id); 23545 23546 -- Entity is definitely not public if enclosing scope is not public 23547 23548 elsif not Is_Public (S) then 23549 return; 23550 23551 -- An object or function declaration that occurs in a handled sequence 23552 -- of statements or within an if statement is the declaration for a 23553 -- temporary object or local subprogram generated by the expander. It 23554 -- never needs to be made public and furthermore, making it public can 23555 -- cause back end problems. 23556 23557 elsif Nkind_In (Parent (Id), N_Object_Declaration, 23558 N_Function_Specification) 23559 and then Within_HSS_Or_If (Id) 23560 then 23561 return; 23562 23563 -- Entities in public packages or records are public 23564 23565 elsif Ekind (S) = E_Package or Is_Record_Type (S) then 23566 Set_Is_Public (Id); 23567 23568 -- The bounds of an entry family declaration can generate object 23569 -- declarations that are visible to the back-end, e.g. in the 23570 -- the declaration of a composite type that contains tasks. 23571 23572 elsif Is_Concurrent_Type (S) 23573 and then not Has_Completion (S) 23574 and then Nkind (Parent (Id)) = N_Object_Declaration 23575 then 23576 Set_Is_Public (Id); 23577 end if; 23578 end Set_Public_Status; 23579 23580 ----------------------------- 23581 -- Set_Referenced_Modified -- 23582 ----------------------------- 23583 23584 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is 23585 Pref : Node_Id; 23586 23587 begin 23588 -- Deal with indexed or selected component where prefix is modified 23589 23590 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then 23591 Pref := Prefix (N); 23592 23593 -- If prefix is access type, then it is the designated object that is 23594 -- being modified, which means we have no entity to set the flag on. 23595 23596 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then 23597 return; 23598 23599 -- Otherwise chase the prefix 23600 23601 else 23602 Set_Referenced_Modified (Pref, Out_Param); 23603 end if; 23604 23605 -- Otherwise see if we have an entity name (only other case to process) 23606 23607 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 23608 Set_Referenced_As_LHS (Entity (N), not Out_Param); 23609 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param); 23610 end if; 23611 end Set_Referenced_Modified; 23612 23613 ------------------ 23614 -- Set_Rep_Info -- 23615 ------------------ 23616 23617 procedure Set_Rep_Info (T1 : Entity_Id; T2 : Entity_Id) is 23618 begin 23619 Set_Is_Atomic (T1, Is_Atomic (T2)); 23620 Set_Is_Independent (T1, Is_Independent (T2)); 23621 Set_Is_Volatile_Full_Access (T1, Is_Volatile_Full_Access (T2)); 23622 23623 if Is_Base_Type (T1) then 23624 Set_Is_Volatile (T1, Is_Volatile (T2)); 23625 end if; 23626 end Set_Rep_Info; 23627 23628 ---------------------------- 23629 -- Set_Scope_Is_Transient -- 23630 ---------------------------- 23631 23632 procedure Set_Scope_Is_Transient (V : Boolean := True) is 23633 begin 23634 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V; 23635 end Set_Scope_Is_Transient; 23636 23637 ------------------- 23638 -- Set_Size_Info -- 23639 ------------------- 23640 23641 procedure Set_Size_Info (T1, T2 : Entity_Id) is 23642 begin 23643 -- We copy Esize, but not RM_Size, since in general RM_Size is 23644 -- subtype specific and does not get inherited by all subtypes. 23645 23646 Set_Esize (T1, Esize (T2)); 23647 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2)); 23648 23649 if Is_Discrete_Or_Fixed_Point_Type (T1) 23650 and then 23651 Is_Discrete_Or_Fixed_Point_Type (T2) 23652 then 23653 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2)); 23654 end if; 23655 23656 Set_Alignment (T1, Alignment (T2)); 23657 end Set_Size_Info; 23658 23659 ------------------------------ 23660 -- Should_Ignore_Pragma_Par -- 23661 ------------------------------ 23662 23663 function Should_Ignore_Pragma_Par (Prag_Name : Name_Id) return Boolean is 23664 pragma Assert (Compiler_State = Parsing); 23665 -- This one can't work during semantic analysis, because we don't have a 23666 -- correct Current_Source_File. 23667 23668 Result : constant Boolean := 23669 Get_Name_Table_Boolean3 (Prag_Name) 23670 and then not Is_Internal_File_Name 23671 (File_Name (Current_Source_File)); 23672 begin 23673 return Result; 23674 end Should_Ignore_Pragma_Par; 23675 23676 ------------------------------ 23677 -- Should_Ignore_Pragma_Sem -- 23678 ------------------------------ 23679 23680 function Should_Ignore_Pragma_Sem (N : Node_Id) return Boolean is 23681 pragma Assert (Compiler_State = Analyzing); 23682 Prag_Name : constant Name_Id := Pragma_Name (N); 23683 Result : constant Boolean := 23684 Get_Name_Table_Boolean3 (Prag_Name) 23685 and then not In_Internal_Unit (N); 23686 23687 begin 23688 return Result; 23689 end Should_Ignore_Pragma_Sem; 23690 23691 -------------------- 23692 -- Static_Boolean -- 23693 -------------------- 23694 23695 function Static_Boolean (N : Node_Id) return Uint is 23696 begin 23697 Analyze_And_Resolve (N, Standard_Boolean); 23698 23699 if N = Error 23700 or else Error_Posted (N) 23701 or else Etype (N) = Any_Type 23702 then 23703 return No_Uint; 23704 end if; 23705 23706 if Is_OK_Static_Expression (N) then 23707 if not Raises_Constraint_Error (N) then 23708 return Expr_Value (N); 23709 else 23710 return No_Uint; 23711 end if; 23712 23713 elsif Etype (N) = Any_Type then 23714 return No_Uint; 23715 23716 else 23717 Flag_Non_Static_Expr 23718 ("static boolean expression required here", N); 23719 return No_Uint; 23720 end if; 23721 end Static_Boolean; 23722 23723 -------------------- 23724 -- Static_Integer -- 23725 -------------------- 23726 23727 function Static_Integer (N : Node_Id) return Uint is 23728 begin 23729 Analyze_And_Resolve (N, Any_Integer); 23730 23731 if N = Error 23732 or else Error_Posted (N) 23733 or else Etype (N) = Any_Type 23734 then 23735 return No_Uint; 23736 end if; 23737 23738 if Is_OK_Static_Expression (N) then 23739 if not Raises_Constraint_Error (N) then 23740 return Expr_Value (N); 23741 else 23742 return No_Uint; 23743 end if; 23744 23745 elsif Etype (N) = Any_Type then 23746 return No_Uint; 23747 23748 else 23749 Flag_Non_Static_Expr 23750 ("static integer expression required here", N); 23751 return No_Uint; 23752 end if; 23753 end Static_Integer; 23754 23755 -------------------------- 23756 -- Statically_Different -- 23757 -------------------------- 23758 23759 function Statically_Different (E1, E2 : Node_Id) return Boolean is 23760 R1 : constant Node_Id := Get_Referenced_Object (E1); 23761 R2 : constant Node_Id := Get_Referenced_Object (E2); 23762 begin 23763 return Is_Entity_Name (R1) 23764 and then Is_Entity_Name (R2) 23765 and then Entity (R1) /= Entity (R2) 23766 and then not Is_Formal (Entity (R1)) 23767 and then not Is_Formal (Entity (R2)); 23768 end Statically_Different; 23769 23770 -------------------------------------- 23771 -- Subject_To_Loop_Entry_Attributes -- 23772 -------------------------------------- 23773 23774 function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is 23775 Stmt : Node_Id; 23776 23777 begin 23778 Stmt := N; 23779 23780 -- The expansion mechanism transform a loop subject to at least one 23781 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack 23782 -- the conditional part. 23783 23784 if Nkind_In (Stmt, N_Block_Statement, N_If_Statement) 23785 and then Nkind (Original_Node (N)) = N_Loop_Statement 23786 then 23787 Stmt := Original_Node (N); 23788 end if; 23789 23790 return 23791 Nkind (Stmt) = N_Loop_Statement 23792 and then Present (Identifier (Stmt)) 23793 and then Present (Entity (Identifier (Stmt))) 23794 and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt))); 23795 end Subject_To_Loop_Entry_Attributes; 23796 23797 ----------------------------- 23798 -- Subprogram_Access_Level -- 23799 ----------------------------- 23800 23801 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is 23802 begin 23803 if Present (Alias (Subp)) then 23804 return Subprogram_Access_Level (Alias (Subp)); 23805 else 23806 return Scope_Depth (Enclosing_Dynamic_Scope (Subp)); 23807 end if; 23808 end Subprogram_Access_Level; 23809 23810 --------------------- 23811 -- Subprogram_Name -- 23812 --------------------- 23813 23814 function Subprogram_Name (N : Node_Id) return String is 23815 Buf : Bounded_String; 23816 Ent : Node_Id := N; 23817 Nod : Node_Id; 23818 23819 begin 23820 while Present (Ent) loop 23821 case Nkind (Ent) is 23822 when N_Subprogram_Body => 23823 Ent := Defining_Unit_Name (Specification (Ent)); 23824 exit; 23825 23826 when N_Subprogram_Declaration => 23827 Nod := Corresponding_Body (Ent); 23828 23829 if Present (Nod) then 23830 Ent := Nod; 23831 else 23832 Ent := Defining_Unit_Name (Specification (Ent)); 23833 end if; 23834 23835 exit; 23836 23837 when N_Subprogram_Instantiation 23838 | N_Package_Body 23839 | N_Package_Specification 23840 => 23841 Ent := Defining_Unit_Name (Ent); 23842 exit; 23843 23844 when N_Protected_Type_Declaration => 23845 Ent := Corresponding_Body (Ent); 23846 exit; 23847 23848 when N_Protected_Body 23849 | N_Task_Body 23850 => 23851 Ent := Defining_Identifier (Ent); 23852 exit; 23853 23854 when others => 23855 null; 23856 end case; 23857 23858 Ent := Parent (Ent); 23859 end loop; 23860 23861 if No (Ent) then 23862 return "unknown subprogram:unknown file:0:0"; 23863 end if; 23864 23865 -- If the subprogram is a child unit, use its simple name to start the 23866 -- construction of the fully qualified name. 23867 23868 if Nkind (Ent) = N_Defining_Program_Unit_Name then 23869 Ent := Defining_Identifier (Ent); 23870 end if; 23871 23872 Append_Entity_Name (Buf, Ent); 23873 23874 -- Append homonym number if needed 23875 23876 if Nkind (N) in N_Entity and then Has_Homonym (N) then 23877 declare 23878 H : Entity_Id := Homonym (N); 23879 Nr : Nat := 1; 23880 23881 begin 23882 while Present (H) loop 23883 if Scope (H) = Scope (N) then 23884 Nr := Nr + 1; 23885 end if; 23886 23887 H := Homonym (H); 23888 end loop; 23889 23890 if Nr > 1 then 23891 Append (Buf, '#'); 23892 Append (Buf, Nr); 23893 end if; 23894 end; 23895 end if; 23896 23897 -- Append source location of Ent to Buf so that the string will 23898 -- look like "subp:file:line:col". 23899 23900 declare 23901 Loc : constant Source_Ptr := Sloc (Ent); 23902 begin 23903 Append (Buf, ':'); 23904 Append (Buf, Reference_Name (Get_Source_File_Index (Loc))); 23905 Append (Buf, ':'); 23906 Append (Buf, Nat (Get_Logical_Line_Number (Loc))); 23907 Append (Buf, ':'); 23908 Append (Buf, Nat (Get_Column_Number (Loc))); 23909 end; 23910 23911 return +Buf; 23912 end Subprogram_Name; 23913 23914 ------------------------------- 23915 -- Support_Atomic_Primitives -- 23916 ------------------------------- 23917 23918 function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is 23919 Size : Int; 23920 23921 begin 23922 -- Verify the alignment of Typ is known 23923 23924 if not Known_Alignment (Typ) then 23925 return False; 23926 end if; 23927 23928 if Known_Static_Esize (Typ) then 23929 Size := UI_To_Int (Esize (Typ)); 23930 23931 -- If the Esize (Object_Size) is unknown at compile time, look at the 23932 -- RM_Size (Value_Size) which may have been set by an explicit rep item. 23933 23934 elsif Known_Static_RM_Size (Typ) then 23935 Size := UI_To_Int (RM_Size (Typ)); 23936 23937 -- Otherwise, the size is considered to be unknown. 23938 23939 else 23940 return False; 23941 end if; 23942 23943 -- Check that the size of the component is 8, 16, 32, or 64 bits and 23944 -- that Typ is properly aligned. 23945 23946 case Size is 23947 when 8 | 16 | 32 | 64 => 23948 return Size = UI_To_Int (Alignment (Typ)) * 8; 23949 23950 when others => 23951 return False; 23952 end case; 23953 end Support_Atomic_Primitives; 23954 23955 ----------------- 23956 -- Trace_Scope -- 23957 ----------------- 23958 23959 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is 23960 begin 23961 if Debug_Flag_W then 23962 for J in 0 .. Scope_Stack.Last loop 23963 Write_Str (" "); 23964 end loop; 23965 23966 Write_Str (Msg); 23967 Write_Name (Chars (E)); 23968 Write_Str (" from "); 23969 Write_Location (Sloc (N)); 23970 Write_Eol; 23971 end if; 23972 end Trace_Scope; 23973 23974 ----------------------- 23975 -- Transfer_Entities -- 23976 ----------------------- 23977 23978 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is 23979 procedure Set_Public_Status_Of (Id : Entity_Id); 23980 -- Set the Is_Public attribute of arbitrary entity Id by calling routine 23981 -- Set_Public_Status. If successful and Id denotes a record type, set 23982 -- the Is_Public attribute of its fields. 23983 23984 -------------------------- 23985 -- Set_Public_Status_Of -- 23986 -------------------------- 23987 23988 procedure Set_Public_Status_Of (Id : Entity_Id) is 23989 Field : Entity_Id; 23990 23991 begin 23992 if not Is_Public (Id) then 23993 Set_Public_Status (Id); 23994 23995 -- When the input entity is a public record type, ensure that all 23996 -- its internal fields are also exposed to the linker. The fields 23997 -- of a class-wide type are never made public. 23998 23999 if Is_Public (Id) 24000 and then Is_Record_Type (Id) 24001 and then not Is_Class_Wide_Type (Id) 24002 then 24003 Field := First_Entity (Id); 24004 while Present (Field) loop 24005 Set_Is_Public (Field); 24006 Next_Entity (Field); 24007 end loop; 24008 end if; 24009 end if; 24010 end Set_Public_Status_Of; 24011 24012 -- Local variables 24013 24014 Full_Id : Entity_Id; 24015 Id : Entity_Id; 24016 24017 -- Start of processing for Transfer_Entities 24018 24019 begin 24020 Id := First_Entity (From); 24021 24022 if Present (Id) then 24023 24024 -- Merge the entity chain of the source scope with that of the 24025 -- destination scope. 24026 24027 if Present (Last_Entity (To)) then 24028 Set_Next_Entity (Last_Entity (To), Id); 24029 else 24030 Set_First_Entity (To, Id); 24031 end if; 24032 24033 Set_Last_Entity (To, Last_Entity (From)); 24034 24035 -- Inspect the entities of the source scope and update their Scope 24036 -- attribute. 24037 24038 while Present (Id) loop 24039 Set_Scope (Id, To); 24040 Set_Public_Status_Of (Id); 24041 24042 -- Handle an internally generated full view for a private type 24043 24044 if Is_Private_Type (Id) 24045 and then Present (Full_View (Id)) 24046 and then Is_Itype (Full_View (Id)) 24047 then 24048 Full_Id := Full_View (Id); 24049 24050 Set_Scope (Full_Id, To); 24051 Set_Public_Status_Of (Full_Id); 24052 end if; 24053 24054 Next_Entity (Id); 24055 end loop; 24056 24057 Set_First_Entity (From, Empty); 24058 Set_Last_Entity (From, Empty); 24059 end if; 24060 end Transfer_Entities; 24061 24062 ----------------------- 24063 -- Type_Access_Level -- 24064 ----------------------- 24065 24066 function Type_Access_Level (Typ : Entity_Id) return Uint is 24067 Btyp : Entity_Id; 24068 24069 begin 24070 Btyp := Base_Type (Typ); 24071 24072 -- Ada 2005 (AI-230): For most cases of anonymous access types, we 24073 -- simply use the level where the type is declared. This is true for 24074 -- stand-alone object declarations, and for anonymous access types 24075 -- associated with components the level is the same as that of the 24076 -- enclosing composite type. However, special treatment is needed for 24077 -- the cases of access parameters, return objects of an anonymous access 24078 -- type, and, in Ada 95, access discriminants of limited types. 24079 24080 if Is_Access_Type (Btyp) then 24081 if Ekind (Btyp) = E_Anonymous_Access_Type then 24082 24083 -- If the type is a nonlocal anonymous access type (such as for 24084 -- an access parameter) we treat it as being declared at the 24085 -- library level to ensure that names such as X.all'access don't 24086 -- fail static accessibility checks. 24087 24088 if not Is_Local_Anonymous_Access (Typ) then 24089 return Scope_Depth (Standard_Standard); 24090 24091 -- If this is a return object, the accessibility level is that of 24092 -- the result subtype of the enclosing function. The test here is 24093 -- little complicated, because we have to account for extended 24094 -- return statements that have been rewritten as blocks, in which 24095 -- case we have to find and the Is_Return_Object attribute of the 24096 -- itype's associated object. It would be nice to find a way to 24097 -- simplify this test, but it doesn't seem worthwhile to add a new 24098 -- flag just for purposes of this test. ??? 24099 24100 elsif Ekind (Scope (Btyp)) = E_Return_Statement 24101 or else 24102 (Is_Itype (Btyp) 24103 and then Nkind (Associated_Node_For_Itype (Btyp)) = 24104 N_Object_Declaration 24105 and then Is_Return_Object 24106 (Defining_Identifier 24107 (Associated_Node_For_Itype (Btyp)))) 24108 then 24109 declare 24110 Scop : Entity_Id; 24111 24112 begin 24113 Scop := Scope (Scope (Btyp)); 24114 while Present (Scop) loop 24115 exit when Ekind (Scop) = E_Function; 24116 Scop := Scope (Scop); 24117 end loop; 24118 24119 -- Treat the return object's type as having the level of the 24120 -- function's result subtype (as per RM05-6.5(5.3/2)). 24121 24122 return Type_Access_Level (Etype (Scop)); 24123 end; 24124 end if; 24125 end if; 24126 24127 Btyp := Root_Type (Btyp); 24128 24129 -- The accessibility level of anonymous access types associated with 24130 -- discriminants is that of the current instance of the type, and 24131 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)). 24132 24133 -- AI-402: access discriminants have accessibility based on the 24134 -- object rather than the type in Ada 2005, so the above paragraph 24135 -- doesn't apply. 24136 24137 -- ??? Needs completion with rules from AI-416 24138 24139 if Ada_Version <= Ada_95 24140 and then Ekind (Typ) = E_Anonymous_Access_Type 24141 and then Present (Associated_Node_For_Itype (Typ)) 24142 and then Nkind (Associated_Node_For_Itype (Typ)) = 24143 N_Discriminant_Specification 24144 then 24145 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1; 24146 end if; 24147 end if; 24148 24149 -- Return library level for a generic formal type. This is done because 24150 -- RM(10.3.2) says that "The statically deeper relationship does not 24151 -- apply to ... a descendant of a generic formal type". Rather than 24152 -- checking at each point where a static accessibility check is 24153 -- performed to see if we are dealing with a formal type, this rule is 24154 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level 24155 -- return extreme values for a formal type; Deepest_Type_Access_Level 24156 -- returns Int'Last. By calling the appropriate function from among the 24157 -- two, we ensure that the static accessibility check will pass if we 24158 -- happen to run into a formal type. More specifically, we should call 24159 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the 24160 -- call occurs as part of a static accessibility check and the error 24161 -- case is the case where the type's level is too shallow (as opposed 24162 -- to too deep). 24163 24164 if Is_Generic_Type (Root_Type (Btyp)) then 24165 return Scope_Depth (Standard_Standard); 24166 end if; 24167 24168 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); 24169 end Type_Access_Level; 24170 24171 ------------------------------------ 24172 -- Type_Without_Stream_Operation -- 24173 ------------------------------------ 24174 24175 function Type_Without_Stream_Operation 24176 (T : Entity_Id; 24177 Op : TSS_Name_Type := TSS_Null) return Entity_Id 24178 is 24179 BT : constant Entity_Id := Base_Type (T); 24180 Op_Missing : Boolean; 24181 24182 begin 24183 if not Restriction_Active (No_Default_Stream_Attributes) then 24184 return Empty; 24185 end if; 24186 24187 if Is_Elementary_Type (T) then 24188 if Op = TSS_Null then 24189 Op_Missing := 24190 No (TSS (BT, TSS_Stream_Read)) 24191 or else No (TSS (BT, TSS_Stream_Write)); 24192 24193 else 24194 Op_Missing := No (TSS (BT, Op)); 24195 end if; 24196 24197 if Op_Missing then 24198 return T; 24199 else 24200 return Empty; 24201 end if; 24202 24203 elsif Is_Array_Type (T) then 24204 return Type_Without_Stream_Operation (Component_Type (T), Op); 24205 24206 elsif Is_Record_Type (T) then 24207 declare 24208 Comp : Entity_Id; 24209 C_Typ : Entity_Id; 24210 24211 begin 24212 Comp := First_Component (T); 24213 while Present (Comp) loop 24214 C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op); 24215 24216 if Present (C_Typ) then 24217 return C_Typ; 24218 end if; 24219 24220 Next_Component (Comp); 24221 end loop; 24222 24223 return Empty; 24224 end; 24225 24226 elsif Is_Private_Type (T) and then Present (Full_View (T)) then 24227 return Type_Without_Stream_Operation (Full_View (T), Op); 24228 else 24229 return Empty; 24230 end if; 24231 end Type_Without_Stream_Operation; 24232 24233 ---------------------------- 24234 -- Unique_Defining_Entity -- 24235 ---------------------------- 24236 24237 function Unique_Defining_Entity (N : Node_Id) return Entity_Id is 24238 begin 24239 return Unique_Entity (Defining_Entity (N)); 24240 end Unique_Defining_Entity; 24241 24242 ------------------- 24243 -- Unique_Entity -- 24244 ------------------- 24245 24246 function Unique_Entity (E : Entity_Id) return Entity_Id is 24247 U : Entity_Id := E; 24248 P : Node_Id; 24249 24250 begin 24251 case Ekind (E) is 24252 when E_Constant => 24253 if Present (Full_View (E)) then 24254 U := Full_View (E); 24255 end if; 24256 24257 when Entry_Kind => 24258 if Nkind (Parent (E)) = N_Entry_Body then 24259 declare 24260 Prot_Item : Entity_Id; 24261 Prot_Type : Entity_Id; 24262 24263 begin 24264 if Ekind (E) = E_Entry then 24265 Prot_Type := Scope (E); 24266 24267 -- Bodies of entry families are nested within an extra scope 24268 -- that contains an entry index declaration. 24269 24270 else 24271 Prot_Type := Scope (Scope (E)); 24272 end if; 24273 24274 -- A protected type may be declared as a private type, in 24275 -- which case we need to get its full view. 24276 24277 if Is_Private_Type (Prot_Type) then 24278 Prot_Type := Full_View (Prot_Type); 24279 end if; 24280 24281 -- Full view may not be present on error, in which case 24282 -- return E by default. 24283 24284 if Present (Prot_Type) then 24285 pragma Assert (Ekind (Prot_Type) = E_Protected_Type); 24286 24287 -- Traverse the entity list of the protected type and 24288 -- locate an entry declaration which matches the entry 24289 -- body. 24290 24291 Prot_Item := First_Entity (Prot_Type); 24292 while Present (Prot_Item) loop 24293 if Ekind (Prot_Item) in Entry_Kind 24294 and then Corresponding_Body (Parent (Prot_Item)) = E 24295 then 24296 U := Prot_Item; 24297 exit; 24298 end if; 24299 24300 Next_Entity (Prot_Item); 24301 end loop; 24302 end if; 24303 end; 24304 end if; 24305 24306 when Formal_Kind => 24307 if Present (Spec_Entity (E)) then 24308 U := Spec_Entity (E); 24309 end if; 24310 24311 when E_Package_Body => 24312 P := Parent (E); 24313 24314 if Nkind (P) = N_Defining_Program_Unit_Name then 24315 P := Parent (P); 24316 end if; 24317 24318 if Nkind (P) = N_Package_Body 24319 and then Present (Corresponding_Spec (P)) 24320 then 24321 U := Corresponding_Spec (P); 24322 24323 elsif Nkind (P) = N_Package_Body_Stub 24324 and then Present (Corresponding_Spec_Of_Stub (P)) 24325 then 24326 U := Corresponding_Spec_Of_Stub (P); 24327 end if; 24328 24329 when E_Protected_Body => 24330 P := Parent (E); 24331 24332 if Nkind (P) = N_Protected_Body 24333 and then Present (Corresponding_Spec (P)) 24334 then 24335 U := Corresponding_Spec (P); 24336 24337 elsif Nkind (P) = N_Protected_Body_Stub 24338 and then Present (Corresponding_Spec_Of_Stub (P)) 24339 then 24340 U := Corresponding_Spec_Of_Stub (P); 24341 24342 if Is_Single_Protected_Object (U) then 24343 U := Etype (U); 24344 end if; 24345 end if; 24346 24347 if Is_Private_Type (U) then 24348 U := Full_View (U); 24349 end if; 24350 24351 when E_Subprogram_Body => 24352 P := Parent (E); 24353 24354 if Nkind (P) = N_Defining_Program_Unit_Name then 24355 P := Parent (P); 24356 end if; 24357 24358 P := Parent (P); 24359 24360 if Nkind (P) = N_Subprogram_Body 24361 and then Present (Corresponding_Spec (P)) 24362 then 24363 U := Corresponding_Spec (P); 24364 24365 elsif Nkind (P) = N_Subprogram_Body_Stub 24366 and then Present (Corresponding_Spec_Of_Stub (P)) 24367 then 24368 U := Corresponding_Spec_Of_Stub (P); 24369 24370 elsif Nkind (P) = N_Subprogram_Renaming_Declaration then 24371 U := Corresponding_Spec (P); 24372 end if; 24373 24374 when E_Task_Body => 24375 P := Parent (E); 24376 24377 if Nkind (P) = N_Task_Body 24378 and then Present (Corresponding_Spec (P)) 24379 then 24380 U := Corresponding_Spec (P); 24381 24382 elsif Nkind (P) = N_Task_Body_Stub 24383 and then Present (Corresponding_Spec_Of_Stub (P)) 24384 then 24385 U := Corresponding_Spec_Of_Stub (P); 24386 24387 if Is_Single_Task_Object (U) then 24388 U := Etype (U); 24389 end if; 24390 end if; 24391 24392 if Is_Private_Type (U) then 24393 U := Full_View (U); 24394 end if; 24395 24396 when Type_Kind => 24397 if Present (Full_View (E)) then 24398 U := Full_View (E); 24399 end if; 24400 24401 when others => 24402 null; 24403 end case; 24404 24405 return U; 24406 end Unique_Entity; 24407 24408 ----------------- 24409 -- Unique_Name -- 24410 ----------------- 24411 24412 function Unique_Name (E : Entity_Id) return String is 24413 24414 -- Names in E_Subprogram_Body or E_Package_Body entities are not 24415 -- reliable, as they may not include the overloading suffix. Instead, 24416 -- when looking for the name of E or one of its enclosing scope, we get 24417 -- the name of the corresponding Unique_Entity. 24418 24419 U : constant Entity_Id := Unique_Entity (E); 24420 24421 function This_Name return String; 24422 24423 --------------- 24424 -- This_Name -- 24425 --------------- 24426 24427 function This_Name return String is 24428 begin 24429 return Get_Name_String (Chars (U)); 24430 end This_Name; 24431 24432 -- Start of processing for Unique_Name 24433 24434 begin 24435 if E = Standard_Standard 24436 or else Has_Fully_Qualified_Name (E) 24437 then 24438 return This_Name; 24439 24440 elsif Ekind (E) = E_Enumeration_Literal then 24441 return Unique_Name (Etype (E)) & "__" & This_Name; 24442 24443 else 24444 declare 24445 S : constant Entity_Id := Scope (U); 24446 pragma Assert (Present (S)); 24447 24448 begin 24449 -- Prefix names of predefined types with standard__, but leave 24450 -- names of user-defined packages and subprograms without prefix 24451 -- (even if technically they are nested in the Standard package). 24452 24453 if S = Standard_Standard then 24454 if Ekind (U) = E_Package or else Is_Subprogram (U) then 24455 return This_Name; 24456 else 24457 return Unique_Name (S) & "__" & This_Name; 24458 end if; 24459 24460 -- For intances of generic subprograms use the name of the related 24461 -- instace and skip the scope of its wrapper package. 24462 24463 elsif Is_Wrapper_Package (S) then 24464 pragma Assert (Scope (S) = Scope (Related_Instance (S))); 24465 -- Wrapper package and the instantiation are in the same scope 24466 24467 declare 24468 Enclosing_Name : constant String := 24469 Unique_Name (Scope (S)) & "__" & 24470 Get_Name_String (Chars (Related_Instance (S))); 24471 24472 begin 24473 if Is_Subprogram (U) 24474 and then not Is_Generic_Actual_Subprogram (U) 24475 then 24476 return Enclosing_Name; 24477 else 24478 return Enclosing_Name & "__" & This_Name; 24479 end if; 24480 end; 24481 24482 else 24483 return Unique_Name (S) & "__" & This_Name; 24484 end if; 24485 end; 24486 end if; 24487 end Unique_Name; 24488 24489 --------------------- 24490 -- Unit_Is_Visible -- 24491 --------------------- 24492 24493 function Unit_Is_Visible (U : Entity_Id) return Boolean is 24494 Curr : constant Node_Id := Cunit (Current_Sem_Unit); 24495 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 24496 24497 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean; 24498 -- For a child unit, check whether unit appears in a with_clause 24499 -- of a parent. 24500 24501 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean; 24502 -- Scan the context clause of one compilation unit looking for a 24503 -- with_clause for the unit in question. 24504 24505 ---------------------------- 24506 -- Unit_In_Parent_Context -- 24507 ---------------------------- 24508 24509 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is 24510 begin 24511 if Unit_In_Context (Par_Unit) then 24512 return True; 24513 24514 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then 24515 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit))); 24516 24517 else 24518 return False; 24519 end if; 24520 end Unit_In_Parent_Context; 24521 24522 --------------------- 24523 -- Unit_In_Context -- 24524 --------------------- 24525 24526 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is 24527 Clause : Node_Id; 24528 24529 begin 24530 Clause := First (Context_Items (Comp_Unit)); 24531 while Present (Clause) loop 24532 if Nkind (Clause) = N_With_Clause then 24533 if Library_Unit (Clause) = U then 24534 return True; 24535 24536 -- The with_clause may denote a renaming of the unit we are 24537 -- looking for, eg. Text_IO which renames Ada.Text_IO. 24538 24539 elsif 24540 Renamed_Entity (Entity (Name (Clause))) = 24541 Defining_Entity (Unit (U)) 24542 then 24543 return True; 24544 end if; 24545 end if; 24546 24547 Next (Clause); 24548 end loop; 24549 24550 return False; 24551 end Unit_In_Context; 24552 24553 -- Start of processing for Unit_Is_Visible 24554 24555 begin 24556 -- The currrent unit is directly visible 24557 24558 if Curr = U then 24559 return True; 24560 24561 elsif Unit_In_Context (Curr) then 24562 return True; 24563 24564 -- If the current unit is a body, check the context of the spec 24565 24566 elsif Nkind (Unit (Curr)) = N_Package_Body 24567 or else 24568 (Nkind (Unit (Curr)) = N_Subprogram_Body 24569 and then not Acts_As_Spec (Unit (Curr))) 24570 then 24571 if Unit_In_Context (Library_Unit (Curr)) then 24572 return True; 24573 end if; 24574 end if; 24575 24576 -- If the spec is a child unit, examine the parents 24577 24578 if Is_Child_Unit (Curr_Entity) then 24579 if Nkind (Unit (Curr)) in N_Unit_Body then 24580 return 24581 Unit_In_Parent_Context 24582 (Parent_Spec (Unit (Library_Unit (Curr)))); 24583 else 24584 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr))); 24585 end if; 24586 24587 else 24588 return False; 24589 end if; 24590 end Unit_Is_Visible; 24591 24592 ------------------------------ 24593 -- Universal_Interpretation -- 24594 ------------------------------ 24595 24596 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is 24597 Index : Interp_Index; 24598 It : Interp; 24599 24600 begin 24601 -- The argument may be a formal parameter of an operator or subprogram 24602 -- with multiple interpretations, or else an expression for an actual. 24603 24604 if Nkind (Opnd) = N_Defining_Identifier 24605 or else not Is_Overloaded (Opnd) 24606 then 24607 if Etype (Opnd) = Universal_Integer 24608 or else Etype (Opnd) = Universal_Real 24609 then 24610 return Etype (Opnd); 24611 else 24612 return Empty; 24613 end if; 24614 24615 else 24616 Get_First_Interp (Opnd, Index, It); 24617 while Present (It.Typ) loop 24618 if It.Typ = Universal_Integer 24619 or else It.Typ = Universal_Real 24620 then 24621 return It.Typ; 24622 end if; 24623 24624 Get_Next_Interp (Index, It); 24625 end loop; 24626 24627 return Empty; 24628 end if; 24629 end Universal_Interpretation; 24630 24631 --------------- 24632 -- Unqualify -- 24633 --------------- 24634 24635 function Unqualify (Expr : Node_Id) return Node_Id is 24636 begin 24637 -- Recurse to handle unlikely case of multiple levels of qualification 24638 24639 if Nkind (Expr) = N_Qualified_Expression then 24640 return Unqualify (Expression (Expr)); 24641 24642 -- Normal case, not a qualified expression 24643 24644 else 24645 return Expr; 24646 end if; 24647 end Unqualify; 24648 24649 ----------------- 24650 -- Unqual_Conv -- 24651 ----------------- 24652 24653 function Unqual_Conv (Expr : Node_Id) return Node_Id is 24654 begin 24655 -- Recurse to handle unlikely case of multiple levels of qualification 24656 -- and/or conversion. 24657 24658 if Nkind_In (Expr, N_Qualified_Expression, 24659 N_Type_Conversion, 24660 N_Unchecked_Type_Conversion) 24661 then 24662 return Unqual_Conv (Expression (Expr)); 24663 24664 -- Normal case, not a qualified expression 24665 24666 else 24667 return Expr; 24668 end if; 24669 end Unqual_Conv; 24670 24671 ----------------------- 24672 -- Visible_Ancestors -- 24673 ----------------------- 24674 24675 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is 24676 List_1 : Elist_Id; 24677 List_2 : Elist_Id; 24678 Elmt : Elmt_Id; 24679 24680 begin 24681 pragma Assert (Is_Record_Type (Typ) and then Is_Tagged_Type (Typ)); 24682 24683 -- Collect all the parents and progenitors of Typ. If the full-view of 24684 -- private parents and progenitors is available then it is used to 24685 -- generate the list of visible ancestors; otherwise their partial 24686 -- view is added to the resulting list. 24687 24688 Collect_Parents 24689 (T => Typ, 24690 List => List_1, 24691 Use_Full_View => True); 24692 24693 Collect_Interfaces 24694 (T => Typ, 24695 Ifaces_List => List_2, 24696 Exclude_Parents => True, 24697 Use_Full_View => True); 24698 24699 -- Join the two lists. Avoid duplications because an interface may 24700 -- simultaneously be parent and progenitor of a type. 24701 24702 Elmt := First_Elmt (List_2); 24703 while Present (Elmt) loop 24704 Append_Unique_Elmt (Node (Elmt), List_1); 24705 Next_Elmt (Elmt); 24706 end loop; 24707 24708 return List_1; 24709 end Visible_Ancestors; 24710 24711 ---------------------- 24712 -- Within_Init_Proc -- 24713 ---------------------- 24714 24715 function Within_Init_Proc return Boolean is 24716 S : Entity_Id; 24717 24718 begin 24719 S := Current_Scope; 24720 while not Is_Overloadable (S) loop 24721 if S = Standard_Standard then 24722 return False; 24723 else 24724 S := Scope (S); 24725 end if; 24726 end loop; 24727 24728 return Is_Init_Proc (S); 24729 end Within_Init_Proc; 24730 24731 --------------------------- 24732 -- Within_Protected_Type -- 24733 --------------------------- 24734 24735 function Within_Protected_Type (E : Entity_Id) return Boolean is 24736 Scop : Entity_Id := Scope (E); 24737 24738 begin 24739 while Present (Scop) loop 24740 if Ekind (Scop) = E_Protected_Type then 24741 return True; 24742 end if; 24743 24744 Scop := Scope (Scop); 24745 end loop; 24746 24747 return False; 24748 end Within_Protected_Type; 24749 24750 ------------------ 24751 -- Within_Scope -- 24752 ------------------ 24753 24754 function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean is 24755 begin 24756 return Scope_Within_Or_Same (Scope (E), S); 24757 end Within_Scope; 24758 24759 ---------------------------- 24760 -- Within_Subprogram_Call -- 24761 ---------------------------- 24762 24763 function Within_Subprogram_Call (N : Node_Id) return Boolean is 24764 Par : Node_Id; 24765 24766 begin 24767 -- Climb the parent chain looking for a function or procedure call 24768 24769 Par := N; 24770 while Present (Par) loop 24771 if Nkind_In (Par, N_Entry_Call_Statement, 24772 N_Function_Call, 24773 N_Procedure_Call_Statement) 24774 then 24775 return True; 24776 24777 -- Prevent the search from going too far 24778 24779 elsif Is_Body_Or_Package_Declaration (Par) then 24780 exit; 24781 end if; 24782 24783 Par := Parent (Par); 24784 end loop; 24785 24786 return False; 24787 end Within_Subprogram_Call; 24788 24789 ---------------- 24790 -- Wrong_Type -- 24791 ---------------- 24792 24793 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is 24794 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr)); 24795 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type); 24796 24797 Matching_Field : Entity_Id; 24798 -- Entity to give a more precise suggestion on how to write a one- 24799 -- element positional aggregate. 24800 24801 function Has_One_Matching_Field return Boolean; 24802 -- Determines if Expec_Type is a record type with a single component or 24803 -- discriminant whose type matches the found type or is one dimensional 24804 -- array whose component type matches the found type. In the case of 24805 -- one discriminant, we ignore the variant parts. That's not accurate, 24806 -- but good enough for the warning. 24807 24808 ---------------------------- 24809 -- Has_One_Matching_Field -- 24810 ---------------------------- 24811 24812 function Has_One_Matching_Field return Boolean is 24813 E : Entity_Id; 24814 24815 begin 24816 Matching_Field := Empty; 24817 24818 if Is_Array_Type (Expec_Type) 24819 and then Number_Dimensions (Expec_Type) = 1 24820 and then Covers (Etype (Component_Type (Expec_Type)), Found_Type) 24821 then 24822 -- Use type name if available. This excludes multidimensional 24823 -- arrays and anonymous arrays. 24824 24825 if Comes_From_Source (Expec_Type) then 24826 Matching_Field := Expec_Type; 24827 24828 -- For an assignment, use name of target 24829 24830 elsif Nkind (Parent (Expr)) = N_Assignment_Statement 24831 and then Is_Entity_Name (Name (Parent (Expr))) 24832 then 24833 Matching_Field := Entity (Name (Parent (Expr))); 24834 end if; 24835 24836 return True; 24837 24838 elsif not Is_Record_Type (Expec_Type) then 24839 return False; 24840 24841 else 24842 E := First_Entity (Expec_Type); 24843 loop 24844 if No (E) then 24845 return False; 24846 24847 elsif not Ekind_In (E, E_Discriminant, E_Component) 24848 or else Nam_In (Chars (E), Name_uTag, Name_uParent) 24849 then 24850 Next_Entity (E); 24851 24852 else 24853 exit; 24854 end if; 24855 end loop; 24856 24857 if not Covers (Etype (E), Found_Type) then 24858 return False; 24859 24860 elsif Present (Next_Entity (E)) 24861 and then (Ekind (E) = E_Component 24862 or else Ekind (Next_Entity (E)) = E_Discriminant) 24863 then 24864 return False; 24865 24866 else 24867 Matching_Field := E; 24868 return True; 24869 end if; 24870 end if; 24871 end Has_One_Matching_Field; 24872 24873 -- Start of processing for Wrong_Type 24874 24875 begin 24876 -- Don't output message if either type is Any_Type, or if a message 24877 -- has already been posted for this node. We need to do the latter 24878 -- check explicitly (it is ordinarily done in Errout), because we 24879 -- are using ! to force the output of the error messages. 24880 24881 if Expec_Type = Any_Type 24882 or else Found_Type = Any_Type 24883 or else Error_Posted (Expr) 24884 then 24885 return; 24886 24887 -- If one of the types is a Taft-Amendment type and the other it its 24888 -- completion, it must be an illegal use of a TAT in the spec, for 24889 -- which an error was already emitted. Avoid cascaded errors. 24890 24891 elsif Is_Incomplete_Type (Expec_Type) 24892 and then Has_Completion_In_Body (Expec_Type) 24893 and then Full_View (Expec_Type) = Etype (Expr) 24894 then 24895 return; 24896 24897 elsif Is_Incomplete_Type (Etype (Expr)) 24898 and then Has_Completion_In_Body (Etype (Expr)) 24899 and then Full_View (Etype (Expr)) = Expec_Type 24900 then 24901 return; 24902 24903 -- In an instance, there is an ongoing problem with completion of 24904 -- type derived from private types. Their structure is what Gigi 24905 -- expects, but the Etype is the parent type rather than the 24906 -- derived private type itself. Do not flag error in this case. The 24907 -- private completion is an entity without a parent, like an Itype. 24908 -- Similarly, full and partial views may be incorrect in the instance. 24909 -- There is no simple way to insure that it is consistent ??? 24910 24911 -- A similar view discrepancy can happen in an inlined body, for the 24912 -- same reason: inserted body may be outside of the original package 24913 -- and only partial views are visible at the point of insertion. 24914 24915 elsif In_Instance or else In_Inlined_Body then 24916 if Etype (Etype (Expr)) = Etype (Expected_Type) 24917 and then 24918 (Has_Private_Declaration (Expected_Type) 24919 or else Has_Private_Declaration (Etype (Expr))) 24920 and then No (Parent (Expected_Type)) 24921 then 24922 return; 24923 24924 elsif Nkind (Parent (Expr)) = N_Qualified_Expression 24925 and then Entity (Subtype_Mark (Parent (Expr))) = Expected_Type 24926 then 24927 return; 24928 24929 elsif Is_Private_Type (Expected_Type) 24930 and then Present (Full_View (Expected_Type)) 24931 and then Covers (Full_View (Expected_Type), Etype (Expr)) 24932 then 24933 return; 24934 24935 -- Conversely, type of expression may be the private one 24936 24937 elsif Is_Private_Type (Base_Type (Etype (Expr))) 24938 and then Full_View (Base_Type (Etype (Expr))) = Expected_Type 24939 then 24940 return; 24941 end if; 24942 end if; 24943 24944 -- An interesting special check. If the expression is parenthesized 24945 -- and its type corresponds to the type of the sole component of the 24946 -- expected record type, or to the component type of the expected one 24947 -- dimensional array type, then assume we have a bad aggregate attempt. 24948 24949 if Nkind (Expr) in N_Subexpr 24950 and then Paren_Count (Expr) /= 0 24951 and then Has_One_Matching_Field 24952 then 24953 Error_Msg_N ("positional aggregate cannot have one component", Expr); 24954 24955 if Present (Matching_Field) then 24956 if Is_Array_Type (Expec_Type) then 24957 Error_Msg_NE 24958 ("\write instead `&''First ='> ...`", Expr, Matching_Field); 24959 else 24960 Error_Msg_NE 24961 ("\write instead `& ='> ...`", Expr, Matching_Field); 24962 end if; 24963 end if; 24964 24965 -- Another special check, if we are looking for a pool-specific access 24966 -- type and we found an E_Access_Attribute_Type, then we have the case 24967 -- of an Access attribute being used in a context which needs a pool- 24968 -- specific type, which is never allowed. The one extra check we make 24969 -- is that the expected designated type covers the Found_Type. 24970 24971 elsif Is_Access_Type (Expec_Type) 24972 and then Ekind (Found_Type) = E_Access_Attribute_Type 24973 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type 24974 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type 24975 and then Covers 24976 (Designated_Type (Expec_Type), Designated_Type (Found_Type)) 24977 then 24978 Error_Msg_N -- CODEFIX 24979 ("result must be general access type!", Expr); 24980 Error_Msg_NE -- CODEFIX 24981 ("add ALL to }!", Expr, Expec_Type); 24982 24983 -- Another special check, if the expected type is an integer type, 24984 -- but the expression is of type System.Address, and the parent is 24985 -- an addition or subtraction operation whose left operand is the 24986 -- expression in question and whose right operand is of an integral 24987 -- type, then this is an attempt at address arithmetic, so give 24988 -- appropriate message. 24989 24990 elsif Is_Integer_Type (Expec_Type) 24991 and then Is_RTE (Found_Type, RE_Address) 24992 and then Nkind_In (Parent (Expr), N_Op_Add, N_Op_Subtract) 24993 and then Expr = Left_Opnd (Parent (Expr)) 24994 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr)))) 24995 then 24996 Error_Msg_N 24997 ("address arithmetic not predefined in package System", 24998 Parent (Expr)); 24999 Error_Msg_N 25000 ("\possible missing with/use of System.Storage_Elements", 25001 Parent (Expr)); 25002 return; 25003 25004 -- If the expected type is an anonymous access type, as for access 25005 -- parameters and discriminants, the error is on the designated types. 25006 25007 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then 25008 if Comes_From_Source (Expec_Type) then 25009 Error_Msg_NE ("expected}!", Expr, Expec_Type); 25010 else 25011 Error_Msg_NE 25012 ("expected an access type with designated}", 25013 Expr, Designated_Type (Expec_Type)); 25014 end if; 25015 25016 if Is_Access_Type (Found_Type) 25017 and then not Comes_From_Source (Found_Type) 25018 then 25019 Error_Msg_NE 25020 ("\\found an access type with designated}!", 25021 Expr, Designated_Type (Found_Type)); 25022 else 25023 if From_Limited_With (Found_Type) then 25024 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); 25025 Error_Msg_Qual_Level := 99; 25026 Error_Msg_NE -- CODEFIX 25027 ("\\missing `WITH &;", Expr, Scope (Found_Type)); 25028 Error_Msg_Qual_Level := 0; 25029 else 25030 Error_Msg_NE ("found}!", Expr, Found_Type); 25031 end if; 25032 end if; 25033 25034 -- Normal case of one type found, some other type expected 25035 25036 else 25037 -- If the names of the two types are the same, see if some number 25038 -- of levels of qualification will help. Don't try more than three 25039 -- levels, and if we get to standard, it's no use (and probably 25040 -- represents an error in the compiler) Also do not bother with 25041 -- internal scope names. 25042 25043 declare 25044 Expec_Scope : Entity_Id; 25045 Found_Scope : Entity_Id; 25046 25047 begin 25048 Expec_Scope := Expec_Type; 25049 Found_Scope := Found_Type; 25050 25051 for Levels in Nat range 0 .. 3 loop 25052 if Chars (Expec_Scope) /= Chars (Found_Scope) then 25053 Error_Msg_Qual_Level := Levels; 25054 exit; 25055 end if; 25056 25057 Expec_Scope := Scope (Expec_Scope); 25058 Found_Scope := Scope (Found_Scope); 25059 25060 exit when Expec_Scope = Standard_Standard 25061 or else Found_Scope = Standard_Standard 25062 or else not Comes_From_Source (Expec_Scope) 25063 or else not Comes_From_Source (Found_Scope); 25064 end loop; 25065 end; 25066 25067 if Is_Record_Type (Expec_Type) 25068 and then Present (Corresponding_Remote_Type (Expec_Type)) 25069 then 25070 Error_Msg_NE ("expected}!", Expr, 25071 Corresponding_Remote_Type (Expec_Type)); 25072 else 25073 Error_Msg_NE ("expected}!", Expr, Expec_Type); 25074 end if; 25075 25076 if Is_Entity_Name (Expr) 25077 and then Is_Package_Or_Generic_Package (Entity (Expr)) 25078 then 25079 Error_Msg_N ("\\found package name!", Expr); 25080 25081 elsif Is_Entity_Name (Expr) 25082 and then Ekind_In (Entity (Expr), E_Procedure, E_Generic_Procedure) 25083 then 25084 if Ekind (Expec_Type) = E_Access_Subprogram_Type then 25085 Error_Msg_N 25086 ("found procedure name, possibly missing Access attribute!", 25087 Expr); 25088 else 25089 Error_Msg_N 25090 ("\\found procedure name instead of function!", Expr); 25091 end if; 25092 25093 elsif Nkind (Expr) = N_Function_Call 25094 and then Ekind (Expec_Type) = E_Access_Subprogram_Type 25095 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr) 25096 and then No (Parameter_Associations (Expr)) 25097 then 25098 Error_Msg_N 25099 ("found function name, possibly missing Access attribute!", 25100 Expr); 25101 25102 -- Catch common error: a prefix or infix operator which is not 25103 -- directly visible because the type isn't. 25104 25105 elsif Nkind (Expr) in N_Op 25106 and then Is_Overloaded (Expr) 25107 and then not Is_Immediately_Visible (Expec_Type) 25108 and then not Is_Potentially_Use_Visible (Expec_Type) 25109 and then not In_Use (Expec_Type) 25110 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type) 25111 then 25112 Error_Msg_N 25113 ("operator of the type is not directly visible!", Expr); 25114 25115 elsif Ekind (Found_Type) = E_Void 25116 and then Present (Parent (Found_Type)) 25117 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration 25118 then 25119 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type); 25120 25121 else 25122 Error_Msg_NE ("\\found}!", Expr, Found_Type); 25123 end if; 25124 25125 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are 25126 -- of the same modular type, and (M1 and M2) = 0 was intended. 25127 25128 if Expec_Type = Standard_Boolean 25129 and then Is_Modular_Integer_Type (Found_Type) 25130 and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor) 25131 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare 25132 then 25133 declare 25134 Op : constant Node_Id := Right_Opnd (Parent (Expr)); 25135 L : constant Node_Id := Left_Opnd (Op); 25136 R : constant Node_Id := Right_Opnd (Op); 25137 25138 begin 25139 -- The case for the message is when the left operand of the 25140 -- comparison is the same modular type, or when it is an 25141 -- integer literal (or other universal integer expression), 25142 -- which would have been typed as the modular type if the 25143 -- parens had been there. 25144 25145 if (Etype (L) = Found_Type 25146 or else 25147 Etype (L) = Universal_Integer) 25148 and then Is_Integer_Type (Etype (R)) 25149 then 25150 Error_Msg_N 25151 ("\\possible missing parens for modular operation", Expr); 25152 end if; 25153 end; 25154 end if; 25155 25156 -- Reset error message qualification indication 25157 25158 Error_Msg_Qual_Level := 0; 25159 end if; 25160 end Wrong_Type; 25161 25162 -------------------------------- 25163 -- Yields_Synchronized_Object -- 25164 -------------------------------- 25165 25166 function Yields_Synchronized_Object (Typ : Entity_Id) return Boolean is 25167 Has_Sync_Comp : Boolean := False; 25168 Id : Entity_Id; 25169 25170 begin 25171 -- An array type yields a synchronized object if its component type 25172 -- yields a synchronized object. 25173 25174 if Is_Array_Type (Typ) then 25175 return Yields_Synchronized_Object (Component_Type (Typ)); 25176 25177 -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object 25178 -- yields a synchronized object by default. 25179 25180 elsif Is_Descendant_Of_Suspension_Object (Typ) then 25181 return True; 25182 25183 -- A protected type yields a synchronized object by default 25184 25185 elsif Is_Protected_Type (Typ) then 25186 return True; 25187 25188 -- A record type or type extension yields a synchronized object when its 25189 -- discriminants (if any) lack default values and all components are of 25190 -- a type that yelds a synchronized object. 25191 25192 elsif Is_Record_Type (Typ) then 25193 25194 -- Inspect all entities defined in the scope of the type, looking for 25195 -- components of a type that does not yeld a synchronized object or 25196 -- for discriminants with default values. 25197 25198 Id := First_Entity (Typ); 25199 while Present (Id) loop 25200 if Comes_From_Source (Id) then 25201 if Ekind (Id) = E_Component then 25202 if Yields_Synchronized_Object (Etype (Id)) then 25203 Has_Sync_Comp := True; 25204 25205 -- The component does not yield a synchronized object 25206 25207 else 25208 return False; 25209 end if; 25210 25211 elsif Ekind (Id) = E_Discriminant 25212 and then Present (Expression (Parent (Id))) 25213 then 25214 return False; 25215 end if; 25216 end if; 25217 25218 Next_Entity (Id); 25219 end loop; 25220 25221 -- Ensure that the parent type of a type extension yields a 25222 -- synchronized object. 25223 25224 if Etype (Typ) /= Typ 25225 and then not Yields_Synchronized_Object (Etype (Typ)) 25226 then 25227 return False; 25228 end if; 25229 25230 -- If we get here, then all discriminants lack default values and all 25231 -- components are of a type that yields a synchronized object. 25232 25233 return Has_Sync_Comp; 25234 25235 -- A synchronized interface type yields a synchronized object by default 25236 25237 elsif Is_Synchronized_Interface (Typ) then 25238 return True; 25239 25240 -- A task type yelds a synchronized object by default 25241 25242 elsif Is_Task_Type (Typ) then 25243 return True; 25244 25245 -- Otherwise the type does not yield a synchronized object 25246 25247 else 25248 return False; 25249 end if; 25250 end Yields_Synchronized_Object; 25251 25252 --------------------------- 25253 -- Yields_Universal_Type -- 25254 --------------------------- 25255 25256 function Yields_Universal_Type (N : Node_Id) return Boolean is 25257 begin 25258 -- Integer and real literals are of a universal type 25259 25260 if Nkind_In (N, N_Integer_Literal, N_Real_Literal) then 25261 return True; 25262 25263 -- The values of certain attributes are of a universal type 25264 25265 elsif Nkind (N) = N_Attribute_Reference then 25266 return 25267 Universal_Type_Attribute (Get_Attribute_Id (Attribute_Name (N))); 25268 25269 -- ??? There are possibly other cases to consider 25270 25271 else 25272 return False; 25273 end if; 25274 end Yields_Universal_Type; 25275 25276begin 25277 Erroutc.Subprogram_Name_Ptr := Subprogram_Name'Access; 25278end Sem_Util; 25279