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-2021, 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 Casing; use Casing; 27with Checks; use Checks; 28with Debug; use Debug; 29with Einfo.Utils; use Einfo.Utils; 30with Elists; use Elists; 31with Errout; use Errout; 32with Erroutc; use Erroutc; 33with Exp_Ch3; use Exp_Ch3; 34with Exp_Ch11; use Exp_Ch11; 35with Exp_Util; use Exp_Util; 36with Fname; use Fname; 37with Freeze; use Freeze; 38with Itypes; use Itypes; 39with Lib; use Lib; 40with Lib.Xref; use Lib.Xref; 41with Namet.Sp; use Namet.Sp; 42with Nlists; use Nlists; 43with Nmake; use Nmake; 44with Output; use Output; 45with Restrict; use Restrict; 46with Rident; use Rident; 47with Rtsfind; use Rtsfind; 48with Sem; use Sem; 49with Sem_Aux; use Sem_Aux; 50with Sem_Attr; use Sem_Attr; 51with Sem_Cat; use Sem_Cat; 52with Sem_Ch6; use Sem_Ch6; 53with Sem_Ch8; use Sem_Ch8; 54with Sem_Ch13; use Sem_Ch13; 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 Sinfo.Nodes; use Sinfo.Nodes; 64with Sinfo.Utils; use Sinfo.Utils; 65with Sinput; use Sinput; 66with Stand; use Stand; 67with Style; 68with Stringt; use Stringt; 69with Targparm; use Targparm; 70with Tbuild; use Tbuild; 71with Ttypes; use Ttypes; 72with Uname; use Uname; 73 74with GNAT.Heap_Sort_G; 75with GNAT.HTable; use GNAT.HTable; 76 77package body Sem_Util is 78 79 --------------------------- 80 -- Local Data Structures -- 81 --------------------------- 82 83 Invalid_Binder_Values : array (Scalar_Id) of Entity_Id := (others => Empty); 84 -- A collection to hold the entities of the variables declared in package 85 -- System.Scalar_Values which describe the invalid values of scalar types. 86 87 Invalid_Binder_Values_Set : Boolean := False; 88 -- This flag prevents multiple attempts to initialize Invalid_Binder_Values 89 90 Invalid_Floats : array (Float_Scalar_Id) of Ureal := (others => No_Ureal); 91 -- A collection to hold the invalid values of float types as specified by 92 -- pragma Initialize_Scalars. 93 94 Invalid_Integers : array (Integer_Scalar_Id) of Uint := (others => No_Uint); 95 -- A collection to hold the invalid values of integer types as specified 96 -- by pragma Initialize_Scalars. 97 98 ----------------------- 99 -- Local Subprograms -- 100 ----------------------- 101 102 function Build_Component_Subtype 103 (C : List_Id; 104 Loc : Source_Ptr; 105 T : Entity_Id) return Node_Id; 106 -- This function builds the subtype for Build_Actual_Subtype_Of_Component 107 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints, 108 -- Loc is the source location, T is the original subtype. 109 110 procedure Examine_Array_Bounds 111 (Typ : Entity_Id; 112 All_Static : out Boolean; 113 Has_Empty : out Boolean); 114 -- Inspect the index constraints of array type Typ. Flag All_Static is set 115 -- when all ranges are static. Flag Has_Empty is set only when All_Static 116 -- is set and indicates that at least one range is empty. 117 118 function Has_Enabled_Property 119 (Item_Id : Entity_Id; 120 Property : Name_Id) return Boolean; 121 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled. 122 -- Determine whether the state abstraction, object, or type denoted by 123 -- entity Item_Id has enabled property Property. 124 125 function Has_Null_Extension (T : Entity_Id) return Boolean; 126 -- T is a derived tagged type. Check whether the type extension is null. 127 -- If the parent type is fully initialized, T can be treated as such. 128 129 function Is_Atomic_Object_Entity (Id : Entity_Id) return Boolean; 130 -- Determine whether arbitrary entity Id denotes an atomic object as per 131 -- RM C.6(7). 132 133 function Is_Container_Aggregate (Exp : Node_Id) return Boolean; 134 -- Is the given expression a container aggregate? 135 136 generic 137 with function Is_Effectively_Volatile_Entity 138 (Id : Entity_Id) return Boolean; 139 -- Function to use on object and type entities 140 function Is_Effectively_Volatile_Object_Shared 141 (N : Node_Id) return Boolean; 142 -- Shared function used to detect effectively volatile objects and 143 -- effectively volatile objects for reading. 144 145 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean; 146 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type 147 -- with discriminants whose default values are static, examine only the 148 -- components in the selected variant to determine whether all of them 149 -- have a default. 150 151 function Is_Preelaborable_Function (Id : Entity_Id) return Boolean; 152 -- Ada 2022: Determine whether the specified function is suitable as the 153 -- name of a call in a preelaborable construct (RM 10.2.1(7/5)). 154 155 type Null_Status_Kind is 156 (Is_Null, 157 -- This value indicates that a subexpression is known to have a null 158 -- value at compile time. 159 160 Is_Non_Null, 161 -- This value indicates that a subexpression is known to have a non-null 162 -- value at compile time. 163 164 Unknown); 165 -- This value indicates that it cannot be determined at compile time 166 -- whether a subexpression yields a null or non-null value. 167 168 function Null_Status (N : Node_Id) return Null_Status_Kind; 169 -- Determine whether subexpression N of an access type yields a null value, 170 -- a non-null value, or the value cannot be determined at compile time. The 171 -- routine does not take simple flow diagnostics into account, it relies on 172 -- static facts such as the presence of null exclusions. 173 174 function Subprogram_Name (N : Node_Id) return String; 175 -- Return the fully qualified name of the enclosing subprogram for the 176 -- given node N, with file:line:col information appended, e.g. 177 -- "subp:file:line:col", corresponding to the source location of the 178 -- body of the subprogram. 179 180 ----------------------------- 181 -- Abstract_Interface_List -- 182 ----------------------------- 183 184 function Abstract_Interface_List (Typ : Entity_Id) return List_Id is 185 Nod : Node_Id; 186 187 begin 188 if Is_Concurrent_Type (Typ) then 189 190 -- If we are dealing with a synchronized subtype, go to the base 191 -- type, whose declaration has the interface list. 192 193 Nod := Declaration_Node (Base_Type (Typ)); 194 195 if Nkind (Nod) in N_Full_Type_Declaration | N_Private_Type_Declaration 196 then 197 return Empty_List; 198 end if; 199 200 elsif Ekind (Typ) = E_Record_Type_With_Private then 201 if Nkind (Parent (Typ)) = N_Full_Type_Declaration then 202 Nod := Type_Definition (Parent (Typ)); 203 204 elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then 205 if Present (Full_View (Typ)) 206 and then 207 Nkind (Parent (Full_View (Typ))) = N_Full_Type_Declaration 208 then 209 Nod := Type_Definition (Parent (Full_View (Typ))); 210 211 -- If the full-view is not available we cannot do anything else 212 -- here (the source has errors). 213 214 else 215 return Empty_List; 216 end if; 217 218 -- Support for generic formals with interfaces is still missing ??? 219 220 elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then 221 return Empty_List; 222 223 else 224 pragma Assert 225 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration); 226 Nod := Parent (Typ); 227 end if; 228 229 elsif Ekind (Typ) = E_Record_Subtype then 230 Nod := Type_Definition (Parent (Etype (Typ))); 231 232 elsif Ekind (Typ) = E_Record_Subtype_With_Private then 233 234 -- Recurse, because parent may still be a private extension. Also 235 -- note that the full view of the subtype or the full view of its 236 -- base type may (both) be unavailable. 237 238 return Abstract_Interface_List (Etype (Typ)); 239 240 elsif Ekind (Typ) = E_Record_Type then 241 if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then 242 Nod := Formal_Type_Definition (Parent (Typ)); 243 else 244 Nod := Type_Definition (Parent (Typ)); 245 end if; 246 247 -- Otherwise the type is of a kind which does not implement interfaces 248 249 else 250 return Empty_List; 251 end if; 252 253 return Interface_List (Nod); 254 end Abstract_Interface_List; 255 256 ------------------------- 257 -- Accessibility_Level -- 258 ------------------------- 259 260 function Accessibility_Level 261 (Expr : Node_Id; 262 Level : Accessibility_Level_Kind; 263 In_Return_Context : Boolean := False; 264 Allow_Alt_Model : Boolean := True) return Node_Id 265 is 266 Loc : constant Source_Ptr := Sloc (Expr); 267 268 function Accessibility_Level (Expr : Node_Id) return Node_Id 269 is (Accessibility_Level (Expr, Level, In_Return_Context)); 270 -- Renaming of the enclosing function to facilitate recursive calls 271 272 function Make_Level_Literal (Level : Uint) return Node_Id; 273 -- Construct an integer literal representing an accessibility level 274 -- with its type set to Natural. 275 276 function Innermost_Master_Scope_Depth (N : Node_Id) return Uint; 277 -- Returns the scope depth of the given node's innermost 278 -- enclosing dynamic scope (effectively the accessibility 279 -- level of the innermost enclosing master). 280 281 function Function_Call_Or_Allocator_Level (N : Node_Id) return Node_Id; 282 -- Centralized processing of subprogram calls which may appear in 283 -- prefix notation. 284 285 function Typ_Access_Level (Typ : Entity_Id) return Uint 286 is (Type_Access_Level (Typ, Allow_Alt_Model)); 287 -- Renaming of Type_Access_Level with Allow_Alt_Model specified to avoid 288 -- passing the parameter specifically in every call. 289 290 ---------------------------------- 291 -- Innermost_Master_Scope_Depth -- 292 ---------------------------------- 293 294 function Innermost_Master_Scope_Depth (N : Node_Id) return Uint is 295 Encl_Scop : Entity_Id; 296 Ent : Entity_Id; 297 Node_Par : Node_Id := Parent (N); 298 Master_Lvl_Modifier : Int := 0; 299 300 begin 301 -- Locate the nearest enclosing node (by traversing Parents) 302 -- that Defining_Entity can be applied to, and return the 303 -- depth of that entity's nearest enclosing dynamic scope. 304 305 -- The rules that define what a master are defined in 306 -- RM 7.6.1 (3), and include statements and conditions for loops 307 -- among other things. These cases are detected properly ??? 308 309 while Present (Node_Par) loop 310 Ent := Defining_Entity_Or_Empty (Node_Par); 311 312 if Present (Ent) then 313 Encl_Scop := Nearest_Dynamic_Scope (Ent); 314 315 -- Ignore transient scopes made during expansion 316 317 if Comes_From_Source (Node_Par) then 318 return 319 Scope_Depth_Default_0 (Encl_Scop) + Master_Lvl_Modifier; 320 end if; 321 322 -- For a return statement within a function, return 323 -- the depth of the function itself. This is not just 324 -- a small optimization, but matters when analyzing 325 -- the expression in an expression function before 326 -- the body is created. 327 328 elsif Nkind (Node_Par) in N_Extended_Return_Statement 329 | N_Simple_Return_Statement 330 and then Ekind (Current_Scope) = E_Function 331 then 332 return Scope_Depth (Current_Scope); 333 334 -- Statements are counted as masters 335 336 elsif Is_Master (Node_Par) then 337 Master_Lvl_Modifier := Master_Lvl_Modifier + 1; 338 339 end if; 340 341 Node_Par := Parent (Node_Par); 342 end loop; 343 344 -- Should never reach the following return 345 346 pragma Assert (False); 347 348 return Scope_Depth (Current_Scope) + 1; 349 end Innermost_Master_Scope_Depth; 350 351 ------------------------ 352 -- Make_Level_Literal -- 353 ------------------------ 354 355 function Make_Level_Literal (Level : Uint) return Node_Id is 356 Result : constant Node_Id := Make_Integer_Literal (Loc, Level); 357 358 begin 359 Set_Etype (Result, Standard_Natural); 360 return Result; 361 end Make_Level_Literal; 362 363 -------------------------------------- 364 -- Function_Call_Or_Allocator_Level -- 365 -------------------------------------- 366 367 function Function_Call_Or_Allocator_Level (N : Node_Id) return Node_Id is 368 Par : Node_Id; 369 Prev_Par : Node_Id; 370 begin 371 -- Results of functions are objects, so we either get the 372 -- accessibility of the function or, in case of a call which is 373 -- indirect, the level of the access-to-subprogram type. 374 375 -- This code looks wrong ??? 376 377 if Nkind (N) = N_Function_Call 378 and then Ada_Version < Ada_2005 379 then 380 if Is_Entity_Name (Name (N)) then 381 return Make_Level_Literal 382 (Subprogram_Access_Level (Entity (Name (N)))); 383 else 384 return Make_Level_Literal 385 (Typ_Access_Level (Etype (Prefix (Name (N))))); 386 end if; 387 388 -- We ignore coextensions as they cannot be implemented under the 389 -- "small-integer" model. 390 391 elsif Nkind (N) = N_Allocator 392 and then (Is_Static_Coextension (N) 393 or else Is_Dynamic_Coextension (N)) 394 then 395 return Make_Level_Literal (Scope_Depth (Standard_Standard)); 396 end if; 397 398 -- Named access types have a designated level 399 400 if Is_Named_Access_Type (Etype (N)) then 401 return Make_Level_Literal (Typ_Access_Level (Etype (N))); 402 403 -- Otherwise, the level is dictated by RM 3.10.2 (10.7/3) 404 405 else 406 -- Check No_Dynamic_Accessibility_Checks restriction override for 407 -- alternative accessibility model. 408 409 if Allow_Alt_Model 410 and then No_Dynamic_Accessibility_Checks_Enabled (N) 411 and then Is_Anonymous_Access_Type (Etype (N)) 412 then 413 -- In the alternative model the level is that of the 414 -- designated type. 415 416 if Debug_Flag_Underscore_B then 417 return Make_Level_Literal (Typ_Access_Level (Etype (N))); 418 419 -- For function calls the level is that of the innermost 420 -- master, otherwise (for allocators etc.) we get the level 421 -- of the corresponding anonymous access type, which is 422 -- calculated through the normal path of execution. 423 424 elsif Nkind (N) = N_Function_Call then 425 return Make_Level_Literal 426 (Innermost_Master_Scope_Depth (Expr)); 427 end if; 428 end if; 429 430 if Nkind (N) = N_Function_Call then 431 -- Dynamic checks are generated when we are within a return 432 -- value or we are in a function call within an anonymous 433 -- access discriminant constraint of a return object (signified 434 -- by In_Return_Context) on the side of the callee. 435 436 -- So, in this case, return accessibility level of the 437 -- enclosing subprogram. 438 439 if In_Return_Value (N) 440 or else In_Return_Context 441 then 442 return Make_Level_Literal 443 (Subprogram_Access_Level (Current_Subprogram)); 444 end if; 445 end if; 446 447 -- When the call is being dereferenced the level is that of the 448 -- enclosing master of the dereferenced call. 449 450 if Nkind (Parent (N)) in N_Explicit_Dereference 451 | N_Indexed_Component 452 | N_Selected_Component 453 then 454 return Make_Level_Literal 455 (Innermost_Master_Scope_Depth (Expr)); 456 end if; 457 458 -- Find any relevant enclosing parent nodes that designate an 459 -- object being initialized. 460 461 -- Note: The above is only relevant if the result is used "in its 462 -- entirety" as RM 3.10.2 (10.2/3) states. However, this is 463 -- accounted for in the case statement in the main body of 464 -- Accessibility_Level for N_Selected_Component. 465 466 Par := Parent (Expr); 467 Prev_Par := Empty; 468 while Present (Par) loop 469 -- Detect an expanded implicit conversion, typically this 470 -- occurs on implicitly converted actuals in calls. 471 472 -- Does this catch all implicit conversions ??? 473 474 if Nkind (Par) = N_Type_Conversion 475 and then Is_Named_Access_Type (Etype (Par)) 476 then 477 return Make_Level_Literal 478 (Typ_Access_Level (Etype (Par))); 479 end if; 480 481 -- Jump out when we hit an object declaration or the right-hand 482 -- side of an assignment, or a construct such as an aggregate 483 -- subtype indication which would be the result is not used 484 -- "in its entirety." 485 486 exit when Nkind (Par) in N_Object_Declaration 487 or else (Nkind (Par) = N_Assignment_Statement 488 and then Name (Par) /= Prev_Par); 489 490 Prev_Par := Par; 491 Par := Parent (Par); 492 end loop; 493 494 -- Assignment statements are handled in a similar way in 495 -- accordance to the left-hand part. However, strictly speaking, 496 -- this is illegal according to the RM, but this change is needed 497 -- to pass an ACATS C-test and is useful in general ??? 498 499 case Nkind (Par) is 500 when N_Object_Declaration => 501 return Make_Level_Literal 502 (Scope_Depth 503 (Scope (Defining_Identifier (Par)))); 504 505 when N_Assignment_Statement => 506 -- Return the accessiblity level of the left-hand part 507 508 return Accessibility_Level 509 (Expr => Name (Par), 510 Level => Object_Decl_Level, 511 In_Return_Context => In_Return_Context); 512 513 when others => 514 return Make_Level_Literal 515 (Innermost_Master_Scope_Depth (Expr)); 516 end case; 517 end if; 518 end Function_Call_Or_Allocator_Level; 519 520 -- Local variables 521 522 E : Entity_Id := Original_Node (Expr); 523 Pre : Node_Id; 524 525 -- Start of processing for Accessibility_Level 526 527 begin 528 -- We could be looking at a reference to a formal due to the expansion 529 -- of entries and other cases, so obtain the renaming if necessary. 530 531 if Present (Param_Entity (Expr)) then 532 E := Param_Entity (Expr); 533 end if; 534 535 -- Extract the entity 536 537 if Nkind (E) in N_Has_Entity and then Present (Entity (E)) then 538 E := Entity (E); 539 540 -- Deal with a possible renaming of a private protected component 541 542 if Ekind (E) in E_Constant | E_Variable and then Is_Prival (E) then 543 E := Prival_Link (E); 544 end if; 545 end if; 546 547 -- Perform the processing on the expression 548 549 case Nkind (E) is 550 -- The level of an aggregate is that of the innermost master that 551 -- evaluates it as defined in RM 3.10.2 (10/4). 552 553 when N_Aggregate => 554 return Make_Level_Literal (Innermost_Master_Scope_Depth (Expr)); 555 556 -- The accessibility level is that of the access type, except for an 557 -- anonymous allocators which have special rules defined in RM 3.10.2 558 -- (14/3). 559 560 when N_Allocator => 561 return Function_Call_Or_Allocator_Level (E); 562 563 -- We could reach this point for two reasons. Either the expression 564 -- applies to a special attribute ('Loop_Entry, 'Result, or 'Old), or 565 -- we are looking at the access attributes directly ('Access, 566 -- 'Address, or 'Unchecked_Access). 567 568 when N_Attribute_Reference => 569 Pre := Original_Node (Prefix (E)); 570 571 -- Regular 'Access attribute presence means we have to look at the 572 -- prefix. 573 574 if Attribute_Name (E) = Name_Access then 575 return Accessibility_Level (Prefix (E)); 576 577 -- Unchecked or unrestricted attributes have unlimited depth 578 579 elsif Attribute_Name (E) in Name_Address 580 | Name_Unchecked_Access 581 | Name_Unrestricted_Access 582 then 583 return Make_Level_Literal (Scope_Depth (Standard_Standard)); 584 585 -- 'Access can be taken further against other special attributes, 586 -- so handle these cases explicitly. 587 588 elsif Attribute_Name (E) 589 in Name_Old | Name_Loop_Entry | Name_Result 590 then 591 -- Named access types 592 593 if Is_Named_Access_Type (Etype (Pre)) then 594 return Make_Level_Literal 595 (Typ_Access_Level (Etype (Pre))); 596 597 -- Anonymous access types 598 599 elsif Nkind (Pre) in N_Has_Entity 600 and then Present (Get_Dynamic_Accessibility (Entity (Pre))) 601 and then Level = Dynamic_Level 602 then 603 return New_Occurrence_Of 604 (Get_Dynamic_Accessibility (Entity (Pre)), Loc); 605 606 -- Otherwise the level is treated in a similar way as 607 -- aggregates according to RM 6.1.1 (35.1/4) which concerns 608 -- an implicit constant declaration - in turn defining the 609 -- accessibility level to be that of the implicit constant 610 -- declaration. 611 612 else 613 return Make_Level_Literal 614 (Innermost_Master_Scope_Depth (Expr)); 615 end if; 616 617 else 618 raise Program_Error; 619 end if; 620 621 -- This is the "base case" for accessibility level calculations which 622 -- means we are near the end of our recursive traversal. 623 624 when N_Defining_Identifier => 625 -- A dynamic check is performed on the side of the callee when we 626 -- are within a return statement, so return a library-level 627 -- accessibility level to null out checks on the side of the 628 -- caller. 629 630 if Is_Explicitly_Aliased (E) 631 and then (In_Return_Context 632 or else (Level /= Dynamic_Level 633 and then In_Return_Value (Expr))) 634 then 635 return Make_Level_Literal (Scope_Depth (Standard_Standard)); 636 637 -- Something went wrong and an extra accessibility formal has not 638 -- been generated when one should have ??? 639 640 elsif Is_Formal (E) 641 and then not Present (Get_Dynamic_Accessibility (E)) 642 and then Ekind (Etype (E)) = E_Anonymous_Access_Type 643 then 644 return Make_Level_Literal (Scope_Depth (Standard_Standard)); 645 646 -- Stand-alone object of an anonymous access type "SAOAAT" 647 648 elsif (Is_Formal (E) 649 or else Ekind (E) in E_Variable 650 | E_Constant) 651 and then Present (Get_Dynamic_Accessibility (E)) 652 and then (Level = Dynamic_Level 653 or else Level = Zero_On_Dynamic_Level) 654 then 655 if Level = Zero_On_Dynamic_Level then 656 return Make_Level_Literal 657 (Scope_Depth (Standard_Standard)); 658 end if; 659 660 -- No_Dynamic_Accessibility_Checks restriction override for 661 -- alternative accessibility model. 662 663 if Allow_Alt_Model 664 and then No_Dynamic_Accessibility_Checks_Enabled (E) 665 then 666 -- In the alternative model the level is that of the 667 -- designated type entity's context. 668 669 if Debug_Flag_Underscore_B then 670 return Make_Level_Literal (Typ_Access_Level (Etype (E))); 671 672 -- Otherwise the level depends on the entity's context 673 674 elsif Is_Formal (E) then 675 return Make_Level_Literal 676 (Subprogram_Access_Level 677 (Enclosing_Subprogram (E))); 678 else 679 return Make_Level_Literal 680 (Scope_Depth (Enclosing_Dynamic_Scope (E))); 681 end if; 682 end if; 683 684 -- Return the dynamic level in the normal case 685 686 return New_Occurrence_Of 687 (Get_Dynamic_Accessibility (E), Loc); 688 689 -- Initialization procedures have a special extra accessibility 690 -- parameter associated with the level at which the object 691 -- being initialized exists 692 693 elsif Ekind (E) = E_Record_Type 694 and then Is_Limited_Record (E) 695 and then Current_Scope = Init_Proc (E) 696 and then Present (Init_Proc_Level_Formal (Current_Scope)) 697 then 698 return New_Occurrence_Of 699 (Init_Proc_Level_Formal (Current_Scope), Loc); 700 701 -- Current instance of the type is deeper than that of the type 702 -- according to RM 3.10.2 (21). 703 704 elsif Is_Type (E) then 705 -- When restriction No_Dynamic_Accessibility_Checks is active 706 -- along with -gnatd_b. 707 708 if Allow_Alt_Model 709 and then No_Dynamic_Accessibility_Checks_Enabled (E) 710 and then Debug_Flag_Underscore_B 711 then 712 return Make_Level_Literal (Typ_Access_Level (E)); 713 end if; 714 715 -- Normal path 716 717 return Make_Level_Literal (Typ_Access_Level (E) + 1); 718 719 -- Move up the renamed entity or object if it came from source 720 -- since expansion may have created a dummy renaming under 721 -- certain circumstances. 722 723 -- Note: We check if the original node of the renaming comes 724 -- from source because the node may have been rewritten. 725 726 elsif Present (Renamed_Entity_Or_Object (E)) 727 and then Comes_From_Source 728 (Original_Node (Renamed_Entity_Or_Object (E))) 729 then 730 return Accessibility_Level (Renamed_Entity_Or_Object (E)); 731 732 -- Named access types get their level from their associated type 733 734 elsif Is_Named_Access_Type (Etype (E)) then 735 return Make_Level_Literal 736 (Typ_Access_Level (Etype (E))); 737 738 -- Check if E is an expansion-generated renaming of an iterator 739 -- by examining Related_Expression. If so, determine the 740 -- accessibility level based on the original expression. 741 742 elsif Ekind (E) in E_Constant | E_Variable 743 and then Present (Related_Expression (E)) 744 then 745 return Accessibility_Level (Related_Expression (E)); 746 747 elsif Level = Dynamic_Level 748 and then Ekind (E) in E_In_Parameter | E_In_Out_Parameter 749 and then Present (Init_Proc_Level_Formal (Scope (E))) 750 then 751 return New_Occurrence_Of 752 (Init_Proc_Level_Formal (Scope (E)), Loc); 753 754 -- Normal object - get the level of the enclosing scope 755 756 else 757 return Make_Level_Literal 758 (Scope_Depth (Enclosing_Dynamic_Scope (E))); 759 end if; 760 761 -- Handle indexed and selected components including the special cases 762 -- whereby there is an implicit dereference, a component of a 763 -- composite type, or a function call in prefix notation. 764 765 -- We don't handle function calls in prefix notation correctly ??? 766 767 when N_Indexed_Component | N_Selected_Component => 768 Pre := Original_Node (Prefix (E)); 769 770 -- When E is an indexed component or selected component and 771 -- the current Expr is a function call, we know that we are 772 -- looking at an expanded call in prefix notation. 773 774 if Nkind (Expr) = N_Function_Call then 775 return Function_Call_Or_Allocator_Level (Expr); 776 777 -- If the prefix is a named access type, then we are dealing 778 -- with an implicit deferences. In that case the level is that 779 -- of the named access type in the prefix. 780 781 elsif Is_Named_Access_Type (Etype (Pre)) then 782 return Make_Level_Literal 783 (Typ_Access_Level (Etype (Pre))); 784 785 -- The current expression is a named access type, so there is no 786 -- reason to look at the prefix. Instead obtain the level of E's 787 -- named access type. 788 789 elsif Is_Named_Access_Type (Etype (E)) then 790 return Make_Level_Literal 791 (Typ_Access_Level (Etype (E))); 792 793 -- A nondiscriminant selected component where the component 794 -- is an anonymous access type means that its associated 795 -- level is that of the containing type - see RM 3.10.2 (16). 796 797 -- Note that when restriction No_Dynamic_Accessibility_Checks is 798 -- in effect we treat discriminant components as regular 799 -- components. 800 801 elsif Nkind (E) = N_Selected_Component 802 and then Ekind (Etype (E)) = E_Anonymous_Access_Type 803 and then Ekind (Etype (Pre)) /= E_Anonymous_Access_Type 804 and then (not (Nkind (Selector_Name (E)) in N_Has_Entity 805 and then Ekind (Entity (Selector_Name (E))) 806 = E_Discriminant) 807 808 -- The alternative accessibility models both treat 809 -- discriminants as regular components. 810 811 or else (No_Dynamic_Accessibility_Checks_Enabled (E) 812 and then Allow_Alt_Model)) 813 then 814 -- When restriction No_Dynamic_Accessibility_Checks is active 815 -- and -gnatd_b set, the level is that of the designated type. 816 817 if Allow_Alt_Model 818 and then No_Dynamic_Accessibility_Checks_Enabled (E) 819 and then Debug_Flag_Underscore_B 820 then 821 return Make_Level_Literal 822 (Typ_Access_Level (Etype (E))); 823 end if; 824 825 -- Otherwise proceed normally 826 827 return Make_Level_Literal 828 (Typ_Access_Level (Etype (Prefix (E)))); 829 830 -- Similar to the previous case - arrays featuring components of 831 -- anonymous access components get their corresponding level from 832 -- their containing type's declaration. 833 834 elsif Nkind (E) = N_Indexed_Component 835 and then Ekind (Etype (E)) = E_Anonymous_Access_Type 836 and then Ekind (Etype (Pre)) in Array_Kind 837 and then Ekind (Component_Type (Base_Type (Etype (Pre)))) 838 = E_Anonymous_Access_Type 839 then 840 -- When restriction No_Dynamic_Accessibility_Checks is active 841 -- and -gnatd_b set, the level is that of the designated type. 842 843 if Allow_Alt_Model 844 and then No_Dynamic_Accessibility_Checks_Enabled (E) 845 and then Debug_Flag_Underscore_B 846 then 847 return Make_Level_Literal 848 (Typ_Access_Level (Etype (E))); 849 end if; 850 851 -- Otherwise proceed normally 852 853 return Make_Level_Literal 854 (Typ_Access_Level (Etype (Prefix (E)))); 855 856 -- The accessibility calculation routine that handles function 857 -- calls (Function_Call_Level) assumes, in the case the 858 -- result is of an anonymous access type, that the result will be 859 -- used "in its entirety" when the call is present within an 860 -- assignment or object declaration. 861 862 -- To properly handle cases where the result is not used in its 863 -- entirety, we test if the prefix of the component in question is 864 -- a function call, which tells us that one of its components has 865 -- been identified and is being accessed. Therefore we can 866 -- conclude that the result is not used "in its entirety" 867 -- according to RM 3.10.2 (10.2/3). 868 869 elsif Nkind (Pre) = N_Function_Call 870 and then not Is_Named_Access_Type (Etype (Pre)) 871 then 872 -- Dynamic checks are generated when we are within a return 873 -- value or we are in a function call within an anonymous 874 -- access discriminant constraint of a return object (signified 875 -- by In_Return_Context) on the side of the callee. 876 877 -- So, in this case, return a library accessibility level to 878 -- null out the check on the side of the caller. 879 880 if (In_Return_Value (E) 881 or else In_Return_Context) 882 and then Level /= Dynamic_Level 883 then 884 return Make_Level_Literal 885 (Scope_Depth (Standard_Standard)); 886 end if; 887 888 return Make_Level_Literal 889 (Innermost_Master_Scope_Depth (Expr)); 890 891 -- Otherwise, continue recursing over the expression prefixes 892 893 else 894 return Accessibility_Level (Prefix (E)); 895 end if; 896 897 -- Qualified expressions 898 899 when N_Qualified_Expression => 900 if Is_Named_Access_Type (Etype (E)) then 901 return Make_Level_Literal 902 (Typ_Access_Level (Etype (E))); 903 else 904 return Accessibility_Level (Expression (E)); 905 end if; 906 907 -- Handle function calls 908 909 when N_Function_Call => 910 return Function_Call_Or_Allocator_Level (E); 911 912 -- Explicit dereference accessibility level calculation 913 914 when N_Explicit_Dereference => 915 Pre := Original_Node (Prefix (E)); 916 917 -- The prefix is a named access type so the level is taken from 918 -- its type. 919 920 if Is_Named_Access_Type (Etype (Pre)) then 921 return Make_Level_Literal (Typ_Access_Level (Etype (Pre))); 922 923 -- Otherwise, recurse deeper 924 925 else 926 return Accessibility_Level (Prefix (E)); 927 end if; 928 929 -- Type conversions 930 931 when N_Type_Conversion | N_Unchecked_Type_Conversion => 932 -- View conversions are special in that they require use to 933 -- inspect the expression of the type conversion. 934 935 -- Allocators of anonymous access types are internally generated, 936 -- so recurse deeper in that case as well. 937 938 if Is_View_Conversion (E) 939 or else Ekind (Etype (E)) = E_Anonymous_Access_Type 940 then 941 return Accessibility_Level (Expression (E)); 942 943 -- We don't care about the master if we are looking at a named 944 -- access type. 945 946 elsif Is_Named_Access_Type (Etype (E)) then 947 return Make_Level_Literal 948 (Typ_Access_Level (Etype (E))); 949 950 -- In section RM 3.10.2 (10/4) the accessibility rules for 951 -- aggregates and value conversions are outlined. Are these 952 -- followed in the case of initialization of an object ??? 953 954 -- Should use Innermost_Master_Scope_Depth ??? 955 956 else 957 return Accessibility_Level (Current_Scope); 958 end if; 959 960 -- Default to the type accessibility level for the type of the 961 -- expression's entity. 962 963 when others => 964 return Make_Level_Literal (Typ_Access_Level (Etype (E))); 965 end case; 966 end Accessibility_Level; 967 968 -------------------------------- 969 -- Static_Accessibility_Level -- 970 -------------------------------- 971 972 function Static_Accessibility_Level 973 (Expr : Node_Id; 974 Level : Static_Accessibility_Level_Kind; 975 In_Return_Context : Boolean := False) return Uint 976 is 977 begin 978 return Intval 979 (Accessibility_Level (Expr, Level, In_Return_Context)); 980 end Static_Accessibility_Level; 981 982 ---------------------------------- 983 -- Acquire_Warning_Match_String -- 984 ---------------------------------- 985 986 function Acquire_Warning_Match_String (Str_Lit : Node_Id) return String is 987 S : constant String := To_String (Strval (Str_Lit)); 988 begin 989 if S = "" then 990 return ""; 991 else 992 -- Put "*" before or after or both, if it's not already there 993 994 declare 995 F : constant Boolean := S (S'First) = '*'; 996 L : constant Boolean := S (S'Last) = '*'; 997 begin 998 if F then 999 if L then 1000 return S; 1001 else 1002 return S & "*"; 1003 end if; 1004 else 1005 if L then 1006 return "*" & S; 1007 else 1008 return "*" & S & "*"; 1009 end if; 1010 end if; 1011 end; 1012 end if; 1013 end Acquire_Warning_Match_String; 1014 1015 -------------------------------- 1016 -- Add_Access_Type_To_Process -- 1017 -------------------------------- 1018 1019 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is 1020 L : Elist_Id; 1021 1022 begin 1023 Ensure_Freeze_Node (E); 1024 L := Access_Types_To_Process (Freeze_Node (E)); 1025 1026 if No (L) then 1027 L := New_Elmt_List; 1028 Set_Access_Types_To_Process (Freeze_Node (E), L); 1029 end if; 1030 1031 Append_Elmt (A, L); 1032 end Add_Access_Type_To_Process; 1033 1034 -------------------------- 1035 -- Add_Block_Identifier -- 1036 -------------------------- 1037 1038 procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is 1039 Loc : constant Source_Ptr := Sloc (N); 1040 begin 1041 pragma Assert (Nkind (N) = N_Block_Statement); 1042 1043 -- The block already has a label, return its entity 1044 1045 if Present (Identifier (N)) then 1046 Id := Entity (Identifier (N)); 1047 1048 -- Create a new block label and set its attributes 1049 1050 else 1051 Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); 1052 Set_Etype (Id, Standard_Void_Type); 1053 Set_Parent (Id, N); 1054 1055 Set_Identifier (N, New_Occurrence_Of (Id, Loc)); 1056 Set_Block_Node (Id, Identifier (N)); 1057 end if; 1058 end Add_Block_Identifier; 1059 1060 ---------------------------- 1061 -- Add_Global_Declaration -- 1062 ---------------------------- 1063 1064 procedure Add_Global_Declaration (N : Node_Id) is 1065 Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit)); 1066 1067 begin 1068 if No (Declarations (Aux_Node)) then 1069 Set_Declarations (Aux_Node, New_List); 1070 end if; 1071 1072 Append_To (Declarations (Aux_Node), N); 1073 Analyze (N); 1074 end Add_Global_Declaration; 1075 1076 -------------------------------- 1077 -- Address_Integer_Convert_OK -- 1078 -------------------------------- 1079 1080 function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is 1081 begin 1082 if Allow_Integer_Address 1083 and then ((Is_Descendant_Of_Address (T1) 1084 and then Is_Private_Type (T1) 1085 and then Is_Integer_Type (T2)) 1086 or else 1087 (Is_Descendant_Of_Address (T2) 1088 and then Is_Private_Type (T2) 1089 and then Is_Integer_Type (T1))) 1090 then 1091 return True; 1092 else 1093 return False; 1094 end if; 1095 end Address_Integer_Convert_OK; 1096 1097 ------------------- 1098 -- Address_Value -- 1099 ------------------- 1100 1101 function Address_Value (N : Node_Id) return Node_Id is 1102 Expr : Node_Id := N; 1103 1104 begin 1105 loop 1106 -- For constant, get constant expression 1107 1108 if Is_Entity_Name (Expr) 1109 and then Ekind (Entity (Expr)) = E_Constant 1110 then 1111 Expr := Constant_Value (Entity (Expr)); 1112 1113 -- For unchecked conversion, get result to convert 1114 1115 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then 1116 Expr := Expression (Expr); 1117 1118 -- For (common case) of To_Address call, get argument 1119 1120 elsif Nkind (Expr) = N_Function_Call 1121 and then Is_Entity_Name (Name (Expr)) 1122 and then Is_RTE (Entity (Name (Expr)), RE_To_Address) 1123 then 1124 Expr := First_Actual (Expr); 1125 1126 -- We finally have the real expression 1127 1128 else 1129 exit; 1130 end if; 1131 end loop; 1132 1133 return Expr; 1134 end Address_Value; 1135 1136 ----------------- 1137 -- Addressable -- 1138 ----------------- 1139 1140 function Addressable (V : Uint) return Boolean is 1141 begin 1142 if No (V) then 1143 return False; 1144 end if; 1145 1146 return V = Uint_8 or else 1147 V = Uint_16 or else 1148 V = Uint_32 or else 1149 V = Uint_64 or else 1150 (V = Uint_128 and then System_Max_Integer_Size = 128); 1151 end Addressable; 1152 1153 function Addressable (V : Int) return Boolean is 1154 begin 1155 return V = 8 or else 1156 V = 16 or else 1157 V = 32 or else 1158 V = 64 or else 1159 V = System_Max_Integer_Size; 1160 end Addressable; 1161 1162 --------------------------------- 1163 -- Aggregate_Constraint_Checks -- 1164 --------------------------------- 1165 1166 procedure Aggregate_Constraint_Checks 1167 (Exp : Node_Id; 1168 Check_Typ : Entity_Id) 1169 is 1170 Exp_Typ : constant Entity_Id := Etype (Exp); 1171 1172 begin 1173 if Raises_Constraint_Error (Exp) then 1174 return; 1175 end if; 1176 1177 -- Ada 2005 (AI-230): Generate a conversion to an anonymous access 1178 -- component's type to force the appropriate accessibility checks. 1179 1180 -- Ada 2005 (AI-231): Generate conversion to the null-excluding type to 1181 -- force the corresponding run-time check 1182 1183 if Is_Access_Type (Check_Typ) 1184 and then Is_Local_Anonymous_Access (Check_Typ) 1185 then 1186 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); 1187 Analyze_And_Resolve (Exp, Check_Typ); 1188 Check_Unset_Reference (Exp); 1189 end if; 1190 1191 -- What follows is really expansion activity, so check that expansion 1192 -- is on and is allowed. In GNATprove mode, we also want check flags to 1193 -- be added in the tree, so that the formal verification can rely on 1194 -- those to be present. In GNATprove mode for formal verification, some 1195 -- treatment typically only done during expansion needs to be performed 1196 -- on the tree, but it should not be applied inside generics. Otherwise, 1197 -- this breaks the name resolution mechanism for generic instances. 1198 1199 if not Expander_Active 1200 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode) 1201 then 1202 return; 1203 end if; 1204 1205 if Is_Access_Type (Check_Typ) 1206 and then Can_Never_Be_Null (Check_Typ) 1207 and then not Can_Never_Be_Null (Exp_Typ) 1208 then 1209 Install_Null_Excluding_Check (Exp); 1210 end if; 1211 1212 -- First check if we have to insert discriminant checks 1213 1214 if Has_Discriminants (Exp_Typ) then 1215 Apply_Discriminant_Check (Exp, Check_Typ); 1216 1217 -- Next emit length checks for array aggregates 1218 1219 elsif Is_Array_Type (Exp_Typ) then 1220 Apply_Length_Check (Exp, Check_Typ); 1221 1222 -- Finally emit scalar and string checks. If we are dealing with a 1223 -- scalar literal we need to check by hand because the Etype of 1224 -- literals is not necessarily correct. 1225 1226 elsif Is_Scalar_Type (Exp_Typ) 1227 and then Compile_Time_Known_Value (Exp) 1228 then 1229 if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then 1230 Apply_Compile_Time_Constraint_Error 1231 (Exp, "value not in range of}??", CE_Range_Check_Failed, 1232 Ent => Base_Type (Check_Typ), 1233 Typ => Base_Type (Check_Typ)); 1234 1235 elsif Is_Out_Of_Range (Exp, Check_Typ) then 1236 Apply_Compile_Time_Constraint_Error 1237 (Exp, "value not in range of}??", CE_Range_Check_Failed, 1238 Ent => Check_Typ, 1239 Typ => Check_Typ); 1240 1241 elsif not Range_Checks_Suppressed (Check_Typ) then 1242 Apply_Scalar_Range_Check (Exp, Check_Typ); 1243 end if; 1244 1245 -- Verify that target type is also scalar, to prevent view anomalies 1246 -- in instantiations. 1247 1248 elsif (Is_Scalar_Type (Exp_Typ) 1249 or else Nkind (Exp) = N_String_Literal) 1250 and then Is_Scalar_Type (Check_Typ) 1251 and then Exp_Typ /= Check_Typ 1252 then 1253 if Is_Entity_Name (Exp) 1254 and then Ekind (Entity (Exp)) = E_Constant 1255 then 1256 -- If expression is a constant, it is worthwhile checking whether 1257 -- it is a bound of the type. 1258 1259 if (Is_Entity_Name (Type_Low_Bound (Check_Typ)) 1260 and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ))) 1261 or else 1262 (Is_Entity_Name (Type_High_Bound (Check_Typ)) 1263 and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ))) 1264 then 1265 return; 1266 1267 else 1268 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); 1269 Analyze_And_Resolve (Exp, Check_Typ); 1270 Check_Unset_Reference (Exp); 1271 end if; 1272 1273 -- Could use a comment on this case ??? 1274 1275 else 1276 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); 1277 Analyze_And_Resolve (Exp, Check_Typ); 1278 Check_Unset_Reference (Exp); 1279 end if; 1280 1281 end if; 1282 end Aggregate_Constraint_Checks; 1283 1284 ----------------------- 1285 -- Alignment_In_Bits -- 1286 ----------------------- 1287 1288 function Alignment_In_Bits (E : Entity_Id) return Uint is 1289 begin 1290 return Alignment (E) * System_Storage_Unit; 1291 end Alignment_In_Bits; 1292 1293 -------------------------------------- 1294 -- All_Composite_Constraints_Static -- 1295 -------------------------------------- 1296 1297 function All_Composite_Constraints_Static 1298 (Constr : Node_Id) return Boolean 1299 is 1300 begin 1301 if No (Constr) or else Error_Posted (Constr) then 1302 return True; 1303 end if; 1304 1305 case Nkind (Constr) is 1306 when N_Subexpr => 1307 if Nkind (Constr) in N_Has_Entity 1308 and then Present (Entity (Constr)) 1309 then 1310 if Is_Type (Entity (Constr)) then 1311 return 1312 not Is_Discrete_Type (Entity (Constr)) 1313 or else Is_OK_Static_Subtype (Entity (Constr)); 1314 end if; 1315 1316 elsif Nkind (Constr) = N_Range then 1317 return 1318 Is_OK_Static_Expression (Low_Bound (Constr)) 1319 and then 1320 Is_OK_Static_Expression (High_Bound (Constr)); 1321 1322 elsif Nkind (Constr) = N_Attribute_Reference 1323 and then Attribute_Name (Constr) = Name_Range 1324 then 1325 return 1326 Is_OK_Static_Expression 1327 (Type_Low_Bound (Etype (Prefix (Constr)))) 1328 and then 1329 Is_OK_Static_Expression 1330 (Type_High_Bound (Etype (Prefix (Constr)))); 1331 end if; 1332 1333 return 1334 not Present (Etype (Constr)) -- previous error 1335 or else not Is_Discrete_Type (Etype (Constr)) 1336 or else Is_OK_Static_Expression (Constr); 1337 1338 when N_Discriminant_Association => 1339 return All_Composite_Constraints_Static (Expression (Constr)); 1340 1341 when N_Range_Constraint => 1342 return 1343 All_Composite_Constraints_Static (Range_Expression (Constr)); 1344 1345 when N_Index_Or_Discriminant_Constraint => 1346 declare 1347 One_Cstr : Entity_Id; 1348 begin 1349 One_Cstr := First (Constraints (Constr)); 1350 while Present (One_Cstr) loop 1351 if not All_Composite_Constraints_Static (One_Cstr) then 1352 return False; 1353 end if; 1354 1355 Next (One_Cstr); 1356 end loop; 1357 end; 1358 1359 return True; 1360 1361 when N_Subtype_Indication => 1362 return 1363 All_Composite_Constraints_Static (Subtype_Mark (Constr)) 1364 and then 1365 All_Composite_Constraints_Static (Constraint (Constr)); 1366 1367 when others => 1368 raise Program_Error; 1369 end case; 1370 end All_Composite_Constraints_Static; 1371 1372 ------------------------ 1373 -- Append_Entity_Name -- 1374 ------------------------ 1375 1376 procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is 1377 Temp : Bounded_String; 1378 1379 procedure Inner (E : Entity_Id); 1380 -- Inner recursive routine, keep outer routine nonrecursive to ease 1381 -- debugging when we get strange results from this routine. 1382 1383 ----------- 1384 -- Inner -- 1385 ----------- 1386 1387 procedure Inner (E : Entity_Id) is 1388 Scop : Node_Id; 1389 1390 begin 1391 -- If entity has an internal name, skip by it, and print its scope. 1392 -- Note that we strip a final R from the name before the test; this 1393 -- is needed for some cases of instantiations. 1394 1395 declare 1396 E_Name : Bounded_String; 1397 1398 begin 1399 Append (E_Name, Chars (E)); 1400 1401 if E_Name.Chars (E_Name.Length) = 'R' then 1402 E_Name.Length := E_Name.Length - 1; 1403 end if; 1404 1405 if Is_Internal_Name (E_Name) then 1406 Inner (Scope (E)); 1407 return; 1408 end if; 1409 end; 1410 1411 Scop := Scope (E); 1412 1413 -- Just print entity name if its scope is at the outer level 1414 1415 if Scop = Standard_Standard then 1416 null; 1417 1418 -- If scope comes from source, write scope and entity 1419 1420 elsif Comes_From_Source (Scop) then 1421 Append_Entity_Name (Temp, Scop); 1422 Append (Temp, '.'); 1423 1424 -- If in wrapper package skip past it 1425 1426 elsif Present (Scop) and then Is_Wrapper_Package (Scop) then 1427 Append_Entity_Name (Temp, Scope (Scop)); 1428 Append (Temp, '.'); 1429 1430 -- Otherwise nothing to output (happens in unnamed block statements) 1431 1432 else 1433 null; 1434 end if; 1435 1436 -- Output the name 1437 1438 declare 1439 E_Name : Bounded_String; 1440 1441 begin 1442 Append_Unqualified_Decoded (E_Name, Chars (E)); 1443 1444 -- Remove trailing upper-case letters from the name (useful for 1445 -- dealing with some cases of internal names generated in the case 1446 -- of references from within a generic). 1447 1448 while E_Name.Length > 1 1449 and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z' 1450 loop 1451 E_Name.Length := E_Name.Length - 1; 1452 end loop; 1453 1454 -- Adjust casing appropriately (gets name from source if possible) 1455 1456 Adjust_Name_Case (E_Name, Sloc (E)); 1457 Append (Temp, E_Name); 1458 end; 1459 end Inner; 1460 1461 -- Start of processing for Append_Entity_Name 1462 1463 begin 1464 Inner (E); 1465 Append (Buf, Temp); 1466 end Append_Entity_Name; 1467 1468 --------------------------------- 1469 -- Append_Inherited_Subprogram -- 1470 --------------------------------- 1471 1472 procedure Append_Inherited_Subprogram (S : Entity_Id) is 1473 Par : constant Entity_Id := Alias (S); 1474 -- The parent subprogram 1475 1476 Scop : constant Entity_Id := Scope (Par); 1477 -- The scope of definition of the parent subprogram 1478 1479 Typ : constant Entity_Id := Defining_Entity (Parent (S)); 1480 -- The derived type of which S is a primitive operation 1481 1482 Decl : Node_Id; 1483 Next_E : Entity_Id; 1484 1485 begin 1486 if Ekind (Current_Scope) = E_Package 1487 and then In_Private_Part (Current_Scope) 1488 and then Has_Private_Declaration (Typ) 1489 and then Is_Tagged_Type (Typ) 1490 and then Scop = Current_Scope 1491 then 1492 -- The inherited operation is available at the earliest place after 1493 -- the derived type declaration (RM 7.3.1 (6/1)). This is only 1494 -- relevant for type extensions. If the parent operation appears 1495 -- after the type extension, the operation is not visible. 1496 1497 Decl := First 1498 (Visible_Declarations 1499 (Package_Specification (Current_Scope))); 1500 while Present (Decl) loop 1501 if Nkind (Decl) = N_Private_Extension_Declaration 1502 and then Defining_Entity (Decl) = Typ 1503 then 1504 if Sloc (Decl) > Sloc (Par) then 1505 Next_E := Next_Entity (Par); 1506 Link_Entities (Par, S); 1507 Link_Entities (S, Next_E); 1508 return; 1509 1510 else 1511 exit; 1512 end if; 1513 end if; 1514 1515 Next (Decl); 1516 end loop; 1517 end if; 1518 1519 -- If partial view is not a type extension, or it appears before the 1520 -- subprogram declaration, insert normally at end of entity list. 1521 1522 Append_Entity (S, Current_Scope); 1523 end Append_Inherited_Subprogram; 1524 1525 ----------------------------------------- 1526 -- Apply_Compile_Time_Constraint_Error -- 1527 ----------------------------------------- 1528 1529 procedure Apply_Compile_Time_Constraint_Error 1530 (N : Node_Id; 1531 Msg : String; 1532 Reason : RT_Exception_Code; 1533 Ent : Entity_Id := Empty; 1534 Typ : Entity_Id := Empty; 1535 Loc : Source_Ptr := No_Location; 1536 Warn : Boolean := False; 1537 Emit_Message : Boolean := True) 1538 is 1539 Stat : constant Boolean := Is_Static_Expression (N); 1540 R_Stat : constant Node_Id := 1541 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason); 1542 Rtyp : Entity_Id; 1543 1544 begin 1545 if No (Typ) then 1546 Rtyp := Etype (N); 1547 else 1548 Rtyp := Typ; 1549 end if; 1550 1551 if Emit_Message then 1552 Discard_Node 1553 (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn)); 1554 end if; 1555 1556 -- Now we replace the node by an N_Raise_Constraint_Error node 1557 -- This does not need reanalyzing, so set it as analyzed now. 1558 1559 Rewrite (N, R_Stat); 1560 Set_Analyzed (N, True); 1561 1562 Set_Etype (N, Rtyp); 1563 Set_Raises_Constraint_Error (N); 1564 1565 -- Now deal with possible local raise handling 1566 1567 Possible_Local_Raise (N, Standard_Constraint_Error); 1568 1569 -- If the original expression was marked as static, the result is 1570 -- still marked as static, but the Raises_Constraint_Error flag is 1571 -- always set so that further static evaluation is not attempted. 1572 1573 if Stat then 1574 Set_Is_Static_Expression (N); 1575 end if; 1576 end Apply_Compile_Time_Constraint_Error; 1577 1578 --------------------------- 1579 -- Async_Readers_Enabled -- 1580 --------------------------- 1581 1582 function Async_Readers_Enabled (Id : Entity_Id) return Boolean is 1583 begin 1584 return Has_Enabled_Property (Id, Name_Async_Readers); 1585 end Async_Readers_Enabled; 1586 1587 --------------------------- 1588 -- Async_Writers_Enabled -- 1589 --------------------------- 1590 1591 function Async_Writers_Enabled (Id : Entity_Id) return Boolean is 1592 begin 1593 return Has_Enabled_Property (Id, Name_Async_Writers); 1594 end Async_Writers_Enabled; 1595 1596 -------------------------------------- 1597 -- Available_Full_View_Of_Component -- 1598 -------------------------------------- 1599 1600 function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is 1601 ST : constant Entity_Id := Scope (T); 1602 SCT : constant Entity_Id := Scope (Component_Type (T)); 1603 begin 1604 return In_Open_Scopes (ST) 1605 and then In_Open_Scopes (SCT) 1606 and then Scope_Depth (ST) >= Scope_Depth (SCT); 1607 end Available_Full_View_Of_Component; 1608 1609 ---------------- 1610 -- Bad_Aspect -- 1611 ---------------- 1612 1613 procedure Bad_Aspect 1614 (N : Node_Id; 1615 Nam : Name_Id; 1616 Warn : Boolean := False) 1617 is 1618 begin 1619 Error_Msg_Warn := Warn; 1620 Error_Msg_N ("<<& is not a valid aspect identifier", N); 1621 1622 -- Check bad spelling 1623 Error_Msg_Name_1 := Aspect_Spell_Check (Nam); 1624 if Error_Msg_Name_1 /= No_Name then 1625 Error_Msg_N -- CODEFIX 1626 ("\<<possible misspelling of %", N); 1627 end if; 1628 end Bad_Aspect; 1629 1630 ------------------- 1631 -- Bad_Attribute -- 1632 ------------------- 1633 1634 procedure Bad_Attribute 1635 (N : Node_Id; 1636 Nam : Name_Id; 1637 Warn : Boolean := False) 1638 is 1639 begin 1640 Error_Msg_Warn := Warn; 1641 Error_Msg_N ("<<unrecognized attribute&", N); 1642 1643 -- Check for possible misspelling 1644 1645 Error_Msg_Name_1 := Attribute_Spell_Check (Nam); 1646 if Error_Msg_Name_1 /= No_Name then 1647 Error_Msg_N -- CODEFIX 1648 ("\<<possible misspelling of %", N); 1649 end if; 1650 end Bad_Attribute; 1651 1652 -------------------------------- 1653 -- Bad_Predicated_Subtype_Use -- 1654 -------------------------------- 1655 1656 procedure Bad_Predicated_Subtype_Use 1657 (Msg : String; 1658 N : Node_Id; 1659 Typ : Entity_Id; 1660 Suggest_Static : Boolean := False) 1661 is 1662 Gen : Entity_Id; 1663 1664 begin 1665 -- Avoid cascaded errors 1666 1667 if Error_Posted (N) then 1668 return; 1669 end if; 1670 1671 if Inside_A_Generic then 1672 Gen := Current_Scope; 1673 while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop 1674 Gen := Scope (Gen); 1675 end loop; 1676 1677 if No (Gen) then 1678 return; 1679 end if; 1680 1681 if Is_Generic_Formal (Typ) and then Is_Discrete_Type (Typ) then 1682 Set_No_Predicate_On_Actual (Typ); 1683 end if; 1684 1685 elsif Has_Predicates (Typ) then 1686 if Is_Generic_Actual_Type (Typ) then 1687 1688 -- The restriction on loop parameters is only that the type 1689 -- should have no dynamic predicates. 1690 1691 if Nkind (Parent (N)) = N_Loop_Parameter_Specification 1692 and then not Has_Dynamic_Predicate_Aspect (Typ) 1693 and then Is_OK_Static_Subtype (Typ) 1694 then 1695 return; 1696 end if; 1697 1698 Gen := Current_Scope; 1699 while not Is_Generic_Instance (Gen) loop 1700 Gen := Scope (Gen); 1701 end loop; 1702 1703 pragma Assert (Present (Gen)); 1704 1705 if Ekind (Gen) = E_Package and then In_Package_Body (Gen) then 1706 Error_Msg_Warn := SPARK_Mode /= On; 1707 Error_Msg_FE (Msg & "<<", N, Typ); 1708 Error_Msg_F ("\Program_Error [<<", N); 1709 1710 Insert_Action (N, 1711 Make_Raise_Program_Error (Sloc (N), 1712 Reason => PE_Bad_Predicated_Generic_Type)); 1713 1714 else 1715 Error_Msg_FE (Msg, N, Typ); 1716 end if; 1717 1718 else 1719 Error_Msg_FE (Msg, N, Typ); 1720 end if; 1721 1722 -- Emit an optional suggestion on how to remedy the error if the 1723 -- context warrants it. 1724 1725 if Suggest_Static and then Has_Static_Predicate (Typ) then 1726 Error_Msg_FE ("\predicate of & should be marked static", N, Typ); 1727 end if; 1728 end if; 1729 end Bad_Predicated_Subtype_Use; 1730 1731 ----------------------------------------- 1732 -- Bad_Unordered_Enumeration_Reference -- 1733 ----------------------------------------- 1734 1735 function Bad_Unordered_Enumeration_Reference 1736 (N : Node_Id; 1737 T : Entity_Id) return Boolean 1738 is 1739 begin 1740 return Is_Enumeration_Type (T) 1741 and then Warn_On_Unordered_Enumeration_Type 1742 and then not Is_Generic_Type (T) 1743 and then Comes_From_Source (N) 1744 and then not Has_Pragma_Ordered (T) 1745 and then not In_Same_Extended_Unit (N, T); 1746 end Bad_Unordered_Enumeration_Reference; 1747 1748 ---------------------------- 1749 -- Begin_Keyword_Location -- 1750 ---------------------------- 1751 1752 function Begin_Keyword_Location (N : Node_Id) return Source_Ptr is 1753 HSS : Node_Id; 1754 1755 begin 1756 pragma Assert 1757 (Nkind (N) in 1758 N_Block_Statement | 1759 N_Entry_Body | 1760 N_Package_Body | 1761 N_Subprogram_Body | 1762 N_Task_Body); 1763 1764 HSS := Handled_Statement_Sequence (N); 1765 1766 -- When the handled sequence of statements comes from source, the 1767 -- location of the "begin" keyword is that of the sequence itself. 1768 -- Note that an internal construct may inherit a source sequence. 1769 1770 if Comes_From_Source (HSS) then 1771 return Sloc (HSS); 1772 1773 -- The parser generates an internal handled sequence of statements to 1774 -- capture the location of the "begin" keyword if present in the source. 1775 -- Since there are no source statements, the location of the "begin" 1776 -- keyword is effectively that of the "end" keyword. 1777 1778 elsif Comes_From_Source (N) then 1779 return Sloc (HSS); 1780 1781 -- Otherwise the construct is internal and should carry the location of 1782 -- the original construct which prompted its creation. 1783 1784 else 1785 return Sloc (N); 1786 end if; 1787 end Begin_Keyword_Location; 1788 1789 -------------------------- 1790 -- Build_Actual_Subtype -- 1791 -------------------------- 1792 1793 function Build_Actual_Subtype 1794 (T : Entity_Id; 1795 N : Node_Or_Entity_Id) return Node_Id 1796 is 1797 Loc : Source_Ptr; 1798 -- Normally Sloc (N), but may point to corresponding body in some cases 1799 1800 Constraints : List_Id; 1801 Decl : Node_Id; 1802 Discr : Entity_Id; 1803 Hi : Node_Id; 1804 Lo : Node_Id; 1805 Subt : Entity_Id; 1806 Disc_Type : Entity_Id; 1807 Obj : Node_Id; 1808 Index : Node_Id; 1809 1810 begin 1811 Loc := Sloc (N); 1812 1813 if Nkind (N) = N_Defining_Identifier then 1814 Obj := New_Occurrence_Of (N, Loc); 1815 1816 -- If this is a formal parameter of a subprogram declaration, and 1817 -- we are compiling the body, we want the declaration for the 1818 -- actual subtype to carry the source position of the body, to 1819 -- prevent anomalies in gdb when stepping through the code. 1820 1821 if Is_Formal (N) then 1822 declare 1823 Decl : constant Node_Id := Unit_Declaration_Node (Scope (N)); 1824 begin 1825 if Nkind (Decl) = N_Subprogram_Declaration 1826 and then Present (Corresponding_Body (Decl)) 1827 then 1828 Loc := Sloc (Corresponding_Body (Decl)); 1829 end if; 1830 end; 1831 end if; 1832 1833 else 1834 Obj := N; 1835 end if; 1836 1837 if Is_Array_Type (T) then 1838 Constraints := New_List; 1839 Index := First_Index (T); 1840 1841 for J in 1 .. Number_Dimensions (T) loop 1842 1843 -- Build an array subtype declaration with the nominal subtype and 1844 -- the bounds of the actual. Add the declaration in front of the 1845 -- local declarations for the subprogram, for analysis before any 1846 -- reference to the formal in the body. 1847 1848 -- If this is for an index with a fixed lower bound, then use 1849 -- the fixed lower bound as the lower bound of the actual 1850 -- subtype's corresponding index. 1851 1852 if not Is_Constrained (T) 1853 and then Is_Fixed_Lower_Bound_Index_Subtype (Etype (Index)) 1854 then 1855 Lo := New_Copy_Tree (Type_Low_Bound (Etype (Index))); 1856 1857 else 1858 Lo := 1859 Make_Attribute_Reference (Loc, 1860 Prefix => 1861 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), 1862 Attribute_Name => Name_First, 1863 Expressions => New_List ( 1864 Make_Integer_Literal (Loc, J))); 1865 end if; 1866 1867 Hi := 1868 Make_Attribute_Reference (Loc, 1869 Prefix => 1870 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), 1871 Attribute_Name => Name_Last, 1872 Expressions => New_List ( 1873 Make_Integer_Literal (Loc, J))); 1874 1875 Append (Make_Range (Loc, Lo, Hi), Constraints); 1876 1877 Next_Index (Index); 1878 end loop; 1879 1880 -- If the type has unknown discriminants there is no constrained 1881 -- subtype to build. This is never called for a formal or for a 1882 -- lhs, so returning the type is ok ??? 1883 1884 elsif Has_Unknown_Discriminants (T) then 1885 return T; 1886 1887 else 1888 Constraints := New_List; 1889 1890 -- Type T is a generic derived type, inherit the discriminants from 1891 -- the parent type. 1892 1893 if Is_Private_Type (T) 1894 and then No (Full_View (T)) 1895 1896 -- T was flagged as an error if it was declared as a formal 1897 -- derived type with known discriminants. In this case there 1898 -- is no need to look at the parent type since T already carries 1899 -- its own discriminants. 1900 1901 and then not Error_Posted (T) 1902 then 1903 Disc_Type := Etype (Base_Type (T)); 1904 else 1905 Disc_Type := T; 1906 end if; 1907 1908 Discr := First_Discriminant (Disc_Type); 1909 while Present (Discr) loop 1910 Append_To (Constraints, 1911 Make_Selected_Component (Loc, 1912 Prefix => 1913 Duplicate_Subexpr_No_Checks (Obj), 1914 Selector_Name => New_Occurrence_Of (Discr, Loc))); 1915 Next_Discriminant (Discr); 1916 end loop; 1917 end if; 1918 1919 Subt := Make_Temporary (Loc, 'S', Related_Node => N); 1920 Set_Is_Internal (Subt); 1921 1922 Decl := 1923 Make_Subtype_Declaration (Loc, 1924 Defining_Identifier => Subt, 1925 Subtype_Indication => 1926 Make_Subtype_Indication (Loc, 1927 Subtype_Mark => New_Occurrence_Of (T, Loc), 1928 Constraint => 1929 Make_Index_Or_Discriminant_Constraint (Loc, 1930 Constraints => Constraints))); 1931 1932 Mark_Rewrite_Insertion (Decl); 1933 return Decl; 1934 end Build_Actual_Subtype; 1935 1936 --------------------------------------- 1937 -- Build_Actual_Subtype_Of_Component -- 1938 --------------------------------------- 1939 1940 function Build_Actual_Subtype_Of_Component 1941 (T : Entity_Id; 1942 N : Node_Id) return Node_Id 1943 is 1944 Loc : constant Source_Ptr := Sloc (N); 1945 P : constant Node_Id := Prefix (N); 1946 1947 D : Elmt_Id; 1948 Id : Node_Id; 1949 Index_Typ : Entity_Id; 1950 Sel : Entity_Id := Empty; 1951 1952 Desig_Typ : Entity_Id; 1953 -- This is either a copy of T, or if T is an access type, then it is 1954 -- the directly designated type of this access type. 1955 1956 function Build_Access_Record_Constraint (C : List_Id) return List_Id; 1957 -- If the record component is a constrained access to the current 1958 -- record, the subtype has not been constructed during analysis of 1959 -- the enclosing record type (see Analyze_Access). In that case, build 1960 -- a constrained access subtype after replacing references to the 1961 -- enclosing discriminants with the corresponding discriminant values 1962 -- of the prefix. 1963 1964 function Build_Actual_Array_Constraint return List_Id; 1965 -- If one or more of the bounds of the component depends on 1966 -- discriminants, build actual constraint using the discriminants 1967 -- of the prefix, as above. 1968 1969 function Build_Actual_Record_Constraint return List_Id; 1970 -- Similar to previous one, for discriminated components constrained 1971 -- by the discriminant of the enclosing object. 1972 1973 function Copy_And_Maybe_Dereference (N : Node_Id) return Node_Id; 1974 -- Copy the subtree rooted at N and insert an explicit dereference if it 1975 -- is of an access type. 1976 1977 ----------------------------------- 1978 -- Build_Actual_Array_Constraint -- 1979 ----------------------------------- 1980 1981 function Build_Actual_Array_Constraint return List_Id is 1982 Constraints : constant List_Id := New_List; 1983 Indx : Node_Id; 1984 Hi : Node_Id; 1985 Lo : Node_Id; 1986 Old_Hi : Node_Id; 1987 Old_Lo : Node_Id; 1988 1989 begin 1990 Indx := First_Index (Desig_Typ); 1991 while Present (Indx) loop 1992 Old_Lo := Type_Low_Bound (Etype (Indx)); 1993 Old_Hi := Type_High_Bound (Etype (Indx)); 1994 1995 if Denotes_Discriminant (Old_Lo) then 1996 Lo := 1997 Make_Selected_Component (Loc, 1998 Prefix => Copy_And_Maybe_Dereference (P), 1999 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc)); 2000 2001 else 2002 Lo := New_Copy_Tree (Old_Lo); 2003 2004 -- The new bound will be reanalyzed in the enclosing 2005 -- declaration. For literal bounds that come from a type 2006 -- declaration, the type of the context must be imposed, so 2007 -- insure that analysis will take place. For non-universal 2008 -- types this is not strictly necessary. 2009 2010 Set_Analyzed (Lo, False); 2011 end if; 2012 2013 if Denotes_Discriminant (Old_Hi) then 2014 Hi := 2015 Make_Selected_Component (Loc, 2016 Prefix => Copy_And_Maybe_Dereference (P), 2017 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc)); 2018 2019 else 2020 Hi := New_Copy_Tree (Old_Hi); 2021 Set_Analyzed (Hi, False); 2022 end if; 2023 2024 Append (Make_Range (Loc, Lo, Hi), Constraints); 2025 Next_Index (Indx); 2026 end loop; 2027 2028 return Constraints; 2029 end Build_Actual_Array_Constraint; 2030 2031 ------------------------------------ 2032 -- Build_Actual_Record_Constraint -- 2033 ------------------------------------ 2034 2035 function Build_Actual_Record_Constraint return List_Id is 2036 Constraints : constant List_Id := New_List; 2037 D : Elmt_Id; 2038 D_Val : Node_Id; 2039 2040 begin 2041 D := First_Elmt (Discriminant_Constraint (Desig_Typ)); 2042 while Present (D) loop 2043 if Denotes_Discriminant (Node (D)) then 2044 D_Val := Make_Selected_Component (Loc, 2045 Prefix => Copy_And_Maybe_Dereference (P), 2046 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc)); 2047 2048 else 2049 D_Val := New_Copy_Tree (Node (D)); 2050 end if; 2051 2052 Append (D_Val, Constraints); 2053 Next_Elmt (D); 2054 end loop; 2055 2056 return Constraints; 2057 end Build_Actual_Record_Constraint; 2058 2059 ------------------------------------ 2060 -- Build_Access_Record_Constraint -- 2061 ------------------------------------ 2062 2063 function Build_Access_Record_Constraint (C : List_Id) return List_Id is 2064 Constraints : constant List_Id := New_List; 2065 D : Node_Id; 2066 D_Val : Node_Id; 2067 2068 begin 2069 -- Retrieve the constraint from the component declaration, because 2070 -- the component subtype has not been constructed and the component 2071 -- type is an unconstrained access. 2072 2073 D := First (C); 2074 while Present (D) loop 2075 if Nkind (D) = N_Discriminant_Association 2076 and then Denotes_Discriminant (Expression (D)) 2077 then 2078 D_Val := New_Copy_Tree (D); 2079 Set_Expression (D_Val, 2080 Make_Selected_Component (Loc, 2081 Prefix => Copy_And_Maybe_Dereference (P), 2082 Selector_Name => 2083 New_Occurrence_Of (Entity (Expression (D)), Loc))); 2084 2085 elsif Denotes_Discriminant (D) then 2086 D_Val := Make_Selected_Component (Loc, 2087 Prefix => Copy_And_Maybe_Dereference (P), 2088 Selector_Name => New_Occurrence_Of (Entity (D), Loc)); 2089 2090 else 2091 D_Val := New_Copy_Tree (D); 2092 end if; 2093 2094 Append (D_Val, Constraints); 2095 Next (D); 2096 end loop; 2097 2098 return Constraints; 2099 end Build_Access_Record_Constraint; 2100 2101 -------------------------------- 2102 -- Copy_And_Maybe_Dereference -- 2103 -------------------------------- 2104 2105 function Copy_And_Maybe_Dereference (N : Node_Id) return Node_Id is 2106 New_N : constant Node_Id := New_Copy_Tree (N); 2107 2108 begin 2109 if Is_Access_Type (Etype (N)) then 2110 return Make_Explicit_Dereference (Sloc (Parent (N)), New_N); 2111 2112 else 2113 return New_N; 2114 end if; 2115 end Copy_And_Maybe_Dereference; 2116 2117 -- Start of processing for Build_Actual_Subtype_Of_Component 2118 2119 begin 2120 -- The subtype does not need to be created for a selected component 2121 -- in a Spec_Expression. 2122 2123 if In_Spec_Expression then 2124 return Empty; 2125 2126 -- More comments for the rest of this body would be good ??? 2127 2128 elsif Nkind (N) = N_Explicit_Dereference then 2129 if Is_Composite_Type (T) 2130 and then not Is_Constrained (T) 2131 and then not (Is_Class_Wide_Type (T) 2132 and then Is_Constrained (Root_Type (T))) 2133 and then not Has_Unknown_Discriminants (T) 2134 then 2135 -- If the type of the dereference is already constrained, it is an 2136 -- actual subtype. 2137 2138 if Is_Array_Type (Etype (N)) 2139 and then Is_Constrained (Etype (N)) 2140 then 2141 return Empty; 2142 else 2143 Remove_Side_Effects (P); 2144 return Build_Actual_Subtype (T, N); 2145 end if; 2146 2147 else 2148 return Empty; 2149 end if; 2150 2151 elsif Nkind (N) = N_Selected_Component then 2152 -- The entity of the selected component allows us to retrieve 2153 -- the original constraint from its component declaration. 2154 2155 Sel := Entity (Selector_Name (N)); 2156 if Parent_Kind (Sel) /= N_Component_Declaration then 2157 return Empty; 2158 end if; 2159 end if; 2160 2161 if Is_Access_Type (T) then 2162 Desig_Typ := Designated_Type (T); 2163 2164 else 2165 Desig_Typ := T; 2166 end if; 2167 2168 if Ekind (Desig_Typ) = E_Array_Subtype then 2169 Id := First_Index (Desig_Typ); 2170 2171 -- Check whether an index bound is constrained by a discriminant 2172 2173 while Present (Id) loop 2174 Index_Typ := Underlying_Type (Etype (Id)); 2175 2176 if Denotes_Discriminant (Type_Low_Bound (Index_Typ)) 2177 or else 2178 Denotes_Discriminant (Type_High_Bound (Index_Typ)) 2179 then 2180 Remove_Side_Effects (P); 2181 return 2182 Build_Component_Subtype 2183 (Build_Actual_Array_Constraint, Loc, Base_Type (T)); 2184 end if; 2185 2186 Next_Index (Id); 2187 end loop; 2188 2189 elsif Is_Composite_Type (Desig_Typ) 2190 and then Has_Discriminants (Desig_Typ) 2191 and then not Is_Empty_Elmt_List (Discriminant_Constraint (Desig_Typ)) 2192 and then not Has_Unknown_Discriminants (Desig_Typ) 2193 then 2194 if Is_Private_Type (Desig_Typ) 2195 and then No (Discriminant_Constraint (Desig_Typ)) 2196 then 2197 Desig_Typ := Full_View (Desig_Typ); 2198 end if; 2199 2200 D := First_Elmt (Discriminant_Constraint (Desig_Typ)); 2201 while Present (D) loop 2202 if Denotes_Discriminant (Node (D)) then 2203 Remove_Side_Effects (P); 2204 return 2205 Build_Component_Subtype ( 2206 Build_Actual_Record_Constraint, Loc, Base_Type (T)); 2207 end if; 2208 2209 Next_Elmt (D); 2210 end loop; 2211 2212 -- Special processing for an access record component that is 2213 -- the target of an assignment. If the designated type is an 2214 -- unconstrained discriminated record we create its actual 2215 -- subtype now. 2216 2217 elsif Ekind (T) = E_Access_Type 2218 and then Present (Sel) 2219 and then Has_Per_Object_Constraint (Sel) 2220 and then Nkind (Parent (N)) = N_Assignment_Statement 2221 and then N = Name (Parent (N)) 2222 -- and then not Inside_Init_Proc 2223 -- and then Has_Discriminants (Desig_Typ) 2224 -- and then not Is_Constrained (Desig_Typ) 2225 then 2226 declare 2227 S_Indic : constant Node_Id := 2228 (Subtype_Indication 2229 (Component_Definition (Parent (Sel)))); 2230 Discs : List_Id; 2231 begin 2232 if Nkind (S_Indic) = N_Subtype_Indication then 2233 Discs := Constraints (Constraint (S_Indic)); 2234 2235 Remove_Side_Effects (P); 2236 return Build_Component_Subtype 2237 (Build_Access_Record_Constraint (Discs), Loc, T); 2238 else 2239 return Empty; 2240 end if; 2241 end; 2242 end if; 2243 2244 -- If none of the above, the actual and nominal subtypes are the same 2245 2246 return Empty; 2247 end Build_Actual_Subtype_Of_Component; 2248 2249 ----------------------------- 2250 -- Build_Component_Subtype -- 2251 ----------------------------- 2252 2253 function Build_Component_Subtype 2254 (C : List_Id; 2255 Loc : Source_Ptr; 2256 T : Entity_Id) return Node_Id 2257 is 2258 Subt : Entity_Id; 2259 Decl : Node_Id; 2260 2261 begin 2262 -- Unchecked_Union components do not require component subtypes 2263 2264 if Is_Unchecked_Union (T) then 2265 return Empty; 2266 end if; 2267 2268 Subt := Make_Temporary (Loc, 'S'); 2269 Set_Is_Internal (Subt); 2270 2271 Decl := 2272 Make_Subtype_Declaration (Loc, 2273 Defining_Identifier => Subt, 2274 Subtype_Indication => 2275 Make_Subtype_Indication (Loc, 2276 Subtype_Mark => New_Occurrence_Of (Base_Type (T), Loc), 2277 Constraint => 2278 Make_Index_Or_Discriminant_Constraint (Loc, 2279 Constraints => C))); 2280 2281 Mark_Rewrite_Insertion (Decl); 2282 return Decl; 2283 end Build_Component_Subtype; 2284 2285 ----------------------------- 2286 -- Build_Constrained_Itype -- 2287 ----------------------------- 2288 2289 procedure Build_Constrained_Itype 2290 (N : Node_Id; 2291 Typ : Entity_Id; 2292 New_Assoc_List : List_Id) 2293 is 2294 Constrs : constant List_Id := New_List; 2295 Loc : constant Source_Ptr := Sloc (N); 2296 Def_Id : Entity_Id; 2297 Indic : Node_Id; 2298 New_Assoc : Node_Id; 2299 Subtyp_Decl : Node_Id; 2300 2301 begin 2302 New_Assoc := First (New_Assoc_List); 2303 while Present (New_Assoc) loop 2304 2305 -- There is exactly one choice in the component association (and 2306 -- it is either a discriminant, a component or the others clause). 2307 pragma Assert (List_Length (Choices (New_Assoc)) = 1); 2308 2309 -- Duplicate expression for the discriminant and put it on the 2310 -- list of constraints for the itype declaration. 2311 2312 if Is_Entity_Name (First (Choices (New_Assoc))) 2313 and then 2314 Ekind (Entity (First (Choices (New_Assoc)))) = E_Discriminant 2315 then 2316 Append_To (Constrs, Duplicate_Subexpr (Expression (New_Assoc))); 2317 end if; 2318 2319 Next (New_Assoc); 2320 end loop; 2321 2322 if Has_Unknown_Discriminants (Typ) 2323 and then Present (Underlying_Record_View (Typ)) 2324 then 2325 Indic := 2326 Make_Subtype_Indication (Loc, 2327 Subtype_Mark => 2328 New_Occurrence_Of (Underlying_Record_View (Typ), Loc), 2329 Constraint => 2330 Make_Index_Or_Discriminant_Constraint (Loc, 2331 Constraints => Constrs)); 2332 else 2333 Indic := 2334 Make_Subtype_Indication (Loc, 2335 Subtype_Mark => 2336 New_Occurrence_Of (Base_Type (Typ), Loc), 2337 Constraint => 2338 Make_Index_Or_Discriminant_Constraint (Loc, 2339 Constraints => Constrs)); 2340 end if; 2341 2342 Def_Id := Create_Itype (Ekind (Typ), N); 2343 2344 Subtyp_Decl := 2345 Make_Subtype_Declaration (Loc, 2346 Defining_Identifier => Def_Id, 2347 Subtype_Indication => Indic); 2348 Set_Parent (Subtyp_Decl, Parent (N)); 2349 2350 -- Itypes must be analyzed with checks off (see itypes.ads) 2351 2352 Analyze (Subtyp_Decl, Suppress => All_Checks); 2353 2354 Set_Etype (N, Def_Id); 2355 end Build_Constrained_Itype; 2356 2357 --------------------------- 2358 -- Build_Default_Subtype -- 2359 --------------------------- 2360 2361 function Build_Default_Subtype 2362 (T : Entity_Id; 2363 N : Node_Id) return Entity_Id 2364 is 2365 Loc : constant Source_Ptr := Sloc (N); 2366 Disc : Entity_Id; 2367 2368 Bas : Entity_Id; 2369 -- The base type that is to be constrained by the defaults 2370 2371 begin 2372 if not Has_Discriminants (T) or else Is_Constrained (T) then 2373 return T; 2374 end if; 2375 2376 Bas := Base_Type (T); 2377 2378 -- If T is non-private but its base type is private, this is the 2379 -- completion of a subtype declaration whose parent type is private 2380 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants 2381 -- are to be found in the full view of the base. Check that the private 2382 -- status of T and its base differ. 2383 2384 if Is_Private_Type (Bas) 2385 and then not Is_Private_Type (T) 2386 and then Present (Full_View (Bas)) 2387 then 2388 Bas := Full_View (Bas); 2389 end if; 2390 2391 Disc := First_Discriminant (T); 2392 2393 if No (Discriminant_Default_Value (Disc)) then 2394 return T; 2395 end if; 2396 2397 declare 2398 Act : constant Entity_Id := Make_Temporary (Loc, 'S'); 2399 Constraints : constant List_Id := New_List; 2400 Decl : Node_Id; 2401 2402 begin 2403 while Present (Disc) loop 2404 Append_To (Constraints, 2405 New_Copy_Tree (Discriminant_Default_Value (Disc))); 2406 Next_Discriminant (Disc); 2407 end loop; 2408 2409 Decl := 2410 Make_Subtype_Declaration (Loc, 2411 Defining_Identifier => Act, 2412 Subtype_Indication => 2413 Make_Subtype_Indication (Loc, 2414 Subtype_Mark => New_Occurrence_Of (Bas, Loc), 2415 Constraint => 2416 Make_Index_Or_Discriminant_Constraint (Loc, 2417 Constraints => Constraints))); 2418 2419 Insert_Action (N, Decl); 2420 2421 -- If the context is a component declaration the subtype declaration 2422 -- will be analyzed when the enclosing type is frozen, otherwise do 2423 -- it now. 2424 2425 if Ekind (Current_Scope) /= E_Record_Type then 2426 Analyze (Decl); 2427 end if; 2428 2429 return Act; 2430 end; 2431 end Build_Default_Subtype; 2432 2433 -------------------------------------------- 2434 -- Build_Discriminal_Subtype_Of_Component -- 2435 -------------------------------------------- 2436 2437 function Build_Discriminal_Subtype_Of_Component 2438 (T : Entity_Id) return Node_Id 2439 is 2440 Loc : constant Source_Ptr := Sloc (T); 2441 D : Elmt_Id; 2442 Id : Node_Id; 2443 2444 function Build_Discriminal_Array_Constraint return List_Id; 2445 -- If one or more of the bounds of the component depends on 2446 -- discriminants, build actual constraint using the discriminants 2447 -- of the prefix. 2448 2449 function Build_Discriminal_Record_Constraint return List_Id; 2450 -- Similar to previous one, for discriminated components constrained by 2451 -- the discriminant of the enclosing object. 2452 2453 ---------------------------------------- 2454 -- Build_Discriminal_Array_Constraint -- 2455 ---------------------------------------- 2456 2457 function Build_Discriminal_Array_Constraint return List_Id is 2458 Constraints : constant List_Id := New_List; 2459 Indx : Node_Id; 2460 Hi : Node_Id; 2461 Lo : Node_Id; 2462 Old_Hi : Node_Id; 2463 Old_Lo : Node_Id; 2464 2465 begin 2466 Indx := First_Index (T); 2467 while Present (Indx) loop 2468 Old_Lo := Type_Low_Bound (Etype (Indx)); 2469 Old_Hi := Type_High_Bound (Etype (Indx)); 2470 2471 if Denotes_Discriminant (Old_Lo) then 2472 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc); 2473 2474 else 2475 Lo := New_Copy_Tree (Old_Lo); 2476 end if; 2477 2478 if Denotes_Discriminant (Old_Hi) then 2479 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc); 2480 2481 else 2482 Hi := New_Copy_Tree (Old_Hi); 2483 end if; 2484 2485 Append (Make_Range (Loc, Lo, Hi), Constraints); 2486 Next_Index (Indx); 2487 end loop; 2488 2489 return Constraints; 2490 end Build_Discriminal_Array_Constraint; 2491 2492 ----------------------------------------- 2493 -- Build_Discriminal_Record_Constraint -- 2494 ----------------------------------------- 2495 2496 function Build_Discriminal_Record_Constraint return List_Id is 2497 Constraints : constant List_Id := New_List; 2498 D : Elmt_Id; 2499 D_Val : Node_Id; 2500 2501 begin 2502 D := First_Elmt (Discriminant_Constraint (T)); 2503 while Present (D) loop 2504 if Denotes_Discriminant (Node (D)) then 2505 D_Val := 2506 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc); 2507 else 2508 D_Val := New_Copy_Tree (Node (D)); 2509 end if; 2510 2511 Append (D_Val, Constraints); 2512 Next_Elmt (D); 2513 end loop; 2514 2515 return Constraints; 2516 end Build_Discriminal_Record_Constraint; 2517 2518 -- Start of processing for Build_Discriminal_Subtype_Of_Component 2519 2520 begin 2521 if Ekind (T) = E_Array_Subtype then 2522 Id := First_Index (T); 2523 while Present (Id) loop 2524 if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) 2525 or else 2526 Denotes_Discriminant (Type_High_Bound (Etype (Id))) 2527 then 2528 return Build_Component_Subtype 2529 (Build_Discriminal_Array_Constraint, Loc, T); 2530 end if; 2531 2532 Next_Index (Id); 2533 end loop; 2534 2535 elsif Ekind (T) = E_Record_Subtype 2536 and then Has_Discriminants (T) 2537 and then not Has_Unknown_Discriminants (T) 2538 then 2539 D := First_Elmt (Discriminant_Constraint (T)); 2540 while Present (D) loop 2541 if Denotes_Discriminant (Node (D)) then 2542 return Build_Component_Subtype 2543 (Build_Discriminal_Record_Constraint, Loc, T); 2544 end if; 2545 2546 Next_Elmt (D); 2547 end loop; 2548 end if; 2549 2550 -- If none of the above, the actual and nominal subtypes are the same 2551 2552 return Empty; 2553 end Build_Discriminal_Subtype_Of_Component; 2554 2555 ------------------------------ 2556 -- Build_Elaboration_Entity -- 2557 ------------------------------ 2558 2559 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is 2560 Loc : constant Source_Ptr := Sloc (N); 2561 Decl : Node_Id; 2562 Elab_Ent : Entity_Id; 2563 2564 procedure Set_Package_Name (Ent : Entity_Id); 2565 -- Given an entity, sets the fully qualified name of the entity in 2566 -- Name_Buffer, with components separated by double underscores. This 2567 -- is a recursive routine that climbs the scope chain to Standard. 2568 2569 ---------------------- 2570 -- Set_Package_Name -- 2571 ---------------------- 2572 2573 procedure Set_Package_Name (Ent : Entity_Id) is 2574 begin 2575 if Scope (Ent) /= Standard_Standard then 2576 Set_Package_Name (Scope (Ent)); 2577 2578 declare 2579 Nam : constant String := Get_Name_String (Chars (Ent)); 2580 begin 2581 Name_Buffer (Name_Len + 1) := '_'; 2582 Name_Buffer (Name_Len + 2) := '_'; 2583 Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam; 2584 Name_Len := Name_Len + Nam'Length + 2; 2585 end; 2586 2587 else 2588 Get_Name_String (Chars (Ent)); 2589 end if; 2590 end Set_Package_Name; 2591 2592 -- Start of processing for Build_Elaboration_Entity 2593 2594 begin 2595 -- Ignore call if already constructed 2596 2597 if Present (Elaboration_Entity (Spec_Id)) then 2598 return; 2599 2600 -- Do not generate an elaboration entity in GNATprove move because the 2601 -- elaboration counter is a form of expansion. 2602 2603 elsif GNATprove_Mode then 2604 return; 2605 2606 -- See if we need elaboration entity 2607 2608 -- We always need an elaboration entity when preserving control flow, as 2609 -- we want to remain explicit about the unit's elaboration order. 2610 2611 elsif Opt.Suppress_Control_Flow_Optimizations then 2612 null; 2613 2614 -- We always need an elaboration entity for the dynamic elaboration 2615 -- model, since it is needed to properly generate the PE exception for 2616 -- access before elaboration. 2617 2618 elsif Dynamic_Elaboration_Checks then 2619 null; 2620 2621 -- For the static model, we don't need the elaboration counter if this 2622 -- unit is sure to have no elaboration code, since that means there 2623 -- is no elaboration unit to be called. Note that we can't just decide 2624 -- after the fact by looking to see whether there was elaboration code, 2625 -- because that's too late to make this decision. 2626 2627 elsif Restriction_Active (No_Elaboration_Code) then 2628 return; 2629 2630 -- Similarly, for the static model, we can skip the elaboration counter 2631 -- if we have the No_Multiple_Elaboration restriction, since for the 2632 -- static model, that's the only purpose of the counter (to avoid 2633 -- multiple elaboration). 2634 2635 elsif Restriction_Active (No_Multiple_Elaboration) then 2636 return; 2637 end if; 2638 2639 -- Here we need the elaboration entity 2640 2641 -- Construct name of elaboration entity as xxx_E, where xxx is the unit 2642 -- name with dots replaced by double underscore. We have to manually 2643 -- construct this name, since it will be elaborated in the outer scope, 2644 -- and thus will not have the unit name automatically prepended. 2645 2646 Set_Package_Name (Spec_Id); 2647 Add_Str_To_Name_Buffer ("_E"); 2648 2649 -- Create elaboration counter 2650 2651 Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find); 2652 Set_Elaboration_Entity (Spec_Id, Elab_Ent); 2653 2654 Decl := 2655 Make_Object_Declaration (Loc, 2656 Defining_Identifier => Elab_Ent, 2657 Object_Definition => 2658 New_Occurrence_Of (Standard_Short_Integer, Loc), 2659 Expression => Make_Integer_Literal (Loc, Uint_0)); 2660 2661 Push_Scope (Standard_Standard); 2662 Add_Global_Declaration (Decl); 2663 Pop_Scope; 2664 2665 -- Reset True_Constant indication, since we will indeed assign a value 2666 -- to the variable in the binder main. We also kill the Current_Value 2667 -- and Last_Assignment fields for the same reason. 2668 2669 Set_Is_True_Constant (Elab_Ent, False); 2670 Set_Current_Value (Elab_Ent, Empty); 2671 Set_Last_Assignment (Elab_Ent, Empty); 2672 2673 -- We do not want any further qualification of the name (if we did not 2674 -- do this, we would pick up the name of the generic package in the case 2675 -- of a library level generic instantiation). 2676 2677 Set_Has_Qualified_Name (Elab_Ent); 2678 Set_Has_Fully_Qualified_Name (Elab_Ent); 2679 end Build_Elaboration_Entity; 2680 2681 -------------------------------- 2682 -- Build_Explicit_Dereference -- 2683 -------------------------------- 2684 2685 procedure Build_Explicit_Dereference 2686 (Expr : Node_Id; 2687 Disc : Entity_Id) 2688 is 2689 Loc : constant Source_Ptr := Sloc (Expr); 2690 I : Interp_Index; 2691 It : Interp; 2692 2693 begin 2694 -- An entity of a type with a reference aspect is overloaded with 2695 -- both interpretations: with and without the dereference. Now that 2696 -- the dereference is made explicit, set the type of the node properly, 2697 -- to prevent anomalies in the backend. Same if the expression is an 2698 -- overloaded function call whose return type has a reference aspect. 2699 2700 if Is_Entity_Name (Expr) then 2701 Set_Etype (Expr, Etype (Entity (Expr))); 2702 2703 -- The designated entity will not be examined again when resolving 2704 -- the dereference, so generate a reference to it now. 2705 2706 Generate_Reference (Entity (Expr), Expr); 2707 2708 elsif Nkind (Expr) = N_Function_Call then 2709 2710 -- If the name of the indexing function is overloaded, locate the one 2711 -- whose return type has an implicit dereference on the desired 2712 -- discriminant, and set entity and type of function call. 2713 2714 if Is_Overloaded (Name (Expr)) then 2715 Get_First_Interp (Name (Expr), I, It); 2716 2717 while Present (It.Nam) loop 2718 if Ekind ((It.Typ)) = E_Record_Type 2719 and then First_Entity ((It.Typ)) = Disc 2720 then 2721 Set_Entity (Name (Expr), It.Nam); 2722 Set_Etype (Name (Expr), Etype (It.Nam)); 2723 exit; 2724 end if; 2725 2726 Get_Next_Interp (I, It); 2727 end loop; 2728 end if; 2729 2730 -- Set type of call from resolved function name. 2731 2732 Set_Etype (Expr, Etype (Name (Expr))); 2733 end if; 2734 2735 Set_Is_Overloaded (Expr, False); 2736 2737 -- The expression will often be a generalized indexing that yields a 2738 -- container element that is then dereferenced, in which case the 2739 -- generalized indexing call is also non-overloaded. 2740 2741 if Nkind (Expr) = N_Indexed_Component 2742 and then Present (Generalized_Indexing (Expr)) 2743 then 2744 Set_Is_Overloaded (Generalized_Indexing (Expr), False); 2745 end if; 2746 2747 Rewrite (Expr, 2748 Make_Explicit_Dereference (Loc, 2749 Prefix => 2750 Make_Selected_Component (Loc, 2751 Prefix => Relocate_Node (Expr), 2752 Selector_Name => New_Occurrence_Of (Disc, Loc)))); 2753 Set_Etype (Prefix (Expr), Etype (Disc)); 2754 Set_Etype (Expr, Designated_Type (Etype (Disc))); 2755 end Build_Explicit_Dereference; 2756 2757 --------------------------- 2758 -- Build_Overriding_Spec -- 2759 --------------------------- 2760 2761 function Build_Overriding_Spec 2762 (Op : Entity_Id; 2763 Typ : Entity_Id) return Node_Id 2764 is 2765 Loc : constant Source_Ptr := Sloc (Typ); 2766 Par_Typ : constant Entity_Id := Find_Dispatching_Type (Op); 2767 Spec : constant Node_Id := Specification (Unit_Declaration_Node (Op)); 2768 2769 Formal_Spec : Node_Id; 2770 Formal_Type : Node_Id; 2771 New_Spec : Node_Id; 2772 2773 begin 2774 New_Spec := Copy_Subprogram_Spec (Spec); 2775 2776 Formal_Spec := First (Parameter_Specifications (New_Spec)); 2777 while Present (Formal_Spec) loop 2778 Formal_Type := Parameter_Type (Formal_Spec); 2779 2780 if Is_Entity_Name (Formal_Type) 2781 and then Entity (Formal_Type) = Par_Typ 2782 then 2783 Rewrite (Formal_Type, New_Occurrence_Of (Typ, Loc)); 2784 end if; 2785 2786 -- Nothing needs to be done for access parameters 2787 2788 Next (Formal_Spec); 2789 end loop; 2790 2791 return New_Spec; 2792 end Build_Overriding_Spec; 2793 2794 ------------------- 2795 -- Build_Subtype -- 2796 ------------------- 2797 2798 function Build_Subtype 2799 (Related_Node : Node_Id; 2800 Loc : Source_Ptr; 2801 Typ : Entity_Id; 2802 Constraints : List_Id) 2803 return Entity_Id 2804 is 2805 Indic : Node_Id; 2806 Subtyp_Decl : Node_Id; 2807 Def_Id : Entity_Id; 2808 Btyp : Entity_Id := Base_Type (Typ); 2809 2810 begin 2811 -- The Related_Node better be here or else we won't be able to 2812 -- attach new itypes to a node in the tree. 2813 2814 pragma Assert (Present (Related_Node)); 2815 2816 -- If the view of the component's type is incomplete or private 2817 -- with unknown discriminants, then the constraint must be applied 2818 -- to the full type. 2819 2820 if Has_Unknown_Discriminants (Btyp) 2821 and then Present (Underlying_Type (Btyp)) 2822 then 2823 Btyp := Underlying_Type (Btyp); 2824 end if; 2825 2826 Indic := 2827 Make_Subtype_Indication (Loc, 2828 Subtype_Mark => New_Occurrence_Of (Btyp, Loc), 2829 Constraint => 2830 Make_Index_Or_Discriminant_Constraint (Loc, Constraints)); 2831 2832 Def_Id := Create_Itype (Ekind (Typ), Related_Node); 2833 2834 Subtyp_Decl := 2835 Make_Subtype_Declaration (Loc, 2836 Defining_Identifier => Def_Id, 2837 Subtype_Indication => Indic); 2838 2839 Set_Parent (Subtyp_Decl, Parent (Related_Node)); 2840 2841 -- Itypes must be analyzed with checks off (see package Itypes) 2842 2843 Analyze (Subtyp_Decl, Suppress => All_Checks); 2844 2845 if Is_Itype (Def_Id) and then Has_Predicates (Typ) then 2846 Inherit_Predicate_Flags (Def_Id, Typ); 2847 2848 -- Indicate where the predicate function may be found 2849 2850 if Is_Itype (Typ) then 2851 if Present (Predicate_Function (Def_Id)) then 2852 null; 2853 2854 elsif Present (Predicate_Function (Typ)) then 2855 Set_Predicate_Function (Def_Id, Predicate_Function (Typ)); 2856 2857 else 2858 Set_Predicated_Parent (Def_Id, Predicated_Parent (Typ)); 2859 end if; 2860 2861 elsif No (Predicate_Function (Def_Id)) then 2862 Set_Predicated_Parent (Def_Id, Typ); 2863 end if; 2864 end if; 2865 2866 return Def_Id; 2867 end Build_Subtype; 2868 2869 ----------------------------------- 2870 -- Cannot_Raise_Constraint_Error -- 2871 ----------------------------------- 2872 2873 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is 2874 2875 function List_Cannot_Raise_CE (L : List_Id) return Boolean; 2876 -- Returns True if none of the list members cannot possibly raise 2877 -- Constraint_Error. 2878 2879 -------------------------- 2880 -- List_Cannot_Raise_CE -- 2881 -------------------------- 2882 2883 function List_Cannot_Raise_CE (L : List_Id) return Boolean is 2884 N : Node_Id; 2885 begin 2886 N := First (L); 2887 while Present (N) loop 2888 if Cannot_Raise_Constraint_Error (N) then 2889 Next (N); 2890 else 2891 return False; 2892 end if; 2893 end loop; 2894 2895 return True; 2896 end List_Cannot_Raise_CE; 2897 2898 -- Start of processing for Cannot_Raise_Constraint_Error 2899 2900 begin 2901 if Compile_Time_Known_Value (Expr) then 2902 return True; 2903 2904 elsif Do_Range_Check (Expr) then 2905 return False; 2906 2907 elsif Raises_Constraint_Error (Expr) then 2908 return False; 2909 2910 else 2911 case Nkind (Expr) is 2912 when N_Identifier => 2913 return True; 2914 2915 when N_Expanded_Name => 2916 return True; 2917 2918 when N_Indexed_Component => 2919 return not Do_Range_Check (Expr) 2920 and then Cannot_Raise_Constraint_Error (Prefix (Expr)) 2921 and then List_Cannot_Raise_CE (Expressions (Expr)); 2922 2923 when N_Selected_Component => 2924 return not Do_Discriminant_Check (Expr) 2925 and then Cannot_Raise_Constraint_Error (Prefix (Expr)); 2926 2927 when N_Attribute_Reference => 2928 if Do_Overflow_Check (Expr) then 2929 return False; 2930 2931 elsif No (Expressions (Expr)) then 2932 return True; 2933 2934 else 2935 return List_Cannot_Raise_CE (Expressions (Expr)); 2936 end if; 2937 2938 when N_Type_Conversion => 2939 if Do_Overflow_Check (Expr) 2940 or else Do_Length_Check (Expr) 2941 then 2942 return False; 2943 else 2944 return Cannot_Raise_Constraint_Error (Expression (Expr)); 2945 end if; 2946 2947 when N_Unchecked_Type_Conversion => 2948 return Cannot_Raise_Constraint_Error (Expression (Expr)); 2949 2950 when N_Unary_Op => 2951 if Do_Overflow_Check (Expr) then 2952 return False; 2953 else 2954 return Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 2955 end if; 2956 2957 when N_Op_Divide 2958 | N_Op_Mod 2959 | N_Op_Rem 2960 => 2961 if Do_Division_Check (Expr) 2962 or else 2963 Do_Overflow_Check (Expr) 2964 then 2965 return False; 2966 else 2967 return 2968 Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) 2969 and then 2970 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 2971 end if; 2972 2973 when N_Op_Add 2974 | N_Op_And 2975 | N_Op_Concat 2976 | N_Op_Eq 2977 | N_Op_Expon 2978 | N_Op_Ge 2979 | N_Op_Gt 2980 | N_Op_Le 2981 | N_Op_Lt 2982 | N_Op_Multiply 2983 | N_Op_Ne 2984 | N_Op_Or 2985 | N_Op_Rotate_Left 2986 | N_Op_Rotate_Right 2987 | N_Op_Shift_Left 2988 | N_Op_Shift_Right 2989 | N_Op_Shift_Right_Arithmetic 2990 | N_Op_Subtract 2991 | N_Op_Xor 2992 => 2993 if Do_Overflow_Check (Expr) then 2994 return False; 2995 else 2996 return 2997 Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) 2998 and then 2999 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 3000 end if; 3001 3002 when others => 3003 return False; 3004 end case; 3005 end if; 3006 end Cannot_Raise_Constraint_Error; 3007 3008 ------------------------------- 3009 -- Check_Ambiguous_Aggregate -- 3010 ------------------------------- 3011 3012 procedure Check_Ambiguous_Aggregate (Call : Node_Id) is 3013 Actual : Node_Id; 3014 3015 begin 3016 if Extensions_Allowed then 3017 Actual := First_Actual (Call); 3018 while Present (Actual) loop 3019 if Nkind (Actual) = N_Aggregate then 3020 Error_Msg_N 3021 ("\add type qualification to aggregate actual", Actual); 3022 exit; 3023 end if; 3024 Next_Actual (Actual); 3025 end loop; 3026 end if; 3027 end Check_Ambiguous_Aggregate; 3028 3029 ----------------------------------------- 3030 -- Check_Dynamically_Tagged_Expression -- 3031 ----------------------------------------- 3032 3033 procedure Check_Dynamically_Tagged_Expression 3034 (Expr : Node_Id; 3035 Typ : Entity_Id; 3036 Related_Nod : Node_Id) 3037 is 3038 begin 3039 pragma Assert (Is_Tagged_Type (Typ)); 3040 3041 -- In order to avoid spurious errors when analyzing the expanded code, 3042 -- this check is done only for nodes that come from source and for 3043 -- actuals of generic instantiations. 3044 3045 if (Comes_From_Source (Related_Nod) 3046 or else In_Generic_Actual (Expr)) 3047 and then (Is_Class_Wide_Type (Etype (Expr)) 3048 or else Is_Dynamically_Tagged (Expr)) 3049 and then not Is_Class_Wide_Type (Typ) 3050 then 3051 Error_Msg_N ("dynamically tagged expression not allowed!", Expr); 3052 end if; 3053 end Check_Dynamically_Tagged_Expression; 3054 3055 -------------------------- 3056 -- Check_Fully_Declared -- 3057 -------------------------- 3058 3059 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is 3060 begin 3061 if Ekind (T) = E_Incomplete_Type then 3062 3063 -- Ada 2005 (AI-50217): If the type is available through a limited 3064 -- with_clause, verify that its full view has been analyzed. 3065 3066 if From_Limited_With (T) 3067 and then Present (Non_Limited_View (T)) 3068 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type 3069 then 3070 -- The non-limited view is fully declared 3071 3072 null; 3073 3074 else 3075 Error_Msg_NE 3076 ("premature usage of incomplete}", N, First_Subtype (T)); 3077 end if; 3078 3079 -- Need comments for these tests ??? 3080 3081 elsif Has_Private_Component (T) 3082 and then not Is_Generic_Type (Root_Type (T)) 3083 and then not In_Spec_Expression 3084 then 3085 -- Special case: if T is the anonymous type created for a single 3086 -- task or protected object, use the name of the source object. 3087 3088 if Is_Concurrent_Type (T) 3089 and then not Comes_From_Source (T) 3090 and then Nkind (N) = N_Object_Declaration 3091 then 3092 Error_Msg_NE 3093 ("type of& has incomplete component", 3094 N, Defining_Identifier (N)); 3095 else 3096 Error_Msg_NE 3097 ("premature usage of incomplete}", 3098 N, First_Subtype (T)); 3099 end if; 3100 end if; 3101 end Check_Fully_Declared; 3102 3103 ------------------------------------------- 3104 -- Check_Function_With_Address_Parameter -- 3105 ------------------------------------------- 3106 3107 procedure Check_Function_With_Address_Parameter (Subp_Id : Entity_Id) is 3108 F : Entity_Id; 3109 T : Entity_Id; 3110 3111 begin 3112 F := First_Formal (Subp_Id); 3113 while Present (F) loop 3114 T := Etype (F); 3115 3116 if Is_Private_Type (T) and then Present (Full_View (T)) then 3117 T := Full_View (T); 3118 end if; 3119 3120 if Is_Descendant_Of_Address (T) or else Is_Limited_Type (T) then 3121 Set_Is_Pure (Subp_Id, False); 3122 exit; 3123 end if; 3124 3125 Next_Formal (F); 3126 end loop; 3127 end Check_Function_With_Address_Parameter; 3128 3129 ------------------------------------- 3130 -- Check_Function_Writable_Actuals -- 3131 ------------------------------------- 3132 3133 procedure Check_Function_Writable_Actuals (N : Node_Id) is 3134 Writable_Actuals_List : Elist_Id := No_Elist; 3135 Identifiers_List : Elist_Id := No_Elist; 3136 Aggr_Error_Node : Node_Id := Empty; 3137 Error_Node : Node_Id := Empty; 3138 3139 procedure Collect_Identifiers (N : Node_Id); 3140 -- In a single traversal of subtree N collect in Writable_Actuals_List 3141 -- all the actuals of functions with writable actuals, and in the list 3142 -- Identifiers_List collect all the identifiers that are not actuals of 3143 -- functions with writable actuals. If a writable actual is referenced 3144 -- twice as writable actual then Error_Node is set to reference its 3145 -- second occurrence, the error is reported, and the tree traversal 3146 -- is abandoned. 3147 3148 ------------------------- 3149 -- Collect_Identifiers -- 3150 ------------------------- 3151 3152 procedure Collect_Identifiers (N : Node_Id) is 3153 3154 function Check_Node (N : Node_Id) return Traverse_Result; 3155 -- Process a single node during the tree traversal to collect the 3156 -- writable actuals of functions and all the identifiers which are 3157 -- not writable actuals of functions. 3158 3159 function Contains (List : Elist_Id; N : Node_Id) return Boolean; 3160 -- Returns True if List has a node whose Entity is Entity (N) 3161 3162 ---------------- 3163 -- Check_Node -- 3164 ---------------- 3165 3166 function Check_Node (N : Node_Id) return Traverse_Result is 3167 Is_Writable_Actual : Boolean := False; 3168 Id : Entity_Id; 3169 3170 begin 3171 if Nkind (N) = N_Identifier then 3172 3173 -- No analysis possible if the entity is not decorated 3174 3175 if No (Entity (N)) then 3176 return Skip; 3177 3178 -- Don't collect identifiers of packages, called functions, etc 3179 3180 elsif Ekind (Entity (N)) in 3181 E_Package | E_Function | E_Procedure | E_Entry 3182 then 3183 return Skip; 3184 3185 -- For rewritten nodes, continue the traversal in the original 3186 -- subtree. Needed to handle aggregates in original expressions 3187 -- extracted from the tree by Remove_Side_Effects. 3188 3189 elsif Is_Rewrite_Substitution (N) then 3190 Collect_Identifiers (Original_Node (N)); 3191 return Skip; 3192 3193 -- For now we skip aggregate discriminants, since they require 3194 -- performing the analysis in two phases to identify conflicts: 3195 -- first one analyzing discriminants and second one analyzing 3196 -- the rest of components (since at run time, discriminants are 3197 -- evaluated prior to components): too much computation cost 3198 -- to identify a corner case??? 3199 3200 elsif Nkind (Parent (N)) = N_Component_Association 3201 and then Nkind (Parent (Parent (N))) in 3202 N_Aggregate | N_Extension_Aggregate 3203 then 3204 declare 3205 Choice : constant Node_Id := First (Choices (Parent (N))); 3206 3207 begin 3208 if Ekind (Entity (N)) = E_Discriminant then 3209 return Skip; 3210 3211 elsif Expression (Parent (N)) = N 3212 and then Nkind (Choice) = N_Identifier 3213 and then Ekind (Entity (Choice)) = E_Discriminant 3214 then 3215 return Skip; 3216 end if; 3217 end; 3218 3219 -- Analyze if N is a writable actual of a function 3220 3221 elsif Nkind (Parent (N)) = N_Function_Call then 3222 declare 3223 Call : constant Node_Id := Parent (N); 3224 Actual : Node_Id; 3225 Formal : Node_Id; 3226 3227 begin 3228 Id := Get_Called_Entity (Call); 3229 3230 -- In case of previous error, no check is possible 3231 3232 if No (Id) then 3233 return Abandon; 3234 end if; 3235 3236 if Ekind (Id) in E_Function | E_Generic_Function 3237 and then Has_Out_Or_In_Out_Parameter (Id) 3238 then 3239 Formal := First_Formal (Id); 3240 Actual := First_Actual (Call); 3241 while Present (Actual) and then Present (Formal) loop 3242 if Actual = N then 3243 if Ekind (Formal) in E_Out_Parameter 3244 | E_In_Out_Parameter 3245 then 3246 Is_Writable_Actual := True; 3247 end if; 3248 3249 exit; 3250 end if; 3251 3252 Next_Formal (Formal); 3253 Next_Actual (Actual); 3254 end loop; 3255 end if; 3256 end; 3257 end if; 3258 3259 if Is_Writable_Actual then 3260 3261 -- Skip checking the error in non-elementary types since 3262 -- RM 6.4.1(6.15/3) is restricted to elementary types, but 3263 -- store this actual in Writable_Actuals_List since it is 3264 -- needed to perform checks on other constructs that have 3265 -- arbitrary order of evaluation (for example, aggregates). 3266 3267 if not Is_Elementary_Type (Etype (N)) then 3268 if not Contains (Writable_Actuals_List, N) then 3269 Append_New_Elmt (N, To => Writable_Actuals_List); 3270 end if; 3271 3272 -- Second occurrence of an elementary type writable actual 3273 3274 elsif Contains (Writable_Actuals_List, N) then 3275 3276 -- Report the error on the second occurrence of the 3277 -- identifier. We cannot assume that N is the second 3278 -- occurrence (according to their location in the 3279 -- sources), since Traverse_Func walks through Field2 3280 -- last (see comment in the body of Traverse_Func). 3281 3282 declare 3283 Elmt : Elmt_Id; 3284 3285 begin 3286 Elmt := First_Elmt (Writable_Actuals_List); 3287 while Present (Elmt) 3288 and then Entity (Node (Elmt)) /= Entity (N) 3289 loop 3290 Next_Elmt (Elmt); 3291 end loop; 3292 3293 if Sloc (N) > Sloc (Node (Elmt)) then 3294 Error_Node := N; 3295 else 3296 Error_Node := Node (Elmt); 3297 end if; 3298 3299 Error_Msg_NE 3300 ("value may be affected by call to & " 3301 & "because order of evaluation is arbitrary", 3302 Error_Node, Id); 3303 return Abandon; 3304 end; 3305 3306 -- First occurrence of a elementary type writable actual 3307 3308 else 3309 Append_New_Elmt (N, To => Writable_Actuals_List); 3310 end if; 3311 3312 else 3313 if Identifiers_List = No_Elist then 3314 Identifiers_List := New_Elmt_List; 3315 end if; 3316 3317 Append_Unique_Elmt (N, Identifiers_List); 3318 end if; 3319 end if; 3320 3321 return OK; 3322 end Check_Node; 3323 3324 -------------- 3325 -- Contains -- 3326 -------------- 3327 3328 function Contains 3329 (List : Elist_Id; 3330 N : Node_Id) return Boolean 3331 is 3332 pragma Assert (Nkind (N) in N_Has_Entity); 3333 3334 Elmt : Elmt_Id; 3335 3336 begin 3337 if List = No_Elist then 3338 return False; 3339 end if; 3340 3341 Elmt := First_Elmt (List); 3342 while Present (Elmt) loop 3343 if Entity (Node (Elmt)) = Entity (N) then 3344 return True; 3345 else 3346 Next_Elmt (Elmt); 3347 end if; 3348 end loop; 3349 3350 return False; 3351 end Contains; 3352 3353 ------------------ 3354 -- Do_Traversal -- 3355 ------------------ 3356 3357 procedure Do_Traversal is new Traverse_Proc (Check_Node); 3358 -- The traversal procedure 3359 3360 -- Start of processing for Collect_Identifiers 3361 3362 begin 3363 if Present (Error_Node) then 3364 return; 3365 end if; 3366 3367 if Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then 3368 return; 3369 end if; 3370 3371 Do_Traversal (N); 3372 end Collect_Identifiers; 3373 3374 -- Start of processing for Check_Function_Writable_Actuals 3375 3376 begin 3377 -- The check only applies to Ada 2012 code on which Check_Actuals has 3378 -- been set, and only to constructs that have multiple constituents 3379 -- whose order of evaluation is not specified by the language. 3380 3381 if Ada_Version < Ada_2012 3382 or else not Check_Actuals (N) 3383 or else Nkind (N) not in N_Op 3384 | N_Membership_Test 3385 | N_Range 3386 | N_Aggregate 3387 | N_Extension_Aggregate 3388 | N_Full_Type_Declaration 3389 | N_Function_Call 3390 | N_Procedure_Call_Statement 3391 | N_Entry_Call_Statement 3392 or else (Nkind (N) = N_Full_Type_Declaration 3393 and then not Is_Record_Type (Defining_Identifier (N))) 3394 3395 -- In addition, this check only applies to source code, not to code 3396 -- generated by constraint checks. 3397 3398 or else not Comes_From_Source (N) 3399 then 3400 return; 3401 end if; 3402 3403 -- If a construct C has two or more direct constituents that are names 3404 -- or expressions whose evaluation may occur in an arbitrary order, at 3405 -- least one of which contains a function call with an in out or out 3406 -- parameter, then the construct is legal only if: for each name N that 3407 -- is passed as a parameter of mode in out or out to some inner function 3408 -- call C2 (not including the construct C itself), there is no other 3409 -- name anywhere within a direct constituent of the construct C other 3410 -- than the one containing C2, that is known to refer to the same 3411 -- object (RM 6.4.1(6.17/3)). 3412 3413 case Nkind (N) is 3414 when N_Range => 3415 Collect_Identifiers (Low_Bound (N)); 3416 Collect_Identifiers (High_Bound (N)); 3417 3418 when N_Membership_Test 3419 | N_Op 3420 => 3421 declare 3422 Expr : Node_Id; 3423 3424 begin 3425 Collect_Identifiers (Left_Opnd (N)); 3426 3427 if Present (Right_Opnd (N)) then 3428 Collect_Identifiers (Right_Opnd (N)); 3429 end if; 3430 3431 if Nkind (N) in N_In | N_Not_In 3432 and then Present (Alternatives (N)) 3433 then 3434 Expr := First (Alternatives (N)); 3435 while Present (Expr) loop 3436 Collect_Identifiers (Expr); 3437 3438 Next (Expr); 3439 end loop; 3440 end if; 3441 end; 3442 3443 when N_Full_Type_Declaration => 3444 declare 3445 function Get_Record_Part (N : Node_Id) return Node_Id; 3446 -- Return the record part of this record type definition 3447 3448 function Get_Record_Part (N : Node_Id) return Node_Id is 3449 Type_Def : constant Node_Id := Type_Definition (N); 3450 begin 3451 if Nkind (Type_Def) = N_Derived_Type_Definition then 3452 return Record_Extension_Part (Type_Def); 3453 else 3454 return Type_Def; 3455 end if; 3456 end Get_Record_Part; 3457 3458 Comp : Node_Id; 3459 Def_Id : Entity_Id := Defining_Identifier (N); 3460 Rec : Node_Id := Get_Record_Part (N); 3461 3462 begin 3463 -- No need to perform any analysis if the record has no 3464 -- components 3465 3466 if No (Rec) or else No (Component_List (Rec)) then 3467 return; 3468 end if; 3469 3470 -- Collect the identifiers starting from the deepest 3471 -- derivation. Done to report the error in the deepest 3472 -- derivation. 3473 3474 loop 3475 if Present (Component_List (Rec)) then 3476 Comp := First (Component_Items (Component_List (Rec))); 3477 while Present (Comp) loop 3478 if Nkind (Comp) = N_Component_Declaration 3479 and then Present (Expression (Comp)) 3480 then 3481 Collect_Identifiers (Expression (Comp)); 3482 end if; 3483 3484 Next (Comp); 3485 end loop; 3486 end if; 3487 3488 exit when No (Underlying_Type (Etype (Def_Id))) 3489 or else Base_Type (Underlying_Type (Etype (Def_Id))) 3490 = Def_Id; 3491 3492 Def_Id := Base_Type (Underlying_Type (Etype (Def_Id))); 3493 Rec := Get_Record_Part (Parent (Def_Id)); 3494 end loop; 3495 end; 3496 3497 when N_Entry_Call_Statement 3498 | N_Subprogram_Call 3499 => 3500 declare 3501 Id : constant Entity_Id := Get_Called_Entity (N); 3502 Formal : Node_Id; 3503 Actual : Node_Id; 3504 3505 begin 3506 Formal := First_Formal (Id); 3507 Actual := First_Actual (N); 3508 while Present (Actual) and then Present (Formal) loop 3509 if Ekind (Formal) in E_Out_Parameter | E_In_Out_Parameter 3510 then 3511 Collect_Identifiers (Actual); 3512 end if; 3513 3514 Next_Formal (Formal); 3515 Next_Actual (Actual); 3516 end loop; 3517 end; 3518 3519 when N_Aggregate 3520 | N_Extension_Aggregate 3521 => 3522 declare 3523 Assoc : Node_Id; 3524 Choice : Node_Id; 3525 Comp_Expr : Node_Id; 3526 3527 begin 3528 -- Handle the N_Others_Choice of array aggregates with static 3529 -- bounds. There is no need to perform this analysis in 3530 -- aggregates without static bounds since we cannot evaluate 3531 -- if the N_Others_Choice covers several elements. There is 3532 -- no need to handle the N_Others choice of record aggregates 3533 -- since at this stage it has been already expanded by 3534 -- Resolve_Record_Aggregate. 3535 3536 if Is_Array_Type (Etype (N)) 3537 and then Nkind (N) = N_Aggregate 3538 and then Present (Aggregate_Bounds (N)) 3539 and then Compile_Time_Known_Bounds (Etype (N)) 3540 and then Expr_Value (High_Bound (Aggregate_Bounds (N))) 3541 > 3542 Expr_Value (Low_Bound (Aggregate_Bounds (N))) 3543 then 3544 declare 3545 Count_Components : Uint := Uint_0; 3546 Num_Components : Uint; 3547 Others_Assoc : Node_Id := Empty; 3548 Others_Choice : Node_Id := Empty; 3549 Others_Box_Present : Boolean := False; 3550 3551 begin 3552 -- Count positional associations 3553 3554 if Present (Expressions (N)) then 3555 Comp_Expr := First (Expressions (N)); 3556 while Present (Comp_Expr) loop 3557 Count_Components := Count_Components + 1; 3558 Next (Comp_Expr); 3559 end loop; 3560 end if; 3561 3562 -- Count the rest of elements and locate the N_Others 3563 -- choice (if any) 3564 3565 Assoc := First (Component_Associations (N)); 3566 while Present (Assoc) loop 3567 Choice := First (Choices (Assoc)); 3568 while Present (Choice) loop 3569 if Nkind (Choice) = N_Others_Choice then 3570 Others_Assoc := Assoc; 3571 Others_Choice := Choice; 3572 Others_Box_Present := Box_Present (Assoc); 3573 3574 -- Count several components 3575 3576 elsif Nkind (Choice) in 3577 N_Range | N_Subtype_Indication 3578 or else (Is_Entity_Name (Choice) 3579 and then Is_Type (Entity (Choice))) 3580 then 3581 declare 3582 L, H : Node_Id; 3583 begin 3584 Get_Index_Bounds (Choice, L, H); 3585 pragma Assert 3586 (Compile_Time_Known_Value (L) 3587 and then Compile_Time_Known_Value (H)); 3588 Count_Components := 3589 Count_Components 3590 + Expr_Value (H) - Expr_Value (L) + 1; 3591 end; 3592 3593 -- Count single component. No other case available 3594 -- since we are handling an aggregate with static 3595 -- bounds. 3596 3597 else 3598 pragma Assert (Is_OK_Static_Expression (Choice) 3599 or else Nkind (Choice) = N_Identifier 3600 or else Nkind (Choice) = N_Integer_Literal); 3601 3602 Count_Components := Count_Components + 1; 3603 end if; 3604 3605 Next (Choice); 3606 end loop; 3607 3608 Next (Assoc); 3609 end loop; 3610 3611 Num_Components := 3612 Expr_Value (High_Bound (Aggregate_Bounds (N))) - 3613 Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1; 3614 3615 pragma Assert (Count_Components <= Num_Components); 3616 3617 -- Handle the N_Others choice if it covers several 3618 -- components 3619 3620 if Present (Others_Choice) 3621 and then (Num_Components - Count_Components) > 1 3622 then 3623 if not Others_Box_Present then 3624 3625 -- At this stage, if expansion is active, the 3626 -- expression of the others choice has not been 3627 -- analyzed. Hence we generate a duplicate and 3628 -- we analyze it silently to have available the 3629 -- minimum decoration required to collect the 3630 -- identifiers. 3631 3632 pragma Assert (Present (Others_Assoc)); 3633 3634 if not Expander_Active then 3635 Comp_Expr := Expression (Others_Assoc); 3636 else 3637 Comp_Expr := 3638 New_Copy_Tree (Expression (Others_Assoc)); 3639 Preanalyze_Without_Errors (Comp_Expr); 3640 end if; 3641 3642 Collect_Identifiers (Comp_Expr); 3643 3644 if Writable_Actuals_List /= No_Elist then 3645 3646 -- As suggested by Robert, at current stage we 3647 -- report occurrences of this case as warnings. 3648 3649 Error_Msg_N 3650 ("writable function parameter may affect " 3651 & "value in other component because order " 3652 & "of evaluation is unspecified??", 3653 Node (First_Elmt (Writable_Actuals_List))); 3654 end if; 3655 end if; 3656 end if; 3657 end; 3658 3659 -- For an array aggregate, a discrete_choice_list that has 3660 -- a nonstatic range is considered as two or more separate 3661 -- occurrences of the expression (RM 6.4.1(20/3)). 3662 3663 elsif Is_Array_Type (Etype (N)) 3664 and then Nkind (N) = N_Aggregate 3665 and then Present (Aggregate_Bounds (N)) 3666 and then not Compile_Time_Known_Bounds (Etype (N)) 3667 then 3668 -- Collect identifiers found in the dynamic bounds 3669 3670 declare 3671 Count_Components : Natural := 0; 3672 Low, High : Node_Id; 3673 3674 begin 3675 Assoc := First (Component_Associations (N)); 3676 while Present (Assoc) loop 3677 Choice := First (Choices (Assoc)); 3678 while Present (Choice) loop 3679 if Nkind (Choice) in 3680 N_Range | N_Subtype_Indication 3681 or else (Is_Entity_Name (Choice) 3682 and then Is_Type (Entity (Choice))) 3683 then 3684 Get_Index_Bounds (Choice, Low, High); 3685 3686 if not Compile_Time_Known_Value (Low) then 3687 Collect_Identifiers (Low); 3688 3689 if No (Aggr_Error_Node) then 3690 Aggr_Error_Node := Low; 3691 end if; 3692 end if; 3693 3694 if not Compile_Time_Known_Value (High) then 3695 Collect_Identifiers (High); 3696 3697 if No (Aggr_Error_Node) then 3698 Aggr_Error_Node := High; 3699 end if; 3700 end if; 3701 3702 -- The RM rule is violated if there is more than 3703 -- a single choice in a component association. 3704 3705 else 3706 Count_Components := Count_Components + 1; 3707 3708 if No (Aggr_Error_Node) 3709 and then Count_Components > 1 3710 then 3711 Aggr_Error_Node := Choice; 3712 end if; 3713 3714 if not Compile_Time_Known_Value (Choice) then 3715 Collect_Identifiers (Choice); 3716 end if; 3717 end if; 3718 3719 Next (Choice); 3720 end loop; 3721 3722 Next (Assoc); 3723 end loop; 3724 end; 3725 end if; 3726 3727 -- Handle ancestor part of extension aggregates 3728 3729 if Nkind (N) = N_Extension_Aggregate then 3730 Collect_Identifiers (Ancestor_Part (N)); 3731 end if; 3732 3733 -- Handle positional associations 3734 3735 if Present (Expressions (N)) then 3736 Comp_Expr := First (Expressions (N)); 3737 while Present (Comp_Expr) loop 3738 if not Is_OK_Static_Expression (Comp_Expr) then 3739 Collect_Identifiers (Comp_Expr); 3740 end if; 3741 3742 Next (Comp_Expr); 3743 end loop; 3744 end if; 3745 3746 -- Handle discrete associations 3747 3748 if Present (Component_Associations (N)) then 3749 Assoc := First (Component_Associations (N)); 3750 while Present (Assoc) loop 3751 3752 if not Box_Present (Assoc) then 3753 Choice := First (Choices (Assoc)); 3754 while Present (Choice) loop 3755 3756 -- For now we skip discriminants since it requires 3757 -- performing the analysis in two phases: first one 3758 -- analyzing discriminants and second one analyzing 3759 -- the rest of components since discriminants are 3760 -- evaluated prior to components: too much extra 3761 -- work to detect a corner case??? 3762 3763 if Nkind (Choice) in N_Has_Entity 3764 and then Present (Entity (Choice)) 3765 and then Ekind (Entity (Choice)) = E_Discriminant 3766 then 3767 null; 3768 3769 elsif Box_Present (Assoc) then 3770 null; 3771 3772 else 3773 if not Analyzed (Expression (Assoc)) then 3774 Comp_Expr := 3775 New_Copy_Tree (Expression (Assoc)); 3776 Set_Parent (Comp_Expr, Parent (N)); 3777 Preanalyze_Without_Errors (Comp_Expr); 3778 else 3779 Comp_Expr := Expression (Assoc); 3780 end if; 3781 3782 Collect_Identifiers (Comp_Expr); 3783 end if; 3784 3785 Next (Choice); 3786 end loop; 3787 end if; 3788 3789 Next (Assoc); 3790 end loop; 3791 end if; 3792 end; 3793 3794 when others => 3795 return; 3796 end case; 3797 3798 -- No further action needed if we already reported an error 3799 3800 if Present (Error_Node) then 3801 return; 3802 end if; 3803 3804 -- Check violation of RM 6.20/3 in aggregates 3805 3806 if Present (Aggr_Error_Node) 3807 and then Writable_Actuals_List /= No_Elist 3808 then 3809 Error_Msg_N 3810 ("value may be affected by call in other component because they " 3811 & "are evaluated in unspecified order", 3812 Node (First_Elmt (Writable_Actuals_List))); 3813 return; 3814 end if; 3815 3816 -- Check if some writable argument of a function is referenced 3817 3818 if Writable_Actuals_List /= No_Elist 3819 and then Identifiers_List /= No_Elist 3820 then 3821 declare 3822 Elmt_1 : Elmt_Id; 3823 Elmt_2 : Elmt_Id; 3824 3825 begin 3826 Elmt_1 := First_Elmt (Writable_Actuals_List); 3827 while Present (Elmt_1) loop 3828 Elmt_2 := First_Elmt (Identifiers_List); 3829 while Present (Elmt_2) loop 3830 if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then 3831 case Nkind (Parent (Node (Elmt_2))) is 3832 when N_Aggregate 3833 | N_Component_Association 3834 | N_Component_Declaration 3835 => 3836 Error_Msg_N 3837 ("value may be affected by call in other " 3838 & "component because they are evaluated " 3839 & "in unspecified order", 3840 Node (Elmt_2)); 3841 3842 when N_In 3843 | N_Not_In 3844 => 3845 Error_Msg_N 3846 ("value may be affected by call in other " 3847 & "alternative because they are evaluated " 3848 & "in unspecified order", 3849 Node (Elmt_2)); 3850 3851 when others => 3852 Error_Msg_N 3853 ("value of actual may be affected by call in " 3854 & "other actual because they are evaluated " 3855 & "in unspecified order", 3856 Node (Elmt_2)); 3857 end case; 3858 end if; 3859 3860 Next_Elmt (Elmt_2); 3861 end loop; 3862 3863 Next_Elmt (Elmt_1); 3864 end loop; 3865 end; 3866 end if; 3867 end Check_Function_Writable_Actuals; 3868 3869 -------------------------------- 3870 -- Check_Implicit_Dereference -- 3871 -------------------------------- 3872 3873 procedure Check_Implicit_Dereference (N : Node_Id; Typ : Entity_Id) is 3874 Disc : Entity_Id; 3875 Desig : Entity_Id; 3876 Nam : Node_Id; 3877 3878 begin 3879 if Nkind (N) = N_Indexed_Component 3880 and then Present (Generalized_Indexing (N)) 3881 then 3882 Nam := Generalized_Indexing (N); 3883 else 3884 Nam := N; 3885 end if; 3886 3887 if Ada_Version < Ada_2012 3888 or else not Has_Implicit_Dereference (Base_Type (Typ)) 3889 then 3890 return; 3891 3892 elsif not Comes_From_Source (N) 3893 and then Nkind (N) /= N_Indexed_Component 3894 then 3895 return; 3896 3897 elsif Is_Entity_Name (Nam) and then Is_Type (Entity (Nam)) then 3898 null; 3899 3900 else 3901 Disc := First_Discriminant (Typ); 3902 while Present (Disc) loop 3903 if Has_Implicit_Dereference (Disc) then 3904 Desig := Designated_Type (Etype (Disc)); 3905 Add_One_Interp (Nam, Disc, Desig); 3906 3907 -- If the node is a generalized indexing, add interpretation 3908 -- to that node as well, for subsequent resolution. 3909 3910 if Nkind (N) = N_Indexed_Component then 3911 Add_One_Interp (N, Disc, Desig); 3912 end if; 3913 3914 -- If the operation comes from a generic unit and the context 3915 -- is a selected component, the selector name may be global 3916 -- and set in the instance already. Remove the entity to 3917 -- force resolution of the selected component, and the 3918 -- generation of an explicit dereference if needed. 3919 3920 if In_Instance 3921 and then Nkind (Parent (Nam)) = N_Selected_Component 3922 then 3923 Set_Entity (Selector_Name (Parent (Nam)), Empty); 3924 end if; 3925 3926 exit; 3927 end if; 3928 3929 Next_Discriminant (Disc); 3930 end loop; 3931 end if; 3932 end Check_Implicit_Dereference; 3933 3934 ---------------------------------- 3935 -- Check_Internal_Protected_Use -- 3936 ---------------------------------- 3937 3938 procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is 3939 S : Entity_Id; 3940 Prot : Entity_Id; 3941 3942 begin 3943 Prot := Empty; 3944 3945 S := Current_Scope; 3946 while Present (S) loop 3947 if S = Standard_Standard then 3948 exit; 3949 3950 elsif Ekind (S) = E_Function 3951 and then Ekind (Scope (S)) = E_Protected_Type 3952 then 3953 Prot := Scope (S); 3954 exit; 3955 end if; 3956 3957 S := Scope (S); 3958 end loop; 3959 3960 if Present (Prot) 3961 and then Scope (Nam) = Prot 3962 and then Ekind (Nam) /= E_Function 3963 then 3964 -- An indirect function call (e.g. a callback within a protected 3965 -- function body) is not statically illegal. If the access type is 3966 -- anonymous and is the type of an access parameter, the scope of Nam 3967 -- will be the protected type, but it is not a protected operation. 3968 3969 if Ekind (Nam) = E_Subprogram_Type 3970 and then Nkind (Associated_Node_For_Itype (Nam)) = 3971 N_Function_Specification 3972 then 3973 null; 3974 3975 elsif Nkind (N) = N_Subprogram_Renaming_Declaration then 3976 Error_Msg_N 3977 ("within protected function cannot use protected procedure in " 3978 & "renaming or as generic actual", N); 3979 3980 elsif Nkind (N) = N_Attribute_Reference then 3981 Error_Msg_N 3982 ("within protected function cannot take access of protected " 3983 & "procedure", N); 3984 3985 else 3986 Error_Msg_N 3987 ("within protected function, protected object is constant", N); 3988 Error_Msg_N 3989 ("\cannot call operation that may modify it", N); 3990 end if; 3991 end if; 3992 3993 -- Verify that an internal call does not appear within a precondition 3994 -- of a protected operation. This implements AI12-0166. 3995 -- The precondition aspect has been rewritten as a pragma Precondition 3996 -- and we check whether the scope of the called subprogram is the same 3997 -- as that of the entity to which the aspect applies. 3998 3999 if Convention (Nam) = Convention_Protected then 4000 declare 4001 P : Node_Id; 4002 4003 begin 4004 P := Parent (N); 4005 while Present (P) loop 4006 if Nkind (P) = N_Pragma 4007 and then Chars (Pragma_Identifier (P)) = Name_Precondition 4008 and then From_Aspect_Specification (P) 4009 and then 4010 Scope (Entity (Corresponding_Aspect (P))) = Scope (Nam) 4011 then 4012 Error_Msg_N 4013 ("internal call cannot appear in precondition of " 4014 & "protected operation", N); 4015 return; 4016 4017 elsif Nkind (P) = N_Pragma 4018 and then Chars (Pragma_Identifier (P)) = Name_Contract_Cases 4019 then 4020 -- Check whether call is in a case guard. It is legal in a 4021 -- consequence. 4022 4023 P := N; 4024 while Present (P) loop 4025 if Nkind (Parent (P)) = N_Component_Association 4026 and then P /= Expression (Parent (P)) 4027 then 4028 Error_Msg_N 4029 ("internal call cannot appear in case guard in a " 4030 & "contract case", N); 4031 end if; 4032 4033 P := Parent (P); 4034 end loop; 4035 4036 return; 4037 4038 elsif Nkind (P) = N_Parameter_Specification 4039 and then Scope (Current_Scope) = Scope (Nam) 4040 and then Nkind (Parent (P)) in 4041 N_Entry_Declaration | N_Subprogram_Declaration 4042 then 4043 Error_Msg_N 4044 ("internal call cannot appear in default for formal of " 4045 & "protected operation", N); 4046 return; 4047 end if; 4048 4049 P := Parent (P); 4050 end loop; 4051 end; 4052 end if; 4053 end Check_Internal_Protected_Use; 4054 4055 --------------------------------------- 4056 -- Check_Later_Vs_Basic_Declarations -- 4057 --------------------------------------- 4058 4059 procedure Check_Later_Vs_Basic_Declarations 4060 (Decls : List_Id; 4061 During_Parsing : Boolean) 4062 is 4063 Body_Sloc : Source_Ptr; 4064 Decl : Node_Id; 4065 4066 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean; 4067 -- Return whether Decl is considered as a declarative item. 4068 -- When During_Parsing is True, the semantics of Ada 83 is followed. 4069 -- When During_Parsing is False, the semantics of SPARK is followed. 4070 4071 ------------------------------- 4072 -- Is_Later_Declarative_Item -- 4073 ------------------------------- 4074 4075 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is 4076 begin 4077 if Nkind (Decl) in N_Later_Decl_Item then 4078 return True; 4079 4080 elsif Nkind (Decl) = N_Pragma then 4081 return True; 4082 4083 elsif During_Parsing then 4084 return False; 4085 4086 -- In SPARK, a package declaration is not considered as a later 4087 -- declarative item. 4088 4089 elsif Nkind (Decl) = N_Package_Declaration then 4090 return False; 4091 4092 -- In SPARK, a renaming is considered as a later declarative item 4093 4094 elsif Nkind (Decl) in N_Renaming_Declaration then 4095 return True; 4096 4097 else 4098 return False; 4099 end if; 4100 end Is_Later_Declarative_Item; 4101 4102 -- Start of processing for Check_Later_Vs_Basic_Declarations 4103 4104 begin 4105 Decl := First (Decls); 4106 4107 -- Loop through sequence of basic declarative items 4108 4109 Outer : while Present (Decl) loop 4110 if Nkind (Decl) not in 4111 N_Subprogram_Body | N_Package_Body | N_Task_Body 4112 and then Nkind (Decl) not in N_Body_Stub 4113 then 4114 Next (Decl); 4115 4116 -- Once a body is encountered, we only allow later declarative 4117 -- items. The inner loop checks the rest of the list. 4118 4119 else 4120 Body_Sloc := Sloc (Decl); 4121 4122 Inner : while Present (Decl) loop 4123 if not Is_Later_Declarative_Item (Decl) then 4124 if During_Parsing then 4125 if Ada_Version = Ada_83 then 4126 Error_Msg_Sloc := Body_Sloc; 4127 Error_Msg_N 4128 ("(Ada 83) decl cannot appear after body#", Decl); 4129 end if; 4130 end if; 4131 end if; 4132 4133 Next (Decl); 4134 end loop Inner; 4135 end if; 4136 end loop Outer; 4137 end Check_Later_Vs_Basic_Declarations; 4138 4139 --------------------------- 4140 -- Check_No_Hidden_State -- 4141 --------------------------- 4142 4143 procedure Check_No_Hidden_State (Id : Entity_Id) is 4144 Context : Entity_Id := Empty; 4145 Not_Visible : Boolean := False; 4146 Scop : Entity_Id; 4147 4148 begin 4149 pragma Assert (Ekind (Id) in E_Abstract_State | E_Variable); 4150 4151 -- Nothing to do for internally-generated abstract states and variables 4152 -- because they do not represent the hidden state of the source unit. 4153 4154 if not Comes_From_Source (Id) then 4155 return; 4156 end if; 4157 4158 -- Find the proper context where the object or state appears 4159 4160 Scop := Scope (Id); 4161 while Present (Scop) loop 4162 Context := Scop; 4163 4164 -- Keep track of the context's visibility 4165 4166 Not_Visible := Not_Visible or else In_Private_Part (Context); 4167 4168 -- Prevent the search from going too far 4169 4170 if Context = Standard_Standard then 4171 return; 4172 4173 -- Objects and states that appear immediately within a subprogram or 4174 -- entry inside a construct nested within a subprogram do not 4175 -- introduce a hidden state. They behave as local variable 4176 -- declarations. The same is true for elaboration code inside a block 4177 -- or a task. 4178 4179 elsif Is_Subprogram_Or_Entry (Context) 4180 or else Ekind (Context) in E_Block | E_Task_Type 4181 then 4182 return; 4183 end if; 4184 4185 -- Stop the traversal when a package subject to a null abstract state 4186 -- has been found. 4187 4188 if Is_Package_Or_Generic_Package (Context) 4189 and then Has_Null_Abstract_State (Context) 4190 then 4191 exit; 4192 end if; 4193 4194 Scop := Scope (Scop); 4195 end loop; 4196 4197 -- At this point we know that there is at least one package with a null 4198 -- abstract state in visibility. Emit an error message unconditionally 4199 -- if the entity being processed is a state because the placement of the 4200 -- related package is irrelevant. This is not the case for objects as 4201 -- the intermediate context matters. 4202 4203 if Present (Context) 4204 and then (Ekind (Id) = E_Abstract_State or else Not_Visible) 4205 then 4206 Error_Msg_N ("cannot introduce hidden state &", Id); 4207 Error_Msg_NE ("\package & has null abstract state", Id, Context); 4208 end if; 4209 end Check_No_Hidden_State; 4210 4211 --------------------------------------------- 4212 -- Check_Nonoverridable_Aspect_Consistency -- 4213 --------------------------------------------- 4214 4215 procedure Check_Inherited_Nonoverridable_Aspects 4216 (Inheritor : Entity_Id; 4217 Interface_List : List_Id; 4218 Parent_Type : Entity_Id) is 4219 4220 -- array needed for iterating over subtype values 4221 Nonoverridable_Aspects : constant array (Positive range <>) of 4222 Nonoverridable_Aspect_Id := 4223 (Aspect_Default_Iterator, 4224 Aspect_Iterator_Element, 4225 Aspect_Implicit_Dereference, 4226 Aspect_Constant_Indexing, 4227 Aspect_Variable_Indexing, 4228 Aspect_Aggregate, 4229 Aspect_Max_Entry_Queue_Length 4230 -- , Aspect_No_Controlled_Parts 4231 ); 4232 4233 -- Note that none of these 8 aspects can be specified (for a type) 4234 -- via a pragma. For 7 of them, the corresponding pragma does not 4235 -- exist. The Pragma_Id enumeration type does include 4236 -- Pragma_Max_Entry_Queue_Length, but that pragma is only use to 4237 -- specify the aspect for a protected entry or entry family, not for 4238 -- a type, and therefore cannot introduce the sorts of inheritance 4239 -- issues that we are concerned with in this procedure. 4240 4241 type Entity_Array is array (Nat range <>) of Entity_Id; 4242 4243 function Ancestor_Entities return Entity_Array; 4244 -- Returns all progenitors (including parent type, if present) 4245 4246 procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors 4247 (Aspect : Nonoverridable_Aspect_Id; 4248 Ancestor_1 : Entity_Id; 4249 Aspect_Spec_1 : Node_Id; 4250 Ancestor_2 : Entity_Id; 4251 Aspect_Spec_2 : Node_Id); 4252 -- A given aspect has been specified for each of two ancestors; 4253 -- check that the two aspect specifications are compatible (see 4254 -- RM 13.1.1(18.5) and AI12-0211). 4255 4256 ----------------------- 4257 -- Ancestor_Entities -- 4258 ----------------------- 4259 4260 function Ancestor_Entities return Entity_Array is 4261 Ifc_Count : constant Nat := List_Length (Interface_List); 4262 Ifc_Ancestors : Entity_Array (1 .. Ifc_Count); 4263 Ifc : Node_Id := First (Interface_List); 4264 begin 4265 for Idx in Ifc_Ancestors'Range loop 4266 Ifc_Ancestors (Idx) := Entity (Ifc); 4267 pragma Assert (Present (Ifc_Ancestors (Idx))); 4268 Ifc := Next (Ifc); 4269 end loop; 4270 pragma Assert (not Present (Ifc)); 4271 if Present (Parent_Type) then 4272 return Parent_Type & Ifc_Ancestors; 4273 else 4274 return Ifc_Ancestors; 4275 end if; 4276 end Ancestor_Entities; 4277 4278 ------------------------------------------------------- 4279 -- Check_Consistency_For_One_Aspect_Of_Two_Ancestors -- 4280 ------------------------------------------------------- 4281 4282 procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors 4283 (Aspect : Nonoverridable_Aspect_Id; 4284 Ancestor_1 : Entity_Id; 4285 Aspect_Spec_1 : Node_Id; 4286 Ancestor_2 : Entity_Id; 4287 Aspect_Spec_2 : Node_Id) is 4288 begin 4289 if not Is_Confirming (Aspect, Aspect_Spec_1, Aspect_Spec_2) then 4290 Error_Msg_Name_1 := Aspect_Names (Aspect); 4291 Error_Msg_Name_2 := Chars (Ancestor_1); 4292 Error_Msg_Name_3 := Chars (Ancestor_2); 4293 4294 Error_Msg ( 4295 "incompatible % aspects inherited from ancestors % and %", 4296 Sloc (Inheritor)); 4297 end if; 4298 end Check_Consistency_For_One_Aspect_Of_Two_Ancestors; 4299 4300 Ancestors : constant Entity_Array := Ancestor_Entities; 4301 4302 -- start of processing for Check_Inherited_Nonoverridable_Aspects 4303 begin 4304 -- No Ada_Version check here; AI12-0211 is a binding interpretation. 4305 4306 if Ancestors'Length < 2 then 4307 return; -- Inconsistency impossible; it takes 2 to disagree. 4308 elsif In_Instance_Body then 4309 return; -- No legality checking in an instance body. 4310 end if; 4311 4312 for Aspect of Nonoverridable_Aspects loop 4313 declare 4314 First_Ancestor_With_Aspect : Entity_Id := Empty; 4315 First_Aspect_Spec, Current_Aspect_Spec : Node_Id := Empty; 4316 begin 4317 for Ancestor of Ancestors loop 4318 Current_Aspect_Spec := Find_Aspect (Ancestor, Aspect); 4319 if Present (Current_Aspect_Spec) then 4320 if Present (First_Ancestor_With_Aspect) then 4321 Check_Consistency_For_One_Aspect_Of_Two_Ancestors 4322 (Aspect => Aspect, 4323 Ancestor_1 => First_Ancestor_With_Aspect, 4324 Aspect_Spec_1 => First_Aspect_Spec, 4325 Ancestor_2 => Ancestor, 4326 Aspect_Spec_2 => Current_Aspect_Spec); 4327 else 4328 First_Ancestor_With_Aspect := Ancestor; 4329 First_Aspect_Spec := Current_Aspect_Spec; 4330 end if; 4331 end if; 4332 end loop; 4333 end; 4334 end loop; 4335 end Check_Inherited_Nonoverridable_Aspects; 4336 4337 ---------------------------------------- 4338 -- Check_Nonvolatile_Function_Profile -- 4339 ---------------------------------------- 4340 4341 procedure Check_Nonvolatile_Function_Profile (Func_Id : Entity_Id) is 4342 Formal : Entity_Id; 4343 4344 begin 4345 -- Inspect all formal parameters 4346 4347 Formal := First_Formal (Func_Id); 4348 while Present (Formal) loop 4349 if Is_Effectively_Volatile_For_Reading (Etype (Formal)) then 4350 Error_Msg_NE 4351 ("nonvolatile function & cannot have a volatile parameter", 4352 Formal, Func_Id); 4353 end if; 4354 4355 Next_Formal (Formal); 4356 end loop; 4357 4358 -- Inspect the return type 4359 4360 if Is_Effectively_Volatile_For_Reading (Etype (Func_Id)) then 4361 Error_Msg_NE 4362 ("nonvolatile function & cannot have a volatile return type", 4363 Result_Definition (Parent (Func_Id)), Func_Id); 4364 end if; 4365 end Check_Nonvolatile_Function_Profile; 4366 4367 ----------------------------- 4368 -- Check_Part_Of_Reference -- 4369 ----------------------------- 4370 4371 procedure Check_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id) is 4372 function Is_Enclosing_Package_Body 4373 (Body_Decl : Node_Id; 4374 Obj_Id : Entity_Id) return Boolean; 4375 pragma Inline (Is_Enclosing_Package_Body); 4376 -- Determine whether package body Body_Decl or its corresponding spec 4377 -- immediately encloses the declaration of object Obj_Id. 4378 4379 function Is_Internal_Declaration_Or_Body 4380 (Decl : Node_Id) return Boolean; 4381 pragma Inline (Is_Internal_Declaration_Or_Body); 4382 -- Determine whether declaration or body denoted by Decl is internal 4383 4384 function Is_Single_Declaration_Or_Body 4385 (Decl : Node_Id; 4386 Conc_Typ : Entity_Id) return Boolean; 4387 pragma Inline (Is_Single_Declaration_Or_Body); 4388 -- Determine whether protected/task declaration or body denoted by Decl 4389 -- belongs to single concurrent type Conc_Typ. 4390 4391 function Is_Single_Task_Pragma 4392 (Prag : Node_Id; 4393 Task_Typ : Entity_Id) return Boolean; 4394 pragma Inline (Is_Single_Task_Pragma); 4395 -- Determine whether pragma Prag belongs to single task type Task_Typ 4396 4397 ------------------------------- 4398 -- Is_Enclosing_Package_Body -- 4399 ------------------------------- 4400 4401 function Is_Enclosing_Package_Body 4402 (Body_Decl : Node_Id; 4403 Obj_Id : Entity_Id) return Boolean 4404 is 4405 Obj_Context : Node_Id; 4406 4407 begin 4408 -- Find the context of the object declaration 4409 4410 Obj_Context := Parent (Declaration_Node (Obj_Id)); 4411 4412 if Nkind (Obj_Context) = N_Package_Specification then 4413 Obj_Context := Parent (Obj_Context); 4414 end if; 4415 4416 -- The object appears immediately within the package body 4417 4418 if Obj_Context = Body_Decl then 4419 return True; 4420 4421 -- The object appears immediately within the corresponding spec 4422 4423 elsif Nkind (Obj_Context) = N_Package_Declaration 4424 and then Unit_Declaration_Node (Corresponding_Spec (Body_Decl)) = 4425 Obj_Context 4426 then 4427 return True; 4428 end if; 4429 4430 return False; 4431 end Is_Enclosing_Package_Body; 4432 4433 ------------------------------------- 4434 -- Is_Internal_Declaration_Or_Body -- 4435 ------------------------------------- 4436 4437 function Is_Internal_Declaration_Or_Body 4438 (Decl : Node_Id) return Boolean 4439 is 4440 begin 4441 if Comes_From_Source (Decl) then 4442 return False; 4443 4444 -- A body generated for an expression function which has not been 4445 -- inserted into the tree yet (In_Spec_Expression is True) is not 4446 -- considered internal. 4447 4448 elsif Nkind (Decl) = N_Subprogram_Body 4449 and then Was_Expression_Function (Decl) 4450 and then not In_Spec_Expression 4451 then 4452 return False; 4453 end if; 4454 4455 return True; 4456 end Is_Internal_Declaration_Or_Body; 4457 4458 ----------------------------------- 4459 -- Is_Single_Declaration_Or_Body -- 4460 ----------------------------------- 4461 4462 function Is_Single_Declaration_Or_Body 4463 (Decl : Node_Id; 4464 Conc_Typ : Entity_Id) return Boolean 4465 is 4466 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl); 4467 4468 begin 4469 return 4470 Present (Anonymous_Object (Spec_Id)) 4471 and then Anonymous_Object (Spec_Id) = Conc_Typ; 4472 end Is_Single_Declaration_Or_Body; 4473 4474 --------------------------- 4475 -- Is_Single_Task_Pragma -- 4476 --------------------------- 4477 4478 function Is_Single_Task_Pragma 4479 (Prag : Node_Id; 4480 Task_Typ : Entity_Id) return Boolean 4481 is 4482 Decl : constant Node_Id := Find_Related_Declaration_Or_Body (Prag); 4483 4484 begin 4485 -- To qualify, the pragma must be associated with single task type 4486 -- Task_Typ. 4487 4488 return 4489 Is_Single_Task_Object (Task_Typ) 4490 and then Nkind (Decl) = N_Object_Declaration 4491 and then Defining_Entity (Decl) = Task_Typ; 4492 end Is_Single_Task_Pragma; 4493 4494 -- Local variables 4495 4496 Conc_Obj : constant Entity_Id := Encapsulating_State (Var_Id); 4497 Par : Node_Id; 4498 Prag_Nam : Name_Id; 4499 Prev : Node_Id; 4500 4501 -- Start of processing for Check_Part_Of_Reference 4502 4503 begin 4504 -- Nothing to do when the variable was recorded, but did not become a 4505 -- constituent of a single concurrent type. 4506 4507 if No (Conc_Obj) then 4508 return; 4509 end if; 4510 4511 -- Traverse the parent chain looking for a suitable context for the 4512 -- reference to the concurrent constituent. 4513 4514 Prev := Ref; 4515 Par := Parent (Prev); 4516 while Present (Par) loop 4517 if Nkind (Par) = N_Pragma then 4518 Prag_Nam := Pragma_Name (Par); 4519 4520 -- A concurrent constituent is allowed to appear in pragmas 4521 -- Initial_Condition and Initializes as this is part of the 4522 -- elaboration checks for the constituent (SPARK RM 9(3)). 4523 4524 if Prag_Nam in Name_Initial_Condition | Name_Initializes then 4525 return; 4526 4527 -- When the reference appears within pragma Depends or Global, 4528 -- check whether the pragma applies to a single task type. Note 4529 -- that the pragma may not encapsulated by the type definition, 4530 -- but this is still a valid context. 4531 4532 elsif Prag_Nam in Name_Depends | Name_Global 4533 and then Is_Single_Task_Pragma (Par, Conc_Obj) 4534 then 4535 return; 4536 end if; 4537 4538 -- The reference appears somewhere in the definition of a single 4539 -- concurrent type (SPARK RM 9(3)). 4540 4541 elsif Nkind (Par) in 4542 N_Single_Protected_Declaration | N_Single_Task_Declaration 4543 and then Defining_Entity (Par) = Conc_Obj 4544 then 4545 return; 4546 4547 -- The reference appears within the declaration or body of a single 4548 -- concurrent type (SPARK RM 9(3)). 4549 4550 elsif Nkind (Par) in N_Protected_Body 4551 | N_Protected_Type_Declaration 4552 | N_Task_Body 4553 | N_Task_Type_Declaration 4554 and then Is_Single_Declaration_Or_Body (Par, Conc_Obj) 4555 then 4556 return; 4557 4558 -- The reference appears within the statement list of the object's 4559 -- immediately enclosing package (SPARK RM 9(3)). 4560 4561 elsif Nkind (Par) = N_Package_Body 4562 and then Nkind (Prev) = N_Handled_Sequence_Of_Statements 4563 and then Is_Enclosing_Package_Body (Par, Var_Id) 4564 then 4565 return; 4566 4567 -- The reference has been relocated within an internally generated 4568 -- package or subprogram. Assume that the reference is legal as the 4569 -- real check was already performed in the original context of the 4570 -- reference. 4571 4572 elsif Nkind (Par) in N_Package_Body 4573 | N_Package_Declaration 4574 | N_Subprogram_Body 4575 | N_Subprogram_Declaration 4576 and then Is_Internal_Declaration_Or_Body (Par) 4577 then 4578 return; 4579 4580 -- The reference has been relocated to an inlined body for GNATprove. 4581 -- Assume that the reference is legal as the real check was already 4582 -- performed in the original context of the reference. 4583 4584 elsif GNATprove_Mode 4585 and then Nkind (Par) = N_Subprogram_Body 4586 and then Chars (Defining_Entity (Par)) = Name_uParent 4587 then 4588 return; 4589 end if; 4590 4591 Prev := Par; 4592 Par := Parent (Prev); 4593 end loop; 4594 4595 -- At this point it is known that the reference does not appear within a 4596 -- legal context. 4597 4598 Error_Msg_NE 4599 ("reference to variable & cannot appear in this context", Ref, Var_Id); 4600 Error_Msg_Name_1 := Chars (Var_Id); 4601 4602 if Is_Single_Protected_Object (Conc_Obj) then 4603 Error_Msg_NE 4604 ("\% is constituent of single protected type &", Ref, Conc_Obj); 4605 4606 else 4607 Error_Msg_NE 4608 ("\% is constituent of single task type &", Ref, Conc_Obj); 4609 end if; 4610 end Check_Part_Of_Reference; 4611 4612 ------------------------------------------ 4613 -- Check_Potentially_Blocking_Operation -- 4614 ------------------------------------------ 4615 4616 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is 4617 S : Entity_Id; 4618 4619 begin 4620 -- N is one of the potentially blocking operations listed in 9.5.1(8). 4621 -- When pragma Detect_Blocking is active, the run time will raise 4622 -- Program_Error. Here we only issue a warning, since we generally 4623 -- support the use of potentially blocking operations in the absence 4624 -- of the pragma. 4625 4626 -- Indirect blocking through a subprogram call cannot be diagnosed 4627 -- statically without interprocedural analysis, so we do not attempt 4628 -- to do it here. 4629 4630 S := Scope (Current_Scope); 4631 while Present (S) and then S /= Standard_Standard loop 4632 if Is_Protected_Type (S) then 4633 Error_Msg_N 4634 ("potentially blocking operation in protected operation??", N); 4635 return; 4636 end if; 4637 4638 S := Scope (S); 4639 end loop; 4640 end Check_Potentially_Blocking_Operation; 4641 4642 ------------------------------------ 4643 -- Check_Previous_Null_Procedure -- 4644 ------------------------------------ 4645 4646 procedure Check_Previous_Null_Procedure 4647 (Decl : Node_Id; 4648 Prev : Entity_Id) 4649 is 4650 begin 4651 if Ekind (Prev) = E_Procedure 4652 and then Nkind (Parent (Prev)) = N_Procedure_Specification 4653 and then Null_Present (Parent (Prev)) 4654 then 4655 Error_Msg_Sloc := Sloc (Prev); 4656 Error_Msg_N 4657 ("declaration cannot complete previous null procedure#", Decl); 4658 end if; 4659 end Check_Previous_Null_Procedure; 4660 4661 --------------------------------- 4662 -- Check_Result_And_Post_State -- 4663 --------------------------------- 4664 4665 procedure Check_Result_And_Post_State (Subp_Id : Entity_Id) is 4666 procedure Check_Result_And_Post_State_In_Pragma 4667 (Prag : Node_Id; 4668 Result_Seen : in out Boolean); 4669 -- Determine whether pragma Prag mentions attribute 'Result and whether 4670 -- the pragma contains an expression that evaluates differently in pre- 4671 -- and post-state. Prag is a [refined] postcondition or a contract-cases 4672 -- pragma. Result_Seen is set when the pragma mentions attribute 'Result 4673 4674 ------------------------------------------- 4675 -- Check_Result_And_Post_State_In_Pragma -- 4676 ------------------------------------------- 4677 4678 procedure Check_Result_And_Post_State_In_Pragma 4679 (Prag : Node_Id; 4680 Result_Seen : in out Boolean) 4681 is 4682 procedure Check_Conjunct (Expr : Node_Id); 4683 -- Check an individual conjunct in a conjunction of Boolean 4684 -- expressions, connected by "and" or "and then" operators. 4685 4686 procedure Check_Conjuncts (Expr : Node_Id); 4687 -- Apply the post-state check to every conjunct in an expression, in 4688 -- case this is a conjunction of Boolean expressions. Otherwise apply 4689 -- it to the expression as a whole. 4690 4691 procedure Check_Expression (Expr : Node_Id); 4692 -- Perform the 'Result and post-state checks on a given expression 4693 4694 function Is_Function_Result (N : Node_Id) return Traverse_Result; 4695 -- Attempt to find attribute 'Result in a subtree denoted by N 4696 4697 function Is_Trivial_Boolean (N : Node_Id) return Boolean; 4698 -- Determine whether source node N denotes "True" or "False" 4699 4700 function Mentions_Post_State (N : Node_Id) return Boolean; 4701 -- Determine whether a subtree denoted by N mentions any construct 4702 -- that denotes a post-state. 4703 4704 procedure Check_Function_Result is 4705 new Traverse_Proc (Is_Function_Result); 4706 4707 -------------------- 4708 -- Check_Conjunct -- 4709 -------------------- 4710 4711 procedure Check_Conjunct (Expr : Node_Id) is 4712 function Adjust_Message (Msg : String) return String; 4713 -- Prepend a prefix to the input message Msg denoting that the 4714 -- message applies to a conjunct in the expression, when this 4715 -- is the case. 4716 4717 function Applied_On_Conjunct return Boolean; 4718 -- Returns True if the message applies to a conjunct in the 4719 -- expression, instead of the whole expression. 4720 4721 function Has_Global_Output (Subp : Entity_Id) return Boolean; 4722 -- Returns True if Subp has an output in its Global contract 4723 4724 function Has_No_Output (Subp : Entity_Id) return Boolean; 4725 -- Returns True if Subp has no declared output: no function 4726 -- result, no output parameter, and no output in its Global 4727 -- contract. 4728 4729 -------------------- 4730 -- Adjust_Message -- 4731 -------------------- 4732 4733 function Adjust_Message (Msg : String) return String is 4734 begin 4735 if Applied_On_Conjunct then 4736 return "conjunct in " & Msg; 4737 else 4738 return Msg; 4739 end if; 4740 end Adjust_Message; 4741 4742 ------------------------- 4743 -- Applied_On_Conjunct -- 4744 ------------------------- 4745 4746 function Applied_On_Conjunct return Boolean is 4747 begin 4748 -- Expr is the conjunct of an enclosing "and" expression 4749 4750 return Nkind (Parent (Expr)) in N_Subexpr 4751 4752 -- or Expr is a conjunct of an enclosing "and then" 4753 -- expression in a postcondition aspect that was split into 4754 -- multiple pragmas. The first conjunct has the "and then" 4755 -- expression as Original_Node, and other conjuncts have 4756 -- Split_PCC set to True. 4757 4758 or else Nkind (Original_Node (Expr)) = N_And_Then 4759 or else Split_PPC (Prag); 4760 end Applied_On_Conjunct; 4761 4762 ----------------------- 4763 -- Has_Global_Output -- 4764 ----------------------- 4765 4766 function Has_Global_Output (Subp : Entity_Id) return Boolean is 4767 Global : constant Node_Id := Get_Pragma (Subp, Pragma_Global); 4768 List : Node_Id; 4769 Assoc : Node_Id; 4770 4771 begin 4772 if No (Global) then 4773 return False; 4774 end if; 4775 4776 List := Expression (Get_Argument (Global, Subp)); 4777 4778 -- Empty list (no global items) or single global item 4779 -- declaration (only input items). 4780 4781 if Nkind (List) in N_Null 4782 | N_Expanded_Name 4783 | N_Identifier 4784 | N_Selected_Component 4785 then 4786 return False; 4787 4788 -- Simple global list (only input items) or moded global list 4789 -- declaration. 4790 4791 elsif Nkind (List) = N_Aggregate then 4792 if Present (Expressions (List)) then 4793 return False; 4794 4795 else 4796 Assoc := First (Component_Associations (List)); 4797 while Present (Assoc) loop 4798 if Chars (First (Choices (Assoc))) /= Name_Input then 4799 return True; 4800 end if; 4801 4802 Next (Assoc); 4803 end loop; 4804 4805 return False; 4806 end if; 4807 4808 -- To accommodate partial decoration of disabled SPARK 4809 -- features, this routine may be called with illegal input. 4810 -- If this is the case, do not raise Program_Error. 4811 4812 else 4813 return False; 4814 end if; 4815 end Has_Global_Output; 4816 4817 ------------------- 4818 -- Has_No_Output -- 4819 ------------------- 4820 4821 function Has_No_Output (Subp : Entity_Id) return Boolean is 4822 Param : Node_Id; 4823 4824 begin 4825 -- A function has its result as output 4826 4827 if Ekind (Subp) = E_Function then 4828 return False; 4829 end if; 4830 4831 -- An OUT or IN OUT parameter is an output 4832 4833 Param := First_Formal (Subp); 4834 while Present (Param) loop 4835 if Ekind (Param) in E_Out_Parameter | E_In_Out_Parameter then 4836 return False; 4837 end if; 4838 4839 Next_Formal (Param); 4840 end loop; 4841 4842 -- An item of mode Output or In_Out in the Global contract is 4843 -- an output. 4844 4845 if Has_Global_Output (Subp) then 4846 return False; 4847 end if; 4848 4849 return True; 4850 end Has_No_Output; 4851 4852 -- Local variables 4853 4854 Err_Node : Node_Id; 4855 -- Error node when reporting a warning on a (refined) 4856 -- postcondition. 4857 4858 -- Start of processing for Check_Conjunct 4859 4860 begin 4861 if Applied_On_Conjunct then 4862 Err_Node := Expr; 4863 else 4864 Err_Node := Prag; 4865 end if; 4866 4867 -- Do not report missing reference to outcome in postcondition if 4868 -- either the postcondition is trivially True or False, or if the 4869 -- subprogram is ghost and has no declared output. 4870 4871 if not Is_Trivial_Boolean (Expr) 4872 and then not Mentions_Post_State (Expr) 4873 and then not (Is_Ghost_Entity (Subp_Id) 4874 and then Has_No_Output (Subp_Id)) 4875 and then not Is_Wrapper (Subp_Id) 4876 then 4877 if Pragma_Name (Prag) = Name_Contract_Cases then 4878 Error_Msg_NE (Adjust_Message 4879 ("contract case does not check the outcome of calling " 4880 & "&?.t?"), Expr, Subp_Id); 4881 4882 elsif Pragma_Name (Prag) = Name_Refined_Post then 4883 Error_Msg_NE (Adjust_Message 4884 ("refined postcondition does not check the outcome of " 4885 & "calling &?.t?"), Err_Node, Subp_Id); 4886 4887 else 4888 Error_Msg_NE (Adjust_Message 4889 ("postcondition does not check the outcome of calling " 4890 & "&?.t?"), Err_Node, Subp_Id); 4891 end if; 4892 end if; 4893 end Check_Conjunct; 4894 4895 --------------------- 4896 -- Check_Conjuncts -- 4897 --------------------- 4898 4899 procedure Check_Conjuncts (Expr : Node_Id) is 4900 begin 4901 if Nkind (Expr) in N_Op_And | N_And_Then then 4902 Check_Conjuncts (Left_Opnd (Expr)); 4903 Check_Conjuncts (Right_Opnd (Expr)); 4904 else 4905 Check_Conjunct (Expr); 4906 end if; 4907 end Check_Conjuncts; 4908 4909 ---------------------- 4910 -- Check_Expression -- 4911 ---------------------- 4912 4913 procedure Check_Expression (Expr : Node_Id) is 4914 begin 4915 if not Is_Trivial_Boolean (Expr) then 4916 Check_Function_Result (Expr); 4917 Check_Conjuncts (Expr); 4918 end if; 4919 end Check_Expression; 4920 4921 ------------------------ 4922 -- Is_Function_Result -- 4923 ------------------------ 4924 4925 function Is_Function_Result (N : Node_Id) return Traverse_Result is 4926 begin 4927 if Is_Attribute_Result (N) then 4928 Result_Seen := True; 4929 return Abandon; 4930 4931 -- Warn on infinite recursion if call is to current function 4932 4933 elsif Nkind (N) = N_Function_Call 4934 and then Is_Entity_Name (Name (N)) 4935 and then Entity (Name (N)) = Subp_Id 4936 and then not Is_Potentially_Unevaluated (N) 4937 then 4938 Error_Msg_NE 4939 ("call to & within its postcondition will lead to infinite " 4940 & "recursion?", N, Subp_Id); 4941 return OK; 4942 4943 -- Continue the traversal 4944 4945 else 4946 return OK; 4947 end if; 4948 end Is_Function_Result; 4949 4950 ------------------------ 4951 -- Is_Trivial_Boolean -- 4952 ------------------------ 4953 4954 function Is_Trivial_Boolean (N : Node_Id) return Boolean is 4955 begin 4956 return 4957 Comes_From_Source (N) 4958 and then Is_Entity_Name (N) 4959 and then (Entity (N) = Standard_True 4960 or else 4961 Entity (N) = Standard_False); 4962 end Is_Trivial_Boolean; 4963 4964 ------------------------- 4965 -- Mentions_Post_State -- 4966 ------------------------- 4967 4968 function Mentions_Post_State (N : Node_Id) return Boolean is 4969 Post_State_Seen : Boolean := False; 4970 4971 function Is_Post_State (N : Node_Id) return Traverse_Result; 4972 -- Attempt to find a construct that denotes a post-state. If this 4973 -- is the case, set flag Post_State_Seen. 4974 4975 ------------------- 4976 -- Is_Post_State -- 4977 ------------------- 4978 4979 function Is_Post_State (N : Node_Id) return Traverse_Result is 4980 Ent : Entity_Id; 4981 4982 begin 4983 if Nkind (N) in N_Explicit_Dereference | N_Function_Call then 4984 Post_State_Seen := True; 4985 return Abandon; 4986 4987 elsif Nkind (N) in N_Expanded_Name | N_Identifier then 4988 Ent := Entity (N); 4989 4990 -- Treat an undecorated reference as OK 4991 4992 if No (Ent) 4993 4994 -- A reference to an assignable entity is considered a 4995 -- change in the post-state of a subprogram. 4996 4997 or else Ekind (Ent) in E_Generic_In_Out_Parameter 4998 | E_In_Out_Parameter 4999 | E_Out_Parameter 5000 | E_Variable 5001 5002 -- The reference may be modified through a dereference 5003 5004 or else (Is_Access_Type (Etype (Ent)) 5005 and then Nkind (Parent (N)) = 5006 N_Selected_Component) 5007 then 5008 Post_State_Seen := True; 5009 return Abandon; 5010 end if; 5011 5012 elsif Nkind (N) = N_Attribute_Reference then 5013 if Attribute_Name (N) = Name_Old then 5014 return Skip; 5015 5016 elsif Attribute_Name (N) = Name_Result then 5017 Post_State_Seen := True; 5018 return Abandon; 5019 end if; 5020 end if; 5021 5022 return OK; 5023 end Is_Post_State; 5024 5025 procedure Find_Post_State is new Traverse_Proc (Is_Post_State); 5026 5027 -- Start of processing for Mentions_Post_State 5028 5029 begin 5030 Find_Post_State (N); 5031 5032 return Post_State_Seen; 5033 end Mentions_Post_State; 5034 5035 -- Local variables 5036 5037 Expr : constant Node_Id := 5038 Get_Pragma_Arg 5039 (First (Pragma_Argument_Associations (Prag))); 5040 Nam : constant Name_Id := Pragma_Name (Prag); 5041 CCase : Node_Id; 5042 5043 -- Start of processing for Check_Result_And_Post_State_In_Pragma 5044 5045 begin 5046 -- Examine all consequences 5047 5048 if Nam = Name_Contract_Cases then 5049 CCase := First (Component_Associations (Expr)); 5050 while Present (CCase) loop 5051 Check_Expression (Expression (CCase)); 5052 5053 Next (CCase); 5054 end loop; 5055 5056 -- Examine the expression of a postcondition 5057 5058 else pragma Assert (Nam in Name_Postcondition | Name_Refined_Post); 5059 Check_Expression (Expr); 5060 end if; 5061 end Check_Result_And_Post_State_In_Pragma; 5062 5063 -- Local variables 5064 5065 Items : constant Node_Id := Contract (Subp_Id); 5066 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); 5067 Case_Prag : Node_Id := Empty; 5068 Post_Prag : Node_Id := Empty; 5069 Prag : Node_Id; 5070 Seen_In_Case : Boolean := False; 5071 Seen_In_Post : Boolean := False; 5072 Spec_Id : Entity_Id; 5073 5074 -- Start of processing for Check_Result_And_Post_State 5075 5076 begin 5077 -- The lack of attribute 'Result or a post-state is classified as a 5078 -- suspicious contract. Do not perform the check if the corresponding 5079 -- swich is not set. 5080 5081 if not Warn_On_Suspicious_Contract then 5082 return; 5083 5084 -- Nothing to do if there is no contract 5085 5086 elsif No (Items) then 5087 return; 5088 end if; 5089 5090 -- Retrieve the entity of the subprogram spec (if any) 5091 5092 if Nkind (Subp_Decl) = N_Subprogram_Body 5093 and then Present (Corresponding_Spec (Subp_Decl)) 5094 then 5095 Spec_Id := Corresponding_Spec (Subp_Decl); 5096 5097 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 5098 and then Present (Corresponding_Spec_Of_Stub (Subp_Decl)) 5099 then 5100 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl); 5101 5102 else 5103 Spec_Id := Subp_Id; 5104 end if; 5105 5106 -- Examine all postconditions for attribute 'Result and a post-state 5107 5108 Prag := Pre_Post_Conditions (Items); 5109 while Present (Prag) loop 5110 if Pragma_Name_Unmapped (Prag) 5111 in Name_Postcondition | Name_Refined_Post 5112 and then not Error_Posted (Prag) 5113 then 5114 Post_Prag := Prag; 5115 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Post); 5116 end if; 5117 5118 Prag := Next_Pragma (Prag); 5119 end loop; 5120 5121 -- Examine the contract cases of the subprogram for attribute 'Result 5122 -- and a post-state. 5123 5124 Prag := Contract_Test_Cases (Items); 5125 while Present (Prag) loop 5126 if Pragma_Name (Prag) = Name_Contract_Cases 5127 and then not Error_Posted (Prag) 5128 then 5129 Case_Prag := Prag; 5130 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Case); 5131 end if; 5132 5133 Prag := Next_Pragma (Prag); 5134 end loop; 5135 5136 -- Do not emit any errors if the subprogram is not a function 5137 5138 if Ekind (Spec_Id) not in E_Function | E_Generic_Function then 5139 null; 5140 5141 -- Regardless of whether the function has postconditions or contract 5142 -- cases, or whether they mention attribute 'Result, an [IN] OUT formal 5143 -- parameter is always treated as a result. 5144 5145 elsif Has_Out_Or_In_Out_Parameter (Spec_Id) then 5146 null; 5147 5148 -- The function has both a postcondition and contract cases and they do 5149 -- not mention attribute 'Result. 5150 5151 elsif Present (Case_Prag) 5152 and then not Seen_In_Case 5153 and then Present (Post_Prag) 5154 and then not Seen_In_Post 5155 then 5156 Error_Msg_N 5157 ("neither postcondition nor contract cases mention function " 5158 & "result?.t?", Post_Prag); 5159 5160 -- The function has contract cases only and they do not mention 5161 -- attribute 'Result. 5162 5163 elsif Present (Case_Prag) and then not Seen_In_Case then 5164 Error_Msg_N ("contract cases do not mention result?.t?", Case_Prag); 5165 5166 -- The function has postconditions only and they do not mention 5167 -- attribute 'Result. 5168 5169 elsif Present (Post_Prag) and then not Seen_In_Post then 5170 Error_Msg_N 5171 ("postcondition does not mention function result?.t?", Post_Prag); 5172 end if; 5173 end Check_Result_And_Post_State; 5174 5175 ----------------------------- 5176 -- Check_State_Refinements -- 5177 ----------------------------- 5178 5179 procedure Check_State_Refinements 5180 (Context : Node_Id; 5181 Is_Main_Unit : Boolean := False) 5182 is 5183 procedure Check_Package (Pack : Node_Id); 5184 -- Verify that all abstract states of a [generic] package denoted by its 5185 -- declarative node Pack have proper refinement. Recursively verify the 5186 -- visible and private declarations of the [generic] package for other 5187 -- nested packages. 5188 5189 procedure Check_Packages_In (Decls : List_Id); 5190 -- Seek out [generic] package declarations within declarative list Decls 5191 -- and verify the status of their abstract state refinement. 5192 5193 function SPARK_Mode_Is_Off (N : Node_Id) return Boolean; 5194 -- Determine whether construct N is subject to pragma SPARK_Mode Off 5195 5196 ------------------- 5197 -- Check_Package -- 5198 ------------------- 5199 5200 procedure Check_Package (Pack : Node_Id) is 5201 Body_Id : constant Entity_Id := Corresponding_Body (Pack); 5202 Spec : constant Node_Id := Specification (Pack); 5203 States : constant Elist_Id := 5204 Abstract_States (Defining_Entity (Pack)); 5205 5206 State_Elmt : Elmt_Id; 5207 State_Id : Entity_Id; 5208 5209 begin 5210 -- Do not verify proper state refinement when the package is subject 5211 -- to pragma SPARK_Mode Off because this disables the requirement for 5212 -- state refinement. 5213 5214 if SPARK_Mode_Is_Off (Pack) then 5215 null; 5216 5217 -- State refinement can only occur in a completing package body. Do 5218 -- not verify proper state refinement when the body is subject to 5219 -- pragma SPARK_Mode Off because this disables the requirement for 5220 -- state refinement. 5221 5222 elsif Present (Body_Id) 5223 and then SPARK_Mode_Is_Off (Unit_Declaration_Node (Body_Id)) 5224 then 5225 null; 5226 5227 -- Do not verify proper state refinement when the package is an 5228 -- instance as this check was already performed in the generic. 5229 5230 elsif Present (Generic_Parent (Spec)) then 5231 null; 5232 5233 -- Otherwise examine the contents of the package 5234 5235 else 5236 if Present (States) then 5237 State_Elmt := First_Elmt (States); 5238 while Present (State_Elmt) loop 5239 State_Id := Node (State_Elmt); 5240 5241 -- Emit an error when a non-null state lacks any form of 5242 -- refinement. 5243 5244 if not Is_Null_State (State_Id) 5245 and then not Has_Null_Refinement (State_Id) 5246 and then not Has_Non_Null_Refinement (State_Id) 5247 then 5248 Error_Msg_N ("state & requires refinement", State_Id); 5249 Error_Msg_N ("\package body should have Refined_State " 5250 & "for state & with constituents", State_Id); 5251 end if; 5252 5253 Next_Elmt (State_Elmt); 5254 end loop; 5255 end if; 5256 5257 Check_Packages_In (Visible_Declarations (Spec)); 5258 Check_Packages_In (Private_Declarations (Spec)); 5259 end if; 5260 end Check_Package; 5261 5262 ----------------------- 5263 -- Check_Packages_In -- 5264 ----------------------- 5265 5266 procedure Check_Packages_In (Decls : List_Id) is 5267 Decl : Node_Id; 5268 5269 begin 5270 if Present (Decls) then 5271 Decl := First (Decls); 5272 while Present (Decl) loop 5273 if Nkind (Decl) in N_Generic_Package_Declaration 5274 | N_Package_Declaration 5275 then 5276 Check_Package (Decl); 5277 end if; 5278 5279 Next (Decl); 5280 end loop; 5281 end if; 5282 end Check_Packages_In; 5283 5284 ----------------------- 5285 -- SPARK_Mode_Is_Off -- 5286 ----------------------- 5287 5288 function SPARK_Mode_Is_Off (N : Node_Id) return Boolean is 5289 Id : constant Entity_Id := Defining_Entity (N); 5290 Prag : constant Node_Id := SPARK_Pragma (Id); 5291 5292 begin 5293 -- Default the mode to "off" when the context is an instance and all 5294 -- SPARK_Mode pragmas found within are to be ignored. 5295 5296 if Ignore_SPARK_Mode_Pragmas (Id) then 5297 return True; 5298 5299 else 5300 return 5301 Present (Prag) 5302 and then Get_SPARK_Mode_From_Annotation (Prag) = Off; 5303 end if; 5304 end SPARK_Mode_Is_Off; 5305 5306 -- Start of processing for Check_State_Refinements 5307 5308 begin 5309 -- A block may declare a nested package 5310 5311 if Nkind (Context) = N_Block_Statement then 5312 Check_Packages_In (Declarations (Context)); 5313 5314 -- An entry, protected, subprogram, or task body may declare a nested 5315 -- package. 5316 5317 elsif Nkind (Context) in N_Entry_Body 5318 | N_Protected_Body 5319 | N_Subprogram_Body 5320 | N_Task_Body 5321 then 5322 -- Do not verify proper state refinement when the body is subject to 5323 -- pragma SPARK_Mode Off because this disables the requirement for 5324 -- state refinement. 5325 5326 if not SPARK_Mode_Is_Off (Context) then 5327 Check_Packages_In (Declarations (Context)); 5328 end if; 5329 5330 -- A package body may declare a nested package 5331 5332 elsif Nkind (Context) = N_Package_Body then 5333 Check_Package (Unit_Declaration_Node (Corresponding_Spec (Context))); 5334 5335 -- Do not verify proper state refinement when the body is subject to 5336 -- pragma SPARK_Mode Off because this disables the requirement for 5337 -- state refinement. 5338 5339 if not SPARK_Mode_Is_Off (Context) then 5340 Check_Packages_In (Declarations (Context)); 5341 end if; 5342 5343 -- A library level [generic] package may declare a nested package 5344 5345 elsif Nkind (Context) in 5346 N_Generic_Package_Declaration | N_Package_Declaration 5347 and then Is_Main_Unit 5348 then 5349 Check_Package (Context); 5350 end if; 5351 end Check_State_Refinements; 5352 5353 ------------------------------ 5354 -- Check_Unprotected_Access -- 5355 ------------------------------ 5356 5357 procedure Check_Unprotected_Access 5358 (Context : Node_Id; 5359 Expr : Node_Id) 5360 is 5361 Cont_Encl_Typ : Entity_Id; 5362 Pref_Encl_Typ : Entity_Id; 5363 5364 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id; 5365 -- Check whether Obj is a private component of a protected object. 5366 -- Return the protected type where the component resides, Empty 5367 -- otherwise. 5368 5369 function Is_Public_Operation return Boolean; 5370 -- Verify that the enclosing operation is callable from outside the 5371 -- protected object, to minimize false positives. 5372 5373 ------------------------------ 5374 -- Enclosing_Protected_Type -- 5375 ------------------------------ 5376 5377 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is 5378 begin 5379 if Is_Entity_Name (Obj) then 5380 declare 5381 Ent : Entity_Id := Entity (Obj); 5382 5383 begin 5384 -- The object can be a renaming of a private component, use 5385 -- the original record component. 5386 5387 if Is_Prival (Ent) then 5388 Ent := Prival_Link (Ent); 5389 end if; 5390 5391 if Is_Protected_Type (Scope (Ent)) then 5392 return Scope (Ent); 5393 end if; 5394 end; 5395 end if; 5396 5397 -- For indexed and selected components, recursively check the prefix 5398 5399 if Nkind (Obj) in N_Indexed_Component | N_Selected_Component then 5400 return Enclosing_Protected_Type (Prefix (Obj)); 5401 5402 -- The object does not denote a protected component 5403 5404 else 5405 return Empty; 5406 end if; 5407 end Enclosing_Protected_Type; 5408 5409 ------------------------- 5410 -- Is_Public_Operation -- 5411 ------------------------- 5412 5413 function Is_Public_Operation return Boolean is 5414 S : Entity_Id; 5415 E : Entity_Id; 5416 5417 begin 5418 S := Current_Scope; 5419 while Present (S) and then S /= Pref_Encl_Typ loop 5420 if Scope (S) = Pref_Encl_Typ then 5421 E := First_Entity (Pref_Encl_Typ); 5422 while Present (E) 5423 and then E /= First_Private_Entity (Pref_Encl_Typ) 5424 loop 5425 if E = S then 5426 return True; 5427 end if; 5428 5429 Next_Entity (E); 5430 end loop; 5431 end if; 5432 5433 S := Scope (S); 5434 end loop; 5435 5436 return False; 5437 end Is_Public_Operation; 5438 5439 -- Start of processing for Check_Unprotected_Access 5440 5441 begin 5442 if Nkind (Expr) = N_Attribute_Reference 5443 and then Attribute_Name (Expr) = Name_Unchecked_Access 5444 then 5445 Cont_Encl_Typ := Enclosing_Protected_Type (Context); 5446 Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr)); 5447 5448 -- Check whether we are trying to export a protected component to a 5449 -- context with an equal or lower access level. 5450 5451 if Present (Pref_Encl_Typ) 5452 and then No (Cont_Encl_Typ) 5453 and then Is_Public_Operation 5454 and then Scope_Depth (Pref_Encl_Typ) 5455 >= Static_Accessibility_Level 5456 (Context, Object_Decl_Level) 5457 then 5458 Error_Msg_N 5459 ("??possible unprotected access to protected data", Expr); 5460 end if; 5461 end if; 5462 end Check_Unprotected_Access; 5463 5464 ------------------------------ 5465 -- Check_Unused_Body_States -- 5466 ------------------------------ 5467 5468 procedure Check_Unused_Body_States (Body_Id : Entity_Id) is 5469 procedure Process_Refinement_Clause 5470 (Clause : Node_Id; 5471 States : Elist_Id); 5472 -- Inspect all constituents of refinement clause Clause and remove any 5473 -- matches from body state list States. 5474 5475 procedure Report_Unused_Body_States (States : Elist_Id); 5476 -- Emit errors for each abstract state or object found in list States 5477 5478 ------------------------------- 5479 -- Process_Refinement_Clause -- 5480 ------------------------------- 5481 5482 procedure Process_Refinement_Clause 5483 (Clause : Node_Id; 5484 States : Elist_Id) 5485 is 5486 procedure Process_Constituent (Constit : Node_Id); 5487 -- Remove constituent Constit from body state list States 5488 5489 ------------------------- 5490 -- Process_Constituent -- 5491 ------------------------- 5492 5493 procedure Process_Constituent (Constit : Node_Id) is 5494 Constit_Id : Entity_Id; 5495 5496 begin 5497 -- Guard against illegal constituents. Only abstract states and 5498 -- objects can appear on the right hand side of a refinement. 5499 5500 if Is_Entity_Name (Constit) then 5501 Constit_Id := Entity_Of (Constit); 5502 5503 if Present (Constit_Id) 5504 and then Ekind (Constit_Id) in 5505 E_Abstract_State | E_Constant | E_Variable 5506 then 5507 Remove (States, Constit_Id); 5508 end if; 5509 end if; 5510 end Process_Constituent; 5511 5512 -- Local variables 5513 5514 Constit : Node_Id; 5515 5516 -- Start of processing for Process_Refinement_Clause 5517 5518 begin 5519 if Nkind (Clause) = N_Component_Association then 5520 Constit := Expression (Clause); 5521 5522 -- Multiple constituents appear as an aggregate 5523 5524 if Nkind (Constit) = N_Aggregate then 5525 Constit := First (Expressions (Constit)); 5526 while Present (Constit) loop 5527 Process_Constituent (Constit); 5528 Next (Constit); 5529 end loop; 5530 5531 -- Various forms of a single constituent 5532 5533 else 5534 Process_Constituent (Constit); 5535 end if; 5536 end if; 5537 end Process_Refinement_Clause; 5538 5539 ------------------------------- 5540 -- Report_Unused_Body_States -- 5541 ------------------------------- 5542 5543 procedure Report_Unused_Body_States (States : Elist_Id) is 5544 Posted : Boolean := False; 5545 State_Elmt : Elmt_Id; 5546 State_Id : Entity_Id; 5547 5548 begin 5549 if Present (States) then 5550 State_Elmt := First_Elmt (States); 5551 while Present (State_Elmt) loop 5552 State_Id := Node (State_Elmt); 5553 5554 -- Constants are part of the hidden state of a package, but the 5555 -- compiler cannot determine whether they have variable input 5556 -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a 5557 -- hidden state. Do not emit an error when a constant does not 5558 -- participate in a state refinement, even though it acts as a 5559 -- hidden state. 5560 5561 if Ekind (State_Id) = E_Constant then 5562 null; 5563 5564 -- Overlays do not contribute to package state 5565 5566 elsif Ekind (State_Id) = E_Variable 5567 and then Present (Ultimate_Overlaid_Entity (State_Id)) 5568 then 5569 null; 5570 5571 -- Generate an error message of the form: 5572 5573 -- body of package ... has unused hidden states 5574 -- abstract state ... defined at ... 5575 -- variable ... defined at ... 5576 5577 else 5578 if not Posted then 5579 Posted := True; 5580 SPARK_Msg_N 5581 ("body of package & has unused hidden states", Body_Id); 5582 end if; 5583 5584 Error_Msg_Sloc := Sloc (State_Id); 5585 5586 if Ekind (State_Id) = E_Abstract_State then 5587 SPARK_Msg_NE 5588 ("\abstract state & defined #", Body_Id, State_Id); 5589 5590 else 5591 SPARK_Msg_NE ("\variable & defined #", Body_Id, State_Id); 5592 end if; 5593 end if; 5594 5595 Next_Elmt (State_Elmt); 5596 end loop; 5597 end if; 5598 end Report_Unused_Body_States; 5599 5600 -- Local variables 5601 5602 Prag : constant Node_Id := Get_Pragma (Body_Id, Pragma_Refined_State); 5603 Spec_Id : constant Entity_Id := Spec_Entity (Body_Id); 5604 Clause : Node_Id; 5605 States : Elist_Id; 5606 5607 -- Start of processing for Check_Unused_Body_States 5608 5609 begin 5610 -- Inspect the clauses of pragma Refined_State and determine whether all 5611 -- visible states declared within the package body participate in the 5612 -- refinement. 5613 5614 if Present (Prag) then 5615 Clause := Expression (Get_Argument (Prag, Spec_Id)); 5616 States := Collect_Body_States (Body_Id); 5617 5618 -- Multiple non-null state refinements appear as an aggregate 5619 5620 if Nkind (Clause) = N_Aggregate then 5621 Clause := First (Component_Associations (Clause)); 5622 while Present (Clause) loop 5623 Process_Refinement_Clause (Clause, States); 5624 Next (Clause); 5625 end loop; 5626 5627 -- Various forms of a single state refinement 5628 5629 else 5630 Process_Refinement_Clause (Clause, States); 5631 end if; 5632 5633 -- Ensure that all abstract states and objects declared in the 5634 -- package body state space are utilized as constituents. 5635 5636 Report_Unused_Body_States (States); 5637 end if; 5638 end Check_Unused_Body_States; 5639 5640 ------------------------------------ 5641 -- Check_Volatility_Compatibility -- 5642 ------------------------------------ 5643 5644 procedure Check_Volatility_Compatibility 5645 (Id1, Id2 : Entity_Id; 5646 Description_1, Description_2 : String; 5647 Srcpos_Bearer : Node_Id) is 5648 5649 begin 5650 if SPARK_Mode /= On then 5651 return; 5652 end if; 5653 5654 declare 5655 AR1 : constant Boolean := Async_Readers_Enabled (Id1); 5656 AW1 : constant Boolean := Async_Writers_Enabled (Id1); 5657 ER1 : constant Boolean := Effective_Reads_Enabled (Id1); 5658 EW1 : constant Boolean := Effective_Writes_Enabled (Id1); 5659 AR2 : constant Boolean := Async_Readers_Enabled (Id2); 5660 AW2 : constant Boolean := Async_Writers_Enabled (Id2); 5661 ER2 : constant Boolean := Effective_Reads_Enabled (Id2); 5662 EW2 : constant Boolean := Effective_Writes_Enabled (Id2); 5663 5664 AR_Check_Failed : constant Boolean := AR1 and not AR2; 5665 AW_Check_Failed : constant Boolean := AW1 and not AW2; 5666 ER_Check_Failed : constant Boolean := ER1 and not ER2; 5667 EW_Check_Failed : constant Boolean := EW1 and not EW2; 5668 5669 package Failure_Description is 5670 procedure Note_If_Failure 5671 (Failed : Boolean; Aspect_Name : String); 5672 -- If Failed is False, do nothing. 5673 -- If Failed is True, add Aspect_Name to the failure description. 5674 5675 function Failure_Text return String; 5676 -- returns accumulated list of failing aspects 5677 end Failure_Description; 5678 5679 package body Failure_Description is 5680 Description_Buffer : Bounded_String; 5681 5682 --------------------- 5683 -- Note_If_Failure -- 5684 --------------------- 5685 5686 procedure Note_If_Failure 5687 (Failed : Boolean; Aspect_Name : String) is 5688 begin 5689 if Failed then 5690 if Description_Buffer.Length /= 0 then 5691 Append (Description_Buffer, ", "); 5692 end if; 5693 Append (Description_Buffer, Aspect_Name); 5694 end if; 5695 end Note_If_Failure; 5696 5697 ------------------ 5698 -- Failure_Text -- 5699 ------------------ 5700 5701 function Failure_Text return String is 5702 begin 5703 return +Description_Buffer; 5704 end Failure_Text; 5705 end Failure_Description; 5706 5707 use Failure_Description; 5708 begin 5709 if AR_Check_Failed 5710 or AW_Check_Failed 5711 or ER_Check_Failed 5712 or EW_Check_Failed 5713 then 5714 Note_If_Failure (AR_Check_Failed, "Async_Readers"); 5715 Note_If_Failure (AW_Check_Failed, "Async_Writers"); 5716 Note_If_Failure (ER_Check_Failed, "Effective_Reads"); 5717 Note_If_Failure (EW_Check_Failed, "Effective_Writes"); 5718 5719 Error_Msg_N 5720 (Description_1 5721 & " and " 5722 & Description_2 5723 & " are not compatible with respect to volatility due to " 5724 & Failure_Text, 5725 Srcpos_Bearer); 5726 end if; 5727 end; 5728 end Check_Volatility_Compatibility; 5729 5730 ----------------- 5731 -- Choice_List -- 5732 ----------------- 5733 5734 function Choice_List (N : Node_Id) return List_Id is 5735 begin 5736 if Nkind (N) = N_Iterated_Component_Association then 5737 return Discrete_Choices (N); 5738 else 5739 return Choices (N); 5740 end if; 5741 end Choice_List; 5742 5743 --------------------- 5744 -- Class_Condition -- 5745 --------------------- 5746 5747 function Class_Condition 5748 (Kind : Condition_Kind; 5749 Subp : Entity_Id) return Node_Id is 5750 5751 begin 5752 case Kind is 5753 when Class_Postcondition => 5754 return Class_Postconditions (Subp); 5755 5756 when Class_Precondition => 5757 return Class_Preconditions (Subp); 5758 5759 when Ignored_Class_Postcondition => 5760 return Ignored_Class_Postconditions (Subp); 5761 5762 when Ignored_Class_Precondition => 5763 return Ignored_Class_Preconditions (Subp); 5764 end case; 5765 end Class_Condition; 5766 5767 ------------------------- 5768 -- Collect_Body_States -- 5769 ------------------------- 5770 5771 function Collect_Body_States (Body_Id : Entity_Id) return Elist_Id is 5772 function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean; 5773 -- Determine whether object Obj_Id is a suitable visible state of a 5774 -- package body. 5775 5776 procedure Collect_Visible_States 5777 (Pack_Id : Entity_Id; 5778 States : in out Elist_Id); 5779 -- Gather the entities of all abstract states and objects declared in 5780 -- the visible state space of package Pack_Id. 5781 5782 ---------------------------- 5783 -- Collect_Visible_States -- 5784 ---------------------------- 5785 5786 procedure Collect_Visible_States 5787 (Pack_Id : Entity_Id; 5788 States : in out Elist_Id) 5789 is 5790 Item_Id : Entity_Id; 5791 5792 begin 5793 -- Traverse the entity chain of the package and inspect all visible 5794 -- items. 5795 5796 Item_Id := First_Entity (Pack_Id); 5797 while Present (Item_Id) and then not In_Private_Part (Item_Id) loop 5798 5799 -- Do not consider internally generated items as those cannot be 5800 -- named and participate in refinement. 5801 5802 if not Comes_From_Source (Item_Id) then 5803 null; 5804 5805 elsif Ekind (Item_Id) = E_Abstract_State then 5806 Append_New_Elmt (Item_Id, States); 5807 5808 elsif Ekind (Item_Id) in E_Constant | E_Variable 5809 and then Is_Visible_Object (Item_Id) 5810 then 5811 Append_New_Elmt (Item_Id, States); 5812 5813 -- Recursively gather the visible states of a nested package 5814 5815 elsif Ekind (Item_Id) = E_Package then 5816 Collect_Visible_States (Item_Id, States); 5817 end if; 5818 5819 Next_Entity (Item_Id); 5820 end loop; 5821 end Collect_Visible_States; 5822 5823 ----------------------- 5824 -- Is_Visible_Object -- 5825 ----------------------- 5826 5827 function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean is 5828 begin 5829 -- Objects that map generic formals to their actuals are not visible 5830 -- from outside the generic instantiation. 5831 5832 if Present (Corresponding_Generic_Association 5833 (Declaration_Node (Obj_Id))) 5834 then 5835 return False; 5836 5837 -- Constituents of a single protected/task type act as components of 5838 -- the type and are not visible from outside the type. 5839 5840 elsif Ekind (Obj_Id) = E_Variable 5841 and then Present (Encapsulating_State (Obj_Id)) 5842 and then Is_Single_Concurrent_Object (Encapsulating_State (Obj_Id)) 5843 then 5844 return False; 5845 5846 else 5847 return True; 5848 end if; 5849 end Is_Visible_Object; 5850 5851 -- Local variables 5852 5853 Body_Decl : constant Node_Id := Unit_Declaration_Node (Body_Id); 5854 Decl : Node_Id; 5855 Item_Id : Entity_Id; 5856 States : Elist_Id := No_Elist; 5857 5858 -- Start of processing for Collect_Body_States 5859 5860 begin 5861 -- Inspect the declarations of the body looking for source objects, 5862 -- packages and package instantiations. Note that even though this 5863 -- processing is very similar to Collect_Visible_States, a package 5864 -- body does not have a First/Next_Entity list. 5865 5866 Decl := First (Declarations (Body_Decl)); 5867 while Present (Decl) loop 5868 5869 -- Capture source objects as internally generated temporaries cannot 5870 -- be named and participate in refinement. 5871 5872 if Nkind (Decl) = N_Object_Declaration then 5873 Item_Id := Defining_Entity (Decl); 5874 5875 if Comes_From_Source (Item_Id) 5876 and then Is_Visible_Object (Item_Id) 5877 then 5878 Append_New_Elmt (Item_Id, States); 5879 end if; 5880 5881 -- Capture the visible abstract states and objects of a source 5882 -- package [instantiation]. 5883 5884 elsif Nkind (Decl) = N_Package_Declaration then 5885 Item_Id := Defining_Entity (Decl); 5886 5887 if Comes_From_Source (Item_Id) then 5888 Collect_Visible_States (Item_Id, States); 5889 end if; 5890 end if; 5891 5892 Next (Decl); 5893 end loop; 5894 5895 return States; 5896 end Collect_Body_States; 5897 5898 ------------------------ 5899 -- Collect_Interfaces -- 5900 ------------------------ 5901 5902 procedure Collect_Interfaces 5903 (T : Entity_Id; 5904 Ifaces_List : out Elist_Id; 5905 Exclude_Parents : Boolean := False; 5906 Use_Full_View : Boolean := True) 5907 is 5908 procedure Collect (Typ : Entity_Id); 5909 -- Subsidiary subprogram used to traverse the whole list 5910 -- of directly and indirectly implemented interfaces 5911 5912 ------------- 5913 -- Collect -- 5914 ------------- 5915 5916 procedure Collect (Typ : Entity_Id) is 5917 Ancestor : Entity_Id; 5918 Full_T : Entity_Id; 5919 Id : Node_Id; 5920 Iface : Entity_Id; 5921 5922 begin 5923 Full_T := Typ; 5924 5925 -- Handle private types and subtypes 5926 5927 if Use_Full_View 5928 and then Is_Private_Type (Typ) 5929 and then Present (Full_View (Typ)) 5930 then 5931 Full_T := Full_View (Typ); 5932 5933 if Ekind (Full_T) = E_Record_Subtype then 5934 Full_T := Etype (Typ); 5935 5936 if Present (Full_View (Full_T)) then 5937 Full_T := Full_View (Full_T); 5938 end if; 5939 end if; 5940 end if; 5941 5942 -- Include the ancestor if we are generating the whole list of 5943 -- abstract interfaces. 5944 5945 if Etype (Full_T) /= Typ 5946 5947 -- Protect the frontend against wrong sources. For example: 5948 5949 -- package P is 5950 -- type A is tagged null record; 5951 -- type B is new A with private; 5952 -- type C is new A with private; 5953 -- private 5954 -- type B is new C with null record; 5955 -- type C is new B with null record; 5956 -- end P; 5957 5958 and then Etype (Full_T) /= T 5959 then 5960 Ancestor := Etype (Full_T); 5961 Collect (Ancestor); 5962 5963 if Is_Interface (Ancestor) and then not Exclude_Parents then 5964 Append_Unique_Elmt (Ancestor, Ifaces_List); 5965 end if; 5966 end if; 5967 5968 -- Traverse the graph of ancestor interfaces 5969 5970 if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then 5971 Id := First (Abstract_Interface_List (Full_T)); 5972 while Present (Id) loop 5973 Iface := Etype (Id); 5974 5975 -- Protect against wrong uses. For example: 5976 -- type I is interface; 5977 -- type O is tagged null record; 5978 -- type Wrong is new I and O with null record; -- ERROR 5979 5980 if Is_Interface (Iface) then 5981 if Exclude_Parents 5982 and then Etype (T) /= T 5983 and then Interface_Present_In_Ancestor (Etype (T), Iface) 5984 then 5985 null; 5986 else 5987 Collect (Iface); 5988 Append_Unique_Elmt (Iface, Ifaces_List); 5989 end if; 5990 end if; 5991 5992 Next (Id); 5993 end loop; 5994 end if; 5995 end Collect; 5996 5997 -- Start of processing for Collect_Interfaces 5998 5999 begin 6000 pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T)); 6001 Ifaces_List := New_Elmt_List; 6002 Collect (T); 6003 end Collect_Interfaces; 6004 6005 ---------------------------------- 6006 -- Collect_Interface_Components -- 6007 ---------------------------------- 6008 6009 procedure Collect_Interface_Components 6010 (Tagged_Type : Entity_Id; 6011 Components_List : out Elist_Id) 6012 is 6013 procedure Collect (Typ : Entity_Id); 6014 -- Subsidiary subprogram used to climb to the parents 6015 6016 ------------- 6017 -- Collect -- 6018 ------------- 6019 6020 procedure Collect (Typ : Entity_Id) is 6021 Tag_Comp : Entity_Id; 6022 Parent_Typ : Entity_Id; 6023 6024 begin 6025 -- Handle private types 6026 6027 if Present (Full_View (Etype (Typ))) then 6028 Parent_Typ := Full_View (Etype (Typ)); 6029 else 6030 Parent_Typ := Etype (Typ); 6031 end if; 6032 6033 if Parent_Typ /= Typ 6034 6035 -- Protect the frontend against wrong sources. For example: 6036 6037 -- package P is 6038 -- type A is tagged null record; 6039 -- type B is new A with private; 6040 -- type C is new A with private; 6041 -- private 6042 -- type B is new C with null record; 6043 -- type C is new B with null record; 6044 -- end P; 6045 6046 and then Parent_Typ /= Tagged_Type 6047 then 6048 Collect (Parent_Typ); 6049 end if; 6050 6051 -- Collect the components containing tags of secondary dispatch 6052 -- tables. 6053 6054 Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ)); 6055 while Present (Tag_Comp) loop 6056 pragma Assert (Present (Related_Type (Tag_Comp))); 6057 Append_Elmt (Tag_Comp, Components_List); 6058 6059 Tag_Comp := Next_Tag_Component (Tag_Comp); 6060 end loop; 6061 end Collect; 6062 6063 -- Start of processing for Collect_Interface_Components 6064 6065 begin 6066 pragma Assert (Ekind (Tagged_Type) = E_Record_Type 6067 and then Is_Tagged_Type (Tagged_Type)); 6068 6069 Components_List := New_Elmt_List; 6070 Collect (Tagged_Type); 6071 end Collect_Interface_Components; 6072 6073 ----------------------------- 6074 -- Collect_Interfaces_Info -- 6075 ----------------------------- 6076 6077 procedure Collect_Interfaces_Info 6078 (T : Entity_Id; 6079 Ifaces_List : out Elist_Id; 6080 Components_List : out Elist_Id; 6081 Tags_List : out Elist_Id) 6082 is 6083 Comps_List : Elist_Id; 6084 Comp_Elmt : Elmt_Id; 6085 Comp_Iface : Entity_Id; 6086 Iface_Elmt : Elmt_Id; 6087 Iface : Entity_Id; 6088 6089 function Search_Tag (Iface : Entity_Id) return Entity_Id; 6090 -- Search for the secondary tag associated with the interface type 6091 -- Iface that is implemented by T. 6092 6093 ---------------- 6094 -- Search_Tag -- 6095 ---------------- 6096 6097 function Search_Tag (Iface : Entity_Id) return Entity_Id is 6098 ADT : Elmt_Id; 6099 begin 6100 if not Is_CPP_Class (T) then 6101 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T)))); 6102 else 6103 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T))); 6104 end if; 6105 6106 while Present (ADT) 6107 and then Is_Tag (Node (ADT)) 6108 and then Related_Type (Node (ADT)) /= Iface 6109 loop 6110 -- Skip secondary dispatch table referencing thunks to user 6111 -- defined primitives covered by this interface. 6112 6113 pragma Assert (Has_Suffix (Node (ADT), 'P')); 6114 Next_Elmt (ADT); 6115 6116 -- Skip secondary dispatch tables of Ada types 6117 6118 if not Is_CPP_Class (T) then 6119 6120 -- Skip secondary dispatch table referencing thunks to 6121 -- predefined primitives. 6122 6123 pragma Assert (Has_Suffix (Node (ADT), 'Y')); 6124 Next_Elmt (ADT); 6125 6126 -- Skip secondary dispatch table referencing user-defined 6127 -- primitives covered by this interface. 6128 6129 pragma Assert (Has_Suffix (Node (ADT), 'D')); 6130 Next_Elmt (ADT); 6131 6132 -- Skip secondary dispatch table referencing predefined 6133 -- primitives. 6134 6135 pragma Assert (Has_Suffix (Node (ADT), 'Z')); 6136 Next_Elmt (ADT); 6137 end if; 6138 end loop; 6139 6140 pragma Assert (Is_Tag (Node (ADT))); 6141 return Node (ADT); 6142 end Search_Tag; 6143 6144 -- Start of processing for Collect_Interfaces_Info 6145 6146 begin 6147 Collect_Interfaces (T, Ifaces_List); 6148 Collect_Interface_Components (T, Comps_List); 6149 6150 -- Search for the record component and tag associated with each 6151 -- interface type of T. 6152 6153 Components_List := New_Elmt_List; 6154 Tags_List := New_Elmt_List; 6155 6156 Iface_Elmt := First_Elmt (Ifaces_List); 6157 while Present (Iface_Elmt) loop 6158 Iface := Node (Iface_Elmt); 6159 6160 -- Associate the primary tag component and the primary dispatch table 6161 -- with all the interfaces that are parents of T 6162 6163 if Is_Ancestor (Iface, T, Use_Full_View => True) then 6164 Append_Elmt (First_Tag_Component (T), Components_List); 6165 Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List); 6166 6167 -- Otherwise search for the tag component and secondary dispatch 6168 -- table of Iface 6169 6170 else 6171 Comp_Elmt := First_Elmt (Comps_List); 6172 while Present (Comp_Elmt) loop 6173 Comp_Iface := Related_Type (Node (Comp_Elmt)); 6174 6175 if Comp_Iface = Iface 6176 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True) 6177 then 6178 Append_Elmt (Node (Comp_Elmt), Components_List); 6179 Append_Elmt (Search_Tag (Comp_Iface), Tags_List); 6180 exit; 6181 end if; 6182 6183 Next_Elmt (Comp_Elmt); 6184 end loop; 6185 pragma Assert (Present (Comp_Elmt)); 6186 end if; 6187 6188 Next_Elmt (Iface_Elmt); 6189 end loop; 6190 end Collect_Interfaces_Info; 6191 6192 --------------------- 6193 -- Collect_Parents -- 6194 --------------------- 6195 6196 procedure Collect_Parents 6197 (T : Entity_Id; 6198 List : out Elist_Id; 6199 Use_Full_View : Boolean := True) 6200 is 6201 Current_Typ : Entity_Id := T; 6202 Parent_Typ : Entity_Id; 6203 6204 begin 6205 List := New_Elmt_List; 6206 6207 -- No action if the if the type has no parents 6208 6209 if T = Etype (T) then 6210 return; 6211 end if; 6212 6213 loop 6214 Parent_Typ := Etype (Current_Typ); 6215 6216 if Is_Private_Type (Parent_Typ) 6217 and then Present (Full_View (Parent_Typ)) 6218 and then Use_Full_View 6219 then 6220 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 6221 end if; 6222 6223 Append_Elmt (Parent_Typ, List); 6224 6225 exit when Parent_Typ = Current_Typ; 6226 Current_Typ := Parent_Typ; 6227 end loop; 6228 end Collect_Parents; 6229 6230 ---------------------------------- 6231 -- Collect_Primitive_Operations -- 6232 ---------------------------------- 6233 6234 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is 6235 B_Type : constant Entity_Id := Base_Type (T); 6236 6237 function Match (E : Entity_Id) return Boolean; 6238 -- True if E's base type is B_Type, or E is of an anonymous access type 6239 -- and the base type of its designated type is B_Type. 6240 6241 ----------- 6242 -- Match -- 6243 ----------- 6244 6245 function Match (E : Entity_Id) return Boolean is 6246 Etyp : Entity_Id := Etype (E); 6247 6248 begin 6249 if Ekind (Etyp) = E_Anonymous_Access_Type then 6250 Etyp := Designated_Type (Etyp); 6251 end if; 6252 6253 -- In Ada 2012 a primitive operation may have a formal of an 6254 -- incomplete view of the parent type. 6255 6256 return Base_Type (Etyp) = B_Type 6257 or else 6258 (Ada_Version >= Ada_2012 6259 and then Ekind (Etyp) = E_Incomplete_Type 6260 and then Full_View (Etyp) = B_Type); 6261 end Match; 6262 6263 -- Local variables 6264 6265 B_Decl : constant Node_Id := Original_Node (Parent (B_Type)); 6266 B_Scope : Entity_Id := Scope (B_Type); 6267 Op_List : Elist_Id; 6268 Eq_Prims_List : Elist_Id := No_Elist; 6269 Formal : Entity_Id; 6270 Is_Prim : Boolean; 6271 Is_Type_In_Pkg : Boolean; 6272 Formal_Derived : Boolean := False; 6273 Id : Entity_Id; 6274 6275 -- Start of processing for Collect_Primitive_Operations 6276 6277 begin 6278 -- For tagged types, the primitive operations are collected as they 6279 -- are declared, and held in an explicit list which is simply returned. 6280 6281 if Is_Tagged_Type (B_Type) then 6282 return Primitive_Operations (B_Type); 6283 6284 -- An untagged generic type that is a derived type inherits the 6285 -- primitive operations of its parent type. Other formal types only 6286 -- have predefined operators, which are not explicitly represented. 6287 6288 elsif Is_Generic_Type (B_Type) then 6289 if Nkind (B_Decl) = N_Formal_Type_Declaration 6290 and then Nkind (Formal_Type_Definition (B_Decl)) = 6291 N_Formal_Derived_Type_Definition 6292 then 6293 Formal_Derived := True; 6294 else 6295 return New_Elmt_List; 6296 end if; 6297 end if; 6298 6299 Op_List := New_Elmt_List; 6300 6301 if B_Scope = Standard_Standard then 6302 if B_Type = Standard_String then 6303 Append_Elmt (Standard_Op_Concat, Op_List); 6304 6305 elsif B_Type = Standard_Wide_String then 6306 Append_Elmt (Standard_Op_Concatw, Op_List); 6307 6308 else 6309 null; 6310 end if; 6311 6312 -- Locate the primitive subprograms of the type 6313 6314 else 6315 -- The primitive operations appear after the base type, except if the 6316 -- derivation happens within the private part of B_Scope and the type 6317 -- is a private type, in which case both the type and some primitive 6318 -- operations may appear before the base type, and the list of 6319 -- candidates starts after the type. 6320 6321 if In_Open_Scopes (B_Scope) 6322 and then Scope (T) = B_Scope 6323 and then In_Private_Part (B_Scope) 6324 then 6325 Id := Next_Entity (T); 6326 6327 -- In Ada 2012, If the type has an incomplete partial view, there may 6328 -- be primitive operations declared before the full view, so we need 6329 -- to start scanning from the incomplete view, which is earlier on 6330 -- the entity chain. 6331 6332 elsif Nkind (Parent (B_Type)) = N_Full_Type_Declaration 6333 and then Present (Incomplete_View (Parent (B_Type))) 6334 then 6335 Id := Defining_Entity (Incomplete_View (Parent (B_Type))); 6336 6337 -- If T is a derived from a type with an incomplete view declared 6338 -- elsewhere, that incomplete view is irrelevant, we want the 6339 -- operations in the scope of T. 6340 6341 if Scope (Id) /= Scope (B_Type) then 6342 Id := Next_Entity (B_Type); 6343 end if; 6344 6345 else 6346 Id := Next_Entity (B_Type); 6347 end if; 6348 6349 -- Set flag if this is a type in a package spec 6350 6351 Is_Type_In_Pkg := 6352 Is_Package_Or_Generic_Package (B_Scope) 6353 and then 6354 Parent_Kind (Declaration_Node (First_Subtype (T))) /= 6355 N_Package_Body; 6356 6357 while Present (Id) loop 6358 6359 -- Test whether the result type or any of the parameter types of 6360 -- each subprogram following the type match that type when the 6361 -- type is declared in a package spec, is a derived type, or the 6362 -- subprogram is marked as primitive. (The Is_Primitive test is 6363 -- needed to find primitives of nonderived types in declarative 6364 -- parts that happen to override the predefined "=" operator.) 6365 6366 -- Note that generic formal subprograms are not considered to be 6367 -- primitive operations and thus are never inherited. 6368 6369 if Is_Overloadable (Id) 6370 and then (Is_Type_In_Pkg 6371 or else Is_Derived_Type (B_Type) 6372 or else Is_Primitive (Id)) 6373 and then Parent_Kind (Parent (Id)) 6374 not in N_Formal_Subprogram_Declaration 6375 then 6376 Is_Prim := False; 6377 6378 if Match (Id) then 6379 Is_Prim := True; 6380 6381 else 6382 Formal := First_Formal (Id); 6383 while Present (Formal) loop 6384 if Match (Formal) then 6385 Is_Prim := True; 6386 exit; 6387 end if; 6388 6389 Next_Formal (Formal); 6390 end loop; 6391 end if; 6392 6393 -- For a formal derived type, the only primitives are the ones 6394 -- inherited from the parent type. Operations appearing in the 6395 -- package declaration are not primitive for it. 6396 6397 if Is_Prim 6398 and then (not Formal_Derived or else Present (Alias (Id))) 6399 then 6400 -- In the special case of an equality operator aliased to 6401 -- an overriding dispatching equality belonging to the same 6402 -- type, we don't include it in the list of primitives. 6403 -- This avoids inheriting multiple equality operators when 6404 -- deriving from untagged private types whose full type is 6405 -- tagged, which can otherwise cause ambiguities. Note that 6406 -- this should only happen for this kind of untagged parent 6407 -- type, since normally dispatching operations are inherited 6408 -- using the type's Primitive_Operations list. 6409 6410 if Chars (Id) = Name_Op_Eq 6411 and then Is_Dispatching_Operation (Id) 6412 and then Present (Alias (Id)) 6413 and then Present (Overridden_Operation (Alias (Id))) 6414 and then Base_Type (Etype (First_Entity (Id))) = 6415 Base_Type (Etype (First_Entity (Alias (Id)))) 6416 then 6417 null; 6418 6419 -- Include the subprogram in the list of primitives 6420 6421 else 6422 Append_Elmt (Id, Op_List); 6423 6424 -- Save collected equality primitives for later filtering 6425 -- (if we are processing a private type for which we can 6426 -- collect several candidates). 6427 6428 if Inherits_From_Tagged_Full_View (T) 6429 and then Chars (Id) = Name_Op_Eq 6430 and then Etype (First_Formal (Id)) = 6431 Etype (Next_Formal (First_Formal (Id))) 6432 then 6433 Append_New_Elmt (Id, Eq_Prims_List); 6434 end if; 6435 end if; 6436 end if; 6437 end if; 6438 6439 Next_Entity (Id); 6440 6441 -- For a type declared in System, some of its operations may 6442 -- appear in the target-specific extension to System. 6443 6444 if No (Id) 6445 and then Is_RTU (B_Scope, System) 6446 and then Present_System_Aux 6447 then 6448 B_Scope := System_Aux_Id; 6449 Id := First_Entity (System_Aux_Id); 6450 end if; 6451 end loop; 6452 6453 -- Filter collected equality primitives 6454 6455 if Inherits_From_Tagged_Full_View (T) 6456 and then Present (Eq_Prims_List) 6457 then 6458 declare 6459 First : constant Elmt_Id := First_Elmt (Eq_Prims_List); 6460 Second : Elmt_Id; 6461 6462 begin 6463 pragma Assert (No (Next_Elmt (First)) 6464 or else No (Next_Elmt (Next_Elmt (First)))); 6465 6466 -- No action needed if we have collected a single equality 6467 -- primitive 6468 6469 if Present (Next_Elmt (First)) then 6470 Second := Next_Elmt (First); 6471 6472 if Is_Dispatching_Operation 6473 (Ultimate_Alias (Node (First))) 6474 then 6475 Remove (Op_List, Node (First)); 6476 6477 elsif Is_Dispatching_Operation 6478 (Ultimate_Alias (Node (Second))) 6479 then 6480 Remove (Op_List, Node (Second)); 6481 6482 else 6483 raise Program_Error; 6484 end if; 6485 end if; 6486 end; 6487 end if; 6488 end if; 6489 6490 return Op_List; 6491 end Collect_Primitive_Operations; 6492 6493 ----------------------------------- 6494 -- Compile_Time_Constraint_Error -- 6495 ----------------------------------- 6496 6497 function Compile_Time_Constraint_Error 6498 (N : Node_Id; 6499 Msg : String; 6500 Ent : Entity_Id := Empty; 6501 Loc : Source_Ptr := No_Location; 6502 Warn : Boolean := False; 6503 Extra_Msg : String := "") return Node_Id 6504 is 6505 Msgc : String (1 .. Msg'Length + 3); 6506 -- Copy of message, with room for possible ?? or << and ! at end 6507 6508 Msgl : Natural; 6509 Wmsg : Boolean; 6510 Eloc : Source_Ptr; 6511 6512 -- Start of processing for Compile_Time_Constraint_Error 6513 6514 begin 6515 -- If this is a warning, convert it into an error if we are in code 6516 -- subject to SPARK_Mode being set On, unless Warn is True to force a 6517 -- warning. The rationale is that a compile-time constraint error should 6518 -- lead to an error instead of a warning when SPARK_Mode is On, but in 6519 -- a few cases we prefer to issue a warning and generate both a suitable 6520 -- run-time error in GNAT and a suitable check message in GNATprove. 6521 -- Those cases are those that likely correspond to deactivated SPARK 6522 -- code, so that this kind of code can be compiled and analyzed instead 6523 -- of being rejected. 6524 6525 Error_Msg_Warn := Warn or SPARK_Mode /= On; 6526 6527 -- A static constraint error in an instance body is not a fatal error. 6528 -- we choose to inhibit the message altogether, because there is no 6529 -- obvious node (for now) on which to post it. On the other hand the 6530 -- offending node must be replaced with a constraint_error in any case. 6531 6532 -- No messages are generated if we already posted an error on this node 6533 6534 if not Error_Posted (N) then 6535 if Loc /= No_Location then 6536 Eloc := Loc; 6537 else 6538 Eloc := Sloc (N); 6539 end if; 6540 6541 -- Copy message to Msgc, converting any ? in the message into < 6542 -- instead, so that we have an error in GNATprove mode. 6543 6544 Msgl := Msg'Length; 6545 6546 for J in 1 .. Msgl loop 6547 if Msg (J) = '?' and then (J = 1 or else Msg (J - 1) /= ''') then 6548 Msgc (J) := '<'; 6549 else 6550 Msgc (J) := Msg (J); 6551 end if; 6552 end loop; 6553 6554 -- Message is a warning, even in Ada 95 case 6555 6556 if Msg (Msg'Last) = '?' or else Msg (Msg'Last) = '<' then 6557 Wmsg := True; 6558 6559 -- In Ada 83, all messages are warnings. In the private part and the 6560 -- body of an instance, constraint_checks are only warnings. We also 6561 -- make this a warning if the Warn parameter is set. 6562 6563 elsif Warn 6564 or else (Ada_Version = Ada_83 and then Comes_From_Source (N)) 6565 or else In_Instance_Not_Visible 6566 then 6567 Msgl := Msgl + 1; 6568 Msgc (Msgl) := '<'; 6569 Msgl := Msgl + 1; 6570 Msgc (Msgl) := '<'; 6571 Wmsg := True; 6572 6573 -- Otherwise we have a real error message (Ada 95 static case) and we 6574 -- make this an unconditional message. Note that in the warning case 6575 -- we do not make the message unconditional, it seems reasonable to 6576 -- delete messages like this (about exceptions that will be raised) 6577 -- in dead code. 6578 6579 else 6580 Wmsg := False; 6581 Msgl := Msgl + 1; 6582 Msgc (Msgl) := '!'; 6583 end if; 6584 6585 -- One more test, skip the warning if the related expression is 6586 -- statically unevaluated, since we don't want to warn about what 6587 -- will happen when something is evaluated if it never will be 6588 -- evaluated. 6589 6590 -- Suppress error reporting when checking that the expression of a 6591 -- static expression function is a potentially static expression, 6592 -- because we don't want additional errors being reported during the 6593 -- preanalysis of the expression (see Analyze_Expression_Function). 6594 6595 if not Is_Statically_Unevaluated (N) 6596 and then not Checking_Potentially_Static_Expression 6597 then 6598 if Present (Ent) then 6599 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc); 6600 else 6601 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc); 6602 end if; 6603 6604 -- Emit any extra message as a continuation 6605 6606 if Extra_Msg /= "" then 6607 Error_Msg_N ('\' & Extra_Msg, N); 6608 end if; 6609 6610 if Wmsg then 6611 6612 -- Check whether the context is an Init_Proc 6613 6614 if Inside_Init_Proc then 6615 declare 6616 Init_Proc_Type : constant Entity_Id := 6617 Etype (First_Formal (Current_Scope_No_Loops)); 6618 6619 Conc_Typ : constant Entity_Id := 6620 (if Present (Init_Proc_Type) 6621 and then Init_Proc_Type in E_Record_Type_Id 6622 then Corresponding_Concurrent_Type (Init_Proc_Type) 6623 else Empty); 6624 6625 begin 6626 -- Don't complain if the corresponding concurrent type 6627 -- doesn't come from source (i.e. a single task/protected 6628 -- object). 6629 6630 if Present (Conc_Typ) 6631 and then not Comes_From_Source (Conc_Typ) 6632 then 6633 Error_Msg_NEL 6634 ("\& [<<", N, Standard_Constraint_Error, Eloc); 6635 6636 else 6637 if GNATprove_Mode then 6638 Error_Msg_NEL 6639 ("\& would have been raised for objects of this " 6640 & "type", N, Standard_Constraint_Error, Eloc); 6641 else 6642 Error_Msg_NEL 6643 ("\& will be raised for objects of this type??", 6644 N, Standard_Constraint_Error, Eloc); 6645 end if; 6646 end if; 6647 end; 6648 6649 else 6650 Error_Msg_NEL ("\& [<<", N, Standard_Constraint_Error, Eloc); 6651 end if; 6652 6653 else 6654 Error_Msg ("\static expression fails Constraint_Check", Eloc); 6655 Set_Error_Posted (N); 6656 end if; 6657 end if; 6658 end if; 6659 6660 return N; 6661 end Compile_Time_Constraint_Error; 6662 6663 ---------------------------- 6664 -- Compute_Returns_By_Ref -- 6665 ---------------------------- 6666 6667 procedure Compute_Returns_By_Ref (Func : Entity_Id) is 6668 Typ : constant Entity_Id := Etype (Func); 6669 Utyp : constant Entity_Id := Underlying_Type (Typ); 6670 6671 begin 6672 if Is_Limited_View (Typ) then 6673 Set_Returns_By_Ref (Func); 6674 6675 elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then 6676 Set_Returns_By_Ref (Func); 6677 end if; 6678 end Compute_Returns_By_Ref; 6679 6680 -------------------------------- 6681 -- Collect_Types_In_Hierarchy -- 6682 -------------------------------- 6683 6684 function Collect_Types_In_Hierarchy 6685 (Typ : Entity_Id; 6686 Examine_Components : Boolean := False) return Elist_Id 6687 is 6688 Results : Elist_Id; 6689 6690 procedure Process_Type (Typ : Entity_Id); 6691 -- Collect type Typ if it satisfies function Predicate. Do so for its 6692 -- parent type, base type, progenitor types, and any component types. 6693 6694 ------------------ 6695 -- Process_Type -- 6696 ------------------ 6697 6698 procedure Process_Type (Typ : Entity_Id) is 6699 Comp : Entity_Id; 6700 Iface_Elmt : Elmt_Id; 6701 6702 begin 6703 if not Is_Type (Typ) or else Error_Posted (Typ) then 6704 return; 6705 end if; 6706 6707 -- Collect the current type if it satisfies the predicate 6708 6709 if Predicate (Typ) then 6710 Append_Elmt (Typ, Results); 6711 end if; 6712 6713 -- Process component types 6714 6715 if Examine_Components then 6716 6717 -- Examine components and discriminants 6718 6719 if Is_Concurrent_Type (Typ) 6720 or else Is_Incomplete_Or_Private_Type (Typ) 6721 or else Is_Record_Type (Typ) 6722 or else Has_Discriminants (Typ) 6723 then 6724 Comp := First_Component_Or_Discriminant (Typ); 6725 6726 while Present (Comp) loop 6727 Process_Type (Etype (Comp)); 6728 6729 Next_Component_Or_Discriminant (Comp); 6730 end loop; 6731 6732 -- Examine array components 6733 6734 elsif Ekind (Typ) = E_Array_Type then 6735 Process_Type (Component_Type (Typ)); 6736 end if; 6737 end if; 6738 6739 -- Examine parent type 6740 6741 if Etype (Typ) /= Typ then 6742 Process_Type (Etype (Typ)); 6743 end if; 6744 6745 -- Examine base type 6746 6747 if Base_Type (Typ) /= Typ then 6748 Process_Type (Base_Type (Typ)); 6749 end if; 6750 6751 -- Examine interfaces 6752 6753 if Is_Record_Type (Typ) 6754 and then Present (Interfaces (Typ)) 6755 then 6756 Iface_Elmt := First_Elmt (Interfaces (Typ)); 6757 while Present (Iface_Elmt) loop 6758 Process_Type (Node (Iface_Elmt)); 6759 6760 Next_Elmt (Iface_Elmt); 6761 end loop; 6762 end if; 6763 end Process_Type; 6764 6765 -- Start of processing for Collect_Types_In_Hierarchy 6766 6767 begin 6768 Results := New_Elmt_List; 6769 Process_Type (Typ); 6770 return Results; 6771 end Collect_Types_In_Hierarchy; 6772 6773 ----------------------- 6774 -- Conditional_Delay -- 6775 ----------------------- 6776 6777 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is 6778 begin 6779 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then 6780 Set_Has_Delayed_Freeze (New_Ent); 6781 end if; 6782 end Conditional_Delay; 6783 6784 ------------------------- 6785 -- Copy_Component_List -- 6786 ------------------------- 6787 6788 function Copy_Component_List 6789 (R_Typ : Entity_Id; 6790 Loc : Source_Ptr) return List_Id 6791 is 6792 Comp : Node_Id; 6793 Comps : constant List_Id := New_List; 6794 6795 begin 6796 Comp := First_Component (Underlying_Type (R_Typ)); 6797 while Present (Comp) loop 6798 if Comes_From_Source (Comp) then 6799 declare 6800 Comp_Decl : constant Node_Id := Declaration_Node (Comp); 6801 begin 6802 Append_To (Comps, 6803 Make_Component_Declaration (Loc, 6804 Defining_Identifier => 6805 Make_Defining_Identifier (Loc, Chars (Comp)), 6806 Component_Definition => 6807 New_Copy_Tree 6808 (Component_Definition (Comp_Decl), New_Sloc => Loc))); 6809 end; 6810 end if; 6811 6812 Next_Component (Comp); 6813 end loop; 6814 6815 return Comps; 6816 end Copy_Component_List; 6817 6818 ------------------------- 6819 -- Copy_Parameter_List -- 6820 ------------------------- 6821 6822 function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is 6823 Loc : constant Source_Ptr := Sloc (Subp_Id); 6824 Plist : List_Id; 6825 Formal : Entity_Id := First_Formal (Subp_Id); 6826 6827 begin 6828 if Present (Formal) then 6829 Plist := New_List; 6830 while Present (Formal) loop 6831 Append_To (Plist, 6832 Make_Parameter_Specification (Loc, 6833 Defining_Identifier => 6834 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), 6835 In_Present => In_Present (Parent (Formal)), 6836 Out_Present => Out_Present (Parent (Formal)), 6837 Parameter_Type => 6838 New_Occurrence_Of (Etype (Formal), Loc), 6839 Expression => 6840 New_Copy_Tree (Expression (Parent (Formal))))); 6841 6842 Next_Formal (Formal); 6843 end loop; 6844 else 6845 Plist := No_List; 6846 end if; 6847 6848 return Plist; 6849 end Copy_Parameter_List; 6850 6851 ---------------------------- 6852 -- Copy_SPARK_Mode_Aspect -- 6853 ---------------------------- 6854 6855 procedure Copy_SPARK_Mode_Aspect (From : Node_Id; To : Node_Id) is 6856 pragma Assert (not Has_Aspects (To)); 6857 Asp : Node_Id; 6858 6859 begin 6860 if Has_Aspects (From) then 6861 Asp := Find_Aspect (Defining_Entity (From), Aspect_SPARK_Mode); 6862 6863 if Present (Asp) then 6864 Set_Aspect_Specifications (To, New_List (New_Copy_Tree (Asp))); 6865 Set_Has_Aspects (To, True); 6866 end if; 6867 end if; 6868 end Copy_SPARK_Mode_Aspect; 6869 6870 -------------------------- 6871 -- Copy_Subprogram_Spec -- 6872 -------------------------- 6873 6874 function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id is 6875 Def_Id : Node_Id; 6876 Formal_Spec : Node_Id; 6877 Result : Node_Id; 6878 6879 begin 6880 -- The structure of the original tree must be replicated without any 6881 -- alterations. Use New_Copy_Tree for this purpose. 6882 6883 Result := New_Copy_Tree (Spec); 6884 6885 -- However, the spec of a null procedure carries the corresponding null 6886 -- statement of the body (created by the parser), and this cannot be 6887 -- shared with the new subprogram spec. 6888 6889 if Nkind (Result) = N_Procedure_Specification then 6890 Set_Null_Statement (Result, Empty); 6891 end if; 6892 6893 -- Create a new entity for the defining unit name 6894 6895 Def_Id := Defining_Unit_Name (Result); 6896 Set_Defining_Unit_Name (Result, 6897 Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id))); 6898 6899 -- Create new entities for the formal parameters 6900 6901 if Present (Parameter_Specifications (Result)) then 6902 Formal_Spec := First (Parameter_Specifications (Result)); 6903 while Present (Formal_Spec) loop 6904 Def_Id := Defining_Identifier (Formal_Spec); 6905 Set_Defining_Identifier (Formal_Spec, 6906 Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id))); 6907 6908 Next (Formal_Spec); 6909 end loop; 6910 end if; 6911 6912 return Result; 6913 end Copy_Subprogram_Spec; 6914 6915 -------------------------------- 6916 -- Corresponding_Generic_Type -- 6917 -------------------------------- 6918 6919 function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is 6920 Inst : Entity_Id; 6921 Gen : Entity_Id; 6922 Typ : Entity_Id; 6923 6924 begin 6925 if not Is_Generic_Actual_Type (T) then 6926 return Any_Type; 6927 6928 -- If the actual is the actual of an enclosing instance, resolution 6929 -- was correct in the generic. 6930 6931 elsif Nkind (Parent (T)) = N_Subtype_Declaration 6932 and then Is_Entity_Name (Subtype_Indication (Parent (T))) 6933 and then 6934 Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T)))) 6935 then 6936 return Any_Type; 6937 6938 else 6939 Inst := Scope (T); 6940 6941 if Is_Wrapper_Package (Inst) then 6942 Inst := Related_Instance (Inst); 6943 end if; 6944 6945 Gen := 6946 Generic_Parent 6947 (Specification (Unit_Declaration_Node (Inst))); 6948 6949 -- Generic actual has the same name as the corresponding formal 6950 6951 Typ := First_Entity (Gen); 6952 while Present (Typ) loop 6953 if Chars (Typ) = Chars (T) then 6954 return Typ; 6955 end if; 6956 6957 Next_Entity (Typ); 6958 end loop; 6959 6960 return Any_Type; 6961 end if; 6962 end Corresponding_Generic_Type; 6963 6964 -------------------------------- 6965 -- Corresponding_Primitive_Op -- 6966 -------------------------------- 6967 6968 function Corresponding_Primitive_Op 6969 (Ancestor_Op : Entity_Id; 6970 Descendant_Type : Entity_Id) return Entity_Id 6971 is 6972 Typ : constant Entity_Id := Find_Dispatching_Type (Ancestor_Op); 6973 Elmt : Elmt_Id; 6974 Subp : Entity_Id; 6975 Prim : Entity_Id; 6976 begin 6977 pragma Assert (Is_Dispatching_Operation (Ancestor_Op)); 6978 pragma Assert (Is_Ancestor (Typ, Descendant_Type) 6979 or else Is_Progenitor (Typ, Descendant_Type)); 6980 6981 Elmt := First_Elmt (Primitive_Operations (Descendant_Type)); 6982 6983 while Present (Elmt) loop 6984 Subp := Node (Elmt); 6985 6986 -- For regular primitives we only need to traverse the chain of 6987 -- ancestors when the name matches the name of Ancestor_Op, but 6988 -- for predefined dispatching operations we cannot rely on the 6989 -- name of the primitive to identify a candidate since their name 6990 -- is internally built adding a suffix to the name of the tagged 6991 -- type. 6992 6993 if Chars (Subp) = Chars (Ancestor_Op) 6994 or else Is_Predefined_Dispatching_Operation (Subp) 6995 then 6996 -- Handle case where Ancestor_Op is a primitive of a progenitor. 6997 -- We rely on internal entities that map interface primitives: 6998 -- their attribute Interface_Alias references the interface 6999 -- primitive, and their Alias attribute references the primitive 7000 -- of Descendant_Type implementing that interface primitive. 7001 7002 if Present (Interface_Alias (Subp)) then 7003 if Interface_Alias (Subp) = Ancestor_Op then 7004 return Alias (Subp); 7005 end if; 7006 7007 -- Traverse the chain of ancestors searching for Ancestor_Op. 7008 -- Overridden primitives have attribute Overridden_Operation; 7009 -- inherited primitives have attribute Alias. 7010 7011 else 7012 Prim := Subp; 7013 7014 while Present (Overridden_Operation (Prim)) 7015 or else Present (Alias (Prim)) 7016 loop 7017 if Present (Overridden_Operation (Prim)) then 7018 Prim := Overridden_Operation (Prim); 7019 else 7020 Prim := Alias (Prim); 7021 end if; 7022 7023 if Prim = Ancestor_Op then 7024 return Subp; 7025 end if; 7026 end loop; 7027 end if; 7028 end if; 7029 7030 Next_Elmt (Elmt); 7031 end loop; 7032 7033 pragma Assert (False); 7034 return Empty; 7035 end Corresponding_Primitive_Op; 7036 7037 -------------------- 7038 -- Current_Entity -- 7039 -------------------- 7040 7041 -- The currently visible definition for a given identifier is the 7042 -- one most chained at the start of the visibility chain, i.e. the 7043 -- one that is referenced by the Node_Id value of the name of the 7044 -- given identifier. 7045 7046 function Current_Entity (N : Node_Id) return Entity_Id is 7047 begin 7048 return Get_Name_Entity_Id (Chars (N)); 7049 end Current_Entity; 7050 7051 ----------------------------- 7052 -- Current_Entity_In_Scope -- 7053 ----------------------------- 7054 7055 function Current_Entity_In_Scope (N : Name_Id) return Entity_Id is 7056 CS : constant Entity_Id := Current_Scope; 7057 7058 E : Entity_Id; 7059 7060 begin 7061 E := Get_Name_Entity_Id (N); 7062 7063 if No (E) then 7064 null; 7065 7066 elsif Scope_Is_Transient then 7067 while Present (E) loop 7068 exit when Scope (E) = CS or else Scope (E) = Scope (CS); 7069 7070 E := Homonym (E); 7071 end loop; 7072 7073 else 7074 while Present (E) loop 7075 exit when Scope (E) = CS; 7076 7077 E := Homonym (E); 7078 end loop; 7079 end if; 7080 7081 return E; 7082 end Current_Entity_In_Scope; 7083 7084 ----------------------------- 7085 -- Current_Entity_In_Scope -- 7086 ----------------------------- 7087 7088 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is 7089 begin 7090 return Current_Entity_In_Scope (Chars (N)); 7091 end Current_Entity_In_Scope; 7092 7093 ------------------- 7094 -- Current_Scope -- 7095 ------------------- 7096 7097 function Current_Scope return Entity_Id is 7098 begin 7099 if Scope_Stack.Last = -1 then 7100 return Standard_Standard; 7101 else 7102 declare 7103 C : constant Entity_Id := 7104 Scope_Stack.Table (Scope_Stack.Last).Entity; 7105 begin 7106 if Present (C) then 7107 return C; 7108 else 7109 return Standard_Standard; 7110 end if; 7111 end; 7112 end if; 7113 end Current_Scope; 7114 7115 ---------------------------- 7116 -- Current_Scope_No_Loops -- 7117 ---------------------------- 7118 7119 function Current_Scope_No_Loops return Entity_Id is 7120 S : Entity_Id; 7121 7122 begin 7123 -- Examine the scope stack starting from the current scope and skip any 7124 -- internally generated loops. 7125 7126 S := Current_Scope; 7127 while Present (S) and then S /= Standard_Standard loop 7128 if Ekind (S) = E_Loop and then not Comes_From_Source (S) then 7129 S := Scope (S); 7130 else 7131 exit; 7132 end if; 7133 end loop; 7134 7135 return S; 7136 end Current_Scope_No_Loops; 7137 7138 ------------------------ 7139 -- Current_Subprogram -- 7140 ------------------------ 7141 7142 function Current_Subprogram return Entity_Id is 7143 Scop : constant Entity_Id := Current_Scope; 7144 begin 7145 if Is_Subprogram_Or_Generic_Subprogram (Scop) then 7146 return Scop; 7147 else 7148 return Enclosing_Subprogram (Scop); 7149 end if; 7150 end Current_Subprogram; 7151 7152 ------------------------------- 7153 -- CW_Or_Has_Controlled_Part -- 7154 ------------------------------- 7155 7156 function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is 7157 begin 7158 return Is_Class_Wide_Type (T) or else Needs_Finalization (T); 7159 end CW_Or_Has_Controlled_Part; 7160 7161 ------------------------------- 7162 -- Deepest_Type_Access_Level -- 7163 ------------------------------- 7164 7165 function Deepest_Type_Access_Level 7166 (Typ : Entity_Id; 7167 Allow_Alt_Model : Boolean := True) return Uint 7168 is 7169 begin 7170 if Ekind (Typ) = E_Anonymous_Access_Type 7171 and then not Is_Local_Anonymous_Access (Typ) 7172 and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration 7173 then 7174 -- No_Dynamic_Accessibility_Checks override for alternative 7175 -- accessibility model. 7176 7177 if Allow_Alt_Model 7178 and then No_Dynamic_Accessibility_Checks_Enabled (Typ) 7179 then 7180 return Type_Access_Level (Typ, Allow_Alt_Model); 7181 end if; 7182 7183 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous 7184 -- access type. 7185 7186 return 7187 Scope_Depth (Enclosing_Dynamic_Scope 7188 (Defining_Identifier 7189 (Associated_Node_For_Itype (Typ)))); 7190 7191 -- For generic formal type, return Int'Last (infinite). 7192 -- See comment preceding Is_Generic_Type call in Type_Access_Level. 7193 7194 elsif Is_Generic_Type (Root_Type (Typ)) then 7195 return UI_From_Int (Int'Last); 7196 7197 else 7198 return Type_Access_Level (Typ, Allow_Alt_Model); 7199 end if; 7200 end Deepest_Type_Access_Level; 7201 7202 --------------------- 7203 -- Defining_Entity -- 7204 --------------------- 7205 7206 function Defining_Entity (N : Node_Id) return Entity_Id is 7207 Ent : constant Entity_Id := Defining_Entity_Or_Empty (N); 7208 7209 begin 7210 if Present (Ent) then 7211 return Ent; 7212 7213 else 7214 raise Program_Error; 7215 end if; 7216 end Defining_Entity; 7217 7218 ------------------------------ 7219 -- Defining_Entity_Or_Empty -- 7220 ------------------------------ 7221 7222 function Defining_Entity_Or_Empty (N : Node_Id) return Entity_Id is 7223 begin 7224 case Nkind (N) is 7225 when N_Abstract_Subprogram_Declaration 7226 | N_Expression_Function 7227 | N_Formal_Subprogram_Declaration 7228 | N_Generic_Package_Declaration 7229 | N_Generic_Subprogram_Declaration 7230 | N_Package_Declaration 7231 | N_Subprogram_Body 7232 | N_Subprogram_Body_Stub 7233 | N_Subprogram_Declaration 7234 | N_Subprogram_Renaming_Declaration 7235 => 7236 return Defining_Entity (Specification (N)); 7237 7238 when N_Component_Declaration 7239 | N_Defining_Program_Unit_Name 7240 | N_Discriminant_Specification 7241 | N_Entry_Body 7242 | N_Entry_Declaration 7243 | N_Entry_Index_Specification 7244 | N_Exception_Declaration 7245 | N_Exception_Renaming_Declaration 7246 | N_Formal_Object_Declaration 7247 | N_Formal_Package_Declaration 7248 | N_Formal_Type_Declaration 7249 | N_Full_Type_Declaration 7250 | N_Implicit_Label_Declaration 7251 | N_Incomplete_Type_Declaration 7252 | N_Iterator_Specification 7253 | N_Loop_Parameter_Specification 7254 | N_Number_Declaration 7255 | N_Object_Declaration 7256 | N_Object_Renaming_Declaration 7257 | N_Package_Body_Stub 7258 | N_Parameter_Specification 7259 | N_Private_Extension_Declaration 7260 | N_Private_Type_Declaration 7261 | N_Protected_Body 7262 | N_Protected_Body_Stub 7263 | N_Protected_Type_Declaration 7264 | N_Single_Protected_Declaration 7265 | N_Single_Task_Declaration 7266 | N_Subtype_Declaration 7267 | N_Task_Body 7268 | N_Task_Body_Stub 7269 | N_Task_Type_Declaration 7270 => 7271 return Defining_Identifier (N); 7272 7273 when N_Compilation_Unit => 7274 return Defining_Entity (Unit (N)); 7275 7276 when N_Subunit => 7277 return Defining_Entity (Proper_Body (N)); 7278 7279 when N_Function_Instantiation 7280 | N_Function_Specification 7281 | N_Generic_Function_Renaming_Declaration 7282 | N_Generic_Package_Renaming_Declaration 7283 | N_Generic_Procedure_Renaming_Declaration 7284 | N_Package_Body 7285 | N_Package_Instantiation 7286 | N_Package_Renaming_Declaration 7287 | N_Package_Specification 7288 | N_Procedure_Instantiation 7289 | N_Procedure_Specification 7290 => 7291 declare 7292 Nam : constant Node_Id := Defining_Unit_Name (N); 7293 Err : Entity_Id := Empty; 7294 7295 begin 7296 if Nkind (Nam) in N_Entity then 7297 return Nam; 7298 7299 -- For Error, make up a name and attach to declaration so we 7300 -- can continue semantic analysis. 7301 7302 elsif Nam = Error then 7303 Err := Make_Temporary (Sloc (N), 'T'); 7304 Set_Defining_Unit_Name (N, Err); 7305 7306 return Err; 7307 7308 -- If not an entity, get defining identifier 7309 7310 else 7311 return Defining_Identifier (Nam); 7312 end if; 7313 end; 7314 7315 when N_Block_Statement 7316 | N_Loop_Statement 7317 => 7318 return Entity (Identifier (N)); 7319 7320 when others => 7321 return Empty; 7322 end case; 7323 end Defining_Entity_Or_Empty; 7324 7325 -------------------------- 7326 -- Denotes_Discriminant -- 7327 -------------------------- 7328 7329 function Denotes_Discriminant 7330 (N : Node_Id; 7331 Check_Concurrent : Boolean := False) return Boolean 7332 is 7333 E : Entity_Id; 7334 7335 begin 7336 if not Is_Entity_Name (N) or else No (Entity (N)) then 7337 return False; 7338 else 7339 E := Entity (N); 7340 end if; 7341 7342 -- If we are checking for a protected type, the discriminant may have 7343 -- been rewritten as the corresponding discriminal of the original type 7344 -- or of the corresponding concurrent record, depending on whether we 7345 -- are in the spec or body of the protected type. 7346 7347 return Ekind (E) = E_Discriminant 7348 or else 7349 (Check_Concurrent 7350 and then Ekind (E) = E_In_Parameter 7351 and then Present (Discriminal_Link (E)) 7352 and then 7353 (Is_Concurrent_Type (Scope (Discriminal_Link (E))) 7354 or else 7355 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E))))); 7356 end Denotes_Discriminant; 7357 7358 ------------------------- 7359 -- Denotes_Same_Object -- 7360 ------------------------- 7361 7362 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is 7363 function Is_Object_Renaming (N : Node_Id) return Boolean; 7364 -- Return true if N names an object renaming entity 7365 7366 function Is_Valid_Renaming (N : Node_Id) return Boolean; 7367 -- For renamings, return False if the prefix of any dereference within 7368 -- the renamed object_name is a variable, or any expression within the 7369 -- renamed object_name contains references to variables or calls on 7370 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3)) 7371 7372 ------------------------ 7373 -- Is_Object_Renaming -- 7374 ------------------------ 7375 7376 function Is_Object_Renaming (N : Node_Id) return Boolean is 7377 begin 7378 return Is_Entity_Name (N) 7379 and then Ekind (Entity (N)) in E_Variable | E_Constant 7380 and then Present (Renamed_Object (Entity (N))); 7381 end Is_Object_Renaming; 7382 7383 ----------------------- 7384 -- Is_Valid_Renaming -- 7385 ----------------------- 7386 7387 function Is_Valid_Renaming (N : Node_Id) return Boolean is 7388 begin 7389 if Is_Object_Renaming (N) 7390 and then not Is_Valid_Renaming (Renamed_Object (Entity (N))) 7391 then 7392 return False; 7393 end if; 7394 7395 -- Check if any expression within the renamed object_name contains no 7396 -- references to variables nor calls on nonstatic functions. 7397 7398 if Nkind (N) = N_Indexed_Component then 7399 declare 7400 Indx : Node_Id; 7401 7402 begin 7403 Indx := First (Expressions (N)); 7404 while Present (Indx) loop 7405 if not Is_OK_Static_Expression (Indx) then 7406 return False; 7407 end if; 7408 7409 Next (Indx); 7410 end loop; 7411 end; 7412 7413 elsif Nkind (N) = N_Slice then 7414 declare 7415 Rng : constant Node_Id := Discrete_Range (N); 7416 begin 7417 -- Bounds specified as a range 7418 7419 if Nkind (Rng) = N_Range then 7420 if not Is_OK_Static_Range (Rng) then 7421 return False; 7422 end if; 7423 7424 -- Bounds specified as a constrained subtype indication 7425 7426 elsif Nkind (Rng) = N_Subtype_Indication then 7427 if not Is_OK_Static_Range 7428 (Range_Expression (Constraint (Rng))) 7429 then 7430 return False; 7431 end if; 7432 7433 -- Bounds specified as a subtype name 7434 7435 elsif not Is_OK_Static_Expression (Rng) then 7436 return False; 7437 end if; 7438 end; 7439 end if; 7440 7441 if Has_Prefix (N) then 7442 declare 7443 P : constant Node_Id := Prefix (N); 7444 7445 begin 7446 if Nkind (N) = N_Explicit_Dereference 7447 and then Is_Variable (P) 7448 then 7449 return False; 7450 7451 elsif Is_Entity_Name (P) 7452 and then Ekind (Entity (P)) = E_Function 7453 then 7454 return False; 7455 7456 elsif Nkind (P) = N_Function_Call then 7457 return False; 7458 end if; 7459 7460 -- Recursion to continue traversing the prefix of the 7461 -- renaming expression 7462 7463 return Is_Valid_Renaming (P); 7464 end; 7465 end if; 7466 7467 return True; 7468 end Is_Valid_Renaming; 7469 7470 -- Start of processing for Denotes_Same_Object 7471 7472 begin 7473 -- Both names statically denote the same stand-alone object or 7474 -- parameter (RM 6.4.1(6.6/3)). 7475 7476 if Is_Entity_Name (A1) 7477 and then Is_Entity_Name (A2) 7478 and then Entity (A1) = Entity (A2) 7479 then 7480 return True; 7481 7482 -- Both names are selected_components, their prefixes are known to 7483 -- denote the same object, and their selector_names denote the same 7484 -- component (RM 6.4.1(6.7/3)). 7485 7486 elsif Nkind (A1) = N_Selected_Component 7487 and then Nkind (A2) = N_Selected_Component 7488 then 7489 return Denotes_Same_Object (Prefix (A1), Prefix (A2)) 7490 and then 7491 Entity (Selector_Name (A1)) = Entity (Selector_Name (A2)); 7492 7493 -- Both names are dereferences and the dereferenced names are known to 7494 -- denote the same object (RM 6.4.1(6.8/3)). 7495 7496 elsif Nkind (A1) = N_Explicit_Dereference 7497 and then Nkind (A2) = N_Explicit_Dereference 7498 then 7499 return Denotes_Same_Object (Prefix (A1), Prefix (A2)); 7500 7501 -- Both names are indexed_components, their prefixes are known to denote 7502 -- the same object, and each of the pairs of corresponding index values 7503 -- are either both static expressions with the same static value or both 7504 -- names that are known to denote the same object (RM 6.4.1(6.9/3)). 7505 7506 elsif Nkind (A1) = N_Indexed_Component 7507 and then Nkind (A2) = N_Indexed_Component 7508 then 7509 if not Denotes_Same_Object (Prefix (A1), Prefix (A2)) then 7510 return False; 7511 else 7512 declare 7513 Indx1 : Node_Id; 7514 Indx2 : Node_Id; 7515 7516 begin 7517 Indx1 := First (Expressions (A1)); 7518 Indx2 := First (Expressions (A2)); 7519 while Present (Indx1) loop 7520 7521 -- Indexes must denote the same static value or same object 7522 7523 if Is_OK_Static_Expression (Indx1) then 7524 if not Is_OK_Static_Expression (Indx2) then 7525 return False; 7526 7527 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then 7528 return False; 7529 end if; 7530 7531 elsif not Denotes_Same_Object (Indx1, Indx2) then 7532 return False; 7533 end if; 7534 7535 Next (Indx1); 7536 Next (Indx2); 7537 end loop; 7538 7539 return True; 7540 end; 7541 end if; 7542 7543 -- Both names are slices, their prefixes are known to denote the same 7544 -- object, and the two slices have statically matching index constraints 7545 -- (RM 6.4.1(6.10/3)). 7546 7547 elsif Nkind (A1) = N_Slice 7548 and then Nkind (A2) = N_Slice 7549 then 7550 if not Denotes_Same_Object (Prefix (A1), Prefix (A2)) then 7551 return False; 7552 else 7553 declare 7554 Lo1, Lo2, Hi1, Hi2 : Node_Id; 7555 7556 begin 7557 Get_Index_Bounds (Discrete_Range (A1), Lo1, Hi1); 7558 Get_Index_Bounds (Discrete_Range (A2), Lo2, Hi2); 7559 7560 -- Check whether bounds are statically identical. There is no 7561 -- attempt to detect partial overlap of slices. 7562 7563 return Is_OK_Static_Expression (Lo1) 7564 and then Is_OK_Static_Expression (Lo2) 7565 and then Is_OK_Static_Expression (Hi1) 7566 and then Is_OK_Static_Expression (Hi2) 7567 and then Expr_Value (Lo1) = Expr_Value (Lo2) 7568 and then Expr_Value (Hi1) = Expr_Value (Hi2); 7569 end; 7570 end if; 7571 7572 -- One of the two names statically denotes a renaming declaration whose 7573 -- renamed object_name is known to denote the same object as the other; 7574 -- the prefix of any dereference within the renamed object_name is not a 7575 -- variable, and any expression within the renamed object_name contains 7576 -- no references to variables nor calls on nonstatic functions (RM 7577 -- 6.4.1(6.11/3)). 7578 7579 elsif Is_Object_Renaming (A1) 7580 and then Is_Valid_Renaming (A1) 7581 then 7582 return Denotes_Same_Object (Renamed_Object (Entity (A1)), A2); 7583 7584 elsif Is_Object_Renaming (A2) 7585 and then Is_Valid_Renaming (A2) 7586 then 7587 return Denotes_Same_Object (A1, Renamed_Object (Entity (A2))); 7588 7589 else 7590 return False; 7591 end if; 7592 end Denotes_Same_Object; 7593 7594 ------------------------- 7595 -- Denotes_Same_Prefix -- 7596 ------------------------- 7597 7598 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is 7599 begin 7600 if Is_Entity_Name (A1) then 7601 if Nkind (A2) in N_Selected_Component | N_Indexed_Component 7602 and then not Is_Access_Type (Etype (A1)) 7603 then 7604 return Denotes_Same_Object (A1, Prefix (A2)) 7605 or else Denotes_Same_Prefix (A1, Prefix (A2)); 7606 else 7607 return False; 7608 end if; 7609 7610 elsif Is_Entity_Name (A2) then 7611 return Denotes_Same_Prefix (A1 => A2, A2 => A1); 7612 7613 elsif Nkind (A1) in N_Selected_Component | N_Indexed_Component | N_Slice 7614 and then 7615 Nkind (A2) in N_Selected_Component | N_Indexed_Component | N_Slice 7616 then 7617 declare 7618 Root1, Root2 : Node_Id; 7619 Depth1, Depth2 : Nat := 0; 7620 7621 begin 7622 Root1 := Prefix (A1); 7623 while not Is_Entity_Name (Root1) loop 7624 if Nkind (Root1) not in 7625 N_Selected_Component | N_Indexed_Component 7626 then 7627 return False; 7628 else 7629 Root1 := Prefix (Root1); 7630 end if; 7631 7632 Depth1 := Depth1 + 1; 7633 end loop; 7634 7635 Root2 := Prefix (A2); 7636 while not Is_Entity_Name (Root2) loop 7637 if Nkind (Root2) not in 7638 N_Selected_Component | N_Indexed_Component 7639 then 7640 return False; 7641 else 7642 Root2 := Prefix (Root2); 7643 end if; 7644 7645 Depth2 := Depth2 + 1; 7646 end loop; 7647 7648 -- If both have the same depth and they do not denote the same 7649 -- object, they are disjoint and no warning is needed. 7650 7651 if Depth1 = Depth2 then 7652 return False; 7653 7654 elsif Depth1 > Depth2 then 7655 Root1 := Prefix (A1); 7656 for J in 1 .. Depth1 - Depth2 - 1 loop 7657 Root1 := Prefix (Root1); 7658 end loop; 7659 7660 return Denotes_Same_Object (Root1, A2); 7661 7662 else 7663 Root2 := Prefix (A2); 7664 for J in 1 .. Depth2 - Depth1 - 1 loop 7665 Root2 := Prefix (Root2); 7666 end loop; 7667 7668 return Denotes_Same_Object (A1, Root2); 7669 end if; 7670 end; 7671 7672 else 7673 return False; 7674 end if; 7675 end Denotes_Same_Prefix; 7676 7677 ---------------------- 7678 -- Denotes_Variable -- 7679 ---------------------- 7680 7681 function Denotes_Variable (N : Node_Id) return Boolean is 7682 begin 7683 return Is_Variable (N) and then Paren_Count (N) = 0; 7684 end Denotes_Variable; 7685 7686 ----------------------------- 7687 -- Depends_On_Discriminant -- 7688 ----------------------------- 7689 7690 function Depends_On_Discriminant (N : Node_Id) return Boolean is 7691 L : Node_Id; 7692 H : Node_Id; 7693 7694 begin 7695 Get_Index_Bounds (N, L, H); 7696 return Denotes_Discriminant (L) or else Denotes_Discriminant (H); 7697 end Depends_On_Discriminant; 7698 7699 ------------------------------------- 7700 -- Derivation_Too_Early_To_Inherit -- 7701 ------------------------------------- 7702 7703 function Derivation_Too_Early_To_Inherit 7704 (Typ : Entity_Id; Streaming_Op : TSS_Name_Type) return Boolean is 7705 Btyp : constant Entity_Id := Implementation_Base_Type (Typ); 7706 Parent_Type : Entity_Id; 7707 begin 7708 if Is_Derived_Type (Btyp) then 7709 Parent_Type := Implementation_Base_Type (Etype (Btyp)); 7710 pragma Assert (Parent_Type /= Btyp); 7711 if Has_Stream_Attribute_Definition 7712 (Parent_Type, Streaming_Op) 7713 and then In_Same_Extended_Unit (Btyp, Parent_Type) 7714 and then Instantiation (Get_Source_File_Index (Sloc (Btyp))) = 7715 Instantiation (Get_Source_File_Index (Sloc (Parent_Type))) 7716 then 7717 declare 7718 -- ??? Avoid code duplication here with 7719 -- Sem_Cat.Has_Stream_Attribute_Definition by introducing a 7720 -- new function to be called from both places? 7721 7722 Rep_Item : Node_Id := First_Rep_Item (Parent_Type); 7723 Real_Rep : Node_Id; 7724 Found : Boolean := False; 7725 begin 7726 while Present (Rep_Item) loop 7727 Real_Rep := Rep_Item; 7728 7729 if Nkind (Rep_Item) = N_Aspect_Specification then 7730 Real_Rep := Aspect_Rep_Item (Rep_Item); 7731 end if; 7732 7733 if Nkind (Real_Rep) = N_Attribute_Definition_Clause then 7734 case Chars (Real_Rep) is 7735 when Name_Read => 7736 Found := Streaming_Op = TSS_Stream_Read; 7737 7738 when Name_Write => 7739 Found := Streaming_Op = TSS_Stream_Write; 7740 7741 when Name_Input => 7742 Found := Streaming_Op = TSS_Stream_Input; 7743 7744 when Name_Output => 7745 Found := Streaming_Op = TSS_Stream_Output; 7746 7747 when others => 7748 null; 7749 end case; 7750 end if; 7751 7752 if Found then 7753 return Earlier_In_Extended_Unit (Btyp, Real_Rep); 7754 end if; 7755 7756 Next_Rep_Item (Rep_Item); 7757 end loop; 7758 end; 7759 end if; 7760 end if; 7761 return False; 7762 end Derivation_Too_Early_To_Inherit; 7763 7764 ------------------------- 7765 -- Designate_Same_Unit -- 7766 ------------------------- 7767 7768 function Designate_Same_Unit 7769 (Name1 : Node_Id; 7770 Name2 : Node_Id) return Boolean 7771 is 7772 K1 : constant Node_Kind := Nkind (Name1); 7773 K2 : constant Node_Kind := Nkind (Name2); 7774 7775 function Prefix_Node (N : Node_Id) return Node_Id; 7776 -- Returns the parent unit name node of a defining program unit name 7777 -- or the prefix if N is a selected component or an expanded name. 7778 7779 function Select_Node (N : Node_Id) return Node_Id; 7780 -- Returns the defining identifier node of a defining program unit 7781 -- name or the selector node if N is a selected component or an 7782 -- expanded name. 7783 7784 ----------------- 7785 -- Prefix_Node -- 7786 ----------------- 7787 7788 function Prefix_Node (N : Node_Id) return Node_Id is 7789 begin 7790 if Nkind (N) = N_Defining_Program_Unit_Name then 7791 return Name (N); 7792 else 7793 return Prefix (N); 7794 end if; 7795 end Prefix_Node; 7796 7797 ----------------- 7798 -- Select_Node -- 7799 ----------------- 7800 7801 function Select_Node (N : Node_Id) return Node_Id is 7802 begin 7803 if Nkind (N) = N_Defining_Program_Unit_Name then 7804 return Defining_Identifier (N); 7805 else 7806 return Selector_Name (N); 7807 end if; 7808 end Select_Node; 7809 7810 -- Start of processing for Designate_Same_Unit 7811 7812 begin 7813 if K1 in N_Identifier | N_Defining_Identifier 7814 and then 7815 K2 in N_Identifier | N_Defining_Identifier 7816 then 7817 return Chars (Name1) = Chars (Name2); 7818 7819 elsif K1 in N_Expanded_Name 7820 | N_Selected_Component 7821 | N_Defining_Program_Unit_Name 7822 and then 7823 K2 in N_Expanded_Name 7824 | N_Selected_Component 7825 | N_Defining_Program_Unit_Name 7826 then 7827 return 7828 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2))) 7829 and then 7830 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2)); 7831 7832 else 7833 return False; 7834 end if; 7835 end Designate_Same_Unit; 7836 7837 --------------------------------------------- 7838 -- Diagnose_Iterated_Component_Association -- 7839 --------------------------------------------- 7840 7841 procedure Diagnose_Iterated_Component_Association (N : Node_Id) is 7842 Def_Id : constant Entity_Id := Defining_Identifier (N); 7843 Aggr : Node_Id; 7844 7845 begin 7846 -- Determine whether the iterated component association appears within 7847 -- an aggregate. If this is the case, raise Program_Error because the 7848 -- iterated component association cannot be left in the tree as is and 7849 -- must always be processed by the related aggregate. 7850 7851 Aggr := N; 7852 while Present (Aggr) loop 7853 if Nkind (Aggr) = N_Aggregate then 7854 raise Program_Error; 7855 7856 -- Prevent the search from going too far 7857 7858 elsif Is_Body_Or_Package_Declaration (Aggr) then 7859 exit; 7860 end if; 7861 7862 Aggr := Parent (Aggr); 7863 end loop; 7864 7865 -- At this point it is known that the iterated component association is 7866 -- not within an aggregate. This is really a quantified expression with 7867 -- a missing "all" or "some" quantifier. 7868 7869 Error_Msg_N ("missing quantifier", Def_Id); 7870 7871 -- Rewrite the iterated component association as True to prevent any 7872 -- cascaded errors. 7873 7874 Rewrite (N, New_Occurrence_Of (Standard_True, Sloc (N))); 7875 Analyze (N); 7876 end Diagnose_Iterated_Component_Association; 7877 7878 ------------------------ 7879 -- Discriminated_Size -- 7880 ------------------------ 7881 7882 function Discriminated_Size (Comp : Entity_Id) return Boolean is 7883 function Non_Static_Bound (Bound : Node_Id) return Boolean; 7884 -- Check whether the bound of an index is non-static and does denote 7885 -- a discriminant, in which case any object of the type (protected or 7886 -- otherwise) will have a non-static size. 7887 7888 ---------------------- 7889 -- Non_Static_Bound -- 7890 ---------------------- 7891 7892 function Non_Static_Bound (Bound : Node_Id) return Boolean is 7893 begin 7894 if Is_OK_Static_Expression (Bound) then 7895 return False; 7896 7897 -- If the bound is given by a discriminant it is non-static 7898 -- (A static constraint replaces the reference with the value). 7899 -- In an protected object the discriminant has been replaced by 7900 -- the corresponding discriminal within the protected operation. 7901 7902 elsif Is_Entity_Name (Bound) 7903 and then 7904 (Ekind (Entity (Bound)) = E_Discriminant 7905 or else Present (Discriminal_Link (Entity (Bound)))) 7906 then 7907 return False; 7908 7909 else 7910 return True; 7911 end if; 7912 end Non_Static_Bound; 7913 7914 -- Local variables 7915 7916 Typ : constant Entity_Id := Etype (Comp); 7917 Index : Node_Id; 7918 7919 -- Start of processing for Discriminated_Size 7920 7921 begin 7922 if not Is_Array_Type (Typ) then 7923 return False; 7924 end if; 7925 7926 if Ekind (Typ) = E_Array_Subtype then 7927 Index := First_Index (Typ); 7928 while Present (Index) loop 7929 if Non_Static_Bound (Low_Bound (Index)) 7930 or else Non_Static_Bound (High_Bound (Index)) 7931 then 7932 return False; 7933 end if; 7934 7935 Next_Index (Index); 7936 end loop; 7937 7938 return True; 7939 end if; 7940 7941 return False; 7942 end Discriminated_Size; 7943 7944 ----------------------------------- 7945 -- Effective_Extra_Accessibility -- 7946 ----------------------------------- 7947 7948 function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is 7949 begin 7950 if Present (Renamed_Object (Id)) 7951 and then Is_Entity_Name (Renamed_Object (Id)) 7952 then 7953 return Effective_Extra_Accessibility (Entity (Renamed_Object (Id))); 7954 else 7955 return Extra_Accessibility (Id); 7956 end if; 7957 end Effective_Extra_Accessibility; 7958 7959 ----------------------------- 7960 -- Effective_Reads_Enabled -- 7961 ----------------------------- 7962 7963 function Effective_Reads_Enabled (Id : Entity_Id) return Boolean is 7964 begin 7965 return Has_Enabled_Property (Id, Name_Effective_Reads); 7966 end Effective_Reads_Enabled; 7967 7968 ------------------------------ 7969 -- Effective_Writes_Enabled -- 7970 ------------------------------ 7971 7972 function Effective_Writes_Enabled (Id : Entity_Id) return Boolean is 7973 begin 7974 return Has_Enabled_Property (Id, Name_Effective_Writes); 7975 end Effective_Writes_Enabled; 7976 7977 ------------------------------ 7978 -- Enclosing_Comp_Unit_Node -- 7979 ------------------------------ 7980 7981 function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is 7982 Current_Node : Node_Id; 7983 7984 begin 7985 Current_Node := N; 7986 while Present (Current_Node) 7987 and then Nkind (Current_Node) /= N_Compilation_Unit 7988 loop 7989 Current_Node := Parent (Current_Node); 7990 end loop; 7991 7992 return Current_Node; 7993 end Enclosing_Comp_Unit_Node; 7994 7995 -------------------------- 7996 -- Enclosing_CPP_Parent -- 7997 -------------------------- 7998 7999 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is 8000 Parent_Typ : Entity_Id := Typ; 8001 8002 begin 8003 while not Is_CPP_Class (Parent_Typ) 8004 and then Etype (Parent_Typ) /= Parent_Typ 8005 loop 8006 Parent_Typ := Etype (Parent_Typ); 8007 8008 if Is_Private_Type (Parent_Typ) then 8009 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 8010 end if; 8011 end loop; 8012 8013 pragma Assert (Is_CPP_Class (Parent_Typ)); 8014 return Parent_Typ; 8015 end Enclosing_CPP_Parent; 8016 8017 --------------------------- 8018 -- Enclosing_Declaration -- 8019 --------------------------- 8020 8021 function Enclosing_Declaration (N : Node_Id) return Node_Id is 8022 Decl : Node_Id := N; 8023 8024 begin 8025 while Present (Decl) 8026 and then not (Nkind (Decl) in N_Declaration 8027 or else 8028 Nkind (Decl) in N_Later_Decl_Item 8029 or else 8030 Nkind (Decl) in N_Renaming_Declaration 8031 or else 8032 Nkind (Decl) = N_Number_Declaration) 8033 loop 8034 Decl := Parent (Decl); 8035 end loop; 8036 8037 return Decl; 8038 end Enclosing_Declaration; 8039 8040 ---------------------------- 8041 -- Enclosing_Generic_Body -- 8042 ---------------------------- 8043 8044 function Enclosing_Generic_Body (N : Node_Id) return Node_Id is 8045 Par : Node_Id; 8046 Spec_Id : Entity_Id; 8047 8048 begin 8049 Par := Parent (N); 8050 while Present (Par) loop 8051 if Nkind (Par) in N_Package_Body | N_Subprogram_Body then 8052 Spec_Id := Corresponding_Spec (Par); 8053 8054 if Present (Spec_Id) 8055 and then Nkind (Unit_Declaration_Node (Spec_Id)) in 8056 N_Generic_Declaration 8057 then 8058 return Par; 8059 end if; 8060 end if; 8061 8062 Par := Parent (Par); 8063 end loop; 8064 8065 return Empty; 8066 end Enclosing_Generic_Body; 8067 8068 ---------------------------- 8069 -- Enclosing_Generic_Unit -- 8070 ---------------------------- 8071 8072 function Enclosing_Generic_Unit (N : Node_Id) return Node_Id is 8073 Par : Node_Id; 8074 Spec_Decl : Node_Id; 8075 Spec_Id : Entity_Id; 8076 8077 begin 8078 Par := Parent (N); 8079 while Present (Par) loop 8080 if Nkind (Par) in N_Generic_Declaration then 8081 return Par; 8082 8083 elsif Nkind (Par) in N_Package_Body | N_Subprogram_Body then 8084 Spec_Id := Corresponding_Spec (Par); 8085 8086 if Present (Spec_Id) then 8087 Spec_Decl := Unit_Declaration_Node (Spec_Id); 8088 8089 if Nkind (Spec_Decl) in N_Generic_Declaration then 8090 return Spec_Decl; 8091 end if; 8092 end if; 8093 end if; 8094 8095 Par := Parent (Par); 8096 end loop; 8097 8098 return Empty; 8099 end Enclosing_Generic_Unit; 8100 8101 ------------------- 8102 -- Enclosing_HSS -- 8103 ------------------- 8104 8105 function Enclosing_HSS (Stmt : Node_Id) return Node_Id is 8106 Par : Node_Id; 8107 begin 8108 pragma Assert (Is_Statement (Stmt)); 8109 8110 Par := Parent (Stmt); 8111 while Present (Par) loop 8112 8113 if Nkind (Par) = N_Handled_Sequence_Of_Statements then 8114 return Par; 8115 8116 -- Prevent the search from going too far 8117 8118 elsif Is_Body_Or_Package_Declaration (Par) then 8119 return Empty; 8120 8121 end if; 8122 8123 Par := Parent (Par); 8124 end loop; 8125 8126 return Par; 8127 end Enclosing_HSS; 8128 8129 ------------------------------- 8130 -- Enclosing_Lib_Unit_Entity -- 8131 ------------------------------- 8132 8133 function Enclosing_Lib_Unit_Entity 8134 (E : Entity_Id := Current_Scope) return Entity_Id 8135 is 8136 Unit_Entity : Entity_Id; 8137 8138 begin 8139 -- Look for enclosing library unit entity by following scope links. 8140 -- Equivalent to, but faster than indexing through the scope stack. 8141 8142 Unit_Entity := E; 8143 while (Present (Scope (Unit_Entity)) 8144 and then Scope (Unit_Entity) /= Standard_Standard) 8145 and not Is_Child_Unit (Unit_Entity) 8146 loop 8147 Unit_Entity := Scope (Unit_Entity); 8148 end loop; 8149 8150 return Unit_Entity; 8151 end Enclosing_Lib_Unit_Entity; 8152 8153 ----------------------------- 8154 -- Enclosing_Lib_Unit_Node -- 8155 ----------------------------- 8156 8157 function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is 8158 Encl_Unit : Node_Id; 8159 8160 begin 8161 Encl_Unit := Enclosing_Comp_Unit_Node (N); 8162 while Present (Encl_Unit) 8163 and then Nkind (Unit (Encl_Unit)) = N_Subunit 8164 loop 8165 Encl_Unit := Library_Unit (Encl_Unit); 8166 end loop; 8167 8168 pragma Assert (Nkind (Encl_Unit) = N_Compilation_Unit); 8169 return Encl_Unit; 8170 end Enclosing_Lib_Unit_Node; 8171 8172 ----------------------- 8173 -- Enclosing_Package -- 8174 ----------------------- 8175 8176 function Enclosing_Package (E : Entity_Id) return Entity_Id is 8177 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E); 8178 8179 begin 8180 if Dynamic_Scope = Standard_Standard then 8181 return Standard_Standard; 8182 8183 elsif Dynamic_Scope = Empty then 8184 return Empty; 8185 8186 elsif Ekind (Dynamic_Scope) in 8187 E_Generic_Package | E_Package | E_Package_Body 8188 then 8189 return Dynamic_Scope; 8190 8191 else 8192 return Enclosing_Package (Dynamic_Scope); 8193 end if; 8194 end Enclosing_Package; 8195 8196 ------------------------------------- 8197 -- Enclosing_Package_Or_Subprogram -- 8198 ------------------------------------- 8199 8200 function Enclosing_Package_Or_Subprogram (E : Entity_Id) return Entity_Id is 8201 S : Entity_Id; 8202 8203 begin 8204 S := Scope (E); 8205 while Present (S) loop 8206 if Is_Package_Or_Generic_Package (S) 8207 or else Is_Subprogram_Or_Generic_Subprogram (S) 8208 then 8209 return S; 8210 8211 else 8212 S := Scope (S); 8213 end if; 8214 end loop; 8215 8216 return Empty; 8217 end Enclosing_Package_Or_Subprogram; 8218 8219 -------------------------- 8220 -- Enclosing_Subprogram -- 8221 -------------------------- 8222 8223 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is 8224 Dyn_Scop : constant Entity_Id := Enclosing_Dynamic_Scope (E); 8225 8226 begin 8227 if Dyn_Scop = Standard_Standard then 8228 return Empty; 8229 8230 elsif Dyn_Scop = Empty then 8231 return Empty; 8232 8233 elsif Ekind (Dyn_Scop) = E_Subprogram_Body then 8234 return Corresponding_Spec (Parent (Parent (Dyn_Scop))); 8235 8236 elsif Ekind (Dyn_Scop) in E_Block | E_Loop | E_Return_Statement then 8237 return Enclosing_Subprogram (Dyn_Scop); 8238 8239 elsif Ekind (Dyn_Scop) in E_Entry | E_Entry_Family then 8240 8241 -- For a task entry or entry family, return the enclosing subprogram 8242 -- of the task itself. 8243 8244 if Ekind (Scope (Dyn_Scop)) = E_Task_Type then 8245 return Enclosing_Subprogram (Dyn_Scop); 8246 8247 -- A protected entry or entry family is rewritten as a protected 8248 -- procedure which is the desired enclosing subprogram. This is 8249 -- relevant when unnesting a procedure local to an entry body. 8250 8251 else 8252 return Protected_Body_Subprogram (Dyn_Scop); 8253 end if; 8254 8255 elsif Ekind (Dyn_Scop) = E_Task_Type then 8256 return Get_Task_Body_Procedure (Dyn_Scop); 8257 8258 -- The scope may appear as a private type or as a private extension 8259 -- whose completion is a task or protected type. 8260 8261 elsif Ekind (Dyn_Scop) in 8262 E_Limited_Private_Type | E_Record_Type_With_Private 8263 and then Present (Full_View (Dyn_Scop)) 8264 and then Ekind (Full_View (Dyn_Scop)) in E_Task_Type | E_Protected_Type 8265 then 8266 return Get_Task_Body_Procedure (Full_View (Dyn_Scop)); 8267 8268 -- No body is generated if the protected operation is eliminated 8269 8270 elsif not Is_Eliminated (Dyn_Scop) 8271 and then Present (Protected_Body_Subprogram (Dyn_Scop)) 8272 then 8273 return Protected_Body_Subprogram (Dyn_Scop); 8274 8275 else 8276 return Dyn_Scop; 8277 end if; 8278 end Enclosing_Subprogram; 8279 8280 -------------------------- 8281 -- End_Keyword_Location -- 8282 -------------------------- 8283 8284 function End_Keyword_Location (N : Node_Id) return Source_Ptr is 8285 function End_Label_Loc (Nod : Node_Id) return Source_Ptr; 8286 -- Return the source location of Nod's end label according to the 8287 -- following precedence rules: 8288 -- 8289 -- 1) If the end label exists, return its location 8290 -- 2) If Nod exists, return its location 8291 -- 3) Return the location of N 8292 8293 ------------------- 8294 -- End_Label_Loc -- 8295 ------------------- 8296 8297 function End_Label_Loc (Nod : Node_Id) return Source_Ptr is 8298 Label : Node_Id; 8299 8300 begin 8301 if Present (Nod) then 8302 Label := End_Label (Nod); 8303 8304 if Present (Label) then 8305 return Sloc (Label); 8306 else 8307 return Sloc (Nod); 8308 end if; 8309 8310 else 8311 return Sloc (N); 8312 end if; 8313 end End_Label_Loc; 8314 8315 -- Local variables 8316 8317 Owner : Node_Id; 8318 8319 -- Start of processing for End_Keyword_Location 8320 8321 begin 8322 if Nkind (N) in N_Block_Statement 8323 | N_Entry_Body 8324 | N_Package_Body 8325 | N_Subprogram_Body 8326 | N_Task_Body 8327 then 8328 Owner := Handled_Statement_Sequence (N); 8329 8330 elsif Nkind (N) = N_Package_Declaration then 8331 Owner := Specification (N); 8332 8333 elsif Nkind (N) = N_Protected_Body then 8334 Owner := N; 8335 8336 elsif Nkind (N) in N_Protected_Type_Declaration 8337 | N_Single_Protected_Declaration 8338 then 8339 Owner := Protected_Definition (N); 8340 8341 elsif Nkind (N) in N_Single_Task_Declaration | N_Task_Type_Declaration 8342 then 8343 Owner := Task_Definition (N); 8344 8345 -- This routine should not be called with other contexts 8346 8347 else 8348 pragma Assert (False); 8349 null; 8350 end if; 8351 8352 return End_Label_Loc (Owner); 8353 end End_Keyword_Location; 8354 8355 ------------------------ 8356 -- Ensure_Freeze_Node -- 8357 ------------------------ 8358 8359 procedure Ensure_Freeze_Node (E : Entity_Id) is 8360 FN : Node_Id; 8361 begin 8362 if No (Freeze_Node (E)) then 8363 FN := Make_Freeze_Entity (Sloc (E)); 8364 Set_Has_Delayed_Freeze (E); 8365 Set_Freeze_Node (E, FN); 8366 Set_Access_Types_To_Process (FN, No_Elist); 8367 Set_TSS_Elist (FN, No_Elist); 8368 Set_Entity (FN, E); 8369 end if; 8370 end Ensure_Freeze_Node; 8371 8372 ---------------- 8373 -- Enter_Name -- 8374 ---------------- 8375 8376 procedure Enter_Name (Def_Id : Entity_Id) is 8377 C : constant Entity_Id := Current_Entity (Def_Id); 8378 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); 8379 S : constant Entity_Id := Current_Scope; 8380 8381 begin 8382 Generate_Definition (Def_Id); 8383 8384 -- Add new name to current scope declarations. Check for duplicate 8385 -- declaration, which may or may not be a genuine error. 8386 8387 if Present (E) then 8388 8389 -- Case of previous entity entered because of a missing declaration 8390 -- or else a bad subtype indication. Best is to use the new entity, 8391 -- and make the previous one invisible. 8392 8393 if Etype (E) = Any_Type then 8394 Set_Is_Immediately_Visible (E, False); 8395 8396 -- Case of renaming declaration constructed for package instances. 8397 -- if there is an explicit declaration with the same identifier, 8398 -- the renaming is not immediately visible any longer, but remains 8399 -- visible through selected component notation. 8400 8401 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration 8402 and then not Comes_From_Source (E) 8403 then 8404 Set_Is_Immediately_Visible (E, False); 8405 8406 -- The new entity may be the package renaming, which has the same 8407 -- same name as a generic formal which has been seen already. 8408 8409 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration 8410 and then not Comes_From_Source (Def_Id) 8411 then 8412 Set_Is_Immediately_Visible (E, False); 8413 8414 -- For a fat pointer corresponding to a remote access to subprogram, 8415 -- we use the same identifier as the RAS type, so that the proper 8416 -- name appears in the stub. This type is only retrieved through 8417 -- the RAS type and never by visibility, and is not added to the 8418 -- visibility list (see below). 8419 8420 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration 8421 and then Ekind (Def_Id) = E_Record_Type 8422 and then Present (Corresponding_Remote_Type (Def_Id)) 8423 then 8424 null; 8425 8426 -- Case of an implicit operation or derived literal. The new entity 8427 -- hides the implicit one, which is removed from all visibility, 8428 -- i.e. the entity list of its scope, and homonym chain of its name. 8429 8430 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E)) 8431 or else Is_Internal (E) 8432 then 8433 declare 8434 Decl : constant Node_Id := Parent (E); 8435 Prev : Entity_Id; 8436 Prev_Vis : Entity_Id; 8437 8438 begin 8439 -- If E is an implicit declaration, it cannot be the first 8440 -- entity in the scope. 8441 8442 Prev := First_Entity (Current_Scope); 8443 while Present (Prev) and then Next_Entity (Prev) /= E loop 8444 Next_Entity (Prev); 8445 end loop; 8446 8447 if No (Prev) then 8448 8449 -- If E is not on the entity chain of the current scope, 8450 -- it is an implicit declaration in the generic formal 8451 -- part of a generic subprogram. When analyzing the body, 8452 -- the generic formals are visible but not on the entity 8453 -- chain of the subprogram. The new entity will become 8454 -- the visible one in the body. 8455 8456 pragma Assert 8457 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration); 8458 null; 8459 8460 else 8461 Link_Entities (Prev, Next_Entity (E)); 8462 8463 if No (Next_Entity (Prev)) then 8464 Set_Last_Entity (Current_Scope, Prev); 8465 end if; 8466 8467 if E = Current_Entity (E) then 8468 Prev_Vis := Empty; 8469 8470 else 8471 Prev_Vis := Current_Entity (E); 8472 while Homonym (Prev_Vis) /= E loop 8473 Prev_Vis := Homonym (Prev_Vis); 8474 end loop; 8475 end if; 8476 8477 if Present (Prev_Vis) then 8478 8479 -- Skip E in the visibility chain 8480 8481 Set_Homonym (Prev_Vis, Homonym (E)); 8482 8483 else 8484 Set_Name_Entity_Id (Chars (E), Homonym (E)); 8485 end if; 8486 8487 -- The inherited operation cannot be retrieved 8488 -- by name, even though it may remain accesssible 8489 -- in some cases involving subprogram bodies without 8490 -- specs appearing in with_clauses.. 8491 8492 Set_Is_Immediately_Visible (E, False); 8493 end if; 8494 end; 8495 8496 -- This section of code could use a comment ??? 8497 8498 elsif Present (Etype (E)) 8499 and then Is_Concurrent_Type (Etype (E)) 8500 and then E = Def_Id 8501 then 8502 return; 8503 8504 -- If the homograph is a protected component renaming, it should not 8505 -- be hiding the current entity. Such renamings are treated as weak 8506 -- declarations. 8507 8508 elsif Is_Prival (E) then 8509 Set_Is_Immediately_Visible (E, False); 8510 8511 -- In this case the current entity is a protected component renaming. 8512 -- Perform minimal decoration by setting the scope and return since 8513 -- the prival should not be hiding other visible entities. 8514 8515 elsif Is_Prival (Def_Id) then 8516 Set_Scope (Def_Id, Current_Scope); 8517 return; 8518 8519 -- Analogous to privals, the discriminal generated for an entry index 8520 -- parameter acts as a weak declaration. Perform minimal decoration 8521 -- to avoid bogus errors. 8522 8523 elsif Is_Discriminal (Def_Id) 8524 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter 8525 then 8526 Set_Scope (Def_Id, Current_Scope); 8527 return; 8528 8529 -- In the body or private part of an instance, a type extension may 8530 -- introduce a component with the same name as that of an actual. The 8531 -- legality rule is not enforced, but the semantics of the full type 8532 -- with two components of same name are not clear at this point??? 8533 8534 elsif In_Instance_Not_Visible then 8535 null; 8536 8537 -- When compiling a package body, some child units may have become 8538 -- visible. They cannot conflict with local entities that hide them. 8539 8540 elsif Is_Child_Unit (E) 8541 and then In_Open_Scopes (Scope (E)) 8542 and then not Is_Immediately_Visible (E) 8543 then 8544 null; 8545 8546 -- Conversely, with front-end inlining we may compile the parent body 8547 -- first, and a child unit subsequently. The context is now the 8548 -- parent spec, and body entities are not visible. 8549 8550 elsif Is_Child_Unit (Def_Id) 8551 and then Is_Package_Body_Entity (E) 8552 and then not In_Package_Body (Current_Scope) 8553 then 8554 null; 8555 8556 -- Case of genuine duplicate declaration 8557 8558 else 8559 Error_Msg_Sloc := Sloc (E); 8560 8561 -- If the previous declaration is an incomplete type declaration 8562 -- this may be an attempt to complete it with a private type. The 8563 -- following avoids confusing cascaded errors. 8564 8565 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration 8566 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration 8567 then 8568 Error_Msg_N 8569 ("incomplete type cannot be completed with a private " & 8570 "declaration", Parent (Def_Id)); 8571 Set_Is_Immediately_Visible (E, False); 8572 Set_Full_View (E, Def_Id); 8573 8574 -- An inherited component of a record conflicts with a new 8575 -- discriminant. The discriminant is inserted first in the scope, 8576 -- but the error should be posted on it, not on the component. 8577 8578 elsif Ekind (E) = E_Discriminant 8579 and then Present (Scope (Def_Id)) 8580 and then Scope (Def_Id) /= Current_Scope 8581 then 8582 Error_Msg_Sloc := Sloc (Def_Id); 8583 Error_Msg_N ("& conflicts with declaration#", E); 8584 return; 8585 8586 -- If the name of the unit appears in its own context clause, a 8587 -- dummy package with the name has already been created, and the 8588 -- error emitted. Try to continue quietly. 8589 8590 elsif Error_Posted (E) 8591 and then Sloc (E) = No_Location 8592 and then Nkind (Parent (E)) = N_Package_Specification 8593 and then Current_Scope = Standard_Standard 8594 then 8595 Set_Scope (Def_Id, Current_Scope); 8596 return; 8597 8598 else 8599 Error_Msg_N ("& conflicts with declaration#", Def_Id); 8600 8601 -- Avoid cascaded messages with duplicate components in 8602 -- derived types. 8603 8604 if Ekind (E) in E_Component | E_Discriminant then 8605 return; 8606 end if; 8607 end if; 8608 8609 if Nkind (Parent (Parent (Def_Id))) = 8610 N_Generic_Subprogram_Declaration 8611 and then Def_Id = 8612 Defining_Entity (Specification (Parent (Parent (Def_Id)))) 8613 then 8614 Error_Msg_N ("\generic units cannot be overloaded", Def_Id); 8615 end if; 8616 8617 -- If entity is in standard, then we are in trouble, because it 8618 -- means that we have a library package with a duplicated name. 8619 -- That's hard to recover from, so abort. 8620 8621 if S = Standard_Standard then 8622 raise Unrecoverable_Error; 8623 8624 -- Otherwise we continue with the declaration. Having two 8625 -- identical declarations should not cause us too much trouble. 8626 8627 else 8628 null; 8629 end if; 8630 end if; 8631 end if; 8632 8633 -- If we fall through, declaration is OK, at least OK enough to continue 8634 8635 -- If Def_Id is a discriminant or a record component we are in the midst 8636 -- of inheriting components in a derived record definition. Preserve 8637 -- their Ekind and Etype. 8638 8639 if Ekind (Def_Id) in E_Discriminant | E_Component then 8640 null; 8641 8642 -- If a type is already set, leave it alone (happens when a type 8643 -- declaration is reanalyzed following a call to the optimizer). 8644 8645 elsif Present (Etype (Def_Id)) then 8646 null; 8647 8648 -- Otherwise, the kind E_Void insures that premature uses of the entity 8649 -- will be detected. Any_Type insures that no cascaded errors will occur 8650 8651 else 8652 Mutate_Ekind (Def_Id, E_Void); 8653 Set_Etype (Def_Id, Any_Type); 8654 end if; 8655 8656 -- All entities except Itypes are immediately visible 8657 8658 if not Is_Itype (Def_Id) then 8659 Set_Is_Immediately_Visible (Def_Id); 8660 Set_Current_Entity (Def_Id); 8661 end if; 8662 8663 Set_Homonym (Def_Id, C); 8664 Append_Entity (Def_Id, S); 8665 Set_Public_Status (Def_Id); 8666 8667 -- Warn if new entity hides an old one 8668 8669 if Warn_On_Hiding and then Present (C) 8670 8671 -- Don't warn for record components since they always have a well 8672 -- defined scope which does not confuse other uses. Note that in 8673 -- some cases, Ekind has not been set yet. 8674 8675 and then Ekind (C) /= E_Component 8676 and then Ekind (C) /= E_Discriminant 8677 and then Nkind (Parent (C)) /= N_Component_Declaration 8678 and then Ekind (Def_Id) /= E_Component 8679 and then Ekind (Def_Id) /= E_Discriminant 8680 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration 8681 8682 -- Don't warn for one character variables. It is too common to use 8683 -- such variables as locals and will just cause too many false hits. 8684 8685 and then Length_Of_Name (Chars (C)) /= 1 8686 8687 -- Don't warn for non-source entities 8688 8689 and then Comes_From_Source (C) 8690 and then Comes_From_Source (Def_Id) 8691 8692 -- Don't warn within a generic instantiation 8693 8694 and then not In_Instance 8695 8696 -- Don't warn unless entity in question is in extended main source 8697 8698 and then In_Extended_Main_Source_Unit (Def_Id) 8699 8700 -- Finally, the hidden entity must be either immediately visible or 8701 -- use visible (i.e. from a used package). 8702 8703 and then 8704 (Is_Immediately_Visible (C) 8705 or else 8706 Is_Potentially_Use_Visible (C)) 8707 then 8708 Error_Msg_Sloc := Sloc (C); 8709 Error_Msg_N ("declaration hides &#?h?", Def_Id); 8710 end if; 8711 end Enter_Name; 8712 8713 --------------- 8714 -- Entity_Of -- 8715 --------------- 8716 8717 function Entity_Of (N : Node_Id) return Entity_Id is 8718 Id : Entity_Id; 8719 Ren : Node_Id; 8720 8721 begin 8722 -- Assume that the arbitrary node does not have an entity 8723 8724 Id := Empty; 8725 8726 if Is_Entity_Name (N) then 8727 Id := Entity (N); 8728 8729 -- Follow a possible chain of renamings to reach the earliest renamed 8730 -- source object. 8731 8732 while Present (Id) 8733 and then Is_Object (Id) 8734 and then Present (Renamed_Object (Id)) 8735 loop 8736 Ren := Renamed_Object (Id); 8737 8738 -- The reference renames an abstract state or a whole object 8739 8740 -- Obj : ...; 8741 -- Ren : ... renames Obj; 8742 8743 if Is_Entity_Name (Ren) then 8744 8745 -- Do not follow a renaming that goes through a generic formal, 8746 -- because these entities are hidden and must not be referenced 8747 -- from outside the generic. 8748 8749 if Is_Hidden (Entity (Ren)) then 8750 exit; 8751 8752 else 8753 Id := Entity (Ren); 8754 end if; 8755 8756 -- The reference renames a function result. Check the original 8757 -- node in case expansion relocates the function call. 8758 8759 -- Ren : ... renames Func_Call; 8760 8761 elsif Nkind (Original_Node (Ren)) = N_Function_Call then 8762 exit; 8763 8764 -- Otherwise the reference renames something which does not yield 8765 -- an abstract state or a whole object. Treat the reference as not 8766 -- having a proper entity for SPARK legality purposes. 8767 8768 else 8769 Id := Empty; 8770 exit; 8771 end if; 8772 end loop; 8773 end if; 8774 8775 return Id; 8776 end Entity_Of; 8777 8778 -------------------------- 8779 -- Examine_Array_Bounds -- 8780 -------------------------- 8781 8782 procedure Examine_Array_Bounds 8783 (Typ : Entity_Id; 8784 All_Static : out Boolean; 8785 Has_Empty : out Boolean) 8786 is 8787 function Is_OK_Static_Bound (Bound : Node_Id) return Boolean; 8788 -- Determine whether bound Bound is a suitable static bound 8789 8790 ------------------------ 8791 -- Is_OK_Static_Bound -- 8792 ------------------------ 8793 8794 function Is_OK_Static_Bound (Bound : Node_Id) return Boolean is 8795 begin 8796 return 8797 not Error_Posted (Bound) 8798 and then Is_OK_Static_Expression (Bound); 8799 end Is_OK_Static_Bound; 8800 8801 -- Local variables 8802 8803 Hi_Bound : Node_Id; 8804 Index : Node_Id; 8805 Lo_Bound : Node_Id; 8806 8807 -- Start of processing for Examine_Array_Bounds 8808 8809 begin 8810 -- An unconstrained array type does not have static bounds, and it is 8811 -- not known whether they are empty or not. 8812 8813 if not Is_Constrained (Typ) then 8814 All_Static := False; 8815 Has_Empty := False; 8816 8817 -- A string literal has static bounds, and is not empty as long as it 8818 -- contains at least one character. 8819 8820 elsif Ekind (Typ) = E_String_Literal_Subtype then 8821 All_Static := True; 8822 Has_Empty := String_Literal_Length (Typ) > 0; 8823 end if; 8824 8825 -- Assume that all bounds are static and not empty 8826 8827 All_Static := True; 8828 Has_Empty := False; 8829 8830 -- Examine each index 8831 8832 Index := First_Index (Typ); 8833 while Present (Index) loop 8834 if Is_Discrete_Type (Etype (Index)) then 8835 Get_Index_Bounds (Index, Lo_Bound, Hi_Bound); 8836 8837 if Is_OK_Static_Bound (Lo_Bound) 8838 and then 8839 Is_OK_Static_Bound (Hi_Bound) 8840 then 8841 -- The static bounds produce an empty range 8842 8843 if Is_Null_Range (Lo_Bound, Hi_Bound) then 8844 Has_Empty := True; 8845 end if; 8846 8847 -- Otherwise at least one of the bounds is not static 8848 8849 else 8850 All_Static := False; 8851 end if; 8852 8853 -- Otherwise the index is non-discrete, therefore not static 8854 8855 else 8856 All_Static := False; 8857 end if; 8858 8859 Next_Index (Index); 8860 end loop; 8861 end Examine_Array_Bounds; 8862 8863 ------------------- 8864 -- Exceptions_OK -- 8865 ------------------- 8866 8867 function Exceptions_OK return Boolean is 8868 begin 8869 return 8870 not (Restriction_Active (No_Exception_Handlers) or else 8871 Restriction_Active (No_Exception_Propagation) or else 8872 Restriction_Active (No_Exceptions)); 8873 end Exceptions_OK; 8874 8875 -------------------------- 8876 -- Explain_Limited_Type -- 8877 -------------------------- 8878 8879 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is 8880 C : Entity_Id; 8881 8882 begin 8883 -- For array, component type must be limited 8884 8885 if Is_Array_Type (T) then 8886 Error_Msg_Node_2 := T; 8887 Error_Msg_NE 8888 ("\component type& of type& is limited", N, Component_Type (T)); 8889 Explain_Limited_Type (Component_Type (T), N); 8890 8891 elsif Is_Record_Type (T) then 8892 8893 -- No need for extra messages if explicit limited record 8894 8895 if Is_Limited_Record (Base_Type (T)) then 8896 return; 8897 end if; 8898 8899 -- Otherwise find a limited component. Check only components that 8900 -- come from source, or inherited components that appear in the 8901 -- source of the ancestor. 8902 8903 C := First_Component (T); 8904 while Present (C) loop 8905 if Is_Limited_Type (Etype (C)) 8906 and then 8907 (Comes_From_Source (C) 8908 or else 8909 (Present (Original_Record_Component (C)) 8910 and then 8911 Comes_From_Source (Original_Record_Component (C)))) 8912 then 8913 Error_Msg_Node_2 := T; 8914 Error_Msg_NE ("\component& of type& has limited type", N, C); 8915 Explain_Limited_Type (Etype (C), N); 8916 return; 8917 end if; 8918 8919 Next_Component (C); 8920 end loop; 8921 8922 -- The type may be declared explicitly limited, even if no component 8923 -- of it is limited, in which case we fall out of the loop. 8924 return; 8925 end if; 8926 end Explain_Limited_Type; 8927 8928 --------------------------------------- 8929 -- Expression_Of_Expression_Function -- 8930 --------------------------------------- 8931 8932 function Expression_Of_Expression_Function 8933 (Subp : Entity_Id) return Node_Id 8934 is 8935 Expr_Func : Node_Id; 8936 8937 begin 8938 pragma Assert (Is_Expression_Function_Or_Completion (Subp)); 8939 8940 if Nkind (Original_Node (Subprogram_Spec (Subp))) = 8941 N_Expression_Function 8942 then 8943 Expr_Func := Original_Node (Subprogram_Spec (Subp)); 8944 8945 elsif Nkind (Original_Node (Subprogram_Body (Subp))) = 8946 N_Expression_Function 8947 then 8948 Expr_Func := Original_Node (Subprogram_Body (Subp)); 8949 8950 else 8951 pragma Assert (False); 8952 null; 8953 end if; 8954 8955 return Original_Node (Expression (Expr_Func)); 8956 end Expression_Of_Expression_Function; 8957 8958 ------------------------------- 8959 -- Extensions_Visible_Status -- 8960 ------------------------------- 8961 8962 function Extensions_Visible_Status 8963 (Id : Entity_Id) return Extensions_Visible_Mode 8964 is 8965 Arg : Node_Id; 8966 Decl : Node_Id; 8967 Expr : Node_Id; 8968 Prag : Node_Id; 8969 Subp : Entity_Id; 8970 8971 begin 8972 -- When a formal parameter is subject to Extensions_Visible, the pragma 8973 -- is stored in the contract of related subprogram. 8974 8975 if Is_Formal (Id) then 8976 Subp := Scope (Id); 8977 8978 elsif Is_Subprogram_Or_Generic_Subprogram (Id) then 8979 Subp := Id; 8980 8981 -- No other construct carries this pragma 8982 8983 else 8984 return Extensions_Visible_None; 8985 end if; 8986 8987 Prag := Get_Pragma (Subp, Pragma_Extensions_Visible); 8988 8989 -- In certain cases analysis may request the Extensions_Visible status 8990 -- of an expression function before the pragma has been analyzed yet. 8991 -- Inspect the declarative items after the expression function looking 8992 -- for the pragma (if any). 8993 8994 if No (Prag) and then Is_Expression_Function (Subp) then 8995 Decl := Next (Unit_Declaration_Node (Subp)); 8996 while Present (Decl) loop 8997 if Nkind (Decl) = N_Pragma 8998 and then Pragma_Name (Decl) = Name_Extensions_Visible 8999 then 9000 Prag := Decl; 9001 exit; 9002 9003 -- A source construct ends the region where Extensions_Visible may 9004 -- appear, stop the traversal. An expanded expression function is 9005 -- no longer a source construct, but it must still be recognized. 9006 9007 elsif Comes_From_Source (Decl) 9008 or else 9009 (Nkind (Decl) in N_Subprogram_Body | N_Subprogram_Declaration 9010 and then Is_Expression_Function (Defining_Entity (Decl))) 9011 then 9012 exit; 9013 end if; 9014 9015 Next (Decl); 9016 end loop; 9017 end if; 9018 9019 -- Extract the value from the Boolean expression (if any) 9020 9021 if Present (Prag) then 9022 Arg := First (Pragma_Argument_Associations (Prag)); 9023 9024 if Present (Arg) then 9025 Expr := Get_Pragma_Arg (Arg); 9026 9027 -- When the associated subprogram is an expression function, the 9028 -- argument of the pragma may not have been analyzed. 9029 9030 if not Analyzed (Expr) then 9031 Preanalyze_And_Resolve (Expr, Standard_Boolean); 9032 end if; 9033 9034 -- Guard against cascading errors when the argument of pragma 9035 -- Extensions_Visible is not a valid static Boolean expression. 9036 9037 if Error_Posted (Expr) then 9038 return Extensions_Visible_None; 9039 9040 elsif Is_True (Expr_Value (Expr)) then 9041 return Extensions_Visible_True; 9042 9043 else 9044 return Extensions_Visible_False; 9045 end if; 9046 9047 -- Otherwise the aspect or pragma defaults to True 9048 9049 else 9050 return Extensions_Visible_True; 9051 end if; 9052 9053 -- Otherwise aspect or pragma Extensions_Visible is not inherited or 9054 -- directly specified. In SPARK code, its value defaults to "False". 9055 9056 elsif SPARK_Mode = On then 9057 return Extensions_Visible_False; 9058 9059 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to 9060 -- "True". 9061 9062 else 9063 return Extensions_Visible_True; 9064 end if; 9065 end Extensions_Visible_Status; 9066 9067 ----------------- 9068 -- Find_Actual -- 9069 ----------------- 9070 9071 procedure Find_Actual 9072 (N : Node_Id; 9073 Formal : out Entity_Id; 9074 Call : out Node_Id) 9075 is 9076 Context : constant Node_Id := Parent (N); 9077 Actual : Node_Id; 9078 Call_Nam : Node_Id; 9079 9080 begin 9081 if Nkind (Context) in N_Indexed_Component | N_Selected_Component 9082 and then N = Prefix (Context) 9083 then 9084 Find_Actual (Context, Formal, Call); 9085 return; 9086 9087 elsif Nkind (Context) = N_Parameter_Association 9088 and then N = Explicit_Actual_Parameter (Context) 9089 then 9090 Call := Parent (Context); 9091 9092 elsif Nkind (Context) in N_Entry_Call_Statement 9093 | N_Function_Call 9094 | N_Procedure_Call_Statement 9095 then 9096 Call := Context; 9097 9098 else 9099 Formal := Empty; 9100 Call := Empty; 9101 return; 9102 end if; 9103 9104 -- If we have a call to a subprogram look for the parameter. Note that 9105 -- we exclude overloaded calls, since we don't know enough to be sure 9106 -- of giving the right answer in this case. 9107 9108 if Nkind (Call) in N_Entry_Call_Statement 9109 | N_Function_Call 9110 | N_Procedure_Call_Statement 9111 then 9112 Call_Nam := Name (Call); 9113 9114 -- A call to a protected or task entry appears as a selected 9115 -- component rather than an expanded name. 9116 9117 if Nkind (Call_Nam) = N_Selected_Component then 9118 Call_Nam := Selector_Name (Call_Nam); 9119 end if; 9120 9121 if Is_Entity_Name (Call_Nam) 9122 and then Present (Entity (Call_Nam)) 9123 and then Is_Overloadable (Entity (Call_Nam)) 9124 and then not Is_Overloaded (Call_Nam) 9125 then 9126 -- If node is name in call it is not an actual 9127 9128 if N = Call_Nam then 9129 Formal := Empty; 9130 Call := Empty; 9131 return; 9132 end if; 9133 9134 -- Fall here if we are definitely a parameter 9135 9136 Actual := First_Actual (Call); 9137 Formal := First_Formal (Entity (Call_Nam)); 9138 while Present (Formal) and then Present (Actual) loop 9139 if Actual = N then 9140 return; 9141 9142 -- An actual that is the prefix in a prefixed call may have 9143 -- been rewritten in the call, after the deferred reference 9144 -- was collected. Check if sloc and kinds and names match. 9145 9146 elsif Sloc (Actual) = Sloc (N) 9147 and then Nkind (Actual) = N_Identifier 9148 and then Nkind (Actual) = Nkind (N) 9149 and then Chars (Actual) = Chars (N) 9150 then 9151 return; 9152 9153 else 9154 Next_Actual (Actual); 9155 Next_Formal (Formal); 9156 end if; 9157 end loop; 9158 end if; 9159 end if; 9160 9161 -- Fall through here if we did not find matching actual 9162 9163 Formal := Empty; 9164 Call := Empty; 9165 end Find_Actual; 9166 9167 --------------------------- 9168 -- Find_Body_Discriminal -- 9169 --------------------------- 9170 9171 function Find_Body_Discriminal 9172 (Spec_Discriminant : Entity_Id) return Entity_Id 9173 is 9174 Tsk : Entity_Id; 9175 Disc : Entity_Id; 9176 9177 begin 9178 -- If expansion is suppressed, then the scope can be the concurrent type 9179 -- itself rather than a corresponding concurrent record type. 9180 9181 if Is_Concurrent_Type (Scope (Spec_Discriminant)) then 9182 Tsk := Scope (Spec_Discriminant); 9183 9184 else 9185 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant))); 9186 9187 Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant)); 9188 end if; 9189 9190 -- Find discriminant of original concurrent type, and use its current 9191 -- discriminal, which is the renaming within the task/protected body. 9192 9193 Disc := First_Discriminant (Tsk); 9194 while Present (Disc) loop 9195 if Chars (Disc) = Chars (Spec_Discriminant) then 9196 return Discriminal (Disc); 9197 end if; 9198 9199 Next_Discriminant (Disc); 9200 end loop; 9201 9202 -- That loop should always succeed in finding a matching entry and 9203 -- returning. Fatal error if not. 9204 9205 raise Program_Error; 9206 end Find_Body_Discriminal; 9207 9208 ------------------------------------- 9209 -- Find_Corresponding_Discriminant -- 9210 ------------------------------------- 9211 9212 function Find_Corresponding_Discriminant 9213 (Id : Node_Id; 9214 Typ : Entity_Id) return Entity_Id 9215 is 9216 Par_Disc : Entity_Id; 9217 Old_Disc : Entity_Id; 9218 New_Disc : Entity_Id; 9219 9220 begin 9221 Par_Disc := Original_Record_Component (Original_Discriminant (Id)); 9222 9223 -- The original type may currently be private, and the discriminant 9224 -- only appear on its full view. 9225 9226 if Is_Private_Type (Scope (Par_Disc)) 9227 and then not Has_Discriminants (Scope (Par_Disc)) 9228 and then Present (Full_View (Scope (Par_Disc))) 9229 then 9230 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc))); 9231 else 9232 Old_Disc := First_Discriminant (Scope (Par_Disc)); 9233 end if; 9234 9235 if Is_Class_Wide_Type (Typ) then 9236 New_Disc := First_Discriminant (Root_Type (Typ)); 9237 else 9238 New_Disc := First_Discriminant (Typ); 9239 end if; 9240 9241 while Present (Old_Disc) and then Present (New_Disc) loop 9242 if Old_Disc = Par_Disc then 9243 return New_Disc; 9244 end if; 9245 9246 Next_Discriminant (Old_Disc); 9247 Next_Discriminant (New_Disc); 9248 end loop; 9249 9250 -- Should always find it 9251 9252 raise Program_Error; 9253 end Find_Corresponding_Discriminant; 9254 9255 ------------------- 9256 -- Find_DIC_Type -- 9257 ------------------- 9258 9259 function Find_DIC_Type (Typ : Entity_Id) return Entity_Id is 9260 Curr_Typ : Entity_Id; 9261 -- The current type being examined in the parent hierarchy traversal 9262 9263 DIC_Typ : Entity_Id; 9264 -- The type which carries the DIC pragma. This variable denotes the 9265 -- partial view when private types are involved. 9266 9267 Par_Typ : Entity_Id; 9268 -- The parent type of the current type. This variable denotes the full 9269 -- view when private types are involved. 9270 9271 begin 9272 -- The input type defines its own DIC pragma, therefore it is the owner 9273 9274 if Has_Own_DIC (Typ) then 9275 DIC_Typ := Typ; 9276 9277 -- Otherwise the DIC pragma is inherited from a parent type 9278 9279 else 9280 pragma Assert (Has_Inherited_DIC (Typ)); 9281 9282 -- Climb the parent chain 9283 9284 Curr_Typ := Typ; 9285 loop 9286 -- Inspect the parent type. Do not consider subtypes as they 9287 -- inherit the DIC attributes from their base types. 9288 9289 DIC_Typ := Base_Type (Etype (Curr_Typ)); 9290 9291 -- Look at the full view of a private type because the type may 9292 -- have a hidden parent introduced in the full view. 9293 9294 Par_Typ := DIC_Typ; 9295 9296 if Is_Private_Type (Par_Typ) 9297 and then Present (Full_View (Par_Typ)) 9298 then 9299 Par_Typ := Full_View (Par_Typ); 9300 end if; 9301 9302 -- Stop the climb once the nearest parent type which defines a DIC 9303 -- pragma of its own is encountered or when the root of the parent 9304 -- chain is reached. 9305 9306 exit when Has_Own_DIC (DIC_Typ) or else Curr_Typ = Par_Typ; 9307 9308 Curr_Typ := Par_Typ; 9309 end loop; 9310 end if; 9311 9312 return DIC_Typ; 9313 end Find_DIC_Type; 9314 9315 ---------------------------------- 9316 -- Find_Enclosing_Iterator_Loop -- 9317 ---------------------------------- 9318 9319 function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id is 9320 Constr : Node_Id; 9321 S : Entity_Id; 9322 9323 begin 9324 -- Traverse the scope chain looking for an iterator loop. Such loops are 9325 -- usually transformed into blocks, hence the use of Original_Node. 9326 9327 S := Id; 9328 while Present (S) and then S /= Standard_Standard loop 9329 if Ekind (S) = E_Loop 9330 and then Nkind (Parent (S)) = N_Implicit_Label_Declaration 9331 then 9332 Constr := Original_Node (Label_Construct (Parent (S))); 9333 9334 if Nkind (Constr) = N_Loop_Statement 9335 and then Present (Iteration_Scheme (Constr)) 9336 and then Nkind (Iterator_Specification 9337 (Iteration_Scheme (Constr))) = 9338 N_Iterator_Specification 9339 then 9340 return S; 9341 end if; 9342 end if; 9343 9344 S := Scope (S); 9345 end loop; 9346 9347 return Empty; 9348 end Find_Enclosing_Iterator_Loop; 9349 9350 -------------------------- 9351 -- Find_Enclosing_Scope -- 9352 -------------------------- 9353 9354 function Find_Enclosing_Scope (N : Node_Id) return Entity_Id is 9355 Par : Node_Id; 9356 9357 begin 9358 -- Examine the parent chain looking for a construct which defines a 9359 -- scope. 9360 9361 Par := Parent (N); 9362 while Present (Par) loop 9363 case Nkind (Par) is 9364 9365 -- The construct denotes a declaration, the proper scope is its 9366 -- entity. 9367 9368 when N_Entry_Declaration 9369 | N_Expression_Function 9370 | N_Full_Type_Declaration 9371 | N_Generic_Package_Declaration 9372 | N_Generic_Subprogram_Declaration 9373 | N_Package_Declaration 9374 | N_Private_Extension_Declaration 9375 | N_Protected_Type_Declaration 9376 | N_Single_Protected_Declaration 9377 | N_Single_Task_Declaration 9378 | N_Subprogram_Declaration 9379 | N_Task_Type_Declaration 9380 => 9381 return Defining_Entity (Par); 9382 9383 -- The construct denotes a body, the proper scope is the entity of 9384 -- the corresponding spec or that of the body if the body does not 9385 -- complete a previous declaration. 9386 9387 when N_Entry_Body 9388 | N_Package_Body 9389 | N_Protected_Body 9390 | N_Subprogram_Body 9391 | N_Task_Body 9392 => 9393 return Unique_Defining_Entity (Par); 9394 9395 -- Special cases 9396 9397 -- Blocks carry either a source or an internally-generated scope, 9398 -- unless the block is a byproduct of exception handling. 9399 9400 when N_Block_Statement => 9401 if not Exception_Junk (Par) then 9402 return Entity (Identifier (Par)); 9403 end if; 9404 9405 -- Loops carry an internally-generated scope 9406 9407 when N_Loop_Statement => 9408 return Entity (Identifier (Par)); 9409 9410 -- Extended return statements carry an internally-generated scope 9411 9412 when N_Extended_Return_Statement => 9413 return Return_Statement_Entity (Par); 9414 9415 -- A traversal from a subunit continues via the corresponding stub 9416 9417 when N_Subunit => 9418 Par := Corresponding_Stub (Par); 9419 9420 when others => 9421 null; 9422 end case; 9423 9424 Par := Parent (Par); 9425 end loop; 9426 9427 return Standard_Standard; 9428 end Find_Enclosing_Scope; 9429 9430 ------------------------------------ 9431 -- Find_Loop_In_Conditional_Block -- 9432 ------------------------------------ 9433 9434 function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is 9435 Stmt : Node_Id; 9436 9437 begin 9438 Stmt := N; 9439 9440 if Nkind (Stmt) = N_If_Statement then 9441 Stmt := First (Then_Statements (Stmt)); 9442 end if; 9443 9444 pragma Assert (Nkind (Stmt) = N_Block_Statement); 9445 9446 -- Inspect the statements of the conditional block. In general the loop 9447 -- should be the first statement in the statement sequence of the block, 9448 -- but the finalization machinery may have introduced extra object 9449 -- declarations. 9450 9451 Stmt := First (Statements (Handled_Statement_Sequence (Stmt))); 9452 while Present (Stmt) loop 9453 if Nkind (Stmt) = N_Loop_Statement then 9454 return Stmt; 9455 end if; 9456 9457 Next (Stmt); 9458 end loop; 9459 9460 -- The expansion of attribute 'Loop_Entry produced a malformed block 9461 9462 raise Program_Error; 9463 end Find_Loop_In_Conditional_Block; 9464 9465 -------------------------- 9466 -- Find_Overlaid_Entity -- 9467 -------------------------- 9468 9469 procedure Find_Overlaid_Entity 9470 (N : Node_Id; 9471 Ent : out Entity_Id; 9472 Off : out Boolean) 9473 is 9474 pragma Assert 9475 (Nkind (N) = N_Attribute_Definition_Clause 9476 and then Chars (N) = Name_Address); 9477 9478 Expr : Node_Id; 9479 9480 begin 9481 -- We are looking for one of the two following forms: 9482 9483 -- for X'Address use Y'Address 9484 9485 -- or 9486 9487 -- Const : constant Address := expr; 9488 -- ... 9489 -- for X'Address use Const; 9490 9491 -- In the second case, the expr is either Y'Address, or recursively a 9492 -- constant that eventually references Y'Address. 9493 9494 Ent := Empty; 9495 Off := False; 9496 9497 Expr := Expression (N); 9498 9499 -- This loop checks the form of the expression for Y'Address, using 9500 -- recursion to deal with intermediate constants. 9501 9502 loop 9503 -- Check for Y'Address 9504 9505 if Nkind (Expr) = N_Attribute_Reference 9506 and then Attribute_Name (Expr) = Name_Address 9507 then 9508 Expr := Prefix (Expr); 9509 exit; 9510 9511 -- Check for Const where Const is a constant entity 9512 9513 elsif Is_Entity_Name (Expr) 9514 and then Ekind (Entity (Expr)) = E_Constant 9515 then 9516 Expr := Constant_Value (Entity (Expr)); 9517 9518 -- Anything else does not need checking 9519 9520 else 9521 return; 9522 end if; 9523 end loop; 9524 9525 -- This loop checks the form of the prefix for an entity, using 9526 -- recursion to deal with intermediate components. 9527 9528 loop 9529 -- Check for Y where Y is an entity 9530 9531 if Is_Entity_Name (Expr) then 9532 Ent := Entity (Expr); 9533 9534 -- If expansion is disabled, then we might see an entity of a 9535 -- protected component or of a discriminant of a concurrent unit. 9536 -- Ignore such entities, because further warnings for overlays 9537 -- expect this routine to only collect entities of entire objects. 9538 9539 if Ekind (Ent) in E_Component | E_Discriminant then 9540 pragma Assert 9541 (not Expander_Active 9542 and then Is_Concurrent_Type (Scope (Ent))); 9543 Ent := Empty; 9544 end if; 9545 return; 9546 9547 -- Check for components 9548 9549 elsif Nkind (Expr) in N_Selected_Component | N_Indexed_Component then 9550 Expr := Prefix (Expr); 9551 Off := True; 9552 9553 -- Anything else does not need checking 9554 9555 else 9556 return; 9557 end if; 9558 end loop; 9559 end Find_Overlaid_Entity; 9560 9561 ------------------------- 9562 -- Find_Parameter_Type -- 9563 ------------------------- 9564 9565 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is 9566 begin 9567 if Nkind (Param) /= N_Parameter_Specification then 9568 return Empty; 9569 9570 -- For an access parameter, obtain the type from the formal entity 9571 -- itself, because access to subprogram nodes do not carry a type. 9572 -- Shouldn't we always use the formal entity ??? 9573 9574 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then 9575 return Etype (Defining_Identifier (Param)); 9576 9577 else 9578 return Etype (Parameter_Type (Param)); 9579 end if; 9580 end Find_Parameter_Type; 9581 9582 ----------------------------------- 9583 -- Find_Placement_In_State_Space -- 9584 ----------------------------------- 9585 9586 procedure Find_Placement_In_State_Space 9587 (Item_Id : Entity_Id; 9588 Placement : out State_Space_Kind; 9589 Pack_Id : out Entity_Id) 9590 is 9591 function Inside_Package_Body (Id : Entity_Id) return Boolean; 9592 function Inside_Private_Part (Id : Entity_Id) return Boolean; 9593 -- Return True if Id is declared directly within the package body 9594 -- and the package private parts, respectively. We cannot use 9595 -- In_Private_Part/In_Body_Part flags, as these are only set during the 9596 -- analysis of the package itself, while Find_Placement_In_State_Space 9597 -- can be called on an entity of another package. 9598 9599 ------------------------ 9600 -- Inside_Package_Body -- 9601 ------------------------ 9602 9603 function Inside_Package_Body (Id : Entity_Id) return Boolean is 9604 Spec_Id : constant Entity_Id := Scope (Id); 9605 Body_Decl : constant Opt_N_Package_Body_Id := Package_Body (Spec_Id); 9606 Decl : constant Node_Id := Enclosing_Declaration (Id); 9607 begin 9608 if Present (Body_Decl) 9609 and then Is_List_Member (Decl) 9610 and then List_Containing (Decl) = Declarations (Body_Decl) 9611 then 9612 return True; 9613 else 9614 return False; 9615 end if; 9616 end Inside_Package_Body; 9617 9618 ------------------------- 9619 -- Inside_Private_Part -- 9620 ------------------------- 9621 9622 function Inside_Private_Part (Id : Entity_Id) return Boolean is 9623 Spec_Id : constant Entity_Id := Scope (Id); 9624 Private_Decls : constant List_Id := 9625 Private_Declarations (Package_Specification (Spec_Id)); 9626 Decl : constant Node_Id := Enclosing_Declaration (Id); 9627 begin 9628 if Is_List_Member (Decl) 9629 and then List_Containing (Decl) = Private_Decls 9630 then 9631 return True; 9632 9633 elsif Ekind (Id) = E_Package 9634 and then Is_Private_Library_Unit (Id) 9635 then 9636 return True; 9637 9638 else 9639 return False; 9640 end if; 9641 end Inside_Private_Part; 9642 9643 -- Local variables 9644 9645 Context : Entity_Id; 9646 9647 -- Start of processing for Find_Placement_In_State_Space 9648 9649 begin 9650 -- Assume that the item does not appear in the state space of a package 9651 9652 Placement := Not_In_Package; 9653 9654 -- Climb the scope stack and examine the enclosing context 9655 9656 Context := Item_Id; 9657 Pack_Id := Scope (Context); 9658 while Present (Pack_Id) and then Pack_Id /= Standard_Standard loop 9659 if Is_Package_Or_Generic_Package (Pack_Id) then 9660 9661 -- A package body is a cut off point for the traversal as the 9662 -- item cannot be visible to the outside from this point on. 9663 9664 if Inside_Package_Body (Context) then 9665 Placement := Body_State_Space; 9666 return; 9667 9668 -- The private part of a package is a cut off point for the 9669 -- traversal as the item cannot be visible to the outside 9670 -- from this point on. 9671 9672 elsif Inside_Private_Part (Context) then 9673 Placement := Private_State_Space; 9674 return; 9675 9676 -- When the item appears in the visible state space of a package, 9677 -- continue to climb the scope stack as this may not be the final 9678 -- state space. 9679 9680 else 9681 Placement := Visible_State_Space; 9682 9683 -- The visible state space of a child unit acts as the proper 9684 -- placement of an item, unless this is a private child unit. 9685 9686 if Is_Child_Unit (Pack_Id) 9687 and then not Is_Private_Library_Unit (Pack_Id) 9688 then 9689 return; 9690 end if; 9691 end if; 9692 9693 -- The item or its enclosing package appear in a construct that has 9694 -- no state space. 9695 9696 else 9697 Placement := Not_In_Package; 9698 Pack_Id := Empty; 9699 return; 9700 end if; 9701 9702 Context := Scope (Context); 9703 Pack_Id := Scope (Context); 9704 end loop; 9705 end Find_Placement_In_State_Space; 9706 9707 ----------------------- 9708 -- Find_Primitive_Eq -- 9709 ----------------------- 9710 9711 function Find_Primitive_Eq (Typ : Entity_Id) return Entity_Id is 9712 function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id; 9713 -- Search for the equality primitive; return Empty if the primitive is 9714 -- not found. 9715 9716 ------------------ 9717 -- Find_Eq_Prim -- 9718 ------------------ 9719 9720 function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id is 9721 Prim : Entity_Id; 9722 Prim_Elmt : Elmt_Id; 9723 9724 begin 9725 Prim_Elmt := First_Elmt (Prims_List); 9726 while Present (Prim_Elmt) loop 9727 Prim := Node (Prim_Elmt); 9728 9729 -- Locate primitive equality with the right signature 9730 9731 if Chars (Prim) = Name_Op_Eq 9732 and then Etype (First_Formal (Prim)) = 9733 Etype (Next_Formal (First_Formal (Prim))) 9734 and then Base_Type (Etype (Prim)) = Standard_Boolean 9735 then 9736 return Prim; 9737 end if; 9738 9739 Next_Elmt (Prim_Elmt); 9740 end loop; 9741 9742 return Empty; 9743 end Find_Eq_Prim; 9744 9745 -- Local Variables 9746 9747 Eq_Prim : Entity_Id; 9748 Full_Type : Entity_Id; 9749 9750 -- Start of processing for Find_Primitive_Eq 9751 9752 begin 9753 if Is_Private_Type (Typ) then 9754 Full_Type := Underlying_Type (Typ); 9755 else 9756 Full_Type := Typ; 9757 end if; 9758 9759 if No (Full_Type) then 9760 return Empty; 9761 end if; 9762 9763 Full_Type := Base_Type (Full_Type); 9764 9765 -- When the base type itself is private, use the full view 9766 9767 if Is_Private_Type (Full_Type) then 9768 Full_Type := Underlying_Type (Full_Type); 9769 end if; 9770 9771 if Is_Class_Wide_Type (Full_Type) then 9772 Full_Type := Root_Type (Full_Type); 9773 end if; 9774 9775 if not Is_Tagged_Type (Full_Type) then 9776 Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ)); 9777 9778 -- If this is an untagged private type completed with a derivation of 9779 -- an untagged private type whose full view is a tagged type, we use 9780 -- the primitive operations of the private parent type (since it does 9781 -- not have a full view, and also because its equality primitive may 9782 -- have been overridden in its untagged full view). If no equality was 9783 -- defined for it then take its dispatching equality primitive. 9784 9785 elsif Inherits_From_Tagged_Full_View (Typ) then 9786 Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ)); 9787 9788 if No (Eq_Prim) then 9789 Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type)); 9790 end if; 9791 9792 else 9793 Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type)); 9794 end if; 9795 9796 return Eq_Prim; 9797 end Find_Primitive_Eq; 9798 9799 ------------------------ 9800 -- Find_Specific_Type -- 9801 ------------------------ 9802 9803 function Find_Specific_Type (CW : Entity_Id) return Entity_Id is 9804 Typ : Entity_Id := Root_Type (CW); 9805 9806 begin 9807 if Ekind (Typ) = E_Incomplete_Type then 9808 if From_Limited_With (Typ) then 9809 Typ := Non_Limited_View (Typ); 9810 else 9811 Typ := Full_View (Typ); 9812 end if; 9813 end if; 9814 9815 if Is_Private_Type (Typ) 9816 and then not Is_Tagged_Type (Typ) 9817 and then Present (Full_View (Typ)) 9818 then 9819 return Full_View (Typ); 9820 else 9821 return Typ; 9822 end if; 9823 end Find_Specific_Type; 9824 9825 ----------------------------- 9826 -- Find_Static_Alternative -- 9827 ----------------------------- 9828 9829 function Find_Static_Alternative (N : Node_Id) return Node_Id is 9830 Expr : constant Node_Id := Expression (N); 9831 Val : constant Uint := Expr_Value (Expr); 9832 Alt : Node_Id; 9833 Choice : Node_Id; 9834 9835 begin 9836 Alt := First (Alternatives (N)); 9837 9838 Search : loop 9839 if Nkind (Alt) /= N_Pragma then 9840 Choice := First (Discrete_Choices (Alt)); 9841 while Present (Choice) loop 9842 9843 -- Others choice, always matches 9844 9845 if Nkind (Choice) = N_Others_Choice then 9846 exit Search; 9847 9848 -- Range, check if value is in the range 9849 9850 elsif Nkind (Choice) = N_Range then 9851 exit Search when 9852 Val >= Expr_Value (Low_Bound (Choice)) 9853 and then 9854 Val <= Expr_Value (High_Bound (Choice)); 9855 9856 -- Choice is a subtype name. Note that we know it must 9857 -- be a static subtype, since otherwise it would have 9858 -- been diagnosed as illegal. 9859 9860 elsif Is_Entity_Name (Choice) 9861 and then Is_Type (Entity (Choice)) 9862 then 9863 exit Search when Is_In_Range (Expr, Etype (Choice), 9864 Assume_Valid => False); 9865 9866 -- Choice is a subtype indication 9867 9868 elsif Nkind (Choice) = N_Subtype_Indication then 9869 declare 9870 C : constant Node_Id := Constraint (Choice); 9871 R : constant Node_Id := Range_Expression (C); 9872 9873 begin 9874 exit Search when 9875 Val >= Expr_Value (Low_Bound (R)) 9876 and then 9877 Val <= Expr_Value (High_Bound (R)); 9878 end; 9879 9880 -- Choice is a simple expression 9881 9882 else 9883 exit Search when Val = Expr_Value (Choice); 9884 end if; 9885 9886 Next (Choice); 9887 end loop; 9888 end if; 9889 9890 Next (Alt); 9891 pragma Assert (Present (Alt)); 9892 end loop Search; 9893 9894 -- The above loop *must* terminate by finding a match, since we know the 9895 -- case statement is valid, and the value of the expression is known at 9896 -- compile time. When we fall out of the loop, Alt points to the 9897 -- alternative that we know will be selected at run time. 9898 9899 return Alt; 9900 end Find_Static_Alternative; 9901 9902 ------------------ 9903 -- First_Actual -- 9904 ------------------ 9905 9906 function First_Actual (Node : Node_Id) return Node_Id is 9907 N : Node_Id; 9908 9909 begin 9910 if No (Parameter_Associations (Node)) then 9911 return Empty; 9912 end if; 9913 9914 N := First (Parameter_Associations (Node)); 9915 9916 if Nkind (N) = N_Parameter_Association then 9917 return First_Named_Actual (Node); 9918 else 9919 return N; 9920 end if; 9921 end First_Actual; 9922 9923 ------------------ 9924 -- First_Global -- 9925 ------------------ 9926 9927 function First_Global 9928 (Subp : Entity_Id; 9929 Global_Mode : Name_Id; 9930 Refined : Boolean := False) return Node_Id 9931 is 9932 function First_From_Global_List 9933 (List : Node_Id; 9934 Global_Mode : Name_Id := Name_Input) return Entity_Id; 9935 -- Get the first item with suitable mode from List 9936 9937 ---------------------------- 9938 -- First_From_Global_List -- 9939 ---------------------------- 9940 9941 function First_From_Global_List 9942 (List : Node_Id; 9943 Global_Mode : Name_Id := Name_Input) return Entity_Id 9944 is 9945 Assoc : Node_Id; 9946 9947 begin 9948 -- Empty list (no global items) 9949 9950 if Nkind (List) = N_Null then 9951 return Empty; 9952 9953 -- Single global item declaration (only input items) 9954 9955 elsif Nkind (List) in N_Expanded_Name | N_Identifier then 9956 if Global_Mode = Name_Input then 9957 return List; 9958 else 9959 return Empty; 9960 end if; 9961 9962 -- Simple global list (only input items) or moded global list 9963 -- declaration. 9964 9965 elsif Nkind (List) = N_Aggregate then 9966 if Present (Expressions (List)) then 9967 if Global_Mode = Name_Input then 9968 return First (Expressions (List)); 9969 else 9970 return Empty; 9971 end if; 9972 9973 else 9974 Assoc := First (Component_Associations (List)); 9975 while Present (Assoc) loop 9976 9977 -- When we find the desired mode in an association, call 9978 -- recursively First_From_Global_List as if the mode was 9979 -- Name_Input, in order to reuse the existing machinery 9980 -- for the other cases. 9981 9982 if Chars (First (Choices (Assoc))) = Global_Mode then 9983 return First_From_Global_List (Expression (Assoc)); 9984 end if; 9985 9986 Next (Assoc); 9987 end loop; 9988 9989 return Empty; 9990 end if; 9991 9992 -- To accommodate partial decoration of disabled SPARK features, 9993 -- this routine may be called with illegal input. If this is the 9994 -- case, do not raise Program_Error. 9995 9996 else 9997 return Empty; 9998 end if; 9999 end First_From_Global_List; 10000 10001 -- Local variables 10002 10003 Global : Node_Id := Empty; 10004 Body_Id : Entity_Id; 10005 10006 -- Start of processing for First_Global 10007 10008 begin 10009 pragma Assert (Global_Mode in Name_In_Out 10010 | Name_Input 10011 | Name_Output 10012 | Name_Proof_In); 10013 10014 -- Retrieve the suitable pragma Global or Refined_Global. In the second 10015 -- case, it can only be located on the body entity. 10016 10017 if Refined then 10018 if Is_Subprogram_Or_Generic_Subprogram (Subp) then 10019 Body_Id := Subprogram_Body_Entity (Subp); 10020 10021 elsif Is_Entry (Subp) or else Is_Task_Type (Subp) then 10022 Body_Id := Corresponding_Body (Parent (Subp)); 10023 10024 -- ??? It should be possible to retrieve the Refined_Global on the 10025 -- task body associated to the task object. This is not yet possible. 10026 10027 elsif Is_Single_Task_Object (Subp) then 10028 Body_Id := Empty; 10029 10030 else 10031 Body_Id := Empty; 10032 end if; 10033 10034 if Present (Body_Id) then 10035 Global := Get_Pragma (Body_Id, Pragma_Refined_Global); 10036 end if; 10037 else 10038 Global := Get_Pragma (Subp, Pragma_Global); 10039 end if; 10040 10041 -- No corresponding global if pragma is not present 10042 10043 if No (Global) then 10044 return Empty; 10045 10046 -- Otherwise retrieve the corresponding list of items depending on the 10047 -- Global_Mode. 10048 10049 else 10050 return First_From_Global_List 10051 (Expression (Get_Argument (Global, Subp)), Global_Mode); 10052 end if; 10053 end First_Global; 10054 10055 ------------- 10056 -- Fix_Msg -- 10057 ------------- 10058 10059 function Fix_Msg (Id : Entity_Id; Msg : String) return String is 10060 Is_Task : constant Boolean := 10061 Ekind (Id) in E_Task_Body | E_Task_Type 10062 or else Is_Single_Task_Object (Id); 10063 Msg_Last : constant Natural := Msg'Last; 10064 Msg_Index : Natural; 10065 Res : String (Msg'Range) := (others => ' '); 10066 Res_Index : Natural; 10067 10068 begin 10069 -- Copy all characters from the input message Msg to result Res with 10070 -- suitable replacements. 10071 10072 Msg_Index := Msg'First; 10073 Res_Index := Res'First; 10074 while Msg_Index <= Msg_Last loop 10075 10076 -- Replace "subprogram" with a different word 10077 10078 if Msg_Index <= Msg_Last - 10 10079 and then Msg (Msg_Index .. Msg_Index + 9) = "subprogram" 10080 then 10081 if Is_Entry (Id) then 10082 Res (Res_Index .. Res_Index + 4) := "entry"; 10083 Res_Index := Res_Index + 5; 10084 10085 elsif Is_Task then 10086 Res (Res_Index .. Res_Index + 8) := "task type"; 10087 Res_Index := Res_Index + 9; 10088 10089 else 10090 Res (Res_Index .. Res_Index + 9) := "subprogram"; 10091 Res_Index := Res_Index + 10; 10092 end if; 10093 10094 Msg_Index := Msg_Index + 10; 10095 10096 -- Replace "protected" with a different word 10097 10098 elsif Msg_Index <= Msg_Last - 9 10099 and then Msg (Msg_Index .. Msg_Index + 8) = "protected" 10100 and then Is_Task 10101 then 10102 Res (Res_Index .. Res_Index + 3) := "task"; 10103 Res_Index := Res_Index + 4; 10104 Msg_Index := Msg_Index + 9; 10105 10106 -- Otherwise copy the character 10107 10108 else 10109 Res (Res_Index) := Msg (Msg_Index); 10110 Msg_Index := Msg_Index + 1; 10111 Res_Index := Res_Index + 1; 10112 end if; 10113 end loop; 10114 10115 return Res (Res'First .. Res_Index - 1); 10116 end Fix_Msg; 10117 10118 ------------------------- 10119 -- From_Nested_Package -- 10120 ------------------------- 10121 10122 function From_Nested_Package (T : Entity_Id) return Boolean is 10123 Pack : constant Entity_Id := Scope (T); 10124 10125 begin 10126 return 10127 Ekind (Pack) = E_Package 10128 and then not Is_Frozen (Pack) 10129 and then not Scope_Within_Or_Same (Current_Scope, Pack) 10130 and then In_Open_Scopes (Scope (Pack)); 10131 end From_Nested_Package; 10132 10133 ----------------------- 10134 -- Gather_Components -- 10135 ----------------------- 10136 10137 procedure Gather_Components 10138 (Typ : Entity_Id; 10139 Comp_List : Node_Id; 10140 Governed_By : List_Id; 10141 Into : Elist_Id; 10142 Report_Errors : out Boolean; 10143 Allow_Compile_Time : Boolean := False; 10144 Include_Interface_Tag : Boolean := False) 10145 is 10146 Assoc : Node_Id; 10147 Variant : Node_Id; 10148 Discrete_Choice : Node_Id; 10149 Comp_Item : Node_Id; 10150 Discrim : Entity_Id; 10151 Discrim_Name : Node_Id; 10152 10153 type Discriminant_Value_Status is 10154 (Static_Expr, Static_Subtype, Bad); 10155 subtype Good_Discrim_Value_Status is Discriminant_Value_Status 10156 range Static_Expr .. Static_Subtype; -- range excludes Bad 10157 10158 Discrim_Value : Node_Id; 10159 Discrim_Value_Subtype : Node_Id; 10160 Discrim_Value_Status : Discriminant_Value_Status := Bad; 10161 10162 function OK_Scope_For_Discrim_Value_Error_Messages return Boolean is 10163 (Scope (Original_Record_Component 10164 (Entity (First (Choices (Assoc))))) = Typ); 10165 -- Used to avoid generating error messages having a source position 10166 -- which refers to somewhere (e.g., a discriminant value in a derived 10167 -- tagged type declaration) unrelated to the offending construct. This 10168 -- is required for correctness - clients of Gather_Components such as 10169 -- Sem_Ch3.Create_Constrained_Components depend on this function 10170 -- returning True while processing semantically correct examples; 10171 -- generating an error message in this case would be wrong. 10172 10173 begin 10174 Report_Errors := False; 10175 10176 if No (Comp_List) or else Null_Present (Comp_List) then 10177 return; 10178 10179 elsif Present (Component_Items (Comp_List)) then 10180 Comp_Item := First (Component_Items (Comp_List)); 10181 10182 else 10183 Comp_Item := Empty; 10184 end if; 10185 10186 while Present (Comp_Item) loop 10187 10188 -- Skip the tag of a tagged record, as well as all items that are not 10189 -- user components (anonymous types, rep clauses, Parent field, 10190 -- controller field). 10191 10192 if Nkind (Comp_Item) = N_Component_Declaration then 10193 declare 10194 Comp : constant Entity_Id := Defining_Identifier (Comp_Item); 10195 begin 10196 if not (Is_Tag (Comp) 10197 and then not 10198 (Include_Interface_Tag 10199 and then Etype (Comp) = RTE (RE_Interface_Tag))) 10200 and then Chars (Comp) /= Name_uParent 10201 then 10202 Append_Elmt (Comp, Into); 10203 end if; 10204 end; 10205 end if; 10206 10207 Next (Comp_Item); 10208 end loop; 10209 10210 if No (Variant_Part (Comp_List)) then 10211 return; 10212 else 10213 Discrim_Name := Name (Variant_Part (Comp_List)); 10214 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); 10215 end if; 10216 10217 -- Look for the discriminant that governs this variant part. 10218 -- The discriminant *must* be in the Governed_By List 10219 10220 Assoc := First (Governed_By); 10221 Find_Constraint : loop 10222 Discrim := First (Choices (Assoc)); 10223 exit Find_Constraint when 10224 Chars (Discrim_Name) = Chars (Discrim) 10225 or else 10226 (Present (Corresponding_Discriminant (Entity (Discrim))) 10227 and then Chars (Corresponding_Discriminant 10228 (Entity (Discrim))) = Chars (Discrim_Name)) 10229 or else 10230 Chars (Original_Record_Component (Entity (Discrim))) = 10231 Chars (Discrim_Name); 10232 10233 if No (Next (Assoc)) then 10234 if not Is_Constrained (Typ) and then Is_Derived_Type (Typ) then 10235 10236 -- If the type is a tagged type with inherited discriminants, 10237 -- use the stored constraint on the parent in order to find 10238 -- the values of discriminants that are otherwise hidden by an 10239 -- explicit constraint. Renamed discriminants are handled in 10240 -- the code above. 10241 10242 -- If several parent discriminants are renamed by a single 10243 -- discriminant of the derived type, the call to obtain the 10244 -- Corresponding_Discriminant field only retrieves the last 10245 -- of them. We recover the constraint on the others from the 10246 -- Stored_Constraint as well. 10247 10248 -- An inherited discriminant may have been constrained in a 10249 -- later ancestor (not the immediate parent) so we must examine 10250 -- the stored constraint of all of them to locate the inherited 10251 -- value. 10252 10253 declare 10254 C : Elmt_Id; 10255 D : Entity_Id; 10256 T : Entity_Id := Typ; 10257 10258 begin 10259 while Is_Derived_Type (T) loop 10260 if Present (Stored_Constraint (T)) then 10261 D := First_Discriminant (Etype (T)); 10262 C := First_Elmt (Stored_Constraint (T)); 10263 while Present (D) and then Present (C) loop 10264 if Chars (Discrim_Name) = Chars (D) then 10265 if Is_Entity_Name (Node (C)) 10266 and then Entity (Node (C)) = Entity (Discrim) 10267 then 10268 -- D is renamed by Discrim, whose value is 10269 -- given in Assoc. 10270 10271 null; 10272 10273 else 10274 Assoc := 10275 Make_Component_Association (Sloc (Typ), 10276 New_List 10277 (New_Occurrence_Of (D, Sloc (Typ))), 10278 Duplicate_Subexpr_No_Checks (Node (C))); 10279 end if; 10280 10281 exit Find_Constraint; 10282 end if; 10283 10284 Next_Discriminant (D); 10285 Next_Elmt (C); 10286 end loop; 10287 end if; 10288 10289 -- Discriminant may be inherited from ancestor 10290 10291 T := Etype (T); 10292 end loop; 10293 end; 10294 end if; 10295 end if; 10296 10297 if No (Next (Assoc)) then 10298 Error_Msg_NE 10299 (" missing value for discriminant&", 10300 First (Governed_By), Discrim_Name); 10301 10302 Report_Errors := True; 10303 return; 10304 end if; 10305 10306 Next (Assoc); 10307 end loop Find_Constraint; 10308 10309 Discrim_Value := Expression (Assoc); 10310 10311 if Is_OK_Static_Expression (Discrim_Value) 10312 or else (Allow_Compile_Time 10313 and then Compile_Time_Known_Value (Discrim_Value)) 10314 then 10315 Discrim_Value_Status := Static_Expr; 10316 else 10317 if Ada_Version >= Ada_2022 then 10318 if Original_Node (Discrim_Value) /= Discrim_Value 10319 and then Nkind (Discrim_Value) = N_Type_Conversion 10320 and then Etype (Original_Node (Discrim_Value)) 10321 = Etype (Expression (Discrim_Value)) 10322 then 10323 Discrim_Value_Subtype := Etype (Original_Node (Discrim_Value)); 10324 -- An unhelpful (for this code) type conversion may be 10325 -- introduced in some cases; deal with it. 10326 else 10327 Discrim_Value_Subtype := Etype (Discrim_Value); 10328 end if; 10329 10330 if Is_OK_Static_Subtype (Discrim_Value_Subtype) and then 10331 not Is_Null_Range (Type_Low_Bound (Discrim_Value_Subtype), 10332 Type_High_Bound (Discrim_Value_Subtype)) 10333 then 10334 -- Is_Null_Range test doesn't account for predicates, as in 10335 -- subtype Null_By_Predicate is Natural 10336 -- with Static_Predicate => Null_By_Predicate < 0; 10337 -- so test for that null case separately. 10338 10339 if (not Has_Static_Predicate (Discrim_Value_Subtype)) 10340 or else Present (First (Static_Discrete_Predicate 10341 (Discrim_Value_Subtype))) 10342 then 10343 Discrim_Value_Status := Static_Subtype; 10344 end if; 10345 end if; 10346 end if; 10347 10348 if Discrim_Value_Status = Bad then 10349 10350 -- If the variant part is governed by a discriminant of the type 10351 -- this is an error. If the variant part and the discriminant are 10352 -- inherited from an ancestor this is legal (AI05-220) unless the 10353 -- components are being gathered for an aggregate, in which case 10354 -- the caller must check Report_Errors. 10355 -- 10356 -- In Ada 2022 the above rules are relaxed. A nonstatic governing 10357 -- discriminant is OK as long as it has a static subtype and 10358 -- every value of that subtype (and there must be at least one) 10359 -- selects the same variant. 10360 10361 if OK_Scope_For_Discrim_Value_Error_Messages then 10362 if Ada_Version >= Ada_2022 then 10363 Error_Msg_FE 10364 ("value for discriminant & must be static or " & 10365 "discriminant's nominal subtype must be static " & 10366 "and non-null!", 10367 Discrim_Value, Discrim); 10368 else 10369 Error_Msg_FE 10370 ("value for discriminant & must be static!", 10371 Discrim_Value, Discrim); 10372 end if; 10373 Why_Not_Static (Discrim_Value); 10374 end if; 10375 10376 Report_Errors := True; 10377 return; 10378 end if; 10379 end if; 10380 10381 Search_For_Discriminant_Value : declare 10382 Low : Node_Id; 10383 High : Node_Id; 10384 10385 UI_High : Uint; 10386 UI_Low : Uint; 10387 UI_Discrim_Value : Uint; 10388 10389 begin 10390 case Good_Discrim_Value_Status'(Discrim_Value_Status) is 10391 when Static_Expr => 10392 UI_Discrim_Value := Expr_Value (Discrim_Value); 10393 when Static_Subtype => 10394 -- Arbitrarily pick one value of the subtype and look 10395 -- for the variant associated with that value; we will 10396 -- check later that the same variant is associated with 10397 -- all of the other values of the subtype. 10398 if Has_Static_Predicate (Discrim_Value_Subtype) then 10399 declare 10400 Range_Or_Expr : constant Node_Id := 10401 First (Static_Discrete_Predicate 10402 (Discrim_Value_Subtype)); 10403 begin 10404 if Nkind (Range_Or_Expr) = N_Range then 10405 UI_Discrim_Value := 10406 Expr_Value (Low_Bound (Range_Or_Expr)); 10407 else 10408 UI_Discrim_Value := Expr_Value (Range_Or_Expr); 10409 end if; 10410 end; 10411 else 10412 UI_Discrim_Value 10413 := Expr_Value (Type_Low_Bound (Discrim_Value_Subtype)); 10414 end if; 10415 end case; 10416 10417 Find_Discrete_Value : while Present (Variant) loop 10418 10419 -- If a choice is a subtype with a static predicate, it must 10420 -- be rewritten as an explicit list of non-predicated choices. 10421 10422 Expand_Static_Predicates_In_Choices (Variant); 10423 10424 Discrete_Choice := First (Discrete_Choices (Variant)); 10425 while Present (Discrete_Choice) loop 10426 exit Find_Discrete_Value when 10427 Nkind (Discrete_Choice) = N_Others_Choice; 10428 10429 Get_Index_Bounds (Discrete_Choice, Low, High); 10430 10431 UI_Low := Expr_Value (Low); 10432 UI_High := Expr_Value (High); 10433 10434 exit Find_Discrete_Value when 10435 UI_Low <= UI_Discrim_Value 10436 and then 10437 UI_High >= UI_Discrim_Value; 10438 10439 Next (Discrete_Choice); 10440 end loop; 10441 10442 Next_Non_Pragma (Variant); 10443 end loop Find_Discrete_Value; 10444 end Search_For_Discriminant_Value; 10445 10446 -- The case statement must include a variant that corresponds to the 10447 -- value of the discriminant, unless the discriminant type has a 10448 -- static predicate. In that case the absence of an others_choice that 10449 -- would cover this value becomes a run-time error (3.8.1 (21.1/2)). 10450 10451 if No (Variant) 10452 and then not Has_Static_Predicate (Etype (Discrim_Name)) 10453 then 10454 Error_Msg_NE 10455 ("value of discriminant & is out of range", Discrim_Value, Discrim); 10456 Report_Errors := True; 10457 return; 10458 end if; 10459 10460 -- If we have found the corresponding choice, recursively add its 10461 -- components to the Into list. The nested components are part of 10462 -- the same record type. 10463 10464 if Present (Variant) then 10465 if Discrim_Value_Status = Static_Subtype then 10466 declare 10467 Discrim_Value_Subtype_Intervals 10468 : constant Interval_Lists.Discrete_Interval_List 10469 := Interval_Lists.Type_Intervals (Discrim_Value_Subtype); 10470 10471 Variant_Intervals 10472 : constant Interval_Lists.Discrete_Interval_List 10473 := Interval_Lists.Choice_List_Intervals 10474 (Discrete_Choices => Discrete_Choices (Variant)); 10475 begin 10476 if not Interval_Lists.Is_Subset 10477 (Subset => Discrim_Value_Subtype_Intervals, 10478 Of_Set => Variant_Intervals) 10479 then 10480 if OK_Scope_For_Discrim_Value_Error_Messages then 10481 Error_Msg_NE 10482 ("no single variant is associated with all values of " & 10483 "the subtype of discriminant value &", 10484 Discrim_Value, Discrim); 10485 end if; 10486 Report_Errors := True; 10487 return; 10488 end if; 10489 end; 10490 end if; 10491 10492 Gather_Components 10493 (Typ, Component_List (Variant), Governed_By, Into, 10494 Report_Errors, Allow_Compile_Time); 10495 end if; 10496 end Gather_Components; 10497 10498 ------------------------------- 10499 -- Get_Dynamic_Accessibility -- 10500 ------------------------------- 10501 10502 function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_Id is 10503 begin 10504 -- When minimum accessibility is set for E then we utilize it - except 10505 -- in a few edge cases like the expansion of select statements where 10506 -- generated subprogram may attempt to unnecessarily use a minimum 10507 -- accessibility object declared outside of scope. 10508 10509 -- To avoid these situations where expansion may get complex we verify 10510 -- that the minimum accessibility object is within scope. 10511 10512 if Is_Formal (E) 10513 and then Present (Minimum_Accessibility (E)) 10514 and then In_Open_Scopes (Scope (Minimum_Accessibility (E))) 10515 then 10516 return Minimum_Accessibility (E); 10517 end if; 10518 10519 return Extra_Accessibility (E); 10520 end Get_Dynamic_Accessibility; 10521 10522 ------------------------ 10523 -- Get_Actual_Subtype -- 10524 ------------------------ 10525 10526 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is 10527 Typ : constant Entity_Id := Etype (N); 10528 Utyp : Entity_Id := Underlying_Type (Typ); 10529 Decl : Node_Id; 10530 Atyp : Entity_Id; 10531 10532 begin 10533 if No (Utyp) then 10534 Utyp := Typ; 10535 end if; 10536 10537 -- If what we have is an identifier that references a subprogram 10538 -- formal, or a variable or constant object, then we get the actual 10539 -- subtype from the referenced entity if one has been built. 10540 10541 if Nkind (N) = N_Identifier 10542 and then 10543 (Is_Formal (Entity (N)) 10544 or else Ekind (Entity (N)) = E_Constant 10545 or else Ekind (Entity (N)) = E_Variable) 10546 and then Present (Actual_Subtype (Entity (N))) 10547 then 10548 return Actual_Subtype (Entity (N)); 10549 10550 -- Actual subtype of unchecked union is always itself. We never need 10551 -- the "real" actual subtype. If we did, we couldn't get it anyway 10552 -- because the discriminant is not available. The restrictions on 10553 -- Unchecked_Union are designed to make sure that this is OK. 10554 10555 elsif Is_Unchecked_Union (Base_Type (Utyp)) then 10556 return Typ; 10557 10558 -- Here for the unconstrained case, we must find actual subtype 10559 -- No actual subtype is available, so we must build it on the fly. 10560 10561 -- Checking the type, not the underlying type, for constrainedness 10562 -- seems to be necessary. Maybe all the tests should be on the type??? 10563 10564 elsif (not Is_Constrained (Typ)) 10565 and then (Is_Array_Type (Utyp) 10566 or else (Is_Record_Type (Utyp) 10567 and then Has_Discriminants (Utyp))) 10568 and then not Has_Unknown_Discriminants (Utyp) 10569 and then not (Ekind (Utyp) = E_String_Literal_Subtype) 10570 then 10571 -- Nothing to do if in spec expression (why not???) 10572 10573 if In_Spec_Expression then 10574 return Typ; 10575 10576 elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then 10577 10578 -- If the type has no discriminants, there is no subtype to 10579 -- build, even if the underlying type is discriminated. 10580 10581 return Typ; 10582 10583 -- Else build the actual subtype 10584 10585 else 10586 Decl := Build_Actual_Subtype (Typ, N); 10587 10588 -- The call may yield a declaration, or just return the entity 10589 10590 if Decl = Typ then 10591 return Typ; 10592 end if; 10593 10594 Atyp := Defining_Identifier (Decl); 10595 10596 -- If Build_Actual_Subtype generated a new declaration then use it 10597 10598 if Atyp /= Typ then 10599 10600 -- The actual subtype is an Itype, so analyze the declaration, 10601 -- but do not attach it to the tree, to get the type defined. 10602 10603 Set_Parent (Decl, N); 10604 Set_Is_Itype (Atyp); 10605 Analyze (Decl, Suppress => All_Checks); 10606 Set_Associated_Node_For_Itype (Atyp, N); 10607 Set_Has_Delayed_Freeze (Atyp, False); 10608 10609 -- We need to freeze the actual subtype immediately. This is 10610 -- needed, because otherwise this Itype will not get frozen 10611 -- at all, and it is always safe to freeze on creation because 10612 -- any associated types must be frozen at this point. 10613 10614 Freeze_Itype (Atyp, N); 10615 return Atyp; 10616 10617 -- Otherwise we did not build a declaration, so return original 10618 10619 else 10620 return Typ; 10621 end if; 10622 end if; 10623 10624 -- For all remaining cases, the actual subtype is the same as 10625 -- the nominal type. 10626 10627 else 10628 return Typ; 10629 end if; 10630 end Get_Actual_Subtype; 10631 10632 ------------------------------------- 10633 -- Get_Actual_Subtype_If_Available -- 10634 ------------------------------------- 10635 10636 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is 10637 Typ : constant Entity_Id := Etype (N); 10638 10639 begin 10640 -- If what we have is an identifier that references a subprogram 10641 -- formal, or a variable or constant object, then we get the actual 10642 -- subtype from the referenced entity if one has been built. 10643 10644 if Nkind (N) = N_Identifier 10645 and then 10646 (Is_Formal (Entity (N)) 10647 or else Ekind (Entity (N)) = E_Constant 10648 or else Ekind (Entity (N)) = E_Variable) 10649 and then Present (Actual_Subtype (Entity (N))) 10650 then 10651 return Actual_Subtype (Entity (N)); 10652 10653 -- Otherwise the Etype of N is returned unchanged 10654 10655 else 10656 return Typ; 10657 end if; 10658 end Get_Actual_Subtype_If_Available; 10659 10660 ------------------------ 10661 -- Get_Body_From_Stub -- 10662 ------------------------ 10663 10664 function Get_Body_From_Stub (N : Node_Id) return Node_Id is 10665 begin 10666 return Proper_Body (Unit (Library_Unit (N))); 10667 end Get_Body_From_Stub; 10668 10669 --------------------- 10670 -- Get_Cursor_Type -- 10671 --------------------- 10672 10673 function Get_Cursor_Type 10674 (Aspect : Node_Id; 10675 Typ : Entity_Id) return Entity_Id 10676 is 10677 Assoc : Node_Id; 10678 Func : Entity_Id; 10679 First_Op : Entity_Id; 10680 Cursor : Entity_Id; 10681 10682 begin 10683 -- If error already detected, return 10684 10685 if Error_Posted (Aspect) then 10686 return Any_Type; 10687 end if; 10688 10689 -- The cursor type for an Iterable aspect is the return type of a 10690 -- non-overloaded First primitive operation. Locate association for 10691 -- First. 10692 10693 Assoc := First (Component_Associations (Expression (Aspect))); 10694 First_Op := Any_Id; 10695 while Present (Assoc) loop 10696 if Chars (First (Choices (Assoc))) = Name_First then 10697 First_Op := Expression (Assoc); 10698 exit; 10699 end if; 10700 10701 Next (Assoc); 10702 end loop; 10703 10704 if First_Op = Any_Id then 10705 Error_Msg_N ("aspect Iterable must specify First operation", Aspect); 10706 return Any_Type; 10707 10708 elsif not Analyzed (First_Op) then 10709 Analyze (First_Op); 10710 end if; 10711 10712 Cursor := Any_Type; 10713 10714 -- Locate function with desired name and profile in scope of type 10715 -- In the rare case where the type is an integer type, a base type 10716 -- is created for it, check that the base type of the first formal 10717 -- of First matches the base type of the domain. 10718 10719 Func := First_Entity (Scope (Typ)); 10720 while Present (Func) loop 10721 if Chars (Func) = Chars (First_Op) 10722 and then Ekind (Func) = E_Function 10723 and then Present (First_Formal (Func)) 10724 and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ) 10725 and then No (Next_Formal (First_Formal (Func))) 10726 then 10727 if Cursor /= Any_Type then 10728 Error_Msg_N 10729 ("operation First for iterable type must be unique", Aspect); 10730 return Any_Type; 10731 else 10732 Cursor := Etype (Func); 10733 end if; 10734 end if; 10735 10736 Next_Entity (Func); 10737 end loop; 10738 10739 -- If not found, no way to resolve remaining primitives 10740 10741 if Cursor = Any_Type then 10742 Error_Msg_N 10743 ("primitive operation for Iterable type must appear in the same " 10744 & "list of declarations as the type", Aspect); 10745 end if; 10746 10747 return Cursor; 10748 end Get_Cursor_Type; 10749 10750 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is 10751 begin 10752 return Etype (Get_Iterable_Type_Primitive (Typ, Name_First)); 10753 end Get_Cursor_Type; 10754 10755 ------------------------------- 10756 -- Get_Default_External_Name -- 10757 ------------------------------- 10758 10759 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is 10760 begin 10761 Get_Decoded_Name_String (Chars (E)); 10762 10763 if Opt.External_Name_Imp_Casing = Uppercase then 10764 Set_Casing (All_Upper_Case); 10765 else 10766 Set_Casing (All_Lower_Case); 10767 end if; 10768 10769 return 10770 Make_String_Literal (Sloc (E), 10771 Strval => String_From_Name_Buffer); 10772 end Get_Default_External_Name; 10773 10774 -------------------------- 10775 -- Get_Enclosing_Object -- 10776 -------------------------- 10777 10778 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is 10779 begin 10780 if Is_Entity_Name (N) then 10781 return Entity (N); 10782 else 10783 case Nkind (N) is 10784 when N_Indexed_Component 10785 | N_Selected_Component 10786 | N_Slice 10787 => 10788 -- If not generating code, a dereference may be left implicit. 10789 -- In thoses cases, return Empty. 10790 10791 if Is_Access_Type (Etype (Prefix (N))) then 10792 return Empty; 10793 else 10794 return Get_Enclosing_Object (Prefix (N)); 10795 end if; 10796 10797 when N_Type_Conversion => 10798 return Get_Enclosing_Object (Expression (N)); 10799 10800 when others => 10801 return Empty; 10802 end case; 10803 end if; 10804 end Get_Enclosing_Object; 10805 10806 --------------------------- 10807 -- Get_Enum_Lit_From_Pos -- 10808 --------------------------- 10809 10810 function Get_Enum_Lit_From_Pos 10811 (T : Entity_Id; 10812 Pos : Uint; 10813 Loc : Source_Ptr) return Node_Id 10814 is 10815 Btyp : Entity_Id := Base_Type (T); 10816 Lit : Node_Id; 10817 LLoc : Source_Ptr; 10818 10819 begin 10820 -- In the case where the literal is of type Character, Wide_Character 10821 -- or Wide_Wide_Character or of a type derived from them, there needs 10822 -- to be some special handling since there is no explicit chain of 10823 -- literals to search. Instead, an N_Character_Literal node is created 10824 -- with the appropriate Char_Code and Chars fields. 10825 10826 if Is_Standard_Character_Type (T) then 10827 Set_Character_Literal_Name (UI_To_CC (Pos)); 10828 10829 return 10830 Make_Character_Literal (Loc, 10831 Chars => Name_Find, 10832 Char_Literal_Value => Pos); 10833 10834 -- For all other cases, we have a complete table of literals, and 10835 -- we simply iterate through the chain of literal until the one 10836 -- with the desired position value is found. 10837 10838 else 10839 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then 10840 Btyp := Full_View (Btyp); 10841 end if; 10842 10843 Lit := First_Literal (Btyp); 10844 10845 -- Position in the enumeration type starts at 0 10846 10847 if Pos < 0 then 10848 raise Constraint_Error; 10849 end if; 10850 10851 for J in 1 .. UI_To_Int (Pos) loop 10852 Next_Literal (Lit); 10853 10854 -- If Lit is Empty, Pos is not in range, so raise Constraint_Error 10855 -- inside the loop to avoid calling Next_Literal on Empty. 10856 10857 if No (Lit) then 10858 raise Constraint_Error; 10859 end if; 10860 end loop; 10861 10862 -- Create a new node from Lit, with source location provided by Loc 10863 -- if not equal to No_Location, or by copying the source location of 10864 -- Lit otherwise. 10865 10866 LLoc := Loc; 10867 10868 if LLoc = No_Location then 10869 LLoc := Sloc (Lit); 10870 end if; 10871 10872 return New_Occurrence_Of (Lit, LLoc); 10873 end if; 10874 end Get_Enum_Lit_From_Pos; 10875 10876 ---------------------- 10877 -- Get_Fullest_View -- 10878 ---------------------- 10879 10880 function Get_Fullest_View 10881 (E : Entity_Id; Include_PAT : Boolean := True) return Entity_Id is 10882 begin 10883 -- Prevent cascaded errors 10884 10885 if No (E) then 10886 return E; 10887 end if; 10888 10889 -- Strictly speaking, the recursion below isn't necessary, but 10890 -- it's both simplest and safest. 10891 10892 case Ekind (E) is 10893 when Incomplete_Kind => 10894 if From_Limited_With (E) then 10895 return Get_Fullest_View (Non_Limited_View (E), Include_PAT); 10896 elsif Present (Full_View (E)) then 10897 return Get_Fullest_View (Full_View (E), Include_PAT); 10898 elsif Ekind (E) = E_Incomplete_Subtype then 10899 return Get_Fullest_View (Etype (E)); 10900 end if; 10901 10902 when Private_Kind => 10903 if Present (Underlying_Full_View (E)) then 10904 return 10905 Get_Fullest_View (Underlying_Full_View (E), Include_PAT); 10906 elsif Present (Full_View (E)) then 10907 return Get_Fullest_View (Full_View (E), Include_PAT); 10908 elsif Etype (E) /= E then 10909 return Get_Fullest_View (Etype (E), Include_PAT); 10910 end if; 10911 10912 when Array_Kind => 10913 if Include_PAT and then Present (Packed_Array_Impl_Type (E)) then 10914 return Get_Fullest_View (Packed_Array_Impl_Type (E)); 10915 end if; 10916 10917 when E_Record_Subtype => 10918 if Present (Cloned_Subtype (E)) then 10919 return Get_Fullest_View (Cloned_Subtype (E), Include_PAT); 10920 end if; 10921 10922 when E_Class_Wide_Type => 10923 return Get_Fullest_View (Root_Type (E), Include_PAT); 10924 10925 when E_Class_Wide_Subtype => 10926 if Present (Equivalent_Type (E)) then 10927 return Get_Fullest_View (Equivalent_Type (E), Include_PAT); 10928 elsif Present (Cloned_Subtype (E)) then 10929 return Get_Fullest_View (Cloned_Subtype (E), Include_PAT); 10930 end if; 10931 10932 when E_Protected_Subtype 10933 | E_Protected_Type 10934 | E_Task_Subtype 10935 | E_Task_Type 10936 => 10937 if Present (Corresponding_Record_Type (E)) then 10938 return Get_Fullest_View (Corresponding_Record_Type (E), 10939 Include_PAT); 10940 end if; 10941 10942 when E_Access_Protected_Subprogram_Type 10943 | E_Anonymous_Access_Protected_Subprogram_Type 10944 => 10945 if Present (Equivalent_Type (E)) then 10946 return Get_Fullest_View (Equivalent_Type (E), Include_PAT); 10947 end if; 10948 10949 when E_Access_Subtype => 10950 return Get_Fullest_View (Base_Type (E), Include_PAT); 10951 10952 when others => 10953 null; 10954 end case; 10955 10956 return E; 10957 end Get_Fullest_View; 10958 10959 ------------------------ 10960 -- Get_Generic_Entity -- 10961 ------------------------ 10962 10963 function Get_Generic_Entity (N : Node_Id) return Entity_Id is 10964 Ent : constant Entity_Id := Entity (Name (N)); 10965 begin 10966 if Present (Renamed_Entity (Ent)) then 10967 return Renamed_Entity (Ent); 10968 else 10969 return Ent; 10970 end if; 10971 end Get_Generic_Entity; 10972 10973 ------------------------------------- 10974 -- Get_Incomplete_View_Of_Ancestor -- 10975 ------------------------------------- 10976 10977 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is 10978 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 10979 Par_Scope : Entity_Id; 10980 Par_Type : Entity_Id; 10981 10982 begin 10983 -- The incomplete view of an ancestor is only relevant for private 10984 -- derived types in child units. 10985 10986 if not Is_Derived_Type (E) 10987 or else not Is_Child_Unit (Cur_Unit) 10988 then 10989 return Empty; 10990 10991 else 10992 Par_Scope := Scope (Cur_Unit); 10993 if No (Par_Scope) then 10994 return Empty; 10995 end if; 10996 10997 Par_Type := Etype (Base_Type (E)); 10998 10999 -- Traverse list of ancestor types until we find one declared in 11000 -- a parent or grandparent unit (two levels seem sufficient). 11001 11002 while Present (Par_Type) loop 11003 if Scope (Par_Type) = Par_Scope 11004 or else Scope (Par_Type) = Scope (Par_Scope) 11005 then 11006 return Par_Type; 11007 11008 elsif not Is_Derived_Type (Par_Type) then 11009 return Empty; 11010 11011 else 11012 Par_Type := Etype (Base_Type (Par_Type)); 11013 end if; 11014 end loop; 11015 11016 -- If none found, there is no relevant ancestor type. 11017 11018 return Empty; 11019 end if; 11020 end Get_Incomplete_View_Of_Ancestor; 11021 11022 ---------------------- 11023 -- Get_Index_Bounds -- 11024 ---------------------- 11025 11026 procedure Get_Index_Bounds 11027 (N : Node_Id; 11028 L : out Node_Id; 11029 H : out Node_Id; 11030 Use_Full_View : Boolean := False) 11031 is 11032 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id; 11033 -- Obtain the scalar range of type Typ. If flag Use_Full_View is set and 11034 -- Typ qualifies, the scalar range is obtained from the full view of the 11035 -- type. 11036 11037 -------------------------- 11038 -- Scalar_Range_Of_Type -- 11039 -------------------------- 11040 11041 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id is 11042 T : Entity_Id := Typ; 11043 11044 begin 11045 if Use_Full_View and then Present (Full_View (T)) then 11046 T := Full_View (T); 11047 end if; 11048 11049 return Scalar_Range (T); 11050 end Scalar_Range_Of_Type; 11051 11052 -- Local variables 11053 11054 Kind : constant Node_Kind := Nkind (N); 11055 Rng : Node_Id; 11056 11057 -- Start of processing for Get_Index_Bounds 11058 11059 begin 11060 if Kind = N_Range then 11061 L := Low_Bound (N); 11062 H := High_Bound (N); 11063 11064 elsif Kind = N_Subtype_Indication then 11065 Rng := Range_Expression (Constraint (N)); 11066 11067 if Rng = Error then 11068 L := Error; 11069 H := Error; 11070 return; 11071 11072 else 11073 L := Low_Bound (Range_Expression (Constraint (N))); 11074 H := High_Bound (Range_Expression (Constraint (N))); 11075 end if; 11076 11077 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then 11078 Rng := Scalar_Range_Of_Type (Entity (N)); 11079 11080 if Error_Posted (Rng) then 11081 L := Error; 11082 H := Error; 11083 11084 elsif Nkind (Rng) = N_Subtype_Indication then 11085 Get_Index_Bounds (Rng, L, H); 11086 11087 else 11088 L := Low_Bound (Rng); 11089 H := High_Bound (Rng); 11090 end if; 11091 11092 else 11093 -- N is an expression, indicating a range with one value 11094 11095 L := N; 11096 H := N; 11097 end if; 11098 end Get_Index_Bounds; 11099 11100 function Get_Index_Bounds 11101 (N : Node_Id; 11102 Use_Full_View : Boolean := False) return Range_Nodes is 11103 Result : Range_Nodes; 11104 begin 11105 Get_Index_Bounds (N, Result.First, Result.Last, Use_Full_View); 11106 return Result; 11107 end Get_Index_Bounds; 11108 11109 function Get_Index_Bounds 11110 (N : Node_Id; 11111 Use_Full_View : Boolean := False) return Range_Values is 11112 Nodes : constant Range_Nodes := Get_Index_Bounds (N, Use_Full_View); 11113 begin 11114 return (Expr_Value (Nodes.First), Expr_Value (Nodes.Last)); 11115 end Get_Index_Bounds; 11116 11117 ----------------------------- 11118 -- Get_Interfacing_Aspects -- 11119 ----------------------------- 11120 11121 procedure Get_Interfacing_Aspects 11122 (Iface_Asp : Node_Id; 11123 Conv_Asp : out Node_Id; 11124 EN_Asp : out Node_Id; 11125 Expo_Asp : out Node_Id; 11126 Imp_Asp : out Node_Id; 11127 LN_Asp : out Node_Id; 11128 Do_Checks : Boolean := False) 11129 is 11130 procedure Save_Or_Duplication_Error 11131 (Asp : Node_Id; 11132 To : in out Node_Id); 11133 -- Save the value of aspect Asp in node To. If To already has a value, 11134 -- then this is considered a duplicate use of aspect. Emit an error if 11135 -- flag Do_Checks is set. 11136 11137 ------------------------------- 11138 -- Save_Or_Duplication_Error -- 11139 ------------------------------- 11140 11141 procedure Save_Or_Duplication_Error 11142 (Asp : Node_Id; 11143 To : in out Node_Id) 11144 is 11145 begin 11146 -- Detect an extra aspect and issue an error 11147 11148 if Present (To) then 11149 if Do_Checks then 11150 Error_Msg_Name_1 := Chars (Identifier (Asp)); 11151 Error_Msg_Sloc := Sloc (To); 11152 Error_Msg_N ("aspect % previously given #", Asp); 11153 end if; 11154 11155 -- Otherwise capture the aspect 11156 11157 else 11158 To := Asp; 11159 end if; 11160 end Save_Or_Duplication_Error; 11161 11162 -- Local variables 11163 11164 Asp : Node_Id; 11165 Asp_Id : Aspect_Id; 11166 11167 -- The following variables capture each individual aspect 11168 11169 Conv : Node_Id := Empty; 11170 EN : Node_Id := Empty; 11171 Expo : Node_Id := Empty; 11172 Imp : Node_Id := Empty; 11173 LN : Node_Id := Empty; 11174 11175 -- Start of processing for Get_Interfacing_Aspects 11176 11177 begin 11178 -- The input interfacing aspect should reside in an aspect specification 11179 -- list. 11180 11181 pragma Assert (Is_List_Member (Iface_Asp)); 11182 11183 -- Examine the aspect specifications of the related entity. Find and 11184 -- capture all interfacing aspects. Detect duplicates and emit errors 11185 -- if applicable. 11186 11187 Asp := First (List_Containing (Iface_Asp)); 11188 while Present (Asp) loop 11189 Asp_Id := Get_Aspect_Id (Asp); 11190 11191 if Asp_Id = Aspect_Convention then 11192 Save_Or_Duplication_Error (Asp, Conv); 11193 11194 elsif Asp_Id = Aspect_External_Name then 11195 Save_Or_Duplication_Error (Asp, EN); 11196 11197 elsif Asp_Id = Aspect_Export then 11198 Save_Or_Duplication_Error (Asp, Expo); 11199 11200 elsif Asp_Id = Aspect_Import then 11201 Save_Or_Duplication_Error (Asp, Imp); 11202 11203 elsif Asp_Id = Aspect_Link_Name then 11204 Save_Or_Duplication_Error (Asp, LN); 11205 end if; 11206 11207 Next (Asp); 11208 end loop; 11209 11210 Conv_Asp := Conv; 11211 EN_Asp := EN; 11212 Expo_Asp := Expo; 11213 Imp_Asp := Imp; 11214 LN_Asp := LN; 11215 end Get_Interfacing_Aspects; 11216 11217 --------------------------------- 11218 -- Get_Iterable_Type_Primitive -- 11219 --------------------------------- 11220 11221 function Get_Iterable_Type_Primitive 11222 (Typ : Entity_Id; 11223 Nam : Name_Id) return Entity_Id 11224 is 11225 pragma Assert 11226 (Is_Type (Typ) 11227 and then 11228 Nam in Name_Element 11229 | Name_First 11230 | Name_Has_Element 11231 | Name_Last 11232 | Name_Next 11233 | Name_Previous); 11234 11235 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable); 11236 Assoc : Node_Id; 11237 11238 begin 11239 if No (Funcs) then 11240 return Empty; 11241 11242 else 11243 Assoc := First (Component_Associations (Funcs)); 11244 while Present (Assoc) loop 11245 if Chars (First (Choices (Assoc))) = Nam then 11246 return Entity (Expression (Assoc)); 11247 end if; 11248 11249 Next (Assoc); 11250 end loop; 11251 11252 return Empty; 11253 end if; 11254 end Get_Iterable_Type_Primitive; 11255 11256 ---------------------------------- 11257 -- Get_Library_Unit_Name_String -- 11258 ---------------------------------- 11259 11260 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is 11261 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node); 11262 11263 begin 11264 Get_Unit_Name_String (Unit_Name_Id); 11265 11266 -- Remove seven last character (" (spec)" or " (body)") 11267 11268 Name_Len := Name_Len - 7; 11269 pragma Assert (Name_Buffer (Name_Len + 1) = ' '); 11270 end Get_Library_Unit_Name_String; 11271 11272 -------------------------- 11273 -- Get_Max_Queue_Length -- 11274 -------------------------- 11275 11276 function Get_Max_Queue_Length (Id : Entity_Id) return Uint is 11277 pragma Assert (Is_Entry (Id)); 11278 Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length); 11279 Max : Uint; 11280 11281 begin 11282 -- A value of 0 or -1 represents no maximum specified, and entries and 11283 -- entry families with no Max_Queue_Length aspect or pragma default to 11284 -- it. 11285 11286 if not Present (Prag) then 11287 return Uint_0; 11288 end if; 11289 11290 Max := Expr_Value 11291 (Expression (First (Pragma_Argument_Associations (Prag)))); 11292 11293 -- Since -1 and 0 are equivalent, return 0 for instances of -1 for 11294 -- uniformity. 11295 11296 if Max = -1 then 11297 return Uint_0; 11298 end if; 11299 11300 return Max; 11301 end Get_Max_Queue_Length; 11302 11303 ------------------------ 11304 -- Get_Name_Entity_Id -- 11305 ------------------------ 11306 11307 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is 11308 begin 11309 return Entity_Id (Get_Name_Table_Int (Id)); 11310 end Get_Name_Entity_Id; 11311 11312 ------------------------------ 11313 -- Get_Name_From_CTC_Pragma -- 11314 ------------------------------ 11315 11316 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is 11317 Arg : constant Node_Id := 11318 Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 11319 begin 11320 return Strval (Expr_Value_S (Arg)); 11321 end Get_Name_From_CTC_Pragma; 11322 11323 ----------------------- 11324 -- Get_Parent_Entity -- 11325 ----------------------- 11326 11327 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is 11328 begin 11329 if Nkind (Unit) = N_Package_Body 11330 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation 11331 then 11332 return Defining_Entity 11333 (Specification (Instance_Spec (Original_Node (Unit)))); 11334 elsif Nkind (Unit) = N_Package_Instantiation then 11335 return Defining_Entity (Specification (Instance_Spec (Unit))); 11336 else 11337 return Defining_Entity (Unit); 11338 end if; 11339 end Get_Parent_Entity; 11340 11341 ------------------- 11342 -- Get_Pragma_Id -- 11343 ------------------- 11344 11345 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is 11346 begin 11347 return Get_Pragma_Id (Pragma_Name_Unmapped (N)); 11348 end Get_Pragma_Id; 11349 11350 ------------------------ 11351 -- Get_Qualified_Name -- 11352 ------------------------ 11353 11354 function Get_Qualified_Name 11355 (Id : Entity_Id; 11356 Suffix : Entity_Id := Empty) return Name_Id 11357 is 11358 Suffix_Nam : Name_Id := No_Name; 11359 11360 begin 11361 if Present (Suffix) then 11362 Suffix_Nam := Chars (Suffix); 11363 end if; 11364 11365 return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id)); 11366 end Get_Qualified_Name; 11367 11368 function Get_Qualified_Name 11369 (Nam : Name_Id; 11370 Suffix : Name_Id := No_Name; 11371 Scop : Entity_Id := Current_Scope) return Name_Id 11372 is 11373 procedure Add_Scope (S : Entity_Id); 11374 -- Add the fully qualified form of scope S to the name buffer. The 11375 -- format is: 11376 -- s-1__s__ 11377 11378 --------------- 11379 -- Add_Scope -- 11380 --------------- 11381 11382 procedure Add_Scope (S : Entity_Id) is 11383 begin 11384 if S = Empty then 11385 null; 11386 11387 elsif S = Standard_Standard then 11388 null; 11389 11390 else 11391 Add_Scope (Scope (S)); 11392 Get_Name_String_And_Append (Chars (S)); 11393 Add_Str_To_Name_Buffer ("__"); 11394 end if; 11395 end Add_Scope; 11396 11397 -- Start of processing for Get_Qualified_Name 11398 11399 begin 11400 Name_Len := 0; 11401 Add_Scope (Scop); 11402 11403 -- Append the base name after all scopes have been chained 11404 11405 Get_Name_String_And_Append (Nam); 11406 11407 -- Append the suffix (if present) 11408 11409 if Suffix /= No_Name then 11410 Add_Str_To_Name_Buffer ("__"); 11411 Get_Name_String_And_Append (Suffix); 11412 end if; 11413 11414 return Name_Find; 11415 end Get_Qualified_Name; 11416 11417 ----------------------- 11418 -- Get_Reason_String -- 11419 ----------------------- 11420 11421 procedure Get_Reason_String (N : Node_Id) is 11422 begin 11423 if Nkind (N) = N_String_Literal then 11424 Store_String_Chars (Strval (N)); 11425 11426 elsif Nkind (N) = N_Op_Concat then 11427 Get_Reason_String (Left_Opnd (N)); 11428 Get_Reason_String (Right_Opnd (N)); 11429 11430 -- If not of required form, error 11431 11432 else 11433 Error_Msg_N 11434 ("Reason for pragma Warnings has wrong form", N); 11435 Error_Msg_N 11436 ("\must be string literal or concatenation of string literals", N); 11437 return; 11438 end if; 11439 end Get_Reason_String; 11440 11441 -------------------------------- 11442 -- Get_Reference_Discriminant -- 11443 -------------------------------- 11444 11445 function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is 11446 D : Entity_Id; 11447 11448 begin 11449 D := First_Discriminant (Typ); 11450 while Present (D) loop 11451 if Has_Implicit_Dereference (D) then 11452 return D; 11453 end if; 11454 Next_Discriminant (D); 11455 end loop; 11456 11457 return Empty; 11458 end Get_Reference_Discriminant; 11459 11460 --------------------------- 11461 -- Get_Referenced_Object -- 11462 --------------------------- 11463 11464 function Get_Referenced_Object (N : Node_Id) return Node_Id is 11465 R : Node_Id; 11466 11467 begin 11468 R := N; 11469 while Is_Entity_Name (R) 11470 and then Is_Object (Entity (R)) 11471 and then Present (Renamed_Object (Entity (R))) 11472 loop 11473 R := Renamed_Object (Entity (R)); 11474 end loop; 11475 11476 return R; 11477 end Get_Referenced_Object; 11478 11479 ------------------------ 11480 -- Get_Renamed_Entity -- 11481 ------------------------ 11482 11483 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is 11484 R : Entity_Id := E; 11485 begin 11486 while Present (Renamed_Entity (R)) loop 11487 R := Renamed_Entity (R); 11488 end loop; 11489 11490 return R; 11491 end Get_Renamed_Entity; 11492 11493 ----------------------- 11494 -- Get_Return_Object -- 11495 ----------------------- 11496 11497 function Get_Return_Object (N : Node_Id) return Entity_Id is 11498 Decl : Node_Id; 11499 11500 begin 11501 Decl := First (Return_Object_Declarations (N)); 11502 while Present (Decl) loop 11503 exit when Nkind (Decl) = N_Object_Declaration 11504 and then Is_Return_Object (Defining_Identifier (Decl)); 11505 Next (Decl); 11506 end loop; 11507 11508 pragma Assert (Present (Decl)); 11509 return Defining_Identifier (Decl); 11510 end Get_Return_Object; 11511 11512 --------------------------- 11513 -- Get_Subprogram_Entity -- 11514 --------------------------- 11515 11516 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is 11517 Subp : Node_Id; 11518 Subp_Id : Entity_Id; 11519 11520 begin 11521 if Nkind (Nod) = N_Accept_Statement then 11522 Subp := Entry_Direct_Name (Nod); 11523 11524 elsif Nkind (Nod) = N_Slice then 11525 Subp := Prefix (Nod); 11526 11527 else 11528 Subp := Name (Nod); 11529 end if; 11530 11531 -- Strip the subprogram call 11532 11533 loop 11534 if Nkind (Subp) in N_Explicit_Dereference 11535 | N_Indexed_Component 11536 | N_Selected_Component 11537 then 11538 Subp := Prefix (Subp); 11539 11540 elsif Nkind (Subp) in N_Type_Conversion 11541 | N_Unchecked_Type_Conversion 11542 then 11543 Subp := Expression (Subp); 11544 11545 else 11546 exit; 11547 end if; 11548 end loop; 11549 11550 -- Extract the entity of the subprogram call 11551 11552 if Is_Entity_Name (Subp) then 11553 Subp_Id := Entity (Subp); 11554 11555 if Ekind (Subp_Id) = E_Access_Subprogram_Type then 11556 Subp_Id := Directly_Designated_Type (Subp_Id); 11557 end if; 11558 11559 if Is_Subprogram (Subp_Id) then 11560 return Subp_Id; 11561 else 11562 return Empty; 11563 end if; 11564 11565 -- The search did not find a construct that denotes a subprogram 11566 11567 else 11568 return Empty; 11569 end if; 11570 end Get_Subprogram_Entity; 11571 11572 ----------------------------- 11573 -- Get_Task_Body_Procedure -- 11574 ----------------------------- 11575 11576 function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is 11577 begin 11578 -- Note: A task type may be the completion of a private type with 11579 -- discriminants. When performing elaboration checks on a task 11580 -- declaration, the current view of the type may be the private one, 11581 -- and the procedure that holds the body of the task is held in its 11582 -- underlying type. 11583 11584 -- This is an odd function, why not have Task_Body_Procedure do 11585 -- the following digging??? 11586 11587 return Task_Body_Procedure (Underlying_Type (Root_Type (E))); 11588 end Get_Task_Body_Procedure; 11589 11590 ------------------------- 11591 -- Get_User_Defined_Eq -- 11592 ------------------------- 11593 11594 function Get_User_Defined_Eq (E : Entity_Id) return Entity_Id is 11595 Prim : Elmt_Id; 11596 Op : Entity_Id; 11597 11598 begin 11599 Prim := First_Elmt (Collect_Primitive_Operations (E)); 11600 while Present (Prim) loop 11601 Op := Node (Prim); 11602 11603 if Chars (Op) = Name_Op_Eq 11604 and then Etype (Op) = Standard_Boolean 11605 and then Etype (First_Formal (Op)) = E 11606 and then Etype (Next_Formal (First_Formal (Op))) = E 11607 then 11608 return Op; 11609 end if; 11610 11611 Next_Elmt (Prim); 11612 end loop; 11613 11614 return Empty; 11615 end Get_User_Defined_Eq; 11616 11617 --------------- 11618 -- Get_Views -- 11619 --------------- 11620 11621 procedure Get_Views 11622 (Typ : Entity_Id; 11623 Priv_Typ : out Entity_Id; 11624 Full_Typ : out Entity_Id; 11625 UFull_Typ : out Entity_Id; 11626 CRec_Typ : out Entity_Id) 11627 is 11628 IP_View : Entity_Id; 11629 11630 begin 11631 -- Assume that none of the views can be recovered 11632 11633 Priv_Typ := Empty; 11634 Full_Typ := Empty; 11635 UFull_Typ := Empty; 11636 CRec_Typ := Empty; 11637 11638 -- The input type is the corresponding record type of a protected or a 11639 -- task type. 11640 11641 if Ekind (Typ) = E_Record_Type 11642 and then Is_Concurrent_Record_Type (Typ) 11643 then 11644 CRec_Typ := Typ; 11645 Full_Typ := Corresponding_Concurrent_Type (CRec_Typ); 11646 Priv_Typ := Incomplete_Or_Partial_View (Full_Typ); 11647 11648 -- Otherwise the input type denotes an arbitrary type 11649 11650 else 11651 IP_View := Incomplete_Or_Partial_View (Typ); 11652 11653 -- The input type denotes the full view of a private type 11654 11655 if Present (IP_View) then 11656 Priv_Typ := IP_View; 11657 Full_Typ := Typ; 11658 11659 -- The input type is a private type 11660 11661 elsif Is_Private_Type (Typ) then 11662 Priv_Typ := Typ; 11663 Full_Typ := Full_View (Priv_Typ); 11664 11665 -- Otherwise the input type does not have any views 11666 11667 else 11668 Full_Typ := Typ; 11669 end if; 11670 11671 if Present (Full_Typ) and then Is_Private_Type (Full_Typ) then 11672 UFull_Typ := Underlying_Full_View (Full_Typ); 11673 11674 if Present (UFull_Typ) 11675 and then Ekind (UFull_Typ) in E_Protected_Type | E_Task_Type 11676 then 11677 CRec_Typ := Corresponding_Record_Type (UFull_Typ); 11678 end if; 11679 11680 else 11681 if Present (Full_Typ) 11682 and then Ekind (Full_Typ) in E_Protected_Type | E_Task_Type 11683 then 11684 CRec_Typ := Corresponding_Record_Type (Full_Typ); 11685 end if; 11686 end if; 11687 end if; 11688 end Get_Views; 11689 11690 ----------------------- 11691 -- Has_Access_Values -- 11692 ----------------------- 11693 11694 function Has_Access_Values (T : Entity_Id) return Boolean 11695 is 11696 Typ : constant Entity_Id := Underlying_Type (T); 11697 11698 begin 11699 -- Case of a private type which is not completed yet. This can only 11700 -- happen in the case of a generic formal type appearing directly, or 11701 -- as a component of the type to which this function is being applied 11702 -- at the top level. Return False in this case, since we certainly do 11703 -- not know that the type contains access types. 11704 11705 if No (Typ) then 11706 return False; 11707 11708 elsif Is_Access_Type (Typ) then 11709 return True; 11710 11711 elsif Is_Array_Type (Typ) then 11712 return Has_Access_Values (Component_Type (Typ)); 11713 11714 elsif Is_Record_Type (Typ) then 11715 declare 11716 Comp : Entity_Id; 11717 11718 begin 11719 -- Loop to check components 11720 11721 Comp := First_Component_Or_Discriminant (Typ); 11722 while Present (Comp) loop 11723 11724 -- Check for access component, tag field does not count, even 11725 -- though it is implemented internally using an access type. 11726 11727 if Has_Access_Values (Etype (Comp)) 11728 and then Chars (Comp) /= Name_uTag 11729 then 11730 return True; 11731 end if; 11732 11733 Next_Component_Or_Discriminant (Comp); 11734 end loop; 11735 end; 11736 11737 return False; 11738 11739 else 11740 return False; 11741 end if; 11742 end Has_Access_Values; 11743 11744 --------------------------------------- 11745 -- Has_Anonymous_Access_Discriminant -- 11746 --------------------------------------- 11747 11748 function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean 11749 is 11750 Disc : Node_Id; 11751 11752 begin 11753 if not Has_Discriminants (Typ) then 11754 return False; 11755 end if; 11756 11757 Disc := First_Discriminant (Typ); 11758 while Present (Disc) loop 11759 if Ekind (Etype (Disc)) = E_Anonymous_Access_Type then 11760 return True; 11761 end if; 11762 11763 Next_Discriminant (Disc); 11764 end loop; 11765 11766 return False; 11767 end Has_Anonymous_Access_Discriminant; 11768 11769 ------------------------------ 11770 -- Has_Compatible_Alignment -- 11771 ------------------------------ 11772 11773 function Has_Compatible_Alignment 11774 (Obj : Entity_Id; 11775 Expr : Node_Id; 11776 Layout_Done : Boolean) return Alignment_Result 11777 is 11778 function Has_Compatible_Alignment_Internal 11779 (Obj : Entity_Id; 11780 Expr : Node_Id; 11781 Layout_Done : Boolean; 11782 Default : Alignment_Result) return Alignment_Result; 11783 -- This is the internal recursive function that actually does the work. 11784 -- There is one additional parameter, which says what the result should 11785 -- be if no alignment information is found, and there is no definite 11786 -- indication of compatible alignments. At the outer level, this is set 11787 -- to Unknown, but for internal recursive calls in the case where types 11788 -- are known to be correct, it is set to Known_Compatible. 11789 11790 --------------------------------------- 11791 -- Has_Compatible_Alignment_Internal -- 11792 --------------------------------------- 11793 11794 function Has_Compatible_Alignment_Internal 11795 (Obj : Entity_Id; 11796 Expr : Node_Id; 11797 Layout_Done : Boolean; 11798 Default : Alignment_Result) return Alignment_Result 11799 is 11800 Result : Alignment_Result := Known_Compatible; 11801 -- Holds the current status of the result. Note that once a value of 11802 -- Known_Incompatible is set, it is sticky and does not get changed 11803 -- to Unknown (the value in Result only gets worse as we go along, 11804 -- never better). 11805 11806 Offs : Uint := No_Uint; 11807 -- Set to a factor of the offset from the base object when Expr is a 11808 -- selected or indexed component, based on Component_Bit_Offset and 11809 -- Component_Size respectively. A negative value is used to represent 11810 -- a value that is not known at compile time. 11811 11812 procedure Check_Prefix; 11813 -- Checks the prefix recursively in the case where the expression 11814 -- is an indexed or selected component. 11815 11816 procedure Set_Result (R : Alignment_Result); 11817 -- If R represents a worse outcome (unknown instead of known 11818 -- compatible, or known incompatible), then set Result to R. 11819 11820 ------------------ 11821 -- Check_Prefix -- 11822 ------------------ 11823 11824 procedure Check_Prefix is 11825 begin 11826 -- The subtlety here is that in doing a recursive call to check 11827 -- the prefix, we have to decide what to do in the case where we 11828 -- don't find any specific indication of an alignment problem. 11829 11830 -- At the outer level, we normally set Unknown as the result in 11831 -- this case, since we can only set Known_Compatible if we really 11832 -- know that the alignment value is OK, but for the recursive 11833 -- call, in the case where the types match, and we have not 11834 -- specified a peculiar alignment for the object, we are only 11835 -- concerned about suspicious rep clauses, the default case does 11836 -- not affect us, since the compiler will, in the absence of such 11837 -- rep clauses, ensure that the alignment is correct. 11838 11839 if Default = Known_Compatible 11840 or else 11841 (Etype (Obj) = Etype (Expr) 11842 and then (not Known_Alignment (Obj) 11843 or else 11844 Alignment (Obj) = Alignment (Etype (Obj)))) 11845 then 11846 Set_Result 11847 (Has_Compatible_Alignment_Internal 11848 (Obj, Prefix (Expr), Layout_Done, Known_Compatible)); 11849 11850 -- In all other cases, we need a full check on the prefix 11851 11852 else 11853 Set_Result 11854 (Has_Compatible_Alignment_Internal 11855 (Obj, Prefix (Expr), Layout_Done, Unknown)); 11856 end if; 11857 end Check_Prefix; 11858 11859 ---------------- 11860 -- Set_Result -- 11861 ---------------- 11862 11863 procedure Set_Result (R : Alignment_Result) is 11864 begin 11865 if R > Result then 11866 Result := R; 11867 end if; 11868 end Set_Result; 11869 11870 -- Start of processing for Has_Compatible_Alignment_Internal 11871 11872 begin 11873 -- If Expr is a selected component, we must make sure there is no 11874 -- potentially troublesome component clause and that the record is 11875 -- not packed if the layout is not done. 11876 11877 if Nkind (Expr) = N_Selected_Component then 11878 11879 -- Packing generates unknown alignment if layout is not done 11880 11881 if Is_Packed (Etype (Prefix (Expr))) and then not Layout_Done then 11882 Set_Result (Unknown); 11883 end if; 11884 11885 -- Check prefix and component offset 11886 11887 Check_Prefix; 11888 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr))); 11889 11890 -- If Expr is an indexed component, we must make sure there is no 11891 -- potentially troublesome Component_Size clause and that the array 11892 -- is not bit-packed if the layout is not done. 11893 11894 elsif Nkind (Expr) = N_Indexed_Component then 11895 declare 11896 Typ : constant Entity_Id := Etype (Prefix (Expr)); 11897 11898 begin 11899 -- Packing generates unknown alignment if layout is not done 11900 11901 if Is_Bit_Packed_Array (Typ) and then not Layout_Done then 11902 Set_Result (Unknown); 11903 end if; 11904 11905 -- Check prefix and component offset (or at least size) 11906 11907 Check_Prefix; 11908 Offs := Indexed_Component_Bit_Offset (Expr); 11909 if No (Offs) then 11910 Offs := Component_Size (Typ); 11911 end if; 11912 end; 11913 end if; 11914 11915 -- If we have a null offset, the result is entirely determined by 11916 -- the base object and has already been computed recursively. 11917 11918 if Present (Offs) and then Offs = Uint_0 then 11919 null; 11920 11921 -- Case where we know the alignment of the object 11922 11923 elsif Known_Alignment (Obj) then 11924 declare 11925 ObjA : constant Uint := Alignment (Obj); 11926 ExpA : Uint := No_Uint; 11927 SizA : Uint := No_Uint; 11928 11929 begin 11930 -- If alignment of Obj is 1, then we are always OK 11931 11932 if ObjA = 1 then 11933 Set_Result (Known_Compatible); 11934 11935 -- Alignment of Obj is greater than 1, so we need to check 11936 11937 else 11938 -- If we have an offset, see if it is compatible 11939 11940 if Present (Offs) and then Offs > Uint_0 then 11941 if Offs mod (System_Storage_Unit * ObjA) /= 0 then 11942 Set_Result (Known_Incompatible); 11943 end if; 11944 11945 -- See if Expr is an object with known alignment 11946 11947 elsif Is_Entity_Name (Expr) 11948 and then Known_Alignment (Entity (Expr)) 11949 then 11950 Offs := Uint_0; 11951 ExpA := Alignment (Entity (Expr)); 11952 11953 -- Otherwise, we can use the alignment of the type of Expr 11954 -- given that we already checked for discombobulating rep 11955 -- clauses for the cases of indexed and selected components 11956 -- above. 11957 11958 elsif Known_Alignment (Etype (Expr)) then 11959 ExpA := Alignment (Etype (Expr)); 11960 11961 -- Otherwise the alignment is unknown 11962 11963 else 11964 Set_Result (Default); 11965 end if; 11966 11967 -- If we got an alignment, see if it is acceptable 11968 11969 if Present (ExpA) and then ExpA < ObjA then 11970 Set_Result (Known_Incompatible); 11971 end if; 11972 11973 -- If Expr is a component or an entire object with a known 11974 -- alignment, then we are fine. Otherwise, if its size is 11975 -- known, it must be big enough for the required alignment. 11976 11977 if Present (Offs) then 11978 null; 11979 11980 -- See if Expr is an object with known size 11981 11982 elsif Is_Entity_Name (Expr) 11983 and then Known_Static_Esize (Entity (Expr)) 11984 then 11985 SizA := Esize (Entity (Expr)); 11986 11987 -- Otherwise, we check the object size of the Expr type 11988 11989 elsif Known_Static_Esize (Etype (Expr)) then 11990 SizA := Esize (Etype (Expr)); 11991 end if; 11992 11993 -- If we got a size, see if it is a multiple of the Obj 11994 -- alignment; if not, then the alignment cannot be 11995 -- acceptable, since the size is always a multiple of the 11996 -- alignment. 11997 11998 if Present (SizA) then 11999 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then 12000 Set_Result (Known_Incompatible); 12001 end if; 12002 end if; 12003 end if; 12004 end; 12005 12006 -- If we do not know required alignment, any non-zero offset is a 12007 -- potential problem (but certainly may be OK, so result is unknown). 12008 12009 elsif Present (Offs) then 12010 Set_Result (Unknown); 12011 12012 -- If we can't find the result by direct comparison of alignment 12013 -- values, then there is still one case that we can determine known 12014 -- result, and that is when we can determine that the types are the 12015 -- same, and no alignments are specified. Then we known that the 12016 -- alignments are compatible, even if we don't know the alignment 12017 -- value in the front end. 12018 12019 elsif Etype (Obj) = Etype (Expr) then 12020 12021 -- Types are the same, but we have to check for possible size 12022 -- and alignments on the Expr object that may make the alignment 12023 -- different, even though the types are the same. 12024 12025 if Is_Entity_Name (Expr) then 12026 12027 -- First check alignment of the Expr object. Any alignment less 12028 -- than Maximum_Alignment is worrisome since this is the case 12029 -- where we do not know the alignment of Obj. 12030 12031 if Known_Alignment (Entity (Expr)) 12032 and then Alignment (Entity (Expr)) < Ttypes.Maximum_Alignment 12033 then 12034 Set_Result (Unknown); 12035 12036 -- Now check size of Expr object. Any size that is not an even 12037 -- multiple of Maximum_Alignment is also worrisome since it 12038 -- may cause the alignment of the object to be less than the 12039 -- alignment of the type. 12040 12041 elsif Known_Static_Esize (Entity (Expr)) 12042 and then 12043 Esize (Entity (Expr)) mod 12044 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit) 12045 /= 0 12046 then 12047 Set_Result (Unknown); 12048 12049 -- Otherwise same type is decisive 12050 12051 else 12052 Set_Result (Known_Compatible); 12053 end if; 12054 end if; 12055 12056 -- Another case to deal with is when there is an explicit size or 12057 -- alignment clause when the types are not the same. If so, then the 12058 -- result is Unknown. We don't need to do this test if the Default is 12059 -- Unknown, since that result will be set in any case. 12060 12061 elsif Default /= Unknown 12062 and then (Has_Size_Clause (Etype (Expr)) 12063 or else 12064 Has_Alignment_Clause (Etype (Expr))) 12065 then 12066 Set_Result (Unknown); 12067 12068 -- If no indication found, set default 12069 12070 else 12071 Set_Result (Default); 12072 end if; 12073 12074 -- Return worst result found 12075 12076 return Result; 12077 end Has_Compatible_Alignment_Internal; 12078 12079 -- Start of processing for Has_Compatible_Alignment 12080 12081 begin 12082 -- If Obj has no specified alignment, then set alignment from the type 12083 -- alignment. Perhaps we should always do this, but for sure we should 12084 -- do it when there is an address clause since we can do more if the 12085 -- alignment is known. 12086 12087 if not Known_Alignment (Obj) and then Known_Alignment (Etype (Obj)) then 12088 Set_Alignment (Obj, Alignment (Etype (Obj))); 12089 end if; 12090 12091 -- Now do the internal call that does all the work 12092 12093 return 12094 Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown); 12095 end Has_Compatible_Alignment; 12096 12097 ---------------------- 12098 -- Has_Declarations -- 12099 ---------------------- 12100 12101 function Has_Declarations (N : Node_Id) return Boolean is 12102 begin 12103 return Nkind (N) in N_Accept_Statement 12104 | N_Block_Statement 12105 | N_Compilation_Unit_Aux 12106 | N_Entry_Body 12107 | N_Package_Body 12108 | N_Protected_Body 12109 | N_Subprogram_Body 12110 | N_Task_Body 12111 | N_Package_Specification; 12112 end Has_Declarations; 12113 12114 --------------------------------- 12115 -- Has_Defaulted_Discriminants -- 12116 --------------------------------- 12117 12118 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is 12119 begin 12120 return Has_Discriminants (Typ) 12121 and then Present (Discriminant_Default_Value 12122 (First_Discriminant (Typ))); 12123 end Has_Defaulted_Discriminants; 12124 12125 ------------------- 12126 -- Has_Denormals -- 12127 ------------------- 12128 12129 function Has_Denormals (E : Entity_Id) return Boolean is 12130 begin 12131 return Is_Floating_Point_Type (E) and then Denorm_On_Target; 12132 end Has_Denormals; 12133 12134 ------------------------------------------- 12135 -- Has_Discriminant_Dependent_Constraint -- 12136 ------------------------------------------- 12137 12138 function Has_Discriminant_Dependent_Constraint 12139 (Comp : Entity_Id) return Boolean 12140 is 12141 Comp_Decl : constant Node_Id := Parent (Comp); 12142 Subt_Indic : Node_Id; 12143 Constr : Node_Id; 12144 Assn : Node_Id; 12145 12146 begin 12147 -- Discriminants can't depend on discriminants 12148 12149 if Ekind (Comp) = E_Discriminant then 12150 return False; 12151 12152 else 12153 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl)); 12154 12155 if Nkind (Subt_Indic) = N_Subtype_Indication then 12156 Constr := Constraint (Subt_Indic); 12157 12158 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then 12159 Assn := First (Constraints (Constr)); 12160 while Present (Assn) loop 12161 case Nkind (Assn) is 12162 when N_Identifier 12163 | N_Range 12164 | N_Subtype_Indication 12165 => 12166 if Depends_On_Discriminant (Assn) then 12167 return True; 12168 end if; 12169 12170 when N_Discriminant_Association => 12171 if Depends_On_Discriminant (Expression (Assn)) then 12172 return True; 12173 end if; 12174 12175 when others => 12176 null; 12177 end case; 12178 12179 Next (Assn); 12180 end loop; 12181 end if; 12182 end if; 12183 end if; 12184 12185 return False; 12186 end Has_Discriminant_Dependent_Constraint; 12187 12188 -------------------------------------- 12189 -- Has_Effectively_Volatile_Profile -- 12190 -------------------------------------- 12191 12192 function Has_Effectively_Volatile_Profile 12193 (Subp_Id : Entity_Id) return Boolean 12194 is 12195 Formal : Entity_Id; 12196 12197 begin 12198 -- Inspect the formal parameters looking for an effectively volatile 12199 -- type for reading. 12200 12201 Formal := First_Formal (Subp_Id); 12202 while Present (Formal) loop 12203 if Is_Effectively_Volatile_For_Reading (Etype (Formal)) then 12204 return True; 12205 end if; 12206 12207 Next_Formal (Formal); 12208 end loop; 12209 12210 -- Inspect the return type of functions 12211 12212 if Ekind (Subp_Id) in E_Function | E_Generic_Function 12213 and then Is_Effectively_Volatile_For_Reading (Etype (Subp_Id)) 12214 then 12215 return True; 12216 end if; 12217 12218 return False; 12219 end Has_Effectively_Volatile_Profile; 12220 12221 -------------------------- 12222 -- Has_Enabled_Property -- 12223 -------------------------- 12224 12225 function Has_Enabled_Property 12226 (Item_Id : Entity_Id; 12227 Property : Name_Id) return Boolean 12228 is 12229 function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean; 12230 -- Determine whether a protected type or variable denoted by Item_Id 12231 -- has the property enabled. 12232 12233 function State_Has_Enabled_Property return Boolean; 12234 -- Determine whether a state denoted by Item_Id has the property enabled 12235 12236 function Type_Or_Variable_Has_Enabled_Property 12237 (Item_Id : Entity_Id) return Boolean; 12238 -- Determine whether type or variable denoted by Item_Id has the 12239 -- property enabled. 12240 12241 ----------------------------------------------------- 12242 -- Protected_Type_Or_Variable_Has_Enabled_Property -- 12243 ----------------------------------------------------- 12244 12245 function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean 12246 is 12247 begin 12248 -- Protected entities always have the properties Async_Readers and 12249 -- Async_Writers (SPARK RM 7.1.2(16)). 12250 12251 if Property = Name_Async_Readers 12252 or else Property = Name_Async_Writers 12253 then 12254 return True; 12255 12256 -- Protected objects that have Part_Of components also inherit their 12257 -- properties Effective_Reads and Effective_Writes 12258 -- (SPARK RM 7.1.2(16)). 12259 12260 elsif Is_Single_Protected_Object (Item_Id) then 12261 declare 12262 Constit_Elmt : Elmt_Id; 12263 Constit_Id : Entity_Id; 12264 Constits : constant Elist_Id 12265 := Part_Of_Constituents (Item_Id); 12266 begin 12267 if Present (Constits) then 12268 Constit_Elmt := First_Elmt (Constits); 12269 while Present (Constit_Elmt) loop 12270 Constit_Id := Node (Constit_Elmt); 12271 12272 if Has_Enabled_Property (Constit_Id, Property) then 12273 return True; 12274 end if; 12275 12276 Next_Elmt (Constit_Elmt); 12277 end loop; 12278 end if; 12279 end; 12280 end if; 12281 12282 return False; 12283 end Protected_Type_Or_Variable_Has_Enabled_Property; 12284 12285 -------------------------------- 12286 -- State_Has_Enabled_Property -- 12287 -------------------------------- 12288 12289 function State_Has_Enabled_Property return Boolean is 12290 Decl : constant Node_Id := Parent (Item_Id); 12291 12292 procedure Find_Simple_Properties 12293 (Has_External : out Boolean; 12294 Has_Synchronous : out Boolean); 12295 -- Extract the simple properties associated with declaration Decl 12296 12297 function Is_Enabled_External_Property return Boolean; 12298 -- Determine whether property Property appears within the external 12299 -- property list of declaration Decl, and return its status. 12300 12301 ---------------------------- 12302 -- Find_Simple_Properties -- 12303 ---------------------------- 12304 12305 procedure Find_Simple_Properties 12306 (Has_External : out Boolean; 12307 Has_Synchronous : out Boolean) 12308 is 12309 Opt : Node_Id; 12310 12311 begin 12312 -- Assume that none of the properties are available 12313 12314 Has_External := False; 12315 Has_Synchronous := False; 12316 12317 Opt := First (Expressions (Decl)); 12318 while Present (Opt) loop 12319 if Nkind (Opt) = N_Identifier then 12320 if Chars (Opt) = Name_External then 12321 Has_External := True; 12322 12323 elsif Chars (Opt) = Name_Synchronous then 12324 Has_Synchronous := True; 12325 end if; 12326 end if; 12327 12328 Next (Opt); 12329 end loop; 12330 end Find_Simple_Properties; 12331 12332 ---------------------------------- 12333 -- Is_Enabled_External_Property -- 12334 ---------------------------------- 12335 12336 function Is_Enabled_External_Property return Boolean is 12337 Opt : Node_Id; 12338 Opt_Nam : Node_Id; 12339 Prop : Node_Id; 12340 Prop_Nam : Node_Id; 12341 Props : Node_Id; 12342 12343 begin 12344 Opt := First (Component_Associations (Decl)); 12345 while Present (Opt) loop 12346 Opt_Nam := First (Choices (Opt)); 12347 12348 if Nkind (Opt_Nam) = N_Identifier 12349 and then Chars (Opt_Nam) = Name_External 12350 then 12351 Props := Expression (Opt); 12352 12353 -- Multiple properties appear as an aggregate 12354 12355 if Nkind (Props) = N_Aggregate then 12356 12357 -- Simple property form 12358 12359 Prop := First (Expressions (Props)); 12360 while Present (Prop) loop 12361 if Chars (Prop) = Property then 12362 return True; 12363 end if; 12364 12365 Next (Prop); 12366 end loop; 12367 12368 -- Property with expression form 12369 12370 Prop := First (Component_Associations (Props)); 12371 while Present (Prop) loop 12372 Prop_Nam := First (Choices (Prop)); 12373 12374 -- The property can be represented in two ways: 12375 -- others => <value> 12376 -- <property> => <value> 12377 12378 if Nkind (Prop_Nam) = N_Others_Choice 12379 or else (Nkind (Prop_Nam) = N_Identifier 12380 and then Chars (Prop_Nam) = Property) 12381 then 12382 return Is_True (Expr_Value (Expression (Prop))); 12383 end if; 12384 12385 Next (Prop); 12386 end loop; 12387 12388 -- Single property 12389 12390 else 12391 return Chars (Props) = Property; 12392 end if; 12393 end if; 12394 12395 Next (Opt); 12396 end loop; 12397 12398 return False; 12399 end Is_Enabled_External_Property; 12400 12401 -- Local variables 12402 12403 Has_External : Boolean; 12404 Has_Synchronous : Boolean; 12405 12406 -- Start of processing for State_Has_Enabled_Property 12407 12408 begin 12409 -- The declaration of an external abstract state appears as an 12410 -- extension aggregate. If this is not the case, properties can 12411 -- never be set. 12412 12413 if Nkind (Decl) /= N_Extension_Aggregate then 12414 return False; 12415 end if; 12416 12417 Find_Simple_Properties (Has_External, Has_Synchronous); 12418 12419 -- Simple option External enables all properties (SPARK RM 7.1.2(2)) 12420 12421 if Has_External then 12422 return True; 12423 12424 -- Option External may enable or disable specific properties 12425 12426 elsif Is_Enabled_External_Property then 12427 return True; 12428 12429 -- Simple option Synchronous 12430 -- 12431 -- enables disables 12432 -- Async_Readers Effective_Reads 12433 -- Async_Writers Effective_Writes 12434 -- 12435 -- Note that both forms of External have higher precedence than 12436 -- Synchronous (SPARK RM 7.1.4(9)). 12437 12438 elsif Has_Synchronous then 12439 return Property in Name_Async_Readers | Name_Async_Writers; 12440 end if; 12441 12442 return False; 12443 end State_Has_Enabled_Property; 12444 12445 ------------------------------------------- 12446 -- Type_Or_Variable_Has_Enabled_Property -- 12447 ------------------------------------------- 12448 12449 function Type_Or_Variable_Has_Enabled_Property 12450 (Item_Id : Entity_Id) return Boolean 12451 is 12452 function Is_Enabled (Prag : Node_Id) return Boolean; 12453 -- Determine whether property pragma Prag (if present) denotes an 12454 -- enabled property. 12455 12456 ---------------- 12457 -- Is_Enabled -- 12458 ---------------- 12459 12460 function Is_Enabled (Prag : Node_Id) return Boolean is 12461 Arg1 : Node_Id; 12462 12463 begin 12464 if Present (Prag) then 12465 Arg1 := First (Pragma_Argument_Associations (Prag)); 12466 12467 -- The pragma has an optional Boolean expression, the related 12468 -- property is enabled only when the expression evaluates to 12469 -- True. 12470 12471 if Present (Arg1) then 12472 return Is_True (Expr_Value (Get_Pragma_Arg (Arg1))); 12473 12474 -- Otherwise the lack of expression enables the property by 12475 -- default. 12476 12477 else 12478 return True; 12479 end if; 12480 12481 -- The property was never set in the first place 12482 12483 else 12484 return False; 12485 end if; 12486 end Is_Enabled; 12487 12488 -- Local variables 12489 12490 AR : constant Node_Id := 12491 Get_Pragma (Item_Id, Pragma_Async_Readers); 12492 AW : constant Node_Id := 12493 Get_Pragma (Item_Id, Pragma_Async_Writers); 12494 ER : constant Node_Id := 12495 Get_Pragma (Item_Id, Pragma_Effective_Reads); 12496 EW : constant Node_Id := 12497 Get_Pragma (Item_Id, Pragma_Effective_Writes); 12498 12499 Is_Derived_Type_With_Volatile_Parent_Type : constant Boolean := 12500 Is_Derived_Type (Item_Id) 12501 and then Is_Effectively_Volatile (Etype (Base_Type (Item_Id))); 12502 12503 -- Start of processing for Type_Or_Variable_Has_Enabled_Property 12504 12505 begin 12506 -- A non-effectively volatile object can never possess external 12507 -- properties. 12508 12509 if not Is_Effectively_Volatile (Item_Id) then 12510 return False; 12511 12512 -- External properties related to variables come in two flavors - 12513 -- explicit and implicit. The explicit case is characterized by the 12514 -- presence of a property pragma with an optional Boolean flag. The 12515 -- property is enabled when the flag evaluates to True or the flag is 12516 -- missing altogether. 12517 12518 elsif Property = Name_Async_Readers and then Present (AR) then 12519 return Is_Enabled (AR); 12520 12521 elsif Property = Name_Async_Writers and then Present (AW) then 12522 return Is_Enabled (AW); 12523 12524 elsif Property = Name_Effective_Reads and then Present (ER) then 12525 return Is_Enabled (ER); 12526 12527 elsif Property = Name_Effective_Writes and then Present (EW) then 12528 return Is_Enabled (EW); 12529 12530 -- If other properties are set explicitly, then this one is set 12531 -- implicitly to False, except in the case of a derived type 12532 -- whose parent type is volatile (in that case, we will inherit 12533 -- from the parent type, below). 12534 12535 elsif (Present (AR) 12536 or else Present (AW) 12537 or else Present (ER) 12538 or else Present (EW)) 12539 and then not Is_Derived_Type_With_Volatile_Parent_Type 12540 then 12541 return False; 12542 12543 -- For a private type, may need to look at the full view 12544 12545 elsif Is_Private_Type (Item_Id) and then Present (Full_View (Item_Id)) 12546 then 12547 return Type_Or_Variable_Has_Enabled_Property (Full_View (Item_Id)); 12548 12549 -- For a derived type whose parent type is volatile, the 12550 -- property may be inherited (but ignore a non-volatile parent). 12551 12552 elsif Is_Derived_Type_With_Volatile_Parent_Type then 12553 return Type_Or_Variable_Has_Enabled_Property 12554 (First_Subtype (Etype (Base_Type (Item_Id)))); 12555 12556 -- If not specified explicitly for an object and the type 12557 -- is effectively volatile, then take result from the type. 12558 12559 elsif not Is_Type (Item_Id) 12560 and then Is_Effectively_Volatile (Etype (Item_Id)) 12561 then 12562 return Has_Enabled_Property (Etype (Item_Id), Property); 12563 12564 -- The implicit case lacks all property pragmas 12565 12566 elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then 12567 if Is_Protected_Type (Etype (Item_Id)) then 12568 return Protected_Type_Or_Variable_Has_Enabled_Property; 12569 else 12570 return True; 12571 end if; 12572 12573 else 12574 return False; 12575 end if; 12576 end Type_Or_Variable_Has_Enabled_Property; 12577 12578 -- Start of processing for Has_Enabled_Property 12579 12580 begin 12581 -- Abstract states and variables have a flexible scheme of specifying 12582 -- external properties. 12583 12584 if Ekind (Item_Id) = E_Abstract_State then 12585 return State_Has_Enabled_Property; 12586 12587 elsif Ekind (Item_Id) in E_Variable | E_Constant then 12588 return Type_Or_Variable_Has_Enabled_Property (Item_Id); 12589 12590 -- Other objects can only inherit properties through their type. We 12591 -- cannot call directly Type_Or_Variable_Has_Enabled_Property on 12592 -- these as they don't have contracts attached, which is expected by 12593 -- this function. 12594 12595 elsif Is_Object (Item_Id) then 12596 return Type_Or_Variable_Has_Enabled_Property (Etype (Item_Id)); 12597 12598 elsif Is_Type (Item_Id) then 12599 return Type_Or_Variable_Has_Enabled_Property 12600 (Item_Id => First_Subtype (Item_Id)); 12601 12602 -- Otherwise a property is enabled when the related item is effectively 12603 -- volatile. 12604 12605 else 12606 return Is_Effectively_Volatile (Item_Id); 12607 end if; 12608 end Has_Enabled_Property; 12609 12610 ------------------------------------- 12611 -- Has_Full_Default_Initialization -- 12612 ------------------------------------- 12613 12614 function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is 12615 Comp : Entity_Id; 12616 12617 begin 12618 -- A type subject to pragma Default_Initial_Condition may be fully 12619 -- default initialized depending on inheritance and the argument of 12620 -- the pragma. Since any type may act as the full view of a private 12621 -- type, this check must be performed prior to the specialized tests 12622 -- below. 12623 12624 if Has_Fully_Default_Initializing_DIC_Pragma (Typ) then 12625 return True; 12626 end if; 12627 12628 -- A scalar type is fully default initialized if it is subject to aspect 12629 -- Default_Value. 12630 12631 if Is_Scalar_Type (Typ) then 12632 return Has_Default_Aspect (Typ); 12633 12634 -- An access type is fully default initialized by default 12635 12636 elsif Is_Access_Type (Typ) then 12637 return True; 12638 12639 -- An array type is fully default initialized if its element type is 12640 -- scalar and the array type carries aspect Default_Component_Value or 12641 -- the element type is fully default initialized. 12642 12643 elsif Is_Array_Type (Typ) then 12644 return 12645 Has_Default_Aspect (Typ) 12646 or else Has_Full_Default_Initialization (Component_Type (Typ)); 12647 12648 -- A protected type, record type, or type extension is fully default 12649 -- initialized if all its components either carry an initialization 12650 -- expression or have a type that is fully default initialized. The 12651 -- parent type of a type extension must be fully default initialized. 12652 12653 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then 12654 12655 -- Inspect all entities defined in the scope of the type, looking for 12656 -- uninitialized components. 12657 12658 Comp := First_Component (Typ); 12659 while Present (Comp) loop 12660 if Comes_From_Source (Comp) 12661 and then No (Expression (Parent (Comp))) 12662 and then not Has_Full_Default_Initialization (Etype (Comp)) 12663 then 12664 return False; 12665 end if; 12666 12667 Next_Component (Comp); 12668 end loop; 12669 12670 -- Ensure that the parent type of a type extension is fully default 12671 -- initialized. 12672 12673 if Etype (Typ) /= Typ 12674 and then not Has_Full_Default_Initialization (Etype (Typ)) 12675 then 12676 return False; 12677 end if; 12678 12679 -- If we get here, then all components and parent portion are fully 12680 -- default initialized. 12681 12682 return True; 12683 12684 -- A task type is fully default initialized by default 12685 12686 elsif Is_Task_Type (Typ) then 12687 return True; 12688 12689 -- Otherwise the type is not fully default initialized 12690 12691 else 12692 return False; 12693 end if; 12694 end Has_Full_Default_Initialization; 12695 12696 ----------------------------------------------- 12697 -- Has_Fully_Default_Initializing_DIC_Pragma -- 12698 ----------------------------------------------- 12699 12700 function Has_Fully_Default_Initializing_DIC_Pragma 12701 (Typ : Entity_Id) return Boolean 12702 is 12703 Args : List_Id; 12704 Prag : Node_Id; 12705 12706 begin 12707 -- A type that inherits pragma Default_Initial_Condition from a parent 12708 -- type is automatically fully default initialized. 12709 12710 if Has_Inherited_DIC (Typ) then 12711 return True; 12712 12713 -- Otherwise the type is fully default initialized only when the pragma 12714 -- appears without an argument, or the argument is non-null. 12715 12716 elsif Has_Own_DIC (Typ) then 12717 Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition); 12718 pragma Assert (Present (Prag)); 12719 Args := Pragma_Argument_Associations (Prag); 12720 12721 -- The pragma appears without an argument in which case it defaults 12722 -- to True. 12723 12724 if No (Args) then 12725 return True; 12726 12727 -- The pragma appears with a non-null expression 12728 12729 elsif Nkind (Get_Pragma_Arg (First (Args))) /= N_Null then 12730 return True; 12731 end if; 12732 end if; 12733 12734 return False; 12735 end Has_Fully_Default_Initializing_DIC_Pragma; 12736 12737 --------------------------------- 12738 -- Has_Inferable_Discriminants -- 12739 --------------------------------- 12740 12741 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is 12742 12743 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean; 12744 -- Determines whether the left-most prefix of a selected component is a 12745 -- formal parameter in a subprogram. Assumes N is a selected component. 12746 12747 -------------------------------- 12748 -- Prefix_Is_Formal_Parameter -- 12749 -------------------------------- 12750 12751 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is 12752 Sel_Comp : Node_Id; 12753 12754 begin 12755 -- Move to the left-most prefix by climbing up the tree 12756 12757 Sel_Comp := N; 12758 while Present (Parent (Sel_Comp)) 12759 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component 12760 loop 12761 Sel_Comp := Parent (Sel_Comp); 12762 end loop; 12763 12764 return Is_Formal (Entity (Prefix (Sel_Comp))); 12765 end Prefix_Is_Formal_Parameter; 12766 12767 -- Start of processing for Has_Inferable_Discriminants 12768 12769 begin 12770 -- For selected components, the subtype of the selector must be a 12771 -- constrained Unchecked_Union. If the component is subject to a 12772 -- per-object constraint, then the enclosing object must have inferable 12773 -- discriminants. 12774 12775 if Nkind (N) = N_Selected_Component then 12776 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then 12777 12778 -- A small hack. If we have a per-object constrained selected 12779 -- component of a formal parameter, return True since we do not 12780 -- know the actual parameter association yet. 12781 12782 if Prefix_Is_Formal_Parameter (N) then 12783 return True; 12784 12785 -- Otherwise, check the enclosing object and the selector 12786 12787 else 12788 return Has_Inferable_Discriminants (Prefix (N)) 12789 and then Has_Inferable_Discriminants (Selector_Name (N)); 12790 end if; 12791 12792 -- The call to Has_Inferable_Discriminants will determine whether 12793 -- the selector has a constrained Unchecked_Union nominal type. 12794 12795 else 12796 return Has_Inferable_Discriminants (Selector_Name (N)); 12797 end if; 12798 12799 -- A qualified expression has inferable discriminants if its subtype 12800 -- mark is a constrained Unchecked_Union subtype. 12801 12802 elsif Nkind (N) = N_Qualified_Expression then 12803 return Is_Unchecked_Union (Etype (Subtype_Mark (N))) 12804 and then Is_Constrained (Etype (Subtype_Mark (N))); 12805 12806 -- For all other names, it is sufficient to have a constrained 12807 -- Unchecked_Union nominal subtype. 12808 12809 else 12810 return Is_Unchecked_Union (Base_Type (Etype (N))) 12811 and then Is_Constrained (Etype (N)); 12812 end if; 12813 end Has_Inferable_Discriminants; 12814 12815 -------------------- 12816 -- Has_Infinities -- 12817 -------------------- 12818 12819 function Has_Infinities (E : Entity_Id) return Boolean is 12820 begin 12821 return 12822 Is_Floating_Point_Type (E) 12823 and then Nkind (Scalar_Range (E)) = N_Range 12824 and then Includes_Infinities (Scalar_Range (E)); 12825 end Has_Infinities; 12826 12827 -------------------- 12828 -- Has_Interfaces -- 12829 -------------------- 12830 12831 function Has_Interfaces 12832 (T : Entity_Id; 12833 Use_Full_View : Boolean := True) return Boolean 12834 is 12835 Typ : Entity_Id := Base_Type (T); 12836 12837 begin 12838 -- Handle concurrent types 12839 12840 if Is_Concurrent_Type (Typ) then 12841 Typ := Corresponding_Record_Type (Typ); 12842 end if; 12843 12844 if not Present (Typ) 12845 or else not Is_Record_Type (Typ) 12846 or else not Is_Tagged_Type (Typ) 12847 then 12848 return False; 12849 end if; 12850 12851 -- Handle private types 12852 12853 if Use_Full_View and then Present (Full_View (Typ)) then 12854 Typ := Full_View (Typ); 12855 end if; 12856 12857 -- Handle concurrent record types 12858 12859 if Is_Concurrent_Record_Type (Typ) 12860 and then Is_Non_Empty_List (Abstract_Interface_List (Typ)) 12861 then 12862 return True; 12863 end if; 12864 12865 loop 12866 if Is_Interface (Typ) 12867 or else 12868 (Is_Record_Type (Typ) 12869 and then Present (Interfaces (Typ)) 12870 and then not Is_Empty_Elmt_List (Interfaces (Typ))) 12871 then 12872 return True; 12873 end if; 12874 12875 exit when Etype (Typ) = Typ 12876 12877 -- Handle private types 12878 12879 or else (Present (Full_View (Etype (Typ))) 12880 and then Full_View (Etype (Typ)) = Typ) 12881 12882 -- Protect frontend against wrong sources with cyclic derivations 12883 12884 or else Etype (Typ) = T; 12885 12886 -- Climb to the ancestor type handling private types 12887 12888 if Present (Full_View (Etype (Typ))) then 12889 Typ := Full_View (Etype (Typ)); 12890 else 12891 Typ := Etype (Typ); 12892 end if; 12893 end loop; 12894 12895 return False; 12896 end Has_Interfaces; 12897 12898 -------------------------- 12899 -- Has_Max_Queue_Length -- 12900 -------------------------- 12901 12902 function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is 12903 begin 12904 return 12905 Ekind (Id) = E_Entry 12906 and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length)); 12907 end Has_Max_Queue_Length; 12908 12909 --------------------------------- 12910 -- Has_No_Obvious_Side_Effects -- 12911 --------------------------------- 12912 12913 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is 12914 begin 12915 -- For now handle literals, constants, and non-volatile variables and 12916 -- expressions combining these with operators or short circuit forms. 12917 12918 if Nkind (N) in N_Numeric_Or_String_Literal then 12919 return True; 12920 12921 elsif Nkind (N) = N_Character_Literal then 12922 return True; 12923 12924 elsif Nkind (N) in N_Unary_Op then 12925 return Has_No_Obvious_Side_Effects (Right_Opnd (N)); 12926 12927 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then 12928 return Has_No_Obvious_Side_Effects (Left_Opnd (N)) 12929 and then 12930 Has_No_Obvious_Side_Effects (Right_Opnd (N)); 12931 12932 elsif Nkind (N) = N_Expression_With_Actions 12933 and then Is_Empty_List (Actions (N)) 12934 then 12935 return Has_No_Obvious_Side_Effects (Expression (N)); 12936 12937 elsif Nkind (N) in N_Has_Entity then 12938 return Present (Entity (N)) 12939 and then 12940 Ekind (Entity (N)) in 12941 E_Variable | E_Constant | E_Enumeration_Literal | 12942 E_In_Parameter | E_Out_Parameter | E_In_Out_Parameter 12943 and then not Is_Volatile (Entity (N)); 12944 12945 else 12946 return False; 12947 end if; 12948 end Has_No_Obvious_Side_Effects; 12949 12950 ----------------------------- 12951 -- Has_Non_Null_Refinement -- 12952 ----------------------------- 12953 12954 function Has_Non_Null_Refinement (Id : Entity_Id) return Boolean is 12955 Constits : Elist_Id; 12956 12957 begin 12958 pragma Assert (Ekind (Id) = E_Abstract_State); 12959 Constits := Refinement_Constituents (Id); 12960 12961 -- For a refinement to be non-null, the first constituent must be 12962 -- anything other than null. 12963 12964 return 12965 Present (Constits) 12966 and then Nkind (Node (First_Elmt (Constits))) /= N_Null; 12967 end Has_Non_Null_Refinement; 12968 12969 ----------------------------- 12970 -- Has_Non_Null_Statements -- 12971 ----------------------------- 12972 12973 function Has_Non_Null_Statements (L : List_Id) return Boolean is 12974 Node : Node_Id; 12975 12976 begin 12977 if Is_Non_Empty_List (L) then 12978 Node := First (L); 12979 12980 loop 12981 if Nkind (Node) not in N_Null_Statement | N_Call_Marker then 12982 return True; 12983 end if; 12984 12985 Next (Node); 12986 exit when Node = Empty; 12987 end loop; 12988 end if; 12989 12990 return False; 12991 end Has_Non_Null_Statements; 12992 12993 ---------------------------------- 12994 -- Is_Access_Subprogram_Wrapper -- 12995 ---------------------------------- 12996 12997 function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean is 12998 Formal : constant Entity_Id := Last_Formal (E); 12999 begin 13000 return Present (Formal) 13001 and then Ekind (Etype (Formal)) in Access_Subprogram_Kind 13002 and then Access_Subprogram_Wrapper 13003 (Directly_Designated_Type (Etype (Formal))) = E; 13004 end Is_Access_Subprogram_Wrapper; 13005 13006 --------------------------- 13007 -- Is_Explicitly_Aliased -- 13008 --------------------------- 13009 13010 function Is_Explicitly_Aliased (N : Node_Id) return Boolean is 13011 begin 13012 return Is_Formal (N) 13013 and then Present (Parent (N)) 13014 and then Nkind (Parent (N)) = N_Parameter_Specification 13015 and then Aliased_Present (Parent (N)); 13016 end Is_Explicitly_Aliased; 13017 13018 ---------------------------- 13019 -- Is_Container_Aggregate -- 13020 ---------------------------- 13021 13022 function Is_Container_Aggregate (Exp : Node_Id) return Boolean is 13023 13024 function Is_Record_Aggregate return Boolean is (False); 13025 -- ??? Unimplemented. Given an aggregate whose type is a 13026 -- record type with specified Aggregate aspect, how do we 13027 -- determine whether it is a record aggregate or a container 13028 -- aggregate? If the code where the aggregate occurs can see only 13029 -- a partial view of the aggregate's type then the aggregate 13030 -- cannot be a record type; an aggregate of a private type has to 13031 -- be a container aggregate. 13032 13033 begin 13034 return Nkind (Exp) = N_Aggregate 13035 and then Present (Find_Aspect (Etype (Exp), Aspect_Aggregate)) 13036 and then not Is_Record_Aggregate; 13037 end Is_Container_Aggregate; 13038 13039 --------------------------------- 13040 -- Side_Effect_Free_Statements -- 13041 --------------------------------- 13042 13043 function Side_Effect_Free_Statements (L : List_Id) return Boolean is 13044 Node : Node_Id; 13045 13046 begin 13047 if Is_Non_Empty_List (L) then 13048 Node := First (L); 13049 13050 loop 13051 case Nkind (Node) is 13052 when N_Null_Statement | N_Call_Marker | N_Raise_xxx_Error => 13053 null; 13054 when N_Object_Declaration => 13055 if Present (Expression (Node)) 13056 and then not Side_Effect_Free (Expression (Node)) 13057 then 13058 return False; 13059 end if; 13060 13061 when others => 13062 return False; 13063 end case; 13064 13065 Next (Node); 13066 exit when Node = Empty; 13067 end loop; 13068 end if; 13069 13070 return True; 13071 end Side_Effect_Free_Statements; 13072 13073 --------------------------- 13074 -- Side_Effect_Free_Loop -- 13075 --------------------------- 13076 13077 function Side_Effect_Free_Loop (N : Node_Id) return Boolean is 13078 Scheme : Node_Id; 13079 Spec : Node_Id; 13080 Subt : Node_Id; 13081 13082 begin 13083 -- If this is not a loop (e.g. because the loop has been rewritten), 13084 -- then return false. 13085 13086 if Nkind (N) /= N_Loop_Statement then 13087 return False; 13088 end if; 13089 13090 -- First check the statements 13091 13092 if Side_Effect_Free_Statements (Statements (N)) then 13093 13094 -- Then check the loop condition/indexes 13095 13096 if Present (Iteration_Scheme (N)) then 13097 Scheme := Iteration_Scheme (N); 13098 13099 if Present (Condition (Scheme)) 13100 or else Present (Iterator_Specification (Scheme)) 13101 then 13102 return False; 13103 elsif Present (Loop_Parameter_Specification (Scheme)) then 13104 Spec := Loop_Parameter_Specification (Scheme); 13105 Subt := Discrete_Subtype_Definition (Spec); 13106 13107 if Present (Subt) then 13108 if Nkind (Subt) = N_Range then 13109 return Side_Effect_Free (Low_Bound (Subt)) 13110 and then Side_Effect_Free (High_Bound (Subt)); 13111 else 13112 -- subtype indication 13113 13114 return True; 13115 end if; 13116 end if; 13117 end if; 13118 end if; 13119 end if; 13120 13121 return False; 13122 end Side_Effect_Free_Loop; 13123 13124 ---------------------------------- 13125 -- Has_Non_Trivial_Precondition -- 13126 ---------------------------------- 13127 13128 function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is 13129 Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre, 13130 Class_Present => True); 13131 begin 13132 return 13133 Present (Pre) 13134 and then not Is_Entity_Name (Expression (Pre)); 13135 end Has_Non_Trivial_Precondition; 13136 13137 ------------------- 13138 -- Has_Null_Body -- 13139 ------------------- 13140 13141 function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is 13142 Body_Id : Entity_Id; 13143 Decl : Node_Id; 13144 Spec : Node_Id; 13145 Stmt1 : Node_Id; 13146 Stmt2 : Node_Id; 13147 13148 begin 13149 Spec := Parent (Proc_Id); 13150 Decl := Parent (Spec); 13151 13152 -- Retrieve the entity of the procedure body (e.g. invariant proc). 13153 13154 if Nkind (Spec) = N_Procedure_Specification 13155 and then Nkind (Decl) = N_Subprogram_Declaration 13156 then 13157 Body_Id := Corresponding_Body (Decl); 13158 13159 -- The body acts as a spec 13160 13161 else 13162 Body_Id := Proc_Id; 13163 end if; 13164 13165 -- The body will be generated later 13166 13167 if No (Body_Id) then 13168 return False; 13169 end if; 13170 13171 Spec := Parent (Body_Id); 13172 Decl := Parent (Spec); 13173 13174 pragma Assert 13175 (Nkind (Spec) = N_Procedure_Specification 13176 and then Nkind (Decl) = N_Subprogram_Body); 13177 13178 Stmt1 := First (Statements (Handled_Statement_Sequence (Decl))); 13179 13180 -- Look for a null statement followed by an optional return 13181 -- statement. 13182 13183 if Nkind (Stmt1) = N_Null_Statement then 13184 Stmt2 := Next (Stmt1); 13185 13186 if Present (Stmt2) then 13187 return Nkind (Stmt2) = N_Simple_Return_Statement; 13188 else 13189 return True; 13190 end if; 13191 end if; 13192 13193 return False; 13194 end Has_Null_Body; 13195 13196 ------------------------ 13197 -- Has_Null_Exclusion -- 13198 ------------------------ 13199 13200 function Has_Null_Exclusion (N : Node_Id) return Boolean is 13201 begin 13202 case Nkind (N) is 13203 when N_Access_Definition 13204 | N_Access_Function_Definition 13205 | N_Access_Procedure_Definition 13206 | N_Access_To_Object_Definition 13207 | N_Allocator 13208 | N_Derived_Type_Definition 13209 | N_Function_Specification 13210 | N_Subtype_Declaration 13211 => 13212 return Null_Exclusion_Present (N); 13213 13214 when N_Component_Definition 13215 | N_Formal_Object_Declaration 13216 => 13217 if Present (Subtype_Mark (N)) then 13218 return Null_Exclusion_Present (N); 13219 else pragma Assert (Present (Access_Definition (N))); 13220 return Null_Exclusion_Present (Access_Definition (N)); 13221 end if; 13222 13223 when N_Object_Renaming_Declaration => 13224 if Present (Subtype_Mark (N)) then 13225 return Null_Exclusion_Present (N); 13226 elsif Present (Access_Definition (N)) then 13227 return Null_Exclusion_Present (Access_Definition (N)); 13228 else 13229 return False; -- Case of no subtype in renaming (AI12-0275) 13230 end if; 13231 13232 when N_Discriminant_Specification => 13233 if Nkind (Discriminant_Type (N)) = N_Access_Definition then 13234 return Null_Exclusion_Present (Discriminant_Type (N)); 13235 else 13236 return Null_Exclusion_Present (N); 13237 end if; 13238 13239 when N_Object_Declaration => 13240 if Nkind (Object_Definition (N)) = N_Access_Definition then 13241 return Null_Exclusion_Present (Object_Definition (N)); 13242 else 13243 return Null_Exclusion_Present (N); 13244 end if; 13245 13246 when N_Parameter_Specification => 13247 if Nkind (Parameter_Type (N)) = N_Access_Definition then 13248 return Null_Exclusion_Present (Parameter_Type (N)) 13249 or else Null_Exclusion_Present (N); 13250 else 13251 return Null_Exclusion_Present (N); 13252 end if; 13253 13254 when others => 13255 return False; 13256 end case; 13257 end Has_Null_Exclusion; 13258 13259 ------------------------ 13260 -- Has_Null_Extension -- 13261 ------------------------ 13262 13263 function Has_Null_Extension (T : Entity_Id) return Boolean is 13264 B : constant Entity_Id := Base_Type (T); 13265 Comps : Node_Id; 13266 Ext : Node_Id; 13267 13268 begin 13269 if Nkind (Parent (B)) = N_Full_Type_Declaration 13270 and then Present (Record_Extension_Part (Type_Definition (Parent (B)))) 13271 then 13272 Ext := Record_Extension_Part (Type_Definition (Parent (B))); 13273 13274 if Present (Ext) then 13275 if Null_Present (Ext) then 13276 return True; 13277 else 13278 Comps := Component_List (Ext); 13279 13280 -- The null component list is rewritten during analysis to 13281 -- include the parent component. Any other component indicates 13282 -- that the extension was not originally null. 13283 13284 return Null_Present (Comps) 13285 or else No (Next (First (Component_Items (Comps)))); 13286 end if; 13287 else 13288 return False; 13289 end if; 13290 13291 else 13292 return False; 13293 end if; 13294 end Has_Null_Extension; 13295 13296 ------------------------- 13297 -- Has_Null_Refinement -- 13298 ------------------------- 13299 13300 function Has_Null_Refinement (Id : Entity_Id) return Boolean is 13301 Constits : Elist_Id; 13302 13303 begin 13304 pragma Assert (Ekind (Id) = E_Abstract_State); 13305 Constits := Refinement_Constituents (Id); 13306 13307 -- For a refinement to be null, the state's sole constituent must be a 13308 -- null. 13309 13310 return 13311 Present (Constits) 13312 and then Nkind (Node (First_Elmt (Constits))) = N_Null; 13313 end Has_Null_Refinement; 13314 13315 ------------------------------------------ 13316 -- Has_Nonstatic_Class_Wide_Pre_Or_Post -- 13317 ------------------------------------------ 13318 13319 function Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post 13320 (Subp : Entity_Id) return Boolean 13321 is 13322 Disp_Type : constant Entity_Id := Find_Dispatching_Type (Subp); 13323 Prag : Node_Id; 13324 Pragma_Arg : Node_Id; 13325 13326 begin 13327 if Present (Disp_Type) 13328 and then Is_Abstract_Type (Disp_Type) 13329 and then Present (Contract (Subp)) 13330 then 13331 Prag := Pre_Post_Conditions (Contract (Subp)); 13332 13333 while Present (Prag) loop 13334 if Pragma_Name (Prag) in Name_Precondition | Name_Postcondition 13335 and then Class_Present (Prag) 13336 then 13337 Pragma_Arg := 13338 Nlists.First 13339 (Pragma_Argument_Associations (Prag)); 13340 13341 if not Is_Static_Expression (Expression (Pragma_Arg)) then 13342 return True; 13343 end if; 13344 end if; 13345 13346 Prag := Next_Pragma (Prag); 13347 end loop; 13348 end if; 13349 13350 return False; 13351 end Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post; 13352 13353 ------------------------------- 13354 -- Has_Overriding_Initialize -- 13355 ------------------------------- 13356 13357 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is 13358 BT : constant Entity_Id := Base_Type (T); 13359 P : Elmt_Id; 13360 13361 begin 13362 if Is_Controlled (BT) then 13363 if Is_RTU (Scope (BT), Ada_Finalization) then 13364 return False; 13365 13366 elsif Present (Primitive_Operations (BT)) then 13367 P := First_Elmt (Primitive_Operations (BT)); 13368 while Present (P) loop 13369 declare 13370 Init : constant Entity_Id := Node (P); 13371 Formal : constant Entity_Id := First_Formal (Init); 13372 begin 13373 if Ekind (Init) = E_Procedure 13374 and then Chars (Init) = Name_Initialize 13375 and then Comes_From_Source (Init) 13376 and then Present (Formal) 13377 and then Etype (Formal) = BT 13378 and then No (Next_Formal (Formal)) 13379 and then (Ada_Version < Ada_2012 13380 or else not Null_Present (Parent (Init))) 13381 then 13382 return True; 13383 end if; 13384 end; 13385 13386 Next_Elmt (P); 13387 end loop; 13388 end if; 13389 13390 -- Here if type itself does not have a non-null Initialize operation: 13391 -- check immediate ancestor. 13392 13393 if Is_Derived_Type (BT) 13394 and then Has_Overriding_Initialize (Etype (BT)) 13395 then 13396 return True; 13397 end if; 13398 end if; 13399 13400 return False; 13401 end Has_Overriding_Initialize; 13402 13403 -------------------------------------- 13404 -- Has_Preelaborable_Initialization -- 13405 -------------------------------------- 13406 13407 function Has_Preelaborable_Initialization 13408 (E : Entity_Id; 13409 Preelab_Init_Expr : Node_Id := Empty) return Boolean 13410 is 13411 Has_PE : Boolean; 13412 13413 procedure Check_Components (E : Entity_Id); 13414 -- Check component/discriminant chain, sets Has_PE False if a component 13415 -- or discriminant does not meet the preelaborable initialization rules. 13416 13417 function Type_Named_In_Preelab_Init_Expression 13418 (Typ : Entity_Id; 13419 Expr : Node_Id) return Boolean; 13420 -- Returns True iff Typ'Preelaborable_Initialization occurs in Expr 13421 -- (where Expr may be a conjunction of one or more P_I attributes). 13422 13423 ---------------------- 13424 -- Check_Components -- 13425 ---------------------- 13426 13427 procedure Check_Components (E : Entity_Id) is 13428 Ent : Entity_Id; 13429 Exp : Node_Id; 13430 13431 begin 13432 -- Loop through entities of record or protected type 13433 13434 Ent := E; 13435 while Present (Ent) loop 13436 13437 -- We are interested only in components and discriminants 13438 13439 Exp := Empty; 13440 13441 case Ekind (Ent) is 13442 when E_Component => 13443 13444 -- Get default expression if any. If there is no declaration 13445 -- node, it means we have an internal entity. The parent and 13446 -- tag fields are examples of such entities. For such cases, 13447 -- we just test the type of the entity. 13448 13449 if Present (Declaration_Node (Ent)) then 13450 Exp := Expression (Declaration_Node (Ent)); 13451 end if; 13452 13453 when E_Discriminant => 13454 13455 -- Note: for a renamed discriminant, the Declaration_Node 13456 -- may point to the one from the ancestor, and have a 13457 -- different expression, so use the proper attribute to 13458 -- retrieve the expression from the derived constraint. 13459 13460 Exp := Discriminant_Default_Value (Ent); 13461 13462 when others => 13463 goto Check_Next_Entity; 13464 end case; 13465 13466 -- A component has PI if it has no default expression and the 13467 -- component type has PI. 13468 13469 if No (Exp) then 13470 if not Has_Preelaborable_Initialization 13471 (Etype (Ent), Preelab_Init_Expr) 13472 then 13473 Has_PE := False; 13474 exit; 13475 end if; 13476 13477 -- Require the default expression to be preelaborable 13478 13479 elsif not Is_Preelaborable_Construct (Exp) then 13480 Has_PE := False; 13481 exit; 13482 end if; 13483 13484 <<Check_Next_Entity>> 13485 Next_Entity (Ent); 13486 end loop; 13487 end Check_Components; 13488 13489 -------------------------------------- 13490 -- Type_Named_In_Preelab_Expression -- 13491 -------------------------------------- 13492 13493 function Type_Named_In_Preelab_Init_Expression 13494 (Typ : Entity_Id; 13495 Expr : Node_Id) return Boolean 13496 is 13497 begin 13498 -- Return True if Expr is a Preelaborable_Initialization attribute 13499 -- and the prefix is a subtype that has the same type as Typ. 13500 13501 if Nkind (Expr) = N_Attribute_Reference 13502 and then Attribute_Name (Expr) = Name_Preelaborable_Initialization 13503 and then Is_Entity_Name (Prefix (Expr)) 13504 and then Base_Type (Entity (Prefix (Expr))) = Base_Type (Typ) 13505 then 13506 return True; 13507 13508 -- In the case where Expr is a conjunction, test whether either 13509 -- operand is a Preelaborable_Initialization attribute whose prefix 13510 -- has the same type as Typ, and return True if so. 13511 13512 elsif Nkind (Expr) = N_Op_And 13513 and then 13514 (Type_Named_In_Preelab_Init_Expression (Typ, Left_Opnd (Expr)) 13515 or else 13516 Type_Named_In_Preelab_Init_Expression (Typ, Right_Opnd (Expr))) 13517 then 13518 return True; 13519 13520 -- Typ not named in a Preelaborable_Initialization attribute of Expr 13521 13522 else 13523 return False; 13524 end if; 13525 end Type_Named_In_Preelab_Init_Expression; 13526 13527 -- Start of processing for Has_Preelaborable_Initialization 13528 13529 begin 13530 -- Immediate return if already marked as known preelaborable init. This 13531 -- covers types for which this function has already been called once 13532 -- and returned True (in which case the result is cached), and also 13533 -- types to which a pragma Preelaborable_Initialization applies. 13534 13535 if Known_To_Have_Preelab_Init (E) then 13536 return True; 13537 end if; 13538 13539 -- If the type is a subtype representing a generic actual type, then 13540 -- test whether its base type has preelaborable initialization since 13541 -- the subtype representing the actual does not inherit this attribute 13542 -- from the actual or formal. (but maybe it should???) 13543 13544 if Is_Generic_Actual_Type (E) then 13545 return Has_Preelaborable_Initialization (Base_Type (E)); 13546 end if; 13547 13548 -- All elementary types have preelaborable initialization 13549 13550 if Is_Elementary_Type (E) then 13551 Has_PE := True; 13552 13553 -- Array types have PI if the component type has PI 13554 13555 elsif Is_Array_Type (E) then 13556 Has_PE := Has_Preelaborable_Initialization 13557 (Component_Type (E), Preelab_Init_Expr); 13558 13559 -- A derived type has preelaborable initialization if its parent type 13560 -- has preelaborable initialization and (in the case of a derived record 13561 -- extension) if the non-inherited components all have preelaborable 13562 -- initialization. However, a user-defined controlled type with an 13563 -- overriding Initialize procedure does not have preelaborable 13564 -- initialization. 13565 13566 elsif Is_Derived_Type (E) then 13567 13568 -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component 13569 -- of a generic formal derived type has preelaborable initialization. 13570 -- (See comment on spec of Has_Preelaborable_Initialization.) 13571 13572 if Is_Generic_Type (E) 13573 and then Present (Preelab_Init_Expr) 13574 and then 13575 Type_Named_In_Preelab_Init_Expression (E, Preelab_Init_Expr) 13576 then 13577 return True; 13578 end if; 13579 13580 -- If the derived type is a private extension then it doesn't have 13581 -- preelaborable initialization. 13582 13583 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then 13584 return False; 13585 end if; 13586 13587 -- First check whether ancestor type has preelaborable initialization 13588 13589 Has_PE := Has_Preelaborable_Initialization 13590 (Etype (Base_Type (E)), Preelab_Init_Expr); 13591 13592 -- If OK, check extension components (if any) 13593 13594 if Has_PE and then Is_Record_Type (E) then 13595 Check_Components (First_Entity (E)); 13596 end if; 13597 13598 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type 13599 -- with a user defined Initialize procedure does not have PI. If 13600 -- the type is untagged, the control primitives come from a component 13601 -- that has already been checked. 13602 13603 if Has_PE 13604 and then Is_Controlled (E) 13605 and then Is_Tagged_Type (E) 13606 and then Has_Overriding_Initialize (E) 13607 then 13608 Has_PE := False; 13609 end if; 13610 13611 -- Private types not derived from a type having preelaborable init and 13612 -- that are not marked with pragma Preelaborable_Initialization do not 13613 -- have preelaborable initialization. 13614 13615 elsif Is_Private_Type (E) then 13616 13617 -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component 13618 -- of a generic formal private type has preelaborable initialization. 13619 -- (See comment on spec of Has_Preelaborable_Initialization.) 13620 13621 if Is_Generic_Type (E) 13622 and then Present (Preelab_Init_Expr) 13623 and then 13624 Type_Named_In_Preelab_Init_Expression (E, Preelab_Init_Expr) 13625 then 13626 return True; 13627 else 13628 return False; 13629 end if; 13630 13631 -- Record type has PI if it is non private and all components have PI 13632 13633 elsif Is_Record_Type (E) then 13634 Has_PE := True; 13635 Check_Components (First_Entity (E)); 13636 13637 -- Protected types must not have entries, and components must meet 13638 -- same set of rules as for record components. 13639 13640 elsif Is_Protected_Type (E) then 13641 if Has_Entries (E) then 13642 Has_PE := False; 13643 else 13644 Has_PE := True; 13645 Check_Components (First_Entity (E)); 13646 Check_Components (First_Private_Entity (E)); 13647 end if; 13648 13649 -- Type System.Address always has preelaborable initialization 13650 13651 elsif Is_RTE (E, RE_Address) then 13652 Has_PE := True; 13653 13654 -- In all other cases, type does not have preelaborable initialization 13655 13656 else 13657 return False; 13658 end if; 13659 13660 -- If type has preelaborable initialization, cache result 13661 13662 if Has_PE then 13663 Set_Known_To_Have_Preelab_Init (E); 13664 end if; 13665 13666 return Has_PE; 13667 end Has_Preelaborable_Initialization; 13668 13669 ---------------- 13670 -- Has_Prefix -- 13671 ---------------- 13672 13673 function Has_Prefix (N : Node_Id) return Boolean is 13674 begin 13675 return Nkind (N) in 13676 N_Attribute_Reference | N_Expanded_Name | N_Explicit_Dereference | 13677 N_Indexed_Component | N_Reference | N_Selected_Component | 13678 N_Slice; 13679 end Has_Prefix; 13680 13681 --------------------------- 13682 -- Has_Private_Component -- 13683 --------------------------- 13684 13685 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is 13686 Btype : Entity_Id := Base_Type (Type_Id); 13687 Component : Entity_Id; 13688 13689 begin 13690 if Error_Posted (Type_Id) 13691 or else Error_Posted (Btype) 13692 then 13693 return False; 13694 end if; 13695 13696 if Is_Class_Wide_Type (Btype) then 13697 Btype := Root_Type (Btype); 13698 end if; 13699 13700 if Is_Private_Type (Btype) then 13701 declare 13702 UT : constant Entity_Id := Underlying_Type (Btype); 13703 begin 13704 if No (UT) then 13705 if No (Full_View (Btype)) then 13706 return not Is_Generic_Type (Btype) 13707 and then 13708 not Is_Generic_Type (Root_Type (Btype)); 13709 else 13710 return not Is_Generic_Type (Root_Type (Full_View (Btype))); 13711 end if; 13712 else 13713 return not Is_Frozen (UT) and then Has_Private_Component (UT); 13714 end if; 13715 end; 13716 13717 elsif Is_Array_Type (Btype) then 13718 return Has_Private_Component (Component_Type (Btype)); 13719 13720 elsif Is_Record_Type (Btype) then 13721 Component := First_Component (Btype); 13722 while Present (Component) loop 13723 if Has_Private_Component (Etype (Component)) then 13724 return True; 13725 end if; 13726 13727 Next_Component (Component); 13728 end loop; 13729 13730 return False; 13731 13732 elsif Is_Protected_Type (Btype) 13733 and then Present (Corresponding_Record_Type (Btype)) 13734 then 13735 return Has_Private_Component (Corresponding_Record_Type (Btype)); 13736 13737 else 13738 return False; 13739 end if; 13740 end Has_Private_Component; 13741 13742 -------------------------------- 13743 -- Has_Relaxed_Initialization -- 13744 -------------------------------- 13745 13746 function Has_Relaxed_Initialization (E : Entity_Id) return Boolean is 13747 13748 function Denotes_Relaxed_Parameter 13749 (Expr : Node_Id; 13750 Param : Entity_Id) 13751 return Boolean; 13752 -- Returns True iff expression Expr denotes a formal parameter or 13753 -- function Param (through its attribute Result). 13754 13755 ------------------------------- 13756 -- Denotes_Relaxed_Parameter -- 13757 ------------------------------- 13758 13759 function Denotes_Relaxed_Parameter 13760 (Expr : Node_Id; 13761 Param : Entity_Id) return Boolean is 13762 begin 13763 if Nkind (Expr) in N_Identifier | N_Expanded_Name then 13764 return Entity (Expr) = Param; 13765 else 13766 pragma Assert (Is_Attribute_Result (Expr)); 13767 return Entity (Prefix (Expr)) = Param; 13768 end if; 13769 end Denotes_Relaxed_Parameter; 13770 13771 -- Start of processing for Has_Relaxed_Initialization 13772 13773 begin 13774 -- When analyzing, we checked all syntax legality rules for the aspect 13775 -- Relaxed_Initialization, but didn't store the property anywhere (e.g. 13776 -- as an Einfo flag). To query the property we look directly at the AST, 13777 -- but now without any syntactic checks. 13778 13779 case Ekind (E) is 13780 -- Abstract states have option Relaxed_Initialization 13781 13782 when E_Abstract_State => 13783 return Is_Relaxed_Initialization_State (E); 13784 13785 -- Constants have this aspect attached directly; for deferred 13786 -- constants, the aspect is attached to the partial view. 13787 13788 when E_Constant => 13789 return Has_Aspect (E, Aspect_Relaxed_Initialization); 13790 13791 -- Variables have this aspect attached directly 13792 13793 when E_Variable => 13794 return Has_Aspect (E, Aspect_Relaxed_Initialization); 13795 13796 -- Types have this aspect attached directly (though we only allow it 13797 -- to be specified for the first subtype). For private types, the 13798 -- aspect is attached to the partial view. 13799 13800 when Type_Kind => 13801 pragma Assert (Is_First_Subtype (E)); 13802 return Has_Aspect (E, Aspect_Relaxed_Initialization); 13803 13804 -- Formal parameters and functions have the Relaxed_Initialization 13805 -- aspect attached to the subprogram entity and must be listed in 13806 -- the aspect expression. 13807 13808 when Formal_Kind 13809 | E_Function 13810 => 13811 declare 13812 Subp_Id : Entity_Id; 13813 Aspect_Expr : Node_Id; 13814 Param_Expr : Node_Id; 13815 Assoc : Node_Id; 13816 13817 begin 13818 if Is_Formal (E) then 13819 Subp_Id := Scope (E); 13820 else 13821 Subp_Id := E; 13822 end if; 13823 13824 if Has_Aspect (Subp_Id, Aspect_Relaxed_Initialization) then 13825 Aspect_Expr := 13826 Find_Value_Of_Aspect 13827 (Subp_Id, Aspect_Relaxed_Initialization); 13828 13829 -- Aspect expression is either an aggregate with an optional 13830 -- Boolean expression (which defaults to True), e.g.: 13831 -- 13832 -- function F (X : Integer) return Integer 13833 -- with Relaxed_Initialization => (X => True, F'Result); 13834 13835 if Nkind (Aspect_Expr) = N_Aggregate then 13836 13837 if Present (Component_Associations (Aspect_Expr)) then 13838 Assoc := First (Component_Associations (Aspect_Expr)); 13839 13840 while Present (Assoc) loop 13841 if Denotes_Relaxed_Parameter 13842 (First (Choices (Assoc)), E) 13843 then 13844 return 13845 Is_True 13846 (Static_Boolean (Expression (Assoc))); 13847 end if; 13848 13849 Next (Assoc); 13850 end loop; 13851 end if; 13852 13853 Param_Expr := First (Expressions (Aspect_Expr)); 13854 13855 while Present (Param_Expr) loop 13856 if Denotes_Relaxed_Parameter (Param_Expr, E) then 13857 return True; 13858 end if; 13859 13860 Next (Param_Expr); 13861 end loop; 13862 13863 return False; 13864 13865 -- or it is a single identifier, e.g.: 13866 -- 13867 -- function F (X : Integer) return Integer 13868 -- with Relaxed_Initialization => X; 13869 13870 else 13871 return Denotes_Relaxed_Parameter (Aspect_Expr, E); 13872 end if; 13873 else 13874 return False; 13875 end if; 13876 end; 13877 13878 when others => 13879 raise Program_Error; 13880 end case; 13881 end Has_Relaxed_Initialization; 13882 13883 ---------------------- 13884 -- Has_Signed_Zeros -- 13885 ---------------------- 13886 13887 function Has_Signed_Zeros (E : Entity_Id) return Boolean is 13888 begin 13889 return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target; 13890 end Has_Signed_Zeros; 13891 13892 ------------------------------ 13893 -- Has_Significant_Contract -- 13894 ------------------------------ 13895 13896 function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is 13897 Subp_Nam : constant Name_Id := Chars (Subp_Id); 13898 13899 begin 13900 -- _Finalizer procedure 13901 13902 if Subp_Nam = Name_uFinalizer then 13903 return False; 13904 13905 -- _Postconditions procedure 13906 13907 elsif Subp_Nam = Name_uPostconditions then 13908 return False; 13909 13910 -- Predicate function 13911 13912 elsif Ekind (Subp_Id) = E_Function 13913 and then Is_Predicate_Function (Subp_Id) 13914 then 13915 return False; 13916 13917 -- TSS subprogram 13918 13919 elsif Get_TSS_Name (Subp_Id) /= TSS_Null then 13920 return False; 13921 13922 else 13923 return True; 13924 end if; 13925 end Has_Significant_Contract; 13926 13927 ----------------------------- 13928 -- Has_Static_Array_Bounds -- 13929 ----------------------------- 13930 13931 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is 13932 All_Static : Boolean; 13933 Dummy : Boolean; 13934 13935 begin 13936 Examine_Array_Bounds (Typ, All_Static, Dummy); 13937 13938 return All_Static; 13939 end Has_Static_Array_Bounds; 13940 13941 --------------------------------------- 13942 -- Has_Static_Non_Empty_Array_Bounds -- 13943 --------------------------------------- 13944 13945 function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean is 13946 All_Static : Boolean; 13947 Has_Empty : Boolean; 13948 13949 begin 13950 Examine_Array_Bounds (Typ, All_Static, Has_Empty); 13951 13952 return All_Static and not Has_Empty; 13953 end Has_Static_Non_Empty_Array_Bounds; 13954 13955 ---------------- 13956 -- Has_Stream -- 13957 ---------------- 13958 13959 function Has_Stream (T : Entity_Id) return Boolean is 13960 E : Entity_Id; 13961 13962 begin 13963 if No (T) then 13964 return False; 13965 13966 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then 13967 return True; 13968 13969 elsif Is_Array_Type (T) then 13970 return Has_Stream (Component_Type (T)); 13971 13972 elsif Is_Record_Type (T) then 13973 E := First_Component (T); 13974 while Present (E) loop 13975 if Has_Stream (Etype (E)) then 13976 return True; 13977 else 13978 Next_Component (E); 13979 end if; 13980 end loop; 13981 13982 return False; 13983 13984 elsif Is_Private_Type (T) then 13985 return Has_Stream (Underlying_Type (T)); 13986 13987 else 13988 return False; 13989 end if; 13990 end Has_Stream; 13991 13992 ---------------- 13993 -- Has_Suffix -- 13994 ---------------- 13995 13996 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is 13997 begin 13998 Get_Name_String (Chars (E)); 13999 return Name_Buffer (Name_Len) = Suffix; 14000 end Has_Suffix; 14001 14002 ---------------- 14003 -- Add_Suffix -- 14004 ---------------- 14005 14006 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is 14007 begin 14008 Get_Name_String (Chars (E)); 14009 Add_Char_To_Name_Buffer (Suffix); 14010 return Name_Find; 14011 end Add_Suffix; 14012 14013 ------------------- 14014 -- Remove_Suffix -- 14015 ------------------- 14016 14017 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is 14018 begin 14019 pragma Assert (Has_Suffix (E, Suffix)); 14020 Get_Name_String (Chars (E)); 14021 Name_Len := Name_Len - 1; 14022 return Name_Find; 14023 end Remove_Suffix; 14024 14025 ---------------------------------- 14026 -- Replace_Null_By_Null_Address -- 14027 ---------------------------------- 14028 14029 procedure Replace_Null_By_Null_Address (N : Node_Id) is 14030 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id); 14031 -- Replace operand Op with a reference to Null_Address when the operand 14032 -- denotes a null Address. Other_Op denotes the other operand. 14033 14034 -------------------------- 14035 -- Replace_Null_Operand -- 14036 -------------------------- 14037 14038 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id) is 14039 begin 14040 -- Check the type of the complementary operand since the N_Null node 14041 -- has not been decorated yet. 14042 14043 if Nkind (Op) = N_Null 14044 and then Is_Descendant_Of_Address (Etype (Other_Op)) 14045 then 14046 Rewrite (Op, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (Op))); 14047 end if; 14048 end Replace_Null_Operand; 14049 14050 -- Start of processing for Replace_Null_By_Null_Address 14051 14052 begin 14053 pragma Assert (Relaxed_RM_Semantics); 14054 pragma Assert 14055 (Nkind (N) in 14056 N_Null | N_Op_Eq | N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt | N_Op_Ne); 14057 14058 if Nkind (N) = N_Null then 14059 Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); 14060 14061 else 14062 declare 14063 L : constant Node_Id := Left_Opnd (N); 14064 R : constant Node_Id := Right_Opnd (N); 14065 14066 begin 14067 Replace_Null_Operand (L, Other_Op => R); 14068 Replace_Null_Operand (R, Other_Op => L); 14069 end; 14070 end if; 14071 end Replace_Null_By_Null_Address; 14072 14073 -------------------------- 14074 -- Has_Tagged_Component -- 14075 -------------------------- 14076 14077 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is 14078 Comp : Entity_Id; 14079 14080 begin 14081 if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then 14082 return Has_Tagged_Component (Underlying_Type (Typ)); 14083 14084 elsif Is_Array_Type (Typ) then 14085 return Has_Tagged_Component (Component_Type (Typ)); 14086 14087 elsif Is_Tagged_Type (Typ) then 14088 return True; 14089 14090 elsif Is_Record_Type (Typ) then 14091 Comp := First_Component (Typ); 14092 while Present (Comp) loop 14093 if Has_Tagged_Component (Etype (Comp)) then 14094 return True; 14095 end if; 14096 14097 Next_Component (Comp); 14098 end loop; 14099 14100 return False; 14101 14102 else 14103 return False; 14104 end if; 14105 end Has_Tagged_Component; 14106 14107 -------------------------------------------- 14108 -- Has_Unconstrained_Access_Discriminants -- 14109 -------------------------------------------- 14110 14111 function Has_Unconstrained_Access_Discriminants 14112 (Subtyp : Entity_Id) return Boolean 14113 is 14114 Discr : Entity_Id; 14115 14116 begin 14117 if Has_Discriminants (Subtyp) 14118 and then not Is_Constrained (Subtyp) 14119 then 14120 Discr := First_Discriminant (Subtyp); 14121 while Present (Discr) loop 14122 if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then 14123 return True; 14124 end if; 14125 14126 Next_Discriminant (Discr); 14127 end loop; 14128 end if; 14129 14130 return False; 14131 end Has_Unconstrained_Access_Discriminants; 14132 14133 ----------------------------- 14134 -- Has_Undefined_Reference -- 14135 ----------------------------- 14136 14137 function Has_Undefined_Reference (Expr : Node_Id) return Boolean is 14138 Has_Undef_Ref : Boolean := False; 14139 -- Flag set when expression Expr contains at least one undefined 14140 -- reference. 14141 14142 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result; 14143 -- Determine whether N denotes a reference and if it does, whether it is 14144 -- undefined. 14145 14146 ---------------------------- 14147 -- Is_Undefined_Reference -- 14148 ---------------------------- 14149 14150 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result is 14151 begin 14152 if Is_Entity_Name (N) 14153 and then Present (Entity (N)) 14154 and then Entity (N) = Any_Id 14155 then 14156 Has_Undef_Ref := True; 14157 return Abandon; 14158 end if; 14159 14160 return OK; 14161 end Is_Undefined_Reference; 14162 14163 procedure Find_Undefined_References is 14164 new Traverse_Proc (Is_Undefined_Reference); 14165 14166 -- Start of processing for Has_Undefined_Reference 14167 14168 begin 14169 Find_Undefined_References (Expr); 14170 14171 return Has_Undef_Ref; 14172 end Has_Undefined_Reference; 14173 14174 ---------------------------- 14175 -- Has_Volatile_Component -- 14176 ---------------------------- 14177 14178 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is 14179 Comp : Entity_Id; 14180 14181 begin 14182 if Has_Volatile_Components (Typ) then 14183 return True; 14184 14185 elsif Is_Array_Type (Typ) then 14186 return Is_Volatile (Component_Type (Typ)); 14187 14188 elsif Is_Record_Type (Typ) then 14189 Comp := First_Component (Typ); 14190 while Present (Comp) loop 14191 if Is_Volatile_Object_Ref (Comp) then 14192 return True; 14193 end if; 14194 14195 Next_Component (Comp); 14196 end loop; 14197 end if; 14198 14199 return False; 14200 end Has_Volatile_Component; 14201 14202 ------------------------- 14203 -- Implementation_Kind -- 14204 ------------------------- 14205 14206 function Implementation_Kind (Subp : Entity_Id) return Name_Id is 14207 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented); 14208 Arg : Node_Id; 14209 begin 14210 pragma Assert (Present (Impl_Prag)); 14211 Arg := Last (Pragma_Argument_Associations (Impl_Prag)); 14212 return Chars (Get_Pragma_Arg (Arg)); 14213 end Implementation_Kind; 14214 14215 -------------------------- 14216 -- Implements_Interface -- 14217 -------------------------- 14218 14219 function Implements_Interface 14220 (Typ_Ent : Entity_Id; 14221 Iface_Ent : Entity_Id; 14222 Exclude_Parents : Boolean := False) return Boolean 14223 is 14224 Ifaces_List : Elist_Id; 14225 Elmt : Elmt_Id; 14226 Iface : Entity_Id := Base_Type (Iface_Ent); 14227 Typ : Entity_Id := Base_Type (Typ_Ent); 14228 14229 begin 14230 if Is_Class_Wide_Type (Typ) then 14231 Typ := Root_Type (Typ); 14232 end if; 14233 14234 if not Has_Interfaces (Typ) then 14235 return False; 14236 end if; 14237 14238 if Is_Class_Wide_Type (Iface) then 14239 Iface := Root_Type (Iface); 14240 end if; 14241 14242 Collect_Interfaces (Typ, Ifaces_List); 14243 14244 Elmt := First_Elmt (Ifaces_List); 14245 while Present (Elmt) loop 14246 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True) 14247 and then Exclude_Parents 14248 then 14249 null; 14250 14251 elsif Node (Elmt) = Iface then 14252 return True; 14253 end if; 14254 14255 Next_Elmt (Elmt); 14256 end loop; 14257 14258 return False; 14259 end Implements_Interface; 14260 14261 -------------------------------- 14262 -- Implicitly_Designated_Type -- 14263 -------------------------------- 14264 14265 function Implicitly_Designated_Type (Typ : Entity_Id) return Entity_Id is 14266 Desig : constant Entity_Id := Designated_Type (Typ); 14267 14268 begin 14269 -- An implicit dereference is a legal occurrence of an incomplete type 14270 -- imported through a limited_with clause, if the full view is visible. 14271 14272 if Is_Incomplete_Type (Desig) 14273 and then From_Limited_With (Desig) 14274 and then not From_Limited_With (Scope (Desig)) 14275 and then 14276 (Is_Immediately_Visible (Scope (Desig)) 14277 or else 14278 (Is_Child_Unit (Scope (Desig)) 14279 and then Is_Visible_Lib_Unit (Scope (Desig)))) 14280 then 14281 return Available_View (Desig); 14282 else 14283 return Desig; 14284 end if; 14285 end Implicitly_Designated_Type; 14286 14287 ------------------------------------ 14288 -- In_Assertion_Expression_Pragma -- 14289 ------------------------------------ 14290 14291 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is 14292 Par : Node_Id; 14293 Prag : Node_Id := Empty; 14294 14295 begin 14296 -- Climb the parent chain looking for an enclosing pragma 14297 14298 Par := N; 14299 while Present (Par) loop 14300 if Nkind (Par) = N_Pragma then 14301 Prag := Par; 14302 exit; 14303 14304 -- Precondition-like pragmas are expanded into if statements, check 14305 -- the original node instead. 14306 14307 elsif Nkind (Original_Node (Par)) = N_Pragma then 14308 Prag := Original_Node (Par); 14309 exit; 14310 14311 -- The expansion of attribute 'Old generates a constant to capture 14312 -- the result of the prefix. If the parent traversal reaches 14313 -- one of these constants, then the node technically came from a 14314 -- postcondition-like pragma. Note that the Ekind is not tested here 14315 -- because N may be the expression of an object declaration which is 14316 -- currently being analyzed. Such objects carry Ekind of E_Void. 14317 14318 elsif Nkind (Par) = N_Object_Declaration 14319 and then Constant_Present (Par) 14320 and then Stores_Attribute_Old_Prefix (Defining_Entity (Par)) 14321 then 14322 return True; 14323 14324 -- Prevent the search from going too far 14325 14326 elsif Is_Body_Or_Package_Declaration (Par) then 14327 return False; 14328 end if; 14329 14330 Par := Parent (Par); 14331 end loop; 14332 14333 return 14334 Present (Prag) 14335 and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag)); 14336 end In_Assertion_Expression_Pragma; 14337 14338 ------------------- 14339 -- In_Check_Node -- 14340 ------------------- 14341 14342 function In_Check_Node (N : Node_Id) return Boolean is 14343 Par : Node_Id := Parent (N); 14344 begin 14345 while Present (Par) loop 14346 if Nkind (Par) in N_Raise_xxx_Error then 14347 return True; 14348 14349 -- Prevent the search from going too far 14350 14351 elsif Is_Body_Or_Package_Declaration (Par) then 14352 return False; 14353 14354 else 14355 Par := Parent (Par); 14356 end if; 14357 end loop; 14358 14359 return False; 14360 end In_Check_Node; 14361 14362 ------------------------------- 14363 -- In_Generic_Formal_Package -- 14364 ------------------------------- 14365 14366 function In_Generic_Formal_Package (E : Entity_Id) return Boolean is 14367 Par : Node_Id; 14368 14369 begin 14370 Par := Parent (E); 14371 while Present (Par) loop 14372 if Nkind (Par) = N_Formal_Package_Declaration 14373 or else Nkind (Original_Node (Par)) = N_Formal_Package_Declaration 14374 then 14375 return True; 14376 end if; 14377 14378 Par := Parent (Par); 14379 end loop; 14380 14381 return False; 14382 end In_Generic_Formal_Package; 14383 14384 ---------------------- 14385 -- In_Generic_Scope -- 14386 ---------------------- 14387 14388 function In_Generic_Scope (E : Entity_Id) return Boolean is 14389 S : Entity_Id; 14390 14391 begin 14392 S := Scope (E); 14393 while Present (S) and then S /= Standard_Standard loop 14394 if Is_Generic_Unit (S) then 14395 return True; 14396 end if; 14397 14398 S := Scope (S); 14399 end loop; 14400 14401 return False; 14402 end In_Generic_Scope; 14403 14404 ----------------- 14405 -- In_Instance -- 14406 ----------------- 14407 14408 function In_Instance return Boolean is 14409 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 14410 S : Entity_Id; 14411 14412 begin 14413 S := Current_Scope; 14414 while Present (S) and then S /= Standard_Standard loop 14415 if Is_Generic_Instance (S) then 14416 14417 -- A child instance is always compiled in the context of a parent 14418 -- instance. Nevertheless, its actuals must not be analyzed in an 14419 -- instance context. We detect this case by examining the current 14420 -- compilation unit, which must be a child instance, and checking 14421 -- that it has not been analyzed yet. 14422 14423 if Is_Child_Unit (Curr_Unit) 14424 and then Nkind (Unit (Cunit (Current_Sem_Unit))) = 14425 N_Package_Instantiation 14426 and then Ekind (Curr_Unit) = E_Void 14427 then 14428 return False; 14429 else 14430 return True; 14431 end if; 14432 end if; 14433 14434 S := Scope (S); 14435 end loop; 14436 14437 return False; 14438 end In_Instance; 14439 14440 ---------------------- 14441 -- In_Instance_Body -- 14442 ---------------------- 14443 14444 function In_Instance_Body return Boolean is 14445 S : Entity_Id; 14446 14447 begin 14448 S := Current_Scope; 14449 while Present (S) and then S /= Standard_Standard loop 14450 if Ekind (S) in E_Function | E_Procedure 14451 and then Is_Generic_Instance (S) 14452 then 14453 return True; 14454 14455 elsif Ekind (S) = E_Package 14456 and then In_Package_Body (S) 14457 and then Is_Generic_Instance (S) 14458 then 14459 return True; 14460 end if; 14461 14462 S := Scope (S); 14463 end loop; 14464 14465 return False; 14466 end In_Instance_Body; 14467 14468 ----------------------------- 14469 -- In_Instance_Not_Visible -- 14470 ----------------------------- 14471 14472 function In_Instance_Not_Visible return Boolean is 14473 S : Entity_Id; 14474 14475 begin 14476 S := Current_Scope; 14477 while Present (S) and then S /= Standard_Standard loop 14478 if Ekind (S) in E_Function | E_Procedure 14479 and then Is_Generic_Instance (S) 14480 then 14481 return True; 14482 14483 elsif Ekind (S) = E_Package 14484 and then (In_Package_Body (S) or else In_Private_Part (S)) 14485 and then Is_Generic_Instance (S) 14486 then 14487 return True; 14488 end if; 14489 14490 S := Scope (S); 14491 end loop; 14492 14493 return False; 14494 end In_Instance_Not_Visible; 14495 14496 ------------------------------ 14497 -- In_Instance_Visible_Part -- 14498 ------------------------------ 14499 14500 function In_Instance_Visible_Part 14501 (Id : Entity_Id := Current_Scope) return Boolean 14502 is 14503 Inst : Entity_Id; 14504 14505 begin 14506 Inst := Id; 14507 while Present (Inst) and then Inst /= Standard_Standard loop 14508 if Ekind (Inst) = E_Package 14509 and then Is_Generic_Instance (Inst) 14510 and then not In_Package_Body (Inst) 14511 and then not In_Private_Part (Inst) 14512 then 14513 return True; 14514 end if; 14515 14516 Inst := Scope (Inst); 14517 end loop; 14518 14519 return False; 14520 end In_Instance_Visible_Part; 14521 14522 --------------------- 14523 -- In_Package_Body -- 14524 --------------------- 14525 14526 function In_Package_Body return Boolean is 14527 S : Entity_Id; 14528 14529 begin 14530 S := Current_Scope; 14531 while Present (S) and then S /= Standard_Standard loop 14532 if Ekind (S) = E_Package and then In_Package_Body (S) then 14533 return True; 14534 else 14535 S := Scope (S); 14536 end if; 14537 end loop; 14538 14539 return False; 14540 end In_Package_Body; 14541 14542 -------------------------- 14543 -- In_Pragma_Expression -- 14544 -------------------------- 14545 14546 function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean is 14547 P : Node_Id; 14548 begin 14549 P := Parent (N); 14550 loop 14551 if No (P) then 14552 return False; 14553 elsif Nkind (P) = N_Pragma and then Pragma_Name (P) = Nam then 14554 return True; 14555 else 14556 P := Parent (P); 14557 end if; 14558 end loop; 14559 end In_Pragma_Expression; 14560 14561 --------------------------- 14562 -- In_Pre_Post_Condition -- 14563 --------------------------- 14564 14565 function In_Pre_Post_Condition 14566 (N : Node_Id; Class_Wide_Only : Boolean := False) return Boolean 14567 is 14568 Par : Node_Id; 14569 Prag : Node_Id := Empty; 14570 Prag_Id : Pragma_Id; 14571 14572 begin 14573 -- Climb the parent chain looking for an enclosing pragma 14574 14575 Par := N; 14576 while Present (Par) loop 14577 if Nkind (Par) = N_Pragma then 14578 Prag := Par; 14579 exit; 14580 14581 -- Prevent the search from going too far 14582 14583 elsif Is_Body_Or_Package_Declaration (Par) then 14584 exit; 14585 end if; 14586 14587 Par := Parent (Par); 14588 end loop; 14589 14590 if Present (Prag) then 14591 Prag_Id := Get_Pragma_Id (Prag); 14592 14593 if Class_Wide_Only then 14594 return 14595 Prag_Id = Pragma_Post_Class 14596 or else Prag_Id = Pragma_Pre_Class 14597 or else (Class_Present (Prag) 14598 and then (Prag_Id = Pragma_Post 14599 or else Prag_Id = Pragma_Postcondition 14600 or else Prag_Id = Pragma_Pre 14601 or else Prag_Id = Pragma_Precondition)); 14602 else 14603 return 14604 Prag_Id = Pragma_Post 14605 or else Prag_Id = Pragma_Post_Class 14606 or else Prag_Id = Pragma_Postcondition 14607 or else Prag_Id = Pragma_Pre 14608 or else Prag_Id = Pragma_Pre_Class 14609 or else Prag_Id = Pragma_Precondition; 14610 end if; 14611 14612 -- Otherwise the node is not enclosed by a pre/postcondition pragma 14613 14614 else 14615 return False; 14616 end if; 14617 end In_Pre_Post_Condition; 14618 14619 ------------------------------ 14620 -- In_Quantified_Expression -- 14621 ------------------------------ 14622 14623 function In_Quantified_Expression (N : Node_Id) return Boolean is 14624 P : Node_Id; 14625 begin 14626 P := Parent (N); 14627 loop 14628 if No (P) then 14629 return False; 14630 elsif Nkind (P) = N_Quantified_Expression then 14631 return True; 14632 else 14633 P := Parent (P); 14634 end if; 14635 end loop; 14636 end In_Quantified_Expression; 14637 14638 ------------------------------------- 14639 -- In_Reverse_Storage_Order_Object -- 14640 ------------------------------------- 14641 14642 function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is 14643 Pref : Node_Id; 14644 Btyp : Entity_Id := Empty; 14645 14646 begin 14647 -- Climb up indexed components 14648 14649 Pref := N; 14650 loop 14651 case Nkind (Pref) is 14652 when N_Selected_Component => 14653 Pref := Prefix (Pref); 14654 exit; 14655 14656 when N_Indexed_Component => 14657 Pref := Prefix (Pref); 14658 14659 when others => 14660 Pref := Empty; 14661 exit; 14662 end case; 14663 end loop; 14664 14665 if Present (Pref) then 14666 Btyp := Base_Type (Etype (Pref)); 14667 end if; 14668 14669 return Present (Btyp) 14670 and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp)) 14671 and then Reverse_Storage_Order (Btyp); 14672 end In_Reverse_Storage_Order_Object; 14673 14674 ------------------------------ 14675 -- In_Same_Declarative_Part -- 14676 ------------------------------ 14677 14678 function In_Same_Declarative_Part 14679 (Context : Node_Id; 14680 N : Node_Id) return Boolean 14681 is 14682 Cont : Node_Id := Context; 14683 Nod : Node_Id; 14684 14685 begin 14686 if Nkind (Cont) = N_Compilation_Unit_Aux then 14687 Cont := Parent (Cont); 14688 end if; 14689 14690 Nod := Parent (N); 14691 while Present (Nod) loop 14692 if Nod = Cont then 14693 return True; 14694 14695 elsif Nkind (Nod) in N_Accept_Statement 14696 | N_Block_Statement 14697 | N_Compilation_Unit 14698 | N_Entry_Body 14699 | N_Package_Body 14700 | N_Package_Declaration 14701 | N_Protected_Body 14702 | N_Subprogram_Body 14703 | N_Task_Body 14704 then 14705 return False; 14706 14707 elsif Nkind (Nod) = N_Subunit then 14708 Nod := Corresponding_Stub (Nod); 14709 14710 else 14711 Nod := Parent (Nod); 14712 end if; 14713 end loop; 14714 14715 return False; 14716 end In_Same_Declarative_Part; 14717 14718 -------------------------------------- 14719 -- In_Subprogram_Or_Concurrent_Unit -- 14720 -------------------------------------- 14721 14722 function In_Subprogram_Or_Concurrent_Unit return Boolean is 14723 E : Entity_Id; 14724 K : Entity_Kind; 14725 14726 begin 14727 -- Use scope chain to check successively outer scopes 14728 14729 E := Current_Scope; 14730 loop 14731 K := Ekind (E); 14732 14733 if K in Subprogram_Kind 14734 or else K in Concurrent_Kind 14735 or else K in Generic_Subprogram_Kind 14736 then 14737 return True; 14738 14739 elsif E = Standard_Standard then 14740 return False; 14741 end if; 14742 14743 E := Scope (E); 14744 end loop; 14745 end In_Subprogram_Or_Concurrent_Unit; 14746 14747 ---------------- 14748 -- In_Subtree -- 14749 ---------------- 14750 14751 function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is 14752 Curr : Node_Id; 14753 14754 begin 14755 Curr := N; 14756 while Present (Curr) loop 14757 if Curr = Root then 14758 return True; 14759 end if; 14760 14761 Curr := Parent (Curr); 14762 end loop; 14763 14764 return False; 14765 end In_Subtree; 14766 14767 ---------------- 14768 -- In_Subtree -- 14769 ---------------- 14770 14771 function In_Subtree 14772 (N : Node_Id; 14773 Root1 : Node_Id; 14774 Root2 : Node_Id) return Boolean 14775 is 14776 Curr : Node_Id; 14777 14778 begin 14779 Curr := N; 14780 while Present (Curr) loop 14781 if Curr = Root1 or else Curr = Root2 then 14782 return True; 14783 end if; 14784 14785 Curr := Parent (Curr); 14786 end loop; 14787 14788 return False; 14789 end In_Subtree; 14790 14791 --------------------- 14792 -- In_Return_Value -- 14793 --------------------- 14794 14795 function In_Return_Value (Expr : Node_Id) return Boolean is 14796 Par : Node_Id; 14797 Prev_Par : Node_Id; 14798 Pre : Node_Id; 14799 In_Function_Call : Boolean := False; 14800 14801 begin 14802 -- Move through parent nodes to determine if Expr contributes to the 14803 -- return value of the current subprogram. 14804 14805 Par := Expr; 14806 Prev_Par := Empty; 14807 while Present (Par) loop 14808 14809 case Nkind (Par) is 14810 -- Ignore ranges and they don't contribute to the result 14811 14812 when N_Range => 14813 return False; 14814 14815 -- An object declaration whose parent is an extended return 14816 -- statement is a return object. 14817 14818 when N_Object_Declaration => 14819 if Present (Parent (Par)) 14820 and then Nkind (Parent (Par)) = N_Extended_Return_Statement 14821 then 14822 return True; 14823 end if; 14824 14825 -- We hit a simple return statement, so we know we are in one 14826 14827 when N_Simple_Return_Statement => 14828 return True; 14829 14830 -- Only include one nexting level of function calls 14831 14832 when N_Function_Call => 14833 if not In_Function_Call then 14834 In_Function_Call := True; 14835 14836 -- When the function return type has implicit dereference 14837 -- specified we know it cannot directly contribute to the 14838 -- return value. 14839 14840 if Present (Etype (Par)) 14841 and then Has_Implicit_Dereference 14842 (Get_Full_View (Etype (Par))) 14843 then 14844 return False; 14845 end if; 14846 else 14847 return False; 14848 end if; 14849 14850 -- Check if we are on the right-hand side of an assignment 14851 -- statement to a return object. 14852 14853 -- This is not specified in the RM ??? 14854 14855 when N_Assignment_Statement => 14856 if Prev_Par = Name (Par) then 14857 return False; 14858 end if; 14859 14860 Pre := Name (Par); 14861 while Present (Pre) loop 14862 if Is_Entity_Name (Pre) 14863 and then Is_Return_Object (Entity (Pre)) 14864 then 14865 return True; 14866 end if; 14867 14868 exit when Nkind (Pre) not in N_Selected_Component 14869 | N_Indexed_Component 14870 | N_Slice; 14871 14872 Pre := Prefix (Pre); 14873 end loop; 14874 14875 -- Otherwise, we hit a master which was not relevant 14876 14877 when others => 14878 if Is_Master (Par) then 14879 return False; 14880 end if; 14881 end case; 14882 14883 -- Iterate up to the next parent, keeping track of the previous one 14884 14885 Prev_Par := Par; 14886 Par := Parent (Par); 14887 end loop; 14888 14889 return False; 14890 end In_Return_Value; 14891 14892 --------------------- 14893 -- In_Visible_Part -- 14894 --------------------- 14895 14896 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is 14897 begin 14898 return Is_Package_Or_Generic_Package (Scope_Id) 14899 and then In_Open_Scopes (Scope_Id) 14900 and then not In_Package_Body (Scope_Id) 14901 and then not In_Private_Part (Scope_Id); 14902 end In_Visible_Part; 14903 14904 ----------------------------- 14905 -- In_While_Loop_Condition -- 14906 ----------------------------- 14907 14908 function In_While_Loop_Condition (N : Node_Id) return Boolean is 14909 Prev : Node_Id := N; 14910 P : Node_Id := Parent (N); 14911 -- P and Prev will be used for traversing the AST, while maintaining an 14912 -- invariant that P = Parent (Prev). 14913 begin 14914 loop 14915 if No (P) then 14916 return False; 14917 elsif Nkind (P) = N_Iteration_Scheme 14918 and then Prev = Condition (P) 14919 then 14920 return True; 14921 else 14922 Prev := P; 14923 P := Parent (P); 14924 end if; 14925 end loop; 14926 end In_While_Loop_Condition; 14927 14928 -------------------------------- 14929 -- Incomplete_Or_Partial_View -- 14930 -------------------------------- 14931 14932 function Incomplete_Or_Partial_View (Id : Entity_Id) return Entity_Id is 14933 S : constant Entity_Id := Scope (Id); 14934 14935 function Inspect_Decls 14936 (Decls : List_Id; 14937 Taft : Boolean := False) return Entity_Id; 14938 -- Check whether a declarative region contains the incomplete or partial 14939 -- view of Id. 14940 14941 ------------------- 14942 -- Inspect_Decls -- 14943 ------------------- 14944 14945 function Inspect_Decls 14946 (Decls : List_Id; 14947 Taft : Boolean := False) return Entity_Id 14948 is 14949 Decl : Node_Id; 14950 Match : Node_Id; 14951 14952 begin 14953 Decl := First (Decls); 14954 while Present (Decl) loop 14955 Match := Empty; 14956 14957 -- The partial view of a Taft-amendment type is an incomplete 14958 -- type. 14959 14960 if Taft then 14961 if Nkind (Decl) = N_Incomplete_Type_Declaration then 14962 Match := Defining_Identifier (Decl); 14963 end if; 14964 14965 -- Otherwise look for a private type whose full view matches the 14966 -- input type. Note that this checks full_type_declaration nodes 14967 -- to account for derivations from a private type where the type 14968 -- declaration hold the partial view and the full view is an 14969 -- itype. 14970 14971 elsif Nkind (Decl) in N_Full_Type_Declaration 14972 | N_Private_Extension_Declaration 14973 | N_Private_Type_Declaration 14974 then 14975 Match := Defining_Identifier (Decl); 14976 end if; 14977 14978 -- Guard against unanalyzed entities 14979 14980 if Present (Match) 14981 and then Is_Type (Match) 14982 and then Present (Full_View (Match)) 14983 and then Full_View (Match) = Id 14984 then 14985 return Match; 14986 end if; 14987 14988 Next (Decl); 14989 end loop; 14990 14991 return Empty; 14992 end Inspect_Decls; 14993 14994 -- Local variables 14995 14996 Prev : Entity_Id; 14997 14998 -- Start of processing for Incomplete_Or_Partial_View 14999 15000 begin 15001 -- Deferred constant or incomplete type case 15002 15003 Prev := Current_Entity (Id); 15004 15005 while Present (Prev) loop 15006 exit when Scope (Prev) = S; 15007 15008 Prev := Homonym (Prev); 15009 end loop; 15010 15011 if Present (Prev) 15012 and then (Is_Incomplete_Type (Prev) or else Ekind (Prev) = E_Constant) 15013 and then Present (Full_View (Prev)) 15014 and then Full_View (Prev) = Id 15015 then 15016 return Prev; 15017 end if; 15018 15019 -- Private or Taft amendment type case 15020 15021 if Present (S) and then Is_Package_Or_Generic_Package (S) then 15022 declare 15023 Pkg_Decl : constant Node_Id := Package_Specification (S); 15024 15025 begin 15026 -- It is knows that Typ has a private view, look for it in the 15027 -- visible declarations of the enclosing scope. A special case 15028 -- of this is when the two views have been exchanged - the full 15029 -- appears earlier than the private. 15030 15031 if Has_Private_Declaration (Id) then 15032 Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl)); 15033 15034 -- Exchanged view case, look in the private declarations 15035 15036 if No (Prev) then 15037 Prev := Inspect_Decls (Private_Declarations (Pkg_Decl)); 15038 end if; 15039 15040 return Prev; 15041 15042 -- Otherwise if this is the package body, then Typ is a potential 15043 -- Taft amendment type. The incomplete view should be located in 15044 -- the private declarations of the enclosing scope. 15045 15046 elsif In_Package_Body (S) then 15047 return Inspect_Decls (Private_Declarations (Pkg_Decl), True); 15048 end if; 15049 end; 15050 end if; 15051 15052 -- The type has no incomplete or private view 15053 15054 return Empty; 15055 end Incomplete_Or_Partial_View; 15056 15057 --------------------------------------- 15058 -- Incomplete_View_From_Limited_With -- 15059 --------------------------------------- 15060 15061 function Incomplete_View_From_Limited_With 15062 (Typ : Entity_Id) return Entity_Id 15063 is 15064 begin 15065 -- It might make sense to make this an attribute in Einfo, and set it 15066 -- in Sem_Ch10 in Build_Shadow_Entity. However, we're running short on 15067 -- slots for new attributes, and it seems a bit simpler to just search 15068 -- the Limited_View (if it exists) for an incomplete type whose 15069 -- Non_Limited_View is Typ. 15070 15071 if Ekind (Scope (Typ)) = E_Package 15072 and then Present (Limited_View (Scope (Typ))) 15073 then 15074 declare 15075 Ent : Entity_Id := First_Entity (Limited_View (Scope (Typ))); 15076 begin 15077 while Present (Ent) loop 15078 if Is_Incomplete_Type (Ent) 15079 and then Non_Limited_View (Ent) = Typ 15080 then 15081 return Ent; 15082 end if; 15083 15084 Next_Entity (Ent); 15085 end loop; 15086 end; 15087 end if; 15088 15089 return Typ; 15090 end Incomplete_View_From_Limited_With; 15091 15092 ---------------------------------- 15093 -- Indexed_Component_Bit_Offset -- 15094 ---------------------------------- 15095 15096 function Indexed_Component_Bit_Offset (N : Node_Id) return Uint is 15097 Exp : constant Node_Id := First (Expressions (N)); 15098 Typ : constant Entity_Id := Etype (Prefix (N)); 15099 Off : constant Uint := Component_Size (Typ); 15100 Ind : Node_Id; 15101 15102 begin 15103 -- Return early if the component size is not known or variable 15104 15105 if No (Off) or else Off < Uint_0 then 15106 return No_Uint; 15107 end if; 15108 15109 -- Deal with the degenerate case of an empty component 15110 15111 if Off = Uint_0 then 15112 return Off; 15113 end if; 15114 15115 -- Check that both the index value and the low bound are known 15116 15117 if not Compile_Time_Known_Value (Exp) then 15118 return No_Uint; 15119 end if; 15120 15121 Ind := First_Index (Typ); 15122 if No (Ind) then 15123 return No_Uint; 15124 end if; 15125 15126 -- Do not attempt to compute offsets within multi-dimensional arrays 15127 15128 if Present (Next_Index (Ind)) then 15129 return No_Uint; 15130 end if; 15131 15132 if Nkind (Ind) = N_Subtype_Indication then 15133 Ind := Constraint (Ind); 15134 15135 if Nkind (Ind) = N_Range_Constraint then 15136 Ind := Range_Expression (Ind); 15137 end if; 15138 end if; 15139 15140 if Nkind (Ind) /= N_Range 15141 or else not Compile_Time_Known_Value (Low_Bound (Ind)) 15142 then 15143 return No_Uint; 15144 end if; 15145 15146 -- Return the scaled offset 15147 15148 return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound (Ind))); 15149 end Indexed_Component_Bit_Offset; 15150 15151 ----------------------------- 15152 -- Inherit_Predicate_Flags -- 15153 ----------------------------- 15154 15155 procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is 15156 begin 15157 if Ada_Version < Ada_2012 15158 or else Present (Predicate_Function (Subt)) 15159 then 15160 return; 15161 end if; 15162 15163 Set_Has_Predicates (Subt, Has_Predicates (Par)); 15164 Set_Has_Static_Predicate_Aspect 15165 (Subt, Has_Static_Predicate_Aspect (Par)); 15166 Set_Has_Dynamic_Predicate_Aspect 15167 (Subt, Has_Dynamic_Predicate_Aspect (Par)); 15168 15169 -- A named subtype does not inherit the predicate function of its 15170 -- parent but an itype declared for a loop index needs the discrete 15171 -- predicate information of its parent to execute the loop properly. 15172 -- A non-discrete type may has a static predicate (for example True) 15173 -- but has no static_discrete_predicate. 15174 15175 if Is_Itype (Subt) and then Present (Predicate_Function (Par)) then 15176 Set_Subprograms_For_Type (Subt, Subprograms_For_Type (Par)); 15177 15178 if Has_Static_Predicate (Par) and then Is_Discrete_Type (Par) then 15179 Set_Static_Discrete_Predicate 15180 (Subt, Static_Discrete_Predicate (Par)); 15181 end if; 15182 end if; 15183 end Inherit_Predicate_Flags; 15184 15185 ---------------------------- 15186 -- Inherit_Rep_Item_Chain -- 15187 ---------------------------- 15188 15189 procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is 15190 Item : Node_Id; 15191 Next_Item : Node_Id; 15192 15193 begin 15194 -- There are several inheritance scenarios to consider depending on 15195 -- whether both types have rep item chains and whether the destination 15196 -- type already inherits part of the source type's rep item chain. 15197 15198 -- 1) The source type lacks a rep item chain 15199 -- From_Typ ---> Empty 15200 -- 15201 -- Typ --------> Item (or Empty) 15202 15203 -- In this case inheritance cannot take place because there are no items 15204 -- to inherit. 15205 15206 -- 2) The destination type lacks a rep item chain 15207 -- From_Typ ---> Item ---> ... 15208 -- 15209 -- Typ --------> Empty 15210 15211 -- Inheritance takes place by setting the First_Rep_Item of the 15212 -- destination type to the First_Rep_Item of the source type. 15213 -- From_Typ ---> Item ---> ... 15214 -- ^ 15215 -- Typ -----------+ 15216 15217 -- 3.1) Both source and destination types have at least one rep item. 15218 -- The destination type does NOT inherit a rep item from the source 15219 -- type. 15220 -- From_Typ ---> Item ---> Item 15221 -- 15222 -- Typ --------> Item ---> Item 15223 15224 -- Inheritance takes place by setting the Next_Rep_Item of the last item 15225 -- of the destination type to the First_Rep_Item of the source type. 15226 -- From_Typ -------------------> Item ---> Item 15227 -- ^ 15228 -- Typ --------> Item ---> Item --+ 15229 15230 -- 3.2) Both source and destination types have at least one rep item. 15231 -- The destination type DOES inherit part of the rep item chain of the 15232 -- source type. 15233 -- From_Typ ---> Item ---> Item ---> Item 15234 -- ^ 15235 -- Typ --------> Item ------+ 15236 15237 -- This rare case arises when the full view of a private extension must 15238 -- inherit the rep item chain from the full view of its parent type and 15239 -- the full view of the parent type contains extra rep items. Currently 15240 -- only invariants may lead to such form of inheritance. 15241 15242 -- type From_Typ is tagged private 15243 -- with Type_Invariant'Class => Item_2; 15244 15245 -- type Typ is new From_Typ with private 15246 -- with Type_Invariant => Item_4; 15247 15248 -- At this point the rep item chains contain the following items 15249 15250 -- From_Typ -----------> Item_2 ---> Item_3 15251 -- ^ 15252 -- Typ --------> Item_4 --+ 15253 15254 -- The full views of both types may introduce extra invariants 15255 15256 -- type From_Typ is tagged null record 15257 -- with Type_Invariant => Item_1; 15258 15259 -- type Typ is new From_Typ with null record; 15260 15261 -- The full view of Typ would have to inherit any new rep items added to 15262 -- the full view of From_Typ. 15263 15264 -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3 15265 -- ^ 15266 -- Typ --------> Item_4 --+ 15267 15268 -- To achieve this form of inheritance, the destination type must first 15269 -- sever the link between its own rep chain and that of the source type, 15270 -- then inheritance 3.1 takes place. 15271 15272 -- Case 1: The source type lacks a rep item chain 15273 15274 if No (First_Rep_Item (From_Typ)) then 15275 return; 15276 15277 -- Case 2: The destination type lacks a rep item chain 15278 15279 elsif No (First_Rep_Item (Typ)) then 15280 Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ)); 15281 15282 -- Case 3: Both the source and destination types have at least one rep 15283 -- item. Traverse the rep item chain of the destination type to find the 15284 -- last rep item. 15285 15286 else 15287 Item := Empty; 15288 Next_Item := First_Rep_Item (Typ); 15289 while Present (Next_Item) loop 15290 15291 -- Detect a link between the destination type's rep chain and that 15292 -- of the source type. There are two possibilities: 15293 15294 -- Variant 1 15295 -- Next_Item 15296 -- V 15297 -- From_Typ ---> Item_1 ---> 15298 -- ^ 15299 -- Typ -----------+ 15300 -- 15301 -- Item is Empty 15302 15303 -- Variant 2 15304 -- Next_Item 15305 -- V 15306 -- From_Typ ---> Item_1 ---> Item_2 ---> 15307 -- ^ 15308 -- Typ --------> Item_3 ------+ 15309 -- ^ 15310 -- Item 15311 15312 if Present_In_Rep_Item (From_Typ, Next_Item) then 15313 exit; 15314 end if; 15315 15316 Item := Next_Item; 15317 Next_Item := Next_Rep_Item (Next_Item); 15318 end loop; 15319 15320 -- Inherit the source type's rep item chain 15321 15322 if Present (Item) then 15323 Set_Next_Rep_Item (Item, First_Rep_Item (From_Typ)); 15324 else 15325 Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ)); 15326 end if; 15327 end if; 15328 end Inherit_Rep_Item_Chain; 15329 15330 ------------------------------------ 15331 -- Inherits_From_Tagged_Full_View -- 15332 ------------------------------------ 15333 15334 function Inherits_From_Tagged_Full_View (Typ : Entity_Id) return Boolean is 15335 begin 15336 return Is_Private_Type (Typ) 15337 and then Present (Full_View (Typ)) 15338 and then Is_Private_Type (Full_View (Typ)) 15339 and then not Is_Tagged_Type (Full_View (Typ)) 15340 and then Present (Underlying_Type (Full_View (Typ))) 15341 and then Is_Tagged_Type (Underlying_Type (Full_View (Typ))); 15342 end Inherits_From_Tagged_Full_View; 15343 15344 --------------------------------- 15345 -- Insert_Explicit_Dereference -- 15346 --------------------------------- 15347 15348 procedure Insert_Explicit_Dereference (N : Node_Id) is 15349 New_Prefix : constant Node_Id := Relocate_Node (N); 15350 Ent : Entity_Id := Empty; 15351 Pref : Node_Id := Empty; 15352 I : Interp_Index; 15353 It : Interp; 15354 T : Entity_Id; 15355 15356 begin 15357 Save_Interps (N, New_Prefix); 15358 15359 Rewrite (N, 15360 Make_Explicit_Dereference (Sloc (Parent (N)), 15361 Prefix => New_Prefix)); 15362 15363 Set_Etype (N, Designated_Type (Etype (New_Prefix))); 15364 15365 if Is_Overloaded (New_Prefix) then 15366 15367 -- The dereference is also overloaded, and its interpretations are 15368 -- the designated types of the interpretations of the original node. 15369 15370 Set_Etype (N, Any_Type); 15371 15372 Get_First_Interp (New_Prefix, I, It); 15373 while Present (It.Nam) loop 15374 T := It.Typ; 15375 15376 if Is_Access_Type (T) then 15377 Add_One_Interp (N, Designated_Type (T), Designated_Type (T)); 15378 end if; 15379 15380 Get_Next_Interp (I, It); 15381 end loop; 15382 15383 else 15384 -- Prefix is unambiguous: mark the original prefix (which might 15385 -- Come_From_Source) as a reference, since the new (relocated) one 15386 -- won't be taken into account. 15387 15388 if Is_Entity_Name (New_Prefix) then 15389 Ent := Entity (New_Prefix); 15390 Pref := New_Prefix; 15391 15392 -- For a retrieval of a subcomponent of some composite object, 15393 -- retrieve the ultimate entity if there is one. 15394 15395 elsif Nkind (New_Prefix) in N_Selected_Component | N_Indexed_Component 15396 then 15397 Pref := Prefix (New_Prefix); 15398 while Present (Pref) 15399 and then Nkind (Pref) in 15400 N_Selected_Component | N_Indexed_Component 15401 loop 15402 Pref := Prefix (Pref); 15403 end loop; 15404 15405 if Present (Pref) and then Is_Entity_Name (Pref) then 15406 Ent := Entity (Pref); 15407 end if; 15408 end if; 15409 15410 -- Place the reference on the entity node 15411 15412 if Present (Ent) then 15413 Generate_Reference (Ent, Pref); 15414 end if; 15415 end if; 15416 end Insert_Explicit_Dereference; 15417 15418 ------------------------------------------ 15419 -- Inspect_Deferred_Constant_Completion -- 15420 ------------------------------------------ 15421 15422 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is 15423 Decl : Node_Id; 15424 15425 begin 15426 Decl := First (Decls); 15427 while Present (Decl) loop 15428 15429 -- Deferred constant signature 15430 15431 if Nkind (Decl) = N_Object_Declaration 15432 and then Constant_Present (Decl) 15433 and then No (Expression (Decl)) 15434 15435 -- No need to check internally generated constants 15436 15437 and then Comes_From_Source (Decl) 15438 15439 -- The constant is not completed. A full object declaration or a 15440 -- pragma Import complete a deferred constant. 15441 15442 and then not Has_Completion (Defining_Identifier (Decl)) 15443 then 15444 Error_Msg_N 15445 ("constant declaration requires initialization expression", 15446 Defining_Identifier (Decl)); 15447 end if; 15448 15449 Next (Decl); 15450 end loop; 15451 end Inspect_Deferred_Constant_Completion; 15452 15453 ------------------------------- 15454 -- Install_Elaboration_Model -- 15455 ------------------------------- 15456 15457 procedure Install_Elaboration_Model (Unit_Id : Entity_Id) is 15458 function Find_Elaboration_Checks_Pragma (L : List_Id) return Node_Id; 15459 -- Try to find pragma Elaboration_Checks in arbitrary list L. Return 15460 -- Empty if there is no such pragma. 15461 15462 ------------------------------------ 15463 -- Find_Elaboration_Checks_Pragma -- 15464 ------------------------------------ 15465 15466 function Find_Elaboration_Checks_Pragma (L : List_Id) return Node_Id is 15467 Item : Node_Id; 15468 15469 begin 15470 Item := First (L); 15471 while Present (Item) loop 15472 if Nkind (Item) = N_Pragma 15473 and then Pragma_Name (Item) = Name_Elaboration_Checks 15474 then 15475 return Item; 15476 end if; 15477 15478 Next (Item); 15479 end loop; 15480 15481 return Empty; 15482 end Find_Elaboration_Checks_Pragma; 15483 15484 -- Local variables 15485 15486 Args : List_Id; 15487 Model : Node_Id; 15488 Prag : Node_Id; 15489 Unit : Node_Id; 15490 15491 -- Start of processing for Install_Elaboration_Model 15492 15493 begin 15494 -- Nothing to do when the unit does not exist 15495 15496 if No (Unit_Id) then 15497 return; 15498 end if; 15499 15500 Unit := Parent (Unit_Declaration_Node (Unit_Id)); 15501 15502 -- Nothing to do when the unit is not a library unit 15503 15504 if Nkind (Unit) /= N_Compilation_Unit then 15505 return; 15506 end if; 15507 15508 Prag := Find_Elaboration_Checks_Pragma (Context_Items (Unit)); 15509 15510 -- The compilation unit is subject to pragma Elaboration_Checks. Set the 15511 -- elaboration model as specified by the pragma. 15512 15513 if Present (Prag) then 15514 Args := Pragma_Argument_Associations (Prag); 15515 15516 -- Guard against an illegal pragma. The sole argument must be an 15517 -- identifier which specifies either Dynamic or Static model. 15518 15519 if Present (Args) then 15520 Model := Get_Pragma_Arg (First (Args)); 15521 15522 if Nkind (Model) = N_Identifier then 15523 Dynamic_Elaboration_Checks := Chars (Model) = Name_Dynamic; 15524 end if; 15525 end if; 15526 end if; 15527 end Install_Elaboration_Model; 15528 15529 ----------------------------- 15530 -- Install_Generic_Formals -- 15531 ----------------------------- 15532 15533 procedure Install_Generic_Formals (Subp_Id : Entity_Id) is 15534 E : Entity_Id; 15535 15536 begin 15537 pragma Assert (Is_Generic_Subprogram (Subp_Id)); 15538 15539 E := First_Entity (Subp_Id); 15540 while Present (E) loop 15541 Install_Entity (E); 15542 Next_Entity (E); 15543 end loop; 15544 end Install_Generic_Formals; 15545 15546 ------------------------ 15547 -- Install_SPARK_Mode -- 15548 ------------------------ 15549 15550 procedure Install_SPARK_Mode (Mode : SPARK_Mode_Type; Prag : Node_Id) is 15551 begin 15552 SPARK_Mode := Mode; 15553 SPARK_Mode_Pragma := Prag; 15554 end Install_SPARK_Mode; 15555 15556 -------------------------- 15557 -- Invalid_Scalar_Value -- 15558 -------------------------- 15559 15560 function Invalid_Scalar_Value 15561 (Loc : Source_Ptr; 15562 Scal_Typ : Scalar_Id) return Node_Id 15563 is 15564 function Invalid_Binder_Value return Node_Id; 15565 -- Return a reference to the corresponding invalid value for type 15566 -- Scal_Typ as defined in unit System.Scalar_Values. 15567 15568 function Invalid_Float_Value return Node_Id; 15569 -- Return the invalid value of float type Scal_Typ 15570 15571 function Invalid_Integer_Value return Node_Id; 15572 -- Return the invalid value of integer type Scal_Typ 15573 15574 procedure Set_Invalid_Binder_Values; 15575 -- Set the contents of collection Invalid_Binder_Values 15576 15577 -------------------------- 15578 -- Invalid_Binder_Value -- 15579 -------------------------- 15580 15581 function Invalid_Binder_Value return Node_Id is 15582 Val_Id : Entity_Id; 15583 15584 begin 15585 -- Initialize the collection of invalid binder values the first time 15586 -- around. 15587 15588 Set_Invalid_Binder_Values; 15589 15590 -- Obtain the corresponding variable from System.Scalar_Values which 15591 -- holds the invalid value for this type. 15592 15593 Val_Id := Invalid_Binder_Values (Scal_Typ); 15594 pragma Assert (Present (Val_Id)); 15595 15596 return New_Occurrence_Of (Val_Id, Loc); 15597 end Invalid_Binder_Value; 15598 15599 ------------------------- 15600 -- Invalid_Float_Value -- 15601 ------------------------- 15602 15603 function Invalid_Float_Value return Node_Id is 15604 Value : constant Ureal := Invalid_Floats (Scal_Typ); 15605 15606 begin 15607 -- Pragma Invalid_Scalars did not specify an invalid value for this 15608 -- type. Fall back to the value provided by the binder. 15609 15610 if Value = No_Ureal then 15611 return Invalid_Binder_Value; 15612 else 15613 return Make_Real_Literal (Loc, Realval => Value); 15614 end if; 15615 end Invalid_Float_Value; 15616 15617 --------------------------- 15618 -- Invalid_Integer_Value -- 15619 --------------------------- 15620 15621 function Invalid_Integer_Value return Node_Id is 15622 Value : constant Uint := Invalid_Integers (Scal_Typ); 15623 15624 begin 15625 -- Pragma Invalid_Scalars did not specify an invalid value for this 15626 -- type. Fall back to the value provided by the binder. 15627 15628 if No (Value) then 15629 return Invalid_Binder_Value; 15630 else 15631 return Make_Integer_Literal (Loc, Intval => Value); 15632 end if; 15633 end Invalid_Integer_Value; 15634 15635 ------------------------------- 15636 -- Set_Invalid_Binder_Values -- 15637 ------------------------------- 15638 15639 procedure Set_Invalid_Binder_Values is 15640 begin 15641 if not Invalid_Binder_Values_Set then 15642 Invalid_Binder_Values_Set := True; 15643 15644 -- Initialize the contents of the collection once since RTE calls 15645 -- are not cheap. 15646 15647 Invalid_Binder_Values := 15648 (Name_Short_Float => RTE (RE_IS_Isf), 15649 Name_Float => RTE (RE_IS_Ifl), 15650 Name_Long_Float => RTE (RE_IS_Ilf), 15651 Name_Long_Long_Float => RTE (RE_IS_Ill), 15652 Name_Signed_8 => RTE (RE_IS_Is1), 15653 Name_Signed_16 => RTE (RE_IS_Is2), 15654 Name_Signed_32 => RTE (RE_IS_Is4), 15655 Name_Signed_64 => RTE (RE_IS_Is8), 15656 Name_Signed_128 => Empty, 15657 Name_Unsigned_8 => RTE (RE_IS_Iu1), 15658 Name_Unsigned_16 => RTE (RE_IS_Iu2), 15659 Name_Unsigned_32 => RTE (RE_IS_Iu4), 15660 Name_Unsigned_64 => RTE (RE_IS_Iu8), 15661 Name_Unsigned_128 => Empty); 15662 15663 if System_Max_Integer_Size < 128 then 15664 Invalid_Binder_Values (Name_Signed_128) := RTE (RE_IS_Is8); 15665 Invalid_Binder_Values (Name_Unsigned_128) := RTE (RE_IS_Iu8); 15666 else 15667 Invalid_Binder_Values (Name_Signed_128) := RTE (RE_IS_Is16); 15668 Invalid_Binder_Values (Name_Unsigned_128) := RTE (RE_IS_Iu16); 15669 end if; 15670 end if; 15671 end Set_Invalid_Binder_Values; 15672 15673 -- Start of processing for Invalid_Scalar_Value 15674 15675 begin 15676 if Scal_Typ in Float_Scalar_Id then 15677 return Invalid_Float_Value; 15678 15679 else pragma Assert (Scal_Typ in Integer_Scalar_Id); 15680 return Invalid_Integer_Value; 15681 end if; 15682 end Invalid_Scalar_Value; 15683 15684 -------------------------------- 15685 -- Is_Anonymous_Access_Actual -- 15686 -------------------------------- 15687 15688 function Is_Anonymous_Access_Actual (N : Node_Id) return Boolean is 15689 Par : Node_Id; 15690 begin 15691 if Ekind (Etype (N)) /= E_Anonymous_Access_Type then 15692 return False; 15693 end if; 15694 15695 Par := Parent (N); 15696 while Present (Par) 15697 and then Nkind (Par) in N_Case_Expression 15698 | N_If_Expression 15699 | N_Parameter_Association 15700 loop 15701 Par := Parent (Par); 15702 end loop; 15703 return Nkind (Par) in N_Subprogram_Call; 15704 end Is_Anonymous_Access_Actual; 15705 15706 ------------------------ 15707 -- Is_Access_Variable -- 15708 ------------------------ 15709 15710 function Is_Access_Variable (E : Entity_Id) return Boolean is 15711 begin 15712 return Is_Access_Type (E) 15713 and then not Is_Access_Constant (E) 15714 and then Ekind (Directly_Designated_Type (E)) /= E_Subprogram_Type; 15715 end Is_Access_Variable; 15716 15717 ----------------------------- 15718 -- Is_Actual_Out_Parameter -- 15719 ----------------------------- 15720 15721 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is 15722 Formal : Entity_Id; 15723 Call : Node_Id; 15724 begin 15725 Find_Actual (N, Formal, Call); 15726 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter; 15727 end Is_Actual_Out_Parameter; 15728 15729 -------------------------------- 15730 -- Is_Actual_In_Out_Parameter -- 15731 -------------------------------- 15732 15733 function Is_Actual_In_Out_Parameter (N : Node_Id) return Boolean is 15734 Formal : Entity_Id; 15735 Call : Node_Id; 15736 begin 15737 Find_Actual (N, Formal, Call); 15738 return Present (Formal) and then Ekind (Formal) = E_In_Out_Parameter; 15739 end Is_Actual_In_Out_Parameter; 15740 15741 --------------------------------------- 15742 -- Is_Actual_Out_Or_In_Out_Parameter -- 15743 --------------------------------------- 15744 15745 function Is_Actual_Out_Or_In_Out_Parameter (N : Node_Id) return Boolean is 15746 Formal : Entity_Id; 15747 Call : Node_Id; 15748 begin 15749 Find_Actual (N, Formal, Call); 15750 return Present (Formal) 15751 and then Ekind (Formal) in E_Out_Parameter | E_In_Out_Parameter; 15752 end Is_Actual_Out_Or_In_Out_Parameter; 15753 15754 ------------------------- 15755 -- Is_Actual_Parameter -- 15756 ------------------------- 15757 15758 function Is_Actual_Parameter (N : Node_Id) return Boolean is 15759 PK : constant Node_Kind := Nkind (Parent (N)); 15760 15761 begin 15762 case PK is 15763 when N_Parameter_Association => 15764 return N = Explicit_Actual_Parameter (Parent (N)); 15765 15766 when N_Entry_Call_Statement 15767 | N_Subprogram_Call 15768 => 15769 return Is_List_Member (N) 15770 and then 15771 List_Containing (N) = Parameter_Associations (Parent (N)); 15772 15773 when others => 15774 return False; 15775 end case; 15776 end Is_Actual_Parameter; 15777 15778 -------------------------------- 15779 -- Is_Actual_Tagged_Parameter -- 15780 -------------------------------- 15781 15782 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is 15783 Formal : Entity_Id; 15784 Call : Node_Id; 15785 begin 15786 Find_Actual (N, Formal, Call); 15787 return Present (Formal) and then Is_Tagged_Type (Etype (Formal)); 15788 end Is_Actual_Tagged_Parameter; 15789 15790 --------------------- 15791 -- Is_Aliased_View -- 15792 --------------------- 15793 15794 function Is_Aliased_View (Obj : Node_Id) return Boolean is 15795 E : Entity_Id; 15796 15797 begin 15798 if Is_Entity_Name (Obj) then 15799 E := Entity (Obj); 15800 15801 return 15802 (Is_Object (E) 15803 and then 15804 (Is_Aliased (E) 15805 or else (Present (Renamed_Object (E)) 15806 and then Is_Aliased_View (Renamed_Object (E))))) 15807 15808 or else ((Is_Formal (E) or else Is_Formal_Object (E)) 15809 and then Is_Tagged_Type (Etype (E))) 15810 15811 or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E)) 15812 15813 -- Current instance of type, either directly or as rewritten 15814 -- reference to the current object. 15815 15816 or else (Is_Entity_Name (Original_Node (Obj)) 15817 and then Present (Entity (Original_Node (Obj))) 15818 and then Is_Type (Entity (Original_Node (Obj)))) 15819 15820 or else (Is_Type (E) and then E = Current_Scope) 15821 15822 or else (Is_Incomplete_Or_Private_Type (E) 15823 and then Full_View (E) = Current_Scope) 15824 15825 -- Ada 2012 AI05-0053: the return object of an extended return 15826 -- statement is aliased if its type is immutably limited. 15827 15828 or else (Is_Return_Object (E) 15829 and then Is_Limited_View (Etype (E))) 15830 15831 -- The current instance of a limited type is aliased, so 15832 -- we want to allow uses of T'Access in the init proc for 15833 -- a limited type T. However, we don't want to mark the formal 15834 -- parameter as being aliased since that could impact callers. 15835 15836 or else (Is_Formal (E) 15837 and then Chars (E) = Name_uInit 15838 and then Is_Limited_View (Etype (E))); 15839 15840 elsif Nkind (Obj) = N_Selected_Component then 15841 return Is_Aliased (Entity (Selector_Name (Obj))); 15842 15843 elsif Nkind (Obj) = N_Indexed_Component then 15844 return Has_Aliased_Components (Etype (Prefix (Obj))) 15845 or else 15846 (Is_Access_Type (Etype (Prefix (Obj))) 15847 and then Has_Aliased_Components 15848 (Designated_Type (Etype (Prefix (Obj))))); 15849 15850 elsif Nkind (Obj) in N_Unchecked_Type_Conversion | N_Type_Conversion then 15851 return Is_Tagged_Type (Etype (Obj)) 15852 and then Is_Aliased_View (Expression (Obj)); 15853 15854 -- Ada 2022 AI12-0228 15855 15856 elsif Nkind (Obj) = N_Qualified_Expression 15857 and then Ada_Version >= Ada_2012 15858 then 15859 return Is_Aliased_View (Expression (Obj)); 15860 15861 elsif Nkind (Obj) = N_Explicit_Dereference then 15862 return Nkind (Original_Node (Obj)) /= N_Function_Call; 15863 15864 else 15865 return False; 15866 end if; 15867 end Is_Aliased_View; 15868 15869 ------------------------- 15870 -- Is_Ancestor_Package -- 15871 ------------------------- 15872 15873 function Is_Ancestor_Package 15874 (E1 : Entity_Id; 15875 E2 : Entity_Id) return Boolean 15876 is 15877 Par : Entity_Id; 15878 15879 begin 15880 Par := E2; 15881 while Present (Par) and then Par /= Standard_Standard loop 15882 if Par = E1 then 15883 return True; 15884 end if; 15885 15886 Par := Scope (Par); 15887 end loop; 15888 15889 return False; 15890 end Is_Ancestor_Package; 15891 15892 ---------------------- 15893 -- Is_Atomic_Object -- 15894 ---------------------- 15895 15896 function Is_Atomic_Object (N : Node_Id) return Boolean is 15897 function Prefix_Has_Atomic_Components (P : Node_Id) return Boolean; 15898 -- Determine whether prefix P has atomic components. This requires the 15899 -- presence of an Atomic_Components aspect/pragma. 15900 15901 --------------------------------- 15902 -- Prefix_Has_Atomic_Components -- 15903 --------------------------------- 15904 15905 function Prefix_Has_Atomic_Components (P : Node_Id) return Boolean is 15906 Typ : constant Entity_Id := Etype (P); 15907 15908 begin 15909 if Is_Access_Type (Typ) then 15910 return Has_Atomic_Components (Designated_Type (Typ)); 15911 15912 elsif Has_Atomic_Components (Typ) then 15913 return True; 15914 15915 elsif Is_Entity_Name (P) 15916 and then Has_Atomic_Components (Entity (P)) 15917 then 15918 return True; 15919 15920 else 15921 return False; 15922 end if; 15923 end Prefix_Has_Atomic_Components; 15924 15925 -- Start of processing for Is_Atomic_Object 15926 15927 begin 15928 if Is_Entity_Name (N) then 15929 return Is_Atomic_Object_Entity (Entity (N)); 15930 15931 elsif Is_Atomic (Etype (N)) then 15932 return True; 15933 15934 elsif Nkind (N) = N_Indexed_Component then 15935 return Prefix_Has_Atomic_Components (Prefix (N)); 15936 15937 elsif Nkind (N) = N_Selected_Component then 15938 return Is_Atomic (Entity (Selector_Name (N))); 15939 15940 else 15941 return False; 15942 end if; 15943 end Is_Atomic_Object; 15944 15945 ----------------------------- 15946 -- Is_Atomic_Object_Entity -- 15947 ----------------------------- 15948 15949 function Is_Atomic_Object_Entity (Id : Entity_Id) return Boolean is 15950 begin 15951 return 15952 Is_Object (Id) 15953 and then (Is_Atomic (Id) or else Is_Atomic (Etype (Id))); 15954 end Is_Atomic_Object_Entity; 15955 15956 ----------------------------- 15957 -- Is_Attribute_Loop_Entry -- 15958 ----------------------------- 15959 15960 function Is_Attribute_Loop_Entry (N : Node_Id) return Boolean is 15961 begin 15962 return Nkind (N) = N_Attribute_Reference 15963 and then Attribute_Name (N) = Name_Loop_Entry; 15964 end Is_Attribute_Loop_Entry; 15965 15966 ---------------------- 15967 -- Is_Attribute_Old -- 15968 ---------------------- 15969 15970 function Is_Attribute_Old (N : Node_Id) return Boolean is 15971 begin 15972 return Nkind (N) = N_Attribute_Reference 15973 and then Attribute_Name (N) = Name_Old; 15974 end Is_Attribute_Old; 15975 15976 ------------------------- 15977 -- Is_Attribute_Result -- 15978 ------------------------- 15979 15980 function Is_Attribute_Result (N : Node_Id) return Boolean is 15981 begin 15982 return Nkind (N) = N_Attribute_Reference 15983 and then Attribute_Name (N) = Name_Result; 15984 end Is_Attribute_Result; 15985 15986 ------------------------- 15987 -- Is_Attribute_Update -- 15988 ------------------------- 15989 15990 function Is_Attribute_Update (N : Node_Id) return Boolean is 15991 begin 15992 return Nkind (N) = N_Attribute_Reference 15993 and then Attribute_Name (N) = Name_Update; 15994 end Is_Attribute_Update; 15995 15996 ------------------------------------ 15997 -- Is_Body_Or_Package_Declaration -- 15998 ------------------------------------ 15999 16000 function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is 16001 begin 16002 return Is_Body (N) or else Nkind (N) = N_Package_Declaration; 16003 end Is_Body_Or_Package_Declaration; 16004 16005 ----------------------- 16006 -- Is_Bounded_String -- 16007 ----------------------- 16008 16009 function Is_Bounded_String (T : Entity_Id) return Boolean is 16010 Under : constant Entity_Id := Underlying_Type (Root_Type (T)); 16011 16012 begin 16013 -- Check whether T is ultimately derived from Ada.Strings.Superbounded. 16014 -- Super_String, or one of the [Wide_]Wide_ versions. This will 16015 -- be True for all the Bounded_String types in instances of the 16016 -- Generic_Bounded_Length generics, and for types derived from those. 16017 16018 return Present (Under) 16019 and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else 16020 Is_RTE (Root_Type (Under), RO_WI_Super_String) or else 16021 Is_RTE (Root_Type (Under), RO_WW_Super_String)); 16022 end Is_Bounded_String; 16023 16024 ------------------------------- 16025 -- Is_By_Protected_Procedure -- 16026 ------------------------------- 16027 16028 function Is_By_Protected_Procedure (Id : Entity_Id) return Boolean is 16029 begin 16030 return Ekind (Id) = E_Procedure 16031 and then Present (Get_Rep_Pragma (Id, Name_Implemented)) 16032 and then Implementation_Kind (Id) = Name_By_Protected_Procedure; 16033 end Is_By_Protected_Procedure; 16034 16035 --------------------- 16036 -- Is_CCT_Instance -- 16037 --------------------- 16038 16039 function Is_CCT_Instance 16040 (Ref_Id : Entity_Id; 16041 Context_Id : Entity_Id) return Boolean 16042 is 16043 begin 16044 pragma Assert (Ekind (Ref_Id) in E_Protected_Type | E_Task_Type); 16045 16046 if Is_Single_Task_Object (Context_Id) then 16047 return Scope_Within_Or_Same (Etype (Context_Id), Ref_Id); 16048 16049 else 16050 pragma Assert 16051 (Ekind (Context_Id) in 16052 E_Entry | E_Entry_Family | E_Function | E_Package | 16053 E_Procedure | E_Protected_Type | E_Task_Type 16054 or else Is_Record_Type (Context_Id)); 16055 return Scope_Within_Or_Same (Context_Id, Ref_Id); 16056 end if; 16057 end Is_CCT_Instance; 16058 16059 ------------------------- 16060 -- Is_Child_Or_Sibling -- 16061 ------------------------- 16062 16063 function Is_Child_Or_Sibling 16064 (Pack_1 : Entity_Id; 16065 Pack_2 : Entity_Id) return Boolean 16066 is 16067 function Distance_From_Standard (Pack : Entity_Id) return Nat; 16068 -- Given an arbitrary package, return the number of "climbs" necessary 16069 -- to reach scope Standard_Standard. 16070 16071 procedure Equalize_Depths 16072 (Pack : in out Entity_Id; 16073 Depth : in out Nat; 16074 Depth_To_Reach : Nat); 16075 -- Given an arbitrary package, its depth and a target depth to reach, 16076 -- climb the scope chain until the said depth is reached. The pointer 16077 -- to the package and its depth a modified during the climb. 16078 16079 ---------------------------- 16080 -- Distance_From_Standard -- 16081 ---------------------------- 16082 16083 function Distance_From_Standard (Pack : Entity_Id) return Nat is 16084 Dist : Nat; 16085 Scop : Entity_Id; 16086 16087 begin 16088 Dist := 0; 16089 Scop := Pack; 16090 while Present (Scop) and then Scop /= Standard_Standard loop 16091 Dist := Dist + 1; 16092 Scop := Scope (Scop); 16093 end loop; 16094 16095 return Dist; 16096 end Distance_From_Standard; 16097 16098 --------------------- 16099 -- Equalize_Depths -- 16100 --------------------- 16101 16102 procedure Equalize_Depths 16103 (Pack : in out Entity_Id; 16104 Depth : in out Nat; 16105 Depth_To_Reach : Nat) 16106 is 16107 begin 16108 -- The package must be at a greater or equal depth 16109 16110 if Depth < Depth_To_Reach then 16111 raise Program_Error; 16112 end if; 16113 16114 -- Climb the scope chain until the desired depth is reached 16115 16116 while Present (Pack) and then Depth /= Depth_To_Reach loop 16117 Pack := Scope (Pack); 16118 Depth := Depth - 1; 16119 end loop; 16120 end Equalize_Depths; 16121 16122 -- Local variables 16123 16124 P_1 : Entity_Id := Pack_1; 16125 P_1_Child : Boolean := False; 16126 P_1_Depth : Nat := Distance_From_Standard (P_1); 16127 P_2 : Entity_Id := Pack_2; 16128 P_2_Child : Boolean := False; 16129 P_2_Depth : Nat := Distance_From_Standard (P_2); 16130 16131 -- Start of processing for Is_Child_Or_Sibling 16132 16133 begin 16134 pragma Assert 16135 (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package); 16136 16137 -- Both packages denote the same entity, therefore they cannot be 16138 -- children or siblings. 16139 16140 if P_1 = P_2 then 16141 return False; 16142 16143 -- One of the packages is at a deeper level than the other. Note that 16144 -- both may still come from different hierarchies. 16145 16146 -- (root) P_2 16147 -- / \ : 16148 -- X P_2 or X 16149 -- : : 16150 -- P_1 P_1 16151 16152 elsif P_1_Depth > P_2_Depth then 16153 Equalize_Depths 16154 (Pack => P_1, 16155 Depth => P_1_Depth, 16156 Depth_To_Reach => P_2_Depth); 16157 P_1_Child := True; 16158 16159 -- (root) P_1 16160 -- / \ : 16161 -- P_1 X or X 16162 -- : : 16163 -- P_2 P_2 16164 16165 elsif P_2_Depth > P_1_Depth then 16166 Equalize_Depths 16167 (Pack => P_2, 16168 Depth => P_2_Depth, 16169 Depth_To_Reach => P_1_Depth); 16170 P_2_Child := True; 16171 end if; 16172 16173 -- At this stage the package pointers have been elevated to the same 16174 -- depth. If the related entities are the same, then one package is a 16175 -- potential child of the other: 16176 16177 -- P_1 16178 -- : 16179 -- X became P_1 P_2 or vice versa 16180 -- : 16181 -- P_2 16182 16183 if P_1 = P_2 then 16184 if P_1_Child then 16185 return Is_Child_Unit (Pack_1); 16186 16187 else pragma Assert (P_2_Child); 16188 return Is_Child_Unit (Pack_2); 16189 end if; 16190 16191 -- The packages may come from the same package chain or from entirely 16192 -- different hierarcies. To determine this, climb the scope stack until 16193 -- a common root is found. 16194 16195 -- (root) (root 1) (root 2) 16196 -- / \ | | 16197 -- P_1 P_2 P_1 P_2 16198 16199 else 16200 while Present (P_1) and then Present (P_2) loop 16201 16202 -- The two packages may be siblings 16203 16204 if P_1 = P_2 then 16205 return Is_Child_Unit (Pack_1) and then Is_Child_Unit (Pack_2); 16206 end if; 16207 16208 P_1 := Scope (P_1); 16209 P_2 := Scope (P_2); 16210 end loop; 16211 end if; 16212 16213 return False; 16214 end Is_Child_Or_Sibling; 16215 16216 ------------------- 16217 -- Is_Confirming -- 16218 ------------------- 16219 16220 function Is_Confirming (Aspect : Nonoverridable_Aspect_Id; 16221 Aspect_Spec_1, Aspect_Spec_2 : Node_Id) 16222 return Boolean is 16223 function Names_Match (Nm1, Nm2 : Node_Id) return Boolean; 16224 16225 ----------------- 16226 -- Names_Match -- 16227 ----------------- 16228 16229 function Names_Match (Nm1, Nm2 : Node_Id) return Boolean is 16230 begin 16231 if Nkind (Nm1) /= Nkind (Nm2) then 16232 return False; 16233 -- This may be too restrictive given that visibility 16234 -- may allow an identifier in one case and an expanded 16235 -- name in the other. 16236 end if; 16237 case Nkind (Nm1) is 16238 when N_Identifier => 16239 return Name_Equals (Chars (Nm1), Chars (Nm2)); 16240 16241 when N_Expanded_Name => 16242 -- An inherited operation has the same name as its 16243 -- ancestor, but they may have different scopes. 16244 -- This may be too permissive for Iterator_Element, which 16245 -- is intended to be identical in parent and derived type. 16246 16247 return Names_Match (Selector_Name (Nm1), 16248 Selector_Name (Nm2)); 16249 16250 when N_Empty => 16251 return True; -- needed for Aggregate aspect checking 16252 16253 when others => 16254 -- e.g., 'Class attribute references 16255 if Is_Entity_Name (Nm1) and Is_Entity_Name (Nm2) then 16256 return Entity (Nm1) = Entity (Nm2); 16257 end if; 16258 16259 raise Program_Error; 16260 end case; 16261 end Names_Match; 16262 begin 16263 -- allow users to disable "shall be confirming" check, at least for now 16264 if Relaxed_RM_Semantics then 16265 return True; 16266 end if; 16267 16268 -- ??? Type conversion here (along with "when others =>" below) is a 16269 -- workaround for a bootstrapping problem related to casing on a 16270 -- static-predicate-bearing subtype. 16271 16272 case Aspect_Id (Aspect) is 16273 -- name-valued aspects; compare text of names, not resolution. 16274 when Aspect_Default_Iterator 16275 | Aspect_Iterator_Element 16276 | Aspect_Constant_Indexing 16277 | Aspect_Variable_Indexing => 16278 declare 16279 Item_1 : constant Node_Id := Aspect_Rep_Item (Aspect_Spec_1); 16280 Item_2 : constant Node_Id := Aspect_Rep_Item (Aspect_Spec_2); 16281 begin 16282 if (Nkind (Item_1) /= N_Attribute_Definition_Clause) 16283 or (Nkind (Item_2) /= N_Attribute_Definition_Clause) 16284 then 16285 pragma Assert (Serious_Errors_Detected > 0); 16286 return True; 16287 end if; 16288 16289 return Names_Match (Expression (Item_1), 16290 Expression (Item_2)); 16291 end; 16292 16293 -- A confirming aspect for Implicit_Derenfence on a derived type 16294 -- has already been checked in Analyze_Aspect_Implicit_Dereference, 16295 -- including the presence of renamed discriminants. 16296 16297 when Aspect_Implicit_Dereference => 16298 return True; 16299 16300 -- one of a kind 16301 when Aspect_Aggregate => 16302 declare 16303 Empty_1, 16304 Add_Named_1, 16305 Add_Unnamed_1, 16306 New_Indexed_1, 16307 Assign_Indexed_1, 16308 Empty_2, 16309 Add_Named_2, 16310 Add_Unnamed_2, 16311 New_Indexed_2, 16312 Assign_Indexed_2 : Node_Id := Empty; 16313 begin 16314 Parse_Aspect_Aggregate 16315 (N => Expression (Aspect_Spec_1), 16316 Empty_Subp => Empty_1, 16317 Add_Named_Subp => Add_Named_1, 16318 Add_Unnamed_Subp => Add_Unnamed_1, 16319 New_Indexed_Subp => New_Indexed_1, 16320 Assign_Indexed_Subp => Assign_Indexed_1); 16321 Parse_Aspect_Aggregate 16322 (N => Expression (Aspect_Spec_2), 16323 Empty_Subp => Empty_2, 16324 Add_Named_Subp => Add_Named_2, 16325 Add_Unnamed_Subp => Add_Unnamed_2, 16326 New_Indexed_Subp => New_Indexed_2, 16327 Assign_Indexed_Subp => Assign_Indexed_2); 16328 return 16329 Names_Match (Empty_1, Empty_2) and then 16330 Names_Match (Add_Named_1, Add_Named_2) and then 16331 Names_Match (Add_Unnamed_1, Add_Unnamed_2) and then 16332 Names_Match (New_Indexed_1, New_Indexed_2) and then 16333 Names_Match (Assign_Indexed_1, Assign_Indexed_2); 16334 end; 16335 16336 -- Checking for this aspect is performed elsewhere during freezing 16337 when Aspect_No_Controlled_Parts => 16338 return True; 16339 16340 -- scalar-valued aspects; compare (static) values. 16341 when Aspect_Max_Entry_Queue_Length => 16342 -- This should be unreachable. Max_Entry_Queue_Length is 16343 -- supported only for protected entries, not for types. 16344 pragma Assert (Serious_Errors_Detected /= 0); 16345 return True; 16346 16347 when others => 16348 raise Program_Error; 16349 end case; 16350 end Is_Confirming; 16351 16352 ----------------------------- 16353 -- Is_Concurrent_Interface -- 16354 ----------------------------- 16355 16356 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is 16357 begin 16358 return Is_Protected_Interface (T) 16359 or else Is_Synchronized_Interface (T) 16360 or else Is_Task_Interface (T); 16361 end Is_Concurrent_Interface; 16362 16363 ------------------------------------------------------ 16364 -- Is_Conjunction_Of_Formal_Preelab_Init_Attributes -- 16365 ------------------------------------------------------ 16366 16367 function Is_Conjunction_Of_Formal_Preelab_Init_Attributes 16368 (Expr : Node_Id) return Boolean 16369 is 16370 16371 function Is_Formal_Preelab_Init_Attribute 16372 (N : Node_Id) return Boolean; 16373 -- Returns True if N is a Preelaborable_Initialization attribute 16374 -- applied to a generic formal type, or N's Original_Node is such 16375 -- an attribute. 16376 16377 -------------------------------------- 16378 -- Is_Formal_Preelab_Init_Attribute -- 16379 -------------------------------------- 16380 16381 function Is_Formal_Preelab_Init_Attribute 16382 (N : Node_Id) return Boolean 16383 is 16384 Orig_N : constant Node_Id := Original_Node (N); 16385 16386 begin 16387 return Nkind (Orig_N) = N_Attribute_Reference 16388 and then Attribute_Name (Orig_N) = Name_Preelaborable_Initialization 16389 and then Is_Entity_Name (Prefix (Orig_N)) 16390 and then Is_Generic_Type (Entity (Prefix (Orig_N))); 16391 end Is_Formal_Preelab_Init_Attribute; 16392 16393 -- Start of Is_Conjunction_Of_Formal_Preelab_Init_Attributes 16394 16395 begin 16396 return Is_Formal_Preelab_Init_Attribute (Expr) 16397 or else (Nkind (Expr) = N_Op_And 16398 and then 16399 Is_Conjunction_Of_Formal_Preelab_Init_Attributes 16400 (Left_Opnd (Expr)) 16401 and then 16402 Is_Conjunction_Of_Formal_Preelab_Init_Attributes 16403 (Right_Opnd (Expr))); 16404 end Is_Conjunction_Of_Formal_Preelab_Init_Attributes; 16405 16406 ----------------------- 16407 -- Is_Constant_Bound -- 16408 ----------------------- 16409 16410 function Is_Constant_Bound (Exp : Node_Id) return Boolean is 16411 begin 16412 if Compile_Time_Known_Value (Exp) then 16413 return True; 16414 16415 elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then 16416 return Is_Constant_Object (Entity (Exp)) 16417 or else Ekind (Entity (Exp)) = E_Enumeration_Literal; 16418 16419 elsif Nkind (Exp) in N_Binary_Op then 16420 return Is_Constant_Bound (Left_Opnd (Exp)) 16421 and then Is_Constant_Bound (Right_Opnd (Exp)) 16422 and then Scope (Entity (Exp)) = Standard_Standard; 16423 16424 else 16425 return False; 16426 end if; 16427 end Is_Constant_Bound; 16428 16429 --------------------------- 16430 -- Is_Container_Element -- 16431 --------------------------- 16432 16433 function Is_Container_Element (Exp : Node_Id) return Boolean is 16434 Loc : constant Source_Ptr := Sloc (Exp); 16435 Pref : constant Node_Id := Prefix (Exp); 16436 16437 Call : Node_Id; 16438 -- Call to an indexing aspect 16439 16440 Cont_Typ : Entity_Id; 16441 -- The type of the container being accessed 16442 16443 Elem_Typ : Entity_Id; 16444 -- Its element type 16445 16446 Indexing : Entity_Id; 16447 Is_Const : Boolean; 16448 -- Indicates that constant indexing is used, and the element is thus 16449 -- a constant. 16450 16451 Ref_Typ : Entity_Id; 16452 -- The reference type returned by the indexing operation 16453 16454 begin 16455 -- If C is a container, in a context that imposes the element type of 16456 -- that container, the indexing notation C (X) is rewritten as: 16457 16458 -- Indexing (C, X).Discr.all 16459 16460 -- where Indexing is one of the indexing aspects of the container. 16461 -- If the context does not require a reference, the construct can be 16462 -- rewritten as 16463 16464 -- Element (C, X) 16465 16466 -- First, verify that the construct has the proper form 16467 16468 if not Expander_Active then 16469 return False; 16470 16471 elsif Nkind (Pref) /= N_Selected_Component then 16472 return False; 16473 16474 elsif Nkind (Prefix (Pref)) /= N_Function_Call then 16475 return False; 16476 16477 else 16478 Call := Prefix (Pref); 16479 Ref_Typ := Etype (Call); 16480 end if; 16481 16482 if not Has_Implicit_Dereference (Ref_Typ) 16483 or else No (First (Parameter_Associations (Call))) 16484 or else not Is_Entity_Name (Name (Call)) 16485 then 16486 return False; 16487 end if; 16488 16489 -- Retrieve type of container object, and its iterator aspects 16490 16491 Cont_Typ := Etype (First (Parameter_Associations (Call))); 16492 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Constant_Indexing); 16493 Is_Const := False; 16494 16495 if No (Indexing) then 16496 16497 -- Container should have at least one indexing operation 16498 16499 return False; 16500 16501 elsif Entity (Name (Call)) /= Entity (Indexing) then 16502 16503 -- This may be a variable indexing operation 16504 16505 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Variable_Indexing); 16506 16507 if No (Indexing) 16508 or else Entity (Name (Call)) /= Entity (Indexing) 16509 then 16510 return False; 16511 end if; 16512 16513 else 16514 Is_Const := True; 16515 end if; 16516 16517 Elem_Typ := Find_Value_Of_Aspect (Cont_Typ, Aspect_Iterator_Element); 16518 16519 if No (Elem_Typ) or else Entity (Elem_Typ) /= Etype (Exp) then 16520 return False; 16521 end if; 16522 16523 -- Check that the expression is not the target of an assignment, in 16524 -- which case the rewriting is not possible. 16525 16526 if not Is_Const then 16527 declare 16528 Par : Node_Id; 16529 16530 begin 16531 Par := Exp; 16532 while Present (Par) 16533 loop 16534 if Nkind (Parent (Par)) = N_Assignment_Statement 16535 and then Par = Name (Parent (Par)) 16536 then 16537 return False; 16538 16539 -- A renaming produces a reference, and the transformation 16540 -- does not apply. 16541 16542 elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then 16543 return False; 16544 16545 elsif Nkind (Parent (Par)) in 16546 N_Function_Call | 16547 N_Procedure_Call_Statement | 16548 N_Entry_Call_Statement 16549 then 16550 -- Check that the element is not part of an actual for an 16551 -- in-out parameter. 16552 16553 declare 16554 F : Entity_Id; 16555 A : Node_Id; 16556 16557 begin 16558 F := First_Formal (Entity (Name (Parent (Par)))); 16559 A := First (Parameter_Associations (Parent (Par))); 16560 while Present (F) loop 16561 if A = Par and then Ekind (F) /= E_In_Parameter then 16562 return False; 16563 end if; 16564 16565 Next_Formal (F); 16566 Next (A); 16567 end loop; 16568 end; 16569 16570 -- E_In_Parameter in a call: element is not modified. 16571 16572 exit; 16573 end if; 16574 16575 Par := Parent (Par); 16576 end loop; 16577 end; 16578 end if; 16579 16580 -- The expression has the proper form and the context requires the 16581 -- element type. Retrieve the Element function of the container and 16582 -- rewrite the construct as a call to it. 16583 16584 declare 16585 Op : Elmt_Id; 16586 16587 begin 16588 Op := First_Elmt (Primitive_Operations (Cont_Typ)); 16589 while Present (Op) loop 16590 exit when Chars (Node (Op)) = Name_Element; 16591 Next_Elmt (Op); 16592 end loop; 16593 16594 if No (Op) then 16595 return False; 16596 16597 else 16598 Rewrite (Exp, 16599 Make_Function_Call (Loc, 16600 Name => New_Occurrence_Of (Node (Op), Loc), 16601 Parameter_Associations => Parameter_Associations (Call))); 16602 Analyze_And_Resolve (Exp, Entity (Elem_Typ)); 16603 return True; 16604 end if; 16605 end; 16606 end Is_Container_Element; 16607 16608 ---------------------------- 16609 -- Is_Contract_Annotation -- 16610 ---------------------------- 16611 16612 function Is_Contract_Annotation (Item : Node_Id) return Boolean is 16613 begin 16614 return Is_Package_Contract_Annotation (Item) 16615 or else 16616 Is_Subprogram_Contract_Annotation (Item); 16617 end Is_Contract_Annotation; 16618 16619 -------------------------------------- 16620 -- Is_Controlling_Limited_Procedure -- 16621 -------------------------------------- 16622 16623 function Is_Controlling_Limited_Procedure 16624 (Proc_Nam : Entity_Id) return Boolean 16625 is 16626 Param : Node_Id; 16627 Param_Typ : Entity_Id := Empty; 16628 16629 begin 16630 if Ekind (Proc_Nam) = E_Procedure 16631 and then Present (Parameter_Specifications (Parent (Proc_Nam))) 16632 then 16633 Param := 16634 Parameter_Type 16635 (First (Parameter_Specifications (Parent (Proc_Nam)))); 16636 16637 -- The formal may be an anonymous access type 16638 16639 if Nkind (Param) = N_Access_Definition then 16640 Param_Typ := Entity (Subtype_Mark (Param)); 16641 else 16642 Param_Typ := Etype (Param); 16643 end if; 16644 16645 -- In the case where an Itype was created for a dispatchin call, the 16646 -- procedure call has been rewritten. The actual may be an access to 16647 -- interface type in which case it is the designated type that is the 16648 -- controlling type. 16649 16650 elsif Present (Associated_Node_For_Itype (Proc_Nam)) 16651 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam))) 16652 and then 16653 Present (Parameter_Associations 16654 (Associated_Node_For_Itype (Proc_Nam))) 16655 then 16656 Param_Typ := 16657 Etype (First (Parameter_Associations 16658 (Associated_Node_For_Itype (Proc_Nam)))); 16659 16660 if Ekind (Param_Typ) = E_Anonymous_Access_Type then 16661 Param_Typ := Directly_Designated_Type (Param_Typ); 16662 end if; 16663 end if; 16664 16665 if Present (Param_Typ) then 16666 return 16667 Is_Interface (Param_Typ) 16668 and then Is_Limited_Record (Param_Typ); 16669 end if; 16670 16671 return False; 16672 end Is_Controlling_Limited_Procedure; 16673 16674 ----------------------------- 16675 -- Is_CPP_Constructor_Call -- 16676 ----------------------------- 16677 16678 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is 16679 begin 16680 return Nkind (N) = N_Function_Call 16681 and then Is_CPP_Class (Etype (Etype (N))) 16682 and then Is_Constructor (Entity (Name (N))) 16683 and then Is_Imported (Entity (Name (N))); 16684 end Is_CPP_Constructor_Call; 16685 16686 ------------------------- 16687 -- Is_Current_Instance -- 16688 ------------------------- 16689 16690 function Is_Current_Instance (N : Node_Id) return Boolean is 16691 Typ : constant Entity_Id := Entity (N); 16692 P : Node_Id; 16693 16694 begin 16695 -- Simplest case: entity is a concurrent type and we are currently 16696 -- inside the body. This will eventually be expanded into a call to 16697 -- Self (for tasks) or _object (for protected objects). 16698 16699 if Is_Concurrent_Type (Typ) and then In_Open_Scopes (Typ) then 16700 return True; 16701 16702 else 16703 -- Check whether the context is a (sub)type declaration for the 16704 -- type entity. 16705 16706 P := Parent (N); 16707 while Present (P) loop 16708 if Nkind (P) in N_Full_Type_Declaration 16709 | N_Private_Type_Declaration 16710 | N_Subtype_Declaration 16711 and then Comes_From_Source (P) 16712 and then Defining_Entity (P) = Typ 16713 then 16714 return True; 16715 16716 -- A subtype name may appear in an aspect specification for a 16717 -- Predicate_Failure aspect, for which we do not construct a 16718 -- wrapper procedure. The subtype will be replaced by the 16719 -- expression being tested when the corresponding predicate 16720 -- check is expanded. It may also appear in the pragma Predicate 16721 -- expression during legality checking. 16722 16723 elsif Nkind (P) = N_Aspect_Specification 16724 and then Nkind (Parent (P)) = N_Subtype_Declaration 16725 then 16726 return True; 16727 16728 elsif Nkind (P) = N_Pragma 16729 and then Get_Pragma_Id (P) in Pragma_Predicate 16730 | Pragma_Predicate_Failure 16731 then 16732 return True; 16733 end if; 16734 16735 P := Parent (P); 16736 end loop; 16737 end if; 16738 16739 -- In any other context this is not a current occurrence 16740 16741 return False; 16742 end Is_Current_Instance; 16743 16744 -------------------------------------------------- 16745 -- Is_Current_Instance_Reference_In_Type_Aspect -- 16746 -------------------------------------------------- 16747 16748 function Is_Current_Instance_Reference_In_Type_Aspect 16749 (N : Node_Id) return Boolean 16750 is 16751 begin 16752 -- When a current_instance is referenced within an aspect_specification 16753 -- of a type or subtype, it will show up as a reference to the formal 16754 -- parameter of the aspect's associated subprogram rather than as a 16755 -- reference to the type or subtype itself (in fact, the original name 16756 -- is never even analyzed). We check for predicate, invariant, and 16757 -- Default_Initial_Condition subprograms (in theory there could be 16758 -- other cases added, in which case this function will need updating). 16759 16760 if Is_Entity_Name (N) then 16761 return Present (Entity (N)) 16762 and then Ekind (Entity (N)) = E_In_Parameter 16763 and then Ekind (Scope (Entity (N))) in E_Function | E_Procedure 16764 and then 16765 (Is_Predicate_Function (Scope (Entity (N))) 16766 or else Is_Predicate_Function_M (Scope (Entity (N))) 16767 or else Is_Invariant_Procedure (Scope (Entity (N))) 16768 or else Is_Partial_Invariant_Procedure (Scope (Entity (N))) 16769 or else Is_DIC_Procedure (Scope (Entity (N)))); 16770 16771 else 16772 case Nkind (N) is 16773 when N_Indexed_Component 16774 | N_Slice 16775 => 16776 return 16777 Is_Current_Instance_Reference_In_Type_Aspect (Prefix (N)); 16778 16779 when N_Selected_Component => 16780 return 16781 Is_Current_Instance_Reference_In_Type_Aspect (Prefix (N)); 16782 16783 when N_Type_Conversion => 16784 return Is_Current_Instance_Reference_In_Type_Aspect 16785 (Expression (N)); 16786 16787 when N_Qualified_Expression => 16788 return Is_Current_Instance_Reference_In_Type_Aspect 16789 (Expression (N)); 16790 16791 when others => 16792 return False; 16793 end case; 16794 end if; 16795 end Is_Current_Instance_Reference_In_Type_Aspect; 16796 16797 -------------------- 16798 -- Is_Declaration -- 16799 -------------------- 16800 16801 function Is_Declaration 16802 (N : Node_Id; 16803 Body_OK : Boolean := True; 16804 Concurrent_OK : Boolean := True; 16805 Formal_OK : Boolean := True; 16806 Generic_OK : Boolean := True; 16807 Instantiation_OK : Boolean := True; 16808 Renaming_OK : Boolean := True; 16809 Stub_OK : Boolean := True; 16810 Subprogram_OK : Boolean := True; 16811 Type_OK : Boolean := True) return Boolean 16812 is 16813 begin 16814 case Nkind (N) is 16815 16816 -- Body declarations 16817 16818 when N_Proper_Body => 16819 return Body_OK; 16820 16821 -- Concurrent type declarations 16822 16823 when N_Protected_Type_Declaration 16824 | N_Single_Protected_Declaration 16825 | N_Single_Task_Declaration 16826 | N_Task_Type_Declaration 16827 => 16828 return Concurrent_OK or Type_OK; 16829 16830 -- Formal declarations 16831 16832 when N_Formal_Abstract_Subprogram_Declaration 16833 | N_Formal_Concrete_Subprogram_Declaration 16834 | N_Formal_Object_Declaration 16835 | N_Formal_Package_Declaration 16836 | N_Formal_Type_Declaration 16837 => 16838 return Formal_OK; 16839 16840 -- Generic declarations 16841 16842 when N_Generic_Package_Declaration 16843 | N_Generic_Subprogram_Declaration 16844 => 16845 return Generic_OK; 16846 16847 -- Generic instantiations 16848 16849 when N_Function_Instantiation 16850 | N_Package_Instantiation 16851 | N_Procedure_Instantiation 16852 => 16853 return Instantiation_OK; 16854 16855 -- Generic renaming declarations 16856 16857 when N_Generic_Renaming_Declaration => 16858 return Generic_OK or Renaming_OK; 16859 16860 -- Renaming declarations 16861 16862 when N_Exception_Renaming_Declaration 16863 | N_Object_Renaming_Declaration 16864 | N_Package_Renaming_Declaration 16865 | N_Subprogram_Renaming_Declaration 16866 => 16867 return Renaming_OK; 16868 16869 -- Stub declarations 16870 16871 when N_Body_Stub => 16872 return Stub_OK; 16873 16874 -- Subprogram declarations 16875 16876 when N_Abstract_Subprogram_Declaration 16877 | N_Entry_Declaration 16878 | N_Expression_Function 16879 | N_Subprogram_Declaration 16880 => 16881 return Subprogram_OK; 16882 16883 -- Type declarations 16884 16885 when N_Full_Type_Declaration 16886 | N_Incomplete_Type_Declaration 16887 | N_Private_Extension_Declaration 16888 | N_Private_Type_Declaration 16889 | N_Subtype_Declaration 16890 => 16891 return Type_OK; 16892 16893 -- Miscellaneous 16894 16895 when N_Component_Declaration 16896 | N_Exception_Declaration 16897 | N_Implicit_Label_Declaration 16898 | N_Number_Declaration 16899 | N_Object_Declaration 16900 | N_Package_Declaration 16901 => 16902 return True; 16903 16904 when others => 16905 return False; 16906 end case; 16907 end Is_Declaration; 16908 16909 -------------------------------- 16910 -- Is_Declared_Within_Variant -- 16911 -------------------------------- 16912 16913 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is 16914 Comp_Decl : constant Node_Id := Parent (Comp); 16915 Comp_List : constant Node_Id := Parent (Comp_Decl); 16916 begin 16917 return Nkind (Parent (Comp_List)) = N_Variant; 16918 end Is_Declared_Within_Variant; 16919 16920 ---------------------------------------------- 16921 -- Is_Dependent_Component_Of_Mutable_Object -- 16922 ---------------------------------------------- 16923 16924 function Is_Dependent_Component_Of_Mutable_Object 16925 (Object : Node_Id) return Boolean 16926 is 16927 P : Node_Id; 16928 Prefix_Type : Entity_Id; 16929 P_Aliased : Boolean := False; 16930 Comp : Entity_Id; 16931 16932 Deref : Node_Id := Original_Node (Object); 16933 -- Dereference node, in something like X.all.Y(2) 16934 16935 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object 16936 16937 begin 16938 -- Find the dereference node if any 16939 16940 while Nkind (Deref) in 16941 N_Indexed_Component | N_Selected_Component | N_Slice 16942 loop 16943 Deref := Original_Node (Prefix (Deref)); 16944 end loop; 16945 16946 -- If the prefix is a qualified expression of a variable, then function 16947 -- Is_Variable will return False for that because a qualified expression 16948 -- denotes a constant view, so we need to get the name being qualified 16949 -- so we can test below whether that's a variable (or a dereference). 16950 16951 if Nkind (Deref) = N_Qualified_Expression then 16952 Deref := Expression (Deref); 16953 end if; 16954 16955 -- Ada 2005: If we have a component or slice of a dereference, something 16956 -- like X.all.Y (2) and the type of X is access-to-constant, Is_Variable 16957 -- will return False, because it is indeed a constant view. But it might 16958 -- be a view of a variable object, so we want the following condition to 16959 -- be True in that case. 16960 16961 if Is_Variable (Object) 16962 or else Is_Variable (Deref) 16963 or else 16964 (Ada_Version >= Ada_2005 16965 and then (Nkind (Deref) = N_Explicit_Dereference 16966 or else (Present (Etype (Deref)) 16967 and then Is_Access_Type (Etype (Deref))))) 16968 then 16969 if Nkind (Object) = N_Selected_Component then 16970 16971 -- If the selector is not a component, then we definitely return 16972 -- False (it could be a function selector in a prefix form call 16973 -- occurring in an iterator specification). 16974 16975 if Ekind (Entity (Selector_Name (Object))) not in 16976 E_Component | E_Discriminant 16977 then 16978 return False; 16979 end if; 16980 16981 -- Get the original node of the prefix in case it has been 16982 -- rewritten, which can occur, for example, in qualified 16983 -- expression cases. Also, a discriminant check on a selected 16984 -- component may be expanded into a dereference when removing 16985 -- side effects, and the subtype of the original node may be 16986 -- unconstrained. 16987 16988 P := Original_Node (Prefix (Object)); 16989 Prefix_Type := Etype (P); 16990 16991 -- If the prefix is a qualified expression, we want to look at its 16992 -- operand. 16993 16994 if Nkind (P) = N_Qualified_Expression then 16995 P := Expression (P); 16996 Prefix_Type := Etype (P); 16997 end if; 16998 16999 if Is_Entity_Name (P) then 17000 -- The Etype may not be set on P (which is wrong) in certain 17001 -- corner cases involving the deprecated front-end inlining of 17002 -- subprograms (via -gnatN), so use the Etype set on the 17003 -- the entity for these instances since we know it is present. 17004 17005 if No (Prefix_Type) then 17006 Prefix_Type := Etype (Entity (P)); 17007 end if; 17008 17009 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then 17010 Prefix_Type := Base_Type (Prefix_Type); 17011 end if; 17012 17013 if Is_Aliased (Entity (P)) then 17014 P_Aliased := True; 17015 end if; 17016 17017 -- For explicit dereferences we get the access prefix so we can 17018 -- treat this similarly to implicit dereferences and examine the 17019 -- kind of the access type and its designated subtype further 17020 -- below. 17021 17022 elsif Nkind (P) = N_Explicit_Dereference then 17023 P := Prefix (P); 17024 Prefix_Type := Etype (P); 17025 17026 else 17027 -- Check for prefix being an aliased component??? 17028 17029 null; 17030 end if; 17031 17032 -- A heap object is constrained by its initial value 17033 17034 -- Ada 2005 (AI-363): Always assume the object could be mutable in 17035 -- the dereferenced case, since the access value might denote an 17036 -- unconstrained aliased object, whereas in Ada 95 the designated 17037 -- object is guaranteed to be constrained. A worst-case assumption 17038 -- has to apply in Ada 2005 because we can't tell at compile 17039 -- time whether the object is "constrained by its initial value", 17040 -- despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic 17041 -- rules (these rules are acknowledged to need fixing). We don't 17042 -- impose this more stringent checking for earlier Ada versions or 17043 -- when Relaxed_RM_Semantics applies (the latter for CodePeer's 17044 -- benefit, though it's unclear on why using -gnat95 would not be 17045 -- sufficient???). 17046 17047 if Ada_Version < Ada_2005 or else Relaxed_RM_Semantics then 17048 if Is_Access_Type (Prefix_Type) 17049 or else Nkind (P) = N_Explicit_Dereference 17050 then 17051 return False; 17052 end if; 17053 17054 else pragma Assert (Ada_Version >= Ada_2005); 17055 if Is_Access_Type (Prefix_Type) then 17056 -- We need to make sure we have the base subtype, in case 17057 -- this is actually an access subtype (whose Ekind will be 17058 -- E_Access_Subtype). 17059 17060 Prefix_Type := Etype (Prefix_Type); 17061 17062 -- If the access type is pool-specific, and there is no 17063 -- constrained partial view of the designated type, then the 17064 -- designated object is known to be constrained. If it's a 17065 -- formal access type and the renaming is in the generic 17066 -- spec, we also treat it as pool-specific (known to be 17067 -- constrained), but assume the worst if in the generic body 17068 -- (see RM 3.3(23.3/3)). 17069 17070 if Ekind (Prefix_Type) = E_Access_Type 17071 and then (not Is_Generic_Type (Prefix_Type) 17072 or else not In_Generic_Body (Current_Scope)) 17073 and then not Object_Type_Has_Constrained_Partial_View 17074 (Typ => Designated_Type (Prefix_Type), 17075 Scop => Current_Scope) 17076 then 17077 return False; 17078 17079 -- Otherwise (general access type, or there is a constrained 17080 -- partial view of the designated type), we need to check 17081 -- based on the designated type. 17082 17083 else 17084 Prefix_Type := Designated_Type (Prefix_Type); 17085 end if; 17086 end if; 17087 end if; 17088 17089 Comp := 17090 Original_Record_Component (Entity (Selector_Name (Object))); 17091 17092 -- As per AI-0017, the renaming is illegal in a generic body, even 17093 -- if the subtype is indefinite (only applies to prefixes of an 17094 -- untagged formal type, see RM 3.3 (23.11/3)). 17095 17096 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable 17097 17098 if not Is_Constrained (Prefix_Type) 17099 and then (Is_Definite_Subtype (Prefix_Type) 17100 or else 17101 (not Is_Tagged_Type (Prefix_Type) 17102 and then Is_Generic_Type (Prefix_Type) 17103 and then In_Generic_Body (Current_Scope))) 17104 17105 and then (Is_Declared_Within_Variant (Comp) 17106 or else Has_Discriminant_Dependent_Constraint (Comp)) 17107 and then (not P_Aliased or else Ada_Version >= Ada_2005) 17108 then 17109 return True; 17110 17111 -- If the prefix is of an access type at this point, then we want 17112 -- to return False, rather than calling this function recursively 17113 -- on the access object (which itself might be a discriminant- 17114 -- dependent component of some other object, but that isn't 17115 -- relevant to checking the object passed to us). This avoids 17116 -- issuing wrong errors when compiling with -gnatc, where there 17117 -- can be implicit dereferences that have not been expanded. 17118 17119 elsif Is_Access_Type (Etype (Prefix (Object))) then 17120 return False; 17121 17122 else 17123 return 17124 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 17125 end if; 17126 17127 elsif Nkind (Object) = N_Indexed_Component 17128 or else Nkind (Object) = N_Slice 17129 then 17130 return Is_Dependent_Component_Of_Mutable_Object 17131 (Original_Node (Prefix (Object))); 17132 17133 -- A type conversion that Is_Variable is a view conversion: 17134 -- go back to the denoted object. 17135 17136 elsif Nkind (Object) = N_Type_Conversion then 17137 return 17138 Is_Dependent_Component_Of_Mutable_Object 17139 (Original_Node (Expression (Object))); 17140 end if; 17141 end if; 17142 17143 return False; 17144 end Is_Dependent_Component_Of_Mutable_Object; 17145 17146 --------------------- 17147 -- Is_Dereferenced -- 17148 --------------------- 17149 17150 function Is_Dereferenced (N : Node_Id) return Boolean is 17151 P : constant Node_Id := Parent (N); 17152 begin 17153 return Nkind (P) in N_Selected_Component 17154 | N_Explicit_Dereference 17155 | N_Indexed_Component 17156 | N_Slice 17157 and then Prefix (P) = N; 17158 end Is_Dereferenced; 17159 17160 ---------------------- 17161 -- Is_Descendant_Of -- 17162 ---------------------- 17163 17164 function Is_Descendant_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is 17165 T : Entity_Id; 17166 Etyp : Entity_Id; 17167 17168 begin 17169 pragma Assert (Nkind (T1) in N_Entity); 17170 pragma Assert (Nkind (T2) in N_Entity); 17171 17172 T := Base_Type (T1); 17173 17174 -- Immediate return if the types match 17175 17176 if T = T2 then 17177 return True; 17178 17179 -- Comment needed here ??? 17180 17181 elsif Ekind (T) = E_Class_Wide_Type then 17182 return Etype (T) = T2; 17183 17184 -- All other cases 17185 17186 else 17187 loop 17188 Etyp := Etype (T); 17189 17190 -- Done if we found the type we are looking for 17191 17192 if Etyp = T2 then 17193 return True; 17194 17195 -- Done if no more derivations to check 17196 17197 elsif T = T1 17198 or else T = Etyp 17199 then 17200 return False; 17201 17202 -- Following test catches error cases resulting from prev errors 17203 17204 elsif No (Etyp) then 17205 return False; 17206 17207 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then 17208 return False; 17209 17210 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then 17211 return False; 17212 end if; 17213 17214 T := Base_Type (Etyp); 17215 end loop; 17216 end if; 17217 end Is_Descendant_Of; 17218 17219 ---------------------------------------- 17220 -- Is_Descendant_Of_Suspension_Object -- 17221 ---------------------------------------- 17222 17223 function Is_Descendant_Of_Suspension_Object 17224 (Typ : Entity_Id) return Boolean 17225 is 17226 Cur_Typ : Entity_Id; 17227 Par_Typ : Entity_Id; 17228 17229 begin 17230 -- Climb the type derivation chain checking each parent type against 17231 -- Suspension_Object. 17232 17233 Cur_Typ := Base_Type (Typ); 17234 while Present (Cur_Typ) loop 17235 Par_Typ := Etype (Cur_Typ); 17236 17237 -- The current type is a match 17238 17239 if Is_RTE (Cur_Typ, RE_Suspension_Object) then 17240 return True; 17241 17242 -- Stop the traversal once the root of the derivation chain has been 17243 -- reached. In that case the current type is its own base type. 17244 17245 elsif Cur_Typ = Par_Typ then 17246 exit; 17247 end if; 17248 17249 Cur_Typ := Base_Type (Par_Typ); 17250 end loop; 17251 17252 return False; 17253 end Is_Descendant_Of_Suspension_Object; 17254 17255 --------------------------------------------- 17256 -- Is_Double_Precision_Floating_Point_Type -- 17257 --------------------------------------------- 17258 17259 function Is_Double_Precision_Floating_Point_Type 17260 (E : Entity_Id) return Boolean is 17261 begin 17262 return Is_Floating_Point_Type (E) 17263 and then Machine_Radix_Value (E) = Uint_2 17264 and then Machine_Mantissa_Value (E) = UI_From_Int (53) 17265 and then Machine_Emax_Value (E) = Uint_2 ** Uint_10 17266 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_10); 17267 end Is_Double_Precision_Floating_Point_Type; 17268 17269 ----------------------------- 17270 -- Is_Effectively_Volatile -- 17271 ----------------------------- 17272 17273 function Is_Effectively_Volatile 17274 (Id : Entity_Id; 17275 Ignore_Protected : Boolean := False) return Boolean is 17276 begin 17277 if Is_Type (Id) then 17278 17279 -- An arbitrary type is effectively volatile when it is subject to 17280 -- pragma Atomic or Volatile. 17281 17282 if Is_Volatile (Id) then 17283 return True; 17284 17285 -- An array type is effectively volatile when it is subject to pragma 17286 -- Atomic_Components or Volatile_Components or its component type is 17287 -- effectively volatile. 17288 17289 elsif Is_Array_Type (Id) then 17290 if Has_Volatile_Components (Id) then 17291 return True; 17292 else 17293 declare 17294 Anc : Entity_Id := Base_Type (Id); 17295 begin 17296 if Is_Private_Type (Anc) then 17297 Anc := Full_View (Anc); 17298 end if; 17299 17300 -- Test for presence of ancestor, as the full view of a 17301 -- private type may be missing in case of error. 17302 17303 return Present (Anc) 17304 and then Is_Effectively_Volatile 17305 (Component_Type (Anc), Ignore_Protected); 17306 end; 17307 end if; 17308 17309 -- A protected type is always volatile unless Ignore_Protected is 17310 -- True. 17311 17312 elsif Is_Protected_Type (Id) and then not Ignore_Protected then 17313 return True; 17314 17315 -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is 17316 -- automatically volatile. 17317 17318 elsif Is_Descendant_Of_Suspension_Object (Id) then 17319 return True; 17320 17321 -- Otherwise the type is not effectively volatile 17322 17323 else 17324 return False; 17325 end if; 17326 17327 -- Otherwise Id denotes an object 17328 17329 else pragma Assert (Is_Object (Id)); 17330 -- A volatile object for which No_Caching is enabled is not 17331 -- effectively volatile. 17332 17333 return 17334 (Is_Volatile (Id) 17335 and then not 17336 (Ekind (Id) = E_Variable and then No_Caching_Enabled (Id))) 17337 or else Has_Volatile_Components (Id) 17338 or else Is_Effectively_Volatile (Etype (Id), Ignore_Protected); 17339 end if; 17340 end Is_Effectively_Volatile; 17341 17342 ----------------------------------------- 17343 -- Is_Effectively_Volatile_For_Reading -- 17344 ----------------------------------------- 17345 17346 function Is_Effectively_Volatile_For_Reading 17347 (Id : Entity_Id; 17348 Ignore_Protected : Boolean := False) return Boolean 17349 is 17350 begin 17351 -- A concurrent type is effectively volatile for reading, except for a 17352 -- protected type when Ignore_Protected is True. 17353 17354 if Is_Task_Type (Id) 17355 or else (Is_Protected_Type (Id) and then not Ignore_Protected) 17356 then 17357 return True; 17358 17359 elsif Is_Effectively_Volatile (Id, Ignore_Protected) then 17360 17361 -- Other volatile types and objects are effectively volatile for 17362 -- reading when they have property Async_Writers or Effective_Reads 17363 -- set to True. This includes the case of an array type whose 17364 -- Volatile_Components aspect is True (hence it is effectively 17365 -- volatile) which does not have the properties Async_Writers 17366 -- and Effective_Reads set to False. 17367 17368 if Async_Writers_Enabled (Id) 17369 or else Effective_Reads_Enabled (Id) 17370 then 17371 return True; 17372 17373 -- In addition, an array type is effectively volatile for reading 17374 -- when its component type is effectively volatile for reading. 17375 17376 elsif Is_Array_Type (Id) then 17377 declare 17378 Anc : Entity_Id := Base_Type (Id); 17379 begin 17380 if Is_Private_Type (Anc) then 17381 Anc := Full_View (Anc); 17382 end if; 17383 17384 -- Test for presence of ancestor, as the full view of a 17385 -- private type may be missing in case of error. 17386 17387 return Present (Anc) 17388 and then Is_Effectively_Volatile_For_Reading 17389 (Component_Type (Anc), Ignore_Protected); 17390 end; 17391 end if; 17392 end if; 17393 17394 return False; 17395 17396 end Is_Effectively_Volatile_For_Reading; 17397 17398 ------------------------------------ 17399 -- Is_Effectively_Volatile_Object -- 17400 ------------------------------------ 17401 17402 function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean is 17403 function Is_Effectively_Volatile (E : Entity_Id) return Boolean is 17404 (Is_Effectively_Volatile (E, Ignore_Protected => False)); 17405 17406 function Is_Effectively_Volatile_Object_Inst 17407 is new Is_Effectively_Volatile_Object_Shared (Is_Effectively_Volatile); 17408 begin 17409 return Is_Effectively_Volatile_Object_Inst (N); 17410 end Is_Effectively_Volatile_Object; 17411 17412 ------------------------------------------------ 17413 -- Is_Effectively_Volatile_Object_For_Reading -- 17414 ------------------------------------------------ 17415 17416 function Is_Effectively_Volatile_Object_For_Reading 17417 (N : Node_Id) return Boolean 17418 is 17419 function Is_Effectively_Volatile_For_Reading 17420 (E : Entity_Id) return Boolean 17421 is (Is_Effectively_Volatile_For_Reading (E, Ignore_Protected => False)); 17422 17423 function Is_Effectively_Volatile_Object_For_Reading_Inst 17424 is new Is_Effectively_Volatile_Object_Shared 17425 (Is_Effectively_Volatile_For_Reading); 17426 begin 17427 return Is_Effectively_Volatile_Object_For_Reading_Inst (N); 17428 end Is_Effectively_Volatile_Object_For_Reading; 17429 17430 ------------------------------------------- 17431 -- Is_Effectively_Volatile_Object_Shared -- 17432 ------------------------------------------- 17433 17434 function Is_Effectively_Volatile_Object_Shared 17435 (N : Node_Id) return Boolean 17436 is 17437 begin 17438 if Is_Entity_Name (N) then 17439 return Is_Object (Entity (N)) 17440 and then Is_Effectively_Volatile_Entity (Entity (N)); 17441 17442 elsif Nkind (N) in N_Indexed_Component | N_Slice then 17443 return Is_Effectively_Volatile_Object_Shared (Prefix (N)); 17444 17445 elsif Nkind (N) = N_Selected_Component then 17446 return 17447 Is_Effectively_Volatile_Object_Shared (Prefix (N)) 17448 or else 17449 Is_Effectively_Volatile_Object_Shared (Selector_Name (N)); 17450 17451 elsif Nkind (N) in N_Qualified_Expression 17452 | N_Unchecked_Type_Conversion 17453 | N_Type_Conversion 17454 then 17455 return Is_Effectively_Volatile_Object_Shared (Expression (N)); 17456 17457 else 17458 return False; 17459 end if; 17460 end Is_Effectively_Volatile_Object_Shared; 17461 17462 ------------------- 17463 -- Is_Entry_Body -- 17464 ------------------- 17465 17466 function Is_Entry_Body (Id : Entity_Id) return Boolean is 17467 begin 17468 return 17469 Is_Entry (Id) 17470 and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Body; 17471 end Is_Entry_Body; 17472 17473 -------------------------- 17474 -- Is_Entry_Declaration -- 17475 -------------------------- 17476 17477 function Is_Entry_Declaration (Id : Entity_Id) return Boolean is 17478 begin 17479 return 17480 Is_Entry (Id) 17481 and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Declaration; 17482 end Is_Entry_Declaration; 17483 17484 ------------------------------------ 17485 -- Is_Expanded_Priority_Attribute -- 17486 ------------------------------------ 17487 17488 function Is_Expanded_Priority_Attribute (E : Entity_Id) return Boolean is 17489 begin 17490 return 17491 Nkind (E) = N_Function_Call 17492 and then not Configurable_Run_Time_Mode 17493 and then Nkind (Original_Node (E)) = N_Attribute_Reference 17494 and then (Is_RTE (Entity (Name (E)), RE_Get_Ceiling) 17495 or else Is_RTE (Entity (Name (E)), RO_PE_Get_Ceiling)); 17496 end Is_Expanded_Priority_Attribute; 17497 17498 ---------------------------- 17499 -- Is_Expression_Function -- 17500 ---------------------------- 17501 17502 function Is_Expression_Function (Subp : Entity_Id) return Boolean is 17503 begin 17504 if Ekind (Subp) in E_Function | E_Subprogram_Body then 17505 return 17506 Nkind (Original_Node (Unit_Declaration_Node (Subp))) = 17507 N_Expression_Function; 17508 else 17509 return False; 17510 end if; 17511 end Is_Expression_Function; 17512 17513 ------------------------------------------ 17514 -- Is_Expression_Function_Or_Completion -- 17515 ------------------------------------------ 17516 17517 function Is_Expression_Function_Or_Completion 17518 (Subp : Entity_Id) return Boolean 17519 is 17520 Subp_Decl : Node_Id; 17521 17522 begin 17523 if Ekind (Subp) = E_Function then 17524 Subp_Decl := Unit_Declaration_Node (Subp); 17525 17526 -- The function declaration is either an expression function or is 17527 -- completed by an expression function body. 17528 17529 return 17530 Is_Expression_Function (Subp) 17531 or else (Nkind (Subp_Decl) = N_Subprogram_Declaration 17532 and then Present (Corresponding_Body (Subp_Decl)) 17533 and then Is_Expression_Function 17534 (Corresponding_Body (Subp_Decl))); 17535 17536 elsif Ekind (Subp) = E_Subprogram_Body then 17537 return Is_Expression_Function (Subp); 17538 17539 else 17540 return False; 17541 end if; 17542 end Is_Expression_Function_Or_Completion; 17543 17544 ----------------------------------------------- 17545 -- Is_Extended_Precision_Floating_Point_Type -- 17546 ----------------------------------------------- 17547 17548 function Is_Extended_Precision_Floating_Point_Type 17549 (E : Entity_Id) return Boolean is 17550 begin 17551 return Is_Floating_Point_Type (E) 17552 and then Machine_Radix_Value (E) = Uint_2 17553 and then Machine_Mantissa_Value (E) = Uint_64 17554 and then Machine_Emax_Value (E) = Uint_2 ** Uint_14 17555 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_14); 17556 end Is_Extended_Precision_Floating_Point_Type; 17557 17558 ----------------------- 17559 -- Is_EVF_Expression -- 17560 ----------------------- 17561 17562 function Is_EVF_Expression (N : Node_Id) return Boolean is 17563 Orig_N : constant Node_Id := Original_Node (N); 17564 Alt : Node_Id; 17565 Expr : Node_Id; 17566 Id : Entity_Id; 17567 17568 begin 17569 -- Detect a reference to a formal parameter of a specific tagged type 17570 -- whose related subprogram is subject to pragma Expresions_Visible with 17571 -- value "False". 17572 17573 if Is_Entity_Name (N) and then Present (Entity (N)) then 17574 Id := Entity (N); 17575 17576 return 17577 Is_Formal (Id) 17578 and then Is_Specific_Tagged_Type (Etype (Id)) 17579 and then Extensions_Visible_Status (Id) = 17580 Extensions_Visible_False; 17581 17582 -- A case expression is an EVF expression when it contains at least one 17583 -- EVF dependent_expression. Note that a case expression may have been 17584 -- expanded, hence the use of Original_Node. 17585 17586 elsif Nkind (Orig_N) = N_Case_Expression then 17587 Alt := First (Alternatives (Orig_N)); 17588 while Present (Alt) loop 17589 if Is_EVF_Expression (Expression (Alt)) then 17590 return True; 17591 end if; 17592 17593 Next (Alt); 17594 end loop; 17595 17596 -- An if expression is an EVF expression when it contains at least one 17597 -- EVF dependent_expression. Note that an if expression may have been 17598 -- expanded, hence the use of Original_Node. 17599 17600 elsif Nkind (Orig_N) = N_If_Expression then 17601 Expr := Next (First (Expressions (Orig_N))); 17602 while Present (Expr) loop 17603 if Is_EVF_Expression (Expr) then 17604 return True; 17605 end if; 17606 17607 Next (Expr); 17608 end loop; 17609 17610 -- A qualified expression or a type conversion is an EVF expression when 17611 -- its operand is an EVF expression. 17612 17613 elsif Nkind (N) in N_Qualified_Expression 17614 | N_Unchecked_Type_Conversion 17615 | N_Type_Conversion 17616 then 17617 return Is_EVF_Expression (Expression (N)); 17618 17619 -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when 17620 -- their prefix denotes an EVF expression. 17621 17622 elsif Nkind (N) = N_Attribute_Reference 17623 and then Attribute_Name (N) in Name_Loop_Entry 17624 | Name_Old 17625 | Name_Update 17626 then 17627 return Is_EVF_Expression (Prefix (N)); 17628 end if; 17629 17630 return False; 17631 end Is_EVF_Expression; 17632 17633 -------------- 17634 -- Is_False -- 17635 -------------- 17636 17637 function Is_False (U : Opt_Ubool) return Boolean is 17638 begin 17639 return not Is_True (U); 17640 end Is_False; 17641 17642 --------------------------- 17643 -- Is_Fixed_Model_Number -- 17644 --------------------------- 17645 17646 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is 17647 S : constant Ureal := Small_Value (T); 17648 M : Urealp.Save_Mark; 17649 R : Boolean; 17650 17651 begin 17652 M := Urealp.Mark; 17653 R := (U = UR_Trunc (U / S) * S); 17654 Urealp.Release (M); 17655 return R; 17656 end Is_Fixed_Model_Number; 17657 17658 ----------------------------- 17659 -- Is_Full_Access_Object -- 17660 ----------------------------- 17661 17662 function Is_Full_Access_Object (N : Node_Id) return Boolean is 17663 begin 17664 return Is_Atomic_Object (N) 17665 or else Is_Volatile_Full_Access_Object_Ref (N); 17666 end Is_Full_Access_Object; 17667 17668 ------------------------------- 17669 -- Is_Fully_Initialized_Type -- 17670 ------------------------------- 17671 17672 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is 17673 begin 17674 -- Scalar types 17675 17676 if Is_Scalar_Type (Typ) then 17677 17678 -- A scalar type with an aspect Default_Value is fully initialized 17679 17680 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization 17681 -- of a scalar type, but we don't take that into account here, since 17682 -- we don't want these to affect warnings. 17683 17684 return Has_Default_Aspect (Typ); 17685 17686 elsif Is_Access_Type (Typ) then 17687 return True; 17688 17689 elsif Is_Array_Type (Typ) then 17690 if Is_Fully_Initialized_Type (Component_Type (Typ)) 17691 or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ)) 17692 then 17693 return True; 17694 end if; 17695 17696 -- An interesting case, if we have a constrained type one of whose 17697 -- bounds is known to be null, then there are no elements to be 17698 -- initialized, so all the elements are initialized. 17699 17700 if Is_Constrained (Typ) then 17701 declare 17702 Indx : Node_Id; 17703 Indx_Typ : Entity_Id; 17704 Lbd, Hbd : Node_Id; 17705 17706 begin 17707 Indx := First_Index (Typ); 17708 while Present (Indx) loop 17709 if Etype (Indx) = Any_Type then 17710 return False; 17711 17712 -- If index is a range, use directly 17713 17714 elsif Nkind (Indx) = N_Range then 17715 Lbd := Low_Bound (Indx); 17716 Hbd := High_Bound (Indx); 17717 17718 else 17719 Indx_Typ := Etype (Indx); 17720 17721 if Is_Private_Type (Indx_Typ) then 17722 Indx_Typ := Full_View (Indx_Typ); 17723 end if; 17724 17725 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then 17726 return False; 17727 else 17728 Lbd := Type_Low_Bound (Indx_Typ); 17729 Hbd := Type_High_Bound (Indx_Typ); 17730 end if; 17731 end if; 17732 17733 if Compile_Time_Known_Value (Lbd) 17734 and then 17735 Compile_Time_Known_Value (Hbd) 17736 then 17737 if Expr_Value (Hbd) < Expr_Value (Lbd) then 17738 return True; 17739 end if; 17740 end if; 17741 17742 Next_Index (Indx); 17743 end loop; 17744 end; 17745 end if; 17746 17747 -- If no null indexes, then type is not fully initialized 17748 17749 return False; 17750 17751 -- Record types 17752 17753 elsif Is_Record_Type (Typ) then 17754 if Has_Defaulted_Discriminants (Typ) 17755 and then Is_Fully_Initialized_Variant (Typ) 17756 then 17757 return True; 17758 end if; 17759 17760 -- We consider bounded string types to be fully initialized, because 17761 -- otherwise we get false alarms when the Data component is not 17762 -- default-initialized. 17763 17764 if Is_Bounded_String (Typ) then 17765 return True; 17766 end if; 17767 17768 -- Controlled records are considered to be fully initialized if 17769 -- there is a user defined Initialize routine. This may not be 17770 -- entirely correct, but as the spec notes, we are guessing here 17771 -- what is best from the point of view of issuing warnings. 17772 17773 if Is_Controlled (Typ) then 17774 declare 17775 Utyp : constant Entity_Id := Underlying_Type (Typ); 17776 17777 begin 17778 if Present (Utyp) then 17779 declare 17780 Init : constant Entity_Id := 17781 (Find_Optional_Prim_Op 17782 (Underlying_Type (Typ), Name_Initialize)); 17783 17784 begin 17785 if Present (Init) 17786 and then Comes_From_Source (Init) 17787 and then not In_Predefined_Unit (Init) 17788 then 17789 return True; 17790 17791 elsif Has_Null_Extension (Typ) 17792 and then 17793 Is_Fully_Initialized_Type 17794 (Etype (Base_Type (Typ))) 17795 then 17796 return True; 17797 end if; 17798 end; 17799 end if; 17800 end; 17801 end if; 17802 17803 -- Otherwise see if all record components are initialized 17804 17805 declare 17806 Comp : Entity_Id; 17807 17808 begin 17809 Comp := First_Component (Typ); 17810 while Present (Comp) loop 17811 if (No (Parent (Comp)) 17812 or else No (Expression (Parent (Comp)))) 17813 and then not Is_Fully_Initialized_Type (Etype (Comp)) 17814 17815 -- Special VM case for tag components, which need to be 17816 -- defined in this case, but are never initialized as VMs 17817 -- are using other dispatching mechanisms. Ignore this 17818 -- uninitialized case. Note that this applies both to the 17819 -- uTag entry and the main vtable pointer (CPP_Class case). 17820 17821 and then (Tagged_Type_Expansion or else not Is_Tag (Comp)) 17822 then 17823 return False; 17824 end if; 17825 17826 Next_Component (Comp); 17827 end loop; 17828 end; 17829 17830 -- No uninitialized components, so type is fully initialized. 17831 -- Note that this catches the case of no components as well. 17832 17833 return True; 17834 17835 elsif Is_Concurrent_Type (Typ) then 17836 return True; 17837 17838 elsif Is_Private_Type (Typ) then 17839 declare 17840 U : constant Entity_Id := Underlying_Type (Typ); 17841 17842 begin 17843 if No (U) then 17844 return False; 17845 else 17846 return Is_Fully_Initialized_Type (U); 17847 end if; 17848 end; 17849 17850 else 17851 return False; 17852 end if; 17853 end Is_Fully_Initialized_Type; 17854 17855 ---------------------------------- 17856 -- Is_Fully_Initialized_Variant -- 17857 ---------------------------------- 17858 17859 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is 17860 Loc : constant Source_Ptr := Sloc (Typ); 17861 Constraints : constant List_Id := New_List; 17862 Components : constant Elist_Id := New_Elmt_List; 17863 Comp_Elmt : Elmt_Id; 17864 Comp_Id : Node_Id; 17865 Comp_List : Node_Id; 17866 Discr : Entity_Id; 17867 Discr_Val : Node_Id; 17868 17869 Report_Errors : Boolean; 17870 pragma Warnings (Off, Report_Errors); 17871 17872 begin 17873 if Serious_Errors_Detected > 0 then 17874 return False; 17875 end if; 17876 17877 if Is_Record_Type (Typ) 17878 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration 17879 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition 17880 then 17881 Comp_List := Component_List (Type_Definition (Parent (Typ))); 17882 17883 Discr := First_Discriminant (Typ); 17884 while Present (Discr) loop 17885 if Nkind (Parent (Discr)) = N_Discriminant_Specification then 17886 Discr_Val := Expression (Parent (Discr)); 17887 17888 if Present (Discr_Val) 17889 and then Is_OK_Static_Expression (Discr_Val) 17890 then 17891 Append_To (Constraints, 17892 Make_Component_Association (Loc, 17893 Choices => New_List (New_Occurrence_Of (Discr, Loc)), 17894 Expression => New_Copy (Discr_Val))); 17895 else 17896 return False; 17897 end if; 17898 else 17899 return False; 17900 end if; 17901 17902 Next_Discriminant (Discr); 17903 end loop; 17904 17905 Gather_Components 17906 (Typ => Typ, 17907 Comp_List => Comp_List, 17908 Governed_By => Constraints, 17909 Into => Components, 17910 Report_Errors => Report_Errors); 17911 17912 -- Check that each component present is fully initialized 17913 17914 Comp_Elmt := First_Elmt (Components); 17915 while Present (Comp_Elmt) loop 17916 Comp_Id := Node (Comp_Elmt); 17917 17918 if Ekind (Comp_Id) = E_Component 17919 and then (No (Parent (Comp_Id)) 17920 or else No (Expression (Parent (Comp_Id)))) 17921 and then not Is_Fully_Initialized_Type (Etype (Comp_Id)) 17922 then 17923 return False; 17924 end if; 17925 17926 Next_Elmt (Comp_Elmt); 17927 end loop; 17928 17929 return True; 17930 17931 elsif Is_Private_Type (Typ) then 17932 declare 17933 U : constant Entity_Id := Underlying_Type (Typ); 17934 17935 begin 17936 if No (U) then 17937 return False; 17938 else 17939 return Is_Fully_Initialized_Variant (U); 17940 end if; 17941 end; 17942 17943 else 17944 return False; 17945 end if; 17946 end Is_Fully_Initialized_Variant; 17947 17948 ------------------------------------ 17949 -- Is_Generic_Declaration_Or_Body -- 17950 ------------------------------------ 17951 17952 function Is_Generic_Declaration_Or_Body (Decl : Node_Id) return Boolean is 17953 Spec_Decl : Node_Id; 17954 17955 begin 17956 -- Package/subprogram body 17957 17958 if Nkind (Decl) in N_Package_Body | N_Subprogram_Body 17959 and then Present (Corresponding_Spec (Decl)) 17960 then 17961 Spec_Decl := Unit_Declaration_Node (Corresponding_Spec (Decl)); 17962 17963 -- Package/subprogram body stub 17964 17965 elsif Nkind (Decl) in N_Package_Body_Stub | N_Subprogram_Body_Stub 17966 and then Present (Corresponding_Spec_Of_Stub (Decl)) 17967 then 17968 Spec_Decl := 17969 Unit_Declaration_Node (Corresponding_Spec_Of_Stub (Decl)); 17970 17971 -- All other cases 17972 17973 else 17974 Spec_Decl := Decl; 17975 end if; 17976 17977 -- Rather than inspecting the defining entity of the spec declaration, 17978 -- look at its Nkind. This takes care of the case where the analysis of 17979 -- a generic body modifies the Ekind of its spec to allow for recursive 17980 -- calls. 17981 17982 return Nkind (Spec_Decl) in N_Generic_Declaration; 17983 end Is_Generic_Declaration_Or_Body; 17984 17985 --------------------------- 17986 -- Is_Independent_Object -- 17987 --------------------------- 17988 17989 function Is_Independent_Object (N : Node_Id) return Boolean is 17990 function Is_Independent_Object_Entity (Id : Entity_Id) return Boolean; 17991 -- Determine whether arbitrary entity Id denotes an object that is 17992 -- Independent. 17993 17994 function Prefix_Has_Independent_Components (P : Node_Id) return Boolean; 17995 -- Determine whether prefix P has independent components. This requires 17996 -- the presence of an Independent_Components aspect/pragma. 17997 17998 ------------------------------------ 17999 -- Is_Independent_Object_Entity -- 18000 ------------------------------------ 18001 18002 function Is_Independent_Object_Entity (Id : Entity_Id) return Boolean is 18003 begin 18004 return 18005 Is_Object (Id) 18006 and then (Is_Independent (Id) 18007 or else 18008 Is_Independent (Etype (Id))); 18009 end Is_Independent_Object_Entity; 18010 18011 ------------------------------------- 18012 -- Prefix_Has_Independent_Components -- 18013 ------------------------------------- 18014 18015 function Prefix_Has_Independent_Components (P : Node_Id) return Boolean 18016 is 18017 Typ : constant Entity_Id := Etype (P); 18018 18019 begin 18020 if Is_Access_Type (Typ) then 18021 return Has_Independent_Components (Designated_Type (Typ)); 18022 18023 elsif Has_Independent_Components (Typ) then 18024 return True; 18025 18026 elsif Is_Entity_Name (P) 18027 and then Has_Independent_Components (Entity (P)) 18028 then 18029 return True; 18030 18031 else 18032 return False; 18033 end if; 18034 end Prefix_Has_Independent_Components; 18035 18036 -- Start of processing for Is_Independent_Object 18037 18038 begin 18039 if Is_Entity_Name (N) then 18040 return Is_Independent_Object_Entity (Entity (N)); 18041 18042 elsif Is_Independent (Etype (N)) then 18043 return True; 18044 18045 elsif Nkind (N) = N_Indexed_Component then 18046 return Prefix_Has_Independent_Components (Prefix (N)); 18047 18048 elsif Nkind (N) = N_Selected_Component then 18049 return Prefix_Has_Independent_Components (Prefix (N)) 18050 or else Is_Independent (Entity (Selector_Name (N))); 18051 18052 else 18053 return False; 18054 end if; 18055 end Is_Independent_Object; 18056 18057 ---------------------------- 18058 -- Is_Inherited_Operation -- 18059 ---------------------------- 18060 18061 function Is_Inherited_Operation (E : Entity_Id) return Boolean is 18062 pragma Assert (Is_Overloadable (E)); 18063 Kind : constant Node_Kind := Nkind (Parent (E)); 18064 begin 18065 return Kind = N_Full_Type_Declaration 18066 or else Kind = N_Private_Extension_Declaration 18067 or else Kind = N_Subtype_Declaration 18068 or else (Ekind (E) = E_Enumeration_Literal 18069 and then Is_Derived_Type (Etype (E))); 18070 end Is_Inherited_Operation; 18071 18072 ------------------------------------- 18073 -- Is_Inherited_Operation_For_Type -- 18074 ------------------------------------- 18075 18076 function Is_Inherited_Operation_For_Type 18077 (E : Entity_Id; 18078 Typ : Entity_Id) return Boolean 18079 is 18080 begin 18081 -- Check that the operation has been created by the type declaration 18082 18083 return Is_Inherited_Operation (E) 18084 and then Defining_Identifier (Parent (E)) = Typ; 18085 end Is_Inherited_Operation_For_Type; 18086 18087 -------------------------------------- 18088 -- Is_Inlinable_Expression_Function -- 18089 -------------------------------------- 18090 18091 function Is_Inlinable_Expression_Function 18092 (Subp : Entity_Id) return Boolean 18093 is 18094 Return_Expr : Node_Id; 18095 18096 begin 18097 if Is_Expression_Function_Or_Completion (Subp) 18098 and then Has_Pragma_Inline_Always (Subp) 18099 and then Needs_No_Actuals (Subp) 18100 and then No (Contract (Subp)) 18101 and then not Is_Dispatching_Operation (Subp) 18102 and then Needs_Finalization (Etype (Subp)) 18103 and then not Is_Class_Wide_Type (Etype (Subp)) 18104 and then not Has_Invariants (Etype (Subp)) 18105 and then Present (Subprogram_Body (Subp)) 18106 and then Was_Expression_Function (Subprogram_Body (Subp)) 18107 then 18108 Return_Expr := Expression_Of_Expression_Function (Subp); 18109 18110 -- The returned object must not have a qualified expression and its 18111 -- nominal subtype must be statically compatible with the result 18112 -- subtype of the expression function. 18113 18114 return 18115 Nkind (Return_Expr) = N_Identifier 18116 and then Etype (Return_Expr) = Etype (Subp); 18117 end if; 18118 18119 return False; 18120 end Is_Inlinable_Expression_Function; 18121 18122 ----------------- 18123 -- Is_Iterator -- 18124 ----------------- 18125 18126 function Is_Iterator (Typ : Entity_Id) return Boolean is 18127 function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean; 18128 -- Determine whether type Iter_Typ is a predefined forward or reversible 18129 -- iterator. 18130 18131 ---------------------- 18132 -- Denotes_Iterator -- 18133 ---------------------- 18134 18135 function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean is 18136 begin 18137 -- Check that the name matches, and that the ultimate ancestor is in 18138 -- a predefined unit, i.e the one that declares iterator interfaces. 18139 18140 return 18141 Chars (Iter_Typ) in Name_Forward_Iterator | Name_Reversible_Iterator 18142 and then In_Predefined_Unit (Root_Type (Iter_Typ)); 18143 end Denotes_Iterator; 18144 18145 -- Local variables 18146 18147 Iface_Elmt : Elmt_Id; 18148 Ifaces : Elist_Id; 18149 18150 -- Start of processing for Is_Iterator 18151 18152 begin 18153 -- The type may be a subtype of a descendant of the proper instance of 18154 -- the predefined interface type, so we must use the root type of the 18155 -- given type. The same is done for Is_Reversible_Iterator. 18156 18157 if Is_Class_Wide_Type (Typ) 18158 and then Denotes_Iterator (Root_Type (Typ)) 18159 then 18160 return True; 18161 18162 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then 18163 return False; 18164 18165 elsif Present (Find_Value_Of_Aspect (Typ, Aspect_Iterable)) then 18166 return True; 18167 18168 else 18169 Collect_Interfaces (Typ, Ifaces); 18170 18171 Iface_Elmt := First_Elmt (Ifaces); 18172 while Present (Iface_Elmt) loop 18173 if Denotes_Iterator (Node (Iface_Elmt)) then 18174 return True; 18175 end if; 18176 18177 Next_Elmt (Iface_Elmt); 18178 end loop; 18179 18180 return False; 18181 end if; 18182 end Is_Iterator; 18183 18184 ---------------------------- 18185 -- Is_Iterator_Over_Array -- 18186 ---------------------------- 18187 18188 function Is_Iterator_Over_Array (N : Node_Id) return Boolean is 18189 Container : constant Node_Id := Name (N); 18190 Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); 18191 begin 18192 return Is_Array_Type (Container_Typ); 18193 end Is_Iterator_Over_Array; 18194 18195 ------------ 18196 -- Is_LHS -- 18197 ------------ 18198 18199 -- We seem to have a lot of overlapping functions that do similar things 18200 -- (testing for left hand sides or lvalues???). 18201 18202 function Is_LHS (N : Node_Id) return Is_LHS_Result is 18203 P : constant Node_Id := Parent (N); 18204 18205 begin 18206 -- Return True if we are the left hand side of an assignment statement 18207 18208 if Nkind (P) = N_Assignment_Statement then 18209 if Name (P) = N then 18210 return Yes; 18211 else 18212 return No; 18213 end if; 18214 18215 -- Case of prefix of indexed or selected component or slice 18216 18217 elsif Nkind (P) in N_Indexed_Component | N_Selected_Component | N_Slice 18218 and then N = Prefix (P) 18219 then 18220 -- Here we have the case where the parent P is N.Q or N(Q .. R). 18221 -- If P is an LHS, then N is also effectively an LHS, but there 18222 -- is an important exception. If N is of an access type, then 18223 -- what we really have is N.all.Q (or N.all(Q .. R)). In either 18224 -- case this makes N.all a left hand side but not N itself. 18225 18226 -- If we don't know the type yet, this is the case where we return 18227 -- Unknown, since the answer depends on the type which is unknown. 18228 18229 if No (Etype (N)) then 18230 return Unknown; 18231 18232 -- We have an Etype set, so we can check it 18233 18234 elsif Is_Access_Type (Etype (N)) then 18235 return No; 18236 18237 -- OK, not access type case, so just test whole expression 18238 18239 else 18240 return Is_LHS (P); 18241 end if; 18242 18243 -- All other cases are not left hand sides 18244 18245 else 18246 return No; 18247 end if; 18248 end Is_LHS; 18249 18250 ----------------------------- 18251 -- Is_Library_Level_Entity -- 18252 ----------------------------- 18253 18254 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is 18255 begin 18256 -- The following is a small optimization, and it also properly handles 18257 -- discriminals, which in task bodies might appear in expressions before 18258 -- the corresponding procedure has been created, and which therefore do 18259 -- not have an assigned scope. 18260 18261 if Is_Formal (E) then 18262 return False; 18263 18264 -- If we somehow got an empty value for Scope, the tree must be 18265 -- malformed. Rather than blow up we return True in this case. 18266 18267 elsif No (Scope (E)) then 18268 return True; 18269 18270 -- Handle loops since Enclosing_Dynamic_Scope skips them; required to 18271 -- properly handle entities local to quantified expressions in library 18272 -- level specifications. 18273 18274 elsif Ekind (Scope (E)) = E_Loop then 18275 return False; 18276 end if; 18277 18278 -- Normal test is simply that the enclosing dynamic scope is Standard 18279 18280 return Enclosing_Dynamic_Scope (E) = Standard_Standard; 18281 end Is_Library_Level_Entity; 18282 18283 -------------------------------- 18284 -- Is_Limited_Class_Wide_Type -- 18285 -------------------------------- 18286 18287 function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is 18288 begin 18289 return 18290 Is_Class_Wide_Type (Typ) 18291 and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ)); 18292 end Is_Limited_Class_Wide_Type; 18293 18294 --------------------------------- 18295 -- Is_Local_Variable_Reference -- 18296 --------------------------------- 18297 18298 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is 18299 begin 18300 if not Is_Entity_Name (Expr) then 18301 return False; 18302 18303 else 18304 declare 18305 Ent : constant Entity_Id := Entity (Expr); 18306 Sub : constant Entity_Id := Enclosing_Subprogram (Ent); 18307 begin 18308 if Ekind (Ent) 18309 not in E_Variable | E_In_Out_Parameter | E_Out_Parameter 18310 then 18311 return False; 18312 else 18313 return Present (Sub) and then Sub = Current_Subprogram; 18314 end if; 18315 end; 18316 end if; 18317 end Is_Local_Variable_Reference; 18318 18319 --------------- 18320 -- Is_Master -- 18321 --------------- 18322 18323 function Is_Master (N : Node_Id) return Boolean is 18324 Disable_Subexpression_Masters : constant Boolean := True; 18325 18326 begin 18327 if Nkind (N) in N_Subprogram_Body | N_Task_Body | N_Entry_Body 18328 or else Is_Statement (N) 18329 then 18330 return True; 18331 end if; 18332 18333 -- We avoid returning True when the master is a subexpression described 18334 -- in RM 7.6.1(3/2) for the proposes of accessibility level calculation 18335 -- in Accessibility_Level_Helper.Innermost_Master_Scope_Depth ??? 18336 18337 if not Disable_Subexpression_Masters 18338 and then Nkind (N) in N_Subexpr 18339 then 18340 declare 18341 Par : Node_Id := N; 18342 18343 subtype N_Simple_Statement_Other_Than_Simple_Return 18344 is Node_Kind with Static_Predicate => 18345 N_Simple_Statement_Other_Than_Simple_Return 18346 in N_Abort_Statement 18347 | N_Assignment_Statement 18348 | N_Code_Statement 18349 | N_Delay_Statement 18350 | N_Entry_Call_Statement 18351 | N_Free_Statement 18352 | N_Goto_Statement 18353 | N_Null_Statement 18354 | N_Raise_Statement 18355 | N_Requeue_Statement 18356 | N_Exit_Statement 18357 | N_Procedure_Call_Statement; 18358 begin 18359 while Present (Par) loop 18360 Par := Parent (Par); 18361 if Nkind (Par) in N_Subexpr | 18362 N_Simple_Statement_Other_Than_Simple_Return 18363 then 18364 return False; 18365 end if; 18366 end loop; 18367 18368 return True; 18369 end; 18370 end if; 18371 18372 return False; 18373 end Is_Master; 18374 18375 ----------------------- 18376 -- Is_Name_Reference -- 18377 ----------------------- 18378 18379 function Is_Name_Reference (N : Node_Id) return Boolean is 18380 begin 18381 if Is_Entity_Name (N) then 18382 return Present (Entity (N)) and then Is_Object (Entity (N)); 18383 end if; 18384 18385 case Nkind (N) is 18386 when N_Indexed_Component 18387 | N_Slice 18388 => 18389 return 18390 Is_Name_Reference (Prefix (N)) 18391 or else Is_Access_Type (Etype (Prefix (N))); 18392 18393 -- Attributes 'Input, 'Old and 'Result produce objects 18394 18395 when N_Attribute_Reference => 18396 return Attribute_Name (N) in Name_Input | Name_Old | Name_Result; 18397 18398 when N_Selected_Component => 18399 return 18400 Is_Name_Reference (Selector_Name (N)) 18401 and then 18402 (Is_Name_Reference (Prefix (N)) 18403 or else Is_Access_Type (Etype (Prefix (N)))); 18404 18405 when N_Explicit_Dereference => 18406 return True; 18407 18408 -- A view conversion of a tagged name is a name reference 18409 18410 when N_Type_Conversion => 18411 return 18412 Is_Tagged_Type (Etype (Subtype_Mark (N))) 18413 and then Is_Tagged_Type (Etype (Expression (N))) 18414 and then Is_Name_Reference (Expression (N)); 18415 18416 -- An unchecked type conversion is considered to be a name if the 18417 -- operand is a name (this construction arises only as a result of 18418 -- expansion activities). 18419 18420 when N_Unchecked_Type_Conversion => 18421 return Is_Name_Reference (Expression (N)); 18422 18423 when others => 18424 return False; 18425 end case; 18426 end Is_Name_Reference; 18427 18428 -------------------------- 18429 -- Is_Newly_Constructed -- 18430 -------------------------- 18431 18432 function Is_Newly_Constructed 18433 (Exp : Node_Id; Context_Requires_NC : Boolean) return Boolean 18434 is 18435 Original_Exp : constant Node_Id := Original_Node (Exp); 18436 18437 function Is_NC (Exp : Node_Id) return Boolean is 18438 (Is_Newly_Constructed (Exp, Context_Requires_NC)); 18439 18440 -- If the context requires that the expression shall be newly 18441 -- constructed, then "True" is a good result in the sense that the 18442 -- expression satisfies the requirements of the context (and "False" 18443 -- is analogously a bad result). If the context requires that the 18444 -- expression shall *not* be newly constructed, then things are 18445 -- reversed: "False" is the good value and "True" is the bad value. 18446 18447 Good_Result : constant Boolean := Context_Requires_NC; 18448 Bad_Result : constant Boolean := not Good_Result; 18449 begin 18450 case Nkind (Original_Exp) is 18451 when N_Aggregate 18452 | N_Extension_Aggregate 18453 | N_Function_Call 18454 | N_Op 18455 => 18456 return True; 18457 18458 when N_Identifier => 18459 return Present (Entity (Original_Exp)) 18460 and then Ekind (Entity (Original_Exp)) = E_Function; 18461 18462 when N_Qualified_Expression => 18463 return Is_NC (Expression (Original_Exp)); 18464 18465 when N_Type_Conversion 18466 | N_Unchecked_Type_Conversion 18467 => 18468 if Is_View_Conversion (Original_Exp) then 18469 return Is_NC (Expression (Original_Exp)); 18470 elsif not Comes_From_Source (Exp) then 18471 if Exp /= Original_Exp then 18472 return Is_NC (Original_Exp); 18473 else 18474 return Is_NC (Expression (Original_Exp)); 18475 end if; 18476 else 18477 return False; 18478 end if; 18479 18480 when N_Explicit_Dereference 18481 | N_Indexed_Component 18482 | N_Selected_Component 18483 => 18484 return Nkind (Exp) = N_Function_Call; 18485 18486 -- A use of 'Input is a function call, hence allowed. Normally the 18487 -- attribute will be changed to a call, but the attribute by itself 18488 -- can occur with -gnatc. 18489 18490 when N_Attribute_Reference => 18491 return Attribute_Name (Original_Exp) = Name_Input; 18492 18493 -- "return raise ..." is OK 18494 18495 when N_Raise_Expression => 18496 return Good_Result; 18497 18498 -- For a case expression, all dependent expressions must be legal 18499 18500 when N_Case_Expression => 18501 declare 18502 Alt : Node_Id; 18503 18504 begin 18505 Alt := First (Alternatives (Original_Exp)); 18506 while Present (Alt) loop 18507 if Is_NC (Expression (Alt)) = Bad_Result then 18508 return Bad_Result; 18509 end if; 18510 18511 Next (Alt); 18512 end loop; 18513 18514 return Good_Result; 18515 end; 18516 18517 -- For an if expression, all dependent expressions must be legal 18518 18519 when N_If_Expression => 18520 declare 18521 Then_Expr : constant Node_Id := 18522 Next (First (Expressions (Original_Exp))); 18523 Else_Expr : constant Node_Id := Next (Then_Expr); 18524 begin 18525 if (Is_NC (Then_Expr) = Bad_Result) 18526 or else (Is_NC (Else_Expr) = Bad_Result) 18527 then 18528 return Bad_Result; 18529 else 18530 return Good_Result; 18531 end if; 18532 end; 18533 18534 when others => 18535 return False; 18536 end case; 18537 end Is_Newly_Constructed; 18538 18539 ------------------------------------ 18540 -- Is_Non_Preelaborable_Construct -- 18541 ------------------------------------ 18542 18543 function Is_Non_Preelaborable_Construct (N : Node_Id) return Boolean is 18544 18545 -- NOTE: the routines within Is_Non_Preelaborable_Construct are 18546 -- intentionally unnested to avoid deep indentation of code. 18547 18548 Non_Preelaborable : exception; 18549 -- This exception is raised when the construct violates preelaborability 18550 -- to terminate the recursion. 18551 18552 procedure Visit (Nod : Node_Id); 18553 -- Semantically inspect construct Nod to determine whether it violates 18554 -- preelaborability. This routine raises Non_Preelaborable. 18555 18556 procedure Visit_List (List : List_Id); 18557 pragma Inline (Visit_List); 18558 -- Invoke Visit on each element of list List. This routine raises 18559 -- Non_Preelaborable. 18560 18561 procedure Visit_Pragma (Prag : Node_Id); 18562 pragma Inline (Visit_Pragma); 18563 -- Semantically inspect pragma Prag to determine whether it violates 18564 -- preelaborability. This routine raises Non_Preelaborable. 18565 18566 procedure Visit_Subexpression (Expr : Node_Id); 18567 pragma Inline (Visit_Subexpression); 18568 -- Semantically inspect expression Expr to determine whether it violates 18569 -- preelaborability. This routine raises Non_Preelaborable. 18570 18571 ----------- 18572 -- Visit -- 18573 ----------- 18574 18575 procedure Visit (Nod : Node_Id) is 18576 begin 18577 case Nkind (Nod) is 18578 18579 -- Declarations 18580 18581 when N_Component_Declaration => 18582 18583 -- Defining_Identifier is left out because it is not relevant 18584 -- for preelaborability. 18585 18586 Visit (Component_Definition (Nod)); 18587 Visit (Expression (Nod)); 18588 18589 when N_Derived_Type_Definition => 18590 18591 -- Interface_List is left out because it is not relevant for 18592 -- preelaborability. 18593 18594 Visit (Record_Extension_Part (Nod)); 18595 Visit (Subtype_Indication (Nod)); 18596 18597 when N_Entry_Declaration => 18598 18599 -- A protected type with at leat one entry is not preelaborable 18600 -- while task types are never preelaborable. This renders entry 18601 -- declarations non-preelaborable. 18602 18603 raise Non_Preelaborable; 18604 18605 when N_Full_Type_Declaration => 18606 18607 -- Defining_Identifier and Discriminant_Specifications are left 18608 -- out because they are not relevant for preelaborability. 18609 18610 Visit (Type_Definition (Nod)); 18611 18612 when N_Function_Instantiation 18613 | N_Package_Instantiation 18614 | N_Procedure_Instantiation 18615 => 18616 -- Defining_Unit_Name and Name are left out because they are 18617 -- not relevant for preelaborability. 18618 18619 Visit_List (Generic_Associations (Nod)); 18620 18621 when N_Object_Declaration => 18622 18623 -- Defining_Identifier is left out because it is not relevant 18624 -- for preelaborability. 18625 18626 Visit (Object_Definition (Nod)); 18627 18628 if Has_Init_Expression (Nod) then 18629 Visit (Expression (Nod)); 18630 18631 elsif not Has_Preelaborable_Initialization 18632 (Etype (Defining_Entity (Nod))) 18633 then 18634 raise Non_Preelaborable; 18635 end if; 18636 18637 when N_Private_Extension_Declaration 18638 | N_Subtype_Declaration 18639 => 18640 -- Defining_Identifier, Discriminant_Specifications, and 18641 -- Interface_List are left out because they are not relevant 18642 -- for preelaborability. 18643 18644 Visit (Subtype_Indication (Nod)); 18645 18646 when N_Protected_Type_Declaration 18647 | N_Single_Protected_Declaration 18648 => 18649 -- Defining_Identifier, Discriminant_Specifications, and 18650 -- Interface_List are left out because they are not relevant 18651 -- for preelaborability. 18652 18653 Visit (Protected_Definition (Nod)); 18654 18655 -- A [single] task type is never preelaborable 18656 18657 when N_Single_Task_Declaration 18658 | N_Task_Type_Declaration 18659 => 18660 raise Non_Preelaborable; 18661 18662 -- Pragmas 18663 18664 when N_Pragma => 18665 Visit_Pragma (Nod); 18666 18667 -- Statements 18668 18669 when N_Statement_Other_Than_Procedure_Call => 18670 if Nkind (Nod) /= N_Null_Statement then 18671 raise Non_Preelaborable; 18672 end if; 18673 18674 -- Subexpressions 18675 18676 when N_Subexpr => 18677 Visit_Subexpression (Nod); 18678 18679 -- Special 18680 18681 when N_Access_To_Object_Definition => 18682 Visit (Subtype_Indication (Nod)); 18683 18684 when N_Case_Expression_Alternative => 18685 Visit (Expression (Nod)); 18686 Visit_List (Discrete_Choices (Nod)); 18687 18688 when N_Component_Definition => 18689 Visit (Access_Definition (Nod)); 18690 Visit (Subtype_Indication (Nod)); 18691 18692 when N_Component_List => 18693 Visit_List (Component_Items (Nod)); 18694 Visit (Variant_Part (Nod)); 18695 18696 when N_Constrained_Array_Definition => 18697 Visit_List (Discrete_Subtype_Definitions (Nod)); 18698 Visit (Component_Definition (Nod)); 18699 18700 when N_Delta_Constraint 18701 | N_Digits_Constraint 18702 => 18703 -- Delta_Expression and Digits_Expression are left out because 18704 -- they are not relevant for preelaborability. 18705 18706 Visit (Range_Constraint (Nod)); 18707 18708 when N_Discriminant_Specification => 18709 18710 -- Defining_Identifier and Expression are left out because they 18711 -- are not relevant for preelaborability. 18712 18713 Visit (Discriminant_Type (Nod)); 18714 18715 when N_Generic_Association => 18716 18717 -- Selector_Name is left out because it is not relevant for 18718 -- preelaborability. 18719 18720 Visit (Explicit_Generic_Actual_Parameter (Nod)); 18721 18722 when N_Index_Or_Discriminant_Constraint => 18723 Visit_List (Constraints (Nod)); 18724 18725 when N_Iterator_Specification => 18726 18727 -- Defining_Identifier is left out because it is not relevant 18728 -- for preelaborability. 18729 18730 Visit (Name (Nod)); 18731 Visit (Subtype_Indication (Nod)); 18732 18733 when N_Loop_Parameter_Specification => 18734 18735 -- Defining_Identifier is left out because it is not relevant 18736 -- for preelaborability. 18737 18738 Visit (Discrete_Subtype_Definition (Nod)); 18739 18740 when N_Parameter_Association => 18741 Visit (Explicit_Actual_Parameter (N)); 18742 18743 when N_Protected_Definition => 18744 18745 -- End_Label is left out because it is not relevant for 18746 -- preelaborability. 18747 18748 Visit_List (Private_Declarations (Nod)); 18749 Visit_List (Visible_Declarations (Nod)); 18750 18751 when N_Range_Constraint => 18752 Visit (Range_Expression (Nod)); 18753 18754 when N_Record_Definition 18755 | N_Variant 18756 => 18757 -- End_Label, Discrete_Choices, and Interface_List are left out 18758 -- because they are not relevant for preelaborability. 18759 18760 Visit (Component_List (Nod)); 18761 18762 when N_Subtype_Indication => 18763 18764 -- Subtype_Mark is left out because it is not relevant for 18765 -- preelaborability. 18766 18767 Visit (Constraint (Nod)); 18768 18769 when N_Unconstrained_Array_Definition => 18770 18771 -- Subtype_Marks is left out because it is not relevant for 18772 -- preelaborability. 18773 18774 Visit (Component_Definition (Nod)); 18775 18776 when N_Variant_Part => 18777 18778 -- Name is left out because it is not relevant for 18779 -- preelaborability. 18780 18781 Visit_List (Variants (Nod)); 18782 18783 -- Default 18784 18785 when others => 18786 null; 18787 end case; 18788 end Visit; 18789 18790 ---------------- 18791 -- Visit_List -- 18792 ---------------- 18793 18794 procedure Visit_List (List : List_Id) is 18795 Nod : Node_Id; 18796 18797 begin 18798 if Present (List) then 18799 Nod := First (List); 18800 while Present (Nod) loop 18801 Visit (Nod); 18802 Next (Nod); 18803 end loop; 18804 end if; 18805 end Visit_List; 18806 18807 ------------------ 18808 -- Visit_Pragma -- 18809 ------------------ 18810 18811 procedure Visit_Pragma (Prag : Node_Id) is 18812 begin 18813 case Get_Pragma_Id (Prag) is 18814 when Pragma_Assert 18815 | Pragma_Assert_And_Cut 18816 | Pragma_Assume 18817 | Pragma_Async_Readers 18818 | Pragma_Async_Writers 18819 | Pragma_Attribute_Definition 18820 | Pragma_Check 18821 | Pragma_Constant_After_Elaboration 18822 | Pragma_CPU 18823 | Pragma_Deadline_Floor 18824 | Pragma_Dispatching_Domain 18825 | Pragma_Effective_Reads 18826 | Pragma_Effective_Writes 18827 | Pragma_Extensions_Visible 18828 | Pragma_Ghost 18829 | Pragma_Secondary_Stack_Size 18830 | Pragma_Task_Name 18831 | Pragma_Volatile_Function 18832 => 18833 Visit_List (Pragma_Argument_Associations (Prag)); 18834 18835 -- Default 18836 18837 when others => 18838 null; 18839 end case; 18840 end Visit_Pragma; 18841 18842 ------------------------- 18843 -- Visit_Subexpression -- 18844 ------------------------- 18845 18846 procedure Visit_Subexpression (Expr : Node_Id) is 18847 procedure Visit_Aggregate (Aggr : Node_Id); 18848 pragma Inline (Visit_Aggregate); 18849 -- Semantically inspect aggregate Aggr to determine whether it 18850 -- violates preelaborability. 18851 18852 --------------------- 18853 -- Visit_Aggregate -- 18854 --------------------- 18855 18856 procedure Visit_Aggregate (Aggr : Node_Id) is 18857 begin 18858 if not Is_Preelaborable_Aggregate (Aggr) then 18859 raise Non_Preelaborable; 18860 end if; 18861 end Visit_Aggregate; 18862 18863 -- Start of processing for Visit_Subexpression 18864 18865 begin 18866 case Nkind (Expr) is 18867 when N_Allocator 18868 | N_Qualified_Expression 18869 | N_Type_Conversion 18870 | N_Unchecked_Expression 18871 | N_Unchecked_Type_Conversion 18872 => 18873 -- Subpool_Handle_Name and Subtype_Mark are left out because 18874 -- they are not relevant for preelaborability. 18875 18876 Visit (Expression (Expr)); 18877 18878 when N_Aggregate 18879 | N_Extension_Aggregate 18880 => 18881 Visit_Aggregate (Expr); 18882 18883 when N_Attribute_Reference 18884 | N_Explicit_Dereference 18885 | N_Reference 18886 => 18887 -- Attribute_Name and Expressions are left out because they are 18888 -- not relevant for preelaborability. 18889 18890 Visit (Prefix (Expr)); 18891 18892 when N_Case_Expression => 18893 18894 -- End_Span is left out because it is not relevant for 18895 -- preelaborability. 18896 18897 Visit_List (Alternatives (Expr)); 18898 Visit (Expression (Expr)); 18899 18900 when N_Delta_Aggregate => 18901 Visit_Aggregate (Expr); 18902 Visit (Expression (Expr)); 18903 18904 when N_Expression_With_Actions => 18905 Visit_List (Actions (Expr)); 18906 Visit (Expression (Expr)); 18907 18908 when N_Function_Call => 18909 18910 -- Ada 2022 (AI12-0175): Calls to certain functions that are 18911 -- essentially unchecked conversions are preelaborable. 18912 18913 if Ada_Version >= Ada_2022 18914 and then Nkind (Expr) = N_Function_Call 18915 and then Is_Entity_Name (Name (Expr)) 18916 and then Is_Preelaborable_Function (Entity (Name (Expr))) 18917 then 18918 Visit_List (Parameter_Associations (Expr)); 18919 else 18920 raise Non_Preelaborable; 18921 end if; 18922 18923 when N_If_Expression => 18924 Visit_List (Expressions (Expr)); 18925 18926 when N_Quantified_Expression => 18927 Visit (Condition (Expr)); 18928 Visit (Iterator_Specification (Expr)); 18929 Visit (Loop_Parameter_Specification (Expr)); 18930 18931 when N_Range => 18932 Visit (High_Bound (Expr)); 18933 Visit (Low_Bound (Expr)); 18934 18935 when N_Slice => 18936 Visit (Discrete_Range (Expr)); 18937 Visit (Prefix (Expr)); 18938 18939 -- Default 18940 18941 when others => 18942 18943 -- The evaluation of an object name is not preelaborable, 18944 -- unless the name is a static expression (checked further 18945 -- below), or statically denotes a discriminant. 18946 18947 if Is_Entity_Name (Expr) then 18948 Object_Name : declare 18949 Id : constant Entity_Id := Entity (Expr); 18950 18951 begin 18952 if Is_Object (Id) then 18953 if Ekind (Id) = E_Discriminant then 18954 null; 18955 18956 elsif Ekind (Id) in E_Constant | E_In_Parameter 18957 and then Present (Discriminal_Link (Id)) 18958 then 18959 null; 18960 18961 else 18962 raise Non_Preelaborable; 18963 end if; 18964 end if; 18965 end Object_Name; 18966 18967 -- A non-static expression is not preelaborable 18968 18969 elsif not Is_OK_Static_Expression (Expr) then 18970 raise Non_Preelaborable; 18971 end if; 18972 end case; 18973 end Visit_Subexpression; 18974 18975 -- Start of processing for Is_Non_Preelaborable_Construct 18976 18977 begin 18978 Visit (N); 18979 18980 -- At this point it is known that the construct is preelaborable 18981 18982 return False; 18983 18984 exception 18985 18986 -- The elaboration of the construct performs an action which violates 18987 -- preelaborability. 18988 18989 when Non_Preelaborable => 18990 return True; 18991 end Is_Non_Preelaborable_Construct; 18992 18993 --------------------------------- 18994 -- Is_Nontrivial_DIC_Procedure -- 18995 --------------------------------- 18996 18997 function Is_Nontrivial_DIC_Procedure (Id : Entity_Id) return Boolean is 18998 Body_Decl : Node_Id; 18999 Stmt : Node_Id; 19000 19001 begin 19002 if Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id) then 19003 Body_Decl := 19004 Unit_Declaration_Node 19005 (Corresponding_Body (Unit_Declaration_Node (Id))); 19006 19007 -- The body of the Default_Initial_Condition procedure must contain 19008 -- at least one statement, otherwise the generation of the subprogram 19009 -- body failed. 19010 19011 pragma Assert (Present (Handled_Statement_Sequence (Body_Decl))); 19012 19013 -- To qualify as nontrivial, the first statement of the procedure 19014 -- must be a check in the form of an if statement. If the original 19015 -- Default_Initial_Condition expression was folded, then the first 19016 -- statement is not a check. 19017 19018 Stmt := First (Statements (Handled_Statement_Sequence (Body_Decl))); 19019 19020 return 19021 Nkind (Stmt) = N_If_Statement 19022 and then Nkind (Original_Node (Stmt)) = N_Pragma; 19023 end if; 19024 19025 return False; 19026 end Is_Nontrivial_DIC_Procedure; 19027 19028 ----------------------- 19029 -- Is_Null_Extension -- 19030 ----------------------- 19031 19032 function Is_Null_Extension 19033 (T : Entity_Id; Ignore_Privacy : Boolean := False) return Boolean 19034 is 19035 Type_Decl : Node_Id; 19036 Type_Def : Node_Id; 19037 begin 19038 if Ignore_Privacy then 19039 Type_Decl := Parent (Underlying_Type (Base_Type (T))); 19040 else 19041 Type_Decl := Parent (Base_Type (T)); 19042 if Nkind (Type_Decl) /= N_Full_Type_Declaration then 19043 return False; 19044 end if; 19045 end if; 19046 pragma Assert (Nkind (Type_Decl) = N_Full_Type_Declaration); 19047 Type_Def := Type_Definition (Type_Decl); 19048 if Present (Discriminant_Specifications (Type_Decl)) 19049 or else Nkind (Type_Def) /= N_Derived_Type_Definition 19050 or else not Is_Tagged_Type (T) 19051 or else No (Record_Extension_Part (Type_Def)) 19052 then 19053 return False; 19054 end if; 19055 19056 return Is_Null_Record_Definition (Record_Extension_Part (Type_Def)); 19057 end Is_Null_Extension; 19058 19059 -------------------------- 19060 -- Is_Null_Extension_Of -- 19061 -------------------------- 19062 19063 function Is_Null_Extension_Of 19064 (Descendant, Ancestor : Entity_Id) return Boolean 19065 is 19066 Ancestor_Type : constant Entity_Id 19067 := Underlying_Type (Base_Type (Ancestor)); 19068 Descendant_Type : Entity_Id := Underlying_Type (Base_Type (Descendant)); 19069 begin 19070 pragma Assert (Descendant_Type /= Ancestor_Type); 19071 while Descendant_Type /= Ancestor_Type loop 19072 if not Is_Null_Extension 19073 (Descendant_Type, Ignore_Privacy => True) 19074 then 19075 return False; 19076 end if; 19077 Descendant_Type := Etype (Subtype_Indication 19078 (Type_Definition (Parent (Descendant_Type)))); 19079 Descendant_Type := Underlying_Type (Base_Type (Descendant_Type)); 19080 end loop; 19081 return True; 19082 end Is_Null_Extension_Of; 19083 19084 ------------------------------- 19085 -- Is_Null_Record_Definition -- 19086 ------------------------------- 19087 19088 function Is_Null_Record_Definition (Record_Def : Node_Id) return Boolean is 19089 Item : Node_Id; 19090 begin 19091 -- Testing Null_Present is just an optimization, not required. 19092 19093 if Null_Present (Record_Def) then 19094 return True; 19095 elsif Present (Variant_Part (Component_List (Record_Def))) then 19096 return False; 19097 elsif not Present (Component_List (Record_Def)) then 19098 return True; 19099 end if; 19100 19101 Item := First (Component_Items (Component_List (Record_Def))); 19102 19103 while Present (Item) loop 19104 if Nkind (Item) = N_Component_Declaration 19105 and then Is_Internal_Name (Chars (Defining_Identifier (Item))) 19106 then 19107 null; 19108 elsif Nkind (Item) = N_Pragma then 19109 null; 19110 else 19111 return False; 19112 end if; 19113 Item := Next (Item); 19114 end loop; 19115 19116 return True; 19117 end Is_Null_Record_Definition; 19118 19119 ------------------------- 19120 -- Is_Null_Record_Type -- 19121 ------------------------- 19122 19123 function Is_Null_Record_Type 19124 (T : Entity_Id; Ignore_Privacy : Boolean := False) return Boolean 19125 is 19126 Decl : Node_Id; 19127 Type_Def : Node_Id; 19128 begin 19129 if not Is_Record_Type (T) then 19130 return False; 19131 end if; 19132 19133 if Ignore_Privacy then 19134 Decl := Parent (Underlying_Type (Base_Type (T))); 19135 else 19136 Decl := Parent (Base_Type (T)); 19137 if Nkind (Decl) /= N_Full_Type_Declaration then 19138 return False; 19139 end if; 19140 end if; 19141 pragma Assert (Nkind (Decl) = N_Full_Type_Declaration); 19142 Type_Def := Type_Definition (Decl); 19143 19144 if Has_Discriminants (Defining_Identifier (Decl)) then 19145 return False; 19146 end if; 19147 19148 case Nkind (Type_Def) is 19149 when N_Record_Definition => 19150 return Is_Null_Record_Definition (Type_Def); 19151 when N_Derived_Type_Definition => 19152 if not Is_Null_Record_Type 19153 (Etype (Subtype_Indication (Type_Def)), 19154 Ignore_Privacy => Ignore_Privacy) 19155 then 19156 return False; 19157 elsif not Is_Tagged_Type (T) then 19158 return True; 19159 else 19160 return Is_Null_Extension (T, Ignore_Privacy => Ignore_Privacy); 19161 end if; 19162 when others => 19163 return False; 19164 end case; 19165 end Is_Null_Record_Type; 19166 19167 --------------------- 19168 -- Is_Object_Image -- 19169 --------------------- 19170 19171 function Is_Object_Image (Prefix : Node_Id) return Boolean is 19172 begin 19173 -- Here we test for the case that the prefix is not a type and assume 19174 -- if it is not then it must be a named value or an object reference. 19175 -- This is because the parser always checks that prefixes of attributes 19176 -- are named. 19177 19178 return not (Is_Entity_Name (Prefix) 19179 and then Is_Type (Entity (Prefix)) 19180 and then not Is_Current_Instance (Prefix)); 19181 end Is_Object_Image; 19182 19183 ------------------------- 19184 -- Is_Object_Reference -- 19185 ------------------------- 19186 19187 function Is_Object_Reference (N : Node_Id) return Boolean is 19188 function Safe_Prefix (N : Node_Id) return Node_Id; 19189 -- Return Prefix (N) unless it has been rewritten as an 19190 -- N_Raise_xxx_Error node, in which case return its original node. 19191 19192 ----------------- 19193 -- Safe_Prefix -- 19194 ----------------- 19195 19196 function Safe_Prefix (N : Node_Id) return Node_Id is 19197 begin 19198 if Nkind (Prefix (N)) in N_Raise_xxx_Error then 19199 return Original_Node (Prefix (N)); 19200 else 19201 return Prefix (N); 19202 end if; 19203 end Safe_Prefix; 19204 19205 begin 19206 -- AI12-0068: Note that a current instance reference in a type or 19207 -- subtype's aspect_specification is considered a value, not an object 19208 -- (see RM 8.6(18/5)). 19209 19210 if Is_Entity_Name (N) then 19211 return Present (Entity (N)) and then Is_Object (Entity (N)) 19212 and then not Is_Current_Instance_Reference_In_Type_Aspect (N); 19213 19214 else 19215 case Nkind (N) is 19216 when N_Indexed_Component 19217 | N_Slice 19218 => 19219 return 19220 Is_Object_Reference (Safe_Prefix (N)) 19221 or else Is_Access_Type (Etype (Safe_Prefix (N))); 19222 19223 -- In Ada 95, a function call is a constant object; a procedure 19224 -- call is not. 19225 19226 -- Note that predefined operators are functions as well, and so 19227 -- are attributes that are (can be renamed as) functions. 19228 19229 when N_Function_Call 19230 | N_Op 19231 => 19232 return Etype (N) /= Standard_Void_Type; 19233 19234 -- Attributes references 'Loop_Entry, 'Old, 'Priority and 'Result 19235 -- yield objects, even though they are not functions. 19236 19237 when N_Attribute_Reference => 19238 return 19239 Attribute_Name (N) in Name_Loop_Entry 19240 | Name_Old 19241 | Name_Priority 19242 | Name_Result 19243 or else Is_Function_Attribute_Name (Attribute_Name (N)); 19244 19245 when N_Selected_Component => 19246 return 19247 Is_Object_Reference (Selector_Name (N)) 19248 and then 19249 (Is_Object_Reference (Safe_Prefix (N)) 19250 or else Is_Access_Type (Etype (Safe_Prefix (N)))); 19251 19252 -- An explicit dereference denotes an object, except that a 19253 -- conditional expression gets turned into an explicit dereference 19254 -- in some cases, and conditional expressions are not object 19255 -- names. 19256 19257 when N_Explicit_Dereference => 19258 return Nkind (Original_Node (N)) not in 19259 N_Case_Expression | N_If_Expression; 19260 19261 -- A view conversion of a tagged object is an object reference 19262 19263 when N_Type_Conversion => 19264 if Ada_Version <= Ada_2012 then 19265 -- A view conversion of a tagged object is an object 19266 -- reference. 19267 return Is_Tagged_Type (Etype (Subtype_Mark (N))) 19268 and then Is_Tagged_Type (Etype (Expression (N))) 19269 and then Is_Object_Reference (Expression (N)); 19270 19271 else 19272 -- AI12-0226: In Ada 2022 a value conversion of an object is 19273 -- an object. 19274 19275 return Is_Object_Reference (Expression (N)); 19276 end if; 19277 19278 -- An unchecked type conversion is considered to be an object if 19279 -- the operand is an object (this construction arises only as a 19280 -- result of expansion activities). 19281 19282 when N_Unchecked_Type_Conversion => 19283 return True; 19284 19285 -- AI05-0003: In Ada 2012 a qualified expression is a name. 19286 -- This allows disambiguation of function calls and the use 19287 -- of aggregates in more contexts. 19288 19289 when N_Qualified_Expression => 19290 return Ada_Version >= Ada_2012 19291 and then Is_Object_Reference (Expression (N)); 19292 19293 -- In Ada 95 an aggregate is an object reference 19294 19295 when N_Aggregate 19296 | N_Delta_Aggregate 19297 | N_Extension_Aggregate 19298 => 19299 return Ada_Version >= Ada_95; 19300 19301 -- A string literal is not an object reference, but it might come 19302 -- from rewriting of an object reference, e.g. from folding of an 19303 -- aggregate. 19304 19305 when N_String_Literal => 19306 return Is_Rewrite_Substitution (N) 19307 and then Is_Object_Reference (Original_Node (N)); 19308 19309 -- AI12-0125: Target name represents a constant object 19310 19311 when N_Target_Name => 19312 return True; 19313 19314 when others => 19315 return False; 19316 end case; 19317 end if; 19318 end Is_Object_Reference; 19319 19320 ----------------------------------- 19321 -- Is_OK_Variable_For_Out_Formal -- 19322 ----------------------------------- 19323 19324 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is 19325 begin 19326 Note_Possible_Modification (AV, Sure => True); 19327 19328 -- We must reject parenthesized variable names. Comes_From_Source is 19329 -- checked because there are currently cases where the compiler violates 19330 -- this rule (e.g. passing a task object to its controlled Initialize 19331 -- routine). This should be properly documented in sinfo??? 19332 19333 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then 19334 return False; 19335 19336 -- A variable is always allowed 19337 19338 elsif Is_Variable (AV) then 19339 return True; 19340 19341 -- Generalized indexing operations are rewritten as explicit 19342 -- dereferences, and it is only during resolution that we can 19343 -- check whether the context requires an access_to_variable type. 19344 19345 elsif Nkind (AV) = N_Explicit_Dereference 19346 and then Present (Etype (Original_Node (AV))) 19347 and then Has_Implicit_Dereference (Etype (Original_Node (AV))) 19348 and then Ada_Version >= Ada_2012 19349 then 19350 return not Is_Access_Constant (Etype (Prefix (AV))); 19351 19352 -- Unchecked conversions are allowed only if they come from the 19353 -- generated code, which sometimes uses unchecked conversions for out 19354 -- parameters in cases where code generation is unaffected. We tell 19355 -- source unchecked conversions by seeing if they are rewrites of 19356 -- an original Unchecked_Conversion function call, or of an explicit 19357 -- conversion of a function call or an aggregate (as may happen in the 19358 -- expansion of a packed array aggregate). 19359 19360 elsif Nkind (AV) = N_Unchecked_Type_Conversion then 19361 if Nkind (Original_Node (AV)) in N_Function_Call | N_Aggregate then 19362 return False; 19363 19364 elsif Comes_From_Source (AV) 19365 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call 19366 then 19367 return False; 19368 19369 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then 19370 return Is_OK_Variable_For_Out_Formal (Expression (AV)); 19371 19372 else 19373 return True; 19374 end if; 19375 19376 -- Normal type conversions are allowed if argument is a variable 19377 19378 elsif Nkind (AV) = N_Type_Conversion then 19379 if Is_Variable (Expression (AV)) 19380 and then Paren_Count (Expression (AV)) = 0 19381 then 19382 Note_Possible_Modification (Expression (AV), Sure => True); 19383 return True; 19384 19385 -- We also allow a non-parenthesized expression that raises 19386 -- constraint error if it rewrites what used to be a variable 19387 19388 elsif Raises_Constraint_Error (Expression (AV)) 19389 and then Paren_Count (Expression (AV)) = 0 19390 and then Is_Variable (Original_Node (Expression (AV))) 19391 then 19392 return True; 19393 19394 -- Type conversion of something other than a variable 19395 19396 else 19397 return False; 19398 end if; 19399 19400 -- If this node is rewritten, then test the original form, if that is 19401 -- OK, then we consider the rewritten node OK (for example, if the 19402 -- original node is a conversion, then Is_Variable will not be true 19403 -- but we still want to allow the conversion if it converts a variable). 19404 19405 elsif Is_Rewrite_Substitution (AV) then 19406 return Is_OK_Variable_For_Out_Formal (Original_Node (AV)); 19407 19408 -- All other non-variables are rejected 19409 19410 else 19411 return False; 19412 end if; 19413 end Is_OK_Variable_For_Out_Formal; 19414 19415 ---------------------------- 19416 -- Is_OK_Volatile_Context -- 19417 ---------------------------- 19418 19419 function Is_OK_Volatile_Context 19420 (Context : Node_Id; 19421 Obj_Ref : Node_Id; 19422 Check_Actuals : Boolean) return Boolean 19423 is 19424 function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean; 19425 -- Determine whether an arbitrary node denotes a call to a protected 19426 -- entry, function, or procedure in prefixed form where the prefix is 19427 -- Obj_Ref. 19428 19429 function Within_Check (Nod : Node_Id) return Boolean; 19430 -- Determine whether an arbitrary node appears in a check node 19431 19432 function Within_Volatile_Function (Id : Entity_Id) return Boolean; 19433 -- Determine whether an arbitrary entity appears in a volatile function 19434 19435 --------------------------------- 19436 -- Is_Protected_Operation_Call -- 19437 --------------------------------- 19438 19439 function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean is 19440 Pref : Node_Id; 19441 Subp : Node_Id; 19442 19443 begin 19444 -- A call to a protected operations retains its selected component 19445 -- form as opposed to other prefixed calls that are transformed in 19446 -- expanded names. 19447 19448 if Nkind (Nod) = N_Selected_Component then 19449 Pref := Prefix (Nod); 19450 Subp := Selector_Name (Nod); 19451 19452 return 19453 Pref = Obj_Ref 19454 and then Present (Etype (Pref)) 19455 and then Is_Protected_Type (Etype (Pref)) 19456 and then Is_Entity_Name (Subp) 19457 and then Present (Entity (Subp)) 19458 and then Ekind (Entity (Subp)) in 19459 E_Entry | E_Entry_Family | E_Function | E_Procedure; 19460 else 19461 return False; 19462 end if; 19463 end Is_Protected_Operation_Call; 19464 19465 ------------------ 19466 -- Within_Check -- 19467 ------------------ 19468 19469 function Within_Check (Nod : Node_Id) return Boolean is 19470 Par : Node_Id; 19471 19472 begin 19473 -- Climb the parent chain looking for a check node 19474 19475 Par := Nod; 19476 while Present (Par) loop 19477 if Nkind (Par) in N_Raise_xxx_Error then 19478 return True; 19479 19480 -- Prevent the search from going too far 19481 19482 elsif Is_Body_Or_Package_Declaration (Par) then 19483 exit; 19484 end if; 19485 19486 Par := Parent (Par); 19487 end loop; 19488 19489 return False; 19490 end Within_Check; 19491 19492 ------------------------------ 19493 -- Within_Volatile_Function -- 19494 ------------------------------ 19495 19496 function Within_Volatile_Function (Id : Entity_Id) return Boolean is 19497 pragma Assert (Ekind (Id) = E_Return_Statement); 19498 19499 Func_Id : constant Entity_Id := Return_Applies_To (Id); 19500 19501 begin 19502 pragma Assert (Ekind (Func_Id) in E_Function | E_Generic_Function); 19503 19504 return Is_Volatile_Function (Func_Id); 19505 end Within_Volatile_Function; 19506 19507 -- Local variables 19508 19509 Obj_Id : Entity_Id; 19510 19511 -- Start of processing for Is_OK_Volatile_Context 19512 19513 begin 19514 -- Ignore context restriction when doing preanalysis, e.g. on a copy of 19515 -- an expression function, because this copy is not fully decorated and 19516 -- it is not possible to reliably decide the legality of the context. 19517 -- Any violations will be reported anyway when doing the full analysis. 19518 19519 if not Full_Analysis then 19520 return True; 19521 end if; 19522 19523 -- For actual parameters within explicit parameter associations switch 19524 -- the context to the corresponding subprogram call. 19525 19526 if Nkind (Context) = N_Parameter_Association then 19527 return Is_OK_Volatile_Context (Context => Parent (Context), 19528 Obj_Ref => Obj_Ref, 19529 Check_Actuals => Check_Actuals); 19530 19531 -- The volatile object appears on either side of an assignment 19532 19533 elsif Nkind (Context) = N_Assignment_Statement then 19534 return True; 19535 19536 -- The volatile object is part of the initialization expression of 19537 -- another object. 19538 19539 elsif Nkind (Context) = N_Object_Declaration 19540 and then Present (Expression (Context)) 19541 and then Expression (Context) = Obj_Ref 19542 and then Nkind (Parent (Context)) /= N_Expression_With_Actions 19543 then 19544 Obj_Id := Defining_Entity (Context); 19545 19546 -- The volatile object acts as the initialization expression of an 19547 -- extended return statement. This is valid context as long as the 19548 -- function is volatile. 19549 19550 if Is_Return_Object (Obj_Id) then 19551 return Within_Volatile_Function (Scope (Obj_Id)); 19552 19553 -- Otherwise this is a normal object initialization 19554 19555 else 19556 return True; 19557 end if; 19558 19559 -- The volatile object acts as the name of a renaming declaration 19560 19561 elsif Nkind (Context) = N_Object_Renaming_Declaration 19562 and then Name (Context) = Obj_Ref 19563 then 19564 return True; 19565 19566 -- The volatile object appears as an actual parameter in a call to an 19567 -- instance of Unchecked_Conversion whose result is renamed. 19568 19569 elsif Nkind (Context) = N_Function_Call 19570 and then Is_Entity_Name (Name (Context)) 19571 and then Is_Unchecked_Conversion_Instance (Entity (Name (Context))) 19572 and then Nkind (Parent (Context)) = N_Object_Renaming_Declaration 19573 then 19574 return True; 19575 19576 -- The volatile object is actually the prefix in a protected entry, 19577 -- function, or procedure call. 19578 19579 elsif Is_Protected_Operation_Call (Context) then 19580 return True; 19581 19582 -- The volatile object appears as the expression of a simple return 19583 -- statement that applies to a volatile function. 19584 19585 elsif Nkind (Context) = N_Simple_Return_Statement 19586 and then Expression (Context) = Obj_Ref 19587 then 19588 return 19589 Within_Volatile_Function (Return_Statement_Entity (Context)); 19590 19591 -- The volatile object appears as the prefix of a name occurring in a 19592 -- non-interfering context. 19593 19594 elsif Nkind (Context) in 19595 N_Attribute_Reference | 19596 N_Explicit_Dereference | 19597 N_Indexed_Component | 19598 N_Selected_Component | 19599 N_Slice 19600 and then Prefix (Context) = Obj_Ref 19601 and then Is_OK_Volatile_Context 19602 (Context => Parent (Context), 19603 Obj_Ref => Context, 19604 Check_Actuals => Check_Actuals) 19605 then 19606 return True; 19607 19608 -- The volatile object appears as the prefix of attributes Address, 19609 -- Alignment, Component_Size, First, First_Bit, Last, Last_Bit, Length, 19610 -- Position, Size, Storage_Size. 19611 19612 elsif Nkind (Context) = N_Attribute_Reference 19613 and then Prefix (Context) = Obj_Ref 19614 and then Attribute_Name (Context) in Name_Address 19615 | Name_Alignment 19616 | Name_Component_Size 19617 | Name_First 19618 | Name_First_Bit 19619 | Name_Last 19620 | Name_Last_Bit 19621 | Name_Length 19622 | Name_Position 19623 | Name_Size 19624 | Name_Storage_Size 19625 then 19626 return True; 19627 19628 -- The volatile object appears as the expression of a type conversion 19629 -- occurring in a non-interfering context. 19630 19631 elsif Nkind (Context) in N_Qualified_Expression 19632 | N_Type_Conversion 19633 | N_Unchecked_Type_Conversion 19634 and then Expression (Context) = Obj_Ref 19635 and then Is_OK_Volatile_Context 19636 (Context => Parent (Context), 19637 Obj_Ref => Context, 19638 Check_Actuals => Check_Actuals) 19639 then 19640 return True; 19641 19642 -- The volatile object appears as the expression in a delay statement 19643 19644 elsif Nkind (Context) in N_Delay_Statement then 19645 return True; 19646 19647 -- Allow references to volatile objects in various checks. This is not a 19648 -- direct SPARK 2014 requirement. 19649 19650 elsif Within_Check (Context) then 19651 return True; 19652 19653 -- References to effectively volatile objects that appear as actual 19654 -- parameters in subprogram calls can be examined only after call itself 19655 -- has been resolved. Before that, assume such references to be legal. 19656 19657 elsif Nkind (Context) in N_Subprogram_Call | N_Entry_Call_Statement then 19658 if Check_Actuals then 19659 declare 19660 Call : Node_Id; 19661 Formal : Entity_Id; 19662 Subp : constant Entity_Id := Get_Called_Entity (Context); 19663 begin 19664 Find_Actual (Obj_Ref, Formal, Call); 19665 pragma Assert (Call = Context); 19666 19667 -- An effectively volatile object may act as an actual when the 19668 -- corresponding formal is of a non-scalar effectively volatile 19669 -- type (SPARK RM 7.1.3(10)). 19670 19671 if not Is_Scalar_Type (Etype (Formal)) 19672 and then Is_Effectively_Volatile_For_Reading (Etype (Formal)) 19673 then 19674 return True; 19675 19676 -- An effectively volatile object may act as an actual in a 19677 -- call to an instance of Unchecked_Conversion. (SPARK RM 19678 -- 7.1.3(10)). 19679 19680 elsif Is_Unchecked_Conversion_Instance (Subp) then 19681 return True; 19682 19683 else 19684 return False; 19685 end if; 19686 end; 19687 else 19688 return True; 19689 end if; 19690 else 19691 return False; 19692 end if; 19693 end Is_OK_Volatile_Context; 19694 19695 ------------------------------------ 19696 -- Is_Package_Contract_Annotation -- 19697 ------------------------------------ 19698 19699 function Is_Package_Contract_Annotation (Item : Node_Id) return Boolean is 19700 Nam : Name_Id; 19701 19702 begin 19703 if Nkind (Item) = N_Aspect_Specification then 19704 Nam := Chars (Identifier (Item)); 19705 19706 else pragma Assert (Nkind (Item) = N_Pragma); 19707 Nam := Pragma_Name (Item); 19708 end if; 19709 19710 return Nam = Name_Abstract_State 19711 or else Nam = Name_Initial_Condition 19712 or else Nam = Name_Initializes 19713 or else Nam = Name_Refined_State; 19714 end Is_Package_Contract_Annotation; 19715 19716 ----------------------------------- 19717 -- Is_Partially_Initialized_Type -- 19718 ----------------------------------- 19719 19720 function Is_Partially_Initialized_Type 19721 (Typ : Entity_Id; 19722 Include_Implicit : Boolean := True) return Boolean 19723 is 19724 begin 19725 if Is_Scalar_Type (Typ) then 19726 return Has_Default_Aspect (Base_Type (Typ)); 19727 19728 elsif Is_Access_Type (Typ) then 19729 return Include_Implicit; 19730 19731 elsif Is_Array_Type (Typ) then 19732 19733 -- If component type is partially initialized, so is array type 19734 19735 if Has_Default_Aspect (Base_Type (Typ)) 19736 or else Is_Partially_Initialized_Type 19737 (Component_Type (Typ), Include_Implicit) 19738 then 19739 return True; 19740 19741 -- Otherwise we are only partially initialized if we are fully 19742 -- initialized (this is the empty array case, no point in us 19743 -- duplicating that code here). 19744 19745 else 19746 return Is_Fully_Initialized_Type (Typ); 19747 end if; 19748 19749 elsif Is_Record_Type (Typ) then 19750 19751 -- A discriminated type is always partially initialized if in 19752 -- all mode 19753 19754 if Has_Discriminants (Typ) and then Include_Implicit then 19755 return True; 19756 19757 -- A tagged type is always partially initialized 19758 19759 elsif Is_Tagged_Type (Typ) then 19760 return True; 19761 19762 -- Case of nondiscriminated record 19763 19764 else 19765 declare 19766 Comp : Entity_Id; 19767 19768 Component_Present : Boolean := False; 19769 -- Set True if at least one component is present. If no 19770 -- components are present, then record type is fully 19771 -- initialized (another odd case, like the null array). 19772 19773 begin 19774 -- Loop through components 19775 19776 Comp := First_Component (Typ); 19777 while Present (Comp) loop 19778 Component_Present := True; 19779 19780 -- If a component has an initialization expression then the 19781 -- enclosing record type is partially initialized 19782 19783 if Present (Parent (Comp)) 19784 and then Present (Expression (Parent (Comp))) 19785 then 19786 return True; 19787 19788 -- If a component is of a type which is itself partially 19789 -- initialized, then the enclosing record type is also. 19790 19791 elsif Is_Partially_Initialized_Type 19792 (Etype (Comp), Include_Implicit) 19793 then 19794 return True; 19795 end if; 19796 19797 Next_Component (Comp); 19798 end loop; 19799 19800 -- No initialized components found. If we found any components 19801 -- they were all uninitialized so the result is false. 19802 19803 if Component_Present then 19804 return False; 19805 19806 -- But if we found no components, then all the components are 19807 -- initialized so we consider the type to be initialized. 19808 19809 else 19810 return True; 19811 end if; 19812 end; 19813 end if; 19814 19815 -- Concurrent types are always fully initialized 19816 19817 elsif Is_Concurrent_Type (Typ) then 19818 return True; 19819 19820 -- For a private type, go to underlying type. If there is no underlying 19821 -- type then just assume this partially initialized. Not clear if this 19822 -- can happen in a non-error case, but no harm in testing for this. 19823 19824 elsif Is_Private_Type (Typ) then 19825 declare 19826 U : constant Entity_Id := Underlying_Type (Typ); 19827 begin 19828 if No (U) then 19829 return True; 19830 else 19831 return Is_Partially_Initialized_Type (U, Include_Implicit); 19832 end if; 19833 end; 19834 19835 -- For any other type (are there any?) assume partially initialized 19836 19837 else 19838 return True; 19839 end if; 19840 end Is_Partially_Initialized_Type; 19841 19842 ------------------------------------ 19843 -- Is_Potentially_Persistent_Type -- 19844 ------------------------------------ 19845 19846 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is 19847 Comp : Entity_Id; 19848 Indx : Node_Id; 19849 19850 begin 19851 -- For private type, test corresponding full type 19852 19853 if Is_Private_Type (T) then 19854 return Is_Potentially_Persistent_Type (Full_View (T)); 19855 19856 -- Scalar types are potentially persistent 19857 19858 elsif Is_Scalar_Type (T) then 19859 return True; 19860 19861 -- Record type is potentially persistent if not tagged and the types of 19862 -- all it components are potentially persistent, and no component has 19863 -- an initialization expression. 19864 19865 elsif Is_Record_Type (T) 19866 and then not Is_Tagged_Type (T) 19867 and then not Is_Partially_Initialized_Type (T) 19868 then 19869 Comp := First_Component (T); 19870 while Present (Comp) loop 19871 if not Is_Potentially_Persistent_Type (Etype (Comp)) then 19872 return False; 19873 else 19874 Next_Entity (Comp); 19875 end if; 19876 end loop; 19877 19878 return True; 19879 19880 -- Array type is potentially persistent if its component type is 19881 -- potentially persistent and if all its constraints are static. 19882 19883 elsif Is_Array_Type (T) then 19884 if not Is_Potentially_Persistent_Type (Component_Type (T)) then 19885 return False; 19886 end if; 19887 19888 Indx := First_Index (T); 19889 while Present (Indx) loop 19890 if not Is_OK_Static_Subtype (Etype (Indx)) then 19891 return False; 19892 else 19893 Next_Index (Indx); 19894 end if; 19895 end loop; 19896 19897 return True; 19898 19899 -- All other types are not potentially persistent 19900 19901 else 19902 return False; 19903 end if; 19904 end Is_Potentially_Persistent_Type; 19905 19906 -------------------------------- 19907 -- Is_Potentially_Unevaluated -- 19908 -------------------------------- 19909 19910 function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is 19911 function Has_Null_Others_Choice (Aggr : Node_Id) return Boolean; 19912 -- Aggr is an array aggregate with static bounds and an others clause; 19913 -- return True if the others choice of the given array aggregate does 19914 -- not cover any component (i.e. is null). 19915 19916 function Immediate_Context_Implies_Is_Potentially_Unevaluated 19917 (Expr : Node_Id) return Boolean; 19918 -- Return True if the *immediate* context of this expression tells us 19919 -- that it is potentially unevaluated; return False if the *immediate* 19920 -- context doesn't provide an answer to this question and we need to 19921 -- keep looking. 19922 19923 function Non_Static_Or_Null_Range (N : Node_Id) return Boolean; 19924 -- Return True if the given range is nonstatic or null 19925 19926 ---------------------------- 19927 -- Has_Null_Others_Choice -- 19928 ---------------------------- 19929 19930 function Has_Null_Others_Choice (Aggr : Node_Id) return Boolean is 19931 Idx : constant Node_Id := First_Index (Etype (Aggr)); 19932 Hiv : constant Uint := Expr_Value (Type_High_Bound (Etype (Idx))); 19933 Lov : constant Uint := Expr_Value (Type_Low_Bound (Etype (Idx))); 19934 19935 begin 19936 declare 19937 Intervals : constant Interval_Lists.Discrete_Interval_List := 19938 Interval_Lists.Aggregate_Intervals (Aggr); 19939 19940 begin 19941 -- The others choice is null if, after normalization, we 19942 -- have a single interval covering the whole aggregate. 19943 19944 return Intervals'Length = 1 19945 and then 19946 Intervals (Intervals'First).Low = Lov 19947 and then 19948 Intervals (Intervals'First).High = Hiv; 19949 end; 19950 19951 -- If the aggregate is malformed (that is, indexes are not disjoint) 19952 -- then no action is needed at this stage; the error will be reported 19953 -- later by the frontend. 19954 19955 exception 19956 when Interval_Lists.Intervals_Error => 19957 return False; 19958 end Has_Null_Others_Choice; 19959 19960 ---------------------------------------------------------- 19961 -- Immediate_Context_Implies_Is_Potentially_Unevaluated -- 19962 ---------------------------------------------------------- 19963 19964 function Immediate_Context_Implies_Is_Potentially_Unevaluated 19965 (Expr : Node_Id) return Boolean 19966 is 19967 Par : constant Node_Id := Parent (Expr); 19968 19969 function Aggregate_Type return Node_Id is (Etype (Parent (Par))); 19970 begin 19971 if Nkind (Par) = N_If_Expression then 19972 return Is_Elsif (Par) or else Expr /= First (Expressions (Par)); 19973 19974 elsif Nkind (Par) = N_Case_Expression then 19975 return Expr /= Expression (Par); 19976 19977 elsif Nkind (Par) in N_And_Then | N_Or_Else then 19978 return Expr = Right_Opnd (Par); 19979 19980 elsif Nkind (Par) in N_In | N_Not_In then 19981 19982 -- If the membership includes several alternatives, only the first 19983 -- is definitely evaluated. 19984 19985 if Present (Alternatives (Par)) then 19986 return Expr /= First (Alternatives (Par)); 19987 19988 -- If this is a range membership both bounds are evaluated 19989 19990 else 19991 return False; 19992 end if; 19993 19994 elsif Nkind (Par) = N_Quantified_Expression then 19995 return Expr = Condition (Par); 19996 19997 elsif Nkind (Par) = N_Component_Association 19998 and then Expr = Expression (Par) 19999 and then Nkind (Parent (Par)) 20000 in N_Aggregate | N_Delta_Aggregate | N_Extension_Aggregate 20001 and then Present (Aggregate_Type) 20002 and then Aggregate_Type /= Any_Composite 20003 then 20004 if Is_Array_Type (Aggregate_Type) then 20005 if Ada_Version >= Ada_2022 then 20006 -- For Ada 2022, this predicate returns True for 20007 -- any "repeatedly evaluated" expression. 20008 return True; 20009 end if; 20010 20011 declare 20012 Choice : Node_Id; 20013 In_Others_Choice : Boolean := False; 20014 Array_Agg : constant Node_Id := Parent (Par); 20015 begin 20016 -- The expression of an array_component_association is 20017 -- potentially unevaluated if the associated choice is a 20018 -- subtype_indication or range that defines a nonstatic or 20019 -- null range. 20020 20021 Choice := First (Choices (Par)); 20022 while Present (Choice) loop 20023 if Nkind (Choice) = N_Range 20024 and then Non_Static_Or_Null_Range (Choice) 20025 then 20026 return True; 20027 20028 elsif Nkind (Choice) = N_Identifier 20029 and then Present (Scalar_Range (Etype (Choice))) 20030 and then 20031 Non_Static_Or_Null_Range 20032 (Scalar_Range (Etype (Choice))) 20033 then 20034 return True; 20035 20036 elsif Nkind (Choice) = N_Others_Choice then 20037 In_Others_Choice := True; 20038 end if; 20039 20040 Next (Choice); 20041 end loop; 20042 20043 -- It is also potentially unevaluated if the associated 20044 -- choice is an others choice and the applicable index 20045 -- constraint is nonstatic or null. 20046 20047 if In_Others_Choice then 20048 if not Compile_Time_Known_Bounds (Aggregate_Type) then 20049 return True; 20050 else 20051 return Has_Null_Others_Choice (Array_Agg); 20052 end if; 20053 end if; 20054 end; 20055 20056 elsif Is_Container_Aggregate (Parent (Par)) then 20057 -- a component of a container aggregate 20058 return True; 20059 end if; 20060 20061 return False; 20062 20063 else 20064 return False; 20065 end if; 20066 end Immediate_Context_Implies_Is_Potentially_Unevaluated; 20067 20068 ------------------------------ 20069 -- Non_Static_Or_Null_Range -- 20070 ------------------------------ 20071 20072 function Non_Static_Or_Null_Range (N : Node_Id) return Boolean is 20073 Low, High : Node_Id; 20074 20075 begin 20076 Get_Index_Bounds (N, Low, High); 20077 20078 -- Check static bounds 20079 20080 if not Compile_Time_Known_Value (Low) 20081 or else not Compile_Time_Known_Value (High) 20082 then 20083 return True; 20084 20085 -- Check null range 20086 20087 elsif Expr_Value (High) < Expr_Value (Low) then 20088 return True; 20089 end if; 20090 20091 return False; 20092 end Non_Static_Or_Null_Range; 20093 20094 -- Local variables 20095 20096 Par : Node_Id; 20097 Expr : Node_Id; 20098 20099 -- Start of processing for Is_Potentially_Unevaluated 20100 20101 begin 20102 Expr := N; 20103 Par := N; 20104 20105 -- A postcondition whose expression is a short-circuit is broken down 20106 -- into individual aspects for better exception reporting. The original 20107 -- short-circuit expression is rewritten as the second operand, and an 20108 -- occurrence of 'Old in that operand is potentially unevaluated. 20109 -- See sem_ch13.adb for details of this transformation. The reference 20110 -- to 'Old may appear within an expression, so we must look for the 20111 -- enclosing pragma argument in the tree that contains the reference. 20112 20113 while Present (Par) 20114 and then Nkind (Par) /= N_Pragma_Argument_Association 20115 loop 20116 if Is_Rewrite_Substitution (Par) 20117 and then Nkind (Original_Node (Par)) = N_And_Then 20118 then 20119 return True; 20120 end if; 20121 20122 Par := Parent (Par); 20123 end loop; 20124 20125 -- Other cases; 'Old appears within other expression (not the top-level 20126 -- conjunct in a postcondition) with a potentially unevaluated operand. 20127 20128 Par := Parent (Expr); 20129 20130 while Present (Par) 20131 and then Nkind (Par) /= N_Pragma_Argument_Association 20132 loop 20133 if Comes_From_Source (Par) 20134 and then 20135 Immediate_Context_Implies_Is_Potentially_Unevaluated (Expr) 20136 then 20137 return True; 20138 20139 -- For component associations continue climbing; it may be part of 20140 -- an array aggregate. 20141 20142 elsif Nkind (Par) = N_Component_Association then 20143 null; 20144 20145 -- If the context is not an expression, or if is the result of 20146 -- expansion of an enclosing construct (such as another attribute) 20147 -- the predicate does not apply. 20148 20149 elsif Nkind (Par) = N_Case_Expression_Alternative then 20150 null; 20151 20152 elsif Nkind (Par) not in N_Subexpr 20153 or else not Comes_From_Source (Par) 20154 then 20155 return False; 20156 end if; 20157 20158 Expr := Par; 20159 Par := Parent (Par); 20160 end loop; 20161 20162 return False; 20163 end Is_Potentially_Unevaluated; 20164 20165 ----------------------------------------- 20166 -- Is_Predefined_Dispatching_Operation -- 20167 ----------------------------------------- 20168 20169 function Is_Predefined_Dispatching_Operation 20170 (E : Entity_Id) return Boolean 20171 is 20172 TSS_Name : TSS_Name_Type; 20173 20174 begin 20175 if not Is_Dispatching_Operation (E) then 20176 return False; 20177 end if; 20178 20179 Get_Name_String (Chars (E)); 20180 20181 -- Most predefined primitives have internally generated names. Equality 20182 -- must be treated differently; the predefined operation is recognized 20183 -- as a homogeneous binary operator that returns Boolean. 20184 20185 if Name_Len > TSS_Name_Type'Last then 20186 TSS_Name := 20187 TSS_Name_Type 20188 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); 20189 20190 if Chars (E) in Name_uAssign | Name_uSize 20191 or else 20192 (Chars (E) = Name_Op_Eq 20193 and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) 20194 or else TSS_Name = TSS_Deep_Adjust 20195 or else TSS_Name = TSS_Deep_Finalize 20196 or else TSS_Name = TSS_Stream_Input 20197 or else TSS_Name = TSS_Stream_Output 20198 or else TSS_Name = TSS_Stream_Read 20199 or else TSS_Name = TSS_Stream_Write 20200 or else TSS_Name = TSS_Put_Image 20201 or else Is_Predefined_Interface_Primitive (E) 20202 then 20203 return True; 20204 end if; 20205 end if; 20206 20207 return False; 20208 end Is_Predefined_Dispatching_Operation; 20209 20210 --------------------------------------- 20211 -- Is_Predefined_Interface_Primitive -- 20212 --------------------------------------- 20213 20214 function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is 20215 begin 20216 -- In VM targets we don't restrict the functionality of this test to 20217 -- compiling in Ada 2005 mode since in VM targets any tagged type has 20218 -- these primitives. 20219 20220 return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion) 20221 and then Chars (E) in Name_uDisp_Asynchronous_Select 20222 | Name_uDisp_Conditional_Select 20223 | Name_uDisp_Get_Prim_Op_Kind 20224 | Name_uDisp_Get_Task_Id 20225 | Name_uDisp_Requeue 20226 | Name_uDisp_Timed_Select; 20227 end Is_Predefined_Interface_Primitive; 20228 20229 --------------------------------------- 20230 -- Is_Predefined_Internal_Operation -- 20231 --------------------------------------- 20232 20233 function Is_Predefined_Internal_Operation 20234 (E : Entity_Id) return Boolean 20235 is 20236 TSS_Name : TSS_Name_Type; 20237 20238 begin 20239 if not Is_Dispatching_Operation (E) then 20240 return False; 20241 end if; 20242 20243 Get_Name_String (Chars (E)); 20244 20245 -- Most predefined primitives have internally generated names. Equality 20246 -- must be treated differently; the predefined operation is recognized 20247 -- as a homogeneous binary operator that returns Boolean. 20248 20249 if Name_Len > TSS_Name_Type'Last then 20250 TSS_Name := 20251 TSS_Name_Type 20252 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); 20253 20254 if Chars (E) in Name_uSize | Name_uAssign 20255 or else 20256 (Chars (E) = Name_Op_Eq 20257 and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) 20258 or else TSS_Name = TSS_Deep_Adjust 20259 or else TSS_Name = TSS_Deep_Finalize 20260 or else Is_Predefined_Interface_Primitive (E) 20261 then 20262 return True; 20263 end if; 20264 end if; 20265 20266 return False; 20267 end Is_Predefined_Internal_Operation; 20268 20269 -------------------------------- 20270 -- Is_Preelaborable_Aggregate -- 20271 -------------------------------- 20272 20273 function Is_Preelaborable_Aggregate (Aggr : Node_Id) return Boolean is 20274 Aggr_Typ : constant Entity_Id := Etype (Aggr); 20275 Array_Aggr : constant Boolean := Is_Array_Type (Aggr_Typ); 20276 20277 Anc_Part : Node_Id; 20278 Assoc : Node_Id; 20279 Choice : Node_Id; 20280 Comp_Typ : Entity_Id := Empty; -- init to avoid warning 20281 Expr : Node_Id; 20282 20283 begin 20284 if Array_Aggr then 20285 Comp_Typ := Component_Type (Aggr_Typ); 20286 end if; 20287 20288 -- Inspect the ancestor part 20289 20290 if Nkind (Aggr) = N_Extension_Aggregate then 20291 Anc_Part := Ancestor_Part (Aggr); 20292 20293 -- The ancestor denotes a subtype mark 20294 20295 if Is_Entity_Name (Anc_Part) 20296 and then Is_Type (Entity (Anc_Part)) 20297 then 20298 if not Has_Preelaborable_Initialization (Entity (Anc_Part)) then 20299 return False; 20300 end if; 20301 20302 -- Otherwise the ancestor denotes an expression 20303 20304 elsif not Is_Preelaborable_Construct (Anc_Part) then 20305 return False; 20306 end if; 20307 end if; 20308 20309 -- Inspect the positional associations 20310 20311 Expr := First (Expressions (Aggr)); 20312 while Present (Expr) loop 20313 if not Is_Preelaborable_Construct (Expr) then 20314 return False; 20315 end if; 20316 20317 Next (Expr); 20318 end loop; 20319 20320 -- Inspect the named associations 20321 20322 Assoc := First (Component_Associations (Aggr)); 20323 while Present (Assoc) loop 20324 20325 -- Inspect the choices of the current named association 20326 20327 Choice := First (Choices (Assoc)); 20328 while Present (Choice) loop 20329 if Array_Aggr then 20330 20331 -- For a choice to be preelaborable, it must denote either a 20332 -- static range or a static expression. 20333 20334 if Nkind (Choice) = N_Others_Choice then 20335 null; 20336 20337 elsif Nkind (Choice) = N_Range then 20338 if not Is_OK_Static_Range (Choice) then 20339 return False; 20340 end if; 20341 20342 elsif not Is_OK_Static_Expression (Choice) then 20343 return False; 20344 end if; 20345 20346 else 20347 Comp_Typ := Etype (Choice); 20348 end if; 20349 20350 Next (Choice); 20351 end loop; 20352 20353 -- The type of the choice must have preelaborable initialization if 20354 -- the association carries a <>. 20355 20356 pragma Assert (Present (Comp_Typ)); 20357 if Box_Present (Assoc) then 20358 if not Has_Preelaborable_Initialization (Comp_Typ) then 20359 return False; 20360 end if; 20361 20362 -- The type of the expression must have preelaborable initialization 20363 20364 elsif not Is_Preelaborable_Construct (Expression (Assoc)) then 20365 return False; 20366 end if; 20367 20368 Next (Assoc); 20369 end loop; 20370 20371 -- At this point the aggregate is preelaborable 20372 20373 return True; 20374 end Is_Preelaborable_Aggregate; 20375 20376 -------------------------------- 20377 -- Is_Preelaborable_Construct -- 20378 -------------------------------- 20379 20380 function Is_Preelaborable_Construct (N : Node_Id) return Boolean is 20381 begin 20382 -- Aggregates 20383 20384 if Nkind (N) in N_Aggregate | N_Extension_Aggregate then 20385 return Is_Preelaborable_Aggregate (N); 20386 20387 -- Attributes are allowed in general, even if their prefix is a formal 20388 -- type. It seems that certain attributes known not to be static might 20389 -- not be allowed, but there are no rules to prevent them. 20390 20391 elsif Nkind (N) = N_Attribute_Reference then 20392 return True; 20393 20394 -- Expressions 20395 20396 elsif Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then 20397 return True; 20398 20399 elsif Nkind (N) = N_Qualified_Expression then 20400 return Is_Preelaborable_Construct (Expression (N)); 20401 20402 -- Names are preelaborable when they denote a discriminant of an 20403 -- enclosing type. Discriminals are also considered for this check. 20404 20405 elsif Is_Entity_Name (N) 20406 and then Present (Entity (N)) 20407 and then 20408 (Ekind (Entity (N)) = E_Discriminant 20409 or else (Ekind (Entity (N)) in E_Constant | E_In_Parameter 20410 and then Present (Discriminal_Link (Entity (N))))) 20411 then 20412 return True; 20413 20414 -- Statements 20415 20416 elsif Nkind (N) = N_Null then 20417 return True; 20418 20419 -- Ada 2022 (AI12-0175): Calls to certain functions that are essentially 20420 -- unchecked conversions are preelaborable. 20421 20422 elsif Ada_Version >= Ada_2022 20423 and then Nkind (N) = N_Function_Call 20424 and then Is_Entity_Name (Name (N)) 20425 and then Is_Preelaborable_Function (Entity (Name (N))) 20426 then 20427 declare 20428 A : Node_Id; 20429 begin 20430 A := First_Actual (N); 20431 20432 while Present (A) loop 20433 if not Is_Preelaborable_Construct (A) then 20434 return False; 20435 end if; 20436 20437 Next_Actual (A); 20438 end loop; 20439 end; 20440 20441 return True; 20442 20443 -- Otherwise the construct is not preelaborable 20444 20445 else 20446 return False; 20447 end if; 20448 end Is_Preelaborable_Construct; 20449 20450 ------------------------------- 20451 -- Is_Preelaborable_Function -- 20452 ------------------------------- 20453 20454 function Is_Preelaborable_Function (Id : Entity_Id) return Boolean is 20455 SATAC : constant Rtsfind.RTU_Id := System_Address_To_Access_Conversions; 20456 Scop : constant Entity_Id := Scope (Id); 20457 20458 begin 20459 -- Small optimization: every allowed function has convention Intrinsic 20460 -- (see Analyze_Subprogram_Instantiation for the subtlety in the test). 20461 20462 if not Is_Intrinsic_Subprogram (Id) 20463 and then Convention (Id) /= Convention_Intrinsic 20464 then 20465 return False; 20466 end if; 20467 20468 -- An instance of Unchecked_Conversion 20469 20470 if Is_Unchecked_Conversion_Instance (Id) then 20471 return True; 20472 end if; 20473 20474 -- A function declared in System.Storage_Elements 20475 20476 if Is_RTU (Scop, System_Storage_Elements) then 20477 return True; 20478 end if; 20479 20480 -- The functions To_Pointer and To_Address declared in an instance of 20481 -- System.Address_To_Access_Conversions (they are the only ones). 20482 20483 if Ekind (Scop) = E_Package 20484 and then Nkind (Parent (Scop)) = N_Package_Specification 20485 and then Present (Generic_Parent (Parent (Scop))) 20486 and then Is_RTU (Generic_Parent (Parent (Scop)), SATAC) 20487 then 20488 return True; 20489 end if; 20490 20491 return False; 20492 end Is_Preelaborable_Function; 20493 20494 ----------------------------- 20495 -- Is_Private_Library_Unit -- 20496 ----------------------------- 20497 20498 function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is 20499 Comp_Unit : constant Node_Id := Parent (Unit_Declaration_Node (Unit)); 20500 begin 20501 return Nkind (Comp_Unit) = N_Compilation_Unit 20502 and then Private_Present (Comp_Unit); 20503 end Is_Private_Library_Unit; 20504 20505 --------------------------------- 20506 -- Is_Protected_Self_Reference -- 20507 --------------------------------- 20508 20509 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is 20510 20511 function In_Access_Definition (N : Node_Id) return Boolean; 20512 -- Returns true if N belongs to an access definition 20513 20514 -------------------------- 20515 -- In_Access_Definition -- 20516 -------------------------- 20517 20518 function In_Access_Definition (N : Node_Id) return Boolean is 20519 P : Node_Id; 20520 20521 begin 20522 P := Parent (N); 20523 while Present (P) loop 20524 if Nkind (P) = N_Access_Definition then 20525 return True; 20526 end if; 20527 20528 P := Parent (P); 20529 end loop; 20530 20531 return False; 20532 end In_Access_Definition; 20533 20534 -- Start of processing for Is_Protected_Self_Reference 20535 20536 begin 20537 -- Verify that prefix is analyzed and has the proper form. Note that 20538 -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also 20539 -- produce the address of an entity, do not analyze their prefix 20540 -- because they denote entities that are not necessarily visible. 20541 -- Neither of them can apply to a protected type. 20542 20543 return Ada_Version >= Ada_2005 20544 and then Is_Entity_Name (N) 20545 and then Present (Entity (N)) 20546 and then Is_Protected_Type (Entity (N)) 20547 and then In_Open_Scopes (Entity (N)) 20548 and then not In_Access_Definition (N); 20549 end Is_Protected_Self_Reference; 20550 20551 ----------------------------- 20552 -- Is_RCI_Pkg_Spec_Or_Body -- 20553 ----------------------------- 20554 20555 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is 20556 20557 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean; 20558 -- Return True if the unit of Cunit is an RCI package declaration 20559 20560 --------------------------- 20561 -- Is_RCI_Pkg_Decl_Cunit -- 20562 --------------------------- 20563 20564 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is 20565 The_Unit : constant Node_Id := Unit (Cunit); 20566 20567 begin 20568 if Nkind (The_Unit) /= N_Package_Declaration then 20569 return False; 20570 end if; 20571 20572 return Is_Remote_Call_Interface (Defining_Entity (The_Unit)); 20573 end Is_RCI_Pkg_Decl_Cunit; 20574 20575 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body 20576 20577 begin 20578 return Is_RCI_Pkg_Decl_Cunit (Cunit) 20579 or else 20580 (Nkind (Unit (Cunit)) = N_Package_Body 20581 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit))); 20582 end Is_RCI_Pkg_Spec_Or_Body; 20583 20584 ----------------------------------------- 20585 -- Is_Remote_Access_To_Class_Wide_Type -- 20586 ----------------------------------------- 20587 20588 function Is_Remote_Access_To_Class_Wide_Type 20589 (E : Entity_Id) return Boolean 20590 is 20591 begin 20592 -- A remote access to class-wide type is a general access to object type 20593 -- declared in the visible part of a Remote_Types or Remote_Call_ 20594 -- Interface unit. 20595 20596 return Ekind (E) = E_General_Access_Type 20597 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); 20598 end Is_Remote_Access_To_Class_Wide_Type; 20599 20600 ----------------------------------------- 20601 -- Is_Remote_Access_To_Subprogram_Type -- 20602 ----------------------------------------- 20603 20604 function Is_Remote_Access_To_Subprogram_Type 20605 (E : Entity_Id) return Boolean 20606 is 20607 begin 20608 return (Ekind (E) = E_Access_Subprogram_Type 20609 or else (Ekind (E) = E_Record_Type 20610 and then Present (Corresponding_Remote_Type (E)))) 20611 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); 20612 end Is_Remote_Access_To_Subprogram_Type; 20613 20614 -------------------- 20615 -- Is_Remote_Call -- 20616 -------------------- 20617 20618 function Is_Remote_Call (N : Node_Id) return Boolean is 20619 begin 20620 if Nkind (N) not in N_Subprogram_Call then 20621 20622 -- An entry call cannot be remote 20623 20624 return False; 20625 20626 elsif Nkind (Name (N)) in N_Has_Entity 20627 and then Is_Remote_Call_Interface (Entity (Name (N))) 20628 then 20629 -- A subprogram declared in the spec of a RCI package is remote 20630 20631 return True; 20632 20633 elsif Nkind (Name (N)) = N_Explicit_Dereference 20634 and then Is_Remote_Access_To_Subprogram_Type 20635 (Etype (Prefix (Name (N)))) 20636 then 20637 -- The dereference of a RAS is a remote call 20638 20639 return True; 20640 20641 elsif Present (Controlling_Argument (N)) 20642 and then Is_Remote_Access_To_Class_Wide_Type 20643 (Etype (Controlling_Argument (N))) 20644 then 20645 -- Any primitive operation call with a controlling argument of 20646 -- a RACW type is a remote call. 20647 20648 return True; 20649 end if; 20650 20651 -- All other calls are local calls 20652 20653 return False; 20654 end Is_Remote_Call; 20655 20656 ---------------------- 20657 -- Is_Renamed_Entry -- 20658 ---------------------- 20659 20660 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is 20661 Orig_Node : Node_Id := Empty; 20662 Subp_Decl : Node_Id := 20663 (if No (Parent (Proc_Nam)) then Empty else Parent (Parent (Proc_Nam))); 20664 20665 function Is_Entry (Nam : Node_Id) return Boolean; 20666 -- Determine whether Nam is an entry. Traverse selectors if there are 20667 -- nested selected components. 20668 20669 -------------- 20670 -- Is_Entry -- 20671 -------------- 20672 20673 function Is_Entry (Nam : Node_Id) return Boolean is 20674 begin 20675 if Nkind (Nam) = N_Selected_Component then 20676 return Is_Entry (Selector_Name (Nam)); 20677 end if; 20678 20679 return Ekind (Entity (Nam)) = E_Entry; 20680 end Is_Entry; 20681 20682 -- Start of processing for Is_Renamed_Entry 20683 20684 begin 20685 if Present (Alias (Proc_Nam)) then 20686 Subp_Decl := Parent (Parent (Alias (Proc_Nam))); 20687 end if; 20688 20689 -- Look for a rewritten subprogram renaming declaration 20690 20691 if Nkind (Subp_Decl) = N_Subprogram_Declaration 20692 and then Present (Original_Node (Subp_Decl)) 20693 then 20694 Orig_Node := Original_Node (Subp_Decl); 20695 end if; 20696 20697 -- The rewritten subprogram is actually an entry 20698 20699 if Present (Orig_Node) 20700 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration 20701 and then Is_Entry (Name (Orig_Node)) 20702 then 20703 return True; 20704 end if; 20705 20706 return False; 20707 end Is_Renamed_Entry; 20708 20709 ---------------------------- 20710 -- Is_Reversible_Iterator -- 20711 ---------------------------- 20712 20713 function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is 20714 Ifaces_List : Elist_Id; 20715 Iface_Elmt : Elmt_Id; 20716 Iface : Entity_Id; 20717 20718 begin 20719 if Is_Class_Wide_Type (Typ) 20720 and then Chars (Root_Type (Typ)) = Name_Reversible_Iterator 20721 and then In_Predefined_Unit (Root_Type (Typ)) 20722 then 20723 return True; 20724 20725 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then 20726 return False; 20727 20728 else 20729 Collect_Interfaces (Typ, Ifaces_List); 20730 20731 Iface_Elmt := First_Elmt (Ifaces_List); 20732 while Present (Iface_Elmt) loop 20733 Iface := Node (Iface_Elmt); 20734 if Chars (Iface) = Name_Reversible_Iterator 20735 and then In_Predefined_Unit (Iface) 20736 then 20737 return True; 20738 end if; 20739 20740 Next_Elmt (Iface_Elmt); 20741 end loop; 20742 end if; 20743 20744 return False; 20745 end Is_Reversible_Iterator; 20746 20747 ---------------------- 20748 -- Is_Selector_Name -- 20749 ---------------------- 20750 20751 function Is_Selector_Name (N : Node_Id) return Boolean is 20752 begin 20753 if not Is_List_Member (N) then 20754 declare 20755 P : constant Node_Id := Parent (N); 20756 begin 20757 return Nkind (P) in N_Expanded_Name 20758 | N_Generic_Association 20759 | N_Parameter_Association 20760 | N_Selected_Component 20761 and then Selector_Name (P) = N; 20762 end; 20763 20764 else 20765 declare 20766 L : constant List_Id := List_Containing (N); 20767 P : constant Node_Id := Parent (L); 20768 begin 20769 return (Nkind (P) = N_Discriminant_Association 20770 and then Selector_Names (P) = L) 20771 or else 20772 (Nkind (P) = N_Component_Association 20773 and then Choices (P) = L); 20774 end; 20775 end if; 20776 end Is_Selector_Name; 20777 20778 --------------------------------- 20779 -- Is_Single_Concurrent_Object -- 20780 --------------------------------- 20781 20782 function Is_Single_Concurrent_Object (Id : Entity_Id) return Boolean is 20783 begin 20784 return 20785 Is_Single_Protected_Object (Id) or else Is_Single_Task_Object (Id); 20786 end Is_Single_Concurrent_Object; 20787 20788 ------------------------------- 20789 -- Is_Single_Concurrent_Type -- 20790 ------------------------------- 20791 20792 function Is_Single_Concurrent_Type (Id : Entity_Id) return Boolean is 20793 begin 20794 return 20795 Ekind (Id) in E_Protected_Type | E_Task_Type 20796 and then Is_Single_Concurrent_Type_Declaration 20797 (Declaration_Node (Id)); 20798 end Is_Single_Concurrent_Type; 20799 20800 ------------------------------------------- 20801 -- Is_Single_Concurrent_Type_Declaration -- 20802 ------------------------------------------- 20803 20804 function Is_Single_Concurrent_Type_Declaration 20805 (N : Node_Id) return Boolean 20806 is 20807 begin 20808 return Nkind (Original_Node (N)) in 20809 N_Single_Protected_Declaration | N_Single_Task_Declaration; 20810 end Is_Single_Concurrent_Type_Declaration; 20811 20812 --------------------------------------------- 20813 -- Is_Single_Precision_Floating_Point_Type -- 20814 --------------------------------------------- 20815 20816 function Is_Single_Precision_Floating_Point_Type 20817 (E : Entity_Id) return Boolean is 20818 begin 20819 return Is_Floating_Point_Type (E) 20820 and then Machine_Radix_Value (E) = Uint_2 20821 and then Machine_Mantissa_Value (E) = Uint_24 20822 and then Machine_Emax_Value (E) = Uint_2 ** Uint_7 20823 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_7); 20824 end Is_Single_Precision_Floating_Point_Type; 20825 20826 -------------------------------- 20827 -- Is_Single_Protected_Object -- 20828 -------------------------------- 20829 20830 function Is_Single_Protected_Object (Id : Entity_Id) return Boolean is 20831 begin 20832 return 20833 Ekind (Id) = E_Variable 20834 and then Ekind (Etype (Id)) = E_Protected_Type 20835 and then Is_Single_Concurrent_Type (Etype (Id)); 20836 end Is_Single_Protected_Object; 20837 20838 --------------------------- 20839 -- Is_Single_Task_Object -- 20840 --------------------------- 20841 20842 function Is_Single_Task_Object (Id : Entity_Id) return Boolean is 20843 begin 20844 return 20845 Ekind (Id) = E_Variable 20846 and then Ekind (Etype (Id)) = E_Task_Type 20847 and then Is_Single_Concurrent_Type (Etype (Id)); 20848 end Is_Single_Task_Object; 20849 20850 -------------------------------------- 20851 -- Is_Special_Aliased_Formal_Access -- 20852 -------------------------------------- 20853 20854 function Is_Special_Aliased_Formal_Access 20855 (Exp : Node_Id; 20856 In_Return_Context : Boolean := False) return Boolean 20857 is 20858 Scop : constant Entity_Id := Current_Subprogram; 20859 begin 20860 -- Verify the expression is an access reference to 'Access within a 20861 -- return statement as this is the only time an explicitly aliased 20862 -- formal has different semantics. 20863 20864 if Nkind (Exp) /= N_Attribute_Reference 20865 or else Get_Attribute_Id (Attribute_Name (Exp)) /= Attribute_Access 20866 or else not (In_Return_Value (Exp) 20867 or else In_Return_Context) 20868 or else not Needs_Result_Accessibility_Level (Scop) 20869 then 20870 return False; 20871 end if; 20872 20873 -- Check if the prefix of the reference is indeed an explicitly aliased 20874 -- formal parameter for the function Scop. Additionally, we must check 20875 -- that Scop returns an anonymous access type, otherwise the special 20876 -- rules dictating a need for a dynamic check are not in effect. 20877 20878 return Is_Entity_Name (Prefix (Exp)) 20879 and then Is_Explicitly_Aliased (Entity (Prefix (Exp))); 20880 end Is_Special_Aliased_Formal_Access; 20881 20882 ----------------------------- 20883 -- Is_Specific_Tagged_Type -- 20884 ----------------------------- 20885 20886 function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean is 20887 Full_Typ : Entity_Id; 20888 20889 begin 20890 -- Handle private types 20891 20892 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 20893 Full_Typ := Full_View (Typ); 20894 else 20895 Full_Typ := Typ; 20896 end if; 20897 20898 -- A specific tagged type is a non-class-wide tagged type 20899 20900 return Is_Tagged_Type (Full_Typ) and not Is_Class_Wide_Type (Full_Typ); 20901 end Is_Specific_Tagged_Type; 20902 20903 ------------------ 20904 -- Is_Statement -- 20905 ------------------ 20906 20907 function Is_Statement (N : Node_Id) return Boolean is 20908 begin 20909 return 20910 Nkind (N) in N_Statement_Other_Than_Procedure_Call 20911 or else Nkind (N) = N_Procedure_Call_Statement; 20912 end Is_Statement; 20913 20914 -------------------------------------- 20915 -- Is_Static_Discriminant_Component -- 20916 -------------------------------------- 20917 20918 function Is_Static_Discriminant_Component (N : Node_Id) return Boolean is 20919 begin 20920 return Nkind (N) = N_Selected_Component 20921 and then not Is_In_Discriminant_Check (N) 20922 and then Present (Etype (Prefix (N))) 20923 and then Ekind (Etype (Prefix (N))) = E_Record_Subtype 20924 and then Has_Static_Discriminants (Etype (Prefix (N))) 20925 and then Present (Entity (Selector_Name (N))) 20926 and then Ekind (Entity (Selector_Name (N))) = E_Discriminant 20927 and then not In_Check_Node (N); 20928 end Is_Static_Discriminant_Component; 20929 20930 ------------------------ 20931 -- Is_Static_Function -- 20932 ------------------------ 20933 20934 function Is_Static_Function (Subp : Entity_Id) return Boolean is 20935 begin 20936 -- Always return False for pre Ada 2022 to e.g. ignore the Static 20937 -- aspect in package Interfaces for Ada_Version < 2022 and also 20938 -- for efficiency. 20939 20940 return Ada_Version >= Ada_2022 20941 and then Has_Aspect (Subp, Aspect_Static) 20942 and then 20943 (No (Find_Value_Of_Aspect (Subp, Aspect_Static)) 20944 or else Is_True (Static_Boolean 20945 (Find_Value_Of_Aspect (Subp, Aspect_Static)))); 20946 end Is_Static_Function; 20947 20948 ----------------------------- 20949 -- Is_Static_Function_Call -- 20950 ----------------------------- 20951 20952 function Is_Static_Function_Call (Call : Node_Id) return Boolean is 20953 function Has_All_Static_Actuals (Call : Node_Id) return Boolean; 20954 -- Return whether all actual parameters of Call are static expressions 20955 20956 ---------------------------- 20957 -- Has_All_Static_Actuals -- 20958 ---------------------------- 20959 20960 function Has_All_Static_Actuals (Call : Node_Id) return Boolean is 20961 Actual : Node_Id := First_Actual (Call); 20962 String_Result : constant Boolean := 20963 Is_String_Type (Etype (Entity (Name (Call)))); 20964 20965 begin 20966 while Present (Actual) loop 20967 if not Is_Static_Expression (Actual) then 20968 20969 -- ??? In the string-returning case we want to avoid a call 20970 -- being made to Establish_Transient_Scope in Resolve_Call, 20971 -- but at the point where that's tested for (which now includes 20972 -- a call to test Is_Static_Function_Call), the actuals of the 20973 -- call haven't been resolved, so expressions of the actuals 20974 -- may not have been marked Is_Static_Expression yet, so we 20975 -- force them to be resolved here, so we can tell if they're 20976 -- static. Calling Resolve here is admittedly a kludge, and we 20977 -- limit this call to string-returning cases. 20978 20979 if String_Result then 20980 Resolve (Actual); 20981 end if; 20982 20983 -- Test flag again in case it's now True due to above Resolve 20984 20985 if not Is_Static_Expression (Actual) then 20986 return False; 20987 end if; 20988 end if; 20989 20990 Next_Actual (Actual); 20991 end loop; 20992 20993 return True; 20994 end Has_All_Static_Actuals; 20995 20996 begin 20997 return Nkind (Call) = N_Function_Call 20998 and then Is_Entity_Name (Name (Call)) 20999 and then Is_Static_Function (Entity (Name (Call))) 21000 and then Has_All_Static_Actuals (Call); 21001 end Is_Static_Function_Call; 21002 21003 ------------------------------------------- 21004 -- Is_Subcomponent_Of_Full_Access_Object -- 21005 ------------------------------------------- 21006 21007 function Is_Subcomponent_Of_Full_Access_Object (N : Node_Id) return Boolean 21008 is 21009 R : Node_Id; 21010 21011 begin 21012 R := Get_Referenced_Object (N); 21013 21014 while Nkind (R) in N_Indexed_Component | N_Selected_Component | N_Slice 21015 loop 21016 R := Get_Referenced_Object (Prefix (R)); 21017 21018 -- If the prefix is an access value, only the designated type matters 21019 21020 if Is_Access_Type (Etype (R)) then 21021 if Is_Full_Access (Designated_Type (Etype (R))) then 21022 return True; 21023 end if; 21024 21025 else 21026 if Is_Full_Access_Object (R) then 21027 return True; 21028 end if; 21029 end if; 21030 end loop; 21031 21032 return False; 21033 end Is_Subcomponent_Of_Full_Access_Object; 21034 21035 --------------------------------------- 21036 -- Is_Subprogram_Contract_Annotation -- 21037 --------------------------------------- 21038 21039 function Is_Subprogram_Contract_Annotation 21040 (Item : Node_Id) return Boolean 21041 is 21042 Nam : Name_Id; 21043 21044 begin 21045 if Nkind (Item) = N_Aspect_Specification then 21046 Nam := Chars (Identifier (Item)); 21047 21048 else pragma Assert (Nkind (Item) = N_Pragma); 21049 Nam := Pragma_Name (Item); 21050 end if; 21051 21052 return Nam = Name_Contract_Cases 21053 or else Nam = Name_Depends 21054 or else Nam = Name_Extensions_Visible 21055 or else Nam = Name_Global 21056 or else Nam = Name_Post 21057 or else Nam = Name_Post_Class 21058 or else Nam = Name_Postcondition 21059 or else Nam = Name_Pre 21060 or else Nam = Name_Pre_Class 21061 or else Nam = Name_Precondition 21062 or else Nam = Name_Refined_Depends 21063 or else Nam = Name_Refined_Global 21064 or else Nam = Name_Refined_Post 21065 or else Nam = Name_Subprogram_Variant 21066 or else Nam = Name_Test_Case; 21067 end Is_Subprogram_Contract_Annotation; 21068 21069 -------------------------------------------------- 21070 -- Is_Subprogram_Stub_Without_Prior_Declaration -- 21071 -------------------------------------------------- 21072 21073 function Is_Subprogram_Stub_Without_Prior_Declaration 21074 (N : Node_Id) return Boolean 21075 is 21076 begin 21077 pragma Assert (Nkind (N) = N_Subprogram_Body_Stub); 21078 21079 case Ekind (Defining_Entity (N)) is 21080 21081 -- A subprogram stub without prior declaration serves as declaration 21082 -- for the actual subprogram body. As such, it has an attached 21083 -- defining entity of E_Function or E_Procedure. 21084 21085 when E_Function 21086 | E_Procedure 21087 => 21088 return True; 21089 21090 -- Otherwise, it is completes a [generic] subprogram declaration 21091 21092 when E_Generic_Function 21093 | E_Generic_Procedure 21094 | E_Subprogram_Body 21095 => 21096 return False; 21097 21098 when others => 21099 raise Program_Error; 21100 end case; 21101 end Is_Subprogram_Stub_Without_Prior_Declaration; 21102 21103 --------------------------- 21104 -- Is_Suitable_Primitive -- 21105 --------------------------- 21106 21107 function Is_Suitable_Primitive (Subp_Id : Entity_Id) return Boolean is 21108 begin 21109 -- The Default_Initial_Condition and invariant procedures must not be 21110 -- treated as primitive operations even when they apply to a tagged 21111 -- type. These routines must not act as targets of dispatching calls 21112 -- because they already utilize class-wide-precondition semantics to 21113 -- handle inheritance and overriding. 21114 21115 if Ekind (Subp_Id) = E_Procedure 21116 and then (Is_DIC_Procedure (Subp_Id) 21117 or else 21118 Is_Invariant_Procedure (Subp_Id)) 21119 then 21120 return False; 21121 end if; 21122 21123 return True; 21124 end Is_Suitable_Primitive; 21125 21126 ---------------------------- 21127 -- Is_Synchronized_Object -- 21128 ---------------------------- 21129 21130 function Is_Synchronized_Object (Id : Entity_Id) return Boolean is 21131 Prag : Node_Id; 21132 21133 begin 21134 if Is_Object (Id) then 21135 21136 -- The object is synchronized if it is of a type that yields a 21137 -- synchronized object. 21138 21139 if Yields_Synchronized_Object (Etype (Id)) then 21140 return True; 21141 21142 -- The object is synchronized if it is atomic and Async_Writers is 21143 -- enabled. 21144 21145 elsif Is_Atomic_Object_Entity (Id) 21146 and then Async_Writers_Enabled (Id) 21147 then 21148 return True; 21149 21150 -- A constant is a synchronized object by default, unless its type is 21151 -- access-to-variable type. 21152 21153 elsif Ekind (Id) = E_Constant 21154 and then not Is_Access_Variable (Etype (Id)) 21155 then 21156 return True; 21157 21158 -- A variable is a synchronized object if it is subject to pragma 21159 -- Constant_After_Elaboration. 21160 21161 elsif Ekind (Id) = E_Variable then 21162 Prag := Get_Pragma (Id, Pragma_Constant_After_Elaboration); 21163 21164 return Present (Prag) and then Is_Enabled_Pragma (Prag); 21165 end if; 21166 end if; 21167 21168 -- Otherwise the input is not an object or it does not qualify as a 21169 -- synchronized object. 21170 21171 return False; 21172 end Is_Synchronized_Object; 21173 21174 --------------------------------- 21175 -- Is_Synchronized_Tagged_Type -- 21176 --------------------------------- 21177 21178 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is 21179 Kind : constant Entity_Kind := Ekind (Base_Type (E)); 21180 21181 begin 21182 -- A task or protected type derived from an interface is a tagged type. 21183 -- Such a tagged type is called a synchronized tagged type, as are 21184 -- synchronized interfaces and private extensions whose declaration 21185 -- includes the reserved word synchronized. 21186 21187 return (Is_Tagged_Type (E) 21188 and then (Kind = E_Task_Type 21189 or else 21190 Kind = E_Protected_Type)) 21191 or else 21192 (Is_Interface (E) 21193 and then Is_Synchronized_Interface (E)) 21194 or else 21195 (Ekind (E) = E_Record_Type_With_Private 21196 and then Nkind (Parent (E)) = N_Private_Extension_Declaration 21197 and then (Synchronized_Present (Parent (E)) 21198 or else Is_Synchronized_Interface (Etype (E)))); 21199 end Is_Synchronized_Tagged_Type; 21200 21201 ----------------- 21202 -- Is_Transfer -- 21203 ----------------- 21204 21205 function Is_Transfer (N : Node_Id) return Boolean is 21206 Kind : constant Node_Kind := Nkind (N); 21207 21208 begin 21209 if Kind = N_Simple_Return_Statement 21210 or else 21211 Kind = N_Extended_Return_Statement 21212 or else 21213 Kind = N_Goto_Statement 21214 or else 21215 Kind = N_Raise_Statement 21216 or else 21217 Kind = N_Requeue_Statement 21218 then 21219 return True; 21220 21221 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error) 21222 and then No (Condition (N)) 21223 then 21224 return True; 21225 21226 elsif Kind = N_Procedure_Call_Statement 21227 and then Is_Entity_Name (Name (N)) 21228 and then Present (Entity (Name (N))) 21229 and then No_Return (Entity (Name (N))) 21230 then 21231 return True; 21232 21233 elsif Nkind (Original_Node (N)) = N_Raise_Statement then 21234 return True; 21235 21236 else 21237 return False; 21238 end if; 21239 end Is_Transfer; 21240 21241 ------------- 21242 -- Is_True -- 21243 ------------- 21244 21245 function Is_True (U : Opt_Ubool) return Boolean is 21246 begin 21247 return No (U) or else U = Uint_1; 21248 end Is_True; 21249 21250 -------------------------------------- 21251 -- Is_Unchecked_Conversion_Instance -- 21252 -------------------------------------- 21253 21254 function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean is 21255 Par : Node_Id; 21256 21257 begin 21258 -- Look for a function whose generic parent is the predefined intrinsic 21259 -- function Unchecked_Conversion, or for one that renames such an 21260 -- instance. 21261 21262 if Ekind (Id) = E_Function then 21263 Par := Parent (Id); 21264 21265 if Nkind (Par) = N_Function_Specification then 21266 Par := Generic_Parent (Par); 21267 21268 if Present (Par) then 21269 return 21270 Chars (Par) = Name_Unchecked_Conversion 21271 and then Is_Intrinsic_Subprogram (Par) 21272 and then In_Predefined_Unit (Par); 21273 else 21274 return 21275 Present (Alias (Id)) 21276 and then Is_Unchecked_Conversion_Instance (Alias (Id)); 21277 end if; 21278 end if; 21279 end if; 21280 21281 return False; 21282 end Is_Unchecked_Conversion_Instance; 21283 21284 ------------------------------- 21285 -- Is_Universal_Numeric_Type -- 21286 ------------------------------- 21287 21288 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is 21289 begin 21290 return T = Universal_Integer or else T = Universal_Real; 21291 end Is_Universal_Numeric_Type; 21292 21293 ------------------------------ 21294 -- Is_User_Defined_Equality -- 21295 ------------------------------ 21296 21297 function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is 21298 begin 21299 return Ekind (Id) = E_Function 21300 and then Chars (Id) = Name_Op_Eq 21301 and then Comes_From_Source (Id) 21302 21303 -- Internally generated equalities have a full type declaration 21304 -- as their parent. 21305 21306 and then Nkind (Parent (Id)) = N_Function_Specification; 21307 end Is_User_Defined_Equality; 21308 21309 -------------------------------------- 21310 -- Is_Validation_Variable_Reference -- 21311 -------------------------------------- 21312 21313 function Is_Validation_Variable_Reference (N : Node_Id) return Boolean is 21314 Var : constant Node_Id := Unqual_Conv (N); 21315 Var_Id : Entity_Id; 21316 21317 begin 21318 Var_Id := Empty; 21319 21320 if Is_Entity_Name (Var) then 21321 Var_Id := Entity (Var); 21322 end if; 21323 21324 return 21325 Present (Var_Id) 21326 and then Ekind (Var_Id) = E_Variable 21327 and then Present (Validated_Object (Var_Id)); 21328 end Is_Validation_Variable_Reference; 21329 21330 ---------------------------- 21331 -- Is_Variable_Size_Array -- 21332 ---------------------------- 21333 21334 function Is_Variable_Size_Array (E : Entity_Id) return Boolean is 21335 Idx : Node_Id; 21336 21337 begin 21338 pragma Assert (Is_Array_Type (E)); 21339 21340 -- Check if some index is initialized with a non-constant value 21341 21342 Idx := First_Index (E); 21343 while Present (Idx) loop 21344 if Nkind (Idx) = N_Range then 21345 if not Is_Constant_Bound (Low_Bound (Idx)) 21346 or else not Is_Constant_Bound (High_Bound (Idx)) 21347 then 21348 return True; 21349 end if; 21350 end if; 21351 21352 Next_Index (Idx); 21353 end loop; 21354 21355 return False; 21356 end Is_Variable_Size_Array; 21357 21358 ----------------------------- 21359 -- Is_Variable_Size_Record -- 21360 ----------------------------- 21361 21362 function Is_Variable_Size_Record (E : Entity_Id) return Boolean is 21363 Comp : Entity_Id; 21364 Comp_Typ : Entity_Id; 21365 21366 begin 21367 pragma Assert (Is_Record_Type (E)); 21368 21369 Comp := First_Component (E); 21370 while Present (Comp) loop 21371 Comp_Typ := Underlying_Type (Etype (Comp)); 21372 21373 -- Recursive call if the record type has discriminants 21374 21375 if Is_Record_Type (Comp_Typ) 21376 and then Has_Discriminants (Comp_Typ) 21377 and then Is_Variable_Size_Record (Comp_Typ) 21378 then 21379 return True; 21380 21381 elsif Is_Array_Type (Comp_Typ) 21382 and then Is_Variable_Size_Array (Comp_Typ) 21383 then 21384 return True; 21385 end if; 21386 21387 Next_Component (Comp); 21388 end loop; 21389 21390 return False; 21391 end Is_Variable_Size_Record; 21392 21393 ----------------- 21394 -- Is_Variable -- 21395 ----------------- 21396 21397 -- Should Is_Variable be refactored to better handle dereferences and 21398 -- technical debt ??? 21399 21400 function Is_Variable 21401 (N : Node_Id; 21402 Use_Original_Node : Boolean := True) return Boolean 21403 is 21404 Orig_Node : Node_Id; 21405 21406 function In_Protected_Function (E : Entity_Id) return Boolean; 21407 -- Within a protected function, the private components of the enclosing 21408 -- protected type are constants. A function nested within a (protected) 21409 -- procedure is not itself protected. Within the body of a protected 21410 -- function the current instance of the protected type is a constant. 21411 21412 function Is_Variable_Prefix (P : Node_Id) return Boolean; 21413 -- Prefixes can involve implicit dereferences, in which case we must 21414 -- test for the case of a reference of a constant access type, which can 21415 -- can never be a variable. 21416 21417 --------------------------- 21418 -- In_Protected_Function -- 21419 --------------------------- 21420 21421 function In_Protected_Function (E : Entity_Id) return Boolean is 21422 Prot : Entity_Id; 21423 S : Entity_Id; 21424 21425 begin 21426 -- E is the current instance of a type 21427 21428 if Is_Type (E) then 21429 Prot := E; 21430 21431 -- E is an object 21432 21433 else 21434 Prot := Scope (E); 21435 end if; 21436 21437 if not Is_Protected_Type (Prot) then 21438 return False; 21439 21440 else 21441 S := Current_Scope; 21442 while Present (S) and then S /= Prot loop 21443 if Ekind (S) = E_Function and then Scope (S) = Prot then 21444 return True; 21445 end if; 21446 21447 S := Scope (S); 21448 end loop; 21449 21450 return False; 21451 end if; 21452 end In_Protected_Function; 21453 21454 ------------------------ 21455 -- Is_Variable_Prefix -- 21456 ------------------------ 21457 21458 function Is_Variable_Prefix (P : Node_Id) return Boolean is 21459 begin 21460 if Is_Access_Type (Etype (P)) then 21461 return not Is_Access_Constant (Root_Type (Etype (P))); 21462 21463 -- For the case of an indexed component whose prefix has a packed 21464 -- array type, the prefix has been rewritten into a type conversion. 21465 -- Determine variable-ness from the converted expression. 21466 21467 elsif Nkind (P) = N_Type_Conversion 21468 and then not Comes_From_Source (P) 21469 and then Is_Packed_Array (Etype (P)) 21470 then 21471 return Is_Variable (Expression (P)); 21472 21473 else 21474 return Is_Variable (P); 21475 end if; 21476 end Is_Variable_Prefix; 21477 21478 -- Start of processing for Is_Variable 21479 21480 begin 21481 -- Special check, allow x'Deref(expr) as a variable 21482 21483 if Nkind (N) = N_Attribute_Reference 21484 and then Attribute_Name (N) = Name_Deref 21485 then 21486 return True; 21487 end if; 21488 21489 -- Check if we perform the test on the original node since this may be a 21490 -- test of syntactic categories which must not be disturbed by whatever 21491 -- rewriting might have occurred. For example, an aggregate, which is 21492 -- certainly NOT a variable, could be turned into a variable by 21493 -- expansion. 21494 21495 if Use_Original_Node then 21496 Orig_Node := Original_Node (N); 21497 else 21498 Orig_Node := N; 21499 end if; 21500 21501 -- Definitely OK if Assignment_OK is set. Since this is something that 21502 -- only gets set for expanded nodes, the test is on N, not Orig_Node. 21503 21504 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then 21505 return True; 21506 21507 -- Normally we go to the original node, but there is one exception where 21508 -- we use the rewritten node, namely when it is an explicit dereference. 21509 -- The generated code may rewrite a prefix which is an access type with 21510 -- an explicit dereference. The dereference is a variable, even though 21511 -- the original node may not be (since it could be a constant of the 21512 -- access type). 21513 21514 -- In Ada 2005 we have a further case to consider: the prefix may be a 21515 -- function call given in prefix notation. The original node appears to 21516 -- be a selected component, but we need to examine the call. 21517 21518 elsif Nkind (N) = N_Explicit_Dereference 21519 and then Nkind (Orig_Node) /= N_Explicit_Dereference 21520 and then Present (Etype (Orig_Node)) 21521 and then Is_Access_Type (Etype (Orig_Node)) 21522 then 21523 -- Note that if the prefix is an explicit dereference that does not 21524 -- come from source, we must check for a rewritten function call in 21525 -- prefixed notation before other forms of rewriting, to prevent a 21526 -- compiler crash. 21527 21528 return 21529 (Nkind (Orig_Node) = N_Function_Call 21530 and then not Is_Access_Constant (Etype (Prefix (N)))) 21531 or else 21532 Is_Variable_Prefix (Original_Node (Prefix (N))); 21533 21534 -- Generalized indexing operations are rewritten as explicit 21535 -- dereferences, and it is only during resolution that we can 21536 -- check whether the context requires an access_to_variable type. 21537 21538 elsif Nkind (N) = N_Explicit_Dereference 21539 and then Present (Etype (Orig_Node)) 21540 and then Has_Implicit_Dereference (Etype (Orig_Node)) 21541 and then Ada_Version >= Ada_2012 21542 then 21543 return not Is_Access_Constant (Etype (Prefix (N))); 21544 21545 -- A function call is never a variable 21546 21547 elsif Nkind (N) = N_Function_Call then 21548 return False; 21549 21550 -- All remaining checks use the original node 21551 21552 elsif Is_Entity_Name (Orig_Node) 21553 and then Present (Entity (Orig_Node)) 21554 then 21555 declare 21556 E : constant Entity_Id := Entity (Orig_Node); 21557 K : constant Entity_Kind := Ekind (E); 21558 21559 begin 21560 if Is_Loop_Parameter (E) then 21561 return False; 21562 end if; 21563 21564 return (K = E_Variable 21565 and then Nkind (Parent (E)) /= N_Exception_Handler) 21566 or else (K = E_Component 21567 and then not In_Protected_Function (E)) 21568 or else (Present (Etype (E)) 21569 and then Is_Access_Object_Type (Etype (E)) 21570 and then Is_Access_Variable (Etype (E)) 21571 and then Is_Dereferenced (N)) 21572 or else K = E_Out_Parameter 21573 or else K = E_In_Out_Parameter 21574 or else K = E_Generic_In_Out_Parameter 21575 21576 -- Current instance of type. If this is a protected type, check 21577 -- we are not within the body of one of its protected functions. 21578 21579 or else (Is_Type (E) 21580 and then In_Open_Scopes (E) 21581 and then not In_Protected_Function (E)) 21582 21583 or else (Is_Incomplete_Or_Private_Type (E) 21584 and then In_Open_Scopes (Full_View (E))); 21585 end; 21586 21587 else 21588 case Nkind (Orig_Node) is 21589 when N_Indexed_Component 21590 | N_Slice 21591 => 21592 return Is_Variable_Prefix (Prefix (Orig_Node)); 21593 21594 when N_Selected_Component => 21595 return (Is_Variable (Selector_Name (Orig_Node)) 21596 and then Is_Variable_Prefix (Prefix (Orig_Node))) 21597 or else 21598 (Nkind (N) = N_Expanded_Name 21599 and then Scope (Entity (N)) = Entity (Prefix (N))); 21600 21601 -- For an explicit dereference, the type of the prefix cannot 21602 -- be an access to constant or an access to subprogram. 21603 21604 when N_Explicit_Dereference => 21605 declare 21606 Typ : constant Entity_Id := Etype (Prefix (Orig_Node)); 21607 begin 21608 return Is_Access_Type (Typ) 21609 and then not Is_Access_Constant (Root_Type (Typ)) 21610 and then Ekind (Typ) /= E_Access_Subprogram_Type; 21611 end; 21612 21613 -- The type conversion is the case where we do not deal with the 21614 -- context dependent special case of an actual parameter. Thus 21615 -- the type conversion is only considered a variable for the 21616 -- purposes of this routine if the target type is tagged. However, 21617 -- a type conversion is considered to be a variable if it does not 21618 -- come from source (this deals for example with the conversions 21619 -- of expressions to their actual subtypes). 21620 21621 when N_Type_Conversion => 21622 return Is_Variable (Expression (Orig_Node)) 21623 and then 21624 (not Comes_From_Source (Orig_Node) 21625 or else 21626 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node))) 21627 and then 21628 Is_Tagged_Type (Etype (Expression (Orig_Node))))); 21629 21630 -- GNAT allows an unchecked type conversion as a variable. This 21631 -- only affects the generation of internal expanded code, since 21632 -- calls to instantiations of Unchecked_Conversion are never 21633 -- considered variables (since they are function calls). 21634 21635 when N_Unchecked_Type_Conversion => 21636 return Is_Variable (Expression (Orig_Node)); 21637 21638 when others => 21639 return False; 21640 end case; 21641 end if; 21642 end Is_Variable; 21643 21644 ------------------------ 21645 -- Is_View_Conversion -- 21646 ------------------------ 21647 21648 function Is_View_Conversion (N : Node_Id) return Boolean is 21649 begin 21650 if Nkind (N) = N_Type_Conversion 21651 and then Nkind (Unqual_Conv (N)) in N_Has_Etype 21652 then 21653 if Is_Tagged_Type (Etype (N)) 21654 and then Is_Tagged_Type (Etype (Unqual_Conv (N))) 21655 then 21656 return True; 21657 21658 elsif Is_Actual_Parameter (N) 21659 and then (Is_Actual_Out_Parameter (N) 21660 or else Is_Actual_In_Out_Parameter (N)) 21661 then 21662 return True; 21663 end if; 21664 end if; 21665 21666 return False; 21667 end Is_View_Conversion; 21668 21669 --------------------------- 21670 -- Is_Visibly_Controlled -- 21671 --------------------------- 21672 21673 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is 21674 Root : constant Entity_Id := Root_Type (T); 21675 begin 21676 return Chars (Scope (Root)) = Name_Finalization 21677 and then Chars (Scope (Scope (Root))) = Name_Ada 21678 and then Scope (Scope (Scope (Root))) = Standard_Standard; 21679 end Is_Visibly_Controlled; 21680 21681 ---------------------------------------- 21682 -- Is_Volatile_Full_Access_Object_Ref -- 21683 ---------------------------------------- 21684 21685 function Is_Volatile_Full_Access_Object_Ref (N : Node_Id) return Boolean is 21686 function Is_VFA_Object_Entity (Id : Entity_Id) return Boolean; 21687 -- Determine whether arbitrary entity Id denotes an object that is 21688 -- Volatile_Full_Access. 21689 21690 ---------------------------- 21691 -- Is_VFA_Object_Entity -- 21692 ---------------------------- 21693 21694 function Is_VFA_Object_Entity (Id : Entity_Id) return Boolean is 21695 begin 21696 return 21697 Is_Object (Id) 21698 and then (Is_Volatile_Full_Access (Id) 21699 or else 21700 Is_Volatile_Full_Access (Etype (Id))); 21701 end Is_VFA_Object_Entity; 21702 21703 -- Start of processing for Is_Volatile_Full_Access_Object_Ref 21704 21705 begin 21706 if Is_Entity_Name (N) then 21707 return Is_VFA_Object_Entity (Entity (N)); 21708 21709 elsif Is_Volatile_Full_Access (Etype (N)) then 21710 return True; 21711 21712 elsif Nkind (N) = N_Selected_Component then 21713 return Is_Volatile_Full_Access (Entity (Selector_Name (N))); 21714 21715 else 21716 return False; 21717 end if; 21718 end Is_Volatile_Full_Access_Object_Ref; 21719 21720 -------------------------- 21721 -- Is_Volatile_Function -- 21722 -------------------------- 21723 21724 function Is_Volatile_Function (Func_Id : Entity_Id) return Boolean is 21725 begin 21726 pragma Assert (Ekind (Func_Id) in E_Function | E_Generic_Function); 21727 21728 -- A protected function is volatile 21729 21730 if Nkind (Parent (Unit_Declaration_Node (Func_Id))) = 21731 N_Protected_Definition 21732 then 21733 return True; 21734 21735 -- An instance of Ada.Unchecked_Conversion is a volatile function if 21736 -- either the source or the target are effectively volatile. 21737 21738 elsif Is_Unchecked_Conversion_Instance (Func_Id) 21739 and then Has_Effectively_Volatile_Profile (Func_Id) 21740 then 21741 return True; 21742 21743 -- Otherwise the function is treated as volatile if it is subject to 21744 -- enabled pragma Volatile_Function. 21745 21746 else 21747 return 21748 Is_Enabled_Pragma (Get_Pragma (Func_Id, Pragma_Volatile_Function)); 21749 end if; 21750 end Is_Volatile_Function; 21751 21752 ---------------------------- 21753 -- Is_Volatile_Object_Ref -- 21754 ---------------------------- 21755 21756 function Is_Volatile_Object_Ref (N : Node_Id) return Boolean is 21757 function Is_Volatile_Object_Entity (Id : Entity_Id) return Boolean; 21758 -- Determine whether arbitrary entity Id denotes an object that is 21759 -- Volatile. 21760 21761 function Prefix_Has_Volatile_Components (P : Node_Id) return Boolean; 21762 -- Determine whether prefix P has volatile components. This requires 21763 -- the presence of a Volatile_Components aspect/pragma or that P be 21764 -- itself a volatile object as per RM C.6(8). 21765 21766 --------------------------------- 21767 -- Is_Volatile_Object_Entity -- 21768 --------------------------------- 21769 21770 function Is_Volatile_Object_Entity (Id : Entity_Id) return Boolean is 21771 begin 21772 return 21773 Is_Object (Id) 21774 and then (Is_Volatile (Id) or else Is_Volatile (Etype (Id))); 21775 end Is_Volatile_Object_Entity; 21776 21777 ------------------------------------ 21778 -- Prefix_Has_Volatile_Components -- 21779 ------------------------------------ 21780 21781 function Prefix_Has_Volatile_Components (P : Node_Id) return Boolean is 21782 Typ : constant Entity_Id := Etype (P); 21783 21784 begin 21785 if Is_Access_Type (Typ) then 21786 declare 21787 Dtyp : constant Entity_Id := Designated_Type (Typ); 21788 21789 begin 21790 return Has_Volatile_Components (Dtyp) 21791 or else Is_Volatile (Dtyp); 21792 end; 21793 21794 elsif Has_Volatile_Components (Typ) then 21795 return True; 21796 21797 elsif Is_Entity_Name (P) 21798 and then Has_Volatile_Component (Entity (P)) 21799 then 21800 return True; 21801 21802 elsif Is_Volatile_Object_Ref (P) then 21803 return True; 21804 21805 else 21806 return False; 21807 end if; 21808 end Prefix_Has_Volatile_Components; 21809 21810 -- Start of processing for Is_Volatile_Object_Ref 21811 21812 begin 21813 if Is_Entity_Name (N) then 21814 return Is_Volatile_Object_Entity (Entity (N)); 21815 21816 elsif Is_Volatile (Etype (N)) then 21817 return True; 21818 21819 elsif Nkind (N) = N_Indexed_Component then 21820 return Prefix_Has_Volatile_Components (Prefix (N)); 21821 21822 elsif Nkind (N) = N_Selected_Component then 21823 return Prefix_Has_Volatile_Components (Prefix (N)) 21824 or else Is_Volatile (Entity (Selector_Name (N))); 21825 21826 else 21827 return False; 21828 end if; 21829 end Is_Volatile_Object_Ref; 21830 21831 ----------------------------- 21832 -- Iterate_Call_Parameters -- 21833 ----------------------------- 21834 21835 procedure Iterate_Call_Parameters (Call : Node_Id) is 21836 Actual : Node_Id := First_Actual (Call); 21837 Formal : Entity_Id := First_Formal (Get_Called_Entity (Call)); 21838 21839 begin 21840 while Present (Formal) and then Present (Actual) loop 21841 Handle_Parameter (Formal, Actual); 21842 21843 Next_Formal (Formal); 21844 Next_Actual (Actual); 21845 end loop; 21846 21847 pragma Assert (No (Formal)); 21848 pragma Assert (No (Actual)); 21849 end Iterate_Call_Parameters; 21850 21851 --------------------------- 21852 -- Itype_Has_Declaration -- 21853 --------------------------- 21854 21855 function Itype_Has_Declaration (Id : Entity_Id) return Boolean is 21856 begin 21857 pragma Assert (Is_Itype (Id)); 21858 return Present (Parent (Id)) 21859 and then Nkind (Parent (Id)) in 21860 N_Full_Type_Declaration | N_Subtype_Declaration 21861 and then Defining_Entity (Parent (Id)) = Id; 21862 end Itype_Has_Declaration; 21863 21864 ------------------------- 21865 -- Kill_Current_Values -- 21866 ------------------------- 21867 21868 procedure Kill_Current_Values 21869 (Ent : Entity_Id; 21870 Last_Assignment_Only : Boolean := False) 21871 is 21872 begin 21873 if Is_Assignable (Ent) then 21874 Set_Last_Assignment (Ent, Empty); 21875 end if; 21876 21877 if Is_Object (Ent) then 21878 if not Last_Assignment_Only then 21879 Kill_Checks (Ent); 21880 Set_Current_Value (Ent, Empty); 21881 21882 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags 21883 -- for a constant. Once the constant is elaborated, its value is 21884 -- not changed, therefore the associated flags that describe the 21885 -- value should not be modified either. 21886 21887 if Ekind (Ent) = E_Constant then 21888 null; 21889 21890 -- Non-constant entities 21891 21892 else 21893 if not Can_Never_Be_Null (Ent) then 21894 Set_Is_Known_Non_Null (Ent, False); 21895 end if; 21896 21897 Set_Is_Known_Null (Ent, False); 21898 21899 -- Reset the Is_Known_Valid flag unless the type is always 21900 -- valid. This does not apply to a loop parameter because its 21901 -- bounds are defined by the loop header and therefore always 21902 -- valid. 21903 21904 if not Is_Known_Valid (Etype (Ent)) 21905 and then Ekind (Ent) /= E_Loop_Parameter 21906 then 21907 Set_Is_Known_Valid (Ent, False); 21908 end if; 21909 end if; 21910 end if; 21911 end if; 21912 end Kill_Current_Values; 21913 21914 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is 21915 S : Entity_Id; 21916 21917 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id); 21918 -- Clear current value for entity E and all entities chained to E 21919 21920 ------------------------------------------ 21921 -- Kill_Current_Values_For_Entity_Chain -- 21922 ------------------------------------------ 21923 21924 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is 21925 Ent : Entity_Id; 21926 begin 21927 Ent := E; 21928 while Present (Ent) loop 21929 Kill_Current_Values (Ent, Last_Assignment_Only); 21930 Next_Entity (Ent); 21931 end loop; 21932 end Kill_Current_Values_For_Entity_Chain; 21933 21934 -- Start of processing for Kill_Current_Values 21935 21936 begin 21937 -- Kill all saved checks, a special case of killing saved values 21938 21939 if not Last_Assignment_Only then 21940 Kill_All_Checks; 21941 end if; 21942 21943 -- Loop through relevant scopes, which includes the current scope and 21944 -- any parent scopes if the current scope is a block or a package. 21945 21946 S := Current_Scope; 21947 Scope_Loop : loop 21948 21949 -- Clear current values of all entities in current scope 21950 21951 Kill_Current_Values_For_Entity_Chain (First_Entity (S)); 21952 21953 -- If scope is a package, also clear current values of all private 21954 -- entities in the scope. 21955 21956 if Is_Package_Or_Generic_Package (S) 21957 or else Is_Concurrent_Type (S) 21958 then 21959 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S)); 21960 end if; 21961 21962 -- If this is a not a subprogram, deal with parents 21963 21964 if not Is_Subprogram (S) then 21965 S := Scope (S); 21966 exit Scope_Loop when S = Standard_Standard; 21967 else 21968 exit Scope_Loop; 21969 end if; 21970 end loop Scope_Loop; 21971 end Kill_Current_Values; 21972 21973 -------------------------- 21974 -- Kill_Size_Check_Code -- 21975 -------------------------- 21976 21977 procedure Kill_Size_Check_Code (E : Entity_Id) is 21978 begin 21979 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 21980 and then Present (Size_Check_Code (E)) 21981 then 21982 Remove (Size_Check_Code (E)); 21983 Set_Size_Check_Code (E, Empty); 21984 end if; 21985 end Kill_Size_Check_Code; 21986 21987 -------------------- 21988 -- Known_Non_Null -- 21989 -------------------- 21990 21991 function Known_Non_Null (N : Node_Id) return Boolean is 21992 Status : constant Null_Status_Kind := Null_Status (N); 21993 21994 Id : Entity_Id; 21995 Op : Node_Kind; 21996 Val : Node_Id; 21997 21998 begin 21999 -- The expression yields a non-null value ignoring simple flow analysis 22000 22001 if Status = Is_Non_Null then 22002 return True; 22003 22004 -- Otherwise check whether N is a reference to an entity that appears 22005 -- within a conditional construct. 22006 22007 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 22008 22009 -- First check if we are in decisive conditional 22010 22011 Get_Current_Value_Condition (N, Op, Val); 22012 22013 if Known_Null (Val) then 22014 if Op = N_Op_Eq then 22015 return False; 22016 elsif Op = N_Op_Ne then 22017 return True; 22018 end if; 22019 end if; 22020 22021 -- If OK to do replacement, test Is_Known_Non_Null flag 22022 22023 Id := Entity (N); 22024 22025 if OK_To_Do_Constant_Replacement (Id) then 22026 return Is_Known_Non_Null (Id); 22027 end if; 22028 end if; 22029 22030 -- Otherwise it is not possible to determine whether N yields a non-null 22031 -- value. 22032 22033 return False; 22034 end Known_Non_Null; 22035 22036 ---------------- 22037 -- Known_Null -- 22038 ---------------- 22039 22040 function Known_Null (N : Node_Id) return Boolean is 22041 Status : constant Null_Status_Kind := Null_Status (N); 22042 22043 Id : Entity_Id; 22044 Op : Node_Kind; 22045 Val : Node_Id; 22046 22047 begin 22048 -- The expression yields a null value ignoring simple flow analysis 22049 22050 if Status = Is_Null then 22051 return True; 22052 22053 -- Otherwise check whether N is a reference to an entity that appears 22054 -- within a conditional construct. 22055 22056 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 22057 22058 -- First check if we are in decisive conditional 22059 22060 Get_Current_Value_Condition (N, Op, Val); 22061 22062 if Known_Null (Val) then 22063 if Op = N_Op_Eq then 22064 return True; 22065 elsif Op = N_Op_Ne then 22066 return False; 22067 end if; 22068 end if; 22069 22070 -- If OK to do replacement, test Is_Known_Null flag 22071 22072 Id := Entity (N); 22073 22074 if OK_To_Do_Constant_Replacement (Id) then 22075 return Is_Known_Null (Id); 22076 end if; 22077 end if; 22078 22079 -- Otherwise it is not possible to determine whether N yields a null 22080 -- value. 22081 22082 return False; 22083 end Known_Null; 22084 22085 -------------------------- 22086 -- Known_To_Be_Assigned -- 22087 -------------------------- 22088 22089 function Known_To_Be_Assigned (N : Node_Id) return Boolean is 22090 P : constant Node_Id := Parent (N); 22091 22092 begin 22093 case Nkind (P) is 22094 22095 -- Test left side of assignment 22096 22097 when N_Assignment_Statement => 22098 return N = Name (P); 22099 22100 -- Function call arguments are never lvalues 22101 22102 when N_Function_Call => 22103 return False; 22104 22105 -- Positional parameter for procedure or accept call 22106 22107 when N_Accept_Statement 22108 | N_Procedure_Call_Statement 22109 => 22110 declare 22111 Proc : Entity_Id; 22112 Form : Entity_Id; 22113 Act : Node_Id; 22114 22115 begin 22116 Proc := Get_Subprogram_Entity (P); 22117 22118 if No (Proc) then 22119 return False; 22120 end if; 22121 22122 -- If we are not a list member, something is strange, so 22123 -- be conservative and return False. 22124 22125 if not Is_List_Member (N) then 22126 return False; 22127 end if; 22128 22129 -- We are going to find the right formal by stepping forward 22130 -- through the formals, as we step backwards in the actuals. 22131 22132 Form := First_Formal (Proc); 22133 Act := N; 22134 loop 22135 -- If no formal, something is weird, so be conservative 22136 -- and return False. 22137 22138 if No (Form) then 22139 return False; 22140 end if; 22141 22142 Prev (Act); 22143 exit when No (Act); 22144 Next_Formal (Form); 22145 end loop; 22146 22147 return Ekind (Form) /= E_In_Parameter; 22148 end; 22149 22150 -- Named parameter for procedure or accept call 22151 22152 when N_Parameter_Association => 22153 declare 22154 Proc : Entity_Id; 22155 Form : Entity_Id; 22156 22157 begin 22158 Proc := Get_Subprogram_Entity (Parent (P)); 22159 22160 if No (Proc) then 22161 return False; 22162 end if; 22163 22164 -- Loop through formals to find the one that matches 22165 22166 Form := First_Formal (Proc); 22167 loop 22168 -- If no matching formal, that's peculiar, some kind of 22169 -- previous error, so return False to be conservative. 22170 -- Actually this also happens in legal code in the case 22171 -- where P is a parameter association for an Extra_Formal??? 22172 22173 if No (Form) then 22174 return False; 22175 end if; 22176 22177 -- Else test for match 22178 22179 if Chars (Form) = Chars (Selector_Name (P)) then 22180 return Ekind (Form) /= E_In_Parameter; 22181 end if; 22182 22183 Next_Formal (Form); 22184 end loop; 22185 end; 22186 22187 -- Test for appearing in a conversion that itself appears 22188 -- in an lvalue context, since this should be an lvalue. 22189 22190 when N_Type_Conversion => 22191 return Known_To_Be_Assigned (P); 22192 22193 -- All other references are definitely not known to be modifications 22194 22195 when others => 22196 return False; 22197 end case; 22198 end Known_To_Be_Assigned; 22199 22200 --------------------------- 22201 -- Last_Source_Statement -- 22202 --------------------------- 22203 22204 function Last_Source_Statement (HSS : Node_Id) return Node_Id is 22205 N : Node_Id; 22206 22207 begin 22208 N := Last (Statements (HSS)); 22209 while Present (N) loop 22210 exit when Comes_From_Source (N); 22211 Prev (N); 22212 end loop; 22213 22214 return N; 22215 end Last_Source_Statement; 22216 22217 ----------------------- 22218 -- Mark_Coextensions -- 22219 ----------------------- 22220 22221 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is 22222 Is_Dynamic : Boolean; 22223 -- Indicates whether the context causes nested coextensions to be 22224 -- dynamic or static 22225 22226 function Mark_Allocator (N : Node_Id) return Traverse_Result; 22227 -- Recognize an allocator node and label it as a dynamic coextension 22228 22229 -------------------- 22230 -- Mark_Allocator -- 22231 -------------------- 22232 22233 function Mark_Allocator (N : Node_Id) return Traverse_Result is 22234 begin 22235 if Nkind (N) = N_Allocator then 22236 if Is_Dynamic then 22237 Set_Is_Static_Coextension (N, False); 22238 Set_Is_Dynamic_Coextension (N); 22239 22240 -- If the allocator expression is potentially dynamic, it may 22241 -- be expanded out of order and require dynamic allocation 22242 -- anyway, so we treat the coextension itself as dynamic. 22243 -- Potential optimization ??? 22244 22245 elsif Nkind (Expression (N)) = N_Qualified_Expression 22246 and then Nkind (Expression (Expression (N))) = N_Op_Concat 22247 then 22248 Set_Is_Static_Coextension (N, False); 22249 Set_Is_Dynamic_Coextension (N); 22250 else 22251 Set_Is_Dynamic_Coextension (N, False); 22252 Set_Is_Static_Coextension (N); 22253 end if; 22254 end if; 22255 22256 return OK; 22257 end Mark_Allocator; 22258 22259 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator); 22260 22261 -- Start of processing for Mark_Coextensions 22262 22263 begin 22264 -- An allocator that appears on the right-hand side of an assignment is 22265 -- treated as a potentially dynamic coextension when the right-hand side 22266 -- is an allocator or a qualified expression. 22267 22268 -- Obj := new ...'(new Coextension ...); 22269 22270 if Nkind (Context_Nod) = N_Assignment_Statement then 22271 Is_Dynamic := Nkind (Expression (Context_Nod)) in 22272 N_Allocator | N_Qualified_Expression; 22273 22274 -- An allocator that appears within the expression of a simple return 22275 -- statement is treated as a potentially dynamic coextension when the 22276 -- expression is either aggregate, allocator, or qualified expression. 22277 22278 -- return (new Coextension ...); 22279 -- return new ...'(new Coextension ...); 22280 22281 elsif Nkind (Context_Nod) = N_Simple_Return_Statement then 22282 Is_Dynamic := Nkind (Expression (Context_Nod)) in 22283 N_Aggregate | N_Allocator | N_Qualified_Expression; 22284 22285 -- An alloctor that appears within the initialization expression of an 22286 -- object declaration is considered a potentially dynamic coextension 22287 -- when the initialization expression is an allocator or a qualified 22288 -- expression. 22289 22290 -- Obj : ... := new ...'(new Coextension ...); 22291 22292 -- A similar case arises when the object declaration is part of an 22293 -- extended return statement. 22294 22295 -- return Obj : ... := new ...'(new Coextension ...); 22296 -- return Obj : ... := (new Coextension ...); 22297 22298 elsif Nkind (Context_Nod) = N_Object_Declaration then 22299 Is_Dynamic := Nkind (Root_Nod) in N_Allocator | N_Qualified_Expression 22300 or else Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement; 22301 22302 -- This routine should not be called with constructs that cannot contain 22303 -- coextensions. 22304 22305 else 22306 raise Program_Error; 22307 end if; 22308 22309 Mark_Allocators (Root_Nod); 22310 end Mark_Coextensions; 22311 22312 --------------------------------- 22313 -- Mark_Elaboration_Attributes -- 22314 --------------------------------- 22315 22316 procedure Mark_Elaboration_Attributes 22317 (N_Id : Node_Or_Entity_Id; 22318 Checks : Boolean := False; 22319 Level : Boolean := False; 22320 Modes : Boolean := False; 22321 Warnings : Boolean := False) 22322 is 22323 function Elaboration_Checks_OK 22324 (Target_Id : Entity_Id; 22325 Context_Id : Entity_Id) return Boolean; 22326 -- Determine whether elaboration checks are enabled for target Target_Id 22327 -- which resides within context Context_Id. 22328 22329 procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id); 22330 -- Preserve relevant attributes of the context in arbitrary entity Id 22331 22332 procedure Mark_Elaboration_Attributes_Node (N : Node_Id); 22333 -- Preserve relevant attributes of the context in arbitrary node N 22334 22335 --------------------------- 22336 -- Elaboration_Checks_OK -- 22337 --------------------------- 22338 22339 function Elaboration_Checks_OK 22340 (Target_Id : Entity_Id; 22341 Context_Id : Entity_Id) return Boolean 22342 is 22343 Encl_Scop : Entity_Id; 22344 22345 begin 22346 -- Elaboration checks are suppressed for the target 22347 22348 if Elaboration_Checks_Suppressed (Target_Id) then 22349 return False; 22350 end if; 22351 22352 -- Otherwise elaboration checks are OK for the target, but may be 22353 -- suppressed for the context where the target is declared. 22354 22355 Encl_Scop := Context_Id; 22356 while Present (Encl_Scop) and then Encl_Scop /= Standard_Standard loop 22357 if Elaboration_Checks_Suppressed (Encl_Scop) then 22358 return False; 22359 end if; 22360 22361 Encl_Scop := Scope (Encl_Scop); 22362 end loop; 22363 22364 -- Neither the target nor its declarative context have elaboration 22365 -- checks suppressed. 22366 22367 return True; 22368 end Elaboration_Checks_OK; 22369 22370 ------------------------------------ 22371 -- Mark_Elaboration_Attributes_Id -- 22372 ------------------------------------ 22373 22374 procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id) is 22375 begin 22376 -- Mark the status of elaboration checks in effect. Do not reset the 22377 -- status in case the entity is reanalyzed with checks suppressed. 22378 22379 if Checks and then not Is_Elaboration_Checks_OK_Id (Id) then 22380 Set_Is_Elaboration_Checks_OK_Id (Id, 22381 Elaboration_Checks_OK 22382 (Target_Id => Id, 22383 Context_Id => Scope (Id))); 22384 end if; 22385 22386 -- Mark the status of elaboration warnings in effect. Do not reset 22387 -- the status in case the entity is reanalyzed with warnings off. 22388 22389 if Warnings and then not Is_Elaboration_Warnings_OK_Id (Id) then 22390 Set_Is_Elaboration_Warnings_OK_Id (Id, Elab_Warnings); 22391 end if; 22392 end Mark_Elaboration_Attributes_Id; 22393 22394 -------------------------------------- 22395 -- Mark_Elaboration_Attributes_Node -- 22396 -------------------------------------- 22397 22398 procedure Mark_Elaboration_Attributes_Node (N : Node_Id) is 22399 function Extract_Name (N : Node_Id) return Node_Id; 22400 -- Obtain the Name attribute of call or instantiation N 22401 22402 ------------------ 22403 -- Extract_Name -- 22404 ------------------ 22405 22406 function Extract_Name (N : Node_Id) return Node_Id is 22407 Nam : Node_Id; 22408 22409 begin 22410 Nam := Name (N); 22411 22412 -- A call to an entry family appears in indexed form 22413 22414 if Nkind (Nam) = N_Indexed_Component then 22415 Nam := Prefix (Nam); 22416 end if; 22417 22418 -- The name may also appear in qualified form 22419 22420 if Nkind (Nam) = N_Selected_Component then 22421 Nam := Selector_Name (Nam); 22422 end if; 22423 22424 return Nam; 22425 end Extract_Name; 22426 22427 -- Local variables 22428 22429 Context_Id : Entity_Id; 22430 Nam : Node_Id; 22431 22432 -- Start of processing for Mark_Elaboration_Attributes_Node 22433 22434 begin 22435 -- Mark the status of elaboration checks in effect. Do not reset the 22436 -- status in case the node is reanalyzed with checks suppressed. 22437 22438 if Checks and then not Is_Elaboration_Checks_OK_Node (N) then 22439 22440 -- Assignments, attribute references, and variable references do 22441 -- not have a "declarative" context. 22442 22443 Context_Id := Empty; 22444 22445 -- The status of elaboration checks for calls and instantiations 22446 -- depends on the most recent pragma Suppress/Unsuppress, as well 22447 -- as the suppression status of the context where the target is 22448 -- defined. 22449 22450 -- package Pack is 22451 -- function Func ...; 22452 -- end Pack; 22453 22454 -- with Pack; 22455 -- procedure Main is 22456 -- pragma Suppress (Elaboration_Checks, Pack); 22457 -- X : ... := Pack.Func; 22458 -- ... 22459 22460 -- In the example above, the call to Func has elaboration checks 22461 -- enabled because there is no active general purpose suppression 22462 -- pragma, however the elaboration checks of Pack are explicitly 22463 -- suppressed. As a result the elaboration checks of the call must 22464 -- be disabled in order to preserve this dependency. 22465 22466 if Nkind (N) in N_Entry_Call_Statement 22467 | N_Function_Call 22468 | N_Function_Instantiation 22469 | N_Package_Instantiation 22470 | N_Procedure_Call_Statement 22471 | N_Procedure_Instantiation 22472 then 22473 Nam := Extract_Name (N); 22474 22475 if Is_Entity_Name (Nam) and then Present (Entity (Nam)) then 22476 Context_Id := Scope (Entity (Nam)); 22477 end if; 22478 end if; 22479 22480 Set_Is_Elaboration_Checks_OK_Node (N, 22481 Elaboration_Checks_OK 22482 (Target_Id => Empty, 22483 Context_Id => Context_Id)); 22484 end if; 22485 22486 -- Mark the enclosing level of the node. Do not reset the status in 22487 -- case the node is relocated and reanalyzed. 22488 22489 if Level and then not Is_Declaration_Level_Node (N) then 22490 Set_Is_Declaration_Level_Node (N, 22491 Find_Enclosing_Level (N) = Declaration_Level); 22492 end if; 22493 22494 -- Mark the Ghost and SPARK mode in effect 22495 22496 if Modes then 22497 if Ghost_Mode = Ignore then 22498 Set_Is_Ignored_Ghost_Node (N); 22499 end if; 22500 22501 if SPARK_Mode = On then 22502 Set_Is_SPARK_Mode_On_Node (N); 22503 end if; 22504 end if; 22505 22506 -- Mark the status of elaboration warnings in effect. Do not reset 22507 -- the status in case the node is reanalyzed with warnings off. 22508 22509 if Warnings and then not Is_Elaboration_Warnings_OK_Node (N) then 22510 Set_Is_Elaboration_Warnings_OK_Node (N, Elab_Warnings); 22511 end if; 22512 end Mark_Elaboration_Attributes_Node; 22513 22514 -- Start of processing for Mark_Elaboration_Attributes 22515 22516 begin 22517 -- Do not capture any elaboration-related attributes when switch -gnatH 22518 -- (legacy elaboration checking mode enabled) is in effect because the 22519 -- attributes are useless to the legacy model. 22520 22521 if Legacy_Elaboration_Checks then 22522 return; 22523 end if; 22524 22525 if Nkind (N_Id) in N_Entity then 22526 Mark_Elaboration_Attributes_Id (N_Id); 22527 else 22528 Mark_Elaboration_Attributes_Node (N_Id); 22529 end if; 22530 end Mark_Elaboration_Attributes; 22531 22532 ---------------------------------------- 22533 -- Mark_Save_Invocation_Graph_Of_Body -- 22534 ---------------------------------------- 22535 22536 procedure Mark_Save_Invocation_Graph_Of_Body is 22537 Main : constant Node_Id := Cunit (Main_Unit); 22538 Main_Unit : constant Node_Id := Unit (Main); 22539 Aux_Id : Entity_Id; 22540 22541 begin 22542 Set_Save_Invocation_Graph_Of_Body (Main); 22543 22544 -- Assume that the main unit does not have a complimentary unit 22545 22546 Aux_Id := Empty; 22547 22548 -- Obtain the complimentary unit of the main unit 22549 22550 if Nkind (Main_Unit) in N_Generic_Package_Declaration 22551 | N_Generic_Subprogram_Declaration 22552 | N_Package_Declaration 22553 | N_Subprogram_Declaration 22554 then 22555 Aux_Id := Corresponding_Body (Main_Unit); 22556 22557 elsif Nkind (Main_Unit) in N_Package_Body 22558 | N_Subprogram_Body 22559 | N_Subprogram_Renaming_Declaration 22560 then 22561 Aux_Id := Corresponding_Spec (Main_Unit); 22562 end if; 22563 22564 if Present (Aux_Id) then 22565 Set_Save_Invocation_Graph_Of_Body 22566 (Parent (Unit_Declaration_Node (Aux_Id))); 22567 end if; 22568 end Mark_Save_Invocation_Graph_Of_Body; 22569 22570 ---------------------------------- 22571 -- Matching_Static_Array_Bounds -- 22572 ---------------------------------- 22573 22574 function Matching_Static_Array_Bounds 22575 (L_Typ : Node_Id; 22576 R_Typ : Node_Id) return Boolean 22577 is 22578 L_Ndims : constant Nat := Number_Dimensions (L_Typ); 22579 R_Ndims : constant Nat := Number_Dimensions (R_Typ); 22580 22581 L_Index : Node_Id := Empty; -- init to ... 22582 R_Index : Node_Id := Empty; -- ...avoid warnings 22583 L_Low : Node_Id; 22584 L_High : Node_Id; 22585 L_Len : Uint; 22586 R_Low : Node_Id; 22587 R_High : Node_Id; 22588 R_Len : Uint; 22589 22590 begin 22591 if L_Ndims /= R_Ndims then 22592 return False; 22593 end if; 22594 22595 -- Unconstrained types do not have static bounds 22596 22597 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then 22598 return False; 22599 end if; 22600 22601 -- First treat specially the first dimension, as the lower bound and 22602 -- length of string literals are not stored like those of arrays. 22603 22604 if Ekind (L_Typ) = E_String_Literal_Subtype then 22605 L_Low := String_Literal_Low_Bound (L_Typ); 22606 L_Len := String_Literal_Length (L_Typ); 22607 else 22608 L_Index := First_Index (L_Typ); 22609 Get_Index_Bounds (L_Index, L_Low, L_High); 22610 22611 if Is_OK_Static_Expression (L_Low) 22612 and then 22613 Is_OK_Static_Expression (L_High) 22614 then 22615 if Expr_Value (L_High) < Expr_Value (L_Low) then 22616 L_Len := Uint_0; 22617 else 22618 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1; 22619 end if; 22620 else 22621 return False; 22622 end if; 22623 end if; 22624 22625 if Ekind (R_Typ) = E_String_Literal_Subtype then 22626 R_Low := String_Literal_Low_Bound (R_Typ); 22627 R_Len := String_Literal_Length (R_Typ); 22628 else 22629 R_Index := First_Index (R_Typ); 22630 Get_Index_Bounds (R_Index, R_Low, R_High); 22631 22632 if Is_OK_Static_Expression (R_Low) 22633 and then 22634 Is_OK_Static_Expression (R_High) 22635 then 22636 if Expr_Value (R_High) < Expr_Value (R_Low) then 22637 R_Len := Uint_0; 22638 else 22639 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1; 22640 end if; 22641 else 22642 return False; 22643 end if; 22644 end if; 22645 22646 if (Is_OK_Static_Expression (L_Low) 22647 and then 22648 Is_OK_Static_Expression (R_Low)) 22649 and then Expr_Value (L_Low) = Expr_Value (R_Low) 22650 and then L_Len = R_Len 22651 then 22652 null; 22653 else 22654 return False; 22655 end if; 22656 22657 -- Then treat all other dimensions 22658 22659 for Indx in 2 .. L_Ndims loop 22660 Next (L_Index); 22661 Next (R_Index); 22662 22663 Get_Index_Bounds (L_Index, L_Low, L_High); 22664 Get_Index_Bounds (R_Index, R_Low, R_High); 22665 22666 if (Is_OK_Static_Expression (L_Low) and then 22667 Is_OK_Static_Expression (L_High) and then 22668 Is_OK_Static_Expression (R_Low) and then 22669 Is_OK_Static_Expression (R_High)) 22670 and then (Expr_Value (L_Low) = Expr_Value (R_Low) 22671 and then 22672 Expr_Value (L_High) = Expr_Value (R_High)) 22673 then 22674 null; 22675 else 22676 return False; 22677 end if; 22678 end loop; 22679 22680 -- If we fall through the loop, all indexes matched 22681 22682 return True; 22683 end Matching_Static_Array_Bounds; 22684 22685 ------------------- 22686 -- May_Be_Lvalue -- 22687 ------------------- 22688 22689 function May_Be_Lvalue (N : Node_Id) return Boolean is 22690 P : constant Node_Id := Parent (N); 22691 22692 begin 22693 case Nkind (P) is 22694 22695 -- Test left side of assignment 22696 22697 when N_Assignment_Statement => 22698 return N = Name (P); 22699 22700 -- Test prefix of component or attribute. Note that the prefix of an 22701 -- explicit or implicit dereference cannot be an l-value. In the case 22702 -- of a 'Read attribute, the reference can be an actual in the 22703 -- argument list of the attribute. 22704 22705 when N_Attribute_Reference => 22706 return (N = Prefix (P) 22707 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P))) 22708 or else 22709 Attribute_Name (P) = Name_Read; 22710 22711 -- For an expanded name, the name is an lvalue if the expanded name 22712 -- is an lvalue, but the prefix is never an lvalue, since it is just 22713 -- the scope where the name is found. 22714 22715 when N_Expanded_Name => 22716 if N = Prefix (P) then 22717 return May_Be_Lvalue (P); 22718 else 22719 return False; 22720 end if; 22721 22722 -- For a selected component A.B, A is certainly an lvalue if A.B is. 22723 -- B is a little interesting, if we have A.B := 3, there is some 22724 -- discussion as to whether B is an lvalue or not, we choose to say 22725 -- it is. Note however that A is not an lvalue if it is of an access 22726 -- type since this is an implicit dereference. 22727 22728 when N_Selected_Component => 22729 if N = Prefix (P) 22730 and then Present (Etype (N)) 22731 and then Is_Access_Type (Etype (N)) 22732 then 22733 return False; 22734 else 22735 return May_Be_Lvalue (P); 22736 end if; 22737 22738 -- For an indexed component or slice, the index or slice bounds is 22739 -- never an lvalue. The prefix is an lvalue if the indexed component 22740 -- or slice is an lvalue, except if it is an access type, where we 22741 -- have an implicit dereference. 22742 22743 when N_Indexed_Component 22744 | N_Slice 22745 => 22746 if N /= Prefix (P) 22747 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N))) 22748 then 22749 return False; 22750 else 22751 return May_Be_Lvalue (P); 22752 end if; 22753 22754 -- Prefix of a reference is an lvalue if the reference is an lvalue 22755 22756 when N_Reference => 22757 return May_Be_Lvalue (P); 22758 22759 -- Prefix of explicit dereference is never an lvalue 22760 22761 when N_Explicit_Dereference => 22762 return False; 22763 22764 -- Positional parameter for subprogram, entry, or accept call. 22765 -- In older versions of Ada function call arguments are never 22766 -- lvalues. In Ada 2012 functions can have in-out parameters. 22767 22768 when N_Accept_Statement 22769 | N_Entry_Call_Statement 22770 | N_Subprogram_Call 22771 => 22772 if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then 22773 return False; 22774 end if; 22775 22776 -- The following mechanism is clumsy and fragile. A single flag 22777 -- set in Resolve_Actuals would be preferable ??? 22778 22779 declare 22780 Proc : Entity_Id; 22781 Form : Entity_Id; 22782 Act : Node_Id; 22783 22784 begin 22785 Proc := Get_Subprogram_Entity (P); 22786 22787 if No (Proc) then 22788 return True; 22789 end if; 22790 22791 -- If we are not a list member, something is strange, so be 22792 -- conservative and return True. 22793 22794 if not Is_List_Member (N) then 22795 return True; 22796 end if; 22797 22798 -- We are going to find the right formal by stepping forward 22799 -- through the formals, as we step backwards in the actuals. 22800 22801 Form := First_Formal (Proc); 22802 Act := N; 22803 loop 22804 -- If no formal, something is weird, so be conservative and 22805 -- return True. 22806 22807 if No (Form) then 22808 return True; 22809 end if; 22810 22811 Prev (Act); 22812 exit when No (Act); 22813 Next_Formal (Form); 22814 end loop; 22815 22816 return Ekind (Form) /= E_In_Parameter; 22817 end; 22818 22819 -- Named parameter for procedure or accept call 22820 22821 when N_Parameter_Association => 22822 declare 22823 Proc : Entity_Id; 22824 Form : Entity_Id; 22825 22826 begin 22827 Proc := Get_Subprogram_Entity (Parent (P)); 22828 22829 if No (Proc) then 22830 return True; 22831 end if; 22832 22833 -- Loop through formals to find the one that matches 22834 22835 Form := First_Formal (Proc); 22836 loop 22837 -- If no matching formal, that's peculiar, some kind of 22838 -- previous error, so return True to be conservative. 22839 -- Actually happens with legal code for an unresolved call 22840 -- where we may get the wrong homonym??? 22841 22842 if No (Form) then 22843 return True; 22844 end if; 22845 22846 -- Else test for match 22847 22848 if Chars (Form) = Chars (Selector_Name (P)) then 22849 return Ekind (Form) /= E_In_Parameter; 22850 end if; 22851 22852 Next_Formal (Form); 22853 end loop; 22854 end; 22855 22856 -- Test for appearing in a conversion that itself appears in an 22857 -- lvalue context, since this should be an lvalue. 22858 22859 when N_Type_Conversion => 22860 return May_Be_Lvalue (P); 22861 22862 -- Test for appearance in object renaming declaration 22863 22864 when N_Object_Renaming_Declaration => 22865 return True; 22866 22867 -- All other references are definitely not lvalues 22868 22869 when others => 22870 return False; 22871 end case; 22872 end May_Be_Lvalue; 22873 22874 ----------------- 22875 -- Might_Raise -- 22876 ----------------- 22877 22878 function Might_Raise (N : Node_Id) return Boolean is 22879 Result : Boolean := False; 22880 22881 function Process (N : Node_Id) return Traverse_Result; 22882 -- Set Result to True if we find something that could raise an exception 22883 22884 ------------- 22885 -- Process -- 22886 ------------- 22887 22888 function Process (N : Node_Id) return Traverse_Result is 22889 begin 22890 if Nkind (N) in N_Procedure_Call_Statement 22891 | N_Function_Call 22892 | N_Raise_Statement 22893 | N_Raise_xxx_Error 22894 then 22895 Result := True; 22896 return Abandon; 22897 else 22898 return OK; 22899 end if; 22900 end Process; 22901 22902 procedure Set_Result is new Traverse_Proc (Process); 22903 22904 -- Start of processing for Might_Raise 22905 22906 begin 22907 -- False if exceptions can't be propagated 22908 22909 if No_Exception_Handlers_Set then 22910 return False; 22911 end if; 22912 22913 -- If the checks handled by the back end are not disabled, we cannot 22914 -- ensure that no exception will be raised. 22915 22916 if not Access_Checks_Suppressed (Empty) 22917 or else not Discriminant_Checks_Suppressed (Empty) 22918 or else not Range_Checks_Suppressed (Empty) 22919 or else not Index_Checks_Suppressed (Empty) 22920 or else Opt.Stack_Checking_Enabled 22921 then 22922 return True; 22923 end if; 22924 22925 Set_Result (N); 22926 return Result; 22927 end Might_Raise; 22928 22929 ---------------------------------------- 22930 -- Nearest_Class_Condition_Subprogram -- 22931 ---------------------------------------- 22932 22933 function Nearest_Class_Condition_Subprogram 22934 (Kind : Condition_Kind; 22935 Spec_Id : Entity_Id) return Entity_Id 22936 is 22937 Subp_Id : constant Entity_Id := Ultimate_Alias (Spec_Id); 22938 22939 begin 22940 -- Prevent cascaded errors 22941 22942 if not Is_Dispatching_Operation (Subp_Id) then 22943 return Empty; 22944 22945 -- No need to search if this subprogram has class-wide postconditions 22946 22947 elsif Present (Class_Condition (Kind, Subp_Id)) then 22948 return Subp_Id; 22949 end if; 22950 22951 -- Process the contracts of inherited subprograms, looking for 22952 -- class-wide pre/postconditions. 22953 22954 declare 22955 Subps : constant Subprogram_List := Inherited_Subprograms (Subp_Id); 22956 Subp_Id : Entity_Id; 22957 22958 begin 22959 for Index in Subps'Range loop 22960 Subp_Id := Subps (Index); 22961 22962 if Present (Alias (Subp_Id)) then 22963 Subp_Id := Ultimate_Alias (Subp_Id); 22964 end if; 22965 22966 -- Wrappers of class-wide pre/postconditions reference the 22967 -- parent primitive that has the inherited contract. 22968 22969 if Is_Wrapper (Subp_Id) 22970 and then Present (LSP_Subprogram (Subp_Id)) 22971 then 22972 Subp_Id := LSP_Subprogram (Subp_Id); 22973 end if; 22974 22975 if Present (Class_Condition (Kind, Subp_Id)) then 22976 return Subp_Id; 22977 end if; 22978 end loop; 22979 end; 22980 22981 return Empty; 22982 end Nearest_Class_Condition_Subprogram; 22983 22984 -------------------------------- 22985 -- Nearest_Enclosing_Instance -- 22986 -------------------------------- 22987 22988 function Nearest_Enclosing_Instance (E : Entity_Id) return Entity_Id is 22989 Inst : Entity_Id; 22990 22991 begin 22992 Inst := Scope (E); 22993 while Present (Inst) and then Inst /= Standard_Standard loop 22994 if Is_Generic_Instance (Inst) then 22995 return Inst; 22996 end if; 22997 22998 Inst := Scope (Inst); 22999 end loop; 23000 23001 return Empty; 23002 end Nearest_Enclosing_Instance; 23003 23004 ------------------------ 23005 -- Needs_Finalization -- 23006 ------------------------ 23007 23008 function Needs_Finalization (Typ : Entity_Id) return Boolean is 23009 function Has_Some_Controlled_Component 23010 (Input_Typ : Entity_Id) return Boolean; 23011 -- Determine whether type Input_Typ has at least one controlled 23012 -- component. 23013 23014 ----------------------------------- 23015 -- Has_Some_Controlled_Component -- 23016 ----------------------------------- 23017 23018 function Has_Some_Controlled_Component 23019 (Input_Typ : Entity_Id) return Boolean 23020 is 23021 Comp : Entity_Id; 23022 23023 begin 23024 -- When a type is already frozen and has at least one controlled 23025 -- component, or is manually decorated, it is sufficient to inspect 23026 -- flag Has_Controlled_Component. 23027 23028 if Has_Controlled_Component (Input_Typ) then 23029 return True; 23030 23031 -- Otherwise inspect the internals of the type 23032 23033 elsif not Is_Frozen (Input_Typ) then 23034 if Is_Array_Type (Input_Typ) then 23035 return Needs_Finalization (Component_Type (Input_Typ)); 23036 23037 elsif Is_Record_Type (Input_Typ) then 23038 Comp := First_Component (Input_Typ); 23039 while Present (Comp) loop 23040 if Needs_Finalization (Etype (Comp)) then 23041 return True; 23042 end if; 23043 23044 Next_Component (Comp); 23045 end loop; 23046 end if; 23047 end if; 23048 23049 return False; 23050 end Has_Some_Controlled_Component; 23051 23052 -- Start of processing for Needs_Finalization 23053 23054 begin 23055 -- Certain run-time configurations and targets do not provide support 23056 -- for controlled types. 23057 23058 if Restriction_Active (No_Finalization) then 23059 return False; 23060 23061 -- C++ types are not considered controlled. It is assumed that the non- 23062 -- Ada side will handle their clean up. 23063 23064 elsif Convention (Typ) = Convention_CPP then 23065 return False; 23066 23067 -- Class-wide types are treated as controlled because derivations from 23068 -- the root type may introduce controlled components. 23069 23070 elsif Is_Class_Wide_Type (Typ) then 23071 return True; 23072 23073 -- Concurrent types are controlled as long as their corresponding record 23074 -- is controlled. 23075 23076 elsif Is_Concurrent_Type (Typ) 23077 and then Present (Corresponding_Record_Type (Typ)) 23078 and then Needs_Finalization (Corresponding_Record_Type (Typ)) 23079 then 23080 return True; 23081 23082 -- Otherwise the type is controlled when it is either derived from type 23083 -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or 23084 -- contains at least one controlled component. 23085 23086 else 23087 return 23088 Is_Controlled (Typ) or else Has_Some_Controlled_Component (Typ); 23089 end if; 23090 end Needs_Finalization; 23091 23092 ---------------------- 23093 -- Needs_One_Actual -- 23094 ---------------------- 23095 23096 function Needs_One_Actual (E : Entity_Id) return Boolean is 23097 Formal : Entity_Id; 23098 23099 begin 23100 -- Ada 2005 or later, and formals present. The first formal must be 23101 -- of a type that supports prefix notation: a controlling argument, 23102 -- a class-wide type, or an access to such. 23103 23104 if Ada_Version >= Ada_2005 23105 and then Present (First_Formal (E)) 23106 and then No (Default_Value (First_Formal (E))) 23107 and then 23108 (Is_Controlling_Formal (First_Formal (E)) 23109 or else Is_Class_Wide_Type (Etype (First_Formal (E))) 23110 or else Is_Anonymous_Access_Type (Etype (First_Formal (E)))) 23111 then 23112 Formal := Next_Formal (First_Formal (E)); 23113 while Present (Formal) loop 23114 if No (Default_Value (Formal)) then 23115 return False; 23116 end if; 23117 23118 Next_Formal (Formal); 23119 end loop; 23120 23121 return True; 23122 23123 -- Ada 83/95 or no formals 23124 23125 else 23126 return False; 23127 end if; 23128 end Needs_One_Actual; 23129 23130 -------------------------------------- 23131 -- Needs_Result_Accessibility_Level -- 23132 -------------------------------------- 23133 23134 function Needs_Result_Accessibility_Level 23135 (Func_Id : Entity_Id) return Boolean 23136 is 23137 Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); 23138 23139 function Has_Unconstrained_Access_Discriminant_Component 23140 (Comp_Typ : Entity_Id) return Boolean; 23141 -- Returns True if any component of the type has an unconstrained access 23142 -- discriminant. 23143 23144 ----------------------------------------------------- 23145 -- Has_Unconstrained_Access_Discriminant_Component -- 23146 ----------------------------------------------------- 23147 23148 function Has_Unconstrained_Access_Discriminant_Component 23149 (Comp_Typ : Entity_Id) return Boolean 23150 is 23151 begin 23152 if not Is_Limited_Type (Comp_Typ) then 23153 return False; 23154 23155 -- Only limited types can have access discriminants with 23156 -- defaults. 23157 23158 elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then 23159 return True; 23160 23161 elsif Is_Array_Type (Comp_Typ) then 23162 return Has_Unconstrained_Access_Discriminant_Component 23163 (Underlying_Type (Component_Type (Comp_Typ))); 23164 23165 elsif Is_Record_Type (Comp_Typ) then 23166 declare 23167 Comp : Entity_Id; 23168 23169 begin 23170 Comp := First_Component (Comp_Typ); 23171 while Present (Comp) loop 23172 if Has_Unconstrained_Access_Discriminant_Component 23173 (Underlying_Type (Etype (Comp))) 23174 then 23175 return True; 23176 end if; 23177 23178 Next_Component (Comp); 23179 end loop; 23180 end; 23181 end if; 23182 23183 return False; 23184 end Has_Unconstrained_Access_Discriminant_Component; 23185 23186 Disable_Coextension_Cases : constant Boolean := True; 23187 -- Flag used to temporarily disable a "True" result for types with 23188 -- access discriminants and related coextension cases. 23189 23190 -- Start of processing for Needs_Result_Accessibility_Level 23191 23192 begin 23193 -- False if completion unavailable (how does this happen???) 23194 23195 if not Present (Func_Typ) then 23196 return False; 23197 23198 -- False if not a function, also handle enum-lit renames case 23199 23200 elsif Func_Typ = Standard_Void_Type 23201 or else Is_Scalar_Type (Func_Typ) 23202 then 23203 return False; 23204 23205 -- Handle a corner case, a cross-dialect subp renaming. For example, 23206 -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when 23207 -- an Ada 2005 (or earlier) unit references predefined run-time units. 23208 23209 elsif Present (Alias (Func_Id)) then 23210 23211 -- Unimplemented: a cross-dialect subp renaming which does not set 23212 -- the Alias attribute (e.g., a rename of a dereference of an access 23213 -- to subprogram value). ??? 23214 23215 return Present (Extra_Accessibility_Of_Result (Alias (Func_Id))); 23216 23217 -- Remaining cases require Ada 2012 mode 23218 23219 elsif Ada_Version < Ada_2012 then 23220 return False; 23221 23222 -- Handle the situation where a result is an anonymous access type 23223 -- RM 3.10.2 (10.3/3). 23224 23225 elsif Ekind (Func_Typ) = E_Anonymous_Access_Type then 23226 return True; 23227 23228 -- The following cases are related to coextensions and do not fully 23229 -- cover everything mentioned in RM 3.10.2 (12) ??? 23230 23231 -- Temporarily disabled ??? 23232 23233 elsif Disable_Coextension_Cases then 23234 return False; 23235 23236 -- In the case of, say, a null tagged record result type, the need for 23237 -- this extra parameter might not be obvious so this function returns 23238 -- True for all tagged types for compatibility reasons. 23239 23240 -- A function with, say, a tagged null controlling result type might 23241 -- be overridden by a primitive of an extension having an access 23242 -- discriminant and the overrider and overridden must have compatible 23243 -- calling conventions (including implicitly declared parameters). 23244 23245 -- Similarly, values of one access-to-subprogram type might designate 23246 -- both a primitive subprogram of a given type and a function which is, 23247 -- for example, not a primitive subprogram of any type. Again, this 23248 -- requires calling convention compatibility. It might be possible to 23249 -- solve these issues by introducing wrappers, but that is not the 23250 -- approach that was chosen. 23251 23252 elsif Is_Tagged_Type (Func_Typ) then 23253 return True; 23254 23255 elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then 23256 return True; 23257 23258 elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then 23259 return True; 23260 23261 -- False for all other cases 23262 23263 else 23264 return False; 23265 end if; 23266 end Needs_Result_Accessibility_Level; 23267 23268 --------------------------------- 23269 -- Needs_Simple_Initialization -- 23270 --------------------------------- 23271 23272 function Needs_Simple_Initialization 23273 (Typ : Entity_Id; 23274 Consider_IS : Boolean := True) return Boolean 23275 is 23276 Consider_IS_NS : constant Boolean := 23277 Normalize_Scalars or (Initialize_Scalars and Consider_IS); 23278 23279 begin 23280 -- Never need initialization if it is suppressed 23281 23282 if Initialization_Suppressed (Typ) then 23283 return False; 23284 end if; 23285 23286 -- Check for private type, in which case test applies to the underlying 23287 -- type of the private type. 23288 23289 if Is_Private_Type (Typ) then 23290 declare 23291 RT : constant Entity_Id := Underlying_Type (Typ); 23292 begin 23293 if Present (RT) then 23294 return Needs_Simple_Initialization (RT); 23295 else 23296 return False; 23297 end if; 23298 end; 23299 23300 -- Scalar type with Default_Value aspect requires initialization 23301 23302 elsif Is_Scalar_Type (Typ) and then Has_Default_Aspect (Typ) then 23303 return True; 23304 23305 -- Cases needing simple initialization are access types, and, if pragma 23306 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar 23307 -- types. 23308 23309 elsif Is_Access_Type (Typ) 23310 or else (Consider_IS_NS and then Is_Scalar_Type (Typ)) 23311 then 23312 return True; 23313 23314 -- If Initialize/Normalize_Scalars is in effect, string objects also 23315 -- need initialization, unless they are created in the course of 23316 -- expanding an aggregate (since in the latter case they will be 23317 -- filled with appropriate initializing values before they are used). 23318 23319 elsif Consider_IS_NS 23320 and then Is_Standard_String_Type (Typ) 23321 and then 23322 (not Is_Itype (Typ) 23323 or else Nkind (Associated_Node_For_Itype (Typ)) /= N_Aggregate) 23324 then 23325 return True; 23326 23327 else 23328 return False; 23329 end if; 23330 end Needs_Simple_Initialization; 23331 23332 ------------------------------------- 23333 -- Needs_Variable_Reference_Marker -- 23334 ------------------------------------- 23335 23336 function Needs_Variable_Reference_Marker 23337 (N : Node_Id; 23338 Calls_OK : Boolean) return Boolean 23339 is 23340 function Within_Suitable_Context (Ref : Node_Id) return Boolean; 23341 -- Deteremine whether variable reference Ref appears within a suitable 23342 -- context that allows the creation of a marker. 23343 23344 ----------------------------- 23345 -- Within_Suitable_Context -- 23346 ----------------------------- 23347 23348 function Within_Suitable_Context (Ref : Node_Id) return Boolean is 23349 Par : Node_Id; 23350 23351 begin 23352 Par := Ref; 23353 while Present (Par) loop 23354 23355 -- The context is not suitable when the reference appears within 23356 -- the formal part of an instantiation which acts as compilation 23357 -- unit because there is no proper list for the insertion of the 23358 -- marker. 23359 23360 if Nkind (Par) = N_Generic_Association 23361 and then Nkind (Parent (Par)) in N_Generic_Instantiation 23362 and then Nkind (Parent (Parent (Par))) = N_Compilation_Unit 23363 then 23364 return False; 23365 23366 -- The context is not suitable when the reference appears within 23367 -- a pragma. If the pragma has run-time semantics, the reference 23368 -- will be reconsidered once the pragma is expanded. 23369 23370 elsif Nkind (Par) = N_Pragma then 23371 return False; 23372 23373 -- The context is not suitable when the reference appears within a 23374 -- subprogram call, and the caller requests this behavior. 23375 23376 elsif not Calls_OK 23377 and then Nkind (Par) in N_Entry_Call_Statement 23378 | N_Function_Call 23379 | N_Procedure_Call_Statement 23380 then 23381 return False; 23382 23383 -- Prevent the search from going too far 23384 23385 elsif Is_Body_Or_Package_Declaration (Par) then 23386 exit; 23387 end if; 23388 23389 Par := Parent (Par); 23390 end loop; 23391 23392 return True; 23393 end Within_Suitable_Context; 23394 23395 -- Local variables 23396 23397 Prag : Node_Id; 23398 Var_Id : Entity_Id; 23399 23400 -- Start of processing for Needs_Variable_Reference_Marker 23401 23402 begin 23403 -- No marker needs to be created when switch -gnatH (legacy elaboration 23404 -- checking mode enabled) is in effect because the legacy ABE mechanism 23405 -- does not use markers. 23406 23407 if Legacy_Elaboration_Checks then 23408 return False; 23409 23410 -- No marker needs to be created when the reference is preanalyzed 23411 -- because the marker will be inserted in the wrong place. 23412 23413 elsif Preanalysis_Active then 23414 return False; 23415 23416 -- Only references warrant a marker 23417 23418 elsif Nkind (N) not in N_Expanded_Name | N_Identifier then 23419 return False; 23420 23421 -- Only source references warrant a marker 23422 23423 elsif not Comes_From_Source (N) then 23424 return False; 23425 23426 -- No marker needs to be created when the reference is erroneous, left 23427 -- in a bad state, or does not denote a variable. 23428 23429 elsif not (Present (Entity (N)) 23430 and then Ekind (Entity (N)) = E_Variable 23431 and then Entity (N) /= Any_Id) 23432 then 23433 return False; 23434 end if; 23435 23436 Var_Id := Entity (N); 23437 Prag := SPARK_Pragma (Var_Id); 23438 23439 -- Both the variable and reference must appear in SPARK_Mode On regions 23440 -- because this elaboration scenario falls under the SPARK rules. 23441 23442 if not (Comes_From_Source (Var_Id) 23443 and then Present (Prag) 23444 and then Get_SPARK_Mode_From_Annotation (Prag) = On 23445 and then Is_SPARK_Mode_On_Node (N)) 23446 then 23447 return False; 23448 23449 -- No marker needs to be created when the reference does not appear 23450 -- within a suitable context (see body for details). 23451 23452 -- Performance note: parent traversal 23453 23454 elsif not Within_Suitable_Context (N) then 23455 return False; 23456 end if; 23457 23458 -- At this point it is known that the variable reference will play a 23459 -- role in ABE diagnostics and requires a marker. 23460 23461 return True; 23462 end Needs_Variable_Reference_Marker; 23463 23464 ------------------------ 23465 -- New_Copy_List_Tree -- 23466 ------------------------ 23467 23468 function New_Copy_List_Tree (List : List_Id) return List_Id is 23469 NL : List_Id; 23470 E : Node_Id; 23471 23472 begin 23473 if List = No_List then 23474 return No_List; 23475 23476 else 23477 NL := New_List; 23478 E := First (List); 23479 23480 while Present (E) loop 23481 Append (New_Copy_Tree (E), NL); 23482 Next (E); 23483 end loop; 23484 23485 return NL; 23486 end if; 23487 end New_Copy_List_Tree; 23488 23489 ---------------------------- 23490 -- New_Copy_Separate_List -- 23491 ---------------------------- 23492 23493 function New_Copy_Separate_List (List : List_Id) return List_Id is 23494 begin 23495 if List = No_List then 23496 return No_List; 23497 23498 else 23499 declare 23500 List_Copy : constant List_Id := New_List; 23501 N : Node_Id := First (List); 23502 23503 begin 23504 while Present (N) loop 23505 Append (New_Copy_Separate_Tree (N), List_Copy); 23506 Next (N); 23507 end loop; 23508 23509 return List_Copy; 23510 end; 23511 end if; 23512 end New_Copy_Separate_List; 23513 23514 ---------------------------- 23515 -- New_Copy_Separate_Tree -- 23516 ---------------------------- 23517 23518 function New_Copy_Separate_Tree (Source : Node_Id) return Node_Id is 23519 function Search_Decl (N : Node_Id) return Traverse_Result; 23520 -- Subtree visitor which collects declarations 23521 23522 procedure Search_Declarations is new Traverse_Proc (Search_Decl); 23523 -- Subtree visitor instantiation 23524 23525 ----------------- 23526 -- Search_Decl -- 23527 ----------------- 23528 23529 Decls : Elist_Id; 23530 23531 function Search_Decl (N : Node_Id) return Traverse_Result is 23532 begin 23533 if Nkind (N) in N_Declaration then 23534 Append_New_Elmt (N, Decls); 23535 end if; 23536 23537 return OK; 23538 end Search_Decl; 23539 23540 -- Local variables 23541 23542 Source_Copy : constant Node_Id := New_Copy_Tree (Source); 23543 23544 -- Start of processing for New_Copy_Separate_Tree 23545 23546 begin 23547 Decls := No_Elist; 23548 Search_Declarations (Source_Copy); 23549 23550 -- Associate a new Entity with all the subtree declarations (keeping 23551 -- their original name). 23552 23553 if Present (Decls) then 23554 declare 23555 Elmt : Elmt_Id; 23556 Decl : Node_Id; 23557 New_E : Entity_Id; 23558 23559 begin 23560 Elmt := First_Elmt (Decls); 23561 while Present (Elmt) loop 23562 Decl := Node (Elmt); 23563 New_E := Make_Defining_Identifier (Sloc (Decl), 23564 New_Internal_Name ('P')); 23565 23566 if Nkind (Decl) = N_Expression_Function then 23567 Decl := Specification (Decl); 23568 end if; 23569 23570 if Nkind (Decl) in N_Function_Instantiation 23571 | N_Function_Specification 23572 | N_Generic_Function_Renaming_Declaration 23573 | N_Generic_Package_Renaming_Declaration 23574 | N_Generic_Procedure_Renaming_Declaration 23575 | N_Package_Body 23576 | N_Package_Instantiation 23577 | N_Package_Renaming_Declaration 23578 | N_Package_Specification 23579 | N_Procedure_Instantiation 23580 | N_Procedure_Specification 23581 then 23582 Set_Chars (New_E, Chars (Defining_Unit_Name (Decl))); 23583 Set_Defining_Unit_Name (Decl, New_E); 23584 else 23585 Set_Chars (New_E, Chars (Defining_Identifier (Decl))); 23586 Set_Defining_Identifier (Decl, New_E); 23587 end if; 23588 23589 Next_Elmt (Elmt); 23590 end loop; 23591 end; 23592 end if; 23593 23594 return Source_Copy; 23595 end New_Copy_Separate_Tree; 23596 23597 ------------------- 23598 -- New_Copy_Tree -- 23599 ------------------- 23600 23601 -- The following tables play a key role in replicating entities and Itypes. 23602 -- They are intentionally declared at the library level rather than within 23603 -- New_Copy_Tree to avoid elaborating them on each call. This performance 23604 -- optimization saves up to 2% of the entire compilation time spent in the 23605 -- front end. Care should be taken to reset the tables on each new call to 23606 -- New_Copy_Tree. 23607 23608 NCT_Table_Max : constant := 511; 23609 23610 subtype NCT_Table_Index is Nat range 0 .. NCT_Table_Max - 1; 23611 23612 function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index; 23613 -- Obtain the hash value of node or entity Key 23614 23615 -------------------- 23616 -- NCT_Table_Hash -- 23617 -------------------- 23618 23619 function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index is 23620 begin 23621 return NCT_Table_Index (Key mod NCT_Table_Max); 23622 end NCT_Table_Hash; 23623 23624 ---------------------- 23625 -- NCT_New_Entities -- 23626 ---------------------- 23627 23628 -- The following table maps old entities and Itypes to their corresponding 23629 -- new entities and Itypes. 23630 23631 -- Aaa -> Xxx 23632 23633 package NCT_New_Entities is new Simple_HTable ( 23634 Header_Num => NCT_Table_Index, 23635 Element => Entity_Id, 23636 No_Element => Empty, 23637 Key => Entity_Id, 23638 Hash => NCT_Table_Hash, 23639 Equal => "="); 23640 23641 ------------------------ 23642 -- NCT_Pending_Itypes -- 23643 ------------------------ 23644 23645 -- The following table maps old Associated_Node_For_Itype nodes to a set of 23646 -- new itypes. Given a set of old Itypes Aaa, Bbb, and Ccc, where all three 23647 -- have the same Associated_Node_For_Itype Ppp, and their corresponding new 23648 -- Itypes Xxx, Yyy, Zzz, the table contains the following mapping: 23649 23650 -- Ppp -> (Xxx, Yyy, Zzz) 23651 23652 -- The set is expressed as an Elist 23653 23654 package NCT_Pending_Itypes is new Simple_HTable ( 23655 Header_Num => NCT_Table_Index, 23656 Element => Elist_Id, 23657 No_Element => No_Elist, 23658 Key => Node_Id, 23659 Hash => NCT_Table_Hash, 23660 Equal => "="); 23661 23662 NCT_Tables_In_Use : Boolean := False; 23663 -- This flag keeps track of whether the two tables NCT_New_Entities and 23664 -- NCT_Pending_Itypes are in use. The flag is part of an optimization 23665 -- where certain operations are not performed if the tables are not in 23666 -- use. This saves up to 8% of the entire compilation time spent in the 23667 -- front end. 23668 23669 ------------------- 23670 -- New_Copy_Tree -- 23671 ------------------- 23672 23673 function New_Copy_Tree 23674 (Source : Node_Id; 23675 Map : Elist_Id := No_Elist; 23676 New_Sloc : Source_Ptr := No_Location; 23677 New_Scope : Entity_Id := Empty; 23678 Scopes_In_EWA_OK : Boolean := False) return Node_Id 23679 is 23680 -- This routine performs low-level tree manipulations and needs access 23681 -- to the internals of the tree. 23682 23683 EWA_Level : Nat := 0; 23684 -- This counter keeps track of how many N_Expression_With_Actions nodes 23685 -- are encountered during a depth-first traversal of the subtree. These 23686 -- nodes may define new entities in their Actions lists and thus require 23687 -- special processing. 23688 23689 EWA_Inner_Scope_Level : Nat := 0; 23690 -- This counter keeps track of how many scoping constructs appear within 23691 -- an N_Expression_With_Actions node. 23692 23693 procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id); 23694 pragma Inline (Add_New_Entity); 23695 -- Add an entry in the NCT_New_Entities table which maps key Old_Id to 23696 -- value New_Id. Old_Id is an entity which appears within the Actions 23697 -- list of an N_Expression_With_Actions node, or within an entity map. 23698 -- New_Id is the corresponding new entity generated during Phase 1. 23699 23700 procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id); 23701 pragma Inline (Add_Pending_Itype); 23702 -- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to 23703 -- value Itype. Assoc_Nod is the associated node of an itype. Itype is 23704 -- an itype. 23705 23706 procedure Build_NCT_Tables (Entity_Map : Elist_Id); 23707 pragma Inline (Build_NCT_Tables); 23708 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with the 23709 -- information supplied in entity map Entity_Map. The format of the 23710 -- entity map must be as follows: 23711 -- 23712 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN 23713 23714 function Copy_Any_Node_With_Replacement 23715 (N : Node_Or_Entity_Id) return Node_Or_Entity_Id; 23716 pragma Inline (Copy_Any_Node_With_Replacement); 23717 -- Replicate entity or node N by invoking one of the following routines: 23718 -- 23719 -- Copy_Node_With_Replacement 23720 -- Corresponding_Entity 23721 23722 function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id; 23723 -- Replicate the elements of entity list List 23724 23725 function Copy_Field_With_Replacement 23726 (Field : Union_Id; 23727 Old_Par : Node_Id := Empty; 23728 New_Par : Node_Id := Empty; 23729 Semantic : Boolean := False) return Union_Id; 23730 -- Replicate field Field by invoking one of the following routines: 23731 -- 23732 -- Copy_Elist_With_Replacement 23733 -- Copy_List_With_Replacement 23734 -- Copy_Node_With_Replacement 23735 -- Corresponding_Entity 23736 -- 23737 -- If the field is not an entity list, entity, itype, syntactic list, 23738 -- or node, then the field is returned unchanged. The routine always 23739 -- replicates entities, itypes, and valid syntactic fields. Old_Par is 23740 -- the expected parent of a syntactic field. New_Par is the new parent 23741 -- associated with a replicated syntactic field. Flag Semantic should 23742 -- be set when the input is a semantic field. 23743 23744 function Copy_List_With_Replacement (List : List_Id) return List_Id; 23745 -- Replicate the elements of syntactic list List 23746 23747 function Copy_Node_With_Replacement (N : Node_Id) return Node_Id; 23748 -- Replicate node N 23749 23750 function Corresponding_Entity (Id : Entity_Id) return Entity_Id; 23751 pragma Inline (Corresponding_Entity); 23752 -- Return the corresponding new entity of Id generated during Phase 1. 23753 -- If there is no such entity, return Id. 23754 23755 function In_Entity_Map 23756 (Id : Entity_Id; 23757 Entity_Map : Elist_Id) return Boolean; 23758 pragma Inline (In_Entity_Map); 23759 -- Determine whether entity Id is one of the old ids specified in entity 23760 -- map Entity_Map. The format of the entity map must be as follows: 23761 -- 23762 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN 23763 23764 procedure Update_CFS_Sloc (N : Node_Or_Entity_Id); 23765 pragma Inline (Update_CFS_Sloc); 23766 -- Update the Comes_From_Source and Sloc attributes of node or entity N 23767 23768 procedure Update_First_Real_Statement 23769 (Old_HSS : Node_Id; 23770 New_HSS : Node_Id); 23771 pragma Inline (Update_First_Real_Statement); 23772 -- Update semantic attribute First_Real_Statement of handled sequence of 23773 -- statements New_HSS based on handled sequence of statements Old_HSS. 23774 23775 procedure Update_Named_Associations 23776 (Old_Call : Node_Id; 23777 New_Call : Node_Id); 23778 pragma Inline (Update_Named_Associations); 23779 -- Update semantic chain First/Next_Named_Association of call New_call 23780 -- based on call Old_Call. 23781 23782 procedure Update_New_Entities (Entity_Map : Elist_Id); 23783 pragma Inline (Update_New_Entities); 23784 -- Update the semantic attributes of all new entities generated during 23785 -- Phase 1 that do not appear in entity map Entity_Map. The format of 23786 -- the entity map must be as follows: 23787 -- 23788 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN 23789 23790 procedure Update_Pending_Itypes 23791 (Old_Assoc : Node_Id; 23792 New_Assoc : Node_Id); 23793 pragma Inline (Update_Pending_Itypes); 23794 -- Update semantic attribute Associated_Node_For_Itype to refer to node 23795 -- New_Assoc for all itypes whose associated node is Old_Assoc. 23796 23797 procedure Update_Semantic_Fields (Id : Entity_Id); 23798 pragma Inline (Update_Semantic_Fields); 23799 -- Subsidiary to Update_New_Entities. Update semantic fields of entity 23800 -- or itype Id. 23801 23802 procedure Visit_Any_Node (N : Node_Or_Entity_Id); 23803 pragma Inline (Visit_Any_Node); 23804 -- Visit entity of node N by invoking one of the following routines: 23805 -- 23806 -- Visit_Entity 23807 -- Visit_Itype 23808 -- Visit_Node 23809 23810 procedure Visit_Elist (List : Elist_Id); 23811 -- Visit the elements of entity list List 23812 23813 procedure Visit_Entity (Id : Entity_Id); 23814 -- Visit entity Id. This action may create a new entity of Id and save 23815 -- it in table NCT_New_Entities. 23816 23817 procedure Visit_Field 23818 (Field : Union_Id; 23819 Par_Nod : Node_Id := Empty; 23820 Semantic : Boolean := False); 23821 -- Visit field Field by invoking one of the following routines: 23822 -- 23823 -- Visit_Elist 23824 -- Visit_Entity 23825 -- Visit_Itype 23826 -- Visit_List 23827 -- Visit_Node 23828 -- 23829 -- If the field is not an entity list, entity, itype, syntactic list, 23830 -- or node, then the field is not visited. The routine always visits 23831 -- valid syntactic fields. Par_Nod is the expected parent of the 23832 -- syntactic field. Flag Semantic should be set when the input is a 23833 -- semantic field. 23834 23835 procedure Visit_Itype (Itype : Entity_Id); 23836 -- Visit itype Itype. This action may create a new entity for Itype and 23837 -- save it in table NCT_New_Entities. In addition, the routine may map 23838 -- the associated node of Itype to the new itype in NCT_Pending_Itypes. 23839 23840 procedure Visit_List (List : List_Id); 23841 -- Visit the elements of syntactic list List 23842 23843 procedure Visit_Node (N : Node_Id); 23844 -- Visit node N 23845 23846 procedure Visit_Semantic_Fields (Id : Entity_Id); 23847 pragma Inline (Visit_Semantic_Fields); 23848 -- Subsidiary to Visit_Entity and Visit_Itype. Visit common semantic 23849 -- fields of entity or itype Id. 23850 23851 -------------------- 23852 -- Add_New_Entity -- 23853 -------------------- 23854 23855 procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id) is 23856 begin 23857 pragma Assert (Present (Old_Id)); 23858 pragma Assert (Present (New_Id)); 23859 pragma Assert (Nkind (Old_Id) in N_Entity); 23860 pragma Assert (Nkind (New_Id) in N_Entity); 23861 23862 NCT_Tables_In_Use := True; 23863 23864 -- Sanity check the NCT_New_Entities table. No previous mapping with 23865 -- key Old_Id should exist. 23866 23867 pragma Assert (No (NCT_New_Entities.Get (Old_Id))); 23868 23869 -- Establish the mapping 23870 23871 -- Old_Id -> New_Id 23872 23873 NCT_New_Entities.Set (Old_Id, New_Id); 23874 end Add_New_Entity; 23875 23876 ----------------------- 23877 -- Add_Pending_Itype -- 23878 ----------------------- 23879 23880 procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id) is 23881 Itypes : Elist_Id; 23882 23883 begin 23884 pragma Assert (Present (Assoc_Nod)); 23885 pragma Assert (Present (Itype)); 23886 pragma Assert (Nkind (Itype) in N_Entity); 23887 pragma Assert (Is_Itype (Itype)); 23888 23889 NCT_Tables_In_Use := True; 23890 23891 -- It is not possible to sanity check the NCT_Pendint_Itypes table 23892 -- directly because a single node may act as the associated node for 23893 -- multiple itypes. 23894 23895 Itypes := NCT_Pending_Itypes.Get (Assoc_Nod); 23896 23897 if No (Itypes) then 23898 Itypes := New_Elmt_List; 23899 NCT_Pending_Itypes.Set (Assoc_Nod, Itypes); 23900 end if; 23901 23902 -- Establish the mapping 23903 23904 -- Assoc_Nod -> (Itype, ...) 23905 23906 -- Avoid inserting the same itype multiple times. This involves a 23907 -- linear search, however the set of itypes with the same associated 23908 -- node is very small. 23909 23910 Append_Unique_Elmt (Itype, Itypes); 23911 end Add_Pending_Itype; 23912 23913 ---------------------- 23914 -- Build_NCT_Tables -- 23915 ---------------------- 23916 23917 procedure Build_NCT_Tables (Entity_Map : Elist_Id) is 23918 Elmt : Elmt_Id; 23919 Old_Id : Entity_Id; 23920 New_Id : Entity_Id; 23921 23922 begin 23923 -- Nothing to do when there is no entity map 23924 23925 if No (Entity_Map) then 23926 return; 23927 end if; 23928 23929 Elmt := First_Elmt (Entity_Map); 23930 while Present (Elmt) loop 23931 23932 -- Extract the (Old_Id, New_Id) pair from the entity map 23933 23934 Old_Id := Node (Elmt); 23935 Next_Elmt (Elmt); 23936 23937 New_Id := Node (Elmt); 23938 Next_Elmt (Elmt); 23939 23940 -- Establish the following mapping within table NCT_New_Entities 23941 23942 -- Old_Id -> New_Id 23943 23944 Add_New_Entity (Old_Id, New_Id); 23945 23946 -- Establish the following mapping within table NCT_Pending_Itypes 23947 -- when the new entity is an itype. 23948 23949 -- Assoc_Nod -> (New_Id, ...) 23950 23951 -- IMPORTANT: the associated node is that of the old itype because 23952 -- the node will be replicated in Phase 2. 23953 23954 if Is_Itype (Old_Id) then 23955 Add_Pending_Itype 23956 (Assoc_Nod => Associated_Node_For_Itype (Old_Id), 23957 Itype => New_Id); 23958 end if; 23959 end loop; 23960 end Build_NCT_Tables; 23961 23962 ------------------------------------ 23963 -- Copy_Any_Node_With_Replacement -- 23964 ------------------------------------ 23965 23966 function Copy_Any_Node_With_Replacement 23967 (N : Node_Or_Entity_Id) return Node_Or_Entity_Id 23968 is 23969 begin 23970 if Nkind (N) in N_Entity then 23971 return Corresponding_Entity (N); 23972 else 23973 return Copy_Node_With_Replacement (N); 23974 end if; 23975 end Copy_Any_Node_With_Replacement; 23976 23977 --------------------------------- 23978 -- Copy_Elist_With_Replacement -- 23979 --------------------------------- 23980 23981 function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id is 23982 Elmt : Elmt_Id; 23983 Result : Elist_Id; 23984 23985 begin 23986 -- Copy the contents of the old list. Note that the list itself may 23987 -- be empty, in which case the routine returns a new empty list. This 23988 -- avoids sharing lists between subtrees. The element of an entity 23989 -- list could be an entity or a node, hence the invocation of routine 23990 -- Copy_Any_Node_With_Replacement. 23991 23992 if Present (List) then 23993 Result := New_Elmt_List; 23994 23995 Elmt := First_Elmt (List); 23996 while Present (Elmt) loop 23997 Append_Elmt 23998 (Copy_Any_Node_With_Replacement (Node (Elmt)), Result); 23999 24000 Next_Elmt (Elmt); 24001 end loop; 24002 24003 -- Otherwise the list does not exist 24004 24005 else 24006 Result := No_Elist; 24007 end if; 24008 24009 return Result; 24010 end Copy_Elist_With_Replacement; 24011 24012 --------------------------------- 24013 -- Copy_Field_With_Replacement -- 24014 --------------------------------- 24015 24016 function Copy_Field_With_Replacement 24017 (Field : Union_Id; 24018 Old_Par : Node_Id := Empty; 24019 New_Par : Node_Id := Empty; 24020 Semantic : Boolean := False) return Union_Id 24021 is 24022 function Has_More_Ids (N : Node_Id) return Boolean; 24023 -- Return True when N has attribute More_Ids set to True 24024 24025 function Is_Syntactic_Node return Boolean; 24026 -- Return True when Field is a syntactic node 24027 24028 ------------------ 24029 -- Has_More_Ids -- 24030 ------------------ 24031 24032 function Has_More_Ids (N : Node_Id) return Boolean is 24033 begin 24034 if Nkind (N) in N_Component_Declaration 24035 | N_Discriminant_Specification 24036 | N_Exception_Declaration 24037 | N_Formal_Object_Declaration 24038 | N_Number_Declaration 24039 | N_Object_Declaration 24040 | N_Parameter_Specification 24041 | N_Use_Package_Clause 24042 | N_Use_Type_Clause 24043 then 24044 return More_Ids (N); 24045 else 24046 return False; 24047 end if; 24048 end Has_More_Ids; 24049 24050 ----------------------- 24051 -- Is_Syntactic_Node -- 24052 ----------------------- 24053 24054 function Is_Syntactic_Node return Boolean is 24055 Old_N : constant Node_Id := Node_Id (Field); 24056 24057 begin 24058 if Parent (Old_N) = Old_Par then 24059 return True; 24060 24061 elsif not Has_More_Ids (Old_Par) then 24062 return False; 24063 24064 -- Perform the check using the last last id in the syntactic chain 24065 24066 else 24067 declare 24068 N : Node_Id := Old_Par; 24069 24070 begin 24071 while Present (N) and then More_Ids (N) loop 24072 Next (N); 24073 end loop; 24074 24075 pragma Assert (Prev_Ids (N)); 24076 return Parent (Old_N) = N; 24077 end; 24078 end if; 24079 end Is_Syntactic_Node; 24080 24081 begin 24082 -- The field is empty 24083 24084 if Field = Union_Id (Empty) then 24085 return Field; 24086 24087 -- The field is an entity/itype/node 24088 24089 elsif Field in Node_Range then 24090 declare 24091 Old_N : constant Node_Id := Node_Id (Field); 24092 Syntactic : constant Boolean := Is_Syntactic_Node; 24093 24094 New_N : Node_Id; 24095 24096 begin 24097 -- The field is an entity/itype 24098 24099 if Nkind (Old_N) in N_Entity then 24100 24101 -- An entity/itype is always replicated 24102 24103 New_N := Corresponding_Entity (Old_N); 24104 24105 -- Update the parent pointer when the entity is a syntactic 24106 -- field. Note that itypes do not have parent pointers. 24107 24108 if Syntactic and then New_N /= Old_N then 24109 Set_Parent (New_N, New_Par); 24110 end if; 24111 24112 -- The field is a node 24113 24114 else 24115 -- A node is replicated when it is either a syntactic field 24116 -- or when the caller treats it as a semantic attribute. 24117 24118 if Syntactic or else Semantic then 24119 New_N := Copy_Node_With_Replacement (Old_N); 24120 24121 -- Update the parent pointer when the node is a syntactic 24122 -- field. 24123 24124 if Syntactic and then New_N /= Old_N then 24125 Set_Parent (New_N, New_Par); 24126 end if; 24127 24128 -- Otherwise the node is returned unchanged 24129 24130 else 24131 New_N := Old_N; 24132 end if; 24133 end if; 24134 24135 return Union_Id (New_N); 24136 end; 24137 24138 -- The field is an entity list 24139 24140 elsif Field in Elist_Range then 24141 return Union_Id (Copy_Elist_With_Replacement (Elist_Id (Field))); 24142 24143 -- The field is a syntactic list 24144 24145 elsif Field in List_Range then 24146 declare 24147 Old_List : constant List_Id := List_Id (Field); 24148 Syntactic : constant Boolean := Parent (Old_List) = Old_Par; 24149 24150 New_List : List_Id; 24151 24152 begin 24153 -- A list is replicated when it is either a syntactic field or 24154 -- when the caller treats it as a semantic attribute. 24155 24156 if Syntactic or else Semantic then 24157 New_List := Copy_List_With_Replacement (Old_List); 24158 24159 -- Update the parent pointer when the list is a syntactic 24160 -- field. 24161 24162 if Syntactic and then New_List /= Old_List then 24163 Set_Parent (New_List, New_Par); 24164 end if; 24165 24166 -- Otherwise the list is returned unchanged 24167 24168 else 24169 New_List := Old_List; 24170 end if; 24171 24172 return Union_Id (New_List); 24173 end; 24174 24175 -- Otherwise the field denotes an attribute that does not need to be 24176 -- replicated (Chars, literals, etc). 24177 24178 else 24179 return Field; 24180 end if; 24181 end Copy_Field_With_Replacement; 24182 24183 -------------------------------- 24184 -- Copy_List_With_Replacement -- 24185 -------------------------------- 24186 24187 function Copy_List_With_Replacement (List : List_Id) return List_Id is 24188 Elmt : Node_Id; 24189 Result : List_Id; 24190 24191 begin 24192 -- Copy the contents of the old list. Note that the list itself may 24193 -- be empty, in which case the routine returns a new empty list. This 24194 -- avoids sharing lists between subtrees. The element of a syntactic 24195 -- list is always a node, never an entity or itype, hence the call to 24196 -- routine Copy_Node_With_Replacement. 24197 24198 if Present (List) then 24199 Result := New_List; 24200 24201 Elmt := First (List); 24202 while Present (Elmt) loop 24203 Append (Copy_Node_With_Replacement (Elmt), Result); 24204 24205 Next (Elmt); 24206 end loop; 24207 24208 -- Otherwise the list does not exist 24209 24210 else 24211 Result := No_List; 24212 end if; 24213 24214 return Result; 24215 end Copy_List_With_Replacement; 24216 24217 -------------------------------- 24218 -- Copy_Node_With_Replacement -- 24219 -------------------------------- 24220 24221 function Copy_Node_With_Replacement (N : Node_Id) return Node_Id is 24222 Result : Node_Id; 24223 24224 function Transform (U : Union_Id) return Union_Id; 24225 -- Copies one field, replacing N with Result 24226 24227 --------------- 24228 -- Transform -- 24229 --------------- 24230 24231 function Transform (U : Union_Id) return Union_Id is 24232 begin 24233 return Copy_Field_With_Replacement 24234 (Field => U, 24235 Old_Par => N, 24236 New_Par => Result); 24237 end Transform; 24238 24239 procedure Walk is new Walk_Sinfo_Fields_Pairwise (Transform); 24240 24241 -- Start of processing for Copy_Node_With_Replacement 24242 24243 begin 24244 -- Assume that the node must be returned unchanged 24245 24246 Result := N; 24247 24248 if N > Empty_Or_Error then 24249 pragma Assert (Nkind (N) not in N_Entity); 24250 24251 Result := New_Copy (N); 24252 24253 Walk (Result, Result); 24254 24255 -- Update the Comes_From_Source and Sloc attributes of the node 24256 -- in case the caller has supplied new values. 24257 24258 Update_CFS_Sloc (Result); 24259 24260 -- Update the Associated_Node_For_Itype attribute of all itypes 24261 -- created during Phase 1 whose associated node is N. As a result 24262 -- the Associated_Node_For_Itype refers to the replicated node. 24263 -- No action needs to be taken when the Associated_Node_For_Itype 24264 -- refers to an entity because this was already handled during 24265 -- Phase 1, in Visit_Itype. 24266 24267 Update_Pending_Itypes 24268 (Old_Assoc => N, 24269 New_Assoc => Result); 24270 24271 -- Update the First/Next_Named_Association chain for a replicated 24272 -- call. 24273 24274 if Nkind (N) in N_Entry_Call_Statement 24275 | N_Function_Call 24276 | N_Procedure_Call_Statement 24277 then 24278 Update_Named_Associations 24279 (Old_Call => N, 24280 New_Call => Result); 24281 24282 -- Update the Renamed_Object attribute of a replicated object 24283 -- declaration. 24284 24285 elsif Nkind (N) = N_Object_Renaming_Declaration then 24286 Set_Renamed_Object_Of_Possibly_Void 24287 (Defining_Entity (Result), Name (Result)); 24288 24289 -- Update the First_Real_Statement attribute of a replicated 24290 -- handled sequence of statements. 24291 24292 elsif Nkind (N) = N_Handled_Sequence_Of_Statements then 24293 Update_First_Real_Statement 24294 (Old_HSS => N, 24295 New_HSS => Result); 24296 24297 -- Update the Chars attribute of identifiers 24298 24299 elsif Nkind (N) = N_Identifier then 24300 24301 -- The Entity field of identifiers that denote aspects is used 24302 -- to store arbitrary expressions (and hence we must check that 24303 -- they reference an actual entity before copying their Chars 24304 -- value). 24305 24306 if Present (Entity (Result)) 24307 and then Nkind (Entity (Result)) in N_Entity 24308 then 24309 Set_Chars (Result, Chars (Entity (Result))); 24310 end if; 24311 end if; 24312 24313 if Has_Aspects (N) then 24314 Set_Aspect_Specifications (Result, 24315 Copy_List_With_Replacement (Aspect_Specifications (N))); 24316 end if; 24317 end if; 24318 24319 return Result; 24320 end Copy_Node_With_Replacement; 24321 24322 -------------------------- 24323 -- Corresponding_Entity -- 24324 -------------------------- 24325 24326 function Corresponding_Entity (Id : Entity_Id) return Entity_Id is 24327 New_Id : Entity_Id; 24328 Result : Entity_Id; 24329 24330 begin 24331 -- Assume that the entity must be returned unchanged 24332 24333 Result := Id; 24334 24335 if Id > Empty_Or_Error then 24336 pragma Assert (Nkind (Id) in N_Entity); 24337 24338 -- Determine whether the entity has a corresponding new entity 24339 -- generated during Phase 1 and if it does, use it. 24340 24341 if NCT_Tables_In_Use then 24342 New_Id := NCT_New_Entities.Get (Id); 24343 24344 if Present (New_Id) then 24345 Result := New_Id; 24346 end if; 24347 end if; 24348 end if; 24349 24350 return Result; 24351 end Corresponding_Entity; 24352 24353 ------------------- 24354 -- In_Entity_Map -- 24355 ------------------- 24356 24357 function In_Entity_Map 24358 (Id : Entity_Id; 24359 Entity_Map : Elist_Id) return Boolean 24360 is 24361 Elmt : Elmt_Id; 24362 Old_Id : Entity_Id; 24363 24364 begin 24365 -- The entity map contains pairs (Old_Id, New_Id). The advancement 24366 -- step always skips the New_Id portion of the pair. 24367 24368 if Present (Entity_Map) then 24369 Elmt := First_Elmt (Entity_Map); 24370 while Present (Elmt) loop 24371 Old_Id := Node (Elmt); 24372 24373 if Old_Id = Id then 24374 return True; 24375 end if; 24376 24377 Next_Elmt (Elmt); 24378 Next_Elmt (Elmt); 24379 end loop; 24380 end if; 24381 24382 return False; 24383 end In_Entity_Map; 24384 24385 --------------------- 24386 -- Update_CFS_Sloc -- 24387 --------------------- 24388 24389 procedure Update_CFS_Sloc (N : Node_Or_Entity_Id) is 24390 begin 24391 -- A new source location defaults the Comes_From_Source attribute 24392 24393 if New_Sloc /= No_Location then 24394 Set_Comes_From_Source (N, Get_Comes_From_Source_Default); 24395 Set_Sloc (N, New_Sloc); 24396 end if; 24397 end Update_CFS_Sloc; 24398 24399 --------------------------------- 24400 -- Update_First_Real_Statement -- 24401 --------------------------------- 24402 24403 procedure Update_First_Real_Statement 24404 (Old_HSS : Node_Id; 24405 New_HSS : Node_Id) 24406 is 24407 Old_First_Stmt : constant Node_Id := First_Real_Statement (Old_HSS); 24408 24409 New_Stmt : Node_Id; 24410 Old_Stmt : Node_Id; 24411 24412 begin 24413 -- Recreate the First_Real_Statement attribute of a handled sequence 24414 -- of statements by traversing the statement lists of both sequences 24415 -- in parallel. 24416 24417 if Present (Old_First_Stmt) then 24418 New_Stmt := First (Statements (New_HSS)); 24419 Old_Stmt := First (Statements (Old_HSS)); 24420 while Present (Old_Stmt) and then Old_Stmt /= Old_First_Stmt loop 24421 Next (New_Stmt); 24422 Next (Old_Stmt); 24423 end loop; 24424 24425 pragma Assert (Present (New_Stmt)); 24426 pragma Assert (Present (Old_Stmt)); 24427 24428 Set_First_Real_Statement (New_HSS, New_Stmt); 24429 end if; 24430 end Update_First_Real_Statement; 24431 24432 ------------------------------- 24433 -- Update_Named_Associations -- 24434 ------------------------------- 24435 24436 procedure Update_Named_Associations 24437 (Old_Call : Node_Id; 24438 New_Call : Node_Id) 24439 is 24440 New_Act : Node_Id; 24441 New_Next : Node_Id; 24442 Old_Act : Node_Id; 24443 Old_Next : Node_Id; 24444 24445 begin 24446 if No (First_Named_Actual (Old_Call)) then 24447 return; 24448 end if; 24449 24450 -- Recreate the First/Next_Named_Actual chain of a call by traversing 24451 -- the chains of both the old and new calls in parallel. 24452 24453 New_Act := First (Parameter_Associations (New_Call)); 24454 Old_Act := First (Parameter_Associations (Old_Call)); 24455 while Present (Old_Act) loop 24456 if Nkind (Old_Act) = N_Parameter_Association 24457 and then Explicit_Actual_Parameter (Old_Act) 24458 = First_Named_Actual (Old_Call) 24459 then 24460 Set_First_Named_Actual (New_Call, 24461 Explicit_Actual_Parameter (New_Act)); 24462 end if; 24463 24464 if Nkind (Old_Act) = N_Parameter_Association 24465 and then Present (Next_Named_Actual (Old_Act)) 24466 then 24467 -- Scan the actual parameter list to find the next suitable 24468 -- named actual. Note that the list may be out of order. 24469 24470 New_Next := First (Parameter_Associations (New_Call)); 24471 Old_Next := First (Parameter_Associations (Old_Call)); 24472 while Nkind (Old_Next) /= N_Parameter_Association 24473 or else Explicit_Actual_Parameter (Old_Next) /= 24474 Next_Named_Actual (Old_Act) 24475 loop 24476 Next (New_Next); 24477 Next (Old_Next); 24478 end loop; 24479 24480 Set_Next_Named_Actual (New_Act, 24481 Explicit_Actual_Parameter (New_Next)); 24482 end if; 24483 24484 Next (New_Act); 24485 Next (Old_Act); 24486 end loop; 24487 end Update_Named_Associations; 24488 24489 ------------------------- 24490 -- Update_New_Entities -- 24491 ------------------------- 24492 24493 procedure Update_New_Entities (Entity_Map : Elist_Id) is 24494 New_Id : Entity_Id := Empty; 24495 Old_Id : Entity_Id := Empty; 24496 24497 begin 24498 if NCT_Tables_In_Use then 24499 NCT_New_Entities.Get_First (Old_Id, New_Id); 24500 24501 -- Update the semantic fields of all new entities created during 24502 -- Phase 1 which were not supplied via an entity map. 24503 -- ??? Is there a better way of distinguishing those? 24504 24505 while Present (Old_Id) and then Present (New_Id) loop 24506 if not (Present (Entity_Map) 24507 and then In_Entity_Map (Old_Id, Entity_Map)) 24508 then 24509 Update_Semantic_Fields (New_Id); 24510 end if; 24511 24512 NCT_New_Entities.Get_Next (Old_Id, New_Id); 24513 end loop; 24514 end if; 24515 end Update_New_Entities; 24516 24517 --------------------------- 24518 -- Update_Pending_Itypes -- 24519 --------------------------- 24520 24521 procedure Update_Pending_Itypes 24522 (Old_Assoc : Node_Id; 24523 New_Assoc : Node_Id) 24524 is 24525 Item : Elmt_Id; 24526 Itypes : Elist_Id; 24527 24528 begin 24529 if NCT_Tables_In_Use then 24530 Itypes := NCT_Pending_Itypes.Get (Old_Assoc); 24531 24532 -- Update the Associated_Node_For_Itype attribute for all itypes 24533 -- which originally refer to Old_Assoc to designate New_Assoc. 24534 24535 if Present (Itypes) then 24536 Item := First_Elmt (Itypes); 24537 while Present (Item) loop 24538 Set_Associated_Node_For_Itype (Node (Item), New_Assoc); 24539 24540 Next_Elmt (Item); 24541 end loop; 24542 end if; 24543 end if; 24544 end Update_Pending_Itypes; 24545 24546 ---------------------------- 24547 -- Update_Semantic_Fields -- 24548 ---------------------------- 24549 24550 procedure Update_Semantic_Fields (Id : Entity_Id) is 24551 begin 24552 -- Discriminant_Constraint 24553 24554 if Is_Type (Id) and then Has_Discriminants (Base_Type (Id)) then 24555 Set_Discriminant_Constraint (Id, Elist_Id ( 24556 Copy_Field_With_Replacement 24557 (Field => Union_Id (Discriminant_Constraint (Id)), 24558 Semantic => True))); 24559 end if; 24560 24561 -- Etype 24562 24563 Set_Etype (Id, Node_Id ( 24564 Copy_Field_With_Replacement 24565 (Field => Union_Id (Etype (Id)), 24566 Semantic => True))); 24567 24568 -- First_Index 24569 -- Packed_Array_Impl_Type 24570 24571 if Is_Array_Type (Id) then 24572 if Present (First_Index (Id)) then 24573 Set_First_Index (Id, First (List_Id ( 24574 Copy_Field_With_Replacement 24575 (Field => Union_Id (List_Containing (First_Index (Id))), 24576 Semantic => True)))); 24577 end if; 24578 24579 if Is_Packed (Id) then 24580 Set_Packed_Array_Impl_Type (Id, Node_Id ( 24581 Copy_Field_With_Replacement 24582 (Field => Union_Id (Packed_Array_Impl_Type (Id)), 24583 Semantic => True))); 24584 end if; 24585 end if; 24586 24587 -- Prev_Entity 24588 24589 Set_Prev_Entity (Id, Node_Id ( 24590 Copy_Field_With_Replacement 24591 (Field => Union_Id (Prev_Entity (Id)), 24592 Semantic => True))); 24593 24594 -- Next_Entity 24595 24596 Set_Next_Entity (Id, Node_Id ( 24597 Copy_Field_With_Replacement 24598 (Field => Union_Id (Next_Entity (Id)), 24599 Semantic => True))); 24600 24601 -- Scalar_Range 24602 24603 if Is_Discrete_Type (Id) then 24604 Set_Scalar_Range (Id, Node_Id ( 24605 Copy_Field_With_Replacement 24606 (Field => Union_Id (Scalar_Range (Id)), 24607 Semantic => True))); 24608 end if; 24609 24610 -- Scope 24611 24612 -- Update the scope when the caller specified an explicit one 24613 24614 if Present (New_Scope) then 24615 Set_Scope (Id, New_Scope); 24616 else 24617 Set_Scope (Id, Node_Id ( 24618 Copy_Field_With_Replacement 24619 (Field => Union_Id (Scope (Id)), 24620 Semantic => True))); 24621 end if; 24622 end Update_Semantic_Fields; 24623 24624 -------------------- 24625 -- Visit_Any_Node -- 24626 -------------------- 24627 24628 procedure Visit_Any_Node (N : Node_Or_Entity_Id) is 24629 begin 24630 if Nkind (N) in N_Entity then 24631 if Is_Itype (N) then 24632 Visit_Itype (N); 24633 else 24634 Visit_Entity (N); 24635 end if; 24636 else 24637 Visit_Node (N); 24638 end if; 24639 end Visit_Any_Node; 24640 24641 ----------------- 24642 -- Visit_Elist -- 24643 ----------------- 24644 24645 procedure Visit_Elist (List : Elist_Id) is 24646 Elmt : Elmt_Id; 24647 24648 begin 24649 -- The element of an entity list could be an entity, itype, or a 24650 -- node, hence the call to Visit_Any_Node. 24651 24652 if Present (List) then 24653 Elmt := First_Elmt (List); 24654 while Present (Elmt) loop 24655 Visit_Any_Node (Node (Elmt)); 24656 24657 Next_Elmt (Elmt); 24658 end loop; 24659 end if; 24660 end Visit_Elist; 24661 24662 ------------------ 24663 -- Visit_Entity -- 24664 ------------------ 24665 24666 procedure Visit_Entity (Id : Entity_Id) is 24667 New_Id : Entity_Id; 24668 24669 begin 24670 pragma Assert (Nkind (Id) in N_Entity); 24671 pragma Assert (not Is_Itype (Id)); 24672 24673 -- Nothing to do when the entity is not defined in the Actions list 24674 -- of an N_Expression_With_Actions node. 24675 24676 if EWA_Level = 0 then 24677 return; 24678 24679 -- Nothing to do when the entity is defined in a scoping construct 24680 -- within an N_Expression_With_Actions node, unless the caller has 24681 -- requested their replication. 24682 24683 -- ??? should this restriction be eliminated? 24684 24685 elsif EWA_Inner_Scope_Level > 0 and then not Scopes_In_EWA_OK then 24686 return; 24687 24688 -- Nothing to do when the entity does not denote a construct that 24689 -- may appear within an N_Expression_With_Actions node. Relaxing 24690 -- this restriction leads to a performance penalty. 24691 24692 -- ??? this list is flaky, and may hide dormant bugs 24693 -- Should functions be included??? 24694 24695 -- Loop parameters appear within quantified expressions and contain 24696 -- an entity declaration that must be replaced when the expander is 24697 -- active if the expression has been preanalyzed or analyzed. 24698 24699 elsif Ekind (Id) not in 24700 E_Block | E_Constant | E_Label | E_Loop_Parameter | 24701 E_Procedure | E_Variable 24702 and then not Is_Type (Id) 24703 then 24704 return; 24705 24706 elsif Ekind (Id) = E_Loop_Parameter 24707 and then No (Etype (Condition (Parent (Parent (Id))))) 24708 then 24709 return; 24710 24711 -- Nothing to do when the entity was already visited 24712 24713 elsif NCT_Tables_In_Use 24714 and then Present (NCT_New_Entities.Get (Id)) 24715 then 24716 return; 24717 24718 -- Nothing to do when the declaration node of the entity is not in 24719 -- the subtree being replicated. 24720 24721 elsif not In_Subtree 24722 (N => Declaration_Node (Id), 24723 Root => Source) 24724 then 24725 return; 24726 end if; 24727 24728 -- Create a new entity by directly copying the old entity. This 24729 -- action causes all attributes of the old entity to be inherited. 24730 24731 New_Id := New_Copy (Id); 24732 24733 -- Create a new name for the new entity because the back end needs 24734 -- distinct names for debugging purposes. 24735 24736 Set_Chars (New_Id, New_Internal_Name ('T')); 24737 24738 -- Update the Comes_From_Source and Sloc attributes of the entity in 24739 -- case the caller has supplied new values. 24740 24741 Update_CFS_Sloc (New_Id); 24742 24743 -- Establish the following mapping within table NCT_New_Entities: 24744 24745 -- Id -> New_Id 24746 24747 Add_New_Entity (Id, New_Id); 24748 24749 -- Deal with the semantic fields of entities. The fields are visited 24750 -- because they may mention entities which reside within the subtree 24751 -- being copied. 24752 24753 Visit_Semantic_Fields (Id); 24754 end Visit_Entity; 24755 24756 ----------------- 24757 -- Visit_Field -- 24758 ----------------- 24759 24760 procedure Visit_Field 24761 (Field : Union_Id; 24762 Par_Nod : Node_Id := Empty; 24763 Semantic : Boolean := False) 24764 is 24765 begin 24766 -- The field is empty 24767 24768 if Field = Union_Id (Empty) then 24769 return; 24770 24771 -- The field is an entity/itype/node 24772 24773 elsif Field in Node_Range then 24774 declare 24775 N : constant Node_Id := Node_Id (Field); 24776 24777 begin 24778 -- The field is an entity/itype 24779 24780 if Nkind (N) in N_Entity then 24781 24782 -- Itypes are always visited 24783 24784 if Is_Itype (N) then 24785 Visit_Itype (N); 24786 24787 -- An entity is visited when it is either a syntactic field 24788 -- or when the caller treats it as a semantic attribute. 24789 24790 elsif Parent (N) = Par_Nod or else Semantic then 24791 Visit_Entity (N); 24792 end if; 24793 24794 -- The field is a node 24795 24796 else 24797 -- A node is visited when it is either a syntactic field or 24798 -- when the caller treats it as a semantic attribute. 24799 24800 if Parent (N) = Par_Nod or else Semantic then 24801 Visit_Node (N); 24802 end if; 24803 end if; 24804 end; 24805 24806 -- The field is an entity list 24807 24808 elsif Field in Elist_Range then 24809 Visit_Elist (Elist_Id (Field)); 24810 24811 -- The field is a syntax list 24812 24813 elsif Field in List_Range then 24814 declare 24815 List : constant List_Id := List_Id (Field); 24816 24817 begin 24818 -- A syntax list is visited when it is either a syntactic field 24819 -- or when the caller treats it as a semantic attribute. 24820 24821 if Parent (List) = Par_Nod or else Semantic then 24822 Visit_List (List); 24823 end if; 24824 end; 24825 24826 -- Otherwise the field denotes information which does not need to be 24827 -- visited (chars, literals, etc.). 24828 24829 else 24830 null; 24831 end if; 24832 end Visit_Field; 24833 24834 ----------------- 24835 -- Visit_Itype -- 24836 ----------------- 24837 24838 procedure Visit_Itype (Itype : Entity_Id) is 24839 New_Assoc : Node_Id; 24840 New_Itype : Entity_Id; 24841 Old_Assoc : Node_Id; 24842 24843 begin 24844 pragma Assert (Nkind (Itype) in N_Entity); 24845 pragma Assert (Is_Itype (Itype)); 24846 24847 -- Itypes that describe the designated type of access to subprograms 24848 -- have the structure of subprogram declarations, with signatures, 24849 -- etc. Either we duplicate the signatures completely, or choose to 24850 -- share such itypes, which is fine because their elaboration will 24851 -- have no side effects. 24852 24853 if Ekind (Itype) = E_Subprogram_Type then 24854 return; 24855 24856 -- Nothing to do if the itype was already visited 24857 24858 elsif NCT_Tables_In_Use 24859 and then Present (NCT_New_Entities.Get (Itype)) 24860 then 24861 return; 24862 24863 -- Nothing to do if the associated node of the itype is not within 24864 -- the subtree being replicated. 24865 24866 elsif not In_Subtree 24867 (N => Associated_Node_For_Itype (Itype), 24868 Root => Source) 24869 then 24870 return; 24871 end if; 24872 24873 -- Create a new itype by directly copying the old itype. This action 24874 -- causes all attributes of the old itype to be inherited. 24875 24876 New_Itype := New_Copy (Itype); 24877 24878 -- Create a new name for the new itype because the back end requires 24879 -- distinct names for debugging purposes. 24880 24881 Set_Chars (New_Itype, New_Internal_Name ('T')); 24882 24883 -- Update the Comes_From_Source and Sloc attributes of the itype in 24884 -- case the caller has supplied new values. 24885 24886 Update_CFS_Sloc (New_Itype); 24887 24888 -- Establish the following mapping within table NCT_New_Entities: 24889 24890 -- Itype -> New_Itype 24891 24892 Add_New_Entity (Itype, New_Itype); 24893 24894 -- The new itype must be unfrozen because the resulting subtree may 24895 -- be inserted anywhere and cause an earlier or later freezing. 24896 24897 if Present (Freeze_Node (New_Itype)) then 24898 Set_Freeze_Node (New_Itype, Empty); 24899 Set_Is_Frozen (New_Itype, False); 24900 end if; 24901 24902 -- If a record subtype is simply copied, the entity list will be 24903 -- shared. Thus cloned_Subtype must be set to indicate the sharing. 24904 -- ??? What does this do? 24905 24906 if Ekind (Itype) in E_Class_Wide_Subtype | E_Record_Subtype then 24907 Set_Cloned_Subtype (New_Itype, Itype); 24908 end if; 24909 24910 -- The associated node may denote an entity, in which case it may 24911 -- already have a new corresponding entity created during a prior 24912 -- call to Visit_Entity or Visit_Itype for the same subtree. 24913 24914 -- Given 24915 -- Old_Assoc ---------> New_Assoc 24916 24917 -- Created by Visit_Itype 24918 -- Itype -------------> New_Itype 24919 -- ANFI = Old_Assoc ANFI = Old_Assoc < must be updated 24920 24921 -- In the example above, Old_Assoc is an arbitrary entity that was 24922 -- already visited for the same subtree and has a corresponding new 24923 -- entity New_Assoc. Old_Assoc was inherited by New_Itype by virtue 24924 -- of copying entities, however it must be updated to New_Assoc. 24925 24926 Old_Assoc := Associated_Node_For_Itype (Itype); 24927 24928 if Nkind (Old_Assoc) in N_Entity then 24929 if NCT_Tables_In_Use then 24930 New_Assoc := NCT_New_Entities.Get (Old_Assoc); 24931 24932 if Present (New_Assoc) then 24933 Set_Associated_Node_For_Itype (New_Itype, New_Assoc); 24934 end if; 24935 end if; 24936 24937 -- Otherwise the associated node denotes a node. Postpone the update 24938 -- until Phase 2 when the node is replicated. Establish the following 24939 -- mapping within table NCT_Pending_Itypes: 24940 24941 -- Old_Assoc -> (New_Type, ...) 24942 24943 else 24944 Add_Pending_Itype (Old_Assoc, New_Itype); 24945 end if; 24946 24947 -- Deal with the semantic fields of itypes. The fields are visited 24948 -- because they may mention entities that reside within the subtree 24949 -- being copied. 24950 24951 Visit_Semantic_Fields (Itype); 24952 end Visit_Itype; 24953 24954 ---------------- 24955 -- Visit_List -- 24956 ---------------- 24957 24958 procedure Visit_List (List : List_Id) is 24959 Elmt : Node_Id; 24960 24961 begin 24962 -- Note that the element of a syntactic list is always a node, never 24963 -- an entity or itype, hence the call to Visit_Node. 24964 24965 if Present (List) then 24966 Elmt := First (List); 24967 while Present (Elmt) loop 24968 Visit_Node (Elmt); 24969 24970 Next (Elmt); 24971 end loop; 24972 end if; 24973 end Visit_List; 24974 24975 ---------------- 24976 -- Visit_Node -- 24977 ---------------- 24978 24979 procedure Visit_Node (N : Node_Id) is 24980 begin 24981 pragma Assert (Nkind (N) not in N_Entity); 24982 24983 -- If the node is a quantified expression and expander is active, 24984 -- it contains an implicit declaration that may require a new entity 24985 -- when the condition has already been (pre)analyzed. 24986 24987 if Nkind (N) = N_Expression_With_Actions 24988 or else 24989 (Nkind (N) = N_Quantified_Expression and then Expander_Active) 24990 then 24991 EWA_Level := EWA_Level + 1; 24992 24993 elsif EWA_Level > 0 24994 and then Nkind (N) in N_Block_Statement 24995 | N_Subprogram_Body 24996 | N_Subprogram_Declaration 24997 then 24998 EWA_Inner_Scope_Level := EWA_Inner_Scope_Level + 1; 24999 end if; 25000 25001 -- If the node is a block, we need to process all declarations 25002 -- in the block and make new entities for each. 25003 25004 if Nkind (N) = N_Block_Statement and then Present (Declarations (N)) 25005 then 25006 declare 25007 Decl : Node_Id := First (Declarations (N)); 25008 25009 begin 25010 while Present (Decl) loop 25011 if Nkind (Decl) = N_Object_Declaration then 25012 Add_New_Entity (Defining_Identifier (Decl), 25013 New_Copy (Defining_Identifier (Decl))); 25014 end if; 25015 25016 Next (Decl); 25017 end loop; 25018 end; 25019 end if; 25020 25021 declare 25022 procedure Action (U : Union_Id); 25023 procedure Action (U : Union_Id) is 25024 begin 25025 Visit_Field (Field => U, Par_Nod => N); 25026 end Action; 25027 25028 procedure Walk is new Walk_Sinfo_Fields (Action); 25029 begin 25030 Walk (N); 25031 end; 25032 25033 if EWA_Level > 0 25034 and then Nkind (N) in N_Block_Statement 25035 | N_Subprogram_Body 25036 | N_Subprogram_Declaration 25037 then 25038 EWA_Inner_Scope_Level := EWA_Inner_Scope_Level - 1; 25039 25040 elsif Nkind (N) = N_Expression_With_Actions then 25041 EWA_Level := EWA_Level - 1; 25042 end if; 25043 end Visit_Node; 25044 25045 --------------------------- 25046 -- Visit_Semantic_Fields -- 25047 --------------------------- 25048 25049 procedure Visit_Semantic_Fields (Id : Entity_Id) is 25050 begin 25051 pragma Assert (Nkind (Id) in N_Entity); 25052 25053 -- Discriminant_Constraint 25054 25055 if Is_Type (Id) and then Has_Discriminants (Base_Type (Id)) then 25056 Visit_Field 25057 (Field => Union_Id (Discriminant_Constraint (Id)), 25058 Semantic => True); 25059 end if; 25060 25061 -- Etype 25062 25063 Visit_Field 25064 (Field => Union_Id (Etype (Id)), 25065 Semantic => True); 25066 25067 -- First_Index 25068 -- Packed_Array_Impl_Type 25069 25070 if Is_Array_Type (Id) then 25071 if Present (First_Index (Id)) then 25072 Visit_Field 25073 (Field => Union_Id (List_Containing (First_Index (Id))), 25074 Semantic => True); 25075 end if; 25076 25077 if Is_Packed (Id) then 25078 Visit_Field 25079 (Field => Union_Id (Packed_Array_Impl_Type (Id)), 25080 Semantic => True); 25081 end if; 25082 end if; 25083 25084 -- Scalar_Range 25085 25086 if Is_Discrete_Type (Id) then 25087 Visit_Field 25088 (Field => Union_Id (Scalar_Range (Id)), 25089 Semantic => True); 25090 end if; 25091 end Visit_Semantic_Fields; 25092 25093 -- Start of processing for New_Copy_Tree 25094 25095 begin 25096 -- Routine New_Copy_Tree performs a deep copy of a subtree by creating 25097 -- shallow copies for each node within, and then updating the child and 25098 -- parent pointers accordingly. This process is straightforward, however 25099 -- the routine must deal with the following complications: 25100 25101 -- * Entities defined within N_Expression_With_Actions nodes must be 25102 -- replicated rather than shared to avoid introducing two identical 25103 -- symbols within the same scope. Note that no other expression can 25104 -- currently define entities. 25105 25106 -- do 25107 -- Source_Low : ...; 25108 -- Source_High : ...; 25109 25110 -- <reference to Source_Low> 25111 -- <reference to Source_High> 25112 -- in ... end; 25113 25114 -- New_Copy_Tree handles this case by first creating new entities 25115 -- and then updating all existing references to point to these new 25116 -- entities. 25117 25118 -- do 25119 -- New_Low : ...; 25120 -- New_High : ...; 25121 25122 -- <reference to New_Low> 25123 -- <reference to New_High> 25124 -- in ... end; 25125 25126 -- * Itypes defined within the subtree must be replicated to avoid any 25127 -- dependencies on invalid or inaccessible data. 25128 25129 -- subtype Source_Itype is ... range Source_Low .. Source_High; 25130 25131 -- New_Copy_Tree handles this case by first creating a new itype in 25132 -- the same fashion as entities, and then updating various relevant 25133 -- constraints. 25134 25135 -- subtype New_Itype is ... range New_Low .. New_High; 25136 25137 -- * The Associated_Node_For_Itype field of itypes must be updated to 25138 -- reference the proper replicated entity or node. 25139 25140 -- * Semantic fields of entities such as Etype and Scope must be 25141 -- updated to reference the proper replicated entities. 25142 25143 -- * Semantic fields of nodes such as First_Real_Statement must be 25144 -- updated to reference the proper replicated nodes. 25145 25146 -- Finally, quantified expressions contain an implicit delaration for 25147 -- the bound variable. Given that quantified expressions appearing 25148 -- in contracts are copied to create pragmas and eventually checking 25149 -- procedures, a new bound variable must be created for each copy, to 25150 -- prevent multiple declarations of the same symbol. 25151 25152 -- To meet all these demands, routine New_Copy_Tree is split into two 25153 -- phases. 25154 25155 -- Phase 1 traverses the tree in order to locate entities and itypes 25156 -- defined within the subtree. New entities are generated and saved in 25157 -- table NCT_New_Entities. The semantic fields of all new entities and 25158 -- itypes are then updated accordingly. 25159 25160 -- Phase 2 traverses the tree in order to replicate each node. Various 25161 -- semantic fields of nodes and entities are updated accordingly. 25162 25163 -- Preparatory phase. Clear the contents of tables NCT_New_Entities and 25164 -- NCT_Pending_Itypes in case a previous call to New_Copy_Tree left some 25165 -- data inside. 25166 25167 if NCT_Tables_In_Use then 25168 NCT_Tables_In_Use := False; 25169 25170 NCT_New_Entities.Reset; 25171 NCT_Pending_Itypes.Reset; 25172 end if; 25173 25174 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with data 25175 -- supplied by a linear entity map. The tables offer faster access to 25176 -- the same data. 25177 25178 Build_NCT_Tables (Map); 25179 25180 -- Execute Phase 1. Traverse the subtree and generate new entities for 25181 -- the following cases: 25182 25183 -- * An entity defined within an N_Expression_With_Actions node 25184 25185 -- * An itype referenced within the subtree where the associated node 25186 -- is also in the subtree. 25187 25188 -- All new entities are accessible via table NCT_New_Entities, which 25189 -- contains mappings of the form: 25190 25191 -- Old_Entity -> New_Entity 25192 -- Old_Itype -> New_Itype 25193 25194 -- In addition, the associated nodes of all new itypes are mapped in 25195 -- table NCT_Pending_Itypes: 25196 25197 -- Assoc_Nod -> (New_Itype1, New_Itype2, .., New_ItypeN) 25198 25199 Visit_Any_Node (Source); 25200 25201 -- Update the semantic attributes of all new entities generated during 25202 -- Phase 1 before starting Phase 2. The updates could be performed in 25203 -- routine Corresponding_Entity, however this may cause the same entity 25204 -- to be updated multiple times, effectively generating useless nodes. 25205 -- Keeping the updates separates from Phase 2 ensures that only one set 25206 -- of attributes is generated for an entity at any one time. 25207 25208 Update_New_Entities (Map); 25209 25210 -- Execute Phase 2. Replicate the source subtree one node at a time. 25211 -- The following transformations take place: 25212 25213 -- * References to entities and itypes are updated to refer to the 25214 -- new entities and itypes generated during Phase 1. 25215 25216 -- * All Associated_Node_For_Itype attributes of itypes are updated 25217 -- to refer to the new replicated Associated_Node_For_Itype. 25218 25219 return Copy_Node_With_Replacement (Source); 25220 end New_Copy_Tree; 25221 25222 ------------------------- 25223 -- New_External_Entity -- 25224 ------------------------- 25225 25226 function New_External_Entity 25227 (Kind : Entity_Kind; 25228 Scope_Id : Entity_Id; 25229 Sloc_Value : Source_Ptr; 25230 Related_Id : Entity_Id; 25231 Suffix : Character; 25232 Suffix_Index : Int := 0; 25233 Prefix : Character := ' ') return Entity_Id 25234 is 25235 N : constant Entity_Id := 25236 Make_Defining_Identifier (Sloc_Value, 25237 New_External_Name 25238 (Chars (Related_Id), Suffix, Suffix_Index, Prefix)); 25239 25240 begin 25241 Mutate_Ekind (N, Kind); 25242 Set_Is_Internal (N, True); 25243 Append_Entity (N, Scope_Id); 25244 Set_Public_Status (N); 25245 25246 if Kind in Type_Kind then 25247 Reinit_Size_Align (N); 25248 end if; 25249 25250 return N; 25251 end New_External_Entity; 25252 25253 ------------------------- 25254 -- New_Internal_Entity -- 25255 ------------------------- 25256 25257 function New_Internal_Entity 25258 (Kind : Entity_Kind; 25259 Scope_Id : Entity_Id; 25260 Sloc_Value : Source_Ptr; 25261 Id_Char : Character) return Entity_Id 25262 is 25263 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); 25264 25265 begin 25266 Mutate_Ekind (N, Kind); 25267 Set_Is_Internal (N, True); 25268 Append_Entity (N, Scope_Id); 25269 25270 if Kind in Type_Kind then 25271 Reinit_Size_Align (N); 25272 end if; 25273 25274 return N; 25275 end New_Internal_Entity; 25276 25277 ----------------- 25278 -- Next_Actual -- 25279 ----------------- 25280 25281 function Next_Actual (Actual_Id : Node_Id) return Node_Id is 25282 Par : constant Node_Id := Parent (Actual_Id); 25283 N : Node_Id; 25284 25285 begin 25286 -- If we are pointing at a positional parameter, it is a member of a 25287 -- node list (the list of parameters), and the next parameter is the 25288 -- next node on the list, unless we hit a parameter association, then 25289 -- we shift to using the chain whose head is the First_Named_Actual in 25290 -- the parent, and then is threaded using the Next_Named_Actual of the 25291 -- Parameter_Association. All this fiddling is because the original node 25292 -- list is in the textual call order, and what we need is the 25293 -- declaration order. 25294 25295 if Is_List_Member (Actual_Id) then 25296 N := Next (Actual_Id); 25297 25298 if Nkind (N) = N_Parameter_Association then 25299 25300 -- In case of a build-in-place call, the call will no longer be a 25301 -- call; it will have been rewritten. 25302 25303 if Nkind (Par) in N_Entry_Call_Statement 25304 | N_Function_Call 25305 | N_Procedure_Call_Statement 25306 then 25307 return First_Named_Actual (Par); 25308 25309 -- In case of a call rewritten in GNATprove mode while "inlining 25310 -- for proof" go to the original call. 25311 25312 elsif Nkind (Par) = N_Null_Statement then 25313 pragma Assert 25314 (GNATprove_Mode 25315 and then 25316 Nkind (Original_Node (Par)) in N_Subprogram_Call); 25317 25318 return First_Named_Actual (Original_Node (Par)); 25319 else 25320 return Empty; 25321 end if; 25322 else 25323 return N; 25324 end if; 25325 25326 else 25327 return Next_Named_Actual (Parent (Actual_Id)); 25328 end if; 25329 end Next_Actual; 25330 25331 procedure Next_Actual (Actual_Id : in out Node_Id) is 25332 begin 25333 Actual_Id := Next_Actual (Actual_Id); 25334 end Next_Actual; 25335 25336 ----------------- 25337 -- Next_Global -- 25338 ----------------- 25339 25340 function Next_Global (Node : Node_Id) return Node_Id is 25341 begin 25342 -- The global item may either be in a list, or by itself, in which case 25343 -- there is no next global item with the same mode. 25344 25345 if Is_List_Member (Node) then 25346 return Next (Node); 25347 else 25348 return Empty; 25349 end if; 25350 end Next_Global; 25351 25352 procedure Next_Global (Node : in out Node_Id) is 25353 begin 25354 Node := Next_Global (Node); 25355 end Next_Global; 25356 25357 ------------------------ 25358 -- No_Caching_Enabled -- 25359 ------------------------ 25360 25361 function No_Caching_Enabled (Id : Entity_Id) return Boolean is 25362 pragma Assert (Ekind (Id) = E_Variable); 25363 Prag : constant Node_Id := Get_Pragma (Id, Pragma_No_Caching); 25364 Arg1 : Node_Id; 25365 25366 begin 25367 if Present (Prag) then 25368 Arg1 := First (Pragma_Argument_Associations (Prag)); 25369 25370 -- The pragma has an optional Boolean expression, the related 25371 -- property is enabled only when the expression evaluates to True. 25372 25373 if Present (Arg1) then 25374 return Is_True (Expr_Value (Get_Pragma_Arg (Arg1))); 25375 25376 -- Otherwise the lack of expression enables the property by 25377 -- default. 25378 25379 else 25380 return True; 25381 end if; 25382 25383 -- The property was never set in the first place 25384 25385 else 25386 return False; 25387 end if; 25388 end No_Caching_Enabled; 25389 25390 -------------------------- 25391 -- No_Heap_Finalization -- 25392 -------------------------- 25393 25394 function No_Heap_Finalization (Typ : Entity_Id) return Boolean is 25395 begin 25396 if Ekind (Typ) in E_Access_Type | E_General_Access_Type 25397 and then Is_Library_Level_Entity (Typ) 25398 then 25399 -- A global No_Heap_Finalization pragma applies to all library-level 25400 -- named access-to-object types. 25401 25402 if Present (No_Heap_Finalization_Pragma) then 25403 return True; 25404 25405 -- The library-level named access-to-object type itself is subject to 25406 -- pragma No_Heap_Finalization. 25407 25408 elsif Present (Get_Pragma (Typ, Pragma_No_Heap_Finalization)) then 25409 return True; 25410 end if; 25411 end if; 25412 25413 return False; 25414 end No_Heap_Finalization; 25415 25416 ----------------------- 25417 -- Normalize_Actuals -- 25418 ----------------------- 25419 25420 -- Chain actuals according to formals of subprogram. If there are no named 25421 -- associations, the chain is simply the list of Parameter Associations, 25422 -- since the order is the same as the declaration order. If there are named 25423 -- associations, then the First_Named_Actual field in the N_Function_Call 25424 -- or N_Procedure_Call_Statement node points to the Parameter_Association 25425 -- node for the parameter that comes first in declaration order. The 25426 -- remaining named parameters are then chained in declaration order using 25427 -- Next_Named_Actual. 25428 25429 -- This routine also verifies that the number of actuals is compatible with 25430 -- the number and default values of formals, but performs no type checking 25431 -- (type checking is done by the caller). 25432 25433 -- If the matching succeeds, Success is set to True and the caller proceeds 25434 -- with type-checking. If the match is unsuccessful, then Success is set to 25435 -- False, and the caller attempts a different interpretation, if there is 25436 -- one. 25437 25438 -- If the flag Report is on, the call is not overloaded, and a failure to 25439 -- match can be reported here, rather than in the caller. 25440 25441 procedure Normalize_Actuals 25442 (N : Node_Id; 25443 S : Entity_Id; 25444 Report : Boolean; 25445 Success : out Boolean) 25446 is 25447 Actuals : constant List_Id := Parameter_Associations (N); 25448 Actual : Node_Id := Empty; 25449 Formal : Entity_Id; 25450 Last : Node_Id := Empty; 25451 First_Named : Node_Id := Empty; 25452 Found : Boolean; 25453 25454 Formals_To_Match : Integer := 0; 25455 Actuals_To_Match : Integer := 0; 25456 25457 procedure Chain (A : Node_Id); 25458 -- Add named actual at the proper place in the list, using the 25459 -- Next_Named_Actual link. 25460 25461 function Reporting return Boolean; 25462 -- Determines if an error is to be reported. To report an error, we 25463 -- need Report to be True, and also we do not report errors caused 25464 -- by calls to init procs that occur within other init procs. Such 25465 -- errors must always be cascaded errors, since if all the types are 25466 -- declared correctly, the compiler will certainly build decent calls. 25467 25468 ----------- 25469 -- Chain -- 25470 ----------- 25471 25472 procedure Chain (A : Node_Id) is 25473 begin 25474 if No (Last) then 25475 25476 -- Call node points to first actual in list 25477 25478 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A)); 25479 25480 else 25481 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A)); 25482 end if; 25483 25484 Last := A; 25485 Set_Next_Named_Actual (Last, Empty); 25486 end Chain; 25487 25488 --------------- 25489 -- Reporting -- 25490 --------------- 25491 25492 function Reporting return Boolean is 25493 begin 25494 if not Report then 25495 return False; 25496 25497 elsif not Within_Init_Proc then 25498 return True; 25499 25500 elsif Is_Init_Proc (Entity (Name (N))) then 25501 return False; 25502 25503 else 25504 return True; 25505 end if; 25506 end Reporting; 25507 25508 -- Start of processing for Normalize_Actuals 25509 25510 begin 25511 if Is_Access_Type (S) then 25512 25513 -- The name in the call is a function call that returns an access 25514 -- to subprogram. The designated type has the list of formals. 25515 25516 Formal := First_Formal (Designated_Type (S)); 25517 else 25518 Formal := First_Formal (S); 25519 end if; 25520 25521 while Present (Formal) loop 25522 Formals_To_Match := Formals_To_Match + 1; 25523 Next_Formal (Formal); 25524 end loop; 25525 25526 -- Find if there is a named association, and verify that no positional 25527 -- associations appear after named ones. 25528 25529 if Present (Actuals) then 25530 Actual := First (Actuals); 25531 end if; 25532 25533 while Present (Actual) 25534 and then Nkind (Actual) /= N_Parameter_Association 25535 loop 25536 Actuals_To_Match := Actuals_To_Match + 1; 25537 Next (Actual); 25538 end loop; 25539 25540 if No (Actual) and Actuals_To_Match = Formals_To_Match then 25541 25542 -- Most common case: positional notation, no defaults 25543 25544 Success := True; 25545 return; 25546 25547 elsif Actuals_To_Match > Formals_To_Match then 25548 25549 -- Too many actuals: will not work 25550 25551 if Reporting then 25552 if Is_Entity_Name (Name (N)) then 25553 Error_Msg_N ("too many arguments in call to&", Name (N)); 25554 else 25555 Error_Msg_N ("too many arguments in call", N); 25556 end if; 25557 end if; 25558 25559 Success := False; 25560 return; 25561 end if; 25562 25563 First_Named := Actual; 25564 25565 while Present (Actual) loop 25566 if Nkind (Actual) /= N_Parameter_Association then 25567 Error_Msg_N 25568 ("positional parameters not allowed after named ones", Actual); 25569 Success := False; 25570 return; 25571 25572 else 25573 Actuals_To_Match := Actuals_To_Match + 1; 25574 end if; 25575 25576 Next (Actual); 25577 end loop; 25578 25579 if Present (Actuals) then 25580 Actual := First (Actuals); 25581 end if; 25582 25583 Formal := First_Formal (S); 25584 while Present (Formal) loop 25585 25586 -- Match the formals in order. If the corresponding actual is 25587 -- positional, nothing to do. Else scan the list of named actuals 25588 -- to find the one with the right name. 25589 25590 if Present (Actual) 25591 and then Nkind (Actual) /= N_Parameter_Association 25592 then 25593 Next (Actual); 25594 Actuals_To_Match := Actuals_To_Match - 1; 25595 Formals_To_Match := Formals_To_Match - 1; 25596 25597 else 25598 -- For named parameters, search the list of actuals to find 25599 -- one that matches the next formal name. 25600 25601 Actual := First_Named; 25602 Found := False; 25603 while Present (Actual) loop 25604 if Chars (Selector_Name (Actual)) = Chars (Formal) then 25605 Found := True; 25606 Chain (Actual); 25607 Actuals_To_Match := Actuals_To_Match - 1; 25608 Formals_To_Match := Formals_To_Match - 1; 25609 exit; 25610 end if; 25611 25612 Next (Actual); 25613 end loop; 25614 25615 if not Found then 25616 if Ekind (Formal) /= E_In_Parameter 25617 or else No (Default_Value (Formal)) 25618 then 25619 if Reporting then 25620 if (Comes_From_Source (S) 25621 or else Sloc (S) = Standard_Location) 25622 and then Is_Overloadable (S) 25623 then 25624 if No (Actuals) 25625 and then 25626 Nkind (Parent (N)) in N_Procedure_Call_Statement 25627 | N_Function_Call 25628 | N_Parameter_Association 25629 and then Ekind (S) /= E_Function 25630 then 25631 Set_Etype (N, Etype (S)); 25632 25633 else 25634 Error_Msg_Name_1 := Chars (S); 25635 Error_Msg_Sloc := Sloc (S); 25636 Error_Msg_NE 25637 ("missing argument for parameter & " 25638 & "in call to % declared #", N, Formal); 25639 end if; 25640 25641 elsif Is_Overloadable (S) then 25642 Error_Msg_Name_1 := Chars (S); 25643 25644 -- Point to type derivation that generated the 25645 -- operation. 25646 25647 Error_Msg_Sloc := Sloc (Parent (S)); 25648 25649 Error_Msg_NE 25650 ("missing argument for parameter & " 25651 & "in call to % (inherited) #", N, Formal); 25652 25653 else 25654 Error_Msg_NE 25655 ("missing argument for parameter &", N, Formal); 25656 end if; 25657 end if; 25658 25659 Success := False; 25660 return; 25661 25662 else 25663 Formals_To_Match := Formals_To_Match - 1; 25664 end if; 25665 end if; 25666 end if; 25667 25668 Next_Formal (Formal); 25669 end loop; 25670 25671 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then 25672 Success := True; 25673 return; 25674 25675 else 25676 if Reporting then 25677 25678 -- Find some superfluous named actual that did not get 25679 -- attached to the list of associations. 25680 25681 Actual := First (Actuals); 25682 while Present (Actual) loop 25683 if Nkind (Actual) = N_Parameter_Association 25684 and then Actual /= Last 25685 and then No (Next_Named_Actual (Actual)) 25686 then 25687 -- A validity check may introduce a copy of a call that 25688 -- includes an extra actual (for example for an unrelated 25689 -- accessibility check). Check that the extra actual matches 25690 -- some extra formal, which must exist already because 25691 -- subprogram must be frozen at this point. 25692 25693 if Present (Extra_Formals (S)) 25694 and then not Comes_From_Source (Actual) 25695 and then Nkind (Actual) = N_Parameter_Association 25696 and then Chars (Extra_Formals (S)) = 25697 Chars (Selector_Name (Actual)) 25698 then 25699 null; 25700 else 25701 Error_Msg_N 25702 ("unmatched actual & in call", Selector_Name (Actual)); 25703 exit; 25704 end if; 25705 end if; 25706 25707 Next (Actual); 25708 end loop; 25709 end if; 25710 25711 Success := False; 25712 return; 25713 end if; 25714 end Normalize_Actuals; 25715 25716 -------------------------------- 25717 -- Note_Possible_Modification -- 25718 -------------------------------- 25719 25720 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is 25721 Modification_Comes_From_Source : constant Boolean := 25722 Comes_From_Source (Parent (N)); 25723 25724 Ent : Entity_Id; 25725 Exp : Node_Id; 25726 25727 begin 25728 -- Loop to find referenced entity, if there is one 25729 25730 Exp := N; 25731 loop 25732 Ent := Empty; 25733 25734 if Is_Entity_Name (Exp) then 25735 Ent := Entity (Exp); 25736 25737 -- If the entity is missing, it is an undeclared identifier, 25738 -- and there is nothing to annotate. 25739 25740 if No (Ent) then 25741 return; 25742 end if; 25743 25744 elsif Nkind (Exp) = N_Explicit_Dereference then 25745 declare 25746 P : constant Node_Id := Prefix (Exp); 25747 25748 begin 25749 -- In formal verification mode, keep track of all reads and 25750 -- writes through explicit dereferences. 25751 25752 if GNATprove_Mode then 25753 SPARK_Specific.Generate_Dereference (N, 'm'); 25754 end if; 25755 25756 if Nkind (P) = N_Selected_Component 25757 and then Present (Entry_Formal (Entity (Selector_Name (P)))) 25758 then 25759 -- Case of a reference to an entry formal 25760 25761 Ent := Entry_Formal (Entity (Selector_Name (P))); 25762 25763 elsif Nkind (P) = N_Identifier 25764 and then Nkind (Parent (Entity (P))) = N_Object_Declaration 25765 and then Present (Expression (Parent (Entity (P)))) 25766 and then Nkind (Expression (Parent (Entity (P)))) = 25767 N_Reference 25768 then 25769 -- Case of a reference to a value on which side effects have 25770 -- been removed. 25771 25772 Exp := Prefix (Expression (Parent (Entity (P)))); 25773 goto Continue; 25774 25775 else 25776 return; 25777 end if; 25778 end; 25779 25780 elsif Nkind (Exp) in N_Type_Conversion | N_Unchecked_Type_Conversion 25781 then 25782 Exp := Expression (Exp); 25783 goto Continue; 25784 25785 elsif Nkind (Exp) in 25786 N_Slice | N_Indexed_Component | N_Selected_Component 25787 then 25788 -- Special check, if the prefix is an access type, then return 25789 -- since we are modifying the thing pointed to, not the prefix. 25790 -- When we are expanding, most usually the prefix is replaced 25791 -- by an explicit dereference, and this test is not needed, but 25792 -- in some cases (notably -gnatc mode and generics) when we do 25793 -- not do full expansion, we need this special test. 25794 25795 if Is_Access_Type (Etype (Prefix (Exp))) then 25796 return; 25797 25798 -- Otherwise go to prefix and keep going 25799 25800 else 25801 Exp := Prefix (Exp); 25802 goto Continue; 25803 end if; 25804 25805 -- All other cases, not a modification 25806 25807 else 25808 return; 25809 end if; 25810 25811 -- Now look for entity being referenced 25812 25813 if Present (Ent) then 25814 if Is_Object (Ent) then 25815 if Comes_From_Source (Exp) 25816 or else Modification_Comes_From_Source 25817 then 25818 -- Give warning if pragma unmodified is given and we are 25819 -- sure this is a modification. 25820 25821 if Has_Pragma_Unmodified (Ent) and then Sure then 25822 25823 -- Note that the entity may be present only as a result 25824 -- of pragma Unused. 25825 25826 if Has_Pragma_Unused (Ent) then 25827 Error_Msg_NE ("??pragma Unused given for &!", N, Ent); 25828 else 25829 Error_Msg_NE 25830 ("??pragma Unmodified given for &!", N, Ent); 25831 end if; 25832 end if; 25833 25834 Set_Never_Set_In_Source (Ent, False); 25835 end if; 25836 25837 Set_Is_True_Constant (Ent, False); 25838 Set_Current_Value (Ent, Empty); 25839 Set_Is_Known_Null (Ent, False); 25840 25841 if not Can_Never_Be_Null (Ent) then 25842 Set_Is_Known_Non_Null (Ent, False); 25843 end if; 25844 25845 -- Follow renaming chain 25846 25847 if Ekind (Ent) in E_Variable | E_Constant 25848 and then Present (Renamed_Object (Ent)) 25849 then 25850 Exp := Renamed_Object (Ent); 25851 25852 -- If the entity is the loop variable in an iteration over 25853 -- a container, retrieve container expression to indicate 25854 -- possible modification. 25855 25856 if Present (Related_Expression (Ent)) 25857 and then Nkind (Parent (Related_Expression (Ent))) = 25858 N_Iterator_Specification 25859 then 25860 Exp := Original_Node (Related_Expression (Ent)); 25861 end if; 25862 25863 goto Continue; 25864 25865 -- The expression may be the renaming of a subcomponent of an 25866 -- array or container. The assignment to the subcomponent is 25867 -- a modification of the container. 25868 25869 elsif Comes_From_Source (Original_Node (Exp)) 25870 and then Nkind (Original_Node (Exp)) in 25871 N_Selected_Component | N_Indexed_Component 25872 then 25873 Exp := Prefix (Original_Node (Exp)); 25874 goto Continue; 25875 end if; 25876 25877 -- Generate a reference only if the assignment comes from 25878 -- source. This excludes, for example, calls to a dispatching 25879 -- assignment operation when the left-hand side is tagged. In 25880 -- GNATprove mode, we need those references also on generated 25881 -- code, as these are used to compute the local effects of 25882 -- subprograms. 25883 25884 if Modification_Comes_From_Source or GNATprove_Mode then 25885 Generate_Reference (Ent, Exp, 'm'); 25886 25887 -- If the target of the assignment is the bound variable 25888 -- in an iterator, indicate that the corresponding array 25889 -- or container is also modified. 25890 25891 if Ada_Version >= Ada_2012 25892 and then Nkind (Parent (Ent)) = N_Iterator_Specification 25893 then 25894 declare 25895 Domain : constant Node_Id := Name (Parent (Ent)); 25896 25897 begin 25898 -- ??? In the full version of the construct, the 25899 -- domain of iteration can be given by an expression. 25900 25901 if Is_Entity_Name (Domain) then 25902 Generate_Reference (Entity (Domain), Exp, 'm'); 25903 Set_Is_True_Constant (Entity (Domain), False); 25904 Set_Never_Set_In_Source (Entity (Domain), False); 25905 end if; 25906 end; 25907 end if; 25908 end if; 25909 end if; 25910 25911 Kill_Checks (Ent); 25912 25913 -- If we are sure this is a modification from source, and we know 25914 -- this modifies a constant, then give an appropriate warning. 25915 25916 if Sure 25917 and then Modification_Comes_From_Source 25918 and then Overlays_Constant (Ent) 25919 and then Address_Clause_Overlay_Warnings 25920 then 25921 declare 25922 Addr : constant Node_Id := Address_Clause (Ent); 25923 O_Ent : Entity_Id; 25924 Off : Boolean; 25925 25926 begin 25927 Find_Overlaid_Entity (Addr, O_Ent, Off); 25928 25929 Error_Msg_Sloc := Sloc (Addr); 25930 Error_Msg_NE 25931 ("??constant& may be modified via address clause#", 25932 N, O_Ent); 25933 end; 25934 end if; 25935 25936 return; 25937 end if; 25938 25939 <<Continue>> 25940 null; 25941 end loop; 25942 end Note_Possible_Modification; 25943 25944 ----------------- 25945 -- Null_Status -- 25946 ----------------- 25947 25948 function Null_Status (N : Node_Id) return Null_Status_Kind is 25949 function Is_Null_Excluding_Def (Def : Node_Id) return Boolean; 25950 -- Determine whether definition Def carries a null exclusion 25951 25952 function Null_Status_Of_Entity (Id : Entity_Id) return Null_Status_Kind; 25953 -- Determine the null status of arbitrary entity Id 25954 25955 function Null_Status_Of_Type (Typ : Entity_Id) return Null_Status_Kind; 25956 -- Determine the null status of type Typ 25957 25958 --------------------------- 25959 -- Is_Null_Excluding_Def -- 25960 --------------------------- 25961 25962 function Is_Null_Excluding_Def (Def : Node_Id) return Boolean is 25963 begin 25964 return Nkind (Def) in N_Access_Definition 25965 | N_Access_Function_Definition 25966 | N_Access_Procedure_Definition 25967 | N_Access_To_Object_Definition 25968 | N_Component_Definition 25969 | N_Derived_Type_Definition 25970 and then Null_Exclusion_Present (Def); 25971 end Is_Null_Excluding_Def; 25972 25973 --------------------------- 25974 -- Null_Status_Of_Entity -- 25975 --------------------------- 25976 25977 function Null_Status_Of_Entity 25978 (Id : Entity_Id) return Null_Status_Kind 25979 is 25980 Decl : constant Node_Id := Declaration_Node (Id); 25981 Def : Node_Id; 25982 25983 begin 25984 -- The value of an imported or exported entity may be set externally 25985 -- regardless of a null exclusion. As a result, the value cannot be 25986 -- determined statically. 25987 25988 if Is_Imported (Id) or else Is_Exported (Id) then 25989 return Unknown; 25990 25991 elsif Nkind (Decl) in N_Component_Declaration 25992 | N_Discriminant_Specification 25993 | N_Formal_Object_Declaration 25994 | N_Object_Declaration 25995 | N_Object_Renaming_Declaration 25996 | N_Parameter_Specification 25997 then 25998 -- A component declaration yields a non-null value when either 25999 -- its component definition or access definition carries a null 26000 -- exclusion. 26001 26002 if Nkind (Decl) = N_Component_Declaration then 26003 Def := Component_Definition (Decl); 26004 26005 if Is_Null_Excluding_Def (Def) then 26006 return Is_Non_Null; 26007 end if; 26008 26009 Def := Access_Definition (Def); 26010 26011 if Present (Def) and then Is_Null_Excluding_Def (Def) then 26012 return Is_Non_Null; 26013 end if; 26014 26015 -- A formal object declaration yields a non-null value if its 26016 -- access definition carries a null exclusion. If the object is 26017 -- default initialized, then the value depends on the expression. 26018 26019 elsif Nkind (Decl) = N_Formal_Object_Declaration then 26020 Def := Access_Definition (Decl); 26021 26022 if Present (Def) and then Is_Null_Excluding_Def (Def) then 26023 return Is_Non_Null; 26024 end if; 26025 26026 -- A constant may yield a null or non-null value depending on its 26027 -- initialization expression. 26028 26029 elsif Ekind (Id) = E_Constant then 26030 return Null_Status (Constant_Value (Id)); 26031 26032 -- The construct yields a non-null value when it has a null 26033 -- exclusion. 26034 26035 elsif Null_Exclusion_Present (Decl) then 26036 return Is_Non_Null; 26037 26038 -- An object renaming declaration yields a non-null value if its 26039 -- access definition carries a null exclusion. Otherwise the value 26040 -- depends on the renamed name. 26041 26042 elsif Nkind (Decl) = N_Object_Renaming_Declaration then 26043 Def := Access_Definition (Decl); 26044 26045 if Present (Def) and then Is_Null_Excluding_Def (Def) then 26046 return Is_Non_Null; 26047 26048 else 26049 return Null_Status (Name (Decl)); 26050 end if; 26051 end if; 26052 end if; 26053 26054 -- At this point the declaration of the entity does not carry a null 26055 -- exclusion and lacks an initialization expression. Check the status 26056 -- of its type. 26057 26058 return Null_Status_Of_Type (Etype (Id)); 26059 end Null_Status_Of_Entity; 26060 26061 ------------------------- 26062 -- Null_Status_Of_Type -- 26063 ------------------------- 26064 26065 function Null_Status_Of_Type (Typ : Entity_Id) return Null_Status_Kind is 26066 Curr : Entity_Id; 26067 Decl : Node_Id; 26068 26069 begin 26070 -- Traverse the type chain looking for types with null exclusion 26071 26072 Curr := Typ; 26073 while Present (Curr) and then Etype (Curr) /= Curr loop 26074 Decl := Parent (Curr); 26075 26076 -- Guard against itypes which do not always have declarations. A 26077 -- type yields a non-null value if it carries a null exclusion. 26078 26079 if Present (Decl) then 26080 if Nkind (Decl) = N_Full_Type_Declaration 26081 and then Is_Null_Excluding_Def (Type_Definition (Decl)) 26082 then 26083 return Is_Non_Null; 26084 26085 elsif Nkind (Decl) = N_Subtype_Declaration 26086 and then Null_Exclusion_Present (Decl) 26087 then 26088 return Is_Non_Null; 26089 end if; 26090 end if; 26091 26092 Curr := Etype (Curr); 26093 end loop; 26094 26095 -- The type chain does not contain any null excluding types 26096 26097 return Unknown; 26098 end Null_Status_Of_Type; 26099 26100 -- Start of processing for Null_Status 26101 26102 begin 26103 -- Prevent cascaded errors or infinite loops when trying to determine 26104 -- the null status of an erroneous construct. 26105 26106 if Error_Posted (N) then 26107 return Unknown; 26108 26109 -- An allocator always creates a non-null value 26110 26111 elsif Nkind (N) = N_Allocator then 26112 return Is_Non_Null; 26113 26114 -- Taking the 'Access of something yields a non-null value 26115 26116 elsif Nkind (N) = N_Attribute_Reference 26117 and then Attribute_Name (N) in Name_Access 26118 | Name_Unchecked_Access 26119 | Name_Unrestricted_Access 26120 then 26121 return Is_Non_Null; 26122 26123 -- "null" yields null 26124 26125 elsif Nkind (N) = N_Null then 26126 return Is_Null; 26127 26128 -- Check the status of the operand of a type conversion 26129 26130 elsif Nkind (N) = N_Type_Conversion then 26131 return Null_Status (Expression (N)); 26132 26133 -- The input denotes a reference to an entity. Determine whether the 26134 -- entity or its type yields a null or non-null value. 26135 26136 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 26137 return Null_Status_Of_Entity (Entity (N)); 26138 end if; 26139 26140 -- Otherwise it is not possible to determine the null status of the 26141 -- subexpression at compile time without resorting to simple flow 26142 -- analysis. 26143 26144 return Unknown; 26145 end Null_Status; 26146 26147 -------------------------------------- 26148 -- Null_To_Null_Address_Convert_OK -- 26149 -------------------------------------- 26150 26151 function Null_To_Null_Address_Convert_OK 26152 (N : Node_Id; 26153 Typ : Entity_Id := Empty) return Boolean 26154 is 26155 begin 26156 if not Relaxed_RM_Semantics then 26157 return False; 26158 end if; 26159 26160 if Nkind (N) = N_Null then 26161 return Present (Typ) and then Is_Descendant_Of_Address (Typ); 26162 26163 elsif Nkind (N) in 26164 N_Op_Eq | N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt | N_Op_Ne 26165 then 26166 declare 26167 L : constant Node_Id := Left_Opnd (N); 26168 R : constant Node_Id := Right_Opnd (N); 26169 26170 begin 26171 -- We check the Etype of the complementary operand since the 26172 -- N_Null node is not decorated at this stage. 26173 26174 return 26175 ((Nkind (L) = N_Null 26176 and then Is_Descendant_Of_Address (Etype (R))) 26177 or else 26178 (Nkind (R) = N_Null 26179 and then Is_Descendant_Of_Address (Etype (L)))); 26180 end; 26181 end if; 26182 26183 return False; 26184 end Null_To_Null_Address_Convert_OK; 26185 26186 --------------------------------- 26187 -- Number_Of_Elements_In_Array -- 26188 --------------------------------- 26189 26190 function Number_Of_Elements_In_Array (T : Entity_Id) return Int is 26191 Indx : Node_Id; 26192 Typ : Entity_Id; 26193 Low : Node_Id; 26194 High : Node_Id; 26195 Num : Int := 1; 26196 26197 begin 26198 pragma Assert (Is_Array_Type (T)); 26199 26200 Indx := First_Index (T); 26201 while Present (Indx) loop 26202 Typ := Underlying_Type (Etype (Indx)); 26203 26204 -- Never look at junk bounds of a generic type 26205 26206 if Is_Generic_Type (Typ) then 26207 return 0; 26208 end if; 26209 26210 -- Check the array bounds are known at compile time and return zero 26211 -- if they are not. 26212 26213 Low := Type_Low_Bound (Typ); 26214 High := Type_High_Bound (Typ); 26215 26216 if not Compile_Time_Known_Value (Low) then 26217 return 0; 26218 elsif not Compile_Time_Known_Value (High) then 26219 return 0; 26220 else 26221 Num := 26222 Num * UI_To_Int ((Expr_Value (High) - Expr_Value (Low) + 1)); 26223 end if; 26224 26225 Next_Index (Indx); 26226 end loop; 26227 26228 return Num; 26229 end Number_Of_Elements_In_Array; 26230 26231 --------------------------------- 26232 -- Original_Aspect_Pragma_Name -- 26233 --------------------------------- 26234 26235 function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id is 26236 Item : Node_Id; 26237 Item_Nam : Name_Id; 26238 26239 begin 26240 pragma Assert (Nkind (N) in N_Aspect_Specification | N_Pragma); 26241 26242 Item := N; 26243 26244 -- The pragma was generated to emulate an aspect, use the original 26245 -- aspect specification. 26246 26247 if Nkind (Item) = N_Pragma and then From_Aspect_Specification (Item) then 26248 Item := Corresponding_Aspect (Item); 26249 end if; 26250 26251 -- Retrieve the name of the aspect/pragma. As assertion pragmas from 26252 -- a generic instantiation might have been rewritten into pragma Check, 26253 -- we look at the original node for Item. Note also that Pre, Pre_Class, 26254 -- Post and Post_Class rewrite their pragma identifier to preserve the 26255 -- original name, so we look at the original node for the identifier. 26256 -- ??? this is kludgey 26257 26258 if Nkind (Item) = N_Pragma then 26259 Item_Nam := 26260 Chars (Original_Node (Pragma_Identifier (Original_Node (Item)))); 26261 26262 else 26263 pragma Assert (Nkind (Item) = N_Aspect_Specification); 26264 Item_Nam := Chars (Identifier (Item)); 26265 end if; 26266 26267 -- Deal with 'Class by converting the name to its _XXX form 26268 26269 if Class_Present (Item) then 26270 if Item_Nam = Name_Invariant then 26271 Item_Nam := Name_uInvariant; 26272 26273 elsif Item_Nam = Name_Post then 26274 Item_Nam := Name_uPost; 26275 26276 elsif Item_Nam = Name_Pre then 26277 Item_Nam := Name_uPre; 26278 26279 elsif Item_Nam in Name_Type_Invariant | Name_Type_Invariant_Class 26280 then 26281 Item_Nam := Name_uType_Invariant; 26282 26283 -- Nothing to do for other cases (e.g. a Check that derived from 26284 -- Pre_Class and has the flag set). Also we do nothing if the name 26285 -- is already in special _xxx form. 26286 26287 end if; 26288 end if; 26289 26290 return Item_Nam; 26291 end Original_Aspect_Pragma_Name; 26292 26293 -------------------------------------- 26294 -- Original_Corresponding_Operation -- 26295 -------------------------------------- 26296 26297 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id 26298 is 26299 Typ : constant Entity_Id := Find_Dispatching_Type (S); 26300 26301 begin 26302 -- If S is an inherited primitive S2 the original corresponding 26303 -- operation of S is the original corresponding operation of S2 26304 26305 if Present (Alias (S)) 26306 and then Find_Dispatching_Type (Alias (S)) /= Typ 26307 then 26308 return Original_Corresponding_Operation (Alias (S)); 26309 26310 -- If S overrides an inherited subprogram S2 the original corresponding 26311 -- operation of S is the original corresponding operation of S2 26312 26313 elsif Present (Overridden_Operation (S)) then 26314 return Original_Corresponding_Operation (Overridden_Operation (S)); 26315 26316 -- otherwise it is S itself 26317 26318 else 26319 return S; 26320 end if; 26321 end Original_Corresponding_Operation; 26322 26323 ----------------------------------- 26324 -- Original_View_In_Visible_Part -- 26325 ----------------------------------- 26326 26327 function Original_View_In_Visible_Part 26328 (Typ : Entity_Id) return Boolean 26329 is 26330 Scop : constant Entity_Id := Scope (Typ); 26331 26332 begin 26333 -- The scope must be a package 26334 26335 if not Is_Package_Or_Generic_Package (Scop) then 26336 return False; 26337 end if; 26338 26339 -- A type with a private declaration has a private view declared in 26340 -- the visible part. 26341 26342 if Has_Private_Declaration (Typ) then 26343 return True; 26344 end if; 26345 26346 return List_Containing (Parent (Typ)) = 26347 Visible_Declarations (Package_Specification (Scop)); 26348 end Original_View_In_Visible_Part; 26349 26350 ------------------- 26351 -- Output_Entity -- 26352 ------------------- 26353 26354 procedure Output_Entity (Id : Entity_Id) is 26355 Scop : Entity_Id; 26356 26357 begin 26358 Scop := Scope (Id); 26359 26360 -- The entity may lack a scope when it is in the process of being 26361 -- analyzed. Use the current scope as an approximation. 26362 26363 if No (Scop) then 26364 Scop := Current_Scope; 26365 end if; 26366 26367 Output_Name (Chars (Id), Scop); 26368 end Output_Entity; 26369 26370 ----------------- 26371 -- Output_Name -- 26372 ----------------- 26373 26374 procedure Output_Name (Nam : Name_Id; Scop : Entity_Id := Current_Scope) is 26375 begin 26376 Write_Str 26377 (Get_Name_String 26378 (Get_Qualified_Name 26379 (Nam => Nam, 26380 Suffix => No_Name, 26381 Scop => Scop))); 26382 Write_Eol; 26383 end Output_Name; 26384 26385 ------------------ 26386 -- Param_Entity -- 26387 ------------------ 26388 26389 -- This would be trivial, simply a test for an identifier that was a 26390 -- reference to a formal, if it were not for the fact that a previous call 26391 -- to Expand_Entry_Parameter will have modified the reference to the 26392 -- identifier. A formal of a protected entity is rewritten as 26393 26394 -- typ!(recobj).rec.all'Constrained 26395 26396 -- where rec is a selector whose Entry_Formal link points to the formal 26397 26398 -- If the type of the entry parameter has a representation clause, then an 26399 -- extra temp is involved (see below). 26400 26401 -- For a formal of a task entity, the formal is rewritten as a local 26402 -- renaming. 26403 26404 -- In addition, a formal that is marked volatile because it is aliased 26405 -- through an address clause is rewritten as dereference as well. 26406 26407 function Param_Entity (N : Node_Id) return Entity_Id is 26408 Renamed_Obj : Node_Id; 26409 26410 begin 26411 -- Simple reference case 26412 26413 if Nkind (N) in N_Identifier | N_Expanded_Name then 26414 if Is_Formal (Entity (N)) then 26415 return Entity (N); 26416 26417 -- Handle renamings of formal parameters and formals of tasks that 26418 -- are rewritten as renamings. 26419 26420 elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then 26421 Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N))); 26422 26423 if Is_Entity_Name (Renamed_Obj) 26424 and then Is_Formal (Entity (Renamed_Obj)) 26425 then 26426 return Entity (Renamed_Obj); 26427 26428 elsif 26429 Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement 26430 then 26431 return Entity (N); 26432 end if; 26433 end if; 26434 26435 else 26436 if Nkind (N) = N_Explicit_Dereference then 26437 declare 26438 P : Node_Id := Prefix (N); 26439 S : Node_Id; 26440 E : Entity_Id; 26441 Decl : Node_Id; 26442 26443 begin 26444 -- If the type of an entry parameter has a representation 26445 -- clause, then the prefix is not a selected component, but 26446 -- instead a reference to a temp pointing at the selected 26447 -- component. In this case, set P to be the initial value of 26448 -- that temp. 26449 26450 if Nkind (P) = N_Identifier then 26451 E := Entity (P); 26452 26453 if Ekind (E) = E_Constant then 26454 Decl := Parent (E); 26455 26456 if Nkind (Decl) = N_Object_Declaration then 26457 P := Expression (Decl); 26458 end if; 26459 end if; 26460 end if; 26461 26462 if Nkind (P) = N_Selected_Component then 26463 S := Selector_Name (P); 26464 26465 if Present (Entry_Formal (Entity (S))) then 26466 return Entry_Formal (Entity (S)); 26467 end if; 26468 26469 elsif Nkind (Original_Node (N)) = N_Identifier then 26470 return Param_Entity (Original_Node (N)); 26471 end if; 26472 end; 26473 end if; 26474 end if; 26475 26476 return Empty; 26477 end Param_Entity; 26478 26479 ---------------------- 26480 -- Policy_In_Effect -- 26481 ---------------------- 26482 26483 function Policy_In_Effect (Policy : Name_Id) return Name_Id is 26484 function Policy_In_List (List : Node_Id) return Name_Id; 26485 -- Determine the mode of a policy in a N_Pragma list 26486 26487 -------------------- 26488 -- Policy_In_List -- 26489 -------------------- 26490 26491 function Policy_In_List (List : Node_Id) return Name_Id is 26492 Arg1 : Node_Id; 26493 Arg2 : Node_Id; 26494 Prag : Node_Id; 26495 26496 begin 26497 Prag := List; 26498 while Present (Prag) loop 26499 Arg1 := First (Pragma_Argument_Associations (Prag)); 26500 Arg2 := Next (Arg1); 26501 26502 Arg1 := Get_Pragma_Arg (Arg1); 26503 Arg2 := Get_Pragma_Arg (Arg2); 26504 26505 -- The current Check_Policy pragma matches the requested policy or 26506 -- appears in the single argument form (Assertion, policy_id). 26507 26508 if Chars (Arg1) in Name_Assertion | Policy then 26509 return Chars (Arg2); 26510 end if; 26511 26512 Prag := Next_Pragma (Prag); 26513 end loop; 26514 26515 return No_Name; 26516 end Policy_In_List; 26517 26518 -- Local variables 26519 26520 Kind : Name_Id; 26521 26522 -- Start of processing for Policy_In_Effect 26523 26524 begin 26525 if not Is_Valid_Assertion_Kind (Policy) then 26526 raise Program_Error; 26527 end if; 26528 26529 -- Inspect all policy pragmas that appear within scopes (if any) 26530 26531 Kind := Policy_In_List (Check_Policy_List); 26532 26533 -- Inspect all configuration policy pragmas (if any) 26534 26535 if Kind = No_Name then 26536 Kind := Policy_In_List (Check_Policy_List_Config); 26537 end if; 26538 26539 -- The context lacks policy pragmas, determine the mode based on whether 26540 -- assertions are enabled at the configuration level. This ensures that 26541 -- the policy is preserved when analyzing generics. 26542 26543 if Kind = No_Name then 26544 if Assertions_Enabled_Config then 26545 Kind := Name_Check; 26546 else 26547 Kind := Name_Ignore; 26548 end if; 26549 end if; 26550 26551 -- In CodePeer mode and GNATprove mode, we need to consider all 26552 -- assertions, unless they are disabled. Force Name_Check on 26553 -- ignored assertions. 26554 26555 if Kind in Name_Ignore | Name_Off 26556 and then (CodePeer_Mode or GNATprove_Mode) 26557 then 26558 Kind := Name_Check; 26559 end if; 26560 26561 return Kind; 26562 end Policy_In_Effect; 26563 26564 ------------------------------- 26565 -- Preanalyze_Without_Errors -- 26566 ------------------------------- 26567 26568 procedure Preanalyze_Without_Errors (N : Node_Id) is 26569 Status : constant Boolean := Get_Ignore_Errors; 26570 begin 26571 Set_Ignore_Errors (True); 26572 Preanalyze (N); 26573 Set_Ignore_Errors (Status); 26574 end Preanalyze_Without_Errors; 26575 26576 ----------------------- 26577 -- Predicate_Enabled -- 26578 ----------------------- 26579 26580 function Predicate_Enabled (Typ : Entity_Id) return Boolean is 26581 begin 26582 return Present (Predicate_Function (Typ)) 26583 and then not Predicates_Ignored (Typ) 26584 and then not Predicate_Checks_Suppressed (Empty); 26585 end Predicate_Enabled; 26586 26587 ---------------------------------- 26588 -- Predicate_Tests_On_Arguments -- 26589 ---------------------------------- 26590 26591 function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean is 26592 begin 26593 -- Always test predicates on indirect call 26594 26595 if Ekind (Subp) = E_Subprogram_Type then 26596 return True; 26597 26598 -- Do not test predicates on call to generated default Finalize, since 26599 -- we are not interested in whether something we are finalizing (and 26600 -- typically destroying) satisfies its predicates. 26601 26602 elsif Chars (Subp) = Name_Finalize 26603 and then not Comes_From_Source (Subp) 26604 then 26605 return False; 26606 26607 -- Do not test predicates on any internally generated routines 26608 26609 elsif Is_Internal_Name (Chars (Subp)) then 26610 return False; 26611 26612 -- Do not test predicates on call to Init_Proc, since if needed the 26613 -- predicate test will occur at some other point. 26614 26615 elsif Is_Init_Proc (Subp) then 26616 return False; 26617 26618 -- Do not test predicates on call to predicate function, since this 26619 -- would cause infinite recursion. 26620 26621 elsif Ekind (Subp) = E_Function 26622 and then (Is_Predicate_Function (Subp) 26623 or else 26624 Is_Predicate_Function_M (Subp)) 26625 then 26626 return False; 26627 26628 -- For now, no other exceptions 26629 26630 else 26631 return True; 26632 end if; 26633 end Predicate_Tests_On_Arguments; 26634 26635 ----------------------- 26636 -- Private_Component -- 26637 ----------------------- 26638 26639 function Private_Component (Type_Id : Entity_Id) return Entity_Id is 26640 Ancestor : constant Entity_Id := Base_Type (Type_Id); 26641 26642 function Trace_Components 26643 (T : Entity_Id; 26644 Check : Boolean) return Entity_Id; 26645 -- Recursive function that does the work, and checks against circular 26646 -- definition for each subcomponent type. 26647 26648 ---------------------- 26649 -- Trace_Components -- 26650 ---------------------- 26651 26652 function Trace_Components 26653 (T : Entity_Id; 26654 Check : Boolean) return Entity_Id 26655 is 26656 Btype : constant Entity_Id := Base_Type (T); 26657 Component : Entity_Id; 26658 P : Entity_Id; 26659 Candidate : Entity_Id := Empty; 26660 26661 begin 26662 if Check and then Btype = Ancestor then 26663 Error_Msg_N ("circular type definition", Type_Id); 26664 return Any_Type; 26665 end if; 26666 26667 if Is_Private_Type (Btype) and then not Is_Generic_Type (Btype) then 26668 if Present (Full_View (Btype)) 26669 and then Is_Record_Type (Full_View (Btype)) 26670 and then not Is_Frozen (Btype) 26671 then 26672 -- To indicate that the ancestor depends on a private type, the 26673 -- current Btype is sufficient. However, to check for circular 26674 -- definition we must recurse on the full view. 26675 26676 Candidate := Trace_Components (Full_View (Btype), True); 26677 26678 if Candidate = Any_Type then 26679 return Any_Type; 26680 else 26681 return Btype; 26682 end if; 26683 26684 else 26685 return Btype; 26686 end if; 26687 26688 elsif Is_Array_Type (Btype) then 26689 return Trace_Components (Component_Type (Btype), True); 26690 26691 elsif Is_Record_Type (Btype) then 26692 Component := First_Entity (Btype); 26693 while Present (Component) 26694 and then Comes_From_Source (Component) 26695 loop 26696 -- Skip anonymous types generated by constrained components 26697 26698 if not Is_Type (Component) then 26699 P := Trace_Components (Etype (Component), True); 26700 26701 if Present (P) then 26702 if P = Any_Type then 26703 return P; 26704 else 26705 Candidate := P; 26706 end if; 26707 end if; 26708 end if; 26709 26710 Next_Entity (Component); 26711 end loop; 26712 26713 return Candidate; 26714 26715 else 26716 return Empty; 26717 end if; 26718 end Trace_Components; 26719 26720 -- Start of processing for Private_Component 26721 26722 begin 26723 return Trace_Components (Type_Id, False); 26724 end Private_Component; 26725 26726 --------------------------- 26727 -- Primitive_Names_Match -- 26728 --------------------------- 26729 26730 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is 26731 function Non_Internal_Name (E : Entity_Id) return Name_Id; 26732 -- Given an internal name, returns the corresponding non-internal name 26733 26734 ------------------------ 26735 -- Non_Internal_Name -- 26736 ------------------------ 26737 26738 function Non_Internal_Name (E : Entity_Id) return Name_Id is 26739 begin 26740 Get_Name_String (Chars (E)); 26741 Name_Len := Name_Len - 1; 26742 return Name_Find; 26743 end Non_Internal_Name; 26744 26745 -- Start of processing for Primitive_Names_Match 26746 26747 begin 26748 pragma Assert (Present (E1) and then Present (E2)); 26749 26750 return Chars (E1) = Chars (E2) 26751 or else 26752 (not Is_Internal_Name (Chars (E1)) 26753 and then Is_Internal_Name (Chars (E2)) 26754 and then Non_Internal_Name (E2) = Chars (E1)) 26755 or else 26756 (not Is_Internal_Name (Chars (E2)) 26757 and then Is_Internal_Name (Chars (E1)) 26758 and then Non_Internal_Name (E1) = Chars (E2)) 26759 or else 26760 (Is_Predefined_Dispatching_Operation (E1) 26761 and then Is_Predefined_Dispatching_Operation (E2) 26762 and then Same_TSS (E1, E2)) 26763 or else 26764 (Is_Init_Proc (E1) and then Is_Init_Proc (E2)); 26765 end Primitive_Names_Match; 26766 26767 ----------------------- 26768 -- Process_End_Label -- 26769 ----------------------- 26770 26771 procedure Process_End_Label 26772 (N : Node_Id; 26773 Typ : Character; 26774 Ent : Entity_Id) 26775 is 26776 Loc : Source_Ptr; 26777 Nam : Node_Id; 26778 Scop : Entity_Id; 26779 26780 Label_Ref : Boolean; 26781 -- Set True if reference to end label itself is required 26782 26783 Endl : Node_Id; 26784 -- Gets set to the operator symbol or identifier that references the 26785 -- entity Ent. For the child unit case, this is the identifier from the 26786 -- designator. For other cases, this is simply Endl. 26787 26788 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id); 26789 -- N is an identifier node that appears as a parent unit reference in 26790 -- the case where Ent is a child unit. This procedure generates an 26791 -- appropriate cross-reference entry. E is the corresponding entity. 26792 26793 ------------------------- 26794 -- Generate_Parent_Ref -- 26795 ------------------------- 26796 26797 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is 26798 begin 26799 -- If names do not match, something weird, skip reference 26800 26801 if Chars (E) = Chars (N) then 26802 26803 -- Generate the reference. We do NOT consider this as a reference 26804 -- for unreferenced symbol purposes. 26805 26806 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True); 26807 26808 if Style_Check then 26809 Style.Check_Identifier (N, E); 26810 end if; 26811 end if; 26812 end Generate_Parent_Ref; 26813 26814 -- Start of processing for Process_End_Label 26815 26816 begin 26817 -- If no node, ignore. This happens in some error situations, and 26818 -- also for some internally generated structures where no end label 26819 -- references are required in any case. 26820 26821 if No (N) then 26822 return; 26823 end if; 26824 26825 -- Nothing to do if no End_Label, happens for internally generated 26826 -- constructs where we don't want an end label reference anyway. Also 26827 -- nothing to do if Endl is a string literal, which means there was 26828 -- some prior error (bad operator symbol) 26829 26830 Endl := End_Label (N); 26831 26832 if No (Endl) or else Nkind (Endl) = N_String_Literal then 26833 return; 26834 end if; 26835 26836 -- Reference node is not in extended main source unit 26837 26838 if not In_Extended_Main_Source_Unit (N) then 26839 26840 -- Generally we do not collect references except for the extended 26841 -- main source unit. The one exception is the 'e' entry for a 26842 -- package spec, where it is useful for a client to have the 26843 -- ending information to define scopes. 26844 26845 if Typ /= 'e' then 26846 return; 26847 26848 else 26849 Label_Ref := False; 26850 26851 -- For this case, we can ignore any parent references, but we 26852 -- need the package name itself for the 'e' entry. 26853 26854 if Nkind (Endl) = N_Designator then 26855 Endl := Identifier (Endl); 26856 end if; 26857 end if; 26858 26859 -- Reference is in extended main source unit 26860 26861 else 26862 Label_Ref := True; 26863 26864 -- For designator, generate references for the parent entries 26865 26866 if Nkind (Endl) = N_Designator then 26867 26868 -- Generate references for the prefix if the END line comes from 26869 -- source (otherwise we do not need these references) We climb the 26870 -- scope stack to find the expected entities. 26871 26872 if Comes_From_Source (Endl) then 26873 Nam := Name (Endl); 26874 Scop := Current_Scope; 26875 while Nkind (Nam) = N_Selected_Component loop 26876 Scop := Scope (Scop); 26877 exit when No (Scop); 26878 Generate_Parent_Ref (Selector_Name (Nam), Scop); 26879 Nam := Prefix (Nam); 26880 end loop; 26881 26882 if Present (Scop) then 26883 Generate_Parent_Ref (Nam, Scope (Scop)); 26884 end if; 26885 end if; 26886 26887 Endl := Identifier (Endl); 26888 end if; 26889 end if; 26890 26891 -- If the end label is not for the given entity, then either we have 26892 -- some previous error, or this is a generic instantiation for which 26893 -- we do not need to make a cross-reference in this case anyway. In 26894 -- either case we simply ignore the call. 26895 26896 if Chars (Ent) /= Chars (Endl) then 26897 return; 26898 end if; 26899 26900 -- If label was really there, then generate a normal reference and then 26901 -- adjust the location in the end label to point past the name (which 26902 -- should almost always be the semicolon). 26903 26904 Loc := Sloc (Endl); 26905 26906 if Comes_From_Source (Endl) then 26907 26908 -- If a label reference is required, then do the style check and 26909 -- generate an l-type cross-reference entry for the label 26910 26911 if Label_Ref then 26912 if Style_Check then 26913 Style.Check_Identifier (Endl, Ent); 26914 end if; 26915 26916 Generate_Reference (Ent, Endl, 'l', Set_Ref => False); 26917 end if; 26918 26919 -- Set the location to point past the label (normally this will 26920 -- mean the semicolon immediately following the label). This is 26921 -- done for the sake of the 'e' or 't' entry generated below. 26922 26923 Get_Decoded_Name_String (Chars (Endl)); 26924 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len)); 26925 end if; 26926 26927 -- Now generate the e/t reference 26928 26929 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True); 26930 26931 -- Restore Sloc, in case modified above, since we have an identifier 26932 -- and the normal Sloc should be left set in the tree. 26933 26934 Set_Sloc (Endl, Loc); 26935 end Process_End_Label; 26936 26937 -------------------------------- 26938 -- Propagate_Concurrent_Flags -- 26939 -------------------------------- 26940 26941 procedure Propagate_Concurrent_Flags 26942 (Typ : Entity_Id; 26943 Comp_Typ : Entity_Id) 26944 is 26945 begin 26946 if Has_Task (Comp_Typ) then 26947 Set_Has_Task (Typ); 26948 end if; 26949 26950 if Has_Protected (Comp_Typ) then 26951 Set_Has_Protected (Typ); 26952 end if; 26953 26954 if Has_Timing_Event (Comp_Typ) then 26955 Set_Has_Timing_Event (Typ); 26956 end if; 26957 end Propagate_Concurrent_Flags; 26958 26959 ------------------------------ 26960 -- Propagate_DIC_Attributes -- 26961 ------------------------------ 26962 26963 procedure Propagate_DIC_Attributes 26964 (Typ : Entity_Id; 26965 From_Typ : Entity_Id) 26966 is 26967 DIC_Proc : Entity_Id; 26968 Partial_DIC_Proc : Entity_Id; 26969 26970 begin 26971 if Present (Typ) and then Present (From_Typ) then 26972 pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ)); 26973 26974 -- Nothing to do if both the source and the destination denote the 26975 -- same type. 26976 26977 if From_Typ = Typ then 26978 return; 26979 26980 -- Nothing to do when the destination denotes an incomplete type 26981 -- because the DIC is associated with the current instance of a 26982 -- private type, thus it can never apply to an incomplete type. 26983 26984 elsif Is_Incomplete_Type (Typ) then 26985 return; 26986 end if; 26987 26988 DIC_Proc := DIC_Procedure (From_Typ); 26989 Partial_DIC_Proc := Partial_DIC_Procedure (From_Typ); 26990 26991 -- The setting of the attributes is intentionally conservative. This 26992 -- prevents accidental clobbering of enabled attributes. We need to 26993 -- call Base_Type twice, because it is sometimes not set to an actual 26994 -- base type. 26995 26996 if Has_Inherited_DIC (From_Typ) then 26997 Set_Has_Inherited_DIC (Base_Type (Base_Type (Typ))); 26998 end if; 26999 27000 if Has_Own_DIC (From_Typ) then 27001 Set_Has_Own_DIC (Base_Type (Base_Type (Typ))); 27002 end if; 27003 27004 if Present (DIC_Proc) and then No (DIC_Procedure (Typ)) then 27005 Set_DIC_Procedure (Typ, DIC_Proc); 27006 end if; 27007 27008 if Present (Partial_DIC_Proc) 27009 and then No (Partial_DIC_Procedure (Typ)) 27010 then 27011 Set_Partial_DIC_Procedure (Typ, Partial_DIC_Proc); 27012 end if; 27013 end if; 27014 end Propagate_DIC_Attributes; 27015 27016 ------------------------------------ 27017 -- Propagate_Invariant_Attributes -- 27018 ------------------------------------ 27019 27020 procedure Propagate_Invariant_Attributes 27021 (Typ : Entity_Id; 27022 From_Typ : Entity_Id) 27023 is 27024 Full_IP : Entity_Id; 27025 Part_IP : Entity_Id; 27026 27027 begin 27028 if Present (Typ) and then Present (From_Typ) then 27029 pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ)); 27030 27031 -- Nothing to do if both the source and the destination denote the 27032 -- same type. 27033 27034 if From_Typ = Typ then 27035 return; 27036 end if; 27037 27038 Full_IP := Invariant_Procedure (From_Typ); 27039 Part_IP := Partial_Invariant_Procedure (From_Typ); 27040 27041 -- The setting of the attributes is intentionally conservative. This 27042 -- prevents accidental clobbering of enabled attributes. We need to 27043 -- call Base_Type twice, because it is sometimes not set to an actual 27044 -- base type. 27045 27046 if Has_Inheritable_Invariants (From_Typ) then 27047 Set_Has_Inheritable_Invariants (Typ); 27048 end if; 27049 27050 if Has_Inherited_Invariants (From_Typ) then 27051 Set_Has_Inherited_Invariants (Typ); 27052 end if; 27053 27054 if Has_Own_Invariants (From_Typ) then 27055 Set_Has_Own_Invariants (Base_Type (Base_Type (Typ))); 27056 end if; 27057 27058 if Present (Full_IP) and then No (Invariant_Procedure (Typ)) then 27059 Set_Invariant_Procedure (Typ, Full_IP); 27060 end if; 27061 27062 if Present (Part_IP) and then No (Partial_Invariant_Procedure (Typ)) 27063 then 27064 Set_Partial_Invariant_Procedure (Typ, Part_IP); 27065 end if; 27066 end if; 27067 end Propagate_Invariant_Attributes; 27068 27069 ------------------------------------ 27070 -- Propagate_Predicate_Attributes -- 27071 ------------------------------------ 27072 27073 procedure Propagate_Predicate_Attributes 27074 (Typ : Entity_Id; 27075 From_Typ : Entity_Id) 27076 is 27077 Pred_Func : Entity_Id; 27078 Pred_Func_M : Entity_Id; 27079 27080 begin 27081 if Present (Typ) and then Present (From_Typ) then 27082 pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ)); 27083 27084 -- Nothing to do if both the source and the destination denote the 27085 -- same type. 27086 27087 if From_Typ = Typ then 27088 return; 27089 end if; 27090 27091 Pred_Func := Predicate_Function (From_Typ); 27092 Pred_Func_M := Predicate_Function_M (From_Typ); 27093 27094 -- The setting of the attributes is intentionally conservative. This 27095 -- prevents accidental clobbering of enabled attributes. 27096 27097 if Has_Predicates (From_Typ) then 27098 Set_Has_Predicates (Typ); 27099 end if; 27100 27101 if Present (Pred_Func) and then No (Predicate_Function (Typ)) then 27102 Set_Predicate_Function (Typ, Pred_Func); 27103 end if; 27104 27105 if Present (Pred_Func_M) and then No (Predicate_Function_M (Typ)) then 27106 Set_Predicate_Function_M (Typ, Pred_Func_M); 27107 end if; 27108 end if; 27109 end Propagate_Predicate_Attributes; 27110 27111 --------------------------------------- 27112 -- Record_Possible_Part_Of_Reference -- 27113 --------------------------------------- 27114 27115 procedure Record_Possible_Part_Of_Reference 27116 (Var_Id : Entity_Id; 27117 Ref : Node_Id) 27118 is 27119 Encap : constant Entity_Id := Encapsulating_State (Var_Id); 27120 Refs : Elist_Id; 27121 27122 begin 27123 -- The variable is a constituent of a single protected/task type. Such 27124 -- a variable acts as a component of the type and must appear within a 27125 -- specific region (SPARK RM 9(3)). Instead of recording the reference, 27126 -- verify its legality now. 27127 27128 if Present (Encap) and then Is_Single_Concurrent_Object (Encap) then 27129 Check_Part_Of_Reference (Var_Id, Ref); 27130 27131 -- The variable is subject to pragma Part_Of and may eventually become a 27132 -- constituent of a single protected/task type. Record the reference to 27133 -- verify its placement when the contract of the variable is analyzed. 27134 27135 elsif Present (Get_Pragma (Var_Id, Pragma_Part_Of)) then 27136 Refs := Part_Of_References (Var_Id); 27137 27138 if No (Refs) then 27139 Refs := New_Elmt_List; 27140 Set_Part_Of_References (Var_Id, Refs); 27141 end if; 27142 27143 Append_Elmt (Ref, Refs); 27144 end if; 27145 end Record_Possible_Part_Of_Reference; 27146 27147 ---------------- 27148 -- Referenced -- 27149 ---------------- 27150 27151 function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is 27152 Seen : Boolean := False; 27153 27154 function Is_Reference (N : Node_Id) return Traverse_Result; 27155 -- Determine whether node N denotes a reference to Id. If this is the 27156 -- case, set global flag Seen to True and stop the traversal. 27157 27158 ------------------ 27159 -- Is_Reference -- 27160 ------------------ 27161 27162 function Is_Reference (N : Node_Id) return Traverse_Result is 27163 begin 27164 if Is_Entity_Name (N) 27165 and then Present (Entity (N)) 27166 and then Entity (N) = Id 27167 then 27168 Seen := True; 27169 return Abandon; 27170 else 27171 return OK; 27172 end if; 27173 end Is_Reference; 27174 27175 procedure Inspect_Expression is new Traverse_Proc (Is_Reference); 27176 27177 -- Start of processing for Referenced 27178 27179 begin 27180 Inspect_Expression (Expr); 27181 return Seen; 27182 end Referenced; 27183 27184 ------------------------------------ 27185 -- References_Generic_Formal_Type -- 27186 ------------------------------------ 27187 27188 function References_Generic_Formal_Type (N : Node_Id) return Boolean is 27189 27190 function Process (N : Node_Id) return Traverse_Result; 27191 -- Process one node in search for generic formal type 27192 27193 ------------- 27194 -- Process -- 27195 ------------- 27196 27197 function Process (N : Node_Id) return Traverse_Result is 27198 begin 27199 if Nkind (N) in N_Has_Entity then 27200 declare 27201 E : constant Entity_Id := Entity (N); 27202 begin 27203 if Present (E) then 27204 if Is_Generic_Type (E) then 27205 return Abandon; 27206 elsif Present (Etype (E)) 27207 and then Is_Generic_Type (Etype (E)) 27208 then 27209 return Abandon; 27210 end if; 27211 end if; 27212 end; 27213 end if; 27214 27215 return Atree.OK; 27216 end Process; 27217 27218 function Traverse is new Traverse_Func (Process); 27219 -- Traverse tree to look for generic type 27220 27221 begin 27222 if Inside_A_Generic then 27223 return Traverse (N) = Abandon; 27224 else 27225 return False; 27226 end if; 27227 end References_Generic_Formal_Type; 27228 27229 ------------------------------- 27230 -- Remove_Entity_And_Homonym -- 27231 ------------------------------- 27232 27233 procedure Remove_Entity_And_Homonym (Id : Entity_Id) is 27234 begin 27235 Remove_Entity (Id); 27236 Remove_Homonym (Id); 27237 end Remove_Entity_And_Homonym; 27238 27239 -------------------- 27240 -- Remove_Homonym -- 27241 -------------------- 27242 27243 procedure Remove_Homonym (Id : Entity_Id) is 27244 Hom : Entity_Id; 27245 Prev : Entity_Id := Empty; 27246 27247 begin 27248 if Id = Current_Entity (Id) then 27249 if Present (Homonym (Id)) then 27250 Set_Current_Entity (Homonym (Id)); 27251 else 27252 Set_Name_Entity_Id (Chars (Id), Empty); 27253 end if; 27254 27255 else 27256 Hom := Current_Entity (Id); 27257 while Present (Hom) and then Hom /= Id loop 27258 Prev := Hom; 27259 Hom := Homonym (Hom); 27260 end loop; 27261 27262 -- If Id is not on the homonym chain, nothing to do 27263 27264 if Present (Hom) then 27265 Set_Homonym (Prev, Homonym (Id)); 27266 end if; 27267 end if; 27268 end Remove_Homonym; 27269 27270 ------------------------------ 27271 -- Remove_Overloaded_Entity -- 27272 ------------------------------ 27273 27274 procedure Remove_Overloaded_Entity (Id : Entity_Id) is 27275 procedure Remove_Primitive_Of (Typ : Entity_Id); 27276 -- Remove primitive subprogram Id from the list of primitives that 27277 -- belong to type Typ. 27278 27279 ------------------------- 27280 -- Remove_Primitive_Of -- 27281 ------------------------- 27282 27283 procedure Remove_Primitive_Of (Typ : Entity_Id) is 27284 Prims : Elist_Id; 27285 27286 begin 27287 if Is_Tagged_Type (Typ) then 27288 Prims := Direct_Primitive_Operations (Typ); 27289 27290 if Present (Prims) then 27291 Remove (Prims, Id); 27292 end if; 27293 end if; 27294 end Remove_Primitive_Of; 27295 27296 -- Local variables 27297 27298 Formal : Entity_Id; 27299 27300 -- Start of processing for Remove_Overloaded_Entity 27301 27302 begin 27303 Remove_Entity_And_Homonym (Id); 27304 27305 -- The entity denotes a primitive subprogram. Remove it from the list of 27306 -- primitives of the associated controlling type. 27307 27308 if Ekind (Id) in E_Function | E_Procedure and then Is_Primitive (Id) then 27309 Formal := First_Formal (Id); 27310 while Present (Formal) loop 27311 if Is_Controlling_Formal (Formal) then 27312 Remove_Primitive_Of (Etype (Formal)); 27313 exit; 27314 end if; 27315 27316 Next_Formal (Formal); 27317 end loop; 27318 27319 if Ekind (Id) = E_Function and then Has_Controlling_Result (Id) then 27320 Remove_Primitive_Of (Etype (Id)); 27321 end if; 27322 end if; 27323 end Remove_Overloaded_Entity; 27324 27325 --------------------- 27326 -- Rep_To_Pos_Flag -- 27327 --------------------- 27328 27329 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is 27330 begin 27331 return New_Occurrence_Of 27332 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc); 27333 end Rep_To_Pos_Flag; 27334 27335 -------------------- 27336 -- Require_Entity -- 27337 -------------------- 27338 27339 procedure Require_Entity (N : Node_Id) is 27340 begin 27341 if Is_Entity_Name (N) and then No (Entity (N)) then 27342 if Total_Errors_Detected /= 0 then 27343 Set_Entity (N, Any_Id); 27344 else 27345 raise Program_Error; 27346 end if; 27347 end if; 27348 end Require_Entity; 27349 27350 ------------------------------ 27351 -- Requires_Transient_Scope -- 27352 ------------------------------ 27353 27354 -- A transient scope is required when variable-sized temporaries are 27355 -- allocated on the secondary stack, or when finalization actions must be 27356 -- generated before the next instruction. 27357 27358 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is 27359 pragma Assert (if Present (Id) then Ekind (Id) in E_Void | Type_Kind); 27360 27361 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean; 27362 -- This is called for untagged records and protected types, with 27363 -- nondefaulted discriminants. Returns True if the size of function 27364 -- results is known at the call site, False otherwise. Returns False 27365 -- if there is a variant part that depends on the discriminants of 27366 -- this type, or if there is an array constrained by the discriminants 27367 -- of this type. ???Currently, this is overly conservative (the array 27368 -- could be nested inside some other record that is constrained by 27369 -- nondiscriminants). That is, the recursive calls are too conservative. 27370 27371 procedure Ensure_Minimum_Decoration (Typ : Entity_Id); 27372 -- If Typ is not frozen then add to Typ the minimum decoration required 27373 -- by Requires_Transient_Scope to reliably provide its functionality; 27374 -- otherwise no action is performed. 27375 27376 function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean; 27377 -- Returns True if Typ is a nonlimited record with defaulted 27378 -- discriminants whose max size makes it unsuitable for allocating on 27379 -- the primary stack. 27380 27381 ------------------------------ 27382 -- Caller_Known_Size_Record -- 27383 ------------------------------ 27384 27385 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is 27386 pragma Assert (Typ = Underlying_Type (Typ)); 27387 27388 begin 27389 if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then 27390 return False; 27391 end if; 27392 27393 declare 27394 Comp : Entity_Id; 27395 27396 begin 27397 Comp := First_Component (Typ); 27398 while Present (Comp) loop 27399 27400 -- Only look at E_Component entities. No need to look at 27401 -- E_Discriminant entities, and we must ignore internal 27402 -- subtypes generated for constrained components. 27403 27404 declare 27405 Comp_Type : constant Entity_Id := 27406 Underlying_Type (Etype (Comp)); 27407 27408 begin 27409 if Is_Record_Type (Comp_Type) 27410 or else 27411 Is_Protected_Type (Comp_Type) 27412 then 27413 if not Caller_Known_Size_Record (Comp_Type) then 27414 return False; 27415 end if; 27416 27417 elsif Is_Array_Type (Comp_Type) then 27418 if Size_Depends_On_Discriminant (Comp_Type) then 27419 return False; 27420 end if; 27421 end if; 27422 end; 27423 27424 Next_Component (Comp); 27425 end loop; 27426 end; 27427 27428 return True; 27429 end Caller_Known_Size_Record; 27430 27431 ------------------------------- 27432 -- Ensure_Minimum_Decoration -- 27433 ------------------------------- 27434 27435 procedure Ensure_Minimum_Decoration (Typ : Entity_Id) is 27436 Comp : Entity_Id; 27437 begin 27438 -- Do not set Has_Controlled_Component on a class-wide equivalent 27439 -- type. See Make_CW_Equivalent_Type. 27440 27441 if not Is_Frozen (Typ) 27442 and then Is_Base_Type (Typ) 27443 and then (Is_Record_Type (Typ) 27444 or else Is_Concurrent_Type (Typ) 27445 or else Is_Incomplete_Or_Private_Type (Typ)) 27446 and then not Is_Class_Wide_Equivalent_Type (Typ) 27447 then 27448 Comp := First_Component (Typ); 27449 while Present (Comp) loop 27450 if Has_Controlled_Component (Etype (Comp)) 27451 or else 27452 (Chars (Comp) /= Name_uParent 27453 and then Is_Controlled (Etype (Comp))) 27454 or else 27455 (Is_Protected_Type (Etype (Comp)) 27456 and then 27457 Present (Corresponding_Record_Type (Etype (Comp))) 27458 and then 27459 Has_Controlled_Component 27460 (Corresponding_Record_Type (Etype (Comp)))) 27461 then 27462 Set_Has_Controlled_Component (Typ); 27463 exit; 27464 end if; 27465 27466 Next_Component (Comp); 27467 end loop; 27468 end if; 27469 end Ensure_Minimum_Decoration; 27470 27471 ------------------------------ 27472 -- Large_Max_Size_Mutable -- 27473 ------------------------------ 27474 27475 function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is 27476 pragma Assert (Typ = Underlying_Type (Typ)); 27477 27478 function Is_Large_Discrete_Type (T : Entity_Id) return Boolean; 27479 -- Returns true if the discrete type T has a large range 27480 27481 ---------------------------- 27482 -- Is_Large_Discrete_Type -- 27483 ---------------------------- 27484 27485 function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is 27486 Threshold : constant Int := 16; 27487 -- Arbitrary threshold above which we consider it "large". We want 27488 -- a fairly large threshold, because these large types really 27489 -- shouldn't have default discriminants in the first place, in 27490 -- most cases. 27491 27492 begin 27493 return UI_To_Int (RM_Size (T)) > Threshold; 27494 end Is_Large_Discrete_Type; 27495 27496 -- Start of processing for Large_Max_Size_Mutable 27497 27498 begin 27499 if Is_Record_Type (Typ) 27500 and then not Is_Limited_View (Typ) 27501 and then Has_Defaulted_Discriminants (Typ) 27502 then 27503 -- Loop through the components, looking for an array whose upper 27504 -- bound(s) depends on discriminants, where both the subtype of 27505 -- the discriminant and the index subtype are too large. 27506 27507 declare 27508 Comp : Entity_Id; 27509 27510 begin 27511 Comp := First_Component (Typ); 27512 while Present (Comp) loop 27513 declare 27514 Comp_Type : constant Entity_Id := 27515 Underlying_Type (Etype (Comp)); 27516 27517 Hi : Node_Id; 27518 Indx : Node_Id; 27519 Ityp : Entity_Id; 27520 27521 begin 27522 if Is_Array_Type (Comp_Type) then 27523 Indx := First_Index (Comp_Type); 27524 27525 while Present (Indx) loop 27526 Ityp := Etype (Indx); 27527 Hi := Type_High_Bound (Ityp); 27528 27529 if Nkind (Hi) = N_Identifier 27530 and then Ekind (Entity (Hi)) = E_Discriminant 27531 and then Is_Large_Discrete_Type (Ityp) 27532 and then Is_Large_Discrete_Type 27533 (Etype (Entity (Hi))) 27534 then 27535 return True; 27536 end if; 27537 27538 Next_Index (Indx); 27539 end loop; 27540 end if; 27541 end; 27542 27543 Next_Component (Comp); 27544 end loop; 27545 end; 27546 end if; 27547 27548 return False; 27549 end Large_Max_Size_Mutable; 27550 27551 -- Local declarations 27552 27553 Typ : constant Entity_Id := Underlying_Type (Id); 27554 27555 -- Start of processing for Requires_Transient_Scope 27556 27557 begin 27558 -- This is a private type which is not completed yet. This can only 27559 -- happen in a default expression (of a formal parameter or of a 27560 -- record component). Do not expand transient scope in this case. 27561 27562 if No (Typ) then 27563 return False; 27564 end if; 27565 27566 Ensure_Minimum_Decoration (Id); 27567 27568 -- Do not expand transient scope for non-existent procedure return or 27569 -- string literal types. 27570 27571 if Typ = Standard_Void_Type 27572 or else Ekind (Typ) = E_String_Literal_Subtype 27573 then 27574 return False; 27575 27576 -- If Typ is a generic formal incomplete type, then we want to look at 27577 -- the actual type. 27578 27579 elsif Ekind (Typ) = E_Record_Subtype 27580 and then Present (Cloned_Subtype (Typ)) 27581 then 27582 return Requires_Transient_Scope (Cloned_Subtype (Typ)); 27583 27584 -- Functions returning specific tagged types may dispatch on result, so 27585 -- their returned value is allocated on the secondary stack, even in the 27586 -- definite case. We must treat nondispatching functions the same way, 27587 -- because access-to-function types can point at both, so the calling 27588 -- conventions must be compatible. Is_Tagged_Type includes controlled 27589 -- types and class-wide types. Controlled type temporaries need 27590 -- finalization. 27591 27592 -- ???It's not clear why we need to return noncontrolled types with 27593 -- controlled components on the secondary stack. 27594 27595 elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then 27596 return True; 27597 27598 -- Untagged definite subtypes are known size. This includes all 27599 -- elementary [sub]types. Tasks are known size even if they have 27600 -- discriminants. So we return False here, with one exception: 27601 -- For a type like: 27602 -- type T (Last : Natural := 0) is 27603 -- X : String (1 .. Last); 27604 -- end record; 27605 -- we return True. That's because for "P(F(...));", where F returns T, 27606 -- we don't know the size of the result at the call site, so if we 27607 -- allocated it on the primary stack, we would have to allocate the 27608 -- maximum size, which is way too big. 27609 27610 elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then 27611 return Large_Max_Size_Mutable (Typ); 27612 27613 -- Indefinite (discriminated) untagged record or protected type 27614 27615 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then 27616 return not Caller_Known_Size_Record (Typ); 27617 27618 -- Unconstrained array 27619 27620 else 27621 pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ)); 27622 return True; 27623 end if; 27624 end Requires_Transient_Scope; 27625 27626 -------------------------- 27627 -- Reset_Analyzed_Flags -- 27628 -------------------------- 27629 27630 procedure Reset_Analyzed_Flags (N : Node_Id) is 27631 function Clear_Analyzed (N : Node_Id) return Traverse_Result; 27632 -- Function used to reset Analyzed flags in tree. Note that we do 27633 -- not reset Analyzed flags in entities, since there is no need to 27634 -- reanalyze entities, and indeed, it is wrong to do so, since it 27635 -- can result in generating auxiliary stuff more than once. 27636 27637 -------------------- 27638 -- Clear_Analyzed -- 27639 -------------------- 27640 27641 function Clear_Analyzed (N : Node_Id) return Traverse_Result is 27642 begin 27643 if Nkind (N) not in N_Entity then 27644 Set_Analyzed (N, False); 27645 end if; 27646 27647 return OK; 27648 end Clear_Analyzed; 27649 27650 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed); 27651 27652 -- Start of processing for Reset_Analyzed_Flags 27653 27654 begin 27655 Reset_Analyzed (N); 27656 end Reset_Analyzed_Flags; 27657 27658 ------------------------ 27659 -- Restore_SPARK_Mode -- 27660 ------------------------ 27661 27662 procedure Restore_SPARK_Mode 27663 (Mode : SPARK_Mode_Type; 27664 Prag : Node_Id) 27665 is 27666 begin 27667 SPARK_Mode := Mode; 27668 SPARK_Mode_Pragma := Prag; 27669 end Restore_SPARK_Mode; 27670 27671 -------------------------------- 27672 -- Returns_Unconstrained_Type -- 27673 -------------------------------- 27674 27675 function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is 27676 begin 27677 return Ekind (Subp) = E_Function 27678 and then not Is_Scalar_Type (Etype (Subp)) 27679 and then not Is_Access_Type (Etype (Subp)) 27680 and then not Is_Constrained (Etype (Subp)); 27681 end Returns_Unconstrained_Type; 27682 27683 ---------------------------- 27684 -- Root_Type_Of_Full_View -- 27685 ---------------------------- 27686 27687 function Root_Type_Of_Full_View (T : Entity_Id) return Entity_Id is 27688 Rtyp : constant Entity_Id := Root_Type (T); 27689 27690 begin 27691 -- The root type of the full view may itself be a private type. Keep 27692 -- looking for the ultimate derivation parent. 27693 27694 if Is_Private_Type (Rtyp) and then Present (Full_View (Rtyp)) then 27695 return Root_Type_Of_Full_View (Full_View (Rtyp)); 27696 else 27697 return Rtyp; 27698 end if; 27699 end Root_Type_Of_Full_View; 27700 27701 --------------------------- 27702 -- Safe_To_Capture_Value -- 27703 --------------------------- 27704 27705 function Safe_To_Capture_Value 27706 (N : Node_Id; 27707 Ent : Entity_Id; 27708 Cond : Boolean := False) return Boolean 27709 is 27710 begin 27711 -- The only entities for which we track constant values are variables 27712 -- that are not renamings, constants and formal parameters, so check 27713 -- if we have this case. 27714 27715 -- Note: it may seem odd to track constant values for constants, but in 27716 -- fact this routine is used for other purposes than simply capturing 27717 -- the value. In particular, the setting of Known[_Non]_Null and 27718 -- Is_Known_Valid. 27719 27720 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent))) 27721 or else 27722 Ekind (Ent) = E_Constant 27723 or else 27724 Is_Formal (Ent) 27725 then 27726 null; 27727 27728 -- For conditionals, we also allow loop parameters 27729 27730 elsif Cond and then Ekind (Ent) = E_Loop_Parameter then 27731 null; 27732 27733 -- For all other cases, not just unsafe, but impossible to capture 27734 -- Current_Value, since the above are the only entities which have 27735 -- Current_Value fields. 27736 27737 else 27738 return False; 27739 end if; 27740 27741 -- Skip if volatile or aliased, since funny things might be going on in 27742 -- these cases which we cannot necessarily track. Also skip any variable 27743 -- for which an address clause is given, or whose address is taken. Also 27744 -- never capture value of library level variables (an attempt to do so 27745 -- can occur in the case of package elaboration code). 27746 27747 if Treat_As_Volatile (Ent) 27748 or else Is_Aliased (Ent) 27749 or else Present (Address_Clause (Ent)) 27750 or else Address_Taken (Ent) 27751 or else (Is_Library_Level_Entity (Ent) 27752 and then Ekind (Ent) = E_Variable) 27753 then 27754 return False; 27755 end if; 27756 27757 -- OK, all above conditions are met. We also require that the scope of 27758 -- the reference be the same as the scope of the entity, not counting 27759 -- packages and blocks and loops. 27760 27761 declare 27762 E_Scope : constant Entity_Id := Scope (Ent); 27763 R_Scope : Entity_Id; 27764 27765 begin 27766 R_Scope := Current_Scope; 27767 while R_Scope /= Standard_Standard loop 27768 exit when R_Scope = E_Scope; 27769 27770 if Ekind (R_Scope) not in E_Package | E_Block | E_Loop then 27771 return False; 27772 else 27773 R_Scope := Scope (R_Scope); 27774 end if; 27775 end loop; 27776 end; 27777 27778 -- We also require that the reference does not appear in a context 27779 -- where it is not sure to be executed (i.e. a conditional context 27780 -- or an exception handler). We skip this if Cond is True, since the 27781 -- capturing of values from conditional tests handles this ok. 27782 27783 if Cond or else No (N) then 27784 return True; 27785 end if; 27786 27787 declare 27788 Desc : Node_Id; 27789 P : Node_Id; 27790 27791 begin 27792 Desc := N; 27793 27794 -- Seems dubious that case expressions are not handled here ??? 27795 27796 P := Parent (N); 27797 while Present (P) loop 27798 if Nkind (P) = N_If_Statement 27799 or else Nkind (P) = N_Case_Statement 27800 or else (Nkind (P) in N_Short_Circuit 27801 and then Desc = Right_Opnd (P)) 27802 or else (Nkind (P) = N_If_Expression 27803 and then Desc /= First (Expressions (P))) 27804 or else Nkind (P) = N_Exception_Handler 27805 or else Nkind (P) = N_Selective_Accept 27806 or else Nkind (P) = N_Conditional_Entry_Call 27807 or else Nkind (P) = N_Timed_Entry_Call 27808 or else Nkind (P) = N_Asynchronous_Select 27809 then 27810 return False; 27811 27812 else 27813 Desc := P; 27814 P := Parent (P); 27815 27816 -- A special Ada 2012 case: the original node may be part 27817 -- of the else_actions of a conditional expression, in which 27818 -- case it might not have been expanded yet, and appears in 27819 -- a non-syntactic list of actions. In that case it is clearly 27820 -- not safe to save a value. 27821 27822 if No (P) 27823 and then Is_List_Member (Desc) 27824 and then No (Parent (List_Containing (Desc))) 27825 then 27826 return False; 27827 end if; 27828 end if; 27829 end loop; 27830 end; 27831 27832 -- OK, looks safe to set value 27833 27834 return True; 27835 end Safe_To_Capture_Value; 27836 27837 --------------- 27838 -- Same_Name -- 27839 --------------- 27840 27841 function Same_Name (N1, N2 : Node_Id) return Boolean is 27842 K1 : constant Node_Kind := Nkind (N1); 27843 K2 : constant Node_Kind := Nkind (N2); 27844 27845 begin 27846 if (K1 = N_Identifier or else K1 = N_Defining_Identifier) 27847 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier) 27848 then 27849 return Chars (N1) = Chars (N2); 27850 27851 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name) 27852 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name) 27853 then 27854 return Same_Name (Selector_Name (N1), Selector_Name (N2)) 27855 and then Same_Name (Prefix (N1), Prefix (N2)); 27856 27857 else 27858 return False; 27859 end if; 27860 end Same_Name; 27861 27862 ----------------- 27863 -- Same_Object -- 27864 ----------------- 27865 27866 function Same_Object (Node1, Node2 : Node_Id) return Boolean is 27867 N1 : constant Node_Id := Original_Node (Node1); 27868 N2 : constant Node_Id := Original_Node (Node2); 27869 -- We do the tests on original nodes, since we are most interested 27870 -- in the original source, not any expansion that got in the way. 27871 27872 K1 : constant Node_Kind := Nkind (N1); 27873 K2 : constant Node_Kind := Nkind (N2); 27874 27875 begin 27876 -- First case, both are entities with same entity 27877 27878 if K1 in N_Has_Entity and then K2 in N_Has_Entity then 27879 declare 27880 EN1 : constant Entity_Id := Entity (N1); 27881 EN2 : constant Entity_Id := Entity (N2); 27882 begin 27883 if Present (EN1) and then Present (EN2) 27884 and then (Ekind (EN1) in E_Variable | E_Constant 27885 or else Is_Formal (EN1)) 27886 and then EN1 = EN2 27887 then 27888 return True; 27889 end if; 27890 end; 27891 end if; 27892 27893 -- Second case, selected component with same selector, same record 27894 27895 if K1 = N_Selected_Component 27896 and then K2 = N_Selected_Component 27897 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2)) 27898 then 27899 return Same_Object (Prefix (N1), Prefix (N2)); 27900 27901 -- Third case, indexed component with same subscripts, same array 27902 27903 elsif K1 = N_Indexed_Component 27904 and then K2 = N_Indexed_Component 27905 and then Same_Object (Prefix (N1), Prefix (N2)) 27906 then 27907 declare 27908 E1, E2 : Node_Id; 27909 begin 27910 E1 := First (Expressions (N1)); 27911 E2 := First (Expressions (N2)); 27912 while Present (E1) loop 27913 if not Same_Value (E1, E2) then 27914 return False; 27915 else 27916 Next (E1); 27917 Next (E2); 27918 end if; 27919 end loop; 27920 27921 return True; 27922 end; 27923 27924 -- Fourth case, slice of same array with same bounds 27925 27926 elsif K1 = N_Slice 27927 and then K2 = N_Slice 27928 and then Nkind (Discrete_Range (N1)) = N_Range 27929 and then Nkind (Discrete_Range (N2)) = N_Range 27930 and then Same_Value (Low_Bound (Discrete_Range (N1)), 27931 Low_Bound (Discrete_Range (N2))) 27932 and then Same_Value (High_Bound (Discrete_Range (N1)), 27933 High_Bound (Discrete_Range (N2))) 27934 then 27935 return Same_Name (Prefix (N1), Prefix (N2)); 27936 27937 -- All other cases, not clearly the same object 27938 27939 else 27940 return False; 27941 end if; 27942 end Same_Object; 27943 27944 --------------------------------- 27945 -- Same_Or_Aliased_Subprograms -- 27946 --------------------------------- 27947 27948 function Same_Or_Aliased_Subprograms 27949 (S : Entity_Id; 27950 E : Entity_Id) return Boolean 27951 is 27952 Subp_Alias : constant Entity_Id := Alias (S); 27953 begin 27954 return S = E or else (Present (Subp_Alias) and then Subp_Alias = E); 27955 end Same_Or_Aliased_Subprograms; 27956 27957 --------------- 27958 -- Same_Type -- 27959 --------------- 27960 27961 function Same_Type (T1, T2 : Entity_Id) return Boolean is 27962 begin 27963 if T1 = T2 then 27964 return True; 27965 27966 elsif not Is_Constrained (T1) 27967 and then not Is_Constrained (T2) 27968 and then Base_Type (T1) = Base_Type (T2) 27969 then 27970 return True; 27971 27972 -- For now don't bother with case of identical constraints, to be 27973 -- fiddled with later on perhaps (this is only used for optimization 27974 -- purposes, so it is not critical to do a best possible job) 27975 27976 else 27977 return False; 27978 end if; 27979 end Same_Type; 27980 27981 ---------------- 27982 -- Same_Value -- 27983 ---------------- 27984 27985 function Same_Value (Node1, Node2 : Node_Id) return Boolean is 27986 begin 27987 if Compile_Time_Known_Value (Node1) 27988 and then Compile_Time_Known_Value (Node2) 27989 then 27990 -- Handle properly compile-time expressions that are not 27991 -- scalar. 27992 27993 if Is_String_Type (Etype (Node1)) then 27994 return Expr_Value_S (Node1) = Expr_Value_S (Node2); 27995 27996 else 27997 return Expr_Value (Node1) = Expr_Value (Node2); 27998 end if; 27999 28000 elsif Same_Object (Node1, Node2) then 28001 return True; 28002 else 28003 return False; 28004 end if; 28005 end Same_Value; 28006 28007 -------------------- 28008 -- Set_SPARK_Mode -- 28009 -------------------- 28010 28011 procedure Set_SPARK_Mode (Context : Entity_Id) is 28012 begin 28013 -- Do not consider illegal or partially decorated constructs 28014 28015 if Ekind (Context) = E_Void or else Error_Posted (Context) then 28016 null; 28017 28018 elsif Present (SPARK_Pragma (Context)) then 28019 Install_SPARK_Mode 28020 (Mode => Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Context)), 28021 Prag => SPARK_Pragma (Context)); 28022 end if; 28023 end Set_SPARK_Mode; 28024 28025 ------------------------- 28026 -- Scalar_Part_Present -- 28027 ------------------------- 28028 28029 function Scalar_Part_Present (Typ : Entity_Id) return Boolean is 28030 Val_Typ : constant Entity_Id := Validated_View (Typ); 28031 Field : Entity_Id; 28032 28033 begin 28034 if Is_Scalar_Type (Val_Typ) then 28035 return True; 28036 28037 elsif Is_Array_Type (Val_Typ) then 28038 return Scalar_Part_Present (Component_Type (Val_Typ)); 28039 28040 elsif Is_Record_Type (Val_Typ) then 28041 Field := First_Component_Or_Discriminant (Val_Typ); 28042 while Present (Field) loop 28043 if Scalar_Part_Present (Etype (Field)) then 28044 return True; 28045 end if; 28046 28047 Next_Component_Or_Discriminant (Field); 28048 end loop; 28049 end if; 28050 28051 return False; 28052 end Scalar_Part_Present; 28053 28054 ------------------------ 28055 -- Scope_Is_Transient -- 28056 ------------------------ 28057 28058 function Scope_Is_Transient return Boolean is 28059 begin 28060 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient; 28061 end Scope_Is_Transient; 28062 28063 ------------------ 28064 -- Scope_Within -- 28065 ------------------ 28066 28067 function Scope_Within 28068 (Inner : Entity_Id; 28069 Outer : Entity_Id) return Boolean 28070 is 28071 Curr : Entity_Id; 28072 28073 begin 28074 Curr := Inner; 28075 while Present (Curr) and then Curr /= Standard_Standard loop 28076 Curr := Scope (Curr); 28077 28078 if Curr = Outer then 28079 return True; 28080 28081 -- A selective accept body appears within a task type, but the 28082 -- enclosing subprogram is the procedure of the task body. 28083 28084 elsif Ekind (Implementation_Base_Type (Curr)) = E_Task_Type 28085 and then 28086 Outer = Task_Body_Procedure (Implementation_Base_Type (Curr)) 28087 then 28088 return True; 28089 28090 -- Ditto for the body of a protected operation 28091 28092 elsif Is_Subprogram (Curr) 28093 and then Outer = Protected_Body_Subprogram (Curr) 28094 then 28095 return True; 28096 28097 -- Outside of its scope, a synchronized type may just be private 28098 28099 elsif Is_Private_Type (Curr) 28100 and then Present (Full_View (Curr)) 28101 and then Is_Concurrent_Type (Full_View (Curr)) 28102 then 28103 return Scope_Within (Full_View (Curr), Outer); 28104 end if; 28105 end loop; 28106 28107 return False; 28108 end Scope_Within; 28109 28110 -------------------------- 28111 -- Scope_Within_Or_Same -- 28112 -------------------------- 28113 28114 function Scope_Within_Or_Same 28115 (Inner : Entity_Id; 28116 Outer : Entity_Id) return Boolean 28117 is 28118 Curr : Entity_Id := Inner; 28119 28120 begin 28121 -- Similar to the above, but check for scope identity first 28122 28123 while Present (Curr) and then Curr /= Standard_Standard loop 28124 if Curr = Outer then 28125 return True; 28126 28127 elsif Ekind (Implementation_Base_Type (Curr)) = E_Task_Type 28128 and then 28129 Outer = Task_Body_Procedure (Implementation_Base_Type (Curr)) 28130 then 28131 return True; 28132 28133 elsif Is_Subprogram (Curr) 28134 and then Outer = Protected_Body_Subprogram (Curr) 28135 then 28136 return True; 28137 28138 elsif Is_Private_Type (Curr) 28139 and then Present (Full_View (Curr)) 28140 then 28141 if Full_View (Curr) = Outer then 28142 return True; 28143 else 28144 return Scope_Within (Full_View (Curr), Outer); 28145 end if; 28146 end if; 28147 28148 Curr := Scope (Curr); 28149 end loop; 28150 28151 return False; 28152 end Scope_Within_Or_Same; 28153 28154 ------------------------ 28155 -- Set_Current_Entity -- 28156 ------------------------ 28157 28158 -- The given entity is to be set as the currently visible definition of its 28159 -- associated name (i.e. the Node_Id associated with its name). All we have 28160 -- to do is to get the name from the identifier, and then set the 28161 -- associated Node_Id to point to the given entity. 28162 28163 procedure Set_Current_Entity (E : Entity_Id) is 28164 begin 28165 Set_Name_Entity_Id (Chars (E), E); 28166 end Set_Current_Entity; 28167 28168 --------------------------- 28169 -- Set_Debug_Info_Needed -- 28170 --------------------------- 28171 28172 procedure Set_Debug_Info_Needed (T : Entity_Id) is 28173 28174 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id); 28175 pragma Inline (Set_Debug_Info_Needed_If_Not_Set); 28176 -- Used to set debug info in a related node if not set already 28177 28178 -------------------------------------- 28179 -- Set_Debug_Info_Needed_If_Not_Set -- 28180 -------------------------------------- 28181 28182 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is 28183 begin 28184 if Present (E) and then not Needs_Debug_Info (E) then 28185 Set_Debug_Info_Needed (E); 28186 28187 -- For a private type, indicate that the full view also needs 28188 -- debug information. 28189 28190 if Is_Type (E) 28191 and then Is_Private_Type (E) 28192 and then Present (Full_View (E)) 28193 then 28194 Set_Debug_Info_Needed (Full_View (E)); 28195 end if; 28196 end if; 28197 end Set_Debug_Info_Needed_If_Not_Set; 28198 28199 -- Start of processing for Set_Debug_Info_Needed 28200 28201 begin 28202 -- Nothing to do if there is no available entity 28203 28204 if No (T) then 28205 return; 28206 28207 -- Nothing to do for an entity with suppressed debug information 28208 28209 elsif Debug_Info_Off (T) then 28210 return; 28211 28212 -- Nothing to do for an ignored Ghost entity because the entity will be 28213 -- eliminated from the tree. 28214 28215 elsif Is_Ignored_Ghost_Entity (T) then 28216 return; 28217 28218 -- Nothing to do if entity comes from a predefined file. Library files 28219 -- are compiled without debug information, but inlined bodies of these 28220 -- routines may appear in user code, and debug information on them ends 28221 -- up complicating debugging the user code. 28222 28223 elsif In_Inlined_Body and then In_Predefined_Unit (T) then 28224 Set_Needs_Debug_Info (T, False); 28225 end if; 28226 28227 -- Set flag in entity itself. Note that we will go through the following 28228 -- circuitry even if the flag is already set on T. That's intentional, 28229 -- it makes sure that the flag will be set in subsidiary entities. 28230 28231 Set_Needs_Debug_Info (T); 28232 28233 -- Set flag on subsidiary entities if not set already 28234 28235 if Is_Object (T) then 28236 Set_Debug_Info_Needed_If_Not_Set (Etype (T)); 28237 28238 elsif Is_Type (T) then 28239 Set_Debug_Info_Needed_If_Not_Set (Etype (T)); 28240 28241 if Is_Record_Type (T) then 28242 declare 28243 Ent : Entity_Id := First_Entity (T); 28244 begin 28245 while Present (Ent) loop 28246 Set_Debug_Info_Needed_If_Not_Set (Ent); 28247 Next_Entity (Ent); 28248 end loop; 28249 end; 28250 28251 -- For a class wide subtype, we also need debug information 28252 -- for the equivalent type. 28253 28254 if Ekind (T) = E_Class_Wide_Subtype then 28255 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T)); 28256 end if; 28257 28258 elsif Is_Array_Type (T) then 28259 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T)); 28260 28261 declare 28262 Indx : Node_Id := First_Index (T); 28263 begin 28264 while Present (Indx) loop 28265 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx)); 28266 Next_Index (Indx); 28267 end loop; 28268 end; 28269 28270 -- For a packed array type, we also need debug information for 28271 -- the type used to represent the packed array. Conversely, we 28272 -- also need it for the former if we need it for the latter. 28273 28274 if Is_Packed (T) then 28275 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Impl_Type (T)); 28276 end if; 28277 28278 if Is_Packed_Array_Impl_Type (T) then 28279 Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T)); 28280 end if; 28281 28282 elsif Is_Access_Type (T) then 28283 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T)); 28284 28285 elsif Is_Private_Type (T) then 28286 declare 28287 FV : constant Entity_Id := Full_View (T); 28288 28289 begin 28290 Set_Debug_Info_Needed_If_Not_Set (FV); 28291 28292 -- If the full view is itself a derived private type, we need 28293 -- debug information on its underlying type. 28294 28295 if Present (FV) 28296 and then Is_Private_Type (FV) 28297 and then Present (Underlying_Full_View (FV)) 28298 then 28299 Set_Needs_Debug_Info (Underlying_Full_View (FV)); 28300 end if; 28301 end; 28302 28303 elsif Is_Protected_Type (T) then 28304 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T)); 28305 28306 elsif Is_Scalar_Type (T) then 28307 28308 -- If the subrange bounds are materialized by dedicated constant 28309 -- objects, also include them in the debug info to make sure the 28310 -- debugger can properly use them. 28311 28312 if Present (Scalar_Range (T)) 28313 and then Nkind (Scalar_Range (T)) = N_Range 28314 then 28315 declare 28316 Low_Bnd : constant Node_Id := Type_Low_Bound (T); 28317 High_Bnd : constant Node_Id := Type_High_Bound (T); 28318 28319 begin 28320 if Is_Entity_Name (Low_Bnd) then 28321 Set_Debug_Info_Needed_If_Not_Set (Entity (Low_Bnd)); 28322 end if; 28323 28324 if Is_Entity_Name (High_Bnd) then 28325 Set_Debug_Info_Needed_If_Not_Set (Entity (High_Bnd)); 28326 end if; 28327 end; 28328 end if; 28329 end if; 28330 end if; 28331 end Set_Debug_Info_Needed; 28332 28333 -------------------------------- 28334 -- Set_Debug_Info_Defining_Id -- 28335 -------------------------------- 28336 28337 procedure Set_Debug_Info_Defining_Id (N : Node_Id) is 28338 begin 28339 if Comes_From_Source (Defining_Identifier (N)) then 28340 Set_Debug_Info_Needed (Defining_Identifier (N)); 28341 end if; 28342 end Set_Debug_Info_Defining_Id; 28343 28344 ---------------------------- 28345 -- Set_Entity_With_Checks -- 28346 ---------------------------- 28347 28348 procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id) is 28349 Val_Actual : Entity_Id; 28350 Nod : Node_Id; 28351 Post_Node : Node_Id; 28352 28353 begin 28354 -- Unconditionally set the entity 28355 28356 Set_Entity (N, Val); 28357 28358 -- The node to post on is the selector in the case of an expanded name, 28359 -- and otherwise the node itself. 28360 28361 if Nkind (N) = N_Expanded_Name then 28362 Post_Node := Selector_Name (N); 28363 else 28364 Post_Node := N; 28365 end if; 28366 28367 -- Check for violation of No_Fixed_IO 28368 28369 if Restriction_Check_Required (No_Fixed_IO) 28370 and then 28371 ((RTU_Loaded (Ada_Text_IO) 28372 and then (Is_RTE (Val, RE_Decimal_IO) 28373 or else 28374 Is_RTE (Val, RE_Fixed_IO))) 28375 28376 or else 28377 (RTU_Loaded (Ada_Wide_Text_IO) 28378 and then (Is_RTE (Val, RO_WT_Decimal_IO) 28379 or else 28380 Is_RTE (Val, RO_WT_Fixed_IO))) 28381 28382 or else 28383 (RTU_Loaded (Ada_Wide_Wide_Text_IO) 28384 and then (Is_RTE (Val, RO_WW_Decimal_IO) 28385 or else 28386 Is_RTE (Val, RO_WW_Fixed_IO)))) 28387 28388 -- A special extra check, don't complain about a reference from within 28389 -- the Ada.Interrupts package itself! 28390 28391 and then not In_Same_Extended_Unit (N, Val) 28392 then 28393 Check_Restriction (No_Fixed_IO, Post_Node); 28394 end if; 28395 28396 -- Remaining checks are only done on source nodes. Note that we test 28397 -- for violation of No_Fixed_IO even on non-source nodes, because the 28398 -- cases for checking violations of this restriction are instantiations 28399 -- where the reference in the instance has Comes_From_Source False. 28400 28401 if not Comes_From_Source (N) then 28402 return; 28403 end if; 28404 28405 -- Check for violation of No_Abort_Statements, which is triggered by 28406 -- call to Ada.Task_Identification.Abort_Task. 28407 28408 if Restriction_Check_Required (No_Abort_Statements) 28409 and then (Is_RTE (Val, RE_Abort_Task)) 28410 28411 -- A special extra check, don't complain about a reference from within 28412 -- the Ada.Task_Identification package itself! 28413 28414 and then not In_Same_Extended_Unit (N, Val) 28415 then 28416 Check_Restriction (No_Abort_Statements, Post_Node); 28417 end if; 28418 28419 if Val = Standard_Long_Long_Integer then 28420 Check_Restriction (No_Long_Long_Integers, Post_Node); 28421 end if; 28422 28423 -- Check for violation of No_Dynamic_Attachment 28424 28425 if Restriction_Check_Required (No_Dynamic_Attachment) 28426 and then RTU_Loaded (Ada_Interrupts) 28427 and then (Is_RTE (Val, RE_Is_Reserved) or else 28428 Is_RTE (Val, RE_Is_Attached) or else 28429 Is_RTE (Val, RE_Current_Handler) or else 28430 Is_RTE (Val, RE_Attach_Handler) or else 28431 Is_RTE (Val, RE_Exchange_Handler) or else 28432 Is_RTE (Val, RE_Detach_Handler) or else 28433 Is_RTE (Val, RE_Reference)) 28434 28435 -- A special extra check, don't complain about a reference from within 28436 -- the Ada.Interrupts package itself! 28437 28438 and then not In_Same_Extended_Unit (N, Val) 28439 then 28440 Check_Restriction (No_Dynamic_Attachment, Post_Node); 28441 end if; 28442 28443 -- Check for No_Implementation_Identifiers 28444 28445 if Restriction_Check_Required (No_Implementation_Identifiers) then 28446 28447 -- We have an implementation defined entity if it is marked as 28448 -- implementation defined, or is defined in a package marked as 28449 -- implementation defined. However, library packages themselves 28450 -- are excluded (we don't want to flag Interfaces itself, just 28451 -- the entities within it). 28452 28453 if (Is_Implementation_Defined (Val) 28454 or else 28455 (Present (Scope (Val)) 28456 and then Is_Implementation_Defined (Scope (Val)))) 28457 and then not (Is_Package_Or_Generic_Package (Val) 28458 and then Is_Library_Level_Entity (Val)) 28459 then 28460 Check_Restriction (No_Implementation_Identifiers, Post_Node); 28461 end if; 28462 end if; 28463 28464 -- Do the style check 28465 28466 if Style_Check 28467 and then not Suppress_Style_Checks (Val) 28468 and then not In_Instance 28469 then 28470 if Nkind (N) = N_Identifier then 28471 Nod := N; 28472 elsif Nkind (N) = N_Expanded_Name then 28473 Nod := Selector_Name (N); 28474 else 28475 return; 28476 end if; 28477 28478 -- A special situation arises for derived operations, where we want 28479 -- to do the check against the parent (since the Sloc of the derived 28480 -- operation points to the derived type declaration itself). 28481 28482 Val_Actual := Val; 28483 while not Comes_From_Source (Val_Actual) 28484 and then Nkind (Val_Actual) in N_Entity 28485 and then (Ekind (Val_Actual) = E_Enumeration_Literal 28486 or else Is_Subprogram_Or_Generic_Subprogram (Val_Actual)) 28487 and then Present (Alias (Val_Actual)) 28488 loop 28489 Val_Actual := Alias (Val_Actual); 28490 end loop; 28491 28492 -- Renaming declarations for generic actuals do not come from source, 28493 -- and have a different name from that of the entity they rename, so 28494 -- there is no style check to perform here. 28495 28496 if Chars (Nod) = Chars (Val_Actual) then 28497 Style.Check_Identifier (Nod, Val_Actual); 28498 end if; 28499 end if; 28500 end Set_Entity_With_Checks; 28501 28502 ------------------------------ 28503 -- Set_Invalid_Scalar_Value -- 28504 ------------------------------ 28505 28506 procedure Set_Invalid_Scalar_Value 28507 (Scal_Typ : Float_Scalar_Id; 28508 Value : Ureal) 28509 is 28510 Slot : Ureal renames Invalid_Floats (Scal_Typ); 28511 28512 begin 28513 -- Detect an attempt to set a different value for the same scalar type 28514 28515 pragma Assert (Slot = No_Ureal); 28516 Slot := Value; 28517 end Set_Invalid_Scalar_Value; 28518 28519 ------------------------------ 28520 -- Set_Invalid_Scalar_Value -- 28521 ------------------------------ 28522 28523 procedure Set_Invalid_Scalar_Value 28524 (Scal_Typ : Integer_Scalar_Id; 28525 Value : Uint) 28526 is 28527 Slot : Uint renames Invalid_Integers (Scal_Typ); 28528 28529 begin 28530 -- Detect an attempt to set a different value for the same scalar type 28531 28532 pragma Assert (No (Slot)); 28533 Slot := Value; 28534 end Set_Invalid_Scalar_Value; 28535 28536 ------------------------ 28537 -- Set_Name_Entity_Id -- 28538 ------------------------ 28539 28540 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is 28541 begin 28542 Set_Name_Table_Int (Id, Int (Val)); 28543 end Set_Name_Entity_Id; 28544 28545 --------------------- 28546 -- Set_Next_Actual -- 28547 --------------------- 28548 28549 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is 28550 begin 28551 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then 28552 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id); 28553 end if; 28554 end Set_Next_Actual; 28555 28556 ---------------------------------- 28557 -- Set_Optimize_Alignment_Flags -- 28558 ---------------------------------- 28559 28560 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is 28561 begin 28562 if Optimize_Alignment = 'S' then 28563 Set_Optimize_Alignment_Space (E); 28564 elsif Optimize_Alignment = 'T' then 28565 Set_Optimize_Alignment_Time (E); 28566 end if; 28567 end Set_Optimize_Alignment_Flags; 28568 28569 ----------------------- 28570 -- Set_Public_Status -- 28571 ----------------------- 28572 28573 procedure Set_Public_Status (Id : Entity_Id) is 28574 S : constant Entity_Id := Current_Scope; 28575 28576 function Within_HSS_Or_If (E : Entity_Id) return Boolean; 28577 -- Determines if E is defined within handled statement sequence or 28578 -- an if statement, returns True if so, False otherwise. 28579 28580 ---------------------- 28581 -- Within_HSS_Or_If -- 28582 ---------------------- 28583 28584 function Within_HSS_Or_If (E : Entity_Id) return Boolean is 28585 N : Node_Id; 28586 begin 28587 N := Declaration_Node (E); 28588 loop 28589 N := Parent (N); 28590 28591 if No (N) then 28592 return False; 28593 28594 elsif Nkind (N) in 28595 N_Handled_Sequence_Of_Statements | N_If_Statement 28596 then 28597 return True; 28598 end if; 28599 end loop; 28600 end Within_HSS_Or_If; 28601 28602 -- Start of processing for Set_Public_Status 28603 28604 begin 28605 -- Everything in the scope of Standard is public 28606 28607 if S = Standard_Standard then 28608 Set_Is_Public (Id); 28609 28610 -- Entity is definitely not public if enclosing scope is not public 28611 28612 elsif not Is_Public (S) then 28613 return; 28614 28615 -- An object or function declaration that occurs in a handled sequence 28616 -- of statements or within an if statement is the declaration for a 28617 -- temporary object or local subprogram generated by the expander. It 28618 -- never needs to be made public and furthermore, making it public can 28619 -- cause back end problems. 28620 28621 elsif Nkind (Parent (Id)) in 28622 N_Object_Declaration | N_Function_Specification 28623 and then Within_HSS_Or_If (Id) 28624 then 28625 return; 28626 28627 -- Entities in public packages or records are public 28628 28629 elsif Ekind (S) = E_Package or Is_Record_Type (S) then 28630 Set_Is_Public (Id); 28631 28632 -- The bounds of an entry family declaration can generate object 28633 -- declarations that are visible to the back-end, e.g. in the 28634 -- the declaration of a composite type that contains tasks. 28635 28636 elsif Is_Concurrent_Type (S) 28637 and then not Has_Completion (S) 28638 and then Nkind (Parent (Id)) = N_Object_Declaration 28639 then 28640 Set_Is_Public (Id); 28641 end if; 28642 end Set_Public_Status; 28643 28644 ----------------------------- 28645 -- Set_Referenced_Modified -- 28646 ----------------------------- 28647 28648 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is 28649 Pref : Node_Id; 28650 28651 begin 28652 -- Deal with indexed or selected component where prefix is modified 28653 28654 if Nkind (N) in N_Indexed_Component | N_Selected_Component then 28655 Pref := Prefix (N); 28656 28657 -- If prefix is access type, then it is the designated object that is 28658 -- being modified, which means we have no entity to set the flag on. 28659 28660 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then 28661 return; 28662 28663 -- Otherwise chase the prefix 28664 28665 else 28666 Set_Referenced_Modified (Pref, Out_Param); 28667 end if; 28668 28669 -- Otherwise see if we have an entity name (only other case to process) 28670 28671 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 28672 Set_Referenced_As_LHS (Entity (N), not Out_Param); 28673 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param); 28674 end if; 28675 end Set_Referenced_Modified; 28676 28677 ------------------ 28678 -- Set_Rep_Info -- 28679 ------------------ 28680 28681 procedure Set_Rep_Info (T1 : Entity_Id; T2 : Entity_Id) is 28682 begin 28683 Set_Is_Atomic (T1, Is_Atomic (T2)); 28684 Set_Is_Independent (T1, Is_Independent (T2)); 28685 Set_Is_Volatile_Full_Access (T1, Is_Volatile_Full_Access (T2)); 28686 28687 if Is_Base_Type (T1) then 28688 Set_Is_Volatile (T1, Is_Volatile (T2)); 28689 end if; 28690 end Set_Rep_Info; 28691 28692 ---------------------------- 28693 -- Set_Scope_Is_Transient -- 28694 ---------------------------- 28695 28696 procedure Set_Scope_Is_Transient (V : Boolean := True) is 28697 begin 28698 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V; 28699 end Set_Scope_Is_Transient; 28700 28701 ------------------- 28702 -- Set_Size_Info -- 28703 ------------------- 28704 28705 procedure Set_Size_Info (T1, T2 : Entity_Id) is 28706 begin 28707 -- We copy Esize, but not RM_Size, since in general RM_Size is 28708 -- subtype specific and does not get inherited by all subtypes. 28709 28710 Copy_Esize (To => T1, From => T2); 28711 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2)); 28712 28713 if Is_Discrete_Or_Fixed_Point_Type (T1) 28714 and then 28715 Is_Discrete_Or_Fixed_Point_Type (T2) 28716 then 28717 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2)); 28718 end if; 28719 28720 Copy_Alignment (To => T1, From => T2); 28721 end Set_Size_Info; 28722 28723 ------------------------------ 28724 -- Should_Ignore_Pragma_Par -- 28725 ------------------------------ 28726 28727 function Should_Ignore_Pragma_Par (Prag_Name : Name_Id) return Boolean is 28728 pragma Assert (Compiler_State = Parsing); 28729 -- This one can't work during semantic analysis, because we don't have a 28730 -- correct Current_Source_File. 28731 28732 Result : constant Boolean := 28733 Get_Name_Table_Boolean3 (Prag_Name) 28734 and then not Is_Internal_File_Name 28735 (File_Name (Current_Source_File)); 28736 begin 28737 return Result; 28738 end Should_Ignore_Pragma_Par; 28739 28740 ------------------------------ 28741 -- Should_Ignore_Pragma_Sem -- 28742 ------------------------------ 28743 28744 function Should_Ignore_Pragma_Sem (N : Node_Id) return Boolean is 28745 pragma Assert (Compiler_State = Analyzing); 28746 Prag_Name : constant Name_Id := Pragma_Name (N); 28747 Result : constant Boolean := 28748 Get_Name_Table_Boolean3 (Prag_Name) 28749 and then not In_Internal_Unit (N); 28750 28751 begin 28752 return Result; 28753 end Should_Ignore_Pragma_Sem; 28754 28755 -------------------- 28756 -- Static_Boolean -- 28757 -------------------- 28758 28759 function Static_Boolean (N : Node_Id) return Opt_Ubool is 28760 begin 28761 Analyze_And_Resolve (N, Standard_Boolean); 28762 28763 if N = Error 28764 or else Error_Posted (N) 28765 or else Etype (N) = Any_Type 28766 then 28767 return No_Uint; 28768 end if; 28769 28770 if Is_OK_Static_Expression (N) then 28771 if not Raises_Constraint_Error (N) then 28772 return Expr_Value (N); 28773 else 28774 return No_Uint; 28775 end if; 28776 28777 elsif Etype (N) = Any_Type then 28778 return No_Uint; 28779 28780 else 28781 Flag_Non_Static_Expr 28782 ("static boolean expression required here", N); 28783 return No_Uint; 28784 end if; 28785 end Static_Boolean; 28786 28787 -------------------- 28788 -- Static_Integer -- 28789 -------------------- 28790 28791 function Static_Integer (N : Node_Id) return Uint is 28792 begin 28793 Analyze_And_Resolve (N, Any_Integer); 28794 28795 if N = Error 28796 or else Error_Posted (N) 28797 or else Etype (N) = Any_Type 28798 then 28799 return No_Uint; 28800 end if; 28801 28802 if Is_OK_Static_Expression (N) then 28803 if not Raises_Constraint_Error (N) then 28804 return Expr_Value (N); 28805 else 28806 return No_Uint; 28807 end if; 28808 28809 elsif Etype (N) = Any_Type then 28810 return No_Uint; 28811 28812 else 28813 Flag_Non_Static_Expr 28814 ("static integer expression required here", N); 28815 return No_Uint; 28816 end if; 28817 end Static_Integer; 28818 28819 ------------------------------- 28820 -- Statically_Denotes_Entity -- 28821 ------------------------------- 28822 function Statically_Denotes_Entity (N : Node_Id) return Boolean is 28823 E : Entity_Id; 28824 begin 28825 if not Is_Entity_Name (N) then 28826 return False; 28827 else 28828 E := Entity (N); 28829 end if; 28830 28831 return 28832 Nkind (Parent (E)) /= N_Object_Renaming_Declaration 28833 or else Is_Prival (E) 28834 or else Statically_Denotes_Entity (Renamed_Object (E)); 28835 end Statically_Denotes_Entity; 28836 28837 ------------------------------- 28838 -- Statically_Denotes_Object -- 28839 ------------------------------- 28840 28841 function Statically_Denotes_Object (N : Node_Id) return Boolean is 28842 begin 28843 return Statically_Denotes_Entity (N) 28844 and then Is_Object_Reference (N); 28845 end Statically_Denotes_Object; 28846 28847 -------------------------- 28848 -- Statically_Different -- 28849 -------------------------- 28850 28851 function Statically_Different (E1, E2 : Node_Id) return Boolean is 28852 R1 : constant Node_Id := Get_Referenced_Object (E1); 28853 R2 : constant Node_Id := Get_Referenced_Object (E2); 28854 begin 28855 return Is_Entity_Name (R1) 28856 and then Is_Entity_Name (R2) 28857 and then Entity (R1) /= Entity (R2) 28858 and then not Is_Formal (Entity (R1)) 28859 and then not Is_Formal (Entity (R2)); 28860 end Statically_Different; 28861 28862 ----------------------------- 28863 -- Statically_Names_Object -- 28864 ----------------------------- 28865 28866 function Statically_Names_Object (N : Node_Id) return Boolean is 28867 begin 28868 if Statically_Denotes_Object (N) then 28869 return True; 28870 elsif Is_Entity_Name (N) then 28871 declare 28872 E : constant Entity_Id := Entity (N); 28873 begin 28874 return Nkind (Parent (E)) = N_Object_Renaming_Declaration 28875 and then Statically_Names_Object (Renamed_Object (E)); 28876 end; 28877 end if; 28878 28879 case Nkind (N) is 28880 when N_Indexed_Component => 28881 if Is_Access_Type (Etype (Prefix (N))) then 28882 -- treat implicit dereference same as explicit 28883 return False; 28884 end if; 28885 28886 if not Is_Constrained (Etype (Prefix (N))) then 28887 return False; 28888 end if; 28889 28890 declare 28891 Indx : Node_Id := First_Index (Etype (Prefix (N))); 28892 Expr : Node_Id := First (Expressions (N)); 28893 Index_Subtype : Node_Id; 28894 begin 28895 loop 28896 Index_Subtype := Etype (Indx); 28897 28898 if not Is_Static_Subtype (Index_Subtype) then 28899 return False; 28900 end if; 28901 if not Is_OK_Static_Expression (Expr) then 28902 return False; 28903 end if; 28904 28905 declare 28906 Index_Value : constant Uint := Expr_Value (Expr); 28907 Low_Value : constant Uint := 28908 Expr_Value (Type_Low_Bound (Index_Subtype)); 28909 High_Value : constant Uint := 28910 Expr_Value (Type_High_Bound (Index_Subtype)); 28911 begin 28912 if (Index_Value < Low_Value) 28913 or (Index_Value > High_Value) 28914 then 28915 return False; 28916 end if; 28917 end; 28918 28919 Next_Index (Indx); 28920 Expr := Next (Expr); 28921 pragma Assert ((Present (Indx) = Present (Expr)) 28922 or else (Serious_Errors_Detected > 0)); 28923 exit when not (Present (Indx) and Present (Expr)); 28924 end loop; 28925 end; 28926 28927 when N_Selected_Component => 28928 if Is_Access_Type (Etype (Prefix (N))) then 28929 -- treat implicit dereference same as explicit 28930 return False; 28931 end if; 28932 28933 if Ekind (Entity (Selector_Name (N))) not in 28934 E_Component | E_Discriminant 28935 then 28936 return False; 28937 end if; 28938 28939 declare 28940 Comp : constant Entity_Id := 28941 Original_Record_Component (Entity (Selector_Name (N))); 28942 begin 28943 -- AI12-0373 confirms that we should not call 28944 -- Has_Discriminant_Dependent_Constraint here which would be 28945 -- too strong. 28946 28947 if Is_Declared_Within_Variant (Comp) then 28948 return False; 28949 end if; 28950 end; 28951 28952 when others => -- includes N_Slice, N_Explicit_Dereference 28953 return False; 28954 end case; 28955 28956 pragma Assert (Present (Prefix (N))); 28957 28958 return Statically_Names_Object (Prefix (N)); 28959 end Statically_Names_Object; 28960 28961 --------------------------------- 28962 -- String_From_Numeric_Literal -- 28963 --------------------------------- 28964 28965 function String_From_Numeric_Literal (N : Node_Id) return String_Id is 28966 Loc : constant Source_Ptr := Sloc (N); 28967 Sbuffer : constant Source_Buffer_Ptr := 28968 Source_Text (Get_Source_File_Index (Loc)); 28969 Src_Ptr : Source_Ptr := Loc; 28970 28971 C : Character := Sbuffer (Src_Ptr); 28972 -- Current source program character 28973 28974 function Belongs_To_Numeric_Literal (C : Character) return Boolean; 28975 -- Return True if C belongs to the numeric literal 28976 28977 -------------------------------- 28978 -- Belongs_To_Numeric_Literal -- 28979 -------------------------------- 28980 28981 function Belongs_To_Numeric_Literal (C : Character) return Boolean is 28982 begin 28983 case C is 28984 when '0' .. '9' 28985 | '_' | '.' | 'e' | '#' | 'A' | 'B' | 'C' | 'D' | 'E' | 'F' 28986 => 28987 return True; 28988 28989 -- Make sure '+' or '-' is part of an exponent 28990 28991 when '+' | '-' => 28992 declare 28993 Prev_C : constant Character := Sbuffer (Src_Ptr - 1); 28994 begin 28995 return Prev_C = 'e' or else Prev_C = 'E'; 28996 end; 28997 28998 -- Other characters cannot belong to a numeric literal 28999 29000 when others => 29001 return False; 29002 end case; 29003 end Belongs_To_Numeric_Literal; 29004 29005 -- Start of processing for String_From_Numeric_Literal 29006 29007 begin 29008 Start_String; 29009 while Belongs_To_Numeric_Literal (C) loop 29010 Store_String_Char (C); 29011 Src_Ptr := Src_Ptr + 1; 29012 C := Sbuffer (Src_Ptr); 29013 end loop; 29014 29015 return End_String; 29016 end String_From_Numeric_Literal; 29017 29018 -------------------------------------- 29019 -- Subject_To_Loop_Entry_Attributes -- 29020 -------------------------------------- 29021 29022 function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is 29023 Stmt : Node_Id; 29024 29025 begin 29026 Stmt := N; 29027 29028 -- The expansion mechanism transform a loop subject to at least one 29029 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack 29030 -- the conditional part. 29031 29032 if Nkind (Stmt) in N_Block_Statement | N_If_Statement 29033 and then Nkind (Original_Node (N)) = N_Loop_Statement 29034 then 29035 Stmt := Original_Node (N); 29036 end if; 29037 29038 return 29039 Nkind (Stmt) = N_Loop_Statement 29040 and then Present (Identifier (Stmt)) 29041 and then Present (Entity (Identifier (Stmt))) 29042 and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt))); 29043 end Subject_To_Loop_Entry_Attributes; 29044 29045 ----------------------------- 29046 -- Subprogram_Access_Level -- 29047 ----------------------------- 29048 29049 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is 29050 begin 29051 if Present (Alias (Subp)) then 29052 return Subprogram_Access_Level (Alias (Subp)); 29053 else 29054 return Scope_Depth (Enclosing_Dynamic_Scope (Subp)); 29055 end if; 29056 end Subprogram_Access_Level; 29057 29058 --------------------- 29059 -- Subprogram_Name -- 29060 --------------------- 29061 29062 function Subprogram_Name (N : Node_Id) return String is 29063 Buf : Bounded_String; 29064 Ent : Node_Id := N; 29065 Nod : Node_Id; 29066 29067 begin 29068 while Present (Ent) loop 29069 case Nkind (Ent) is 29070 when N_Subprogram_Body => 29071 Ent := Defining_Unit_Name (Specification (Ent)); 29072 exit; 29073 29074 when N_Subprogram_Declaration => 29075 Nod := Corresponding_Body (Ent); 29076 29077 if Present (Nod) then 29078 Ent := Nod; 29079 else 29080 Ent := Defining_Unit_Name (Specification (Ent)); 29081 end if; 29082 29083 exit; 29084 29085 when N_Subprogram_Instantiation 29086 | N_Package_Body 29087 | N_Package_Specification 29088 => 29089 Ent := Defining_Unit_Name (Ent); 29090 exit; 29091 29092 when N_Protected_Type_Declaration => 29093 Ent := Corresponding_Body (Ent); 29094 exit; 29095 29096 when N_Protected_Body 29097 | N_Task_Body 29098 => 29099 Ent := Defining_Identifier (Ent); 29100 exit; 29101 29102 when others => 29103 null; 29104 end case; 29105 29106 Ent := Parent (Ent); 29107 end loop; 29108 29109 if No (Ent) then 29110 return "unknown subprogram:unknown file:0:0"; 29111 end if; 29112 29113 -- If the subprogram is a child unit, use its simple name to start the 29114 -- construction of the fully qualified name. 29115 29116 if Nkind (Ent) = N_Defining_Program_Unit_Name then 29117 Ent := Defining_Identifier (Ent); 29118 end if; 29119 29120 Append_Entity_Name (Buf, Ent); 29121 29122 -- Append homonym number if needed 29123 29124 if Nkind (N) in N_Entity and then Has_Homonym (N) then 29125 declare 29126 H : Entity_Id := Homonym (N); 29127 Nr : Nat := 1; 29128 29129 begin 29130 while Present (H) loop 29131 if Scope (H) = Scope (N) then 29132 Nr := Nr + 1; 29133 end if; 29134 29135 H := Homonym (H); 29136 end loop; 29137 29138 if Nr > 1 then 29139 Append (Buf, '#'); 29140 Append (Buf, Nr); 29141 end if; 29142 end; 29143 end if; 29144 29145 -- Append source location of Ent to Buf so that the string will 29146 -- look like "subp:file:line:col". 29147 29148 declare 29149 Loc : constant Source_Ptr := Sloc (Ent); 29150 begin 29151 Append (Buf, ':'); 29152 Append (Buf, Reference_Name (Get_Source_File_Index (Loc))); 29153 Append (Buf, ':'); 29154 Append (Buf, Nat (Get_Logical_Line_Number (Loc))); 29155 Append (Buf, ':'); 29156 Append (Buf, Nat (Get_Column_Number (Loc))); 29157 end; 29158 29159 return +Buf; 29160 end Subprogram_Name; 29161 29162 ------------------------------- 29163 -- Support_Atomic_Primitives -- 29164 ------------------------------- 29165 29166 function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is 29167 Size : Int; 29168 29169 begin 29170 -- Verify the alignment of Typ is known 29171 29172 if not Known_Alignment (Typ) then 29173 return False; 29174 end if; 29175 29176 if Known_Static_Esize (Typ) then 29177 Size := UI_To_Int (Esize (Typ)); 29178 29179 -- If the Esize (Object_Size) is unknown at compile time, look at the 29180 -- RM_Size (Value_Size) which may have been set by an explicit rep item. 29181 29182 elsif Known_Static_RM_Size (Typ) then 29183 Size := UI_To_Int (RM_Size (Typ)); 29184 29185 -- Otherwise, the size is considered to be unknown. 29186 29187 else 29188 return False; 29189 end if; 29190 29191 -- Check that the size of the component is 8, 16, 32, or 64 bits and 29192 -- that Typ is properly aligned. 29193 29194 case Size is 29195 when 8 | 16 | 32 | 64 => 29196 return Size = UI_To_Int (Alignment (Typ)) * 8; 29197 29198 when others => 29199 return False; 29200 end case; 29201 end Support_Atomic_Primitives; 29202 29203 ----------------- 29204 -- Trace_Scope -- 29205 ----------------- 29206 29207 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is 29208 begin 29209 if Debug_Flag_W then 29210 for J in 0 .. Scope_Stack.Last loop 29211 Write_Str (" "); 29212 end loop; 29213 29214 Write_Str (Msg); 29215 Write_Name (Chars (E)); 29216 Write_Str (" from "); 29217 Write_Location (Sloc (N)); 29218 Write_Eol; 29219 end if; 29220 end Trace_Scope; 29221 29222 ----------------------- 29223 -- Transfer_Entities -- 29224 ----------------------- 29225 29226 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is 29227 procedure Set_Public_Status_Of (Id : Entity_Id); 29228 -- Set the Is_Public attribute of arbitrary entity Id by calling routine 29229 -- Set_Public_Status. If successful and Id denotes a record type, set 29230 -- the Is_Public attribute of its fields. 29231 29232 -------------------------- 29233 -- Set_Public_Status_Of -- 29234 -------------------------- 29235 29236 procedure Set_Public_Status_Of (Id : Entity_Id) is 29237 Field : Entity_Id; 29238 29239 begin 29240 if not Is_Public (Id) then 29241 Set_Public_Status (Id); 29242 29243 -- When the input entity is a public record type, ensure that all 29244 -- its internal fields are also exposed to the linker. The fields 29245 -- of a class-wide type are never made public. 29246 29247 if Is_Public (Id) 29248 and then Is_Record_Type (Id) 29249 and then not Is_Class_Wide_Type (Id) 29250 then 29251 Field := First_Entity (Id); 29252 while Present (Field) loop 29253 Set_Is_Public (Field); 29254 Next_Entity (Field); 29255 end loop; 29256 end if; 29257 end if; 29258 end Set_Public_Status_Of; 29259 29260 -- Local variables 29261 29262 Full_Id : Entity_Id; 29263 Id : Entity_Id; 29264 29265 -- Start of processing for Transfer_Entities 29266 29267 begin 29268 Id := First_Entity (From); 29269 29270 if Present (Id) then 29271 29272 -- Merge the entity chain of the source scope with that of the 29273 -- destination scope. 29274 29275 if Present (Last_Entity (To)) then 29276 Link_Entities (Last_Entity (To), Id); 29277 else 29278 Set_First_Entity (To, Id); 29279 end if; 29280 29281 Set_Last_Entity (To, Last_Entity (From)); 29282 29283 -- Inspect the entities of the source scope and update their Scope 29284 -- attribute. 29285 29286 while Present (Id) loop 29287 Set_Scope (Id, To); 29288 Set_Public_Status_Of (Id); 29289 29290 -- Handle an internally generated full view for a private type 29291 29292 if Is_Private_Type (Id) 29293 and then Present (Full_View (Id)) 29294 and then Is_Itype (Full_View (Id)) 29295 then 29296 Full_Id := Full_View (Id); 29297 29298 Set_Scope (Full_Id, To); 29299 Set_Public_Status_Of (Full_Id); 29300 end if; 29301 29302 Next_Entity (Id); 29303 end loop; 29304 29305 Set_First_Entity (From, Empty); 29306 Set_Last_Entity (From, Empty); 29307 end if; 29308 end Transfer_Entities; 29309 29310 ------------------------ 29311 -- Traverse_More_Func -- 29312 ------------------------ 29313 29314 function Traverse_More_Func (Node : Node_Id) return Traverse_Final_Result is 29315 29316 Processing_Itype : Boolean := False; 29317 -- Set to True while traversing the nodes under an Itype, to prevent 29318 -- looping on Itype handling during that traversal. 29319 29320 function Process_More (N : Node_Id) return Traverse_Result; 29321 -- Wrapper over the Process callback to handle parts of the AST that 29322 -- are not normally traversed as syntactic children. 29323 29324 function Traverse_Rec (N : Node_Id) return Traverse_Final_Result; 29325 -- Main recursive traversal implemented as an instantiation of 29326 -- Traverse_Func over a modified Process callback. 29327 29328 ------------------ 29329 -- Process_More -- 29330 ------------------ 29331 29332 function Process_More (N : Node_Id) return Traverse_Result is 29333 29334 procedure Traverse_More (N : Node_Id; 29335 Res : in out Traverse_Result); 29336 procedure Traverse_More (L : List_Id; 29337 Res : in out Traverse_Result); 29338 -- Traverse a node or list and update the traversal result to value 29339 -- Abandon when needed. 29340 29341 ------------------- 29342 -- Traverse_More -- 29343 ------------------- 29344 29345 procedure Traverse_More (N : Node_Id; 29346 Res : in out Traverse_Result) 29347 is 29348 begin 29349 -- Do not process any more nodes if Abandon was reached 29350 29351 if Res = Abandon then 29352 return; 29353 end if; 29354 29355 if Traverse_Rec (N) = Abandon then 29356 Res := Abandon; 29357 end if; 29358 end Traverse_More; 29359 29360 procedure Traverse_More (L : List_Id; 29361 Res : in out Traverse_Result) 29362 is 29363 N : Node_Id := First (L); 29364 29365 begin 29366 -- Do not process any more nodes if Abandon was reached 29367 29368 if Res = Abandon then 29369 return; 29370 end if; 29371 29372 while Present (N) loop 29373 Traverse_More (N, Res); 29374 Next (N); 29375 end loop; 29376 end Traverse_More; 29377 29378 -- Local variables 29379 29380 Node : Node_Id; 29381 Result : Traverse_Result; 29382 29383 -- Start of processing for Process_More 29384 29385 begin 29386 -- Initial callback to Process. Return immediately on Skip/Abandon. 29387 -- Otherwise update the value of Node for further processing of 29388 -- non-syntactic children. 29389 29390 Result := Process (N); 29391 29392 case Result is 29393 when OK => Node := N; 29394 when OK_Orig => Node := Original_Node (N); 29395 when Skip => return Skip; 29396 when Abandon => return Abandon; 29397 end case; 29398 29399 -- Process the relevant semantic children which are a logical part of 29400 -- the AST under this node before returning for the processing of 29401 -- syntactic children. 29402 29403 -- Start with all non-syntactic lists of action nodes 29404 29405 case Nkind (Node) is 29406 when N_Component_Association => 29407 Traverse_More (Loop_Actions (Node), Result); 29408 29409 when N_Elsif_Part => 29410 Traverse_More (Condition_Actions (Node), Result); 29411 29412 when N_Short_Circuit => 29413 Traverse_More (Actions (Node), Result); 29414 29415 when N_Case_Expression_Alternative => 29416 Traverse_More (Actions (Node), Result); 29417 29418 when N_Iterated_Component_Association => 29419 Traverse_More (Loop_Actions (Node), Result); 29420 29421 when N_Iteration_Scheme => 29422 Traverse_More (Condition_Actions (Node), Result); 29423 29424 when N_If_Expression => 29425 Traverse_More (Then_Actions (Node), Result); 29426 Traverse_More (Else_Actions (Node), Result); 29427 29428 -- Various nodes have a field Actions as a syntactic node, 29429 -- so it will be traversed in the regular syntactic traversal. 29430 29431 when N_Compilation_Unit_Aux 29432 | N_Compound_Statement 29433 | N_Expression_With_Actions 29434 | N_Freeze_Entity 29435 => 29436 null; 29437 29438 when others => 29439 null; 29440 end case; 29441 29442 -- If Process_Itypes is True, process unattached nodes which come 29443 -- from Itypes. This only concerns currently ranges of scalar 29444 -- (possibly as index) types. This traversal is protected against 29445 -- looping with Processing_Itype. 29446 29447 if Process_Itypes 29448 and then not Processing_Itype 29449 and then Nkind (Node) in N_Has_Etype 29450 and then Present (Etype (Node)) 29451 and then Is_Itype (Etype (Node)) 29452 then 29453 declare 29454 Typ : constant Entity_Id := Etype (Node); 29455 begin 29456 Processing_Itype := True; 29457 29458 case Ekind (Typ) is 29459 when Scalar_Kind => 29460 Traverse_More (Scalar_Range (Typ), Result); 29461 29462 when Array_Kind => 29463 declare 29464 Index : Node_Id := First_Index (Typ); 29465 Rng : Node_Id; 29466 begin 29467 while Present (Index) loop 29468 if Nkind (Index) in N_Has_Entity then 29469 Rng := Scalar_Range (Entity (Index)); 29470 else 29471 Rng := Index; 29472 end if; 29473 29474 Traverse_More (Rng, Result); 29475 Next_Index (Index); 29476 end loop; 29477 end; 29478 when others => 29479 null; 29480 end case; 29481 29482 Processing_Itype := False; 29483 end; 29484 end if; 29485 29486 return Result; 29487 end Process_More; 29488 29489 -- Define Traverse_Rec as a renaming of the instantiation, as an 29490 -- instantiation cannot complete a previous spec. 29491 29492 function Traverse_Recursive is new Traverse_Func (Process_More); 29493 function Traverse_Rec (N : Node_Id) return Traverse_Final_Result 29494 renames Traverse_Recursive; 29495 29496 -- Start of processing for Traverse_More_Func 29497 29498 begin 29499 return Traverse_Rec (Node); 29500 end Traverse_More_Func; 29501 29502 ------------------------ 29503 -- Traverse_More_Proc -- 29504 ------------------------ 29505 29506 procedure Traverse_More_Proc (Node : Node_Id) is 29507 function Traverse is new Traverse_More_Func (Process, Process_Itypes); 29508 Discard : Traverse_Final_Result; 29509 pragma Warnings (Off, Discard); 29510 begin 29511 Discard := Traverse (Node); 29512 end Traverse_More_Proc; 29513 29514 ----------------------- 29515 -- Type_Access_Level -- 29516 ----------------------- 29517 29518 function Type_Access_Level 29519 (Typ : Entity_Id; 29520 Allow_Alt_Model : Boolean := True; 29521 Assoc_Ent : Entity_Id := Empty) return Uint 29522 is 29523 Btyp : Entity_Id := Base_Type (Typ); 29524 Def_Ent : Entity_Id; 29525 29526 begin 29527 -- Ada 2005 (AI-230): For most cases of anonymous access types, we 29528 -- simply use the level where the type is declared. This is true for 29529 -- stand-alone object declarations, and for anonymous access types 29530 -- associated with components the level is the same as that of the 29531 -- enclosing composite type. However, special treatment is needed for 29532 -- the cases of access parameters, return objects of an anonymous access 29533 -- type, and, in Ada 95, access discriminants of limited types. 29534 29535 if Is_Access_Type (Btyp) then 29536 if Ekind (Btyp) = E_Anonymous_Access_Type then 29537 -- No_Dynamic_Accessibility_Checks restriction override for 29538 -- alternative accessibility model. 29539 29540 if Allow_Alt_Model 29541 and then No_Dynamic_Accessibility_Checks_Enabled (Btyp) 29542 then 29543 -- In the -gnatd_b model, the level of an anonymous access 29544 -- type is always that of the designated type. 29545 29546 if Debug_Flag_Underscore_B then 29547 return Type_Access_Level 29548 (Designated_Type (Btyp), Allow_Alt_Model); 29549 end if; 29550 29551 -- When an anonymous access type's Assoc_Ent is specified, 29552 -- calculate the result based on the general accessibility 29553 -- level routine. 29554 29555 -- We would like to use Associated_Node_For_Itype here instead, 29556 -- but in some cases it is not fine grained enough ??? 29557 29558 if Present (Assoc_Ent) then 29559 return Static_Accessibility_Level 29560 (Assoc_Ent, Object_Decl_Level); 29561 end if; 29562 29563 -- Otherwise take the context of the anonymous access type into 29564 -- account. 29565 29566 -- Obtain the defining entity for the internally generated 29567 -- anonymous access type. 29568 29569 Def_Ent := Defining_Entity_Or_Empty 29570 (Associated_Node_For_Itype (Typ)); 29571 29572 if Present (Def_Ent) then 29573 -- When the defining entity is a subprogram then we know the 29574 -- anonymous access type Typ has been generated to either 29575 -- describe an anonymous access type formal or an anonymous 29576 -- access result type. 29577 29578 -- Since we are only interested in the formal case, avoid 29579 -- the anonymous access result type. 29580 29581 if Is_Subprogram (Def_Ent) 29582 and then not (Ekind (Def_Ent) = E_Function 29583 and then Etype (Def_Ent) = Typ) 29584 then 29585 -- When the type comes from an anonymous access 29586 -- parameter, the level is that of the subprogram 29587 -- declaration. 29588 29589 return Scope_Depth (Def_Ent); 29590 29591 -- When the type is an access discriminant, the level is 29592 -- that of the type. 29593 29594 elsif Ekind (Def_Ent) = E_Discriminant then 29595 return Scope_Depth (Scope (Def_Ent)); 29596 end if; 29597 end if; 29598 29599 -- If the type is a nonlocal anonymous access type (such as for 29600 -- an access parameter) we treat it as being declared at the 29601 -- library level to ensure that names such as X.all'access don't 29602 -- fail static accessibility checks. 29603 29604 elsif not Is_Local_Anonymous_Access (Typ) then 29605 return Scope_Depth (Standard_Standard); 29606 29607 -- If this is a return object, the accessibility level is that of 29608 -- the result subtype of the enclosing function. The test here is 29609 -- little complicated, because we have to account for extended 29610 -- return statements that have been rewritten as blocks, in which 29611 -- case we have to find and the Is_Return_Object attribute of the 29612 -- itype's associated object. It would be nice to find a way to 29613 -- simplify this test, but it doesn't seem worthwhile to add a new 29614 -- flag just for purposes of this test. ??? 29615 29616 elsif Ekind (Scope (Btyp)) = E_Return_Statement 29617 or else 29618 (Is_Itype (Btyp) 29619 and then Nkind (Associated_Node_For_Itype (Btyp)) = 29620 N_Object_Declaration 29621 and then Is_Return_Object 29622 (Defining_Identifier 29623 (Associated_Node_For_Itype (Btyp)))) 29624 then 29625 declare 29626 Scop : Entity_Id; 29627 29628 begin 29629 Scop := Scope (Scope (Btyp)); 29630 while Present (Scop) loop 29631 exit when Ekind (Scop) = E_Function; 29632 Scop := Scope (Scop); 29633 end loop; 29634 29635 -- Treat the return object's type as having the level of the 29636 -- function's result subtype (as per RM05-6.5(5.3/2)). 29637 29638 return Type_Access_Level (Etype (Scop), Allow_Alt_Model); 29639 end; 29640 end if; 29641 end if; 29642 29643 Btyp := Root_Type (Btyp); 29644 29645 -- The accessibility level of anonymous access types associated with 29646 -- discriminants is that of the current instance of the type, and 29647 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)). 29648 29649 -- AI-402: access discriminants have accessibility based on the 29650 -- object rather than the type in Ada 2005, so the above paragraph 29651 -- doesn't apply. 29652 29653 -- ??? Needs completion with rules from AI-416 29654 29655 if Ada_Version <= Ada_95 29656 and then Ekind (Typ) = E_Anonymous_Access_Type 29657 and then Present (Associated_Node_For_Itype (Typ)) 29658 and then Nkind (Associated_Node_For_Itype (Typ)) = 29659 N_Discriminant_Specification 29660 then 29661 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1; 29662 end if; 29663 end if; 29664 29665 -- Return library level for a generic formal type. This is done because 29666 -- RM(10.3.2) says that "The statically deeper relationship does not 29667 -- apply to ... a descendant of a generic formal type". Rather than 29668 -- checking at each point where a static accessibility check is 29669 -- performed to see if we are dealing with a formal type, this rule is 29670 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level 29671 -- return extreme values for a formal type; Deepest_Type_Access_Level 29672 -- returns Int'Last. By calling the appropriate function from among the 29673 -- two, we ensure that the static accessibility check will pass if we 29674 -- happen to run into a formal type. More specifically, we should call 29675 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the 29676 -- call occurs as part of a static accessibility check and the error 29677 -- case is the case where the type's level is too shallow (as opposed 29678 -- to too deep). 29679 29680 if Is_Generic_Type (Root_Type (Btyp)) then 29681 return Scope_Depth (Standard_Standard); 29682 end if; 29683 29684 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); 29685 end Type_Access_Level; 29686 29687 ------------------------------------ 29688 -- Type_Without_Stream_Operation -- 29689 ------------------------------------ 29690 29691 function Type_Without_Stream_Operation 29692 (T : Entity_Id; 29693 Op : TSS_Name_Type := TSS_Null) return Entity_Id 29694 is 29695 BT : constant Entity_Id := Base_Type (T); 29696 Op_Missing : Boolean; 29697 29698 begin 29699 if not Restriction_Active (No_Default_Stream_Attributes) then 29700 return Empty; 29701 end if; 29702 29703 if Is_Elementary_Type (T) then 29704 if Op = TSS_Null then 29705 Op_Missing := 29706 No (TSS (BT, TSS_Stream_Read)) 29707 or else No (TSS (BT, TSS_Stream_Write)); 29708 29709 else 29710 Op_Missing := No (TSS (BT, Op)); 29711 end if; 29712 29713 if Op_Missing then 29714 return T; 29715 else 29716 return Empty; 29717 end if; 29718 29719 elsif Is_Array_Type (T) then 29720 return Type_Without_Stream_Operation (Component_Type (T), Op); 29721 29722 elsif Is_Record_Type (T) then 29723 declare 29724 Comp : Entity_Id; 29725 C_Typ : Entity_Id; 29726 29727 begin 29728 Comp := First_Component (T); 29729 while Present (Comp) loop 29730 C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op); 29731 29732 if Present (C_Typ) then 29733 return C_Typ; 29734 end if; 29735 29736 Next_Component (Comp); 29737 end loop; 29738 29739 return Empty; 29740 end; 29741 29742 elsif Is_Private_Type (T) and then Present (Full_View (T)) then 29743 return Type_Without_Stream_Operation (Full_View (T), Op); 29744 else 29745 return Empty; 29746 end if; 29747 end Type_Without_Stream_Operation; 29748 29749 ------------------------------ 29750 -- Ultimate_Overlaid_Entity -- 29751 ------------------------------ 29752 29753 function Ultimate_Overlaid_Entity (E : Entity_Id) return Entity_Id is 29754 Address : Node_Id; 29755 Alias : Entity_Id := E; 29756 Offset : Boolean; 29757 29758 begin 29759 -- Currently this routine is only called for stand-alone objects that 29760 -- have been analysed, since the analysis of the Address aspect is often 29761 -- delayed. 29762 29763 pragma Assert (Ekind (E) in E_Constant | E_Variable); 29764 29765 loop 29766 Address := Address_Clause (Alias); 29767 if Present (Address) then 29768 Find_Overlaid_Entity (Address, Alias, Offset); 29769 if Present (Alias) then 29770 null; 29771 else 29772 return Empty; 29773 end if; 29774 elsif Alias = E then 29775 return Empty; 29776 else 29777 return Alias; 29778 end if; 29779 end loop; 29780 end Ultimate_Overlaid_Entity; 29781 29782 --------------------- 29783 -- Ultimate_Prefix -- 29784 --------------------- 29785 29786 function Ultimate_Prefix (N : Node_Id) return Node_Id is 29787 Pref : Node_Id; 29788 29789 begin 29790 Pref := N; 29791 while Nkind (Pref) in N_Explicit_Dereference 29792 | N_Indexed_Component 29793 | N_Selected_Component 29794 | N_Slice 29795 loop 29796 Pref := Prefix (Pref); 29797 end loop; 29798 29799 return Pref; 29800 end Ultimate_Prefix; 29801 29802 ---------------------------- 29803 -- Unique_Defining_Entity -- 29804 ---------------------------- 29805 29806 function Unique_Defining_Entity (N : Node_Id) return Entity_Id is 29807 begin 29808 return Unique_Entity (Defining_Entity (N)); 29809 end Unique_Defining_Entity; 29810 29811 ------------------- 29812 -- Unique_Entity -- 29813 ------------------- 29814 29815 function Unique_Entity (E : Entity_Id) return Entity_Id is 29816 U : Entity_Id := E; 29817 P : Node_Id; 29818 29819 begin 29820 case Ekind (E) is 29821 when E_Constant => 29822 if Present (Full_View (E)) then 29823 U := Full_View (E); 29824 end if; 29825 29826 when Entry_Kind => 29827 if Nkind (Parent (E)) = N_Entry_Body then 29828 declare 29829 Prot_Item : Entity_Id; 29830 Prot_Type : Entity_Id; 29831 29832 begin 29833 if Ekind (E) = E_Entry then 29834 Prot_Type := Scope (E); 29835 29836 -- Bodies of entry families are nested within an extra scope 29837 -- that contains an entry index declaration. 29838 29839 else 29840 Prot_Type := Scope (Scope (E)); 29841 end if; 29842 29843 -- A protected type may be declared as a private type, in 29844 -- which case we need to get its full view. 29845 29846 if Is_Private_Type (Prot_Type) then 29847 Prot_Type := Full_View (Prot_Type); 29848 end if; 29849 29850 -- Full view may not be present on error, in which case 29851 -- return E by default. 29852 29853 if Present (Prot_Type) then 29854 pragma Assert (Ekind (Prot_Type) = E_Protected_Type); 29855 29856 -- Traverse the entity list of the protected type and 29857 -- locate an entry declaration which matches the entry 29858 -- body. 29859 29860 Prot_Item := First_Entity (Prot_Type); 29861 while Present (Prot_Item) loop 29862 if Ekind (Prot_Item) in Entry_Kind 29863 and then Corresponding_Body (Parent (Prot_Item)) = E 29864 then 29865 U := Prot_Item; 29866 exit; 29867 end if; 29868 29869 Next_Entity (Prot_Item); 29870 end loop; 29871 end if; 29872 end; 29873 end if; 29874 29875 when Formal_Kind => 29876 if Present (Spec_Entity (E)) then 29877 U := Spec_Entity (E); 29878 end if; 29879 29880 when E_Package_Body => 29881 P := Parent (E); 29882 29883 if Nkind (P) = N_Defining_Program_Unit_Name then 29884 P := Parent (P); 29885 end if; 29886 29887 if Nkind (P) = N_Package_Body 29888 and then Present (Corresponding_Spec (P)) 29889 then 29890 U := Corresponding_Spec (P); 29891 29892 elsif Nkind (P) = N_Package_Body_Stub 29893 and then Present (Corresponding_Spec_Of_Stub (P)) 29894 then 29895 U := Corresponding_Spec_Of_Stub (P); 29896 end if; 29897 29898 when E_Protected_Body => 29899 P := Parent (E); 29900 29901 if Nkind (P) = N_Protected_Body 29902 and then Present (Corresponding_Spec (P)) 29903 then 29904 U := Corresponding_Spec (P); 29905 29906 elsif Nkind (P) = N_Protected_Body_Stub 29907 and then Present (Corresponding_Spec_Of_Stub (P)) 29908 then 29909 U := Corresponding_Spec_Of_Stub (P); 29910 29911 if Is_Single_Protected_Object (U) then 29912 U := Etype (U); 29913 end if; 29914 end if; 29915 29916 if Is_Private_Type (U) then 29917 U := Full_View (U); 29918 end if; 29919 29920 when E_Subprogram_Body => 29921 P := Parent (E); 29922 29923 if Nkind (P) = N_Defining_Program_Unit_Name then 29924 P := Parent (P); 29925 end if; 29926 29927 P := Parent (P); 29928 29929 if Nkind (P) = N_Subprogram_Body 29930 and then Present (Corresponding_Spec (P)) 29931 then 29932 U := Corresponding_Spec (P); 29933 29934 elsif Nkind (P) = N_Subprogram_Body_Stub 29935 and then Present (Corresponding_Spec_Of_Stub (P)) 29936 then 29937 U := Corresponding_Spec_Of_Stub (P); 29938 29939 elsif Nkind (P) = N_Subprogram_Renaming_Declaration then 29940 U := Corresponding_Spec (P); 29941 end if; 29942 29943 when E_Task_Body => 29944 P := Parent (E); 29945 29946 if Nkind (P) = N_Task_Body 29947 and then Present (Corresponding_Spec (P)) 29948 then 29949 U := Corresponding_Spec (P); 29950 29951 elsif Nkind (P) = N_Task_Body_Stub 29952 and then Present (Corresponding_Spec_Of_Stub (P)) 29953 then 29954 U := Corresponding_Spec_Of_Stub (P); 29955 29956 if Is_Single_Task_Object (U) then 29957 U := Etype (U); 29958 end if; 29959 end if; 29960 29961 if Is_Private_Type (U) then 29962 U := Full_View (U); 29963 end if; 29964 29965 when Type_Kind => 29966 if Present (Full_View (E)) then 29967 U := Full_View (E); 29968 end if; 29969 29970 when others => 29971 null; 29972 end case; 29973 29974 return U; 29975 end Unique_Entity; 29976 29977 ----------------- 29978 -- Unique_Name -- 29979 ----------------- 29980 29981 function Unique_Name (E : Entity_Id) return String is 29982 29983 -- Local subprograms 29984 29985 function Add_Homonym_Suffix (E : Entity_Id) return String; 29986 29987 function This_Name return String; 29988 29989 ------------------------ 29990 -- Add_Homonym_Suffix -- 29991 ------------------------ 29992 29993 function Add_Homonym_Suffix (E : Entity_Id) return String is 29994 29995 -- Names in E_Subprogram_Body or E_Package_Body entities are not 29996 -- reliable, as they may not include the overloading suffix. 29997 -- Instead, when looking for the name of E or one of its enclosing 29998 -- scope, we get the name of the corresponding Unique_Entity. 29999 30000 U : constant Entity_Id := Unique_Entity (E); 30001 Nam : constant String := Get_Name_String (Chars (U)); 30002 30003 begin 30004 -- If E has homonyms but is not fully qualified, as done in 30005 -- GNATprove mode, append the homonym number on the fly. Strip the 30006 -- leading space character in the image of natural numbers. Also do 30007 -- not print the homonym value of 1. 30008 30009 if Has_Homonym (U) then 30010 declare 30011 N : constant Pos := Homonym_Number (U); 30012 S : constant String := N'Img; 30013 begin 30014 if N > 1 then 30015 return Nam & "__" & S (2 .. S'Last); 30016 end if; 30017 end; 30018 end if; 30019 30020 return Nam; 30021 end Add_Homonym_Suffix; 30022 30023 --------------- 30024 -- This_Name -- 30025 --------------- 30026 30027 function This_Name return String is 30028 begin 30029 return Add_Homonym_Suffix (E); 30030 end This_Name; 30031 30032 -- Local variables 30033 30034 U : constant Entity_Id := Unique_Entity (E); 30035 30036 -- Start of processing for Unique_Name 30037 30038 begin 30039 if E = Standard_Standard 30040 or else Has_Fully_Qualified_Name (E) 30041 then 30042 return This_Name; 30043 30044 elsif Ekind (E) = E_Enumeration_Literal then 30045 return Unique_Name (Etype (E)) & "__" & This_Name; 30046 30047 else 30048 declare 30049 S : constant Entity_Id := Scope (U); 30050 pragma Assert (Present (S)); 30051 30052 begin 30053 -- Prefix names of predefined types with standard__, but leave 30054 -- names of user-defined packages and subprograms without prefix 30055 -- (even if technically they are nested in the Standard package). 30056 30057 if S = Standard_Standard then 30058 if Ekind (U) = E_Package or else Is_Subprogram (U) then 30059 return This_Name; 30060 else 30061 return Unique_Name (S) & "__" & This_Name; 30062 end if; 30063 30064 -- For intances of generic subprograms use the name of the related 30065 -- instance and skip the scope of its wrapper package. 30066 30067 elsif Is_Wrapper_Package (S) then 30068 pragma Assert (Scope (S) = Scope (Related_Instance (S))); 30069 -- Wrapper package and the instantiation are in the same scope 30070 30071 declare 30072 Related_Name : constant String := 30073 Add_Homonym_Suffix (Related_Instance (S)); 30074 Enclosing_Name : constant String := 30075 Unique_Name (Scope (S)) & "__" & Related_Name; 30076 30077 begin 30078 if Is_Subprogram (U) 30079 and then not Is_Generic_Actual_Subprogram (U) 30080 then 30081 return Enclosing_Name; 30082 else 30083 return Enclosing_Name & "__" & This_Name; 30084 end if; 30085 end; 30086 30087 elsif Is_Child_Unit (U) then 30088 return Child_Prefix & Unique_Name (S) & "__" & This_Name; 30089 else 30090 return Unique_Name (S) & "__" & This_Name; 30091 end if; 30092 end; 30093 end if; 30094 end Unique_Name; 30095 30096 --------------------- 30097 -- Unit_Is_Visible -- 30098 --------------------- 30099 30100 function Unit_Is_Visible (U : Entity_Id) return Boolean is 30101 Curr : constant Node_Id := Cunit (Current_Sem_Unit); 30102 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 30103 30104 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean; 30105 -- For a child unit, check whether unit appears in a with_clause 30106 -- of a parent. 30107 30108 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean; 30109 -- Scan the context clause of one compilation unit looking for a 30110 -- with_clause for the unit in question. 30111 30112 ---------------------------- 30113 -- Unit_In_Parent_Context -- 30114 ---------------------------- 30115 30116 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is 30117 begin 30118 if Unit_In_Context (Par_Unit) then 30119 return True; 30120 30121 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then 30122 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit))); 30123 30124 else 30125 return False; 30126 end if; 30127 end Unit_In_Parent_Context; 30128 30129 --------------------- 30130 -- Unit_In_Context -- 30131 --------------------- 30132 30133 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is 30134 Clause : Node_Id; 30135 30136 begin 30137 Clause := First (Context_Items (Comp_Unit)); 30138 while Present (Clause) loop 30139 if Nkind (Clause) = N_With_Clause then 30140 if Library_Unit (Clause) = U then 30141 return True; 30142 30143 -- The with_clause may denote a renaming of the unit we are 30144 -- looking for, eg. Text_IO which renames Ada.Text_IO. 30145 30146 elsif 30147 Renamed_Entity (Entity (Name (Clause))) = 30148 Defining_Entity (Unit (U)) 30149 then 30150 return True; 30151 end if; 30152 end if; 30153 30154 Next (Clause); 30155 end loop; 30156 30157 return False; 30158 end Unit_In_Context; 30159 30160 -- Start of processing for Unit_Is_Visible 30161 30162 begin 30163 -- The currrent unit is directly visible 30164 30165 if Curr = U then 30166 return True; 30167 30168 elsif Unit_In_Context (Curr) then 30169 return True; 30170 30171 -- If the current unit is a body, check the context of the spec 30172 30173 elsif Nkind (Unit (Curr)) = N_Package_Body 30174 or else 30175 (Nkind (Unit (Curr)) = N_Subprogram_Body 30176 and then not Acts_As_Spec (Unit (Curr))) 30177 then 30178 if Unit_In_Context (Library_Unit (Curr)) then 30179 return True; 30180 end if; 30181 end if; 30182 30183 -- If the spec is a child unit, examine the parents 30184 30185 if Is_Child_Unit (Curr_Entity) then 30186 if Nkind (Unit (Curr)) in N_Unit_Body then 30187 return 30188 Unit_In_Parent_Context 30189 (Parent_Spec (Unit (Library_Unit (Curr)))); 30190 else 30191 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr))); 30192 end if; 30193 30194 else 30195 return False; 30196 end if; 30197 end Unit_Is_Visible; 30198 30199 ------------------------------ 30200 -- Universal_Interpretation -- 30201 ------------------------------ 30202 30203 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is 30204 Index : Interp_Index; 30205 It : Interp; 30206 30207 begin 30208 -- The argument may be a formal parameter of an operator or subprogram 30209 -- with multiple interpretations, or else an expression for an actual. 30210 30211 if Nkind (Opnd) = N_Defining_Identifier 30212 or else not Is_Overloaded (Opnd) 30213 then 30214 if Is_Universal_Numeric_Type (Etype (Opnd)) then 30215 return Etype (Opnd); 30216 else 30217 return Empty; 30218 end if; 30219 30220 else 30221 Get_First_Interp (Opnd, Index, It); 30222 while Present (It.Typ) loop 30223 if Is_Universal_Numeric_Type (It.Typ) then 30224 return It.Typ; 30225 end if; 30226 30227 Get_Next_Interp (Index, It); 30228 end loop; 30229 30230 return Empty; 30231 end if; 30232 end Universal_Interpretation; 30233 30234 --------------- 30235 -- Unqualify -- 30236 --------------- 30237 30238 function Unqualify (Expr : Node_Id) return Node_Id is 30239 begin 30240 -- Recurse to handle unlikely case of multiple levels of qualification 30241 30242 if Nkind (Expr) = N_Qualified_Expression then 30243 return Unqualify (Expression (Expr)); 30244 30245 -- Normal case, not a qualified expression 30246 30247 else 30248 return Expr; 30249 end if; 30250 end Unqualify; 30251 30252 ----------------- 30253 -- Unqual_Conv -- 30254 ----------------- 30255 30256 function Unqual_Conv (Expr : Node_Id) return Node_Id is 30257 begin 30258 -- Recurse to handle unlikely case of multiple levels of qualification 30259 -- and/or conversion. 30260 30261 if Nkind (Expr) in N_Qualified_Expression 30262 | N_Type_Conversion 30263 | N_Unchecked_Type_Conversion 30264 then 30265 return Unqual_Conv (Expression (Expr)); 30266 30267 -- Normal case, not a qualified expression 30268 30269 else 30270 return Expr; 30271 end if; 30272 end Unqual_Conv; 30273 30274 -------------------- 30275 -- Validated_View -- 30276 -------------------- 30277 30278 function Validated_View (Typ : Entity_Id) return Entity_Id is 30279 begin 30280 -- Scalar types can be always validated. In fast, switiching to the base 30281 -- type would drop the range constraints and force validation to use a 30282 -- larger type than necessary. 30283 30284 if Is_Scalar_Type (Typ) then 30285 return Typ; 30286 30287 -- Array types can be validated even when they are derived, because 30288 -- validation only requires their bounds and component types to be 30289 -- accessible. In fact, switching to the parent type would pollute 30290 -- expansion of attribute Valid_Scalars with unnecessary conversion 30291 -- that might not be eliminated by the frontend. 30292 30293 elsif Is_Array_Type (Typ) then 30294 return Typ; 30295 30296 -- For other types, in particular for record subtypes, we switch to the 30297 -- base type. 30298 30299 elsif not Is_Base_Type (Typ) then 30300 return Validated_View (Base_Type (Typ)); 30301 30302 -- Obtain the full view of the input type by stripping away concurrency, 30303 -- derivations, and privacy. 30304 30305 elsif Is_Concurrent_Type (Typ) then 30306 if Present (Corresponding_Record_Type (Typ)) then 30307 return Corresponding_Record_Type (Typ); 30308 else 30309 return Typ; 30310 end if; 30311 30312 elsif Is_Derived_Type (Typ) then 30313 return Validated_View (Etype (Typ)); 30314 30315 elsif Is_Private_Type (Typ) then 30316 if Present (Underlying_Full_View (Typ)) then 30317 return Validated_View (Underlying_Full_View (Typ)); 30318 30319 elsif Present (Full_View (Typ)) then 30320 return Validated_View (Full_View (Typ)); 30321 else 30322 return Typ; 30323 end if; 30324 30325 else 30326 return Typ; 30327 end if; 30328 end Validated_View; 30329 30330 ----------------------- 30331 -- Visible_Ancestors -- 30332 ----------------------- 30333 30334 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is 30335 List_1 : Elist_Id; 30336 List_2 : Elist_Id; 30337 Elmt : Elmt_Id; 30338 30339 begin 30340 pragma Assert (Is_Record_Type (Typ) and then Is_Tagged_Type (Typ)); 30341 30342 -- Collect all the parents and progenitors of Typ. If the full-view of 30343 -- private parents and progenitors is available then it is used to 30344 -- generate the list of visible ancestors; otherwise their partial 30345 -- view is added to the resulting list. 30346 30347 Collect_Parents 30348 (T => Typ, 30349 List => List_1, 30350 Use_Full_View => True); 30351 30352 Collect_Interfaces 30353 (T => Typ, 30354 Ifaces_List => List_2, 30355 Exclude_Parents => True, 30356 Use_Full_View => True); 30357 30358 -- Join the two lists. Avoid duplications because an interface may 30359 -- simultaneously be parent and progenitor of a type. 30360 30361 Elmt := First_Elmt (List_2); 30362 while Present (Elmt) loop 30363 Append_Unique_Elmt (Node (Elmt), List_1); 30364 Next_Elmt (Elmt); 30365 end loop; 30366 30367 return List_1; 30368 end Visible_Ancestors; 30369 30370 ---------------------- 30371 -- Within_Init_Proc -- 30372 ---------------------- 30373 30374 function Within_Init_Proc return Boolean is 30375 S : Entity_Id; 30376 30377 begin 30378 S := Current_Scope; 30379 while not Is_Overloadable (S) loop 30380 if S = Standard_Standard then 30381 return False; 30382 else 30383 S := Scope (S); 30384 end if; 30385 end loop; 30386 30387 return Is_Init_Proc (S); 30388 end Within_Init_Proc; 30389 30390 --------------------------- 30391 -- Within_Protected_Type -- 30392 --------------------------- 30393 30394 function Within_Protected_Type (E : Entity_Id) return Boolean is 30395 Scop : Entity_Id := Scope (E); 30396 30397 begin 30398 while Present (Scop) loop 30399 if Ekind (Scop) = E_Protected_Type then 30400 return True; 30401 end if; 30402 30403 Scop := Scope (Scop); 30404 end loop; 30405 30406 return False; 30407 end Within_Protected_Type; 30408 30409 ------------------ 30410 -- Within_Scope -- 30411 ------------------ 30412 30413 function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean is 30414 begin 30415 return Scope_Within_Or_Same (Scope (E), S); 30416 end Within_Scope; 30417 30418 ---------------- 30419 -- Wrong_Type -- 30420 ---------------- 30421 30422 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is 30423 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr)); 30424 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type); 30425 30426 Matching_Field : Entity_Id; 30427 -- Entity to give a more precise suggestion on how to write a one- 30428 -- element positional aggregate. 30429 30430 function Has_One_Matching_Field return Boolean; 30431 -- Determines if Expec_Type is a record type with a single component or 30432 -- discriminant whose type matches the found type or is one dimensional 30433 -- array whose component type matches the found type. In the case of 30434 -- one discriminant, we ignore the variant parts. That's not accurate, 30435 -- but good enough for the warning. 30436 30437 ---------------------------- 30438 -- Has_One_Matching_Field -- 30439 ---------------------------- 30440 30441 function Has_One_Matching_Field return Boolean is 30442 E : Entity_Id; 30443 30444 begin 30445 Matching_Field := Empty; 30446 30447 if Is_Array_Type (Expec_Type) 30448 and then Number_Dimensions (Expec_Type) = 1 30449 and then Covers (Etype (Component_Type (Expec_Type)), Found_Type) 30450 then 30451 -- Use type name if available. This excludes multidimensional 30452 -- arrays and anonymous arrays. 30453 30454 if Comes_From_Source (Expec_Type) then 30455 Matching_Field := Expec_Type; 30456 30457 -- For an assignment, use name of target 30458 30459 elsif Nkind (Parent (Expr)) = N_Assignment_Statement 30460 and then Is_Entity_Name (Name (Parent (Expr))) 30461 then 30462 Matching_Field := Entity (Name (Parent (Expr))); 30463 end if; 30464 30465 return True; 30466 30467 elsif not Is_Record_Type (Expec_Type) then 30468 return False; 30469 30470 else 30471 E := First_Entity (Expec_Type); 30472 loop 30473 if No (E) then 30474 return False; 30475 30476 elsif Ekind (E) not in E_Discriminant | E_Component 30477 or else Chars (E) in Name_uTag | Name_uParent 30478 then 30479 Next_Entity (E); 30480 30481 else 30482 exit; 30483 end if; 30484 end loop; 30485 30486 if not Covers (Etype (E), Found_Type) then 30487 return False; 30488 30489 elsif Present (Next_Entity (E)) 30490 and then (Ekind (E) = E_Component 30491 or else Ekind (Next_Entity (E)) = E_Discriminant) 30492 then 30493 return False; 30494 30495 else 30496 Matching_Field := E; 30497 return True; 30498 end if; 30499 end if; 30500 end Has_One_Matching_Field; 30501 30502 -- Start of processing for Wrong_Type 30503 30504 begin 30505 -- Don't output message if either type is Any_Type, or if a message 30506 -- has already been posted for this node. We need to do the latter 30507 -- check explicitly (it is ordinarily done in Errout), because we 30508 -- are using ! to force the output of the error messages. 30509 30510 if Expec_Type = Any_Type 30511 or else Found_Type = Any_Type 30512 or else Error_Posted (Expr) 30513 then 30514 return; 30515 30516 -- If one of the types is a Taft-Amendment type and the other it its 30517 -- completion, it must be an illegal use of a TAT in the spec, for 30518 -- which an error was already emitted. Avoid cascaded errors. 30519 30520 elsif Is_Incomplete_Type (Expec_Type) 30521 and then Has_Completion_In_Body (Expec_Type) 30522 and then Full_View (Expec_Type) = Etype (Expr) 30523 then 30524 return; 30525 30526 elsif Is_Incomplete_Type (Etype (Expr)) 30527 and then Has_Completion_In_Body (Etype (Expr)) 30528 and then Full_View (Etype (Expr)) = Expec_Type 30529 then 30530 return; 30531 30532 -- In an instance, there is an ongoing problem with completion of 30533 -- types derived from private types. Their structure is what Gigi 30534 -- expects, but the Etype is the parent type rather than the derived 30535 -- private type itself. Do not flag error in this case. The private 30536 -- completion is an entity without a parent, like an Itype. Similarly, 30537 -- full and partial views may be incorrect in the instance. 30538 -- There is no simple way to insure that it is consistent ??? 30539 30540 -- A similar view discrepancy can happen in an inlined body, for the 30541 -- same reason: inserted body may be outside of the original package 30542 -- and only partial views are visible at the point of insertion. 30543 30544 -- If In_Generic_Actual (Expr) is True then we cannot assume that 30545 -- the successful semantic analysis of the generic guarantees anything 30546 -- useful about type checking of this instance, so we ignore 30547 -- In_Instance in that case. There may be cases where this is not 30548 -- right (the symptom would probably be rejecting something 30549 -- that ought to be accepted) but we don't currently have any 30550 -- concrete examples of this. 30551 30552 elsif (In_Instance and then not In_Generic_Actual (Expr)) 30553 or else In_Inlined_Body 30554 then 30555 if Etype (Etype (Expr)) = Etype (Expected_Type) 30556 and then 30557 (Has_Private_Declaration (Expected_Type) 30558 or else Has_Private_Declaration (Etype (Expr))) 30559 and then No (Parent (Expected_Type)) 30560 then 30561 return; 30562 30563 elsif Nkind (Parent (Expr)) = N_Qualified_Expression 30564 and then Entity (Subtype_Mark (Parent (Expr))) = Expected_Type 30565 then 30566 return; 30567 30568 elsif Is_Private_Type (Expected_Type) 30569 and then Present (Full_View (Expected_Type)) 30570 and then Covers (Full_View (Expected_Type), Etype (Expr)) 30571 then 30572 return; 30573 30574 -- Conversely, type of expression may be the private one 30575 30576 elsif Is_Private_Type (Base_Type (Etype (Expr))) 30577 and then Full_View (Base_Type (Etype (Expr))) = Expected_Type 30578 then 30579 return; 30580 end if; 30581 end if; 30582 30583 -- An interesting special check. If the expression is parenthesized 30584 -- and its type corresponds to the type of the sole component of the 30585 -- expected record type, or to the component type of the expected one 30586 -- dimensional array type, then assume we have a bad aggregate attempt. 30587 30588 if Nkind (Expr) in N_Subexpr 30589 and then Paren_Count (Expr) /= 0 30590 and then Has_One_Matching_Field 30591 then 30592 Error_Msg_N ("positional aggregate cannot have one component", Expr); 30593 30594 if Present (Matching_Field) then 30595 if Is_Array_Type (Expec_Type) then 30596 Error_Msg_NE 30597 ("\write instead `&''First ='> ...`", Expr, Matching_Field); 30598 else 30599 Error_Msg_NE 30600 ("\write instead `& ='> ...`", Expr, Matching_Field); 30601 end if; 30602 end if; 30603 30604 -- Another special check, if we are looking for a pool-specific access 30605 -- type and we found an E_Access_Attribute_Type, then we have the case 30606 -- of an Access attribute being used in a context which needs a pool- 30607 -- specific type, which is never allowed. The one extra check we make 30608 -- is that the expected designated type covers the Found_Type. 30609 30610 elsif Is_Access_Type (Expec_Type) 30611 and then Ekind (Found_Type) = E_Access_Attribute_Type 30612 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type 30613 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type 30614 and then Covers 30615 (Designated_Type (Expec_Type), Designated_Type (Found_Type)) 30616 then 30617 Error_Msg_N 30618 ("result must be general access type!", Expr); 30619 Error_Msg_NE -- CODEFIX 30620 ("\add ALL to }!", Expr, Expec_Type); 30621 30622 -- Another special check, if the expected type is an integer type, 30623 -- but the expression is of type System.Address, and the parent is 30624 -- an addition or subtraction operation whose left operand is the 30625 -- expression in question and whose right operand is of an integral 30626 -- type, then this is an attempt at address arithmetic, so give 30627 -- appropriate message. 30628 30629 elsif Is_Integer_Type (Expec_Type) 30630 and then Is_RTE (Found_Type, RE_Address) 30631 and then Nkind (Parent (Expr)) in N_Op_Add | N_Op_Subtract 30632 and then Expr = Left_Opnd (Parent (Expr)) 30633 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr)))) 30634 then 30635 Error_Msg_N 30636 ("address arithmetic not predefined in package System", 30637 Parent (Expr)); 30638 Error_Msg_N 30639 ("\possible missing with/use of System.Storage_Elements", 30640 Parent (Expr)); 30641 return; 30642 30643 -- If the expected type is an anonymous access type, as for access 30644 -- parameters and discriminants, the error is on the designated types. 30645 30646 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then 30647 if Comes_From_Source (Expec_Type) then 30648 Error_Msg_NE ("expected}!", Expr, Expec_Type); 30649 else 30650 Error_Msg_NE 30651 ("expected an access type with designated}", 30652 Expr, Designated_Type (Expec_Type)); 30653 end if; 30654 30655 if Is_Access_Type (Found_Type) 30656 and then not Comes_From_Source (Found_Type) 30657 then 30658 Error_Msg_NE 30659 ("\\found an access type with designated}!", 30660 Expr, Designated_Type (Found_Type)); 30661 else 30662 if From_Limited_With (Found_Type) then 30663 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); 30664 Error_Msg_Qual_Level := 99; 30665 Error_Msg_NE -- CODEFIX 30666 ("\\missing `WITH &;", Expr, Scope (Found_Type)); 30667 Error_Msg_Qual_Level := 0; 30668 else 30669 Error_Msg_NE ("found}!", Expr, Found_Type); 30670 end if; 30671 end if; 30672 30673 -- Normal case of one type found, some other type expected 30674 30675 else 30676 -- If the names of the two types are the same, see if some number 30677 -- of levels of qualification will help. Don't try more than three 30678 -- levels, and if we get to standard, it's no use (and probably 30679 -- represents an error in the compiler) Also do not bother with 30680 -- internal scope names. 30681 30682 declare 30683 Expec_Scope : Entity_Id; 30684 Found_Scope : Entity_Id; 30685 30686 begin 30687 Expec_Scope := Expec_Type; 30688 Found_Scope := Found_Type; 30689 30690 for Levels in Nat range 0 .. 3 loop 30691 if Chars (Expec_Scope) /= Chars (Found_Scope) then 30692 Error_Msg_Qual_Level := Levels; 30693 exit; 30694 end if; 30695 30696 Expec_Scope := Scope (Expec_Scope); 30697 Found_Scope := Scope (Found_Scope); 30698 30699 exit when Expec_Scope = Standard_Standard 30700 or else Found_Scope = Standard_Standard 30701 or else not Comes_From_Source (Expec_Scope) 30702 or else not Comes_From_Source (Found_Scope); 30703 end loop; 30704 end; 30705 30706 if Is_Record_Type (Expec_Type) 30707 and then Present (Corresponding_Remote_Type (Expec_Type)) 30708 then 30709 Error_Msg_NE ("expected}!", Expr, 30710 Corresponding_Remote_Type (Expec_Type)); 30711 else 30712 Error_Msg_NE ("expected}!", Expr, Expec_Type); 30713 end if; 30714 30715 if Is_Entity_Name (Expr) 30716 and then Is_Package_Or_Generic_Package (Entity (Expr)) 30717 then 30718 Error_Msg_N ("\\found package name!", Expr); 30719 30720 elsif Is_Entity_Name (Expr) 30721 and then Ekind (Entity (Expr)) in E_Procedure | E_Generic_Procedure 30722 then 30723 if Ekind (Expec_Type) = E_Access_Subprogram_Type then 30724 Error_Msg_N 30725 ("found procedure name, possibly missing Access attribute!", 30726 Expr); 30727 else 30728 Error_Msg_N 30729 ("\\found procedure name instead of function!", Expr); 30730 end if; 30731 30732 elsif Nkind (Expr) = N_Function_Call 30733 and then Ekind (Expec_Type) = E_Access_Subprogram_Type 30734 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr) 30735 and then No (Parameter_Associations (Expr)) 30736 then 30737 Error_Msg_N 30738 ("found function name, possibly missing Access attribute!", 30739 Expr); 30740 30741 -- Catch common error: a prefix or infix operator which is not 30742 -- directly visible because the type isn't. 30743 30744 elsif Nkind (Expr) in N_Op 30745 and then Is_Overloaded (Expr) 30746 and then not Is_Immediately_Visible (Expec_Type) 30747 and then not Is_Potentially_Use_Visible (Expec_Type) 30748 and then not In_Use (Expec_Type) 30749 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type) 30750 then 30751 Error_Msg_N 30752 ("operator of the type is not directly visible!", Expr); 30753 30754 elsif Ekind (Found_Type) = E_Void 30755 and then Present (Parent (Found_Type)) 30756 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration 30757 then 30758 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type); 30759 30760 else 30761 Error_Msg_NE ("\\found}!", Expr, Found_Type); 30762 end if; 30763 30764 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are 30765 -- of the same modular type, and (M1 and M2) = 0 was intended. 30766 30767 if Expec_Type = Standard_Boolean 30768 and then Is_Modular_Integer_Type (Found_Type) 30769 and then Nkind (Parent (Expr)) in N_Op_And | N_Op_Or | N_Op_Xor 30770 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare 30771 then 30772 declare 30773 Op : constant Node_Id := Right_Opnd (Parent (Expr)); 30774 L : constant Node_Id := Left_Opnd (Op); 30775 R : constant Node_Id := Right_Opnd (Op); 30776 30777 begin 30778 -- The case for the message is when the left operand of the 30779 -- comparison is the same modular type, or when it is an 30780 -- integer literal (or other universal integer expression), 30781 -- which would have been typed as the modular type if the 30782 -- parens had been there. 30783 30784 if (Etype (L) = Found_Type 30785 or else 30786 Etype (L) = Universal_Integer) 30787 and then Is_Integer_Type (Etype (R)) 30788 then 30789 Error_Msg_N 30790 ("\\possible missing parens for modular operation", Expr); 30791 end if; 30792 end; 30793 end if; 30794 30795 -- Reset error message qualification indication 30796 30797 Error_Msg_Qual_Level := 0; 30798 end if; 30799 end Wrong_Type; 30800 30801 -------------------------------- 30802 -- Yields_Synchronized_Object -- 30803 -------------------------------- 30804 30805 function Yields_Synchronized_Object (Typ : Entity_Id) return Boolean is 30806 Has_Sync_Comp : Boolean := False; 30807 Id : Entity_Id; 30808 30809 begin 30810 -- An array type yields a synchronized object if its component type 30811 -- yields a synchronized object. 30812 30813 if Is_Array_Type (Typ) then 30814 return Yields_Synchronized_Object (Component_Type (Typ)); 30815 30816 -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object 30817 -- yields a synchronized object by default. 30818 30819 elsif Is_Descendant_Of_Suspension_Object (Typ) then 30820 return True; 30821 30822 -- A protected type yields a synchronized object by default 30823 30824 elsif Is_Protected_Type (Typ) then 30825 return True; 30826 30827 -- A record type or type extension yields a synchronized object when its 30828 -- discriminants (if any) lack default values and all components are of 30829 -- a type that yields a synchronized object. 30830 30831 elsif Is_Record_Type (Typ) then 30832 30833 -- Inspect all entities defined in the scope of the type, looking for 30834 -- components of a type that does not yield a synchronized object or 30835 -- for discriminants with default values. 30836 30837 Id := First_Entity (Typ); 30838 while Present (Id) loop 30839 if Comes_From_Source (Id) then 30840 if Ekind (Id) = E_Component then 30841 if Yields_Synchronized_Object (Etype (Id)) then 30842 Has_Sync_Comp := True; 30843 30844 -- The component does not yield a synchronized object 30845 30846 else 30847 return False; 30848 end if; 30849 30850 elsif Ekind (Id) = E_Discriminant 30851 and then Present (Expression (Parent (Id))) 30852 then 30853 return False; 30854 end if; 30855 end if; 30856 30857 Next_Entity (Id); 30858 end loop; 30859 30860 -- Ensure that the parent type of a type extension yields a 30861 -- synchronized object. 30862 30863 if Etype (Typ) /= Typ 30864 and then not Is_Private_Type (Etype (Typ)) 30865 and then not Yields_Synchronized_Object (Etype (Typ)) 30866 then 30867 return False; 30868 end if; 30869 30870 -- If we get here, then all discriminants lack default values and all 30871 -- components are of a type that yields a synchronized object. 30872 30873 return Has_Sync_Comp; 30874 30875 -- A synchronized interface type yields a synchronized object by default 30876 30877 elsif Is_Synchronized_Interface (Typ) then 30878 return True; 30879 30880 -- A task type yields a synchronized object by default 30881 30882 elsif Is_Task_Type (Typ) then 30883 return True; 30884 30885 -- A private type yields a synchronized object if its underlying type 30886 -- does. 30887 30888 elsif Is_Private_Type (Typ) 30889 and then Present (Underlying_Type (Typ)) 30890 then 30891 return Yields_Synchronized_Object (Underlying_Type (Typ)); 30892 30893 -- Otherwise the type does not yield a synchronized object 30894 30895 else 30896 return False; 30897 end if; 30898 end Yields_Synchronized_Object; 30899 30900 --------------------------- 30901 -- Yields_Universal_Type -- 30902 --------------------------- 30903 30904 function Yields_Universal_Type (N : Node_Id) return Boolean is 30905 begin 30906 -- Integer and real literals are of a universal type 30907 30908 if Nkind (N) in N_Integer_Literal | N_Real_Literal then 30909 return True; 30910 30911 -- The values of certain attributes are of a universal type 30912 30913 elsif Nkind (N) = N_Attribute_Reference then 30914 return 30915 Universal_Type_Attribute (Get_Attribute_Id (Attribute_Name (N))); 30916 30917 -- ??? There are possibly other cases to consider 30918 30919 else 30920 return False; 30921 end if; 30922 end Yields_Universal_Type; 30923 30924 package body Interval_Lists is 30925 30926 procedure Check_Consistency (Intervals : Discrete_Interval_List); 30927 -- Check that list is sorted, lacks null intervals, and has gaps 30928 -- between intervals. 30929 30930 function Chosen_Interval (Choice : Node_Id) return Discrete_Interval; 30931 -- Given an element of a Discrete_Choices list, a 30932 -- Static_Discrete_Predicate list, or an Others_Discrete_Choices 30933 -- list (but not an N_Others_Choice node) return the corresponding 30934 -- interval. If an element that does not represent a single 30935 -- contiguous interval due to a static predicate (or which 30936 -- represents a single contiguous interval whose bounds depend on 30937 -- a static predicate) is encountered, then that is an error on the 30938 -- part of whoever built the list in question. 30939 30940 function In_Interval 30941 (Value : Uint; Interval : Discrete_Interval) return Boolean; 30942 -- Does the given value lie within the given interval? 30943 30944 procedure Normalize_Interval_List 30945 (List : in out Discrete_Interval_List; Last : out Nat); 30946 -- Perform sorting and merging as required by Check_Consistency 30947 30948 ------------------------- 30949 -- Aggregate_Intervals -- 30950 ------------------------- 30951 30952 function Aggregate_Intervals (N : Node_Id) return Discrete_Interval_List 30953 is 30954 pragma Assert (Nkind (N) = N_Aggregate 30955 and then Is_Array_Type (Etype (N))); 30956 30957 function Unmerged_Intervals_Count return Nat; 30958 -- Count the number of intervals given in the aggregate N; the others 30959 -- choice (if present) is not taken into account. 30960 30961 ------------------------------ 30962 -- Unmerged_Intervals_Count -- 30963 ------------------------------ 30964 30965 function Unmerged_Intervals_Count return Nat is 30966 Count : Nat := 0; 30967 Choice : Node_Id; 30968 Comp : Node_Id; 30969 begin 30970 Comp := First (Component_Associations (N)); 30971 while Present (Comp) loop 30972 Choice := First (Choices (Comp)); 30973 30974 while Present (Choice) loop 30975 if Nkind (Choice) /= N_Others_Choice then 30976 Count := Count + 1; 30977 end if; 30978 30979 Next (Choice); 30980 end loop; 30981 30982 Next (Comp); 30983 end loop; 30984 30985 return Count; 30986 end Unmerged_Intervals_Count; 30987 30988 -- Local variables 30989 30990 Comp : Node_Id; 30991 Max_I : constant Nat := Unmerged_Intervals_Count; 30992 Intervals : Discrete_Interval_List (1 .. Max_I); 30993 Num_I : Nat := 0; 30994 30995 -- Start of processing for Aggregate_Intervals 30996 30997 begin 30998 -- No action needed if there are no intervals 30999 31000 if Max_I = 0 then 31001 return Intervals; 31002 end if; 31003 31004 -- Internally store all the unsorted intervals 31005 31006 Comp := First (Component_Associations (N)); 31007 while Present (Comp) loop 31008 declare 31009 Choice_Intervals : constant Discrete_Interval_List 31010 := Choice_List_Intervals (Choices (Comp)); 31011 begin 31012 for J in Choice_Intervals'Range loop 31013 Num_I := Num_I + 1; 31014 Intervals (Num_I) := Choice_Intervals (J); 31015 end loop; 31016 end; 31017 31018 Next (Comp); 31019 end loop; 31020 31021 -- Normalize the lists sorting and merging the intervals 31022 31023 declare 31024 Aggr_Intervals : Discrete_Interval_List (1 .. Num_I) 31025 := Intervals (1 .. Num_I); 31026 begin 31027 Normalize_Interval_List (Aggr_Intervals, Num_I); 31028 Check_Consistency (Aggr_Intervals (1 .. Num_I)); 31029 return Aggr_Intervals (1 .. Num_I); 31030 end; 31031 end Aggregate_Intervals; 31032 31033 ------------------------ 31034 -- Check_Consistency -- 31035 ------------------------ 31036 31037 procedure Check_Consistency (Intervals : Discrete_Interval_List) is 31038 begin 31039 if Serious_Errors_Detected > 0 then 31040 return; 31041 end if; 31042 31043 -- low bound is 1 and high bound equals length 31044 pragma Assert (Intervals'First = 1 and Intervals'Last >= 0); 31045 for Idx in Intervals'Range loop 31046 -- each interval is non-null 31047 pragma Assert (Intervals (Idx).Low <= Intervals (Idx).High); 31048 if Idx /= Intervals'First then 31049 -- intervals are sorted with non-empty gaps between them 31050 pragma Assert 31051 (Intervals (Idx - 1).High < (Intervals (Idx).Low - 1)); 31052 null; 31053 end if; 31054 end loop; 31055 end Check_Consistency; 31056 31057 --------------------------- 31058 -- Choice_List_Intervals -- 31059 --------------------------- 31060 31061 function Choice_List_Intervals 31062 (Discrete_Choices : List_Id) return Discrete_Interval_List 31063 is 31064 function Unmerged_Choice_Count return Nat; 31065 -- The number of intervals before adjacent intervals are merged 31066 31067 --------------------------- 31068 -- Unmerged_Choice_Count -- 31069 --------------------------- 31070 31071 function Unmerged_Choice_Count return Nat is 31072 Choice : Node_Id := First (Discrete_Choices); 31073 Count : Nat := 0; 31074 begin 31075 while Present (Choice) loop 31076 -- Non-contiguous choices involving static predicates 31077 -- have already been normalized away. 31078 31079 if Nkind (Choice) = N_Others_Choice then 31080 Count := 31081 Count + List_Length (Others_Discrete_Choices (Choice)); 31082 else 31083 Count := Count + 1; -- an ordinary expression or range 31084 end if; 31085 31086 Next (Choice); 31087 end loop; 31088 return Count; 31089 end Unmerged_Choice_Count; 31090 31091 -- Local variables 31092 31093 Choice : Node_Id := First (Discrete_Choices); 31094 Result : Discrete_Interval_List (1 .. Unmerged_Choice_Count); 31095 Count : Nat := 0; 31096 31097 -- Start of processing for Choice_List_Intervals 31098 31099 begin 31100 while Present (Choice) loop 31101 if Nkind (Choice) = N_Others_Choice then 31102 declare 31103 Others_Choice : Node_Id 31104 := First (Others_Discrete_Choices (Choice)); 31105 begin 31106 while Present (Others_Choice) loop 31107 Count := Count + 1; 31108 Result (Count) := Chosen_Interval (Others_Choice); 31109 Next (Others_Choice); 31110 end loop; 31111 end; 31112 else 31113 Count := Count + 1; 31114 Result (Count) := Chosen_Interval (Choice); 31115 end if; 31116 31117 Next (Choice); 31118 end loop; 31119 31120 pragma Assert (Count = Result'Last); 31121 Normalize_Interval_List (Result, Count); 31122 Check_Consistency (Result (1 .. Count)); 31123 return Result (1 .. Count); 31124 end Choice_List_Intervals; 31125 31126 --------------------- 31127 -- Chosen_Interval -- 31128 --------------------- 31129 31130 function Chosen_Interval (Choice : Node_Id) return Discrete_Interval is 31131 begin 31132 case Nkind (Choice) is 31133 when N_Range => 31134 return (Low => Expr_Value (Low_Bound (Choice)), 31135 High => Expr_Value (High_Bound (Choice))); 31136 31137 when N_Subtype_Indication => 31138 declare 31139 Range_Exp : constant Node_Id 31140 := Range_Expression (Constraint (Choice)); 31141 begin 31142 return (Low => Expr_Value (Low_Bound (Range_Exp)), 31143 High => Expr_Value (High_Bound (Range_Exp))); 31144 end; 31145 31146 when N_Others_Choice => 31147 raise Program_Error; 31148 31149 when others => 31150 if Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)) 31151 then 31152 return 31153 (Low => Expr_Value (Type_Low_Bound (Entity (Choice))), 31154 High => Expr_Value (Type_High_Bound (Entity (Choice)))); 31155 else 31156 -- an expression 31157 return (Low | High => Expr_Value (Choice)); 31158 end if; 31159 end case; 31160 end Chosen_Interval; 31161 31162 ----------------- 31163 -- In_Interval -- 31164 ----------------- 31165 31166 function In_Interval 31167 (Value : Uint; Interval : Discrete_Interval) return Boolean is 31168 begin 31169 return Value >= Interval.Low and then Value <= Interval.High; 31170 end In_Interval; 31171 31172 --------------- 31173 -- Is_Subset -- 31174 --------------- 31175 31176 function Is_Subset 31177 (Subset, Of_Set : Discrete_Interval_List) return Boolean 31178 is 31179 -- Returns True iff for each interval of Subset we can find 31180 -- a single interval of Of_Set which contains the Subset interval. 31181 begin 31182 if Of_Set'Length = 0 then 31183 return Subset'Length = 0; 31184 end if; 31185 31186 declare 31187 Set_Index : Pos range Of_Set'Range := Of_Set'First; 31188 31189 begin 31190 for Ss_Idx in Subset'Range loop 31191 while not In_Interval 31192 (Value => Subset (Ss_Idx).Low, 31193 Interval => Of_Set (Set_Index)) 31194 loop 31195 if Set_Index = Of_Set'Last then 31196 return False; 31197 end if; 31198 31199 Set_Index := Set_Index + 1; 31200 end loop; 31201 31202 if not In_Interval 31203 (Value => Subset (Ss_Idx).High, 31204 Interval => Of_Set (Set_Index)) 31205 then 31206 return False; 31207 end if; 31208 end loop; 31209 end; 31210 31211 return True; 31212 end Is_Subset; 31213 31214 ----------------------------- 31215 -- Normalize_Interval_List -- 31216 ----------------------------- 31217 31218 procedure Normalize_Interval_List 31219 (List : in out Discrete_Interval_List; Last : out Nat) 31220 is 31221 Temp_0 : Discrete_Interval := (others => Uint_0); 31222 -- Cope with Heap_Sort_G idiosyncrasies. 31223 31224 function Is_Null (Idx : Pos) return Boolean; 31225 -- True iff List (Idx) defines a null range 31226 31227 function Lt_Interval (Idx1, Idx2 : Natural) return Boolean; 31228 -- Compare two list elements 31229 31230 procedure Merge_Intervals (Null_Interval_Count : out Nat); 31231 -- Merge contiguous ranges by replacing one with merged range and 31232 -- the other with a null value. Return a count of the null intervals, 31233 -- both preexisting and those introduced by merging. 31234 31235 procedure Move_Interval (From, To : Natural); 31236 -- Copy interval from one location to another 31237 31238 function Read_Interval (From : Natural) return Discrete_Interval; 31239 -- Normal array indexing unless From = 0 31240 31241 ---------------------- 31242 -- Interval_Sorting -- 31243 ---------------------- 31244 31245 package Interval_Sorting is 31246 new Gnat.Heap_Sort_G (Move_Interval, Lt_Interval); 31247 31248 ------------- 31249 -- Is_Null -- 31250 ------------- 31251 31252 function Is_Null (Idx : Pos) return Boolean is 31253 begin 31254 return List (Idx).Low > List (Idx).High; 31255 end Is_Null; 31256 31257 ----------------- 31258 -- Lt_Interval -- 31259 ----------------- 31260 31261 function Lt_Interval (Idx1, Idx2 : Natural) return Boolean is 31262 Elem1 : constant Discrete_Interval := Read_Interval (Idx1); 31263 Elem2 : constant Discrete_Interval := Read_Interval (Idx2); 31264 Null_1 : constant Boolean := Elem1.Low > Elem1.High; 31265 Null_2 : constant Boolean := Elem2.Low > Elem2.High; 31266 begin 31267 if Null_1 /= Null_2 then 31268 -- So that sorting moves null intervals to high end 31269 return Null_2; 31270 31271 elsif Elem1.Low /= Elem2.Low then 31272 return Elem1.Low < Elem2.Low; 31273 31274 else 31275 return Elem1.High < Elem2.High; 31276 end if; 31277 end Lt_Interval; 31278 31279 --------------------- 31280 -- Merge_Intervals -- 31281 --------------------- 31282 31283 procedure Merge_Intervals (Null_Interval_Count : out Nat) is 31284 Not_Null : Pos range List'Range; 31285 -- Index of the most recently examined non-null interval 31286 31287 Null_Interval : constant Discrete_Interval 31288 := (Low => Uint_1, High => Uint_0); -- any null range ok here 31289 begin 31290 if List'Length = 0 or else Is_Null (List'First) then 31291 Null_Interval_Count := List'Length; 31292 -- no non-null elements, so no merge candidates 31293 return; 31294 end if; 31295 31296 Null_Interval_Count := 0; 31297 Not_Null := List'First; 31298 31299 for Idx in List'First + 1 .. List'Last loop 31300 if Is_Null (Idx) then 31301 31302 -- all remaining elements are null 31303 31304 Null_Interval_Count := 31305 Null_Interval_Count + List (Idx .. List'Last)'Length; 31306 return; 31307 31308 elsif List (Idx).Low = List (Not_Null).High + 1 then 31309 31310 -- Merge the two intervals into one; discard the other 31311 31312 List (Not_Null).High := List (Idx).High; 31313 List (Idx) := Null_Interval; 31314 Null_Interval_Count := Null_Interval_Count + 1; 31315 31316 else 31317 if List (Idx).Low <= List (Not_Null).High then 31318 raise Intervals_Error; 31319 end if; 31320 31321 pragma Assert (List (Idx).Low > List (Not_Null).High); 31322 Not_Null := Idx; 31323 end if; 31324 end loop; 31325 end Merge_Intervals; 31326 31327 ------------------- 31328 -- Move_Interval -- 31329 ------------------- 31330 31331 procedure Move_Interval (From, To : Natural) is 31332 Rhs : constant Discrete_Interval := Read_Interval (From); 31333 begin 31334 if To = 0 then 31335 Temp_0 := Rhs; 31336 else 31337 List (Pos (To)) := Rhs; 31338 end if; 31339 end Move_Interval; 31340 31341 ------------------- 31342 -- Read_Interval -- 31343 ------------------- 31344 31345 function Read_Interval (From : Natural) return Discrete_Interval is 31346 begin 31347 if From = 0 then 31348 return Temp_0; 31349 else 31350 return List (Pos (From)); 31351 end if; 31352 end Read_Interval; 31353 31354 -- Start of processing for Normalize_Interval_Lists 31355 31356 begin 31357 Interval_Sorting.Sort (Natural (List'Last)); 31358 31359 declare 31360 Null_Interval_Count : Nat; 31361 31362 begin 31363 Merge_Intervals (Null_Interval_Count); 31364 Last := List'Last - Null_Interval_Count; 31365 31366 if Null_Interval_Count /= 0 then 31367 -- Move null intervals introduced during merging to high end 31368 Interval_Sorting.Sort (Natural (List'Last)); 31369 end if; 31370 end; 31371 end Normalize_Interval_List; 31372 31373 -------------------- 31374 -- Type_Intervals -- 31375 -------------------- 31376 31377 function Type_Intervals (Typ : Entity_Id) return Discrete_Interval_List 31378 is 31379 begin 31380 if Has_Static_Predicate (Typ) then 31381 declare 31382 -- No sorting or merging needed 31383 SDP_List : constant List_Id := Static_Discrete_Predicate (Typ); 31384 Range_Or_Expr : Node_Id := First (SDP_List); 31385 Result : Discrete_Interval_List (1 .. List_Length (SDP_List)); 31386 31387 begin 31388 for Idx in Result'Range loop 31389 Result (Idx) := Chosen_Interval (Range_Or_Expr); 31390 Next (Range_Or_Expr); 31391 end loop; 31392 31393 pragma Assert (not Present (Range_Or_Expr)); 31394 Check_Consistency (Result); 31395 return Result; 31396 end; 31397 else 31398 declare 31399 Low : constant Uint := Expr_Value (Type_Low_Bound (Typ)); 31400 High : constant Uint := Expr_Value (Type_High_Bound (Typ)); 31401 begin 31402 if Low > High then 31403 declare 31404 Null_Array : Discrete_Interval_List (1 .. 0); 31405 begin 31406 return Null_Array; 31407 end; 31408 else 31409 return (1 => (Low => Low, High => High)); 31410 end if; 31411 end; 31412 end if; 31413 end Type_Intervals; 31414 31415 end Interval_Lists; 31416 31417 package body Old_Attr_Util is 31418 package body Conditional_Evaluation is 31419 type Determining_Expr_Context is 31420 (No_Context, If_Expr, Case_Expr, Short_Circuit_Op, Membership_Test); 31421 31422 -- Determining_Expr_Context enumeration elements (except for 31423 -- No_Context) correspond to the list items in RM 6.1.1 definition 31424 -- of "determining expression". 31425 31426 type Determining_Expr 31427 (Context : Determining_Expr_Context := No_Context) 31428 is record 31429 Expr : Node_Id := Empty; 31430 case Context is 31431 when Short_Circuit_Op => 31432 Is_And_Then : Boolean; 31433 when If_Expr => 31434 Is_Then_Part : Boolean; 31435 when Case_Expr => 31436 Alternatives : Node_Id; 31437 when Membership_Test => 31438 -- Given a subexpression of <exp4> in a membership test 31439 -- <exp1> in <exp2> | <exp3> | <exp4> | <exp5> 31440 -- the corresponding determining expression value would 31441 -- have First_Non_Preceding = <exp4> (See RM 6.1.1). 31442 First_Non_Preceding : Node_Id; 31443 when No_Context => 31444 null; 31445 end case; 31446 end record; 31447 31448 type Determining_Expression_List is 31449 array (Positive range <>) of Determining_Expr; 31450 31451 function Determining_Condition (Det : Determining_Expr) 31452 return Node_Id; 31453 -- Given a determining expression, build a Boolean-valued 31454 -- condition that incorporates that expression into condition 31455 -- suitable for deciding whether to initialize a 'Old constant. 31456 -- Polarity is "True => initialize the constant". 31457 31458 function Determining_Expressions 31459 (Expr : Node_Id; Expr_Trailer : Node_Id := Empty) 31460 return Determining_Expression_List; 31461 -- Given a conditionally evaluated expression, return its 31462 -- determining expressions. 31463 -- See RM 6.1.1 for definition of term "determining expressions". 31464 -- Tests should be performed in the order they occur in the 31465 -- array, with short circuiting. 31466 -- A determining expression need not be of a boolean type (e.g., 31467 -- it might be the determining expression of a case expression). 31468 -- The Expr_Trailer parameter should be defaulted for nonrecursive 31469 -- calls. 31470 31471 function Is_Conditionally_Evaluated (Expr : Node_Id) return Boolean; 31472 -- See RM 6.1.1 for definition of term "conditionally evaluated". 31473 31474 function Is_Known_On_Entry (Expr : Node_Id) return Boolean; 31475 -- See RM 6.1.1 for definition of term "known on entry". 31476 31477 -------------------------------------- 31478 -- Conditional_Evaluation_Condition -- 31479 -------------------------------------- 31480 31481 function Conditional_Evaluation_Condition 31482 (Expr : Node_Id) return Node_Id 31483 is 31484 Determiners : constant Determining_Expression_List := 31485 Determining_Expressions (Expr); 31486 Loc : constant Source_Ptr := Sloc (Expr); 31487 Result : Node_Id := 31488 New_Occurrence_Of (Standard_True, Loc); 31489 begin 31490 pragma Assert (Determiners'Length > 0 or else 31491 Is_Anonymous_Access_Type (Etype (Expr))); 31492 31493 for I in Determiners'Range loop 31494 Result := Make_And_Then 31495 (Loc, 31496 Left_Opnd => Result, 31497 Right_Opnd => 31498 Determining_Condition (Determiners (I))); 31499 end loop; 31500 return Result; 31501 end Conditional_Evaluation_Condition; 31502 31503 --------------------------- 31504 -- Determining_Condition -- 31505 --------------------------- 31506 31507 function Determining_Condition (Det : Determining_Expr) return Node_Id 31508 is 31509 Loc : constant Source_Ptr := Sloc (Det.Expr); 31510 begin 31511 case Det.Context is 31512 when Short_Circuit_Op => 31513 if Det.Is_And_Then then 31514 return New_Copy_Tree (Det.Expr); 31515 else 31516 return Make_Op_Not (Loc, New_Copy_Tree (Det.Expr)); 31517 end if; 31518 31519 when If_Expr => 31520 if Det.Is_Then_Part then 31521 return New_Copy_Tree (Det.Expr); 31522 else 31523 return Make_Op_Not (Loc, New_Copy_Tree (Det.Expr)); 31524 end if; 31525 31526 when Case_Expr => 31527 declare 31528 Alts : List_Id := Discrete_Choices (Det.Alternatives); 31529 begin 31530 if Nkind (First (Alts)) = N_Others_Choice then 31531 Alts := Others_Discrete_Choices (First (Alts)); 31532 end if; 31533 31534 return Make_In (Loc, 31535 Left_Opnd => New_Copy_Tree (Det.Expr), 31536 Right_Opnd => Empty, 31537 Alternatives => New_Copy_List (Alts)); 31538 end; 31539 31540 when Membership_Test => 31541 declare 31542 function Copy_Prefix 31543 (List : List_Id; Suffix_Start : Node_Id) 31544 return List_Id; 31545 -- Given a list and a member of that list, returns 31546 -- a copy (similar to Nlists.New_Copy_List) of the 31547 -- prefix of the list up to but not including 31548 -- Suffix_Start. 31549 31550 ----------------- 31551 -- Copy_Prefix -- 31552 ----------------- 31553 31554 function Copy_Prefix 31555 (List : List_Id; Suffix_Start : Node_Id) 31556 return List_Id 31557 is 31558 Result : constant List_Id := New_List; 31559 Elem : Node_Id := First (List); 31560 begin 31561 while Elem /= Suffix_Start loop 31562 Append (New_Copy (Elem), Result); 31563 Next (Elem); 31564 pragma Assert (Present (Elem)); 31565 end loop; 31566 return Result; 31567 end Copy_Prefix; 31568 31569 begin 31570 return Make_In (Loc, 31571 Left_Opnd => New_Copy_Tree (Left_Opnd (Det.Expr)), 31572 Right_Opnd => Empty, 31573 Alternatives => Copy_Prefix 31574 (Alternatives (Det.Expr), 31575 Det.First_Non_Preceding)); 31576 end; 31577 31578 when No_Context => 31579 raise Program_Error; 31580 end case; 31581 end Determining_Condition; 31582 31583 ----------------------------- 31584 -- Determining_Expressions -- 31585 ----------------------------- 31586 31587 function Determining_Expressions 31588 (Expr : Node_Id; Expr_Trailer : Node_Id := Empty) 31589 return Determining_Expression_List 31590 is 31591 Par : Node_Id := Expr; 31592 Trailer : Node_Id := Expr_Trailer; 31593 Next_Element : Determining_Expr; 31594 begin 31595 -- We want to stop climbing up the tree when we reach the 31596 -- postcondition expression. An aspect_specification is 31597 -- transformed into a pragma, so reaching a pragma is our 31598 -- termination condition. This relies on the fact that 31599 -- pragmas are not allowed in declare expressions (or any 31600 -- other kind of expression). 31601 31602 loop 31603 Next_Element.Expr := Empty; 31604 31605 case Nkind (Par) is 31606 when N_Short_Circuit => 31607 if Trailer = Right_Opnd (Par) then 31608 Next_Element := 31609 (Expr => Left_Opnd (Par), 31610 Context => Short_Circuit_Op, 31611 Is_And_Then => Nkind (Par) = N_And_Then); 31612 end if; 31613 31614 when N_If_Expression => 31615 -- For an expression like 31616 -- (if C1 then ... elsif C2 then ... else Foo'Old) 31617 -- the RM says are two determining expressions, 31618 -- C1 and C2. Our treatment here (where we only add 31619 -- one determining expression to the list) is ok because 31620 -- we will see two if-expressions, one within the other. 31621 31622 if Trailer /= First (Expressions (Par)) then 31623 Next_Element := 31624 (Expr => First (Expressions (Par)), 31625 Context => If_Expr, 31626 Is_Then_Part => 31627 Trailer = Next (First (Expressions (Par)))); 31628 end if; 31629 31630 when N_Case_Expression_Alternative => 31631 pragma Assert (Nkind (Parent (Par)) = N_Case_Expression); 31632 31633 Next_Element := 31634 (Expr => Expression (Parent (Par)), 31635 Context => Case_Expr, 31636 Alternatives => Par); 31637 31638 when N_Membership_Test => 31639 if Trailer /= Left_Opnd (Par) 31640 and then Is_Non_Empty_List (Alternatives (Par)) 31641 and then Trailer /= First (Alternatives (Par)) 31642 then 31643 pragma Assert (not Present (Right_Opnd (Par))); 31644 pragma Assert 31645 (Is_List_Member (Trailer) 31646 and then List_Containing (Trailer) 31647 = Alternatives (Par)); 31648 31649 -- This one is different than the others 31650 -- because one element in the array result 31651 -- may represent multiple determining 31652 -- expressions (i.e. every member of the list 31653 -- Alternatives (Par) 31654 -- up to but not including Trailer). 31655 31656 Next_Element := 31657 (Expr => Par, 31658 Context => Membership_Test, 31659 First_Non_Preceding => Trailer); 31660 end if; 31661 31662 when N_Pragma => 31663 declare 31664 Previous : constant Node_Id := Prev (Par); 31665 Prev_Expr : Node_Id; 31666 begin 31667 if Nkind (Previous) = N_Pragma and then 31668 Split_PPC (Previous) 31669 then 31670 -- A source-level postcondition of 31671 -- A and then B and then C 31672 -- results in 31673 -- pragma Postcondition (A); 31674 -- pragma Postcondition (B); 31675 -- pragma Postcondition (C); 31676 -- with Split_PPC set to True on all but the 31677 -- last pragma. We account for that here. 31678 31679 Prev_Expr := 31680 Expression (First 31681 (Pragma_Argument_Associations (Previous))); 31682 31683 -- This Analyze call is needed in the case when 31684 -- Sem_Attr.Analyze_Attribute calls 31685 -- Eligible_For_Conditional_Evaluation. Without 31686 -- it, we end up passing an unanalyzed expression 31687 -- to Is_Known_On_Entry and that doesn't work. 31688 31689 Analyze (Prev_Expr); 31690 31691 Next_Element := 31692 (Expr => Prev_Expr, 31693 Context => Short_Circuit_Op, 31694 Is_And_Then => True); 31695 31696 return Determining_Expressions (Prev_Expr) 31697 & Next_Element; 31698 else 31699 pragma Assert 31700 (Get_Pragma_Id (Pragma_Name (Par)) in 31701 Pragma_Post | Pragma_Postcondition 31702 | Pragma_Post_Class | Pragma_Refined_Post 31703 | Pragma_Check | Pragma_Contract_Cases); 31704 31705 return (1 .. 0 => <>); -- recursion terminates here 31706 end if; 31707 end; 31708 31709 when N_Empty => 31710 -- This case should be impossible, but if it does 31711 -- happen somehow then we don't want an infinite loop. 31712 raise Program_Error; 31713 31714 when others => 31715 null; 31716 end case; 31717 31718 Trailer := Par; 31719 Par := Parent (Par); 31720 31721 if Present (Next_Element.Expr) then 31722 return Determining_Expressions 31723 (Expr => Par, Expr_Trailer => Trailer) 31724 & Next_Element; 31725 end if; 31726 end loop; 31727 end Determining_Expressions; 31728 31729 ----------------------------------------- 31730 -- Eligible_For_Conditional_Evaluation -- 31731 ----------------------------------------- 31732 31733 function Eligible_For_Conditional_Evaluation 31734 (Expr : Node_Id) return Boolean 31735 is 31736 begin 31737 if Is_Anonymous_Access_Type (Etype (Expr)) then 31738 -- The code in exp_attr.adb that also builds declarations 31739 -- for 'Old constants doesn't handle the anonymous access 31740 -- type case correctly, so we avoid that problem by 31741 -- returning True here. 31742 return True; 31743 31744 elsif Ada_Version < Ada_2022 then 31745 return False; 31746 31747 elsif Inside_Class_Condition_Preanalysis then 31748 -- No need to evaluate it during preanalysis of a class-wide 31749 -- pre/postcondition since the expression is not installed yet 31750 -- on its definite context. 31751 return False; 31752 31753 elsif not Is_Conditionally_Evaluated (Expr) then 31754 return False; 31755 else 31756 declare 31757 Determiners : constant Determining_Expression_List := 31758 Determining_Expressions (Expr); 31759 begin 31760 pragma Assert (Determiners'Length > 0); 31761 31762 for Idx in Determiners'Range loop 31763 if not Is_Known_On_Entry (Determiners (Idx).Expr) then 31764 return False; 31765 end if; 31766 end loop; 31767 end; 31768 return True; 31769 end if; 31770 end Eligible_For_Conditional_Evaluation; 31771 31772 -------------------------------- 31773 -- Is_Conditionally_Evaluated -- 31774 -------------------------------- 31775 31776 function Is_Conditionally_Evaluated (Expr : Node_Id) return Boolean 31777 is 31778 -- There are three possibilities - the expression is 31779 -- unconditionally evaluated, repeatedly evaluated, or 31780 -- conditionally evaluated (see RM 6.1.1). So we implement 31781 -- this test by testing for the other two. 31782 31783 function Is_Repeatedly_Evaluated (Expr : Node_Id) return Boolean; 31784 -- See RM 6.1.1 for definition of "repeatedly evaluated". 31785 31786 ----------------------------- 31787 -- Is_Repeatedly_Evaluated -- 31788 ----------------------------- 31789 31790 function Is_Repeatedly_Evaluated (Expr : Node_Id) return Boolean is 31791 Par : Node_Id := Expr; 31792 Trailer : Node_Id := Empty; 31793 31794 -- There are three ways that an expression can be repeatedly 31795 -- evaluated. 31796 begin 31797 -- An aspect_specification is transformed into a pragma, so 31798 -- reaching a pragma is our termination condition. We want to 31799 -- stop when we reach the postcondition expression. 31800 31801 while Nkind (Par) /= N_Pragma loop 31802 pragma Assert (Present (Par)); 31803 31804 -- test for case 1: 31805 -- A subexpression of a predicate of a 31806 -- quantified_expression. 31807 31808 if Nkind (Par) = N_Quantified_Expression 31809 and then Trailer = Condition (Par) 31810 then 31811 return True; 31812 elsif Nkind (Par) = N_Expression_With_Actions 31813 and then 31814 Nkind (Original_Node (Par)) = N_Quantified_Expression 31815 then 31816 return True; 31817 end if; 31818 31819 -- test for cases 2 and 3: 31820 -- A subexpression of the expression of an 31821 -- array_component_association or of 31822 -- a container_element_associatiation. 31823 31824 if Nkind (Par) = N_Component_Association 31825 and then Trailer = Expression (Par) 31826 then 31827 -- determine whether Par is part of an array aggregate 31828 -- or a container aggregate 31829 declare 31830 Rover : Node_Id := Par; 31831 begin 31832 while Nkind (Rover) not in N_Has_Etype loop 31833 pragma Assert (Present (Rover)); 31834 Rover := Parent (Rover); 31835 end loop; 31836 if Present (Etype (Rover)) then 31837 if Is_Array_Type (Etype (Rover)) 31838 or else Is_Container_Aggregate (Rover) 31839 then 31840 return True; 31841 end if; 31842 end if; 31843 end; 31844 end if; 31845 31846 Trailer := Par; 31847 Par := Parent (Par); 31848 end loop; 31849 31850 return False; 31851 end Is_Repeatedly_Evaluated; 31852 31853 begin 31854 if not Is_Potentially_Unevaluated (Expr) then 31855 -- the expression is unconditionally evaluated 31856 return False; 31857 elsif Is_Repeatedly_Evaluated (Expr) then 31858 return False; 31859 end if; 31860 31861 return True; 31862 end Is_Conditionally_Evaluated; 31863 31864 ----------------------- 31865 -- Is_Known_On_Entry -- 31866 ----------------------- 31867 31868 function Is_Known_On_Entry (Expr : Node_Id) return Boolean is 31869 -- ??? This implementation is incomplete. See RM 6.1.1 31870 -- for details. In particular, this function *should* return 31871 -- True for a function call (or a user-defined literal, which 31872 -- is equivalent to a function call) if all actual parameters 31873 -- (including defaulted params) are known on entry and the 31874 -- function has "Globals => null" specified; the current 31875 -- implementation will incorrectly return False in this case. 31876 31877 function All_Exps_Known_On_Entry 31878 (Expr_List : List_Id) return Boolean; 31879 -- Given a list of expressions, returns False iff 31880 -- Is_Known_On_Entry is False for at least one list element. 31881 31882 ----------------------------- 31883 -- All_Exps_Known_On_Entry -- 31884 ----------------------------- 31885 31886 function All_Exps_Known_On_Entry 31887 (Expr_List : List_Id) return Boolean 31888 is 31889 Expr : Node_Id := First (Expr_List); 31890 begin 31891 while Present (Expr) loop 31892 if not Is_Known_On_Entry (Expr) then 31893 return False; 31894 end if; 31895 Next (Expr); 31896 end loop; 31897 return True; 31898 end All_Exps_Known_On_Entry; 31899 31900 begin 31901 if Is_Static_Expression (Expr) then 31902 return True; 31903 end if; 31904 31905 if Is_Attribute_Old (Expr) then 31906 return True; 31907 end if; 31908 31909 declare 31910 Pref : Node_Id := Expr; 31911 begin 31912 loop 31913 case Nkind (Pref) is 31914 when N_Selected_Component => 31915 null; 31916 31917 when N_Indexed_Component => 31918 if not All_Exps_Known_On_Entry (Expressions (Pref)) 31919 then 31920 return False; 31921 end if; 31922 31923 when N_Slice => 31924 return False; -- just to be clear about this case 31925 31926 when others => 31927 exit; 31928 end case; 31929 31930 Pref := Prefix (Pref); 31931 end loop; 31932 31933 if Is_Entity_Name (Pref) 31934 and then Is_Constant_Object (Entity (Pref)) 31935 then 31936 declare 31937 Obj : constant Entity_Id := Entity (Pref); 31938 Obj_Typ : constant Entity_Id := Etype (Obj); 31939 begin 31940 case Ekind (Obj) is 31941 when E_In_Parameter => 31942 if not Is_Elementary_Type (Obj_Typ) then 31943 return False; 31944 elsif Is_Aliased (Obj) then 31945 return False; 31946 end if; 31947 31948 when E_Constant => 31949 -- return False for a deferred constant 31950 if Present (Full_View (Obj)) then 31951 return False; 31952 end if; 31953 31954 -- return False if not "all views are constant". 31955 if Is_Immutably_Limited_Type (Obj_Typ) 31956 or Needs_Finalization (Obj_Typ) 31957 then 31958 return False; 31959 end if; 31960 31961 when others => 31962 null; 31963 end case; 31964 end; 31965 31966 return True; 31967 end if; 31968 31969 -- ??? Cope with a malformed tree. Code to cope with a 31970 -- nonstatic use of an enumeration literal should not be 31971 -- necessary. 31972 if Is_Entity_Name (Pref) 31973 and then Ekind (Entity (Pref)) = E_Enumeration_Literal 31974 then 31975 return True; 31976 end if; 31977 end; 31978 31979 case Nkind (Expr) is 31980 when N_Unary_Op => 31981 return Is_Known_On_Entry (Right_Opnd (Expr)); 31982 31983 when N_Binary_Op => 31984 return Is_Known_On_Entry (Left_Opnd (Expr)) 31985 and then Is_Known_On_Entry (Right_Opnd (Expr)); 31986 31987 when N_Type_Conversion | N_Qualified_Expression => 31988 return Is_Known_On_Entry (Expression (Expr)); 31989 31990 when N_If_Expression => 31991 if not All_Exps_Known_On_Entry (Expressions (Expr)) then 31992 return False; 31993 end if; 31994 31995 when N_Case_Expression => 31996 if not Is_Known_On_Entry (Expression (Expr)) then 31997 return False; 31998 end if; 31999 32000 declare 32001 Alt : Node_Id := First (Alternatives (Expr)); 32002 begin 32003 while Present (Alt) loop 32004 if not Is_Known_On_Entry (Expression (Alt)) then 32005 return False; 32006 end if; 32007 Next (Alt); 32008 end loop; 32009 end; 32010 32011 return True; 32012 32013 when others => 32014 null; 32015 end case; 32016 32017 return False; 32018 end Is_Known_On_Entry; 32019 32020 end Conditional_Evaluation; 32021 32022 package body Indirect_Temps is 32023 32024 Indirect_Temp_Access_Type_Char : constant Character := 'K'; 32025 -- The character passed to Make_Temporary when declaring 32026 -- the access type that is used in the implementation of an 32027 -- indirect temporary. 32028 32029 -------------------------- 32030 -- Indirect_Temp_Needed -- 32031 -------------------------- 32032 32033 function Indirect_Temp_Needed (Typ : Entity_Id) return Boolean is 32034 begin 32035 -- There should be no correctness issues if the only cases where 32036 -- this function returns False are cases where Typ is an 32037 -- anonymous access type and we need to generate a saooaaat (a 32038 -- stand-alone object of an anonymous access type) in order get 32039 -- accessibility right. In other cases where this function 32040 -- returns False, there would be no correctness problems with 32041 -- returning True instead; however, returning False when we can 32042 -- generally results in simpler code. 32043 32044 return False 32045 32046 -- If Typ is not definite, then we cannot generate 32047 -- Temp : Typ; 32048 32049 or else not Is_Definite_Subtype (Typ) 32050 32051 -- If Typ is tagged, then generating 32052 -- Temp : Typ; 32053 -- might generate an object with the wrong tag. If we had 32054 -- a predicate that indicated whether the nominal tag is 32055 -- trustworthy, we could use that predicate here. 32056 32057 or else Is_Tagged_Type (Typ) 32058 32059 -- If Typ needs finalization, then generating an implicit 32060 -- Temp : Typ; 32061 -- declaration could have user-visible side effects. 32062 32063 or else Needs_Finalization (Typ) 32064 32065 -- In the anonymous access type case, we need to 32066 -- generate a saooaaat. We don't want the code in 32067 -- in exp_attr.adb that deals with the case where this 32068 -- function returns False to have to deal with that case 32069 -- (just to avoid code duplication). So we cheat a little 32070 -- bit and return True here for an anonymous access type. 32071 32072 or else Is_Anonymous_Access_Type (Typ); 32073 32074 -- ??? Unimplemented - spec description says: 32075 -- For an unconstrained-but-definite discriminated subtype, 32076 -- returns True if the potential difference in size between an 32077 -- unconstrained object and a constrained object is large. 32078 -- 32079 -- For example, 32080 -- type Typ (Len : Natural := 0) is 32081 -- record F : String (1 .. Len); end record; 32082 -- 32083 -- See Large_Max_Size_Mutable function elsewhere in this 32084 -- file (currently declared inside of 32085 -- Requires_Transient_Scope, so it would have to be 32086 -- moved if we want it to be callable from here). 32087 32088 end Indirect_Temp_Needed; 32089 32090 --------------------------- 32091 -- Declare_Indirect_Temp -- 32092 --------------------------- 32093 32094 procedure Declare_Indirect_Temp 32095 (Attr_Prefix : Node_Id; Indirect_Temp : out Entity_Id) 32096 is 32097 Loc : constant Source_Ptr := Sloc (Attr_Prefix); 32098 Prefix_Type : constant Entity_Id := Etype (Attr_Prefix); 32099 Temp_Id : constant Entity_Id := 32100 Make_Temporary (Loc, 'P', Attr_Prefix); 32101 32102 procedure Declare_Indirect_Temp_Via_Allocation; 32103 -- Handle the usual case. 32104 32105 ------------------------------------------- 32106 -- Declare_Indirect_Temp_Via_Allocation -- 32107 ------------------------------------------- 32108 32109 procedure Declare_Indirect_Temp_Via_Allocation is 32110 Access_Type_Id : constant Entity_Id 32111 := Make_Temporary 32112 (Loc, Indirect_Temp_Access_Type_Char, Attr_Prefix); 32113 32114 Temp_Decl : constant Node_Id := 32115 Make_Object_Declaration (Loc, 32116 Defining_Identifier => Temp_Id, 32117 Object_Definition => 32118 New_Occurrence_Of (Access_Type_Id, Loc)); 32119 32120 Allocate_Class_Wide : constant Boolean := 32121 Is_Specific_Tagged_Type (Prefix_Type); 32122 -- If True then access type designates the class-wide type in 32123 -- order to preserve (at run time) the value of the underlying 32124 -- tag. 32125 -- ??? We could do better here (in the case where Prefix_Type 32126 -- is tagged and specific) if we had a predicate which takes an 32127 -- expression and returns True iff the expression is of 32128 -- a specific tagged type and the underlying tag (at run time) 32129 -- is statically known to match that of the specific type. 32130 -- In that case, Allocate_Class_Wide could safely be False. 32131 32132 function Designated_Subtype_Mark return Node_Id; 32133 -- Usually, a subtype mark indicating the subtype of the 32134 -- attribute prefix. If that subtype is a specific tagged 32135 -- type, then returns the corresponding class-wide type. 32136 -- If the prefix is of an anonymous access type, then returns 32137 -- the designated type of that type. 32138 32139 ----------------------------- 32140 -- Designated_Subtype_Mark -- 32141 ----------------------------- 32142 32143 function Designated_Subtype_Mark return Node_Id is 32144 Typ : Entity_Id := Prefix_Type; 32145 begin 32146 if Allocate_Class_Wide then 32147 if Is_Private_Type (Typ) 32148 and then Present (Full_View (Typ)) 32149 then 32150 Typ := Full_View (Typ); 32151 end if; 32152 Typ := Class_Wide_Type (Typ); 32153 end if; 32154 32155 return New_Occurrence_Of (Typ, Loc); 32156 end Designated_Subtype_Mark; 32157 32158 Access_Type_Def : constant Node_Id 32159 := Make_Access_To_Object_Definition 32160 (Loc, Subtype_Indication => Designated_Subtype_Mark); 32161 32162 Access_Type_Decl : constant Node_Id 32163 := Make_Full_Type_Declaration 32164 (Loc, Access_Type_Id, 32165 Type_Definition => Access_Type_Def); 32166 begin 32167 Mutate_Ekind (Temp_Id, E_Variable); 32168 Set_Etype (Temp_Id, Access_Type_Id); 32169 Mutate_Ekind (Access_Type_Id, E_Access_Type); 32170 32171 if Append_Decls_In_Reverse_Order then 32172 Append_Item (Temp_Decl, Is_Eval_Stmt => False); 32173 Append_Item (Access_Type_Decl, Is_Eval_Stmt => False); 32174 else 32175 Append_Item (Access_Type_Decl, Is_Eval_Stmt => False); 32176 Append_Item (Temp_Decl, Is_Eval_Stmt => False); 32177 end if; 32178 32179 -- When a type associated with an indirect temporary gets 32180 -- created for a 'Old attribute reference we need to mark 32181 -- the type as such. This allows, for example, finalization 32182 -- masters associated with them to be finalized in the correct 32183 -- order after postcondition checks. 32184 32185 if Attribute_Name (Parent (Attr_Prefix)) = Name_Old then 32186 Set_Stores_Attribute_Old_Prefix (Access_Type_Id); 32187 end if; 32188 32189 Analyze (Access_Type_Decl); 32190 Analyze (Temp_Decl); 32191 32192 pragma Assert 32193 (Is_Access_Type_For_Indirect_Temp (Access_Type_Id)); 32194 32195 declare 32196 Expression : Node_Id := Attr_Prefix; 32197 Allocator : Node_Id; 32198 begin 32199 if Allocate_Class_Wide then 32200 -- generate T'Class'(T'Class (<prefix>)) 32201 Expression := 32202 Make_Type_Conversion (Loc, 32203 Subtype_Mark => Designated_Subtype_Mark, 32204 Expression => Expression); 32205 end if; 32206 32207 Allocator := 32208 Make_Allocator (Loc, 32209 Make_Qualified_Expression 32210 (Loc, 32211 Subtype_Mark => Designated_Subtype_Mark, 32212 Expression => Expression)); 32213 32214 -- Allocate saved prefix value on the secondary stack 32215 -- in order to avoid introducing a storage leak. This 32216 -- allocated object is never explicitly reclaimed. 32217 -- 32218 -- ??? Emit storage leak warning if RE_SS_Pool 32219 -- unavailable? 32220 32221 if RTE_Available (RE_SS_Pool) then 32222 Set_Storage_Pool (Allocator, RTE (RE_SS_Pool)); 32223 Set_Procedure_To_Call 32224 (Allocator, RTE (RE_SS_Allocate)); 32225 Set_Uses_Sec_Stack (Current_Scope); 32226 end if; 32227 32228 Append_Item 32229 (Make_Assignment_Statement (Loc, 32230 Name => New_Occurrence_Of (Temp_Id, Loc), 32231 Expression => Allocator), 32232 Is_Eval_Stmt => True); 32233 end; 32234 end Declare_Indirect_Temp_Via_Allocation; 32235 32236 begin 32237 Indirect_Temp := Temp_Id; 32238 32239 if Is_Anonymous_Access_Type (Prefix_Type) then 32240 -- In the anonymous access type case, we do not want a level 32241 -- indirection (which would result in declaring an 32242 -- access-to-access type); that would result in correctness 32243 -- problems - the accessibility level of the type of the 32244 -- 'Old constant would be wrong (See 6.1.1.). So in that case, 32245 -- we do not generate an allocator. Instead we generate 32246 -- Temp : access Designated := null; 32247 -- which is unconditionally elaborated and then 32248 -- Temp := <attribute prefix>; 32249 -- which is conditionally executed. 32250 32251 declare 32252 Temp_Decl : constant Node_Id := 32253 Make_Object_Declaration (Loc, 32254 Defining_Identifier => Temp_Id, 32255 Object_Definition => 32256 Make_Access_Definition 32257 (Loc, 32258 Constant_Present => 32259 Is_Access_Constant (Prefix_Type), 32260 Subtype_Mark => 32261 New_Occurrence_Of 32262 (Designated_Type (Prefix_Type), Loc))); 32263 begin 32264 Append_Item (Temp_Decl, Is_Eval_Stmt => False); 32265 Analyze (Temp_Decl); 32266 Append_Item 32267 (Make_Assignment_Statement (Loc, 32268 Name => New_Occurrence_Of (Temp_Id, Loc), 32269 Expression => Attr_Prefix), 32270 Is_Eval_Stmt => True); 32271 end; 32272 else 32273 -- the usual case 32274 Declare_Indirect_Temp_Via_Allocation; 32275 end if; 32276 end Declare_Indirect_Temp; 32277 32278 ------------------------- 32279 -- Indirect_Temp_Value -- 32280 ------------------------- 32281 32282 function Indirect_Temp_Value 32283 (Temp : Entity_Id; 32284 Typ : Entity_Id; 32285 Loc : Source_Ptr) return Node_Id 32286 is 32287 Result : Node_Id; 32288 begin 32289 if Is_Anonymous_Access_Type (Typ) then 32290 -- No indirection in this case; just evaluate the temp. 32291 Result := New_Occurrence_Of (Temp, Loc); 32292 Set_Etype (Result, Etype (Temp)); 32293 32294 else 32295 Result := Make_Explicit_Dereference (Loc, 32296 New_Occurrence_Of (Temp, Loc)); 32297 32298 Set_Etype (Result, Designated_Type (Etype (Temp))); 32299 32300 if Is_Specific_Tagged_Type (Typ) then 32301 -- The designated type of the access type is class-wide, so 32302 -- convert to the specific type. 32303 32304 Result := 32305 Make_Type_Conversion (Loc, 32306 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 32307 Expression => Result); 32308 32309 Set_Etype (Result, Typ); 32310 end if; 32311 end if; 32312 32313 return Result; 32314 end Indirect_Temp_Value; 32315 32316 function Is_Access_Type_For_Indirect_Temp 32317 (T : Entity_Id) return Boolean is 32318 begin 32319 if Is_Access_Type (T) 32320 and then not Comes_From_Source (T) 32321 and then Is_Internal_Name (Chars (T)) 32322 and then Nkind (Scope (T)) in N_Entity 32323 and then Ekind (Scope (T)) 32324 in E_Entry | E_Entry_Family | E_Function | E_Procedure 32325 and then 32326 (Present (Postconditions_Proc (Scope (T))) 32327 or else Present (Contract (Scope (T)))) 32328 then 32329 -- ??? Should define a flag for this. We could incorrectly 32330 -- return True if other clients of Make_Temporary happen to 32331 -- pass in the same character. 32332 declare 32333 Name : constant String := Get_Name_String (Chars (T)); 32334 begin 32335 if Name (Name'First) = Indirect_Temp_Access_Type_Char then 32336 return True; 32337 end if; 32338 end; 32339 end if; 32340 32341 return False; 32342 end Is_Access_Type_For_Indirect_Temp; 32343 32344 end Indirect_Temps; 32345 end Old_Attr_Util; 32346 32347 package body Storage_Model_Support is 32348 32349 ----------------------------------- 32350 -- Get_Storage_Model_Type_Entity -- 32351 ----------------------------------- 32352 32353 function Get_Storage_Model_Type_Entity 32354 (Typ : Entity_Id; 32355 Nam : Name_Id) return Entity_Id 32356 is 32357 pragma Assert 32358 (Is_Type (Typ) 32359 and then 32360 Nam in Name_Address_Type 32361 | Name_Null_Address 32362 | Name_Allocate 32363 | Name_Deallocate 32364 | Name_Copy_From 32365 | Name_Copy_To 32366 | Name_Storage_Size); 32367 32368 SMT_Aspect_Value : constant Node_Id := 32369 Find_Value_Of_Aspect (Typ, Aspect_Storage_Model_Type); 32370 Assoc : Node_Id; 32371 32372 begin 32373 if No (SMT_Aspect_Value) then 32374 return Empty; 32375 32376 else 32377 Assoc := First (Component_Associations (SMT_Aspect_Value)); 32378 while Present (Assoc) loop 32379 if Chars (First (Choices (Assoc))) = Nam then 32380 return Entity (Expression (Assoc)); 32381 end if; 32382 32383 Next (Assoc); 32384 end loop; 32385 32386 return Empty; 32387 end if; 32388 end Get_Storage_Model_Type_Entity; 32389 32390 ----------------------------------------- 32391 -- Has_Designated_Storage_Model_Aspect -- 32392 ----------------------------------------- 32393 32394 function Has_Designated_Storage_Model_Aspect 32395 (Typ : Entity_Id) return Boolean 32396 is 32397 begin 32398 return Present (Find_Aspect (Typ, Aspect_Designated_Storage_Model)); 32399 end Has_Designated_Storage_Model_Aspect; 32400 32401 ----------------------------------- 32402 -- Has_Storage_Model_Type_Aspect -- 32403 ----------------------------------- 32404 32405 function Has_Storage_Model_Type_Aspect (Typ : Entity_Id) return Boolean 32406 is 32407 begin 32408 return Present (Find_Aspect (Typ, Aspect_Storage_Model_Type)); 32409 end Has_Storage_Model_Type_Aspect; 32410 32411 -------------------------- 32412 -- Storage_Model_Object -- 32413 -------------------------- 32414 32415 function Storage_Model_Object (Typ : Entity_Id) return Entity_Id is 32416 begin 32417 if Has_Designated_Storage_Model_Aspect (Typ) then 32418 return 32419 Entity 32420 (Find_Value_Of_Aspect (Typ, Aspect_Designated_Storage_Model)); 32421 else 32422 return Empty; 32423 end if; 32424 end Storage_Model_Object; 32425 32426 ------------------------ 32427 -- Storage_Model_Type -- 32428 ------------------------ 32429 32430 function Storage_Model_Type (Obj : Entity_Id) return Entity_Id is 32431 begin 32432 if Present 32433 (Find_Value_Of_Aspect (Etype (Obj), Aspect_Storage_Model_Type)) 32434 then 32435 return Etype (Obj); 32436 else 32437 return Empty; 32438 end if; 32439 end Storage_Model_Type; 32440 32441 -------------------------------- 32442 -- Storage_Model_Address_Type -- 32443 -------------------------------- 32444 32445 function Storage_Model_Address_Type (Typ : Entity_Id) return Entity_Id is 32446 begin 32447 return Get_Storage_Model_Type_Entity (Typ, Name_Address_Type); 32448 end Storage_Model_Address_Type; 32449 32450 -------------------------------- 32451 -- Storage_Model_Null_Address -- 32452 -------------------------------- 32453 32454 function Storage_Model_Null_Address (Typ : Entity_Id) return Entity_Id is 32455 begin 32456 return Get_Storage_Model_Type_Entity (Typ, Name_Null_Address); 32457 end Storage_Model_Null_Address; 32458 32459 ---------------------------- 32460 -- Storage_Model_Allocate -- 32461 ---------------------------- 32462 32463 function Storage_Model_Allocate (Typ : Entity_Id) return Entity_Id is 32464 begin 32465 return Get_Storage_Model_Type_Entity (Typ, Name_Allocate); 32466 end Storage_Model_Allocate; 32467 32468 ------------------------------ 32469 -- Storage_Model_Deallocate -- 32470 ------------------------------ 32471 32472 function Storage_Model_Deallocate (Typ : Entity_Id) return Entity_Id is 32473 begin 32474 return Get_Storage_Model_Type_Entity (Typ, Name_Deallocate); 32475 end Storage_Model_Deallocate; 32476 32477 ----------------------------- 32478 -- Storage_Model_Copy_From -- 32479 ----------------------------- 32480 32481 function Storage_Model_Copy_From (Typ : Entity_Id) return Entity_Id is 32482 begin 32483 return Get_Storage_Model_Type_Entity (Typ, Name_Copy_From); 32484 end Storage_Model_Copy_From; 32485 32486 --------------------------- 32487 -- Storage_Model_Copy_To -- 32488 --------------------------- 32489 32490 function Storage_Model_Copy_To (Typ : Entity_Id) return Entity_Id is 32491 begin 32492 return Get_Storage_Model_Type_Entity (Typ, Name_Copy_To); 32493 end Storage_Model_Copy_To; 32494 32495 -------------------------------- 32496 -- Storage_Model_Storage_Size -- 32497 -------------------------------- 32498 32499 function Storage_Model_Storage_Size (Typ : Entity_Id) return Entity_Id is 32500 begin 32501 return Get_Storage_Model_Type_Entity (Typ, Name_Storage_Size); 32502 end Storage_Model_Storage_Size; 32503 32504 end Storage_Model_Support; 32505 32506begin 32507 Erroutc.Subprogram_Name_Ptr := Subprogram_Name'Access; 32508end Sem_Util; 32509