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-2020, 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 Elists; use Elists; 30with Errout; use Errout; 31with Erroutc; use Erroutc; 32with Exp_Ch3; use Exp_Ch3; 33with Exp_Ch11; use Exp_Ch11; 34with Exp_Util; use Exp_Util; 35with Fname; use Fname; 36with Freeze; use Freeze; 37with Itypes; use Itypes; 38with Lib; use Lib; 39with Lib.Xref; use Lib.Xref; 40with Namet.Sp; use Namet.Sp; 41with Nlists; use Nlists; 42with Nmake; use Nmake; 43with Output; use Output; 44with Restrict; use Restrict; 45with Rident; use Rident; 46with Rtsfind; use Rtsfind; 47with Sem; use Sem; 48with Sem_Aux; use Sem_Aux; 49with Sem_Attr; use Sem_Attr; 50with Sem_Cat; use Sem_Cat; 51with Sem_Ch6; use Sem_Ch6; 52with Sem_Ch8; use Sem_Ch8; 53with Sem_Ch13; use Sem_Ch13; 54with Sem_Disp; use Sem_Disp; 55with Sem_Elab; use Sem_Elab; 56with Sem_Eval; use Sem_Eval; 57with Sem_Prag; use Sem_Prag; 58with Sem_Res; use Sem_Res; 59with Sem_Warn; use Sem_Warn; 60with Sem_Type; use Sem_Type; 61with Sinfo; use Sinfo; 62with Sinput; use Sinput; 63with Stand; use Stand; 64with Style; 65with Stringt; use Stringt; 66with Targparm; use Targparm; 67with Tbuild; use Tbuild; 68with Ttypes; use Ttypes; 69with Uname; use Uname; 70 71with GNAT.Heap_Sort_G; 72with GNAT.HTable; use GNAT.HTable; 73 74package body Sem_Util is 75 76 --------------------------- 77 -- Local Data Structures -- 78 --------------------------- 79 80 Invalid_Binder_Values : array (Scalar_Id) of Entity_Id := (others => Empty); 81 -- A collection to hold the entities of the variables declared in package 82 -- System.Scalar_Values which describe the invalid values of scalar types. 83 84 Invalid_Binder_Values_Set : Boolean := False; 85 -- This flag prevents multiple attempts to initialize Invalid_Binder_Values 86 87 Invalid_Floats : array (Float_Scalar_Id) of Ureal := (others => No_Ureal); 88 -- A collection to hold the invalid values of float types as specified by 89 -- pragma Initialize_Scalars. 90 91 Invalid_Integers : array (Integer_Scalar_Id) of Uint := (others => No_Uint); 92 -- A collection to hold the invalid values of integer types as specified 93 -- by pragma Initialize_Scalars. 94 95 ----------------------- 96 -- Local Subprograms -- 97 ----------------------- 98 99 function Build_Component_Subtype 100 (C : List_Id; 101 Loc : Source_Ptr; 102 T : Entity_Id) return Node_Id; 103 -- This function builds the subtype for Build_Actual_Subtype_Of_Component 104 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints, 105 -- Loc is the source location, T is the original subtype. 106 107 procedure Examine_Array_Bounds 108 (Typ : Entity_Id; 109 All_Static : out Boolean; 110 Has_Empty : out Boolean); 111 -- Inspect the index constraints of array type Typ. Flag All_Static is set 112 -- when all ranges are static. Flag Has_Empty is set only when All_Static 113 -- is set and indicates that at least one range is empty. 114 115 function Has_Enabled_Property 116 (Item_Id : Entity_Id; 117 Property : Name_Id) return Boolean; 118 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled. 119 -- Determine whether the state abstraction, object, or type denoted by 120 -- entity Item_Id has enabled property Property. 121 122 function Has_Null_Extension (T : Entity_Id) return Boolean; 123 -- T is a derived tagged type. Check whether the type extension is null. 124 -- If the parent type is fully initialized, T can be treated as such. 125 126 function Is_Atomic_Object_Entity (Id : Entity_Id) return Boolean; 127 -- Determine whether arbitrary entity Id denotes an atomic object as per 128 -- RM C.6(7). 129 130 function Is_Container_Aggregate (Exp : Node_Id) return Boolean; 131 -- Is the given expression a container aggregate? 132 133 generic 134 with function Is_Effectively_Volatile_Entity 135 (Id : Entity_Id) return Boolean; 136 -- Function to use on object and type entities 137 function Is_Effectively_Volatile_Object_Shared 138 (N : Node_Id) return Boolean; 139 -- Shared function used to detect effectively volatile objects and 140 -- effectively volatile objects for reading. 141 142 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean; 143 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type 144 -- with discriminants whose default values are static, examine only the 145 -- components in the selected variant to determine whether all of them 146 -- have a default. 147 148 function Is_Preelaborable_Function (Id : Entity_Id) return Boolean; 149 -- Ada 2020: Determine whether the specified function is suitable as the 150 -- name of a call in a preelaborable construct (RM 10.2.1(7/5)). 151 152 type Null_Status_Kind is 153 (Is_Null, 154 -- This value indicates that a subexpression is known to have a null 155 -- value at compile time. 156 157 Is_Non_Null, 158 -- This value indicates that a subexpression is known to have a non-null 159 -- value at compile time. 160 161 Unknown); 162 -- This value indicates that it cannot be determined at compile time 163 -- whether a subexpression yields a null or non-null value. 164 165 function Null_Status (N : Node_Id) return Null_Status_Kind; 166 -- Determine whether subexpression N of an access type yields a null value, 167 -- a non-null value, or the value cannot be determined at compile time. The 168 -- routine does not take simple flow diagnostics into account, it relies on 169 -- static facts such as the presence of null exclusions. 170 171 function Subprogram_Name (N : Node_Id) return String; 172 -- Return the fully qualified name of the enclosing subprogram for the 173 -- given node N, with file:line:col information appended, e.g. 174 -- "subp:file:line:col", corresponding to the source location of the 175 -- body of the subprogram. 176 177 ------------------------------ 178 -- Abstract_Interface_List -- 179 ------------------------------ 180 181 function Abstract_Interface_List (Typ : Entity_Id) return List_Id is 182 Nod : Node_Id; 183 184 begin 185 if Is_Concurrent_Type (Typ) then 186 187 -- If we are dealing with a synchronized subtype, go to the base 188 -- type, whose declaration has the interface list. 189 190 Nod := Declaration_Node (Base_Type (Typ)); 191 192 if Nkind (Nod) in N_Full_Type_Declaration | N_Private_Type_Declaration 193 then 194 return Empty_List; 195 end if; 196 197 elsif Ekind (Typ) = E_Record_Type_With_Private then 198 if Nkind (Parent (Typ)) = N_Full_Type_Declaration then 199 Nod := Type_Definition (Parent (Typ)); 200 201 elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then 202 if Present (Full_View (Typ)) 203 and then 204 Nkind (Parent (Full_View (Typ))) = N_Full_Type_Declaration 205 then 206 Nod := Type_Definition (Parent (Full_View (Typ))); 207 208 -- If the full-view is not available we cannot do anything else 209 -- here (the source has errors). 210 211 else 212 return Empty_List; 213 end if; 214 215 -- Support for generic formals with interfaces is still missing ??? 216 217 elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then 218 return Empty_List; 219 220 else 221 pragma Assert 222 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration); 223 Nod := Parent (Typ); 224 end if; 225 226 elsif Ekind (Typ) = E_Record_Subtype then 227 Nod := Type_Definition (Parent (Etype (Typ))); 228 229 elsif Ekind (Typ) = E_Record_Subtype_With_Private then 230 231 -- Recurse, because parent may still be a private extension. Also 232 -- note that the full view of the subtype or the full view of its 233 -- base type may (both) be unavailable. 234 235 return Abstract_Interface_List (Etype (Typ)); 236 237 elsif Ekind (Typ) = E_Record_Type then 238 if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then 239 Nod := Formal_Type_Definition (Parent (Typ)); 240 else 241 Nod := Type_Definition (Parent (Typ)); 242 end if; 243 244 -- Otherwise the type is of a kind which does not implement interfaces 245 246 else 247 return Empty_List; 248 end if; 249 250 return Interface_List (Nod); 251 end Abstract_Interface_List; 252 253 ------------------------- 254 -- Accessibility_Level -- 255 ------------------------- 256 257 function Accessibility_Level 258 (Expr : Node_Id; 259 Level : Accessibility_Level_Kind; 260 In_Return_Context : Boolean := False) return Node_Id 261 is 262 Loc : constant Source_Ptr := Sloc (Expr); 263 264 function Accessibility_Level (Expr : Node_Id) return Node_Id 265 is (Accessibility_Level (Expr, Level, In_Return_Context)); 266 -- Renaming of the enclosing function to facilitate recursive calls 267 268 function Make_Level_Literal (Level : Uint) return Node_Id; 269 -- Construct an integer literal representing an accessibility level 270 -- with its type set to Natural. 271 272 function Innermost_Master_Scope_Depth 273 (N : Node_Id) return Uint; 274 -- Returns the scope depth of the given node's innermost 275 -- enclosing dynamic scope (effectively the accessibility 276 -- level of the innermost enclosing master). 277 278 function Function_Call_Or_Allocator_Level 279 (N : Node_Id) return Node_Id; 280 -- Centralized processing of subprogram calls which may appear in 281 -- prefix notation. 282 283 ---------------------------------- 284 -- Innermost_Master_Scope_Depth -- 285 ---------------------------------- 286 287 function Innermost_Master_Scope_Depth 288 (N : Node_Id) return Uint 289 is 290 Encl_Scop : Entity_Id; 291 Node_Par : Node_Id := Parent (N); 292 Master_Lvl_Modifier : Int := 0; 293 294 begin 295 -- Locate the nearest enclosing node (by traversing Parents) 296 -- that Defining_Entity can be applied to, and return the 297 -- depth of that entity's nearest enclosing dynamic scope. 298 299 -- The rules that define what a master are defined in 300 -- RM 7.6.1 (3), and include statements and conditions for loops 301 -- among other things. These cases are detected properly ??? 302 303 while Present (Node_Par) loop 304 305 if Present (Defining_Entity 306 (Node_Par, Empty_On_Errors => True)) 307 then 308 Encl_Scop := Nearest_Dynamic_Scope 309 (Defining_Entity (Node_Par)); 310 311 -- Ignore transient scopes made during expansion 312 313 if Comes_From_Source (Node_Par) then 314 return Scope_Depth (Encl_Scop) + Master_Lvl_Modifier; 315 end if; 316 317 -- For a return statement within a function, return 318 -- the depth of the function itself. This is not just 319 -- a small optimization, but matters when analyzing 320 -- the expression in an expression function before 321 -- the body is created. 322 323 elsif Nkind (Node_Par) in N_Extended_Return_Statement 324 | N_Simple_Return_Statement 325 and then Ekind (Current_Scope) = E_Function 326 then 327 return Scope_Depth (Current_Scope); 328 329 -- Statements are counted as masters 330 331 elsif Is_Master (Node_Par) then 332 Master_Lvl_Modifier := Master_Lvl_Modifier + 1; 333 334 end if; 335 336 Node_Par := Parent (Node_Par); 337 end loop; 338 339 -- Should never reach the following return 340 341 pragma Assert (False); 342 343 return Scope_Depth (Current_Scope) + 1; 344 end Innermost_Master_Scope_Depth; 345 346 ------------------------ 347 -- Make_Level_Literal -- 348 ------------------------ 349 350 function Make_Level_Literal (Level : Uint) return Node_Id is 351 Result : constant Node_Id := Make_Integer_Literal (Loc, Level); 352 353 begin 354 Set_Etype (Result, Standard_Natural); 355 return Result; 356 end Make_Level_Literal; 357 358 -------------------------------------- 359 -- Function_Call_Or_Allocator_Level -- 360 -------------------------------------- 361 362 function Function_Call_Or_Allocator_Level (N : Node_Id) return Node_Id is 363 Par : Node_Id; 364 Prev_Par : Node_Id; 365 begin 366 -- Results of functions are objects, so we either get the 367 -- accessibility of the function or, in case of a call which is 368 -- indirect, the level of the access-to-subprogram type. 369 370 -- This code looks wrong ??? 371 372 if Nkind (N) = N_Function_Call 373 and then Ada_Version < Ada_2005 374 then 375 if Is_Entity_Name (Name (N)) then 376 return Make_Level_Literal 377 (Subprogram_Access_Level (Entity (Name (N)))); 378 else 379 return Make_Level_Literal 380 (Type_Access_Level (Etype (Prefix (Name (N))))); 381 end if; 382 383 -- We ignore coextensions as they cannot be implemented under the 384 -- "small-integer" model. 385 386 elsif Nkind (N) = N_Allocator 387 and then (Is_Static_Coextension (N) 388 or else Is_Dynamic_Coextension (N)) 389 then 390 return Make_Level_Literal 391 (Scope_Depth (Standard_Standard)); 392 end if; 393 394 -- Named access types have a designated level 395 396 if Is_Named_Access_Type (Etype (N)) then 397 return Make_Level_Literal (Type_Access_Level (Etype (N))); 398 399 -- Otherwise, the level is dictated by RM 3.10.2 (10.7/3) 400 401 else 402 if Nkind (N) = N_Function_Call then 403 -- Dynamic checks are generated when we are within a return 404 -- value or we are in a function call within an anonymous 405 -- access discriminant constraint of a return object (signified 406 -- by In_Return_Context) on the side of the callee. 407 408 -- So, in this case, return library accessibility level to null 409 -- out the check on the side of the caller. 410 411 if In_Return_Value (N) 412 or else In_Return_Context 413 then 414 return Make_Level_Literal 415 (Subprogram_Access_Level (Current_Subprogram)); 416 end if; 417 end if; 418 419 -- Find any relevant enclosing parent nodes that designate an 420 -- object being initialized. 421 422 -- Note: The above is only relevant if the result is used "in its 423 -- entirety" as RM 3.10.2 (10.2/3) states. However, this is 424 -- accounted for in the case statement in the main body of 425 -- Accessibility_Level for N_Selected_Component. 426 427 Par := Parent (Expr); 428 Prev_Par := Empty; 429 while Present (Par) loop 430 -- Detect an expanded implicit conversion, typically this 431 -- occurs on implicitly converted actuals in calls. 432 433 -- Does this catch all implicit conversions ??? 434 435 if Nkind (Par) = N_Type_Conversion 436 and then Is_Named_Access_Type (Etype (Par)) 437 then 438 return Make_Level_Literal 439 (Type_Access_Level (Etype (Par))); 440 end if; 441 442 -- Jump out when we hit an object declaration or the right-hand 443 -- side of an assignment, or a construct such as an aggregate 444 -- subtype indication which would be the result is not used 445 -- "in its entirety." 446 447 exit when Nkind (Par) in N_Object_Declaration 448 or else (Nkind (Par) = N_Assignment_Statement 449 and then Name (Par) /= Prev_Par); 450 451 Prev_Par := Par; 452 Par := Parent (Par); 453 end loop; 454 455 -- Assignment statements are handled in a similar way in 456 -- accordance to the left-hand part. However, strictly speaking, 457 -- this is illegal according to the RM, but this change is needed 458 -- to pass an ACATS C-test and is useful in general ??? 459 460 case Nkind (Par) is 461 when N_Object_Declaration => 462 return Make_Level_Literal 463 (Scope_Depth 464 (Scope (Defining_Identifier (Par)))); 465 466 when N_Assignment_Statement => 467 -- Return the accessiblity level of the left-hand part 468 469 return Accessibility_Level 470 (Expr => Name (Par), 471 Level => Object_Decl_Level, 472 In_Return_Context => In_Return_Context); 473 474 when others => 475 return Make_Level_Literal 476 (Innermost_Master_Scope_Depth (Expr)); 477 end case; 478 end if; 479 end Function_Call_Or_Allocator_Level; 480 481 -- Local variables 482 483 E : Entity_Id := Original_Node (Expr); 484 Pre : Node_Id; 485 486 -- Start of processing for Accessibility_Level 487 488 begin 489 -- We could be looking at a reference to a formal due to the expansion 490 -- of entries and other cases, so obtain the renaming if necessary. 491 492 if Present (Param_Entity (Expr)) then 493 E := Param_Entity (Expr); 494 end if; 495 496 -- Extract the entity 497 498 if Nkind (E) in N_Has_Entity and then Present (Entity (E)) then 499 E := Entity (E); 500 501 -- Deal with a possible renaming of a private protected component 502 503 if Ekind (E) in E_Constant | E_Variable and then Is_Prival (E) then 504 E := Prival_Link (E); 505 end if; 506 end if; 507 508 -- Perform the processing on the expression 509 510 case Nkind (E) is 511 -- The level of an aggregate is that of the innermost master that 512 -- evaluates it as defined in RM 3.10.2 (10/4). 513 514 when N_Aggregate => 515 return Make_Level_Literal (Innermost_Master_Scope_Depth (Expr)); 516 517 -- The accessibility level is that of the access type, except for an 518 -- anonymous allocators which have special rules defined in RM 3.10.2 519 -- (14/3). 520 521 when N_Allocator => 522 return Function_Call_Or_Allocator_Level (E); 523 524 -- We could reach this point for two reasons. Either the expression 525 -- applies to a special attribute ('Loop_Entry, 'Result, or 'Old), or 526 -- we are looking at the access attributes directly ('Access, 527 -- 'Address, or 'Unchecked_Access). 528 529 when N_Attribute_Reference => 530 Pre := Original_Node (Prefix (E)); 531 532 -- Regular 'Access attribute presence means we have to look at the 533 -- prefix. 534 535 if Attribute_Name (E) = Name_Access then 536 return Accessibility_Level (Prefix (E)); 537 538 -- Unchecked or unrestricted attributes have unlimited depth 539 540 elsif Attribute_Name (E) in Name_Address 541 | Name_Unchecked_Access 542 | Name_Unrestricted_Access 543 then 544 return Make_Level_Literal (Scope_Depth (Standard_Standard)); 545 546 -- 'Access can be taken further against other special attributes, 547 -- so handle these cases explicitly. 548 549 elsif Attribute_Name (E) 550 in Name_Old | Name_Loop_Entry | Name_Result 551 then 552 -- Named access types 553 554 if Is_Named_Access_Type (Etype (Pre)) then 555 return Make_Level_Literal 556 (Type_Access_Level (Etype (Pre))); 557 558 -- Anonymous access types 559 560 elsif Nkind (Pre) in N_Has_Entity 561 and then Present (Get_Dynamic_Accessibility (Entity (Pre))) 562 and then Level = Dynamic_Level 563 then 564 return New_Occurrence_Of 565 (Get_Dynamic_Accessibility (Entity (Pre)), Loc); 566 567 -- Otherwise the level is treated in a similar way as 568 -- aggregates according to RM 6.1.1 (35.1/4) which concerns 569 -- an implicit constant declaration - in turn defining the 570 -- accessibility level to be that of the implicit constant 571 -- declaration. 572 573 else 574 return Make_Level_Literal 575 (Innermost_Master_Scope_Depth (Expr)); 576 end if; 577 578 else 579 raise Program_Error; 580 end if; 581 582 -- This is the "base case" for accessibility level calculations which 583 -- means we are near the end of our recursive traversal. 584 585 when N_Defining_Identifier => 586 -- A dynamic check is performed on the side of the callee when we 587 -- are within a return statement, so return a library-level 588 -- accessibility level to null out checks on the side of the 589 -- caller. 590 591 if Is_Explicitly_Aliased (E) 592 and then Level /= Dynamic_Level 593 and then (In_Return_Value (Expr) 594 or else In_Return_Context) 595 then 596 return Make_Level_Literal (Scope_Depth (Standard_Standard)); 597 598 -- Something went wrong and an extra accessibility formal has not 599 -- been generated when one should have ??? 600 601 elsif Is_Formal (E) 602 and then not Present (Get_Dynamic_Accessibility (E)) 603 and then Ekind (Etype (E)) = E_Anonymous_Access_Type 604 then 605 return Make_Level_Literal (Scope_Depth (Standard_Standard)); 606 607 -- Stand-alone object of an anonymous access type "SAOAAT" 608 609 elsif (Is_Formal (E) 610 or else Ekind (E) in E_Variable 611 | E_Constant) 612 and then Present (Get_Dynamic_Accessibility (E)) 613 and then (Level = Dynamic_Level 614 or else Level = Zero_On_Dynamic_Level) 615 then 616 if Level = Zero_On_Dynamic_Level then 617 return Make_Level_Literal 618 (Scope_Depth (Standard_Standard)); 619 end if; 620 621 return 622 New_Occurrence_Of (Get_Dynamic_Accessibility (E), Loc); 623 624 -- Initialization procedures have a special extra accessitility 625 -- parameter associated with the level at which the object 626 -- begin initialized exists 627 628 elsif Ekind (E) = E_Record_Type 629 and then Is_Limited_Record (E) 630 and then Current_Scope = Init_Proc (E) 631 and then Present (Init_Proc_Level_Formal (Current_Scope)) 632 then 633 return New_Occurrence_Of 634 (Init_Proc_Level_Formal (Current_Scope), Loc); 635 636 -- Current instance of the type is deeper than that of the type 637 -- according to RM 3.10.2 (21). 638 639 elsif Is_Type (E) then 640 return Make_Level_Literal 641 (Type_Access_Level (E) + 1); 642 643 -- Move up the renamed entity if it came from source since 644 -- expansion may have created a dummy renaming under certain 645 -- circumstances. 646 647 elsif Present (Renamed_Object (E)) 648 and then Comes_From_Source (Renamed_Object (E)) 649 then 650 return Accessibility_Level (Renamed_Object (E)); 651 652 -- Named access types get their level from their associated type 653 654 elsif Is_Named_Access_Type (Etype (E)) then 655 return Make_Level_Literal 656 (Type_Access_Level (Etype (E))); 657 658 -- When E is a component of the current instance of a 659 -- protected type, we assume the level to be deeper than that of 660 -- the type itself. 661 662 elsif not Is_Overloadable (E) 663 and then Ekind (Scope (E)) = E_Protected_Type 664 and then Comes_From_Source (Scope (E)) 665 then 666 return Make_Level_Literal 667 (Scope_Depth (Enclosing_Dynamic_Scope (E)) + 1); 668 669 -- Normal object - get the level of the enclosing scope 670 671 else 672 return Make_Level_Literal 673 (Scope_Depth (Enclosing_Dynamic_Scope (E))); 674 end if; 675 676 -- Handle indexed and selected components including the special cases 677 -- whereby there is an implicit dereference, a component of a 678 -- composite type, or a function call in prefix notation. 679 680 -- We don't handle function calls in prefix notation correctly ??? 681 682 when N_Indexed_Component | N_Selected_Component => 683 Pre := Original_Node (Prefix (E)); 684 685 -- When E is an indexed component or selected component and 686 -- the current Expr is a function call, we know that we are 687 -- looking at an expanded call in prefix notation. 688 689 if Nkind (Expr) = N_Function_Call then 690 return Function_Call_Or_Allocator_Level (Expr); 691 692 -- If the prefix is a named access type, then we are dealing 693 -- with an implicit deferences. In that case the level is that 694 -- of the named access type in the prefix. 695 696 elsif Is_Named_Access_Type (Etype (Pre)) then 697 return Make_Level_Literal 698 (Type_Access_Level (Etype (Pre))); 699 700 -- The current expression is a named access type, so there is no 701 -- reason to look at the prefix. Instead obtain the level of E's 702 -- named access type. 703 704 elsif Is_Named_Access_Type (Etype (E)) then 705 return Make_Level_Literal 706 (Type_Access_Level (Etype (E))); 707 708 -- A non-discriminant selected component where the component 709 -- is an anonymous access type means that its associated 710 -- level is that of the containing type - see RM 3.10.2 (16). 711 712 elsif Nkind (E) = N_Selected_Component 713 and then Ekind (Etype (E)) = E_Anonymous_Access_Type 714 and then Ekind (Etype (Pre)) /= E_Anonymous_Access_Type 715 and then not (Nkind (Selector_Name (E)) in N_Has_Entity 716 and then Ekind (Entity (Selector_Name (E))) 717 = E_Discriminant) 718 then 719 return Make_Level_Literal 720 (Type_Access_Level (Etype (Prefix (E)))); 721 722 -- Similar to the previous case - arrays featuring components of 723 -- anonymous access components get their corresponding level from 724 -- their containing type's declaration. 725 726 elsif Nkind (E) = N_Indexed_Component 727 and then Ekind (Etype (E)) = E_Anonymous_Access_Type 728 and then Ekind (Etype (Pre)) in Array_Kind 729 and then Ekind (Component_Type (Base_Type (Etype (Pre)))) 730 = E_Anonymous_Access_Type 731 then 732 return Make_Level_Literal 733 (Type_Access_Level (Etype (Prefix (E)))); 734 735 -- The accessibility calculation routine that handles function 736 -- calls (Function_Call_Level) assumes, in the case the 737 -- result is of an anonymous access type, that the result will be 738 -- used "in its entirety" when the call is present within an 739 -- assignment or object declaration. 740 741 -- To properly handle cases where the result is not used in its 742 -- entirety, we test if the prefix of the component in question is 743 -- a function call, which tells us that one of its components has 744 -- been identified and is being accessed. Therefore we can 745 -- conclude that the result is not used "in its entirety" 746 -- according to RM 3.10.2 (10.2/3). 747 748 elsif Nkind (Pre) = N_Function_Call 749 and then not Is_Named_Access_Type (Etype (Pre)) 750 then 751 -- Dynamic checks are generated when we are within a return 752 -- value or we are in a function call within an anonymous 753 -- access discriminant constraint of a return object (signified 754 -- by In_Return_Context) on the side of the callee. 755 756 -- So, in this case, return a library accessibility level to 757 -- null out the check on the side of the caller. 758 759 if (In_Return_Value (E) 760 or else In_Return_Context) 761 and then Level /= Dynamic_Level 762 then 763 return Make_Level_Literal 764 (Scope_Depth (Standard_Standard)); 765 end if; 766 767 return Make_Level_Literal 768 (Innermost_Master_Scope_Depth (Expr)); 769 770 -- Otherwise, continue recursing over the expression prefixes 771 772 else 773 return Accessibility_Level (Prefix (E)); 774 end if; 775 776 -- Qualified expressions 777 778 when N_Qualified_Expression => 779 if Is_Named_Access_Type (Etype (E)) then 780 return Make_Level_Literal 781 (Type_Access_Level (Etype (E))); 782 else 783 return Accessibility_Level (Expression (E)); 784 end if; 785 786 -- Handle function calls 787 788 when N_Function_Call => 789 return Function_Call_Or_Allocator_Level (E); 790 791 -- Explicit dereference accessibility level calculation 792 793 when N_Explicit_Dereference => 794 Pre := Original_Node (Prefix (E)); 795 796 -- The prefix is a named access type so the level is taken from 797 -- its type. 798 799 if Is_Named_Access_Type (Etype (Pre)) then 800 return Make_Level_Literal (Type_Access_Level (Etype (Pre))); 801 802 -- Otherwise, recurse deeper 803 804 else 805 return Accessibility_Level (Prefix (E)); 806 end if; 807 808 -- Type conversions 809 810 when N_Type_Conversion | N_Unchecked_Type_Conversion => 811 -- View conversions are special in that they require use to 812 -- inspect the expression of the type conversion. 813 814 -- Allocators of anonymous access types are internally generated, 815 -- so recurse deeper in that case as well. 816 817 if Is_View_Conversion (E) 818 or else Ekind (Etype (E)) = E_Anonymous_Access_Type 819 then 820 return Accessibility_Level (Expression (E)); 821 822 -- We don't care about the master if we are looking at a named 823 -- access type. 824 825 elsif Is_Named_Access_Type (Etype (E)) then 826 return Make_Level_Literal 827 (Type_Access_Level (Etype (E))); 828 829 -- In section RM 3.10.2 (10/4) the accessibility rules for 830 -- aggregates and value conversions are outlined. Are these 831 -- followed in the case of initialization of an object ??? 832 833 -- Should use Innermost_Master_Scope_Depth ??? 834 835 else 836 return Accessibility_Level (Current_Scope); 837 end if; 838 839 -- Default to the type accessibility level for the type of the 840 -- expression's entity. 841 842 when others => 843 return Make_Level_Literal (Type_Access_Level (Etype (E))); 844 end case; 845 end Accessibility_Level; 846 847 -------------------------------- 848 -- Static_Accessibility_Level -- 849 -------------------------------- 850 851 function Static_Accessibility_Level 852 (Expr : Node_Id; 853 Level : Static_Accessibility_Level_Kind; 854 In_Return_Context : Boolean := False) return Uint 855 is 856 begin 857 return Intval 858 (Accessibility_Level (Expr, Level, In_Return_Context)); 859 end Static_Accessibility_Level; 860 861 ---------------------------------- 862 -- Acquire_Warning_Match_String -- 863 ---------------------------------- 864 865 function Acquire_Warning_Match_String (Str_Lit : Node_Id) return String is 866 S : constant String := To_String (Strval (Str_Lit)); 867 begin 868 if S = "" then 869 return ""; 870 else 871 -- Put "*" before or after or both, if it's not already there 872 873 declare 874 F : constant Boolean := S (S'First) = '*'; 875 L : constant Boolean := S (S'Last) = '*'; 876 begin 877 if F then 878 if L then 879 return S; 880 else 881 return S & "*"; 882 end if; 883 else 884 if L then 885 return "*" & S; 886 else 887 return "*" & S & "*"; 888 end if; 889 end if; 890 end; 891 end if; 892 end Acquire_Warning_Match_String; 893 894 -------------------------------- 895 -- Add_Access_Type_To_Process -- 896 -------------------------------- 897 898 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is 899 L : Elist_Id; 900 901 begin 902 Ensure_Freeze_Node (E); 903 L := Access_Types_To_Process (Freeze_Node (E)); 904 905 if No (L) then 906 L := New_Elmt_List; 907 Set_Access_Types_To_Process (Freeze_Node (E), L); 908 end if; 909 910 Append_Elmt (A, L); 911 end Add_Access_Type_To_Process; 912 913 -------------------------- 914 -- Add_Block_Identifier -- 915 -------------------------- 916 917 procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is 918 Loc : constant Source_Ptr := Sloc (N); 919 begin 920 pragma Assert (Nkind (N) = N_Block_Statement); 921 922 -- The block already has a label, return its entity 923 924 if Present (Identifier (N)) then 925 Id := Entity (Identifier (N)); 926 927 -- Create a new block label and set its attributes 928 929 else 930 Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); 931 Set_Etype (Id, Standard_Void_Type); 932 Set_Parent (Id, N); 933 934 Set_Identifier (N, New_Occurrence_Of (Id, Loc)); 935 Set_Block_Node (Id, Identifier (N)); 936 end if; 937 end Add_Block_Identifier; 938 939 ---------------------------- 940 -- Add_Global_Declaration -- 941 ---------------------------- 942 943 procedure Add_Global_Declaration (N : Node_Id) is 944 Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit)); 945 946 begin 947 if No (Declarations (Aux_Node)) then 948 Set_Declarations (Aux_Node, New_List); 949 end if; 950 951 Append_To (Declarations (Aux_Node), N); 952 Analyze (N); 953 end Add_Global_Declaration; 954 955 -------------------------------- 956 -- Address_Integer_Convert_OK -- 957 -------------------------------- 958 959 function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is 960 begin 961 if Allow_Integer_Address 962 and then ((Is_Descendant_Of_Address (T1) 963 and then Is_Private_Type (T1) 964 and then Is_Integer_Type (T2)) 965 or else 966 (Is_Descendant_Of_Address (T2) 967 and then Is_Private_Type (T2) 968 and then Is_Integer_Type (T1))) 969 then 970 return True; 971 else 972 return False; 973 end if; 974 end Address_Integer_Convert_OK; 975 976 ------------------- 977 -- Address_Value -- 978 ------------------- 979 980 function Address_Value (N : Node_Id) return Node_Id is 981 Expr : Node_Id := N; 982 983 begin 984 loop 985 -- For constant, get constant expression 986 987 if Is_Entity_Name (Expr) 988 and then Ekind (Entity (Expr)) = E_Constant 989 then 990 Expr := Constant_Value (Entity (Expr)); 991 992 -- For unchecked conversion, get result to convert 993 994 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then 995 Expr := Expression (Expr); 996 997 -- For (common case) of To_Address call, get argument 998 999 elsif Nkind (Expr) = N_Function_Call 1000 and then Is_Entity_Name (Name (Expr)) 1001 and then Is_RTE (Entity (Name (Expr)), RE_To_Address) 1002 then 1003 Expr := First (Parameter_Associations (Expr)); 1004 1005 if Nkind (Expr) = N_Parameter_Association then 1006 Expr := Explicit_Actual_Parameter (Expr); 1007 end if; 1008 1009 -- We finally have the real expression 1010 1011 else 1012 exit; 1013 end if; 1014 end loop; 1015 1016 return Expr; 1017 end Address_Value; 1018 1019 ----------------- 1020 -- Addressable -- 1021 ----------------- 1022 1023 function Addressable (V : Uint) return Boolean is 1024 begin 1025 return V = Uint_8 or else 1026 V = Uint_16 or else 1027 V = Uint_32 or else 1028 V = Uint_64 or else 1029 (V = Uint_128 and then System_Max_Integer_Size = 128); 1030 end Addressable; 1031 1032 function Addressable (V : Int) return Boolean is 1033 begin 1034 return V = 8 or else 1035 V = 16 or else 1036 V = 32 or else 1037 V = 64 or else 1038 V = System_Max_Integer_Size; 1039 end Addressable; 1040 1041 --------------------------------- 1042 -- Aggregate_Constraint_Checks -- 1043 --------------------------------- 1044 1045 procedure Aggregate_Constraint_Checks 1046 (Exp : Node_Id; 1047 Check_Typ : Entity_Id) 1048 is 1049 Exp_Typ : constant Entity_Id := Etype (Exp); 1050 1051 begin 1052 if Raises_Constraint_Error (Exp) then 1053 return; 1054 end if; 1055 1056 -- Ada 2005 (AI-230): Generate a conversion to an anonymous access 1057 -- component's type to force the appropriate accessibility checks. 1058 1059 -- Ada 2005 (AI-231): Generate conversion to the null-excluding type to 1060 -- force the corresponding run-time check 1061 1062 if Is_Access_Type (Check_Typ) 1063 and then Is_Local_Anonymous_Access (Check_Typ) 1064 then 1065 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); 1066 Analyze_And_Resolve (Exp, Check_Typ); 1067 Check_Unset_Reference (Exp); 1068 end if; 1069 1070 -- What follows is really expansion activity, so check that expansion 1071 -- is on and is allowed. In GNATprove mode, we also want check flags to 1072 -- be added in the tree, so that the formal verification can rely on 1073 -- those to be present. In GNATprove mode for formal verification, some 1074 -- treatment typically only done during expansion needs to be performed 1075 -- on the tree, but it should not be applied inside generics. Otherwise, 1076 -- this breaks the name resolution mechanism for generic instances. 1077 1078 if not Expander_Active 1079 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode) 1080 then 1081 return; 1082 end if; 1083 1084 if Is_Access_Type (Check_Typ) 1085 and then Can_Never_Be_Null (Check_Typ) 1086 and then not Can_Never_Be_Null (Exp_Typ) 1087 then 1088 Install_Null_Excluding_Check (Exp); 1089 end if; 1090 1091 -- First check if we have to insert discriminant checks 1092 1093 if Has_Discriminants (Exp_Typ) then 1094 Apply_Discriminant_Check (Exp, Check_Typ); 1095 1096 -- Next emit length checks for array aggregates 1097 1098 elsif Is_Array_Type (Exp_Typ) then 1099 Apply_Length_Check (Exp, Check_Typ); 1100 1101 -- Finally emit scalar and string checks. If we are dealing with a 1102 -- scalar literal we need to check by hand because the Etype of 1103 -- literals is not necessarily correct. 1104 1105 elsif Is_Scalar_Type (Exp_Typ) 1106 and then Compile_Time_Known_Value (Exp) 1107 then 1108 if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then 1109 Apply_Compile_Time_Constraint_Error 1110 (Exp, "value not in range of}??", CE_Range_Check_Failed, 1111 Ent => Base_Type (Check_Typ), 1112 Typ => Base_Type (Check_Typ)); 1113 1114 elsif Is_Out_Of_Range (Exp, Check_Typ) then 1115 Apply_Compile_Time_Constraint_Error 1116 (Exp, "value not in range of}??", CE_Range_Check_Failed, 1117 Ent => Check_Typ, 1118 Typ => Check_Typ); 1119 1120 elsif not Range_Checks_Suppressed (Check_Typ) then 1121 Apply_Scalar_Range_Check (Exp, Check_Typ); 1122 end if; 1123 1124 -- Verify that target type is also scalar, to prevent view anomalies 1125 -- in instantiations. 1126 1127 elsif (Is_Scalar_Type (Exp_Typ) 1128 or else Nkind (Exp) = N_String_Literal) 1129 and then Is_Scalar_Type (Check_Typ) 1130 and then Exp_Typ /= Check_Typ 1131 then 1132 if Is_Entity_Name (Exp) 1133 and then Ekind (Entity (Exp)) = E_Constant 1134 then 1135 -- If expression is a constant, it is worthwhile checking whether 1136 -- it is a bound of the type. 1137 1138 if (Is_Entity_Name (Type_Low_Bound (Check_Typ)) 1139 and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ))) 1140 or else 1141 (Is_Entity_Name (Type_High_Bound (Check_Typ)) 1142 and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ))) 1143 then 1144 return; 1145 1146 else 1147 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); 1148 Analyze_And_Resolve (Exp, Check_Typ); 1149 Check_Unset_Reference (Exp); 1150 end if; 1151 1152 -- Could use a comment on this case ??? 1153 1154 else 1155 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); 1156 Analyze_And_Resolve (Exp, Check_Typ); 1157 Check_Unset_Reference (Exp); 1158 end if; 1159 1160 end if; 1161 end Aggregate_Constraint_Checks; 1162 1163 ----------------------- 1164 -- Alignment_In_Bits -- 1165 ----------------------- 1166 1167 function Alignment_In_Bits (E : Entity_Id) return Uint is 1168 begin 1169 return Alignment (E) * System_Storage_Unit; 1170 end Alignment_In_Bits; 1171 1172 -------------------------------------- 1173 -- All_Composite_Constraints_Static -- 1174 -------------------------------------- 1175 1176 function All_Composite_Constraints_Static 1177 (Constr : Node_Id) return Boolean 1178 is 1179 begin 1180 if No (Constr) or else Error_Posted (Constr) then 1181 return True; 1182 end if; 1183 1184 case Nkind (Constr) is 1185 when N_Subexpr => 1186 if Nkind (Constr) in N_Has_Entity 1187 and then Present (Entity (Constr)) 1188 then 1189 if Is_Type (Entity (Constr)) then 1190 return 1191 not Is_Discrete_Type (Entity (Constr)) 1192 or else Is_OK_Static_Subtype (Entity (Constr)); 1193 end if; 1194 1195 elsif Nkind (Constr) = N_Range then 1196 return 1197 Is_OK_Static_Expression (Low_Bound (Constr)) 1198 and then 1199 Is_OK_Static_Expression (High_Bound (Constr)); 1200 1201 elsif Nkind (Constr) = N_Attribute_Reference 1202 and then Attribute_Name (Constr) = Name_Range 1203 then 1204 return 1205 Is_OK_Static_Expression 1206 (Type_Low_Bound (Etype (Prefix (Constr)))) 1207 and then 1208 Is_OK_Static_Expression 1209 (Type_High_Bound (Etype (Prefix (Constr)))); 1210 end if; 1211 1212 return 1213 not Present (Etype (Constr)) -- previous error 1214 or else not Is_Discrete_Type (Etype (Constr)) 1215 or else Is_OK_Static_Expression (Constr); 1216 1217 when N_Discriminant_Association => 1218 return All_Composite_Constraints_Static (Expression (Constr)); 1219 1220 when N_Range_Constraint => 1221 return 1222 All_Composite_Constraints_Static (Range_Expression (Constr)); 1223 1224 when N_Index_Or_Discriminant_Constraint => 1225 declare 1226 One_Cstr : Entity_Id; 1227 begin 1228 One_Cstr := First (Constraints (Constr)); 1229 while Present (One_Cstr) loop 1230 if not All_Composite_Constraints_Static (One_Cstr) then 1231 return False; 1232 end if; 1233 1234 Next (One_Cstr); 1235 end loop; 1236 end; 1237 1238 return True; 1239 1240 when N_Subtype_Indication => 1241 return 1242 All_Composite_Constraints_Static (Subtype_Mark (Constr)) 1243 and then 1244 All_Composite_Constraints_Static (Constraint (Constr)); 1245 1246 when others => 1247 raise Program_Error; 1248 end case; 1249 end All_Composite_Constraints_Static; 1250 1251 ------------------------ 1252 -- Append_Entity_Name -- 1253 ------------------------ 1254 1255 procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is 1256 Temp : Bounded_String; 1257 1258 procedure Inner (E : Entity_Id); 1259 -- Inner recursive routine, keep outer routine nonrecursive to ease 1260 -- debugging when we get strange results from this routine. 1261 1262 ----------- 1263 -- Inner -- 1264 ----------- 1265 1266 procedure Inner (E : Entity_Id) is 1267 Scop : Node_Id; 1268 1269 begin 1270 -- If entity has an internal name, skip by it, and print its scope. 1271 -- Note that we strip a final R from the name before the test; this 1272 -- is needed for some cases of instantiations. 1273 1274 declare 1275 E_Name : Bounded_String; 1276 1277 begin 1278 Append (E_Name, Chars (E)); 1279 1280 if E_Name.Chars (E_Name.Length) = 'R' then 1281 E_Name.Length := E_Name.Length - 1; 1282 end if; 1283 1284 if Is_Internal_Name (E_Name) then 1285 Inner (Scope (E)); 1286 return; 1287 end if; 1288 end; 1289 1290 Scop := Scope (E); 1291 1292 -- Just print entity name if its scope is at the outer level 1293 1294 if Scop = Standard_Standard then 1295 null; 1296 1297 -- If scope comes from source, write scope and entity 1298 1299 elsif Comes_From_Source (Scop) then 1300 Append_Entity_Name (Temp, Scop); 1301 Append (Temp, '.'); 1302 1303 -- If in wrapper package skip past it 1304 1305 elsif Present (Scop) and then Is_Wrapper_Package (Scop) then 1306 Append_Entity_Name (Temp, Scope (Scop)); 1307 Append (Temp, '.'); 1308 1309 -- Otherwise nothing to output (happens in unnamed block statements) 1310 1311 else 1312 null; 1313 end if; 1314 1315 -- Output the name 1316 1317 declare 1318 E_Name : Bounded_String; 1319 1320 begin 1321 Append_Unqualified_Decoded (E_Name, Chars (E)); 1322 1323 -- Remove trailing upper-case letters from the name (useful for 1324 -- dealing with some cases of internal names generated in the case 1325 -- of references from within a generic). 1326 1327 while E_Name.Length > 1 1328 and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z' 1329 loop 1330 E_Name.Length := E_Name.Length - 1; 1331 end loop; 1332 1333 -- Adjust casing appropriately (gets name from source if possible) 1334 1335 Adjust_Name_Case (E_Name, Sloc (E)); 1336 Append (Temp, E_Name); 1337 end; 1338 end Inner; 1339 1340 -- Start of processing for Append_Entity_Name 1341 1342 begin 1343 Inner (E); 1344 Append (Buf, Temp); 1345 end Append_Entity_Name; 1346 1347 --------------------------------- 1348 -- Append_Inherited_Subprogram -- 1349 --------------------------------- 1350 1351 procedure Append_Inherited_Subprogram (S : Entity_Id) is 1352 Par : constant Entity_Id := Alias (S); 1353 -- The parent subprogram 1354 1355 Scop : constant Entity_Id := Scope (Par); 1356 -- The scope of definition of the parent subprogram 1357 1358 Typ : constant Entity_Id := Defining_Entity (Parent (S)); 1359 -- The derived type of which S is a primitive operation 1360 1361 Decl : Node_Id; 1362 Next_E : Entity_Id; 1363 1364 begin 1365 if Ekind (Current_Scope) = E_Package 1366 and then In_Private_Part (Current_Scope) 1367 and then Has_Private_Declaration (Typ) 1368 and then Is_Tagged_Type (Typ) 1369 and then Scop = Current_Scope 1370 then 1371 -- The inherited operation is available at the earliest place after 1372 -- the derived type declaration (RM 7.3.1 (6/1)). This is only 1373 -- relevant for type extensions. If the parent operation appears 1374 -- after the type extension, the operation is not visible. 1375 1376 Decl := First 1377 (Visible_Declarations 1378 (Package_Specification (Current_Scope))); 1379 while Present (Decl) loop 1380 if Nkind (Decl) = N_Private_Extension_Declaration 1381 and then Defining_Entity (Decl) = Typ 1382 then 1383 if Sloc (Decl) > Sloc (Par) then 1384 Next_E := Next_Entity (Par); 1385 Link_Entities (Par, S); 1386 Link_Entities (S, Next_E); 1387 return; 1388 1389 else 1390 exit; 1391 end if; 1392 end if; 1393 1394 Next (Decl); 1395 end loop; 1396 end if; 1397 1398 -- If partial view is not a type extension, or it appears before the 1399 -- subprogram declaration, insert normally at end of entity list. 1400 1401 Append_Entity (S, Current_Scope); 1402 end Append_Inherited_Subprogram; 1403 1404 ----------------------------------------- 1405 -- Apply_Compile_Time_Constraint_Error -- 1406 ----------------------------------------- 1407 1408 procedure Apply_Compile_Time_Constraint_Error 1409 (N : Node_Id; 1410 Msg : String; 1411 Reason : RT_Exception_Code; 1412 Ent : Entity_Id := Empty; 1413 Typ : Entity_Id := Empty; 1414 Loc : Source_Ptr := No_Location; 1415 Rep : Boolean := True; 1416 Warn : Boolean := False) 1417 is 1418 Stat : constant Boolean := Is_Static_Expression (N); 1419 R_Stat : constant Node_Id := 1420 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason); 1421 Rtyp : Entity_Id; 1422 1423 begin 1424 if No (Typ) then 1425 Rtyp := Etype (N); 1426 else 1427 Rtyp := Typ; 1428 end if; 1429 1430 Discard_Node 1431 (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn)); 1432 1433 -- In GNATprove mode, do not replace the node with an exception raised. 1434 -- In such a case, either the call to Compile_Time_Constraint_Error 1435 -- issues an error which stops analysis, or it issues a warning in 1436 -- a few cases where a suitable check flag is set for GNATprove to 1437 -- generate a check message. 1438 1439 if not Rep or GNATprove_Mode then 1440 return; 1441 end if; 1442 1443 -- Now we replace the node by an N_Raise_Constraint_Error node 1444 -- This does not need reanalyzing, so set it as analyzed now. 1445 1446 Rewrite (N, R_Stat); 1447 Set_Analyzed (N, True); 1448 1449 Set_Etype (N, Rtyp); 1450 Set_Raises_Constraint_Error (N); 1451 1452 -- Now deal with possible local raise handling 1453 1454 Possible_Local_Raise (N, Standard_Constraint_Error); 1455 1456 -- If the original expression was marked as static, the result is 1457 -- still marked as static, but the Raises_Constraint_Error flag is 1458 -- always set so that further static evaluation is not attempted. 1459 1460 if Stat then 1461 Set_Is_Static_Expression (N); 1462 end if; 1463 end Apply_Compile_Time_Constraint_Error; 1464 1465 --------------------------- 1466 -- Async_Readers_Enabled -- 1467 --------------------------- 1468 1469 function Async_Readers_Enabled (Id : Entity_Id) return Boolean is 1470 begin 1471 return Has_Enabled_Property (Id, Name_Async_Readers); 1472 end Async_Readers_Enabled; 1473 1474 --------------------------- 1475 -- Async_Writers_Enabled -- 1476 --------------------------- 1477 1478 function Async_Writers_Enabled (Id : Entity_Id) return Boolean is 1479 begin 1480 return Has_Enabled_Property (Id, Name_Async_Writers); 1481 end Async_Writers_Enabled; 1482 1483 -------------------------------------- 1484 -- Available_Full_View_Of_Component -- 1485 -------------------------------------- 1486 1487 function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is 1488 ST : constant Entity_Id := Scope (T); 1489 SCT : constant Entity_Id := Scope (Component_Type (T)); 1490 begin 1491 return In_Open_Scopes (ST) 1492 and then In_Open_Scopes (SCT) 1493 and then Scope_Depth (ST) >= Scope_Depth (SCT); 1494 end Available_Full_View_Of_Component; 1495 1496 ------------------- 1497 -- Bad_Attribute -- 1498 ------------------- 1499 1500 procedure Bad_Attribute 1501 (N : Node_Id; 1502 Nam : Name_Id; 1503 Warn : Boolean := False) 1504 is 1505 begin 1506 Error_Msg_Warn := Warn; 1507 Error_Msg_N ("unrecognized attribute&<<", N); 1508 1509 -- Check for possible misspelling 1510 1511 Error_Msg_Name_1 := First_Attribute_Name; 1512 while Error_Msg_Name_1 <= Last_Attribute_Name loop 1513 if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then 1514 Error_Msg_N -- CODEFIX 1515 ("\possible misspelling of %<<", N); 1516 exit; 1517 end if; 1518 1519 Error_Msg_Name_1 := Error_Msg_Name_1 + 1; 1520 end loop; 1521 end Bad_Attribute; 1522 1523 -------------------------------- 1524 -- Bad_Predicated_Subtype_Use -- 1525 -------------------------------- 1526 1527 procedure Bad_Predicated_Subtype_Use 1528 (Msg : String; 1529 N : Node_Id; 1530 Typ : Entity_Id; 1531 Suggest_Static : Boolean := False) 1532 is 1533 Gen : Entity_Id; 1534 1535 begin 1536 -- Avoid cascaded errors 1537 1538 if Error_Posted (N) then 1539 return; 1540 end if; 1541 1542 if Inside_A_Generic then 1543 Gen := Current_Scope; 1544 while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop 1545 Gen := Scope (Gen); 1546 end loop; 1547 1548 if No (Gen) then 1549 return; 1550 end if; 1551 1552 if Is_Generic_Formal (Typ) and then Is_Discrete_Type (Typ) then 1553 Set_No_Predicate_On_Actual (Typ); 1554 end if; 1555 1556 elsif Has_Predicates (Typ) then 1557 if Is_Generic_Actual_Type (Typ) then 1558 1559 -- The restriction on loop parameters is only that the type 1560 -- should have no dynamic predicates. 1561 1562 if Nkind (Parent (N)) = N_Loop_Parameter_Specification 1563 and then not Has_Dynamic_Predicate_Aspect (Typ) 1564 and then Is_OK_Static_Subtype (Typ) 1565 then 1566 return; 1567 end if; 1568 1569 Gen := Current_Scope; 1570 while not Is_Generic_Instance (Gen) loop 1571 Gen := Scope (Gen); 1572 end loop; 1573 1574 pragma Assert (Present (Gen)); 1575 1576 if Ekind (Gen) = E_Package and then In_Package_Body (Gen) then 1577 Error_Msg_Warn := SPARK_Mode /= On; 1578 Error_Msg_FE (Msg & "<<", N, Typ); 1579 Error_Msg_F ("\Program_Error [<<", N); 1580 1581 Insert_Action (N, 1582 Make_Raise_Program_Error (Sloc (N), 1583 Reason => PE_Bad_Predicated_Generic_Type)); 1584 1585 else 1586 Error_Msg_FE (Msg, N, Typ); 1587 end if; 1588 1589 else 1590 Error_Msg_FE (Msg, N, Typ); 1591 end if; 1592 1593 -- Emit an optional suggestion on how to remedy the error if the 1594 -- context warrants it. 1595 1596 if Suggest_Static and then Has_Static_Predicate (Typ) then 1597 Error_Msg_FE ("\predicate of & should be marked static", N, Typ); 1598 end if; 1599 end if; 1600 end Bad_Predicated_Subtype_Use; 1601 1602 ----------------------------------------- 1603 -- Bad_Unordered_Enumeration_Reference -- 1604 ----------------------------------------- 1605 1606 function Bad_Unordered_Enumeration_Reference 1607 (N : Node_Id; 1608 T : Entity_Id) return Boolean 1609 is 1610 begin 1611 return Is_Enumeration_Type (T) 1612 and then Warn_On_Unordered_Enumeration_Type 1613 and then not Is_Generic_Type (T) 1614 and then Comes_From_Source (N) 1615 and then not Has_Pragma_Ordered (T) 1616 and then not In_Same_Extended_Unit (N, T); 1617 end Bad_Unordered_Enumeration_Reference; 1618 1619 ---------------------------- 1620 -- Begin_Keyword_Location -- 1621 ---------------------------- 1622 1623 function Begin_Keyword_Location (N : Node_Id) return Source_Ptr is 1624 HSS : Node_Id; 1625 1626 begin 1627 pragma Assert 1628 (Nkind (N) in 1629 N_Block_Statement | 1630 N_Entry_Body | 1631 N_Package_Body | 1632 N_Subprogram_Body | 1633 N_Task_Body); 1634 1635 HSS := Handled_Statement_Sequence (N); 1636 1637 -- When the handled sequence of statements comes from source, the 1638 -- location of the "begin" keyword is that of the sequence itself. 1639 -- Note that an internal construct may inherit a source sequence. 1640 1641 if Comes_From_Source (HSS) then 1642 return Sloc (HSS); 1643 1644 -- The parser generates an internal handled sequence of statements to 1645 -- capture the location of the "begin" keyword if present in the source. 1646 -- Since there are no source statements, the location of the "begin" 1647 -- keyword is effectively that of the "end" keyword. 1648 1649 elsif Comes_From_Source (N) then 1650 return Sloc (HSS); 1651 1652 -- Otherwise the construct is internal and should carry the location of 1653 -- the original construct which prompted its creation. 1654 1655 else 1656 return Sloc (N); 1657 end if; 1658 end Begin_Keyword_Location; 1659 1660 -------------------------- 1661 -- Build_Actual_Subtype -- 1662 -------------------------- 1663 1664 function Build_Actual_Subtype 1665 (T : Entity_Id; 1666 N : Node_Or_Entity_Id) return Node_Id 1667 is 1668 Loc : Source_Ptr; 1669 -- Normally Sloc (N), but may point to corresponding body in some cases 1670 1671 Constraints : List_Id; 1672 Decl : Node_Id; 1673 Discr : Entity_Id; 1674 Hi : Node_Id; 1675 Lo : Node_Id; 1676 Subt : Entity_Id; 1677 Disc_Type : Entity_Id; 1678 Obj : Node_Id; 1679 1680 begin 1681 Loc := Sloc (N); 1682 1683 if Nkind (N) = N_Defining_Identifier then 1684 Obj := New_Occurrence_Of (N, Loc); 1685 1686 -- If this is a formal parameter of a subprogram declaration, and 1687 -- we are compiling the body, we want the declaration for the 1688 -- actual subtype to carry the source position of the body, to 1689 -- prevent anomalies in gdb when stepping through the code. 1690 1691 if Is_Formal (N) then 1692 declare 1693 Decl : constant Node_Id := Unit_Declaration_Node (Scope (N)); 1694 begin 1695 if Nkind (Decl) = N_Subprogram_Declaration 1696 and then Present (Corresponding_Body (Decl)) 1697 then 1698 Loc := Sloc (Corresponding_Body (Decl)); 1699 end if; 1700 end; 1701 end if; 1702 1703 else 1704 Obj := N; 1705 end if; 1706 1707 if Is_Array_Type (T) then 1708 Constraints := New_List; 1709 for J in 1 .. Number_Dimensions (T) loop 1710 1711 -- Build an array subtype declaration with the nominal subtype and 1712 -- the bounds of the actual. Add the declaration in front of the 1713 -- local declarations for the subprogram, for analysis before any 1714 -- reference to the formal in the body. 1715 1716 Lo := 1717 Make_Attribute_Reference (Loc, 1718 Prefix => 1719 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), 1720 Attribute_Name => Name_First, 1721 Expressions => New_List ( 1722 Make_Integer_Literal (Loc, J))); 1723 1724 Hi := 1725 Make_Attribute_Reference (Loc, 1726 Prefix => 1727 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), 1728 Attribute_Name => Name_Last, 1729 Expressions => New_List ( 1730 Make_Integer_Literal (Loc, J))); 1731 1732 Append (Make_Range (Loc, Lo, Hi), Constraints); 1733 end loop; 1734 1735 -- If the type has unknown discriminants there is no constrained 1736 -- subtype to build. This is never called for a formal or for a 1737 -- lhs, so returning the type is ok ??? 1738 1739 elsif Has_Unknown_Discriminants (T) then 1740 return T; 1741 1742 else 1743 Constraints := New_List; 1744 1745 -- Type T is a generic derived type, inherit the discriminants from 1746 -- the parent type. 1747 1748 if Is_Private_Type (T) 1749 and then No (Full_View (T)) 1750 1751 -- T was flagged as an error if it was declared as a formal 1752 -- derived type with known discriminants. In this case there 1753 -- is no need to look at the parent type since T already carries 1754 -- its own discriminants. 1755 1756 and then not Error_Posted (T) 1757 then 1758 Disc_Type := Etype (Base_Type (T)); 1759 else 1760 Disc_Type := T; 1761 end if; 1762 1763 Discr := First_Discriminant (Disc_Type); 1764 while Present (Discr) loop 1765 Append_To (Constraints, 1766 Make_Selected_Component (Loc, 1767 Prefix => 1768 Duplicate_Subexpr_No_Checks (Obj), 1769 Selector_Name => New_Occurrence_Of (Discr, Loc))); 1770 Next_Discriminant (Discr); 1771 end loop; 1772 end if; 1773 1774 Subt := Make_Temporary (Loc, 'S', Related_Node => N); 1775 Set_Is_Internal (Subt); 1776 1777 Decl := 1778 Make_Subtype_Declaration (Loc, 1779 Defining_Identifier => Subt, 1780 Subtype_Indication => 1781 Make_Subtype_Indication (Loc, 1782 Subtype_Mark => New_Occurrence_Of (T, Loc), 1783 Constraint => 1784 Make_Index_Or_Discriminant_Constraint (Loc, 1785 Constraints => Constraints))); 1786 1787 Mark_Rewrite_Insertion (Decl); 1788 return Decl; 1789 end Build_Actual_Subtype; 1790 1791 --------------------------------------- 1792 -- Build_Actual_Subtype_Of_Component -- 1793 --------------------------------------- 1794 1795 function Build_Actual_Subtype_Of_Component 1796 (T : Entity_Id; 1797 N : Node_Id) return Node_Id 1798 is 1799 Loc : constant Source_Ptr := Sloc (N); 1800 P : constant Node_Id := Prefix (N); 1801 1802 D : Elmt_Id; 1803 Id : Node_Id; 1804 Index_Typ : Entity_Id; 1805 Sel : Entity_Id := Empty; 1806 1807 Desig_Typ : Entity_Id; 1808 -- This is either a copy of T, or if T is an access type, then it is 1809 -- the directly designated type of this access type. 1810 1811 function Build_Access_Record_Constraint (C : List_Id) return List_Id; 1812 -- If the record component is a constrained access to the current 1813 -- record, the subtype has not been constructed during analysis of 1814 -- the enclosing record type (see Analyze_Access). In that case, build 1815 -- a constrained access subtype after replacing references to the 1816 -- enclosing discriminants with the corresponding discriminant values 1817 -- of the prefix. 1818 1819 function Build_Actual_Array_Constraint return List_Id; 1820 -- If one or more of the bounds of the component depends on 1821 -- discriminants, build actual constraint using the discriminants 1822 -- of the prefix, as above. 1823 1824 function Build_Actual_Record_Constraint return List_Id; 1825 -- Similar to previous one, for discriminated components constrained 1826 -- by the discriminant of the enclosing object. 1827 1828 function Copy_And_Maybe_Dereference (N : Node_Id) return Node_Id; 1829 -- Copy the subtree rooted at N and insert an explicit dereference if it 1830 -- is of an access type. 1831 1832 ----------------------------------- 1833 -- Build_Actual_Array_Constraint -- 1834 ----------------------------------- 1835 1836 function Build_Actual_Array_Constraint return List_Id is 1837 Constraints : constant List_Id := New_List; 1838 Indx : Node_Id; 1839 Hi : Node_Id; 1840 Lo : Node_Id; 1841 Old_Hi : Node_Id; 1842 Old_Lo : Node_Id; 1843 1844 begin 1845 Indx := First_Index (Desig_Typ); 1846 while Present (Indx) loop 1847 Old_Lo := Type_Low_Bound (Etype (Indx)); 1848 Old_Hi := Type_High_Bound (Etype (Indx)); 1849 1850 if Denotes_Discriminant (Old_Lo) then 1851 Lo := 1852 Make_Selected_Component (Loc, 1853 Prefix => Copy_And_Maybe_Dereference (P), 1854 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc)); 1855 1856 else 1857 Lo := New_Copy_Tree (Old_Lo); 1858 1859 -- The new bound will be reanalyzed in the enclosing 1860 -- declaration. For literal bounds that come from a type 1861 -- declaration, the type of the context must be imposed, so 1862 -- insure that analysis will take place. For non-universal 1863 -- types this is not strictly necessary. 1864 1865 Set_Analyzed (Lo, False); 1866 end if; 1867 1868 if Denotes_Discriminant (Old_Hi) then 1869 Hi := 1870 Make_Selected_Component (Loc, 1871 Prefix => Copy_And_Maybe_Dereference (P), 1872 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc)); 1873 1874 else 1875 Hi := New_Copy_Tree (Old_Hi); 1876 Set_Analyzed (Hi, False); 1877 end if; 1878 1879 Append (Make_Range (Loc, Lo, Hi), Constraints); 1880 Next_Index (Indx); 1881 end loop; 1882 1883 return Constraints; 1884 end Build_Actual_Array_Constraint; 1885 1886 ------------------------------------ 1887 -- Build_Actual_Record_Constraint -- 1888 ------------------------------------ 1889 1890 function Build_Actual_Record_Constraint return List_Id is 1891 Constraints : constant List_Id := New_List; 1892 D : Elmt_Id; 1893 D_Val : Node_Id; 1894 1895 begin 1896 D := First_Elmt (Discriminant_Constraint (Desig_Typ)); 1897 while Present (D) loop 1898 if Denotes_Discriminant (Node (D)) then 1899 D_Val := Make_Selected_Component (Loc, 1900 Prefix => Copy_And_Maybe_Dereference (P), 1901 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc)); 1902 1903 else 1904 D_Val := New_Copy_Tree (Node (D)); 1905 end if; 1906 1907 Append (D_Val, Constraints); 1908 Next_Elmt (D); 1909 end loop; 1910 1911 return Constraints; 1912 end Build_Actual_Record_Constraint; 1913 1914 ------------------------------------ 1915 -- Build_Access_Record_Constraint -- 1916 ------------------------------------ 1917 1918 function Build_Access_Record_Constraint (C : List_Id) return List_Id is 1919 Constraints : constant List_Id := New_List; 1920 D : Node_Id; 1921 D_Val : Node_Id; 1922 1923 begin 1924 -- Retrieve the constraint from the component declaration, because 1925 -- the component subtype has not been constructed and the component 1926 -- type is an unconstrained access. 1927 1928 D := First (C); 1929 while Present (D) loop 1930 if Nkind (D) = N_Discriminant_Association 1931 and then Denotes_Discriminant (Expression (D)) 1932 then 1933 D_Val := New_Copy_Tree (D); 1934 Set_Expression (D_Val, 1935 Make_Selected_Component (Loc, 1936 Prefix => Copy_And_Maybe_Dereference (P), 1937 Selector_Name => 1938 New_Occurrence_Of (Entity (Expression (D)), Loc))); 1939 1940 elsif Denotes_Discriminant (D) then 1941 D_Val := Make_Selected_Component (Loc, 1942 Prefix => Copy_And_Maybe_Dereference (P), 1943 Selector_Name => New_Occurrence_Of (Entity (D), Loc)); 1944 1945 else 1946 D_Val := New_Copy_Tree (D); 1947 end if; 1948 1949 Append (D_Val, Constraints); 1950 Next (D); 1951 end loop; 1952 1953 return Constraints; 1954 end Build_Access_Record_Constraint; 1955 1956 -------------------------------- 1957 -- Copy_And_Maybe_Dereference -- 1958 -------------------------------- 1959 1960 function Copy_And_Maybe_Dereference (N : Node_Id) return Node_Id is 1961 New_N : constant Node_Id := New_Copy_Tree (N); 1962 1963 begin 1964 if Is_Access_Type (Etype (N)) then 1965 return Make_Explicit_Dereference (Sloc (Parent (N)), New_N); 1966 1967 else 1968 return New_N; 1969 end if; 1970 end Copy_And_Maybe_Dereference; 1971 1972 -- Start of processing for Build_Actual_Subtype_Of_Component 1973 1974 begin 1975 -- The subtype does not need to be created for a selected component 1976 -- in a Spec_Expression. 1977 1978 if In_Spec_Expression then 1979 return Empty; 1980 1981 -- More comments for the rest of this body would be good ??? 1982 1983 elsif Nkind (N) = N_Explicit_Dereference then 1984 if Is_Composite_Type (T) 1985 and then not Is_Constrained (T) 1986 and then not (Is_Class_Wide_Type (T) 1987 and then Is_Constrained (Root_Type (T))) 1988 and then not Has_Unknown_Discriminants (T) 1989 then 1990 -- If the type of the dereference is already constrained, it is an 1991 -- actual subtype. 1992 1993 if Is_Array_Type (Etype (N)) 1994 and then Is_Constrained (Etype (N)) 1995 then 1996 return Empty; 1997 else 1998 Remove_Side_Effects (P); 1999 return Build_Actual_Subtype (T, N); 2000 end if; 2001 2002 else 2003 return Empty; 2004 end if; 2005 2006 elsif Nkind (N) = N_Selected_Component then 2007 -- The entity of the selected component allows us to retrieve 2008 -- the original constraint from its component declaration. 2009 2010 Sel := Entity (Selector_Name (N)); 2011 if Nkind (Parent (Sel)) /= N_Component_Declaration then 2012 return Empty; 2013 end if; 2014 end if; 2015 2016 if Is_Access_Type (T) then 2017 Desig_Typ := Designated_Type (T); 2018 2019 else 2020 Desig_Typ := T; 2021 end if; 2022 2023 if Ekind (Desig_Typ) = E_Array_Subtype then 2024 Id := First_Index (Desig_Typ); 2025 2026 -- Check whether an index bound is constrained by a discriminant 2027 2028 while Present (Id) loop 2029 Index_Typ := Underlying_Type (Etype (Id)); 2030 2031 if Denotes_Discriminant (Type_Low_Bound (Index_Typ)) 2032 or else 2033 Denotes_Discriminant (Type_High_Bound (Index_Typ)) 2034 then 2035 Remove_Side_Effects (P); 2036 return 2037 Build_Component_Subtype 2038 (Build_Actual_Array_Constraint, Loc, Base_Type (T)); 2039 end if; 2040 2041 Next_Index (Id); 2042 end loop; 2043 2044 elsif Is_Composite_Type (Desig_Typ) 2045 and then Has_Discriminants (Desig_Typ) 2046 and then not Is_Empty_Elmt_List (Discriminant_Constraint (Desig_Typ)) 2047 and then not Has_Unknown_Discriminants (Desig_Typ) 2048 then 2049 if Is_Private_Type (Desig_Typ) 2050 and then No (Discriminant_Constraint (Desig_Typ)) 2051 then 2052 Desig_Typ := Full_View (Desig_Typ); 2053 end if; 2054 2055 D := First_Elmt (Discriminant_Constraint (Desig_Typ)); 2056 while Present (D) loop 2057 if Denotes_Discriminant (Node (D)) then 2058 Remove_Side_Effects (P); 2059 return 2060 Build_Component_Subtype ( 2061 Build_Actual_Record_Constraint, Loc, Base_Type (T)); 2062 end if; 2063 2064 Next_Elmt (D); 2065 end loop; 2066 2067 -- Special processing for an access record component that is 2068 -- the target of an assignment. If the designated type is an 2069 -- unconstrained discriminated record we create its actual 2070 -- subtype now. 2071 2072 elsif Ekind (T) = E_Access_Type 2073 and then Present (Sel) 2074 and then Has_Per_Object_Constraint (Sel) 2075 and then Nkind (Parent (N)) = N_Assignment_Statement 2076 and then N = Name (Parent (N)) 2077 -- and then not Inside_Init_Proc 2078 -- and then Has_Discriminants (Desig_Typ) 2079 -- and then not Is_Constrained (Desig_Typ) 2080 then 2081 declare 2082 S_Indic : constant Node_Id := 2083 (Subtype_Indication 2084 (Component_Definition (Parent (Sel)))); 2085 Discs : List_Id; 2086 begin 2087 if Nkind (S_Indic) = N_Subtype_Indication then 2088 Discs := Constraints (Constraint (S_Indic)); 2089 2090 Remove_Side_Effects (P); 2091 return Build_Component_Subtype 2092 (Build_Access_Record_Constraint (Discs), Loc, T); 2093 else 2094 return Empty; 2095 end if; 2096 end; 2097 end if; 2098 2099 -- If none of the above, the actual and nominal subtypes are the same 2100 2101 return Empty; 2102 end Build_Actual_Subtype_Of_Component; 2103 2104 --------------------------------- 2105 -- Build_Class_Wide_Clone_Body -- 2106 --------------------------------- 2107 2108 procedure Build_Class_Wide_Clone_Body 2109 (Spec_Id : Entity_Id; 2110 Bod : Node_Id) 2111 is 2112 Loc : constant Source_Ptr := Sloc (Bod); 2113 Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id); 2114 Clone_Body : Node_Id; 2115 Assoc_List : constant Elist_Id := New_Elmt_List; 2116 2117 begin 2118 -- The declaration of the class-wide clone was created when the 2119 -- corresponding class-wide condition was analyzed. 2120 2121 -- The body of the original condition may contain references to 2122 -- the formals of Spec_Id. In the body of the class-wide clone, 2123 -- these must be replaced with the corresponding formals of 2124 -- the clone. 2125 2126 declare 2127 Spec_Formal_Id : Entity_Id := First_Formal (Spec_Id); 2128 Clone_Formal_Id : Entity_Id := First_Formal (Clone_Id); 2129 begin 2130 while Present (Spec_Formal_Id) loop 2131 Append_Elmt (Spec_Formal_Id, Assoc_List); 2132 Append_Elmt (Clone_Formal_Id, Assoc_List); 2133 2134 Next_Formal (Spec_Formal_Id); 2135 Next_Formal (Clone_Formal_Id); 2136 end loop; 2137 end; 2138 2139 Clone_Body := 2140 Make_Subprogram_Body (Loc, 2141 Specification => 2142 Copy_Subprogram_Spec (Parent (Clone_Id)), 2143 Declarations => Declarations (Bod), 2144 Handled_Statement_Sequence => 2145 New_Copy_Tree (Handled_Statement_Sequence (Bod), 2146 Map => Assoc_List)); 2147 2148 -- The new operation is internal and overriding indicators do not apply 2149 -- (the original primitive may have carried one). 2150 2151 Set_Must_Override (Specification (Clone_Body), False); 2152 2153 -- If the subprogram body is the proper body of a stub, insert the 2154 -- subprogram after the stub, i.e. the same declarative region as 2155 -- the original sugprogram. 2156 2157 if Nkind (Parent (Bod)) = N_Subunit then 2158 Insert_After (Corresponding_Stub (Parent (Bod)), Clone_Body); 2159 2160 else 2161 Insert_Before (Bod, Clone_Body); 2162 end if; 2163 2164 Analyze (Clone_Body); 2165 end Build_Class_Wide_Clone_Body; 2166 2167 --------------------------------- 2168 -- Build_Class_Wide_Clone_Call -- 2169 --------------------------------- 2170 2171 function Build_Class_Wide_Clone_Call 2172 (Loc : Source_Ptr; 2173 Decls : List_Id; 2174 Spec_Id : Entity_Id; 2175 Spec : Node_Id) return Node_Id 2176 is 2177 Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id); 2178 Par_Type : constant Entity_Id := Find_Dispatching_Type (Spec_Id); 2179 2180 Actuals : List_Id; 2181 Call : Node_Id; 2182 Formal : Entity_Id; 2183 New_Body : Node_Id; 2184 New_F_Spec : Entity_Id; 2185 New_Formal : Entity_Id; 2186 2187 begin 2188 Actuals := Empty_List; 2189 Formal := First_Formal (Spec_Id); 2190 New_F_Spec := First (Parameter_Specifications (Spec)); 2191 2192 -- Build parameter association for call to class-wide clone. 2193 2194 while Present (Formal) loop 2195 New_Formal := Defining_Identifier (New_F_Spec); 2196 2197 -- If controlling argument and operation is inherited, add conversion 2198 -- to parent type for the call. 2199 2200 if Etype (Formal) = Par_Type 2201 and then not Is_Empty_List (Decls) 2202 then 2203 Append_To (Actuals, 2204 Make_Type_Conversion (Loc, 2205 New_Occurrence_Of (Par_Type, Loc), 2206 New_Occurrence_Of (New_Formal, Loc))); 2207 2208 else 2209 Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc)); 2210 end if; 2211 2212 Next_Formal (Formal); 2213 Next (New_F_Spec); 2214 end loop; 2215 2216 if Ekind (Spec_Id) = E_Procedure then 2217 Call := 2218 Make_Procedure_Call_Statement (Loc, 2219 Name => New_Occurrence_Of (Clone_Id, Loc), 2220 Parameter_Associations => Actuals); 2221 else 2222 Call := 2223 Make_Simple_Return_Statement (Loc, 2224 Expression => 2225 Make_Function_Call (Loc, 2226 Name => New_Occurrence_Of (Clone_Id, Loc), 2227 Parameter_Associations => Actuals)); 2228 end if; 2229 2230 New_Body := 2231 Make_Subprogram_Body (Loc, 2232 Specification => 2233 Copy_Subprogram_Spec (Spec), 2234 Declarations => Decls, 2235 Handled_Statement_Sequence => 2236 Make_Handled_Sequence_Of_Statements (Loc, 2237 Statements => New_List (Call), 2238 End_Label => Make_Identifier (Loc, Chars (Spec_Id)))); 2239 2240 return New_Body; 2241 end Build_Class_Wide_Clone_Call; 2242 2243 --------------------------------- 2244 -- Build_Class_Wide_Clone_Decl -- 2245 --------------------------------- 2246 2247 procedure Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id) is 2248 Loc : constant Source_Ptr := Sloc (Spec_Id); 2249 Clone_Id : constant Entity_Id := 2250 Make_Defining_Identifier (Loc, 2251 New_External_Name (Chars (Spec_Id), Suffix => "CL")); 2252 2253 Decl : Node_Id; 2254 Spec : Node_Id; 2255 2256 begin 2257 Spec := Copy_Subprogram_Spec (Parent (Spec_Id)); 2258 Set_Must_Override (Spec, False); 2259 Set_Must_Not_Override (Spec, False); 2260 Set_Defining_Unit_Name (Spec, Clone_Id); 2261 2262 Decl := Make_Subprogram_Declaration (Loc, Spec); 2263 Append (Decl, List_Containing (Unit_Declaration_Node (Spec_Id))); 2264 2265 -- Link clone to original subprogram, for use when building body and 2266 -- wrapper call to inherited operation. 2267 2268 Set_Class_Wide_Clone (Spec_Id, Clone_Id); 2269 2270 -- Inherit debug info flag from Spec_Id to Clone_Id to allow debugging 2271 -- of the class-wide clone subprogram. 2272 2273 if Needs_Debug_Info (Spec_Id) then 2274 Set_Debug_Info_Needed (Clone_Id); 2275 end if; 2276 end Build_Class_Wide_Clone_Decl; 2277 2278 ----------------------------- 2279 -- Build_Component_Subtype -- 2280 ----------------------------- 2281 2282 function Build_Component_Subtype 2283 (C : List_Id; 2284 Loc : Source_Ptr; 2285 T : Entity_Id) return Node_Id 2286 is 2287 Subt : Entity_Id; 2288 Decl : Node_Id; 2289 2290 begin 2291 -- Unchecked_Union components do not require component subtypes 2292 2293 if Is_Unchecked_Union (T) then 2294 return Empty; 2295 end if; 2296 2297 Subt := Make_Temporary (Loc, 'S'); 2298 Set_Is_Internal (Subt); 2299 2300 Decl := 2301 Make_Subtype_Declaration (Loc, 2302 Defining_Identifier => Subt, 2303 Subtype_Indication => 2304 Make_Subtype_Indication (Loc, 2305 Subtype_Mark => New_Occurrence_Of (Base_Type (T), Loc), 2306 Constraint => 2307 Make_Index_Or_Discriminant_Constraint (Loc, 2308 Constraints => C))); 2309 2310 Mark_Rewrite_Insertion (Decl); 2311 return Decl; 2312 end Build_Component_Subtype; 2313 2314 ----------------------------- 2315 -- Build_Constrained_Itype -- 2316 ----------------------------- 2317 2318 procedure Build_Constrained_Itype 2319 (N : Node_Id; 2320 Typ : Entity_Id; 2321 New_Assoc_List : List_Id) 2322 is 2323 Constrs : constant List_Id := New_List; 2324 Loc : constant Source_Ptr := Sloc (N); 2325 Def_Id : Entity_Id; 2326 Indic : Node_Id; 2327 New_Assoc : Node_Id; 2328 Subtyp_Decl : Node_Id; 2329 2330 begin 2331 New_Assoc := First (New_Assoc_List); 2332 while Present (New_Assoc) loop 2333 2334 -- There is exactly one choice in the component association (and 2335 -- it is either a discriminant, a component or the others clause). 2336 pragma Assert (List_Length (Choices (New_Assoc)) = 1); 2337 2338 -- Duplicate expression for the discriminant and put it on the 2339 -- list of constraints for the itype declaration. 2340 2341 if Is_Entity_Name (First (Choices (New_Assoc))) 2342 and then 2343 Ekind (Entity (First (Choices (New_Assoc)))) = E_Discriminant 2344 then 2345 Append_To (Constrs, Duplicate_Subexpr (Expression (New_Assoc))); 2346 end if; 2347 2348 Next (New_Assoc); 2349 end loop; 2350 2351 if Has_Unknown_Discriminants (Typ) 2352 and then Present (Underlying_Record_View (Typ)) 2353 then 2354 Indic := 2355 Make_Subtype_Indication (Loc, 2356 Subtype_Mark => 2357 New_Occurrence_Of (Underlying_Record_View (Typ), Loc), 2358 Constraint => 2359 Make_Index_Or_Discriminant_Constraint (Loc, 2360 Constraints => Constrs)); 2361 else 2362 Indic := 2363 Make_Subtype_Indication (Loc, 2364 Subtype_Mark => 2365 New_Occurrence_Of (Base_Type (Typ), Loc), 2366 Constraint => 2367 Make_Index_Or_Discriminant_Constraint (Loc, 2368 Constraints => Constrs)); 2369 end if; 2370 2371 Def_Id := Create_Itype (Ekind (Typ), N); 2372 2373 Subtyp_Decl := 2374 Make_Subtype_Declaration (Loc, 2375 Defining_Identifier => Def_Id, 2376 Subtype_Indication => Indic); 2377 Set_Parent (Subtyp_Decl, Parent (N)); 2378 2379 -- Itypes must be analyzed with checks off (see itypes.ads) 2380 2381 Analyze (Subtyp_Decl, Suppress => All_Checks); 2382 2383 Set_Etype (N, Def_Id); 2384 end Build_Constrained_Itype; 2385 2386 --------------------------- 2387 -- Build_Default_Subtype -- 2388 --------------------------- 2389 2390 function Build_Default_Subtype 2391 (T : Entity_Id; 2392 N : Node_Id) return Entity_Id 2393 is 2394 Loc : constant Source_Ptr := Sloc (N); 2395 Disc : Entity_Id; 2396 2397 Bas : Entity_Id; 2398 -- The base type that is to be constrained by the defaults 2399 2400 begin 2401 if not Has_Discriminants (T) or else Is_Constrained (T) then 2402 return T; 2403 end if; 2404 2405 Bas := Base_Type (T); 2406 2407 -- If T is non-private but its base type is private, this is the 2408 -- completion of a subtype declaration whose parent type is private 2409 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants 2410 -- are to be found in the full view of the base. Check that the private 2411 -- status of T and its base differ. 2412 2413 if Is_Private_Type (Bas) 2414 and then not Is_Private_Type (T) 2415 and then Present (Full_View (Bas)) 2416 then 2417 Bas := Full_View (Bas); 2418 end if; 2419 2420 Disc := First_Discriminant (T); 2421 2422 if No (Discriminant_Default_Value (Disc)) then 2423 return T; 2424 end if; 2425 2426 declare 2427 Act : constant Entity_Id := Make_Temporary (Loc, 'S'); 2428 Constraints : constant List_Id := New_List; 2429 Decl : Node_Id; 2430 2431 begin 2432 while Present (Disc) loop 2433 Append_To (Constraints, 2434 New_Copy_Tree (Discriminant_Default_Value (Disc))); 2435 Next_Discriminant (Disc); 2436 end loop; 2437 2438 Decl := 2439 Make_Subtype_Declaration (Loc, 2440 Defining_Identifier => Act, 2441 Subtype_Indication => 2442 Make_Subtype_Indication (Loc, 2443 Subtype_Mark => New_Occurrence_Of (Bas, Loc), 2444 Constraint => 2445 Make_Index_Or_Discriminant_Constraint (Loc, 2446 Constraints => Constraints))); 2447 2448 Insert_Action (N, Decl); 2449 2450 -- If the context is a component declaration the subtype declaration 2451 -- will be analyzed when the enclosing type is frozen, otherwise do 2452 -- it now. 2453 2454 if Ekind (Current_Scope) /= E_Record_Type then 2455 Analyze (Decl); 2456 end if; 2457 2458 return Act; 2459 end; 2460 end Build_Default_Subtype; 2461 2462 -------------------------------------------- 2463 -- Build_Discriminal_Subtype_Of_Component -- 2464 -------------------------------------------- 2465 2466 function Build_Discriminal_Subtype_Of_Component 2467 (T : Entity_Id) return Node_Id 2468 is 2469 Loc : constant Source_Ptr := Sloc (T); 2470 D : Elmt_Id; 2471 Id : Node_Id; 2472 2473 function Build_Discriminal_Array_Constraint return List_Id; 2474 -- If one or more of the bounds of the component depends on 2475 -- discriminants, build actual constraint using the discriminants 2476 -- of the prefix. 2477 2478 function Build_Discriminal_Record_Constraint return List_Id; 2479 -- Similar to previous one, for discriminated components constrained by 2480 -- the discriminant of the enclosing object. 2481 2482 ---------------------------------------- 2483 -- Build_Discriminal_Array_Constraint -- 2484 ---------------------------------------- 2485 2486 function Build_Discriminal_Array_Constraint return List_Id is 2487 Constraints : constant List_Id := New_List; 2488 Indx : Node_Id; 2489 Hi : Node_Id; 2490 Lo : Node_Id; 2491 Old_Hi : Node_Id; 2492 Old_Lo : Node_Id; 2493 2494 begin 2495 Indx := First_Index (T); 2496 while Present (Indx) loop 2497 Old_Lo := Type_Low_Bound (Etype (Indx)); 2498 Old_Hi := Type_High_Bound (Etype (Indx)); 2499 2500 if Denotes_Discriminant (Old_Lo) then 2501 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc); 2502 2503 else 2504 Lo := New_Copy_Tree (Old_Lo); 2505 end if; 2506 2507 if Denotes_Discriminant (Old_Hi) then 2508 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc); 2509 2510 else 2511 Hi := New_Copy_Tree (Old_Hi); 2512 end if; 2513 2514 Append (Make_Range (Loc, Lo, Hi), Constraints); 2515 Next_Index (Indx); 2516 end loop; 2517 2518 return Constraints; 2519 end Build_Discriminal_Array_Constraint; 2520 2521 ----------------------------------------- 2522 -- Build_Discriminal_Record_Constraint -- 2523 ----------------------------------------- 2524 2525 function Build_Discriminal_Record_Constraint return List_Id is 2526 Constraints : constant List_Id := New_List; 2527 D : Elmt_Id; 2528 D_Val : Node_Id; 2529 2530 begin 2531 D := First_Elmt (Discriminant_Constraint (T)); 2532 while Present (D) loop 2533 if Denotes_Discriminant (Node (D)) then 2534 D_Val := 2535 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc); 2536 else 2537 D_Val := New_Copy_Tree (Node (D)); 2538 end if; 2539 2540 Append (D_Val, Constraints); 2541 Next_Elmt (D); 2542 end loop; 2543 2544 return Constraints; 2545 end Build_Discriminal_Record_Constraint; 2546 2547 -- Start of processing for Build_Discriminal_Subtype_Of_Component 2548 2549 begin 2550 if Ekind (T) = E_Array_Subtype then 2551 Id := First_Index (T); 2552 while Present (Id) loop 2553 if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) 2554 or else 2555 Denotes_Discriminant (Type_High_Bound (Etype (Id))) 2556 then 2557 return Build_Component_Subtype 2558 (Build_Discriminal_Array_Constraint, Loc, T); 2559 end if; 2560 2561 Next_Index (Id); 2562 end loop; 2563 2564 elsif Ekind (T) = E_Record_Subtype 2565 and then Has_Discriminants (T) 2566 and then not Has_Unknown_Discriminants (T) 2567 then 2568 D := First_Elmt (Discriminant_Constraint (T)); 2569 while Present (D) loop 2570 if Denotes_Discriminant (Node (D)) then 2571 return Build_Component_Subtype 2572 (Build_Discriminal_Record_Constraint, Loc, T); 2573 end if; 2574 2575 Next_Elmt (D); 2576 end loop; 2577 end if; 2578 2579 -- If none of the above, the actual and nominal subtypes are the same 2580 2581 return Empty; 2582 end Build_Discriminal_Subtype_Of_Component; 2583 2584 ------------------------------ 2585 -- Build_Elaboration_Entity -- 2586 ------------------------------ 2587 2588 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is 2589 Loc : constant Source_Ptr := Sloc (N); 2590 Decl : Node_Id; 2591 Elab_Ent : Entity_Id; 2592 2593 procedure Set_Package_Name (Ent : Entity_Id); 2594 -- Given an entity, sets the fully qualified name of the entity in 2595 -- Name_Buffer, with components separated by double underscores. This 2596 -- is a recursive routine that climbs the scope chain to Standard. 2597 2598 ---------------------- 2599 -- Set_Package_Name -- 2600 ---------------------- 2601 2602 procedure Set_Package_Name (Ent : Entity_Id) is 2603 begin 2604 if Scope (Ent) /= Standard_Standard then 2605 Set_Package_Name (Scope (Ent)); 2606 2607 declare 2608 Nam : constant String := Get_Name_String (Chars (Ent)); 2609 begin 2610 Name_Buffer (Name_Len + 1) := '_'; 2611 Name_Buffer (Name_Len + 2) := '_'; 2612 Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam; 2613 Name_Len := Name_Len + Nam'Length + 2; 2614 end; 2615 2616 else 2617 Get_Name_String (Chars (Ent)); 2618 end if; 2619 end Set_Package_Name; 2620 2621 -- Start of processing for Build_Elaboration_Entity 2622 2623 begin 2624 -- Ignore call if already constructed 2625 2626 if Present (Elaboration_Entity (Spec_Id)) then 2627 return; 2628 2629 -- Do not generate an elaboration entity in GNATprove move because the 2630 -- elaboration counter is a form of expansion. 2631 2632 elsif GNATprove_Mode then 2633 return; 2634 2635 -- See if we need elaboration entity 2636 2637 -- We always need an elaboration entity when preserving control flow, as 2638 -- we want to remain explicit about the unit's elaboration order. 2639 2640 elsif Opt.Suppress_Control_Flow_Optimizations then 2641 null; 2642 2643 -- We always need an elaboration entity for the dynamic elaboration 2644 -- model, since it is needed to properly generate the PE exception for 2645 -- access before elaboration. 2646 2647 elsif Dynamic_Elaboration_Checks then 2648 null; 2649 2650 -- For the static model, we don't need the elaboration counter if this 2651 -- unit is sure to have no elaboration code, since that means there 2652 -- is no elaboration unit to be called. Note that we can't just decide 2653 -- after the fact by looking to see whether there was elaboration code, 2654 -- because that's too late to make this decision. 2655 2656 elsif Restriction_Active (No_Elaboration_Code) then 2657 return; 2658 2659 -- Similarly, for the static model, we can skip the elaboration counter 2660 -- if we have the No_Multiple_Elaboration restriction, since for the 2661 -- static model, that's the only purpose of the counter (to avoid 2662 -- multiple elaboration). 2663 2664 elsif Restriction_Active (No_Multiple_Elaboration) then 2665 return; 2666 end if; 2667 2668 -- Here we need the elaboration entity 2669 2670 -- Construct name of elaboration entity as xxx_E, where xxx is the unit 2671 -- name with dots replaced by double underscore. We have to manually 2672 -- construct this name, since it will be elaborated in the outer scope, 2673 -- and thus will not have the unit name automatically prepended. 2674 2675 Set_Package_Name (Spec_Id); 2676 Add_Str_To_Name_Buffer ("_E"); 2677 2678 -- Create elaboration counter 2679 2680 Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find); 2681 Set_Elaboration_Entity (Spec_Id, Elab_Ent); 2682 2683 Decl := 2684 Make_Object_Declaration (Loc, 2685 Defining_Identifier => Elab_Ent, 2686 Object_Definition => 2687 New_Occurrence_Of (Standard_Short_Integer, Loc), 2688 Expression => Make_Integer_Literal (Loc, Uint_0)); 2689 2690 Push_Scope (Standard_Standard); 2691 Add_Global_Declaration (Decl); 2692 Pop_Scope; 2693 2694 -- Reset True_Constant indication, since we will indeed assign a value 2695 -- to the variable in the binder main. We also kill the Current_Value 2696 -- and Last_Assignment fields for the same reason. 2697 2698 Set_Is_True_Constant (Elab_Ent, False); 2699 Set_Current_Value (Elab_Ent, Empty); 2700 Set_Last_Assignment (Elab_Ent, Empty); 2701 2702 -- We do not want any further qualification of the name (if we did not 2703 -- do this, we would pick up the name of the generic package in the case 2704 -- of a library level generic instantiation). 2705 2706 Set_Has_Qualified_Name (Elab_Ent); 2707 Set_Has_Fully_Qualified_Name (Elab_Ent); 2708 end Build_Elaboration_Entity; 2709 2710 -------------------------------- 2711 -- Build_Explicit_Dereference -- 2712 -------------------------------- 2713 2714 procedure Build_Explicit_Dereference 2715 (Expr : Node_Id; 2716 Disc : Entity_Id) 2717 is 2718 Loc : constant Source_Ptr := Sloc (Expr); 2719 I : Interp_Index; 2720 It : Interp; 2721 2722 begin 2723 -- An entity of a type with a reference aspect is overloaded with 2724 -- both interpretations: with and without the dereference. Now that 2725 -- the dereference is made explicit, set the type of the node properly, 2726 -- to prevent anomalies in the backend. Same if the expression is an 2727 -- overloaded function call whose return type has a reference aspect. 2728 2729 if Is_Entity_Name (Expr) then 2730 Set_Etype (Expr, Etype (Entity (Expr))); 2731 2732 -- The designated entity will not be examined again when resolving 2733 -- the dereference, so generate a reference to it now. 2734 2735 Generate_Reference (Entity (Expr), Expr); 2736 2737 elsif Nkind (Expr) = N_Function_Call then 2738 2739 -- If the name of the indexing function is overloaded, locate the one 2740 -- whose return type has an implicit dereference on the desired 2741 -- discriminant, and set entity and type of function call. 2742 2743 if Is_Overloaded (Name (Expr)) then 2744 Get_First_Interp (Name (Expr), I, It); 2745 2746 while Present (It.Nam) loop 2747 if Ekind ((It.Typ)) = E_Record_Type 2748 and then First_Entity ((It.Typ)) = Disc 2749 then 2750 Set_Entity (Name (Expr), It.Nam); 2751 Set_Etype (Name (Expr), Etype (It.Nam)); 2752 exit; 2753 end if; 2754 2755 Get_Next_Interp (I, It); 2756 end loop; 2757 end if; 2758 2759 -- Set type of call from resolved function name. 2760 2761 Set_Etype (Expr, Etype (Name (Expr))); 2762 end if; 2763 2764 Set_Is_Overloaded (Expr, False); 2765 2766 -- The expression will often be a generalized indexing that yields a 2767 -- container element that is then dereferenced, in which case the 2768 -- generalized indexing call is also non-overloaded. 2769 2770 if Nkind (Expr) = N_Indexed_Component 2771 and then Present (Generalized_Indexing (Expr)) 2772 then 2773 Set_Is_Overloaded (Generalized_Indexing (Expr), False); 2774 end if; 2775 2776 Rewrite (Expr, 2777 Make_Explicit_Dereference (Loc, 2778 Prefix => 2779 Make_Selected_Component (Loc, 2780 Prefix => Relocate_Node (Expr), 2781 Selector_Name => New_Occurrence_Of (Disc, Loc)))); 2782 Set_Etype (Prefix (Expr), Etype (Disc)); 2783 Set_Etype (Expr, Designated_Type (Etype (Disc))); 2784 end Build_Explicit_Dereference; 2785 2786 --------------------------- 2787 -- Build_Overriding_Spec -- 2788 --------------------------- 2789 2790 function Build_Overriding_Spec 2791 (Op : Entity_Id; 2792 Typ : Entity_Id) return Node_Id 2793 is 2794 Loc : constant Source_Ptr := Sloc (Typ); 2795 Par_Typ : constant Entity_Id := Find_Dispatching_Type (Op); 2796 Spec : constant Node_Id := Specification (Unit_Declaration_Node (Op)); 2797 2798 Formal_Spec : Node_Id; 2799 Formal_Type : Node_Id; 2800 New_Spec : Node_Id; 2801 2802 begin 2803 New_Spec := Copy_Subprogram_Spec (Spec); 2804 2805 Formal_Spec := First (Parameter_Specifications (New_Spec)); 2806 while Present (Formal_Spec) loop 2807 Formal_Type := Parameter_Type (Formal_Spec); 2808 2809 if Is_Entity_Name (Formal_Type) 2810 and then Entity (Formal_Type) = Par_Typ 2811 then 2812 Rewrite (Formal_Type, New_Occurrence_Of (Typ, Loc)); 2813 end if; 2814 2815 -- Nothing needs to be done for access parameters 2816 2817 Next (Formal_Spec); 2818 end loop; 2819 2820 return New_Spec; 2821 end Build_Overriding_Spec; 2822 2823 ------------------- 2824 -- Build_Subtype -- 2825 ------------------- 2826 2827 function Build_Subtype 2828 (Related_Node : Node_Id; 2829 Loc : Source_Ptr; 2830 Typ : Entity_Id; 2831 Constraints : List_Id) 2832 return Entity_Id 2833 is 2834 Indic : Node_Id; 2835 Subtyp_Decl : Node_Id; 2836 Def_Id : Entity_Id; 2837 Btyp : Entity_Id := Base_Type (Typ); 2838 2839 begin 2840 -- The Related_Node better be here or else we won't be able to 2841 -- attach new itypes to a node in the tree. 2842 2843 pragma Assert (Present (Related_Node)); 2844 2845 -- If the view of the component's type is incomplete or private 2846 -- with unknown discriminants, then the constraint must be applied 2847 -- to the full type. 2848 2849 if Has_Unknown_Discriminants (Btyp) 2850 and then Present (Underlying_Type (Btyp)) 2851 then 2852 Btyp := Underlying_Type (Btyp); 2853 end if; 2854 2855 Indic := 2856 Make_Subtype_Indication (Loc, 2857 Subtype_Mark => New_Occurrence_Of (Btyp, Loc), 2858 Constraint => 2859 Make_Index_Or_Discriminant_Constraint (Loc, Constraints)); 2860 2861 Def_Id := Create_Itype (Ekind (Typ), Related_Node); 2862 2863 Subtyp_Decl := 2864 Make_Subtype_Declaration (Loc, 2865 Defining_Identifier => Def_Id, 2866 Subtype_Indication => Indic); 2867 2868 Set_Parent (Subtyp_Decl, Parent (Related_Node)); 2869 2870 -- Itypes must be analyzed with checks off (see package Itypes) 2871 2872 Analyze (Subtyp_Decl, Suppress => All_Checks); 2873 2874 if Is_Itype (Def_Id) and then Has_Predicates (Typ) then 2875 Inherit_Predicate_Flags (Def_Id, Typ); 2876 2877 -- Indicate where the predicate function may be found 2878 2879 if Is_Itype (Typ) then 2880 if Present (Predicate_Function (Def_Id)) then 2881 null; 2882 2883 elsif Present (Predicate_Function (Typ)) then 2884 Set_Predicate_Function (Def_Id, Predicate_Function (Typ)); 2885 2886 else 2887 Set_Predicated_Parent (Def_Id, Predicated_Parent (Typ)); 2888 end if; 2889 2890 elsif No (Predicate_Function (Def_Id)) then 2891 Set_Predicated_Parent (Def_Id, Typ); 2892 end if; 2893 end if; 2894 2895 return Def_Id; 2896 end Build_Subtype; 2897 2898 ----------------------------------- 2899 -- Cannot_Raise_Constraint_Error -- 2900 ----------------------------------- 2901 2902 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is 2903 begin 2904 if Compile_Time_Known_Value (Expr) then 2905 return True; 2906 2907 elsif Do_Range_Check (Expr) then 2908 return False; 2909 2910 elsif Raises_Constraint_Error (Expr) then 2911 return False; 2912 2913 else 2914 case Nkind (Expr) is 2915 when N_Identifier => 2916 return True; 2917 2918 when N_Expanded_Name => 2919 return True; 2920 2921 when N_Selected_Component => 2922 return not Do_Discriminant_Check (Expr); 2923 2924 when N_Attribute_Reference => 2925 if Do_Overflow_Check (Expr) then 2926 return False; 2927 2928 elsif No (Expressions (Expr)) then 2929 return True; 2930 2931 else 2932 declare 2933 N : Node_Id; 2934 2935 begin 2936 N := First (Expressions (Expr)); 2937 while Present (N) loop 2938 if Cannot_Raise_Constraint_Error (N) then 2939 Next (N); 2940 else 2941 return False; 2942 end if; 2943 end loop; 2944 2945 return True; 2946 end; 2947 end if; 2948 2949 when N_Type_Conversion => 2950 if Do_Overflow_Check (Expr) 2951 or else Do_Length_Check (Expr) 2952 or else Do_Tag_Check (Expr) 2953 then 2954 return False; 2955 else 2956 return Cannot_Raise_Constraint_Error (Expression (Expr)); 2957 end if; 2958 2959 when N_Unchecked_Type_Conversion => 2960 return Cannot_Raise_Constraint_Error (Expression (Expr)); 2961 2962 when N_Unary_Op => 2963 if Do_Overflow_Check (Expr) then 2964 return False; 2965 else 2966 return Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 2967 end if; 2968 2969 when N_Op_Divide 2970 | N_Op_Mod 2971 | N_Op_Rem 2972 => 2973 if Do_Division_Check (Expr) 2974 or else 2975 Do_Overflow_Check (Expr) 2976 then 2977 return False; 2978 else 2979 return 2980 Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) 2981 and then 2982 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 2983 end if; 2984 2985 when N_Op_Add 2986 | N_Op_And 2987 | N_Op_Concat 2988 | N_Op_Eq 2989 | N_Op_Expon 2990 | N_Op_Ge 2991 | N_Op_Gt 2992 | N_Op_Le 2993 | N_Op_Lt 2994 | N_Op_Multiply 2995 | N_Op_Ne 2996 | N_Op_Or 2997 | N_Op_Rotate_Left 2998 | N_Op_Rotate_Right 2999 | N_Op_Shift_Left 3000 | N_Op_Shift_Right 3001 | N_Op_Shift_Right_Arithmetic 3002 | N_Op_Subtract 3003 | N_Op_Xor 3004 => 3005 if Do_Overflow_Check (Expr) then 3006 return False; 3007 else 3008 return 3009 Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) 3010 and then 3011 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 3012 end if; 3013 3014 when others => 3015 return False; 3016 end case; 3017 end if; 3018 end Cannot_Raise_Constraint_Error; 3019 3020 ------------------------------- 3021 -- Check_Ambiguous_Aggregate -- 3022 ------------------------------- 3023 3024 procedure Check_Ambiguous_Aggregate (Call : Node_Id) is 3025 Actual : Node_Id; 3026 3027 begin 3028 if Extensions_Allowed then 3029 Actual := First_Actual (Call); 3030 while Present (Actual) loop 3031 if Nkind (Actual) = N_Aggregate then 3032 Error_Msg_N 3033 ("\add type qualification to aggregate actual", Actual); 3034 exit; 3035 end if; 3036 Next_Actual (Actual); 3037 end loop; 3038 end if; 3039 end Check_Ambiguous_Aggregate; 3040 3041 ----------------------------------------- 3042 -- Check_Dynamically_Tagged_Expression -- 3043 ----------------------------------------- 3044 3045 procedure Check_Dynamically_Tagged_Expression 3046 (Expr : Node_Id; 3047 Typ : Entity_Id; 3048 Related_Nod : Node_Id) 3049 is 3050 begin 3051 pragma Assert (Is_Tagged_Type (Typ)); 3052 3053 -- In order to avoid spurious errors when analyzing the expanded code, 3054 -- this check is done only for nodes that come from source and for 3055 -- actuals of generic instantiations. 3056 3057 if (Comes_From_Source (Related_Nod) 3058 or else In_Generic_Actual (Expr)) 3059 and then (Is_Class_Wide_Type (Etype (Expr)) 3060 or else Is_Dynamically_Tagged (Expr)) 3061 and then not Is_Class_Wide_Type (Typ) 3062 then 3063 Error_Msg_N ("dynamically tagged expression not allowed!", Expr); 3064 end if; 3065 end Check_Dynamically_Tagged_Expression; 3066 3067 -------------------------- 3068 -- Check_Fully_Declared -- 3069 -------------------------- 3070 3071 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is 3072 begin 3073 if Ekind (T) = E_Incomplete_Type then 3074 3075 -- Ada 2005 (AI-50217): If the type is available through a limited 3076 -- with_clause, verify that its full view has been analyzed. 3077 3078 if From_Limited_With (T) 3079 and then Present (Non_Limited_View (T)) 3080 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type 3081 then 3082 -- The non-limited view is fully declared 3083 3084 null; 3085 3086 else 3087 Error_Msg_NE 3088 ("premature usage of incomplete}", N, First_Subtype (T)); 3089 end if; 3090 3091 -- Need comments for these tests ??? 3092 3093 elsif Has_Private_Component (T) 3094 and then not Is_Generic_Type (Root_Type (T)) 3095 and then not In_Spec_Expression 3096 then 3097 -- Special case: if T is the anonymous type created for a single 3098 -- task or protected object, use the name of the source object. 3099 3100 if Is_Concurrent_Type (T) 3101 and then not Comes_From_Source (T) 3102 and then Nkind (N) = N_Object_Declaration 3103 then 3104 Error_Msg_NE 3105 ("type of& has incomplete component", 3106 N, Defining_Identifier (N)); 3107 else 3108 Error_Msg_NE 3109 ("premature usage of incomplete}", 3110 N, First_Subtype (T)); 3111 end if; 3112 end if; 3113 end Check_Fully_Declared; 3114 3115 ------------------------------------------- 3116 -- Check_Function_With_Address_Parameter -- 3117 ------------------------------------------- 3118 3119 procedure Check_Function_With_Address_Parameter (Subp_Id : Entity_Id) is 3120 F : Entity_Id; 3121 T : Entity_Id; 3122 3123 begin 3124 F := First_Formal (Subp_Id); 3125 while Present (F) loop 3126 T := Etype (F); 3127 3128 if Is_Private_Type (T) and then Present (Full_View (T)) then 3129 T := Full_View (T); 3130 end if; 3131 3132 if Is_Descendant_Of_Address (T) or else Is_Limited_Type (T) then 3133 Set_Is_Pure (Subp_Id, False); 3134 exit; 3135 end if; 3136 3137 Next_Formal (F); 3138 end loop; 3139 end Check_Function_With_Address_Parameter; 3140 3141 ------------------------------------- 3142 -- Check_Function_Writable_Actuals -- 3143 ------------------------------------- 3144 3145 procedure Check_Function_Writable_Actuals (N : Node_Id) is 3146 Writable_Actuals_List : Elist_Id := No_Elist; 3147 Identifiers_List : Elist_Id := No_Elist; 3148 Aggr_Error_Node : Node_Id := Empty; 3149 Error_Node : Node_Id := Empty; 3150 3151 procedure Collect_Identifiers (N : Node_Id); 3152 -- In a single traversal of subtree N collect in Writable_Actuals_List 3153 -- all the actuals of functions with writable actuals, and in the list 3154 -- Identifiers_List collect all the identifiers that are not actuals of 3155 -- functions with writable actuals. If a writable actual is referenced 3156 -- twice as writable actual then Error_Node is set to reference its 3157 -- second occurrence, the error is reported, and the tree traversal 3158 -- is abandoned. 3159 3160 ------------------------- 3161 -- Collect_Identifiers -- 3162 ------------------------- 3163 3164 procedure Collect_Identifiers (N : Node_Id) is 3165 3166 function Check_Node (N : Node_Id) return Traverse_Result; 3167 -- Process a single node during the tree traversal to collect the 3168 -- writable actuals of functions and all the identifiers which are 3169 -- not writable actuals of functions. 3170 3171 function Contains (List : Elist_Id; N : Node_Id) return Boolean; 3172 -- Returns True if List has a node whose Entity is Entity (N) 3173 3174 ---------------- 3175 -- Check_Node -- 3176 ---------------- 3177 3178 function Check_Node (N : Node_Id) return Traverse_Result is 3179 Is_Writable_Actual : Boolean := False; 3180 Id : Entity_Id; 3181 3182 begin 3183 if Nkind (N) = N_Identifier then 3184 3185 -- No analysis possible if the entity is not decorated 3186 3187 if No (Entity (N)) then 3188 return Skip; 3189 3190 -- Don't collect identifiers of packages, called functions, etc 3191 3192 elsif Ekind (Entity (N)) in 3193 E_Package | E_Function | E_Procedure | E_Entry 3194 then 3195 return Skip; 3196 3197 -- For rewritten nodes, continue the traversal in the original 3198 -- subtree. Needed to handle aggregates in original expressions 3199 -- extracted from the tree by Remove_Side_Effects. 3200 3201 elsif Is_Rewrite_Substitution (N) then 3202 Collect_Identifiers (Original_Node (N)); 3203 return Skip; 3204 3205 -- For now we skip aggregate discriminants, since they require 3206 -- performing the analysis in two phases to identify conflicts: 3207 -- first one analyzing discriminants and second one analyzing 3208 -- the rest of components (since at run time, discriminants are 3209 -- evaluated prior to components): too much computation cost 3210 -- to identify a corner case??? 3211 3212 elsif Nkind (Parent (N)) = N_Component_Association 3213 and then Nkind (Parent (Parent (N))) in 3214 N_Aggregate | N_Extension_Aggregate 3215 then 3216 declare 3217 Choice : constant Node_Id := First (Choices (Parent (N))); 3218 3219 begin 3220 if Ekind (Entity (N)) = E_Discriminant then 3221 return Skip; 3222 3223 elsif Expression (Parent (N)) = N 3224 and then Nkind (Choice) = N_Identifier 3225 and then Ekind (Entity (Choice)) = E_Discriminant 3226 then 3227 return Skip; 3228 end if; 3229 end; 3230 3231 -- Analyze if N is a writable actual of a function 3232 3233 elsif Nkind (Parent (N)) = N_Function_Call then 3234 declare 3235 Call : constant Node_Id := Parent (N); 3236 Actual : Node_Id; 3237 Formal : Node_Id; 3238 3239 begin 3240 Id := Get_Called_Entity (Call); 3241 3242 -- In case of previous error, no check is possible 3243 3244 if No (Id) then 3245 return Abandon; 3246 end if; 3247 3248 if Ekind (Id) in E_Function | E_Generic_Function 3249 and then Has_Out_Or_In_Out_Parameter (Id) 3250 then 3251 Formal := First_Formal (Id); 3252 Actual := First_Actual (Call); 3253 while Present (Actual) and then Present (Formal) loop 3254 if Actual = N then 3255 if Ekind (Formal) in E_Out_Parameter 3256 | E_In_Out_Parameter 3257 then 3258 Is_Writable_Actual := True; 3259 end if; 3260 3261 exit; 3262 end if; 3263 3264 Next_Formal (Formal); 3265 Next_Actual (Actual); 3266 end loop; 3267 end if; 3268 end; 3269 end if; 3270 3271 if Is_Writable_Actual then 3272 3273 -- Skip checking the error in non-elementary types since 3274 -- RM 6.4.1(6.15/3) is restricted to elementary types, but 3275 -- store this actual in Writable_Actuals_List since it is 3276 -- needed to perform checks on other constructs that have 3277 -- arbitrary order of evaluation (for example, aggregates). 3278 3279 if not Is_Elementary_Type (Etype (N)) then 3280 if not Contains (Writable_Actuals_List, N) then 3281 Append_New_Elmt (N, To => Writable_Actuals_List); 3282 end if; 3283 3284 -- Second occurrence of an elementary type writable actual 3285 3286 elsif Contains (Writable_Actuals_List, N) then 3287 3288 -- Report the error on the second occurrence of the 3289 -- identifier. We cannot assume that N is the second 3290 -- occurrence (according to their location in the 3291 -- sources), since Traverse_Func walks through Field2 3292 -- last (see comment in the body of Traverse_Func). 3293 3294 declare 3295 Elmt : Elmt_Id; 3296 3297 begin 3298 Elmt := First_Elmt (Writable_Actuals_List); 3299 while Present (Elmt) 3300 and then Entity (Node (Elmt)) /= Entity (N) 3301 loop 3302 Next_Elmt (Elmt); 3303 end loop; 3304 3305 if Sloc (N) > Sloc (Node (Elmt)) then 3306 Error_Node := N; 3307 else 3308 Error_Node := Node (Elmt); 3309 end if; 3310 3311 Error_Msg_NE 3312 ("value may be affected by call to & " 3313 & "because order of evaluation is arbitrary", 3314 Error_Node, Id); 3315 return Abandon; 3316 end; 3317 3318 -- First occurrence of a elementary type writable actual 3319 3320 else 3321 Append_New_Elmt (N, To => Writable_Actuals_List); 3322 end if; 3323 3324 else 3325 if Identifiers_List = No_Elist then 3326 Identifiers_List := New_Elmt_List; 3327 end if; 3328 3329 Append_Unique_Elmt (N, Identifiers_List); 3330 end if; 3331 end if; 3332 3333 return OK; 3334 end Check_Node; 3335 3336 -------------- 3337 -- Contains -- 3338 -------------- 3339 3340 function Contains 3341 (List : Elist_Id; 3342 N : Node_Id) return Boolean 3343 is 3344 pragma Assert (Nkind (N) in N_Has_Entity); 3345 3346 Elmt : Elmt_Id; 3347 3348 begin 3349 if List = No_Elist then 3350 return False; 3351 end if; 3352 3353 Elmt := First_Elmt (List); 3354 while Present (Elmt) loop 3355 if Entity (Node (Elmt)) = Entity (N) then 3356 return True; 3357 else 3358 Next_Elmt (Elmt); 3359 end if; 3360 end loop; 3361 3362 return False; 3363 end Contains; 3364 3365 ------------------ 3366 -- Do_Traversal -- 3367 ------------------ 3368 3369 procedure Do_Traversal is new Traverse_Proc (Check_Node); 3370 -- The traversal procedure 3371 3372 -- Start of processing for Collect_Identifiers 3373 3374 begin 3375 if Present (Error_Node) then 3376 return; 3377 end if; 3378 3379 if Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then 3380 return; 3381 end if; 3382 3383 Do_Traversal (N); 3384 end Collect_Identifiers; 3385 3386 -- Start of processing for Check_Function_Writable_Actuals 3387 3388 begin 3389 -- The check only applies to Ada 2012 code on which Check_Actuals has 3390 -- been set, and only to constructs that have multiple constituents 3391 -- whose order of evaluation is not specified by the language. 3392 3393 if Ada_Version < Ada_2012 3394 or else not Check_Actuals (N) 3395 or else Nkind (N) not in N_Op 3396 | N_Membership_Test 3397 | N_Range 3398 | N_Aggregate 3399 | N_Extension_Aggregate 3400 | N_Full_Type_Declaration 3401 | N_Function_Call 3402 | N_Procedure_Call_Statement 3403 | N_Entry_Call_Statement 3404 or else (Nkind (N) = N_Full_Type_Declaration 3405 and then not Is_Record_Type (Defining_Identifier (N))) 3406 3407 -- In addition, this check only applies to source code, not to code 3408 -- generated by constraint checks. 3409 3410 or else not Comes_From_Source (N) 3411 then 3412 return; 3413 end if; 3414 3415 -- If a construct C has two or more direct constituents that are names 3416 -- or expressions whose evaluation may occur in an arbitrary order, at 3417 -- least one of which contains a function call with an in out or out 3418 -- parameter, then the construct is legal only if: for each name N that 3419 -- is passed as a parameter of mode in out or out to some inner function 3420 -- call C2 (not including the construct C itself), there is no other 3421 -- name anywhere within a direct constituent of the construct C other 3422 -- than the one containing C2, that is known to refer to the same 3423 -- object (RM 6.4.1(6.17/3)). 3424 3425 case Nkind (N) is 3426 when N_Range => 3427 Collect_Identifiers (Low_Bound (N)); 3428 Collect_Identifiers (High_Bound (N)); 3429 3430 when N_Membership_Test 3431 | N_Op 3432 => 3433 declare 3434 Expr : Node_Id; 3435 3436 begin 3437 Collect_Identifiers (Left_Opnd (N)); 3438 3439 if Present (Right_Opnd (N)) then 3440 Collect_Identifiers (Right_Opnd (N)); 3441 end if; 3442 3443 if Nkind (N) in N_In | N_Not_In 3444 and then Present (Alternatives (N)) 3445 then 3446 Expr := First (Alternatives (N)); 3447 while Present (Expr) loop 3448 Collect_Identifiers (Expr); 3449 3450 Next (Expr); 3451 end loop; 3452 end if; 3453 end; 3454 3455 when N_Full_Type_Declaration => 3456 declare 3457 function Get_Record_Part (N : Node_Id) return Node_Id; 3458 -- Return the record part of this record type definition 3459 3460 function Get_Record_Part (N : Node_Id) return Node_Id is 3461 Type_Def : constant Node_Id := Type_Definition (N); 3462 begin 3463 if Nkind (Type_Def) = N_Derived_Type_Definition then 3464 return Record_Extension_Part (Type_Def); 3465 else 3466 return Type_Def; 3467 end if; 3468 end Get_Record_Part; 3469 3470 Comp : Node_Id; 3471 Def_Id : Entity_Id := Defining_Identifier (N); 3472 Rec : Node_Id := Get_Record_Part (N); 3473 3474 begin 3475 -- No need to perform any analysis if the record has no 3476 -- components 3477 3478 if No (Rec) or else No (Component_List (Rec)) then 3479 return; 3480 end if; 3481 3482 -- Collect the identifiers starting from the deepest 3483 -- derivation. Done to report the error in the deepest 3484 -- derivation. 3485 3486 loop 3487 if Present (Component_List (Rec)) then 3488 Comp := First (Component_Items (Component_List (Rec))); 3489 while Present (Comp) loop 3490 if Nkind (Comp) = N_Component_Declaration 3491 and then Present (Expression (Comp)) 3492 then 3493 Collect_Identifiers (Expression (Comp)); 3494 end if; 3495 3496 Next (Comp); 3497 end loop; 3498 end if; 3499 3500 exit when No (Underlying_Type (Etype (Def_Id))) 3501 or else Base_Type (Underlying_Type (Etype (Def_Id))) 3502 = Def_Id; 3503 3504 Def_Id := Base_Type (Underlying_Type (Etype (Def_Id))); 3505 Rec := Get_Record_Part (Parent (Def_Id)); 3506 end loop; 3507 end; 3508 3509 when N_Entry_Call_Statement 3510 | N_Subprogram_Call 3511 => 3512 declare 3513 Id : constant Entity_Id := Get_Called_Entity (N); 3514 Formal : Node_Id; 3515 Actual : Node_Id; 3516 3517 begin 3518 Formal := First_Formal (Id); 3519 Actual := First_Actual (N); 3520 while Present (Actual) and then Present (Formal) loop 3521 if Ekind (Formal) in E_Out_Parameter | E_In_Out_Parameter 3522 then 3523 Collect_Identifiers (Actual); 3524 end if; 3525 3526 Next_Formal (Formal); 3527 Next_Actual (Actual); 3528 end loop; 3529 end; 3530 3531 when N_Aggregate 3532 | N_Extension_Aggregate 3533 => 3534 declare 3535 Assoc : Node_Id; 3536 Choice : Node_Id; 3537 Comp_Expr : Node_Id; 3538 3539 begin 3540 -- Handle the N_Others_Choice of array aggregates with static 3541 -- bounds. There is no need to perform this analysis in 3542 -- aggregates without static bounds since we cannot evaluate 3543 -- if the N_Others_Choice covers several elements. There is 3544 -- no need to handle the N_Others choice of record aggregates 3545 -- since at this stage it has been already expanded by 3546 -- Resolve_Record_Aggregate. 3547 3548 if Is_Array_Type (Etype (N)) 3549 and then Nkind (N) = N_Aggregate 3550 and then Present (Aggregate_Bounds (N)) 3551 and then Compile_Time_Known_Bounds (Etype (N)) 3552 and then Expr_Value (High_Bound (Aggregate_Bounds (N))) 3553 > 3554 Expr_Value (Low_Bound (Aggregate_Bounds (N))) 3555 then 3556 declare 3557 Count_Components : Uint := Uint_0; 3558 Num_Components : Uint; 3559 Others_Assoc : Node_Id := Empty; 3560 Others_Choice : Node_Id := Empty; 3561 Others_Box_Present : Boolean := False; 3562 3563 begin 3564 -- Count positional associations 3565 3566 if Present (Expressions (N)) then 3567 Comp_Expr := First (Expressions (N)); 3568 while Present (Comp_Expr) loop 3569 Count_Components := Count_Components + 1; 3570 Next (Comp_Expr); 3571 end loop; 3572 end if; 3573 3574 -- Count the rest of elements and locate the N_Others 3575 -- choice (if any) 3576 3577 Assoc := First (Component_Associations (N)); 3578 while Present (Assoc) loop 3579 Choice := First (Choices (Assoc)); 3580 while Present (Choice) loop 3581 if Nkind (Choice) = N_Others_Choice then 3582 Others_Assoc := Assoc; 3583 Others_Choice := Choice; 3584 Others_Box_Present := Box_Present (Assoc); 3585 3586 -- Count several components 3587 3588 elsif Nkind (Choice) in 3589 N_Range | N_Subtype_Indication 3590 or else (Is_Entity_Name (Choice) 3591 and then Is_Type (Entity (Choice))) 3592 then 3593 declare 3594 L, H : Node_Id; 3595 begin 3596 Get_Index_Bounds (Choice, L, H); 3597 pragma Assert 3598 (Compile_Time_Known_Value (L) 3599 and then Compile_Time_Known_Value (H)); 3600 Count_Components := 3601 Count_Components 3602 + Expr_Value (H) - Expr_Value (L) + 1; 3603 end; 3604 3605 -- Count single component. No other case available 3606 -- since we are handling an aggregate with static 3607 -- bounds. 3608 3609 else 3610 pragma Assert (Is_OK_Static_Expression (Choice) 3611 or else Nkind (Choice) = N_Identifier 3612 or else Nkind (Choice) = N_Integer_Literal); 3613 3614 Count_Components := Count_Components + 1; 3615 end if; 3616 3617 Next (Choice); 3618 end loop; 3619 3620 Next (Assoc); 3621 end loop; 3622 3623 Num_Components := 3624 Expr_Value (High_Bound (Aggregate_Bounds (N))) - 3625 Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1; 3626 3627 pragma Assert (Count_Components <= Num_Components); 3628 3629 -- Handle the N_Others choice if it covers several 3630 -- components 3631 3632 if Present (Others_Choice) 3633 and then (Num_Components - Count_Components) > 1 3634 then 3635 if not Others_Box_Present then 3636 3637 -- At this stage, if expansion is active, the 3638 -- expression of the others choice has not been 3639 -- analyzed. Hence we generate a duplicate and 3640 -- we analyze it silently to have available the 3641 -- minimum decoration required to collect the 3642 -- identifiers. 3643 3644 pragma Assert (Present (Others_Assoc)); 3645 3646 if not Expander_Active then 3647 Comp_Expr := Expression (Others_Assoc); 3648 else 3649 Comp_Expr := 3650 New_Copy_Tree (Expression (Others_Assoc)); 3651 Preanalyze_Without_Errors (Comp_Expr); 3652 end if; 3653 3654 Collect_Identifiers (Comp_Expr); 3655 3656 if Writable_Actuals_List /= No_Elist then 3657 3658 -- As suggested by Robert, at current stage we 3659 -- report occurrences of this case as warnings. 3660 3661 Error_Msg_N 3662 ("writable function parameter may affect " 3663 & "value in other component because order " 3664 & "of evaluation is unspecified??", 3665 Node (First_Elmt (Writable_Actuals_List))); 3666 end if; 3667 end if; 3668 end if; 3669 end; 3670 3671 -- For an array aggregate, a discrete_choice_list that has 3672 -- a nonstatic range is considered as two or more separate 3673 -- occurrences of the expression (RM 6.4.1(20/3)). 3674 3675 elsif Is_Array_Type (Etype (N)) 3676 and then Nkind (N) = N_Aggregate 3677 and then Present (Aggregate_Bounds (N)) 3678 and then not Compile_Time_Known_Bounds (Etype (N)) 3679 then 3680 -- Collect identifiers found in the dynamic bounds 3681 3682 declare 3683 Count_Components : Natural := 0; 3684 Low, High : Node_Id; 3685 3686 begin 3687 Assoc := First (Component_Associations (N)); 3688 while Present (Assoc) loop 3689 Choice := First (Choices (Assoc)); 3690 while Present (Choice) loop 3691 if Nkind (Choice) in 3692 N_Range | N_Subtype_Indication 3693 or else (Is_Entity_Name (Choice) 3694 and then Is_Type (Entity (Choice))) 3695 then 3696 Get_Index_Bounds (Choice, Low, High); 3697 3698 if not Compile_Time_Known_Value (Low) then 3699 Collect_Identifiers (Low); 3700 3701 if No (Aggr_Error_Node) then 3702 Aggr_Error_Node := Low; 3703 end if; 3704 end if; 3705 3706 if not Compile_Time_Known_Value (High) then 3707 Collect_Identifiers (High); 3708 3709 if No (Aggr_Error_Node) then 3710 Aggr_Error_Node := High; 3711 end if; 3712 end if; 3713 3714 -- The RM rule is violated if there is more than 3715 -- a single choice in a component association. 3716 3717 else 3718 Count_Components := Count_Components + 1; 3719 3720 if No (Aggr_Error_Node) 3721 and then Count_Components > 1 3722 then 3723 Aggr_Error_Node := Choice; 3724 end if; 3725 3726 if not Compile_Time_Known_Value (Choice) then 3727 Collect_Identifiers (Choice); 3728 end if; 3729 end if; 3730 3731 Next (Choice); 3732 end loop; 3733 3734 Next (Assoc); 3735 end loop; 3736 end; 3737 end if; 3738 3739 -- Handle ancestor part of extension aggregates 3740 3741 if Nkind (N) = N_Extension_Aggregate then 3742 Collect_Identifiers (Ancestor_Part (N)); 3743 end if; 3744 3745 -- Handle positional associations 3746 3747 if Present (Expressions (N)) then 3748 Comp_Expr := First (Expressions (N)); 3749 while Present (Comp_Expr) loop 3750 if not Is_OK_Static_Expression (Comp_Expr) then 3751 Collect_Identifiers (Comp_Expr); 3752 end if; 3753 3754 Next (Comp_Expr); 3755 end loop; 3756 end if; 3757 3758 -- Handle discrete associations 3759 3760 if Present (Component_Associations (N)) then 3761 Assoc := First (Component_Associations (N)); 3762 while Present (Assoc) loop 3763 3764 if not Box_Present (Assoc) then 3765 Choice := First (Choices (Assoc)); 3766 while Present (Choice) loop 3767 3768 -- For now we skip discriminants since it requires 3769 -- performing the analysis in two phases: first one 3770 -- analyzing discriminants and second one analyzing 3771 -- the rest of components since discriminants are 3772 -- evaluated prior to components: too much extra 3773 -- work to detect a corner case??? 3774 3775 if Nkind (Choice) in N_Has_Entity 3776 and then Present (Entity (Choice)) 3777 and then Ekind (Entity (Choice)) = E_Discriminant 3778 then 3779 null; 3780 3781 elsif Box_Present (Assoc) then 3782 null; 3783 3784 else 3785 if not Analyzed (Expression (Assoc)) then 3786 Comp_Expr := 3787 New_Copy_Tree (Expression (Assoc)); 3788 Set_Parent (Comp_Expr, Parent (N)); 3789 Preanalyze_Without_Errors (Comp_Expr); 3790 else 3791 Comp_Expr := Expression (Assoc); 3792 end if; 3793 3794 Collect_Identifiers (Comp_Expr); 3795 end if; 3796 3797 Next (Choice); 3798 end loop; 3799 end if; 3800 3801 Next (Assoc); 3802 end loop; 3803 end if; 3804 end; 3805 3806 when others => 3807 return; 3808 end case; 3809 3810 -- No further action needed if we already reported an error 3811 3812 if Present (Error_Node) then 3813 return; 3814 end if; 3815 3816 -- Check violation of RM 6.20/3 in aggregates 3817 3818 if Present (Aggr_Error_Node) 3819 and then Writable_Actuals_List /= No_Elist 3820 then 3821 Error_Msg_N 3822 ("value may be affected by call in other component because they " 3823 & "are evaluated in unspecified order", 3824 Node (First_Elmt (Writable_Actuals_List))); 3825 return; 3826 end if; 3827 3828 -- Check if some writable argument of a function is referenced 3829 3830 if Writable_Actuals_List /= No_Elist 3831 and then Identifiers_List /= No_Elist 3832 then 3833 declare 3834 Elmt_1 : Elmt_Id; 3835 Elmt_2 : Elmt_Id; 3836 3837 begin 3838 Elmt_1 := First_Elmt (Writable_Actuals_List); 3839 while Present (Elmt_1) loop 3840 Elmt_2 := First_Elmt (Identifiers_List); 3841 while Present (Elmt_2) loop 3842 if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then 3843 case Nkind (Parent (Node (Elmt_2))) is 3844 when N_Aggregate 3845 | N_Component_Association 3846 | N_Component_Declaration 3847 => 3848 Error_Msg_N 3849 ("value may be affected by call in other " 3850 & "component because they are evaluated " 3851 & "in unspecified order", 3852 Node (Elmt_2)); 3853 3854 when N_In 3855 | N_Not_In 3856 => 3857 Error_Msg_N 3858 ("value may be affected by call in other " 3859 & "alternative because they are evaluated " 3860 & "in unspecified order", 3861 Node (Elmt_2)); 3862 3863 when others => 3864 Error_Msg_N 3865 ("value of actual may be affected by call in " 3866 & "other actual because they are evaluated " 3867 & "in unspecified order", 3868 Node (Elmt_2)); 3869 end case; 3870 end if; 3871 3872 Next_Elmt (Elmt_2); 3873 end loop; 3874 3875 Next_Elmt (Elmt_1); 3876 end loop; 3877 end; 3878 end if; 3879 end Check_Function_Writable_Actuals; 3880 3881 -------------------------------- 3882 -- Check_Implicit_Dereference -- 3883 -------------------------------- 3884 3885 procedure Check_Implicit_Dereference (N : Node_Id; Typ : Entity_Id) is 3886 Disc : Entity_Id; 3887 Desig : Entity_Id; 3888 Nam : Node_Id; 3889 3890 begin 3891 if Nkind (N) = N_Indexed_Component 3892 and then Present (Generalized_Indexing (N)) 3893 then 3894 Nam := Generalized_Indexing (N); 3895 else 3896 Nam := N; 3897 end if; 3898 3899 if Ada_Version < Ada_2012 3900 or else not Has_Implicit_Dereference (Base_Type (Typ)) 3901 then 3902 return; 3903 3904 elsif not Comes_From_Source (N) 3905 and then Nkind (N) /= N_Indexed_Component 3906 then 3907 return; 3908 3909 elsif Is_Entity_Name (Nam) and then Is_Type (Entity (Nam)) then 3910 null; 3911 3912 else 3913 Disc := First_Discriminant (Typ); 3914 while Present (Disc) loop 3915 if Has_Implicit_Dereference (Disc) then 3916 Desig := Designated_Type (Etype (Disc)); 3917 Add_One_Interp (Nam, Disc, Desig); 3918 3919 -- If the node is a generalized indexing, add interpretation 3920 -- to that node as well, for subsequent resolution. 3921 3922 if Nkind (N) = N_Indexed_Component then 3923 Add_One_Interp (N, Disc, Desig); 3924 end if; 3925 3926 -- If the operation comes from a generic unit and the context 3927 -- is a selected component, the selector name may be global 3928 -- and set in the instance already. Remove the entity to 3929 -- force resolution of the selected component, and the 3930 -- generation of an explicit dereference if needed. 3931 3932 if In_Instance 3933 and then Nkind (Parent (Nam)) = N_Selected_Component 3934 then 3935 Set_Entity (Selector_Name (Parent (Nam)), Empty); 3936 end if; 3937 3938 exit; 3939 end if; 3940 3941 Next_Discriminant (Disc); 3942 end loop; 3943 end if; 3944 end Check_Implicit_Dereference; 3945 3946 ---------------------------------- 3947 -- Check_Internal_Protected_Use -- 3948 ---------------------------------- 3949 3950 procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is 3951 S : Entity_Id; 3952 Prot : Entity_Id; 3953 3954 begin 3955 Prot := Empty; 3956 3957 S := Current_Scope; 3958 while Present (S) loop 3959 if S = Standard_Standard then 3960 exit; 3961 3962 elsif Ekind (S) = E_Function 3963 and then Ekind (Scope (S)) = E_Protected_Type 3964 then 3965 Prot := Scope (S); 3966 exit; 3967 end if; 3968 3969 S := Scope (S); 3970 end loop; 3971 3972 if Present (Prot) 3973 and then Scope (Nam) = Prot 3974 and then Ekind (Nam) /= E_Function 3975 then 3976 -- An indirect function call (e.g. a callback within a protected 3977 -- function body) is not statically illegal. If the access type is 3978 -- anonymous and is the type of an access parameter, the scope of Nam 3979 -- will be the protected type, but it is not a protected operation. 3980 3981 if Ekind (Nam) = E_Subprogram_Type 3982 and then Nkind (Associated_Node_For_Itype (Nam)) = 3983 N_Function_Specification 3984 then 3985 null; 3986 3987 elsif Nkind (N) = N_Subprogram_Renaming_Declaration then 3988 Error_Msg_N 3989 ("within protected function cannot use protected procedure in " 3990 & "renaming or as generic actual", N); 3991 3992 elsif Nkind (N) = N_Attribute_Reference then 3993 Error_Msg_N 3994 ("within protected function cannot take access of protected " 3995 & "procedure", N); 3996 3997 else 3998 Error_Msg_N 3999 ("within protected function, protected object is constant", N); 4000 Error_Msg_N 4001 ("\cannot call operation that may modify it", N); 4002 end if; 4003 end if; 4004 4005 -- Verify that an internal call does not appear within a precondition 4006 -- of a protected operation. This implements AI12-0166. 4007 -- The precondition aspect has been rewritten as a pragma Precondition 4008 -- and we check whether the scope of the called subprogram is the same 4009 -- as that of the entity to which the aspect applies. 4010 4011 if Convention (Nam) = Convention_Protected then 4012 declare 4013 P : Node_Id; 4014 4015 begin 4016 P := Parent (N); 4017 while Present (P) loop 4018 if Nkind (P) = N_Pragma 4019 and then Chars (Pragma_Identifier (P)) = Name_Precondition 4020 and then From_Aspect_Specification (P) 4021 and then 4022 Scope (Entity (Corresponding_Aspect (P))) = Scope (Nam) 4023 then 4024 Error_Msg_N 4025 ("internal call cannot appear in precondition of " 4026 & "protected operation", N); 4027 return; 4028 4029 elsif Nkind (P) = N_Pragma 4030 and then Chars (Pragma_Identifier (P)) = Name_Contract_Cases 4031 then 4032 -- Check whether call is in a case guard. It is legal in a 4033 -- consequence. 4034 4035 P := N; 4036 while Present (P) loop 4037 if Nkind (Parent (P)) = N_Component_Association 4038 and then P /= Expression (Parent (P)) 4039 then 4040 Error_Msg_N 4041 ("internal call cannot appear in case guard in a " 4042 & "contract case", N); 4043 end if; 4044 4045 P := Parent (P); 4046 end loop; 4047 4048 return; 4049 4050 elsif Nkind (P) = N_Parameter_Specification 4051 and then Scope (Current_Scope) = Scope (Nam) 4052 and then Nkind (Parent (P)) in 4053 N_Entry_Declaration | N_Subprogram_Declaration 4054 then 4055 Error_Msg_N 4056 ("internal call cannot appear in default for formal of " 4057 & "protected operation", N); 4058 return; 4059 end if; 4060 4061 P := Parent (P); 4062 end loop; 4063 end; 4064 end if; 4065 end Check_Internal_Protected_Use; 4066 4067 --------------------------------------- 4068 -- Check_Later_Vs_Basic_Declarations -- 4069 --------------------------------------- 4070 4071 procedure Check_Later_Vs_Basic_Declarations 4072 (Decls : List_Id; 4073 During_Parsing : Boolean) 4074 is 4075 Body_Sloc : Source_Ptr; 4076 Decl : Node_Id; 4077 4078 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean; 4079 -- Return whether Decl is considered as a declarative item. 4080 -- When During_Parsing is True, the semantics of Ada 83 is followed. 4081 -- When During_Parsing is False, the semantics of SPARK is followed. 4082 4083 ------------------------------- 4084 -- Is_Later_Declarative_Item -- 4085 ------------------------------- 4086 4087 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is 4088 begin 4089 if Nkind (Decl) in N_Later_Decl_Item then 4090 return True; 4091 4092 elsif Nkind (Decl) = N_Pragma then 4093 return True; 4094 4095 elsif During_Parsing then 4096 return False; 4097 4098 -- In SPARK, a package declaration is not considered as a later 4099 -- declarative item. 4100 4101 elsif Nkind (Decl) = N_Package_Declaration then 4102 return False; 4103 4104 -- In SPARK, a renaming is considered as a later declarative item 4105 4106 elsif Nkind (Decl) in N_Renaming_Declaration then 4107 return True; 4108 4109 else 4110 return False; 4111 end if; 4112 end Is_Later_Declarative_Item; 4113 4114 -- Start of processing for Check_Later_Vs_Basic_Declarations 4115 4116 begin 4117 Decl := First (Decls); 4118 4119 -- Loop through sequence of basic declarative items 4120 4121 Outer : while Present (Decl) loop 4122 if Nkind (Decl) not in 4123 N_Subprogram_Body | N_Package_Body | N_Task_Body 4124 and then Nkind (Decl) not in N_Body_Stub 4125 then 4126 Next (Decl); 4127 4128 -- Once a body is encountered, we only allow later declarative 4129 -- items. The inner loop checks the rest of the list. 4130 4131 else 4132 Body_Sloc := Sloc (Decl); 4133 4134 Inner : while Present (Decl) loop 4135 if not Is_Later_Declarative_Item (Decl) then 4136 if During_Parsing then 4137 if Ada_Version = Ada_83 then 4138 Error_Msg_Sloc := Body_Sloc; 4139 Error_Msg_N 4140 ("(Ada 83) decl cannot appear after body#", Decl); 4141 end if; 4142 end if; 4143 end if; 4144 4145 Next (Decl); 4146 end loop Inner; 4147 end if; 4148 end loop Outer; 4149 end Check_Later_Vs_Basic_Declarations; 4150 4151 --------------------------- 4152 -- Check_No_Hidden_State -- 4153 --------------------------- 4154 4155 procedure Check_No_Hidden_State (Id : Entity_Id) is 4156 Context : Entity_Id := Empty; 4157 Not_Visible : Boolean := False; 4158 Scop : Entity_Id; 4159 4160 begin 4161 pragma Assert (Ekind (Id) in E_Abstract_State | E_Variable); 4162 4163 -- Nothing to do for internally-generated abstract states and variables 4164 -- because they do not represent the hidden state of the source unit. 4165 4166 if not Comes_From_Source (Id) then 4167 return; 4168 end if; 4169 4170 -- Find the proper context where the object or state appears 4171 4172 Scop := Scope (Id); 4173 while Present (Scop) loop 4174 Context := Scop; 4175 4176 -- Keep track of the context's visibility 4177 4178 Not_Visible := Not_Visible or else In_Private_Part (Context); 4179 4180 -- Prevent the search from going too far 4181 4182 if Context = Standard_Standard then 4183 return; 4184 4185 -- Objects and states that appear immediately within a subprogram or 4186 -- entry inside a construct nested within a subprogram do not 4187 -- introduce a hidden state. They behave as local variable 4188 -- declarations. The same is true for elaboration code inside a block 4189 -- or a task. 4190 4191 elsif Is_Subprogram_Or_Entry (Context) 4192 or else Ekind (Context) in E_Block | E_Task_Type 4193 then 4194 return; 4195 end if; 4196 4197 -- Stop the traversal when a package subject to a null abstract state 4198 -- has been found. 4199 4200 if Is_Package_Or_Generic_Package (Context) 4201 and then Has_Null_Abstract_State (Context) 4202 then 4203 exit; 4204 end if; 4205 4206 Scop := Scope (Scop); 4207 end loop; 4208 4209 -- At this point we know that there is at least one package with a null 4210 -- abstract state in visibility. Emit an error message unconditionally 4211 -- if the entity being processed is a state because the placement of the 4212 -- related package is irrelevant. This is not the case for objects as 4213 -- the intermediate context matters. 4214 4215 if Present (Context) 4216 and then (Ekind (Id) = E_Abstract_State or else Not_Visible) 4217 then 4218 Error_Msg_N ("cannot introduce hidden state &", Id); 4219 Error_Msg_NE ("\package & has null abstract state", Id, Context); 4220 end if; 4221 end Check_No_Hidden_State; 4222 4223 --------------------------------------------- 4224 -- Check_Nonoverridable_Aspect_Consistency -- 4225 --------------------------------------------- 4226 4227 procedure Check_Inherited_Nonoverridable_Aspects 4228 (Inheritor : Entity_Id; 4229 Interface_List : List_Id; 4230 Parent_Type : Entity_Id) is 4231 4232 -- array needed for iterating over subtype values 4233 Nonoverridable_Aspects : constant array (Positive range <>) of 4234 Nonoverridable_Aspect_Id := 4235 (Aspect_Default_Iterator, 4236 Aspect_Iterator_Element, 4237 Aspect_Implicit_Dereference, 4238 Aspect_Constant_Indexing, 4239 Aspect_Variable_Indexing, 4240 Aspect_Aggregate, 4241 Aspect_Max_Entry_Queue_Length 4242 -- , Aspect_No_Controlled_Parts 4243 ); 4244 4245 -- Note that none of these 8 aspects can be specified (for a type) 4246 -- via a pragma. For 7 of them, the corresponding pragma does not 4247 -- exist. The Pragma_Id enumeration type does include 4248 -- Pragma_Max_Entry_Queue_Length, but that pragma is only use to 4249 -- specify the aspect for a protected entry or entry family, not for 4250 -- a type, and therefore cannot introduce the sorts of inheritance 4251 -- issues that we are concerned with in this procedure. 4252 4253 type Entity_Array is array (Nat range <>) of Entity_Id; 4254 4255 function Ancestor_Entities return Entity_Array; 4256 -- Returns all progenitors (including parent type, if present) 4257 4258 procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors 4259 (Aspect : Nonoverridable_Aspect_Id; 4260 Ancestor_1 : Entity_Id; 4261 Aspect_Spec_1 : Node_Id; 4262 Ancestor_2 : Entity_Id; 4263 Aspect_Spec_2 : Node_Id); 4264 -- A given aspect has been specified for each of two ancestors; 4265 -- check that the two aspect specifications are compatible (see 4266 -- RM 13.1.1(18.5) and AI12-0211). 4267 4268 ----------------------- 4269 -- Ancestor_Entities -- 4270 ----------------------- 4271 4272 function Ancestor_Entities return Entity_Array is 4273 Ifc_Count : constant Nat := List_Length (Interface_List); 4274 Ifc_Ancestors : Entity_Array (1 .. Ifc_Count); 4275 Ifc : Node_Id := First (Interface_List); 4276 begin 4277 for Idx in Ifc_Ancestors'Range loop 4278 Ifc_Ancestors (Idx) := Entity (Ifc); 4279 pragma Assert (Present (Ifc_Ancestors (Idx))); 4280 Ifc := Next (Ifc); 4281 end loop; 4282 pragma Assert (not Present (Ifc)); 4283 if Present (Parent_Type) then 4284 return Parent_Type & Ifc_Ancestors; 4285 else 4286 return Ifc_Ancestors; 4287 end if; 4288 end Ancestor_Entities; 4289 4290 ------------------------------------------------------- 4291 -- Check_Consistency_For_One_Aspect_Of_Two_Ancestors -- 4292 ------------------------------------------------------- 4293 4294 procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors 4295 (Aspect : Nonoverridable_Aspect_Id; 4296 Ancestor_1 : Entity_Id; 4297 Aspect_Spec_1 : Node_Id; 4298 Ancestor_2 : Entity_Id; 4299 Aspect_Spec_2 : Node_Id) is 4300 begin 4301 if not Is_Confirming (Aspect, Aspect_Spec_1, Aspect_Spec_2) then 4302 Error_Msg_Name_1 := Aspect_Names (Aspect); 4303 Error_Msg_Name_2 := Chars (Ancestor_1); 4304 Error_Msg_Name_3 := Chars (Ancestor_2); 4305 4306 Error_Msg ( 4307 "incompatible % aspects inherited from ancestors % and %", 4308 Sloc (Inheritor)); 4309 end if; 4310 end Check_Consistency_For_One_Aspect_Of_Two_Ancestors; 4311 4312 Ancestors : constant Entity_Array := Ancestor_Entities; 4313 4314 -- start of processing for Check_Inherited_Nonoverridable_Aspects 4315 begin 4316 -- No Ada_Version check here; AI12-0211 is a binding interpretation. 4317 4318 if Ancestors'Length < 2 then 4319 return; -- Inconsistency impossible; it takes 2 to disagree. 4320 elsif In_Instance_Body then 4321 return; -- No legality checking in an instance body. 4322 end if; 4323 4324 for Aspect of Nonoverridable_Aspects loop 4325 declare 4326 First_Ancestor_With_Aspect : Entity_Id := Empty; 4327 First_Aspect_Spec, Current_Aspect_Spec : Node_Id := Empty; 4328 begin 4329 for Ancestor of Ancestors loop 4330 Current_Aspect_Spec := Find_Aspect (Ancestor, Aspect); 4331 if Present (Current_Aspect_Spec) then 4332 if Present (First_Ancestor_With_Aspect) then 4333 Check_Consistency_For_One_Aspect_Of_Two_Ancestors 4334 (Aspect => Aspect, 4335 Ancestor_1 => First_Ancestor_With_Aspect, 4336 Aspect_Spec_1 => First_Aspect_Spec, 4337 Ancestor_2 => Ancestor, 4338 Aspect_Spec_2 => Current_Aspect_Spec); 4339 else 4340 First_Ancestor_With_Aspect := Ancestor; 4341 First_Aspect_Spec := Current_Aspect_Spec; 4342 end if; 4343 end if; 4344 end loop; 4345 end; 4346 end loop; 4347 end Check_Inherited_Nonoverridable_Aspects; 4348 4349 ---------------------------------------- 4350 -- Check_Nonvolatile_Function_Profile -- 4351 ---------------------------------------- 4352 4353 procedure Check_Nonvolatile_Function_Profile (Func_Id : Entity_Id) is 4354 Formal : Entity_Id; 4355 4356 begin 4357 -- Inspect all formal parameters 4358 4359 Formal := First_Formal (Func_Id); 4360 while Present (Formal) loop 4361 if Is_Effectively_Volatile_For_Reading (Etype (Formal)) then 4362 Error_Msg_NE 4363 ("nonvolatile function & cannot have a volatile parameter", 4364 Formal, Func_Id); 4365 end if; 4366 4367 Next_Formal (Formal); 4368 end loop; 4369 4370 -- Inspect the return type 4371 4372 if Is_Effectively_Volatile_For_Reading (Etype (Func_Id)) then 4373 Error_Msg_NE 4374 ("nonvolatile function & cannot have a volatile return type", 4375 Result_Definition (Parent (Func_Id)), Func_Id); 4376 end if; 4377 end Check_Nonvolatile_Function_Profile; 4378 4379 ----------------------------- 4380 -- Check_Part_Of_Reference -- 4381 ----------------------------- 4382 4383 procedure Check_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id) is 4384 function Is_Enclosing_Package_Body 4385 (Body_Decl : Node_Id; 4386 Obj_Id : Entity_Id) return Boolean; 4387 pragma Inline (Is_Enclosing_Package_Body); 4388 -- Determine whether package body Body_Decl or its corresponding spec 4389 -- immediately encloses the declaration of object Obj_Id. 4390 4391 function Is_Internal_Declaration_Or_Body 4392 (Decl : Node_Id) return Boolean; 4393 pragma Inline (Is_Internal_Declaration_Or_Body); 4394 -- Determine whether declaration or body denoted by Decl is internal 4395 4396 function Is_Single_Declaration_Or_Body 4397 (Decl : Node_Id; 4398 Conc_Typ : Entity_Id) return Boolean; 4399 pragma Inline (Is_Single_Declaration_Or_Body); 4400 -- Determine whether protected/task declaration or body denoted by Decl 4401 -- belongs to single concurrent type Conc_Typ. 4402 4403 function Is_Single_Task_Pragma 4404 (Prag : Node_Id; 4405 Task_Typ : Entity_Id) return Boolean; 4406 pragma Inline (Is_Single_Task_Pragma); 4407 -- Determine whether pragma Prag belongs to single task type Task_Typ 4408 4409 ------------------------------- 4410 -- Is_Enclosing_Package_Body -- 4411 ------------------------------- 4412 4413 function Is_Enclosing_Package_Body 4414 (Body_Decl : Node_Id; 4415 Obj_Id : Entity_Id) return Boolean 4416 is 4417 Obj_Context : Node_Id; 4418 4419 begin 4420 -- Find the context of the object declaration 4421 4422 Obj_Context := Parent (Declaration_Node (Obj_Id)); 4423 4424 if Nkind (Obj_Context) = N_Package_Specification then 4425 Obj_Context := Parent (Obj_Context); 4426 end if; 4427 4428 -- The object appears immediately within the package body 4429 4430 if Obj_Context = Body_Decl then 4431 return True; 4432 4433 -- The object appears immediately within the corresponding spec 4434 4435 elsif Nkind (Obj_Context) = N_Package_Declaration 4436 and then Unit_Declaration_Node (Corresponding_Spec (Body_Decl)) = 4437 Obj_Context 4438 then 4439 return True; 4440 end if; 4441 4442 return False; 4443 end Is_Enclosing_Package_Body; 4444 4445 ------------------------------------- 4446 -- Is_Internal_Declaration_Or_Body -- 4447 ------------------------------------- 4448 4449 function Is_Internal_Declaration_Or_Body 4450 (Decl : Node_Id) return Boolean 4451 is 4452 begin 4453 if Comes_From_Source (Decl) then 4454 return False; 4455 4456 -- A body generated for an expression function which has not been 4457 -- inserted into the tree yet (In_Spec_Expression is True) is not 4458 -- considered internal. 4459 4460 elsif Nkind (Decl) = N_Subprogram_Body 4461 and then Was_Expression_Function (Decl) 4462 and then not In_Spec_Expression 4463 then 4464 return False; 4465 end if; 4466 4467 return True; 4468 end Is_Internal_Declaration_Or_Body; 4469 4470 ----------------------------------- 4471 -- Is_Single_Declaration_Or_Body -- 4472 ----------------------------------- 4473 4474 function Is_Single_Declaration_Or_Body 4475 (Decl : Node_Id; 4476 Conc_Typ : Entity_Id) return Boolean 4477 is 4478 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl); 4479 4480 begin 4481 return 4482 Present (Anonymous_Object (Spec_Id)) 4483 and then Anonymous_Object (Spec_Id) = Conc_Typ; 4484 end Is_Single_Declaration_Or_Body; 4485 4486 --------------------------- 4487 -- Is_Single_Task_Pragma -- 4488 --------------------------- 4489 4490 function Is_Single_Task_Pragma 4491 (Prag : Node_Id; 4492 Task_Typ : Entity_Id) return Boolean 4493 is 4494 Decl : constant Node_Id := Find_Related_Declaration_Or_Body (Prag); 4495 4496 begin 4497 -- To qualify, the pragma must be associated with single task type 4498 -- Task_Typ. 4499 4500 return 4501 Is_Single_Task_Object (Task_Typ) 4502 and then Nkind (Decl) = N_Object_Declaration 4503 and then Defining_Entity (Decl) = Task_Typ; 4504 end Is_Single_Task_Pragma; 4505 4506 -- Local variables 4507 4508 Conc_Obj : constant Entity_Id := Encapsulating_State (Var_Id); 4509 Par : Node_Id; 4510 Prag_Nam : Name_Id; 4511 Prev : Node_Id; 4512 4513 -- Start of processing for Check_Part_Of_Reference 4514 4515 begin 4516 -- Nothing to do when the variable was recorded, but did not become a 4517 -- constituent of a single concurrent type. 4518 4519 if No (Conc_Obj) then 4520 return; 4521 end if; 4522 4523 -- Traverse the parent chain looking for a suitable context for the 4524 -- reference to the concurrent constituent. 4525 4526 Prev := Ref; 4527 Par := Parent (Prev); 4528 while Present (Par) loop 4529 if Nkind (Par) = N_Pragma then 4530 Prag_Nam := Pragma_Name (Par); 4531 4532 -- A concurrent constituent is allowed to appear in pragmas 4533 -- Initial_Condition and Initializes as this is part of the 4534 -- elaboration checks for the constituent (SPARK RM 9(3)). 4535 4536 if Prag_Nam in Name_Initial_Condition | Name_Initializes then 4537 return; 4538 4539 -- When the reference appears within pragma Depends or Global, 4540 -- check whether the pragma applies to a single task type. Note 4541 -- that the pragma may not encapsulated by the type definition, 4542 -- but this is still a valid context. 4543 4544 elsif Prag_Nam in Name_Depends | Name_Global 4545 and then Is_Single_Task_Pragma (Par, Conc_Obj) 4546 then 4547 return; 4548 end if; 4549 4550 -- The reference appears somewhere in the definition of a single 4551 -- concurrent type (SPARK RM 9(3)). 4552 4553 elsif Nkind (Par) in 4554 N_Single_Protected_Declaration | N_Single_Task_Declaration 4555 and then Defining_Entity (Par) = Conc_Obj 4556 then 4557 return; 4558 4559 -- The reference appears within the declaration or body of a single 4560 -- concurrent type (SPARK RM 9(3)). 4561 4562 elsif Nkind (Par) in N_Protected_Body 4563 | N_Protected_Type_Declaration 4564 | N_Task_Body 4565 | N_Task_Type_Declaration 4566 and then Is_Single_Declaration_Or_Body (Par, Conc_Obj) 4567 then 4568 return; 4569 4570 -- The reference appears within the statement list of the object's 4571 -- immediately enclosing package (SPARK RM 9(3)). 4572 4573 elsif Nkind (Par) = N_Package_Body 4574 and then Nkind (Prev) = N_Handled_Sequence_Of_Statements 4575 and then Is_Enclosing_Package_Body (Par, Var_Id) 4576 then 4577 return; 4578 4579 -- The reference has been relocated within an internally generated 4580 -- package or subprogram. Assume that the reference is legal as the 4581 -- real check was already performed in the original context of the 4582 -- reference. 4583 4584 elsif Nkind (Par) in N_Package_Body 4585 | N_Package_Declaration 4586 | N_Subprogram_Body 4587 | N_Subprogram_Declaration 4588 and then Is_Internal_Declaration_Or_Body (Par) 4589 then 4590 return; 4591 4592 -- The reference has been relocated to an inlined body for GNATprove. 4593 -- Assume that the reference is legal as the real check was already 4594 -- performed in the original context of the reference. 4595 4596 elsif GNATprove_Mode 4597 and then Nkind (Par) = N_Subprogram_Body 4598 and then Chars (Defining_Entity (Par)) = Name_uParent 4599 then 4600 return; 4601 end if; 4602 4603 Prev := Par; 4604 Par := Parent (Prev); 4605 end loop; 4606 4607 -- At this point it is known that the reference does not appear within a 4608 -- legal context. 4609 4610 Error_Msg_NE 4611 ("reference to variable & cannot appear in this context", Ref, Var_Id); 4612 Error_Msg_Name_1 := Chars (Var_Id); 4613 4614 if Is_Single_Protected_Object (Conc_Obj) then 4615 Error_Msg_NE 4616 ("\% is constituent of single protected type &", Ref, Conc_Obj); 4617 4618 else 4619 Error_Msg_NE 4620 ("\% is constituent of single task type &", Ref, Conc_Obj); 4621 end if; 4622 end Check_Part_Of_Reference; 4623 4624 ------------------------------------------ 4625 -- Check_Potentially_Blocking_Operation -- 4626 ------------------------------------------ 4627 4628 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is 4629 S : Entity_Id; 4630 4631 begin 4632 -- N is one of the potentially blocking operations listed in 9.5.1(8). 4633 -- When pragma Detect_Blocking is active, the run time will raise 4634 -- Program_Error. Here we only issue a warning, since we generally 4635 -- support the use of potentially blocking operations in the absence 4636 -- of the pragma. 4637 4638 -- Indirect blocking through a subprogram call cannot be diagnosed 4639 -- statically without interprocedural analysis, so we do not attempt 4640 -- to do it here. 4641 4642 S := Scope (Current_Scope); 4643 while Present (S) and then S /= Standard_Standard loop 4644 if Is_Protected_Type (S) then 4645 Error_Msg_N 4646 ("potentially blocking operation in protected operation??", N); 4647 return; 4648 end if; 4649 4650 S := Scope (S); 4651 end loop; 4652 end Check_Potentially_Blocking_Operation; 4653 4654 ------------------------------------ 4655 -- Check_Previous_Null_Procedure -- 4656 ------------------------------------ 4657 4658 procedure Check_Previous_Null_Procedure 4659 (Decl : Node_Id; 4660 Prev : Entity_Id) 4661 is 4662 begin 4663 if Ekind (Prev) = E_Procedure 4664 and then Nkind (Parent (Prev)) = N_Procedure_Specification 4665 and then Null_Present (Parent (Prev)) 4666 then 4667 Error_Msg_Sloc := Sloc (Prev); 4668 Error_Msg_N 4669 ("declaration cannot complete previous null procedure#", Decl); 4670 end if; 4671 end Check_Previous_Null_Procedure; 4672 4673 --------------------------------- 4674 -- Check_Result_And_Post_State -- 4675 --------------------------------- 4676 4677 procedure Check_Result_And_Post_State (Subp_Id : Entity_Id) is 4678 procedure Check_Result_And_Post_State_In_Pragma 4679 (Prag : Node_Id; 4680 Result_Seen : in out Boolean); 4681 -- Determine whether pragma Prag mentions attribute 'Result and whether 4682 -- the pragma contains an expression that evaluates differently in pre- 4683 -- and post-state. Prag is a [refined] postcondition or a contract-cases 4684 -- pragma. Result_Seen is set when the pragma mentions attribute 'Result 4685 4686 function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean; 4687 -- Determine whether subprogram Subp_Id contains at least one IN OUT 4688 -- formal parameter. 4689 4690 ------------------------------------------- 4691 -- Check_Result_And_Post_State_In_Pragma -- 4692 ------------------------------------------- 4693 4694 procedure Check_Result_And_Post_State_In_Pragma 4695 (Prag : Node_Id; 4696 Result_Seen : in out Boolean) 4697 is 4698 procedure Check_Conjunct (Expr : Node_Id); 4699 -- Check an individual conjunct in a conjunction of Boolean 4700 -- expressions, connected by "and" or "and then" operators. 4701 4702 procedure Check_Conjuncts (Expr : Node_Id); 4703 -- Apply the post-state check to every conjunct in an expression, in 4704 -- case this is a conjunction of Boolean expressions. Otherwise apply 4705 -- it to the expression as a whole. 4706 4707 procedure Check_Expression (Expr : Node_Id); 4708 -- Perform the 'Result and post-state checks on a given expression 4709 4710 function Is_Function_Result (N : Node_Id) return Traverse_Result; 4711 -- Attempt to find attribute 'Result in a subtree denoted by N 4712 4713 function Is_Trivial_Boolean (N : Node_Id) return Boolean; 4714 -- Determine whether source node N denotes "True" or "False" 4715 4716 function Mentions_Post_State (N : Node_Id) return Boolean; 4717 -- Determine whether a subtree denoted by N mentions any construct 4718 -- that denotes a post-state. 4719 4720 procedure Check_Function_Result is 4721 new Traverse_Proc (Is_Function_Result); 4722 4723 -------------------- 4724 -- Check_Conjunct -- 4725 -------------------- 4726 4727 procedure Check_Conjunct (Expr : Node_Id) is 4728 function Adjust_Message (Msg : String) return String; 4729 -- Prepend a prefix to the input message Msg denoting that the 4730 -- message applies to a conjunct in the expression, when this 4731 -- is the case. 4732 4733 function Applied_On_Conjunct return Boolean; 4734 -- Returns True if the message applies to a conjunct in the 4735 -- expression, instead of the whole expression. 4736 4737 function Has_Global_Output (Subp : Entity_Id) return Boolean; 4738 -- Returns True if Subp has an output in its Global contract 4739 4740 function Has_No_Output (Subp : Entity_Id) return Boolean; 4741 -- Returns True if Subp has no declared output: no function 4742 -- result, no output parameter, and no output in its Global 4743 -- contract. 4744 4745 -------------------- 4746 -- Adjust_Message -- 4747 -------------------- 4748 4749 function Adjust_Message (Msg : String) return String is 4750 begin 4751 if Applied_On_Conjunct then 4752 return "conjunct in " & Msg; 4753 else 4754 return Msg; 4755 end if; 4756 end Adjust_Message; 4757 4758 ------------------------- 4759 -- Applied_On_Conjunct -- 4760 ------------------------- 4761 4762 function Applied_On_Conjunct return Boolean is 4763 begin 4764 -- Expr is the conjunct of an enclosing "and" expression 4765 4766 return Nkind (Parent (Expr)) in N_Subexpr 4767 4768 -- or Expr is a conjunct of an enclosing "and then" 4769 -- expression in a postcondition aspect that was split into 4770 -- multiple pragmas. The first conjunct has the "and then" 4771 -- expression as Original_Node, and other conjuncts have 4772 -- Split_PCC set to True. 4773 4774 or else Nkind (Original_Node (Expr)) = N_And_Then 4775 or else Split_PPC (Prag); 4776 end Applied_On_Conjunct; 4777 4778 ----------------------- 4779 -- Has_Global_Output -- 4780 ----------------------- 4781 4782 function Has_Global_Output (Subp : Entity_Id) return Boolean is 4783 Global : constant Node_Id := Get_Pragma (Subp, Pragma_Global); 4784 List : Node_Id; 4785 Assoc : Node_Id; 4786 4787 begin 4788 if No (Global) then 4789 return False; 4790 end if; 4791 4792 List := Expression (Get_Argument (Global, Subp)); 4793 4794 -- Empty list (no global items) or single global item 4795 -- declaration (only input items). 4796 4797 if Nkind (List) in N_Null 4798 | N_Expanded_Name 4799 | N_Identifier 4800 | N_Selected_Component 4801 then 4802 return False; 4803 4804 -- Simple global list (only input items) or moded global list 4805 -- declaration. 4806 4807 elsif Nkind (List) = N_Aggregate then 4808 if Present (Expressions (List)) then 4809 return False; 4810 4811 else 4812 Assoc := First (Component_Associations (List)); 4813 while Present (Assoc) loop 4814 if Chars (First (Choices (Assoc))) /= Name_Input then 4815 return True; 4816 end if; 4817 4818 Next (Assoc); 4819 end loop; 4820 4821 return False; 4822 end if; 4823 4824 -- To accommodate partial decoration of disabled SPARK 4825 -- features, this routine may be called with illegal input. 4826 -- If this is the case, do not raise Program_Error. 4827 4828 else 4829 return False; 4830 end if; 4831 end Has_Global_Output; 4832 4833 ------------------- 4834 -- Has_No_Output -- 4835 ------------------- 4836 4837 function Has_No_Output (Subp : Entity_Id) return Boolean is 4838 Param : Node_Id; 4839 4840 begin 4841 -- A function has its result as output 4842 4843 if Ekind (Subp) = E_Function then 4844 return False; 4845 end if; 4846 4847 -- An OUT or IN OUT parameter is an output 4848 4849 Param := First_Formal (Subp); 4850 while Present (Param) loop 4851 if Ekind (Param) in E_Out_Parameter | E_In_Out_Parameter then 4852 return False; 4853 end if; 4854 4855 Next_Formal (Param); 4856 end loop; 4857 4858 -- An item of mode Output or In_Out in the Global contract is 4859 -- an output. 4860 4861 if Has_Global_Output (Subp) then 4862 return False; 4863 end if; 4864 4865 return True; 4866 end Has_No_Output; 4867 4868 -- Local variables 4869 4870 Err_Node : Node_Id; 4871 -- Error node when reporting a warning on a (refined) 4872 -- postcondition. 4873 4874 -- Start of processing for Check_Conjunct 4875 4876 begin 4877 if Applied_On_Conjunct then 4878 Err_Node := Expr; 4879 else 4880 Err_Node := Prag; 4881 end if; 4882 4883 -- Do not report missing reference to outcome in postcondition if 4884 -- either the postcondition is trivially True or False, or if the 4885 -- subprogram is ghost and has no declared output. 4886 4887 if not Is_Trivial_Boolean (Expr) 4888 and then not Mentions_Post_State (Expr) 4889 and then not (Is_Ghost_Entity (Subp_Id) 4890 and then Has_No_Output (Subp_Id)) 4891 then 4892 if Pragma_Name (Prag) = Name_Contract_Cases then 4893 Error_Msg_NE (Adjust_Message 4894 ("contract case does not check the outcome of calling " 4895 & "&?T?"), Expr, Subp_Id); 4896 4897 elsif Pragma_Name (Prag) = Name_Refined_Post then 4898 Error_Msg_NE (Adjust_Message 4899 ("refined postcondition does not check the outcome of " 4900 & "calling &?T?"), Err_Node, Subp_Id); 4901 4902 else 4903 Error_Msg_NE (Adjust_Message 4904 ("postcondition does not check the outcome of calling " 4905 & "&?T?"), Err_Node, Subp_Id); 4906 end if; 4907 end if; 4908 end Check_Conjunct; 4909 4910 --------------------- 4911 -- Check_Conjuncts -- 4912 --------------------- 4913 4914 procedure Check_Conjuncts (Expr : Node_Id) is 4915 begin 4916 if Nkind (Expr) in N_Op_And | N_And_Then then 4917 Check_Conjuncts (Left_Opnd (Expr)); 4918 Check_Conjuncts (Right_Opnd (Expr)); 4919 else 4920 Check_Conjunct (Expr); 4921 end if; 4922 end Check_Conjuncts; 4923 4924 ---------------------- 4925 -- Check_Expression -- 4926 ---------------------- 4927 4928 procedure Check_Expression (Expr : Node_Id) is 4929 begin 4930 if not Is_Trivial_Boolean (Expr) then 4931 Check_Function_Result (Expr); 4932 Check_Conjuncts (Expr); 4933 end if; 4934 end Check_Expression; 4935 4936 ------------------------ 4937 -- Is_Function_Result -- 4938 ------------------------ 4939 4940 function Is_Function_Result (N : Node_Id) return Traverse_Result is 4941 begin 4942 if Is_Attribute_Result (N) then 4943 Result_Seen := True; 4944 return Abandon; 4945 4946 -- Warn on infinite recursion if call is to current function 4947 4948 elsif Nkind (N) = N_Function_Call 4949 and then Is_Entity_Name (Name (N)) 4950 and then Entity (Name (N)) = Subp_Id 4951 and then not Is_Potentially_Unevaluated (N) 4952 then 4953 Error_Msg_NE 4954 ("call to & within its postcondition will lead to infinite " 4955 & "recursion?", N, Subp_Id); 4956 return OK; 4957 4958 -- Continue the traversal 4959 4960 else 4961 return OK; 4962 end if; 4963 end Is_Function_Result; 4964 4965 ------------------------ 4966 -- Is_Trivial_Boolean -- 4967 ------------------------ 4968 4969 function Is_Trivial_Boolean (N : Node_Id) return Boolean is 4970 begin 4971 return 4972 Comes_From_Source (N) 4973 and then Is_Entity_Name (N) 4974 and then (Entity (N) = Standard_True 4975 or else 4976 Entity (N) = Standard_False); 4977 end Is_Trivial_Boolean; 4978 4979 ------------------------- 4980 -- Mentions_Post_State -- 4981 ------------------------- 4982 4983 function Mentions_Post_State (N : Node_Id) return Boolean is 4984 Post_State_Seen : Boolean := False; 4985 4986 function Is_Post_State (N : Node_Id) return Traverse_Result; 4987 -- Attempt to find a construct that denotes a post-state. If this 4988 -- is the case, set flag Post_State_Seen. 4989 4990 ------------------- 4991 -- Is_Post_State -- 4992 ------------------- 4993 4994 function Is_Post_State (N : Node_Id) return Traverse_Result is 4995 Ent : Entity_Id; 4996 4997 begin 4998 if Nkind (N) in N_Explicit_Dereference | N_Function_Call then 4999 Post_State_Seen := True; 5000 return Abandon; 5001 5002 elsif Nkind (N) in N_Expanded_Name | N_Identifier then 5003 Ent := Entity (N); 5004 5005 -- Treat an undecorated reference as OK 5006 5007 if No (Ent) 5008 5009 -- A reference to an assignable entity is considered a 5010 -- change in the post-state of a subprogram. 5011 5012 or else Ekind (Ent) in E_Generic_In_Out_Parameter 5013 | E_In_Out_Parameter 5014 | E_Out_Parameter 5015 | E_Variable 5016 5017 -- The reference may be modified through a dereference 5018 5019 or else (Is_Access_Type (Etype (Ent)) 5020 and then Nkind (Parent (N)) = 5021 N_Selected_Component) 5022 then 5023 Post_State_Seen := True; 5024 return Abandon; 5025 end if; 5026 5027 elsif Nkind (N) = N_Attribute_Reference then 5028 if Attribute_Name (N) = Name_Old then 5029 return Skip; 5030 5031 elsif Attribute_Name (N) = Name_Result then 5032 Post_State_Seen := True; 5033 return Abandon; 5034 end if; 5035 end if; 5036 5037 return OK; 5038 end Is_Post_State; 5039 5040 procedure Find_Post_State is new Traverse_Proc (Is_Post_State); 5041 5042 -- Start of processing for Mentions_Post_State 5043 5044 begin 5045 Find_Post_State (N); 5046 5047 return Post_State_Seen; 5048 end Mentions_Post_State; 5049 5050 -- Local variables 5051 5052 Expr : constant Node_Id := 5053 Get_Pragma_Arg 5054 (First (Pragma_Argument_Associations (Prag))); 5055 Nam : constant Name_Id := Pragma_Name (Prag); 5056 CCase : Node_Id; 5057 5058 -- Start of processing for Check_Result_And_Post_State_In_Pragma 5059 5060 begin 5061 -- Examine all consequences 5062 5063 if Nam = Name_Contract_Cases then 5064 CCase := First (Component_Associations (Expr)); 5065 while Present (CCase) loop 5066 Check_Expression (Expression (CCase)); 5067 5068 Next (CCase); 5069 end loop; 5070 5071 -- Examine the expression of a postcondition 5072 5073 else pragma Assert (Nam in Name_Postcondition | Name_Refined_Post); 5074 Check_Expression (Expr); 5075 end if; 5076 end Check_Result_And_Post_State_In_Pragma; 5077 5078 -------------------------- 5079 -- Has_In_Out_Parameter -- 5080 -------------------------- 5081 5082 function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean is 5083 Formal : Entity_Id; 5084 5085 begin 5086 -- Traverse the formals looking for an IN OUT parameter 5087 5088 Formal := First_Formal (Subp_Id); 5089 while Present (Formal) loop 5090 if Ekind (Formal) = E_In_Out_Parameter then 5091 return True; 5092 end if; 5093 5094 Next_Formal (Formal); 5095 end loop; 5096 5097 return False; 5098 end Has_In_Out_Parameter; 5099 5100 -- Local variables 5101 5102 Items : constant Node_Id := Contract (Subp_Id); 5103 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); 5104 Case_Prag : Node_Id := Empty; 5105 Post_Prag : Node_Id := Empty; 5106 Prag : Node_Id; 5107 Seen_In_Case : Boolean := False; 5108 Seen_In_Post : Boolean := False; 5109 Spec_Id : Entity_Id; 5110 5111 -- Start of processing for Check_Result_And_Post_State 5112 5113 begin 5114 -- The lack of attribute 'Result or a post-state is classified as a 5115 -- suspicious contract. Do not perform the check if the corresponding 5116 -- swich is not set. 5117 5118 if not Warn_On_Suspicious_Contract then 5119 return; 5120 5121 -- Nothing to do if there is no contract 5122 5123 elsif No (Items) then 5124 return; 5125 end if; 5126 5127 -- Retrieve the entity of the subprogram spec (if any) 5128 5129 if Nkind (Subp_Decl) = N_Subprogram_Body 5130 and then Present (Corresponding_Spec (Subp_Decl)) 5131 then 5132 Spec_Id := Corresponding_Spec (Subp_Decl); 5133 5134 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 5135 and then Present (Corresponding_Spec_Of_Stub (Subp_Decl)) 5136 then 5137 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl); 5138 5139 else 5140 Spec_Id := Subp_Id; 5141 end if; 5142 5143 -- Examine all postconditions for attribute 'Result and a post-state 5144 5145 Prag := Pre_Post_Conditions (Items); 5146 while Present (Prag) loop 5147 if Pragma_Name_Unmapped (Prag) 5148 in Name_Postcondition | Name_Refined_Post 5149 and then not Error_Posted (Prag) 5150 then 5151 Post_Prag := Prag; 5152 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Post); 5153 end if; 5154 5155 Prag := Next_Pragma (Prag); 5156 end loop; 5157 5158 -- Examine the contract cases of the subprogram for attribute 'Result 5159 -- and a post-state. 5160 5161 Prag := Contract_Test_Cases (Items); 5162 while Present (Prag) loop 5163 if Pragma_Name (Prag) = Name_Contract_Cases 5164 and then not Error_Posted (Prag) 5165 then 5166 Case_Prag := Prag; 5167 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Case); 5168 end if; 5169 5170 Prag := Next_Pragma (Prag); 5171 end loop; 5172 5173 -- Do not emit any errors if the subprogram is not a function 5174 5175 if Ekind (Spec_Id) not in E_Function | E_Generic_Function then 5176 null; 5177 5178 -- Regardless of whether the function has postconditions or contract 5179 -- cases, or whether they mention attribute 'Result, an IN OUT formal 5180 -- parameter is always treated as a result. 5181 5182 elsif Has_In_Out_Parameter (Spec_Id) then 5183 null; 5184 5185 -- The function has both a postcondition and contract cases and they do 5186 -- not mention attribute 'Result. 5187 5188 elsif Present (Case_Prag) 5189 and then not Seen_In_Case 5190 and then Present (Post_Prag) 5191 and then not Seen_In_Post 5192 then 5193 Error_Msg_N 5194 ("neither postcondition nor contract cases mention function " 5195 & "result?T?", Post_Prag); 5196 5197 -- The function has contract cases only and they do not mention 5198 -- attribute 'Result. 5199 5200 elsif Present (Case_Prag) and then not Seen_In_Case then 5201 Error_Msg_N ("contract cases do not mention result?T?", Case_Prag); 5202 5203 -- The function has postconditions only and they do not mention 5204 -- attribute 'Result. 5205 5206 elsif Present (Post_Prag) and then not Seen_In_Post then 5207 Error_Msg_N 5208 ("postcondition does not mention function result?T?", Post_Prag); 5209 end if; 5210 end Check_Result_And_Post_State; 5211 5212 ----------------------------- 5213 -- Check_State_Refinements -- 5214 ----------------------------- 5215 5216 procedure Check_State_Refinements 5217 (Context : Node_Id; 5218 Is_Main_Unit : Boolean := False) 5219 is 5220 procedure Check_Package (Pack : Node_Id); 5221 -- Verify that all abstract states of a [generic] package denoted by its 5222 -- declarative node Pack have proper refinement. Recursively verify the 5223 -- visible and private declarations of the [generic] package for other 5224 -- nested packages. 5225 5226 procedure Check_Packages_In (Decls : List_Id); 5227 -- Seek out [generic] package declarations within declarative list Decls 5228 -- and verify the status of their abstract state refinement. 5229 5230 function SPARK_Mode_Is_Off (N : Node_Id) return Boolean; 5231 -- Determine whether construct N is subject to pragma SPARK_Mode Off 5232 5233 ------------------- 5234 -- Check_Package -- 5235 ------------------- 5236 5237 procedure Check_Package (Pack : Node_Id) is 5238 Body_Id : constant Entity_Id := Corresponding_Body (Pack); 5239 Spec : constant Node_Id := Specification (Pack); 5240 States : constant Elist_Id := 5241 Abstract_States (Defining_Entity (Pack)); 5242 5243 State_Elmt : Elmt_Id; 5244 State_Id : Entity_Id; 5245 5246 begin 5247 -- Do not verify proper state refinement when the package is subject 5248 -- to pragma SPARK_Mode Off because this disables the requirement for 5249 -- state refinement. 5250 5251 if SPARK_Mode_Is_Off (Pack) then 5252 null; 5253 5254 -- State refinement can only occur in a completing package body. Do 5255 -- not verify proper state refinement when the body is subject to 5256 -- pragma SPARK_Mode Off because this disables the requirement for 5257 -- state refinement. 5258 5259 elsif Present (Body_Id) 5260 and then SPARK_Mode_Is_Off (Unit_Declaration_Node (Body_Id)) 5261 then 5262 null; 5263 5264 -- Do not verify proper state refinement when the package is an 5265 -- instance as this check was already performed in the generic. 5266 5267 elsif Present (Generic_Parent (Spec)) then 5268 null; 5269 5270 -- Otherwise examine the contents of the package 5271 5272 else 5273 if Present (States) then 5274 State_Elmt := First_Elmt (States); 5275 while Present (State_Elmt) loop 5276 State_Id := Node (State_Elmt); 5277 5278 -- Emit an error when a non-null state lacks any form of 5279 -- refinement. 5280 5281 if not Is_Null_State (State_Id) 5282 and then not Has_Null_Refinement (State_Id) 5283 and then not Has_Non_Null_Refinement (State_Id) 5284 then 5285 Error_Msg_N ("state & requires refinement", State_Id); 5286 end if; 5287 5288 Next_Elmt (State_Elmt); 5289 end loop; 5290 end if; 5291 5292 Check_Packages_In (Visible_Declarations (Spec)); 5293 Check_Packages_In (Private_Declarations (Spec)); 5294 end if; 5295 end Check_Package; 5296 5297 ----------------------- 5298 -- Check_Packages_In -- 5299 ----------------------- 5300 5301 procedure Check_Packages_In (Decls : List_Id) is 5302 Decl : Node_Id; 5303 5304 begin 5305 if Present (Decls) then 5306 Decl := First (Decls); 5307 while Present (Decl) loop 5308 if Nkind (Decl) in N_Generic_Package_Declaration 5309 | N_Package_Declaration 5310 then 5311 Check_Package (Decl); 5312 end if; 5313 5314 Next (Decl); 5315 end loop; 5316 end if; 5317 end Check_Packages_In; 5318 5319 ----------------------- 5320 -- SPARK_Mode_Is_Off -- 5321 ----------------------- 5322 5323 function SPARK_Mode_Is_Off (N : Node_Id) return Boolean is 5324 Id : constant Entity_Id := Defining_Entity (N); 5325 Prag : constant Node_Id := SPARK_Pragma (Id); 5326 5327 begin 5328 -- Default the mode to "off" when the context is an instance and all 5329 -- SPARK_Mode pragmas found within are to be ignored. 5330 5331 if Ignore_SPARK_Mode_Pragmas (Id) then 5332 return True; 5333 5334 else 5335 return 5336 Present (Prag) 5337 and then Get_SPARK_Mode_From_Annotation (Prag) = Off; 5338 end if; 5339 end SPARK_Mode_Is_Off; 5340 5341 -- Start of processing for Check_State_Refinements 5342 5343 begin 5344 -- A block may declare a nested package 5345 5346 if Nkind (Context) = N_Block_Statement then 5347 Check_Packages_In (Declarations (Context)); 5348 5349 -- An entry, protected, subprogram, or task body may declare a nested 5350 -- package. 5351 5352 elsif Nkind (Context) in N_Entry_Body 5353 | N_Protected_Body 5354 | N_Subprogram_Body 5355 | N_Task_Body 5356 then 5357 -- Do not verify proper state refinement when the body is subject to 5358 -- pragma SPARK_Mode Off because this disables the requirement for 5359 -- state refinement. 5360 5361 if not SPARK_Mode_Is_Off (Context) then 5362 Check_Packages_In (Declarations (Context)); 5363 end if; 5364 5365 -- A package body may declare a nested package 5366 5367 elsif Nkind (Context) = N_Package_Body then 5368 Check_Package (Unit_Declaration_Node (Corresponding_Spec (Context))); 5369 5370 -- Do not verify proper state refinement when the body is subject to 5371 -- pragma SPARK_Mode Off because this disables the requirement for 5372 -- state refinement. 5373 5374 if not SPARK_Mode_Is_Off (Context) then 5375 Check_Packages_In (Declarations (Context)); 5376 end if; 5377 5378 -- A library level [generic] package may declare a nested package 5379 5380 elsif Nkind (Context) in 5381 N_Generic_Package_Declaration | N_Package_Declaration 5382 and then Is_Main_Unit 5383 then 5384 Check_Package (Context); 5385 end if; 5386 end Check_State_Refinements; 5387 5388 ------------------------------ 5389 -- Check_Unprotected_Access -- 5390 ------------------------------ 5391 5392 procedure Check_Unprotected_Access 5393 (Context : Node_Id; 5394 Expr : Node_Id) 5395 is 5396 Cont_Encl_Typ : Entity_Id; 5397 Pref_Encl_Typ : Entity_Id; 5398 5399 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id; 5400 -- Check whether Obj is a private component of a protected object. 5401 -- Return the protected type where the component resides, Empty 5402 -- otherwise. 5403 5404 function Is_Public_Operation return Boolean; 5405 -- Verify that the enclosing operation is callable from outside the 5406 -- protected object, to minimize false positives. 5407 5408 ------------------------------ 5409 -- Enclosing_Protected_Type -- 5410 ------------------------------ 5411 5412 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is 5413 begin 5414 if Is_Entity_Name (Obj) then 5415 declare 5416 Ent : Entity_Id := Entity (Obj); 5417 5418 begin 5419 -- The object can be a renaming of a private component, use 5420 -- the original record component. 5421 5422 if Is_Prival (Ent) then 5423 Ent := Prival_Link (Ent); 5424 end if; 5425 5426 if Is_Protected_Type (Scope (Ent)) then 5427 return Scope (Ent); 5428 end if; 5429 end; 5430 end if; 5431 5432 -- For indexed and selected components, recursively check the prefix 5433 5434 if Nkind (Obj) in N_Indexed_Component | N_Selected_Component then 5435 return Enclosing_Protected_Type (Prefix (Obj)); 5436 5437 -- The object does not denote a protected component 5438 5439 else 5440 return Empty; 5441 end if; 5442 end Enclosing_Protected_Type; 5443 5444 ------------------------- 5445 -- Is_Public_Operation -- 5446 ------------------------- 5447 5448 function Is_Public_Operation return Boolean is 5449 S : Entity_Id; 5450 E : Entity_Id; 5451 5452 begin 5453 S := Current_Scope; 5454 while Present (S) and then S /= Pref_Encl_Typ loop 5455 if Scope (S) = Pref_Encl_Typ then 5456 E := First_Entity (Pref_Encl_Typ); 5457 while Present (E) 5458 and then E /= First_Private_Entity (Pref_Encl_Typ) 5459 loop 5460 if E = S then 5461 return True; 5462 end if; 5463 5464 Next_Entity (E); 5465 end loop; 5466 end if; 5467 5468 S := Scope (S); 5469 end loop; 5470 5471 return False; 5472 end Is_Public_Operation; 5473 5474 -- Start of processing for Check_Unprotected_Access 5475 5476 begin 5477 if Nkind (Expr) = N_Attribute_Reference 5478 and then Attribute_Name (Expr) = Name_Unchecked_Access 5479 then 5480 Cont_Encl_Typ := Enclosing_Protected_Type (Context); 5481 Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr)); 5482 5483 -- Check whether we are trying to export a protected component to a 5484 -- context with an equal or lower access level. 5485 5486 if Present (Pref_Encl_Typ) 5487 and then No (Cont_Encl_Typ) 5488 and then Is_Public_Operation 5489 and then Scope_Depth (Pref_Encl_Typ) 5490 >= Static_Accessibility_Level 5491 (Context, Object_Decl_Level) 5492 then 5493 Error_Msg_N 5494 ("??possible unprotected access to protected data", Expr); 5495 end if; 5496 end if; 5497 end Check_Unprotected_Access; 5498 5499 ------------------------------ 5500 -- Check_Unused_Body_States -- 5501 ------------------------------ 5502 5503 procedure Check_Unused_Body_States (Body_Id : Entity_Id) is 5504 procedure Process_Refinement_Clause 5505 (Clause : Node_Id; 5506 States : Elist_Id); 5507 -- Inspect all constituents of refinement clause Clause and remove any 5508 -- matches from body state list States. 5509 5510 procedure Report_Unused_Body_States (States : Elist_Id); 5511 -- Emit errors for each abstract state or object found in list States 5512 5513 ------------------------------- 5514 -- Process_Refinement_Clause -- 5515 ------------------------------- 5516 5517 procedure Process_Refinement_Clause 5518 (Clause : Node_Id; 5519 States : Elist_Id) 5520 is 5521 procedure Process_Constituent (Constit : Node_Id); 5522 -- Remove constituent Constit from body state list States 5523 5524 ------------------------- 5525 -- Process_Constituent -- 5526 ------------------------- 5527 5528 procedure Process_Constituent (Constit : Node_Id) is 5529 Constit_Id : Entity_Id; 5530 5531 begin 5532 -- Guard against illegal constituents. Only abstract states and 5533 -- objects can appear on the right hand side of a refinement. 5534 5535 if Is_Entity_Name (Constit) then 5536 Constit_Id := Entity_Of (Constit); 5537 5538 if Present (Constit_Id) 5539 and then Ekind (Constit_Id) in 5540 E_Abstract_State | E_Constant | E_Variable 5541 then 5542 Remove (States, Constit_Id); 5543 end if; 5544 end if; 5545 end Process_Constituent; 5546 5547 -- Local variables 5548 5549 Constit : Node_Id; 5550 5551 -- Start of processing for Process_Refinement_Clause 5552 5553 begin 5554 if Nkind (Clause) = N_Component_Association then 5555 Constit := Expression (Clause); 5556 5557 -- Multiple constituents appear as an aggregate 5558 5559 if Nkind (Constit) = N_Aggregate then 5560 Constit := First (Expressions (Constit)); 5561 while Present (Constit) loop 5562 Process_Constituent (Constit); 5563 Next (Constit); 5564 end loop; 5565 5566 -- Various forms of a single constituent 5567 5568 else 5569 Process_Constituent (Constit); 5570 end if; 5571 end if; 5572 end Process_Refinement_Clause; 5573 5574 ------------------------------- 5575 -- Report_Unused_Body_States -- 5576 ------------------------------- 5577 5578 procedure Report_Unused_Body_States (States : Elist_Id) is 5579 Posted : Boolean := False; 5580 State_Elmt : Elmt_Id; 5581 State_Id : Entity_Id; 5582 5583 begin 5584 if Present (States) then 5585 State_Elmt := First_Elmt (States); 5586 while Present (State_Elmt) loop 5587 State_Id := Node (State_Elmt); 5588 5589 -- Constants are part of the hidden state of a package, but the 5590 -- compiler cannot determine whether they have variable input 5591 -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a 5592 -- hidden state. Do not emit an error when a constant does not 5593 -- participate in a state refinement, even though it acts as a 5594 -- hidden state. 5595 5596 if Ekind (State_Id) = E_Constant then 5597 null; 5598 5599 -- Generate an error message of the form: 5600 5601 -- body of package ... has unused hidden states 5602 -- abstract state ... defined at ... 5603 -- variable ... defined at ... 5604 5605 else 5606 if not Posted then 5607 Posted := True; 5608 SPARK_Msg_N 5609 ("body of package & has unused hidden states", Body_Id); 5610 end if; 5611 5612 Error_Msg_Sloc := Sloc (State_Id); 5613 5614 if Ekind (State_Id) = E_Abstract_State then 5615 SPARK_Msg_NE 5616 ("\abstract state & defined #", Body_Id, State_Id); 5617 5618 else 5619 SPARK_Msg_NE ("\variable & defined #", Body_Id, State_Id); 5620 end if; 5621 end if; 5622 5623 Next_Elmt (State_Elmt); 5624 end loop; 5625 end if; 5626 end Report_Unused_Body_States; 5627 5628 -- Local variables 5629 5630 Prag : constant Node_Id := Get_Pragma (Body_Id, Pragma_Refined_State); 5631 Spec_Id : constant Entity_Id := Spec_Entity (Body_Id); 5632 Clause : Node_Id; 5633 States : Elist_Id; 5634 5635 -- Start of processing for Check_Unused_Body_States 5636 5637 begin 5638 -- Inspect the clauses of pragma Refined_State and determine whether all 5639 -- visible states declared within the package body participate in the 5640 -- refinement. 5641 5642 if Present (Prag) then 5643 Clause := Expression (Get_Argument (Prag, Spec_Id)); 5644 States := Collect_Body_States (Body_Id); 5645 5646 -- Multiple non-null state refinements appear as an aggregate 5647 5648 if Nkind (Clause) = N_Aggregate then 5649 Clause := First (Component_Associations (Clause)); 5650 while Present (Clause) loop 5651 Process_Refinement_Clause (Clause, States); 5652 Next (Clause); 5653 end loop; 5654 5655 -- Various forms of a single state refinement 5656 5657 else 5658 Process_Refinement_Clause (Clause, States); 5659 end if; 5660 5661 -- Ensure that all abstract states and objects declared in the 5662 -- package body state space are utilized as constituents. 5663 5664 Report_Unused_Body_States (States); 5665 end if; 5666 end Check_Unused_Body_States; 5667 5668 ------------------------------------ 5669 -- Check_Volatility_Compatibility -- 5670 ------------------------------------ 5671 5672 procedure Check_Volatility_Compatibility 5673 (Id1, Id2 : Entity_Id; 5674 Description_1, Description_2 : String; 5675 Srcpos_Bearer : Node_Id) is 5676 5677 begin 5678 if SPARK_Mode /= On then 5679 return; 5680 end if; 5681 5682 declare 5683 AR1 : constant Boolean := Async_Readers_Enabled (Id1); 5684 AW1 : constant Boolean := Async_Writers_Enabled (Id1); 5685 ER1 : constant Boolean := Effective_Reads_Enabled (Id1); 5686 EW1 : constant Boolean := Effective_Writes_Enabled (Id1); 5687 AR2 : constant Boolean := Async_Readers_Enabled (Id2); 5688 AW2 : constant Boolean := Async_Writers_Enabled (Id2); 5689 ER2 : constant Boolean := Effective_Reads_Enabled (Id2); 5690 EW2 : constant Boolean := Effective_Writes_Enabled (Id2); 5691 5692 AR_Check_Failed : constant Boolean := AR1 and not AR2; 5693 AW_Check_Failed : constant Boolean := AW1 and not AW2; 5694 ER_Check_Failed : constant Boolean := ER1 and not ER2; 5695 EW_Check_Failed : constant Boolean := EW1 and not EW2; 5696 5697 package Failure_Description is 5698 procedure Note_If_Failure 5699 (Failed : Boolean; Aspect_Name : String); 5700 -- If Failed is False, do nothing. 5701 -- If Failed is True, add Aspect_Name to the failure description. 5702 5703 function Failure_Text return String; 5704 -- returns accumulated list of failing aspects 5705 end Failure_Description; 5706 5707 package body Failure_Description is 5708 Description_Buffer : Bounded_String; 5709 5710 --------------------- 5711 -- Note_If_Failure -- 5712 --------------------- 5713 5714 procedure Note_If_Failure 5715 (Failed : Boolean; Aspect_Name : String) is 5716 begin 5717 if Failed then 5718 if Description_Buffer.Length /= 0 then 5719 Append (Description_Buffer, ", "); 5720 end if; 5721 Append (Description_Buffer, Aspect_Name); 5722 end if; 5723 end Note_If_Failure; 5724 5725 ------------------ 5726 -- Failure_Text -- 5727 ------------------ 5728 5729 function Failure_Text return String is 5730 begin 5731 return +Description_Buffer; 5732 end Failure_Text; 5733 end Failure_Description; 5734 5735 use Failure_Description; 5736 begin 5737 if AR_Check_Failed 5738 or AW_Check_Failed 5739 or ER_Check_Failed 5740 or EW_Check_Failed 5741 then 5742 Note_If_Failure (AR_Check_Failed, "Async_Readers"); 5743 Note_If_Failure (AW_Check_Failed, "Async_Writers"); 5744 Note_If_Failure (ER_Check_Failed, "Effective_Reads"); 5745 Note_If_Failure (EW_Check_Failed, "Effective_Writes"); 5746 5747 Error_Msg_N 5748 (Description_1 5749 & " and " 5750 & Description_2 5751 & " are not compatible with respect to volatility due to " 5752 & Failure_Text, 5753 Srcpos_Bearer); 5754 end if; 5755 end; 5756 end Check_Volatility_Compatibility; 5757 5758 ----------------- 5759 -- Choice_List -- 5760 ----------------- 5761 5762 function Choice_List (N : Node_Id) return List_Id is 5763 begin 5764 if Nkind (N) = N_Iterated_Component_Association then 5765 return Discrete_Choices (N); 5766 else 5767 return Choices (N); 5768 end if; 5769 end Choice_List; 5770 5771 ------------------------- 5772 -- Collect_Body_States -- 5773 ------------------------- 5774 5775 function Collect_Body_States (Body_Id : Entity_Id) return Elist_Id is 5776 function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean; 5777 -- Determine whether object Obj_Id is a suitable visible state of a 5778 -- package body. 5779 5780 procedure Collect_Visible_States 5781 (Pack_Id : Entity_Id; 5782 States : in out Elist_Id); 5783 -- Gather the entities of all abstract states and objects declared in 5784 -- the visible state space of package Pack_Id. 5785 5786 ---------------------------- 5787 -- Collect_Visible_States -- 5788 ---------------------------- 5789 5790 procedure Collect_Visible_States 5791 (Pack_Id : Entity_Id; 5792 States : in out Elist_Id) 5793 is 5794 Item_Id : Entity_Id; 5795 5796 begin 5797 -- Traverse the entity chain of the package and inspect all visible 5798 -- items. 5799 5800 Item_Id := First_Entity (Pack_Id); 5801 while Present (Item_Id) and then not In_Private_Part (Item_Id) loop 5802 5803 -- Do not consider internally generated items as those cannot be 5804 -- named and participate in refinement. 5805 5806 if not Comes_From_Source (Item_Id) then 5807 null; 5808 5809 elsif Ekind (Item_Id) = E_Abstract_State then 5810 Append_New_Elmt (Item_Id, States); 5811 5812 elsif Ekind (Item_Id) in E_Constant | E_Variable 5813 and then Is_Visible_Object (Item_Id) 5814 then 5815 Append_New_Elmt (Item_Id, States); 5816 5817 -- Recursively gather the visible states of a nested package 5818 5819 elsif Ekind (Item_Id) = E_Package then 5820 Collect_Visible_States (Item_Id, States); 5821 end if; 5822 5823 Next_Entity (Item_Id); 5824 end loop; 5825 end Collect_Visible_States; 5826 5827 ----------------------- 5828 -- Is_Visible_Object -- 5829 ----------------------- 5830 5831 function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean is 5832 begin 5833 -- Objects that map generic formals to their actuals are not visible 5834 -- from outside the generic instantiation. 5835 5836 if Present (Corresponding_Generic_Association 5837 (Declaration_Node (Obj_Id))) 5838 then 5839 return False; 5840 5841 -- Constituents of a single protected/task type act as components of 5842 -- the type and are not visible from outside the type. 5843 5844 elsif Ekind (Obj_Id) = E_Variable 5845 and then Present (Encapsulating_State (Obj_Id)) 5846 and then Is_Single_Concurrent_Object (Encapsulating_State (Obj_Id)) 5847 then 5848 return False; 5849 5850 else 5851 return True; 5852 end if; 5853 end Is_Visible_Object; 5854 5855 -- Local variables 5856 5857 Body_Decl : constant Node_Id := Unit_Declaration_Node (Body_Id); 5858 Decl : Node_Id; 5859 Item_Id : Entity_Id; 5860 States : Elist_Id := No_Elist; 5861 5862 -- Start of processing for Collect_Body_States 5863 5864 begin 5865 -- Inspect the declarations of the body looking for source objects, 5866 -- packages and package instantiations. Note that even though this 5867 -- processing is very similar to Collect_Visible_States, a package 5868 -- body does not have a First/Next_Entity list. 5869 5870 Decl := First (Declarations (Body_Decl)); 5871 while Present (Decl) loop 5872 5873 -- Capture source objects as internally generated temporaries cannot 5874 -- be named and participate in refinement. 5875 5876 if Nkind (Decl) = N_Object_Declaration then 5877 Item_Id := Defining_Entity (Decl); 5878 5879 if Comes_From_Source (Item_Id) 5880 and then Is_Visible_Object (Item_Id) 5881 then 5882 Append_New_Elmt (Item_Id, States); 5883 end if; 5884 5885 -- Capture the visible abstract states and objects of a source 5886 -- package [instantiation]. 5887 5888 elsif Nkind (Decl) = N_Package_Declaration then 5889 Item_Id := Defining_Entity (Decl); 5890 5891 if Comes_From_Source (Item_Id) then 5892 Collect_Visible_States (Item_Id, States); 5893 end if; 5894 end if; 5895 5896 Next (Decl); 5897 end loop; 5898 5899 return States; 5900 end Collect_Body_States; 5901 5902 ------------------------ 5903 -- Collect_Interfaces -- 5904 ------------------------ 5905 5906 procedure Collect_Interfaces 5907 (T : Entity_Id; 5908 Ifaces_List : out Elist_Id; 5909 Exclude_Parents : Boolean := False; 5910 Use_Full_View : Boolean := True) 5911 is 5912 procedure Collect (Typ : Entity_Id); 5913 -- Subsidiary subprogram used to traverse the whole list 5914 -- of directly and indirectly implemented interfaces 5915 5916 ------------- 5917 -- Collect -- 5918 ------------- 5919 5920 procedure Collect (Typ : Entity_Id) is 5921 Ancestor : Entity_Id; 5922 Full_T : Entity_Id; 5923 Id : Node_Id; 5924 Iface : Entity_Id; 5925 5926 begin 5927 Full_T := Typ; 5928 5929 -- Handle private types and subtypes 5930 5931 if Use_Full_View 5932 and then Is_Private_Type (Typ) 5933 and then Present (Full_View (Typ)) 5934 then 5935 Full_T := Full_View (Typ); 5936 5937 if Ekind (Full_T) = E_Record_Subtype then 5938 Full_T := Etype (Typ); 5939 5940 if Present (Full_View (Full_T)) then 5941 Full_T := Full_View (Full_T); 5942 end if; 5943 end if; 5944 end if; 5945 5946 -- Include the ancestor if we are generating the whole list of 5947 -- abstract interfaces. 5948 5949 if Etype (Full_T) /= Typ 5950 5951 -- Protect the frontend against wrong sources. For example: 5952 5953 -- package P is 5954 -- type A is tagged null record; 5955 -- type B is new A with private; 5956 -- type C is new A with private; 5957 -- private 5958 -- type B is new C with null record; 5959 -- type C is new B with null record; 5960 -- end P; 5961 5962 and then Etype (Full_T) /= T 5963 then 5964 Ancestor := Etype (Full_T); 5965 Collect (Ancestor); 5966 5967 if Is_Interface (Ancestor) and then not Exclude_Parents then 5968 Append_Unique_Elmt (Ancestor, Ifaces_List); 5969 end if; 5970 end if; 5971 5972 -- Traverse the graph of ancestor interfaces 5973 5974 if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then 5975 Id := First (Abstract_Interface_List (Full_T)); 5976 while Present (Id) loop 5977 Iface := Etype (Id); 5978 5979 -- Protect against wrong uses. For example: 5980 -- type I is interface; 5981 -- type O is tagged null record; 5982 -- type Wrong is new I and O with null record; -- ERROR 5983 5984 if Is_Interface (Iface) then 5985 if Exclude_Parents 5986 and then Etype (T) /= T 5987 and then Interface_Present_In_Ancestor (Etype (T), Iface) 5988 then 5989 null; 5990 else 5991 Collect (Iface); 5992 Append_Unique_Elmt (Iface, Ifaces_List); 5993 end if; 5994 end if; 5995 5996 Next (Id); 5997 end loop; 5998 end if; 5999 end Collect; 6000 6001 -- Start of processing for Collect_Interfaces 6002 6003 begin 6004 pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T)); 6005 Ifaces_List := New_Elmt_List; 6006 Collect (T); 6007 end Collect_Interfaces; 6008 6009 ---------------------------------- 6010 -- Collect_Interface_Components -- 6011 ---------------------------------- 6012 6013 procedure Collect_Interface_Components 6014 (Tagged_Type : Entity_Id; 6015 Components_List : out Elist_Id) 6016 is 6017 procedure Collect (Typ : Entity_Id); 6018 -- Subsidiary subprogram used to climb to the parents 6019 6020 ------------- 6021 -- Collect -- 6022 ------------- 6023 6024 procedure Collect (Typ : Entity_Id) is 6025 Tag_Comp : Entity_Id; 6026 Parent_Typ : Entity_Id; 6027 6028 begin 6029 -- Handle private types 6030 6031 if Present (Full_View (Etype (Typ))) then 6032 Parent_Typ := Full_View (Etype (Typ)); 6033 else 6034 Parent_Typ := Etype (Typ); 6035 end if; 6036 6037 if Parent_Typ /= Typ 6038 6039 -- Protect the frontend against wrong sources. For example: 6040 6041 -- package P is 6042 -- type A is tagged null record; 6043 -- type B is new A with private; 6044 -- type C is new A with private; 6045 -- private 6046 -- type B is new C with null record; 6047 -- type C is new B with null record; 6048 -- end P; 6049 6050 and then Parent_Typ /= Tagged_Type 6051 then 6052 Collect (Parent_Typ); 6053 end if; 6054 6055 -- Collect the components containing tags of secondary dispatch 6056 -- tables. 6057 6058 Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ)); 6059 while Present (Tag_Comp) loop 6060 pragma Assert (Present (Related_Type (Tag_Comp))); 6061 Append_Elmt (Tag_Comp, Components_List); 6062 6063 Tag_Comp := Next_Tag_Component (Tag_Comp); 6064 end loop; 6065 end Collect; 6066 6067 -- Start of processing for Collect_Interface_Components 6068 6069 begin 6070 pragma Assert (Ekind (Tagged_Type) = E_Record_Type 6071 and then Is_Tagged_Type (Tagged_Type)); 6072 6073 Components_List := New_Elmt_List; 6074 Collect (Tagged_Type); 6075 end Collect_Interface_Components; 6076 6077 ----------------------------- 6078 -- Collect_Interfaces_Info -- 6079 ----------------------------- 6080 6081 procedure Collect_Interfaces_Info 6082 (T : Entity_Id; 6083 Ifaces_List : out Elist_Id; 6084 Components_List : out Elist_Id; 6085 Tags_List : out Elist_Id) 6086 is 6087 Comps_List : Elist_Id; 6088 Comp_Elmt : Elmt_Id; 6089 Comp_Iface : Entity_Id; 6090 Iface_Elmt : Elmt_Id; 6091 Iface : Entity_Id; 6092 6093 function Search_Tag (Iface : Entity_Id) return Entity_Id; 6094 -- Search for the secondary tag associated with the interface type 6095 -- Iface that is implemented by T. 6096 6097 ---------------- 6098 -- Search_Tag -- 6099 ---------------- 6100 6101 function Search_Tag (Iface : Entity_Id) return Entity_Id is 6102 ADT : Elmt_Id; 6103 begin 6104 if not Is_CPP_Class (T) then 6105 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T)))); 6106 else 6107 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T))); 6108 end if; 6109 6110 while Present (ADT) 6111 and then Is_Tag (Node (ADT)) 6112 and then Related_Type (Node (ADT)) /= Iface 6113 loop 6114 -- Skip secondary dispatch table referencing thunks to user 6115 -- defined primitives covered by this interface. 6116 6117 pragma Assert (Has_Suffix (Node (ADT), 'P')); 6118 Next_Elmt (ADT); 6119 6120 -- Skip secondary dispatch tables of Ada types 6121 6122 if not Is_CPP_Class (T) then 6123 6124 -- Skip secondary dispatch table referencing thunks to 6125 -- predefined primitives. 6126 6127 pragma Assert (Has_Suffix (Node (ADT), 'Y')); 6128 Next_Elmt (ADT); 6129 6130 -- Skip secondary dispatch table referencing user-defined 6131 -- primitives covered by this interface. 6132 6133 pragma Assert (Has_Suffix (Node (ADT), 'D')); 6134 Next_Elmt (ADT); 6135 6136 -- Skip secondary dispatch table referencing predefined 6137 -- primitives. 6138 6139 pragma Assert (Has_Suffix (Node (ADT), 'Z')); 6140 Next_Elmt (ADT); 6141 end if; 6142 end loop; 6143 6144 pragma Assert (Is_Tag (Node (ADT))); 6145 return Node (ADT); 6146 end Search_Tag; 6147 6148 -- Start of processing for Collect_Interfaces_Info 6149 6150 begin 6151 Collect_Interfaces (T, Ifaces_List); 6152 Collect_Interface_Components (T, Comps_List); 6153 6154 -- Search for the record component and tag associated with each 6155 -- interface type of T. 6156 6157 Components_List := New_Elmt_List; 6158 Tags_List := New_Elmt_List; 6159 6160 Iface_Elmt := First_Elmt (Ifaces_List); 6161 while Present (Iface_Elmt) loop 6162 Iface := Node (Iface_Elmt); 6163 6164 -- Associate the primary tag component and the primary dispatch table 6165 -- with all the interfaces that are parents of T 6166 6167 if Is_Ancestor (Iface, T, Use_Full_View => True) then 6168 Append_Elmt (First_Tag_Component (T), Components_List); 6169 Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List); 6170 6171 -- Otherwise search for the tag component and secondary dispatch 6172 -- table of Iface 6173 6174 else 6175 Comp_Elmt := First_Elmt (Comps_List); 6176 while Present (Comp_Elmt) loop 6177 Comp_Iface := Related_Type (Node (Comp_Elmt)); 6178 6179 if Comp_Iface = Iface 6180 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True) 6181 then 6182 Append_Elmt (Node (Comp_Elmt), Components_List); 6183 Append_Elmt (Search_Tag (Comp_Iface), Tags_List); 6184 exit; 6185 end if; 6186 6187 Next_Elmt (Comp_Elmt); 6188 end loop; 6189 pragma Assert (Present (Comp_Elmt)); 6190 end if; 6191 6192 Next_Elmt (Iface_Elmt); 6193 end loop; 6194 end Collect_Interfaces_Info; 6195 6196 --------------------- 6197 -- Collect_Parents -- 6198 --------------------- 6199 6200 procedure Collect_Parents 6201 (T : Entity_Id; 6202 List : out Elist_Id; 6203 Use_Full_View : Boolean := True) 6204 is 6205 Current_Typ : Entity_Id := T; 6206 Parent_Typ : Entity_Id; 6207 6208 begin 6209 List := New_Elmt_List; 6210 6211 -- No action if the if the type has no parents 6212 6213 if T = Etype (T) then 6214 return; 6215 end if; 6216 6217 loop 6218 Parent_Typ := Etype (Current_Typ); 6219 6220 if Is_Private_Type (Parent_Typ) 6221 and then Present (Full_View (Parent_Typ)) 6222 and then Use_Full_View 6223 then 6224 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 6225 end if; 6226 6227 Append_Elmt (Parent_Typ, List); 6228 6229 exit when Parent_Typ = Current_Typ; 6230 Current_Typ := Parent_Typ; 6231 end loop; 6232 end Collect_Parents; 6233 6234 ---------------------------------- 6235 -- Collect_Primitive_Operations -- 6236 ---------------------------------- 6237 6238 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is 6239 B_Type : constant Entity_Id := Base_Type (T); 6240 6241 function Match (E : Entity_Id) return Boolean; 6242 -- True if E's base type is B_Type, or E is of an anonymous access type 6243 -- and the base type of its designated type is B_Type. 6244 6245 ----------- 6246 -- Match -- 6247 ----------- 6248 6249 function Match (E : Entity_Id) return Boolean is 6250 Etyp : Entity_Id := Etype (E); 6251 6252 begin 6253 if Ekind (Etyp) = E_Anonymous_Access_Type then 6254 Etyp := Designated_Type (Etyp); 6255 end if; 6256 6257 -- In Ada 2012 a primitive operation may have a formal of an 6258 -- incomplete view of the parent type. 6259 6260 return Base_Type (Etyp) = B_Type 6261 or else 6262 (Ada_Version >= Ada_2012 6263 and then Ekind (Etyp) = E_Incomplete_Type 6264 and then Full_View (Etyp) = B_Type); 6265 end Match; 6266 6267 -- Local variables 6268 6269 B_Decl : constant Node_Id := Original_Node (Parent (B_Type)); 6270 B_Scope : Entity_Id := Scope (B_Type); 6271 Op_List : Elist_Id; 6272 Eq_Prims_List : Elist_Id := No_Elist; 6273 Formal : Entity_Id; 6274 Is_Prim : Boolean; 6275 Is_Type_In_Pkg : Boolean; 6276 Formal_Derived : Boolean := False; 6277 Id : Entity_Id; 6278 6279 -- Start of processing for Collect_Primitive_Operations 6280 6281 begin 6282 -- For tagged types, the primitive operations are collected as they 6283 -- are declared, and held in an explicit list which is simply returned. 6284 6285 if Is_Tagged_Type (B_Type) then 6286 return Primitive_Operations (B_Type); 6287 6288 -- An untagged generic type that is a derived type inherits the 6289 -- primitive operations of its parent type. Other formal types only 6290 -- have predefined operators, which are not explicitly represented. 6291 6292 elsif Is_Generic_Type (B_Type) then 6293 if Nkind (B_Decl) = N_Formal_Type_Declaration 6294 and then Nkind (Formal_Type_Definition (B_Decl)) = 6295 N_Formal_Derived_Type_Definition 6296 then 6297 Formal_Derived := True; 6298 else 6299 return New_Elmt_List; 6300 end if; 6301 end if; 6302 6303 Op_List := New_Elmt_List; 6304 6305 if B_Scope = Standard_Standard then 6306 if B_Type = Standard_String then 6307 Append_Elmt (Standard_Op_Concat, Op_List); 6308 6309 elsif B_Type = Standard_Wide_String then 6310 Append_Elmt (Standard_Op_Concatw, Op_List); 6311 6312 else 6313 null; 6314 end if; 6315 6316 -- Locate the primitive subprograms of the type 6317 6318 else 6319 -- The primitive operations appear after the base type, except if the 6320 -- derivation happens within the private part of B_Scope and the type 6321 -- is a private type, in which case both the type and some primitive 6322 -- operations may appear before the base type, and the list of 6323 -- candidates starts after the type. 6324 6325 if In_Open_Scopes (B_Scope) 6326 and then Scope (T) = B_Scope 6327 and then In_Private_Part (B_Scope) 6328 then 6329 Id := Next_Entity (T); 6330 6331 -- In Ada 2012, If the type has an incomplete partial view, there may 6332 -- be primitive operations declared before the full view, so we need 6333 -- to start scanning from the incomplete view, which is earlier on 6334 -- the entity chain. 6335 6336 elsif Nkind (Parent (B_Type)) = N_Full_Type_Declaration 6337 and then Present (Incomplete_View (Parent (B_Type))) 6338 then 6339 Id := Defining_Entity (Incomplete_View (Parent (B_Type))); 6340 6341 -- If T is a derived from a type with an incomplete view declared 6342 -- elsewhere, that incomplete view is irrelevant, we want the 6343 -- operations in the scope of T. 6344 6345 if Scope (Id) /= Scope (B_Type) then 6346 Id := Next_Entity (B_Type); 6347 end if; 6348 6349 else 6350 Id := Next_Entity (B_Type); 6351 end if; 6352 6353 -- Set flag if this is a type in a package spec 6354 6355 Is_Type_In_Pkg := 6356 Is_Package_Or_Generic_Package (B_Scope) 6357 and then 6358 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /= 6359 N_Package_Body; 6360 6361 while Present (Id) loop 6362 6363 -- Test whether the result type or any of the parameter types of 6364 -- each subprogram following the type match that type when the 6365 -- type is declared in a package spec, is a derived type, or the 6366 -- subprogram is marked as primitive. (The Is_Primitive test is 6367 -- needed to find primitives of nonderived types in declarative 6368 -- parts that happen to override the predefined "=" operator.) 6369 6370 -- Note that generic formal subprograms are not considered to be 6371 -- primitive operations and thus are never inherited. 6372 6373 if Is_Overloadable (Id) 6374 and then (Is_Type_In_Pkg 6375 or else Is_Derived_Type (B_Type) 6376 or else Is_Primitive (Id)) 6377 and then Nkind (Parent (Parent (Id))) 6378 not in N_Formal_Subprogram_Declaration 6379 then 6380 Is_Prim := False; 6381 6382 if Match (Id) then 6383 Is_Prim := True; 6384 6385 else 6386 Formal := First_Formal (Id); 6387 while Present (Formal) loop 6388 if Match (Formal) then 6389 Is_Prim := True; 6390 exit; 6391 end if; 6392 6393 Next_Formal (Formal); 6394 end loop; 6395 end if; 6396 6397 -- For a formal derived type, the only primitives are the ones 6398 -- inherited from the parent type. Operations appearing in the 6399 -- package declaration are not primitive for it. 6400 6401 if Is_Prim 6402 and then (not Formal_Derived or else Present (Alias (Id))) 6403 then 6404 -- In the special case of an equality operator aliased to 6405 -- an overriding dispatching equality belonging to the same 6406 -- type, we don't include it in the list of primitives. 6407 -- This avoids inheriting multiple equality operators when 6408 -- deriving from untagged private types whose full type is 6409 -- tagged, which can otherwise cause ambiguities. Note that 6410 -- this should only happen for this kind of untagged parent 6411 -- type, since normally dispatching operations are inherited 6412 -- using the type's Primitive_Operations list. 6413 6414 if Chars (Id) = Name_Op_Eq 6415 and then Is_Dispatching_Operation (Id) 6416 and then Present (Alias (Id)) 6417 and then Present (Overridden_Operation (Alias (Id))) 6418 and then Base_Type (Etype (First_Entity (Id))) = 6419 Base_Type (Etype (First_Entity (Alias (Id)))) 6420 then 6421 null; 6422 6423 -- Include the subprogram in the list of primitives 6424 6425 else 6426 Append_Elmt (Id, Op_List); 6427 6428 -- Save collected equality primitives for later filtering 6429 -- (if we are processing a private type for which we can 6430 -- collect several candidates). 6431 6432 if Inherits_From_Tagged_Full_View (T) 6433 and then Chars (Id) = Name_Op_Eq 6434 and then Etype (First_Formal (Id)) = 6435 Etype (Next_Formal (First_Formal (Id))) 6436 then 6437 Append_New_Elmt (Id, Eq_Prims_List); 6438 end if; 6439 end if; 6440 end if; 6441 end if; 6442 6443 Next_Entity (Id); 6444 6445 -- For a type declared in System, some of its operations may 6446 -- appear in the target-specific extension to System. 6447 6448 if No (Id) 6449 and then B_Scope = RTU_Entity (System) 6450 and then Present_System_Aux 6451 then 6452 B_Scope := System_Aux_Id; 6453 Id := First_Entity (System_Aux_Id); 6454 end if; 6455 end loop; 6456 6457 -- Filter collected equality primitives 6458 6459 if Inherits_From_Tagged_Full_View (T) 6460 and then Present (Eq_Prims_List) 6461 then 6462 declare 6463 First : constant Elmt_Id := First_Elmt (Eq_Prims_List); 6464 Second : Elmt_Id; 6465 6466 begin 6467 pragma Assert (No (Next_Elmt (First)) 6468 or else No (Next_Elmt (Next_Elmt (First)))); 6469 6470 -- No action needed if we have collected a single equality 6471 -- primitive 6472 6473 if Present (Next_Elmt (First)) then 6474 Second := Next_Elmt (First); 6475 6476 if Is_Dispatching_Operation 6477 (Ultimate_Alias (Node (First))) 6478 then 6479 Remove (Op_List, Node (First)); 6480 6481 elsif Is_Dispatching_Operation 6482 (Ultimate_Alias (Node (Second))) 6483 then 6484 Remove (Op_List, Node (Second)); 6485 6486 else 6487 pragma Assert (False); 6488 raise Program_Error; 6489 end if; 6490 end if; 6491 end; 6492 end if; 6493 end if; 6494 6495 return Op_List; 6496 end Collect_Primitive_Operations; 6497 6498 ----------------------------------- 6499 -- Compile_Time_Constraint_Error -- 6500 ----------------------------------- 6501 6502 function Compile_Time_Constraint_Error 6503 (N : Node_Id; 6504 Msg : String; 6505 Ent : Entity_Id := Empty; 6506 Loc : Source_Ptr := No_Location; 6507 Warn : Boolean := False; 6508 Extra_Msg : String := "") return Node_Id 6509 is 6510 Msgc : String (1 .. Msg'Length + 3); 6511 -- Copy of message, with room for possible ?? or << and ! at end 6512 6513 Msgl : Natural; 6514 Wmsg : Boolean; 6515 Eloc : Source_Ptr; 6516 6517 -- Start of processing for Compile_Time_Constraint_Error 6518 6519 begin 6520 -- If this is a warning, convert it into an error if we are in code 6521 -- subject to SPARK_Mode being set On, unless Warn is True to force a 6522 -- warning. The rationale is that a compile-time constraint error should 6523 -- lead to an error instead of a warning when SPARK_Mode is On, but in 6524 -- a few cases we prefer to issue a warning and generate both a suitable 6525 -- run-time error in GNAT and a suitable check message in GNATprove. 6526 -- Those cases are those that likely correspond to deactivated SPARK 6527 -- code, so that this kind of code can be compiled and analyzed instead 6528 -- of being rejected. 6529 6530 Error_Msg_Warn := Warn or SPARK_Mode /= On; 6531 6532 -- A static constraint error in an instance body is not a fatal error. 6533 -- we choose to inhibit the message altogether, because there is no 6534 -- obvious node (for now) on which to post it. On the other hand the 6535 -- offending node must be replaced with a constraint_error in any case. 6536 6537 -- No messages are generated if we already posted an error on this node 6538 6539 if not Error_Posted (N) then 6540 if Loc /= No_Location then 6541 Eloc := Loc; 6542 else 6543 Eloc := Sloc (N); 6544 end if; 6545 6546 -- Copy message to Msgc, converting any ? in the message into < 6547 -- instead, so that we have an error in GNATprove mode. 6548 6549 Msgl := Msg'Length; 6550 6551 for J in 1 .. Msgl loop 6552 if Msg (J) = '?' and then (J = 1 or else Msg (J - 1) /= ''') then 6553 Msgc (J) := '<'; 6554 else 6555 Msgc (J) := Msg (J); 6556 end if; 6557 end loop; 6558 6559 -- Message is a warning, even in Ada 95 case 6560 6561 if Msg (Msg'Last) = '?' or else Msg (Msg'Last) = '<' then 6562 Wmsg := True; 6563 6564 -- In Ada 83, all messages are warnings. In the private part and the 6565 -- body of an instance, constraint_checks are only warnings. We also 6566 -- make this a warning if the Warn parameter is set. 6567 6568 elsif Warn 6569 or else (Ada_Version = Ada_83 and then Comes_From_Source (N)) 6570 or else In_Instance_Not_Visible 6571 then 6572 Msgl := Msgl + 1; 6573 Msgc (Msgl) := '<'; 6574 Msgl := Msgl + 1; 6575 Msgc (Msgl) := '<'; 6576 Wmsg := True; 6577 6578 -- Otherwise we have a real error message (Ada 95 static case) and we 6579 -- make this an unconditional message. Note that in the warning case 6580 -- we do not make the message unconditional, it seems reasonable to 6581 -- delete messages like this (about exceptions that will be raised) 6582 -- in dead code. 6583 6584 else 6585 Wmsg := False; 6586 Msgl := Msgl + 1; 6587 Msgc (Msgl) := '!'; 6588 end if; 6589 6590 -- One more test, skip the warning if the related expression is 6591 -- statically unevaluated, since we don't want to warn about what 6592 -- will happen when something is evaluated if it never will be 6593 -- evaluated. 6594 6595 -- Suppress error reporting when checking that the expression of a 6596 -- static expression function is a potentially static expression, 6597 -- because we don't want additional errors being reported during the 6598 -- preanalysis of the expression (see Analyze_Expression_Function). 6599 6600 if not Is_Statically_Unevaluated (N) 6601 and then not Checking_Potentially_Static_Expression 6602 then 6603 if Present (Ent) then 6604 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc); 6605 else 6606 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc); 6607 end if; 6608 6609 -- Emit any extra message as a continuation 6610 6611 if Extra_Msg /= "" then 6612 Error_Msg_N ('\' & Extra_Msg, N); 6613 end if; 6614 6615 if Wmsg then 6616 6617 -- Check whether the context is an Init_Proc 6618 6619 if Inside_Init_Proc then 6620 declare 6621 Conc_Typ : constant Entity_Id := 6622 Corresponding_Concurrent_Type 6623 (Entity (Parameter_Type (First 6624 (Parameter_Specifications 6625 (Parent (Current_Scope)))))); 6626 6627 begin 6628 -- Don't complain if the corresponding concurrent type 6629 -- doesn't come from source (i.e. a single task/protected 6630 -- object). 6631 6632 if Present (Conc_Typ) 6633 and then not Comes_From_Source (Conc_Typ) 6634 then 6635 Error_Msg_NEL 6636 ("\& [<<", N, Standard_Constraint_Error, Eloc); 6637 6638 else 6639 if GNATprove_Mode then 6640 Error_Msg_NEL 6641 ("\& would have been raised for objects of this " 6642 & "type", N, Standard_Constraint_Error, Eloc); 6643 else 6644 Error_Msg_NEL 6645 ("\& will be raised for objects of this type??", 6646 N, Standard_Constraint_Error, Eloc); 6647 end if; 6648 end if; 6649 end; 6650 6651 else 6652 Error_Msg_NEL ("\& [<<", N, Standard_Constraint_Error, Eloc); 6653 end if; 6654 6655 else 6656 Error_Msg ("\static expression fails Constraint_Check", Eloc); 6657 Set_Error_Posted (N); 6658 end if; 6659 end if; 6660 end if; 6661 6662 return N; 6663 end Compile_Time_Constraint_Error; 6664 6665 ----------------------- 6666 -- Conditional_Delay -- 6667 ----------------------- 6668 6669 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is 6670 begin 6671 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then 6672 Set_Has_Delayed_Freeze (New_Ent); 6673 end if; 6674 end Conditional_Delay; 6675 6676 ------------------------- 6677 -- Copy_Component_List -- 6678 ------------------------- 6679 6680 function Copy_Component_List 6681 (R_Typ : Entity_Id; 6682 Loc : Source_Ptr) return List_Id 6683 is 6684 Comp : Node_Id; 6685 Comps : constant List_Id := New_List; 6686 6687 begin 6688 Comp := First_Component (Underlying_Type (R_Typ)); 6689 while Present (Comp) loop 6690 if Comes_From_Source (Comp) then 6691 declare 6692 Comp_Decl : constant Node_Id := Declaration_Node (Comp); 6693 begin 6694 Append_To (Comps, 6695 Make_Component_Declaration (Loc, 6696 Defining_Identifier => 6697 Make_Defining_Identifier (Loc, Chars (Comp)), 6698 Component_Definition => 6699 New_Copy_Tree 6700 (Component_Definition (Comp_Decl), New_Sloc => Loc))); 6701 end; 6702 end if; 6703 6704 Next_Component (Comp); 6705 end loop; 6706 6707 return Comps; 6708 end Copy_Component_List; 6709 6710 ------------------------- 6711 -- Copy_Parameter_List -- 6712 ------------------------- 6713 6714 function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is 6715 Loc : constant Source_Ptr := Sloc (Subp_Id); 6716 Plist : List_Id; 6717 Formal : Entity_Id; 6718 6719 begin 6720 if No (First_Formal (Subp_Id)) then 6721 return No_List; 6722 else 6723 Plist := New_List; 6724 Formal := First_Formal (Subp_Id); 6725 while Present (Formal) loop 6726 Append_To (Plist, 6727 Make_Parameter_Specification (Loc, 6728 Defining_Identifier => 6729 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), 6730 In_Present => In_Present (Parent (Formal)), 6731 Out_Present => Out_Present (Parent (Formal)), 6732 Parameter_Type => 6733 New_Occurrence_Of (Etype (Formal), Loc), 6734 Expression => 6735 New_Copy_Tree (Expression (Parent (Formal))))); 6736 6737 Next_Formal (Formal); 6738 end loop; 6739 end if; 6740 6741 return Plist; 6742 end Copy_Parameter_List; 6743 6744 ---------------------------- 6745 -- Copy_SPARK_Mode_Aspect -- 6746 ---------------------------- 6747 6748 procedure Copy_SPARK_Mode_Aspect (From : Node_Id; To : Node_Id) is 6749 pragma Assert (not Has_Aspects (To)); 6750 Asp : Node_Id; 6751 6752 begin 6753 if Has_Aspects (From) then 6754 Asp := Find_Aspect (Defining_Entity (From), Aspect_SPARK_Mode); 6755 6756 if Present (Asp) then 6757 Set_Aspect_Specifications (To, New_List (New_Copy_Tree (Asp))); 6758 Set_Has_Aspects (To, True); 6759 end if; 6760 end if; 6761 end Copy_SPARK_Mode_Aspect; 6762 6763 -------------------------- 6764 -- Copy_Subprogram_Spec -- 6765 -------------------------- 6766 6767 function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id is 6768 Def_Id : Node_Id; 6769 Formal_Spec : Node_Id; 6770 Result : Node_Id; 6771 6772 begin 6773 -- The structure of the original tree must be replicated without any 6774 -- alterations. Use New_Copy_Tree for this purpose. 6775 6776 Result := New_Copy_Tree (Spec); 6777 6778 -- However, the spec of a null procedure carries the corresponding null 6779 -- statement of the body (created by the parser), and this cannot be 6780 -- shared with the new subprogram spec. 6781 6782 if Nkind (Result) = N_Procedure_Specification then 6783 Set_Null_Statement (Result, Empty); 6784 end if; 6785 6786 -- Create a new entity for the defining unit name 6787 6788 Def_Id := Defining_Unit_Name (Result); 6789 Set_Defining_Unit_Name (Result, 6790 Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id))); 6791 6792 -- Create new entities for the formal parameters 6793 6794 if Present (Parameter_Specifications (Result)) then 6795 Formal_Spec := First (Parameter_Specifications (Result)); 6796 while Present (Formal_Spec) loop 6797 Def_Id := Defining_Identifier (Formal_Spec); 6798 Set_Defining_Identifier (Formal_Spec, 6799 Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id))); 6800 6801 Next (Formal_Spec); 6802 end loop; 6803 end if; 6804 6805 return Result; 6806 end Copy_Subprogram_Spec; 6807 6808 -------------------------------- 6809 -- Corresponding_Generic_Type -- 6810 -------------------------------- 6811 6812 function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is 6813 Inst : Entity_Id; 6814 Gen : Entity_Id; 6815 Typ : Entity_Id; 6816 6817 begin 6818 if not Is_Generic_Actual_Type (T) then 6819 return Any_Type; 6820 6821 -- If the actual is the actual of an enclosing instance, resolution 6822 -- was correct in the generic. 6823 6824 elsif Nkind (Parent (T)) = N_Subtype_Declaration 6825 and then Is_Entity_Name (Subtype_Indication (Parent (T))) 6826 and then 6827 Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T)))) 6828 then 6829 return Any_Type; 6830 6831 else 6832 Inst := Scope (T); 6833 6834 if Is_Wrapper_Package (Inst) then 6835 Inst := Related_Instance (Inst); 6836 end if; 6837 6838 Gen := 6839 Generic_Parent 6840 (Specification (Unit_Declaration_Node (Inst))); 6841 6842 -- Generic actual has the same name as the corresponding formal 6843 6844 Typ := First_Entity (Gen); 6845 while Present (Typ) loop 6846 if Chars (Typ) = Chars (T) then 6847 return Typ; 6848 end if; 6849 6850 Next_Entity (Typ); 6851 end loop; 6852 6853 return Any_Type; 6854 end if; 6855 end Corresponding_Generic_Type; 6856 6857 -------------------- 6858 -- Current_Entity -- 6859 -------------------- 6860 6861 -- The currently visible definition for a given identifier is the 6862 -- one most chained at the start of the visibility chain, i.e. the 6863 -- one that is referenced by the Node_Id value of the name of the 6864 -- given identifier. 6865 6866 function Current_Entity (N : Node_Id) return Entity_Id is 6867 begin 6868 return Get_Name_Entity_Id (Chars (N)); 6869 end Current_Entity; 6870 6871 ----------------------------- 6872 -- Current_Entity_In_Scope -- 6873 ----------------------------- 6874 6875 function Current_Entity_In_Scope (N : Name_Id) return Entity_Id is 6876 E : Entity_Id; 6877 CS : constant Entity_Id := Current_Scope; 6878 6879 Transient_Case : constant Boolean := Scope_Is_Transient; 6880 6881 begin 6882 E := Get_Name_Entity_Id (N); 6883 while Present (E) 6884 and then Scope (E) /= CS 6885 and then (not Transient_Case or else Scope (E) /= Scope (CS)) 6886 loop 6887 E := Homonym (E); 6888 end loop; 6889 6890 return E; 6891 end Current_Entity_In_Scope; 6892 6893 ----------------------------- 6894 -- Current_Entity_In_Scope -- 6895 ----------------------------- 6896 6897 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is 6898 begin 6899 return Current_Entity_In_Scope (Chars (N)); 6900 end Current_Entity_In_Scope; 6901 6902 ------------------- 6903 -- Current_Scope -- 6904 ------------------- 6905 6906 function Current_Scope return Entity_Id is 6907 begin 6908 if Scope_Stack.Last = -1 then 6909 return Standard_Standard; 6910 else 6911 declare 6912 C : constant Entity_Id := 6913 Scope_Stack.Table (Scope_Stack.Last).Entity; 6914 begin 6915 if Present (C) then 6916 return C; 6917 else 6918 return Standard_Standard; 6919 end if; 6920 end; 6921 end if; 6922 end Current_Scope; 6923 6924 ---------------------------- 6925 -- Current_Scope_No_Loops -- 6926 ---------------------------- 6927 6928 function Current_Scope_No_Loops return Entity_Id is 6929 S : Entity_Id; 6930 6931 begin 6932 -- Examine the scope stack starting from the current scope and skip any 6933 -- internally generated loops. 6934 6935 S := Current_Scope; 6936 while Present (S) and then S /= Standard_Standard loop 6937 if Ekind (S) = E_Loop and then not Comes_From_Source (S) then 6938 S := Scope (S); 6939 else 6940 exit; 6941 end if; 6942 end loop; 6943 6944 return S; 6945 end Current_Scope_No_Loops; 6946 6947 ------------------------ 6948 -- Current_Subprogram -- 6949 ------------------------ 6950 6951 function Current_Subprogram return Entity_Id is 6952 Scop : constant Entity_Id := Current_Scope; 6953 begin 6954 if Is_Subprogram_Or_Generic_Subprogram (Scop) then 6955 return Scop; 6956 else 6957 return Enclosing_Subprogram (Scop); 6958 end if; 6959 end Current_Subprogram; 6960 6961 ------------------------------- 6962 -- Deepest_Type_Access_Level -- 6963 ------------------------------- 6964 6965 function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is 6966 begin 6967 if Ekind (Typ) = E_Anonymous_Access_Type 6968 and then not Is_Local_Anonymous_Access (Typ) 6969 and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration 6970 then 6971 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous 6972 -- access type. 6973 6974 return 6975 Scope_Depth (Enclosing_Dynamic_Scope 6976 (Defining_Identifier 6977 (Associated_Node_For_Itype (Typ)))); 6978 6979 -- For generic formal type, return Int'Last (infinite). 6980 -- See comment preceding Is_Generic_Type call in Type_Access_Level. 6981 6982 elsif Is_Generic_Type (Root_Type (Typ)) then 6983 return UI_From_Int (Int'Last); 6984 6985 else 6986 return Type_Access_Level (Typ); 6987 end if; 6988 end Deepest_Type_Access_Level; 6989 6990 --------------------- 6991 -- Defining_Entity -- 6992 --------------------- 6993 6994 function Defining_Entity 6995 (N : Node_Id; 6996 Empty_On_Errors : Boolean := False) return Entity_Id 6997 is 6998 begin 6999 case Nkind (N) is 7000 when N_Abstract_Subprogram_Declaration 7001 | N_Expression_Function 7002 | N_Formal_Subprogram_Declaration 7003 | N_Generic_Package_Declaration 7004 | N_Generic_Subprogram_Declaration 7005 | N_Package_Declaration 7006 | N_Subprogram_Body 7007 | N_Subprogram_Body_Stub 7008 | N_Subprogram_Declaration 7009 | N_Subprogram_Renaming_Declaration 7010 => 7011 return Defining_Entity (Specification (N)); 7012 7013 when N_Component_Declaration 7014 | N_Defining_Program_Unit_Name 7015 | N_Discriminant_Specification 7016 | N_Entry_Body 7017 | N_Entry_Declaration 7018 | N_Entry_Index_Specification 7019 | N_Exception_Declaration 7020 | N_Exception_Renaming_Declaration 7021 | N_Formal_Object_Declaration 7022 | N_Formal_Package_Declaration 7023 | N_Formal_Type_Declaration 7024 | N_Full_Type_Declaration 7025 | N_Implicit_Label_Declaration 7026 | N_Incomplete_Type_Declaration 7027 | N_Iterator_Specification 7028 | N_Loop_Parameter_Specification 7029 | N_Number_Declaration 7030 | N_Object_Declaration 7031 | N_Object_Renaming_Declaration 7032 | N_Package_Body_Stub 7033 | N_Parameter_Specification 7034 | N_Private_Extension_Declaration 7035 | N_Private_Type_Declaration 7036 | N_Protected_Body 7037 | N_Protected_Body_Stub 7038 | N_Protected_Type_Declaration 7039 | N_Single_Protected_Declaration 7040 | N_Single_Task_Declaration 7041 | N_Subtype_Declaration 7042 | N_Task_Body 7043 | N_Task_Body_Stub 7044 | N_Task_Type_Declaration 7045 => 7046 return Defining_Identifier (N); 7047 7048 when N_Compilation_Unit => 7049 return Defining_Entity (Unit (N)); 7050 7051 when N_Subunit => 7052 return Defining_Entity (Proper_Body (N)); 7053 7054 when N_Function_Instantiation 7055 | N_Function_Specification 7056 | N_Generic_Function_Renaming_Declaration 7057 | N_Generic_Package_Renaming_Declaration 7058 | N_Generic_Procedure_Renaming_Declaration 7059 | N_Package_Body 7060 | N_Package_Instantiation 7061 | N_Package_Renaming_Declaration 7062 | N_Package_Specification 7063 | N_Procedure_Instantiation 7064 | N_Procedure_Specification 7065 => 7066 declare 7067 Nam : constant Node_Id := Defining_Unit_Name (N); 7068 Err : Entity_Id := Empty; 7069 7070 begin 7071 if Nkind (Nam) in N_Entity then 7072 return Nam; 7073 7074 -- For Error, make up a name and attach to declaration so we 7075 -- can continue semantic analysis. 7076 7077 elsif Nam = Error then 7078 Err := Make_Temporary (Sloc (N), 'T'); 7079 Set_Defining_Unit_Name (N, Err); 7080 7081 return Err; 7082 7083 -- If not an entity, get defining identifier 7084 7085 else 7086 return Defining_Identifier (Nam); 7087 end if; 7088 end; 7089 7090 when N_Block_Statement 7091 | N_Loop_Statement 7092 => 7093 return Entity (Identifier (N)); 7094 7095 when others => 7096 if Empty_On_Errors then 7097 return Empty; 7098 end if; 7099 7100 raise Program_Error; 7101 end case; 7102 end Defining_Entity; 7103 7104 -------------------------- 7105 -- Denotes_Discriminant -- 7106 -------------------------- 7107 7108 function Denotes_Discriminant 7109 (N : Node_Id; 7110 Check_Concurrent : Boolean := False) return Boolean 7111 is 7112 E : Entity_Id; 7113 7114 begin 7115 if not Is_Entity_Name (N) or else No (Entity (N)) then 7116 return False; 7117 else 7118 E := Entity (N); 7119 end if; 7120 7121 -- If we are checking for a protected type, the discriminant may have 7122 -- been rewritten as the corresponding discriminal of the original type 7123 -- or of the corresponding concurrent record, depending on whether we 7124 -- are in the spec or body of the protected type. 7125 7126 return Ekind (E) = E_Discriminant 7127 or else 7128 (Check_Concurrent 7129 and then Ekind (E) = E_In_Parameter 7130 and then Present (Discriminal_Link (E)) 7131 and then 7132 (Is_Concurrent_Type (Scope (Discriminal_Link (E))) 7133 or else 7134 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E))))); 7135 end Denotes_Discriminant; 7136 7137 ------------------------- 7138 -- Denotes_Same_Object -- 7139 ------------------------- 7140 7141 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is 7142 function Is_Renaming (N : Node_Id) return Boolean; 7143 -- Return true if N names a renaming entity 7144 7145 function Is_Valid_Renaming (N : Node_Id) return Boolean; 7146 -- For renamings, return False if the prefix of any dereference within 7147 -- the renamed object_name is a variable, or any expression within the 7148 -- renamed object_name contains references to variables or calls on 7149 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3)) 7150 7151 ----------------- 7152 -- Is_Renaming -- 7153 ----------------- 7154 7155 function Is_Renaming (N : Node_Id) return Boolean is 7156 begin 7157 if not Is_Entity_Name (N) then 7158 return False; 7159 end if; 7160 7161 case Ekind (Entity (N)) is 7162 when E_Variable | E_Constant => 7163 return Present (Renamed_Object (Entity (N))); 7164 7165 when E_Exception 7166 | E_Function 7167 | E_Generic_Function 7168 | E_Generic_Package 7169 | E_Generic_Procedure 7170 | E_Operator 7171 | E_Package 7172 | E_Procedure 7173 => 7174 return Present (Renamed_Entity (Entity (N))); 7175 7176 when others => 7177 return False; 7178 end case; 7179 end Is_Renaming; 7180 7181 ----------------------- 7182 -- Is_Valid_Renaming -- 7183 ----------------------- 7184 7185 function Is_Valid_Renaming (N : Node_Id) return Boolean is 7186 function Check_Renaming (N : Node_Id) return Boolean; 7187 -- Recursive function used to traverse all the prefixes of N 7188 7189 -------------------- 7190 -- Check_Renaming -- 7191 -------------------- 7192 7193 function Check_Renaming (N : Node_Id) return Boolean is 7194 begin 7195 if Is_Renaming (N) 7196 and then not Check_Renaming (Renamed_Entity (Entity (N))) 7197 then 7198 return False; 7199 end if; 7200 7201 if Nkind (N) = N_Indexed_Component then 7202 declare 7203 Indx : Node_Id; 7204 7205 begin 7206 Indx := First (Expressions (N)); 7207 while Present (Indx) loop 7208 if not Is_OK_Static_Expression (Indx) then 7209 return False; 7210 end if; 7211 7212 Next_Index (Indx); 7213 end loop; 7214 end; 7215 end if; 7216 7217 if Has_Prefix (N) then 7218 declare 7219 P : constant Node_Id := Prefix (N); 7220 7221 begin 7222 if Nkind (N) = N_Explicit_Dereference 7223 and then Is_Variable (P) 7224 then 7225 return False; 7226 7227 elsif Is_Entity_Name (P) 7228 and then Ekind (Entity (P)) = E_Function 7229 then 7230 return False; 7231 7232 elsif Nkind (P) = N_Function_Call then 7233 return False; 7234 end if; 7235 7236 -- Recursion to continue traversing the prefix of the 7237 -- renaming expression 7238 7239 return Check_Renaming (P); 7240 end; 7241 end if; 7242 7243 return True; 7244 end Check_Renaming; 7245 7246 -- Start of processing for Is_Valid_Renaming 7247 7248 begin 7249 return Check_Renaming (N); 7250 end Is_Valid_Renaming; 7251 7252 -- Local variables 7253 7254 Obj1 : Node_Id := A1; 7255 Obj2 : Node_Id := A2; 7256 7257 -- Start of processing for Denotes_Same_Object 7258 7259 begin 7260 -- Both names statically denote the same stand-alone object or parameter 7261 -- (RM 6.4.1(6.5/3)) 7262 7263 if Is_Entity_Name (Obj1) 7264 and then Is_Entity_Name (Obj2) 7265 and then Entity (Obj1) = Entity (Obj2) 7266 then 7267 return True; 7268 end if; 7269 7270 -- For renamings, the prefix of any dereference within the renamed 7271 -- object_name is not a variable, and any expression within the 7272 -- renamed object_name contains no references to variables nor 7273 -- calls on nonstatic functions (RM 6.4.1(6.10/3)). 7274 7275 if Is_Renaming (Obj1) then 7276 if Is_Valid_Renaming (Obj1) then 7277 Obj1 := Renamed_Entity (Entity (Obj1)); 7278 else 7279 return False; 7280 end if; 7281 end if; 7282 7283 if Is_Renaming (Obj2) then 7284 if Is_Valid_Renaming (Obj2) then 7285 Obj2 := Renamed_Entity (Entity (Obj2)); 7286 else 7287 return False; 7288 end if; 7289 end if; 7290 7291 -- No match if not same node kind (such cases are handled by 7292 -- Denotes_Same_Prefix) 7293 7294 if Nkind (Obj1) /= Nkind (Obj2) then 7295 return False; 7296 7297 -- After handling valid renamings, one of the two names statically 7298 -- denoted a renaming declaration whose renamed object_name is known 7299 -- to denote the same object as the other (RM 6.4.1(6.10/3)) 7300 7301 elsif Is_Entity_Name (Obj1) then 7302 if Is_Entity_Name (Obj2) then 7303 return Entity (Obj1) = Entity (Obj2); 7304 else 7305 return False; 7306 end if; 7307 7308 -- Both names are selected_components, their prefixes are known to 7309 -- denote the same object, and their selector_names denote the same 7310 -- component (RM 6.4.1(6.6/3)). 7311 7312 elsif Nkind (Obj1) = N_Selected_Component then 7313 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) 7314 and then 7315 Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2)); 7316 7317 -- Both names are dereferences and the dereferenced names are known to 7318 -- denote the same object (RM 6.4.1(6.7/3)) 7319 7320 elsif Nkind (Obj1) = N_Explicit_Dereference then 7321 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)); 7322 7323 -- Both names are indexed_components, their prefixes are known to denote 7324 -- the same object, and each of the pairs of corresponding index values 7325 -- are either both static expressions with the same static value or both 7326 -- names that are known to denote the same object (RM 6.4.1(6.8/3)) 7327 7328 elsif Nkind (Obj1) = N_Indexed_Component then 7329 if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then 7330 return False; 7331 else 7332 declare 7333 Indx1 : Node_Id; 7334 Indx2 : Node_Id; 7335 7336 begin 7337 Indx1 := First (Expressions (Obj1)); 7338 Indx2 := First (Expressions (Obj2)); 7339 while Present (Indx1) loop 7340 7341 -- Indexes must denote the same static value or same object 7342 7343 if Is_OK_Static_Expression (Indx1) then 7344 if not Is_OK_Static_Expression (Indx2) then 7345 return False; 7346 7347 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then 7348 return False; 7349 end if; 7350 7351 elsif not Denotes_Same_Object (Indx1, Indx2) then 7352 return False; 7353 end if; 7354 7355 Next (Indx1); 7356 Next (Indx2); 7357 end loop; 7358 7359 return True; 7360 end; 7361 end if; 7362 7363 -- Both names are slices, their prefixes are known to denote the same 7364 -- object, and the two slices have statically matching index constraints 7365 -- (RM 6.4.1(6.9/3)) 7366 7367 elsif Nkind (Obj1) = N_Slice 7368 and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) 7369 then 7370 declare 7371 Lo1, Lo2, Hi1, Hi2 : Node_Id; 7372 7373 begin 7374 Get_Index_Bounds (Etype (Obj1), Lo1, Hi1); 7375 Get_Index_Bounds (Etype (Obj2), Lo2, Hi2); 7376 7377 -- Check whether bounds are statically identical. There is no 7378 -- attempt to detect partial overlap of slices. 7379 7380 return Denotes_Same_Object (Lo1, Lo2) 7381 and then 7382 Denotes_Same_Object (Hi1, Hi2); 7383 end; 7384 7385 -- In the recursion, literals appear as indexes 7386 7387 elsif Nkind (Obj1) = N_Integer_Literal 7388 and then 7389 Nkind (Obj2) = N_Integer_Literal 7390 then 7391 return Intval (Obj1) = Intval (Obj2); 7392 7393 else 7394 return False; 7395 end if; 7396 end Denotes_Same_Object; 7397 7398 ------------------------- 7399 -- Denotes_Same_Prefix -- 7400 ------------------------- 7401 7402 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is 7403 begin 7404 if Is_Entity_Name (A1) then 7405 if Nkind (A2) in N_Selected_Component | N_Indexed_Component 7406 and then not Is_Access_Type (Etype (A1)) 7407 then 7408 return Denotes_Same_Object (A1, Prefix (A2)) 7409 or else Denotes_Same_Prefix (A1, Prefix (A2)); 7410 else 7411 return False; 7412 end if; 7413 7414 elsif Is_Entity_Name (A2) then 7415 return Denotes_Same_Prefix (A1 => A2, A2 => A1); 7416 7417 elsif Nkind (A1) in N_Selected_Component | N_Indexed_Component | N_Slice 7418 and then 7419 Nkind (A2) in N_Selected_Component | N_Indexed_Component | N_Slice 7420 then 7421 declare 7422 Root1, Root2 : Node_Id; 7423 Depth1, Depth2 : Nat := 0; 7424 7425 begin 7426 Root1 := Prefix (A1); 7427 while not Is_Entity_Name (Root1) loop 7428 if Nkind (Root1) not in 7429 N_Selected_Component | N_Indexed_Component 7430 then 7431 return False; 7432 else 7433 Root1 := Prefix (Root1); 7434 end if; 7435 7436 Depth1 := Depth1 + 1; 7437 end loop; 7438 7439 Root2 := Prefix (A2); 7440 while not Is_Entity_Name (Root2) loop 7441 if Nkind (Root2) not in 7442 N_Selected_Component | N_Indexed_Component 7443 then 7444 return False; 7445 else 7446 Root2 := Prefix (Root2); 7447 end if; 7448 7449 Depth2 := Depth2 + 1; 7450 end loop; 7451 7452 -- If both have the same depth and they do not denote the same 7453 -- object, they are disjoint and no warning is needed. 7454 7455 if Depth1 = Depth2 then 7456 return False; 7457 7458 elsif Depth1 > Depth2 then 7459 Root1 := Prefix (A1); 7460 for J in 1 .. Depth1 - Depth2 - 1 loop 7461 Root1 := Prefix (Root1); 7462 end loop; 7463 7464 return Denotes_Same_Object (Root1, A2); 7465 7466 else 7467 Root2 := Prefix (A2); 7468 for J in 1 .. Depth2 - Depth1 - 1 loop 7469 Root2 := Prefix (Root2); 7470 end loop; 7471 7472 return Denotes_Same_Object (A1, Root2); 7473 end if; 7474 end; 7475 7476 else 7477 return False; 7478 end if; 7479 end Denotes_Same_Prefix; 7480 7481 ---------------------- 7482 -- Denotes_Variable -- 7483 ---------------------- 7484 7485 function Denotes_Variable (N : Node_Id) return Boolean is 7486 begin 7487 return Is_Variable (N) and then Paren_Count (N) = 0; 7488 end Denotes_Variable; 7489 7490 ----------------------------- 7491 -- Depends_On_Discriminant -- 7492 ----------------------------- 7493 7494 function Depends_On_Discriminant (N : Node_Id) return Boolean is 7495 L : Node_Id; 7496 H : Node_Id; 7497 7498 begin 7499 Get_Index_Bounds (N, L, H); 7500 return Denotes_Discriminant (L) or else Denotes_Discriminant (H); 7501 end Depends_On_Discriminant; 7502 7503 ------------------------------------- 7504 -- Derivation_Too_Early_To_Inherit -- 7505 ------------------------------------- 7506 7507 function Derivation_Too_Early_To_Inherit 7508 (Typ : Entity_Id; Streaming_Op : TSS_Name_Type) return Boolean is 7509 Btyp : constant Entity_Id := Implementation_Base_Type (Typ); 7510 Parent_Type : Entity_Id; 7511 begin 7512 if Is_Derived_Type (Btyp) then 7513 Parent_Type := Implementation_Base_Type (Etype (Btyp)); 7514 pragma Assert (Parent_Type /= Btyp); 7515 if Has_Stream_Attribute_Definition 7516 (Parent_Type, Streaming_Op) 7517 and then In_Same_Extended_Unit (Btyp, Parent_Type) 7518 and then Instantiation (Get_Source_File_Index (Sloc (Btyp))) = 7519 Instantiation (Get_Source_File_Index (Sloc (Parent_Type))) 7520 then 7521 declare 7522 -- ??? Avoid code duplication here with 7523 -- Sem_Cat.Has_Stream_Attribute_Definition by introducing a 7524 -- new function to be called from both places? 7525 7526 Rep_Item : Node_Id := First_Rep_Item (Parent_Type); 7527 Real_Rep : Node_Id; 7528 Found : Boolean := False; 7529 begin 7530 while Present (Rep_Item) loop 7531 Real_Rep := Rep_Item; 7532 7533 if Nkind (Rep_Item) = N_Aspect_Specification then 7534 Real_Rep := Aspect_Rep_Item (Rep_Item); 7535 end if; 7536 7537 if Nkind (Real_Rep) = N_Attribute_Definition_Clause then 7538 case Chars (Real_Rep) is 7539 when Name_Read => 7540 Found := Streaming_Op = TSS_Stream_Read; 7541 7542 when Name_Write => 7543 Found := Streaming_Op = TSS_Stream_Write; 7544 7545 when Name_Input => 7546 Found := Streaming_Op = TSS_Stream_Input; 7547 7548 when Name_Output => 7549 Found := Streaming_Op = TSS_Stream_Output; 7550 7551 when others => 7552 null; 7553 end case; 7554 end if; 7555 7556 if Found then 7557 return Earlier_In_Extended_Unit (Btyp, Real_Rep); 7558 end if; 7559 7560 Next_Rep_Item (Rep_Item); 7561 end loop; 7562 end; 7563 end if; 7564 end if; 7565 return False; 7566 end Derivation_Too_Early_To_Inherit; 7567 7568 ------------------------- 7569 -- Designate_Same_Unit -- 7570 ------------------------- 7571 7572 function Designate_Same_Unit 7573 (Name1 : Node_Id; 7574 Name2 : Node_Id) return Boolean 7575 is 7576 K1 : constant Node_Kind := Nkind (Name1); 7577 K2 : constant Node_Kind := Nkind (Name2); 7578 7579 function Prefix_Node (N : Node_Id) return Node_Id; 7580 -- Returns the parent unit name node of a defining program unit name 7581 -- or the prefix if N is a selected component or an expanded name. 7582 7583 function Select_Node (N : Node_Id) return Node_Id; 7584 -- Returns the defining identifier node of a defining program unit 7585 -- name or the selector node if N is a selected component or an 7586 -- expanded name. 7587 7588 ----------------- 7589 -- Prefix_Node -- 7590 ----------------- 7591 7592 function Prefix_Node (N : Node_Id) return Node_Id is 7593 begin 7594 if Nkind (N) = N_Defining_Program_Unit_Name then 7595 return Name (N); 7596 else 7597 return Prefix (N); 7598 end if; 7599 end Prefix_Node; 7600 7601 ----------------- 7602 -- Select_Node -- 7603 ----------------- 7604 7605 function Select_Node (N : Node_Id) return Node_Id is 7606 begin 7607 if Nkind (N) = N_Defining_Program_Unit_Name then 7608 return Defining_Identifier (N); 7609 else 7610 return Selector_Name (N); 7611 end if; 7612 end Select_Node; 7613 7614 -- Start of processing for Designate_Same_Unit 7615 7616 begin 7617 if K1 in N_Identifier | N_Defining_Identifier 7618 and then 7619 K2 in N_Identifier | N_Defining_Identifier 7620 then 7621 return Chars (Name1) = Chars (Name2); 7622 7623 elsif K1 in N_Expanded_Name 7624 | N_Selected_Component 7625 | N_Defining_Program_Unit_Name 7626 and then 7627 K2 in N_Expanded_Name 7628 | N_Selected_Component 7629 | N_Defining_Program_Unit_Name 7630 then 7631 return 7632 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2))) 7633 and then 7634 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2)); 7635 7636 else 7637 return False; 7638 end if; 7639 end Designate_Same_Unit; 7640 7641 --------------------------------------------- 7642 -- Diagnose_Iterated_Component_Association -- 7643 --------------------------------------------- 7644 7645 procedure Diagnose_Iterated_Component_Association (N : Node_Id) is 7646 Def_Id : constant Entity_Id := Defining_Identifier (N); 7647 Aggr : Node_Id; 7648 7649 begin 7650 -- Determine whether the iterated component association appears within 7651 -- an aggregate. If this is the case, raise Program_Error because the 7652 -- iterated component association cannot be left in the tree as is and 7653 -- must always be processed by the related aggregate. 7654 7655 Aggr := N; 7656 while Present (Aggr) loop 7657 if Nkind (Aggr) = N_Aggregate then 7658 raise Program_Error; 7659 7660 -- Prevent the search from going too far 7661 7662 elsif Is_Body_Or_Package_Declaration (Aggr) then 7663 exit; 7664 end if; 7665 7666 Aggr := Parent (Aggr); 7667 end loop; 7668 7669 -- At this point it is known that the iterated component association is 7670 -- not within an aggregate. This is really a quantified expression with 7671 -- a missing "all" or "some" quantifier. 7672 7673 Error_Msg_N ("missing quantifier", Def_Id); 7674 7675 -- Rewrite the iterated component association as True to prevent any 7676 -- cascaded errors. 7677 7678 Rewrite (N, New_Occurrence_Of (Standard_True, Sloc (N))); 7679 Analyze (N); 7680 end Diagnose_Iterated_Component_Association; 7681 7682 ------------------------ 7683 -- Discriminated_Size -- 7684 ------------------------ 7685 7686 function Discriminated_Size (Comp : Entity_Id) return Boolean is 7687 function Non_Static_Bound (Bound : Node_Id) return Boolean; 7688 -- Check whether the bound of an index is non-static and does denote 7689 -- a discriminant, in which case any object of the type (protected or 7690 -- otherwise) will have a non-static size. 7691 7692 ---------------------- 7693 -- Non_Static_Bound -- 7694 ---------------------- 7695 7696 function Non_Static_Bound (Bound : Node_Id) return Boolean is 7697 begin 7698 if Is_OK_Static_Expression (Bound) then 7699 return False; 7700 7701 -- If the bound is given by a discriminant it is non-static 7702 -- (A static constraint replaces the reference with the value). 7703 -- In an protected object the discriminant has been replaced by 7704 -- the corresponding discriminal within the protected operation. 7705 7706 elsif Is_Entity_Name (Bound) 7707 and then 7708 (Ekind (Entity (Bound)) = E_Discriminant 7709 or else Present (Discriminal_Link (Entity (Bound)))) 7710 then 7711 return False; 7712 7713 else 7714 return True; 7715 end if; 7716 end Non_Static_Bound; 7717 7718 -- Local variables 7719 7720 Typ : constant Entity_Id := Etype (Comp); 7721 Index : Node_Id; 7722 7723 -- Start of processing for Discriminated_Size 7724 7725 begin 7726 if not Is_Array_Type (Typ) then 7727 return False; 7728 end if; 7729 7730 if Ekind (Typ) = E_Array_Subtype then 7731 Index := First_Index (Typ); 7732 while Present (Index) loop 7733 if Non_Static_Bound (Low_Bound (Index)) 7734 or else Non_Static_Bound (High_Bound (Index)) 7735 then 7736 return False; 7737 end if; 7738 7739 Next_Index (Index); 7740 end loop; 7741 7742 return True; 7743 end if; 7744 7745 return False; 7746 end Discriminated_Size; 7747 7748 ----------------------------------- 7749 -- Effective_Extra_Accessibility -- 7750 ----------------------------------- 7751 7752 function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is 7753 begin 7754 if Present (Renamed_Object (Id)) 7755 and then Is_Entity_Name (Renamed_Object (Id)) 7756 then 7757 return Effective_Extra_Accessibility (Entity (Renamed_Object (Id))); 7758 else 7759 return Extra_Accessibility (Id); 7760 end if; 7761 end Effective_Extra_Accessibility; 7762 7763 ----------------------------- 7764 -- Effective_Reads_Enabled -- 7765 ----------------------------- 7766 7767 function Effective_Reads_Enabled (Id : Entity_Id) return Boolean is 7768 begin 7769 return Has_Enabled_Property (Id, Name_Effective_Reads); 7770 end Effective_Reads_Enabled; 7771 7772 ------------------------------ 7773 -- Effective_Writes_Enabled -- 7774 ------------------------------ 7775 7776 function Effective_Writes_Enabled (Id : Entity_Id) return Boolean is 7777 begin 7778 return Has_Enabled_Property (Id, Name_Effective_Writes); 7779 end Effective_Writes_Enabled; 7780 7781 ------------------------------ 7782 -- Enclosing_Comp_Unit_Node -- 7783 ------------------------------ 7784 7785 function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is 7786 Current_Node : Node_Id; 7787 7788 begin 7789 Current_Node := N; 7790 while Present (Current_Node) 7791 and then Nkind (Current_Node) /= N_Compilation_Unit 7792 loop 7793 Current_Node := Parent (Current_Node); 7794 end loop; 7795 7796 if Nkind (Current_Node) /= N_Compilation_Unit then 7797 return Empty; 7798 else 7799 return Current_Node; 7800 end if; 7801 end Enclosing_Comp_Unit_Node; 7802 7803 -------------------------- 7804 -- Enclosing_CPP_Parent -- 7805 -------------------------- 7806 7807 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is 7808 Parent_Typ : Entity_Id := Typ; 7809 7810 begin 7811 while not Is_CPP_Class (Parent_Typ) 7812 and then Etype (Parent_Typ) /= Parent_Typ 7813 loop 7814 Parent_Typ := Etype (Parent_Typ); 7815 7816 if Is_Private_Type (Parent_Typ) then 7817 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 7818 end if; 7819 end loop; 7820 7821 pragma Assert (Is_CPP_Class (Parent_Typ)); 7822 return Parent_Typ; 7823 end Enclosing_CPP_Parent; 7824 7825 --------------------------- 7826 -- Enclosing_Declaration -- 7827 --------------------------- 7828 7829 function Enclosing_Declaration (N : Node_Id) return Node_Id is 7830 Decl : Node_Id := N; 7831 7832 begin 7833 while Present (Decl) 7834 and then not (Nkind (Decl) in N_Declaration 7835 or else 7836 Nkind (Decl) in N_Later_Decl_Item 7837 or else 7838 Nkind (Decl) in N_Renaming_Declaration 7839 or else 7840 Nkind (Decl) = N_Number_Declaration) 7841 loop 7842 Decl := Parent (Decl); 7843 end loop; 7844 7845 return Decl; 7846 end Enclosing_Declaration; 7847 7848 ---------------------------- 7849 -- Enclosing_Generic_Body -- 7850 ---------------------------- 7851 7852 function Enclosing_Generic_Body (N : Node_Id) return Node_Id is 7853 Par : Node_Id; 7854 Spec_Id : Entity_Id; 7855 7856 begin 7857 Par := Parent (N); 7858 while Present (Par) loop 7859 if Nkind (Par) in N_Package_Body | N_Subprogram_Body then 7860 Spec_Id := Corresponding_Spec (Par); 7861 7862 if Present (Spec_Id) 7863 and then Nkind (Unit_Declaration_Node (Spec_Id)) in 7864 N_Generic_Package_Declaration | 7865 N_Generic_Subprogram_Declaration 7866 then 7867 return Par; 7868 end if; 7869 end if; 7870 7871 Par := Parent (Par); 7872 end loop; 7873 7874 return Empty; 7875 end Enclosing_Generic_Body; 7876 7877 ---------------------------- 7878 -- Enclosing_Generic_Unit -- 7879 ---------------------------- 7880 7881 function Enclosing_Generic_Unit (N : Node_Id) return Node_Id is 7882 Par : Node_Id; 7883 Spec_Decl : Node_Id; 7884 Spec_Id : Entity_Id; 7885 7886 begin 7887 Par := Parent (N); 7888 while Present (Par) loop 7889 if Nkind (Par) in N_Generic_Package_Declaration 7890 | N_Generic_Subprogram_Declaration 7891 then 7892 return Par; 7893 7894 elsif Nkind (Par) in N_Package_Body | N_Subprogram_Body then 7895 Spec_Id := Corresponding_Spec (Par); 7896 7897 if Present (Spec_Id) then 7898 Spec_Decl := Unit_Declaration_Node (Spec_Id); 7899 7900 if Nkind (Spec_Decl) in N_Generic_Package_Declaration 7901 | N_Generic_Subprogram_Declaration 7902 then 7903 return Spec_Decl; 7904 end if; 7905 end if; 7906 end if; 7907 7908 Par := Parent (Par); 7909 end loop; 7910 7911 return Empty; 7912 end Enclosing_Generic_Unit; 7913 7914 ------------------- 7915 -- Enclosing_HSS -- 7916 ------------------- 7917 7918 function Enclosing_HSS (Stmt : Node_Id) return Node_Id is 7919 Par : Node_Id; 7920 begin 7921 pragma Assert (Is_Statement (Stmt)); 7922 7923 Par := Parent (Stmt); 7924 while Present (Par) loop 7925 7926 if Nkind (Par) = N_Handled_Sequence_Of_Statements then 7927 return Par; 7928 7929 -- Prevent the search from going too far 7930 7931 elsif Is_Body_Or_Package_Declaration (Par) then 7932 return Empty; 7933 7934 end if; 7935 7936 Par := Parent (Par); 7937 end loop; 7938 7939 return Par; 7940 end Enclosing_HSS; 7941 7942 ------------------------------- 7943 -- Enclosing_Lib_Unit_Entity -- 7944 ------------------------------- 7945 7946 function Enclosing_Lib_Unit_Entity 7947 (E : Entity_Id := Current_Scope) return Entity_Id 7948 is 7949 Unit_Entity : Entity_Id; 7950 7951 begin 7952 -- Look for enclosing library unit entity by following scope links. 7953 -- Equivalent to, but faster than indexing through the scope stack. 7954 7955 Unit_Entity := E; 7956 while (Present (Scope (Unit_Entity)) 7957 and then Scope (Unit_Entity) /= Standard_Standard) 7958 and not Is_Child_Unit (Unit_Entity) 7959 loop 7960 Unit_Entity := Scope (Unit_Entity); 7961 end loop; 7962 7963 return Unit_Entity; 7964 end Enclosing_Lib_Unit_Entity; 7965 7966 ----------------------------- 7967 -- Enclosing_Lib_Unit_Node -- 7968 ----------------------------- 7969 7970 function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is 7971 Encl_Unit : Node_Id; 7972 7973 begin 7974 Encl_Unit := Enclosing_Comp_Unit_Node (N); 7975 while Present (Encl_Unit) 7976 and then Nkind (Unit (Encl_Unit)) = N_Subunit 7977 loop 7978 Encl_Unit := Library_Unit (Encl_Unit); 7979 end loop; 7980 7981 pragma Assert (Nkind (Encl_Unit) = N_Compilation_Unit); 7982 return Encl_Unit; 7983 end Enclosing_Lib_Unit_Node; 7984 7985 ----------------------- 7986 -- Enclosing_Package -- 7987 ----------------------- 7988 7989 function Enclosing_Package (E : Entity_Id) return Entity_Id is 7990 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E); 7991 7992 begin 7993 if Dynamic_Scope = Standard_Standard then 7994 return Standard_Standard; 7995 7996 elsif Dynamic_Scope = Empty then 7997 return Empty; 7998 7999 elsif Ekind (Dynamic_Scope) in 8000 E_Generic_Package | E_Package | E_Package_Body 8001 then 8002 return Dynamic_Scope; 8003 8004 else 8005 return Enclosing_Package (Dynamic_Scope); 8006 end if; 8007 end Enclosing_Package; 8008 8009 ------------------------------------- 8010 -- Enclosing_Package_Or_Subprogram -- 8011 ------------------------------------- 8012 8013 function Enclosing_Package_Or_Subprogram (E : Entity_Id) return Entity_Id is 8014 S : Entity_Id; 8015 8016 begin 8017 S := Scope (E); 8018 while Present (S) loop 8019 if Is_Package_Or_Generic_Package (S) 8020 or else Is_Subprogram_Or_Generic_Subprogram (S) 8021 then 8022 return S; 8023 8024 else 8025 S := Scope (S); 8026 end if; 8027 end loop; 8028 8029 return Empty; 8030 end Enclosing_Package_Or_Subprogram; 8031 8032 -------------------------- 8033 -- Enclosing_Subprogram -- 8034 -------------------------- 8035 8036 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is 8037 Dyn_Scop : constant Entity_Id := Enclosing_Dynamic_Scope (E); 8038 8039 begin 8040 if Dyn_Scop = Standard_Standard then 8041 return Empty; 8042 8043 elsif Dyn_Scop = Empty then 8044 return Empty; 8045 8046 elsif Ekind (Dyn_Scop) = E_Subprogram_Body then 8047 return Corresponding_Spec (Parent (Parent (Dyn_Scop))); 8048 8049 elsif Ekind (Dyn_Scop) in E_Block | E_Loop | E_Return_Statement then 8050 return Enclosing_Subprogram (Dyn_Scop); 8051 8052 elsif Ekind (Dyn_Scop) in E_Entry | E_Entry_Family then 8053 8054 -- For a task entry or entry family, return the enclosing subprogram 8055 -- of the task itself. 8056 8057 if Ekind (Scope (Dyn_Scop)) = E_Task_Type then 8058 return Enclosing_Subprogram (Dyn_Scop); 8059 8060 -- A protected entry or entry family is rewritten as a protected 8061 -- procedure which is the desired enclosing subprogram. This is 8062 -- relevant when unnesting a procedure local to an entry body. 8063 8064 else 8065 return Protected_Body_Subprogram (Dyn_Scop); 8066 end if; 8067 8068 elsif Ekind (Dyn_Scop) = E_Task_Type then 8069 return Get_Task_Body_Procedure (Dyn_Scop); 8070 8071 -- The scope may appear as a private type or as a private extension 8072 -- whose completion is a task or protected type. 8073 8074 elsif Ekind (Dyn_Scop) in 8075 E_Limited_Private_Type | E_Record_Type_With_Private 8076 and then Present (Full_View (Dyn_Scop)) 8077 and then Ekind (Full_View (Dyn_Scop)) in E_Task_Type | E_Protected_Type 8078 then 8079 return Get_Task_Body_Procedure (Full_View (Dyn_Scop)); 8080 8081 -- No body is generated if the protected operation is eliminated 8082 8083 elsif not Is_Eliminated (Dyn_Scop) 8084 and then Present (Protected_Body_Subprogram (Dyn_Scop)) 8085 then 8086 return Protected_Body_Subprogram (Dyn_Scop); 8087 8088 else 8089 return Dyn_Scop; 8090 end if; 8091 end Enclosing_Subprogram; 8092 8093 -------------------------- 8094 -- End_Keyword_Location -- 8095 -------------------------- 8096 8097 function End_Keyword_Location (N : Node_Id) return Source_Ptr is 8098 function End_Label_Loc (Nod : Node_Id) return Source_Ptr; 8099 -- Return the source location of Nod's end label according to the 8100 -- following precedence rules: 8101 -- 8102 -- 1) If the end label exists, return its location 8103 -- 2) If Nod exists, return its location 8104 -- 3) Return the location of N 8105 8106 ------------------- 8107 -- End_Label_Loc -- 8108 ------------------- 8109 8110 function End_Label_Loc (Nod : Node_Id) return Source_Ptr is 8111 Label : Node_Id; 8112 8113 begin 8114 if Present (Nod) then 8115 Label := End_Label (Nod); 8116 8117 if Present (Label) then 8118 return Sloc (Label); 8119 else 8120 return Sloc (Nod); 8121 end if; 8122 8123 else 8124 return Sloc (N); 8125 end if; 8126 end End_Label_Loc; 8127 8128 -- Local variables 8129 8130 Owner : Node_Id; 8131 8132 -- Start of processing for End_Keyword_Location 8133 8134 begin 8135 if Nkind (N) in N_Block_Statement 8136 | N_Entry_Body 8137 | N_Package_Body 8138 | N_Subprogram_Body 8139 | N_Task_Body 8140 then 8141 Owner := Handled_Statement_Sequence (N); 8142 8143 elsif Nkind (N) = N_Package_Declaration then 8144 Owner := Specification (N); 8145 8146 elsif Nkind (N) = N_Protected_Body then 8147 Owner := N; 8148 8149 elsif Nkind (N) in N_Protected_Type_Declaration 8150 | N_Single_Protected_Declaration 8151 then 8152 Owner := Protected_Definition (N); 8153 8154 elsif Nkind (N) in N_Single_Task_Declaration | N_Task_Type_Declaration 8155 then 8156 Owner := Task_Definition (N); 8157 8158 -- This routine should not be called with other contexts 8159 8160 else 8161 pragma Assert (False); 8162 null; 8163 end if; 8164 8165 return End_Label_Loc (Owner); 8166 end End_Keyword_Location; 8167 8168 ------------------------ 8169 -- Ensure_Freeze_Node -- 8170 ------------------------ 8171 8172 procedure Ensure_Freeze_Node (E : Entity_Id) is 8173 FN : Node_Id; 8174 begin 8175 if No (Freeze_Node (E)) then 8176 FN := Make_Freeze_Entity (Sloc (E)); 8177 Set_Has_Delayed_Freeze (E); 8178 Set_Freeze_Node (E, FN); 8179 Set_Access_Types_To_Process (FN, No_Elist); 8180 Set_TSS_Elist (FN, No_Elist); 8181 Set_Entity (FN, E); 8182 end if; 8183 end Ensure_Freeze_Node; 8184 8185 ---------------- 8186 -- Enter_Name -- 8187 ---------------- 8188 8189 procedure Enter_Name (Def_Id : Entity_Id) is 8190 C : constant Entity_Id := Current_Entity (Def_Id); 8191 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); 8192 S : constant Entity_Id := Current_Scope; 8193 8194 begin 8195 Generate_Definition (Def_Id); 8196 8197 -- Add new name to current scope declarations. Check for duplicate 8198 -- declaration, which may or may not be a genuine error. 8199 8200 if Present (E) then 8201 8202 -- Case of previous entity entered because of a missing declaration 8203 -- or else a bad subtype indication. Best is to use the new entity, 8204 -- and make the previous one invisible. 8205 8206 if Etype (E) = Any_Type then 8207 Set_Is_Immediately_Visible (E, False); 8208 8209 -- Case of renaming declaration constructed for package instances. 8210 -- if there is an explicit declaration with the same identifier, 8211 -- the renaming is not immediately visible any longer, but remains 8212 -- visible through selected component notation. 8213 8214 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration 8215 and then not Comes_From_Source (E) 8216 then 8217 Set_Is_Immediately_Visible (E, False); 8218 8219 -- The new entity may be the package renaming, which has the same 8220 -- same name as a generic formal which has been seen already. 8221 8222 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration 8223 and then not Comes_From_Source (Def_Id) 8224 then 8225 Set_Is_Immediately_Visible (E, False); 8226 8227 -- For a fat pointer corresponding to a remote access to subprogram, 8228 -- we use the same identifier as the RAS type, so that the proper 8229 -- name appears in the stub. This type is only retrieved through 8230 -- the RAS type and never by visibility, and is not added to the 8231 -- visibility list (see below). 8232 8233 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration 8234 and then Ekind (Def_Id) = E_Record_Type 8235 and then Present (Corresponding_Remote_Type (Def_Id)) 8236 then 8237 null; 8238 8239 -- Case of an implicit operation or derived literal. The new entity 8240 -- hides the implicit one, which is removed from all visibility, 8241 -- i.e. the entity list of its scope, and homonym chain of its name. 8242 8243 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E)) 8244 or else Is_Internal (E) 8245 then 8246 declare 8247 Decl : constant Node_Id := Parent (E); 8248 Prev : Entity_Id; 8249 Prev_Vis : Entity_Id; 8250 8251 begin 8252 -- If E is an implicit declaration, it cannot be the first 8253 -- entity in the scope. 8254 8255 Prev := First_Entity (Current_Scope); 8256 while Present (Prev) and then Next_Entity (Prev) /= E loop 8257 Next_Entity (Prev); 8258 end loop; 8259 8260 if No (Prev) then 8261 8262 -- If E is not on the entity chain of the current scope, 8263 -- it is an implicit declaration in the generic formal 8264 -- part of a generic subprogram. When analyzing the body, 8265 -- the generic formals are visible but not on the entity 8266 -- chain of the subprogram. The new entity will become 8267 -- the visible one in the body. 8268 8269 pragma Assert 8270 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration); 8271 null; 8272 8273 else 8274 Link_Entities (Prev, Next_Entity (E)); 8275 8276 if No (Next_Entity (Prev)) then 8277 Set_Last_Entity (Current_Scope, Prev); 8278 end if; 8279 8280 if E = Current_Entity (E) then 8281 Prev_Vis := Empty; 8282 8283 else 8284 Prev_Vis := Current_Entity (E); 8285 while Homonym (Prev_Vis) /= E loop 8286 Prev_Vis := Homonym (Prev_Vis); 8287 end loop; 8288 end if; 8289 8290 if Present (Prev_Vis) then 8291 8292 -- Skip E in the visibility chain 8293 8294 Set_Homonym (Prev_Vis, Homonym (E)); 8295 8296 else 8297 Set_Name_Entity_Id (Chars (E), Homonym (E)); 8298 end if; 8299 8300 -- The inherited operation cannot be retrieved 8301 -- by name, even though it may remain accesssible 8302 -- in some cases involving subprogram bodies without 8303 -- specs appearing in with_clauses.. 8304 8305 Set_Is_Immediately_Visible (E, False); 8306 end if; 8307 end; 8308 8309 -- This section of code could use a comment ??? 8310 8311 elsif Present (Etype (E)) 8312 and then Is_Concurrent_Type (Etype (E)) 8313 and then E = Def_Id 8314 then 8315 return; 8316 8317 -- If the homograph is a protected component renaming, it should not 8318 -- be hiding the current entity. Such renamings are treated as weak 8319 -- declarations. 8320 8321 elsif Is_Prival (E) then 8322 Set_Is_Immediately_Visible (E, False); 8323 8324 -- In this case the current entity is a protected component renaming. 8325 -- Perform minimal decoration by setting the scope and return since 8326 -- the prival should not be hiding other visible entities. 8327 8328 elsif Is_Prival (Def_Id) then 8329 Set_Scope (Def_Id, Current_Scope); 8330 return; 8331 8332 -- Analogous to privals, the discriminal generated for an entry index 8333 -- parameter acts as a weak declaration. Perform minimal decoration 8334 -- to avoid bogus errors. 8335 8336 elsif Is_Discriminal (Def_Id) 8337 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter 8338 then 8339 Set_Scope (Def_Id, Current_Scope); 8340 return; 8341 8342 -- In the body or private part of an instance, a type extension may 8343 -- introduce a component with the same name as that of an actual. The 8344 -- legality rule is not enforced, but the semantics of the full type 8345 -- with two components of same name are not clear at this point??? 8346 8347 elsif In_Instance_Not_Visible then 8348 null; 8349 8350 -- When compiling a package body, some child units may have become 8351 -- visible. They cannot conflict with local entities that hide them. 8352 8353 elsif Is_Child_Unit (E) 8354 and then In_Open_Scopes (Scope (E)) 8355 and then not Is_Immediately_Visible (E) 8356 then 8357 null; 8358 8359 -- Conversely, with front-end inlining we may compile the parent body 8360 -- first, and a child unit subsequently. The context is now the 8361 -- parent spec, and body entities are not visible. 8362 8363 elsif Is_Child_Unit (Def_Id) 8364 and then Is_Package_Body_Entity (E) 8365 and then not In_Package_Body (Current_Scope) 8366 then 8367 null; 8368 8369 -- Case of genuine duplicate declaration 8370 8371 else 8372 Error_Msg_Sloc := Sloc (E); 8373 8374 -- If the previous declaration is an incomplete type declaration 8375 -- this may be an attempt to complete it with a private type. The 8376 -- following avoids confusing cascaded errors. 8377 8378 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration 8379 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration 8380 then 8381 Error_Msg_N 8382 ("incomplete type cannot be completed with a private " & 8383 "declaration", Parent (Def_Id)); 8384 Set_Is_Immediately_Visible (E, False); 8385 Set_Full_View (E, Def_Id); 8386 8387 -- An inherited component of a record conflicts with a new 8388 -- discriminant. The discriminant is inserted first in the scope, 8389 -- but the error should be posted on it, not on the component. 8390 8391 elsif Ekind (E) = E_Discriminant 8392 and then Present (Scope (Def_Id)) 8393 and then Scope (Def_Id) /= Current_Scope 8394 then 8395 Error_Msg_Sloc := Sloc (Def_Id); 8396 Error_Msg_N ("& conflicts with declaration#", E); 8397 return; 8398 8399 -- If the name of the unit appears in its own context clause, a 8400 -- dummy package with the name has already been created, and the 8401 -- error emitted. Try to continue quietly. 8402 8403 elsif Error_Posted (E) 8404 and then Sloc (E) = No_Location 8405 and then Nkind (Parent (E)) = N_Package_Specification 8406 and then Current_Scope = Standard_Standard 8407 then 8408 Set_Scope (Def_Id, Current_Scope); 8409 return; 8410 8411 else 8412 Error_Msg_N ("& conflicts with declaration#", Def_Id); 8413 8414 -- Avoid cascaded messages with duplicate components in 8415 -- derived types. 8416 8417 if Ekind (E) in E_Component | E_Discriminant then 8418 return; 8419 end if; 8420 end if; 8421 8422 if Nkind (Parent (Parent (Def_Id))) = 8423 N_Generic_Subprogram_Declaration 8424 and then Def_Id = 8425 Defining_Entity (Specification (Parent (Parent (Def_Id)))) 8426 then 8427 Error_Msg_N ("\generic units cannot be overloaded", Def_Id); 8428 end if; 8429 8430 -- If entity is in standard, then we are in trouble, because it 8431 -- means that we have a library package with a duplicated name. 8432 -- That's hard to recover from, so abort. 8433 8434 if S = Standard_Standard then 8435 raise Unrecoverable_Error; 8436 8437 -- Otherwise we continue with the declaration. Having two 8438 -- identical declarations should not cause us too much trouble. 8439 8440 else 8441 null; 8442 end if; 8443 end if; 8444 end if; 8445 8446 -- If we fall through, declaration is OK, at least OK enough to continue 8447 8448 -- If Def_Id is a discriminant or a record component we are in the midst 8449 -- of inheriting components in a derived record definition. Preserve 8450 -- their Ekind and Etype. 8451 8452 if Ekind (Def_Id) in E_Discriminant | E_Component then 8453 null; 8454 8455 -- If a type is already set, leave it alone (happens when a type 8456 -- declaration is reanalyzed following a call to the optimizer). 8457 8458 elsif Present (Etype (Def_Id)) then 8459 null; 8460 8461 -- Otherwise, the kind E_Void insures that premature uses of the entity 8462 -- will be detected. Any_Type insures that no cascaded errors will occur 8463 8464 else 8465 Set_Ekind (Def_Id, E_Void); 8466 Set_Etype (Def_Id, Any_Type); 8467 end if; 8468 8469 -- All entities except Itypes are immediately visible 8470 8471 if not Is_Itype (Def_Id) then 8472 Set_Is_Immediately_Visible (Def_Id); 8473 Set_Current_Entity (Def_Id); 8474 end if; 8475 8476 Set_Homonym (Def_Id, C); 8477 Append_Entity (Def_Id, S); 8478 Set_Public_Status (Def_Id); 8479 8480 -- Warn if new entity hides an old one 8481 8482 if Warn_On_Hiding and then Present (C) 8483 8484 -- Don't warn for record components since they always have a well 8485 -- defined scope which does not confuse other uses. Note that in 8486 -- some cases, Ekind has not been set yet. 8487 8488 and then Ekind (C) /= E_Component 8489 and then Ekind (C) /= E_Discriminant 8490 and then Nkind (Parent (C)) /= N_Component_Declaration 8491 and then Ekind (Def_Id) /= E_Component 8492 and then Ekind (Def_Id) /= E_Discriminant 8493 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration 8494 8495 -- Don't warn for one character variables. It is too common to use 8496 -- such variables as locals and will just cause too many false hits. 8497 8498 and then Length_Of_Name (Chars (C)) /= 1 8499 8500 -- Don't warn for non-source entities 8501 8502 and then Comes_From_Source (C) 8503 and then Comes_From_Source (Def_Id) 8504 8505 -- Don't warn unless entity in question is in extended main source 8506 8507 and then In_Extended_Main_Source_Unit (Def_Id) 8508 8509 -- Finally, the hidden entity must be either immediately visible or 8510 -- use visible (i.e. from a used package). 8511 8512 and then 8513 (Is_Immediately_Visible (C) 8514 or else 8515 Is_Potentially_Use_Visible (C)) 8516 then 8517 Error_Msg_Sloc := Sloc (C); 8518 Error_Msg_N ("declaration hides &#?h?", Def_Id); 8519 end if; 8520 end Enter_Name; 8521 8522 --------------- 8523 -- Entity_Of -- 8524 --------------- 8525 8526 function Entity_Of (N : Node_Id) return Entity_Id is 8527 Id : Entity_Id; 8528 Ren : Node_Id; 8529 8530 begin 8531 -- Assume that the arbitrary node does not have an entity 8532 8533 Id := Empty; 8534 8535 if Is_Entity_Name (N) then 8536 Id := Entity (N); 8537 8538 -- Follow a possible chain of renamings to reach the earliest renamed 8539 -- source object. 8540 8541 while Present (Id) 8542 and then Is_Object (Id) 8543 and then Present (Renamed_Object (Id)) 8544 loop 8545 Ren := Renamed_Object (Id); 8546 8547 -- The reference renames an abstract state or a whole object 8548 8549 -- Obj : ...; 8550 -- Ren : ... renames Obj; 8551 8552 if Is_Entity_Name (Ren) then 8553 8554 -- Do not follow a renaming that goes through a generic formal, 8555 -- because these entities are hidden and must not be referenced 8556 -- from outside the generic. 8557 8558 if Is_Hidden (Entity (Ren)) then 8559 exit; 8560 8561 else 8562 Id := Entity (Ren); 8563 end if; 8564 8565 -- The reference renames a function result. Check the original 8566 -- node in case expansion relocates the function call. 8567 8568 -- Ren : ... renames Func_Call; 8569 8570 elsif Nkind (Original_Node (Ren)) = N_Function_Call then 8571 exit; 8572 8573 -- Otherwise the reference renames something which does not yield 8574 -- an abstract state or a whole object. Treat the reference as not 8575 -- having a proper entity for SPARK legality purposes. 8576 8577 else 8578 Id := Empty; 8579 exit; 8580 end if; 8581 end loop; 8582 end if; 8583 8584 return Id; 8585 end Entity_Of; 8586 8587 -------------------------- 8588 -- Examine_Array_Bounds -- 8589 -------------------------- 8590 8591 procedure Examine_Array_Bounds 8592 (Typ : Entity_Id; 8593 All_Static : out Boolean; 8594 Has_Empty : out Boolean) 8595 is 8596 function Is_OK_Static_Bound (Bound : Node_Id) return Boolean; 8597 -- Determine whether bound Bound is a suitable static bound 8598 8599 ------------------------ 8600 -- Is_OK_Static_Bound -- 8601 ------------------------ 8602 8603 function Is_OK_Static_Bound (Bound : Node_Id) return Boolean is 8604 begin 8605 return 8606 not Error_Posted (Bound) 8607 and then Is_OK_Static_Expression (Bound); 8608 end Is_OK_Static_Bound; 8609 8610 -- Local variables 8611 8612 Hi_Bound : Node_Id; 8613 Index : Node_Id; 8614 Lo_Bound : Node_Id; 8615 8616 -- Start of processing for Examine_Array_Bounds 8617 8618 begin 8619 -- An unconstrained array type does not have static bounds, and it is 8620 -- not known whether they are empty or not. 8621 8622 if not Is_Constrained (Typ) then 8623 All_Static := False; 8624 Has_Empty := False; 8625 8626 -- A string literal has static bounds, and is not empty as long as it 8627 -- contains at least one character. 8628 8629 elsif Ekind (Typ) = E_String_Literal_Subtype then 8630 All_Static := True; 8631 Has_Empty := String_Literal_Length (Typ) > 0; 8632 end if; 8633 8634 -- Assume that all bounds are static and not empty 8635 8636 All_Static := True; 8637 Has_Empty := False; 8638 8639 -- Examine each index 8640 8641 Index := First_Index (Typ); 8642 while Present (Index) loop 8643 if Is_Discrete_Type (Etype (Index)) then 8644 Get_Index_Bounds (Index, Lo_Bound, Hi_Bound); 8645 8646 if Is_OK_Static_Bound (Lo_Bound) 8647 and then 8648 Is_OK_Static_Bound (Hi_Bound) 8649 then 8650 -- The static bounds produce an empty range 8651 8652 if Is_Null_Range (Lo_Bound, Hi_Bound) then 8653 Has_Empty := True; 8654 end if; 8655 8656 -- Otherwise at least one of the bounds is not static 8657 8658 else 8659 All_Static := False; 8660 end if; 8661 8662 -- Otherwise the index is non-discrete, therefore not static 8663 8664 else 8665 All_Static := False; 8666 end if; 8667 8668 Next_Index (Index); 8669 end loop; 8670 end Examine_Array_Bounds; 8671 8672 ------------------- 8673 -- Exceptions_OK -- 8674 ------------------- 8675 8676 function Exceptions_OK return Boolean is 8677 begin 8678 return 8679 not (Restriction_Active (No_Exception_Handlers) or else 8680 Restriction_Active (No_Exception_Propagation) or else 8681 Restriction_Active (No_Exceptions)); 8682 end Exceptions_OK; 8683 8684 -------------------------- 8685 -- Explain_Limited_Type -- 8686 -------------------------- 8687 8688 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is 8689 C : Entity_Id; 8690 8691 begin 8692 -- For array, component type must be limited 8693 8694 if Is_Array_Type (T) then 8695 Error_Msg_Node_2 := T; 8696 Error_Msg_NE 8697 ("\component type& of type& is limited", N, Component_Type (T)); 8698 Explain_Limited_Type (Component_Type (T), N); 8699 8700 elsif Is_Record_Type (T) then 8701 8702 -- No need for extra messages if explicit limited record 8703 8704 if Is_Limited_Record (Base_Type (T)) then 8705 return; 8706 end if; 8707 8708 -- Otherwise find a limited component. Check only components that 8709 -- come from source, or inherited components that appear in the 8710 -- source of the ancestor. 8711 8712 C := First_Component (T); 8713 while Present (C) loop 8714 if Is_Limited_Type (Etype (C)) 8715 and then 8716 (Comes_From_Source (C) 8717 or else 8718 (Present (Original_Record_Component (C)) 8719 and then 8720 Comes_From_Source (Original_Record_Component (C)))) 8721 then 8722 Error_Msg_Node_2 := T; 8723 Error_Msg_NE ("\component& of type& has limited type", N, C); 8724 Explain_Limited_Type (Etype (C), N); 8725 return; 8726 end if; 8727 8728 Next_Component (C); 8729 end loop; 8730 8731 -- The type may be declared explicitly limited, even if no component 8732 -- of it is limited, in which case we fall out of the loop. 8733 return; 8734 end if; 8735 end Explain_Limited_Type; 8736 8737 --------------------------------------- 8738 -- Expression_Of_Expression_Function -- 8739 --------------------------------------- 8740 8741 function Expression_Of_Expression_Function 8742 (Subp : Entity_Id) return Node_Id 8743 is 8744 Expr_Func : Node_Id; 8745 8746 begin 8747 pragma Assert (Is_Expression_Function_Or_Completion (Subp)); 8748 8749 if Nkind (Original_Node (Subprogram_Spec (Subp))) = 8750 N_Expression_Function 8751 then 8752 Expr_Func := Original_Node (Subprogram_Spec (Subp)); 8753 8754 elsif Nkind (Original_Node (Subprogram_Body (Subp))) = 8755 N_Expression_Function 8756 then 8757 Expr_Func := Original_Node (Subprogram_Body (Subp)); 8758 8759 else 8760 pragma Assert (False); 8761 null; 8762 end if; 8763 8764 return Original_Node (Expression (Expr_Func)); 8765 end Expression_Of_Expression_Function; 8766 8767 ------------------------------- 8768 -- Extensions_Visible_Status -- 8769 ------------------------------- 8770 8771 function Extensions_Visible_Status 8772 (Id : Entity_Id) return Extensions_Visible_Mode 8773 is 8774 Arg : Node_Id; 8775 Decl : Node_Id; 8776 Expr : Node_Id; 8777 Prag : Node_Id; 8778 Subp : Entity_Id; 8779 8780 begin 8781 -- When a formal parameter is subject to Extensions_Visible, the pragma 8782 -- is stored in the contract of related subprogram. 8783 8784 if Is_Formal (Id) then 8785 Subp := Scope (Id); 8786 8787 elsif Is_Subprogram_Or_Generic_Subprogram (Id) then 8788 Subp := Id; 8789 8790 -- No other construct carries this pragma 8791 8792 else 8793 return Extensions_Visible_None; 8794 end if; 8795 8796 Prag := Get_Pragma (Subp, Pragma_Extensions_Visible); 8797 8798 -- In certain cases analysis may request the Extensions_Visible status 8799 -- of an expression function before the pragma has been analyzed yet. 8800 -- Inspect the declarative items after the expression function looking 8801 -- for the pragma (if any). 8802 8803 if No (Prag) and then Is_Expression_Function (Subp) then 8804 Decl := Next (Unit_Declaration_Node (Subp)); 8805 while Present (Decl) loop 8806 if Nkind (Decl) = N_Pragma 8807 and then Pragma_Name (Decl) = Name_Extensions_Visible 8808 then 8809 Prag := Decl; 8810 exit; 8811 8812 -- A source construct ends the region where Extensions_Visible may 8813 -- appear, stop the traversal. An expanded expression function is 8814 -- no longer a source construct, but it must still be recognized. 8815 8816 elsif Comes_From_Source (Decl) 8817 or else 8818 (Nkind (Decl) in N_Subprogram_Body | N_Subprogram_Declaration 8819 and then Is_Expression_Function (Defining_Entity (Decl))) 8820 then 8821 exit; 8822 end if; 8823 8824 Next (Decl); 8825 end loop; 8826 end if; 8827 8828 -- Extract the value from the Boolean expression (if any) 8829 8830 if Present (Prag) then 8831 Arg := First (Pragma_Argument_Associations (Prag)); 8832 8833 if Present (Arg) then 8834 Expr := Get_Pragma_Arg (Arg); 8835 8836 -- When the associated subprogram is an expression function, the 8837 -- argument of the pragma may not have been analyzed. 8838 8839 if not Analyzed (Expr) then 8840 Preanalyze_And_Resolve (Expr, Standard_Boolean); 8841 end if; 8842 8843 -- Guard against cascading errors when the argument of pragma 8844 -- Extensions_Visible is not a valid static Boolean expression. 8845 8846 if Error_Posted (Expr) then 8847 return Extensions_Visible_None; 8848 8849 elsif Is_True (Expr_Value (Expr)) then 8850 return Extensions_Visible_True; 8851 8852 else 8853 return Extensions_Visible_False; 8854 end if; 8855 8856 -- Otherwise the aspect or pragma defaults to True 8857 8858 else 8859 return Extensions_Visible_True; 8860 end if; 8861 8862 -- Otherwise aspect or pragma Extensions_Visible is not inherited or 8863 -- directly specified. In SPARK code, its value defaults to "False". 8864 8865 elsif SPARK_Mode = On then 8866 return Extensions_Visible_False; 8867 8868 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to 8869 -- "True". 8870 8871 else 8872 return Extensions_Visible_True; 8873 end if; 8874 end Extensions_Visible_Status; 8875 8876 ----------------- 8877 -- Find_Actual -- 8878 ----------------- 8879 8880 procedure Find_Actual 8881 (N : Node_Id; 8882 Formal : out Entity_Id; 8883 Call : out Node_Id) 8884 is 8885 Context : constant Node_Id := Parent (N); 8886 Actual : Node_Id; 8887 Call_Nam : Node_Id; 8888 8889 begin 8890 if Nkind (Context) in N_Indexed_Component | N_Selected_Component 8891 and then N = Prefix (Context) 8892 then 8893 Find_Actual (Context, Formal, Call); 8894 return; 8895 8896 elsif Nkind (Context) = N_Parameter_Association 8897 and then N = Explicit_Actual_Parameter (Context) 8898 then 8899 Call := Parent (Context); 8900 8901 elsif Nkind (Context) in N_Entry_Call_Statement 8902 | N_Function_Call 8903 | N_Procedure_Call_Statement 8904 then 8905 Call := Context; 8906 8907 else 8908 Formal := Empty; 8909 Call := Empty; 8910 return; 8911 end if; 8912 8913 -- If we have a call to a subprogram look for the parameter. Note that 8914 -- we exclude overloaded calls, since we don't know enough to be sure 8915 -- of giving the right answer in this case. 8916 8917 if Nkind (Call) in N_Entry_Call_Statement 8918 | N_Function_Call 8919 | N_Procedure_Call_Statement 8920 then 8921 Call_Nam := Name (Call); 8922 8923 -- A call to a protected or task entry appears as a selected 8924 -- component rather than an expanded name. 8925 8926 if Nkind (Call_Nam) = N_Selected_Component then 8927 Call_Nam := Selector_Name (Call_Nam); 8928 end if; 8929 8930 if Is_Entity_Name (Call_Nam) 8931 and then Present (Entity (Call_Nam)) 8932 and then Is_Overloadable (Entity (Call_Nam)) 8933 and then not Is_Overloaded (Call_Nam) 8934 then 8935 -- If node is name in call it is not an actual 8936 8937 if N = Call_Nam then 8938 Formal := Empty; 8939 Call := Empty; 8940 return; 8941 end if; 8942 8943 -- Fall here if we are definitely a parameter 8944 8945 Actual := First_Actual (Call); 8946 Formal := First_Formal (Entity (Call_Nam)); 8947 while Present (Formal) and then Present (Actual) loop 8948 if Actual = N then 8949 return; 8950 8951 -- An actual that is the prefix in a prefixed call may have 8952 -- been rewritten in the call, after the deferred reference 8953 -- was collected. Check if sloc and kinds and names match. 8954 8955 elsif Sloc (Actual) = Sloc (N) 8956 and then Nkind (Actual) = N_Identifier 8957 and then Nkind (Actual) = Nkind (N) 8958 and then Chars (Actual) = Chars (N) 8959 then 8960 return; 8961 8962 else 8963 Next_Actual (Actual); 8964 Next_Formal (Formal); 8965 end if; 8966 end loop; 8967 end if; 8968 end if; 8969 8970 -- Fall through here if we did not find matching actual 8971 8972 Formal := Empty; 8973 Call := Empty; 8974 end Find_Actual; 8975 8976 --------------------------- 8977 -- Find_Body_Discriminal -- 8978 --------------------------- 8979 8980 function Find_Body_Discriminal 8981 (Spec_Discriminant : Entity_Id) return Entity_Id 8982 is 8983 Tsk : Entity_Id; 8984 Disc : Entity_Id; 8985 8986 begin 8987 -- If expansion is suppressed, then the scope can be the concurrent type 8988 -- itself rather than a corresponding concurrent record type. 8989 8990 if Is_Concurrent_Type (Scope (Spec_Discriminant)) then 8991 Tsk := Scope (Spec_Discriminant); 8992 8993 else 8994 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant))); 8995 8996 Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant)); 8997 end if; 8998 8999 -- Find discriminant of original concurrent type, and use its current 9000 -- discriminal, which is the renaming within the task/protected body. 9001 9002 Disc := First_Discriminant (Tsk); 9003 while Present (Disc) loop 9004 if Chars (Disc) = Chars (Spec_Discriminant) then 9005 return Discriminal (Disc); 9006 end if; 9007 9008 Next_Discriminant (Disc); 9009 end loop; 9010 9011 -- That loop should always succeed in finding a matching entry and 9012 -- returning. Fatal error if not. 9013 9014 raise Program_Error; 9015 end Find_Body_Discriminal; 9016 9017 ------------------------------------- 9018 -- Find_Corresponding_Discriminant -- 9019 ------------------------------------- 9020 9021 function Find_Corresponding_Discriminant 9022 (Id : Node_Id; 9023 Typ : Entity_Id) return Entity_Id 9024 is 9025 Par_Disc : Entity_Id; 9026 Old_Disc : Entity_Id; 9027 New_Disc : Entity_Id; 9028 9029 begin 9030 Par_Disc := Original_Record_Component (Original_Discriminant (Id)); 9031 9032 -- The original type may currently be private, and the discriminant 9033 -- only appear on its full view. 9034 9035 if Is_Private_Type (Scope (Par_Disc)) 9036 and then not Has_Discriminants (Scope (Par_Disc)) 9037 and then Present (Full_View (Scope (Par_Disc))) 9038 then 9039 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc))); 9040 else 9041 Old_Disc := First_Discriminant (Scope (Par_Disc)); 9042 end if; 9043 9044 if Is_Class_Wide_Type (Typ) then 9045 New_Disc := First_Discriminant (Root_Type (Typ)); 9046 else 9047 New_Disc := First_Discriminant (Typ); 9048 end if; 9049 9050 while Present (Old_Disc) and then Present (New_Disc) loop 9051 if Old_Disc = Par_Disc then 9052 return New_Disc; 9053 end if; 9054 9055 Next_Discriminant (Old_Disc); 9056 Next_Discriminant (New_Disc); 9057 end loop; 9058 9059 -- Should always find it 9060 9061 raise Program_Error; 9062 end Find_Corresponding_Discriminant; 9063 9064 ------------------- 9065 -- Find_DIC_Type -- 9066 ------------------- 9067 9068 function Find_DIC_Type (Typ : Entity_Id) return Entity_Id is 9069 Curr_Typ : Entity_Id; 9070 -- The current type being examined in the parent hierarchy traversal 9071 9072 DIC_Typ : Entity_Id; 9073 -- The type which carries the DIC pragma. This variable denotes the 9074 -- partial view when private types are involved. 9075 9076 Par_Typ : Entity_Id; 9077 -- The parent type of the current type. This variable denotes the full 9078 -- view when private types are involved. 9079 9080 begin 9081 -- The input type defines its own DIC pragma, therefore it is the owner 9082 9083 if Has_Own_DIC (Typ) then 9084 DIC_Typ := Typ; 9085 9086 -- Otherwise the DIC pragma is inherited from a parent type 9087 9088 else 9089 pragma Assert (Has_Inherited_DIC (Typ)); 9090 9091 -- Climb the parent chain 9092 9093 Curr_Typ := Typ; 9094 loop 9095 -- Inspect the parent type. Do not consider subtypes as they 9096 -- inherit the DIC attributes from their base types. 9097 9098 DIC_Typ := Base_Type (Etype (Curr_Typ)); 9099 9100 -- Look at the full view of a private type because the type may 9101 -- have a hidden parent introduced in the full view. 9102 9103 Par_Typ := DIC_Typ; 9104 9105 if Is_Private_Type (Par_Typ) 9106 and then Present (Full_View (Par_Typ)) 9107 then 9108 Par_Typ := Full_View (Par_Typ); 9109 end if; 9110 9111 -- Stop the climb once the nearest parent type which defines a DIC 9112 -- pragma of its own is encountered or when the root of the parent 9113 -- chain is reached. 9114 9115 exit when Has_Own_DIC (DIC_Typ) or else Curr_Typ = Par_Typ; 9116 9117 Curr_Typ := Par_Typ; 9118 end loop; 9119 end if; 9120 9121 return DIC_Typ; 9122 end Find_DIC_Type; 9123 9124 ---------------------------------- 9125 -- Find_Enclosing_Iterator_Loop -- 9126 ---------------------------------- 9127 9128 function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id is 9129 Constr : Node_Id; 9130 S : Entity_Id; 9131 9132 begin 9133 -- Traverse the scope chain looking for an iterator loop. Such loops are 9134 -- usually transformed into blocks, hence the use of Original_Node. 9135 9136 S := Id; 9137 while Present (S) and then S /= Standard_Standard loop 9138 if Ekind (S) = E_Loop 9139 and then Nkind (Parent (S)) = N_Implicit_Label_Declaration 9140 then 9141 Constr := Original_Node (Label_Construct (Parent (S))); 9142 9143 if Nkind (Constr) = N_Loop_Statement 9144 and then Present (Iteration_Scheme (Constr)) 9145 and then Nkind (Iterator_Specification 9146 (Iteration_Scheme (Constr))) = 9147 N_Iterator_Specification 9148 then 9149 return S; 9150 end if; 9151 end if; 9152 9153 S := Scope (S); 9154 end loop; 9155 9156 return Empty; 9157 end Find_Enclosing_Iterator_Loop; 9158 9159 -------------------------- 9160 -- Find_Enclosing_Scope -- 9161 -------------------------- 9162 9163 function Find_Enclosing_Scope (N : Node_Id) return Entity_Id is 9164 Par : Node_Id; 9165 9166 begin 9167 -- Examine the parent chain looking for a construct which defines a 9168 -- scope. 9169 9170 Par := Parent (N); 9171 while Present (Par) loop 9172 case Nkind (Par) is 9173 9174 -- The construct denotes a declaration, the proper scope is its 9175 -- entity. 9176 9177 when N_Entry_Declaration 9178 | N_Expression_Function 9179 | N_Full_Type_Declaration 9180 | N_Generic_Package_Declaration 9181 | N_Generic_Subprogram_Declaration 9182 | N_Package_Declaration 9183 | N_Private_Extension_Declaration 9184 | N_Protected_Type_Declaration 9185 | N_Single_Protected_Declaration 9186 | N_Single_Task_Declaration 9187 | N_Subprogram_Declaration 9188 | N_Task_Type_Declaration 9189 => 9190 return Defining_Entity (Par); 9191 9192 -- The construct denotes a body, the proper scope is the entity of 9193 -- the corresponding spec or that of the body if the body does not 9194 -- complete a previous declaration. 9195 9196 when N_Entry_Body 9197 | N_Package_Body 9198 | N_Protected_Body 9199 | N_Subprogram_Body 9200 | N_Task_Body 9201 => 9202 return Unique_Defining_Entity (Par); 9203 9204 -- Special cases 9205 9206 -- Blocks carry either a source or an internally-generated scope, 9207 -- unless the block is a byproduct of exception handling. 9208 9209 when N_Block_Statement => 9210 if not Exception_Junk (Par) then 9211 return Entity (Identifier (Par)); 9212 end if; 9213 9214 -- Loops carry an internally-generated scope 9215 9216 when N_Loop_Statement => 9217 return Entity (Identifier (Par)); 9218 9219 -- Extended return statements carry an internally-generated scope 9220 9221 when N_Extended_Return_Statement => 9222 return Return_Statement_Entity (Par); 9223 9224 -- A traversal from a subunit continues via the corresponding stub 9225 9226 when N_Subunit => 9227 Par := Corresponding_Stub (Par); 9228 9229 when others => 9230 null; 9231 end case; 9232 9233 Par := Parent (Par); 9234 end loop; 9235 9236 return Standard_Standard; 9237 end Find_Enclosing_Scope; 9238 9239 ------------------------------------ 9240 -- Find_Loop_In_Conditional_Block -- 9241 ------------------------------------ 9242 9243 function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is 9244 Stmt : Node_Id; 9245 9246 begin 9247 Stmt := N; 9248 9249 if Nkind (Stmt) = N_If_Statement then 9250 Stmt := First (Then_Statements (Stmt)); 9251 end if; 9252 9253 pragma Assert (Nkind (Stmt) = N_Block_Statement); 9254 9255 -- Inspect the statements of the conditional block. In general the loop 9256 -- should be the first statement in the statement sequence of the block, 9257 -- but the finalization machinery may have introduced extra object 9258 -- declarations. 9259 9260 Stmt := First (Statements (Handled_Statement_Sequence (Stmt))); 9261 while Present (Stmt) loop 9262 if Nkind (Stmt) = N_Loop_Statement then 9263 return Stmt; 9264 end if; 9265 9266 Next (Stmt); 9267 end loop; 9268 9269 -- The expansion of attribute 'Loop_Entry produced a malformed block 9270 9271 raise Program_Error; 9272 end Find_Loop_In_Conditional_Block; 9273 9274 -------------------------- 9275 -- Find_Overlaid_Entity -- 9276 -------------------------- 9277 9278 procedure Find_Overlaid_Entity 9279 (N : Node_Id; 9280 Ent : out Entity_Id; 9281 Off : out Boolean) 9282 is 9283 Expr : Node_Id; 9284 9285 begin 9286 -- We are looking for one of the two following forms: 9287 9288 -- for X'Address use Y'Address 9289 9290 -- or 9291 9292 -- Const : constant Address := expr; 9293 -- ... 9294 -- for X'Address use Const; 9295 9296 -- In the second case, the expr is either Y'Address, or recursively a 9297 -- constant that eventually references Y'Address. 9298 9299 Ent := Empty; 9300 Off := False; 9301 9302 if Nkind (N) = N_Attribute_Definition_Clause 9303 and then Chars (N) = Name_Address 9304 then 9305 Expr := Expression (N); 9306 9307 -- This loop checks the form of the expression for Y'Address, 9308 -- using recursion to deal with intermediate constants. 9309 9310 loop 9311 -- Check for Y'Address 9312 9313 if Nkind (Expr) = N_Attribute_Reference 9314 and then Attribute_Name (Expr) = Name_Address 9315 then 9316 Expr := Prefix (Expr); 9317 exit; 9318 9319 -- Check for Const where Const is a constant entity 9320 9321 elsif Is_Entity_Name (Expr) 9322 and then Ekind (Entity (Expr)) = E_Constant 9323 then 9324 Expr := Constant_Value (Entity (Expr)); 9325 9326 -- Anything else does not need checking 9327 9328 else 9329 return; 9330 end if; 9331 end loop; 9332 9333 -- This loop checks the form of the prefix for an entity, using 9334 -- recursion to deal with intermediate components. 9335 9336 loop 9337 -- Check for Y where Y is an entity 9338 9339 if Is_Entity_Name (Expr) then 9340 Ent := Entity (Expr); 9341 return; 9342 9343 -- Check for components 9344 9345 elsif Nkind (Expr) in N_Selected_Component | N_Indexed_Component 9346 then 9347 Expr := Prefix (Expr); 9348 Off := True; 9349 9350 -- Anything else does not need checking 9351 9352 else 9353 return; 9354 end if; 9355 end loop; 9356 end if; 9357 end Find_Overlaid_Entity; 9358 9359 ------------------------- 9360 -- Find_Parameter_Type -- 9361 ------------------------- 9362 9363 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is 9364 begin 9365 if Nkind (Param) /= N_Parameter_Specification then 9366 return Empty; 9367 9368 -- For an access parameter, obtain the type from the formal entity 9369 -- itself, because access to subprogram nodes do not carry a type. 9370 -- Shouldn't we always use the formal entity ??? 9371 9372 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then 9373 return Etype (Defining_Identifier (Param)); 9374 9375 else 9376 return Etype (Parameter_Type (Param)); 9377 end if; 9378 end Find_Parameter_Type; 9379 9380 ----------------------------------- 9381 -- Find_Placement_In_State_Space -- 9382 ----------------------------------- 9383 9384 procedure Find_Placement_In_State_Space 9385 (Item_Id : Entity_Id; 9386 Placement : out State_Space_Kind; 9387 Pack_Id : out Entity_Id) 9388 is 9389 Context : Entity_Id; 9390 9391 begin 9392 -- Assume that the item does not appear in the state space of a package 9393 9394 Placement := Not_In_Package; 9395 Pack_Id := Empty; 9396 9397 -- Climb the scope stack and examine the enclosing context 9398 9399 Context := Scope (Item_Id); 9400 while Present (Context) and then Context /= Standard_Standard loop 9401 if Is_Package_Or_Generic_Package (Context) then 9402 Pack_Id := Context; 9403 9404 -- A package body is a cut off point for the traversal as the item 9405 -- cannot be visible to the outside from this point on. Note that 9406 -- this test must be done first as a body is also classified as a 9407 -- private part. 9408 9409 if In_Package_Body (Context) then 9410 Placement := Body_State_Space; 9411 return; 9412 9413 -- The private part of a package is a cut off point for the 9414 -- traversal as the item cannot be visible to the outside from 9415 -- this point on. 9416 9417 elsif In_Private_Part (Context) then 9418 Placement := Private_State_Space; 9419 return; 9420 9421 -- When the item appears in the visible state space of a package, 9422 -- continue to climb the scope stack as this may not be the final 9423 -- state space. 9424 9425 else 9426 Placement := Visible_State_Space; 9427 9428 -- The visible state space of a child unit acts as the proper 9429 -- placement of an item. 9430 9431 if Is_Child_Unit (Context) then 9432 return; 9433 end if; 9434 end if; 9435 9436 -- The item or its enclosing package appear in a construct that has 9437 -- no state space. 9438 9439 else 9440 Placement := Not_In_Package; 9441 return; 9442 end if; 9443 9444 Context := Scope (Context); 9445 end loop; 9446 end Find_Placement_In_State_Space; 9447 9448 ----------------------- 9449 -- Find_Primitive_Eq -- 9450 ----------------------- 9451 9452 function Find_Primitive_Eq (Typ : Entity_Id) return Entity_Id is 9453 function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id; 9454 -- Search for the equality primitive; return Empty if the primitive is 9455 -- not found. 9456 9457 ------------------ 9458 -- Find_Eq_Prim -- 9459 ------------------ 9460 9461 function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id is 9462 Prim : Entity_Id; 9463 Prim_Elmt : Elmt_Id; 9464 9465 begin 9466 Prim_Elmt := First_Elmt (Prims_List); 9467 while Present (Prim_Elmt) loop 9468 Prim := Node (Prim_Elmt); 9469 9470 -- Locate primitive equality with the right signature 9471 9472 if Chars (Prim) = Name_Op_Eq 9473 and then Etype (First_Formal (Prim)) = 9474 Etype (Next_Formal (First_Formal (Prim))) 9475 and then Base_Type (Etype (Prim)) = Standard_Boolean 9476 then 9477 return Prim; 9478 end if; 9479 9480 Next_Elmt (Prim_Elmt); 9481 end loop; 9482 9483 return Empty; 9484 end Find_Eq_Prim; 9485 9486 -- Local Variables 9487 9488 Eq_Prim : Entity_Id; 9489 Full_Type : Entity_Id; 9490 9491 -- Start of processing for Find_Primitive_Eq 9492 9493 begin 9494 if Is_Private_Type (Typ) then 9495 Full_Type := Underlying_Type (Typ); 9496 else 9497 Full_Type := Typ; 9498 end if; 9499 9500 if No (Full_Type) then 9501 return Empty; 9502 end if; 9503 9504 Full_Type := Base_Type (Full_Type); 9505 9506 -- When the base type itself is private, use the full view 9507 9508 if Is_Private_Type (Full_Type) then 9509 Full_Type := Underlying_Type (Full_Type); 9510 end if; 9511 9512 if Is_Class_Wide_Type (Full_Type) then 9513 Full_Type := Root_Type (Full_Type); 9514 end if; 9515 9516 if not Is_Tagged_Type (Full_Type) then 9517 Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ)); 9518 9519 -- If this is an untagged private type completed with a derivation of 9520 -- an untagged private type whose full view is a tagged type, we use 9521 -- the primitive operations of the private parent type (since it does 9522 -- not have a full view, and also because its equality primitive may 9523 -- have been overridden in its untagged full view). If no equality was 9524 -- defined for it then take its dispatching equality primitive. 9525 9526 elsif Inherits_From_Tagged_Full_View (Typ) then 9527 Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ)); 9528 9529 if No (Eq_Prim) then 9530 Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type)); 9531 end if; 9532 9533 else 9534 Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type)); 9535 end if; 9536 9537 return Eq_Prim; 9538 end Find_Primitive_Eq; 9539 9540 ------------------------ 9541 -- Find_Specific_Type -- 9542 ------------------------ 9543 9544 function Find_Specific_Type (CW : Entity_Id) return Entity_Id is 9545 Typ : Entity_Id := Root_Type (CW); 9546 9547 begin 9548 if Ekind (Typ) = E_Incomplete_Type then 9549 if From_Limited_With (Typ) then 9550 Typ := Non_Limited_View (Typ); 9551 else 9552 Typ := Full_View (Typ); 9553 end if; 9554 end if; 9555 9556 if Is_Private_Type (Typ) 9557 and then not Is_Tagged_Type (Typ) 9558 and then Present (Full_View (Typ)) 9559 then 9560 return Full_View (Typ); 9561 else 9562 return Typ; 9563 end if; 9564 end Find_Specific_Type; 9565 9566 ----------------------------- 9567 -- Find_Static_Alternative -- 9568 ----------------------------- 9569 9570 function Find_Static_Alternative (N : Node_Id) return Node_Id is 9571 Expr : constant Node_Id := Expression (N); 9572 Val : constant Uint := Expr_Value (Expr); 9573 Alt : Node_Id; 9574 Choice : Node_Id; 9575 9576 begin 9577 Alt := First (Alternatives (N)); 9578 9579 Search : loop 9580 if Nkind (Alt) /= N_Pragma then 9581 Choice := First (Discrete_Choices (Alt)); 9582 while Present (Choice) loop 9583 9584 -- Others choice, always matches 9585 9586 if Nkind (Choice) = N_Others_Choice then 9587 exit Search; 9588 9589 -- Range, check if value is in the range 9590 9591 elsif Nkind (Choice) = N_Range then 9592 exit Search when 9593 Val >= Expr_Value (Low_Bound (Choice)) 9594 and then 9595 Val <= Expr_Value (High_Bound (Choice)); 9596 9597 -- Choice is a subtype name. Note that we know it must 9598 -- be a static subtype, since otherwise it would have 9599 -- been diagnosed as illegal. 9600 9601 elsif Is_Entity_Name (Choice) 9602 and then Is_Type (Entity (Choice)) 9603 then 9604 exit Search when Is_In_Range (Expr, Etype (Choice), 9605 Assume_Valid => False); 9606 9607 -- Choice is a subtype indication 9608 9609 elsif Nkind (Choice) = N_Subtype_Indication then 9610 declare 9611 C : constant Node_Id := Constraint (Choice); 9612 R : constant Node_Id := Range_Expression (C); 9613 9614 begin 9615 exit Search when 9616 Val >= Expr_Value (Low_Bound (R)) 9617 and then 9618 Val <= Expr_Value (High_Bound (R)); 9619 end; 9620 9621 -- Choice is a simple expression 9622 9623 else 9624 exit Search when Val = Expr_Value (Choice); 9625 end if; 9626 9627 Next (Choice); 9628 end loop; 9629 end if; 9630 9631 Next (Alt); 9632 pragma Assert (Present (Alt)); 9633 end loop Search; 9634 9635 -- The above loop *must* terminate by finding a match, since we know the 9636 -- case statement is valid, and the value of the expression is known at 9637 -- compile time. When we fall out of the loop, Alt points to the 9638 -- alternative that we know will be selected at run time. 9639 9640 return Alt; 9641 end Find_Static_Alternative; 9642 9643 ------------------ 9644 -- First_Actual -- 9645 ------------------ 9646 9647 function First_Actual (Node : Node_Id) return Node_Id is 9648 N : Node_Id; 9649 9650 begin 9651 if No (Parameter_Associations (Node)) then 9652 return Empty; 9653 end if; 9654 9655 N := First (Parameter_Associations (Node)); 9656 9657 if Nkind (N) = N_Parameter_Association then 9658 return First_Named_Actual (Node); 9659 else 9660 return N; 9661 end if; 9662 end First_Actual; 9663 9664 ------------------ 9665 -- First_Global -- 9666 ------------------ 9667 9668 function First_Global 9669 (Subp : Entity_Id; 9670 Global_Mode : Name_Id; 9671 Refined : Boolean := False) return Node_Id 9672 is 9673 function First_From_Global_List 9674 (List : Node_Id; 9675 Global_Mode : Name_Id := Name_Input) return Entity_Id; 9676 -- Get the first item with suitable mode from List 9677 9678 ---------------------------- 9679 -- First_From_Global_List -- 9680 ---------------------------- 9681 9682 function First_From_Global_List 9683 (List : Node_Id; 9684 Global_Mode : Name_Id := Name_Input) return Entity_Id 9685 is 9686 Assoc : Node_Id; 9687 9688 begin 9689 -- Empty list (no global items) 9690 9691 if Nkind (List) = N_Null then 9692 return Empty; 9693 9694 -- Single global item declaration (only input items) 9695 9696 elsif Nkind (List) in N_Expanded_Name | N_Identifier then 9697 if Global_Mode = Name_Input then 9698 return List; 9699 else 9700 return Empty; 9701 end if; 9702 9703 -- Simple global list (only input items) or moded global list 9704 -- declaration. 9705 9706 elsif Nkind (List) = N_Aggregate then 9707 if Present (Expressions (List)) then 9708 if Global_Mode = Name_Input then 9709 return First (Expressions (List)); 9710 else 9711 return Empty; 9712 end if; 9713 9714 else 9715 Assoc := First (Component_Associations (List)); 9716 while Present (Assoc) loop 9717 9718 -- When we find the desired mode in an association, call 9719 -- recursively First_From_Global_List as if the mode was 9720 -- Name_Input, in order to reuse the existing machinery 9721 -- for the other cases. 9722 9723 if Chars (First (Choices (Assoc))) = Global_Mode then 9724 return First_From_Global_List (Expression (Assoc)); 9725 end if; 9726 9727 Next (Assoc); 9728 end loop; 9729 9730 return Empty; 9731 end if; 9732 9733 -- To accommodate partial decoration of disabled SPARK features, 9734 -- this routine may be called with illegal input. If this is the 9735 -- case, do not raise Program_Error. 9736 9737 else 9738 return Empty; 9739 end if; 9740 end First_From_Global_List; 9741 9742 -- Local variables 9743 9744 Global : Node_Id := Empty; 9745 Body_Id : Entity_Id; 9746 9747 -- Start of processing for First_Global 9748 9749 begin 9750 pragma Assert (Global_Mode in Name_In_Out 9751 | Name_Input 9752 | Name_Output 9753 | Name_Proof_In); 9754 9755 -- Retrieve the suitable pragma Global or Refined_Global. In the second 9756 -- case, it can only be located on the body entity. 9757 9758 if Refined then 9759 if Is_Subprogram_Or_Generic_Subprogram (Subp) then 9760 Body_Id := Subprogram_Body_Entity (Subp); 9761 9762 elsif Is_Entry (Subp) or else Is_Task_Type (Subp) then 9763 Body_Id := Corresponding_Body (Parent (Subp)); 9764 9765 -- ??? It should be possible to retrieve the Refined_Global on the 9766 -- task body associated to the task object. This is not yet possible. 9767 9768 elsif Is_Single_Task_Object (Subp) then 9769 Body_Id := Empty; 9770 9771 else 9772 Body_Id := Empty; 9773 end if; 9774 9775 if Present (Body_Id) then 9776 Global := Get_Pragma (Body_Id, Pragma_Refined_Global); 9777 end if; 9778 else 9779 Global := Get_Pragma (Subp, Pragma_Global); 9780 end if; 9781 9782 -- No corresponding global if pragma is not present 9783 9784 if No (Global) then 9785 return Empty; 9786 9787 -- Otherwise retrieve the corresponding list of items depending on the 9788 -- Global_Mode. 9789 9790 else 9791 return First_From_Global_List 9792 (Expression (Get_Argument (Global, Subp)), Global_Mode); 9793 end if; 9794 end First_Global; 9795 9796 ------------- 9797 -- Fix_Msg -- 9798 ------------- 9799 9800 function Fix_Msg (Id : Entity_Id; Msg : String) return String is 9801 Is_Task : constant Boolean := 9802 Ekind (Id) in E_Task_Body | E_Task_Type 9803 or else Is_Single_Task_Object (Id); 9804 Msg_Last : constant Natural := Msg'Last; 9805 Msg_Index : Natural; 9806 Res : String (Msg'Range) := (others => ' '); 9807 Res_Index : Natural; 9808 9809 begin 9810 -- Copy all characters from the input message Msg to result Res with 9811 -- suitable replacements. 9812 9813 Msg_Index := Msg'First; 9814 Res_Index := Res'First; 9815 while Msg_Index <= Msg_Last loop 9816 9817 -- Replace "subprogram" with a different word 9818 9819 if Msg_Index <= Msg_Last - 10 9820 and then Msg (Msg_Index .. Msg_Index + 9) = "subprogram" 9821 then 9822 if Is_Entry (Id) then 9823 Res (Res_Index .. Res_Index + 4) := "entry"; 9824 Res_Index := Res_Index + 5; 9825 9826 elsif Is_Task then 9827 Res (Res_Index .. Res_Index + 8) := "task type"; 9828 Res_Index := Res_Index + 9; 9829 9830 else 9831 Res (Res_Index .. Res_Index + 9) := "subprogram"; 9832 Res_Index := Res_Index + 10; 9833 end if; 9834 9835 Msg_Index := Msg_Index + 10; 9836 9837 -- Replace "protected" with a different word 9838 9839 elsif Msg_Index <= Msg_Last - 9 9840 and then Msg (Msg_Index .. Msg_Index + 8) = "protected" 9841 and then Is_Task 9842 then 9843 Res (Res_Index .. Res_Index + 3) := "task"; 9844 Res_Index := Res_Index + 4; 9845 Msg_Index := Msg_Index + 9; 9846 9847 -- Otherwise copy the character 9848 9849 else 9850 Res (Res_Index) := Msg (Msg_Index); 9851 Msg_Index := Msg_Index + 1; 9852 Res_Index := Res_Index + 1; 9853 end if; 9854 end loop; 9855 9856 return Res (Res'First .. Res_Index - 1); 9857 end Fix_Msg; 9858 9859 ------------------------- 9860 -- From_Nested_Package -- 9861 ------------------------- 9862 9863 function From_Nested_Package (T : Entity_Id) return Boolean is 9864 Pack : constant Entity_Id := Scope (T); 9865 9866 begin 9867 return 9868 Ekind (Pack) = E_Package 9869 and then not Is_Frozen (Pack) 9870 and then not Scope_Within_Or_Same (Current_Scope, Pack) 9871 and then In_Open_Scopes (Scope (Pack)); 9872 end From_Nested_Package; 9873 9874 ----------------------- 9875 -- Gather_Components -- 9876 ----------------------- 9877 9878 procedure Gather_Components 9879 (Typ : Entity_Id; 9880 Comp_List : Node_Id; 9881 Governed_By : List_Id; 9882 Into : Elist_Id; 9883 Report_Errors : out Boolean; 9884 Allow_Compile_Time : Boolean := False; 9885 Include_Interface_Tag : Boolean := False) 9886 is 9887 Assoc : Node_Id; 9888 Variant : Node_Id; 9889 Discrete_Choice : Node_Id; 9890 Comp_Item : Node_Id; 9891 Discrim : Entity_Id; 9892 Discrim_Name : Node_Id; 9893 9894 type Discriminant_Value_Status is 9895 (Static_Expr, Static_Subtype, Bad); 9896 subtype Good_Discrim_Value_Status is Discriminant_Value_Status 9897 range Static_Expr .. Static_Subtype; -- range excludes Bad 9898 9899 Discrim_Value : Node_Id; 9900 Discrim_Value_Subtype : Node_Id; 9901 Discrim_Value_Status : Discriminant_Value_Status := Bad; 9902 begin 9903 Report_Errors := False; 9904 9905 if No (Comp_List) or else Null_Present (Comp_List) then 9906 return; 9907 9908 elsif Present (Component_Items (Comp_List)) then 9909 Comp_Item := First (Component_Items (Comp_List)); 9910 9911 else 9912 Comp_Item := Empty; 9913 end if; 9914 9915 while Present (Comp_Item) loop 9916 9917 -- Skip the tag of a tagged record, as well as all items that are not 9918 -- user components (anonymous types, rep clauses, Parent field, 9919 -- controller field). 9920 9921 if Nkind (Comp_Item) = N_Component_Declaration then 9922 declare 9923 Comp : constant Entity_Id := Defining_Identifier (Comp_Item); 9924 begin 9925 if not (Is_Tag (Comp) 9926 and then not 9927 (Include_Interface_Tag 9928 and then Etype (Comp) = RTE (RE_Interface_Tag))) 9929 and then Chars (Comp) /= Name_uParent 9930 then 9931 Append_Elmt (Comp, Into); 9932 end if; 9933 end; 9934 end if; 9935 9936 Next (Comp_Item); 9937 end loop; 9938 9939 if No (Variant_Part (Comp_List)) then 9940 return; 9941 else 9942 Discrim_Name := Name (Variant_Part (Comp_List)); 9943 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); 9944 end if; 9945 9946 -- Look for the discriminant that governs this variant part. 9947 -- The discriminant *must* be in the Governed_By List 9948 9949 Assoc := First (Governed_By); 9950 Find_Constraint : loop 9951 Discrim := First (Choices (Assoc)); 9952 exit Find_Constraint when 9953 Chars (Discrim_Name) = Chars (Discrim) 9954 or else 9955 (Present (Corresponding_Discriminant (Entity (Discrim))) 9956 and then Chars (Corresponding_Discriminant 9957 (Entity (Discrim))) = Chars (Discrim_Name)) 9958 or else 9959 Chars (Original_Record_Component (Entity (Discrim))) = 9960 Chars (Discrim_Name); 9961 9962 if No (Next (Assoc)) then 9963 if not Is_Constrained (Typ) and then Is_Derived_Type (Typ) then 9964 9965 -- If the type is a tagged type with inherited discriminants, 9966 -- use the stored constraint on the parent in order to find 9967 -- the values of discriminants that are otherwise hidden by an 9968 -- explicit constraint. Renamed discriminants are handled in 9969 -- the code above. 9970 9971 -- If several parent discriminants are renamed by a single 9972 -- discriminant of the derived type, the call to obtain the 9973 -- Corresponding_Discriminant field only retrieves the last 9974 -- of them. We recover the constraint on the others from the 9975 -- Stored_Constraint as well. 9976 9977 -- An inherited discriminant may have been constrained in a 9978 -- later ancestor (not the immediate parent) so we must examine 9979 -- the stored constraint of all of them to locate the inherited 9980 -- value. 9981 9982 declare 9983 C : Elmt_Id; 9984 D : Entity_Id; 9985 T : Entity_Id := Typ; 9986 9987 begin 9988 while Is_Derived_Type (T) loop 9989 if Present (Stored_Constraint (T)) then 9990 D := First_Discriminant (Etype (T)); 9991 C := First_Elmt (Stored_Constraint (T)); 9992 while Present (D) and then Present (C) loop 9993 if Chars (Discrim_Name) = Chars (D) then 9994 if Is_Entity_Name (Node (C)) 9995 and then Entity (Node (C)) = Entity (Discrim) 9996 then 9997 -- D is renamed by Discrim, whose value is 9998 -- given in Assoc. 9999 10000 null; 10001 10002 else 10003 Assoc := 10004 Make_Component_Association (Sloc (Typ), 10005 New_List 10006 (New_Occurrence_Of (D, Sloc (Typ))), 10007 Duplicate_Subexpr_No_Checks (Node (C))); 10008 end if; 10009 10010 exit Find_Constraint; 10011 end if; 10012 10013 Next_Discriminant (D); 10014 Next_Elmt (C); 10015 end loop; 10016 end if; 10017 10018 -- Discriminant may be inherited from ancestor 10019 10020 T := Etype (T); 10021 end loop; 10022 end; 10023 end if; 10024 end if; 10025 10026 if No (Next (Assoc)) then 10027 Error_Msg_NE 10028 (" missing value for discriminant&", 10029 First (Governed_By), Discrim_Name); 10030 10031 Report_Errors := True; 10032 return; 10033 end if; 10034 10035 Next (Assoc); 10036 end loop Find_Constraint; 10037 10038 Discrim_Value := Expression (Assoc); 10039 10040 if Is_OK_Static_Expression (Discrim_Value) 10041 or else (Allow_Compile_Time 10042 and then Compile_Time_Known_Value (Discrim_Value)) 10043 then 10044 Discrim_Value_Status := Static_Expr; 10045 else 10046 if Ada_Version >= Ada_2020 then 10047 if Original_Node (Discrim_Value) /= Discrim_Value 10048 and then Nkind (Discrim_Value) = N_Type_Conversion 10049 and then Etype (Original_Node (Discrim_Value)) 10050 = Etype (Expression (Discrim_Value)) 10051 then 10052 Discrim_Value_Subtype := Etype (Original_Node (Discrim_Value)); 10053 -- An unhelpful (for this code) type conversion may be 10054 -- introduced in some cases; deal with it. 10055 else 10056 Discrim_Value_Subtype := Etype (Discrim_Value); 10057 end if; 10058 10059 if Is_OK_Static_Subtype (Discrim_Value_Subtype) and then 10060 not Is_Null_Range (Type_Low_Bound (Discrim_Value_Subtype), 10061 Type_High_Bound (Discrim_Value_Subtype)) 10062 then 10063 -- Is_Null_Range test doesn't account for predicates, as in 10064 -- subtype Null_By_Predicate is Natural 10065 -- with Static_Predicate => Null_By_Predicate < 0; 10066 -- so test for that null case separately. 10067 10068 if (not Has_Static_Predicate (Discrim_Value_Subtype)) 10069 or else Present (First (Static_Discrete_Predicate 10070 (Discrim_Value_Subtype))) 10071 then 10072 Discrim_Value_Status := Static_Subtype; 10073 end if; 10074 end if; 10075 end if; 10076 10077 if Discrim_Value_Status = Bad then 10078 10079 -- If the variant part is governed by a discriminant of the type 10080 -- this is an error. If the variant part and the discriminant are 10081 -- inherited from an ancestor this is legal (AI05-220) unless the 10082 -- components are being gathered for an aggregate, in which case 10083 -- the caller must check Report_Errors. 10084 -- 10085 -- In Ada 2020 the above rules are relaxed. A nonstatic governing 10086 -- discriminant is OK as long as it has a static subtype and 10087 -- every value of that subtype (and there must be at least one) 10088 -- selects the same variant. 10089 10090 if Scope (Original_Record_Component 10091 ((Entity (First (Choices (Assoc)))))) = Typ 10092 then 10093 if Ada_Version >= Ada_2020 then 10094 Error_Msg_FE 10095 ("value for discriminant & must be static or " & 10096 "discriminant's nominal subtype must be static " & 10097 "and non-null!", 10098 Discrim_Value, Discrim); 10099 else 10100 Error_Msg_FE 10101 ("value for discriminant & must be static!", 10102 Discrim_Value, Discrim); 10103 end if; 10104 Why_Not_Static (Discrim_Value); 10105 end if; 10106 10107 Report_Errors := True; 10108 return; 10109 end if; 10110 end if; 10111 10112 Search_For_Discriminant_Value : declare 10113 Low : Node_Id; 10114 High : Node_Id; 10115 10116 UI_High : Uint; 10117 UI_Low : Uint; 10118 UI_Discrim_Value : Uint; 10119 10120 begin 10121 case Good_Discrim_Value_Status'(Discrim_Value_Status) is 10122 when Static_Expr => 10123 UI_Discrim_Value := Expr_Value (Discrim_Value); 10124 when Static_Subtype => 10125 -- Arbitrarily pick one value of the subtype and look 10126 -- for the variant associated with that value; we will 10127 -- check later that the same variant is associated with 10128 -- all of the other values of the subtype. 10129 if Has_Static_Predicate (Discrim_Value_Subtype) then 10130 declare 10131 Range_Or_Expr : constant Node_Id := 10132 First (Static_Discrete_Predicate 10133 (Discrim_Value_Subtype)); 10134 begin 10135 if Nkind (Range_Or_Expr) = N_Range then 10136 UI_Discrim_Value := 10137 Expr_Value (Low_Bound (Range_Or_Expr)); 10138 else 10139 UI_Discrim_Value := Expr_Value (Range_Or_Expr); 10140 end if; 10141 end; 10142 else 10143 UI_Discrim_Value 10144 := Expr_Value (Type_Low_Bound (Discrim_Value_Subtype)); 10145 end if; 10146 end case; 10147 10148 Find_Discrete_Value : while Present (Variant) loop 10149 10150 -- If a choice is a subtype with a static predicate, it must 10151 -- be rewritten as an explicit list of non-predicated choices. 10152 10153 Expand_Static_Predicates_In_Choices (Variant); 10154 10155 Discrete_Choice := First (Discrete_Choices (Variant)); 10156 while Present (Discrete_Choice) loop 10157 exit Find_Discrete_Value when 10158 Nkind (Discrete_Choice) = N_Others_Choice; 10159 10160 Get_Index_Bounds (Discrete_Choice, Low, High); 10161 10162 UI_Low := Expr_Value (Low); 10163 UI_High := Expr_Value (High); 10164 10165 exit Find_Discrete_Value when 10166 UI_Low <= UI_Discrim_Value 10167 and then 10168 UI_High >= UI_Discrim_Value; 10169 10170 Next (Discrete_Choice); 10171 end loop; 10172 10173 Next_Non_Pragma (Variant); 10174 end loop Find_Discrete_Value; 10175 end Search_For_Discriminant_Value; 10176 10177 -- The case statement must include a variant that corresponds to the 10178 -- value of the discriminant, unless the discriminant type has a 10179 -- static predicate. In that case the absence of an others_choice that 10180 -- would cover this value becomes a run-time error (3.8.1 (21.1/2)). 10181 10182 if No (Variant) 10183 and then not Has_Static_Predicate (Etype (Discrim_Name)) 10184 then 10185 Error_Msg_NE 10186 ("value of discriminant & is out of range", Discrim_Value, Discrim); 10187 Report_Errors := True; 10188 return; 10189 end if; 10190 10191 -- If we have found the corresponding choice, recursively add its 10192 -- components to the Into list. The nested components are part of 10193 -- the same record type. 10194 10195 if Present (Variant) then 10196 if Discrim_Value_Status = Static_Subtype then 10197 declare 10198 Discrim_Value_Subtype_Intervals 10199 : constant Interval_Lists.Discrete_Interval_List 10200 := Interval_Lists.Type_Intervals (Discrim_Value_Subtype); 10201 10202 Variant_Intervals 10203 : constant Interval_Lists.Discrete_Interval_List 10204 := Interval_Lists.Choice_List_Intervals 10205 (Discrete_Choices => Discrete_Choices (Variant)); 10206 begin 10207 if not Interval_Lists.Is_Subset 10208 (Subset => Discrim_Value_Subtype_Intervals, 10209 Of_Set => Variant_Intervals) 10210 then 10211 Error_Msg_NE 10212 ("no single variant is associated with all values of " & 10213 "the subtype of discriminant value &", 10214 Discrim_Value, Discrim); 10215 Report_Errors := True; 10216 return; 10217 end if; 10218 end; 10219 end if; 10220 10221 Gather_Components 10222 (Typ, Component_List (Variant), Governed_By, Into, 10223 Report_Errors, Allow_Compile_Time); 10224 end if; 10225 end Gather_Components; 10226 10227 ------------------------------- 10228 -- Get_Dynamic_Accessibility -- 10229 ------------------------------- 10230 10231 function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_Id is 10232 begin 10233 -- When minimum accessibility is set for E then we utilize it - except 10234 -- in a few edge cases like the expansion of select statements where 10235 -- generated subprogram may attempt to unnecessarily use a minimum 10236 -- accessibility object declared outside of scope. 10237 10238 -- To avoid these situations where expansion may get complex we verify 10239 -- that the minimum accessibility object is within scope. 10240 10241 if Is_Formal (E) 10242 and then Present (Minimum_Accessibility (E)) 10243 and then In_Open_Scopes (Scope (Minimum_Accessibility (E))) 10244 then 10245 return Minimum_Accessibility (E); 10246 end if; 10247 10248 return Extra_Accessibility (E); 10249 end Get_Dynamic_Accessibility; 10250 10251 ------------------------ 10252 -- Get_Actual_Subtype -- 10253 ------------------------ 10254 10255 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is 10256 Typ : constant Entity_Id := Etype (N); 10257 Utyp : Entity_Id := Underlying_Type (Typ); 10258 Decl : Node_Id; 10259 Atyp : Entity_Id; 10260 10261 begin 10262 if No (Utyp) then 10263 Utyp := Typ; 10264 end if; 10265 10266 -- If what we have is an identifier that references a subprogram 10267 -- formal, or a variable or constant object, then we get the actual 10268 -- subtype from the referenced entity if one has been built. 10269 10270 if Nkind (N) = N_Identifier 10271 and then 10272 (Is_Formal (Entity (N)) 10273 or else Ekind (Entity (N)) = E_Constant 10274 or else Ekind (Entity (N)) = E_Variable) 10275 and then Present (Actual_Subtype (Entity (N))) 10276 then 10277 return Actual_Subtype (Entity (N)); 10278 10279 -- Actual subtype of unchecked union is always itself. We never need 10280 -- the "real" actual subtype. If we did, we couldn't get it anyway 10281 -- because the discriminant is not available. The restrictions on 10282 -- Unchecked_Union are designed to make sure that this is OK. 10283 10284 elsif Is_Unchecked_Union (Base_Type (Utyp)) then 10285 return Typ; 10286 10287 -- Here for the unconstrained case, we must find actual subtype 10288 -- No actual subtype is available, so we must build it on the fly. 10289 10290 -- Checking the type, not the underlying type, for constrainedness 10291 -- seems to be necessary. Maybe all the tests should be on the type??? 10292 10293 elsif (not Is_Constrained (Typ)) 10294 and then (Is_Array_Type (Utyp) 10295 or else (Is_Record_Type (Utyp) 10296 and then Has_Discriminants (Utyp))) 10297 and then not Has_Unknown_Discriminants (Utyp) 10298 and then not (Ekind (Utyp) = E_String_Literal_Subtype) 10299 then 10300 -- Nothing to do if in spec expression (why not???) 10301 10302 if In_Spec_Expression then 10303 return Typ; 10304 10305 elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then 10306 10307 -- If the type has no discriminants, there is no subtype to 10308 -- build, even if the underlying type is discriminated. 10309 10310 return Typ; 10311 10312 -- Else build the actual subtype 10313 10314 else 10315 Decl := Build_Actual_Subtype (Typ, N); 10316 10317 -- The call may yield a declaration, or just return the entity 10318 10319 if Decl = Typ then 10320 return Typ; 10321 end if; 10322 10323 Atyp := Defining_Identifier (Decl); 10324 10325 -- If Build_Actual_Subtype generated a new declaration then use it 10326 10327 if Atyp /= Typ then 10328 10329 -- The actual subtype is an Itype, so analyze the declaration, 10330 -- but do not attach it to the tree, to get the type defined. 10331 10332 Set_Parent (Decl, N); 10333 Set_Is_Itype (Atyp); 10334 Analyze (Decl, Suppress => All_Checks); 10335 Set_Associated_Node_For_Itype (Atyp, N); 10336 Set_Has_Delayed_Freeze (Atyp, False); 10337 10338 -- We need to freeze the actual subtype immediately. This is 10339 -- needed, because otherwise this Itype will not get frozen 10340 -- at all, and it is always safe to freeze on creation because 10341 -- any associated types must be frozen at this point. 10342 10343 Freeze_Itype (Atyp, N); 10344 return Atyp; 10345 10346 -- Otherwise we did not build a declaration, so return original 10347 10348 else 10349 return Typ; 10350 end if; 10351 end if; 10352 10353 -- For all remaining cases, the actual subtype is the same as 10354 -- the nominal type. 10355 10356 else 10357 return Typ; 10358 end if; 10359 end Get_Actual_Subtype; 10360 10361 ------------------------------------- 10362 -- Get_Actual_Subtype_If_Available -- 10363 ------------------------------------- 10364 10365 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is 10366 Typ : constant Entity_Id := Etype (N); 10367 10368 begin 10369 -- If what we have is an identifier that references a subprogram 10370 -- formal, or a variable or constant object, then we get the actual 10371 -- subtype from the referenced entity if one has been built. 10372 10373 if Nkind (N) = N_Identifier 10374 and then 10375 (Is_Formal (Entity (N)) 10376 or else Ekind (Entity (N)) = E_Constant 10377 or else Ekind (Entity (N)) = E_Variable) 10378 and then Present (Actual_Subtype (Entity (N))) 10379 then 10380 return Actual_Subtype (Entity (N)); 10381 10382 -- Otherwise the Etype of N is returned unchanged 10383 10384 else 10385 return Typ; 10386 end if; 10387 end Get_Actual_Subtype_If_Available; 10388 10389 ------------------------ 10390 -- Get_Body_From_Stub -- 10391 ------------------------ 10392 10393 function Get_Body_From_Stub (N : Node_Id) return Node_Id is 10394 begin 10395 return Proper_Body (Unit (Library_Unit (N))); 10396 end Get_Body_From_Stub; 10397 10398 --------------------- 10399 -- Get_Cursor_Type -- 10400 --------------------- 10401 10402 function Get_Cursor_Type 10403 (Aspect : Node_Id; 10404 Typ : Entity_Id) return Entity_Id 10405 is 10406 Assoc : Node_Id; 10407 Func : Entity_Id; 10408 First_Op : Entity_Id; 10409 Cursor : Entity_Id; 10410 10411 begin 10412 -- If error already detected, return 10413 10414 if Error_Posted (Aspect) then 10415 return Any_Type; 10416 end if; 10417 10418 -- The cursor type for an Iterable aspect is the return type of a 10419 -- non-overloaded First primitive operation. Locate association for 10420 -- First. 10421 10422 Assoc := First (Component_Associations (Expression (Aspect))); 10423 First_Op := Any_Id; 10424 while Present (Assoc) loop 10425 if Chars (First (Choices (Assoc))) = Name_First then 10426 First_Op := Expression (Assoc); 10427 exit; 10428 end if; 10429 10430 Next (Assoc); 10431 end loop; 10432 10433 if First_Op = Any_Id then 10434 Error_Msg_N ("aspect Iterable must specify First operation", Aspect); 10435 return Any_Type; 10436 10437 elsif not Analyzed (First_Op) then 10438 Analyze (First_Op); 10439 end if; 10440 10441 Cursor := Any_Type; 10442 10443 -- Locate function with desired name and profile in scope of type 10444 -- In the rare case where the type is an integer type, a base type 10445 -- is created for it, check that the base type of the first formal 10446 -- of First matches the base type of the domain. 10447 10448 Func := First_Entity (Scope (Typ)); 10449 while Present (Func) loop 10450 if Chars (Func) = Chars (First_Op) 10451 and then Ekind (Func) = E_Function 10452 and then Present (First_Formal (Func)) 10453 and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ) 10454 and then No (Next_Formal (First_Formal (Func))) 10455 then 10456 if Cursor /= Any_Type then 10457 Error_Msg_N 10458 ("operation First for iterable type must be unique", Aspect); 10459 return Any_Type; 10460 else 10461 Cursor := Etype (Func); 10462 end if; 10463 end if; 10464 10465 Next_Entity (Func); 10466 end loop; 10467 10468 -- If not found, no way to resolve remaining primitives 10469 10470 if Cursor = Any_Type then 10471 Error_Msg_N 10472 ("primitive operation for Iterable type must appear in the same " 10473 & "list of declarations as the type", Aspect); 10474 end if; 10475 10476 return Cursor; 10477 end Get_Cursor_Type; 10478 10479 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is 10480 begin 10481 return Etype (Get_Iterable_Type_Primitive (Typ, Name_First)); 10482 end Get_Cursor_Type; 10483 10484 ------------------------------- 10485 -- Get_Default_External_Name -- 10486 ------------------------------- 10487 10488 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is 10489 begin 10490 Get_Decoded_Name_String (Chars (E)); 10491 10492 if Opt.External_Name_Imp_Casing = Uppercase then 10493 Set_Casing (All_Upper_Case); 10494 else 10495 Set_Casing (All_Lower_Case); 10496 end if; 10497 10498 return 10499 Make_String_Literal (Sloc (E), 10500 Strval => String_From_Name_Buffer); 10501 end Get_Default_External_Name; 10502 10503 -------------------------- 10504 -- Get_Enclosing_Object -- 10505 -------------------------- 10506 10507 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is 10508 begin 10509 if Is_Entity_Name (N) then 10510 return Entity (N); 10511 else 10512 case Nkind (N) is 10513 when N_Indexed_Component 10514 | N_Selected_Component 10515 | N_Slice 10516 => 10517 -- If not generating code, a dereference may be left implicit. 10518 -- In thoses cases, return Empty. 10519 10520 if Is_Access_Type (Etype (Prefix (N))) then 10521 return Empty; 10522 else 10523 return Get_Enclosing_Object (Prefix (N)); 10524 end if; 10525 10526 when N_Type_Conversion => 10527 return Get_Enclosing_Object (Expression (N)); 10528 10529 when others => 10530 return Empty; 10531 end case; 10532 end if; 10533 end Get_Enclosing_Object; 10534 10535 --------------------------- 10536 -- Get_Enum_Lit_From_Pos -- 10537 --------------------------- 10538 10539 function Get_Enum_Lit_From_Pos 10540 (T : Entity_Id; 10541 Pos : Uint; 10542 Loc : Source_Ptr) return Node_Id 10543 is 10544 Btyp : Entity_Id := Base_Type (T); 10545 Lit : Node_Id; 10546 LLoc : Source_Ptr; 10547 10548 begin 10549 -- In the case where the literal is of type Character, Wide_Character 10550 -- or Wide_Wide_Character or of a type derived from them, there needs 10551 -- to be some special handling since there is no explicit chain of 10552 -- literals to search. Instead, an N_Character_Literal node is created 10553 -- with the appropriate Char_Code and Chars fields. 10554 10555 if Is_Standard_Character_Type (T) then 10556 Set_Character_Literal_Name (UI_To_CC (Pos)); 10557 10558 return 10559 Make_Character_Literal (Loc, 10560 Chars => Name_Find, 10561 Char_Literal_Value => Pos); 10562 10563 -- For all other cases, we have a complete table of literals, and 10564 -- we simply iterate through the chain of literal until the one 10565 -- with the desired position value is found. 10566 10567 else 10568 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then 10569 Btyp := Full_View (Btyp); 10570 end if; 10571 10572 Lit := First_Literal (Btyp); 10573 10574 -- Position in the enumeration type starts at 0 10575 10576 if Pos < 0 then 10577 raise Constraint_Error; 10578 end if; 10579 10580 for J in 1 .. UI_To_Int (Pos) loop 10581 Next_Literal (Lit); 10582 10583 -- If Lit is Empty, Pos is not in range, so raise Constraint_Error 10584 -- inside the loop to avoid calling Next_Literal on Empty. 10585 10586 if No (Lit) then 10587 raise Constraint_Error; 10588 end if; 10589 end loop; 10590 10591 -- Create a new node from Lit, with source location provided by Loc 10592 -- if not equal to No_Location, or by copying the source location of 10593 -- Lit otherwise. 10594 10595 LLoc := Loc; 10596 10597 if LLoc = No_Location then 10598 LLoc := Sloc (Lit); 10599 end if; 10600 10601 return New_Occurrence_Of (Lit, LLoc); 10602 end if; 10603 end Get_Enum_Lit_From_Pos; 10604 10605 ---------------------- 10606 -- Get_Fullest_View -- 10607 ---------------------- 10608 10609 function Get_Fullest_View 10610 (E : Entity_Id; Include_PAT : Boolean := True) return Entity_Id is 10611 begin 10612 -- Prevent cascaded errors 10613 10614 if No (E) then 10615 return E; 10616 end if; 10617 10618 -- Strictly speaking, the recursion below isn't necessary, but 10619 -- it's both simplest and safest. 10620 10621 case Ekind (E) is 10622 when Incomplete_Kind => 10623 if From_Limited_With (E) then 10624 return Get_Fullest_View (Non_Limited_View (E), Include_PAT); 10625 elsif Present (Full_View (E)) then 10626 return Get_Fullest_View (Full_View (E), Include_PAT); 10627 elsif Ekind (E) = E_Incomplete_Subtype then 10628 return Get_Fullest_View (Etype (E)); 10629 end if; 10630 10631 when Private_Kind => 10632 if Present (Underlying_Full_View (E)) then 10633 return 10634 Get_Fullest_View (Underlying_Full_View (E), Include_PAT); 10635 elsif Present (Full_View (E)) then 10636 return Get_Fullest_View (Full_View (E), Include_PAT); 10637 elsif Etype (E) /= E then 10638 return Get_Fullest_View (Etype (E), Include_PAT); 10639 end if; 10640 10641 when Array_Kind => 10642 if Include_PAT and then Present (Packed_Array_Impl_Type (E)) then 10643 return Get_Fullest_View (Packed_Array_Impl_Type (E)); 10644 end if; 10645 10646 when E_Record_Subtype => 10647 if Present (Cloned_Subtype (E)) then 10648 return Get_Fullest_View (Cloned_Subtype (E), Include_PAT); 10649 end if; 10650 10651 when E_Class_Wide_Type => 10652 return Get_Fullest_View (Root_Type (E), Include_PAT); 10653 10654 when E_Class_Wide_Subtype => 10655 if Present (Equivalent_Type (E)) then 10656 return Get_Fullest_View (Equivalent_Type (E), Include_PAT); 10657 elsif Present (Cloned_Subtype (E)) then 10658 return Get_Fullest_View (Cloned_Subtype (E), Include_PAT); 10659 end if; 10660 10661 when E_Protected_Type | E_Protected_Subtype 10662 | E_Task_Type | E_Task_Subtype => 10663 if Present (Corresponding_Record_Type (E)) then 10664 return Get_Fullest_View (Corresponding_Record_Type (E), 10665 Include_PAT); 10666 end if; 10667 10668 when E_Access_Protected_Subprogram_Type 10669 | E_Anonymous_Access_Protected_Subprogram_Type => 10670 if Present (Equivalent_Type (E)) then 10671 return Get_Fullest_View (Equivalent_Type (E), Include_PAT); 10672 end if; 10673 10674 when E_Access_Subtype => 10675 return Get_Fullest_View (Base_Type (E), Include_PAT); 10676 10677 when others => 10678 null; 10679 end case; 10680 10681 return E; 10682 end Get_Fullest_View; 10683 10684 ------------------------ 10685 -- Get_Generic_Entity -- 10686 ------------------------ 10687 10688 function Get_Generic_Entity (N : Node_Id) return Entity_Id is 10689 Ent : constant Entity_Id := Entity (Name (N)); 10690 begin 10691 if Present (Renamed_Object (Ent)) then 10692 return Renamed_Object (Ent); 10693 else 10694 return Ent; 10695 end if; 10696 end Get_Generic_Entity; 10697 10698 ------------------------------------- 10699 -- Get_Incomplete_View_Of_Ancestor -- 10700 ------------------------------------- 10701 10702 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is 10703 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 10704 Par_Scope : Entity_Id; 10705 Par_Type : Entity_Id; 10706 10707 begin 10708 -- The incomplete view of an ancestor is only relevant for private 10709 -- derived types in child units. 10710 10711 if not Is_Derived_Type (E) 10712 or else not Is_Child_Unit (Cur_Unit) 10713 then 10714 return Empty; 10715 10716 else 10717 Par_Scope := Scope (Cur_Unit); 10718 if No (Par_Scope) then 10719 return Empty; 10720 end if; 10721 10722 Par_Type := Etype (Base_Type (E)); 10723 10724 -- Traverse list of ancestor types until we find one declared in 10725 -- a parent or grandparent unit (two levels seem sufficient). 10726 10727 while Present (Par_Type) loop 10728 if Scope (Par_Type) = Par_Scope 10729 or else Scope (Par_Type) = Scope (Par_Scope) 10730 then 10731 return Par_Type; 10732 10733 elsif not Is_Derived_Type (Par_Type) then 10734 return Empty; 10735 10736 else 10737 Par_Type := Etype (Base_Type (Par_Type)); 10738 end if; 10739 end loop; 10740 10741 -- If none found, there is no relevant ancestor type. 10742 10743 return Empty; 10744 end if; 10745 end Get_Incomplete_View_Of_Ancestor; 10746 10747 ---------------------- 10748 -- Get_Index_Bounds -- 10749 ---------------------- 10750 10751 procedure Get_Index_Bounds 10752 (N : Node_Id; 10753 L : out Node_Id; 10754 H : out Node_Id; 10755 Use_Full_View : Boolean := False) 10756 is 10757 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id; 10758 -- Obtain the scalar range of type Typ. If flag Use_Full_View is set and 10759 -- Typ qualifies, the scalar range is obtained from the full view of the 10760 -- type. 10761 10762 -------------------------- 10763 -- Scalar_Range_Of_Type -- 10764 -------------------------- 10765 10766 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id is 10767 T : Entity_Id := Typ; 10768 10769 begin 10770 if Use_Full_View and then Present (Full_View (T)) then 10771 T := Full_View (T); 10772 end if; 10773 10774 return Scalar_Range (T); 10775 end Scalar_Range_Of_Type; 10776 10777 -- Local variables 10778 10779 Kind : constant Node_Kind := Nkind (N); 10780 Rng : Node_Id; 10781 10782 -- Start of processing for Get_Index_Bounds 10783 10784 begin 10785 if Kind = N_Range then 10786 L := Low_Bound (N); 10787 H := High_Bound (N); 10788 10789 elsif Kind = N_Subtype_Indication then 10790 Rng := Range_Expression (Constraint (N)); 10791 10792 if Rng = Error then 10793 L := Error; 10794 H := Error; 10795 return; 10796 10797 else 10798 L := Low_Bound (Range_Expression (Constraint (N))); 10799 H := High_Bound (Range_Expression (Constraint (N))); 10800 end if; 10801 10802 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then 10803 Rng := Scalar_Range_Of_Type (Entity (N)); 10804 10805 if Error_Posted (Rng) then 10806 L := Error; 10807 H := Error; 10808 10809 elsif Nkind (Rng) = N_Subtype_Indication then 10810 Get_Index_Bounds (Rng, L, H); 10811 10812 else 10813 L := Low_Bound (Rng); 10814 H := High_Bound (Rng); 10815 end if; 10816 10817 else 10818 -- N is an expression, indicating a range with one value 10819 10820 L := N; 10821 H := N; 10822 end if; 10823 end Get_Index_Bounds; 10824 10825 ----------------------------- 10826 -- Get_Interfacing_Aspects -- 10827 ----------------------------- 10828 10829 procedure Get_Interfacing_Aspects 10830 (Iface_Asp : Node_Id; 10831 Conv_Asp : out Node_Id; 10832 EN_Asp : out Node_Id; 10833 Expo_Asp : out Node_Id; 10834 Imp_Asp : out Node_Id; 10835 LN_Asp : out Node_Id; 10836 Do_Checks : Boolean := False) 10837 is 10838 procedure Save_Or_Duplication_Error 10839 (Asp : Node_Id; 10840 To : in out Node_Id); 10841 -- Save the value of aspect Asp in node To. If To already has a value, 10842 -- then this is considered a duplicate use of aspect. Emit an error if 10843 -- flag Do_Checks is set. 10844 10845 ------------------------------- 10846 -- Save_Or_Duplication_Error -- 10847 ------------------------------- 10848 10849 procedure Save_Or_Duplication_Error 10850 (Asp : Node_Id; 10851 To : in out Node_Id) 10852 is 10853 begin 10854 -- Detect an extra aspect and issue an error 10855 10856 if Present (To) then 10857 if Do_Checks then 10858 Error_Msg_Name_1 := Chars (Identifier (Asp)); 10859 Error_Msg_Sloc := Sloc (To); 10860 Error_Msg_N ("aspect % previously given #", Asp); 10861 end if; 10862 10863 -- Otherwise capture the aspect 10864 10865 else 10866 To := Asp; 10867 end if; 10868 end Save_Or_Duplication_Error; 10869 10870 -- Local variables 10871 10872 Asp : Node_Id; 10873 Asp_Id : Aspect_Id; 10874 10875 -- The following variables capture each individual aspect 10876 10877 Conv : Node_Id := Empty; 10878 EN : Node_Id := Empty; 10879 Expo : Node_Id := Empty; 10880 Imp : Node_Id := Empty; 10881 LN : Node_Id := Empty; 10882 10883 -- Start of processing for Get_Interfacing_Aspects 10884 10885 begin 10886 -- The input interfacing aspect should reside in an aspect specification 10887 -- list. 10888 10889 pragma Assert (Is_List_Member (Iface_Asp)); 10890 10891 -- Examine the aspect specifications of the related entity. Find and 10892 -- capture all interfacing aspects. Detect duplicates and emit errors 10893 -- if applicable. 10894 10895 Asp := First (List_Containing (Iface_Asp)); 10896 while Present (Asp) loop 10897 Asp_Id := Get_Aspect_Id (Asp); 10898 10899 if Asp_Id = Aspect_Convention then 10900 Save_Or_Duplication_Error (Asp, Conv); 10901 10902 elsif Asp_Id = Aspect_External_Name then 10903 Save_Or_Duplication_Error (Asp, EN); 10904 10905 elsif Asp_Id = Aspect_Export then 10906 Save_Or_Duplication_Error (Asp, Expo); 10907 10908 elsif Asp_Id = Aspect_Import then 10909 Save_Or_Duplication_Error (Asp, Imp); 10910 10911 elsif Asp_Id = Aspect_Link_Name then 10912 Save_Or_Duplication_Error (Asp, LN); 10913 end if; 10914 10915 Next (Asp); 10916 end loop; 10917 10918 Conv_Asp := Conv; 10919 EN_Asp := EN; 10920 Expo_Asp := Expo; 10921 Imp_Asp := Imp; 10922 LN_Asp := LN; 10923 end Get_Interfacing_Aspects; 10924 10925 --------------------------------- 10926 -- Get_Iterable_Type_Primitive -- 10927 --------------------------------- 10928 10929 function Get_Iterable_Type_Primitive 10930 (Typ : Entity_Id; 10931 Nam : Name_Id) return Entity_Id 10932 is 10933 pragma Assert 10934 (Is_Type (Typ) 10935 and then 10936 Nam in Name_Element 10937 | Name_First 10938 | Name_Has_Element 10939 | Name_Last 10940 | Name_Next 10941 | Name_Previous); 10942 10943 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable); 10944 Assoc : Node_Id; 10945 10946 begin 10947 if No (Funcs) then 10948 return Empty; 10949 10950 else 10951 Assoc := First (Component_Associations (Funcs)); 10952 while Present (Assoc) loop 10953 if Chars (First (Choices (Assoc))) = Nam then 10954 return Entity (Expression (Assoc)); 10955 end if; 10956 10957 Next (Assoc); 10958 end loop; 10959 10960 return Empty; 10961 end if; 10962 end Get_Iterable_Type_Primitive; 10963 10964 ---------------------------------- 10965 -- Get_Library_Unit_Name_String -- 10966 ---------------------------------- 10967 10968 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is 10969 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node); 10970 10971 begin 10972 Get_Unit_Name_String (Unit_Name_Id); 10973 10974 -- Remove seven last character (" (spec)" or " (body)") 10975 10976 Name_Len := Name_Len - 7; 10977 pragma Assert (Name_Buffer (Name_Len + 1) = ' '); 10978 end Get_Library_Unit_Name_String; 10979 10980 -------------------------- 10981 -- Get_Max_Queue_Length -- 10982 -------------------------- 10983 10984 function Get_Max_Queue_Length (Id : Entity_Id) return Uint is 10985 pragma Assert (Is_Entry (Id)); 10986 Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length); 10987 Max : Uint; 10988 10989 begin 10990 -- A value of 0 or -1 represents no maximum specified, and entries and 10991 -- entry families with no Max_Queue_Length aspect or pragma default to 10992 -- it. 10993 10994 if not Present (Prag) then 10995 return Uint_0; 10996 end if; 10997 10998 Max := Expr_Value 10999 (Expression (First (Pragma_Argument_Associations (Prag)))); 11000 11001 -- Since -1 and 0 are equivalent, return 0 for instances of -1 for 11002 -- uniformity. 11003 11004 if Max = -1 then 11005 return Uint_0; 11006 end if; 11007 11008 return Max; 11009 end Get_Max_Queue_Length; 11010 11011 ------------------------ 11012 -- Get_Name_Entity_Id -- 11013 ------------------------ 11014 11015 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is 11016 begin 11017 return Entity_Id (Get_Name_Table_Int (Id)); 11018 end Get_Name_Entity_Id; 11019 11020 ------------------------------ 11021 -- Get_Name_From_CTC_Pragma -- 11022 ------------------------------ 11023 11024 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is 11025 Arg : constant Node_Id := 11026 Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 11027 begin 11028 return Strval (Expr_Value_S (Arg)); 11029 end Get_Name_From_CTC_Pragma; 11030 11031 ----------------------- 11032 -- Get_Parent_Entity -- 11033 ----------------------- 11034 11035 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is 11036 begin 11037 if Nkind (Unit) = N_Package_Body 11038 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation 11039 then 11040 return Defining_Entity 11041 (Specification (Instance_Spec (Original_Node (Unit)))); 11042 elsif Nkind (Unit) = N_Package_Instantiation then 11043 return Defining_Entity (Specification (Instance_Spec (Unit))); 11044 else 11045 return Defining_Entity (Unit); 11046 end if; 11047 end Get_Parent_Entity; 11048 11049 ------------------- 11050 -- Get_Pragma_Id -- 11051 ------------------- 11052 11053 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is 11054 begin 11055 return Get_Pragma_Id (Pragma_Name_Unmapped (N)); 11056 end Get_Pragma_Id; 11057 11058 ------------------------ 11059 -- Get_Qualified_Name -- 11060 ------------------------ 11061 11062 function Get_Qualified_Name 11063 (Id : Entity_Id; 11064 Suffix : Entity_Id := Empty) return Name_Id 11065 is 11066 Suffix_Nam : Name_Id := No_Name; 11067 11068 begin 11069 if Present (Suffix) then 11070 Suffix_Nam := Chars (Suffix); 11071 end if; 11072 11073 return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id)); 11074 end Get_Qualified_Name; 11075 11076 function Get_Qualified_Name 11077 (Nam : Name_Id; 11078 Suffix : Name_Id := No_Name; 11079 Scop : Entity_Id := Current_Scope) return Name_Id 11080 is 11081 procedure Add_Scope (S : Entity_Id); 11082 -- Add the fully qualified form of scope S to the name buffer. The 11083 -- format is: 11084 -- s-1__s__ 11085 11086 --------------- 11087 -- Add_Scope -- 11088 --------------- 11089 11090 procedure Add_Scope (S : Entity_Id) is 11091 begin 11092 if S = Empty then 11093 null; 11094 11095 elsif S = Standard_Standard then 11096 null; 11097 11098 else 11099 Add_Scope (Scope (S)); 11100 Get_Name_String_And_Append (Chars (S)); 11101 Add_Str_To_Name_Buffer ("__"); 11102 end if; 11103 end Add_Scope; 11104 11105 -- Start of processing for Get_Qualified_Name 11106 11107 begin 11108 Name_Len := 0; 11109 Add_Scope (Scop); 11110 11111 -- Append the base name after all scopes have been chained 11112 11113 Get_Name_String_And_Append (Nam); 11114 11115 -- Append the suffix (if present) 11116 11117 if Suffix /= No_Name then 11118 Add_Str_To_Name_Buffer ("__"); 11119 Get_Name_String_And_Append (Suffix); 11120 end if; 11121 11122 return Name_Find; 11123 end Get_Qualified_Name; 11124 11125 ----------------------- 11126 -- Get_Reason_String -- 11127 ----------------------- 11128 11129 procedure Get_Reason_String (N : Node_Id) is 11130 begin 11131 if Nkind (N) = N_String_Literal then 11132 Store_String_Chars (Strval (N)); 11133 11134 elsif Nkind (N) = N_Op_Concat then 11135 Get_Reason_String (Left_Opnd (N)); 11136 Get_Reason_String (Right_Opnd (N)); 11137 11138 -- If not of required form, error 11139 11140 else 11141 Error_Msg_N 11142 ("Reason for pragma Warnings has wrong form", N); 11143 Error_Msg_N 11144 ("\must be string literal or concatenation of string literals", N); 11145 return; 11146 end if; 11147 end Get_Reason_String; 11148 11149 -------------------------------- 11150 -- Get_Reference_Discriminant -- 11151 -------------------------------- 11152 11153 function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is 11154 D : Entity_Id; 11155 11156 begin 11157 D := First_Discriminant (Typ); 11158 while Present (D) loop 11159 if Has_Implicit_Dereference (D) then 11160 return D; 11161 end if; 11162 Next_Discriminant (D); 11163 end loop; 11164 11165 return Empty; 11166 end Get_Reference_Discriminant; 11167 11168 --------------------------- 11169 -- Get_Referenced_Object -- 11170 --------------------------- 11171 11172 function Get_Referenced_Object (N : Node_Id) return Node_Id is 11173 R : Node_Id; 11174 11175 begin 11176 R := N; 11177 while Is_Entity_Name (R) 11178 and then Is_Object (Entity (R)) 11179 and then Present (Renamed_Object (Entity (R))) 11180 loop 11181 R := Renamed_Object (Entity (R)); 11182 end loop; 11183 11184 return R; 11185 end Get_Referenced_Object; 11186 11187 ------------------------ 11188 -- Get_Renamed_Entity -- 11189 ------------------------ 11190 11191 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is 11192 R : Entity_Id; 11193 11194 begin 11195 R := E; 11196 while Present (Renamed_Entity (R)) loop 11197 R := Renamed_Entity (R); 11198 end loop; 11199 11200 return R; 11201 end Get_Renamed_Entity; 11202 11203 ----------------------- 11204 -- Get_Return_Object -- 11205 ----------------------- 11206 11207 function Get_Return_Object (N : Node_Id) return Entity_Id is 11208 Decl : Node_Id; 11209 11210 begin 11211 Decl := First (Return_Object_Declarations (N)); 11212 while Present (Decl) loop 11213 exit when Nkind (Decl) = N_Object_Declaration 11214 and then Is_Return_Object (Defining_Identifier (Decl)); 11215 Next (Decl); 11216 end loop; 11217 11218 pragma Assert (Present (Decl)); 11219 return Defining_Identifier (Decl); 11220 end Get_Return_Object; 11221 11222 --------------------------- 11223 -- Get_Subprogram_Entity -- 11224 --------------------------- 11225 11226 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is 11227 Subp : Node_Id; 11228 Subp_Id : Entity_Id; 11229 11230 begin 11231 if Nkind (Nod) = N_Accept_Statement then 11232 Subp := Entry_Direct_Name (Nod); 11233 11234 elsif Nkind (Nod) = N_Slice then 11235 Subp := Prefix (Nod); 11236 11237 else 11238 Subp := Name (Nod); 11239 end if; 11240 11241 -- Strip the subprogram call 11242 11243 loop 11244 if Nkind (Subp) in N_Explicit_Dereference 11245 | N_Indexed_Component 11246 | N_Selected_Component 11247 then 11248 Subp := Prefix (Subp); 11249 11250 elsif Nkind (Subp) in N_Type_Conversion 11251 | N_Unchecked_Type_Conversion 11252 then 11253 Subp := Expression (Subp); 11254 11255 else 11256 exit; 11257 end if; 11258 end loop; 11259 11260 -- Extract the entity of the subprogram call 11261 11262 if Is_Entity_Name (Subp) then 11263 Subp_Id := Entity (Subp); 11264 11265 if Ekind (Subp_Id) = E_Access_Subprogram_Type then 11266 Subp_Id := Directly_Designated_Type (Subp_Id); 11267 end if; 11268 11269 if Is_Subprogram (Subp_Id) then 11270 return Subp_Id; 11271 else 11272 return Empty; 11273 end if; 11274 11275 -- The search did not find a construct that denotes a subprogram 11276 11277 else 11278 return Empty; 11279 end if; 11280 end Get_Subprogram_Entity; 11281 11282 ----------------------------- 11283 -- Get_Task_Body_Procedure -- 11284 ----------------------------- 11285 11286 function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is 11287 begin 11288 -- Note: A task type may be the completion of a private type with 11289 -- discriminants. When performing elaboration checks on a task 11290 -- declaration, the current view of the type may be the private one, 11291 -- and the procedure that holds the body of the task is held in its 11292 -- underlying type. 11293 11294 -- This is an odd function, why not have Task_Body_Procedure do 11295 -- the following digging??? 11296 11297 return Task_Body_Procedure (Underlying_Type (Root_Type (E))); 11298 end Get_Task_Body_Procedure; 11299 11300 ------------------------- 11301 -- Get_User_Defined_Eq -- 11302 ------------------------- 11303 11304 function Get_User_Defined_Eq (E : Entity_Id) return Entity_Id is 11305 Prim : Elmt_Id; 11306 Op : Entity_Id; 11307 11308 begin 11309 Prim := First_Elmt (Collect_Primitive_Operations (E)); 11310 while Present (Prim) loop 11311 Op := Node (Prim); 11312 11313 if Chars (Op) = Name_Op_Eq 11314 and then Etype (Op) = Standard_Boolean 11315 and then Etype (First_Formal (Op)) = E 11316 and then Etype (Next_Formal (First_Formal (Op))) = E 11317 then 11318 return Op; 11319 end if; 11320 11321 Next_Elmt (Prim); 11322 end loop; 11323 11324 return Empty; 11325 end Get_User_Defined_Eq; 11326 11327 --------------- 11328 -- Get_Views -- 11329 --------------- 11330 11331 procedure Get_Views 11332 (Typ : Entity_Id; 11333 Priv_Typ : out Entity_Id; 11334 Full_Typ : out Entity_Id; 11335 UFull_Typ : out Entity_Id; 11336 CRec_Typ : out Entity_Id) 11337 is 11338 IP_View : Entity_Id; 11339 11340 begin 11341 -- Assume that none of the views can be recovered 11342 11343 Priv_Typ := Empty; 11344 Full_Typ := Empty; 11345 UFull_Typ := Empty; 11346 CRec_Typ := Empty; 11347 11348 -- The input type is the corresponding record type of a protected or a 11349 -- task type. 11350 11351 if Ekind (Typ) = E_Record_Type 11352 and then Is_Concurrent_Record_Type (Typ) 11353 then 11354 CRec_Typ := Typ; 11355 Full_Typ := Corresponding_Concurrent_Type (CRec_Typ); 11356 Priv_Typ := Incomplete_Or_Partial_View (Full_Typ); 11357 11358 -- Otherwise the input type denotes an arbitrary type 11359 11360 else 11361 IP_View := Incomplete_Or_Partial_View (Typ); 11362 11363 -- The input type denotes the full view of a private type 11364 11365 if Present (IP_View) then 11366 Priv_Typ := IP_View; 11367 Full_Typ := Typ; 11368 11369 -- The input type is a private type 11370 11371 elsif Is_Private_Type (Typ) then 11372 Priv_Typ := Typ; 11373 Full_Typ := Full_View (Priv_Typ); 11374 11375 -- Otherwise the input type does not have any views 11376 11377 else 11378 Full_Typ := Typ; 11379 end if; 11380 11381 if Present (Full_Typ) and then Is_Private_Type (Full_Typ) then 11382 UFull_Typ := Underlying_Full_View (Full_Typ); 11383 11384 if Present (UFull_Typ) 11385 and then Ekind (UFull_Typ) in E_Protected_Type | E_Task_Type 11386 then 11387 CRec_Typ := Corresponding_Record_Type (UFull_Typ); 11388 end if; 11389 11390 else 11391 if Present (Full_Typ) 11392 and then Ekind (Full_Typ) in E_Protected_Type | E_Task_Type 11393 then 11394 CRec_Typ := Corresponding_Record_Type (Full_Typ); 11395 end if; 11396 end if; 11397 end if; 11398 end Get_Views; 11399 11400 ----------------------- 11401 -- Has_Access_Values -- 11402 ----------------------- 11403 11404 function Has_Access_Values (T : Entity_Id) return Boolean is 11405 Typ : constant Entity_Id := Underlying_Type (T); 11406 11407 begin 11408 -- Case of a private type which is not completed yet. This can only 11409 -- happen in the case of a generic format type appearing directly, or 11410 -- as a component of the type to which this function is being applied 11411 -- at the top level. Return False in this case, since we certainly do 11412 -- not know that the type contains access types. 11413 11414 if No (Typ) then 11415 return False; 11416 11417 elsif Is_Access_Type (Typ) then 11418 return True; 11419 11420 elsif Is_Array_Type (Typ) then 11421 return Has_Access_Values (Component_Type (Typ)); 11422 11423 elsif Is_Record_Type (Typ) then 11424 declare 11425 Comp : Entity_Id; 11426 11427 begin 11428 -- Loop to check components 11429 11430 Comp := First_Component_Or_Discriminant (Typ); 11431 while Present (Comp) loop 11432 11433 -- Check for access component, tag field does not count, even 11434 -- though it is implemented internally using an access type. 11435 11436 if Has_Access_Values (Etype (Comp)) 11437 and then Chars (Comp) /= Name_uTag 11438 then 11439 return True; 11440 end if; 11441 11442 Next_Component_Or_Discriminant (Comp); 11443 end loop; 11444 end; 11445 11446 return False; 11447 11448 else 11449 return False; 11450 end if; 11451 end Has_Access_Values; 11452 11453 --------------------------------------- 11454 -- Has_Anonymous_Access_Discriminant -- 11455 --------------------------------------- 11456 11457 function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean 11458 is 11459 Disc : Node_Id; 11460 11461 begin 11462 if not Has_Discriminants (Typ) then 11463 return False; 11464 end if; 11465 11466 Disc := First_Discriminant (Typ); 11467 while Present (Disc) loop 11468 if Ekind (Etype (Disc)) = E_Anonymous_Access_Type then 11469 return True; 11470 end if; 11471 11472 Next_Discriminant (Disc); 11473 end loop; 11474 11475 return False; 11476 end Has_Anonymous_Access_Discriminant; 11477 11478 ------------------------------ 11479 -- Has_Compatible_Alignment -- 11480 ------------------------------ 11481 11482 function Has_Compatible_Alignment 11483 (Obj : Entity_Id; 11484 Expr : Node_Id; 11485 Layout_Done : Boolean) return Alignment_Result 11486 is 11487 function Has_Compatible_Alignment_Internal 11488 (Obj : Entity_Id; 11489 Expr : Node_Id; 11490 Layout_Done : Boolean; 11491 Default : Alignment_Result) return Alignment_Result; 11492 -- This is the internal recursive function that actually does the work. 11493 -- There is one additional parameter, which says what the result should 11494 -- be if no alignment information is found, and there is no definite 11495 -- indication of compatible alignments. At the outer level, this is set 11496 -- to Unknown, but for internal recursive calls in the case where types 11497 -- are known to be correct, it is set to Known_Compatible. 11498 11499 --------------------------------------- 11500 -- Has_Compatible_Alignment_Internal -- 11501 --------------------------------------- 11502 11503 function Has_Compatible_Alignment_Internal 11504 (Obj : Entity_Id; 11505 Expr : Node_Id; 11506 Layout_Done : Boolean; 11507 Default : Alignment_Result) return Alignment_Result 11508 is 11509 Result : Alignment_Result := Known_Compatible; 11510 -- Holds the current status of the result. Note that once a value of 11511 -- Known_Incompatible is set, it is sticky and does not get changed 11512 -- to Unknown (the value in Result only gets worse as we go along, 11513 -- never better). 11514 11515 Offs : Uint := No_Uint; 11516 -- Set to a factor of the offset from the base object when Expr is a 11517 -- selected or indexed component, based on Component_Bit_Offset and 11518 -- Component_Size respectively. A negative value is used to represent 11519 -- a value which is not known at compile time. 11520 11521 procedure Check_Prefix; 11522 -- Checks the prefix recursively in the case where the expression 11523 -- is an indexed or selected component. 11524 11525 procedure Set_Result (R : Alignment_Result); 11526 -- If R represents a worse outcome (unknown instead of known 11527 -- compatible, or known incompatible), then set Result to R. 11528 11529 ------------------ 11530 -- Check_Prefix -- 11531 ------------------ 11532 11533 procedure Check_Prefix is 11534 begin 11535 -- The subtlety here is that in doing a recursive call to check 11536 -- the prefix, we have to decide what to do in the case where we 11537 -- don't find any specific indication of an alignment problem. 11538 11539 -- At the outer level, we normally set Unknown as the result in 11540 -- this case, since we can only set Known_Compatible if we really 11541 -- know that the alignment value is OK, but for the recursive 11542 -- call, in the case where the types match, and we have not 11543 -- specified a peculiar alignment for the object, we are only 11544 -- concerned about suspicious rep clauses, the default case does 11545 -- not affect us, since the compiler will, in the absence of such 11546 -- rep clauses, ensure that the alignment is correct. 11547 11548 if Default = Known_Compatible 11549 or else 11550 (Etype (Obj) = Etype (Expr) 11551 and then (Unknown_Alignment (Obj) 11552 or else 11553 Alignment (Obj) = Alignment (Etype (Obj)))) 11554 then 11555 Set_Result 11556 (Has_Compatible_Alignment_Internal 11557 (Obj, Prefix (Expr), Layout_Done, Known_Compatible)); 11558 11559 -- In all other cases, we need a full check on the prefix 11560 11561 else 11562 Set_Result 11563 (Has_Compatible_Alignment_Internal 11564 (Obj, Prefix (Expr), Layout_Done, Unknown)); 11565 end if; 11566 end Check_Prefix; 11567 11568 ---------------- 11569 -- Set_Result -- 11570 ---------------- 11571 11572 procedure Set_Result (R : Alignment_Result) is 11573 begin 11574 if R > Result then 11575 Result := R; 11576 end if; 11577 end Set_Result; 11578 11579 -- Start of processing for Has_Compatible_Alignment_Internal 11580 11581 begin 11582 -- If Expr is a selected component, we must make sure there is no 11583 -- potentially troublesome component clause and that the record is 11584 -- not packed if the layout is not done. 11585 11586 if Nkind (Expr) = N_Selected_Component then 11587 11588 -- Packing generates unknown alignment if layout is not done 11589 11590 if Is_Packed (Etype (Prefix (Expr))) and then not Layout_Done then 11591 Set_Result (Unknown); 11592 end if; 11593 11594 -- Check prefix and component offset 11595 11596 Check_Prefix; 11597 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr))); 11598 11599 -- If Expr is an indexed component, we must make sure there is no 11600 -- potentially troublesome Component_Size clause and that the array 11601 -- is not bit-packed if the layout is not done. 11602 11603 elsif Nkind (Expr) = N_Indexed_Component then 11604 declare 11605 Typ : constant Entity_Id := Etype (Prefix (Expr)); 11606 11607 begin 11608 -- Packing generates unknown alignment if layout is not done 11609 11610 if Is_Bit_Packed_Array (Typ) and then not Layout_Done then 11611 Set_Result (Unknown); 11612 end if; 11613 11614 -- Check prefix and component offset (or at least size) 11615 11616 Check_Prefix; 11617 Offs := Indexed_Component_Bit_Offset (Expr); 11618 if Offs = No_Uint then 11619 Offs := Component_Size (Typ); 11620 end if; 11621 end; 11622 end if; 11623 11624 -- If we have a null offset, the result is entirely determined by 11625 -- the base object and has already been computed recursively. 11626 11627 if Offs = Uint_0 then 11628 null; 11629 11630 -- Case where we know the alignment of the object 11631 11632 elsif Known_Alignment (Obj) then 11633 declare 11634 ObjA : constant Uint := Alignment (Obj); 11635 ExpA : Uint := No_Uint; 11636 SizA : Uint := No_Uint; 11637 11638 begin 11639 -- If alignment of Obj is 1, then we are always OK 11640 11641 if ObjA = 1 then 11642 Set_Result (Known_Compatible); 11643 11644 -- Alignment of Obj is greater than 1, so we need to check 11645 11646 else 11647 -- If we have an offset, see if it is compatible 11648 11649 if Offs /= No_Uint and Offs > Uint_0 then 11650 if Offs mod (System_Storage_Unit * ObjA) /= 0 then 11651 Set_Result (Known_Incompatible); 11652 end if; 11653 11654 -- See if Expr is an object with known alignment 11655 11656 elsif Is_Entity_Name (Expr) 11657 and then Known_Alignment (Entity (Expr)) 11658 then 11659 ExpA := Alignment (Entity (Expr)); 11660 11661 -- Otherwise, we can use the alignment of the type of 11662 -- Expr given that we already checked for 11663 -- discombobulating rep clauses for the cases of indexed 11664 -- and selected components above. 11665 11666 elsif Known_Alignment (Etype (Expr)) then 11667 ExpA := Alignment (Etype (Expr)); 11668 11669 -- Otherwise the alignment is unknown 11670 11671 else 11672 Set_Result (Default); 11673 end if; 11674 11675 -- If we got an alignment, see if it is acceptable 11676 11677 if ExpA /= No_Uint and then ExpA < ObjA then 11678 Set_Result (Known_Incompatible); 11679 end if; 11680 11681 -- If Expr is not a piece of a larger object, see if size 11682 -- is given. If so, check that it is not too small for the 11683 -- required alignment. 11684 11685 if Offs /= No_Uint then 11686 null; 11687 11688 -- See if Expr is an object with known size 11689 11690 elsif Is_Entity_Name (Expr) 11691 and then Known_Static_Esize (Entity (Expr)) 11692 then 11693 SizA := Esize (Entity (Expr)); 11694 11695 -- Otherwise, we check the object size of the Expr type 11696 11697 elsif Known_Static_Esize (Etype (Expr)) then 11698 SizA := Esize (Etype (Expr)); 11699 end if; 11700 11701 -- If we got a size, see if it is a multiple of the Obj 11702 -- alignment, if not, then the alignment cannot be 11703 -- acceptable, since the size is always a multiple of the 11704 -- alignment. 11705 11706 if SizA /= No_Uint then 11707 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then 11708 Set_Result (Known_Incompatible); 11709 end if; 11710 end if; 11711 end if; 11712 end; 11713 11714 -- If we do not know required alignment, any non-zero offset is a 11715 -- potential problem (but certainly may be OK, so result is unknown). 11716 11717 elsif Offs /= No_Uint then 11718 Set_Result (Unknown); 11719 11720 -- If we can't find the result by direct comparison of alignment 11721 -- values, then there is still one case that we can determine known 11722 -- result, and that is when we can determine that the types are the 11723 -- same, and no alignments are specified. Then we known that the 11724 -- alignments are compatible, even if we don't know the alignment 11725 -- value in the front end. 11726 11727 elsif Etype (Obj) = Etype (Expr) then 11728 11729 -- Types are the same, but we have to check for possible size 11730 -- and alignments on the Expr object that may make the alignment 11731 -- different, even though the types are the same. 11732 11733 if Is_Entity_Name (Expr) then 11734 11735 -- First check alignment of the Expr object. Any alignment less 11736 -- than Maximum_Alignment is worrisome since this is the case 11737 -- where we do not know the alignment of Obj. 11738 11739 if Known_Alignment (Entity (Expr)) 11740 and then UI_To_Int (Alignment (Entity (Expr))) < 11741 Ttypes.Maximum_Alignment 11742 then 11743 Set_Result (Unknown); 11744 11745 -- Now check size of Expr object. Any size that is not an 11746 -- even multiple of Maximum_Alignment is also worrisome 11747 -- since it may cause the alignment of the object to be less 11748 -- than the alignment of the type. 11749 11750 elsif Known_Static_Esize (Entity (Expr)) 11751 and then 11752 (UI_To_Int (Esize (Entity (Expr))) mod 11753 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)) 11754 /= 0 11755 then 11756 Set_Result (Unknown); 11757 11758 -- Otherwise same type is decisive 11759 11760 else 11761 Set_Result (Known_Compatible); 11762 end if; 11763 end if; 11764 11765 -- Another case to deal with is when there is an explicit size or 11766 -- alignment clause when the types are not the same. If so, then the 11767 -- result is Unknown. We don't need to do this test if the Default is 11768 -- Unknown, since that result will be set in any case. 11769 11770 elsif Default /= Unknown 11771 and then (Has_Size_Clause (Etype (Expr)) 11772 or else 11773 Has_Alignment_Clause (Etype (Expr))) 11774 then 11775 Set_Result (Unknown); 11776 11777 -- If no indication found, set default 11778 11779 else 11780 Set_Result (Default); 11781 end if; 11782 11783 -- Return worst result found 11784 11785 return Result; 11786 end Has_Compatible_Alignment_Internal; 11787 11788 -- Start of processing for Has_Compatible_Alignment 11789 11790 begin 11791 -- If Obj has no specified alignment, then set alignment from the type 11792 -- alignment. Perhaps we should always do this, but for sure we should 11793 -- do it when there is an address clause since we can do more if the 11794 -- alignment is known. 11795 11796 if Unknown_Alignment (Obj) then 11797 Set_Alignment (Obj, Alignment (Etype (Obj))); 11798 end if; 11799 11800 -- Now do the internal call that does all the work 11801 11802 return 11803 Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown); 11804 end Has_Compatible_Alignment; 11805 11806 ---------------------- 11807 -- Has_Declarations -- 11808 ---------------------- 11809 11810 function Has_Declarations (N : Node_Id) return Boolean is 11811 begin 11812 return Nkind (N) in N_Accept_Statement 11813 | N_Block_Statement 11814 | N_Compilation_Unit_Aux 11815 | N_Entry_Body 11816 | N_Package_Body 11817 | N_Protected_Body 11818 | N_Subprogram_Body 11819 | N_Task_Body 11820 | N_Package_Specification; 11821 end Has_Declarations; 11822 11823 --------------------------------- 11824 -- Has_Defaulted_Discriminants -- 11825 --------------------------------- 11826 11827 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is 11828 begin 11829 return Has_Discriminants (Typ) 11830 and then Present (First_Discriminant (Typ)) 11831 and then Present (Discriminant_Default_Value 11832 (First_Discriminant (Typ))); 11833 end Has_Defaulted_Discriminants; 11834 11835 ------------------- 11836 -- Has_Denormals -- 11837 ------------------- 11838 11839 function Has_Denormals (E : Entity_Id) return Boolean is 11840 begin 11841 return Is_Floating_Point_Type (E) and then Denorm_On_Target; 11842 end Has_Denormals; 11843 11844 ------------------------------------------- 11845 -- Has_Discriminant_Dependent_Constraint -- 11846 ------------------------------------------- 11847 11848 function Has_Discriminant_Dependent_Constraint 11849 (Comp : Entity_Id) return Boolean 11850 is 11851 Comp_Decl : constant Node_Id := Parent (Comp); 11852 Subt_Indic : Node_Id; 11853 Constr : Node_Id; 11854 Assn : Node_Id; 11855 11856 begin 11857 -- Discriminants can't depend on discriminants 11858 11859 if Ekind (Comp) = E_Discriminant then 11860 return False; 11861 11862 else 11863 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl)); 11864 11865 if Nkind (Subt_Indic) = N_Subtype_Indication then 11866 Constr := Constraint (Subt_Indic); 11867 11868 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then 11869 Assn := First (Constraints (Constr)); 11870 while Present (Assn) loop 11871 case Nkind (Assn) is 11872 when N_Identifier 11873 | N_Range 11874 | N_Subtype_Indication 11875 => 11876 if Depends_On_Discriminant (Assn) then 11877 return True; 11878 end if; 11879 11880 when N_Discriminant_Association => 11881 if Depends_On_Discriminant (Expression (Assn)) then 11882 return True; 11883 end if; 11884 11885 when others => 11886 null; 11887 end case; 11888 11889 Next (Assn); 11890 end loop; 11891 end if; 11892 end if; 11893 end if; 11894 11895 return False; 11896 end Has_Discriminant_Dependent_Constraint; 11897 11898 -------------------------------------- 11899 -- Has_Effectively_Volatile_Profile -- 11900 -------------------------------------- 11901 11902 function Has_Effectively_Volatile_Profile 11903 (Subp_Id : Entity_Id) return Boolean 11904 is 11905 Formal : Entity_Id; 11906 11907 begin 11908 -- Inspect the formal parameters looking for an effectively volatile 11909 -- type for reading. 11910 11911 Formal := First_Formal (Subp_Id); 11912 while Present (Formal) loop 11913 if Is_Effectively_Volatile_For_Reading (Etype (Formal)) then 11914 return True; 11915 end if; 11916 11917 Next_Formal (Formal); 11918 end loop; 11919 11920 -- Inspect the return type of functions 11921 11922 if Ekind (Subp_Id) in E_Function | E_Generic_Function 11923 and then Is_Effectively_Volatile_For_Reading (Etype (Subp_Id)) 11924 then 11925 return True; 11926 end if; 11927 11928 return False; 11929 end Has_Effectively_Volatile_Profile; 11930 11931 -------------------------- 11932 -- Has_Enabled_Property -- 11933 -------------------------- 11934 11935 function Has_Enabled_Property 11936 (Item_Id : Entity_Id; 11937 Property : Name_Id) return Boolean 11938 is 11939 function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean; 11940 -- Determine whether a protected type or variable denoted by Item_Id 11941 -- has the property enabled. 11942 11943 function State_Has_Enabled_Property return Boolean; 11944 -- Determine whether a state denoted by Item_Id has the property enabled 11945 11946 function Type_Or_Variable_Has_Enabled_Property 11947 (Item_Id : Entity_Id) return Boolean; 11948 -- Determine whether type or variable denoted by Item_Id has the 11949 -- property enabled. 11950 11951 ----------------------------------------------------- 11952 -- Protected_Type_Or_Variable_Has_Enabled_Property -- 11953 ----------------------------------------------------- 11954 11955 function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean 11956 is 11957 begin 11958 -- Protected entities always have the properties Async_Readers and 11959 -- Async_Writers (SPARK RM 7.1.2(16)). 11960 11961 if Property = Name_Async_Readers 11962 or else Property = Name_Async_Writers 11963 then 11964 return True; 11965 11966 -- Protected objects that have Part_Of components also inherit their 11967 -- properties Effective_Reads and Effective_Writes 11968 -- (SPARK RM 7.1.2(16)). 11969 11970 elsif Is_Single_Protected_Object (Item_Id) then 11971 declare 11972 Constit_Elmt : Elmt_Id; 11973 Constit_Id : Entity_Id; 11974 Constits : constant Elist_Id 11975 := Part_Of_Constituents (Item_Id); 11976 begin 11977 if Present (Constits) then 11978 Constit_Elmt := First_Elmt (Constits); 11979 while Present (Constit_Elmt) loop 11980 Constit_Id := Node (Constit_Elmt); 11981 11982 if Has_Enabled_Property (Constit_Id, Property) then 11983 return True; 11984 end if; 11985 11986 Next_Elmt (Constit_Elmt); 11987 end loop; 11988 end if; 11989 end; 11990 end if; 11991 11992 return False; 11993 end Protected_Type_Or_Variable_Has_Enabled_Property; 11994 11995 -------------------------------- 11996 -- State_Has_Enabled_Property -- 11997 -------------------------------- 11998 11999 function State_Has_Enabled_Property return Boolean is 12000 Decl : constant Node_Id := Parent (Item_Id); 12001 12002 procedure Find_Simple_Properties 12003 (Has_External : out Boolean; 12004 Has_Synchronous : out Boolean); 12005 -- Extract the simple properties associated with declaration Decl 12006 12007 function Is_Enabled_External_Property return Boolean; 12008 -- Determine whether property Property appears within the external 12009 -- property list of declaration Decl, and return its status. 12010 12011 ---------------------------- 12012 -- Find_Simple_Properties -- 12013 ---------------------------- 12014 12015 procedure Find_Simple_Properties 12016 (Has_External : out Boolean; 12017 Has_Synchronous : out Boolean) 12018 is 12019 Opt : Node_Id; 12020 12021 begin 12022 -- Assume that none of the properties are available 12023 12024 Has_External := False; 12025 Has_Synchronous := False; 12026 12027 Opt := First (Expressions (Decl)); 12028 while Present (Opt) loop 12029 if Nkind (Opt) = N_Identifier then 12030 if Chars (Opt) = Name_External then 12031 Has_External := True; 12032 12033 elsif Chars (Opt) = Name_Synchronous then 12034 Has_Synchronous := True; 12035 end if; 12036 end if; 12037 12038 Next (Opt); 12039 end loop; 12040 end Find_Simple_Properties; 12041 12042 ---------------------------------- 12043 -- Is_Enabled_External_Property -- 12044 ---------------------------------- 12045 12046 function Is_Enabled_External_Property return Boolean is 12047 Opt : Node_Id; 12048 Opt_Nam : Node_Id; 12049 Prop : Node_Id; 12050 Prop_Nam : Node_Id; 12051 Props : Node_Id; 12052 12053 begin 12054 Opt := First (Component_Associations (Decl)); 12055 while Present (Opt) loop 12056 Opt_Nam := First (Choices (Opt)); 12057 12058 if Nkind (Opt_Nam) = N_Identifier 12059 and then Chars (Opt_Nam) = Name_External 12060 then 12061 Props := Expression (Opt); 12062 12063 -- Multiple properties appear as an aggregate 12064 12065 if Nkind (Props) = N_Aggregate then 12066 12067 -- Simple property form 12068 12069 Prop := First (Expressions (Props)); 12070 while Present (Prop) loop 12071 if Chars (Prop) = Property then 12072 return True; 12073 end if; 12074 12075 Next (Prop); 12076 end loop; 12077 12078 -- Property with expression form 12079 12080 Prop := First (Component_Associations (Props)); 12081 while Present (Prop) loop 12082 Prop_Nam := First (Choices (Prop)); 12083 12084 -- The property can be represented in two ways: 12085 -- others => <value> 12086 -- <property> => <value> 12087 12088 if Nkind (Prop_Nam) = N_Others_Choice 12089 or else (Nkind (Prop_Nam) = N_Identifier 12090 and then Chars (Prop_Nam) = Property) 12091 then 12092 return Is_True (Expr_Value (Expression (Prop))); 12093 end if; 12094 12095 Next (Prop); 12096 end loop; 12097 12098 -- Single property 12099 12100 else 12101 return Chars (Props) = Property; 12102 end if; 12103 end if; 12104 12105 Next (Opt); 12106 end loop; 12107 12108 return False; 12109 end Is_Enabled_External_Property; 12110 12111 -- Local variables 12112 12113 Has_External : Boolean; 12114 Has_Synchronous : Boolean; 12115 12116 -- Start of processing for State_Has_Enabled_Property 12117 12118 begin 12119 -- The declaration of an external abstract state appears as an 12120 -- extension aggregate. If this is not the case, properties can 12121 -- never be set. 12122 12123 if Nkind (Decl) /= N_Extension_Aggregate then 12124 return False; 12125 end if; 12126 12127 Find_Simple_Properties (Has_External, Has_Synchronous); 12128 12129 -- Simple option External enables all properties (SPARK RM 7.1.2(2)) 12130 12131 if Has_External then 12132 return True; 12133 12134 -- Option External may enable or disable specific properties 12135 12136 elsif Is_Enabled_External_Property then 12137 return True; 12138 12139 -- Simple option Synchronous 12140 -- 12141 -- enables disables 12142 -- Async_Readers Effective_Reads 12143 -- Async_Writers Effective_Writes 12144 -- 12145 -- Note that both forms of External have higher precedence than 12146 -- Synchronous (SPARK RM 7.1.4(9)). 12147 12148 elsif Has_Synchronous then 12149 return Property in Name_Async_Readers | Name_Async_Writers; 12150 end if; 12151 12152 return False; 12153 end State_Has_Enabled_Property; 12154 12155 ------------------------------------------- 12156 -- Type_Or_Variable_Has_Enabled_Property -- 12157 ------------------------------------------- 12158 12159 function Type_Or_Variable_Has_Enabled_Property 12160 (Item_Id : Entity_Id) return Boolean 12161 is 12162 function Is_Enabled (Prag : Node_Id) return Boolean; 12163 -- Determine whether property pragma Prag (if present) denotes an 12164 -- enabled property. 12165 12166 ---------------- 12167 -- Is_Enabled -- 12168 ---------------- 12169 12170 function Is_Enabled (Prag : Node_Id) return Boolean is 12171 Arg1 : Node_Id; 12172 12173 begin 12174 if Present (Prag) then 12175 Arg1 := First (Pragma_Argument_Associations (Prag)); 12176 12177 -- The pragma has an optional Boolean expression, the related 12178 -- property is enabled only when the expression evaluates to 12179 -- True. 12180 12181 if Present (Arg1) then 12182 return Is_True (Expr_Value (Get_Pragma_Arg (Arg1))); 12183 12184 -- Otherwise the lack of expression enables the property by 12185 -- default. 12186 12187 else 12188 return True; 12189 end if; 12190 12191 -- The property was never set in the first place 12192 12193 else 12194 return False; 12195 end if; 12196 end Is_Enabled; 12197 12198 -- Local variables 12199 12200 AR : constant Node_Id := 12201 Get_Pragma (Item_Id, Pragma_Async_Readers); 12202 AW : constant Node_Id := 12203 Get_Pragma (Item_Id, Pragma_Async_Writers); 12204 ER : constant Node_Id := 12205 Get_Pragma (Item_Id, Pragma_Effective_Reads); 12206 EW : constant Node_Id := 12207 Get_Pragma (Item_Id, Pragma_Effective_Writes); 12208 12209 Is_Derived_Type_With_Volatile_Parent_Type : constant Boolean := 12210 Is_Derived_Type (Item_Id) 12211 and then Is_Effectively_Volatile (Etype (Base_Type (Item_Id))); 12212 12213 -- Start of processing for Type_Or_Variable_Has_Enabled_Property 12214 12215 begin 12216 -- A non-effectively volatile object can never possess external 12217 -- properties. 12218 12219 if not Is_Effectively_Volatile (Item_Id) then 12220 return False; 12221 12222 -- External properties related to variables come in two flavors - 12223 -- explicit and implicit. The explicit case is characterized by the 12224 -- presence of a property pragma with an optional Boolean flag. The 12225 -- property is enabled when the flag evaluates to True or the flag is 12226 -- missing altogether. 12227 12228 elsif Property = Name_Async_Readers and then Present (AR) then 12229 return Is_Enabled (AR); 12230 12231 elsif Property = Name_Async_Writers and then Present (AW) then 12232 return Is_Enabled (AW); 12233 12234 elsif Property = Name_Effective_Reads and then Present (ER) then 12235 return Is_Enabled (ER); 12236 12237 elsif Property = Name_Effective_Writes and then Present (EW) then 12238 return Is_Enabled (EW); 12239 12240 -- If other properties are set explicitly, then this one is set 12241 -- implicitly to False, except in the case of a derived type 12242 -- whose parent type is volatile (in that case, we will inherit 12243 -- from the parent type, below). 12244 12245 elsif (Present (AR) 12246 or else Present (AW) 12247 or else Present (ER) 12248 or else Present (EW)) 12249 and then not Is_Derived_Type_With_Volatile_Parent_Type 12250 then 12251 return False; 12252 12253 -- For a private type, may need to look at the full view 12254 12255 elsif Is_Private_Type (Item_Id) and then Present (Full_View (Item_Id)) 12256 then 12257 return Type_Or_Variable_Has_Enabled_Property (Full_View (Item_Id)); 12258 12259 -- For a derived type whose parent type is volatile, the 12260 -- property may be inherited (but ignore a non-volatile parent). 12261 12262 elsif Is_Derived_Type_With_Volatile_Parent_Type then 12263 return Type_Or_Variable_Has_Enabled_Property 12264 (First_Subtype (Etype (Base_Type (Item_Id)))); 12265 12266 -- If not specified explicitly for an object and the type 12267 -- is effectively volatile, then take result from the type. 12268 12269 elsif not Is_Type (Item_Id) 12270 and then Is_Effectively_Volatile (Etype (Item_Id)) 12271 then 12272 return Has_Enabled_Property (Etype (Item_Id), Property); 12273 12274 -- The implicit case lacks all property pragmas 12275 12276 elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then 12277 if Is_Protected_Type (Etype (Item_Id)) then 12278 return Protected_Type_Or_Variable_Has_Enabled_Property; 12279 else 12280 return True; 12281 end if; 12282 12283 else 12284 return False; 12285 end if; 12286 end Type_Or_Variable_Has_Enabled_Property; 12287 12288 -- Start of processing for Has_Enabled_Property 12289 12290 begin 12291 -- Abstract states and variables have a flexible scheme of specifying 12292 -- external properties. 12293 12294 if Ekind (Item_Id) = E_Abstract_State then 12295 return State_Has_Enabled_Property; 12296 12297 elsif Ekind (Item_Id) in E_Variable | E_Constant then 12298 return Type_Or_Variable_Has_Enabled_Property (Item_Id); 12299 12300 -- Other objects can only inherit properties through their type. We 12301 -- cannot call directly Type_Or_Variable_Has_Enabled_Property on 12302 -- these as they don't have contracts attached, which is expected by 12303 -- this function. 12304 12305 elsif Is_Object (Item_Id) then 12306 return Type_Or_Variable_Has_Enabled_Property (Etype (Item_Id)); 12307 12308 elsif Is_Type (Item_Id) then 12309 return Type_Or_Variable_Has_Enabled_Property 12310 (Item_Id => First_Subtype (Item_Id)); 12311 12312 -- Otherwise a property is enabled when the related item is effectively 12313 -- volatile. 12314 12315 else 12316 return Is_Effectively_Volatile (Item_Id); 12317 end if; 12318 end Has_Enabled_Property; 12319 12320 ------------------------------------- 12321 -- Has_Full_Default_Initialization -- 12322 ------------------------------------- 12323 12324 function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is 12325 Comp : Entity_Id; 12326 12327 begin 12328 -- A type subject to pragma Default_Initial_Condition may be fully 12329 -- default initialized depending on inheritance and the argument of 12330 -- the pragma. Since any type may act as the full view of a private 12331 -- type, this check must be performed prior to the specialized tests 12332 -- below. 12333 12334 if Has_Fully_Default_Initializing_DIC_Pragma (Typ) then 12335 return True; 12336 end if; 12337 12338 -- A scalar type is fully default initialized if it is subject to aspect 12339 -- Default_Value. 12340 12341 if Is_Scalar_Type (Typ) then 12342 return Has_Default_Aspect (Typ); 12343 12344 -- An access type is fully default initialized by default 12345 12346 elsif Is_Access_Type (Typ) then 12347 return True; 12348 12349 -- An array type is fully default initialized if its element type is 12350 -- scalar and the array type carries aspect Default_Component_Value or 12351 -- the element type is fully default initialized. 12352 12353 elsif Is_Array_Type (Typ) then 12354 return 12355 Has_Default_Aspect (Typ) 12356 or else Has_Full_Default_Initialization (Component_Type (Typ)); 12357 12358 -- A protected type, record type, or type extension is fully default 12359 -- initialized if all its components either carry an initialization 12360 -- expression or have a type that is fully default initialized. The 12361 -- parent type of a type extension must be fully default initialized. 12362 12363 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then 12364 12365 -- Inspect all entities defined in the scope of the type, looking for 12366 -- uninitialized components. 12367 12368 Comp := First_Component (Typ); 12369 while Present (Comp) loop 12370 if Comes_From_Source (Comp) 12371 and then No (Expression (Parent (Comp))) 12372 and then not Has_Full_Default_Initialization (Etype (Comp)) 12373 then 12374 return False; 12375 end if; 12376 12377 Next_Component (Comp); 12378 end loop; 12379 12380 -- Ensure that the parent type of a type extension is fully default 12381 -- initialized. 12382 12383 if Etype (Typ) /= Typ 12384 and then not Has_Full_Default_Initialization (Etype (Typ)) 12385 then 12386 return False; 12387 end if; 12388 12389 -- If we get here, then all components and parent portion are fully 12390 -- default initialized. 12391 12392 return True; 12393 12394 -- A task type is fully default initialized by default 12395 12396 elsif Is_Task_Type (Typ) then 12397 return True; 12398 12399 -- Otherwise the type is not fully default initialized 12400 12401 else 12402 return False; 12403 end if; 12404 end Has_Full_Default_Initialization; 12405 12406 ----------------------------------------------- 12407 -- Has_Fully_Default_Initializing_DIC_Pragma -- 12408 ----------------------------------------------- 12409 12410 function Has_Fully_Default_Initializing_DIC_Pragma 12411 (Typ : Entity_Id) return Boolean 12412 is 12413 Args : List_Id; 12414 Prag : Node_Id; 12415 12416 begin 12417 -- A type that inherits pragma Default_Initial_Condition from a parent 12418 -- type is automatically fully default initialized. 12419 12420 if Has_Inherited_DIC (Typ) then 12421 return True; 12422 12423 -- Otherwise the type is fully default initialized only when the pragma 12424 -- appears without an argument, or the argument is non-null. 12425 12426 elsif Has_Own_DIC (Typ) then 12427 Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition); 12428 pragma Assert (Present (Prag)); 12429 Args := Pragma_Argument_Associations (Prag); 12430 12431 -- The pragma appears without an argument in which case it defaults 12432 -- to True. 12433 12434 if No (Args) then 12435 return True; 12436 12437 -- The pragma appears with a non-null expression 12438 12439 elsif Nkind (Get_Pragma_Arg (First (Args))) /= N_Null then 12440 return True; 12441 end if; 12442 end if; 12443 12444 return False; 12445 end Has_Fully_Default_Initializing_DIC_Pragma; 12446 12447 -------------------- 12448 -- Has_Infinities -- 12449 -------------------- 12450 12451 function Has_Infinities (E : Entity_Id) return Boolean is 12452 begin 12453 return 12454 Is_Floating_Point_Type (E) 12455 and then Nkind (Scalar_Range (E)) = N_Range 12456 and then Includes_Infinities (Scalar_Range (E)); 12457 end Has_Infinities; 12458 12459 -------------------- 12460 -- Has_Interfaces -- 12461 -------------------- 12462 12463 function Has_Interfaces 12464 (T : Entity_Id; 12465 Use_Full_View : Boolean := True) return Boolean 12466 is 12467 Typ : Entity_Id := Base_Type (T); 12468 12469 begin 12470 -- Handle concurrent types 12471 12472 if Is_Concurrent_Type (Typ) then 12473 Typ := Corresponding_Record_Type (Typ); 12474 end if; 12475 12476 if not Present (Typ) 12477 or else not Is_Record_Type (Typ) 12478 or else not Is_Tagged_Type (Typ) 12479 then 12480 return False; 12481 end if; 12482 12483 -- Handle private types 12484 12485 if Use_Full_View and then Present (Full_View (Typ)) then 12486 Typ := Full_View (Typ); 12487 end if; 12488 12489 -- Handle concurrent record types 12490 12491 if Is_Concurrent_Record_Type (Typ) 12492 and then Is_Non_Empty_List (Abstract_Interface_List (Typ)) 12493 then 12494 return True; 12495 end if; 12496 12497 loop 12498 if Is_Interface (Typ) 12499 or else 12500 (Is_Record_Type (Typ) 12501 and then Present (Interfaces (Typ)) 12502 and then not Is_Empty_Elmt_List (Interfaces (Typ))) 12503 then 12504 return True; 12505 end if; 12506 12507 exit when Etype (Typ) = Typ 12508 12509 -- Handle private types 12510 12511 or else (Present (Full_View (Etype (Typ))) 12512 and then Full_View (Etype (Typ)) = Typ) 12513 12514 -- Protect frontend against wrong sources with cyclic derivations 12515 12516 or else Etype (Typ) = T; 12517 12518 -- Climb to the ancestor type handling private types 12519 12520 if Present (Full_View (Etype (Typ))) then 12521 Typ := Full_View (Etype (Typ)); 12522 else 12523 Typ := Etype (Typ); 12524 end if; 12525 end loop; 12526 12527 return False; 12528 end Has_Interfaces; 12529 12530 -------------------------- 12531 -- Has_Max_Queue_Length -- 12532 -------------------------- 12533 12534 function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is 12535 begin 12536 return 12537 Ekind (Id) = E_Entry 12538 and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length)); 12539 end Has_Max_Queue_Length; 12540 12541 --------------------------------- 12542 -- Has_No_Obvious_Side_Effects -- 12543 --------------------------------- 12544 12545 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is 12546 begin 12547 -- For now handle literals, constants, and non-volatile variables and 12548 -- expressions combining these with operators or short circuit forms. 12549 12550 if Nkind (N) in N_Numeric_Or_String_Literal then 12551 return True; 12552 12553 elsif Nkind (N) = N_Character_Literal then 12554 return True; 12555 12556 elsif Nkind (N) in N_Unary_Op then 12557 return Has_No_Obvious_Side_Effects (Right_Opnd (N)); 12558 12559 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then 12560 return Has_No_Obvious_Side_Effects (Left_Opnd (N)) 12561 and then 12562 Has_No_Obvious_Side_Effects (Right_Opnd (N)); 12563 12564 elsif Nkind (N) = N_Expression_With_Actions 12565 and then Is_Empty_List (Actions (N)) 12566 then 12567 return Has_No_Obvious_Side_Effects (Expression (N)); 12568 12569 elsif Nkind (N) in N_Has_Entity then 12570 return Present (Entity (N)) 12571 and then 12572 Ekind (Entity (N)) in 12573 E_Variable | E_Constant | E_Enumeration_Literal | 12574 E_In_Parameter | E_Out_Parameter | E_In_Out_Parameter 12575 and then not Is_Volatile (Entity (N)); 12576 12577 else 12578 return False; 12579 end if; 12580 end Has_No_Obvious_Side_Effects; 12581 12582 ----------------------------- 12583 -- Has_Non_Null_Refinement -- 12584 ----------------------------- 12585 12586 function Has_Non_Null_Refinement (Id : Entity_Id) return Boolean is 12587 Constits : Elist_Id; 12588 12589 begin 12590 pragma Assert (Ekind (Id) = E_Abstract_State); 12591 Constits := Refinement_Constituents (Id); 12592 12593 -- For a refinement to be non-null, the first constituent must be 12594 -- anything other than null. 12595 12596 return 12597 Present (Constits) 12598 and then Nkind (Node (First_Elmt (Constits))) /= N_Null; 12599 end Has_Non_Null_Refinement; 12600 12601 ----------------------------- 12602 -- Has_Non_Null_Statements -- 12603 ----------------------------- 12604 12605 function Has_Non_Null_Statements (L : List_Id) return Boolean is 12606 Node : Node_Id; 12607 12608 begin 12609 if Is_Non_Empty_List (L) then 12610 Node := First (L); 12611 12612 loop 12613 if Nkind (Node) not in N_Null_Statement | N_Call_Marker then 12614 return True; 12615 end if; 12616 12617 Next (Node); 12618 exit when Node = Empty; 12619 end loop; 12620 end if; 12621 12622 return False; 12623 end Has_Non_Null_Statements; 12624 12625 ---------------------------------- 12626 -- Is_Access_Subprogram_Wrapper -- 12627 ---------------------------------- 12628 12629 function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean is 12630 Formal : constant Entity_Id := Last_Formal (E); 12631 begin 12632 return Present (Formal) 12633 and then Ekind (Etype (Formal)) in Access_Subprogram_Kind 12634 and then Access_Subprogram_Wrapper 12635 (Directly_Designated_Type (Etype (Formal))) = E; 12636 end Is_Access_Subprogram_Wrapper; 12637 12638 --------------------------- 12639 -- Is_Explicitly_Aliased -- 12640 --------------------------- 12641 12642 function Is_Explicitly_Aliased (N : Node_Id) return Boolean is 12643 begin 12644 return Is_Formal (N) 12645 and then Present (Parent (N)) 12646 and then Nkind (Parent (N)) = N_Parameter_Specification 12647 and then Aliased_Present (Parent (N)); 12648 end Is_Explicitly_Aliased; 12649 12650 ---------------------------- 12651 -- Is_Container_Aggregate -- 12652 ---------------------------- 12653 12654 function Is_Container_Aggregate (Exp : Node_Id) return Boolean is 12655 12656 function Is_Record_Aggregate return Boolean is (False); 12657 -- ??? Unimplemented. Given an aggregate whose type is a 12658 -- record type with specified Aggregate aspect, how do we 12659 -- determine whether it is a record aggregate or a container 12660 -- aggregate? If the code where the aggregate occurs can see only 12661 -- a partial view of the aggregate's type then the aggregate 12662 -- cannot be a record type; an aggregate of a private type has to 12663 -- be a container aggregate. 12664 12665 begin 12666 return Nkind (Exp) = N_Aggregate 12667 and then Present (Find_Aspect (Etype (Exp), Aspect_Aggregate)) 12668 and then not Is_Record_Aggregate; 12669 end Is_Container_Aggregate; 12670 12671 --------------------------------- 12672 -- Side_Effect_Free_Statements -- 12673 --------------------------------- 12674 12675 function Side_Effect_Free_Statements (L : List_Id) return Boolean is 12676 Node : Node_Id; 12677 12678 begin 12679 if Is_Non_Empty_List (L) then 12680 Node := First (L); 12681 12682 loop 12683 case Nkind (Node) is 12684 when N_Null_Statement | N_Call_Marker | N_Raise_xxx_Error => 12685 null; 12686 when N_Object_Declaration => 12687 if Present (Expression (Node)) 12688 and then not Side_Effect_Free (Expression (Node)) 12689 then 12690 return False; 12691 end if; 12692 12693 when others => 12694 return False; 12695 end case; 12696 12697 Next (Node); 12698 exit when Node = Empty; 12699 end loop; 12700 end if; 12701 12702 return True; 12703 end Side_Effect_Free_Statements; 12704 12705 --------------------------- 12706 -- Side_Effect_Free_Loop -- 12707 --------------------------- 12708 12709 function Side_Effect_Free_Loop (N : Node_Id) return Boolean is 12710 Scheme : Node_Id; 12711 Spec : Node_Id; 12712 Subt : Node_Id; 12713 12714 begin 12715 -- If this is not a loop (e.g. because the loop has been rewritten), 12716 -- then return false. 12717 12718 if Nkind (N) /= N_Loop_Statement then 12719 return False; 12720 end if; 12721 12722 -- First check the statements 12723 12724 if Side_Effect_Free_Statements (Statements (N)) then 12725 12726 -- Then check the loop condition/indexes 12727 12728 if Present (Iteration_Scheme (N)) then 12729 Scheme := Iteration_Scheme (N); 12730 12731 if Present (Condition (Scheme)) 12732 or else Present (Iterator_Specification (Scheme)) 12733 then 12734 return False; 12735 elsif Present (Loop_Parameter_Specification (Scheme)) then 12736 Spec := Loop_Parameter_Specification (Scheme); 12737 Subt := Discrete_Subtype_Definition (Spec); 12738 12739 if Present (Subt) then 12740 if Nkind (Subt) = N_Range then 12741 return Side_Effect_Free (Low_Bound (Subt)) 12742 and then Side_Effect_Free (High_Bound (Subt)); 12743 else 12744 -- subtype indication 12745 12746 return True; 12747 end if; 12748 end if; 12749 end if; 12750 end if; 12751 end if; 12752 12753 return False; 12754 end Side_Effect_Free_Loop; 12755 12756 ---------------------------------- 12757 -- Has_Non_Trivial_Precondition -- 12758 ---------------------------------- 12759 12760 function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is 12761 Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre, 12762 Class_Present => True); 12763 begin 12764 return 12765 Present (Pre) 12766 and then not Is_Entity_Name (Expression (Pre)); 12767 end Has_Non_Trivial_Precondition; 12768 12769 ------------------- 12770 -- Has_Null_Body -- 12771 ------------------- 12772 12773 function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is 12774 Body_Id : Entity_Id; 12775 Decl : Node_Id; 12776 Spec : Node_Id; 12777 Stmt1 : Node_Id; 12778 Stmt2 : Node_Id; 12779 12780 begin 12781 Spec := Parent (Proc_Id); 12782 Decl := Parent (Spec); 12783 12784 -- Retrieve the entity of the procedure body (e.g. invariant proc). 12785 12786 if Nkind (Spec) = N_Procedure_Specification 12787 and then Nkind (Decl) = N_Subprogram_Declaration 12788 then 12789 Body_Id := Corresponding_Body (Decl); 12790 12791 -- The body acts as a spec 12792 12793 else 12794 Body_Id := Proc_Id; 12795 end if; 12796 12797 -- The body will be generated later 12798 12799 if No (Body_Id) then 12800 return False; 12801 end if; 12802 12803 Spec := Parent (Body_Id); 12804 Decl := Parent (Spec); 12805 12806 pragma Assert 12807 (Nkind (Spec) = N_Procedure_Specification 12808 and then Nkind (Decl) = N_Subprogram_Body); 12809 12810 Stmt1 := First (Statements (Handled_Statement_Sequence (Decl))); 12811 12812 -- Look for a null statement followed by an optional return 12813 -- statement. 12814 12815 if Nkind (Stmt1) = N_Null_Statement then 12816 Stmt2 := Next (Stmt1); 12817 12818 if Present (Stmt2) then 12819 return Nkind (Stmt2) = N_Simple_Return_Statement; 12820 else 12821 return True; 12822 end if; 12823 end if; 12824 12825 return False; 12826 end Has_Null_Body; 12827 12828 ------------------------ 12829 -- Has_Null_Exclusion -- 12830 ------------------------ 12831 12832 function Has_Null_Exclusion (N : Node_Id) return Boolean is 12833 begin 12834 case Nkind (N) is 12835 when N_Access_Definition 12836 | N_Access_Function_Definition 12837 | N_Access_Procedure_Definition 12838 | N_Access_To_Object_Definition 12839 | N_Allocator 12840 | N_Derived_Type_Definition 12841 | N_Function_Specification 12842 | N_Subtype_Declaration 12843 => 12844 return Null_Exclusion_Present (N); 12845 12846 when N_Component_Definition 12847 | N_Formal_Object_Declaration 12848 => 12849 if Present (Subtype_Mark (N)) then 12850 return Null_Exclusion_Present (N); 12851 else pragma Assert (Present (Access_Definition (N))); 12852 return Null_Exclusion_Present (Access_Definition (N)); 12853 end if; 12854 12855 when N_Object_Renaming_Declaration => 12856 if Present (Subtype_Mark (N)) then 12857 return Null_Exclusion_Present (N); 12858 elsif Present (Access_Definition (N)) then 12859 return Null_Exclusion_Present (Access_Definition (N)); 12860 else 12861 return False; -- Case of no subtype in renaming (AI12-0275) 12862 end if; 12863 12864 when N_Discriminant_Specification => 12865 if Nkind (Discriminant_Type (N)) = N_Access_Definition then 12866 return Null_Exclusion_Present (Discriminant_Type (N)); 12867 else 12868 return Null_Exclusion_Present (N); 12869 end if; 12870 12871 when N_Object_Declaration => 12872 if Nkind (Object_Definition (N)) = N_Access_Definition then 12873 return Null_Exclusion_Present (Object_Definition (N)); 12874 else 12875 return Null_Exclusion_Present (N); 12876 end if; 12877 12878 when N_Parameter_Specification => 12879 if Nkind (Parameter_Type (N)) = N_Access_Definition then 12880 return Null_Exclusion_Present (Parameter_Type (N)) 12881 or else Null_Exclusion_Present (N); 12882 else 12883 return Null_Exclusion_Present (N); 12884 end if; 12885 12886 when others => 12887 return False; 12888 end case; 12889 end Has_Null_Exclusion; 12890 12891 ------------------------ 12892 -- Has_Null_Extension -- 12893 ------------------------ 12894 12895 function Has_Null_Extension (T : Entity_Id) return Boolean is 12896 B : constant Entity_Id := Base_Type (T); 12897 Comps : Node_Id; 12898 Ext : Node_Id; 12899 12900 begin 12901 if Nkind (Parent (B)) = N_Full_Type_Declaration 12902 and then Present (Record_Extension_Part (Type_Definition (Parent (B)))) 12903 then 12904 Ext := Record_Extension_Part (Type_Definition (Parent (B))); 12905 12906 if Present (Ext) then 12907 if Null_Present (Ext) then 12908 return True; 12909 else 12910 Comps := Component_List (Ext); 12911 12912 -- The null component list is rewritten during analysis to 12913 -- include the parent component. Any other component indicates 12914 -- that the extension was not originally null. 12915 12916 return Null_Present (Comps) 12917 or else No (Next (First (Component_Items (Comps)))); 12918 end if; 12919 else 12920 return False; 12921 end if; 12922 12923 else 12924 return False; 12925 end if; 12926 end Has_Null_Extension; 12927 12928 ------------------------- 12929 -- Has_Null_Refinement -- 12930 ------------------------- 12931 12932 function Has_Null_Refinement (Id : Entity_Id) return Boolean is 12933 Constits : Elist_Id; 12934 12935 begin 12936 pragma Assert (Ekind (Id) = E_Abstract_State); 12937 Constits := Refinement_Constituents (Id); 12938 12939 -- For a refinement to be null, the state's sole constituent must be a 12940 -- null. 12941 12942 return 12943 Present (Constits) 12944 and then Nkind (Node (First_Elmt (Constits))) = N_Null; 12945 end Has_Null_Refinement; 12946 12947 ------------------------------- 12948 -- Has_Overriding_Initialize -- 12949 ------------------------------- 12950 12951 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is 12952 BT : constant Entity_Id := Base_Type (T); 12953 P : Elmt_Id; 12954 12955 begin 12956 if Is_Controlled (BT) then 12957 if Is_RTU (Scope (BT), Ada_Finalization) then 12958 return False; 12959 12960 elsif Present (Primitive_Operations (BT)) then 12961 P := First_Elmt (Primitive_Operations (BT)); 12962 while Present (P) loop 12963 declare 12964 Init : constant Entity_Id := Node (P); 12965 Formal : constant Entity_Id := First_Formal (Init); 12966 begin 12967 if Ekind (Init) = E_Procedure 12968 and then Chars (Init) = Name_Initialize 12969 and then Comes_From_Source (Init) 12970 and then Present (Formal) 12971 and then Etype (Formal) = BT 12972 and then No (Next_Formal (Formal)) 12973 and then (Ada_Version < Ada_2012 12974 or else not Null_Present (Parent (Init))) 12975 then 12976 return True; 12977 end if; 12978 end; 12979 12980 Next_Elmt (P); 12981 end loop; 12982 end if; 12983 12984 -- Here if type itself does not have a non-null Initialize operation: 12985 -- check immediate ancestor. 12986 12987 if Is_Derived_Type (BT) 12988 and then Has_Overriding_Initialize (Etype (BT)) 12989 then 12990 return True; 12991 end if; 12992 end if; 12993 12994 return False; 12995 end Has_Overriding_Initialize; 12996 12997 -------------------------------------- 12998 -- Has_Preelaborable_Initialization -- 12999 -------------------------------------- 13000 13001 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is 13002 Has_PE : Boolean; 13003 13004 procedure Check_Components (E : Entity_Id); 13005 -- Check component/discriminant chain, sets Has_PE False if a component 13006 -- or discriminant does not meet the preelaborable initialization rules. 13007 13008 ---------------------- 13009 -- Check_Components -- 13010 ---------------------- 13011 13012 procedure Check_Components (E : Entity_Id) is 13013 Ent : Entity_Id; 13014 Exp : Node_Id; 13015 13016 begin 13017 -- Loop through entities of record or protected type 13018 13019 Ent := E; 13020 while Present (Ent) loop 13021 13022 -- We are interested only in components and discriminants 13023 13024 Exp := Empty; 13025 13026 case Ekind (Ent) is 13027 when E_Component => 13028 13029 -- Get default expression if any. If there is no declaration 13030 -- node, it means we have an internal entity. The parent and 13031 -- tag fields are examples of such entities. For such cases, 13032 -- we just test the type of the entity. 13033 13034 if Present (Declaration_Node (Ent)) then 13035 Exp := Expression (Declaration_Node (Ent)); 13036 end if; 13037 13038 when E_Discriminant => 13039 13040 -- Note: for a renamed discriminant, the Declaration_Node 13041 -- may point to the one from the ancestor, and have a 13042 -- different expression, so use the proper attribute to 13043 -- retrieve the expression from the derived constraint. 13044 13045 Exp := Discriminant_Default_Value (Ent); 13046 13047 when others => 13048 goto Check_Next_Entity; 13049 end case; 13050 13051 -- A component has PI if it has no default expression and the 13052 -- component type has PI. 13053 13054 if No (Exp) then 13055 if not Has_Preelaborable_Initialization (Etype (Ent)) then 13056 Has_PE := False; 13057 exit; 13058 end if; 13059 13060 -- Require the default expression to be preelaborable 13061 13062 elsif not Is_Preelaborable_Construct (Exp) then 13063 Has_PE := False; 13064 exit; 13065 end if; 13066 13067 <<Check_Next_Entity>> 13068 Next_Entity (Ent); 13069 end loop; 13070 end Check_Components; 13071 13072 -- Start of processing for Has_Preelaborable_Initialization 13073 13074 begin 13075 -- Immediate return if already marked as known preelaborable init. This 13076 -- covers types for which this function has already been called once 13077 -- and returned True (in which case the result is cached), and also 13078 -- types to which a pragma Preelaborable_Initialization applies. 13079 13080 if Known_To_Have_Preelab_Init (E) then 13081 return True; 13082 end if; 13083 13084 -- If the type is a subtype representing a generic actual type, then 13085 -- test whether its base type has preelaborable initialization since 13086 -- the subtype representing the actual does not inherit this attribute 13087 -- from the actual or formal. (but maybe it should???) 13088 13089 if Is_Generic_Actual_Type (E) then 13090 return Has_Preelaborable_Initialization (Base_Type (E)); 13091 end if; 13092 13093 -- All elementary types have preelaborable initialization 13094 13095 if Is_Elementary_Type (E) then 13096 Has_PE := True; 13097 13098 -- Array types have PI if the component type has PI 13099 13100 elsif Is_Array_Type (E) then 13101 Has_PE := Has_Preelaborable_Initialization (Component_Type (E)); 13102 13103 -- A derived type has preelaborable initialization if its parent type 13104 -- has preelaborable initialization and (in the case of a derived record 13105 -- extension) if the non-inherited components all have preelaborable 13106 -- initialization. However, a user-defined controlled type with an 13107 -- overriding Initialize procedure does not have preelaborable 13108 -- initialization. 13109 13110 elsif Is_Derived_Type (E) then 13111 13112 -- If the derived type is a private extension then it doesn't have 13113 -- preelaborable initialization. 13114 13115 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then 13116 return False; 13117 end if; 13118 13119 -- First check whether ancestor type has preelaborable initialization 13120 13121 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E))); 13122 13123 -- If OK, check extension components (if any) 13124 13125 if Has_PE and then Is_Record_Type (E) then 13126 Check_Components (First_Entity (E)); 13127 end if; 13128 13129 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type 13130 -- with a user defined Initialize procedure does not have PI. If 13131 -- the type is untagged, the control primitives come from a component 13132 -- that has already been checked. 13133 13134 if Has_PE 13135 and then Is_Controlled (E) 13136 and then Is_Tagged_Type (E) 13137 and then Has_Overriding_Initialize (E) 13138 then 13139 Has_PE := False; 13140 end if; 13141 13142 -- Private types not derived from a type having preelaborable init and 13143 -- that are not marked with pragma Preelaborable_Initialization do not 13144 -- have preelaborable initialization. 13145 13146 elsif Is_Private_Type (E) then 13147 return False; 13148 13149 -- Record type has PI if it is non private and all components have PI 13150 13151 elsif Is_Record_Type (E) then 13152 Has_PE := True; 13153 Check_Components (First_Entity (E)); 13154 13155 -- Protected types must not have entries, and components must meet 13156 -- same set of rules as for record components. 13157 13158 elsif Is_Protected_Type (E) then 13159 if Has_Entries (E) then 13160 Has_PE := False; 13161 else 13162 Has_PE := True; 13163 Check_Components (First_Entity (E)); 13164 Check_Components (First_Private_Entity (E)); 13165 end if; 13166 13167 -- Type System.Address always has preelaborable initialization 13168 13169 elsif Is_RTE (E, RE_Address) then 13170 Has_PE := True; 13171 13172 -- In all other cases, type does not have preelaborable initialization 13173 13174 else 13175 return False; 13176 end if; 13177 13178 -- If type has preelaborable initialization, cache result 13179 13180 if Has_PE then 13181 Set_Known_To_Have_Preelab_Init (E); 13182 end if; 13183 13184 return Has_PE; 13185 end Has_Preelaborable_Initialization; 13186 13187 ---------------- 13188 -- Has_Prefix -- 13189 ---------------- 13190 13191 function Has_Prefix (N : Node_Id) return Boolean is 13192 begin 13193 return Nkind (N) in 13194 N_Attribute_Reference | N_Expanded_Name | N_Explicit_Dereference | 13195 N_Indexed_Component | N_Reference | N_Selected_Component | 13196 N_Slice; 13197 end Has_Prefix; 13198 13199 --------------------------- 13200 -- Has_Private_Component -- 13201 --------------------------- 13202 13203 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is 13204 Btype : Entity_Id := Base_Type (Type_Id); 13205 Component : Entity_Id; 13206 13207 begin 13208 if Error_Posted (Type_Id) 13209 or else Error_Posted (Btype) 13210 then 13211 return False; 13212 end if; 13213 13214 if Is_Class_Wide_Type (Btype) then 13215 Btype := Root_Type (Btype); 13216 end if; 13217 13218 if Is_Private_Type (Btype) then 13219 declare 13220 UT : constant Entity_Id := Underlying_Type (Btype); 13221 begin 13222 if No (UT) then 13223 if No (Full_View (Btype)) then 13224 return not Is_Generic_Type (Btype) 13225 and then 13226 not Is_Generic_Type (Root_Type (Btype)); 13227 else 13228 return not Is_Generic_Type (Root_Type (Full_View (Btype))); 13229 end if; 13230 else 13231 return not Is_Frozen (UT) and then Has_Private_Component (UT); 13232 end if; 13233 end; 13234 13235 elsif Is_Array_Type (Btype) then 13236 return Has_Private_Component (Component_Type (Btype)); 13237 13238 elsif Is_Record_Type (Btype) then 13239 Component := First_Component (Btype); 13240 while Present (Component) loop 13241 if Has_Private_Component (Etype (Component)) then 13242 return True; 13243 end if; 13244 13245 Next_Component (Component); 13246 end loop; 13247 13248 return False; 13249 13250 elsif Is_Protected_Type (Btype) 13251 and then Present (Corresponding_Record_Type (Btype)) 13252 then 13253 return Has_Private_Component (Corresponding_Record_Type (Btype)); 13254 13255 else 13256 return False; 13257 end if; 13258 end Has_Private_Component; 13259 13260 -------------------------------- 13261 -- Has_Relaxed_Initialization -- 13262 -------------------------------- 13263 13264 function Has_Relaxed_Initialization (E : Entity_Id) return Boolean is 13265 13266 function Denotes_Relaxed_Parameter 13267 (Expr : Node_Id; 13268 Param : Entity_Id) 13269 return Boolean; 13270 -- Returns True iff expression Expr denotes a formal parameter or 13271 -- function Param (through its attribute Result). 13272 13273 ------------------------------- 13274 -- Denotes_Relaxed_Parameter -- 13275 ------------------------------- 13276 13277 function Denotes_Relaxed_Parameter 13278 (Expr : Node_Id; 13279 Param : Entity_Id) return Boolean is 13280 begin 13281 if Nkind (Expr) in N_Identifier | N_Expanded_Name then 13282 return Entity (Expr) = Param; 13283 else 13284 pragma Assert (Is_Attribute_Result (Expr)); 13285 return Entity (Prefix (Expr)) = Param; 13286 end if; 13287 end Denotes_Relaxed_Parameter; 13288 13289 -- Start of processing for Has_Relaxed_Initialization 13290 13291 begin 13292 -- When analyzing, we checked all syntax legality rules for the aspect 13293 -- Relaxed_Initialization, but didn't store the property anywhere (e.g. 13294 -- as an Einfo flag). To query the property we look directly at the AST, 13295 -- but now without any syntactic checks. 13296 13297 case Ekind (E) is 13298 -- Abstract states have option Relaxed_Initialization 13299 13300 when E_Abstract_State => 13301 return Is_Relaxed_Initialization_State (E); 13302 13303 -- Constants have this aspect attached directly; for deferred 13304 -- constants, the aspect is attached to the partial view. 13305 13306 when E_Constant => 13307 return Has_Aspect (E, Aspect_Relaxed_Initialization); 13308 13309 -- Variables have this aspect attached directly 13310 13311 when E_Variable => 13312 return Has_Aspect (E, Aspect_Relaxed_Initialization); 13313 13314 -- Types have this aspect attached directly (though we only allow it 13315 -- to be specified for the first subtype). For private types, the 13316 -- aspect is attached to the partial view. 13317 13318 when Type_Kind => 13319 pragma Assert (Is_First_Subtype (E)); 13320 return Has_Aspect (E, Aspect_Relaxed_Initialization); 13321 13322 -- Formal parameters and functions have the Relaxed_Initialization 13323 -- aspect attached to the subprogram entity and must be listed in 13324 -- the aspect expression. 13325 13326 when Formal_Kind 13327 | E_Function 13328 => 13329 declare 13330 Subp_Id : Entity_Id; 13331 Aspect_Expr : Node_Id; 13332 Param_Expr : Node_Id; 13333 Assoc : Node_Id; 13334 13335 begin 13336 if Is_Formal (E) then 13337 Subp_Id := Scope (E); 13338 else 13339 Subp_Id := E; 13340 end if; 13341 13342 if Has_Aspect (Subp_Id, Aspect_Relaxed_Initialization) then 13343 Aspect_Expr := 13344 Find_Value_Of_Aspect 13345 (Subp_Id, Aspect_Relaxed_Initialization); 13346 13347 -- Aspect expression is either an aggregate with an optional 13348 -- Boolean expression (which defaults to True), e.g.: 13349 -- 13350 -- function F (X : Integer) return Integer 13351 -- with Relaxed_Initialization => (X => True, F'Result); 13352 13353 if Nkind (Aspect_Expr) = N_Aggregate then 13354 13355 if Present (Component_Associations (Aspect_Expr)) then 13356 Assoc := First (Component_Associations (Aspect_Expr)); 13357 13358 while Present (Assoc) loop 13359 if Denotes_Relaxed_Parameter 13360 (First (Choices (Assoc)), E) 13361 then 13362 return 13363 Is_True 13364 (Static_Boolean (Expression (Assoc))); 13365 end if; 13366 13367 Next (Assoc); 13368 end loop; 13369 end if; 13370 13371 Param_Expr := First (Expressions (Aspect_Expr)); 13372 13373 while Present (Param_Expr) loop 13374 if Denotes_Relaxed_Parameter (Param_Expr, E) then 13375 return True; 13376 end if; 13377 13378 Next (Param_Expr); 13379 end loop; 13380 13381 return False; 13382 13383 -- or it is a single identifier, e.g.: 13384 -- 13385 -- function F (X : Integer) return Integer 13386 -- with Relaxed_Initialization => X; 13387 13388 else 13389 return Denotes_Relaxed_Parameter (Aspect_Expr, E); 13390 end if; 13391 else 13392 return False; 13393 end if; 13394 end; 13395 13396 when others => 13397 raise Program_Error; 13398 end case; 13399 end Has_Relaxed_Initialization; 13400 13401 ---------------------- 13402 -- Has_Signed_Zeros -- 13403 ---------------------- 13404 13405 function Has_Signed_Zeros (E : Entity_Id) return Boolean is 13406 begin 13407 return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target; 13408 end Has_Signed_Zeros; 13409 13410 ------------------------------ 13411 -- Has_Significant_Contract -- 13412 ------------------------------ 13413 13414 function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is 13415 Subp_Nam : constant Name_Id := Chars (Subp_Id); 13416 13417 begin 13418 -- _Finalizer procedure 13419 13420 if Subp_Nam = Name_uFinalizer then 13421 return False; 13422 13423 -- _Postconditions procedure 13424 13425 elsif Subp_Nam = Name_uPostconditions then 13426 return False; 13427 13428 -- Predicate function 13429 13430 elsif Ekind (Subp_Id) = E_Function 13431 and then Is_Predicate_Function (Subp_Id) 13432 then 13433 return False; 13434 13435 -- TSS subprogram 13436 13437 elsif Get_TSS_Name (Subp_Id) /= TSS_Null then 13438 return False; 13439 13440 else 13441 return True; 13442 end if; 13443 end Has_Significant_Contract; 13444 13445 ----------------------------- 13446 -- Has_Static_Array_Bounds -- 13447 ----------------------------- 13448 13449 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is 13450 All_Static : Boolean; 13451 Dummy : Boolean; 13452 13453 begin 13454 Examine_Array_Bounds (Typ, All_Static, Dummy); 13455 13456 return All_Static; 13457 end Has_Static_Array_Bounds; 13458 13459 --------------------------------------- 13460 -- Has_Static_Non_Empty_Array_Bounds -- 13461 --------------------------------------- 13462 13463 function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean is 13464 All_Static : Boolean; 13465 Has_Empty : Boolean; 13466 13467 begin 13468 Examine_Array_Bounds (Typ, All_Static, Has_Empty); 13469 13470 return All_Static and not Has_Empty; 13471 end Has_Static_Non_Empty_Array_Bounds; 13472 13473 ---------------- 13474 -- Has_Stream -- 13475 ---------------- 13476 13477 function Has_Stream (T : Entity_Id) return Boolean is 13478 E : Entity_Id; 13479 13480 begin 13481 if No (T) then 13482 return False; 13483 13484 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then 13485 return True; 13486 13487 elsif Is_Array_Type (T) then 13488 return Has_Stream (Component_Type (T)); 13489 13490 elsif Is_Record_Type (T) then 13491 E := First_Component (T); 13492 while Present (E) loop 13493 if Has_Stream (Etype (E)) then 13494 return True; 13495 else 13496 Next_Component (E); 13497 end if; 13498 end loop; 13499 13500 return False; 13501 13502 elsif Is_Private_Type (T) then 13503 return Has_Stream (Underlying_Type (T)); 13504 13505 else 13506 return False; 13507 end if; 13508 end Has_Stream; 13509 13510 ---------------- 13511 -- Has_Suffix -- 13512 ---------------- 13513 13514 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is 13515 begin 13516 Get_Name_String (Chars (E)); 13517 return Name_Buffer (Name_Len) = Suffix; 13518 end Has_Suffix; 13519 13520 ---------------- 13521 -- Add_Suffix -- 13522 ---------------- 13523 13524 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is 13525 begin 13526 Get_Name_String (Chars (E)); 13527 Add_Char_To_Name_Buffer (Suffix); 13528 return Name_Find; 13529 end Add_Suffix; 13530 13531 ------------------- 13532 -- Remove_Suffix -- 13533 ------------------- 13534 13535 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is 13536 begin 13537 pragma Assert (Has_Suffix (E, Suffix)); 13538 Get_Name_String (Chars (E)); 13539 Name_Len := Name_Len - 1; 13540 return Name_Find; 13541 end Remove_Suffix; 13542 13543 ---------------------------------- 13544 -- Replace_Null_By_Null_Address -- 13545 ---------------------------------- 13546 13547 procedure Replace_Null_By_Null_Address (N : Node_Id) is 13548 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id); 13549 -- Replace operand Op with a reference to Null_Address when the operand 13550 -- denotes a null Address. Other_Op denotes the other operand. 13551 13552 -------------------------- 13553 -- Replace_Null_Operand -- 13554 -------------------------- 13555 13556 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id) is 13557 begin 13558 -- Check the type of the complementary operand since the N_Null node 13559 -- has not been decorated yet. 13560 13561 if Nkind (Op) = N_Null 13562 and then Is_Descendant_Of_Address (Etype (Other_Op)) 13563 then 13564 Rewrite (Op, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (Op))); 13565 end if; 13566 end Replace_Null_Operand; 13567 13568 -- Start of processing for Replace_Null_By_Null_Address 13569 13570 begin 13571 pragma Assert (Relaxed_RM_Semantics); 13572 pragma Assert 13573 (Nkind (N) in 13574 N_Null | N_Op_Eq | N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt | N_Op_Ne); 13575 13576 if Nkind (N) = N_Null then 13577 Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); 13578 13579 else 13580 declare 13581 L : constant Node_Id := Left_Opnd (N); 13582 R : constant Node_Id := Right_Opnd (N); 13583 13584 begin 13585 Replace_Null_Operand (L, Other_Op => R); 13586 Replace_Null_Operand (R, Other_Op => L); 13587 end; 13588 end if; 13589 end Replace_Null_By_Null_Address; 13590 13591 -------------------------- 13592 -- Has_Tagged_Component -- 13593 -------------------------- 13594 13595 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is 13596 Comp : Entity_Id; 13597 13598 begin 13599 if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then 13600 return Has_Tagged_Component (Underlying_Type (Typ)); 13601 13602 elsif Is_Array_Type (Typ) then 13603 return Has_Tagged_Component (Component_Type (Typ)); 13604 13605 elsif Is_Tagged_Type (Typ) then 13606 return True; 13607 13608 elsif Is_Record_Type (Typ) then 13609 Comp := First_Component (Typ); 13610 while Present (Comp) loop 13611 if Has_Tagged_Component (Etype (Comp)) then 13612 return True; 13613 end if; 13614 13615 Next_Component (Comp); 13616 end loop; 13617 13618 return False; 13619 13620 else 13621 return False; 13622 end if; 13623 end Has_Tagged_Component; 13624 13625 -------------------------------------------- 13626 -- Has_Unconstrained_Access_Discriminants -- 13627 -------------------------------------------- 13628 13629 function Has_Unconstrained_Access_Discriminants 13630 (Subtyp : Entity_Id) return Boolean 13631 is 13632 Discr : Entity_Id; 13633 13634 begin 13635 if Has_Discriminants (Subtyp) 13636 and then not Is_Constrained (Subtyp) 13637 then 13638 Discr := First_Discriminant (Subtyp); 13639 while Present (Discr) loop 13640 if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then 13641 return True; 13642 end if; 13643 13644 Next_Discriminant (Discr); 13645 end loop; 13646 end if; 13647 13648 return False; 13649 end Has_Unconstrained_Access_Discriminants; 13650 13651 ----------------------------- 13652 -- Has_Undefined_Reference -- 13653 ----------------------------- 13654 13655 function Has_Undefined_Reference (Expr : Node_Id) return Boolean is 13656 Has_Undef_Ref : Boolean := False; 13657 -- Flag set when expression Expr contains at least one undefined 13658 -- reference. 13659 13660 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result; 13661 -- Determine whether N denotes a reference and if it does, whether it is 13662 -- undefined. 13663 13664 ---------------------------- 13665 -- Is_Undefined_Reference -- 13666 ---------------------------- 13667 13668 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result is 13669 begin 13670 if Is_Entity_Name (N) 13671 and then Present (Entity (N)) 13672 and then Entity (N) = Any_Id 13673 then 13674 Has_Undef_Ref := True; 13675 return Abandon; 13676 end if; 13677 13678 return OK; 13679 end Is_Undefined_Reference; 13680 13681 procedure Find_Undefined_References is 13682 new Traverse_Proc (Is_Undefined_Reference); 13683 13684 -- Start of processing for Has_Undefined_Reference 13685 13686 begin 13687 Find_Undefined_References (Expr); 13688 13689 return Has_Undef_Ref; 13690 end Has_Undefined_Reference; 13691 13692 ---------------------------- 13693 -- Has_Volatile_Component -- 13694 ---------------------------- 13695 13696 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is 13697 Comp : Entity_Id; 13698 13699 begin 13700 if Has_Volatile_Components (Typ) then 13701 return True; 13702 13703 elsif Is_Array_Type (Typ) then 13704 return Is_Volatile (Component_Type (Typ)); 13705 13706 elsif Is_Record_Type (Typ) then 13707 Comp := First_Component (Typ); 13708 while Present (Comp) loop 13709 if Is_Volatile_Object (Comp) then 13710 return True; 13711 end if; 13712 13713 Next_Component (Comp); 13714 end loop; 13715 end if; 13716 13717 return False; 13718 end Has_Volatile_Component; 13719 13720 ------------------------- 13721 -- Implementation_Kind -- 13722 ------------------------- 13723 13724 function Implementation_Kind (Subp : Entity_Id) return Name_Id is 13725 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented); 13726 Arg : Node_Id; 13727 begin 13728 pragma Assert (Present (Impl_Prag)); 13729 Arg := Last (Pragma_Argument_Associations (Impl_Prag)); 13730 return Chars (Get_Pragma_Arg (Arg)); 13731 end Implementation_Kind; 13732 13733 -------------------------- 13734 -- Implements_Interface -- 13735 -------------------------- 13736 13737 function Implements_Interface 13738 (Typ_Ent : Entity_Id; 13739 Iface_Ent : Entity_Id; 13740 Exclude_Parents : Boolean := False) return Boolean 13741 is 13742 Ifaces_List : Elist_Id; 13743 Elmt : Elmt_Id; 13744 Iface : Entity_Id := Base_Type (Iface_Ent); 13745 Typ : Entity_Id := Base_Type (Typ_Ent); 13746 13747 begin 13748 if Is_Class_Wide_Type (Typ) then 13749 Typ := Root_Type (Typ); 13750 end if; 13751 13752 if not Has_Interfaces (Typ) then 13753 return False; 13754 end if; 13755 13756 if Is_Class_Wide_Type (Iface) then 13757 Iface := Root_Type (Iface); 13758 end if; 13759 13760 Collect_Interfaces (Typ, Ifaces_List); 13761 13762 Elmt := First_Elmt (Ifaces_List); 13763 while Present (Elmt) loop 13764 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True) 13765 and then Exclude_Parents 13766 then 13767 null; 13768 13769 elsif Node (Elmt) = Iface then 13770 return True; 13771 end if; 13772 13773 Next_Elmt (Elmt); 13774 end loop; 13775 13776 return False; 13777 end Implements_Interface; 13778 13779 -------------------------------- 13780 -- Implicitly_Designated_Type -- 13781 -------------------------------- 13782 13783 function Implicitly_Designated_Type (Typ : Entity_Id) return Entity_Id is 13784 Desig : constant Entity_Id := Designated_Type (Typ); 13785 13786 begin 13787 -- An implicit dereference is a legal occurrence of an incomplete type 13788 -- imported through a limited_with clause, if the full view is visible. 13789 13790 if Is_Incomplete_Type (Desig) 13791 and then From_Limited_With (Desig) 13792 and then not From_Limited_With (Scope (Desig)) 13793 and then 13794 (Is_Immediately_Visible (Scope (Desig)) 13795 or else 13796 (Is_Child_Unit (Scope (Desig)) 13797 and then Is_Visible_Lib_Unit (Scope (Desig)))) 13798 then 13799 return Available_View (Desig); 13800 else 13801 return Desig; 13802 end if; 13803 end Implicitly_Designated_Type; 13804 13805 ------------------------------------ 13806 -- In_Assertion_Expression_Pragma -- 13807 ------------------------------------ 13808 13809 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is 13810 Par : Node_Id; 13811 Prag : Node_Id := Empty; 13812 13813 begin 13814 -- Climb the parent chain looking for an enclosing pragma 13815 13816 Par := N; 13817 while Present (Par) loop 13818 if Nkind (Par) = N_Pragma then 13819 Prag := Par; 13820 exit; 13821 13822 -- Precondition-like pragmas are expanded into if statements, check 13823 -- the original node instead. 13824 13825 elsif Nkind (Original_Node (Par)) = N_Pragma then 13826 Prag := Original_Node (Par); 13827 exit; 13828 13829 -- The expansion of attribute 'Old generates a constant to capture 13830 -- the result of the prefix. If the parent traversal reaches 13831 -- one of these constants, then the node technically came from a 13832 -- postcondition-like pragma. Note that the Ekind is not tested here 13833 -- because N may be the expression of an object declaration which is 13834 -- currently being analyzed. Such objects carry Ekind of E_Void. 13835 13836 elsif Nkind (Par) = N_Object_Declaration 13837 and then Constant_Present (Par) 13838 and then Stores_Attribute_Old_Prefix (Defining_Entity (Par)) 13839 then 13840 return True; 13841 13842 -- Prevent the search from going too far 13843 13844 elsif Is_Body_Or_Package_Declaration (Par) then 13845 return False; 13846 end if; 13847 13848 Par := Parent (Par); 13849 end loop; 13850 13851 return 13852 Present (Prag) 13853 and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag)); 13854 end In_Assertion_Expression_Pragma; 13855 13856 ------------------- 13857 -- In_Check_Node -- 13858 ------------------- 13859 13860 function In_Check_Node (N : Node_Id) return Boolean is 13861 Par : Node_Id := Parent (N); 13862 begin 13863 while Present (Par) loop 13864 if Nkind (Par) in N_Raise_xxx_Error then 13865 return True; 13866 13867 -- Prevent the search from going too far 13868 13869 elsif Is_Body_Or_Package_Declaration (Par) then 13870 return False; 13871 13872 else 13873 Par := Parent (Par); 13874 end if; 13875 end loop; 13876 13877 return False; 13878 end In_Check_Node; 13879 13880 ------------------------------- 13881 -- In_Generic_Formal_Package -- 13882 ------------------------------- 13883 13884 function In_Generic_Formal_Package (E : Entity_Id) return Boolean is 13885 Par : Node_Id; 13886 13887 begin 13888 Par := Parent (E); 13889 while Present (Par) loop 13890 if Nkind (Par) = N_Formal_Package_Declaration 13891 or else Nkind (Original_Node (Par)) = N_Formal_Package_Declaration 13892 then 13893 return True; 13894 end if; 13895 13896 Par := Parent (Par); 13897 end loop; 13898 13899 return False; 13900 end In_Generic_Formal_Package; 13901 13902 ---------------------- 13903 -- In_Generic_Scope -- 13904 ---------------------- 13905 13906 function In_Generic_Scope (E : Entity_Id) return Boolean is 13907 S : Entity_Id; 13908 13909 begin 13910 S := Scope (E); 13911 while Present (S) and then S /= Standard_Standard loop 13912 if Is_Generic_Unit (S) then 13913 return True; 13914 end if; 13915 13916 S := Scope (S); 13917 end loop; 13918 13919 return False; 13920 end In_Generic_Scope; 13921 13922 ----------------- 13923 -- In_Instance -- 13924 ----------------- 13925 13926 function In_Instance return Boolean is 13927 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 13928 S : Entity_Id; 13929 13930 begin 13931 S := Current_Scope; 13932 while Present (S) and then S /= Standard_Standard loop 13933 if Is_Generic_Instance (S) then 13934 13935 -- A child instance is always compiled in the context of a parent 13936 -- instance. Nevertheless, its actuals must not be analyzed in an 13937 -- instance context. We detect this case by examining the current 13938 -- compilation unit, which must be a child instance, and checking 13939 -- that it has not been analyzed yet. 13940 13941 if Is_Child_Unit (Curr_Unit) 13942 and then Nkind (Unit (Cunit (Current_Sem_Unit))) = 13943 N_Package_Instantiation 13944 and then Ekind (Curr_Unit) = E_Void 13945 then 13946 return False; 13947 else 13948 return True; 13949 end if; 13950 end if; 13951 13952 S := Scope (S); 13953 end loop; 13954 13955 return False; 13956 end In_Instance; 13957 13958 ---------------------- 13959 -- In_Instance_Body -- 13960 ---------------------- 13961 13962 function In_Instance_Body return Boolean is 13963 S : Entity_Id; 13964 13965 begin 13966 S := Current_Scope; 13967 while Present (S) and then S /= Standard_Standard loop 13968 if Ekind (S) in E_Function | E_Procedure 13969 and then Is_Generic_Instance (S) 13970 then 13971 return True; 13972 13973 elsif Ekind (S) = E_Package 13974 and then In_Package_Body (S) 13975 and then Is_Generic_Instance (S) 13976 then 13977 return True; 13978 end if; 13979 13980 S := Scope (S); 13981 end loop; 13982 13983 return False; 13984 end In_Instance_Body; 13985 13986 ----------------------------- 13987 -- In_Instance_Not_Visible -- 13988 ----------------------------- 13989 13990 function In_Instance_Not_Visible return Boolean is 13991 S : Entity_Id; 13992 13993 begin 13994 S := Current_Scope; 13995 while Present (S) and then S /= Standard_Standard loop 13996 if Ekind (S) in E_Function | E_Procedure 13997 and then Is_Generic_Instance (S) 13998 then 13999 return True; 14000 14001 elsif Ekind (S) = E_Package 14002 and then (In_Package_Body (S) or else In_Private_Part (S)) 14003 and then Is_Generic_Instance (S) 14004 then 14005 return True; 14006 end if; 14007 14008 S := Scope (S); 14009 end loop; 14010 14011 return False; 14012 end In_Instance_Not_Visible; 14013 14014 ------------------------------ 14015 -- In_Instance_Visible_Part -- 14016 ------------------------------ 14017 14018 function In_Instance_Visible_Part 14019 (Id : Entity_Id := Current_Scope) return Boolean 14020 is 14021 Inst : Entity_Id; 14022 14023 begin 14024 Inst := Id; 14025 while Present (Inst) and then Inst /= Standard_Standard loop 14026 if Ekind (Inst) = E_Package 14027 and then Is_Generic_Instance (Inst) 14028 and then not In_Package_Body (Inst) 14029 and then not In_Private_Part (Inst) 14030 then 14031 return True; 14032 end if; 14033 14034 Inst := Scope (Inst); 14035 end loop; 14036 14037 return False; 14038 end In_Instance_Visible_Part; 14039 14040 --------------------- 14041 -- In_Package_Body -- 14042 --------------------- 14043 14044 function In_Package_Body return Boolean is 14045 S : Entity_Id; 14046 14047 begin 14048 S := Current_Scope; 14049 while Present (S) and then S /= Standard_Standard loop 14050 if Ekind (S) = E_Package and then In_Package_Body (S) then 14051 return True; 14052 else 14053 S := Scope (S); 14054 end if; 14055 end loop; 14056 14057 return False; 14058 end In_Package_Body; 14059 14060 -------------------------- 14061 -- In_Pragma_Expression -- 14062 -------------------------- 14063 14064 function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean is 14065 P : Node_Id; 14066 begin 14067 P := Parent (N); 14068 loop 14069 if No (P) then 14070 return False; 14071 elsif Nkind (P) = N_Pragma and then Pragma_Name (P) = Nam then 14072 return True; 14073 else 14074 P := Parent (P); 14075 end if; 14076 end loop; 14077 end In_Pragma_Expression; 14078 14079 --------------------------- 14080 -- In_Pre_Post_Condition -- 14081 --------------------------- 14082 14083 function In_Pre_Post_Condition (N : Node_Id) return Boolean is 14084 Par : Node_Id; 14085 Prag : Node_Id := Empty; 14086 Prag_Id : Pragma_Id; 14087 14088 begin 14089 -- Climb the parent chain looking for an enclosing pragma 14090 14091 Par := N; 14092 while Present (Par) loop 14093 if Nkind (Par) = N_Pragma then 14094 Prag := Par; 14095 exit; 14096 14097 -- Prevent the search from going too far 14098 14099 elsif Is_Body_Or_Package_Declaration (Par) then 14100 exit; 14101 end if; 14102 14103 Par := Parent (Par); 14104 end loop; 14105 14106 if Present (Prag) then 14107 Prag_Id := Get_Pragma_Id (Prag); 14108 14109 return 14110 Prag_Id = Pragma_Post 14111 or else Prag_Id = Pragma_Post_Class 14112 or else Prag_Id = Pragma_Postcondition 14113 or else Prag_Id = Pragma_Pre 14114 or else Prag_Id = Pragma_Pre_Class 14115 or else Prag_Id = Pragma_Precondition; 14116 14117 -- Otherwise the node is not enclosed by a pre/postcondition pragma 14118 14119 else 14120 return False; 14121 end if; 14122 end In_Pre_Post_Condition; 14123 14124 ------------------------------ 14125 -- In_Quantified_Expression -- 14126 ------------------------------ 14127 14128 function In_Quantified_Expression (N : Node_Id) return Boolean is 14129 P : Node_Id; 14130 begin 14131 P := Parent (N); 14132 loop 14133 if No (P) then 14134 return False; 14135 elsif Nkind (P) = N_Quantified_Expression then 14136 return True; 14137 else 14138 P := Parent (P); 14139 end if; 14140 end loop; 14141 end In_Quantified_Expression; 14142 14143 ------------------------------------- 14144 -- In_Reverse_Storage_Order_Object -- 14145 ------------------------------------- 14146 14147 function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is 14148 Pref : Node_Id; 14149 Btyp : Entity_Id := Empty; 14150 14151 begin 14152 -- Climb up indexed components 14153 14154 Pref := N; 14155 loop 14156 case Nkind (Pref) is 14157 when N_Selected_Component => 14158 Pref := Prefix (Pref); 14159 exit; 14160 14161 when N_Indexed_Component => 14162 Pref := Prefix (Pref); 14163 14164 when others => 14165 Pref := Empty; 14166 exit; 14167 end case; 14168 end loop; 14169 14170 if Present (Pref) then 14171 Btyp := Base_Type (Etype (Pref)); 14172 end if; 14173 14174 return Present (Btyp) 14175 and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp)) 14176 and then Reverse_Storage_Order (Btyp); 14177 end In_Reverse_Storage_Order_Object; 14178 14179 ------------------------------ 14180 -- In_Same_Declarative_Part -- 14181 ------------------------------ 14182 14183 function In_Same_Declarative_Part 14184 (Context : Node_Id; 14185 N : Node_Id) return Boolean 14186 is 14187 Cont : Node_Id := Context; 14188 Nod : Node_Id; 14189 14190 begin 14191 if Nkind (Cont) = N_Compilation_Unit_Aux then 14192 Cont := Parent (Cont); 14193 end if; 14194 14195 Nod := Parent (N); 14196 while Present (Nod) loop 14197 if Nod = Cont then 14198 return True; 14199 14200 elsif Nkind (Nod) in N_Accept_Statement 14201 | N_Block_Statement 14202 | N_Compilation_Unit 14203 | N_Entry_Body 14204 | N_Package_Body 14205 | N_Package_Declaration 14206 | N_Protected_Body 14207 | N_Subprogram_Body 14208 | N_Task_Body 14209 then 14210 return False; 14211 14212 elsif Nkind (Nod) = N_Subunit then 14213 Nod := Corresponding_Stub (Nod); 14214 14215 else 14216 Nod := Parent (Nod); 14217 end if; 14218 end loop; 14219 14220 return False; 14221 end In_Same_Declarative_Part; 14222 14223 -------------------------------------- 14224 -- In_Subprogram_Or_Concurrent_Unit -- 14225 -------------------------------------- 14226 14227 function In_Subprogram_Or_Concurrent_Unit return Boolean is 14228 E : Entity_Id; 14229 K : Entity_Kind; 14230 14231 begin 14232 -- Use scope chain to check successively outer scopes 14233 14234 E := Current_Scope; 14235 loop 14236 K := Ekind (E); 14237 14238 if K in Subprogram_Kind 14239 or else K in Concurrent_Kind 14240 or else K in Generic_Subprogram_Kind 14241 then 14242 return True; 14243 14244 elsif E = Standard_Standard then 14245 return False; 14246 end if; 14247 14248 E := Scope (E); 14249 end loop; 14250 end In_Subprogram_Or_Concurrent_Unit; 14251 14252 ---------------- 14253 -- In_Subtree -- 14254 ---------------- 14255 14256 function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is 14257 Curr : Node_Id; 14258 14259 begin 14260 Curr := N; 14261 while Present (Curr) loop 14262 if Curr = Root then 14263 return True; 14264 end if; 14265 14266 Curr := Parent (Curr); 14267 end loop; 14268 14269 return False; 14270 end In_Subtree; 14271 14272 ---------------- 14273 -- In_Subtree -- 14274 ---------------- 14275 14276 function In_Subtree 14277 (N : Node_Id; 14278 Root1 : Node_Id; 14279 Root2 : Node_Id) return Boolean 14280 is 14281 Curr : Node_Id; 14282 14283 begin 14284 Curr := N; 14285 while Present (Curr) loop 14286 if Curr = Root1 or else Curr = Root2 then 14287 return True; 14288 end if; 14289 14290 Curr := Parent (Curr); 14291 end loop; 14292 14293 return False; 14294 end In_Subtree; 14295 14296 --------------------- 14297 -- In_Return_Value -- 14298 --------------------- 14299 14300 function In_Return_Value (Expr : Node_Id) return Boolean is 14301 Par : Node_Id; 14302 Prev_Par : Node_Id; 14303 Pre : Node_Id; 14304 In_Function_Call : Boolean := False; 14305 14306 begin 14307 -- Move through parent nodes to determine if Expr contributes to the 14308 -- return value of the current subprogram. 14309 14310 Par := Expr; 14311 Prev_Par := Empty; 14312 while Present (Par) loop 14313 14314 case Nkind (Par) is 14315 -- Ignore ranges and they don't contribute to the result 14316 14317 when N_Range => 14318 return False; 14319 14320 -- An object declaration whose parent is an extended return 14321 -- statement is a return object. 14322 14323 when N_Object_Declaration => 14324 if Present (Parent (Par)) 14325 and then Nkind (Parent (Par)) = N_Extended_Return_Statement 14326 then 14327 return True; 14328 end if; 14329 14330 -- We hit a simple return statement, so we know we are in one 14331 14332 when N_Simple_Return_Statement => 14333 return True; 14334 14335 -- Only include one nexting level of function calls 14336 14337 when N_Function_Call => 14338 if not In_Function_Call then 14339 In_Function_Call := True; 14340 else 14341 return False; 14342 end if; 14343 14344 -- Check if we are on the right-hand side of an assignment 14345 -- statement to a return object. 14346 14347 -- This is not specified in the RM ??? 14348 14349 when N_Assignment_Statement => 14350 if Prev_Par = Name (Par) then 14351 return False; 14352 end if; 14353 14354 Pre := Name (Par); 14355 while Present (Pre) loop 14356 if Is_Entity_Name (Pre) 14357 and then Is_Return_Object (Entity (Pre)) 14358 then 14359 return True; 14360 end if; 14361 14362 exit when Nkind (Pre) not in N_Selected_Component 14363 | N_Indexed_Component 14364 | N_Slice; 14365 14366 Pre := Prefix (Pre); 14367 end loop; 14368 14369 -- Otherwise, we hit a master which was not relevant 14370 14371 when others => 14372 if Is_Master (Par) then 14373 return False; 14374 end if; 14375 end case; 14376 14377 -- Iterate up to the next parent, keeping track of the previous one 14378 14379 Prev_Par := Par; 14380 Par := Parent (Par); 14381 end loop; 14382 14383 return False; 14384 end In_Return_Value; 14385 14386 --------------------- 14387 -- In_Visible_Part -- 14388 --------------------- 14389 14390 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is 14391 begin 14392 return Is_Package_Or_Generic_Package (Scope_Id) 14393 and then In_Open_Scopes (Scope_Id) 14394 and then not In_Package_Body (Scope_Id) 14395 and then not In_Private_Part (Scope_Id); 14396 end In_Visible_Part; 14397 14398 ----------------------------- 14399 -- In_While_Loop_Condition -- 14400 ----------------------------- 14401 14402 function In_While_Loop_Condition (N : Node_Id) return Boolean is 14403 Prev : Node_Id := N; 14404 P : Node_Id := Parent (N); 14405 -- P and Prev will be used for traversing the AST, while maintaining an 14406 -- invariant that P = Parent (Prev). 14407 begin 14408 loop 14409 if No (P) then 14410 return False; 14411 elsif Nkind (P) = N_Iteration_Scheme 14412 and then Prev = Condition (P) 14413 then 14414 return True; 14415 else 14416 Prev := P; 14417 P := Parent (P); 14418 end if; 14419 end loop; 14420 end In_While_Loop_Condition; 14421 14422 -------------------------------- 14423 -- Incomplete_Or_Partial_View -- 14424 -------------------------------- 14425 14426 function Incomplete_Or_Partial_View (Id : Entity_Id) return Entity_Id is 14427 function Inspect_Decls 14428 (Decls : List_Id; 14429 Taft : Boolean := False) return Entity_Id; 14430 -- Check whether a declarative region contains the incomplete or partial 14431 -- view of Id. 14432 14433 ------------------- 14434 -- Inspect_Decls -- 14435 ------------------- 14436 14437 function Inspect_Decls 14438 (Decls : List_Id; 14439 Taft : Boolean := False) return Entity_Id 14440 is 14441 Decl : Node_Id; 14442 Match : Node_Id; 14443 14444 begin 14445 Decl := First (Decls); 14446 while Present (Decl) loop 14447 Match := Empty; 14448 14449 -- The partial view of a Taft-amendment type is an incomplete 14450 -- type. 14451 14452 if Taft then 14453 if Nkind (Decl) = N_Incomplete_Type_Declaration then 14454 Match := Defining_Identifier (Decl); 14455 end if; 14456 14457 -- Otherwise look for a private type whose full view matches the 14458 -- input type. Note that this checks full_type_declaration nodes 14459 -- to account for derivations from a private type where the type 14460 -- declaration hold the partial view and the full view is an 14461 -- itype. 14462 14463 elsif Nkind (Decl) in N_Full_Type_Declaration 14464 | N_Private_Extension_Declaration 14465 | N_Private_Type_Declaration 14466 then 14467 Match := Defining_Identifier (Decl); 14468 end if; 14469 14470 -- Guard against unanalyzed entities 14471 14472 if Present (Match) 14473 and then Is_Type (Match) 14474 and then Present (Full_View (Match)) 14475 and then Full_View (Match) = Id 14476 then 14477 return Match; 14478 end if; 14479 14480 Next (Decl); 14481 end loop; 14482 14483 return Empty; 14484 end Inspect_Decls; 14485 14486 -- Local variables 14487 14488 Prev : Entity_Id; 14489 14490 -- Start of processing for Incomplete_Or_Partial_View 14491 14492 begin 14493 -- Deferred constant or incomplete type case 14494 14495 Prev := Current_Entity_In_Scope (Id); 14496 14497 if Present (Prev) 14498 and then (Is_Incomplete_Type (Prev) or else Ekind (Prev) = E_Constant) 14499 and then Present (Full_View (Prev)) 14500 and then Full_View (Prev) = Id 14501 then 14502 return Prev; 14503 end if; 14504 14505 -- Private or Taft amendment type case 14506 14507 declare 14508 Pkg : constant Entity_Id := Scope (Id); 14509 Pkg_Decl : Node_Id := Pkg; 14510 14511 begin 14512 if Present (Pkg) 14513 and then Is_Package_Or_Generic_Package (Pkg) 14514 then 14515 while Nkind (Pkg_Decl) /= N_Package_Specification loop 14516 Pkg_Decl := Parent (Pkg_Decl); 14517 end loop; 14518 14519 -- It is knows that Typ has a private view, look for it in the 14520 -- visible declarations of the enclosing scope. A special case 14521 -- of this is when the two views have been exchanged - the full 14522 -- appears earlier than the private. 14523 14524 if Has_Private_Declaration (Id) then 14525 Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl)); 14526 14527 -- Exchanged view case, look in the private declarations 14528 14529 if No (Prev) then 14530 Prev := Inspect_Decls (Private_Declarations (Pkg_Decl)); 14531 end if; 14532 14533 return Prev; 14534 14535 -- Otherwise if this is the package body, then Typ is a potential 14536 -- Taft amendment type. The incomplete view should be located in 14537 -- the private declarations of the enclosing scope. 14538 14539 elsif In_Package_Body (Pkg) then 14540 return Inspect_Decls (Private_Declarations (Pkg_Decl), True); 14541 end if; 14542 end if; 14543 end; 14544 14545 -- The type has no incomplete or private view 14546 14547 return Empty; 14548 end Incomplete_Or_Partial_View; 14549 14550 --------------------------------------- 14551 -- Incomplete_View_From_Limited_With -- 14552 --------------------------------------- 14553 14554 function Incomplete_View_From_Limited_With 14555 (Typ : Entity_Id) return Entity_Id 14556 is 14557 begin 14558 -- It might make sense to make this an attribute in Einfo, and set it 14559 -- in Sem_Ch10 in Build_Shadow_Entity. However, we're running short on 14560 -- slots for new attributes, and it seems a bit simpler to just search 14561 -- the Limited_View (if it exists) for an incomplete type whose 14562 -- Non_Limited_View is Typ. 14563 14564 if Ekind (Scope (Typ)) = E_Package 14565 and then Present (Limited_View (Scope (Typ))) 14566 then 14567 declare 14568 Ent : Entity_Id := First_Entity (Limited_View (Scope (Typ))); 14569 begin 14570 while Present (Ent) loop 14571 if Is_Incomplete_Type (Ent) 14572 and then Non_Limited_View (Ent) = Typ 14573 then 14574 return Ent; 14575 end if; 14576 14577 Next_Entity (Ent); 14578 end loop; 14579 end; 14580 end if; 14581 14582 return Typ; 14583 end Incomplete_View_From_Limited_With; 14584 14585 ---------------------------------- 14586 -- Indexed_Component_Bit_Offset -- 14587 ---------------------------------- 14588 14589 function Indexed_Component_Bit_Offset (N : Node_Id) return Uint is 14590 Exp : constant Node_Id := First (Expressions (N)); 14591 Typ : constant Entity_Id := Etype (Prefix (N)); 14592 Off : constant Uint := Component_Size (Typ); 14593 Ind : Node_Id; 14594 14595 begin 14596 -- Return early if the component size is not known or variable 14597 14598 if Off = No_Uint or else Off < Uint_0 then 14599 return No_Uint; 14600 end if; 14601 14602 -- Deal with the degenerate case of an empty component 14603 14604 if Off = Uint_0 then 14605 return Off; 14606 end if; 14607 14608 -- Check that both the index value and the low bound are known 14609 14610 if not Compile_Time_Known_Value (Exp) then 14611 return No_Uint; 14612 end if; 14613 14614 Ind := First_Index (Typ); 14615 if No (Ind) then 14616 return No_Uint; 14617 end if; 14618 14619 if Nkind (Ind) = N_Subtype_Indication then 14620 Ind := Constraint (Ind); 14621 14622 if Nkind (Ind) = N_Range_Constraint then 14623 Ind := Range_Expression (Ind); 14624 end if; 14625 end if; 14626 14627 if Nkind (Ind) /= N_Range 14628 or else not Compile_Time_Known_Value (Low_Bound (Ind)) 14629 then 14630 return No_Uint; 14631 end if; 14632 14633 -- Return the scaled offset 14634 14635 return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound ((Ind)))); 14636 end Indexed_Component_Bit_Offset; 14637 14638 ----------------------------- 14639 -- Inherit_Predicate_Flags -- 14640 ----------------------------- 14641 14642 procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is 14643 begin 14644 if Ada_Version < Ada_2012 14645 or else Present (Predicate_Function (Subt)) 14646 then 14647 return; 14648 end if; 14649 14650 Set_Has_Predicates (Subt, Has_Predicates (Par)); 14651 Set_Has_Static_Predicate_Aspect 14652 (Subt, Has_Static_Predicate_Aspect (Par)); 14653 Set_Has_Dynamic_Predicate_Aspect 14654 (Subt, Has_Dynamic_Predicate_Aspect (Par)); 14655 14656 -- A named subtype does not inherit the predicate function of its 14657 -- parent but an itype declared for a loop index needs the discrete 14658 -- predicate information of its parent to execute the loop properly. 14659 -- A non-discrete type may has a static predicate (for example True) 14660 -- but has no static_discrete_predicate. 14661 14662 if Is_Itype (Subt) and then Present (Predicate_Function (Par)) then 14663 Set_Subprograms_For_Type (Subt, Subprograms_For_Type (Par)); 14664 14665 if Has_Static_Predicate (Par) and then Is_Discrete_Type (Par) then 14666 Set_Static_Discrete_Predicate 14667 (Subt, Static_Discrete_Predicate (Par)); 14668 end if; 14669 end if; 14670 end Inherit_Predicate_Flags; 14671 14672 ---------------------------- 14673 -- Inherit_Rep_Item_Chain -- 14674 ---------------------------- 14675 14676 procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is 14677 Item : Node_Id; 14678 Next_Item : Node_Id; 14679 14680 begin 14681 -- There are several inheritance scenarios to consider depending on 14682 -- whether both types have rep item chains and whether the destination 14683 -- type already inherits part of the source type's rep item chain. 14684 14685 -- 1) The source type lacks a rep item chain 14686 -- From_Typ ---> Empty 14687 -- 14688 -- Typ --------> Item (or Empty) 14689 14690 -- In this case inheritance cannot take place because there are no items 14691 -- to inherit. 14692 14693 -- 2) The destination type lacks a rep item chain 14694 -- From_Typ ---> Item ---> ... 14695 -- 14696 -- Typ --------> Empty 14697 14698 -- Inheritance takes place by setting the First_Rep_Item of the 14699 -- destination type to the First_Rep_Item of the source type. 14700 -- From_Typ ---> Item ---> ... 14701 -- ^ 14702 -- Typ -----------+ 14703 14704 -- 3.1) Both source and destination types have at least one rep item. 14705 -- The destination type does NOT inherit a rep item from the source 14706 -- type. 14707 -- From_Typ ---> Item ---> Item 14708 -- 14709 -- Typ --------> Item ---> Item 14710 14711 -- Inheritance takes place by setting the Next_Rep_Item of the last item 14712 -- of the destination type to the First_Rep_Item of the source type. 14713 -- From_Typ -------------------> Item ---> Item 14714 -- ^ 14715 -- Typ --------> Item ---> Item --+ 14716 14717 -- 3.2) Both source and destination types have at least one rep item. 14718 -- The destination type DOES inherit part of the rep item chain of the 14719 -- source type. 14720 -- From_Typ ---> Item ---> Item ---> Item 14721 -- ^ 14722 -- Typ --------> Item ------+ 14723 14724 -- This rare case arises when the full view of a private extension must 14725 -- inherit the rep item chain from the full view of its parent type and 14726 -- the full view of the parent type contains extra rep items. Currently 14727 -- only invariants may lead to such form of inheritance. 14728 14729 -- type From_Typ is tagged private 14730 -- with Type_Invariant'Class => Item_2; 14731 14732 -- type Typ is new From_Typ with private 14733 -- with Type_Invariant => Item_4; 14734 14735 -- At this point the rep item chains contain the following items 14736 14737 -- From_Typ -----------> Item_2 ---> Item_3 14738 -- ^ 14739 -- Typ --------> Item_4 --+ 14740 14741 -- The full views of both types may introduce extra invariants 14742 14743 -- type From_Typ is tagged null record 14744 -- with Type_Invariant => Item_1; 14745 14746 -- type Typ is new From_Typ with null record; 14747 14748 -- The full view of Typ would have to inherit any new rep items added to 14749 -- the full view of From_Typ. 14750 14751 -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3 14752 -- ^ 14753 -- Typ --------> Item_4 --+ 14754 14755 -- To achieve this form of inheritance, the destination type must first 14756 -- sever the link between its own rep chain and that of the source type, 14757 -- then inheritance 3.1 takes place. 14758 14759 -- Case 1: The source type lacks a rep item chain 14760 14761 if No (First_Rep_Item (From_Typ)) then 14762 return; 14763 14764 -- Case 2: The destination type lacks a rep item chain 14765 14766 elsif No (First_Rep_Item (Typ)) then 14767 Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ)); 14768 14769 -- Case 3: Both the source and destination types have at least one rep 14770 -- item. Traverse the rep item chain of the destination type to find the 14771 -- last rep item. 14772 14773 else 14774 Item := Empty; 14775 Next_Item := First_Rep_Item (Typ); 14776 while Present (Next_Item) loop 14777 14778 -- Detect a link between the destination type's rep chain and that 14779 -- of the source type. There are two possibilities: 14780 14781 -- Variant 1 14782 -- Next_Item 14783 -- V 14784 -- From_Typ ---> Item_1 ---> 14785 -- ^ 14786 -- Typ -----------+ 14787 -- 14788 -- Item is Empty 14789 14790 -- Variant 2 14791 -- Next_Item 14792 -- V 14793 -- From_Typ ---> Item_1 ---> Item_2 ---> 14794 -- ^ 14795 -- Typ --------> Item_3 ------+ 14796 -- ^ 14797 -- Item 14798 14799 if Present_In_Rep_Item (From_Typ, Next_Item) then 14800 exit; 14801 end if; 14802 14803 Item := Next_Item; 14804 Next_Item := Next_Rep_Item (Next_Item); 14805 end loop; 14806 14807 -- Inherit the source type's rep item chain 14808 14809 if Present (Item) then 14810 Set_Next_Rep_Item (Item, First_Rep_Item (From_Typ)); 14811 else 14812 Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ)); 14813 end if; 14814 end if; 14815 end Inherit_Rep_Item_Chain; 14816 14817 ------------------------------------ 14818 -- Inherits_From_Tagged_Full_View -- 14819 ------------------------------------ 14820 14821 function Inherits_From_Tagged_Full_View (Typ : Entity_Id) return Boolean is 14822 begin 14823 return Is_Private_Type (Typ) 14824 and then Present (Full_View (Typ)) 14825 and then Is_Private_Type (Full_View (Typ)) 14826 and then not Is_Tagged_Type (Full_View (Typ)) 14827 and then Present (Underlying_Type (Full_View (Typ))) 14828 and then Is_Tagged_Type (Underlying_Type (Full_View (Typ))); 14829 end Inherits_From_Tagged_Full_View; 14830 14831 --------------------------------- 14832 -- Insert_Explicit_Dereference -- 14833 --------------------------------- 14834 14835 procedure Insert_Explicit_Dereference (N : Node_Id) is 14836 New_Prefix : constant Node_Id := Relocate_Node (N); 14837 Ent : Entity_Id := Empty; 14838 Pref : Node_Id := Empty; 14839 I : Interp_Index; 14840 It : Interp; 14841 T : Entity_Id; 14842 14843 begin 14844 Save_Interps (N, New_Prefix); 14845 14846 Rewrite (N, 14847 Make_Explicit_Dereference (Sloc (Parent (N)), 14848 Prefix => New_Prefix)); 14849 14850 Set_Etype (N, Designated_Type (Etype (New_Prefix))); 14851 14852 if Is_Overloaded (New_Prefix) then 14853 14854 -- The dereference is also overloaded, and its interpretations are 14855 -- the designated types of the interpretations of the original node. 14856 14857 Set_Etype (N, Any_Type); 14858 14859 Get_First_Interp (New_Prefix, I, It); 14860 while Present (It.Nam) loop 14861 T := It.Typ; 14862 14863 if Is_Access_Type (T) then 14864 Add_One_Interp (N, Designated_Type (T), Designated_Type (T)); 14865 end if; 14866 14867 Get_Next_Interp (I, It); 14868 end loop; 14869 14870 End_Interp_List; 14871 14872 else 14873 -- Prefix is unambiguous: mark the original prefix (which might 14874 -- Come_From_Source) as a reference, since the new (relocated) one 14875 -- won't be taken into account. 14876 14877 if Is_Entity_Name (New_Prefix) then 14878 Ent := Entity (New_Prefix); 14879 Pref := New_Prefix; 14880 14881 -- For a retrieval of a subcomponent of some composite object, 14882 -- retrieve the ultimate entity if there is one. 14883 14884 elsif Nkind (New_Prefix) in N_Selected_Component | N_Indexed_Component 14885 then 14886 Pref := Prefix (New_Prefix); 14887 while Present (Pref) 14888 and then Nkind (Pref) in 14889 N_Selected_Component | N_Indexed_Component 14890 loop 14891 Pref := Prefix (Pref); 14892 end loop; 14893 14894 if Present (Pref) and then Is_Entity_Name (Pref) then 14895 Ent := Entity (Pref); 14896 end if; 14897 end if; 14898 14899 -- Place the reference on the entity node 14900 14901 if Present (Ent) then 14902 Generate_Reference (Ent, Pref); 14903 end if; 14904 end if; 14905 end Insert_Explicit_Dereference; 14906 14907 ------------------------------------------ 14908 -- Inspect_Deferred_Constant_Completion -- 14909 ------------------------------------------ 14910 14911 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is 14912 Decl : Node_Id; 14913 14914 begin 14915 Decl := First (Decls); 14916 while Present (Decl) loop 14917 14918 -- Deferred constant signature 14919 14920 if Nkind (Decl) = N_Object_Declaration 14921 and then Constant_Present (Decl) 14922 and then No (Expression (Decl)) 14923 14924 -- No need to check internally generated constants 14925 14926 and then Comes_From_Source (Decl) 14927 14928 -- The constant is not completed. A full object declaration or a 14929 -- pragma Import complete a deferred constant. 14930 14931 and then not Has_Completion (Defining_Identifier (Decl)) 14932 then 14933 Error_Msg_N 14934 ("constant declaration requires initialization expression", 14935 Defining_Identifier (Decl)); 14936 end if; 14937 14938 Next (Decl); 14939 end loop; 14940 end Inspect_Deferred_Constant_Completion; 14941 14942 ------------------------------- 14943 -- Install_Elaboration_Model -- 14944 ------------------------------- 14945 14946 procedure Install_Elaboration_Model (Unit_Id : Entity_Id) is 14947 function Find_Elaboration_Checks_Pragma (L : List_Id) return Node_Id; 14948 -- Try to find pragma Elaboration_Checks in arbitrary list L. Return 14949 -- Empty if there is no such pragma. 14950 14951 ------------------------------------ 14952 -- Find_Elaboration_Checks_Pragma -- 14953 ------------------------------------ 14954 14955 function Find_Elaboration_Checks_Pragma (L : List_Id) return Node_Id is 14956 Item : Node_Id; 14957 14958 begin 14959 Item := First (L); 14960 while Present (Item) loop 14961 if Nkind (Item) = N_Pragma 14962 and then Pragma_Name (Item) = Name_Elaboration_Checks 14963 then 14964 return Item; 14965 end if; 14966 14967 Next (Item); 14968 end loop; 14969 14970 return Empty; 14971 end Find_Elaboration_Checks_Pragma; 14972 14973 -- Local variables 14974 14975 Args : List_Id; 14976 Model : Node_Id; 14977 Prag : Node_Id; 14978 Unit : Node_Id; 14979 14980 -- Start of processing for Install_Elaboration_Model 14981 14982 begin 14983 -- Nothing to do when the unit does not exist 14984 14985 if No (Unit_Id) then 14986 return; 14987 end if; 14988 14989 Unit := Parent (Unit_Declaration_Node (Unit_Id)); 14990 14991 -- Nothing to do when the unit is not a library unit 14992 14993 if Nkind (Unit) /= N_Compilation_Unit then 14994 return; 14995 end if; 14996 14997 Prag := Find_Elaboration_Checks_Pragma (Context_Items (Unit)); 14998 14999 -- The compilation unit is subject to pragma Elaboration_Checks. Set the 15000 -- elaboration model as specified by the pragma. 15001 15002 if Present (Prag) then 15003 Args := Pragma_Argument_Associations (Prag); 15004 15005 -- Guard against an illegal pragma. The sole argument must be an 15006 -- identifier which specifies either Dynamic or Static model. 15007 15008 if Present (Args) then 15009 Model := Get_Pragma_Arg (First (Args)); 15010 15011 if Nkind (Model) = N_Identifier then 15012 Dynamic_Elaboration_Checks := Chars (Model) = Name_Dynamic; 15013 end if; 15014 end if; 15015 end if; 15016 end Install_Elaboration_Model; 15017 15018 ----------------------------- 15019 -- Install_Generic_Formals -- 15020 ----------------------------- 15021 15022 procedure Install_Generic_Formals (Subp_Id : Entity_Id) is 15023 E : Entity_Id; 15024 15025 begin 15026 pragma Assert (Is_Generic_Subprogram (Subp_Id)); 15027 15028 E := First_Entity (Subp_Id); 15029 while Present (E) loop 15030 Install_Entity (E); 15031 Next_Entity (E); 15032 end loop; 15033 end Install_Generic_Formals; 15034 15035 ------------------------ 15036 -- Install_SPARK_Mode -- 15037 ------------------------ 15038 15039 procedure Install_SPARK_Mode (Mode : SPARK_Mode_Type; Prag : Node_Id) is 15040 begin 15041 SPARK_Mode := Mode; 15042 SPARK_Mode_Pragma := Prag; 15043 end Install_SPARK_Mode; 15044 15045 -------------------------- 15046 -- Invalid_Scalar_Value -- 15047 -------------------------- 15048 15049 function Invalid_Scalar_Value 15050 (Loc : Source_Ptr; 15051 Scal_Typ : Scalar_Id) return Node_Id 15052 is 15053 function Invalid_Binder_Value return Node_Id; 15054 -- Return a reference to the corresponding invalid value for type 15055 -- Scal_Typ as defined in unit System.Scalar_Values. 15056 15057 function Invalid_Float_Value return Node_Id; 15058 -- Return the invalid value of float type Scal_Typ 15059 15060 function Invalid_Integer_Value return Node_Id; 15061 -- Return the invalid value of integer type Scal_Typ 15062 15063 procedure Set_Invalid_Binder_Values; 15064 -- Set the contents of collection Invalid_Binder_Values 15065 15066 -------------------------- 15067 -- Invalid_Binder_Value -- 15068 -------------------------- 15069 15070 function Invalid_Binder_Value return Node_Id is 15071 Val_Id : Entity_Id; 15072 15073 begin 15074 -- Initialize the collection of invalid binder values the first time 15075 -- around. 15076 15077 Set_Invalid_Binder_Values; 15078 15079 -- Obtain the corresponding variable from System.Scalar_Values which 15080 -- holds the invalid value for this type. 15081 15082 Val_Id := Invalid_Binder_Values (Scal_Typ); 15083 pragma Assert (Present (Val_Id)); 15084 15085 return New_Occurrence_Of (Val_Id, Loc); 15086 end Invalid_Binder_Value; 15087 15088 ------------------------- 15089 -- Invalid_Float_Value -- 15090 ------------------------- 15091 15092 function Invalid_Float_Value return Node_Id is 15093 Value : constant Ureal := Invalid_Floats (Scal_Typ); 15094 15095 begin 15096 -- Pragma Invalid_Scalars did not specify an invalid value for this 15097 -- type. Fall back to the value provided by the binder. 15098 15099 if Value = No_Ureal then 15100 return Invalid_Binder_Value; 15101 else 15102 return Make_Real_Literal (Loc, Realval => Value); 15103 end if; 15104 end Invalid_Float_Value; 15105 15106 --------------------------- 15107 -- Invalid_Integer_Value -- 15108 --------------------------- 15109 15110 function Invalid_Integer_Value return Node_Id is 15111 Value : constant Uint := Invalid_Integers (Scal_Typ); 15112 15113 begin 15114 -- Pragma Invalid_Scalars did not specify an invalid value for this 15115 -- type. Fall back to the value provided by the binder. 15116 15117 if Value = No_Uint then 15118 return Invalid_Binder_Value; 15119 else 15120 return Make_Integer_Literal (Loc, Intval => Value); 15121 end if; 15122 end Invalid_Integer_Value; 15123 15124 ------------------------------- 15125 -- Set_Invalid_Binder_Values -- 15126 ------------------------------- 15127 15128 procedure Set_Invalid_Binder_Values is 15129 begin 15130 if not Invalid_Binder_Values_Set then 15131 Invalid_Binder_Values_Set := True; 15132 15133 -- Initialize the contents of the collection once since RTE calls 15134 -- are not cheap. 15135 15136 Invalid_Binder_Values := 15137 (Name_Short_Float => RTE (RE_IS_Isf), 15138 Name_Float => RTE (RE_IS_Ifl), 15139 Name_Long_Float => RTE (RE_IS_Ilf), 15140 Name_Long_Long_Float => RTE (RE_IS_Ill), 15141 Name_Signed_8 => RTE (RE_IS_Is1), 15142 Name_Signed_16 => RTE (RE_IS_Is2), 15143 Name_Signed_32 => RTE (RE_IS_Is4), 15144 Name_Signed_64 => RTE (RE_IS_Is8), 15145 Name_Signed_128 => Empty, 15146 Name_Unsigned_8 => RTE (RE_IS_Iu1), 15147 Name_Unsigned_16 => RTE (RE_IS_Iu2), 15148 Name_Unsigned_32 => RTE (RE_IS_Iu4), 15149 Name_Unsigned_64 => RTE (RE_IS_Iu8), 15150 Name_Unsigned_128 => Empty); 15151 15152 if System_Max_Integer_Size < 128 then 15153 Invalid_Binder_Values (Name_Signed_128) := RTE (RE_IS_Is8); 15154 Invalid_Binder_Values (Name_Unsigned_128) := RTE (RE_IS_Iu8); 15155 else 15156 Invalid_Binder_Values (Name_Signed_128) := RTE (RE_IS_Is16); 15157 Invalid_Binder_Values (Name_Unsigned_128) := RTE (RE_IS_Iu16); 15158 end if; 15159 end if; 15160 end Set_Invalid_Binder_Values; 15161 15162 -- Start of processing for Invalid_Scalar_Value 15163 15164 begin 15165 if Scal_Typ in Float_Scalar_Id then 15166 return Invalid_Float_Value; 15167 15168 else pragma Assert (Scal_Typ in Integer_Scalar_Id); 15169 return Invalid_Integer_Value; 15170 end if; 15171 end Invalid_Scalar_Value; 15172 15173 -------------------------------- 15174 -- Is_Anonymous_Access_Actual -- 15175 -------------------------------- 15176 15177 function Is_Anonymous_Access_Actual (N : Node_Id) return Boolean is 15178 Par : Node_Id; 15179 begin 15180 if Ekind (Etype (N)) /= E_Anonymous_Access_Type then 15181 return False; 15182 end if; 15183 15184 Par := Parent (N); 15185 while Present (Par) 15186 and then Nkind (Par) in N_Case_Expression 15187 | N_If_Expression 15188 | N_Parameter_Association 15189 loop 15190 Par := Parent (Par); 15191 end loop; 15192 return Nkind (Par) in N_Subprogram_Call; 15193 end Is_Anonymous_Access_Actual; 15194 15195 ------------------------ 15196 -- Is_Access_Variable -- 15197 ------------------------ 15198 15199 function Is_Access_Variable (E : Entity_Id) return Boolean is 15200 begin 15201 return Is_Access_Object_Type (E) 15202 and then not Is_Access_Constant (E); 15203 end Is_Access_Variable; 15204 15205 ----------------------------- 15206 -- Is_Actual_Out_Parameter -- 15207 ----------------------------- 15208 15209 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is 15210 Formal : Entity_Id; 15211 Call : Node_Id; 15212 begin 15213 Find_Actual (N, Formal, Call); 15214 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter; 15215 end Is_Actual_Out_Parameter; 15216 15217 -------------------------------- 15218 -- Is_Actual_In_Out_Parameter -- 15219 -------------------------------- 15220 15221 function Is_Actual_In_Out_Parameter (N : Node_Id) return Boolean is 15222 Formal : Entity_Id; 15223 Call : Node_Id; 15224 begin 15225 Find_Actual (N, Formal, Call); 15226 return Present (Formal) and then Ekind (Formal) = E_In_Out_Parameter; 15227 end Is_Actual_In_Out_Parameter; 15228 15229 --------------------------------------- 15230 -- Is_Actual_Out_Or_In_Out_Parameter -- 15231 --------------------------------------- 15232 15233 function Is_Actual_Out_Or_In_Out_Parameter (N : Node_Id) return Boolean is 15234 Formal : Entity_Id; 15235 Call : Node_Id; 15236 begin 15237 Find_Actual (N, Formal, Call); 15238 return Present (Formal) 15239 and then Ekind (Formal) in E_Out_Parameter | E_In_Out_Parameter; 15240 end Is_Actual_Out_Or_In_Out_Parameter; 15241 15242 ------------------------- 15243 -- Is_Actual_Parameter -- 15244 ------------------------- 15245 15246 function Is_Actual_Parameter (N : Node_Id) return Boolean is 15247 PK : constant Node_Kind := Nkind (Parent (N)); 15248 15249 begin 15250 case PK is 15251 when N_Parameter_Association => 15252 return N = Explicit_Actual_Parameter (Parent (N)); 15253 15254 when N_Subprogram_Call => 15255 return Is_List_Member (N) 15256 and then 15257 List_Containing (N) = Parameter_Associations (Parent (N)); 15258 15259 when others => 15260 return False; 15261 end case; 15262 end Is_Actual_Parameter; 15263 15264 -------------------------------- 15265 -- Is_Actual_Tagged_Parameter -- 15266 -------------------------------- 15267 15268 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is 15269 Formal : Entity_Id; 15270 Call : Node_Id; 15271 begin 15272 Find_Actual (N, Formal, Call); 15273 return Present (Formal) and then Is_Tagged_Type (Etype (Formal)); 15274 end Is_Actual_Tagged_Parameter; 15275 15276 --------------------- 15277 -- Is_Aliased_View -- 15278 --------------------- 15279 15280 function Is_Aliased_View (Obj : Node_Id) return Boolean is 15281 E : Entity_Id; 15282 15283 begin 15284 if Is_Entity_Name (Obj) then 15285 E := Entity (Obj); 15286 15287 return 15288 (Is_Object (E) 15289 and then 15290 (Is_Aliased (E) 15291 or else (Present (Renamed_Object (E)) 15292 and then Is_Aliased_View (Renamed_Object (E))))) 15293 15294 or else ((Is_Formal (E) or else Is_Formal_Object (E)) 15295 and then Is_Tagged_Type (Etype (E))) 15296 15297 or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E)) 15298 15299 -- Current instance of type, either directly or as rewritten 15300 -- reference to the current object. 15301 15302 or else (Is_Entity_Name (Original_Node (Obj)) 15303 and then Present (Entity (Original_Node (Obj))) 15304 and then Is_Type (Entity (Original_Node (Obj)))) 15305 15306 or else (Is_Type (E) and then E = Current_Scope) 15307 15308 or else (Is_Incomplete_Or_Private_Type (E) 15309 and then Full_View (E) = Current_Scope) 15310 15311 -- Ada 2012 AI05-0053: the return object of an extended return 15312 -- statement is aliased if its type is immutably limited. 15313 15314 or else (Is_Return_Object (E) 15315 and then Is_Limited_View (Etype (E))); 15316 15317 elsif Nkind (Obj) = N_Selected_Component then 15318 return Is_Aliased (Entity (Selector_Name (Obj))); 15319 15320 elsif Nkind (Obj) = N_Indexed_Component then 15321 return Has_Aliased_Components (Etype (Prefix (Obj))) 15322 or else 15323 (Is_Access_Type (Etype (Prefix (Obj))) 15324 and then Has_Aliased_Components 15325 (Designated_Type (Etype (Prefix (Obj))))); 15326 15327 elsif Nkind (Obj) in N_Unchecked_Type_Conversion | N_Type_Conversion then 15328 return Is_Tagged_Type (Etype (Obj)) 15329 and then Is_Aliased_View (Expression (Obj)); 15330 15331 -- Ada 202x AI12-0228 15332 15333 elsif Nkind (Obj) = N_Qualified_Expression 15334 and then Ada_Version >= Ada_2012 15335 then 15336 return Is_Aliased_View (Expression (Obj)); 15337 15338 elsif Nkind (Obj) = N_Explicit_Dereference then 15339 return Nkind (Original_Node (Obj)) /= N_Function_Call; 15340 15341 else 15342 return False; 15343 end if; 15344 end Is_Aliased_View; 15345 15346 ------------------------- 15347 -- Is_Ancestor_Package -- 15348 ------------------------- 15349 15350 function Is_Ancestor_Package 15351 (E1 : Entity_Id; 15352 E2 : Entity_Id) return Boolean 15353 is 15354 Par : Entity_Id; 15355 15356 begin 15357 Par := E2; 15358 while Present (Par) and then Par /= Standard_Standard loop 15359 if Par = E1 then 15360 return True; 15361 end if; 15362 15363 Par := Scope (Par); 15364 end loop; 15365 15366 return False; 15367 end Is_Ancestor_Package; 15368 15369 ---------------------- 15370 -- Is_Atomic_Object -- 15371 ---------------------- 15372 15373 function Is_Atomic_Object (N : Node_Id) return Boolean is 15374 function Prefix_Has_Atomic_Components (P : Node_Id) return Boolean; 15375 -- Determine whether prefix P has atomic components. This requires the 15376 -- presence of an Atomic_Components aspect/pragma. 15377 15378 --------------------------------- 15379 -- Prefix_Has_Atomic_Components -- 15380 --------------------------------- 15381 15382 function Prefix_Has_Atomic_Components (P : Node_Id) return Boolean is 15383 Typ : constant Entity_Id := Etype (P); 15384 15385 begin 15386 if Is_Access_Type (Typ) then 15387 return Has_Atomic_Components (Designated_Type (Typ)); 15388 15389 elsif Has_Atomic_Components (Typ) then 15390 return True; 15391 15392 elsif Is_Entity_Name (P) 15393 and then Has_Atomic_Components (Entity (P)) 15394 then 15395 return True; 15396 15397 else 15398 return False; 15399 end if; 15400 end Prefix_Has_Atomic_Components; 15401 15402 -- Start of processing for Is_Atomic_Object 15403 15404 begin 15405 if Is_Entity_Name (N) then 15406 return Is_Atomic_Object_Entity (Entity (N)); 15407 15408 elsif Is_Atomic (Etype (N)) then 15409 return True; 15410 15411 elsif Nkind (N) = N_Indexed_Component then 15412 return Prefix_Has_Atomic_Components (Prefix (N)); 15413 15414 elsif Nkind (N) = N_Selected_Component then 15415 return Is_Atomic (Entity (Selector_Name (N))); 15416 15417 else 15418 return False; 15419 end if; 15420 end Is_Atomic_Object; 15421 15422 ----------------------------- 15423 -- Is_Atomic_Object_Entity -- 15424 ----------------------------- 15425 15426 function Is_Atomic_Object_Entity (Id : Entity_Id) return Boolean is 15427 begin 15428 return 15429 Is_Object (Id) 15430 and then (Is_Atomic (Id) or else Is_Atomic (Etype (Id))); 15431 end Is_Atomic_Object_Entity; 15432 15433 ----------------------------- 15434 -- Is_Attribute_Loop_Entry -- 15435 ----------------------------- 15436 15437 function Is_Attribute_Loop_Entry (N : Node_Id) return Boolean is 15438 begin 15439 return Nkind (N) = N_Attribute_Reference 15440 and then Attribute_Name (N) = Name_Loop_Entry; 15441 end Is_Attribute_Loop_Entry; 15442 15443 ---------------------- 15444 -- Is_Attribute_Old -- 15445 ---------------------- 15446 15447 function Is_Attribute_Old (N : Node_Id) return Boolean is 15448 begin 15449 return Nkind (N) = N_Attribute_Reference 15450 and then Attribute_Name (N) = Name_Old; 15451 end Is_Attribute_Old; 15452 15453 ------------------------- 15454 -- Is_Attribute_Result -- 15455 ------------------------- 15456 15457 function Is_Attribute_Result (N : Node_Id) return Boolean is 15458 begin 15459 return Nkind (N) = N_Attribute_Reference 15460 and then Attribute_Name (N) = Name_Result; 15461 end Is_Attribute_Result; 15462 15463 ------------------------- 15464 -- Is_Attribute_Update -- 15465 ------------------------- 15466 15467 function Is_Attribute_Update (N : Node_Id) return Boolean is 15468 begin 15469 return Nkind (N) = N_Attribute_Reference 15470 and then Attribute_Name (N) = Name_Update; 15471 end Is_Attribute_Update; 15472 15473 ------------------------------------ 15474 -- Is_Body_Or_Package_Declaration -- 15475 ------------------------------------ 15476 15477 function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is 15478 begin 15479 return Is_Body (N) or else Nkind (N) = N_Package_Declaration; 15480 end Is_Body_Or_Package_Declaration; 15481 15482 ----------------------- 15483 -- Is_Bounded_String -- 15484 ----------------------- 15485 15486 function Is_Bounded_String (T : Entity_Id) return Boolean is 15487 Under : constant Entity_Id := Underlying_Type (Root_Type (T)); 15488 15489 begin 15490 -- Check whether T is ultimately derived from Ada.Strings.Superbounded. 15491 -- Super_String, or one of the [Wide_]Wide_ versions. This will 15492 -- be True for all the Bounded_String types in instances of the 15493 -- Generic_Bounded_Length generics, and for types derived from those. 15494 15495 return Present (Under) 15496 and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else 15497 Is_RTE (Root_Type (Under), RO_WI_Super_String) or else 15498 Is_RTE (Root_Type (Under), RO_WW_Super_String)); 15499 end Is_Bounded_String; 15500 15501 ------------------------------- 15502 -- Is_By_Protected_Procedure -- 15503 ------------------------------- 15504 15505 function Is_By_Protected_Procedure (Id : Entity_Id) return Boolean is 15506 begin 15507 return Ekind (Id) = E_Procedure 15508 and then Present (Get_Rep_Pragma (Id, Name_Implemented)) 15509 and then Implementation_Kind (Id) = Name_By_Protected_Procedure; 15510 end Is_By_Protected_Procedure; 15511 15512 --------------------- 15513 -- Is_CCT_Instance -- 15514 --------------------- 15515 15516 function Is_CCT_Instance 15517 (Ref_Id : Entity_Id; 15518 Context_Id : Entity_Id) return Boolean 15519 is 15520 begin 15521 pragma Assert (Ekind (Ref_Id) in E_Protected_Type | E_Task_Type); 15522 15523 if Is_Single_Task_Object (Context_Id) then 15524 return Scope_Within_Or_Same (Etype (Context_Id), Ref_Id); 15525 15526 else 15527 pragma Assert 15528 (Ekind (Context_Id) in 15529 E_Entry | E_Entry_Family | E_Function | E_Package | 15530 E_Procedure | E_Protected_Type | E_Task_Type 15531 or else Is_Record_Type (Context_Id)); 15532 return Scope_Within_Or_Same (Context_Id, Ref_Id); 15533 end if; 15534 end Is_CCT_Instance; 15535 15536 ------------------------- 15537 -- Is_Child_Or_Sibling -- 15538 ------------------------- 15539 15540 function Is_Child_Or_Sibling 15541 (Pack_1 : Entity_Id; 15542 Pack_2 : Entity_Id) return Boolean 15543 is 15544 function Distance_From_Standard (Pack : Entity_Id) return Nat; 15545 -- Given an arbitrary package, return the number of "climbs" necessary 15546 -- to reach scope Standard_Standard. 15547 15548 procedure Equalize_Depths 15549 (Pack : in out Entity_Id; 15550 Depth : in out Nat; 15551 Depth_To_Reach : Nat); 15552 -- Given an arbitrary package, its depth and a target depth to reach, 15553 -- climb the scope chain until the said depth is reached. The pointer 15554 -- to the package and its depth a modified during the climb. 15555 15556 ---------------------------- 15557 -- Distance_From_Standard -- 15558 ---------------------------- 15559 15560 function Distance_From_Standard (Pack : Entity_Id) return Nat is 15561 Dist : Nat; 15562 Scop : Entity_Id; 15563 15564 begin 15565 Dist := 0; 15566 Scop := Pack; 15567 while Present (Scop) and then Scop /= Standard_Standard loop 15568 Dist := Dist + 1; 15569 Scop := Scope (Scop); 15570 end loop; 15571 15572 return Dist; 15573 end Distance_From_Standard; 15574 15575 --------------------- 15576 -- Equalize_Depths -- 15577 --------------------- 15578 15579 procedure Equalize_Depths 15580 (Pack : in out Entity_Id; 15581 Depth : in out Nat; 15582 Depth_To_Reach : Nat) 15583 is 15584 begin 15585 -- The package must be at a greater or equal depth 15586 15587 if Depth < Depth_To_Reach then 15588 raise Program_Error; 15589 end if; 15590 15591 -- Climb the scope chain until the desired depth is reached 15592 15593 while Present (Pack) and then Depth /= Depth_To_Reach loop 15594 Pack := Scope (Pack); 15595 Depth := Depth - 1; 15596 end loop; 15597 end Equalize_Depths; 15598 15599 -- Local variables 15600 15601 P_1 : Entity_Id := Pack_1; 15602 P_1_Child : Boolean := False; 15603 P_1_Depth : Nat := Distance_From_Standard (P_1); 15604 P_2 : Entity_Id := Pack_2; 15605 P_2_Child : Boolean := False; 15606 P_2_Depth : Nat := Distance_From_Standard (P_2); 15607 15608 -- Start of processing for Is_Child_Or_Sibling 15609 15610 begin 15611 pragma Assert 15612 (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package); 15613 15614 -- Both packages denote the same entity, therefore they cannot be 15615 -- children or siblings. 15616 15617 if P_1 = P_2 then 15618 return False; 15619 15620 -- One of the packages is at a deeper level than the other. Note that 15621 -- both may still come from different hierarchies. 15622 15623 -- (root) P_2 15624 -- / \ : 15625 -- X P_2 or X 15626 -- : : 15627 -- P_1 P_1 15628 15629 elsif P_1_Depth > P_2_Depth then 15630 Equalize_Depths 15631 (Pack => P_1, 15632 Depth => P_1_Depth, 15633 Depth_To_Reach => P_2_Depth); 15634 P_1_Child := True; 15635 15636 -- (root) P_1 15637 -- / \ : 15638 -- P_1 X or X 15639 -- : : 15640 -- P_2 P_2 15641 15642 elsif P_2_Depth > P_1_Depth then 15643 Equalize_Depths 15644 (Pack => P_2, 15645 Depth => P_2_Depth, 15646 Depth_To_Reach => P_1_Depth); 15647 P_2_Child := True; 15648 end if; 15649 15650 -- At this stage the package pointers have been elevated to the same 15651 -- depth. If the related entities are the same, then one package is a 15652 -- potential child of the other: 15653 15654 -- P_1 15655 -- : 15656 -- X became P_1 P_2 or vice versa 15657 -- : 15658 -- P_2 15659 15660 if P_1 = P_2 then 15661 if P_1_Child then 15662 return Is_Child_Unit (Pack_1); 15663 15664 else pragma Assert (P_2_Child); 15665 return Is_Child_Unit (Pack_2); 15666 end if; 15667 15668 -- The packages may come from the same package chain or from entirely 15669 -- different hierarcies. To determine this, climb the scope stack until 15670 -- a common root is found. 15671 15672 -- (root) (root 1) (root 2) 15673 -- / \ | | 15674 -- P_1 P_2 P_1 P_2 15675 15676 else 15677 while Present (P_1) and then Present (P_2) loop 15678 15679 -- The two packages may be siblings 15680 15681 if P_1 = P_2 then 15682 return Is_Child_Unit (Pack_1) and then Is_Child_Unit (Pack_2); 15683 end if; 15684 15685 P_1 := Scope (P_1); 15686 P_2 := Scope (P_2); 15687 end loop; 15688 end if; 15689 15690 return False; 15691 end Is_Child_Or_Sibling; 15692 15693 ------------------- 15694 -- Is_Confirming -- 15695 ------------------- 15696 15697 function Is_Confirming (Aspect : Nonoverridable_Aspect_Id; 15698 Aspect_Spec_1, Aspect_Spec_2 : Node_Id) 15699 return Boolean is 15700 function Names_Match (Nm1, Nm2 : Node_Id) return Boolean; 15701 function Names_Match (Nm1, Nm2 : Node_Id) return Boolean is 15702 begin 15703 if Nkind (Nm1) /= Nkind (Nm2) then 15704 return False; 15705 end if; 15706 case Nkind (Nm1) is 15707 when N_Identifier => 15708 return Name_Equals (Chars (Nm1), Chars (Nm2)); 15709 when N_Expanded_Name => 15710 return Names_Match (Prefix (Nm1), Prefix (Nm2)) 15711 and then Names_Match (Selector_Name (Nm1), 15712 Selector_Name (Nm2)); 15713 when N_Empty => 15714 return True; -- needed for Aggregate aspect checking 15715 15716 when others => 15717 -- e.g., 'Class attribute references 15718 if Is_Entity_Name (Nm1) and Is_Entity_Name (Nm2) then 15719 return Entity (Nm1) = Entity (Nm2); 15720 end if; 15721 15722 raise Program_Error; 15723 end case; 15724 end Names_Match; 15725 begin 15726 -- allow users to disable "shall be confirming" check, at least for now 15727 if Relaxed_RM_Semantics then 15728 return True; 15729 end if; 15730 15731 -- ??? Type conversion here (along with "when others =>" below) is a 15732 -- workaround for a bootstrapping problem related to casing on a 15733 -- static-predicate-bearing subtype. 15734 15735 case Aspect_Id (Aspect) is 15736 -- name-valued aspects; compare text of names, not resolution. 15737 when Aspect_Default_Iterator 15738 | Aspect_Iterator_Element 15739 | Aspect_Constant_Indexing 15740 | Aspect_Variable_Indexing 15741 | Aspect_Implicit_Dereference => 15742 declare 15743 Item_1 : constant Node_Id := Aspect_Rep_Item (Aspect_Spec_1); 15744 Item_2 : constant Node_Id := Aspect_Rep_Item (Aspect_Spec_2); 15745 begin 15746 if (Nkind (Item_1) /= N_Attribute_Definition_Clause) 15747 or (Nkind (Item_2) /= N_Attribute_Definition_Clause) 15748 then 15749 pragma Assert (Serious_Errors_Detected > 0); 15750 return True; 15751 end if; 15752 15753 return Names_Match (Expression (Item_1), 15754 Expression (Item_2)); 15755 end; 15756 15757 -- one of a kind 15758 when Aspect_Aggregate => 15759 declare 15760 Empty_1, 15761 Add_Named_1, 15762 Add_Unnamed_1, 15763 New_Indexed_1, 15764 Assign_Indexed_1, 15765 Empty_2, 15766 Add_Named_2, 15767 Add_Unnamed_2, 15768 New_Indexed_2, 15769 Assign_Indexed_2 : Node_Id := Empty; 15770 begin 15771 Parse_Aspect_Aggregate 15772 (N => Expression (Aspect_Spec_1), 15773 Empty_Subp => Empty_1, 15774 Add_Named_Subp => Add_Named_1, 15775 Add_Unnamed_Subp => Add_Unnamed_1, 15776 New_Indexed_Subp => New_Indexed_1, 15777 Assign_Indexed_Subp => Assign_Indexed_1); 15778 Parse_Aspect_Aggregate 15779 (N => Expression (Aspect_Spec_2), 15780 Empty_Subp => Empty_2, 15781 Add_Named_Subp => Add_Named_2, 15782 Add_Unnamed_Subp => Add_Unnamed_2, 15783 New_Indexed_Subp => New_Indexed_2, 15784 Assign_Indexed_Subp => Assign_Indexed_2); 15785 return 15786 Names_Match (Empty_1, Empty_2) and then 15787 Names_Match (Add_Named_1, Add_Named_2) and then 15788 Names_Match (Add_Unnamed_1, Add_Unnamed_2) and then 15789 Names_Match (New_Indexed_1, New_Indexed_2) and then 15790 Names_Match (Assign_Indexed_1, Assign_Indexed_2); 15791 end; 15792 15793 -- scalar-valued aspects; compare (static) values. 15794 when Aspect_Max_Entry_Queue_Length -- | Aspect_No_Controlled_Parts 15795 => 15796 -- This should be unreachable. No_Controlled_Parts is 15797 -- not yet supported at all in GNAT and Max_Entry_Queue_Length 15798 -- is supported only for protected entries, not for types. 15799 pragma Assert (Serious_Errors_Detected /= 0); 15800 return True; 15801 15802 when others => 15803 raise Program_Error; 15804 end case; 15805 end Is_Confirming; 15806 15807 ----------------------------- 15808 -- Is_Concurrent_Interface -- 15809 ----------------------------- 15810 15811 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is 15812 begin 15813 return Is_Interface (T) 15814 and then 15815 (Is_Protected_Interface (T) 15816 or else Is_Synchronized_Interface (T) 15817 or else Is_Task_Interface (T)); 15818 end Is_Concurrent_Interface; 15819 15820 ----------------------- 15821 -- Is_Constant_Bound -- 15822 ----------------------- 15823 15824 function Is_Constant_Bound (Exp : Node_Id) return Boolean is 15825 begin 15826 if Compile_Time_Known_Value (Exp) then 15827 return True; 15828 15829 elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then 15830 return Is_Constant_Object (Entity (Exp)) 15831 or else Ekind (Entity (Exp)) = E_Enumeration_Literal; 15832 15833 elsif Nkind (Exp) in N_Binary_Op then 15834 return Is_Constant_Bound (Left_Opnd (Exp)) 15835 and then Is_Constant_Bound (Right_Opnd (Exp)) 15836 and then Scope (Entity (Exp)) = Standard_Standard; 15837 15838 else 15839 return False; 15840 end if; 15841 end Is_Constant_Bound; 15842 15843 --------------------------- 15844 -- Is_Container_Element -- 15845 --------------------------- 15846 15847 function Is_Container_Element (Exp : Node_Id) return Boolean is 15848 Loc : constant Source_Ptr := Sloc (Exp); 15849 Pref : constant Node_Id := Prefix (Exp); 15850 15851 Call : Node_Id; 15852 -- Call to an indexing aspect 15853 15854 Cont_Typ : Entity_Id; 15855 -- The type of the container being accessed 15856 15857 Elem_Typ : Entity_Id; 15858 -- Its element type 15859 15860 Indexing : Entity_Id; 15861 Is_Const : Boolean; 15862 -- Indicates that constant indexing is used, and the element is thus 15863 -- a constant. 15864 15865 Ref_Typ : Entity_Id; 15866 -- The reference type returned by the indexing operation 15867 15868 begin 15869 -- If C is a container, in a context that imposes the element type of 15870 -- that container, the indexing notation C (X) is rewritten as: 15871 15872 -- Indexing (C, X).Discr.all 15873 15874 -- where Indexing is one of the indexing aspects of the container. 15875 -- If the context does not require a reference, the construct can be 15876 -- rewritten as 15877 15878 -- Element (C, X) 15879 15880 -- First, verify that the construct has the proper form 15881 15882 if not Expander_Active then 15883 return False; 15884 15885 elsif Nkind (Pref) /= N_Selected_Component then 15886 return False; 15887 15888 elsif Nkind (Prefix (Pref)) /= N_Function_Call then 15889 return False; 15890 15891 else 15892 Call := Prefix (Pref); 15893 Ref_Typ := Etype (Call); 15894 end if; 15895 15896 if not Has_Implicit_Dereference (Ref_Typ) 15897 or else No (First (Parameter_Associations (Call))) 15898 or else not Is_Entity_Name (Name (Call)) 15899 then 15900 return False; 15901 end if; 15902 15903 -- Retrieve type of container object, and its iterator aspects 15904 15905 Cont_Typ := Etype (First (Parameter_Associations (Call))); 15906 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Constant_Indexing); 15907 Is_Const := False; 15908 15909 if No (Indexing) then 15910 15911 -- Container should have at least one indexing operation 15912 15913 return False; 15914 15915 elsif Entity (Name (Call)) /= Entity (Indexing) then 15916 15917 -- This may be a variable indexing operation 15918 15919 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Variable_Indexing); 15920 15921 if No (Indexing) 15922 or else Entity (Name (Call)) /= Entity (Indexing) 15923 then 15924 return False; 15925 end if; 15926 15927 else 15928 Is_Const := True; 15929 end if; 15930 15931 Elem_Typ := Find_Value_Of_Aspect (Cont_Typ, Aspect_Iterator_Element); 15932 15933 if No (Elem_Typ) or else Entity (Elem_Typ) /= Etype (Exp) then 15934 return False; 15935 end if; 15936 15937 -- Check that the expression is not the target of an assignment, in 15938 -- which case the rewriting is not possible. 15939 15940 if not Is_Const then 15941 declare 15942 Par : Node_Id; 15943 15944 begin 15945 Par := Exp; 15946 while Present (Par) 15947 loop 15948 if Nkind (Parent (Par)) = N_Assignment_Statement 15949 and then Par = Name (Parent (Par)) 15950 then 15951 return False; 15952 15953 -- A renaming produces a reference, and the transformation 15954 -- does not apply. 15955 15956 elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then 15957 return False; 15958 15959 elsif Nkind (Parent (Par)) in 15960 N_Function_Call | 15961 N_Procedure_Call_Statement | 15962 N_Entry_Call_Statement 15963 then 15964 -- Check that the element is not part of an actual for an 15965 -- in-out parameter. 15966 15967 declare 15968 F : Entity_Id; 15969 A : Node_Id; 15970 15971 begin 15972 F := First_Formal (Entity (Name (Parent (Par)))); 15973 A := First (Parameter_Associations (Parent (Par))); 15974 while Present (F) loop 15975 if A = Par and then Ekind (F) /= E_In_Parameter then 15976 return False; 15977 end if; 15978 15979 Next_Formal (F); 15980 Next (A); 15981 end loop; 15982 end; 15983 15984 -- E_In_Parameter in a call: element is not modified. 15985 15986 exit; 15987 end if; 15988 15989 Par := Parent (Par); 15990 end loop; 15991 end; 15992 end if; 15993 15994 -- The expression has the proper form and the context requires the 15995 -- element type. Retrieve the Element function of the container and 15996 -- rewrite the construct as a call to it. 15997 15998 declare 15999 Op : Elmt_Id; 16000 16001 begin 16002 Op := First_Elmt (Primitive_Operations (Cont_Typ)); 16003 while Present (Op) loop 16004 exit when Chars (Node (Op)) = Name_Element; 16005 Next_Elmt (Op); 16006 end loop; 16007 16008 if No (Op) then 16009 return False; 16010 16011 else 16012 Rewrite (Exp, 16013 Make_Function_Call (Loc, 16014 Name => New_Occurrence_Of (Node (Op), Loc), 16015 Parameter_Associations => Parameter_Associations (Call))); 16016 Analyze_And_Resolve (Exp, Entity (Elem_Typ)); 16017 return True; 16018 end if; 16019 end; 16020 end Is_Container_Element; 16021 16022 ---------------------------- 16023 -- Is_Contract_Annotation -- 16024 ---------------------------- 16025 16026 function Is_Contract_Annotation (Item : Node_Id) return Boolean is 16027 begin 16028 return Is_Package_Contract_Annotation (Item) 16029 or else 16030 Is_Subprogram_Contract_Annotation (Item); 16031 end Is_Contract_Annotation; 16032 16033 -------------------------------------- 16034 -- Is_Controlling_Limited_Procedure -- 16035 -------------------------------------- 16036 16037 function Is_Controlling_Limited_Procedure 16038 (Proc_Nam : Entity_Id) return Boolean 16039 is 16040 Param : Node_Id; 16041 Param_Typ : Entity_Id := Empty; 16042 16043 begin 16044 if Ekind (Proc_Nam) = E_Procedure 16045 and then Present (Parameter_Specifications (Parent (Proc_Nam))) 16046 then 16047 Param := 16048 Parameter_Type 16049 (First (Parameter_Specifications (Parent (Proc_Nam)))); 16050 16051 -- The formal may be an anonymous access type 16052 16053 if Nkind (Param) = N_Access_Definition then 16054 Param_Typ := Entity (Subtype_Mark (Param)); 16055 else 16056 Param_Typ := Etype (Param); 16057 end if; 16058 16059 -- In the case where an Itype was created for a dispatchin call, the 16060 -- procedure call has been rewritten. The actual may be an access to 16061 -- interface type in which case it is the designated type that is the 16062 -- controlling type. 16063 16064 elsif Present (Associated_Node_For_Itype (Proc_Nam)) 16065 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam))) 16066 and then 16067 Present (Parameter_Associations 16068 (Associated_Node_For_Itype (Proc_Nam))) 16069 then 16070 Param_Typ := 16071 Etype (First (Parameter_Associations 16072 (Associated_Node_For_Itype (Proc_Nam)))); 16073 16074 if Ekind (Param_Typ) = E_Anonymous_Access_Type then 16075 Param_Typ := Directly_Designated_Type (Param_Typ); 16076 end if; 16077 end if; 16078 16079 if Present (Param_Typ) then 16080 return 16081 Is_Interface (Param_Typ) 16082 and then Is_Limited_Record (Param_Typ); 16083 end if; 16084 16085 return False; 16086 end Is_Controlling_Limited_Procedure; 16087 16088 ----------------------------- 16089 -- Is_CPP_Constructor_Call -- 16090 ----------------------------- 16091 16092 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is 16093 begin 16094 return Nkind (N) = N_Function_Call 16095 and then Is_CPP_Class (Etype (Etype (N))) 16096 and then Is_Constructor (Entity (Name (N))) 16097 and then Is_Imported (Entity (Name (N))); 16098 end Is_CPP_Constructor_Call; 16099 16100 ------------------------- 16101 -- Is_Current_Instance -- 16102 ------------------------- 16103 16104 function Is_Current_Instance (N : Node_Id) return Boolean is 16105 Typ : constant Entity_Id := Entity (N); 16106 P : Node_Id; 16107 16108 begin 16109 -- Simplest case: entity is a concurrent type and we are currently 16110 -- inside the body. This will eventually be expanded into a call to 16111 -- Self (for tasks) or _object (for protected objects). 16112 16113 if Is_Concurrent_Type (Typ) and then In_Open_Scopes (Typ) then 16114 return True; 16115 16116 else 16117 -- Check whether the context is a (sub)type declaration for the 16118 -- type entity. 16119 16120 P := Parent (N); 16121 while Present (P) loop 16122 if Nkind (P) in N_Full_Type_Declaration 16123 | N_Private_Type_Declaration 16124 | N_Subtype_Declaration 16125 and then Comes_From_Source (P) 16126 and then Defining_Entity (P) = Typ 16127 then 16128 return True; 16129 16130 -- A subtype name may appear in an aspect specification for a 16131 -- Predicate_Failure aspect, for which we do not construct a 16132 -- wrapper procedure. The subtype will be replaced by the 16133 -- expression being tested when the corresponding predicate 16134 -- check is expanded. 16135 16136 elsif Nkind (P) = N_Aspect_Specification 16137 and then Nkind (Parent (P)) = N_Subtype_Declaration 16138 then 16139 return True; 16140 16141 elsif Nkind (P) = N_Pragma 16142 and then Get_Pragma_Id (P) = Pragma_Predicate_Failure 16143 then 16144 return True; 16145 end if; 16146 16147 P := Parent (P); 16148 end loop; 16149 end if; 16150 16151 -- In any other context this is not a current occurrence 16152 16153 return False; 16154 end Is_Current_Instance; 16155 16156 -------------------------------------------------- 16157 -- Is_Current_Instance_Reference_In_Type_Aspect -- 16158 -------------------------------------------------- 16159 16160 function Is_Current_Instance_Reference_In_Type_Aspect 16161 (N : Node_Id) return Boolean 16162 is 16163 begin 16164 -- When a current_instance is referenced within an aspect_specification 16165 -- of a type or subtype, it will show up as a reference to the formal 16166 -- parameter of the aspect's associated subprogram rather than as a 16167 -- reference to the type or subtype itself (in fact, the original name 16168 -- is never even analyzed). We check for predicate, invariant, and 16169 -- Default_Initial_Condition subprograms (in theory there could be 16170 -- other cases added, in which case this function will need updating). 16171 16172 if Is_Entity_Name (N) then 16173 return Present (Entity (N)) 16174 and then Ekind (Entity (N)) = E_In_Parameter 16175 and then Ekind (Scope (Entity (N))) in E_Function | E_Procedure 16176 and then 16177 (Is_Predicate_Function (Scope (Entity (N))) 16178 or else Is_Predicate_Function_M (Scope (Entity (N))) 16179 or else Is_Invariant_Procedure (Scope (Entity (N))) 16180 or else Is_Partial_Invariant_Procedure (Scope (Entity (N))) 16181 or else Is_DIC_Procedure (Scope (Entity (N)))); 16182 16183 else 16184 case Nkind (N) is 16185 when N_Indexed_Component 16186 | N_Slice 16187 => 16188 return 16189 Is_Current_Instance_Reference_In_Type_Aspect (Prefix (N)); 16190 16191 when N_Selected_Component => 16192 return 16193 Is_Current_Instance_Reference_In_Type_Aspect (Prefix (N)); 16194 16195 when N_Type_Conversion => 16196 return Is_Current_Instance_Reference_In_Type_Aspect 16197 (Expression (N)); 16198 16199 when N_Qualified_Expression => 16200 return Is_Current_Instance_Reference_In_Type_Aspect 16201 (Expression (N)); 16202 16203 when others => 16204 return False; 16205 end case; 16206 end if; 16207 end Is_Current_Instance_Reference_In_Type_Aspect; 16208 16209 -------------------- 16210 -- Is_Declaration -- 16211 -------------------- 16212 16213 function Is_Declaration 16214 (N : Node_Id; 16215 Body_OK : Boolean := True; 16216 Concurrent_OK : Boolean := True; 16217 Formal_OK : Boolean := True; 16218 Generic_OK : Boolean := True; 16219 Instantiation_OK : Boolean := True; 16220 Renaming_OK : Boolean := True; 16221 Stub_OK : Boolean := True; 16222 Subprogram_OK : Boolean := True; 16223 Type_OK : Boolean := True) return Boolean 16224 is 16225 begin 16226 case Nkind (N) is 16227 16228 -- Body declarations 16229 16230 when N_Proper_Body => 16231 return Body_OK; 16232 16233 -- Concurrent type declarations 16234 16235 when N_Protected_Type_Declaration 16236 | N_Single_Protected_Declaration 16237 | N_Single_Task_Declaration 16238 | N_Task_Type_Declaration 16239 => 16240 return Concurrent_OK or Type_OK; 16241 16242 -- Formal declarations 16243 16244 when N_Formal_Abstract_Subprogram_Declaration 16245 | N_Formal_Concrete_Subprogram_Declaration 16246 | N_Formal_Object_Declaration 16247 | N_Formal_Package_Declaration 16248 | N_Formal_Type_Declaration 16249 => 16250 return Formal_OK; 16251 16252 -- Generic declarations 16253 16254 when N_Generic_Package_Declaration 16255 | N_Generic_Subprogram_Declaration 16256 => 16257 return Generic_OK; 16258 16259 -- Generic instantiations 16260 16261 when N_Function_Instantiation 16262 | N_Package_Instantiation 16263 | N_Procedure_Instantiation 16264 => 16265 return Instantiation_OK; 16266 16267 -- Generic renaming declarations 16268 16269 when N_Generic_Renaming_Declaration => 16270 return Generic_OK or Renaming_OK; 16271 16272 -- Renaming declarations 16273 16274 when N_Exception_Renaming_Declaration 16275 | N_Object_Renaming_Declaration 16276 | N_Package_Renaming_Declaration 16277 | N_Subprogram_Renaming_Declaration 16278 => 16279 return Renaming_OK; 16280 16281 -- Stub declarations 16282 16283 when N_Body_Stub => 16284 return Stub_OK; 16285 16286 -- Subprogram declarations 16287 16288 when N_Abstract_Subprogram_Declaration 16289 | N_Entry_Declaration 16290 | N_Expression_Function 16291 | N_Subprogram_Declaration 16292 => 16293 return Subprogram_OK; 16294 16295 -- Type declarations 16296 16297 when N_Full_Type_Declaration 16298 | N_Incomplete_Type_Declaration 16299 | N_Private_Extension_Declaration 16300 | N_Private_Type_Declaration 16301 | N_Subtype_Declaration 16302 => 16303 return Type_OK; 16304 16305 -- Miscellaneous 16306 16307 when N_Component_Declaration 16308 | N_Exception_Declaration 16309 | N_Implicit_Label_Declaration 16310 | N_Number_Declaration 16311 | N_Object_Declaration 16312 | N_Package_Declaration 16313 => 16314 return True; 16315 16316 when others => 16317 return False; 16318 end case; 16319 end Is_Declaration; 16320 16321 -------------------------------- 16322 -- Is_Declared_Within_Variant -- 16323 -------------------------------- 16324 16325 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is 16326 Comp_Decl : constant Node_Id := Parent (Comp); 16327 Comp_List : constant Node_Id := Parent (Comp_Decl); 16328 begin 16329 return Nkind (Parent (Comp_List)) = N_Variant; 16330 end Is_Declared_Within_Variant; 16331 16332 ---------------------------------------------- 16333 -- Is_Dependent_Component_Of_Mutable_Object -- 16334 ---------------------------------------------- 16335 16336 function Is_Dependent_Component_Of_Mutable_Object 16337 (Object : Node_Id) return Boolean 16338 is 16339 P : Node_Id; 16340 Prefix_Type : Entity_Id; 16341 P_Aliased : Boolean := False; 16342 Comp : Entity_Id; 16343 16344 Deref : Node_Id := Original_Node (Object); 16345 -- Dereference node, in something like X.all.Y(2) 16346 16347 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object 16348 16349 begin 16350 -- Find the dereference node if any 16351 16352 while Nkind (Deref) in 16353 N_Indexed_Component | N_Selected_Component | N_Slice 16354 loop 16355 Deref := Original_Node (Prefix (Deref)); 16356 end loop; 16357 16358 -- If the prefix is a qualified expression of a variable, then function 16359 -- Is_Variable will return False for that because a qualified expression 16360 -- denotes a constant view, so we need to get the name being qualified 16361 -- so we can test below whether that's a variable (or a dereference). 16362 16363 if Nkind (Deref) = N_Qualified_Expression then 16364 Deref := Expression (Deref); 16365 end if; 16366 16367 -- Ada 2005: If we have a component or slice of a dereference, something 16368 -- like X.all.Y (2) and the type of X is access-to-constant, Is_Variable 16369 -- will return False, because it is indeed a constant view. But it might 16370 -- be a view of a variable object, so we want the following condition to 16371 -- be True in that case. 16372 16373 if Is_Variable (Object) 16374 or else Is_Variable (Deref) 16375 or else 16376 (Ada_Version >= Ada_2005 16377 and then (Nkind (Deref) = N_Explicit_Dereference 16378 or else (Present (Etype (Deref)) 16379 and then Is_Access_Type (Etype (Deref))))) 16380 then 16381 if Nkind (Object) = N_Selected_Component then 16382 16383 -- If the selector is not a component, then we definitely return 16384 -- False (it could be a function selector in a prefix form call 16385 -- occurring in an iterator specification). 16386 16387 if Ekind (Entity (Selector_Name (Object))) not in 16388 E_Component | E_Discriminant 16389 then 16390 return False; 16391 end if; 16392 16393 -- Get the original node of the prefix in case it has been 16394 -- rewritten, which can occur, for example, in qualified 16395 -- expression cases. Also, a discriminant check on a selected 16396 -- component may be expanded into a dereference when removing 16397 -- side effects, and the subtype of the original node may be 16398 -- unconstrained. 16399 16400 P := Original_Node (Prefix (Object)); 16401 Prefix_Type := Etype (P); 16402 16403 -- If the prefix is a qualified expression, we want to look at its 16404 -- operand. 16405 16406 if Nkind (P) = N_Qualified_Expression then 16407 P := Expression (P); 16408 Prefix_Type := Etype (P); 16409 end if; 16410 16411 if Is_Entity_Name (P) then 16412 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then 16413 Prefix_Type := Base_Type (Prefix_Type); 16414 end if; 16415 16416 if Is_Aliased (Entity (P)) then 16417 P_Aliased := True; 16418 end if; 16419 16420 -- For explicit dereferences we get the access prefix so we can 16421 -- treat this similarly to implicit dereferences and examine the 16422 -- kind of the access type and its designated subtype further 16423 -- below. 16424 16425 elsif Nkind (P) = N_Explicit_Dereference then 16426 P := Prefix (P); 16427 Prefix_Type := Etype (P); 16428 16429 else 16430 -- Check for prefix being an aliased component??? 16431 16432 null; 16433 end if; 16434 16435 -- A heap object is constrained by its initial value 16436 16437 -- Ada 2005 (AI-363): Always assume the object could be mutable in 16438 -- the dereferenced case, since the access value might denote an 16439 -- unconstrained aliased object, whereas in Ada 95 the designated 16440 -- object is guaranteed to be constrained. A worst-case assumption 16441 -- has to apply in Ada 2005 because we can't tell at compile 16442 -- time whether the object is "constrained by its initial value", 16443 -- despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic 16444 -- rules (these rules are acknowledged to need fixing). We don't 16445 -- impose this more stringent checking for earlier Ada versions or 16446 -- when Relaxed_RM_Semantics applies (the latter for CodePeer's 16447 -- benefit, though it's unclear on why using -gnat95 would not be 16448 -- sufficient???). 16449 16450 if Ada_Version < Ada_2005 or else Relaxed_RM_Semantics then 16451 if Is_Access_Type (Prefix_Type) 16452 or else Nkind (P) = N_Explicit_Dereference 16453 then 16454 return False; 16455 end if; 16456 16457 else pragma Assert (Ada_Version >= Ada_2005); 16458 if Is_Access_Type (Prefix_Type) then 16459 -- We need to make sure we have the base subtype, in case 16460 -- this is actually an access subtype (whose Ekind will be 16461 -- E_Access_Subtype). 16462 16463 Prefix_Type := Etype (Prefix_Type); 16464 16465 -- If the access type is pool-specific, and there is no 16466 -- constrained partial view of the designated type, then the 16467 -- designated object is known to be constrained. If it's a 16468 -- formal access type and the renaming is in the generic 16469 -- spec, we also treat it as pool-specific (known to be 16470 -- constrained), but assume the worst if in the generic body 16471 -- (see RM 3.3(23.3/3)). 16472 16473 if Ekind (Prefix_Type) = E_Access_Type 16474 and then (not Is_Generic_Type (Prefix_Type) 16475 or else not In_Generic_Body (Current_Scope)) 16476 and then not Object_Type_Has_Constrained_Partial_View 16477 (Typ => Designated_Type (Prefix_Type), 16478 Scop => Current_Scope) 16479 then 16480 return False; 16481 16482 -- Otherwise (general access type, or there is a constrained 16483 -- partial view of the designated type), we need to check 16484 -- based on the designated type. 16485 16486 else 16487 Prefix_Type := Designated_Type (Prefix_Type); 16488 end if; 16489 end if; 16490 end if; 16491 16492 Comp := 16493 Original_Record_Component (Entity (Selector_Name (Object))); 16494 16495 -- As per AI-0017, the renaming is illegal in a generic body, even 16496 -- if the subtype is indefinite (only applies to prefixes of an 16497 -- untagged formal type, see RM 3.3 (23.11/3)). 16498 16499 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable 16500 16501 if not Is_Constrained (Prefix_Type) 16502 and then (Is_Definite_Subtype (Prefix_Type) 16503 or else 16504 (not Is_Tagged_Type (Prefix_Type) 16505 and then Is_Generic_Type (Prefix_Type) 16506 and then In_Generic_Body (Current_Scope))) 16507 16508 and then (Is_Declared_Within_Variant (Comp) 16509 or else Has_Discriminant_Dependent_Constraint (Comp)) 16510 and then (not P_Aliased or else Ada_Version >= Ada_2005) 16511 then 16512 return True; 16513 16514 -- If the prefix is of an access type at this point, then we want 16515 -- to return False, rather than calling this function recursively 16516 -- on the access object (which itself might be a discriminant- 16517 -- dependent component of some other object, but that isn't 16518 -- relevant to checking the object passed to us). This avoids 16519 -- issuing wrong errors when compiling with -gnatc, where there 16520 -- can be implicit dereferences that have not been expanded. 16521 16522 elsif Is_Access_Type (Etype (Prefix (Object))) then 16523 return False; 16524 16525 else 16526 return 16527 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 16528 end if; 16529 16530 elsif Nkind (Object) = N_Indexed_Component 16531 or else Nkind (Object) = N_Slice 16532 then 16533 return Is_Dependent_Component_Of_Mutable_Object 16534 (Original_Node (Prefix (Object))); 16535 16536 -- A type conversion that Is_Variable is a view conversion: 16537 -- go back to the denoted object. 16538 16539 elsif Nkind (Object) = N_Type_Conversion then 16540 return 16541 Is_Dependent_Component_Of_Mutable_Object 16542 (Original_Node (Expression (Object))); 16543 end if; 16544 end if; 16545 16546 return False; 16547 end Is_Dependent_Component_Of_Mutable_Object; 16548 16549 --------------------- 16550 -- Is_Dereferenced -- 16551 --------------------- 16552 16553 function Is_Dereferenced (N : Node_Id) return Boolean is 16554 P : constant Node_Id := Parent (N); 16555 begin 16556 return Nkind (P) in N_Selected_Component 16557 | N_Explicit_Dereference 16558 | N_Indexed_Component 16559 | N_Slice 16560 and then Prefix (P) = N; 16561 end Is_Dereferenced; 16562 16563 ---------------------- 16564 -- Is_Descendant_Of -- 16565 ---------------------- 16566 16567 function Is_Descendant_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is 16568 T : Entity_Id; 16569 Etyp : Entity_Id; 16570 16571 begin 16572 pragma Assert (Nkind (T1) in N_Entity); 16573 pragma Assert (Nkind (T2) in N_Entity); 16574 16575 T := Base_Type (T1); 16576 16577 -- Immediate return if the types match 16578 16579 if T = T2 then 16580 return True; 16581 16582 -- Comment needed here ??? 16583 16584 elsif Ekind (T) = E_Class_Wide_Type then 16585 return Etype (T) = T2; 16586 16587 -- All other cases 16588 16589 else 16590 loop 16591 Etyp := Etype (T); 16592 16593 -- Done if we found the type we are looking for 16594 16595 if Etyp = T2 then 16596 return True; 16597 16598 -- Done if no more derivations to check 16599 16600 elsif T = T1 16601 or else T = Etyp 16602 then 16603 return False; 16604 16605 -- Following test catches error cases resulting from prev errors 16606 16607 elsif No (Etyp) then 16608 return False; 16609 16610 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then 16611 return False; 16612 16613 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then 16614 return False; 16615 end if; 16616 16617 T := Base_Type (Etyp); 16618 end loop; 16619 end if; 16620 end Is_Descendant_Of; 16621 16622 ---------------------------------------- 16623 -- Is_Descendant_Of_Suspension_Object -- 16624 ---------------------------------------- 16625 16626 function Is_Descendant_Of_Suspension_Object 16627 (Typ : Entity_Id) return Boolean 16628 is 16629 Cur_Typ : Entity_Id; 16630 Par_Typ : Entity_Id; 16631 16632 begin 16633 -- Climb the type derivation chain checking each parent type against 16634 -- Suspension_Object. 16635 16636 Cur_Typ := Base_Type (Typ); 16637 while Present (Cur_Typ) loop 16638 Par_Typ := Etype (Cur_Typ); 16639 16640 -- The current type is a match 16641 16642 if Is_Suspension_Object (Cur_Typ) then 16643 return True; 16644 16645 -- Stop the traversal once the root of the derivation chain has been 16646 -- reached. In that case the current type is its own base type. 16647 16648 elsif Cur_Typ = Par_Typ then 16649 exit; 16650 end if; 16651 16652 Cur_Typ := Base_Type (Par_Typ); 16653 end loop; 16654 16655 return False; 16656 end Is_Descendant_Of_Suspension_Object; 16657 16658 --------------------------------------------- 16659 -- Is_Double_Precision_Floating_Point_Type -- 16660 --------------------------------------------- 16661 16662 function Is_Double_Precision_Floating_Point_Type 16663 (E : Entity_Id) return Boolean is 16664 begin 16665 return Is_Floating_Point_Type (E) 16666 and then Machine_Radix_Value (E) = Uint_2 16667 and then Machine_Mantissa_Value (E) = UI_From_Int (53) 16668 and then Machine_Emax_Value (E) = Uint_2 ** Uint_10 16669 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_10); 16670 end Is_Double_Precision_Floating_Point_Type; 16671 16672 ----------------------------- 16673 -- Is_Effectively_Volatile -- 16674 ----------------------------- 16675 16676 function Is_Effectively_Volatile 16677 (Id : Entity_Id; 16678 Ignore_Protected : Boolean := False) return Boolean is 16679 begin 16680 if Is_Type (Id) then 16681 16682 -- An arbitrary type is effectively volatile when it is subject to 16683 -- pragma Atomic or Volatile. 16684 16685 if Is_Volatile (Id) then 16686 return True; 16687 16688 -- An array type is effectively volatile when it is subject to pragma 16689 -- Atomic_Components or Volatile_Components or its component type is 16690 -- effectively volatile. 16691 16692 elsif Is_Array_Type (Id) then 16693 if Has_Volatile_Components (Id) then 16694 return True; 16695 else 16696 declare 16697 Anc : Entity_Id := Base_Type (Id); 16698 begin 16699 if Is_Private_Type (Anc) then 16700 Anc := Full_View (Anc); 16701 end if; 16702 16703 -- Test for presence of ancestor, as the full view of a 16704 -- private type may be missing in case of error. 16705 16706 return Present (Anc) 16707 and then Is_Effectively_Volatile 16708 (Component_Type (Anc), Ignore_Protected); 16709 end; 16710 end if; 16711 16712 -- A protected type is always volatile unless Ignore_Protected is 16713 -- True. 16714 16715 elsif Is_Protected_Type (Id) and then not Ignore_Protected then 16716 return True; 16717 16718 -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is 16719 -- automatically volatile. 16720 16721 elsif Is_Descendant_Of_Suspension_Object (Id) then 16722 return True; 16723 16724 -- Otherwise the type is not effectively volatile 16725 16726 else 16727 return False; 16728 end if; 16729 16730 -- Otherwise Id denotes an object 16731 16732 else pragma Assert (Is_Object (Id)); 16733 -- A volatile object for which No_Caching is enabled is not 16734 -- effectively volatile. 16735 16736 return 16737 (Is_Volatile (Id) 16738 and then not 16739 (Ekind (Id) = E_Variable and then No_Caching_Enabled (Id))) 16740 or else Has_Volatile_Components (Id) 16741 or else Is_Effectively_Volatile (Etype (Id), Ignore_Protected); 16742 end if; 16743 end Is_Effectively_Volatile; 16744 16745 ----------------------------------------- 16746 -- Is_Effectively_Volatile_For_Reading -- 16747 ----------------------------------------- 16748 16749 function Is_Effectively_Volatile_For_Reading 16750 (Id : Entity_Id; 16751 Ignore_Protected : Boolean := False) return Boolean 16752 is 16753 begin 16754 -- A concurrent type is effectively volatile for reading, except for a 16755 -- protected type when Ignore_Protected is True. 16756 16757 if Is_Task_Type (Id) 16758 or else (Is_Protected_Type (Id) and then not Ignore_Protected) 16759 then 16760 return True; 16761 16762 elsif Is_Effectively_Volatile (Id, Ignore_Protected) then 16763 16764 -- Other volatile types and objects are effectively volatile for 16765 -- reading when they have property Async_Writers or Effective_Reads 16766 -- set to True. This includes the case of an array type whose 16767 -- Volatile_Components aspect is True (hence it is effectively 16768 -- volatile) which does not have the properties Async_Writers 16769 -- and Effective_Reads set to False. 16770 16771 if Async_Writers_Enabled (Id) 16772 or else Effective_Reads_Enabled (Id) 16773 then 16774 return True; 16775 16776 -- In addition, an array type is effectively volatile for reading 16777 -- when its component type is effectively volatile for reading. 16778 16779 elsif Is_Array_Type (Id) then 16780 declare 16781 Anc : Entity_Id := Base_Type (Id); 16782 begin 16783 if Is_Private_Type (Anc) then 16784 Anc := Full_View (Anc); 16785 end if; 16786 16787 -- Test for presence of ancestor, as the full view of a 16788 -- private type may be missing in case of error. 16789 16790 return Present (Anc) 16791 and then Is_Effectively_Volatile_For_Reading 16792 (Component_Type (Anc), Ignore_Protected); 16793 end; 16794 end if; 16795 end if; 16796 16797 return False; 16798 16799 end Is_Effectively_Volatile_For_Reading; 16800 16801 ------------------------------------ 16802 -- Is_Effectively_Volatile_Object -- 16803 ------------------------------------ 16804 16805 function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean is 16806 function Is_Effectively_Volatile (E : Entity_Id) return Boolean is 16807 (Is_Effectively_Volatile (E, Ignore_Protected => False)); 16808 16809 function Is_Effectively_Volatile_Object_Inst 16810 is new Is_Effectively_Volatile_Object_Shared (Is_Effectively_Volatile); 16811 begin 16812 return Is_Effectively_Volatile_Object_Inst (N); 16813 end Is_Effectively_Volatile_Object; 16814 16815 ------------------------------------------------ 16816 -- Is_Effectively_Volatile_Object_For_Reading -- 16817 ------------------------------------------------ 16818 16819 function Is_Effectively_Volatile_Object_For_Reading 16820 (N : Node_Id) return Boolean 16821 is 16822 function Is_Effectively_Volatile_For_Reading 16823 (E : Entity_Id) return Boolean 16824 is (Is_Effectively_Volatile_For_Reading (E, Ignore_Protected => False)); 16825 16826 function Is_Effectively_Volatile_Object_For_Reading_Inst 16827 is new Is_Effectively_Volatile_Object_Shared 16828 (Is_Effectively_Volatile_For_Reading); 16829 begin 16830 return Is_Effectively_Volatile_Object_For_Reading_Inst (N); 16831 end Is_Effectively_Volatile_Object_For_Reading; 16832 16833 ------------------------------------------- 16834 -- Is_Effectively_Volatile_Object_Shared -- 16835 ------------------------------------------- 16836 16837 function Is_Effectively_Volatile_Object_Shared 16838 (N : Node_Id) return Boolean 16839 is 16840 begin 16841 if Is_Entity_Name (N) then 16842 return Is_Object (Entity (N)) 16843 and then Is_Effectively_Volatile_Entity (Entity (N)); 16844 16845 elsif Nkind (N) in N_Indexed_Component | N_Slice then 16846 return Is_Effectively_Volatile_Object_Shared (Prefix (N)); 16847 16848 elsif Nkind (N) = N_Selected_Component then 16849 return 16850 Is_Effectively_Volatile_Object_Shared (Prefix (N)) 16851 or else 16852 Is_Effectively_Volatile_Object_Shared (Selector_Name (N)); 16853 16854 elsif Nkind (N) in N_Qualified_Expression 16855 | N_Unchecked_Type_Conversion 16856 | N_Type_Conversion 16857 then 16858 return Is_Effectively_Volatile_Object_Shared (Expression (N)); 16859 16860 else 16861 return False; 16862 end if; 16863 end Is_Effectively_Volatile_Object_Shared; 16864 16865 ------------------- 16866 -- Is_Entry_Body -- 16867 ------------------- 16868 16869 function Is_Entry_Body (Id : Entity_Id) return Boolean is 16870 begin 16871 return 16872 Is_Entry (Id) 16873 and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Body; 16874 end Is_Entry_Body; 16875 16876 -------------------------- 16877 -- Is_Entry_Declaration -- 16878 -------------------------- 16879 16880 function Is_Entry_Declaration (Id : Entity_Id) return Boolean is 16881 begin 16882 return 16883 Is_Entry (Id) 16884 and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Declaration; 16885 end Is_Entry_Declaration; 16886 16887 ------------------------------------ 16888 -- Is_Expanded_Priority_Attribute -- 16889 ------------------------------------ 16890 16891 function Is_Expanded_Priority_Attribute (E : Entity_Id) return Boolean is 16892 begin 16893 return 16894 Nkind (E) = N_Function_Call 16895 and then not Configurable_Run_Time_Mode 16896 and then Nkind (Original_Node (E)) = N_Attribute_Reference 16897 and then (Entity (Name (E)) = RTE (RE_Get_Ceiling) 16898 or else Entity (Name (E)) = RTE (RO_PE_Get_Ceiling)); 16899 end Is_Expanded_Priority_Attribute; 16900 16901 ---------------------------- 16902 -- Is_Expression_Function -- 16903 ---------------------------- 16904 16905 function Is_Expression_Function (Subp : Entity_Id) return Boolean is 16906 begin 16907 if Ekind (Subp) in E_Function | E_Subprogram_Body then 16908 return 16909 Nkind (Original_Node (Unit_Declaration_Node (Subp))) = 16910 N_Expression_Function; 16911 else 16912 return False; 16913 end if; 16914 end Is_Expression_Function; 16915 16916 ------------------------------------------ 16917 -- Is_Expression_Function_Or_Completion -- 16918 ------------------------------------------ 16919 16920 function Is_Expression_Function_Or_Completion 16921 (Subp : Entity_Id) return Boolean 16922 is 16923 Subp_Decl : Node_Id; 16924 16925 begin 16926 if Ekind (Subp) = E_Function then 16927 Subp_Decl := Unit_Declaration_Node (Subp); 16928 16929 -- The function declaration is either an expression function or is 16930 -- completed by an expression function body. 16931 16932 return 16933 Is_Expression_Function (Subp) 16934 or else (Nkind (Subp_Decl) = N_Subprogram_Declaration 16935 and then Present (Corresponding_Body (Subp_Decl)) 16936 and then Is_Expression_Function 16937 (Corresponding_Body (Subp_Decl))); 16938 16939 elsif Ekind (Subp) = E_Subprogram_Body then 16940 return Is_Expression_Function (Subp); 16941 16942 else 16943 return False; 16944 end if; 16945 end Is_Expression_Function_Or_Completion; 16946 16947 ----------------------- 16948 -- Is_EVF_Expression -- 16949 ----------------------- 16950 16951 function Is_EVF_Expression (N : Node_Id) return Boolean is 16952 Orig_N : constant Node_Id := Original_Node (N); 16953 Alt : Node_Id; 16954 Expr : Node_Id; 16955 Id : Entity_Id; 16956 16957 begin 16958 -- Detect a reference to a formal parameter of a specific tagged type 16959 -- whose related subprogram is subject to pragma Expresions_Visible with 16960 -- value "False". 16961 16962 if Is_Entity_Name (N) and then Present (Entity (N)) then 16963 Id := Entity (N); 16964 16965 return 16966 Is_Formal (Id) 16967 and then Is_Specific_Tagged_Type (Etype (Id)) 16968 and then Extensions_Visible_Status (Id) = 16969 Extensions_Visible_False; 16970 16971 -- A case expression is an EVF expression when it contains at least one 16972 -- EVF dependent_expression. Note that a case expression may have been 16973 -- expanded, hence the use of Original_Node. 16974 16975 elsif Nkind (Orig_N) = N_Case_Expression then 16976 Alt := First (Alternatives (Orig_N)); 16977 while Present (Alt) loop 16978 if Is_EVF_Expression (Expression (Alt)) then 16979 return True; 16980 end if; 16981 16982 Next (Alt); 16983 end loop; 16984 16985 -- An if expression is an EVF expression when it contains at least one 16986 -- EVF dependent_expression. Note that an if expression may have been 16987 -- expanded, hence the use of Original_Node. 16988 16989 elsif Nkind (Orig_N) = N_If_Expression then 16990 Expr := Next (First (Expressions (Orig_N))); 16991 while Present (Expr) loop 16992 if Is_EVF_Expression (Expr) then 16993 return True; 16994 end if; 16995 16996 Next (Expr); 16997 end loop; 16998 16999 -- A qualified expression or a type conversion is an EVF expression when 17000 -- its operand is an EVF expression. 17001 17002 elsif Nkind (N) in N_Qualified_Expression 17003 | N_Unchecked_Type_Conversion 17004 | N_Type_Conversion 17005 then 17006 return Is_EVF_Expression (Expression (N)); 17007 17008 -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when 17009 -- their prefix denotes an EVF expression. 17010 17011 elsif Nkind (N) = N_Attribute_Reference 17012 and then Attribute_Name (N) in Name_Loop_Entry 17013 | Name_Old 17014 | Name_Update 17015 then 17016 return Is_EVF_Expression (Prefix (N)); 17017 end if; 17018 17019 return False; 17020 end Is_EVF_Expression; 17021 17022 -------------- 17023 -- Is_False -- 17024 -------------- 17025 17026 function Is_False (U : Uint) return Boolean is 17027 begin 17028 return (U = 0); 17029 end Is_False; 17030 17031 --------------------------- 17032 -- Is_Fixed_Model_Number -- 17033 --------------------------- 17034 17035 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is 17036 S : constant Ureal := Small_Value (T); 17037 M : Urealp.Save_Mark; 17038 R : Boolean; 17039 17040 begin 17041 M := Urealp.Mark; 17042 R := (U = UR_Trunc (U / S) * S); 17043 Urealp.Release (M); 17044 return R; 17045 end Is_Fixed_Model_Number; 17046 17047 ----------------------------- 17048 -- Is_Full_Access_Object -- 17049 ----------------------------- 17050 17051 function Is_Full_Access_Object (N : Node_Id) return Boolean is 17052 begin 17053 return Is_Atomic_Object (N) or else Is_Volatile_Full_Access_Object (N); 17054 end Is_Full_Access_Object; 17055 17056 ------------------------------- 17057 -- Is_Fully_Initialized_Type -- 17058 ------------------------------- 17059 17060 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is 17061 begin 17062 -- Scalar types 17063 17064 if Is_Scalar_Type (Typ) then 17065 17066 -- A scalar type with an aspect Default_Value is fully initialized 17067 17068 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization 17069 -- of a scalar type, but we don't take that into account here, since 17070 -- we don't want these to affect warnings. 17071 17072 return Has_Default_Aspect (Typ); 17073 17074 elsif Is_Access_Type (Typ) then 17075 return True; 17076 17077 elsif Is_Array_Type (Typ) then 17078 if Is_Fully_Initialized_Type (Component_Type (Typ)) 17079 or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ)) 17080 then 17081 return True; 17082 end if; 17083 17084 -- An interesting case, if we have a constrained type one of whose 17085 -- bounds is known to be null, then there are no elements to be 17086 -- initialized, so all the elements are initialized. 17087 17088 if Is_Constrained (Typ) then 17089 declare 17090 Indx : Node_Id; 17091 Indx_Typ : Entity_Id; 17092 Lbd, Hbd : Node_Id; 17093 17094 begin 17095 Indx := First_Index (Typ); 17096 while Present (Indx) loop 17097 if Etype (Indx) = Any_Type then 17098 return False; 17099 17100 -- If index is a range, use directly 17101 17102 elsif Nkind (Indx) = N_Range then 17103 Lbd := Low_Bound (Indx); 17104 Hbd := High_Bound (Indx); 17105 17106 else 17107 Indx_Typ := Etype (Indx); 17108 17109 if Is_Private_Type (Indx_Typ) then 17110 Indx_Typ := Full_View (Indx_Typ); 17111 end if; 17112 17113 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then 17114 return False; 17115 else 17116 Lbd := Type_Low_Bound (Indx_Typ); 17117 Hbd := Type_High_Bound (Indx_Typ); 17118 end if; 17119 end if; 17120 17121 if Compile_Time_Known_Value (Lbd) 17122 and then 17123 Compile_Time_Known_Value (Hbd) 17124 then 17125 if Expr_Value (Hbd) < Expr_Value (Lbd) then 17126 return True; 17127 end if; 17128 end if; 17129 17130 Next_Index (Indx); 17131 end loop; 17132 end; 17133 end if; 17134 17135 -- If no null indexes, then type is not fully initialized 17136 17137 return False; 17138 17139 -- Record types 17140 17141 elsif Is_Record_Type (Typ) then 17142 if Has_Discriminants (Typ) 17143 and then 17144 Present (Discriminant_Default_Value (First_Discriminant (Typ))) 17145 and then Is_Fully_Initialized_Variant (Typ) 17146 then 17147 return True; 17148 end if; 17149 17150 -- We consider bounded string types to be fully initialized, because 17151 -- otherwise we get false alarms when the Data component is not 17152 -- default-initialized. 17153 17154 if Is_Bounded_String (Typ) then 17155 return True; 17156 end if; 17157 17158 -- Controlled records are considered to be fully initialized if 17159 -- there is a user defined Initialize routine. This may not be 17160 -- entirely correct, but as the spec notes, we are guessing here 17161 -- what is best from the point of view of issuing warnings. 17162 17163 if Is_Controlled (Typ) then 17164 declare 17165 Utyp : constant Entity_Id := Underlying_Type (Typ); 17166 17167 begin 17168 if Present (Utyp) then 17169 declare 17170 Init : constant Entity_Id := 17171 (Find_Optional_Prim_Op 17172 (Underlying_Type (Typ), Name_Initialize)); 17173 17174 begin 17175 if Present (Init) 17176 and then Comes_From_Source (Init) 17177 and then not In_Predefined_Unit (Init) 17178 then 17179 return True; 17180 17181 elsif Has_Null_Extension (Typ) 17182 and then 17183 Is_Fully_Initialized_Type 17184 (Etype (Base_Type (Typ))) 17185 then 17186 return True; 17187 end if; 17188 end; 17189 end if; 17190 end; 17191 end if; 17192 17193 -- Otherwise see if all record components are initialized 17194 17195 declare 17196 Ent : Entity_Id; 17197 17198 begin 17199 Ent := First_Entity (Typ); 17200 while Present (Ent) loop 17201 if Ekind (Ent) = E_Component 17202 and then (No (Parent (Ent)) 17203 or else No (Expression (Parent (Ent)))) 17204 and then not Is_Fully_Initialized_Type (Etype (Ent)) 17205 17206 -- Special VM case for tag components, which need to be 17207 -- defined in this case, but are never initialized as VMs 17208 -- are using other dispatching mechanisms. Ignore this 17209 -- uninitialized case. Note that this applies both to the 17210 -- uTag entry and the main vtable pointer (CPP_Class case). 17211 17212 and then (Tagged_Type_Expansion or else not Is_Tag (Ent)) 17213 then 17214 return False; 17215 end if; 17216 17217 Next_Entity (Ent); 17218 end loop; 17219 end; 17220 17221 -- No uninitialized components, so type is fully initialized. 17222 -- Note that this catches the case of no components as well. 17223 17224 return True; 17225 17226 elsif Is_Concurrent_Type (Typ) then 17227 return True; 17228 17229 elsif Is_Private_Type (Typ) then 17230 declare 17231 U : constant Entity_Id := Underlying_Type (Typ); 17232 17233 begin 17234 if No (U) then 17235 return False; 17236 else 17237 return Is_Fully_Initialized_Type (U); 17238 end if; 17239 end; 17240 17241 else 17242 return False; 17243 end if; 17244 end Is_Fully_Initialized_Type; 17245 17246 ---------------------------------- 17247 -- Is_Fully_Initialized_Variant -- 17248 ---------------------------------- 17249 17250 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is 17251 Loc : constant Source_Ptr := Sloc (Typ); 17252 Constraints : constant List_Id := New_List; 17253 Components : constant Elist_Id := New_Elmt_List; 17254 Comp_Elmt : Elmt_Id; 17255 Comp_Id : Node_Id; 17256 Comp_List : Node_Id; 17257 Discr : Entity_Id; 17258 Discr_Val : Node_Id; 17259 17260 Report_Errors : Boolean; 17261 pragma Warnings (Off, Report_Errors); 17262 17263 begin 17264 if Serious_Errors_Detected > 0 then 17265 return False; 17266 end if; 17267 17268 if Is_Record_Type (Typ) 17269 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration 17270 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition 17271 then 17272 Comp_List := Component_List (Type_Definition (Parent (Typ))); 17273 17274 Discr := First_Discriminant (Typ); 17275 while Present (Discr) loop 17276 if Nkind (Parent (Discr)) = N_Discriminant_Specification then 17277 Discr_Val := Expression (Parent (Discr)); 17278 17279 if Present (Discr_Val) 17280 and then Is_OK_Static_Expression (Discr_Val) 17281 then 17282 Append_To (Constraints, 17283 Make_Component_Association (Loc, 17284 Choices => New_List (New_Occurrence_Of (Discr, Loc)), 17285 Expression => New_Copy (Discr_Val))); 17286 else 17287 return False; 17288 end if; 17289 else 17290 return False; 17291 end if; 17292 17293 Next_Discriminant (Discr); 17294 end loop; 17295 17296 Gather_Components 17297 (Typ => Typ, 17298 Comp_List => Comp_List, 17299 Governed_By => Constraints, 17300 Into => Components, 17301 Report_Errors => Report_Errors); 17302 17303 -- Check that each component present is fully initialized 17304 17305 Comp_Elmt := First_Elmt (Components); 17306 while Present (Comp_Elmt) loop 17307 Comp_Id := Node (Comp_Elmt); 17308 17309 if Ekind (Comp_Id) = E_Component 17310 and then (No (Parent (Comp_Id)) 17311 or else No (Expression (Parent (Comp_Id)))) 17312 and then not Is_Fully_Initialized_Type (Etype (Comp_Id)) 17313 then 17314 return False; 17315 end if; 17316 17317 Next_Elmt (Comp_Elmt); 17318 end loop; 17319 17320 return True; 17321 17322 elsif Is_Private_Type (Typ) then 17323 declare 17324 U : constant Entity_Id := Underlying_Type (Typ); 17325 17326 begin 17327 if No (U) then 17328 return False; 17329 else 17330 return Is_Fully_Initialized_Variant (U); 17331 end if; 17332 end; 17333 17334 else 17335 return False; 17336 end if; 17337 end Is_Fully_Initialized_Variant; 17338 17339 ------------------------------------ 17340 -- Is_Generic_Declaration_Or_Body -- 17341 ------------------------------------ 17342 17343 function Is_Generic_Declaration_Or_Body (Decl : Node_Id) return Boolean is 17344 Spec_Decl : Node_Id; 17345 17346 begin 17347 -- Package/subprogram body 17348 17349 if Nkind (Decl) in N_Package_Body | N_Subprogram_Body 17350 and then Present (Corresponding_Spec (Decl)) 17351 then 17352 Spec_Decl := Unit_Declaration_Node (Corresponding_Spec (Decl)); 17353 17354 -- Package/subprogram body stub 17355 17356 elsif Nkind (Decl) in N_Package_Body_Stub | N_Subprogram_Body_Stub 17357 and then Present (Corresponding_Spec_Of_Stub (Decl)) 17358 then 17359 Spec_Decl := 17360 Unit_Declaration_Node (Corresponding_Spec_Of_Stub (Decl)); 17361 17362 -- All other cases 17363 17364 else 17365 Spec_Decl := Decl; 17366 end if; 17367 17368 -- Rather than inspecting the defining entity of the spec declaration, 17369 -- look at its Nkind. This takes care of the case where the analysis of 17370 -- a generic body modifies the Ekind of its spec to allow for recursive 17371 -- calls. 17372 17373 return 17374 Nkind (Spec_Decl) in N_Generic_Package_Declaration 17375 | N_Generic_Subprogram_Declaration; 17376 end Is_Generic_Declaration_Or_Body; 17377 17378 --------------------------- 17379 -- Is_Independent_Object -- 17380 --------------------------- 17381 17382 function Is_Independent_Object (N : Node_Id) return Boolean is 17383 function Is_Independent_Object_Entity (Id : Entity_Id) return Boolean; 17384 -- Determine whether arbitrary entity Id denotes an object that is 17385 -- Independent. 17386 17387 function Prefix_Has_Independent_Components (P : Node_Id) return Boolean; 17388 -- Determine whether prefix P has independent components. This requires 17389 -- the presence of an Independent_Components aspect/pragma. 17390 17391 ------------------------------------ 17392 -- Is_Independent_Object_Entity -- 17393 ------------------------------------ 17394 17395 function Is_Independent_Object_Entity (Id : Entity_Id) return Boolean is 17396 begin 17397 return 17398 Is_Object (Id) 17399 and then (Is_Independent (Id) 17400 or else 17401 Is_Independent (Etype (Id))); 17402 end Is_Independent_Object_Entity; 17403 17404 ------------------------------------- 17405 -- Prefix_Has_Independent_Components -- 17406 ------------------------------------- 17407 17408 function Prefix_Has_Independent_Components (P : Node_Id) return Boolean 17409 is 17410 Typ : constant Entity_Id := Etype (P); 17411 17412 begin 17413 if Is_Access_Type (Typ) then 17414 return Has_Independent_Components (Designated_Type (Typ)); 17415 17416 elsif Has_Independent_Components (Typ) then 17417 return True; 17418 17419 elsif Is_Entity_Name (P) 17420 and then Has_Independent_Components (Entity (P)) 17421 then 17422 return True; 17423 17424 else 17425 return False; 17426 end if; 17427 end Prefix_Has_Independent_Components; 17428 17429 -- Start of processing for Is_Independent_Object 17430 17431 begin 17432 if Is_Entity_Name (N) then 17433 return Is_Independent_Object_Entity (Entity (N)); 17434 17435 elsif Is_Independent (Etype (N)) then 17436 return True; 17437 17438 elsif Nkind (N) = N_Indexed_Component then 17439 return Prefix_Has_Independent_Components (Prefix (N)); 17440 17441 elsif Nkind (N) = N_Selected_Component then 17442 return Prefix_Has_Independent_Components (Prefix (N)) 17443 or else Is_Independent (Entity (Selector_Name (N))); 17444 17445 else 17446 return False; 17447 end if; 17448 end Is_Independent_Object; 17449 17450 ---------------------------- 17451 -- Is_Inherited_Operation -- 17452 ---------------------------- 17453 17454 function Is_Inherited_Operation (E : Entity_Id) return Boolean is 17455 pragma Assert (Is_Overloadable (E)); 17456 Kind : constant Node_Kind := Nkind (Parent (E)); 17457 begin 17458 return Kind = N_Full_Type_Declaration 17459 or else Kind = N_Private_Extension_Declaration 17460 or else Kind = N_Subtype_Declaration 17461 or else (Ekind (E) = E_Enumeration_Literal 17462 and then Is_Derived_Type (Etype (E))); 17463 end Is_Inherited_Operation; 17464 17465 ------------------------------------- 17466 -- Is_Inherited_Operation_For_Type -- 17467 ------------------------------------- 17468 17469 function Is_Inherited_Operation_For_Type 17470 (E : Entity_Id; 17471 Typ : Entity_Id) return Boolean 17472 is 17473 begin 17474 -- Check that the operation has been created by the type declaration 17475 17476 return Is_Inherited_Operation (E) 17477 and then Defining_Identifier (Parent (E)) = Typ; 17478 end Is_Inherited_Operation_For_Type; 17479 17480 -------------------------------------- 17481 -- Is_Inlinable_Expression_Function -- 17482 -------------------------------------- 17483 17484 function Is_Inlinable_Expression_Function 17485 (Subp : Entity_Id) return Boolean 17486 is 17487 Return_Expr : Node_Id; 17488 17489 begin 17490 if Is_Expression_Function_Or_Completion (Subp) 17491 and then Has_Pragma_Inline_Always (Subp) 17492 and then Needs_No_Actuals (Subp) 17493 and then No (Contract (Subp)) 17494 and then not Is_Dispatching_Operation (Subp) 17495 and then Needs_Finalization (Etype (Subp)) 17496 and then not Is_Class_Wide_Type (Etype (Subp)) 17497 and then not Has_Invariants (Etype (Subp)) 17498 and then Present (Subprogram_Body (Subp)) 17499 and then Was_Expression_Function (Subprogram_Body (Subp)) 17500 then 17501 Return_Expr := Expression_Of_Expression_Function (Subp); 17502 17503 -- The returned object must not have a qualified expression and its 17504 -- nominal subtype must be statically compatible with the result 17505 -- subtype of the expression function. 17506 17507 return 17508 Nkind (Return_Expr) = N_Identifier 17509 and then Etype (Return_Expr) = Etype (Subp); 17510 end if; 17511 17512 return False; 17513 end Is_Inlinable_Expression_Function; 17514 17515 ----------------- 17516 -- Is_Iterator -- 17517 ----------------- 17518 17519 function Is_Iterator (Typ : Entity_Id) return Boolean is 17520 function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean; 17521 -- Determine whether type Iter_Typ is a predefined forward or reversible 17522 -- iterator. 17523 17524 ---------------------- 17525 -- Denotes_Iterator -- 17526 ---------------------- 17527 17528 function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean is 17529 begin 17530 -- Check that the name matches, and that the ultimate ancestor is in 17531 -- a predefined unit, i.e the one that declares iterator interfaces. 17532 17533 return 17534 Chars (Iter_Typ) in Name_Forward_Iterator | Name_Reversible_Iterator 17535 and then In_Predefined_Unit (Root_Type (Iter_Typ)); 17536 end Denotes_Iterator; 17537 17538 -- Local variables 17539 17540 Iface_Elmt : Elmt_Id; 17541 Ifaces : Elist_Id; 17542 17543 -- Start of processing for Is_Iterator 17544 17545 begin 17546 -- The type may be a subtype of a descendant of the proper instance of 17547 -- the predefined interface type, so we must use the root type of the 17548 -- given type. The same is done for Is_Reversible_Iterator. 17549 17550 if Is_Class_Wide_Type (Typ) 17551 and then Denotes_Iterator (Root_Type (Typ)) 17552 then 17553 return True; 17554 17555 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then 17556 return False; 17557 17558 elsif Present (Find_Value_Of_Aspect (Typ, Aspect_Iterable)) then 17559 return True; 17560 17561 else 17562 Collect_Interfaces (Typ, Ifaces); 17563 17564 Iface_Elmt := First_Elmt (Ifaces); 17565 while Present (Iface_Elmt) loop 17566 if Denotes_Iterator (Node (Iface_Elmt)) then 17567 return True; 17568 end if; 17569 17570 Next_Elmt (Iface_Elmt); 17571 end loop; 17572 17573 return False; 17574 end if; 17575 end Is_Iterator; 17576 17577 ---------------------------- 17578 -- Is_Iterator_Over_Array -- 17579 ---------------------------- 17580 17581 function Is_Iterator_Over_Array (N : Node_Id) return Boolean is 17582 Container : constant Node_Id := Name (N); 17583 Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); 17584 begin 17585 return Is_Array_Type (Container_Typ); 17586 end Is_Iterator_Over_Array; 17587 17588 ------------ 17589 -- Is_LHS -- 17590 ------------ 17591 17592 -- We seem to have a lot of overlapping functions that do similar things 17593 -- (testing for left hand sides or lvalues???). 17594 17595 function Is_LHS (N : Node_Id) return Is_LHS_Result is 17596 P : constant Node_Id := Parent (N); 17597 17598 begin 17599 -- Return True if we are the left hand side of an assignment statement 17600 17601 if Nkind (P) = N_Assignment_Statement then 17602 if Name (P) = N then 17603 return Yes; 17604 else 17605 return No; 17606 end if; 17607 17608 -- Case of prefix of indexed or selected component or slice 17609 17610 elsif Nkind (P) in N_Indexed_Component | N_Selected_Component | N_Slice 17611 and then N = Prefix (P) 17612 then 17613 -- Here we have the case where the parent P is N.Q or N(Q .. R). 17614 -- If P is an LHS, then N is also effectively an LHS, but there 17615 -- is an important exception. If N is of an access type, then 17616 -- what we really have is N.all.Q (or N.all(Q .. R)). In either 17617 -- case this makes N.all a left hand side but not N itself. 17618 17619 -- If we don't know the type yet, this is the case where we return 17620 -- Unknown, since the answer depends on the type which is unknown. 17621 17622 if No (Etype (N)) then 17623 return Unknown; 17624 17625 -- We have an Etype set, so we can check it 17626 17627 elsif Is_Access_Type (Etype (N)) then 17628 return No; 17629 17630 -- OK, not access type case, so just test whole expression 17631 17632 else 17633 return Is_LHS (P); 17634 end if; 17635 17636 -- All other cases are not left hand sides 17637 17638 else 17639 return No; 17640 end if; 17641 end Is_LHS; 17642 17643 ----------------------------- 17644 -- Is_Library_Level_Entity -- 17645 ----------------------------- 17646 17647 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is 17648 begin 17649 -- The following is a small optimization, and it also properly handles 17650 -- discriminals, which in task bodies might appear in expressions before 17651 -- the corresponding procedure has been created, and which therefore do 17652 -- not have an assigned scope. 17653 17654 if Is_Formal (E) then 17655 return False; 17656 end if; 17657 17658 -- Normal test is simply that the enclosing dynamic scope is Standard 17659 17660 return Enclosing_Dynamic_Scope (E) = Standard_Standard; 17661 end Is_Library_Level_Entity; 17662 17663 -------------------------------- 17664 -- Is_Limited_Class_Wide_Type -- 17665 -------------------------------- 17666 17667 function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is 17668 begin 17669 return 17670 Is_Class_Wide_Type (Typ) 17671 and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ)); 17672 end Is_Limited_Class_Wide_Type; 17673 17674 --------------------------------- 17675 -- Is_Local_Variable_Reference -- 17676 --------------------------------- 17677 17678 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is 17679 begin 17680 if not Is_Entity_Name (Expr) then 17681 return False; 17682 17683 else 17684 declare 17685 Ent : constant Entity_Id := Entity (Expr); 17686 Sub : constant Entity_Id := Enclosing_Subprogram (Ent); 17687 begin 17688 if Ekind (Ent) not in E_Variable | E_In_Out_Parameter then 17689 return False; 17690 else 17691 return Present (Sub) and then Sub = Current_Subprogram; 17692 end if; 17693 end; 17694 end if; 17695 end Is_Local_Variable_Reference; 17696 17697 --------------- 17698 -- Is_Master -- 17699 --------------- 17700 17701 function Is_Master (N : Node_Id) return Boolean is 17702 Disable_Subexpression_Masters : constant Boolean := True; 17703 17704 begin 17705 if Nkind (N) in N_Subprogram_Body | N_Task_Body | N_Entry_Body 17706 or else Is_Statement (N) 17707 then 17708 return True; 17709 end if; 17710 17711 -- We avoid returning True when the master is a subexpression described 17712 -- in RM 7.6.1(3/2) for the proposes of accessibility level calculation 17713 -- in Accessibility_Level_Helper.Innermost_Master_Scope_Depth ??? 17714 17715 if not Disable_Subexpression_Masters 17716 and then Nkind (N) in N_Subexpr 17717 then 17718 declare 17719 Par : Node_Id := N; 17720 17721 subtype N_Simple_Statement_Other_Than_Simple_Return 17722 is Node_Kind with Static_Predicate => 17723 N_Simple_Statement_Other_Than_Simple_Return 17724 in N_Abort_Statement 17725 | N_Assignment_Statement 17726 | N_Code_Statement 17727 | N_Delay_Statement 17728 | N_Entry_Call_Statement 17729 | N_Free_Statement 17730 | N_Goto_Statement 17731 | N_Null_Statement 17732 | N_Raise_Statement 17733 | N_Requeue_Statement 17734 | N_Exit_Statement 17735 | N_Procedure_Call_Statement; 17736 begin 17737 while Present (Par) loop 17738 Par := Parent (Par); 17739 if Nkind (Par) in N_Subexpr | 17740 N_Simple_Statement_Other_Than_Simple_Return 17741 then 17742 return False; 17743 end if; 17744 end loop; 17745 17746 return True; 17747 end; 17748 end if; 17749 17750 return False; 17751 end Is_Master; 17752 17753 ----------------------- 17754 -- Is_Name_Reference -- 17755 ----------------------- 17756 17757 function Is_Name_Reference (N : Node_Id) return Boolean is 17758 begin 17759 if Is_Entity_Name (N) then 17760 return Present (Entity (N)) and then Is_Object (Entity (N)); 17761 end if; 17762 17763 case Nkind (N) is 17764 when N_Indexed_Component 17765 | N_Slice 17766 => 17767 return 17768 Is_Name_Reference (Prefix (N)) 17769 or else Is_Access_Type (Etype (Prefix (N))); 17770 17771 -- Attributes 'Input, 'Old and 'Result produce objects 17772 17773 when N_Attribute_Reference => 17774 return Attribute_Name (N) in Name_Input | Name_Old | Name_Result; 17775 17776 when N_Selected_Component => 17777 return 17778 Is_Name_Reference (Selector_Name (N)) 17779 and then 17780 (Is_Name_Reference (Prefix (N)) 17781 or else Is_Access_Type (Etype (Prefix (N)))); 17782 17783 when N_Explicit_Dereference => 17784 return True; 17785 17786 -- A view conversion of a tagged name is a name reference 17787 17788 when N_Type_Conversion => 17789 return 17790 Is_Tagged_Type (Etype (Subtype_Mark (N))) 17791 and then Is_Tagged_Type (Etype (Expression (N))) 17792 and then Is_Name_Reference (Expression (N)); 17793 17794 -- An unchecked type conversion is considered to be a name if the 17795 -- operand is a name (this construction arises only as a result of 17796 -- expansion activities). 17797 17798 when N_Unchecked_Type_Conversion => 17799 return Is_Name_Reference (Expression (N)); 17800 17801 when others => 17802 return False; 17803 end case; 17804 end Is_Name_Reference; 17805 17806 ------------------------------------ 17807 -- Is_Non_Preelaborable_Construct -- 17808 ------------------------------------ 17809 17810 function Is_Non_Preelaborable_Construct (N : Node_Id) return Boolean is 17811 17812 -- NOTE: the routines within Is_Non_Preelaborable_Construct are 17813 -- intentionally unnested to avoid deep indentation of code. 17814 17815 Non_Preelaborable : exception; 17816 -- This exception is raised when the construct violates preelaborability 17817 -- to terminate the recursion. 17818 17819 procedure Visit (Nod : Node_Id); 17820 -- Semantically inspect construct Nod to determine whether it violates 17821 -- preelaborability. This routine raises Non_Preelaborable. 17822 17823 procedure Visit_List (List : List_Id); 17824 pragma Inline (Visit_List); 17825 -- Invoke Visit on each element of list List. This routine raises 17826 -- Non_Preelaborable. 17827 17828 procedure Visit_Pragma (Prag : Node_Id); 17829 pragma Inline (Visit_Pragma); 17830 -- Semantically inspect pragma Prag to determine whether it violates 17831 -- preelaborability. This routine raises Non_Preelaborable. 17832 17833 procedure Visit_Subexpression (Expr : Node_Id); 17834 pragma Inline (Visit_Subexpression); 17835 -- Semantically inspect expression Expr to determine whether it violates 17836 -- preelaborability. This routine raises Non_Preelaborable. 17837 17838 ----------- 17839 -- Visit -- 17840 ----------- 17841 17842 procedure Visit (Nod : Node_Id) is 17843 begin 17844 case Nkind (Nod) is 17845 17846 -- Declarations 17847 17848 when N_Component_Declaration => 17849 17850 -- Defining_Identifier is left out because it is not relevant 17851 -- for preelaborability. 17852 17853 Visit (Component_Definition (Nod)); 17854 Visit (Expression (Nod)); 17855 17856 when N_Derived_Type_Definition => 17857 17858 -- Interface_List is left out because it is not relevant for 17859 -- preelaborability. 17860 17861 Visit (Record_Extension_Part (Nod)); 17862 Visit (Subtype_Indication (Nod)); 17863 17864 when N_Entry_Declaration => 17865 17866 -- A protected type with at leat one entry is not preelaborable 17867 -- while task types are never preelaborable. This renders entry 17868 -- declarations non-preelaborable. 17869 17870 raise Non_Preelaborable; 17871 17872 when N_Full_Type_Declaration => 17873 17874 -- Defining_Identifier and Discriminant_Specifications are left 17875 -- out because they are not relevant for preelaborability. 17876 17877 Visit (Type_Definition (Nod)); 17878 17879 when N_Function_Instantiation 17880 | N_Package_Instantiation 17881 | N_Procedure_Instantiation 17882 => 17883 -- Defining_Unit_Name and Name are left out because they are 17884 -- not relevant for preelaborability. 17885 17886 Visit_List (Generic_Associations (Nod)); 17887 17888 when N_Object_Declaration => 17889 17890 -- Defining_Identifier is left out because it is not relevant 17891 -- for preelaborability. 17892 17893 Visit (Object_Definition (Nod)); 17894 17895 if Has_Init_Expression (Nod) then 17896 Visit (Expression (Nod)); 17897 17898 elsif not Has_Preelaborable_Initialization 17899 (Etype (Defining_Entity (Nod))) 17900 then 17901 raise Non_Preelaborable; 17902 end if; 17903 17904 when N_Private_Extension_Declaration 17905 | N_Subtype_Declaration 17906 => 17907 -- Defining_Identifier, Discriminant_Specifications, and 17908 -- Interface_List are left out because they are not relevant 17909 -- for preelaborability. 17910 17911 Visit (Subtype_Indication (Nod)); 17912 17913 when N_Protected_Type_Declaration 17914 | N_Single_Protected_Declaration 17915 => 17916 -- Defining_Identifier, Discriminant_Specifications, and 17917 -- Interface_List are left out because they are not relevant 17918 -- for preelaborability. 17919 17920 Visit (Protected_Definition (Nod)); 17921 17922 -- A [single] task type is never preelaborable 17923 17924 when N_Single_Task_Declaration 17925 | N_Task_Type_Declaration 17926 => 17927 raise Non_Preelaborable; 17928 17929 -- Pragmas 17930 17931 when N_Pragma => 17932 Visit_Pragma (Nod); 17933 17934 -- Statements 17935 17936 when N_Statement_Other_Than_Procedure_Call => 17937 if Nkind (Nod) /= N_Null_Statement then 17938 raise Non_Preelaborable; 17939 end if; 17940 17941 -- Subexpressions 17942 17943 when N_Subexpr => 17944 Visit_Subexpression (Nod); 17945 17946 -- Special 17947 17948 when N_Access_To_Object_Definition => 17949 Visit (Subtype_Indication (Nod)); 17950 17951 when N_Case_Expression_Alternative => 17952 Visit (Expression (Nod)); 17953 Visit_List (Discrete_Choices (Nod)); 17954 17955 when N_Component_Definition => 17956 Visit (Access_Definition (Nod)); 17957 Visit (Subtype_Indication (Nod)); 17958 17959 when N_Component_List => 17960 Visit_List (Component_Items (Nod)); 17961 Visit (Variant_Part (Nod)); 17962 17963 when N_Constrained_Array_Definition => 17964 Visit_List (Discrete_Subtype_Definitions (Nod)); 17965 Visit (Component_Definition (Nod)); 17966 17967 when N_Delta_Constraint 17968 | N_Digits_Constraint 17969 => 17970 -- Delta_Expression and Digits_Expression are left out because 17971 -- they are not relevant for preelaborability. 17972 17973 Visit (Range_Constraint (Nod)); 17974 17975 when N_Discriminant_Specification => 17976 17977 -- Defining_Identifier and Expression are left out because they 17978 -- are not relevant for preelaborability. 17979 17980 Visit (Discriminant_Type (Nod)); 17981 17982 when N_Generic_Association => 17983 17984 -- Selector_Name is left out because it is not relevant for 17985 -- preelaborability. 17986 17987 Visit (Explicit_Generic_Actual_Parameter (Nod)); 17988 17989 when N_Index_Or_Discriminant_Constraint => 17990 Visit_List (Constraints (Nod)); 17991 17992 when N_Iterator_Specification => 17993 17994 -- Defining_Identifier is left out because it is not relevant 17995 -- for preelaborability. 17996 17997 Visit (Name (Nod)); 17998 Visit (Subtype_Indication (Nod)); 17999 18000 when N_Loop_Parameter_Specification => 18001 18002 -- Defining_Identifier is left out because it is not relevant 18003 -- for preelaborability. 18004 18005 Visit (Discrete_Subtype_Definition (Nod)); 18006 18007 when N_Parameter_Association => 18008 Visit (Explicit_Actual_Parameter (N)); 18009 18010 when N_Protected_Definition => 18011 18012 -- End_Label is left out because it is not relevant for 18013 -- preelaborability. 18014 18015 Visit_List (Private_Declarations (Nod)); 18016 Visit_List (Visible_Declarations (Nod)); 18017 18018 when N_Range_Constraint => 18019 Visit (Range_Expression (Nod)); 18020 18021 when N_Record_Definition 18022 | N_Variant 18023 => 18024 -- End_Label, Discrete_Choices, and Interface_List are left out 18025 -- because they are not relevant for preelaborability. 18026 18027 Visit (Component_List (Nod)); 18028 18029 when N_Subtype_Indication => 18030 18031 -- Subtype_Mark is left out because it is not relevant for 18032 -- preelaborability. 18033 18034 Visit (Constraint (Nod)); 18035 18036 when N_Unconstrained_Array_Definition => 18037 18038 -- Subtype_Marks is left out because it is not relevant for 18039 -- preelaborability. 18040 18041 Visit (Component_Definition (Nod)); 18042 18043 when N_Variant_Part => 18044 18045 -- Name is left out because it is not relevant for 18046 -- preelaborability. 18047 18048 Visit_List (Variants (Nod)); 18049 18050 -- Default 18051 18052 when others => 18053 null; 18054 end case; 18055 end Visit; 18056 18057 ---------------- 18058 -- Visit_List -- 18059 ---------------- 18060 18061 procedure Visit_List (List : List_Id) is 18062 Nod : Node_Id; 18063 18064 begin 18065 if Present (List) then 18066 Nod := First (List); 18067 while Present (Nod) loop 18068 Visit (Nod); 18069 Next (Nod); 18070 end loop; 18071 end if; 18072 end Visit_List; 18073 18074 ------------------ 18075 -- Visit_Pragma -- 18076 ------------------ 18077 18078 procedure Visit_Pragma (Prag : Node_Id) is 18079 begin 18080 case Get_Pragma_Id (Prag) is 18081 when Pragma_Assert 18082 | Pragma_Assert_And_Cut 18083 | Pragma_Assume 18084 | Pragma_Async_Readers 18085 | Pragma_Async_Writers 18086 | Pragma_Attribute_Definition 18087 | Pragma_Check 18088 | Pragma_Constant_After_Elaboration 18089 | Pragma_CPU 18090 | Pragma_Deadline_Floor 18091 | Pragma_Dispatching_Domain 18092 | Pragma_Effective_Reads 18093 | Pragma_Effective_Writes 18094 | Pragma_Extensions_Visible 18095 | Pragma_Ghost 18096 | Pragma_Secondary_Stack_Size 18097 | Pragma_Task_Name 18098 | Pragma_Volatile_Function 18099 => 18100 Visit_List (Pragma_Argument_Associations (Prag)); 18101 18102 -- Default 18103 18104 when others => 18105 null; 18106 end case; 18107 end Visit_Pragma; 18108 18109 ------------------------- 18110 -- Visit_Subexpression -- 18111 ------------------------- 18112 18113 procedure Visit_Subexpression (Expr : Node_Id) is 18114 procedure Visit_Aggregate (Aggr : Node_Id); 18115 pragma Inline (Visit_Aggregate); 18116 -- Semantically inspect aggregate Aggr to determine whether it 18117 -- violates preelaborability. 18118 18119 --------------------- 18120 -- Visit_Aggregate -- 18121 --------------------- 18122 18123 procedure Visit_Aggregate (Aggr : Node_Id) is 18124 begin 18125 if not Is_Preelaborable_Aggregate (Aggr) then 18126 raise Non_Preelaborable; 18127 end if; 18128 end Visit_Aggregate; 18129 18130 -- Start of processing for Visit_Subexpression 18131 18132 begin 18133 case Nkind (Expr) is 18134 when N_Allocator 18135 | N_Qualified_Expression 18136 | N_Type_Conversion 18137 | N_Unchecked_Expression 18138 | N_Unchecked_Type_Conversion 18139 => 18140 -- Subpool_Handle_Name and Subtype_Mark are left out because 18141 -- they are not relevant for preelaborability. 18142 18143 Visit (Expression (Expr)); 18144 18145 when N_Aggregate 18146 | N_Extension_Aggregate 18147 => 18148 Visit_Aggregate (Expr); 18149 18150 when N_Attribute_Reference 18151 | N_Explicit_Dereference 18152 | N_Reference 18153 => 18154 -- Attribute_Name and Expressions are left out because they are 18155 -- not relevant for preelaborability. 18156 18157 Visit (Prefix (Expr)); 18158 18159 when N_Case_Expression => 18160 18161 -- End_Span is left out because it is not relevant for 18162 -- preelaborability. 18163 18164 Visit_List (Alternatives (Expr)); 18165 Visit (Expression (Expr)); 18166 18167 when N_Delta_Aggregate => 18168 Visit_Aggregate (Expr); 18169 Visit (Expression (Expr)); 18170 18171 when N_Expression_With_Actions => 18172 Visit_List (Actions (Expr)); 18173 Visit (Expression (Expr)); 18174 18175 when N_Function_Call => 18176 18177 -- Ada 2020 (AI12-0175): Calls to certain functions that are 18178 -- essentially unchecked conversions are preelaborable. 18179 18180 if Ada_Version >= Ada_2020 18181 and then Nkind (Expr) = N_Function_Call 18182 and then Is_Entity_Name (Name (Expr)) 18183 and then Is_Preelaborable_Function (Entity (Name (Expr))) 18184 then 18185 Visit_List (Parameter_Associations (Expr)); 18186 else 18187 raise Non_Preelaborable; 18188 end if; 18189 18190 when N_If_Expression => 18191 Visit_List (Expressions (Expr)); 18192 18193 when N_Quantified_Expression => 18194 Visit (Condition (Expr)); 18195 Visit (Iterator_Specification (Expr)); 18196 Visit (Loop_Parameter_Specification (Expr)); 18197 18198 when N_Range => 18199 Visit (High_Bound (Expr)); 18200 Visit (Low_Bound (Expr)); 18201 18202 when N_Slice => 18203 Visit (Discrete_Range (Expr)); 18204 Visit (Prefix (Expr)); 18205 18206 -- Default 18207 18208 when others => 18209 18210 -- The evaluation of an object name is not preelaborable, 18211 -- unless the name is a static expression (checked further 18212 -- below), or statically denotes a discriminant. 18213 18214 if Is_Entity_Name (Expr) then 18215 Object_Name : declare 18216 Id : constant Entity_Id := Entity (Expr); 18217 18218 begin 18219 if Is_Object (Id) then 18220 if Ekind (Id) = E_Discriminant then 18221 null; 18222 18223 elsif Ekind (Id) in E_Constant | E_In_Parameter 18224 and then Present (Discriminal_Link (Id)) 18225 then 18226 null; 18227 18228 else 18229 raise Non_Preelaborable; 18230 end if; 18231 end if; 18232 end Object_Name; 18233 18234 -- A non-static expression is not preelaborable 18235 18236 elsif not Is_OK_Static_Expression (Expr) then 18237 raise Non_Preelaborable; 18238 end if; 18239 end case; 18240 end Visit_Subexpression; 18241 18242 -- Start of processing for Is_Non_Preelaborable_Construct 18243 18244 begin 18245 Visit (N); 18246 18247 -- At this point it is known that the construct is preelaborable 18248 18249 return False; 18250 18251 exception 18252 18253 -- The elaboration of the construct performs an action which violates 18254 -- preelaborability. 18255 18256 when Non_Preelaborable => 18257 return True; 18258 end Is_Non_Preelaborable_Construct; 18259 18260 --------------------------------- 18261 -- Is_Nontrivial_DIC_Procedure -- 18262 --------------------------------- 18263 18264 function Is_Nontrivial_DIC_Procedure (Id : Entity_Id) return Boolean is 18265 Body_Decl : Node_Id; 18266 Stmt : Node_Id; 18267 18268 begin 18269 if Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id) then 18270 Body_Decl := 18271 Unit_Declaration_Node 18272 (Corresponding_Body (Unit_Declaration_Node (Id))); 18273 18274 -- The body of the Default_Initial_Condition procedure must contain 18275 -- at least one statement, otherwise the generation of the subprogram 18276 -- body failed. 18277 18278 pragma Assert (Present (Handled_Statement_Sequence (Body_Decl))); 18279 18280 -- To qualify as nontrivial, the first statement of the procedure 18281 -- must be a check in the form of an if statement. If the original 18282 -- Default_Initial_Condition expression was folded, then the first 18283 -- statement is not a check. 18284 18285 Stmt := First (Statements (Handled_Statement_Sequence (Body_Decl))); 18286 18287 return 18288 Nkind (Stmt) = N_If_Statement 18289 and then Nkind (Original_Node (Stmt)) = N_Pragma; 18290 end if; 18291 18292 return False; 18293 end Is_Nontrivial_DIC_Procedure; 18294 18295 ------------------------- 18296 -- Is_Null_Record_Type -- 18297 ------------------------- 18298 18299 function Is_Null_Record_Type (T : Entity_Id) return Boolean is 18300 Decl : constant Node_Id := Parent (T); 18301 begin 18302 return Nkind (Decl) = N_Full_Type_Declaration 18303 and then Nkind (Type_Definition (Decl)) = N_Record_Definition 18304 and then 18305 (No (Component_List (Type_Definition (Decl))) 18306 or else Null_Present (Component_List (Type_Definition (Decl)))); 18307 end Is_Null_Record_Type; 18308 18309 --------------------- 18310 -- Is_Object_Image -- 18311 --------------------- 18312 18313 function Is_Object_Image (Prefix : Node_Id) return Boolean is 18314 begin 18315 -- Here we test for the case that the prefix is not a type and assume 18316 -- if it is not then it must be a named value or an object reference. 18317 -- This is because the parser always checks that prefixes of attributes 18318 -- are named. 18319 18320 return not (Is_Entity_Name (Prefix) and then Is_Type (Entity (Prefix))); 18321 end Is_Object_Image; 18322 18323 ------------------------- 18324 -- Is_Object_Reference -- 18325 ------------------------- 18326 18327 function Is_Object_Reference (N : Node_Id) return Boolean is 18328 function Safe_Prefix (N : Node_Id) return Node_Id; 18329 -- Return Prefix (N) unless it has been rewritten as an 18330 -- N_Raise_xxx_Error node, in which case return its original node. 18331 18332 ----------------- 18333 -- Safe_Prefix -- 18334 ----------------- 18335 18336 function Safe_Prefix (N : Node_Id) return Node_Id is 18337 begin 18338 if Nkind (Prefix (N)) in N_Raise_xxx_Error then 18339 return Original_Node (Prefix (N)); 18340 else 18341 return Prefix (N); 18342 end if; 18343 end Safe_Prefix; 18344 18345 begin 18346 -- AI12-0068: Note that a current instance reference in a type or 18347 -- subtype's aspect_specification is considered a value, not an object 18348 -- (see RM 8.6(18/5)). 18349 18350 if Is_Entity_Name (N) then 18351 return Present (Entity (N)) and then Is_Object (Entity (N)) 18352 and then not Is_Current_Instance_Reference_In_Type_Aspect (N); 18353 18354 else 18355 case Nkind (N) is 18356 when N_Indexed_Component 18357 | N_Slice 18358 => 18359 return 18360 Is_Object_Reference (Safe_Prefix (N)) 18361 or else Is_Access_Type (Etype (Safe_Prefix (N))); 18362 18363 -- In Ada 95, a function call is a constant object; a procedure 18364 -- call is not. 18365 18366 -- Note that predefined operators are functions as well, and so 18367 -- are attributes that are (can be renamed as) functions. 18368 18369 when N_Function_Call 18370 | N_Op 18371 => 18372 return Etype (N) /= Standard_Void_Type; 18373 18374 -- Attributes references 'Loop_Entry, 'Old, 'Priority and 'Result 18375 -- yield objects, even though they are not functions. 18376 18377 when N_Attribute_Reference => 18378 return 18379 Attribute_Name (N) in Name_Loop_Entry 18380 | Name_Old 18381 | Name_Priority 18382 | Name_Result 18383 or else Is_Function_Attribute_Name (Attribute_Name (N)); 18384 18385 when N_Selected_Component => 18386 return 18387 Is_Object_Reference (Selector_Name (N)) 18388 and then 18389 (Is_Object_Reference (Safe_Prefix (N)) 18390 or else Is_Access_Type (Etype (Safe_Prefix (N)))); 18391 18392 -- An explicit dereference denotes an object, except that a 18393 -- conditional expression gets turned into an explicit dereference 18394 -- in some cases, and conditional expressions are not object 18395 -- names. 18396 18397 when N_Explicit_Dereference => 18398 return Nkind (Original_Node (N)) not in 18399 N_Case_Expression | N_If_Expression; 18400 18401 -- A view conversion of a tagged object is an object reference 18402 18403 when N_Type_Conversion => 18404 if Ada_Version <= Ada_2012 then 18405 -- A view conversion of a tagged object is an object 18406 -- reference. 18407 return Is_Tagged_Type (Etype (Subtype_Mark (N))) 18408 and then Is_Tagged_Type (Etype (Expression (N))) 18409 and then Is_Object_Reference (Expression (N)); 18410 18411 else 18412 -- AI12-0226: In Ada 202x a value conversion of an object is 18413 -- an object. 18414 18415 return Is_Object_Reference (Expression (N)); 18416 end if; 18417 18418 -- An unchecked type conversion is considered to be an object if 18419 -- the operand is an object (this construction arises only as a 18420 -- result of expansion activities). 18421 18422 when N_Unchecked_Type_Conversion => 18423 return True; 18424 18425 -- AI05-0003: In Ada 2012 a qualified expression is a name. 18426 -- This allows disambiguation of function calls and the use 18427 -- of aggregates in more contexts. 18428 18429 when N_Qualified_Expression => 18430 return Ada_Version >= Ada_2012 18431 and then Is_Object_Reference (Expression (N)); 18432 18433 -- In Ada 95 an aggregate is an object reference 18434 18435 when N_Aggregate 18436 | N_Delta_Aggregate 18437 | N_Extension_Aggregate 18438 => 18439 return Ada_Version >= Ada_95; 18440 18441 -- A string literal is not an object reference, but it might come 18442 -- from rewriting of an object reference, e.g. from folding of an 18443 -- aggregate. 18444 18445 when N_String_Literal => 18446 return Is_Rewrite_Substitution (N) 18447 and then Is_Object_Reference (Original_Node (N)); 18448 18449 -- AI12-0125: Target name represents a constant object 18450 18451 when N_Target_Name => 18452 return True; 18453 18454 when others => 18455 return False; 18456 end case; 18457 end if; 18458 end Is_Object_Reference; 18459 18460 ----------------------------------- 18461 -- Is_OK_Variable_For_Out_Formal -- 18462 ----------------------------------- 18463 18464 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is 18465 begin 18466 Note_Possible_Modification (AV, Sure => True); 18467 18468 -- We must reject parenthesized variable names. Comes_From_Source is 18469 -- checked because there are currently cases where the compiler violates 18470 -- this rule (e.g. passing a task object to its controlled Initialize 18471 -- routine). This should be properly documented in sinfo??? 18472 18473 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then 18474 return False; 18475 18476 -- A variable is always allowed 18477 18478 elsif Is_Variable (AV) then 18479 return True; 18480 18481 -- Generalized indexing operations are rewritten as explicit 18482 -- dereferences, and it is only during resolution that we can 18483 -- check whether the context requires an access_to_variable type. 18484 18485 elsif Nkind (AV) = N_Explicit_Dereference 18486 and then Present (Etype (Original_Node (AV))) 18487 and then Has_Implicit_Dereference (Etype (Original_Node (AV))) 18488 and then Ada_Version >= Ada_2012 18489 then 18490 return not Is_Access_Constant (Etype (Prefix (AV))); 18491 18492 -- Unchecked conversions are allowed only if they come from the 18493 -- generated code, which sometimes uses unchecked conversions for out 18494 -- parameters in cases where code generation is unaffected. We tell 18495 -- source unchecked conversions by seeing if they are rewrites of 18496 -- an original Unchecked_Conversion function call, or of an explicit 18497 -- conversion of a function call or an aggregate (as may happen in the 18498 -- expansion of a packed array aggregate). 18499 18500 elsif Nkind (AV) = N_Unchecked_Type_Conversion then 18501 if Nkind (Original_Node (AV)) in N_Function_Call | N_Aggregate then 18502 return False; 18503 18504 elsif Comes_From_Source (AV) 18505 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call 18506 then 18507 return False; 18508 18509 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then 18510 return Is_OK_Variable_For_Out_Formal (Expression (AV)); 18511 18512 else 18513 return True; 18514 end if; 18515 18516 -- Normal type conversions are allowed if argument is a variable 18517 18518 elsif Nkind (AV) = N_Type_Conversion then 18519 if Is_Variable (Expression (AV)) 18520 and then Paren_Count (Expression (AV)) = 0 18521 then 18522 Note_Possible_Modification (Expression (AV), Sure => True); 18523 return True; 18524 18525 -- We also allow a non-parenthesized expression that raises 18526 -- constraint error if it rewrites what used to be a variable 18527 18528 elsif Raises_Constraint_Error (Expression (AV)) 18529 and then Paren_Count (Expression (AV)) = 0 18530 and then Is_Variable (Original_Node (Expression (AV))) 18531 then 18532 return True; 18533 18534 -- Type conversion of something other than a variable 18535 18536 else 18537 return False; 18538 end if; 18539 18540 -- If this node is rewritten, then test the original form, if that is 18541 -- OK, then we consider the rewritten node OK (for example, if the 18542 -- original node is a conversion, then Is_Variable will not be true 18543 -- but we still want to allow the conversion if it converts a variable). 18544 18545 elsif Is_Rewrite_Substitution (AV) then 18546 return Is_OK_Variable_For_Out_Formal (Original_Node (AV)); 18547 18548 -- All other non-variables are rejected 18549 18550 else 18551 return False; 18552 end if; 18553 end Is_OK_Variable_For_Out_Formal; 18554 18555 ---------------------------- 18556 -- Is_OK_Volatile_Context -- 18557 ---------------------------- 18558 18559 function Is_OK_Volatile_Context 18560 (Context : Node_Id; 18561 Obj_Ref : Node_Id) return Boolean 18562 is 18563 function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean; 18564 -- Determine whether an arbitrary node denotes a call to a protected 18565 -- entry, function, or procedure in prefixed form where the prefix is 18566 -- Obj_Ref. 18567 18568 function Within_Check (Nod : Node_Id) return Boolean; 18569 -- Determine whether an arbitrary node appears in a check node 18570 18571 function Within_Volatile_Function (Id : Entity_Id) return Boolean; 18572 -- Determine whether an arbitrary entity appears in a volatile function 18573 18574 --------------------------------- 18575 -- Is_Protected_Operation_Call -- 18576 --------------------------------- 18577 18578 function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean is 18579 Pref : Node_Id; 18580 Subp : Node_Id; 18581 18582 begin 18583 -- A call to a protected operations retains its selected component 18584 -- form as opposed to other prefixed calls that are transformed in 18585 -- expanded names. 18586 18587 if Nkind (Nod) = N_Selected_Component then 18588 Pref := Prefix (Nod); 18589 Subp := Selector_Name (Nod); 18590 18591 return 18592 Pref = Obj_Ref 18593 and then Present (Etype (Pref)) 18594 and then Is_Protected_Type (Etype (Pref)) 18595 and then Is_Entity_Name (Subp) 18596 and then Present (Entity (Subp)) 18597 and then Ekind (Entity (Subp)) in 18598 E_Entry | E_Entry_Family | E_Function | E_Procedure; 18599 else 18600 return False; 18601 end if; 18602 end Is_Protected_Operation_Call; 18603 18604 ------------------ 18605 -- Within_Check -- 18606 ------------------ 18607 18608 function Within_Check (Nod : Node_Id) return Boolean is 18609 Par : Node_Id; 18610 18611 begin 18612 -- Climb the parent chain looking for a check node 18613 18614 Par := Nod; 18615 while Present (Par) loop 18616 if Nkind (Par) in N_Raise_xxx_Error then 18617 return True; 18618 18619 -- Prevent the search from going too far 18620 18621 elsif Is_Body_Or_Package_Declaration (Par) then 18622 exit; 18623 end if; 18624 18625 Par := Parent (Par); 18626 end loop; 18627 18628 return False; 18629 end Within_Check; 18630 18631 ------------------------------ 18632 -- Within_Volatile_Function -- 18633 ------------------------------ 18634 18635 function Within_Volatile_Function (Id : Entity_Id) return Boolean is 18636 Func_Id : Entity_Id; 18637 18638 begin 18639 -- Traverse the scope stack looking for a [generic] function 18640 18641 Func_Id := Id; 18642 while Present (Func_Id) and then Func_Id /= Standard_Standard loop 18643 if Ekind (Func_Id) in E_Function | E_Generic_Function then 18644 return Is_Volatile_Function (Func_Id); 18645 end if; 18646 18647 Func_Id := Scope (Func_Id); 18648 end loop; 18649 18650 return False; 18651 end Within_Volatile_Function; 18652 18653 -- Local variables 18654 18655 Obj_Id : Entity_Id; 18656 18657 -- Start of processing for Is_OK_Volatile_Context 18658 18659 begin 18660 -- The volatile object appears on either side of an assignment 18661 18662 if Nkind (Context) = N_Assignment_Statement then 18663 return True; 18664 18665 -- The volatile object is part of the initialization expression of 18666 -- another object. 18667 18668 elsif Nkind (Context) = N_Object_Declaration 18669 and then Present (Expression (Context)) 18670 and then Expression (Context) = Obj_Ref 18671 and then Nkind (Parent (Context)) /= N_Expression_With_Actions 18672 then 18673 Obj_Id := Defining_Entity (Context); 18674 18675 -- The volatile object acts as the initialization expression of an 18676 -- extended return statement. This is valid context as long as the 18677 -- function is volatile. 18678 18679 if Is_Return_Object (Obj_Id) then 18680 return Within_Volatile_Function (Obj_Id); 18681 18682 -- Otherwise this is a normal object initialization 18683 18684 else 18685 return True; 18686 end if; 18687 18688 -- The volatile object acts as the name of a renaming declaration 18689 18690 elsif Nkind (Context) = N_Object_Renaming_Declaration 18691 and then Name (Context) = Obj_Ref 18692 then 18693 return True; 18694 18695 -- The volatile object appears as an actual parameter in a call to an 18696 -- instance of Unchecked_Conversion whose result is renamed. 18697 18698 elsif Nkind (Context) = N_Function_Call 18699 and then Is_Entity_Name (Name (Context)) 18700 and then Is_Unchecked_Conversion_Instance (Entity (Name (Context))) 18701 and then Nkind (Parent (Context)) = N_Object_Renaming_Declaration 18702 then 18703 return True; 18704 18705 -- The volatile object is actually the prefix in a protected entry, 18706 -- function, or procedure call. 18707 18708 elsif Is_Protected_Operation_Call (Context) then 18709 return True; 18710 18711 -- The volatile object appears as the expression of a simple return 18712 -- statement that applies to a volatile function. 18713 18714 elsif Nkind (Context) = N_Simple_Return_Statement 18715 and then Expression (Context) = Obj_Ref 18716 then 18717 return 18718 Within_Volatile_Function (Return_Statement_Entity (Context)); 18719 18720 -- The volatile object appears as the prefix of a name occurring in a 18721 -- non-interfering context. 18722 18723 elsif Nkind (Context) in 18724 N_Attribute_Reference | 18725 N_Explicit_Dereference | 18726 N_Indexed_Component | 18727 N_Selected_Component | 18728 N_Slice 18729 and then Prefix (Context) = Obj_Ref 18730 and then Is_OK_Volatile_Context 18731 (Context => Parent (Context), 18732 Obj_Ref => Context) 18733 then 18734 return True; 18735 18736 -- The volatile object appears as the prefix of attributes Address, 18737 -- Alignment, Component_Size, First, First_Bit, Last, Last_Bit, Length, 18738 -- Position, Size, Storage_Size. 18739 18740 elsif Nkind (Context) = N_Attribute_Reference 18741 and then Prefix (Context) = Obj_Ref 18742 and then Attribute_Name (Context) in Name_Address 18743 | Name_Alignment 18744 | Name_Component_Size 18745 | Name_First 18746 | Name_First_Bit 18747 | Name_Last 18748 | Name_Last_Bit 18749 | Name_Length 18750 | Name_Position 18751 | Name_Size 18752 | Name_Storage_Size 18753 then 18754 return True; 18755 18756 -- The volatile object appears as the expression of a type conversion 18757 -- occurring in a non-interfering context. 18758 18759 elsif Nkind (Context) in N_Qualified_Expression 18760 | N_Type_Conversion 18761 | N_Unchecked_Type_Conversion 18762 and then Expression (Context) = Obj_Ref 18763 and then Is_OK_Volatile_Context 18764 (Context => Parent (Context), 18765 Obj_Ref => Context) 18766 then 18767 return True; 18768 18769 -- The volatile object appears as the expression in a delay statement 18770 18771 elsif Nkind (Context) in N_Delay_Statement then 18772 return True; 18773 18774 -- Allow references to volatile objects in various checks. This is not a 18775 -- direct SPARK 2014 requirement. 18776 18777 elsif Within_Check (Context) then 18778 return True; 18779 18780 -- Assume that references to effectively volatile objects that appear 18781 -- as actual parameters in a subprogram call are always legal. A full 18782 -- legality check is done when the actuals are resolved (see routine 18783 -- Resolve_Actuals). 18784 18785 elsif Within_Subprogram_Call (Context) then 18786 return True; 18787 18788 -- Otherwise the context is not suitable for an effectively volatile 18789 -- object. 18790 18791 else 18792 return False; 18793 end if; 18794 end Is_OK_Volatile_Context; 18795 18796 ------------------------------------ 18797 -- Is_Package_Contract_Annotation -- 18798 ------------------------------------ 18799 18800 function Is_Package_Contract_Annotation (Item : Node_Id) return Boolean is 18801 Nam : Name_Id; 18802 18803 begin 18804 if Nkind (Item) = N_Aspect_Specification then 18805 Nam := Chars (Identifier (Item)); 18806 18807 else pragma Assert (Nkind (Item) = N_Pragma); 18808 Nam := Pragma_Name (Item); 18809 end if; 18810 18811 return Nam = Name_Abstract_State 18812 or else Nam = Name_Initial_Condition 18813 or else Nam = Name_Initializes 18814 or else Nam = Name_Refined_State; 18815 end Is_Package_Contract_Annotation; 18816 18817 ----------------------------------- 18818 -- Is_Partially_Initialized_Type -- 18819 ----------------------------------- 18820 18821 function Is_Partially_Initialized_Type 18822 (Typ : Entity_Id; 18823 Include_Implicit : Boolean := True) return Boolean 18824 is 18825 begin 18826 if Is_Scalar_Type (Typ) then 18827 return Has_Default_Aspect (Base_Type (Typ)); 18828 18829 elsif Is_Access_Type (Typ) then 18830 return Include_Implicit; 18831 18832 elsif Is_Array_Type (Typ) then 18833 18834 -- If component type is partially initialized, so is array type 18835 18836 if Has_Default_Aspect (Base_Type (Typ)) 18837 or else Is_Partially_Initialized_Type 18838 (Component_Type (Typ), Include_Implicit) 18839 then 18840 return True; 18841 18842 -- Otherwise we are only partially initialized if we are fully 18843 -- initialized (this is the empty array case, no point in us 18844 -- duplicating that code here). 18845 18846 else 18847 return Is_Fully_Initialized_Type (Typ); 18848 end if; 18849 18850 elsif Is_Record_Type (Typ) then 18851 18852 -- A discriminated type is always partially initialized if in 18853 -- all mode 18854 18855 if Has_Discriminants (Typ) and then Include_Implicit then 18856 return True; 18857 18858 -- A tagged type is always partially initialized 18859 18860 elsif Is_Tagged_Type (Typ) then 18861 return True; 18862 18863 -- Case of non-discriminated record 18864 18865 else 18866 declare 18867 Comp : Entity_Id; 18868 18869 Component_Present : Boolean := False; 18870 -- Set True if at least one component is present. If no 18871 -- components are present, then record type is fully 18872 -- initialized (another odd case, like the null array). 18873 18874 begin 18875 -- Loop through components 18876 18877 Comp := First_Component (Typ); 18878 while Present (Comp) loop 18879 Component_Present := True; 18880 18881 -- If a component has an initialization expression then the 18882 -- enclosing record type is partially initialized 18883 18884 if Present (Parent (Comp)) 18885 and then Present (Expression (Parent (Comp))) 18886 then 18887 return True; 18888 18889 -- If a component is of a type which is itself partially 18890 -- initialized, then the enclosing record type is also. 18891 18892 elsif Is_Partially_Initialized_Type 18893 (Etype (Comp), Include_Implicit) 18894 then 18895 return True; 18896 end if; 18897 18898 Next_Component (Comp); 18899 end loop; 18900 18901 -- No initialized components found. If we found any components 18902 -- they were all uninitialized so the result is false. 18903 18904 if Component_Present then 18905 return False; 18906 18907 -- But if we found no components, then all the components are 18908 -- initialized so we consider the type to be initialized. 18909 18910 else 18911 return True; 18912 end if; 18913 end; 18914 end if; 18915 18916 -- Concurrent types are always fully initialized 18917 18918 elsif Is_Concurrent_Type (Typ) then 18919 return True; 18920 18921 -- For a private type, go to underlying type. If there is no underlying 18922 -- type then just assume this partially initialized. Not clear if this 18923 -- can happen in a non-error case, but no harm in testing for this. 18924 18925 elsif Is_Private_Type (Typ) then 18926 declare 18927 U : constant Entity_Id := Underlying_Type (Typ); 18928 begin 18929 if No (U) then 18930 return True; 18931 else 18932 return Is_Partially_Initialized_Type (U, Include_Implicit); 18933 end if; 18934 end; 18935 18936 -- For any other type (are there any?) assume partially initialized 18937 18938 else 18939 return True; 18940 end if; 18941 end Is_Partially_Initialized_Type; 18942 18943 ------------------------------------ 18944 -- Is_Potentially_Persistent_Type -- 18945 ------------------------------------ 18946 18947 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is 18948 Comp : Entity_Id; 18949 Indx : Node_Id; 18950 18951 begin 18952 -- For private type, test corresponding full type 18953 18954 if Is_Private_Type (T) then 18955 return Is_Potentially_Persistent_Type (Full_View (T)); 18956 18957 -- Scalar types are potentially persistent 18958 18959 elsif Is_Scalar_Type (T) then 18960 return True; 18961 18962 -- Record type is potentially persistent if not tagged and the types of 18963 -- all it components are potentially persistent, and no component has 18964 -- an initialization expression. 18965 18966 elsif Is_Record_Type (T) 18967 and then not Is_Tagged_Type (T) 18968 and then not Is_Partially_Initialized_Type (T) 18969 then 18970 Comp := First_Component (T); 18971 while Present (Comp) loop 18972 if not Is_Potentially_Persistent_Type (Etype (Comp)) then 18973 return False; 18974 else 18975 Next_Entity (Comp); 18976 end if; 18977 end loop; 18978 18979 return True; 18980 18981 -- Array type is potentially persistent if its component type is 18982 -- potentially persistent and if all its constraints are static. 18983 18984 elsif Is_Array_Type (T) then 18985 if not Is_Potentially_Persistent_Type (Component_Type (T)) then 18986 return False; 18987 end if; 18988 18989 Indx := First_Index (T); 18990 while Present (Indx) loop 18991 if not Is_OK_Static_Subtype (Etype (Indx)) then 18992 return False; 18993 else 18994 Next_Index (Indx); 18995 end if; 18996 end loop; 18997 18998 return True; 18999 19000 -- All other types are not potentially persistent 19001 19002 else 19003 return False; 19004 end if; 19005 end Is_Potentially_Persistent_Type; 19006 19007 -------------------------------- 19008 -- Is_Potentially_Unevaluated -- 19009 -------------------------------- 19010 19011 function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is 19012 function Has_Null_Others_Choice (Aggr : Node_Id) return Boolean; 19013 -- Aggr is an array aggregate with static bounds and an others clause; 19014 -- return True if the others choice of the given array aggregate does 19015 -- not cover any component (i.e. is null). 19016 19017 function Immediate_Context_Implies_Is_Potentially_Unevaluated 19018 (Expr : Node_Id) return Boolean; 19019 -- Return True if the *immediate* context of this expression tells us 19020 -- that it is potentially unevaluated; return False if the *immediate* 19021 -- context doesn't provide an answer to this question and we need to 19022 -- keep looking. 19023 19024 function Non_Static_Or_Null_Range (N : Node_Id) return Boolean; 19025 -- Return True if the given range is nonstatic or null 19026 19027 ---------------------------- 19028 -- Has_Null_Others_Choice -- 19029 ---------------------------- 19030 19031 function Has_Null_Others_Choice (Aggr : Node_Id) return Boolean is 19032 Idx : constant Node_Id := First_Index (Etype (Aggr)); 19033 Hiv : constant Uint := Expr_Value (Type_High_Bound (Etype (Idx))); 19034 Lov : constant Uint := Expr_Value (Type_Low_Bound (Etype (Idx))); 19035 19036 begin 19037 declare 19038 Intervals : constant Interval_Lists.Discrete_Interval_List := 19039 Interval_Lists.Aggregate_Intervals (Aggr); 19040 19041 begin 19042 -- The others choice is null if, after normalization, we 19043 -- have a single interval covering the whole aggregate. 19044 19045 return Intervals'Length = 1 19046 and then 19047 Intervals (Intervals'First).Low = Lov 19048 and then 19049 Intervals (Intervals'First).High = Hiv; 19050 end; 19051 19052 -- If the aggregate is malformed (that is, indexes are not disjoint) 19053 -- then no action is needed at this stage; the error will be reported 19054 -- later by the frontend. 19055 19056 exception 19057 when Interval_Lists.Intervals_Error => 19058 return False; 19059 end Has_Null_Others_Choice; 19060 19061 ---------------------------------------------------------- 19062 -- Immediate_Context_Implies_Is_Potentially_Unevaluated -- 19063 ---------------------------------------------------------- 19064 19065 function Immediate_Context_Implies_Is_Potentially_Unevaluated 19066 (Expr : Node_Id) return Boolean 19067 is 19068 Par : constant Node_Id := Parent (Expr); 19069 19070 function Aggregate_Type return Node_Id is (Etype (Parent (Par))); 19071 begin 19072 if Nkind (Par) = N_If_Expression then 19073 return Is_Elsif (Par) or else Expr /= First (Expressions (Par)); 19074 19075 elsif Nkind (Par) = N_Case_Expression then 19076 return Expr /= Expression (Par); 19077 19078 elsif Nkind (Par) in N_And_Then | N_Or_Else then 19079 return Expr = Right_Opnd (Par); 19080 19081 elsif Nkind (Par) in N_In | N_Not_In then 19082 19083 -- If the membership includes several alternatives, only the first 19084 -- is definitely evaluated. 19085 19086 if Present (Alternatives (Par)) then 19087 return Expr /= First (Alternatives (Par)); 19088 19089 -- If this is a range membership both bounds are evaluated 19090 19091 else 19092 return False; 19093 end if; 19094 19095 elsif Nkind (Par) = N_Quantified_Expression then 19096 return Expr = Condition (Par); 19097 19098 elsif Nkind (Par) = N_Component_Association 19099 and then Expr = Expression (Par) 19100 and then Nkind (Parent (Par)) 19101 in N_Aggregate | N_Delta_Aggregate | N_Extension_Aggregate 19102 and then Present (Aggregate_Type) 19103 and then Aggregate_Type /= Any_Composite 19104 then 19105 if Is_Array_Type (Aggregate_Type) then 19106 if Ada_Version >= Ada_2020 then 19107 -- For Ada_2020, this predicate returns True for 19108 -- any "repeatedly evaluated" expression. 19109 return True; 19110 end if; 19111 19112 declare 19113 Choice : Node_Id; 19114 In_Others_Choice : Boolean := False; 19115 Array_Agg : constant Node_Id := Parent (Par); 19116 begin 19117 -- The expression of an array_component_association is 19118 -- potentially unevaluated if the associated choice is a 19119 -- subtype_indication or range that defines a nonstatic or 19120 -- null range. 19121 19122 Choice := First (Choices (Par)); 19123 while Present (Choice) loop 19124 if Nkind (Choice) = N_Range 19125 and then Non_Static_Or_Null_Range (Choice) 19126 then 19127 return True; 19128 19129 elsif Nkind (Choice) = N_Identifier 19130 and then Present (Scalar_Range (Etype (Choice))) 19131 and then 19132 Non_Static_Or_Null_Range 19133 (Scalar_Range (Etype (Choice))) 19134 then 19135 return True; 19136 19137 elsif Nkind (Choice) = N_Others_Choice then 19138 In_Others_Choice := True; 19139 end if; 19140 19141 Next (Choice); 19142 end loop; 19143 19144 -- It is also potentially unevaluated if the associated 19145 -- choice is an others choice and the applicable index 19146 -- constraint is nonstatic or null. 19147 19148 if In_Others_Choice then 19149 if not Compile_Time_Known_Bounds (Aggregate_Type) then 19150 return True; 19151 else 19152 return Has_Null_Others_Choice (Array_Agg); 19153 end if; 19154 end if; 19155 end; 19156 19157 elsif Is_Container_Aggregate (Parent (Par)) then 19158 -- a component of a container aggregate 19159 return True; 19160 end if; 19161 19162 return False; 19163 19164 else 19165 return False; 19166 end if; 19167 end Immediate_Context_Implies_Is_Potentially_Unevaluated; 19168 19169 ------------------------------ 19170 -- Non_Static_Or_Null_Range -- 19171 ------------------------------ 19172 19173 function Non_Static_Or_Null_Range (N : Node_Id) return Boolean is 19174 Low, High : Node_Id; 19175 19176 begin 19177 Get_Index_Bounds (N, Low, High); 19178 19179 -- Check static bounds 19180 19181 if not Compile_Time_Known_Value (Low) 19182 or else not Compile_Time_Known_Value (High) 19183 then 19184 return True; 19185 19186 -- Check null range 19187 19188 elsif Expr_Value (High) < Expr_Value (Low) then 19189 return True; 19190 end if; 19191 19192 return False; 19193 end Non_Static_Or_Null_Range; 19194 19195 -- Local variables 19196 19197 Par : Node_Id; 19198 Expr : Node_Id; 19199 19200 -- Start of processing for Is_Potentially_Unevaluated 19201 19202 begin 19203 Expr := N; 19204 Par := N; 19205 19206 -- A postcondition whose expression is a short-circuit is broken down 19207 -- into individual aspects for better exception reporting. The original 19208 -- short-circuit expression is rewritten as the second operand, and an 19209 -- occurrence of 'Old in that operand is potentially unevaluated. 19210 -- See sem_ch13.adb for details of this transformation. The reference 19211 -- to 'Old may appear within an expression, so we must look for the 19212 -- enclosing pragma argument in the tree that contains the reference. 19213 19214 while Present (Par) 19215 and then Nkind (Par) /= N_Pragma_Argument_Association 19216 loop 19217 if Is_Rewrite_Substitution (Par) 19218 and then Nkind (Original_Node (Par)) = N_And_Then 19219 then 19220 return True; 19221 end if; 19222 19223 Par := Parent (Par); 19224 end loop; 19225 19226 -- Other cases; 'Old appears within other expression (not the top-level 19227 -- conjunct in a postcondition) with a potentially unevaluated operand. 19228 19229 Par := Parent (Expr); 19230 19231 while Present (Par) 19232 and then Nkind (Par) /= N_Pragma_Argument_Association 19233 loop 19234 if Comes_From_Source (Par) 19235 and then 19236 Immediate_Context_Implies_Is_Potentially_Unevaluated (Expr) 19237 then 19238 return True; 19239 19240 -- For component associations continue climbing; it may be part of 19241 -- an array aggregate. 19242 19243 elsif Nkind (Par) = N_Component_Association then 19244 null; 19245 19246 -- If the context is not an expression, or if is the result of 19247 -- expansion of an enclosing construct (such as another attribute) 19248 -- the predicate does not apply. 19249 19250 elsif Nkind (Par) = N_Case_Expression_Alternative then 19251 null; 19252 19253 elsif Nkind (Par) not in N_Subexpr 19254 or else not Comes_From_Source (Par) 19255 then 19256 return False; 19257 end if; 19258 19259 Expr := Par; 19260 Par := Parent (Par); 19261 end loop; 19262 19263 return False; 19264 end Is_Potentially_Unevaluated; 19265 19266 ----------------------------------------- 19267 -- Is_Predefined_Dispatching_Operation -- 19268 ----------------------------------------- 19269 19270 function Is_Predefined_Dispatching_Operation 19271 (E : Entity_Id) return Boolean 19272 is 19273 TSS_Name : TSS_Name_Type; 19274 19275 begin 19276 if not Is_Dispatching_Operation (E) then 19277 return False; 19278 end if; 19279 19280 Get_Name_String (Chars (E)); 19281 19282 -- Most predefined primitives have internally generated names. Equality 19283 -- must be treated differently; the predefined operation is recognized 19284 -- as a homogeneous binary operator that returns Boolean. 19285 19286 if Name_Len > TSS_Name_Type'Last then 19287 TSS_Name := 19288 TSS_Name_Type 19289 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); 19290 19291 if Chars (E) in Name_uAssign | Name_uSize 19292 or else 19293 (Chars (E) = Name_Op_Eq 19294 and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) 19295 or else TSS_Name = TSS_Deep_Adjust 19296 or else TSS_Name = TSS_Deep_Finalize 19297 or else TSS_Name = TSS_Stream_Input 19298 or else TSS_Name = TSS_Stream_Output 19299 or else TSS_Name = TSS_Stream_Read 19300 or else TSS_Name = TSS_Stream_Write 19301 or else TSS_Name = TSS_Put_Image 19302 or else Is_Predefined_Interface_Primitive (E) 19303 then 19304 return True; 19305 end if; 19306 end if; 19307 19308 return False; 19309 end Is_Predefined_Dispatching_Operation; 19310 19311 --------------------------------------- 19312 -- Is_Predefined_Interface_Primitive -- 19313 --------------------------------------- 19314 19315 function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is 19316 begin 19317 -- In VM targets we don't restrict the functionality of this test to 19318 -- compiling in Ada 2005 mode since in VM targets any tagged type has 19319 -- these primitives. 19320 19321 return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion) 19322 and then Chars (E) in Name_uDisp_Asynchronous_Select 19323 | Name_uDisp_Conditional_Select 19324 | Name_uDisp_Get_Prim_Op_Kind 19325 | Name_uDisp_Get_Task_Id 19326 | Name_uDisp_Requeue 19327 | Name_uDisp_Timed_Select; 19328 end Is_Predefined_Interface_Primitive; 19329 19330 --------------------------------------- 19331 -- Is_Predefined_Internal_Operation -- 19332 --------------------------------------- 19333 19334 function Is_Predefined_Internal_Operation 19335 (E : Entity_Id) return Boolean 19336 is 19337 TSS_Name : TSS_Name_Type; 19338 19339 begin 19340 if not Is_Dispatching_Operation (E) then 19341 return False; 19342 end if; 19343 19344 Get_Name_String (Chars (E)); 19345 19346 -- Most predefined primitives have internally generated names. Equality 19347 -- must be treated differently; the predefined operation is recognized 19348 -- as a homogeneous binary operator that returns Boolean. 19349 19350 if Name_Len > TSS_Name_Type'Last then 19351 TSS_Name := 19352 TSS_Name_Type 19353 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); 19354 19355 if Chars (E) in Name_uSize | Name_uAssign 19356 or else 19357 (Chars (E) = Name_Op_Eq 19358 and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) 19359 or else TSS_Name = TSS_Deep_Adjust 19360 or else TSS_Name = TSS_Deep_Finalize 19361 or else Is_Predefined_Interface_Primitive (E) 19362 then 19363 return True; 19364 end if; 19365 end if; 19366 19367 return False; 19368 end Is_Predefined_Internal_Operation; 19369 19370 -------------------------------- 19371 -- Is_Preelaborable_Aggregate -- 19372 -------------------------------- 19373 19374 function Is_Preelaborable_Aggregate (Aggr : Node_Id) return Boolean is 19375 Aggr_Typ : constant Entity_Id := Etype (Aggr); 19376 Array_Aggr : constant Boolean := Is_Array_Type (Aggr_Typ); 19377 19378 Anc_Part : Node_Id; 19379 Assoc : Node_Id; 19380 Choice : Node_Id; 19381 Comp_Typ : Entity_Id := Empty; -- init to avoid warning 19382 Expr : Node_Id; 19383 19384 begin 19385 if Array_Aggr then 19386 Comp_Typ := Component_Type (Aggr_Typ); 19387 end if; 19388 19389 -- Inspect the ancestor part 19390 19391 if Nkind (Aggr) = N_Extension_Aggregate then 19392 Anc_Part := Ancestor_Part (Aggr); 19393 19394 -- The ancestor denotes a subtype mark 19395 19396 if Is_Entity_Name (Anc_Part) 19397 and then Is_Type (Entity (Anc_Part)) 19398 then 19399 if not Has_Preelaborable_Initialization (Entity (Anc_Part)) then 19400 return False; 19401 end if; 19402 19403 -- Otherwise the ancestor denotes an expression 19404 19405 elsif not Is_Preelaborable_Construct (Anc_Part) then 19406 return False; 19407 end if; 19408 end if; 19409 19410 -- Inspect the positional associations 19411 19412 Expr := First (Expressions (Aggr)); 19413 while Present (Expr) loop 19414 if not Is_Preelaborable_Construct (Expr) then 19415 return False; 19416 end if; 19417 19418 Next (Expr); 19419 end loop; 19420 19421 -- Inspect the named associations 19422 19423 Assoc := First (Component_Associations (Aggr)); 19424 while Present (Assoc) loop 19425 19426 -- Inspect the choices of the current named association 19427 19428 Choice := First (Choices (Assoc)); 19429 while Present (Choice) loop 19430 if Array_Aggr then 19431 19432 -- For a choice to be preelaborable, it must denote either a 19433 -- static range or a static expression. 19434 19435 if Nkind (Choice) = N_Others_Choice then 19436 null; 19437 19438 elsif Nkind (Choice) = N_Range then 19439 if not Is_OK_Static_Range (Choice) then 19440 return False; 19441 end if; 19442 19443 elsif not Is_OK_Static_Expression (Choice) then 19444 return False; 19445 end if; 19446 19447 else 19448 Comp_Typ := Etype (Choice); 19449 end if; 19450 19451 Next (Choice); 19452 end loop; 19453 19454 -- The type of the choice must have preelaborable initialization if 19455 -- the association carries a <>. 19456 19457 pragma Assert (Present (Comp_Typ)); 19458 if Box_Present (Assoc) then 19459 if not Has_Preelaborable_Initialization (Comp_Typ) then 19460 return False; 19461 end if; 19462 19463 -- The type of the expression must have preelaborable initialization 19464 19465 elsif not Is_Preelaborable_Construct (Expression (Assoc)) then 19466 return False; 19467 end if; 19468 19469 Next (Assoc); 19470 end loop; 19471 19472 -- At this point the aggregate is preelaborable 19473 19474 return True; 19475 end Is_Preelaborable_Aggregate; 19476 19477 -------------------------------- 19478 -- Is_Preelaborable_Construct -- 19479 -------------------------------- 19480 19481 function Is_Preelaborable_Construct (N : Node_Id) return Boolean is 19482 begin 19483 -- Aggregates 19484 19485 if Nkind (N) in N_Aggregate | N_Extension_Aggregate then 19486 return Is_Preelaborable_Aggregate (N); 19487 19488 -- Attributes are allowed in general, even if their prefix is a formal 19489 -- type. It seems that certain attributes known not to be static might 19490 -- not be allowed, but there are no rules to prevent them. 19491 19492 elsif Nkind (N) = N_Attribute_Reference then 19493 return True; 19494 19495 -- Expressions 19496 19497 elsif Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then 19498 return True; 19499 19500 elsif Nkind (N) = N_Qualified_Expression then 19501 return Is_Preelaborable_Construct (Expression (N)); 19502 19503 -- Names are preelaborable when they denote a discriminant of an 19504 -- enclosing type. Discriminals are also considered for this check. 19505 19506 elsif Is_Entity_Name (N) 19507 and then Present (Entity (N)) 19508 and then 19509 (Ekind (Entity (N)) = E_Discriminant 19510 or else (Ekind (Entity (N)) in E_Constant | E_In_Parameter 19511 and then Present (Discriminal_Link (Entity (N))))) 19512 then 19513 return True; 19514 19515 -- Statements 19516 19517 elsif Nkind (N) = N_Null then 19518 return True; 19519 19520 -- Ada 2020 (AI12-0175): Calls to certain functions that are essentially 19521 -- unchecked conversions are preelaborable. 19522 19523 elsif Ada_Version >= Ada_2020 19524 and then Nkind (N) = N_Function_Call 19525 and then Is_Entity_Name (Name (N)) 19526 and then Is_Preelaborable_Function (Entity (Name (N))) 19527 then 19528 declare 19529 A : Node_Id; 19530 begin 19531 A := First_Actual (N); 19532 19533 while Present (A) loop 19534 if not Is_Preelaborable_Construct (A) then 19535 return False; 19536 end if; 19537 19538 Next_Actual (A); 19539 end loop; 19540 end; 19541 19542 return True; 19543 19544 -- Otherwise the construct is not preelaborable 19545 19546 else 19547 return False; 19548 end if; 19549 end Is_Preelaborable_Construct; 19550 19551 ------------------------------- 19552 -- Is_Preelaborable_Function -- 19553 ------------------------------- 19554 19555 function Is_Preelaborable_Function (Id : Entity_Id) return Boolean is 19556 SATAC : constant Rtsfind.RTU_Id := System_Address_To_Access_Conversions; 19557 Scop : constant Entity_Id := Scope (Id); 19558 19559 begin 19560 -- Small optimization: every allowed function has convention Intrinsic 19561 -- (see Analyze_Subprogram_Instantiation for the subtlety in the test). 19562 19563 if not Is_Intrinsic_Subprogram (Id) 19564 and then Convention (Id) /= Convention_Intrinsic 19565 then 19566 return False; 19567 end if; 19568 19569 -- An instance of Unchecked_Conversion 19570 19571 if Is_Unchecked_Conversion_Instance (Id) then 19572 return True; 19573 end if; 19574 19575 -- A function declared in System.Storage_Elements 19576 19577 if Is_RTU (Scop, System_Storage_Elements) then 19578 return True; 19579 end if; 19580 19581 -- The functions To_Pointer and To_Address declared in an instance of 19582 -- System.Address_To_Access_Conversions (they are the only ones). 19583 19584 if Ekind (Scop) = E_Package 19585 and then Nkind (Parent (Scop)) = N_Package_Specification 19586 and then Present (Generic_Parent (Parent (Scop))) 19587 and then Is_RTU (Generic_Parent (Parent (Scop)), SATAC) 19588 then 19589 return True; 19590 end if; 19591 19592 return False; 19593 end Is_Preelaborable_Function; 19594 19595 --------------------------------- 19596 -- Is_Protected_Self_Reference -- 19597 --------------------------------- 19598 19599 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is 19600 19601 function In_Access_Definition (N : Node_Id) return Boolean; 19602 -- Returns true if N belongs to an access definition 19603 19604 -------------------------- 19605 -- In_Access_Definition -- 19606 -------------------------- 19607 19608 function In_Access_Definition (N : Node_Id) return Boolean is 19609 P : Node_Id; 19610 19611 begin 19612 P := Parent (N); 19613 while Present (P) loop 19614 if Nkind (P) = N_Access_Definition then 19615 return True; 19616 end if; 19617 19618 P := Parent (P); 19619 end loop; 19620 19621 return False; 19622 end In_Access_Definition; 19623 19624 -- Start of processing for Is_Protected_Self_Reference 19625 19626 begin 19627 -- Verify that prefix is analyzed and has the proper form. Note that 19628 -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also 19629 -- produce the address of an entity, do not analyze their prefix 19630 -- because they denote entities that are not necessarily visible. 19631 -- Neither of them can apply to a protected type. 19632 19633 return Ada_Version >= Ada_2005 19634 and then Is_Entity_Name (N) 19635 and then Present (Entity (N)) 19636 and then Is_Protected_Type (Entity (N)) 19637 and then In_Open_Scopes (Entity (N)) 19638 and then not In_Access_Definition (N); 19639 end Is_Protected_Self_Reference; 19640 19641 ----------------------------- 19642 -- Is_RCI_Pkg_Spec_Or_Body -- 19643 ----------------------------- 19644 19645 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is 19646 19647 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean; 19648 -- Return True if the unit of Cunit is an RCI package declaration 19649 19650 --------------------------- 19651 -- Is_RCI_Pkg_Decl_Cunit -- 19652 --------------------------- 19653 19654 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is 19655 The_Unit : constant Node_Id := Unit (Cunit); 19656 19657 begin 19658 if Nkind (The_Unit) /= N_Package_Declaration then 19659 return False; 19660 end if; 19661 19662 return Is_Remote_Call_Interface (Defining_Entity (The_Unit)); 19663 end Is_RCI_Pkg_Decl_Cunit; 19664 19665 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body 19666 19667 begin 19668 return Is_RCI_Pkg_Decl_Cunit (Cunit) 19669 or else 19670 (Nkind (Unit (Cunit)) = N_Package_Body 19671 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit))); 19672 end Is_RCI_Pkg_Spec_Or_Body; 19673 19674 ----------------------------------------- 19675 -- Is_Remote_Access_To_Class_Wide_Type -- 19676 ----------------------------------------- 19677 19678 function Is_Remote_Access_To_Class_Wide_Type 19679 (E : Entity_Id) return Boolean 19680 is 19681 begin 19682 -- A remote access to class-wide type is a general access to object type 19683 -- declared in the visible part of a Remote_Types or Remote_Call_ 19684 -- Interface unit. 19685 19686 return Ekind (E) = E_General_Access_Type 19687 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); 19688 end Is_Remote_Access_To_Class_Wide_Type; 19689 19690 ----------------------------------------- 19691 -- Is_Remote_Access_To_Subprogram_Type -- 19692 ----------------------------------------- 19693 19694 function Is_Remote_Access_To_Subprogram_Type 19695 (E : Entity_Id) return Boolean 19696 is 19697 begin 19698 return (Ekind (E) = E_Access_Subprogram_Type 19699 or else (Ekind (E) = E_Record_Type 19700 and then Present (Corresponding_Remote_Type (E)))) 19701 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); 19702 end Is_Remote_Access_To_Subprogram_Type; 19703 19704 -------------------- 19705 -- Is_Remote_Call -- 19706 -------------------- 19707 19708 function Is_Remote_Call (N : Node_Id) return Boolean is 19709 begin 19710 if Nkind (N) not in N_Subprogram_Call then 19711 19712 -- An entry call cannot be remote 19713 19714 return False; 19715 19716 elsif Nkind (Name (N)) in N_Has_Entity 19717 and then Is_Remote_Call_Interface (Entity (Name (N))) 19718 then 19719 -- A subprogram declared in the spec of a RCI package is remote 19720 19721 return True; 19722 19723 elsif Nkind (Name (N)) = N_Explicit_Dereference 19724 and then Is_Remote_Access_To_Subprogram_Type 19725 (Etype (Prefix (Name (N)))) 19726 then 19727 -- The dereference of a RAS is a remote call 19728 19729 return True; 19730 19731 elsif Present (Controlling_Argument (N)) 19732 and then Is_Remote_Access_To_Class_Wide_Type 19733 (Etype (Controlling_Argument (N))) 19734 then 19735 -- Any primitive operation call with a controlling argument of 19736 -- a RACW type is a remote call. 19737 19738 return True; 19739 end if; 19740 19741 -- All other calls are local calls 19742 19743 return False; 19744 end Is_Remote_Call; 19745 19746 ---------------------- 19747 -- Is_Renamed_Entry -- 19748 ---------------------- 19749 19750 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is 19751 Orig_Node : Node_Id := Empty; 19752 Subp_Decl : Node_Id := Parent (Parent (Proc_Nam)); 19753 19754 function Is_Entry (Nam : Node_Id) return Boolean; 19755 -- Determine whether Nam is an entry. Traverse selectors if there are 19756 -- nested selected components. 19757 19758 -------------- 19759 -- Is_Entry -- 19760 -------------- 19761 19762 function Is_Entry (Nam : Node_Id) return Boolean is 19763 begin 19764 if Nkind (Nam) = N_Selected_Component then 19765 return Is_Entry (Selector_Name (Nam)); 19766 end if; 19767 19768 return Ekind (Entity (Nam)) = E_Entry; 19769 end Is_Entry; 19770 19771 -- Start of processing for Is_Renamed_Entry 19772 19773 begin 19774 if Present (Alias (Proc_Nam)) then 19775 Subp_Decl := Parent (Parent (Alias (Proc_Nam))); 19776 end if; 19777 19778 -- Look for a rewritten subprogram renaming declaration 19779 19780 if Nkind (Subp_Decl) = N_Subprogram_Declaration 19781 and then Present (Original_Node (Subp_Decl)) 19782 then 19783 Orig_Node := Original_Node (Subp_Decl); 19784 end if; 19785 19786 -- The rewritten subprogram is actually an entry 19787 19788 if Present (Orig_Node) 19789 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration 19790 and then Is_Entry (Name (Orig_Node)) 19791 then 19792 return True; 19793 end if; 19794 19795 return False; 19796 end Is_Renamed_Entry; 19797 19798 ---------------------------- 19799 -- Is_Reversible_Iterator -- 19800 ---------------------------- 19801 19802 function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is 19803 Ifaces_List : Elist_Id; 19804 Iface_Elmt : Elmt_Id; 19805 Iface : Entity_Id; 19806 19807 begin 19808 if Is_Class_Wide_Type (Typ) 19809 and then Chars (Root_Type (Typ)) = Name_Reversible_Iterator 19810 and then In_Predefined_Unit (Root_Type (Typ)) 19811 then 19812 return True; 19813 19814 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then 19815 return False; 19816 19817 else 19818 Collect_Interfaces (Typ, Ifaces_List); 19819 19820 Iface_Elmt := First_Elmt (Ifaces_List); 19821 while Present (Iface_Elmt) loop 19822 Iface := Node (Iface_Elmt); 19823 if Chars (Iface) = Name_Reversible_Iterator 19824 and then In_Predefined_Unit (Iface) 19825 then 19826 return True; 19827 end if; 19828 19829 Next_Elmt (Iface_Elmt); 19830 end loop; 19831 end if; 19832 19833 return False; 19834 end Is_Reversible_Iterator; 19835 19836 ---------------------- 19837 -- Is_Selector_Name -- 19838 ---------------------- 19839 19840 function Is_Selector_Name (N : Node_Id) return Boolean is 19841 begin 19842 if not Is_List_Member (N) then 19843 declare 19844 P : constant Node_Id := Parent (N); 19845 begin 19846 return Nkind (P) in N_Expanded_Name 19847 | N_Generic_Association 19848 | N_Parameter_Association 19849 | N_Selected_Component 19850 and then Selector_Name (P) = N; 19851 end; 19852 19853 else 19854 declare 19855 L : constant List_Id := List_Containing (N); 19856 P : constant Node_Id := Parent (L); 19857 begin 19858 return (Nkind (P) = N_Discriminant_Association 19859 and then Selector_Names (P) = L) 19860 or else 19861 (Nkind (P) = N_Component_Association 19862 and then Choices (P) = L); 19863 end; 19864 end if; 19865 end Is_Selector_Name; 19866 19867 --------------------------------- 19868 -- Is_Single_Concurrent_Object -- 19869 --------------------------------- 19870 19871 function Is_Single_Concurrent_Object (Id : Entity_Id) return Boolean is 19872 begin 19873 return 19874 Is_Single_Protected_Object (Id) or else Is_Single_Task_Object (Id); 19875 end Is_Single_Concurrent_Object; 19876 19877 ------------------------------- 19878 -- Is_Single_Concurrent_Type -- 19879 ------------------------------- 19880 19881 function Is_Single_Concurrent_Type (Id : Entity_Id) return Boolean is 19882 begin 19883 return 19884 Ekind (Id) in E_Protected_Type | E_Task_Type 19885 and then Is_Single_Concurrent_Type_Declaration 19886 (Declaration_Node (Id)); 19887 end Is_Single_Concurrent_Type; 19888 19889 ------------------------------------------- 19890 -- Is_Single_Concurrent_Type_Declaration -- 19891 ------------------------------------------- 19892 19893 function Is_Single_Concurrent_Type_Declaration 19894 (N : Node_Id) return Boolean 19895 is 19896 begin 19897 return Nkind (Original_Node (N)) in 19898 N_Single_Protected_Declaration | N_Single_Task_Declaration; 19899 end Is_Single_Concurrent_Type_Declaration; 19900 19901 --------------------------------------------- 19902 -- Is_Single_Precision_Floating_Point_Type -- 19903 --------------------------------------------- 19904 19905 function Is_Single_Precision_Floating_Point_Type 19906 (E : Entity_Id) return Boolean is 19907 begin 19908 return Is_Floating_Point_Type (E) 19909 and then Machine_Radix_Value (E) = Uint_2 19910 and then Machine_Mantissa_Value (E) = Uint_24 19911 and then Machine_Emax_Value (E) = Uint_2 ** Uint_7 19912 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_7); 19913 end Is_Single_Precision_Floating_Point_Type; 19914 19915 -------------------------------- 19916 -- Is_Single_Protected_Object -- 19917 -------------------------------- 19918 19919 function Is_Single_Protected_Object (Id : Entity_Id) return Boolean is 19920 begin 19921 return 19922 Ekind (Id) = E_Variable 19923 and then Ekind (Etype (Id)) = E_Protected_Type 19924 and then Is_Single_Concurrent_Type (Etype (Id)); 19925 end Is_Single_Protected_Object; 19926 19927 --------------------------- 19928 -- Is_Single_Task_Object -- 19929 --------------------------- 19930 19931 function Is_Single_Task_Object (Id : Entity_Id) return Boolean is 19932 begin 19933 return 19934 Ekind (Id) = E_Variable 19935 and then Ekind (Etype (Id)) = E_Task_Type 19936 and then Is_Single_Concurrent_Type (Etype (Id)); 19937 end Is_Single_Task_Object; 19938 19939 -------------------------------------- 19940 -- Is_Special_Aliased_Formal_Access -- 19941 -------------------------------------- 19942 19943 function Is_Special_Aliased_Formal_Access 19944 (Exp : Node_Id; 19945 In_Return_Context : Boolean := False) return Boolean 19946 is 19947 Scop : constant Entity_Id := Current_Subprogram; 19948 begin 19949 -- Verify the expression is an access reference to 'Access within a 19950 -- return statement as this is the only time an explicitly aliased 19951 -- formal has different semantics. 19952 19953 if Nkind (Exp) /= N_Attribute_Reference 19954 or else Get_Attribute_Id (Attribute_Name (Exp)) /= Attribute_Access 19955 or else not (In_Return_Value (Exp) 19956 or else In_Return_Context) 19957 or else not Needs_Result_Accessibility_Level (Scop) 19958 then 19959 return False; 19960 end if; 19961 19962 -- Check if the prefix of the reference is indeed an explicitly aliased 19963 -- formal parameter for the function Scop. Additionally, we must check 19964 -- that Scop returns an anonymous access type, otherwise the special 19965 -- rules dictating a need for a dynamic check are not in effect. 19966 19967 return Is_Entity_Name (Prefix (Exp)) 19968 and then Is_Explicitly_Aliased (Entity (Prefix (Exp))); 19969 end Is_Special_Aliased_Formal_Access; 19970 19971 ----------------------------- 19972 -- Is_Specific_Tagged_Type -- 19973 ----------------------------- 19974 19975 function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean is 19976 Full_Typ : Entity_Id; 19977 19978 begin 19979 -- Handle private types 19980 19981 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 19982 Full_Typ := Full_View (Typ); 19983 else 19984 Full_Typ := Typ; 19985 end if; 19986 19987 -- A specific tagged type is a non-class-wide tagged type 19988 19989 return Is_Tagged_Type (Full_Typ) and not Is_Class_Wide_Type (Full_Typ); 19990 end Is_Specific_Tagged_Type; 19991 19992 ------------------ 19993 -- Is_Statement -- 19994 ------------------ 19995 19996 function Is_Statement (N : Node_Id) return Boolean is 19997 begin 19998 return 19999 Nkind (N) in N_Statement_Other_Than_Procedure_Call 20000 or else Nkind (N) = N_Procedure_Call_Statement; 20001 end Is_Statement; 20002 20003 -------------------------------------- 20004 -- Is_Static_Discriminant_Component -- 20005 -------------------------------------- 20006 20007 function Is_Static_Discriminant_Component (N : Node_Id) return Boolean is 20008 begin 20009 return Nkind (N) = N_Selected_Component 20010 and then not Is_In_Discriminant_Check (N) 20011 and then Present (Etype (Prefix (N))) 20012 and then Ekind (Etype (Prefix (N))) = E_Record_Subtype 20013 and then Has_Static_Discriminants (Etype (Prefix (N))) 20014 and then Present (Entity (Selector_Name (N))) 20015 and then Ekind (Entity (Selector_Name (N))) = E_Discriminant 20016 and then not In_Check_Node (N); 20017 end Is_Static_Discriminant_Component; 20018 20019 ------------------------ 20020 -- Is_Static_Function -- 20021 ------------------------ 20022 20023 function Is_Static_Function (Subp : Entity_Id) return Boolean is 20024 begin 20025 -- Always return False for pre Ada 2020 to e.g. ignore the Static 20026 -- aspect in package Interfaces for Ada_Version < 2020 and also 20027 -- for efficiency. 20028 20029 return Ada_Version >= Ada_2020 20030 and then Has_Aspect (Subp, Aspect_Static) 20031 and then 20032 (No (Find_Value_Of_Aspect (Subp, Aspect_Static)) 20033 or else Is_True (Static_Boolean 20034 (Find_Value_Of_Aspect (Subp, Aspect_Static)))); 20035 end Is_Static_Function; 20036 20037 ----------------------------- 20038 -- Is_Static_Function_Call -- 20039 ----------------------------- 20040 20041 function Is_Static_Function_Call (Call : Node_Id) return Boolean is 20042 function Has_All_Static_Actuals (Call : Node_Id) return Boolean; 20043 -- Return whether all actual parameters of Call are static expressions 20044 20045 ---------------------------- 20046 -- Has_All_Static_Actuals -- 20047 ---------------------------- 20048 20049 function Has_All_Static_Actuals (Call : Node_Id) return Boolean is 20050 Actual : Node_Id := First_Actual (Call); 20051 String_Result : constant Boolean := 20052 Is_String_Type (Etype (Entity (Name (Call)))); 20053 20054 begin 20055 while Present (Actual) loop 20056 if not Is_Static_Expression (Actual) then 20057 20058 -- ??? In the string-returning case we want to avoid a call 20059 -- being made to Establish_Transient_Scope in Resolve_Call, 20060 -- but at the point where that's tested for (which now includes 20061 -- a call to test Is_Static_Function_Call), the actuals of the 20062 -- call haven't been resolved, so expressions of the actuals 20063 -- may not have been marked Is_Static_Expression yet, so we 20064 -- force them to be resolved here, so we can tell if they're 20065 -- static. Calling Resolve here is admittedly a kludge, and we 20066 -- limit this call to string-returning cases. 20067 20068 if String_Result then 20069 Resolve (Actual); 20070 end if; 20071 20072 -- Test flag again in case it's now True due to above Resolve 20073 20074 if not Is_Static_Expression (Actual) then 20075 return False; 20076 end if; 20077 end if; 20078 20079 Next_Actual (Actual); 20080 end loop; 20081 20082 return True; 20083 end Has_All_Static_Actuals; 20084 20085 begin 20086 return Nkind (Call) = N_Function_Call 20087 and then Is_Entity_Name (Name (Call)) 20088 and then Is_Static_Function (Entity (Name (Call))) 20089 and then Has_All_Static_Actuals (Call); 20090 end Is_Static_Function_Call; 20091 20092 ------------------------------------------- 20093 -- Is_Subcomponent_Of_Full_Access_Object -- 20094 ------------------------------------------- 20095 20096 function Is_Subcomponent_Of_Full_Access_Object (N : Node_Id) return Boolean 20097 is 20098 R : Node_Id; 20099 20100 begin 20101 R := Get_Referenced_Object (N); 20102 20103 while Nkind (R) in N_Indexed_Component | N_Selected_Component | N_Slice 20104 loop 20105 R := Get_Referenced_Object (Prefix (R)); 20106 20107 -- If the prefix is an access value, only the designated type matters 20108 20109 if Is_Access_Type (Etype (R)) then 20110 if Is_Full_Access (Designated_Type (Etype (R))) then 20111 return True; 20112 end if; 20113 20114 else 20115 if Is_Full_Access_Object (R) then 20116 return True; 20117 end if; 20118 end if; 20119 end loop; 20120 20121 return False; 20122 end Is_Subcomponent_Of_Full_Access_Object; 20123 20124 --------------------------------------- 20125 -- Is_Subprogram_Contract_Annotation -- 20126 --------------------------------------- 20127 20128 function Is_Subprogram_Contract_Annotation 20129 (Item : Node_Id) return Boolean 20130 is 20131 Nam : Name_Id; 20132 20133 begin 20134 if Nkind (Item) = N_Aspect_Specification then 20135 Nam := Chars (Identifier (Item)); 20136 20137 else pragma Assert (Nkind (Item) = N_Pragma); 20138 Nam := Pragma_Name (Item); 20139 end if; 20140 20141 return Nam = Name_Contract_Cases 20142 or else Nam = Name_Depends 20143 or else Nam = Name_Extensions_Visible 20144 or else Nam = Name_Global 20145 or else Nam = Name_Post 20146 or else Nam = Name_Post_Class 20147 or else Nam = Name_Postcondition 20148 or else Nam = Name_Pre 20149 or else Nam = Name_Pre_Class 20150 or else Nam = Name_Precondition 20151 or else Nam = Name_Refined_Depends 20152 or else Nam = Name_Refined_Global 20153 or else Nam = Name_Refined_Post 20154 or else Nam = Name_Subprogram_Variant 20155 or else Nam = Name_Test_Case; 20156 end Is_Subprogram_Contract_Annotation; 20157 20158 -------------------------------------------------- 20159 -- Is_Subprogram_Stub_Without_Prior_Declaration -- 20160 -------------------------------------------------- 20161 20162 function Is_Subprogram_Stub_Without_Prior_Declaration 20163 (N : Node_Id) return Boolean 20164 is 20165 begin 20166 pragma Assert (Nkind (N) = N_Subprogram_Body_Stub); 20167 20168 case Ekind (Defining_Entity (N)) is 20169 20170 -- A subprogram stub without prior declaration serves as declaration 20171 -- for the actual subprogram body. As such, it has an attached 20172 -- defining entity of E_Function or E_Procedure. 20173 20174 when E_Function 20175 | E_Procedure 20176 => 20177 return True; 20178 20179 -- Otherwise, it is completes a [generic] subprogram declaration 20180 20181 when E_Generic_Function 20182 | E_Generic_Procedure 20183 | E_Subprogram_Body 20184 => 20185 return False; 20186 20187 when others => 20188 raise Program_Error; 20189 end case; 20190 end Is_Subprogram_Stub_Without_Prior_Declaration; 20191 20192 --------------------------- 20193 -- Is_Suitable_Primitive -- 20194 --------------------------- 20195 20196 function Is_Suitable_Primitive (Subp_Id : Entity_Id) return Boolean is 20197 begin 20198 -- The Default_Initial_Condition and invariant procedures must not be 20199 -- treated as primitive operations even when they apply to a tagged 20200 -- type. These routines must not act as targets of dispatching calls 20201 -- because they already utilize class-wide-precondition semantics to 20202 -- handle inheritance and overriding. 20203 20204 if Ekind (Subp_Id) = E_Procedure 20205 and then (Is_DIC_Procedure (Subp_Id) 20206 or else 20207 Is_Invariant_Procedure (Subp_Id)) 20208 then 20209 return False; 20210 end if; 20211 20212 return True; 20213 end Is_Suitable_Primitive; 20214 20215 -------------------------- 20216 -- Is_Suspension_Object -- 20217 -------------------------- 20218 20219 function Is_Suspension_Object (Id : Entity_Id) return Boolean is 20220 begin 20221 -- This approach does an exact name match rather than to rely on 20222 -- RTSfind. Routine Is_Effectively_Volatile is used by clients of the 20223 -- front end at point where all auxiliary tables are locked and any 20224 -- modifications to them are treated as violations. Do not tamper with 20225 -- the tables, instead examine the Chars fields of all the scopes of Id. 20226 20227 return 20228 Chars (Id) = Name_Suspension_Object 20229 and then Present (Scope (Id)) 20230 and then Chars (Scope (Id)) = Name_Synchronous_Task_Control 20231 and then Present (Scope (Scope (Id))) 20232 and then Chars (Scope (Scope (Id))) = Name_Ada 20233 and then Present (Scope (Scope (Scope (Id)))) 20234 and then Scope (Scope (Scope (Id))) = Standard_Standard; 20235 end Is_Suspension_Object; 20236 20237 ---------------------------- 20238 -- Is_Synchronized_Object -- 20239 ---------------------------- 20240 20241 function Is_Synchronized_Object (Id : Entity_Id) return Boolean is 20242 Prag : Node_Id; 20243 20244 begin 20245 if Is_Object (Id) then 20246 20247 -- The object is synchronized if it is of a type that yields a 20248 -- synchronized object. 20249 20250 if Yields_Synchronized_Object (Etype (Id)) then 20251 return True; 20252 20253 -- The object is synchronized if it is atomic and Async_Writers is 20254 -- enabled. 20255 20256 elsif Is_Atomic_Object_Entity (Id) 20257 and then Async_Writers_Enabled (Id) 20258 then 20259 return True; 20260 20261 -- A constant is a synchronized object by default, unless its type is 20262 -- access-to-variable type. 20263 20264 elsif Ekind (Id) = E_Constant 20265 and then not Is_Access_Variable (Etype (Id)) 20266 then 20267 return True; 20268 20269 -- A variable is a synchronized object if it is subject to pragma 20270 -- Constant_After_Elaboration. 20271 20272 elsif Ekind (Id) = E_Variable then 20273 Prag := Get_Pragma (Id, Pragma_Constant_After_Elaboration); 20274 20275 return Present (Prag) and then Is_Enabled_Pragma (Prag); 20276 end if; 20277 end if; 20278 20279 -- Otherwise the input is not an object or it does not qualify as a 20280 -- synchronized object. 20281 20282 return False; 20283 end Is_Synchronized_Object; 20284 20285 --------------------------------- 20286 -- Is_Synchronized_Tagged_Type -- 20287 --------------------------------- 20288 20289 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is 20290 Kind : constant Entity_Kind := Ekind (Base_Type (E)); 20291 20292 begin 20293 -- A task or protected type derived from an interface is a tagged type. 20294 -- Such a tagged type is called a synchronized tagged type, as are 20295 -- synchronized interfaces and private extensions whose declaration 20296 -- includes the reserved word synchronized. 20297 20298 return (Is_Tagged_Type (E) 20299 and then (Kind = E_Task_Type 20300 or else 20301 Kind = E_Protected_Type)) 20302 or else 20303 (Is_Interface (E) 20304 and then Is_Synchronized_Interface (E)) 20305 or else 20306 (Ekind (E) = E_Record_Type_With_Private 20307 and then Nkind (Parent (E)) = N_Private_Extension_Declaration 20308 and then (Synchronized_Present (Parent (E)) 20309 or else Is_Synchronized_Interface (Etype (E)))); 20310 end Is_Synchronized_Tagged_Type; 20311 20312 ----------------- 20313 -- Is_Transfer -- 20314 ----------------- 20315 20316 function Is_Transfer (N : Node_Id) return Boolean is 20317 Kind : constant Node_Kind := Nkind (N); 20318 20319 begin 20320 if Kind = N_Simple_Return_Statement 20321 or else 20322 Kind = N_Extended_Return_Statement 20323 or else 20324 Kind = N_Goto_Statement 20325 or else 20326 Kind = N_Raise_Statement 20327 or else 20328 Kind = N_Requeue_Statement 20329 then 20330 return True; 20331 20332 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error) 20333 and then No (Condition (N)) 20334 then 20335 return True; 20336 20337 elsif Kind = N_Procedure_Call_Statement 20338 and then Is_Entity_Name (Name (N)) 20339 and then Present (Entity (Name (N))) 20340 and then No_Return (Entity (Name (N))) 20341 then 20342 return True; 20343 20344 elsif Nkind (Original_Node (N)) = N_Raise_Statement then 20345 return True; 20346 20347 else 20348 return False; 20349 end if; 20350 end Is_Transfer; 20351 20352 ------------- 20353 -- Is_True -- 20354 ------------- 20355 20356 function Is_True (U : Uint) return Boolean is 20357 begin 20358 return U /= 0; 20359 end Is_True; 20360 20361 -------------------------------------- 20362 -- Is_Unchecked_Conversion_Instance -- 20363 -------------------------------------- 20364 20365 function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean is 20366 Par : Node_Id; 20367 20368 begin 20369 -- Look for a function whose generic parent is the predefined intrinsic 20370 -- function Unchecked_Conversion, or for one that renames such an 20371 -- instance. 20372 20373 if Ekind (Id) = E_Function then 20374 Par := Parent (Id); 20375 20376 if Nkind (Par) = N_Function_Specification then 20377 Par := Generic_Parent (Par); 20378 20379 if Present (Par) then 20380 return 20381 Chars (Par) = Name_Unchecked_Conversion 20382 and then Is_Intrinsic_Subprogram (Par) 20383 and then In_Predefined_Unit (Par); 20384 else 20385 return 20386 Present (Alias (Id)) 20387 and then Is_Unchecked_Conversion_Instance (Alias (Id)); 20388 end if; 20389 end if; 20390 end if; 20391 20392 return False; 20393 end Is_Unchecked_Conversion_Instance; 20394 20395 ------------------------------- 20396 -- Is_Universal_Numeric_Type -- 20397 ------------------------------- 20398 20399 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is 20400 begin 20401 return T = Universal_Integer or else T = Universal_Real; 20402 end Is_Universal_Numeric_Type; 20403 20404 ------------------------------ 20405 -- Is_User_Defined_Equality -- 20406 ------------------------------ 20407 20408 function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is 20409 begin 20410 return Ekind (Id) = E_Function 20411 and then Chars (Id) = Name_Op_Eq 20412 and then Comes_From_Source (Id) 20413 20414 -- Internally generated equalities have a full type declaration 20415 -- as their parent. 20416 20417 and then Nkind (Parent (Id)) = N_Function_Specification; 20418 end Is_User_Defined_Equality; 20419 20420 -------------------------------------- 20421 -- Is_Validation_Variable_Reference -- 20422 -------------------------------------- 20423 20424 function Is_Validation_Variable_Reference (N : Node_Id) return Boolean is 20425 Var : constant Node_Id := Unqual_Conv (N); 20426 Var_Id : Entity_Id; 20427 20428 begin 20429 Var_Id := Empty; 20430 20431 if Is_Entity_Name (Var) then 20432 Var_Id := Entity (Var); 20433 end if; 20434 20435 return 20436 Present (Var_Id) 20437 and then Ekind (Var_Id) = E_Variable 20438 and then Present (Validated_Object (Var_Id)); 20439 end Is_Validation_Variable_Reference; 20440 20441 ---------------------------- 20442 -- Is_Variable_Size_Array -- 20443 ---------------------------- 20444 20445 function Is_Variable_Size_Array (E : Entity_Id) return Boolean is 20446 Idx : Node_Id; 20447 20448 begin 20449 pragma Assert (Is_Array_Type (E)); 20450 20451 -- Check if some index is initialized with a non-constant value 20452 20453 Idx := First_Index (E); 20454 while Present (Idx) loop 20455 if Nkind (Idx) = N_Range then 20456 if not Is_Constant_Bound (Low_Bound (Idx)) 20457 or else not Is_Constant_Bound (High_Bound (Idx)) 20458 then 20459 return True; 20460 end if; 20461 end if; 20462 20463 Next_Index (Idx); 20464 end loop; 20465 20466 return False; 20467 end Is_Variable_Size_Array; 20468 20469 ----------------------------- 20470 -- Is_Variable_Size_Record -- 20471 ----------------------------- 20472 20473 function Is_Variable_Size_Record (E : Entity_Id) return Boolean is 20474 Comp : Entity_Id; 20475 Comp_Typ : Entity_Id; 20476 20477 begin 20478 pragma Assert (Is_Record_Type (E)); 20479 20480 Comp := First_Component (E); 20481 while Present (Comp) loop 20482 Comp_Typ := Underlying_Type (Etype (Comp)); 20483 20484 -- Recursive call if the record type has discriminants 20485 20486 if Is_Record_Type (Comp_Typ) 20487 and then Has_Discriminants (Comp_Typ) 20488 and then Is_Variable_Size_Record (Comp_Typ) 20489 then 20490 return True; 20491 20492 elsif Is_Array_Type (Comp_Typ) 20493 and then Is_Variable_Size_Array (Comp_Typ) 20494 then 20495 return True; 20496 end if; 20497 20498 Next_Component (Comp); 20499 end loop; 20500 20501 return False; 20502 end Is_Variable_Size_Record; 20503 20504 ----------------- 20505 -- Is_Variable -- 20506 ----------------- 20507 20508 function Is_Variable 20509 (N : Node_Id; 20510 Use_Original_Node : Boolean := True) return Boolean 20511 is 20512 Orig_Node : Node_Id; 20513 20514 function In_Protected_Function (E : Entity_Id) return Boolean; 20515 -- Within a protected function, the private components of the enclosing 20516 -- protected type are constants. A function nested within a (protected) 20517 -- procedure is not itself protected. Within the body of a protected 20518 -- function the current instance of the protected type is a constant. 20519 20520 function Is_Variable_Prefix (P : Node_Id) return Boolean; 20521 -- Prefixes can involve implicit dereferences, in which case we must 20522 -- test for the case of a reference of a constant access type, which can 20523 -- can never be a variable. 20524 20525 --------------------------- 20526 -- In_Protected_Function -- 20527 --------------------------- 20528 20529 function In_Protected_Function (E : Entity_Id) return Boolean is 20530 Prot : Entity_Id; 20531 S : Entity_Id; 20532 20533 begin 20534 -- E is the current instance of a type 20535 20536 if Is_Type (E) then 20537 Prot := E; 20538 20539 -- E is an object 20540 20541 else 20542 Prot := Scope (E); 20543 end if; 20544 20545 if not Is_Protected_Type (Prot) then 20546 return False; 20547 20548 else 20549 S := Current_Scope; 20550 while Present (S) and then S /= Prot loop 20551 if Ekind (S) = E_Function and then Scope (S) = Prot then 20552 return True; 20553 end if; 20554 20555 S := Scope (S); 20556 end loop; 20557 20558 return False; 20559 end if; 20560 end In_Protected_Function; 20561 20562 ------------------------ 20563 -- Is_Variable_Prefix -- 20564 ------------------------ 20565 20566 function Is_Variable_Prefix (P : Node_Id) return Boolean is 20567 begin 20568 if Is_Access_Type (Etype (P)) then 20569 return not Is_Access_Constant (Root_Type (Etype (P))); 20570 20571 -- For the case of an indexed component whose prefix has a packed 20572 -- array type, the prefix has been rewritten into a type conversion. 20573 -- Determine variable-ness from the converted expression. 20574 20575 elsif Nkind (P) = N_Type_Conversion 20576 and then not Comes_From_Source (P) 20577 and then Is_Packed_Array (Etype (P)) 20578 then 20579 return Is_Variable (Expression (P)); 20580 20581 else 20582 return Is_Variable (P); 20583 end if; 20584 end Is_Variable_Prefix; 20585 20586 -- Start of processing for Is_Variable 20587 20588 begin 20589 -- Special check, allow x'Deref(expr) as a variable 20590 20591 if Nkind (N) = N_Attribute_Reference 20592 and then Attribute_Name (N) = Name_Deref 20593 then 20594 return True; 20595 end if; 20596 20597 -- Check if we perform the test on the original node since this may be a 20598 -- test of syntactic categories which must not be disturbed by whatever 20599 -- rewriting might have occurred. For example, an aggregate, which is 20600 -- certainly NOT a variable, could be turned into a variable by 20601 -- expansion. 20602 20603 if Use_Original_Node then 20604 Orig_Node := Original_Node (N); 20605 else 20606 Orig_Node := N; 20607 end if; 20608 20609 -- Definitely OK if Assignment_OK is set. Since this is something that 20610 -- only gets set for expanded nodes, the test is on N, not Orig_Node. 20611 20612 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then 20613 return True; 20614 20615 -- Normally we go to the original node, but there is one exception where 20616 -- we use the rewritten node, namely when it is an explicit dereference. 20617 -- The generated code may rewrite a prefix which is an access type with 20618 -- an explicit dereference. The dereference is a variable, even though 20619 -- the original node may not be (since it could be a constant of the 20620 -- access type). 20621 20622 -- In Ada 2005 we have a further case to consider: the prefix may be a 20623 -- function call given in prefix notation. The original node appears to 20624 -- be a selected component, but we need to examine the call. 20625 20626 elsif Nkind (N) = N_Explicit_Dereference 20627 and then Nkind (Orig_Node) /= N_Explicit_Dereference 20628 and then Present (Etype (Orig_Node)) 20629 and then Is_Access_Type (Etype (Orig_Node)) 20630 then 20631 -- Note that if the prefix is an explicit dereference that does not 20632 -- come from source, we must check for a rewritten function call in 20633 -- prefixed notation before other forms of rewriting, to prevent a 20634 -- compiler crash. 20635 20636 return 20637 (Nkind (Orig_Node) = N_Function_Call 20638 and then not Is_Access_Constant (Etype (Prefix (N)))) 20639 or else 20640 Is_Variable_Prefix (Original_Node (Prefix (N))); 20641 20642 -- Generalized indexing operations are rewritten as explicit 20643 -- dereferences, and it is only during resolution that we can 20644 -- check whether the context requires an access_to_variable type. 20645 20646 elsif Nkind (N) = N_Explicit_Dereference 20647 and then Present (Etype (Orig_Node)) 20648 and then Has_Implicit_Dereference (Etype (Orig_Node)) 20649 and then Ada_Version >= Ada_2012 20650 then 20651 return not Is_Access_Constant (Etype (Prefix (N))); 20652 20653 -- A function call is never a variable 20654 20655 elsif Nkind (N) = N_Function_Call then 20656 return False; 20657 20658 -- All remaining checks use the original node 20659 20660 elsif Is_Entity_Name (Orig_Node) 20661 and then Present (Entity (Orig_Node)) 20662 then 20663 declare 20664 E : constant Entity_Id := Entity (Orig_Node); 20665 K : constant Entity_Kind := Ekind (E); 20666 20667 begin 20668 if Is_Loop_Parameter (E) then 20669 return False; 20670 end if; 20671 20672 return (K = E_Variable 20673 and then Nkind (Parent (E)) /= N_Exception_Handler) 20674 or else (K = E_Component 20675 and then not In_Protected_Function (E)) 20676 or else K = E_Out_Parameter 20677 or else K = E_In_Out_Parameter 20678 or else K = E_Generic_In_Out_Parameter 20679 20680 -- Current instance of type. If this is a protected type, check 20681 -- we are not within the body of one of its protected functions. 20682 20683 or else (Is_Type (E) 20684 and then In_Open_Scopes (E) 20685 and then not In_Protected_Function (E)) 20686 20687 or else (Is_Incomplete_Or_Private_Type (E) 20688 and then In_Open_Scopes (Full_View (E))); 20689 end; 20690 20691 else 20692 case Nkind (Orig_Node) is 20693 when N_Indexed_Component 20694 | N_Slice 20695 => 20696 return Is_Variable_Prefix (Prefix (Orig_Node)); 20697 20698 when N_Selected_Component => 20699 return (Is_Variable (Selector_Name (Orig_Node)) 20700 and then Is_Variable_Prefix (Prefix (Orig_Node))) 20701 or else 20702 (Nkind (N) = N_Expanded_Name 20703 and then Scope (Entity (N)) = Entity (Prefix (N))); 20704 20705 -- For an explicit dereference, the type of the prefix cannot 20706 -- be an access to constant or an access to subprogram. 20707 20708 when N_Explicit_Dereference => 20709 declare 20710 Typ : constant Entity_Id := Etype (Prefix (Orig_Node)); 20711 begin 20712 return Is_Access_Type (Typ) 20713 and then not Is_Access_Constant (Root_Type (Typ)) 20714 and then Ekind (Typ) /= E_Access_Subprogram_Type; 20715 end; 20716 20717 -- The type conversion is the case where we do not deal with the 20718 -- context dependent special case of an actual parameter. Thus 20719 -- the type conversion is only considered a variable for the 20720 -- purposes of this routine if the target type is tagged. However, 20721 -- a type conversion is considered to be a variable if it does not 20722 -- come from source (this deals for example with the conversions 20723 -- of expressions to their actual subtypes). 20724 20725 when N_Type_Conversion => 20726 return Is_Variable (Expression (Orig_Node)) 20727 and then 20728 (not Comes_From_Source (Orig_Node) 20729 or else 20730 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node))) 20731 and then 20732 Is_Tagged_Type (Etype (Expression (Orig_Node))))); 20733 20734 -- GNAT allows an unchecked type conversion as a variable. This 20735 -- only affects the generation of internal expanded code, since 20736 -- calls to instantiations of Unchecked_Conversion are never 20737 -- considered variables (since they are function calls). 20738 20739 when N_Unchecked_Type_Conversion => 20740 return Is_Variable (Expression (Orig_Node)); 20741 20742 when others => 20743 return False; 20744 end case; 20745 end if; 20746 end Is_Variable; 20747 20748 ------------------------ 20749 -- Is_View_Conversion -- 20750 ------------------------ 20751 20752 function Is_View_Conversion (N : Node_Id) return Boolean is 20753 begin 20754 if Nkind (N) = N_Type_Conversion 20755 and then Nkind (Unqual_Conv (N)) in N_Has_Etype 20756 then 20757 if Is_Tagged_Type (Etype (N)) 20758 and then Is_Tagged_Type (Etype (Unqual_Conv (N))) 20759 then 20760 return True; 20761 20762 elsif Is_Actual_Parameter (N) 20763 and then (Is_Actual_Out_Parameter (N) 20764 or else Is_Actual_In_Out_Parameter (N)) 20765 then 20766 return True; 20767 end if; 20768 end if; 20769 20770 return False; 20771 end Is_View_Conversion; 20772 20773 --------------------------- 20774 -- Is_Visibly_Controlled -- 20775 --------------------------- 20776 20777 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is 20778 Root : constant Entity_Id := Root_Type (T); 20779 begin 20780 return Chars (Scope (Root)) = Name_Finalization 20781 and then Chars (Scope (Scope (Root))) = Name_Ada 20782 and then Scope (Scope (Scope (Root))) = Standard_Standard; 20783 end Is_Visibly_Controlled; 20784 20785 -------------------------------------- 20786 -- Is_Volatile_Full_Access_Object -- 20787 -------------------------------------- 20788 20789 function Is_Volatile_Full_Access_Object (N : Node_Id) return Boolean is 20790 function Is_VFA_Object_Entity (Id : Entity_Id) return Boolean; 20791 -- Determine whether arbitrary entity Id denotes an object that is 20792 -- Volatile_Full_Access. 20793 20794 ---------------------------- 20795 -- Is_VFA_Object_Entity -- 20796 ---------------------------- 20797 20798 function Is_VFA_Object_Entity (Id : Entity_Id) return Boolean is 20799 begin 20800 return 20801 Is_Object (Id) 20802 and then (Is_Volatile_Full_Access (Id) 20803 or else 20804 Is_Volatile_Full_Access (Etype (Id))); 20805 end Is_VFA_Object_Entity; 20806 20807 -- Start of processing for Is_Volatile_Full_Access_Object 20808 20809 begin 20810 if Is_Entity_Name (N) then 20811 return Is_VFA_Object_Entity (Entity (N)); 20812 20813 elsif Is_Volatile_Full_Access (Etype (N)) then 20814 return True; 20815 20816 elsif Nkind (N) = N_Selected_Component then 20817 return Is_Volatile_Full_Access (Entity (Selector_Name (N))); 20818 20819 else 20820 return False; 20821 end if; 20822 end Is_Volatile_Full_Access_Object; 20823 20824 -------------------------- 20825 -- Is_Volatile_Function -- 20826 -------------------------- 20827 20828 function Is_Volatile_Function (Func_Id : Entity_Id) return Boolean is 20829 begin 20830 pragma Assert (Ekind (Func_Id) in E_Function | E_Generic_Function); 20831 20832 -- A function declared within a protected type is volatile 20833 20834 if Is_Protected_Type (Scope (Func_Id)) then 20835 return True; 20836 20837 -- An instance of Ada.Unchecked_Conversion is a volatile function if 20838 -- either the source or the target are effectively volatile. 20839 20840 elsif Is_Unchecked_Conversion_Instance (Func_Id) 20841 and then Has_Effectively_Volatile_Profile (Func_Id) 20842 then 20843 return True; 20844 20845 -- Otherwise the function is treated as volatile if it is subject to 20846 -- enabled pragma Volatile_Function. 20847 20848 else 20849 return 20850 Is_Enabled_Pragma (Get_Pragma (Func_Id, Pragma_Volatile_Function)); 20851 end if; 20852 end Is_Volatile_Function; 20853 20854 ------------------------ 20855 -- Is_Volatile_Object -- 20856 ------------------------ 20857 20858 function Is_Volatile_Object (N : Node_Id) return Boolean is 20859 function Is_Volatile_Object_Entity (Id : Entity_Id) return Boolean; 20860 -- Determine whether arbitrary entity Id denotes an object that is 20861 -- Volatile. 20862 20863 function Prefix_Has_Volatile_Components (P : Node_Id) return Boolean; 20864 -- Determine whether prefix P has volatile components. This requires 20865 -- the presence of a Volatile_Components aspect/pragma or that P be 20866 -- itself a volatile object as per RM C.6(8). 20867 20868 --------------------------------- 20869 -- Is_Volatile_Object_Entity -- 20870 --------------------------------- 20871 20872 function Is_Volatile_Object_Entity (Id : Entity_Id) return Boolean is 20873 begin 20874 return 20875 Is_Object (Id) 20876 and then (Is_Volatile (Id) or else Is_Volatile (Etype (Id))); 20877 end Is_Volatile_Object_Entity; 20878 20879 ------------------------------------ 20880 -- Prefix_Has_Volatile_Components -- 20881 ------------------------------------ 20882 20883 function Prefix_Has_Volatile_Components (P : Node_Id) return Boolean is 20884 Typ : constant Entity_Id := Etype (P); 20885 20886 begin 20887 if Is_Access_Type (Typ) then 20888 declare 20889 Dtyp : constant Entity_Id := Designated_Type (Typ); 20890 20891 begin 20892 return Has_Volatile_Components (Dtyp) 20893 or else Is_Volatile (Dtyp); 20894 end; 20895 20896 elsif Has_Volatile_Components (Typ) then 20897 return True; 20898 20899 elsif Is_Entity_Name (P) 20900 and then Has_Volatile_Component (Entity (P)) 20901 then 20902 return True; 20903 20904 elsif Is_Volatile_Object (P) then 20905 return True; 20906 20907 else 20908 return False; 20909 end if; 20910 end Prefix_Has_Volatile_Components; 20911 20912 -- Start of processing for Is_Volatile_Object 20913 20914 begin 20915 if Is_Entity_Name (N) then 20916 return Is_Volatile_Object_Entity (Entity (N)); 20917 20918 elsif Is_Volatile (Etype (N)) then 20919 return True; 20920 20921 elsif Nkind (N) = N_Indexed_Component then 20922 return Prefix_Has_Volatile_Components (Prefix (N)); 20923 20924 elsif Nkind (N) = N_Selected_Component then 20925 return Prefix_Has_Volatile_Components (Prefix (N)) 20926 or else Is_Volatile (Entity (Selector_Name (N))); 20927 20928 else 20929 return False; 20930 end if; 20931 end Is_Volatile_Object; 20932 20933 ----------------------------- 20934 -- Iterate_Call_Parameters -- 20935 ----------------------------- 20936 20937 procedure Iterate_Call_Parameters (Call : Node_Id) is 20938 Actual : Node_Id := First_Actual (Call); 20939 Formal : Entity_Id := First_Formal (Get_Called_Entity (Call)); 20940 20941 begin 20942 while Present (Formal) and then Present (Actual) loop 20943 Handle_Parameter (Formal, Actual); 20944 20945 Next_Formal (Formal); 20946 Next_Actual (Actual); 20947 end loop; 20948 20949 pragma Assert (No (Formal)); 20950 pragma Assert (No (Actual)); 20951 end Iterate_Call_Parameters; 20952 20953 --------------------------- 20954 -- Itype_Has_Declaration -- 20955 --------------------------- 20956 20957 function Itype_Has_Declaration (Id : Entity_Id) return Boolean is 20958 begin 20959 pragma Assert (Is_Itype (Id)); 20960 return Present (Parent (Id)) 20961 and then Nkind (Parent (Id)) in 20962 N_Full_Type_Declaration | N_Subtype_Declaration 20963 and then Defining_Entity (Parent (Id)) = Id; 20964 end Itype_Has_Declaration; 20965 20966 ------------------------- 20967 -- Kill_Current_Values -- 20968 ------------------------- 20969 20970 procedure Kill_Current_Values 20971 (Ent : Entity_Id; 20972 Last_Assignment_Only : Boolean := False) 20973 is 20974 begin 20975 if Is_Assignable (Ent) then 20976 Set_Last_Assignment (Ent, Empty); 20977 end if; 20978 20979 if Is_Object (Ent) then 20980 if not Last_Assignment_Only then 20981 Kill_Checks (Ent); 20982 Set_Current_Value (Ent, Empty); 20983 20984 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags 20985 -- for a constant. Once the constant is elaborated, its value is 20986 -- not changed, therefore the associated flags that describe the 20987 -- value should not be modified either. 20988 20989 if Ekind (Ent) = E_Constant then 20990 null; 20991 20992 -- Non-constant entities 20993 20994 else 20995 if not Can_Never_Be_Null (Ent) then 20996 Set_Is_Known_Non_Null (Ent, False); 20997 end if; 20998 20999 Set_Is_Known_Null (Ent, False); 21000 21001 -- Reset the Is_Known_Valid flag unless the type is always 21002 -- valid. This does not apply to a loop parameter because its 21003 -- bounds are defined by the loop header and therefore always 21004 -- valid. 21005 21006 if not Is_Known_Valid (Etype (Ent)) 21007 and then Ekind (Ent) /= E_Loop_Parameter 21008 then 21009 Set_Is_Known_Valid (Ent, False); 21010 end if; 21011 end if; 21012 end if; 21013 end if; 21014 end Kill_Current_Values; 21015 21016 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is 21017 S : Entity_Id; 21018 21019 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id); 21020 -- Clear current value for entity E and all entities chained to E 21021 21022 ------------------------------------------ 21023 -- Kill_Current_Values_For_Entity_Chain -- 21024 ------------------------------------------ 21025 21026 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is 21027 Ent : Entity_Id; 21028 begin 21029 Ent := E; 21030 while Present (Ent) loop 21031 Kill_Current_Values (Ent, Last_Assignment_Only); 21032 Next_Entity (Ent); 21033 end loop; 21034 end Kill_Current_Values_For_Entity_Chain; 21035 21036 -- Start of processing for Kill_Current_Values 21037 21038 begin 21039 -- Kill all saved checks, a special case of killing saved values 21040 21041 if not Last_Assignment_Only then 21042 Kill_All_Checks; 21043 end if; 21044 21045 -- Loop through relevant scopes, which includes the current scope and 21046 -- any parent scopes if the current scope is a block or a package. 21047 21048 S := Current_Scope; 21049 Scope_Loop : loop 21050 21051 -- Clear current values of all entities in current scope 21052 21053 Kill_Current_Values_For_Entity_Chain (First_Entity (S)); 21054 21055 -- If scope is a package, also clear current values of all private 21056 -- entities in the scope. 21057 21058 if Is_Package_Or_Generic_Package (S) 21059 or else Is_Concurrent_Type (S) 21060 then 21061 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S)); 21062 end if; 21063 21064 -- If this is a not a subprogram, deal with parents 21065 21066 if not Is_Subprogram (S) then 21067 S := Scope (S); 21068 exit Scope_Loop when S = Standard_Standard; 21069 else 21070 exit Scope_Loop; 21071 end if; 21072 end loop Scope_Loop; 21073 end Kill_Current_Values; 21074 21075 -------------------------- 21076 -- Kill_Size_Check_Code -- 21077 -------------------------- 21078 21079 procedure Kill_Size_Check_Code (E : Entity_Id) is 21080 begin 21081 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 21082 and then Present (Size_Check_Code (E)) 21083 then 21084 Remove (Size_Check_Code (E)); 21085 Set_Size_Check_Code (E, Empty); 21086 end if; 21087 end Kill_Size_Check_Code; 21088 21089 -------------------- 21090 -- Known_Non_Null -- 21091 -------------------- 21092 21093 function Known_Non_Null (N : Node_Id) return Boolean is 21094 Status : constant Null_Status_Kind := Null_Status (N); 21095 21096 Id : Entity_Id; 21097 Op : Node_Kind; 21098 Val : Node_Id; 21099 21100 begin 21101 -- The expression yields a non-null value ignoring simple flow analysis 21102 21103 if Status = Is_Non_Null then 21104 return True; 21105 21106 -- Otherwise check whether N is a reference to an entity that appears 21107 -- within a conditional construct. 21108 21109 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 21110 21111 -- First check if we are in decisive conditional 21112 21113 Get_Current_Value_Condition (N, Op, Val); 21114 21115 if Known_Null (Val) then 21116 if Op = N_Op_Eq then 21117 return False; 21118 elsif Op = N_Op_Ne then 21119 return True; 21120 end if; 21121 end if; 21122 21123 -- If OK to do replacement, test Is_Known_Non_Null flag 21124 21125 Id := Entity (N); 21126 21127 if OK_To_Do_Constant_Replacement (Id) then 21128 return Is_Known_Non_Null (Id); 21129 end if; 21130 end if; 21131 21132 -- Otherwise it is not possible to determine whether N yields a non-null 21133 -- value. 21134 21135 return False; 21136 end Known_Non_Null; 21137 21138 ---------------- 21139 -- Known_Null -- 21140 ---------------- 21141 21142 function Known_Null (N : Node_Id) return Boolean is 21143 Status : constant Null_Status_Kind := Null_Status (N); 21144 21145 Id : Entity_Id; 21146 Op : Node_Kind; 21147 Val : Node_Id; 21148 21149 begin 21150 -- The expression yields a null value ignoring simple flow analysis 21151 21152 if Status = Is_Null then 21153 return True; 21154 21155 -- Otherwise check whether N is a reference to an entity that appears 21156 -- within a conditional construct. 21157 21158 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 21159 21160 -- First check if we are in decisive conditional 21161 21162 Get_Current_Value_Condition (N, Op, Val); 21163 21164 if Known_Null (Val) then 21165 if Op = N_Op_Eq then 21166 return True; 21167 elsif Op = N_Op_Ne then 21168 return False; 21169 end if; 21170 end if; 21171 21172 -- If OK to do replacement, test Is_Known_Null flag 21173 21174 Id := Entity (N); 21175 21176 if OK_To_Do_Constant_Replacement (Id) then 21177 return Is_Known_Null (Id); 21178 end if; 21179 end if; 21180 21181 -- Otherwise it is not possible to determine whether N yields a null 21182 -- value. 21183 21184 return False; 21185 end Known_Null; 21186 21187 -------------------------- 21188 -- Known_To_Be_Assigned -- 21189 -------------------------- 21190 21191 function Known_To_Be_Assigned (N : Node_Id) return Boolean is 21192 P : constant Node_Id := Parent (N); 21193 21194 begin 21195 case Nkind (P) is 21196 21197 -- Test left side of assignment 21198 21199 when N_Assignment_Statement => 21200 return N = Name (P); 21201 21202 -- Function call arguments are never lvalues 21203 21204 when N_Function_Call => 21205 return False; 21206 21207 -- Positional parameter for procedure or accept call 21208 21209 when N_Accept_Statement 21210 | N_Procedure_Call_Statement 21211 => 21212 declare 21213 Proc : Entity_Id; 21214 Form : Entity_Id; 21215 Act : Node_Id; 21216 21217 begin 21218 Proc := Get_Subprogram_Entity (P); 21219 21220 if No (Proc) then 21221 return False; 21222 end if; 21223 21224 -- If we are not a list member, something is strange, so 21225 -- be conservative and return False. 21226 21227 if not Is_List_Member (N) then 21228 return False; 21229 end if; 21230 21231 -- We are going to find the right formal by stepping forward 21232 -- through the formals, as we step backwards in the actuals. 21233 21234 Form := First_Formal (Proc); 21235 Act := N; 21236 loop 21237 -- If no formal, something is weird, so be conservative 21238 -- and return False. 21239 21240 if No (Form) then 21241 return False; 21242 end if; 21243 21244 Prev (Act); 21245 exit when No (Act); 21246 Next_Formal (Form); 21247 end loop; 21248 21249 return Ekind (Form) /= E_In_Parameter; 21250 end; 21251 21252 -- Named parameter for procedure or accept call 21253 21254 when N_Parameter_Association => 21255 declare 21256 Proc : Entity_Id; 21257 Form : Entity_Id; 21258 21259 begin 21260 Proc := Get_Subprogram_Entity (Parent (P)); 21261 21262 if No (Proc) then 21263 return False; 21264 end if; 21265 21266 -- Loop through formals to find the one that matches 21267 21268 Form := First_Formal (Proc); 21269 loop 21270 -- If no matching formal, that's peculiar, some kind of 21271 -- previous error, so return False to be conservative. 21272 -- Actually this also happens in legal code in the case 21273 -- where P is a parameter association for an Extra_Formal??? 21274 21275 if No (Form) then 21276 return False; 21277 end if; 21278 21279 -- Else test for match 21280 21281 if Chars (Form) = Chars (Selector_Name (P)) then 21282 return Ekind (Form) /= E_In_Parameter; 21283 end if; 21284 21285 Next_Formal (Form); 21286 end loop; 21287 end; 21288 21289 -- Test for appearing in a conversion that itself appears 21290 -- in an lvalue context, since this should be an lvalue. 21291 21292 when N_Type_Conversion => 21293 return Known_To_Be_Assigned (P); 21294 21295 -- All other references are definitely not known to be modifications 21296 21297 when others => 21298 return False; 21299 end case; 21300 end Known_To_Be_Assigned; 21301 21302 --------------------------- 21303 -- Last_Source_Statement -- 21304 --------------------------- 21305 21306 function Last_Source_Statement (HSS : Node_Id) return Node_Id is 21307 N : Node_Id; 21308 21309 begin 21310 N := Last (Statements (HSS)); 21311 while Present (N) loop 21312 exit when Comes_From_Source (N); 21313 Prev (N); 21314 end loop; 21315 21316 return N; 21317 end Last_Source_Statement; 21318 21319 ----------------------- 21320 -- Mark_Coextensions -- 21321 ----------------------- 21322 21323 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is 21324 Is_Dynamic : Boolean; 21325 -- Indicates whether the context causes nested coextensions to be 21326 -- dynamic or static 21327 21328 function Mark_Allocator (N : Node_Id) return Traverse_Result; 21329 -- Recognize an allocator node and label it as a dynamic coextension 21330 21331 -------------------- 21332 -- Mark_Allocator -- 21333 -------------------- 21334 21335 function Mark_Allocator (N : Node_Id) return Traverse_Result is 21336 begin 21337 if Nkind (N) = N_Allocator then 21338 if Is_Dynamic then 21339 Set_Is_Static_Coextension (N, False); 21340 Set_Is_Dynamic_Coextension (N); 21341 21342 -- If the allocator expression is potentially dynamic, it may 21343 -- be expanded out of order and require dynamic allocation 21344 -- anyway, so we treat the coextension itself as dynamic. 21345 -- Potential optimization ??? 21346 21347 elsif Nkind (Expression (N)) = N_Qualified_Expression 21348 and then Nkind (Expression (Expression (N))) = N_Op_Concat 21349 then 21350 Set_Is_Static_Coextension (N, False); 21351 Set_Is_Dynamic_Coextension (N); 21352 else 21353 Set_Is_Dynamic_Coextension (N, False); 21354 Set_Is_Static_Coextension (N); 21355 end if; 21356 end if; 21357 21358 return OK; 21359 end Mark_Allocator; 21360 21361 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator); 21362 21363 -- Start of processing for Mark_Coextensions 21364 21365 begin 21366 -- An allocator that appears on the right-hand side of an assignment is 21367 -- treated as a potentially dynamic coextension when the right-hand side 21368 -- is an allocator or a qualified expression. 21369 21370 -- Obj := new ...'(new Coextension ...); 21371 21372 if Nkind (Context_Nod) = N_Assignment_Statement then 21373 Is_Dynamic := Nkind (Expression (Context_Nod)) in 21374 N_Allocator | N_Qualified_Expression; 21375 21376 -- An allocator that appears within the expression of a simple return 21377 -- statement is treated as a potentially dynamic coextension when the 21378 -- expression is either aggregate, allocator, or qualified expression. 21379 21380 -- return (new Coextension ...); 21381 -- return new ...'(new Coextension ...); 21382 21383 elsif Nkind (Context_Nod) = N_Simple_Return_Statement then 21384 Is_Dynamic := Nkind (Expression (Context_Nod)) in 21385 N_Aggregate | N_Allocator | N_Qualified_Expression; 21386 21387 -- An alloctor that appears within the initialization expression of an 21388 -- object declaration is considered a potentially dynamic coextension 21389 -- when the initialization expression is an allocator or a qualified 21390 -- expression. 21391 21392 -- Obj : ... := new ...'(new Coextension ...); 21393 21394 -- A similar case arises when the object declaration is part of an 21395 -- extended return statement. 21396 21397 -- return Obj : ... := new ...'(new Coextension ...); 21398 -- return Obj : ... := (new Coextension ...); 21399 21400 elsif Nkind (Context_Nod) = N_Object_Declaration then 21401 Is_Dynamic := Nkind (Root_Nod) in N_Allocator | N_Qualified_Expression 21402 or else Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement; 21403 21404 -- This routine should not be called with constructs that cannot contain 21405 -- coextensions. 21406 21407 else 21408 raise Program_Error; 21409 end if; 21410 21411 Mark_Allocators (Root_Nod); 21412 end Mark_Coextensions; 21413 21414 --------------------------------- 21415 -- Mark_Elaboration_Attributes -- 21416 --------------------------------- 21417 21418 procedure Mark_Elaboration_Attributes 21419 (N_Id : Node_Or_Entity_Id; 21420 Checks : Boolean := False; 21421 Level : Boolean := False; 21422 Modes : Boolean := False; 21423 Warnings : Boolean := False) 21424 is 21425 function Elaboration_Checks_OK 21426 (Target_Id : Entity_Id; 21427 Context_Id : Entity_Id) return Boolean; 21428 -- Determine whether elaboration checks are enabled for target Target_Id 21429 -- which resides within context Context_Id. 21430 21431 procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id); 21432 -- Preserve relevant attributes of the context in arbitrary entity Id 21433 21434 procedure Mark_Elaboration_Attributes_Node (N : Node_Id); 21435 -- Preserve relevant attributes of the context in arbitrary node N 21436 21437 --------------------------- 21438 -- Elaboration_Checks_OK -- 21439 --------------------------- 21440 21441 function Elaboration_Checks_OK 21442 (Target_Id : Entity_Id; 21443 Context_Id : Entity_Id) return Boolean 21444 is 21445 Encl_Scop : Entity_Id; 21446 21447 begin 21448 -- Elaboration checks are suppressed for the target 21449 21450 if Elaboration_Checks_Suppressed (Target_Id) then 21451 return False; 21452 end if; 21453 21454 -- Otherwise elaboration checks are OK for the target, but may be 21455 -- suppressed for the context where the target is declared. 21456 21457 Encl_Scop := Context_Id; 21458 while Present (Encl_Scop) and then Encl_Scop /= Standard_Standard loop 21459 if Elaboration_Checks_Suppressed (Encl_Scop) then 21460 return False; 21461 end if; 21462 21463 Encl_Scop := Scope (Encl_Scop); 21464 end loop; 21465 21466 -- Neither the target nor its declarative context have elaboration 21467 -- checks suppressed. 21468 21469 return True; 21470 end Elaboration_Checks_OK; 21471 21472 ------------------------------------ 21473 -- Mark_Elaboration_Attributes_Id -- 21474 ------------------------------------ 21475 21476 procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id) is 21477 begin 21478 -- Mark the status of elaboration checks in effect. Do not reset the 21479 -- status in case the entity is reanalyzed with checks suppressed. 21480 21481 if Checks and then not Is_Elaboration_Checks_OK_Id (Id) then 21482 Set_Is_Elaboration_Checks_OK_Id (Id, 21483 Elaboration_Checks_OK 21484 (Target_Id => Id, 21485 Context_Id => Scope (Id))); 21486 end if; 21487 21488 -- Mark the status of elaboration warnings in effect. Do not reset 21489 -- the status in case the entity is reanalyzed with warnings off. 21490 21491 if Warnings and then not Is_Elaboration_Warnings_OK_Id (Id) then 21492 Set_Is_Elaboration_Warnings_OK_Id (Id, Elab_Warnings); 21493 end if; 21494 end Mark_Elaboration_Attributes_Id; 21495 21496 -------------------------------------- 21497 -- Mark_Elaboration_Attributes_Node -- 21498 -------------------------------------- 21499 21500 procedure Mark_Elaboration_Attributes_Node (N : Node_Id) is 21501 function Extract_Name (N : Node_Id) return Node_Id; 21502 -- Obtain the Name attribute of call or instantiation N 21503 21504 ------------------ 21505 -- Extract_Name -- 21506 ------------------ 21507 21508 function Extract_Name (N : Node_Id) return Node_Id is 21509 Nam : Node_Id; 21510 21511 begin 21512 Nam := Name (N); 21513 21514 -- A call to an entry family appears in indexed form 21515 21516 if Nkind (Nam) = N_Indexed_Component then 21517 Nam := Prefix (Nam); 21518 end if; 21519 21520 -- The name may also appear in qualified form 21521 21522 if Nkind (Nam) = N_Selected_Component then 21523 Nam := Selector_Name (Nam); 21524 end if; 21525 21526 return Nam; 21527 end Extract_Name; 21528 21529 -- Local variables 21530 21531 Context_Id : Entity_Id; 21532 Nam : Node_Id; 21533 21534 -- Start of processing for Mark_Elaboration_Attributes_Node 21535 21536 begin 21537 -- Mark the status of elaboration checks in effect. Do not reset the 21538 -- status in case the node is reanalyzed with checks suppressed. 21539 21540 if Checks and then not Is_Elaboration_Checks_OK_Node (N) then 21541 21542 -- Assignments, attribute references, and variable references do 21543 -- not have a "declarative" context. 21544 21545 Context_Id := Empty; 21546 21547 -- The status of elaboration checks for calls and instantiations 21548 -- depends on the most recent pragma Suppress/Unsuppress, as well 21549 -- as the suppression status of the context where the target is 21550 -- defined. 21551 21552 -- package Pack is 21553 -- function Func ...; 21554 -- end Pack; 21555 21556 -- with Pack; 21557 -- procedure Main is 21558 -- pragma Suppress (Elaboration_Checks, Pack); 21559 -- X : ... := Pack.Func; 21560 -- ... 21561 21562 -- In the example above, the call to Func has elaboration checks 21563 -- enabled because there is no active general purpose suppression 21564 -- pragma, however the elaboration checks of Pack are explicitly 21565 -- suppressed. As a result the elaboration checks of the call must 21566 -- be disabled in order to preserve this dependency. 21567 21568 if Nkind (N) in N_Entry_Call_Statement 21569 | N_Function_Call 21570 | N_Function_Instantiation 21571 | N_Package_Instantiation 21572 | N_Procedure_Call_Statement 21573 | N_Procedure_Instantiation 21574 then 21575 Nam := Extract_Name (N); 21576 21577 if Is_Entity_Name (Nam) and then Present (Entity (Nam)) then 21578 Context_Id := Scope (Entity (Nam)); 21579 end if; 21580 end if; 21581 21582 Set_Is_Elaboration_Checks_OK_Node (N, 21583 Elaboration_Checks_OK 21584 (Target_Id => Empty, 21585 Context_Id => Context_Id)); 21586 end if; 21587 21588 -- Mark the enclosing level of the node. Do not reset the status in 21589 -- case the node is relocated and reanalyzed. 21590 21591 if Level and then not Is_Declaration_Level_Node (N) then 21592 Set_Is_Declaration_Level_Node (N, 21593 Find_Enclosing_Level (N) = Declaration_Level); 21594 end if; 21595 21596 -- Mark the Ghost and SPARK mode in effect 21597 21598 if Modes then 21599 if Ghost_Mode = Ignore then 21600 Set_Is_Ignored_Ghost_Node (N); 21601 end if; 21602 21603 if SPARK_Mode = On then 21604 Set_Is_SPARK_Mode_On_Node (N); 21605 end if; 21606 end if; 21607 21608 -- Mark the status of elaboration warnings in effect. Do not reset 21609 -- the status in case the node is reanalyzed with warnings off. 21610 21611 if Warnings and then not Is_Elaboration_Warnings_OK_Node (N) then 21612 Set_Is_Elaboration_Warnings_OK_Node (N, Elab_Warnings); 21613 end if; 21614 end Mark_Elaboration_Attributes_Node; 21615 21616 -- Start of processing for Mark_Elaboration_Attributes 21617 21618 begin 21619 -- Do not capture any elaboration-related attributes when switch -gnatH 21620 -- (legacy elaboration checking mode enabled) is in effect because the 21621 -- attributes are useless to the legacy model. 21622 21623 if Legacy_Elaboration_Checks then 21624 return; 21625 end if; 21626 21627 if Nkind (N_Id) in N_Entity then 21628 Mark_Elaboration_Attributes_Id (N_Id); 21629 else 21630 Mark_Elaboration_Attributes_Node (N_Id); 21631 end if; 21632 end Mark_Elaboration_Attributes; 21633 21634 ---------------------------------------- 21635 -- Mark_Save_Invocation_Graph_Of_Body -- 21636 ---------------------------------------- 21637 21638 procedure Mark_Save_Invocation_Graph_Of_Body is 21639 Main : constant Node_Id := Cunit (Main_Unit); 21640 Main_Unit : constant Node_Id := Unit (Main); 21641 Aux_Id : Entity_Id; 21642 21643 begin 21644 Set_Save_Invocation_Graph_Of_Body (Main); 21645 21646 -- Assume that the main unit does not have a complimentary unit 21647 21648 Aux_Id := Empty; 21649 21650 -- Obtain the complimentary unit of the main unit 21651 21652 if Nkind (Main_Unit) in N_Generic_Package_Declaration 21653 | N_Generic_Subprogram_Declaration 21654 | N_Package_Declaration 21655 | N_Subprogram_Declaration 21656 then 21657 Aux_Id := Corresponding_Body (Main_Unit); 21658 21659 elsif Nkind (Main_Unit) in N_Package_Body 21660 | N_Subprogram_Body 21661 | N_Subprogram_Renaming_Declaration 21662 then 21663 Aux_Id := Corresponding_Spec (Main_Unit); 21664 end if; 21665 21666 if Present (Aux_Id) then 21667 Set_Save_Invocation_Graph_Of_Body 21668 (Parent (Unit_Declaration_Node (Aux_Id))); 21669 end if; 21670 end Mark_Save_Invocation_Graph_Of_Body; 21671 21672 ---------------------------------- 21673 -- Matching_Static_Array_Bounds -- 21674 ---------------------------------- 21675 21676 function Matching_Static_Array_Bounds 21677 (L_Typ : Node_Id; 21678 R_Typ : Node_Id) return Boolean 21679 is 21680 L_Ndims : constant Nat := Number_Dimensions (L_Typ); 21681 R_Ndims : constant Nat := Number_Dimensions (R_Typ); 21682 21683 L_Index : Node_Id := Empty; -- init to ... 21684 R_Index : Node_Id := Empty; -- ...avoid warnings 21685 L_Low : Node_Id; 21686 L_High : Node_Id; 21687 L_Len : Uint; 21688 R_Low : Node_Id; 21689 R_High : Node_Id; 21690 R_Len : Uint; 21691 21692 begin 21693 if L_Ndims /= R_Ndims then 21694 return False; 21695 end if; 21696 21697 -- Unconstrained types do not have static bounds 21698 21699 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then 21700 return False; 21701 end if; 21702 21703 -- First treat specially the first dimension, as the lower bound and 21704 -- length of string literals are not stored like those of arrays. 21705 21706 if Ekind (L_Typ) = E_String_Literal_Subtype then 21707 L_Low := String_Literal_Low_Bound (L_Typ); 21708 L_Len := String_Literal_Length (L_Typ); 21709 else 21710 L_Index := First_Index (L_Typ); 21711 Get_Index_Bounds (L_Index, L_Low, L_High); 21712 21713 if Is_OK_Static_Expression (L_Low) 21714 and then 21715 Is_OK_Static_Expression (L_High) 21716 then 21717 if Expr_Value (L_High) < Expr_Value (L_Low) then 21718 L_Len := Uint_0; 21719 else 21720 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1; 21721 end if; 21722 else 21723 return False; 21724 end if; 21725 end if; 21726 21727 if Ekind (R_Typ) = E_String_Literal_Subtype then 21728 R_Low := String_Literal_Low_Bound (R_Typ); 21729 R_Len := String_Literal_Length (R_Typ); 21730 else 21731 R_Index := First_Index (R_Typ); 21732 Get_Index_Bounds (R_Index, R_Low, R_High); 21733 21734 if Is_OK_Static_Expression (R_Low) 21735 and then 21736 Is_OK_Static_Expression (R_High) 21737 then 21738 if Expr_Value (R_High) < Expr_Value (R_Low) then 21739 R_Len := Uint_0; 21740 else 21741 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1; 21742 end if; 21743 else 21744 return False; 21745 end if; 21746 end if; 21747 21748 if (Is_OK_Static_Expression (L_Low) 21749 and then 21750 Is_OK_Static_Expression (R_Low)) 21751 and then Expr_Value (L_Low) = Expr_Value (R_Low) 21752 and then L_Len = R_Len 21753 then 21754 null; 21755 else 21756 return False; 21757 end if; 21758 21759 -- Then treat all other dimensions 21760 21761 for Indx in 2 .. L_Ndims loop 21762 Next (L_Index); 21763 Next (R_Index); 21764 21765 Get_Index_Bounds (L_Index, L_Low, L_High); 21766 Get_Index_Bounds (R_Index, R_Low, R_High); 21767 21768 if (Is_OK_Static_Expression (L_Low) and then 21769 Is_OK_Static_Expression (L_High) and then 21770 Is_OK_Static_Expression (R_Low) and then 21771 Is_OK_Static_Expression (R_High)) 21772 and then (Expr_Value (L_Low) = Expr_Value (R_Low) 21773 and then 21774 Expr_Value (L_High) = Expr_Value (R_High)) 21775 then 21776 null; 21777 else 21778 return False; 21779 end if; 21780 end loop; 21781 21782 -- If we fall through the loop, all indexes matched 21783 21784 return True; 21785 end Matching_Static_Array_Bounds; 21786 21787 ------------------- 21788 -- May_Be_Lvalue -- 21789 ------------------- 21790 21791 function May_Be_Lvalue (N : Node_Id) return Boolean is 21792 P : constant Node_Id := Parent (N); 21793 21794 begin 21795 case Nkind (P) is 21796 21797 -- Test left side of assignment 21798 21799 when N_Assignment_Statement => 21800 return N = Name (P); 21801 21802 -- Test prefix of component or attribute. Note that the prefix of an 21803 -- explicit or implicit dereference cannot be an l-value. In the case 21804 -- of a 'Read attribute, the reference can be an actual in the 21805 -- argument list of the attribute. 21806 21807 when N_Attribute_Reference => 21808 return (N = Prefix (P) 21809 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P))) 21810 or else 21811 Attribute_Name (P) = Name_Read; 21812 21813 -- For an expanded name, the name is an lvalue if the expanded name 21814 -- is an lvalue, but the prefix is never an lvalue, since it is just 21815 -- the scope where the name is found. 21816 21817 when N_Expanded_Name => 21818 if N = Prefix (P) then 21819 return May_Be_Lvalue (P); 21820 else 21821 return False; 21822 end if; 21823 21824 -- For a selected component A.B, A is certainly an lvalue if A.B is. 21825 -- B is a little interesting, if we have A.B := 3, there is some 21826 -- discussion as to whether B is an lvalue or not, we choose to say 21827 -- it is. Note however that A is not an lvalue if it is of an access 21828 -- type since this is an implicit dereference. 21829 21830 when N_Selected_Component => 21831 if N = Prefix (P) 21832 and then Present (Etype (N)) 21833 and then Is_Access_Type (Etype (N)) 21834 then 21835 return False; 21836 else 21837 return May_Be_Lvalue (P); 21838 end if; 21839 21840 -- For an indexed component or slice, the index or slice bounds is 21841 -- never an lvalue. The prefix is an lvalue if the indexed component 21842 -- or slice is an lvalue, except if it is an access type, where we 21843 -- have an implicit dereference. 21844 21845 when N_Indexed_Component 21846 | N_Slice 21847 => 21848 if N /= Prefix (P) 21849 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N))) 21850 then 21851 return False; 21852 else 21853 return May_Be_Lvalue (P); 21854 end if; 21855 21856 -- Prefix of a reference is an lvalue if the reference is an lvalue 21857 21858 when N_Reference => 21859 return May_Be_Lvalue (P); 21860 21861 -- Prefix of explicit dereference is never an lvalue 21862 21863 when N_Explicit_Dereference => 21864 return False; 21865 21866 -- Positional parameter for subprogram, entry, or accept call. 21867 -- In older versions of Ada function call arguments are never 21868 -- lvalues. In Ada 2012 functions can have in-out parameters. 21869 21870 when N_Accept_Statement 21871 | N_Entry_Call_Statement 21872 | N_Subprogram_Call 21873 => 21874 if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then 21875 return False; 21876 end if; 21877 21878 -- The following mechanism is clumsy and fragile. A single flag 21879 -- set in Resolve_Actuals would be preferable ??? 21880 21881 declare 21882 Proc : Entity_Id; 21883 Form : Entity_Id; 21884 Act : Node_Id; 21885 21886 begin 21887 Proc := Get_Subprogram_Entity (P); 21888 21889 if No (Proc) then 21890 return True; 21891 end if; 21892 21893 -- If we are not a list member, something is strange, so be 21894 -- conservative and return True. 21895 21896 if not Is_List_Member (N) then 21897 return True; 21898 end if; 21899 21900 -- We are going to find the right formal by stepping forward 21901 -- through the formals, as we step backwards in the actuals. 21902 21903 Form := First_Formal (Proc); 21904 Act := N; 21905 loop 21906 -- If no formal, something is weird, so be conservative and 21907 -- return True. 21908 21909 if No (Form) then 21910 return True; 21911 end if; 21912 21913 Prev (Act); 21914 exit when No (Act); 21915 Next_Formal (Form); 21916 end loop; 21917 21918 return Ekind (Form) /= E_In_Parameter; 21919 end; 21920 21921 -- Named parameter for procedure or accept call 21922 21923 when N_Parameter_Association => 21924 declare 21925 Proc : Entity_Id; 21926 Form : Entity_Id; 21927 21928 begin 21929 Proc := Get_Subprogram_Entity (Parent (P)); 21930 21931 if No (Proc) then 21932 return True; 21933 end if; 21934 21935 -- Loop through formals to find the one that matches 21936 21937 Form := First_Formal (Proc); 21938 loop 21939 -- If no matching formal, that's peculiar, some kind of 21940 -- previous error, so return True to be conservative. 21941 -- Actually happens with legal code for an unresolved call 21942 -- where we may get the wrong homonym??? 21943 21944 if No (Form) then 21945 return True; 21946 end if; 21947 21948 -- Else test for match 21949 21950 if Chars (Form) = Chars (Selector_Name (P)) then 21951 return Ekind (Form) /= E_In_Parameter; 21952 end if; 21953 21954 Next_Formal (Form); 21955 end loop; 21956 end; 21957 21958 -- Test for appearing in a conversion that itself appears in an 21959 -- lvalue context, since this should be an lvalue. 21960 21961 when N_Type_Conversion => 21962 return May_Be_Lvalue (P); 21963 21964 -- Test for appearance in object renaming declaration 21965 21966 when N_Object_Renaming_Declaration => 21967 return True; 21968 21969 -- All other references are definitely not lvalues 21970 21971 when others => 21972 return False; 21973 end case; 21974 end May_Be_Lvalue; 21975 21976 ----------------- 21977 -- Might_Raise -- 21978 ----------------- 21979 21980 function Might_Raise (N : Node_Id) return Boolean is 21981 Result : Boolean := False; 21982 21983 function Process (N : Node_Id) return Traverse_Result; 21984 -- Set Result to True if we find something that could raise an exception 21985 21986 ------------- 21987 -- Process -- 21988 ------------- 21989 21990 function Process (N : Node_Id) return Traverse_Result is 21991 begin 21992 if Nkind (N) in N_Procedure_Call_Statement 21993 | N_Function_Call 21994 | N_Raise_Statement 21995 | N_Raise_xxx_Error 21996 then 21997 Result := True; 21998 return Abandon; 21999 else 22000 return OK; 22001 end if; 22002 end Process; 22003 22004 procedure Set_Result is new Traverse_Proc (Process); 22005 22006 -- Start of processing for Might_Raise 22007 22008 begin 22009 -- False if exceptions can't be propagated 22010 22011 if No_Exception_Handlers_Set then 22012 return False; 22013 end if; 22014 22015 -- If the checks handled by the back end are not disabled, we cannot 22016 -- ensure that no exception will be raised. 22017 22018 if not Access_Checks_Suppressed (Empty) 22019 or else not Discriminant_Checks_Suppressed (Empty) 22020 or else not Range_Checks_Suppressed (Empty) 22021 or else not Index_Checks_Suppressed (Empty) 22022 or else Opt.Stack_Checking_Enabled 22023 then 22024 return True; 22025 end if; 22026 22027 Set_Result (N); 22028 return Result; 22029 end Might_Raise; 22030 22031 -------------------------------- 22032 -- Nearest_Enclosing_Instance -- 22033 -------------------------------- 22034 22035 function Nearest_Enclosing_Instance (E : Entity_Id) return Entity_Id is 22036 Inst : Entity_Id; 22037 22038 begin 22039 Inst := Scope (E); 22040 while Present (Inst) and then Inst /= Standard_Standard loop 22041 if Is_Generic_Instance (Inst) then 22042 return Inst; 22043 end if; 22044 22045 Inst := Scope (Inst); 22046 end loop; 22047 22048 return Empty; 22049 end Nearest_Enclosing_Instance; 22050 22051 ------------------------ 22052 -- Needs_Finalization -- 22053 ------------------------ 22054 22055 function Needs_Finalization (Typ : Entity_Id) return Boolean is 22056 function Has_Some_Controlled_Component 22057 (Input_Typ : Entity_Id) return Boolean; 22058 -- Determine whether type Input_Typ has at least one controlled 22059 -- component. 22060 22061 ----------------------------------- 22062 -- Has_Some_Controlled_Component -- 22063 ----------------------------------- 22064 22065 function Has_Some_Controlled_Component 22066 (Input_Typ : Entity_Id) return Boolean 22067 is 22068 Comp : Entity_Id; 22069 22070 begin 22071 -- When a type is already frozen and has at least one controlled 22072 -- component, or is manually decorated, it is sufficient to inspect 22073 -- flag Has_Controlled_Component. 22074 22075 if Has_Controlled_Component (Input_Typ) then 22076 return True; 22077 22078 -- Otherwise inspect the internals of the type 22079 22080 elsif not Is_Frozen (Input_Typ) then 22081 if Is_Array_Type (Input_Typ) then 22082 return Needs_Finalization (Component_Type (Input_Typ)); 22083 22084 elsif Is_Record_Type (Input_Typ) then 22085 Comp := First_Component (Input_Typ); 22086 while Present (Comp) loop 22087 if Needs_Finalization (Etype (Comp)) then 22088 return True; 22089 end if; 22090 22091 Next_Component (Comp); 22092 end loop; 22093 end if; 22094 end if; 22095 22096 return False; 22097 end Has_Some_Controlled_Component; 22098 22099 -- Start of processing for Needs_Finalization 22100 22101 begin 22102 -- Certain run-time configurations and targets do not provide support 22103 -- for controlled types. 22104 22105 if Restriction_Active (No_Finalization) then 22106 return False; 22107 22108 -- C++ types are not considered controlled. It is assumed that the non- 22109 -- Ada side will handle their clean up. 22110 22111 elsif Convention (Typ) = Convention_CPP then 22112 return False; 22113 22114 -- Class-wide types are treated as controlled because derivations from 22115 -- the root type may introduce controlled components. 22116 22117 elsif Is_Class_Wide_Type (Typ) then 22118 return True; 22119 22120 -- Concurrent types are controlled as long as their corresponding record 22121 -- is controlled. 22122 22123 elsif Is_Concurrent_Type (Typ) 22124 and then Present (Corresponding_Record_Type (Typ)) 22125 and then Needs_Finalization (Corresponding_Record_Type (Typ)) 22126 then 22127 return True; 22128 22129 -- Otherwise the type is controlled when it is either derived from type 22130 -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or 22131 -- contains at least one controlled component. 22132 22133 else 22134 return 22135 Is_Controlled (Typ) or else Has_Some_Controlled_Component (Typ); 22136 end if; 22137 end Needs_Finalization; 22138 22139 ---------------------- 22140 -- Needs_One_Actual -- 22141 ---------------------- 22142 22143 function Needs_One_Actual (E : Entity_Id) return Boolean is 22144 Formal : Entity_Id; 22145 22146 begin 22147 -- Ada 2005 or later, and formals present. The first formal must be 22148 -- of a type that supports prefix notation: a controlling argument, 22149 -- a class-wide type, or an access to such. 22150 22151 if Ada_Version >= Ada_2005 22152 and then Present (First_Formal (E)) 22153 and then No (Default_Value (First_Formal (E))) 22154 and then 22155 (Is_Controlling_Formal (First_Formal (E)) 22156 or else Is_Class_Wide_Type (Etype (First_Formal (E))) 22157 or else Is_Anonymous_Access_Type (Etype (First_Formal (E)))) 22158 then 22159 Formal := Next_Formal (First_Formal (E)); 22160 while Present (Formal) loop 22161 if No (Default_Value (Formal)) then 22162 return False; 22163 end if; 22164 22165 Next_Formal (Formal); 22166 end loop; 22167 22168 return True; 22169 22170 -- Ada 83/95 or no formals 22171 22172 else 22173 return False; 22174 end if; 22175 end Needs_One_Actual; 22176 22177 -------------------------------------- 22178 -- Needs_Result_Accessibility_Level -- 22179 -------------------------------------- 22180 22181 function Needs_Result_Accessibility_Level 22182 (Func_Id : Entity_Id) return Boolean 22183 is 22184 Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); 22185 22186 function Has_Unconstrained_Access_Discriminant_Component 22187 (Comp_Typ : Entity_Id) return Boolean; 22188 -- Returns True if any component of the type has an unconstrained access 22189 -- discriminant. 22190 22191 ----------------------------------------------------- 22192 -- Has_Unconstrained_Access_Discriminant_Component -- 22193 ----------------------------------------------------- 22194 22195 function Has_Unconstrained_Access_Discriminant_Component 22196 (Comp_Typ : Entity_Id) return Boolean 22197 is 22198 begin 22199 if not Is_Limited_Type (Comp_Typ) then 22200 return False; 22201 22202 -- Only limited types can have access discriminants with 22203 -- defaults. 22204 22205 elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then 22206 return True; 22207 22208 elsif Is_Array_Type (Comp_Typ) then 22209 return Has_Unconstrained_Access_Discriminant_Component 22210 (Underlying_Type (Component_Type (Comp_Typ))); 22211 22212 elsif Is_Record_Type (Comp_Typ) then 22213 declare 22214 Comp : Entity_Id; 22215 22216 begin 22217 Comp := First_Component (Comp_Typ); 22218 while Present (Comp) loop 22219 if Has_Unconstrained_Access_Discriminant_Component 22220 (Underlying_Type (Etype (Comp))) 22221 then 22222 return True; 22223 end if; 22224 22225 Next_Component (Comp); 22226 end loop; 22227 end; 22228 end if; 22229 22230 return False; 22231 end Has_Unconstrained_Access_Discriminant_Component; 22232 22233 Disable_Coextension_Cases : constant Boolean := True; 22234 -- Flag used to temporarily disable a "True" result for types with 22235 -- access discriminants and related coextension cases. 22236 22237 -- Start of processing for Needs_Result_Accessibility_Level 22238 22239 begin 22240 -- False if completion unavailable (how does this happen???) 22241 22242 if not Present (Func_Typ) then 22243 return False; 22244 22245 -- False if not a function, also handle enum-lit renames case 22246 22247 elsif Func_Typ = Standard_Void_Type 22248 or else Is_Scalar_Type (Func_Typ) 22249 then 22250 return False; 22251 22252 -- Handle a corner case, a cross-dialect subp renaming. For example, 22253 -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when 22254 -- an Ada 2005 (or earlier) unit references predefined run-time units. 22255 22256 elsif Present (Alias (Func_Id)) then 22257 22258 -- Unimplemented: a cross-dialect subp renaming which does not set 22259 -- the Alias attribute (e.g., a rename of a dereference of an access 22260 -- to subprogram value). ??? 22261 22262 return Present (Extra_Accessibility_Of_Result (Alias (Func_Id))); 22263 22264 -- Remaining cases require Ada 2012 mode 22265 22266 elsif Ada_Version < Ada_2012 then 22267 return False; 22268 22269 -- Handle the situation where a result is an anonymous access type 22270 -- RM 3.10.2 (10.3/3). 22271 22272 elsif Ekind (Func_Typ) = E_Anonymous_Access_Type then 22273 return True; 22274 22275 -- The following cases are related to coextensions and do not fully 22276 -- cover everything mentioned in RM 3.10.2 (12) ??? 22277 22278 -- Temporarily disabled ??? 22279 22280 elsif Disable_Coextension_Cases then 22281 return False; 22282 22283 -- In the case of, say, a null tagged record result type, the need for 22284 -- this extra parameter might not be obvious so this function returns 22285 -- True for all tagged types for compatibility reasons. 22286 22287 -- A function with, say, a tagged null controlling result type might 22288 -- be overridden by a primitive of an extension having an access 22289 -- discriminant and the overrider and overridden must have compatible 22290 -- calling conventions (including implicitly declared parameters). 22291 22292 -- Similarly, values of one access-to-subprogram type might designate 22293 -- both a primitive subprogram of a given type and a function which is, 22294 -- for example, not a primitive subprogram of any type. Again, this 22295 -- requires calling convention compatibility. It might be possible to 22296 -- solve these issues by introducing wrappers, but that is not the 22297 -- approach that was chosen. 22298 22299 elsif Is_Tagged_Type (Func_Typ) then 22300 return True; 22301 22302 elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then 22303 return True; 22304 22305 elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then 22306 return True; 22307 22308 -- False for all other cases 22309 22310 else 22311 return False; 22312 end if; 22313 end Needs_Result_Accessibility_Level; 22314 22315 --------------------------------- 22316 -- Needs_Simple_Initialization -- 22317 --------------------------------- 22318 22319 function Needs_Simple_Initialization 22320 (Typ : Entity_Id; 22321 Consider_IS : Boolean := True) return Boolean 22322 is 22323 Consider_IS_NS : constant Boolean := 22324 Normalize_Scalars or (Initialize_Scalars and Consider_IS); 22325 22326 begin 22327 -- Never need initialization if it is suppressed 22328 22329 if Initialization_Suppressed (Typ) then 22330 return False; 22331 end if; 22332 22333 -- Check for private type, in which case test applies to the underlying 22334 -- type of the private type. 22335 22336 if Is_Private_Type (Typ) then 22337 declare 22338 RT : constant Entity_Id := Underlying_Type (Typ); 22339 begin 22340 if Present (RT) then 22341 return Needs_Simple_Initialization (RT); 22342 else 22343 return False; 22344 end if; 22345 end; 22346 22347 -- Scalar type with Default_Value aspect requires initialization 22348 22349 elsif Is_Scalar_Type (Typ) and then Has_Default_Aspect (Typ) then 22350 return True; 22351 22352 -- Cases needing simple initialization are access types, and, if pragma 22353 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar 22354 -- types. 22355 22356 elsif Is_Access_Type (Typ) 22357 or else (Consider_IS_NS and then (Is_Scalar_Type (Typ))) 22358 then 22359 return True; 22360 22361 -- If Initialize/Normalize_Scalars is in effect, string objects also 22362 -- need initialization, unless they are created in the course of 22363 -- expanding an aggregate (since in the latter case they will be 22364 -- filled with appropriate initializing values before they are used). 22365 22366 elsif Consider_IS_NS 22367 and then Is_Standard_String_Type (Typ) 22368 and then 22369 (not Is_Itype (Typ) 22370 or else Nkind (Associated_Node_For_Itype (Typ)) /= N_Aggregate) 22371 then 22372 return True; 22373 22374 else 22375 return False; 22376 end if; 22377 end Needs_Simple_Initialization; 22378 22379 ------------------------------------- 22380 -- Needs_Variable_Reference_Marker -- 22381 ------------------------------------- 22382 22383 function Needs_Variable_Reference_Marker 22384 (N : Node_Id; 22385 Calls_OK : Boolean) return Boolean 22386 is 22387 function Within_Suitable_Context (Ref : Node_Id) return Boolean; 22388 -- Deteremine whether variable reference Ref appears within a suitable 22389 -- context that allows the creation of a marker. 22390 22391 ----------------------------- 22392 -- Within_Suitable_Context -- 22393 ----------------------------- 22394 22395 function Within_Suitable_Context (Ref : Node_Id) return Boolean is 22396 Par : Node_Id; 22397 22398 begin 22399 Par := Ref; 22400 while Present (Par) loop 22401 22402 -- The context is not suitable when the reference appears within 22403 -- the formal part of an instantiation which acts as compilation 22404 -- unit because there is no proper list for the insertion of the 22405 -- marker. 22406 22407 if Nkind (Par) = N_Generic_Association 22408 and then Nkind (Parent (Par)) in N_Generic_Instantiation 22409 and then Nkind (Parent (Parent (Par))) = N_Compilation_Unit 22410 then 22411 return False; 22412 22413 -- The context is not suitable when the reference appears within 22414 -- a pragma. If the pragma has run-time semantics, the reference 22415 -- will be reconsidered once the pragma is expanded. 22416 22417 elsif Nkind (Par) = N_Pragma then 22418 return False; 22419 22420 -- The context is not suitable when the reference appears within a 22421 -- subprogram call, and the caller requests this behavior. 22422 22423 elsif not Calls_OK 22424 and then Nkind (Par) in N_Entry_Call_Statement 22425 | N_Function_Call 22426 | N_Procedure_Call_Statement 22427 then 22428 return False; 22429 22430 -- Prevent the search from going too far 22431 22432 elsif Is_Body_Or_Package_Declaration (Par) then 22433 exit; 22434 end if; 22435 22436 Par := Parent (Par); 22437 end loop; 22438 22439 return True; 22440 end Within_Suitable_Context; 22441 22442 -- Local variables 22443 22444 Prag : Node_Id; 22445 Var_Id : Entity_Id; 22446 22447 -- Start of processing for Needs_Variable_Reference_Marker 22448 22449 begin 22450 -- No marker needs to be created when switch -gnatH (legacy elaboration 22451 -- checking mode enabled) is in effect because the legacy ABE mechanism 22452 -- does not use markers. 22453 22454 if Legacy_Elaboration_Checks then 22455 return False; 22456 22457 -- No marker needs to be created when the reference is preanalyzed 22458 -- because the marker will be inserted in the wrong place. 22459 22460 elsif Preanalysis_Active then 22461 return False; 22462 22463 -- Only references warrant a marker 22464 22465 elsif Nkind (N) not in N_Expanded_Name | N_Identifier then 22466 return False; 22467 22468 -- Only source references warrant a marker 22469 22470 elsif not Comes_From_Source (N) then 22471 return False; 22472 22473 -- No marker needs to be created when the reference is erroneous, left 22474 -- in a bad state, or does not denote a variable. 22475 22476 elsif not (Present (Entity (N)) 22477 and then Ekind (Entity (N)) = E_Variable 22478 and then Entity (N) /= Any_Id) 22479 then 22480 return False; 22481 end if; 22482 22483 Var_Id := Entity (N); 22484 Prag := SPARK_Pragma (Var_Id); 22485 22486 -- Both the variable and reference must appear in SPARK_Mode On regions 22487 -- because this elaboration scenario falls under the SPARK rules. 22488 22489 if not (Comes_From_Source (Var_Id) 22490 and then Present (Prag) 22491 and then Get_SPARK_Mode_From_Annotation (Prag) = On 22492 and then Is_SPARK_Mode_On_Node (N)) 22493 then 22494 return False; 22495 22496 -- No marker needs to be created when the reference does not appear 22497 -- within a suitable context (see body for details). 22498 22499 -- Performance note: parent traversal 22500 22501 elsif not Within_Suitable_Context (N) then 22502 return False; 22503 end if; 22504 22505 -- At this point it is known that the variable reference will play a 22506 -- role in ABE diagnostics and requires a marker. 22507 22508 return True; 22509 end Needs_Variable_Reference_Marker; 22510 22511 ------------------------ 22512 -- New_Copy_List_Tree -- 22513 ------------------------ 22514 22515 function New_Copy_List_Tree (List : List_Id) return List_Id is 22516 NL : List_Id; 22517 E : Node_Id; 22518 22519 begin 22520 if List = No_List then 22521 return No_List; 22522 22523 else 22524 NL := New_List; 22525 E := First (List); 22526 22527 while Present (E) loop 22528 Append (New_Copy_Tree (E), NL); 22529 Next (E); 22530 end loop; 22531 22532 return NL; 22533 end if; 22534 end New_Copy_List_Tree; 22535 22536 ---------------------------- 22537 -- New_Copy_Separate_List -- 22538 ---------------------------- 22539 22540 function New_Copy_Separate_List (List : List_Id) return List_Id is 22541 begin 22542 if List = No_List then 22543 return No_List; 22544 22545 else 22546 declare 22547 List_Copy : constant List_Id := New_List; 22548 N : Node_Id := First (List); 22549 22550 begin 22551 while Present (N) loop 22552 Append (New_Copy_Separate_Tree (N), List_Copy); 22553 Next (N); 22554 end loop; 22555 22556 return List_Copy; 22557 end; 22558 end if; 22559 end New_Copy_Separate_List; 22560 22561 ---------------------------- 22562 -- New_Copy_Separate_Tree -- 22563 ---------------------------- 22564 22565 function New_Copy_Separate_Tree (Source : Node_Id) return Node_Id is 22566 function Search_Decl (N : Node_Id) return Traverse_Result; 22567 -- Subtree visitor which collects declarations 22568 22569 procedure Search_Declarations is new Traverse_Proc (Search_Decl); 22570 -- Subtree visitor instantiation 22571 22572 ----------------- 22573 -- Search_Decl -- 22574 ----------------- 22575 22576 Decls : Elist_Id; 22577 22578 function Search_Decl (N : Node_Id) return Traverse_Result is 22579 begin 22580 if Nkind (N) in N_Declaration then 22581 Append_New_Elmt (N, Decls); 22582 end if; 22583 22584 return OK; 22585 end Search_Decl; 22586 22587 -- Local variables 22588 22589 Source_Copy : constant Node_Id := New_Copy_Tree (Source); 22590 22591 -- Start of processing for New_Copy_Separate_Tree 22592 22593 begin 22594 Decls := No_Elist; 22595 Search_Declarations (Source_Copy); 22596 22597 -- Associate a new Entity with all the subtree declarations (keeping 22598 -- their original name). 22599 22600 if Present (Decls) then 22601 declare 22602 Elmt : Elmt_Id; 22603 Decl : Node_Id; 22604 New_E : Entity_Id; 22605 22606 begin 22607 Elmt := First_Elmt (Decls); 22608 while Present (Elmt) loop 22609 Decl := Node (Elmt); 22610 New_E := Make_Defining_Identifier (Sloc (Decl), 22611 New_Internal_Name ('P')); 22612 22613 if Nkind (Decl) = N_Expression_Function then 22614 Decl := Specification (Decl); 22615 end if; 22616 22617 if Nkind (Decl) in N_Function_Instantiation 22618 | N_Function_Specification 22619 | N_Generic_Function_Renaming_Declaration 22620 | N_Generic_Package_Renaming_Declaration 22621 | N_Generic_Procedure_Renaming_Declaration 22622 | N_Package_Body 22623 | N_Package_Instantiation 22624 | N_Package_Renaming_Declaration 22625 | N_Package_Specification 22626 | N_Procedure_Instantiation 22627 | N_Procedure_Specification 22628 then 22629 Set_Chars (New_E, Chars (Defining_Unit_Name (Decl))); 22630 Set_Defining_Unit_Name (Decl, New_E); 22631 else 22632 Set_Chars (New_E, Chars (Defining_Identifier (Decl))); 22633 Set_Defining_Identifier (Decl, New_E); 22634 end if; 22635 22636 Next_Elmt (Elmt); 22637 end loop; 22638 end; 22639 end if; 22640 22641 return Source_Copy; 22642 end New_Copy_Separate_Tree; 22643 22644 ------------------- 22645 -- New_Copy_Tree -- 22646 ------------------- 22647 22648 -- The following tables play a key role in replicating entities and Itypes. 22649 -- They are intentionally declared at the library level rather than within 22650 -- New_Copy_Tree to avoid elaborating them on each call. This performance 22651 -- optimization saves up to 2% of the entire compilation time spent in the 22652 -- front end. Care should be taken to reset the tables on each new call to 22653 -- New_Copy_Tree. 22654 22655 NCT_Table_Max : constant := 511; 22656 22657 subtype NCT_Table_Index is Nat range 0 .. NCT_Table_Max - 1; 22658 22659 function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index; 22660 -- Obtain the hash value of node or entity Key 22661 22662 -------------------- 22663 -- NCT_Table_Hash -- 22664 -------------------- 22665 22666 function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index is 22667 begin 22668 return NCT_Table_Index (Key mod NCT_Table_Max); 22669 end NCT_Table_Hash; 22670 22671 ---------------------- 22672 -- NCT_New_Entities -- 22673 ---------------------- 22674 22675 -- The following table maps old entities and Itypes to their corresponding 22676 -- new entities and Itypes. 22677 22678 -- Aaa -> Xxx 22679 22680 package NCT_New_Entities is new Simple_HTable ( 22681 Header_Num => NCT_Table_Index, 22682 Element => Entity_Id, 22683 No_Element => Empty, 22684 Key => Entity_Id, 22685 Hash => NCT_Table_Hash, 22686 Equal => "="); 22687 22688 ------------------------ 22689 -- NCT_Pending_Itypes -- 22690 ------------------------ 22691 22692 -- The following table maps old Associated_Node_For_Itype nodes to a set of 22693 -- new itypes. Given a set of old Itypes Aaa, Bbb, and Ccc, where all three 22694 -- have the same Associated_Node_For_Itype Ppp, and their corresponding new 22695 -- Itypes Xxx, Yyy, Zzz, the table contains the following mapping: 22696 22697 -- Ppp -> (Xxx, Yyy, Zzz) 22698 22699 -- The set is expressed as an Elist 22700 22701 package NCT_Pending_Itypes is new Simple_HTable ( 22702 Header_Num => NCT_Table_Index, 22703 Element => Elist_Id, 22704 No_Element => No_Elist, 22705 Key => Node_Id, 22706 Hash => NCT_Table_Hash, 22707 Equal => "="); 22708 22709 NCT_Tables_In_Use : Boolean := False; 22710 -- This flag keeps track of whether the two tables NCT_New_Entities and 22711 -- NCT_Pending_Itypes are in use. The flag is part of an optimization 22712 -- where certain operations are not performed if the tables are not in 22713 -- use. This saves up to 8% of the entire compilation time spent in the 22714 -- front end. 22715 22716 ------------------- 22717 -- New_Copy_Tree -- 22718 ------------------- 22719 22720 function New_Copy_Tree 22721 (Source : Node_Id; 22722 Map : Elist_Id := No_Elist; 22723 New_Sloc : Source_Ptr := No_Location; 22724 New_Scope : Entity_Id := Empty; 22725 Scopes_In_EWA_OK : Boolean := False) return Node_Id 22726 is 22727 -- This routine performs low-level tree manipulations and needs access 22728 -- to the internals of the tree. 22729 22730 use Atree.Unchecked_Access; 22731 use Atree_Private_Part; 22732 22733 EWA_Level : Nat := 0; 22734 -- This counter keeps track of how many N_Expression_With_Actions nodes 22735 -- are encountered during a depth-first traversal of the subtree. These 22736 -- nodes may define new entities in their Actions lists and thus require 22737 -- special processing. 22738 22739 EWA_Inner_Scope_Level : Nat := 0; 22740 -- This counter keeps track of how many scoping constructs appear within 22741 -- an N_Expression_With_Actions node. 22742 22743 procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id); 22744 pragma Inline (Add_New_Entity); 22745 -- Add an entry in the NCT_New_Entities table which maps key Old_Id to 22746 -- value New_Id. Old_Id is an entity which appears within the Actions 22747 -- list of an N_Expression_With_Actions node, or within an entity map. 22748 -- New_Id is the corresponding new entity generated during Phase 1. 22749 22750 procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id); 22751 pragma Inline (Add_Pending_Itype); 22752 -- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to 22753 -- value Itype. Assoc_Nod is the associated node of an itype. Itype is 22754 -- an itype. 22755 22756 procedure Build_NCT_Tables (Entity_Map : Elist_Id); 22757 pragma Inline (Build_NCT_Tables); 22758 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with the 22759 -- information supplied in entity map Entity_Map. The format of the 22760 -- entity map must be as follows: 22761 -- 22762 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN 22763 22764 function Copy_Any_Node_With_Replacement 22765 (N : Node_Or_Entity_Id) return Node_Or_Entity_Id; 22766 pragma Inline (Copy_Any_Node_With_Replacement); 22767 -- Replicate entity or node N by invoking one of the following routines: 22768 -- 22769 -- Copy_Node_With_Replacement 22770 -- Corresponding_Entity 22771 22772 function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id; 22773 -- Replicate the elements of entity list List 22774 22775 function Copy_Field_With_Replacement 22776 (Field : Union_Id; 22777 Old_Par : Node_Id := Empty; 22778 New_Par : Node_Id := Empty; 22779 Semantic : Boolean := False) return Union_Id; 22780 -- Replicate field Field by invoking one of the following routines: 22781 -- 22782 -- Copy_Elist_With_Replacement 22783 -- Copy_List_With_Replacement 22784 -- Copy_Node_With_Replacement 22785 -- Corresponding_Entity 22786 -- 22787 -- If the field is not an entity list, entity, itype, syntactic list, 22788 -- or node, then the field is returned unchanged. The routine always 22789 -- replicates entities, itypes, and valid syntactic fields. Old_Par is 22790 -- the expected parent of a syntactic field. New_Par is the new parent 22791 -- associated with a replicated syntactic field. Flag Semantic should 22792 -- be set when the input is a semantic field. 22793 22794 function Copy_List_With_Replacement (List : List_Id) return List_Id; 22795 -- Replicate the elements of syntactic list List 22796 22797 function Copy_Node_With_Replacement (N : Node_Id) return Node_Id; 22798 -- Replicate node N 22799 22800 function Corresponding_Entity (Id : Entity_Id) return Entity_Id; 22801 pragma Inline (Corresponding_Entity); 22802 -- Return the corresponding new entity of Id generated during Phase 1. 22803 -- If there is no such entity, return Id. 22804 22805 function In_Entity_Map 22806 (Id : Entity_Id; 22807 Entity_Map : Elist_Id) return Boolean; 22808 pragma Inline (In_Entity_Map); 22809 -- Determine whether entity Id is one of the old ids specified in entity 22810 -- map Entity_Map. The format of the entity map must be as follows: 22811 -- 22812 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN 22813 22814 procedure Update_CFS_Sloc (N : Node_Or_Entity_Id); 22815 pragma Inline (Update_CFS_Sloc); 22816 -- Update the Comes_From_Source and Sloc attributes of node or entity N 22817 22818 procedure Update_First_Real_Statement 22819 (Old_HSS : Node_Id; 22820 New_HSS : Node_Id); 22821 pragma Inline (Update_First_Real_Statement); 22822 -- Update semantic attribute First_Real_Statement of handled sequence of 22823 -- statements New_HSS based on handled sequence of statements Old_HSS. 22824 22825 procedure Update_Named_Associations 22826 (Old_Call : Node_Id; 22827 New_Call : Node_Id); 22828 pragma Inline (Update_Named_Associations); 22829 -- Update semantic chain First/Next_Named_Association of call New_call 22830 -- based on call Old_Call. 22831 22832 procedure Update_New_Entities (Entity_Map : Elist_Id); 22833 pragma Inline (Update_New_Entities); 22834 -- Update the semantic attributes of all new entities generated during 22835 -- Phase 1 that do not appear in entity map Entity_Map. The format of 22836 -- the entity map must be as follows: 22837 -- 22838 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN 22839 22840 procedure Update_Pending_Itypes 22841 (Old_Assoc : Node_Id; 22842 New_Assoc : Node_Id); 22843 pragma Inline (Update_Pending_Itypes); 22844 -- Update semantic attribute Associated_Node_For_Itype to refer to node 22845 -- New_Assoc for all itypes whose associated node is Old_Assoc. 22846 22847 procedure Update_Semantic_Fields (Id : Entity_Id); 22848 pragma Inline (Update_Semantic_Fields); 22849 -- Subsidiary to Update_New_Entities. Update semantic fields of entity 22850 -- or itype Id. 22851 22852 procedure Visit_Any_Node (N : Node_Or_Entity_Id); 22853 pragma Inline (Visit_Any_Node); 22854 -- Visit entity of node N by invoking one of the following routines: 22855 -- 22856 -- Visit_Entity 22857 -- Visit_Itype 22858 -- Visit_Node 22859 22860 procedure Visit_Elist (List : Elist_Id); 22861 -- Visit the elements of entity list List 22862 22863 procedure Visit_Entity (Id : Entity_Id); 22864 -- Visit entity Id. This action may create a new entity of Id and save 22865 -- it in table NCT_New_Entities. 22866 22867 procedure Visit_Field 22868 (Field : Union_Id; 22869 Par_Nod : Node_Id := Empty; 22870 Semantic : Boolean := False); 22871 -- Visit field Field by invoking one of the following routines: 22872 -- 22873 -- Visit_Elist 22874 -- Visit_Entity 22875 -- Visit_Itype 22876 -- Visit_List 22877 -- Visit_Node 22878 -- 22879 -- If the field is not an entity list, entity, itype, syntactic list, 22880 -- or node, then the field is not visited. The routine always visits 22881 -- valid syntactic fields. Par_Nod is the expected parent of the 22882 -- syntactic field. Flag Semantic should be set when the input is a 22883 -- semantic field. 22884 22885 procedure Visit_Itype (Itype : Entity_Id); 22886 -- Visit itype Itype. This action may create a new entity for Itype and 22887 -- save it in table NCT_New_Entities. In addition, the routine may map 22888 -- the associated node of Itype to the new itype in NCT_Pending_Itypes. 22889 22890 procedure Visit_List (List : List_Id); 22891 -- Visit the elements of syntactic list List 22892 22893 procedure Visit_Node (N : Node_Id); 22894 -- Visit node N 22895 22896 procedure Visit_Semantic_Fields (Id : Entity_Id); 22897 pragma Inline (Visit_Semantic_Fields); 22898 -- Subsidiary to Visit_Entity and Visit_Itype. Visit common semantic 22899 -- fields of entity or itype Id. 22900 22901 -------------------- 22902 -- Add_New_Entity -- 22903 -------------------- 22904 22905 procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id) is 22906 begin 22907 pragma Assert (Present (Old_Id)); 22908 pragma Assert (Present (New_Id)); 22909 pragma Assert (Nkind (Old_Id) in N_Entity); 22910 pragma Assert (Nkind (New_Id) in N_Entity); 22911 22912 NCT_Tables_In_Use := True; 22913 22914 -- Sanity check the NCT_New_Entities table. No previous mapping with 22915 -- key Old_Id should exist. 22916 22917 pragma Assert (No (NCT_New_Entities.Get (Old_Id))); 22918 22919 -- Establish the mapping 22920 22921 -- Old_Id -> New_Id 22922 22923 NCT_New_Entities.Set (Old_Id, New_Id); 22924 end Add_New_Entity; 22925 22926 ----------------------- 22927 -- Add_Pending_Itype -- 22928 ----------------------- 22929 22930 procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id) is 22931 Itypes : Elist_Id; 22932 22933 begin 22934 pragma Assert (Present (Assoc_Nod)); 22935 pragma Assert (Present (Itype)); 22936 pragma Assert (Nkind (Itype) in N_Entity); 22937 pragma Assert (Is_Itype (Itype)); 22938 22939 NCT_Tables_In_Use := True; 22940 22941 -- It is not possible to sanity check the NCT_Pendint_Itypes table 22942 -- directly because a single node may act as the associated node for 22943 -- multiple itypes. 22944 22945 Itypes := NCT_Pending_Itypes.Get (Assoc_Nod); 22946 22947 if No (Itypes) then 22948 Itypes := New_Elmt_List; 22949 NCT_Pending_Itypes.Set (Assoc_Nod, Itypes); 22950 end if; 22951 22952 -- Establish the mapping 22953 22954 -- Assoc_Nod -> (Itype, ...) 22955 22956 -- Avoid inserting the same itype multiple times. This involves a 22957 -- linear search, however the set of itypes with the same associated 22958 -- node is very small. 22959 22960 Append_Unique_Elmt (Itype, Itypes); 22961 end Add_Pending_Itype; 22962 22963 ---------------------- 22964 -- Build_NCT_Tables -- 22965 ---------------------- 22966 22967 procedure Build_NCT_Tables (Entity_Map : Elist_Id) is 22968 Elmt : Elmt_Id; 22969 Old_Id : Entity_Id; 22970 New_Id : Entity_Id; 22971 22972 begin 22973 -- Nothing to do when there is no entity map 22974 22975 if No (Entity_Map) then 22976 return; 22977 end if; 22978 22979 Elmt := First_Elmt (Entity_Map); 22980 while Present (Elmt) loop 22981 22982 -- Extract the (Old_Id, New_Id) pair from the entity map 22983 22984 Old_Id := Node (Elmt); 22985 Next_Elmt (Elmt); 22986 22987 New_Id := Node (Elmt); 22988 Next_Elmt (Elmt); 22989 22990 -- Establish the following mapping within table NCT_New_Entities 22991 22992 -- Old_Id -> New_Id 22993 22994 Add_New_Entity (Old_Id, New_Id); 22995 22996 -- Establish the following mapping within table NCT_Pending_Itypes 22997 -- when the new entity is an itype. 22998 22999 -- Assoc_Nod -> (New_Id, ...) 23000 23001 -- IMPORTANT: the associated node is that of the old itype because 23002 -- the node will be replicated in Phase 2. 23003 23004 if Is_Itype (Old_Id) then 23005 Add_Pending_Itype 23006 (Assoc_Nod => Associated_Node_For_Itype (Old_Id), 23007 Itype => New_Id); 23008 end if; 23009 end loop; 23010 end Build_NCT_Tables; 23011 23012 ------------------------------------ 23013 -- Copy_Any_Node_With_Replacement -- 23014 ------------------------------------ 23015 23016 function Copy_Any_Node_With_Replacement 23017 (N : Node_Or_Entity_Id) return Node_Or_Entity_Id 23018 is 23019 begin 23020 if Nkind (N) in N_Entity then 23021 return Corresponding_Entity (N); 23022 else 23023 return Copy_Node_With_Replacement (N); 23024 end if; 23025 end Copy_Any_Node_With_Replacement; 23026 23027 --------------------------------- 23028 -- Copy_Elist_With_Replacement -- 23029 --------------------------------- 23030 23031 function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id is 23032 Elmt : Elmt_Id; 23033 Result : Elist_Id; 23034 23035 begin 23036 -- Copy the contents of the old list. Note that the list itself may 23037 -- be empty, in which case the routine returns a new empty list. This 23038 -- avoids sharing lists between subtrees. The element of an entity 23039 -- list could be an entity or a node, hence the invocation of routine 23040 -- Copy_Any_Node_With_Replacement. 23041 23042 if Present (List) then 23043 Result := New_Elmt_List; 23044 23045 Elmt := First_Elmt (List); 23046 while Present (Elmt) loop 23047 Append_Elmt 23048 (Copy_Any_Node_With_Replacement (Node (Elmt)), Result); 23049 23050 Next_Elmt (Elmt); 23051 end loop; 23052 23053 -- Otherwise the list does not exist 23054 23055 else 23056 Result := No_Elist; 23057 end if; 23058 23059 return Result; 23060 end Copy_Elist_With_Replacement; 23061 23062 --------------------------------- 23063 -- Copy_Field_With_Replacement -- 23064 --------------------------------- 23065 23066 function Copy_Field_With_Replacement 23067 (Field : Union_Id; 23068 Old_Par : Node_Id := Empty; 23069 New_Par : Node_Id := Empty; 23070 Semantic : Boolean := False) return Union_Id 23071 is 23072 function Has_More_Ids (N : Node_Id) return Boolean; 23073 -- Return True when N has attribute More_Ids set to True 23074 23075 function Is_Syntactic_Node return Boolean; 23076 -- Return True when Field is a syntactic node 23077 23078 ------------------ 23079 -- Has_More_Ids -- 23080 ------------------ 23081 23082 function Has_More_Ids (N : Node_Id) return Boolean is 23083 begin 23084 if Nkind (N) in N_Component_Declaration 23085 | N_Discriminant_Specification 23086 | N_Exception_Declaration 23087 | N_Formal_Object_Declaration 23088 | N_Number_Declaration 23089 | N_Object_Declaration 23090 | N_Parameter_Specification 23091 | N_Use_Package_Clause 23092 | N_Use_Type_Clause 23093 then 23094 return More_Ids (N); 23095 else 23096 return False; 23097 end if; 23098 end Has_More_Ids; 23099 23100 ----------------------- 23101 -- Is_Syntactic_Node -- 23102 ----------------------- 23103 23104 function Is_Syntactic_Node return Boolean is 23105 Old_N : constant Node_Id := Node_Id (Field); 23106 23107 begin 23108 if Parent (Old_N) = Old_Par then 23109 return True; 23110 23111 elsif not Has_More_Ids (Old_Par) then 23112 return False; 23113 23114 -- Perform the check using the last last id in the syntactic chain 23115 23116 else 23117 declare 23118 N : Node_Id := Old_Par; 23119 23120 begin 23121 while Present (N) and then More_Ids (N) loop 23122 Next (N); 23123 end loop; 23124 23125 pragma Assert (Prev_Ids (N)); 23126 return Parent (Old_N) = N; 23127 end; 23128 end if; 23129 end Is_Syntactic_Node; 23130 23131 begin 23132 -- The field is empty 23133 23134 if Field = Union_Id (Empty) then 23135 return Field; 23136 23137 -- The field is an entity/itype/node 23138 23139 elsif Field in Node_Range then 23140 declare 23141 Old_N : constant Node_Id := Node_Id (Field); 23142 Syntactic : constant Boolean := Is_Syntactic_Node; 23143 23144 New_N : Node_Id; 23145 23146 begin 23147 -- The field is an entity/itype 23148 23149 if Nkind (Old_N) in N_Entity then 23150 23151 -- An entity/itype is always replicated 23152 23153 New_N := Corresponding_Entity (Old_N); 23154 23155 -- Update the parent pointer when the entity is a syntactic 23156 -- field. Note that itypes do not have parent pointers. 23157 23158 if Syntactic and then New_N /= Old_N then 23159 Set_Parent (New_N, New_Par); 23160 end if; 23161 23162 -- The field is a node 23163 23164 else 23165 -- A node is replicated when it is either a syntactic field 23166 -- or when the caller treats it as a semantic attribute. 23167 23168 if Syntactic or else Semantic then 23169 New_N := Copy_Node_With_Replacement (Old_N); 23170 23171 -- Update the parent pointer when the node is a syntactic 23172 -- field. 23173 23174 if Syntactic and then New_N /= Old_N then 23175 Set_Parent (New_N, New_Par); 23176 end if; 23177 23178 -- Otherwise the node is returned unchanged 23179 23180 else 23181 New_N := Old_N; 23182 end if; 23183 end if; 23184 23185 return Union_Id (New_N); 23186 end; 23187 23188 -- The field is an entity list 23189 23190 elsif Field in Elist_Range then 23191 return Union_Id (Copy_Elist_With_Replacement (Elist_Id (Field))); 23192 23193 -- The field is a syntactic list 23194 23195 elsif Field in List_Range then 23196 declare 23197 Old_List : constant List_Id := List_Id (Field); 23198 Syntactic : constant Boolean := Parent (Old_List) = Old_Par; 23199 23200 New_List : List_Id; 23201 23202 begin 23203 -- A list is replicated when it is either a syntactic field or 23204 -- when the caller treats it as a semantic attribute. 23205 23206 if Syntactic or else Semantic then 23207 New_List := Copy_List_With_Replacement (Old_List); 23208 23209 -- Update the parent pointer when the list is a syntactic 23210 -- field. 23211 23212 if Syntactic and then New_List /= Old_List then 23213 Set_Parent (New_List, New_Par); 23214 end if; 23215 23216 -- Otherwise the list is returned unchanged 23217 23218 else 23219 New_List := Old_List; 23220 end if; 23221 23222 return Union_Id (New_List); 23223 end; 23224 23225 -- Otherwise the field denotes an attribute that does not need to be 23226 -- replicated (Chars, literals, etc). 23227 23228 else 23229 return Field; 23230 end if; 23231 end Copy_Field_With_Replacement; 23232 23233 -------------------------------- 23234 -- Copy_List_With_Replacement -- 23235 -------------------------------- 23236 23237 function Copy_List_With_Replacement (List : List_Id) return List_Id is 23238 Elmt : Node_Id; 23239 Result : List_Id; 23240 23241 begin 23242 -- Copy the contents of the old list. Note that the list itself may 23243 -- be empty, in which case the routine returns a new empty list. This 23244 -- avoids sharing lists between subtrees. The element of a syntactic 23245 -- list is always a node, never an entity or itype, hence the call to 23246 -- routine Copy_Node_With_Replacement. 23247 23248 if Present (List) then 23249 Result := New_List; 23250 23251 Elmt := First (List); 23252 while Present (Elmt) loop 23253 Append (Copy_Node_With_Replacement (Elmt), Result); 23254 23255 Next (Elmt); 23256 end loop; 23257 23258 -- Otherwise the list does not exist 23259 23260 else 23261 Result := No_List; 23262 end if; 23263 23264 return Result; 23265 end Copy_List_With_Replacement; 23266 23267 -------------------------------- 23268 -- Copy_Node_With_Replacement -- 23269 -------------------------------- 23270 23271 function Copy_Node_With_Replacement (N : Node_Id) return Node_Id is 23272 Result : Node_Id; 23273 23274 begin 23275 -- Assume that the node must be returned unchanged 23276 23277 Result := N; 23278 23279 if N > Empty_Or_Error then 23280 pragma Assert (Nkind (N) not in N_Entity); 23281 23282 Result := New_Copy (N); 23283 23284 Set_Field1 (Result, 23285 Copy_Field_With_Replacement 23286 (Field => Field1 (Result), 23287 Old_Par => N, 23288 New_Par => Result)); 23289 23290 Set_Field2 (Result, 23291 Copy_Field_With_Replacement 23292 (Field => Field2 (Result), 23293 Old_Par => N, 23294 New_Par => Result)); 23295 23296 Set_Field3 (Result, 23297 Copy_Field_With_Replacement 23298 (Field => Field3 (Result), 23299 Old_Par => N, 23300 New_Par => Result)); 23301 23302 Set_Field4 (Result, 23303 Copy_Field_With_Replacement 23304 (Field => Field4 (Result), 23305 Old_Par => N, 23306 New_Par => Result)); 23307 23308 Set_Field5 (Result, 23309 Copy_Field_With_Replacement 23310 (Field => Field5 (Result), 23311 Old_Par => N, 23312 New_Par => Result)); 23313 23314 -- Update the Comes_From_Source and Sloc attributes of the node 23315 -- in case the caller has supplied new values. 23316 23317 Update_CFS_Sloc (Result); 23318 23319 -- Update the Associated_Node_For_Itype attribute of all itypes 23320 -- created during Phase 1 whose associated node is N. As a result 23321 -- the Associated_Node_For_Itype refers to the replicated node. 23322 -- No action needs to be taken when the Associated_Node_For_Itype 23323 -- refers to an entity because this was already handled during 23324 -- Phase 1, in Visit_Itype. 23325 23326 Update_Pending_Itypes 23327 (Old_Assoc => N, 23328 New_Assoc => Result); 23329 23330 -- Update the First/Next_Named_Association chain for a replicated 23331 -- call. 23332 23333 if Nkind (N) in N_Entry_Call_Statement 23334 | N_Function_Call 23335 | N_Procedure_Call_Statement 23336 then 23337 Update_Named_Associations 23338 (Old_Call => N, 23339 New_Call => Result); 23340 23341 -- Update the Renamed_Object attribute of a replicated object 23342 -- declaration. 23343 23344 elsif Nkind (N) = N_Object_Renaming_Declaration then 23345 Set_Renamed_Object (Defining_Entity (Result), Name (Result)); 23346 23347 -- Update the First_Real_Statement attribute of a replicated 23348 -- handled sequence of statements. 23349 23350 elsif Nkind (N) = N_Handled_Sequence_Of_Statements then 23351 Update_First_Real_Statement 23352 (Old_HSS => N, 23353 New_HSS => Result); 23354 23355 -- Update the Chars attribute of identifiers 23356 23357 elsif Nkind (N) = N_Identifier then 23358 23359 -- The Entity field of identifiers that denote aspects is used 23360 -- to store arbitrary expressions (and hence we must check that 23361 -- they reference an actual entity before copying their Chars 23362 -- value). 23363 23364 if Present (Entity (Result)) 23365 and then Nkind (Entity (Result)) in N_Entity 23366 then 23367 Set_Chars (Result, Chars (Entity (Result))); 23368 end if; 23369 end if; 23370 23371 if Has_Aspects (N) then 23372 Set_Aspect_Specifications (Result, 23373 Copy_List_With_Replacement (Aspect_Specifications (N))); 23374 end if; 23375 end if; 23376 23377 return Result; 23378 end Copy_Node_With_Replacement; 23379 23380 -------------------------- 23381 -- Corresponding_Entity -- 23382 -------------------------- 23383 23384 function Corresponding_Entity (Id : Entity_Id) return Entity_Id is 23385 New_Id : Entity_Id; 23386 Result : Entity_Id; 23387 23388 begin 23389 -- Assume that the entity must be returned unchanged 23390 23391 Result := Id; 23392 23393 if Id > Empty_Or_Error then 23394 pragma Assert (Nkind (Id) in N_Entity); 23395 23396 -- Determine whether the entity has a corresponding new entity 23397 -- generated during Phase 1 and if it does, use it. 23398 23399 if NCT_Tables_In_Use then 23400 New_Id := NCT_New_Entities.Get (Id); 23401 23402 if Present (New_Id) then 23403 Result := New_Id; 23404 end if; 23405 end if; 23406 end if; 23407 23408 return Result; 23409 end Corresponding_Entity; 23410 23411 ------------------- 23412 -- In_Entity_Map -- 23413 ------------------- 23414 23415 function In_Entity_Map 23416 (Id : Entity_Id; 23417 Entity_Map : Elist_Id) return Boolean 23418 is 23419 Elmt : Elmt_Id; 23420 Old_Id : Entity_Id; 23421 23422 begin 23423 -- The entity map contains pairs (Old_Id, New_Id). The advancement 23424 -- step always skips the New_Id portion of the pair. 23425 23426 if Present (Entity_Map) then 23427 Elmt := First_Elmt (Entity_Map); 23428 while Present (Elmt) loop 23429 Old_Id := Node (Elmt); 23430 23431 if Old_Id = Id then 23432 return True; 23433 end if; 23434 23435 Next_Elmt (Elmt); 23436 Next_Elmt (Elmt); 23437 end loop; 23438 end if; 23439 23440 return False; 23441 end In_Entity_Map; 23442 23443 --------------------- 23444 -- Update_CFS_Sloc -- 23445 --------------------- 23446 23447 procedure Update_CFS_Sloc (N : Node_Or_Entity_Id) is 23448 begin 23449 -- A new source location defaults the Comes_From_Source attribute 23450 23451 if New_Sloc /= No_Location then 23452 Set_Comes_From_Source (N, Default_Node.Comes_From_Source); 23453 Set_Sloc (N, New_Sloc); 23454 end if; 23455 end Update_CFS_Sloc; 23456 23457 --------------------------------- 23458 -- Update_First_Real_Statement -- 23459 --------------------------------- 23460 23461 procedure Update_First_Real_Statement 23462 (Old_HSS : Node_Id; 23463 New_HSS : Node_Id) 23464 is 23465 Old_First_Stmt : constant Node_Id := First_Real_Statement (Old_HSS); 23466 23467 New_Stmt : Node_Id; 23468 Old_Stmt : Node_Id; 23469 23470 begin 23471 -- Recreate the First_Real_Statement attribute of a handled sequence 23472 -- of statements by traversing the statement lists of both sequences 23473 -- in parallel. 23474 23475 if Present (Old_First_Stmt) then 23476 New_Stmt := First (Statements (New_HSS)); 23477 Old_Stmt := First (Statements (Old_HSS)); 23478 while Present (Old_Stmt) and then Old_Stmt /= Old_First_Stmt loop 23479 Next (New_Stmt); 23480 Next (Old_Stmt); 23481 end loop; 23482 23483 pragma Assert (Present (New_Stmt)); 23484 pragma Assert (Present (Old_Stmt)); 23485 23486 Set_First_Real_Statement (New_HSS, New_Stmt); 23487 end if; 23488 end Update_First_Real_Statement; 23489 23490 ------------------------------- 23491 -- Update_Named_Associations -- 23492 ------------------------------- 23493 23494 procedure Update_Named_Associations 23495 (Old_Call : Node_Id; 23496 New_Call : Node_Id) 23497 is 23498 New_Act : Node_Id; 23499 New_Next : Node_Id; 23500 Old_Act : Node_Id; 23501 Old_Next : Node_Id; 23502 23503 begin 23504 if No (First_Named_Actual (Old_Call)) then 23505 return; 23506 end if; 23507 23508 -- Recreate the First/Next_Named_Actual chain of a call by traversing 23509 -- the chains of both the old and new calls in parallel. 23510 23511 New_Act := First (Parameter_Associations (New_Call)); 23512 Old_Act := First (Parameter_Associations (Old_Call)); 23513 while Present (Old_Act) loop 23514 if Nkind (Old_Act) = N_Parameter_Association 23515 and then Explicit_Actual_Parameter (Old_Act) 23516 = First_Named_Actual (Old_Call) 23517 then 23518 Set_First_Named_Actual (New_Call, 23519 Explicit_Actual_Parameter (New_Act)); 23520 end if; 23521 23522 if Nkind (Old_Act) = N_Parameter_Association 23523 and then Present (Next_Named_Actual (Old_Act)) 23524 then 23525 -- Scan the actual parameter list to find the next suitable 23526 -- named actual. Note that the list may be out of order. 23527 23528 New_Next := First (Parameter_Associations (New_Call)); 23529 Old_Next := First (Parameter_Associations (Old_Call)); 23530 while Nkind (Old_Next) /= N_Parameter_Association 23531 or else Explicit_Actual_Parameter (Old_Next) /= 23532 Next_Named_Actual (Old_Act) 23533 loop 23534 Next (New_Next); 23535 Next (Old_Next); 23536 end loop; 23537 23538 Set_Next_Named_Actual (New_Act, 23539 Explicit_Actual_Parameter (New_Next)); 23540 end if; 23541 23542 Next (New_Act); 23543 Next (Old_Act); 23544 end loop; 23545 end Update_Named_Associations; 23546 23547 ------------------------- 23548 -- Update_New_Entities -- 23549 ------------------------- 23550 23551 procedure Update_New_Entities (Entity_Map : Elist_Id) is 23552 New_Id : Entity_Id := Empty; 23553 Old_Id : Entity_Id := Empty; 23554 23555 begin 23556 if NCT_Tables_In_Use then 23557 NCT_New_Entities.Get_First (Old_Id, New_Id); 23558 23559 -- Update the semantic fields of all new entities created during 23560 -- Phase 1 which were not supplied via an entity map. 23561 -- ??? Is there a better way of distinguishing those? 23562 23563 while Present (Old_Id) and then Present (New_Id) loop 23564 if not (Present (Entity_Map) 23565 and then In_Entity_Map (Old_Id, Entity_Map)) 23566 then 23567 Update_Semantic_Fields (New_Id); 23568 end if; 23569 23570 NCT_New_Entities.Get_Next (Old_Id, New_Id); 23571 end loop; 23572 end if; 23573 end Update_New_Entities; 23574 23575 --------------------------- 23576 -- Update_Pending_Itypes -- 23577 --------------------------- 23578 23579 procedure Update_Pending_Itypes 23580 (Old_Assoc : Node_Id; 23581 New_Assoc : Node_Id) 23582 is 23583 Item : Elmt_Id; 23584 Itypes : Elist_Id; 23585 23586 begin 23587 if NCT_Tables_In_Use then 23588 Itypes := NCT_Pending_Itypes.Get (Old_Assoc); 23589 23590 -- Update the Associated_Node_For_Itype attribute for all itypes 23591 -- which originally refer to Old_Assoc to designate New_Assoc. 23592 23593 if Present (Itypes) then 23594 Item := First_Elmt (Itypes); 23595 while Present (Item) loop 23596 Set_Associated_Node_For_Itype (Node (Item), New_Assoc); 23597 23598 Next_Elmt (Item); 23599 end loop; 23600 end if; 23601 end if; 23602 end Update_Pending_Itypes; 23603 23604 ---------------------------- 23605 -- Update_Semantic_Fields -- 23606 ---------------------------- 23607 23608 procedure Update_Semantic_Fields (Id : Entity_Id) is 23609 begin 23610 -- Discriminant_Constraint 23611 23612 if Is_Type (Id) and then Has_Discriminants (Base_Type (Id)) then 23613 Set_Discriminant_Constraint (Id, Elist_Id ( 23614 Copy_Field_With_Replacement 23615 (Field => Union_Id (Discriminant_Constraint (Id)), 23616 Semantic => True))); 23617 end if; 23618 23619 -- Etype 23620 23621 Set_Etype (Id, Node_Id ( 23622 Copy_Field_With_Replacement 23623 (Field => Union_Id (Etype (Id)), 23624 Semantic => True))); 23625 23626 -- First_Index 23627 -- Packed_Array_Impl_Type 23628 23629 if Is_Array_Type (Id) then 23630 if Present (First_Index (Id)) then 23631 Set_First_Index (Id, First (List_Id ( 23632 Copy_Field_With_Replacement 23633 (Field => Union_Id (List_Containing (First_Index (Id))), 23634 Semantic => True)))); 23635 end if; 23636 23637 if Is_Packed (Id) then 23638 Set_Packed_Array_Impl_Type (Id, Node_Id ( 23639 Copy_Field_With_Replacement 23640 (Field => Union_Id (Packed_Array_Impl_Type (Id)), 23641 Semantic => True))); 23642 end if; 23643 end if; 23644 23645 -- Prev_Entity 23646 23647 Set_Prev_Entity (Id, Node_Id ( 23648 Copy_Field_With_Replacement 23649 (Field => Union_Id (Prev_Entity (Id)), 23650 Semantic => True))); 23651 23652 -- Next_Entity 23653 23654 Set_Next_Entity (Id, Node_Id ( 23655 Copy_Field_With_Replacement 23656 (Field => Union_Id (Next_Entity (Id)), 23657 Semantic => True))); 23658 23659 -- Scalar_Range 23660 23661 if Is_Discrete_Type (Id) then 23662 Set_Scalar_Range (Id, Node_Id ( 23663 Copy_Field_With_Replacement 23664 (Field => Union_Id (Scalar_Range (Id)), 23665 Semantic => True))); 23666 end if; 23667 23668 -- Scope 23669 23670 -- Update the scope when the caller specified an explicit one 23671 23672 if Present (New_Scope) then 23673 Set_Scope (Id, New_Scope); 23674 else 23675 Set_Scope (Id, Node_Id ( 23676 Copy_Field_With_Replacement 23677 (Field => Union_Id (Scope (Id)), 23678 Semantic => True))); 23679 end if; 23680 end Update_Semantic_Fields; 23681 23682 -------------------- 23683 -- Visit_Any_Node -- 23684 -------------------- 23685 23686 procedure Visit_Any_Node (N : Node_Or_Entity_Id) is 23687 begin 23688 if Nkind (N) in N_Entity then 23689 if Is_Itype (N) then 23690 Visit_Itype (N); 23691 else 23692 Visit_Entity (N); 23693 end if; 23694 else 23695 Visit_Node (N); 23696 end if; 23697 end Visit_Any_Node; 23698 23699 ----------------- 23700 -- Visit_Elist -- 23701 ----------------- 23702 23703 procedure Visit_Elist (List : Elist_Id) is 23704 Elmt : Elmt_Id; 23705 23706 begin 23707 -- The element of an entity list could be an entity, itype, or a 23708 -- node, hence the call to Visit_Any_Node. 23709 23710 if Present (List) then 23711 Elmt := First_Elmt (List); 23712 while Present (Elmt) loop 23713 Visit_Any_Node (Node (Elmt)); 23714 23715 Next_Elmt (Elmt); 23716 end loop; 23717 end if; 23718 end Visit_Elist; 23719 23720 ------------------ 23721 -- Visit_Entity -- 23722 ------------------ 23723 23724 procedure Visit_Entity (Id : Entity_Id) is 23725 New_Id : Entity_Id; 23726 23727 begin 23728 pragma Assert (Nkind (Id) in N_Entity); 23729 pragma Assert (not Is_Itype (Id)); 23730 23731 -- Nothing to do when the entity is not defined in the Actions list 23732 -- of an N_Expression_With_Actions node. 23733 23734 if EWA_Level = 0 then 23735 return; 23736 23737 -- Nothing to do when the entity is defined in a scoping construct 23738 -- within an N_Expression_With_Actions node, unless the caller has 23739 -- requested their replication. 23740 23741 -- ??? should this restriction be eliminated? 23742 23743 elsif EWA_Inner_Scope_Level > 0 and then not Scopes_In_EWA_OK then 23744 return; 23745 23746 -- Nothing to do when the entity does not denote a construct that 23747 -- may appear within an N_Expression_With_Actions node. Relaxing 23748 -- this restriction leads to a performance penalty. 23749 23750 -- ??? this list is flaky, and may hide dormant bugs 23751 -- Should functions be included??? 23752 23753 -- Loop parameters appear within quantified expressions and contain 23754 -- an entity declaration that must be replaced when the expander is 23755 -- active if the expression has been preanalyzed or analyzed. 23756 23757 elsif Ekind (Id) not in 23758 E_Block | E_Constant | E_Label | E_Loop_Parameter | 23759 E_Procedure | E_Variable 23760 and then not Is_Type (Id) 23761 then 23762 return; 23763 23764 elsif Ekind (Id) = E_Loop_Parameter 23765 and then No (Etype (Condition (Parent (Parent (Id))))) 23766 then 23767 return; 23768 23769 -- Nothing to do when the entity was already visited 23770 23771 elsif NCT_Tables_In_Use 23772 and then Present (NCT_New_Entities.Get (Id)) 23773 then 23774 return; 23775 23776 -- Nothing to do when the declaration node of the entity is not in 23777 -- the subtree being replicated. 23778 23779 elsif not In_Subtree 23780 (N => Declaration_Node (Id), 23781 Root => Source) 23782 then 23783 return; 23784 end if; 23785 23786 -- Create a new entity by directly copying the old entity. This 23787 -- action causes all attributes of the old entity to be inherited. 23788 23789 New_Id := New_Copy (Id); 23790 23791 -- Create a new name for the new entity because the back end needs 23792 -- distinct names for debugging purposes. 23793 23794 Set_Chars (New_Id, New_Internal_Name ('T')); 23795 23796 -- Update the Comes_From_Source and Sloc attributes of the entity in 23797 -- case the caller has supplied new values. 23798 23799 Update_CFS_Sloc (New_Id); 23800 23801 -- Establish the following mapping within table NCT_New_Entities: 23802 23803 -- Id -> New_Id 23804 23805 Add_New_Entity (Id, New_Id); 23806 23807 -- Deal with the semantic fields of entities. The fields are visited 23808 -- because they may mention entities which reside within the subtree 23809 -- being copied. 23810 23811 Visit_Semantic_Fields (Id); 23812 end Visit_Entity; 23813 23814 ----------------- 23815 -- Visit_Field -- 23816 ----------------- 23817 23818 procedure Visit_Field 23819 (Field : Union_Id; 23820 Par_Nod : Node_Id := Empty; 23821 Semantic : Boolean := False) 23822 is 23823 begin 23824 -- The field is empty 23825 23826 if Field = Union_Id (Empty) then 23827 return; 23828 23829 -- The field is an entity/itype/node 23830 23831 elsif Field in Node_Range then 23832 declare 23833 N : constant Node_Id := Node_Id (Field); 23834 23835 begin 23836 -- The field is an entity/itype 23837 23838 if Nkind (N) in N_Entity then 23839 23840 -- Itypes are always visited 23841 23842 if Is_Itype (N) then 23843 Visit_Itype (N); 23844 23845 -- An entity is visited when it is either a syntactic field 23846 -- or when the caller treats it as a semantic attribute. 23847 23848 elsif Parent (N) = Par_Nod or else Semantic then 23849 Visit_Entity (N); 23850 end if; 23851 23852 -- The field is a node 23853 23854 else 23855 -- A node is visited when it is either a syntactic field or 23856 -- when the caller treats it as a semantic attribute. 23857 23858 if Parent (N) = Par_Nod or else Semantic then 23859 Visit_Node (N); 23860 end if; 23861 end if; 23862 end; 23863 23864 -- The field is an entity list 23865 23866 elsif Field in Elist_Range then 23867 Visit_Elist (Elist_Id (Field)); 23868 23869 -- The field is a syntax list 23870 23871 elsif Field in List_Range then 23872 declare 23873 List : constant List_Id := List_Id (Field); 23874 23875 begin 23876 -- A syntax list is visited when it is either a syntactic field 23877 -- or when the caller treats it as a semantic attribute. 23878 23879 if Parent (List) = Par_Nod or else Semantic then 23880 Visit_List (List); 23881 end if; 23882 end; 23883 23884 -- Otherwise the field denotes information which does not need to be 23885 -- visited (chars, literals, etc.). 23886 23887 else 23888 null; 23889 end if; 23890 end Visit_Field; 23891 23892 ----------------- 23893 -- Visit_Itype -- 23894 ----------------- 23895 23896 procedure Visit_Itype (Itype : Entity_Id) is 23897 New_Assoc : Node_Id; 23898 New_Itype : Entity_Id; 23899 Old_Assoc : Node_Id; 23900 23901 begin 23902 pragma Assert (Nkind (Itype) in N_Entity); 23903 pragma Assert (Is_Itype (Itype)); 23904 23905 -- Itypes that describe the designated type of access to subprograms 23906 -- have the structure of subprogram declarations, with signatures, 23907 -- etc. Either we duplicate the signatures completely, or choose to 23908 -- share such itypes, which is fine because their elaboration will 23909 -- have no side effects. 23910 23911 if Ekind (Itype) = E_Subprogram_Type then 23912 return; 23913 23914 -- Nothing to do if the itype was already visited 23915 23916 elsif NCT_Tables_In_Use 23917 and then Present (NCT_New_Entities.Get (Itype)) 23918 then 23919 return; 23920 23921 -- Nothing to do if the associated node of the itype is not within 23922 -- the subtree being replicated. 23923 23924 elsif not In_Subtree 23925 (N => Associated_Node_For_Itype (Itype), 23926 Root => Source) 23927 then 23928 return; 23929 end if; 23930 23931 -- Create a new itype by directly copying the old itype. This action 23932 -- causes all attributes of the old itype to be inherited. 23933 23934 New_Itype := New_Copy (Itype); 23935 23936 -- Create a new name for the new itype because the back end requires 23937 -- distinct names for debugging purposes. 23938 23939 Set_Chars (New_Itype, New_Internal_Name ('T')); 23940 23941 -- Update the Comes_From_Source and Sloc attributes of the itype in 23942 -- case the caller has supplied new values. 23943 23944 Update_CFS_Sloc (New_Itype); 23945 23946 -- Establish the following mapping within table NCT_New_Entities: 23947 23948 -- Itype -> New_Itype 23949 23950 Add_New_Entity (Itype, New_Itype); 23951 23952 -- The new itype must be unfrozen because the resulting subtree may 23953 -- be inserted anywhere and cause an earlier or later freezing. 23954 23955 if Present (Freeze_Node (New_Itype)) then 23956 Set_Freeze_Node (New_Itype, Empty); 23957 Set_Is_Frozen (New_Itype, False); 23958 end if; 23959 23960 -- If a record subtype is simply copied, the entity list will be 23961 -- shared. Thus cloned_Subtype must be set to indicate the sharing. 23962 -- ??? What does this do? 23963 23964 if Ekind (Itype) in E_Class_Wide_Subtype | E_Record_Subtype then 23965 Set_Cloned_Subtype (New_Itype, Itype); 23966 end if; 23967 23968 -- The associated node may denote an entity, in which case it may 23969 -- already have a new corresponding entity created during a prior 23970 -- call to Visit_Entity or Visit_Itype for the same subtree. 23971 23972 -- Given 23973 -- Old_Assoc ---------> New_Assoc 23974 23975 -- Created by Visit_Itype 23976 -- Itype -------------> New_Itype 23977 -- ANFI = Old_Assoc ANFI = Old_Assoc < must be updated 23978 23979 -- In the example above, Old_Assoc is an arbitrary entity that was 23980 -- already visited for the same subtree and has a corresponding new 23981 -- entity New_Assoc. Old_Assoc was inherited by New_Itype by virtue 23982 -- of copying entities, however it must be updated to New_Assoc. 23983 23984 Old_Assoc := Associated_Node_For_Itype (Itype); 23985 23986 if Nkind (Old_Assoc) in N_Entity then 23987 if NCT_Tables_In_Use then 23988 New_Assoc := NCT_New_Entities.Get (Old_Assoc); 23989 23990 if Present (New_Assoc) then 23991 Set_Associated_Node_For_Itype (New_Itype, New_Assoc); 23992 end if; 23993 end if; 23994 23995 -- Otherwise the associated node denotes a node. Postpone the update 23996 -- until Phase 2 when the node is replicated. Establish the following 23997 -- mapping within table NCT_Pending_Itypes: 23998 23999 -- Old_Assoc -> (New_Type, ...) 24000 24001 else 24002 Add_Pending_Itype (Old_Assoc, New_Itype); 24003 end if; 24004 24005 -- Deal with the semantic fields of itypes. The fields are visited 24006 -- because they may mention entities that reside within the subtree 24007 -- being copied. 24008 24009 Visit_Semantic_Fields (Itype); 24010 end Visit_Itype; 24011 24012 ---------------- 24013 -- Visit_List -- 24014 ---------------- 24015 24016 procedure Visit_List (List : List_Id) is 24017 Elmt : Node_Id; 24018 24019 begin 24020 -- Note that the element of a syntactic list is always a node, never 24021 -- an entity or itype, hence the call to Visit_Node. 24022 24023 if Present (List) then 24024 Elmt := First (List); 24025 while Present (Elmt) loop 24026 Visit_Node (Elmt); 24027 24028 Next (Elmt); 24029 end loop; 24030 end if; 24031 end Visit_List; 24032 24033 ---------------- 24034 -- Visit_Node -- 24035 ---------------- 24036 24037 procedure Visit_Node (N : Node_Or_Entity_Id) is 24038 begin 24039 pragma Assert (Nkind (N) not in N_Entity); 24040 24041 -- If the node is a quantified expression and expander is active, 24042 -- it contains an implicit declaration that may require a new entity 24043 -- when the condition has already been (pre)analyzed. 24044 24045 if Nkind (N) = N_Expression_With_Actions 24046 or else 24047 (Nkind (N) = N_Quantified_Expression and then Expander_Active) 24048 then 24049 EWA_Level := EWA_Level + 1; 24050 24051 elsif EWA_Level > 0 24052 and then Nkind (N) in N_Block_Statement 24053 | N_Subprogram_Body 24054 | N_Subprogram_Declaration 24055 then 24056 EWA_Inner_Scope_Level := EWA_Inner_Scope_Level + 1; 24057 end if; 24058 24059 Visit_Field 24060 (Field => Field1 (N), 24061 Par_Nod => N); 24062 24063 Visit_Field 24064 (Field => Field2 (N), 24065 Par_Nod => N); 24066 24067 Visit_Field 24068 (Field => Field3 (N), 24069 Par_Nod => N); 24070 24071 Visit_Field 24072 (Field => Field4 (N), 24073 Par_Nod => N); 24074 24075 Visit_Field 24076 (Field => Field5 (N), 24077 Par_Nod => N); 24078 24079 if EWA_Level > 0 24080 and then Nkind (N) in N_Block_Statement 24081 | N_Subprogram_Body 24082 | N_Subprogram_Declaration 24083 then 24084 EWA_Inner_Scope_Level := EWA_Inner_Scope_Level - 1; 24085 24086 elsif Nkind (N) = N_Expression_With_Actions then 24087 EWA_Level := EWA_Level - 1; 24088 end if; 24089 end Visit_Node; 24090 24091 --------------------------- 24092 -- Visit_Semantic_Fields -- 24093 --------------------------- 24094 24095 procedure Visit_Semantic_Fields (Id : Entity_Id) is 24096 begin 24097 pragma Assert (Nkind (Id) in N_Entity); 24098 24099 -- Discriminant_Constraint 24100 24101 if Is_Type (Id) and then Has_Discriminants (Base_Type (Id)) then 24102 Visit_Field 24103 (Field => Union_Id (Discriminant_Constraint (Id)), 24104 Semantic => True); 24105 end if; 24106 24107 -- Etype 24108 24109 Visit_Field 24110 (Field => Union_Id (Etype (Id)), 24111 Semantic => True); 24112 24113 -- First_Index 24114 -- Packed_Array_Impl_Type 24115 24116 if Is_Array_Type (Id) then 24117 if Present (First_Index (Id)) then 24118 Visit_Field 24119 (Field => Union_Id (List_Containing (First_Index (Id))), 24120 Semantic => True); 24121 end if; 24122 24123 if Is_Packed (Id) then 24124 Visit_Field 24125 (Field => Union_Id (Packed_Array_Impl_Type (Id)), 24126 Semantic => True); 24127 end if; 24128 end if; 24129 24130 -- Scalar_Range 24131 24132 if Is_Discrete_Type (Id) then 24133 Visit_Field 24134 (Field => Union_Id (Scalar_Range (Id)), 24135 Semantic => True); 24136 end if; 24137 end Visit_Semantic_Fields; 24138 24139 -- Start of processing for New_Copy_Tree 24140 24141 begin 24142 -- Routine New_Copy_Tree performs a deep copy of a subtree by creating 24143 -- shallow copies for each node within, and then updating the child and 24144 -- parent pointers accordingly. This process is straightforward, however 24145 -- the routine must deal with the following complications: 24146 24147 -- * Entities defined within N_Expression_With_Actions nodes must be 24148 -- replicated rather than shared to avoid introducing two identical 24149 -- symbols within the same scope. Note that no other expression can 24150 -- currently define entities. 24151 24152 -- do 24153 -- Source_Low : ...; 24154 -- Source_High : ...; 24155 24156 -- <reference to Source_Low> 24157 -- <reference to Source_High> 24158 -- in ... end; 24159 24160 -- New_Copy_Tree handles this case by first creating new entities 24161 -- and then updating all existing references to point to these new 24162 -- entities. 24163 24164 -- do 24165 -- New_Low : ...; 24166 -- New_High : ...; 24167 24168 -- <reference to New_Low> 24169 -- <reference to New_High> 24170 -- in ... end; 24171 24172 -- * Itypes defined within the subtree must be replicated to avoid any 24173 -- dependencies on invalid or inaccessible data. 24174 24175 -- subtype Source_Itype is ... range Source_Low .. Source_High; 24176 24177 -- New_Copy_Tree handles this case by first creating a new itype in 24178 -- the same fashion as entities, and then updating various relevant 24179 -- constraints. 24180 24181 -- subtype New_Itype is ... range New_Low .. New_High; 24182 24183 -- * The Associated_Node_For_Itype field of itypes must be updated to 24184 -- reference the proper replicated entity or node. 24185 24186 -- * Semantic fields of entities such as Etype and Scope must be 24187 -- updated to reference the proper replicated entities. 24188 24189 -- * Semantic fields of nodes such as First_Real_Statement must be 24190 -- updated to reference the proper replicated nodes. 24191 24192 -- Finally, quantified expressions contain an implicit delaration for 24193 -- the bound variable. Given that quantified expressions appearing 24194 -- in contracts are copied to create pragmas and eventually checking 24195 -- procedures, a new bound variable must be created for each copy, to 24196 -- prevent multiple declarations of the same symbol. 24197 24198 -- To meet all these demands, routine New_Copy_Tree is split into two 24199 -- phases. 24200 24201 -- Phase 1 traverses the tree in order to locate entities and itypes 24202 -- defined within the subtree. New entities are generated and saved in 24203 -- table NCT_New_Entities. The semantic fields of all new entities and 24204 -- itypes are then updated accordingly. 24205 24206 -- Phase 2 traverses the tree in order to replicate each node. Various 24207 -- semantic fields of nodes and entities are updated accordingly. 24208 24209 -- Preparatory phase. Clear the contents of tables NCT_New_Entities and 24210 -- NCT_Pending_Itypes in case a previous call to New_Copy_Tree left some 24211 -- data inside. 24212 24213 if NCT_Tables_In_Use then 24214 NCT_Tables_In_Use := False; 24215 24216 NCT_New_Entities.Reset; 24217 NCT_Pending_Itypes.Reset; 24218 end if; 24219 24220 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with data 24221 -- supplied by a linear entity map. The tables offer faster access to 24222 -- the same data. 24223 24224 Build_NCT_Tables (Map); 24225 24226 -- Execute Phase 1. Traverse the subtree and generate new entities for 24227 -- the following cases: 24228 24229 -- * An entity defined within an N_Expression_With_Actions node 24230 24231 -- * An itype referenced within the subtree where the associated node 24232 -- is also in the subtree. 24233 24234 -- All new entities are accessible via table NCT_New_Entities, which 24235 -- contains mappings of the form: 24236 24237 -- Old_Entity -> New_Entity 24238 -- Old_Itype -> New_Itype 24239 24240 -- In addition, the associated nodes of all new itypes are mapped in 24241 -- table NCT_Pending_Itypes: 24242 24243 -- Assoc_Nod -> (New_Itype1, New_Itype2, .., New_ItypeN) 24244 24245 Visit_Any_Node (Source); 24246 24247 -- Update the semantic attributes of all new entities generated during 24248 -- Phase 1 before starting Phase 2. The updates could be performed in 24249 -- routine Corresponding_Entity, however this may cause the same entity 24250 -- to be updated multiple times, effectively generating useless nodes. 24251 -- Keeping the updates separates from Phase 2 ensures that only one set 24252 -- of attributes is generated for an entity at any one time. 24253 24254 Update_New_Entities (Map); 24255 24256 -- Execute Phase 2. Replicate the source subtree one node at a time. 24257 -- The following transformations take place: 24258 24259 -- * References to entities and itypes are updated to refer to the 24260 -- new entities and itypes generated during Phase 1. 24261 24262 -- * All Associated_Node_For_Itype attributes of itypes are updated 24263 -- to refer to the new replicated Associated_Node_For_Itype. 24264 24265 return Copy_Node_With_Replacement (Source); 24266 end New_Copy_Tree; 24267 24268 ------------------------- 24269 -- New_External_Entity -- 24270 ------------------------- 24271 24272 function New_External_Entity 24273 (Kind : Entity_Kind; 24274 Scope_Id : Entity_Id; 24275 Sloc_Value : Source_Ptr; 24276 Related_Id : Entity_Id; 24277 Suffix : Character; 24278 Suffix_Index : Int := 0; 24279 Prefix : Character := ' ') return Entity_Id 24280 is 24281 N : constant Entity_Id := 24282 Make_Defining_Identifier (Sloc_Value, 24283 New_External_Name 24284 (Chars (Related_Id), Suffix, Suffix_Index, Prefix)); 24285 24286 begin 24287 Set_Ekind (N, Kind); 24288 Set_Is_Internal (N, True); 24289 Append_Entity (N, Scope_Id); 24290 Set_Public_Status (N); 24291 24292 if Kind in Type_Kind then 24293 Init_Size_Align (N); 24294 end if; 24295 24296 return N; 24297 end New_External_Entity; 24298 24299 ------------------------- 24300 -- New_Internal_Entity -- 24301 ------------------------- 24302 24303 function New_Internal_Entity 24304 (Kind : Entity_Kind; 24305 Scope_Id : Entity_Id; 24306 Sloc_Value : Source_Ptr; 24307 Id_Char : Character) return Entity_Id 24308 is 24309 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); 24310 24311 begin 24312 Set_Ekind (N, Kind); 24313 Set_Is_Internal (N, True); 24314 Append_Entity (N, Scope_Id); 24315 24316 if Kind in Type_Kind then 24317 Init_Size_Align (N); 24318 end if; 24319 24320 return N; 24321 end New_Internal_Entity; 24322 24323 ----------------- 24324 -- Next_Actual -- 24325 ----------------- 24326 24327 function Next_Actual (Actual_Id : Node_Id) return Node_Id is 24328 Par : constant Node_Id := Parent (Actual_Id); 24329 N : Node_Id; 24330 24331 begin 24332 -- If we are pointing at a positional parameter, it is a member of a 24333 -- node list (the list of parameters), and the next parameter is the 24334 -- next node on the list, unless we hit a parameter association, then 24335 -- we shift to using the chain whose head is the First_Named_Actual in 24336 -- the parent, and then is threaded using the Next_Named_Actual of the 24337 -- Parameter_Association. All this fiddling is because the original node 24338 -- list is in the textual call order, and what we need is the 24339 -- declaration order. 24340 24341 if Is_List_Member (Actual_Id) then 24342 N := Next (Actual_Id); 24343 24344 if Nkind (N) = N_Parameter_Association then 24345 24346 -- In case of a build-in-place call, the call will no longer be a 24347 -- call; it will have been rewritten. 24348 24349 if Nkind (Par) in N_Entry_Call_Statement 24350 | N_Function_Call 24351 | N_Procedure_Call_Statement 24352 then 24353 return First_Named_Actual (Par); 24354 24355 -- In case of a call rewritten in GNATprove mode while "inlining 24356 -- for proof" go to the original call. 24357 24358 elsif Nkind (Par) = N_Null_Statement then 24359 pragma Assert 24360 (GNATprove_Mode 24361 and then 24362 Nkind (Original_Node (Par)) in N_Subprogram_Call); 24363 24364 return First_Named_Actual (Original_Node (Par)); 24365 else 24366 return Empty; 24367 end if; 24368 else 24369 return N; 24370 end if; 24371 24372 else 24373 return Next_Named_Actual (Parent (Actual_Id)); 24374 end if; 24375 end Next_Actual; 24376 24377 procedure Next_Actual (Actual_Id : in out Node_Id) is 24378 begin 24379 Actual_Id := Next_Actual (Actual_Id); 24380 end Next_Actual; 24381 24382 ----------------- 24383 -- Next_Global -- 24384 ----------------- 24385 24386 function Next_Global (Node : Node_Id) return Node_Id is 24387 begin 24388 -- The global item may either be in a list, or by itself, in which case 24389 -- there is no next global item with the same mode. 24390 24391 if Is_List_Member (Node) then 24392 return Next (Node); 24393 else 24394 return Empty; 24395 end if; 24396 end Next_Global; 24397 24398 procedure Next_Global (Node : in out Node_Id) is 24399 begin 24400 Node := Next_Global (Node); 24401 end Next_Global; 24402 24403 ------------------------ 24404 -- No_Caching_Enabled -- 24405 ------------------------ 24406 24407 function No_Caching_Enabled (Id : Entity_Id) return Boolean is 24408 pragma Assert (Ekind (Id) = E_Variable); 24409 Prag : constant Node_Id := Get_Pragma (Id, Pragma_No_Caching); 24410 Arg1 : Node_Id; 24411 24412 begin 24413 if Present (Prag) then 24414 Arg1 := First (Pragma_Argument_Associations (Prag)); 24415 24416 -- The pragma has an optional Boolean expression, the related 24417 -- property is enabled only when the expression evaluates to True. 24418 24419 if Present (Arg1) then 24420 return Is_True (Expr_Value (Get_Pragma_Arg (Arg1))); 24421 24422 -- Otherwise the lack of expression enables the property by 24423 -- default. 24424 24425 else 24426 return True; 24427 end if; 24428 24429 -- The property was never set in the first place 24430 24431 else 24432 return False; 24433 end if; 24434 end No_Caching_Enabled; 24435 24436 -------------------------- 24437 -- No_Heap_Finalization -- 24438 -------------------------- 24439 24440 function No_Heap_Finalization (Typ : Entity_Id) return Boolean is 24441 begin 24442 if Ekind (Typ) in E_Access_Type | E_General_Access_Type 24443 and then Is_Library_Level_Entity (Typ) 24444 then 24445 -- A global No_Heap_Finalization pragma applies to all library-level 24446 -- named access-to-object types. 24447 24448 if Present (No_Heap_Finalization_Pragma) then 24449 return True; 24450 24451 -- The library-level named access-to-object type itself is subject to 24452 -- pragma No_Heap_Finalization. 24453 24454 elsif Present (Get_Pragma (Typ, Pragma_No_Heap_Finalization)) then 24455 return True; 24456 end if; 24457 end if; 24458 24459 return False; 24460 end No_Heap_Finalization; 24461 24462 ----------------------- 24463 -- Normalize_Actuals -- 24464 ----------------------- 24465 24466 -- Chain actuals according to formals of subprogram. If there are no named 24467 -- associations, the chain is simply the list of Parameter Associations, 24468 -- since the order is the same as the declaration order. If there are named 24469 -- associations, then the First_Named_Actual field in the N_Function_Call 24470 -- or N_Procedure_Call_Statement node points to the Parameter_Association 24471 -- node for the parameter that comes first in declaration order. The 24472 -- remaining named parameters are then chained in declaration order using 24473 -- Next_Named_Actual. 24474 24475 -- This routine also verifies that the number of actuals is compatible with 24476 -- the number and default values of formals, but performs no type checking 24477 -- (type checking is done by the caller). 24478 24479 -- If the matching succeeds, Success is set to True and the caller proceeds 24480 -- with type-checking. If the match is unsuccessful, then Success is set to 24481 -- False, and the caller attempts a different interpretation, if there is 24482 -- one. 24483 24484 -- If the flag Report is on, the call is not overloaded, and a failure to 24485 -- match can be reported here, rather than in the caller. 24486 24487 procedure Normalize_Actuals 24488 (N : Node_Id; 24489 S : Entity_Id; 24490 Report : Boolean; 24491 Success : out Boolean) 24492 is 24493 Actuals : constant List_Id := Parameter_Associations (N); 24494 Actual : Node_Id := Empty; 24495 Formal : Entity_Id; 24496 Last : Node_Id := Empty; 24497 First_Named : Node_Id := Empty; 24498 Found : Boolean; 24499 24500 Formals_To_Match : Integer := 0; 24501 Actuals_To_Match : Integer := 0; 24502 24503 procedure Chain (A : Node_Id); 24504 -- Add named actual at the proper place in the list, using the 24505 -- Next_Named_Actual link. 24506 24507 function Reporting return Boolean; 24508 -- Determines if an error is to be reported. To report an error, we 24509 -- need Report to be True, and also we do not report errors caused 24510 -- by calls to init procs that occur within other init procs. Such 24511 -- errors must always be cascaded errors, since if all the types are 24512 -- declared correctly, the compiler will certainly build decent calls. 24513 24514 ----------- 24515 -- Chain -- 24516 ----------- 24517 24518 procedure Chain (A : Node_Id) is 24519 begin 24520 if No (Last) then 24521 24522 -- Call node points to first actual in list 24523 24524 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A)); 24525 24526 else 24527 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A)); 24528 end if; 24529 24530 Last := A; 24531 Set_Next_Named_Actual (Last, Empty); 24532 end Chain; 24533 24534 --------------- 24535 -- Reporting -- 24536 --------------- 24537 24538 function Reporting return Boolean is 24539 begin 24540 if not Report then 24541 return False; 24542 24543 elsif not Within_Init_Proc then 24544 return True; 24545 24546 elsif Is_Init_Proc (Entity (Name (N))) then 24547 return False; 24548 24549 else 24550 return True; 24551 end if; 24552 end Reporting; 24553 24554 -- Start of processing for Normalize_Actuals 24555 24556 begin 24557 if Is_Access_Type (S) then 24558 24559 -- The name in the call is a function call that returns an access 24560 -- to subprogram. The designated type has the list of formals. 24561 24562 Formal := First_Formal (Designated_Type (S)); 24563 else 24564 Formal := First_Formal (S); 24565 end if; 24566 24567 while Present (Formal) loop 24568 Formals_To_Match := Formals_To_Match + 1; 24569 Next_Formal (Formal); 24570 end loop; 24571 24572 -- Find if there is a named association, and verify that no positional 24573 -- associations appear after named ones. 24574 24575 if Present (Actuals) then 24576 Actual := First (Actuals); 24577 end if; 24578 24579 while Present (Actual) 24580 and then Nkind (Actual) /= N_Parameter_Association 24581 loop 24582 Actuals_To_Match := Actuals_To_Match + 1; 24583 Next (Actual); 24584 end loop; 24585 24586 if No (Actual) and Actuals_To_Match = Formals_To_Match then 24587 24588 -- Most common case: positional notation, no defaults 24589 24590 Success := True; 24591 return; 24592 24593 elsif Actuals_To_Match > Formals_To_Match then 24594 24595 -- Too many actuals: will not work 24596 24597 if Reporting then 24598 if Is_Entity_Name (Name (N)) then 24599 Error_Msg_N ("too many arguments in call to&", Name (N)); 24600 else 24601 Error_Msg_N ("too many arguments in call", N); 24602 end if; 24603 end if; 24604 24605 Success := False; 24606 return; 24607 end if; 24608 24609 First_Named := Actual; 24610 24611 while Present (Actual) loop 24612 if Nkind (Actual) /= N_Parameter_Association then 24613 Error_Msg_N 24614 ("positional parameters not allowed after named ones", Actual); 24615 Success := False; 24616 return; 24617 24618 else 24619 Actuals_To_Match := Actuals_To_Match + 1; 24620 end if; 24621 24622 Next (Actual); 24623 end loop; 24624 24625 if Present (Actuals) then 24626 Actual := First (Actuals); 24627 end if; 24628 24629 Formal := First_Formal (S); 24630 while Present (Formal) loop 24631 24632 -- Match the formals in order. If the corresponding actual is 24633 -- positional, nothing to do. Else scan the list of named actuals 24634 -- to find the one with the right name. 24635 24636 if Present (Actual) 24637 and then Nkind (Actual) /= N_Parameter_Association 24638 then 24639 Next (Actual); 24640 Actuals_To_Match := Actuals_To_Match - 1; 24641 Formals_To_Match := Formals_To_Match - 1; 24642 24643 else 24644 -- For named parameters, search the list of actuals to find 24645 -- one that matches the next formal name. 24646 24647 Actual := First_Named; 24648 Found := False; 24649 while Present (Actual) loop 24650 if Chars (Selector_Name (Actual)) = Chars (Formal) then 24651 Found := True; 24652 Chain (Actual); 24653 Actuals_To_Match := Actuals_To_Match - 1; 24654 Formals_To_Match := Formals_To_Match - 1; 24655 exit; 24656 end if; 24657 24658 Next (Actual); 24659 end loop; 24660 24661 if not Found then 24662 if Ekind (Formal) /= E_In_Parameter 24663 or else No (Default_Value (Formal)) 24664 then 24665 if Reporting then 24666 if (Comes_From_Source (S) 24667 or else Sloc (S) = Standard_Location) 24668 and then Is_Overloadable (S) 24669 then 24670 if No (Actuals) 24671 and then 24672 Nkind (Parent (N)) in N_Procedure_Call_Statement 24673 | N_Function_Call 24674 | N_Parameter_Association 24675 and then Ekind (S) /= E_Function 24676 then 24677 Set_Etype (N, Etype (S)); 24678 24679 else 24680 Error_Msg_Name_1 := Chars (S); 24681 Error_Msg_Sloc := Sloc (S); 24682 Error_Msg_NE 24683 ("missing argument for parameter & " 24684 & "in call to % declared #", N, Formal); 24685 end if; 24686 24687 elsif Is_Overloadable (S) then 24688 Error_Msg_Name_1 := Chars (S); 24689 24690 -- Point to type derivation that generated the 24691 -- operation. 24692 24693 Error_Msg_Sloc := Sloc (Parent (S)); 24694 24695 Error_Msg_NE 24696 ("missing argument for parameter & " 24697 & "in call to % (inherited) #", N, Formal); 24698 24699 else 24700 Error_Msg_NE 24701 ("missing argument for parameter &", N, Formal); 24702 end if; 24703 end if; 24704 24705 Success := False; 24706 return; 24707 24708 else 24709 Formals_To_Match := Formals_To_Match - 1; 24710 end if; 24711 end if; 24712 end if; 24713 24714 Next_Formal (Formal); 24715 end loop; 24716 24717 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then 24718 Success := True; 24719 return; 24720 24721 else 24722 if Reporting then 24723 24724 -- Find some superfluous named actual that did not get 24725 -- attached to the list of associations. 24726 24727 Actual := First (Actuals); 24728 while Present (Actual) loop 24729 if Nkind (Actual) = N_Parameter_Association 24730 and then Actual /= Last 24731 and then No (Next_Named_Actual (Actual)) 24732 then 24733 -- A validity check may introduce a copy of a call that 24734 -- includes an extra actual (for example for an unrelated 24735 -- accessibility check). Check that the extra actual matches 24736 -- some extra formal, which must exist already because 24737 -- subprogram must be frozen at this point. 24738 24739 if Present (Extra_Formals (S)) 24740 and then not Comes_From_Source (Actual) 24741 and then Nkind (Actual) = N_Parameter_Association 24742 and then Chars (Extra_Formals (S)) = 24743 Chars (Selector_Name (Actual)) 24744 then 24745 null; 24746 else 24747 Error_Msg_N 24748 ("unmatched actual & in call", Selector_Name (Actual)); 24749 exit; 24750 end if; 24751 end if; 24752 24753 Next (Actual); 24754 end loop; 24755 end if; 24756 24757 Success := False; 24758 return; 24759 end if; 24760 end Normalize_Actuals; 24761 24762 -------------------------------- 24763 -- Note_Possible_Modification -- 24764 -------------------------------- 24765 24766 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is 24767 Modification_Comes_From_Source : constant Boolean := 24768 Comes_From_Source (Parent (N)); 24769 24770 Ent : Entity_Id; 24771 Exp : Node_Id; 24772 24773 begin 24774 -- Loop to find referenced entity, if there is one 24775 24776 Exp := N; 24777 loop 24778 Ent := Empty; 24779 24780 if Is_Entity_Name (Exp) then 24781 Ent := Entity (Exp); 24782 24783 -- If the entity is missing, it is an undeclared identifier, 24784 -- and there is nothing to annotate. 24785 24786 if No (Ent) then 24787 return; 24788 end if; 24789 24790 elsif Nkind (Exp) = N_Explicit_Dereference then 24791 declare 24792 P : constant Node_Id := Prefix (Exp); 24793 24794 begin 24795 -- In formal verification mode, keep track of all reads and 24796 -- writes through explicit dereferences. 24797 24798 if GNATprove_Mode then 24799 SPARK_Specific.Generate_Dereference (N, 'm'); 24800 end if; 24801 24802 if Nkind (P) = N_Selected_Component 24803 and then Present (Entry_Formal (Entity (Selector_Name (P)))) 24804 then 24805 -- Case of a reference to an entry formal 24806 24807 Ent := Entry_Formal (Entity (Selector_Name (P))); 24808 24809 elsif Nkind (P) = N_Identifier 24810 and then Nkind (Parent (Entity (P))) = N_Object_Declaration 24811 and then Present (Expression (Parent (Entity (P)))) 24812 and then Nkind (Expression (Parent (Entity (P)))) = 24813 N_Reference 24814 then 24815 -- Case of a reference to a value on which side effects have 24816 -- been removed. 24817 24818 Exp := Prefix (Expression (Parent (Entity (P)))); 24819 goto Continue; 24820 24821 else 24822 return; 24823 end if; 24824 end; 24825 24826 elsif Nkind (Exp) in N_Type_Conversion | N_Unchecked_Type_Conversion 24827 then 24828 Exp := Expression (Exp); 24829 goto Continue; 24830 24831 elsif Nkind (Exp) in 24832 N_Slice | N_Indexed_Component | N_Selected_Component 24833 then 24834 -- Special check, if the prefix is an access type, then return 24835 -- since we are modifying the thing pointed to, not the prefix. 24836 -- When we are expanding, most usually the prefix is replaced 24837 -- by an explicit dereference, and this test is not needed, but 24838 -- in some cases (notably -gnatc mode and generics) when we do 24839 -- not do full expansion, we need this special test. 24840 24841 if Is_Access_Type (Etype (Prefix (Exp))) then 24842 return; 24843 24844 -- Otherwise go to prefix and keep going 24845 24846 else 24847 Exp := Prefix (Exp); 24848 goto Continue; 24849 end if; 24850 24851 -- All other cases, not a modification 24852 24853 else 24854 return; 24855 end if; 24856 24857 -- Now look for entity being referenced 24858 24859 if Present (Ent) then 24860 if Is_Object (Ent) then 24861 if Comes_From_Source (Exp) 24862 or else Modification_Comes_From_Source 24863 then 24864 -- Give warning if pragma unmodified is given and we are 24865 -- sure this is a modification. 24866 24867 if Has_Pragma_Unmodified (Ent) and then Sure then 24868 24869 -- Note that the entity may be present only as a result 24870 -- of pragma Unused. 24871 24872 if Has_Pragma_Unused (Ent) then 24873 Error_Msg_NE ("??pragma Unused given for &!", N, Ent); 24874 else 24875 Error_Msg_NE 24876 ("??pragma Unmodified given for &!", N, Ent); 24877 end if; 24878 end if; 24879 24880 Set_Never_Set_In_Source (Ent, False); 24881 end if; 24882 24883 Set_Is_True_Constant (Ent, False); 24884 Set_Current_Value (Ent, Empty); 24885 Set_Is_Known_Null (Ent, False); 24886 24887 if not Can_Never_Be_Null (Ent) then 24888 Set_Is_Known_Non_Null (Ent, False); 24889 end if; 24890 24891 -- Follow renaming chain 24892 24893 if Ekind (Ent) in E_Variable | E_Constant 24894 and then Present (Renamed_Object (Ent)) 24895 then 24896 Exp := Renamed_Object (Ent); 24897 24898 -- If the entity is the loop variable in an iteration over 24899 -- a container, retrieve container expression to indicate 24900 -- possible modification. 24901 24902 if Present (Related_Expression (Ent)) 24903 and then Nkind (Parent (Related_Expression (Ent))) = 24904 N_Iterator_Specification 24905 then 24906 Exp := Original_Node (Related_Expression (Ent)); 24907 end if; 24908 24909 goto Continue; 24910 24911 -- The expression may be the renaming of a subcomponent of an 24912 -- array or container. The assignment to the subcomponent is 24913 -- a modification of the container. 24914 24915 elsif Comes_From_Source (Original_Node (Exp)) 24916 and then Nkind (Original_Node (Exp)) in 24917 N_Selected_Component | N_Indexed_Component 24918 then 24919 Exp := Prefix (Original_Node (Exp)); 24920 goto Continue; 24921 end if; 24922 24923 -- Generate a reference only if the assignment comes from 24924 -- source. This excludes, for example, calls to a dispatching 24925 -- assignment operation when the left-hand side is tagged. In 24926 -- GNATprove mode, we need those references also on generated 24927 -- code, as these are used to compute the local effects of 24928 -- subprograms. 24929 24930 if Modification_Comes_From_Source or GNATprove_Mode then 24931 Generate_Reference (Ent, Exp, 'm'); 24932 24933 -- If the target of the assignment is the bound variable 24934 -- in an iterator, indicate that the corresponding array 24935 -- or container is also modified. 24936 24937 if Ada_Version >= Ada_2012 24938 and then Nkind (Parent (Ent)) = N_Iterator_Specification 24939 then 24940 declare 24941 Domain : constant Node_Id := Name (Parent (Ent)); 24942 24943 begin 24944 -- TBD : in the full version of the construct, the 24945 -- domain of iteration can be given by an expression. 24946 24947 if Is_Entity_Name (Domain) then 24948 Generate_Reference (Entity (Domain), Exp, 'm'); 24949 Set_Is_True_Constant (Entity (Domain), False); 24950 Set_Never_Set_In_Source (Entity (Domain), False); 24951 end if; 24952 end; 24953 end if; 24954 end if; 24955 end if; 24956 24957 Kill_Checks (Ent); 24958 24959 -- If we are sure this is a modification from source, and we know 24960 -- this modifies a constant, then give an appropriate warning. 24961 24962 if Sure 24963 and then Modification_Comes_From_Source 24964 and then Overlays_Constant (Ent) 24965 and then Address_Clause_Overlay_Warnings 24966 then 24967 declare 24968 Addr : constant Node_Id := Address_Clause (Ent); 24969 O_Ent : Entity_Id; 24970 Off : Boolean; 24971 24972 begin 24973 Find_Overlaid_Entity (Addr, O_Ent, Off); 24974 24975 Error_Msg_Sloc := Sloc (Addr); 24976 Error_Msg_NE 24977 ("??constant& may be modified via address clause#", 24978 N, O_Ent); 24979 end; 24980 end if; 24981 24982 return; 24983 end if; 24984 24985 <<Continue>> 24986 null; 24987 end loop; 24988 end Note_Possible_Modification; 24989 24990 ----------------- 24991 -- Null_Status -- 24992 ----------------- 24993 24994 function Null_Status (N : Node_Id) return Null_Status_Kind is 24995 function Is_Null_Excluding_Def (Def : Node_Id) return Boolean; 24996 -- Determine whether definition Def carries a null exclusion 24997 24998 function Null_Status_Of_Entity (Id : Entity_Id) return Null_Status_Kind; 24999 -- Determine the null status of arbitrary entity Id 25000 25001 function Null_Status_Of_Type (Typ : Entity_Id) return Null_Status_Kind; 25002 -- Determine the null status of type Typ 25003 25004 --------------------------- 25005 -- Is_Null_Excluding_Def -- 25006 --------------------------- 25007 25008 function Is_Null_Excluding_Def (Def : Node_Id) return Boolean is 25009 begin 25010 return Nkind (Def) in N_Access_Definition 25011 | N_Access_Function_Definition 25012 | N_Access_Procedure_Definition 25013 | N_Access_To_Object_Definition 25014 | N_Component_Definition 25015 | N_Derived_Type_Definition 25016 and then Null_Exclusion_Present (Def); 25017 end Is_Null_Excluding_Def; 25018 25019 --------------------------- 25020 -- Null_Status_Of_Entity -- 25021 --------------------------- 25022 25023 function Null_Status_Of_Entity 25024 (Id : Entity_Id) return Null_Status_Kind 25025 is 25026 Decl : constant Node_Id := Declaration_Node (Id); 25027 Def : Node_Id; 25028 25029 begin 25030 -- The value of an imported or exported entity may be set externally 25031 -- regardless of a null exclusion. As a result, the value cannot be 25032 -- determined statically. 25033 25034 if Is_Imported (Id) or else Is_Exported (Id) then 25035 return Unknown; 25036 25037 elsif Nkind (Decl) in N_Component_Declaration 25038 | N_Discriminant_Specification 25039 | N_Formal_Object_Declaration 25040 | N_Object_Declaration 25041 | N_Object_Renaming_Declaration 25042 | N_Parameter_Specification 25043 then 25044 -- A component declaration yields a non-null value when either 25045 -- its component definition or access definition carries a null 25046 -- exclusion. 25047 25048 if Nkind (Decl) = N_Component_Declaration then 25049 Def := Component_Definition (Decl); 25050 25051 if Is_Null_Excluding_Def (Def) then 25052 return Is_Non_Null; 25053 end if; 25054 25055 Def := Access_Definition (Def); 25056 25057 if Present (Def) and then Is_Null_Excluding_Def (Def) then 25058 return Is_Non_Null; 25059 end if; 25060 25061 -- A formal object declaration yields a non-null value if its 25062 -- access definition carries a null exclusion. If the object is 25063 -- default initialized, then the value depends on the expression. 25064 25065 elsif Nkind (Decl) = N_Formal_Object_Declaration then 25066 Def := Access_Definition (Decl); 25067 25068 if Present (Def) and then Is_Null_Excluding_Def (Def) then 25069 return Is_Non_Null; 25070 end if; 25071 25072 -- A constant may yield a null or non-null value depending on its 25073 -- initialization expression. 25074 25075 elsif Ekind (Id) = E_Constant then 25076 return Null_Status (Constant_Value (Id)); 25077 25078 -- The construct yields a non-null value when it has a null 25079 -- exclusion. 25080 25081 elsif Null_Exclusion_Present (Decl) then 25082 return Is_Non_Null; 25083 25084 -- An object renaming declaration yields a non-null value if its 25085 -- access definition carries a null exclusion. Otherwise the value 25086 -- depends on the renamed name. 25087 25088 elsif Nkind (Decl) = N_Object_Renaming_Declaration then 25089 Def := Access_Definition (Decl); 25090 25091 if Present (Def) and then Is_Null_Excluding_Def (Def) then 25092 return Is_Non_Null; 25093 25094 else 25095 return Null_Status (Name (Decl)); 25096 end if; 25097 end if; 25098 end if; 25099 25100 -- At this point the declaration of the entity does not carry a null 25101 -- exclusion and lacks an initialization expression. Check the status 25102 -- of its type. 25103 25104 return Null_Status_Of_Type (Etype (Id)); 25105 end Null_Status_Of_Entity; 25106 25107 ------------------------- 25108 -- Null_Status_Of_Type -- 25109 ------------------------- 25110 25111 function Null_Status_Of_Type (Typ : Entity_Id) return Null_Status_Kind is 25112 Curr : Entity_Id; 25113 Decl : Node_Id; 25114 25115 begin 25116 -- Traverse the type chain looking for types with null exclusion 25117 25118 Curr := Typ; 25119 while Present (Curr) and then Etype (Curr) /= Curr loop 25120 Decl := Parent (Curr); 25121 25122 -- Guard against itypes which do not always have declarations. A 25123 -- type yields a non-null value if it carries a null exclusion. 25124 25125 if Present (Decl) then 25126 if Nkind (Decl) = N_Full_Type_Declaration 25127 and then Is_Null_Excluding_Def (Type_Definition (Decl)) 25128 then 25129 return Is_Non_Null; 25130 25131 elsif Nkind (Decl) = N_Subtype_Declaration 25132 and then Null_Exclusion_Present (Decl) 25133 then 25134 return Is_Non_Null; 25135 end if; 25136 end if; 25137 25138 Curr := Etype (Curr); 25139 end loop; 25140 25141 -- The type chain does not contain any null excluding types 25142 25143 return Unknown; 25144 end Null_Status_Of_Type; 25145 25146 -- Start of processing for Null_Status 25147 25148 begin 25149 -- Prevent cascaded errors or infinite loops when trying to determine 25150 -- the null status of an erroneous construct. 25151 25152 if Error_Posted (N) then 25153 return Unknown; 25154 25155 -- An allocator always creates a non-null value 25156 25157 elsif Nkind (N) = N_Allocator then 25158 return Is_Non_Null; 25159 25160 -- Taking the 'Access of something yields a non-null value 25161 25162 elsif Nkind (N) = N_Attribute_Reference 25163 and then Attribute_Name (N) in Name_Access 25164 | Name_Unchecked_Access 25165 | Name_Unrestricted_Access 25166 then 25167 return Is_Non_Null; 25168 25169 -- "null" yields null 25170 25171 elsif Nkind (N) = N_Null then 25172 return Is_Null; 25173 25174 -- Check the status of the operand of a type conversion 25175 25176 elsif Nkind (N) = N_Type_Conversion then 25177 return Null_Status (Expression (N)); 25178 25179 -- The input denotes a reference to an entity. Determine whether the 25180 -- entity or its type yields a null or non-null value. 25181 25182 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 25183 return Null_Status_Of_Entity (Entity (N)); 25184 end if; 25185 25186 -- Otherwise it is not possible to determine the null status of the 25187 -- subexpression at compile time without resorting to simple flow 25188 -- analysis. 25189 25190 return Unknown; 25191 end Null_Status; 25192 25193 -------------------------------------- 25194 -- Null_To_Null_Address_Convert_OK -- 25195 -------------------------------------- 25196 25197 function Null_To_Null_Address_Convert_OK 25198 (N : Node_Id; 25199 Typ : Entity_Id := Empty) return Boolean 25200 is 25201 begin 25202 if not Relaxed_RM_Semantics then 25203 return False; 25204 end if; 25205 25206 if Nkind (N) = N_Null then 25207 return Present (Typ) and then Is_Descendant_Of_Address (Typ); 25208 25209 elsif Nkind (N) in 25210 N_Op_Eq | N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt | N_Op_Ne 25211 then 25212 declare 25213 L : constant Node_Id := Left_Opnd (N); 25214 R : constant Node_Id := Right_Opnd (N); 25215 25216 begin 25217 -- We check the Etype of the complementary operand since the 25218 -- N_Null node is not decorated at this stage. 25219 25220 return 25221 ((Nkind (L) = N_Null 25222 and then Is_Descendant_Of_Address (Etype (R))) 25223 or else 25224 (Nkind (R) = N_Null 25225 and then Is_Descendant_Of_Address (Etype (L)))); 25226 end; 25227 end if; 25228 25229 return False; 25230 end Null_To_Null_Address_Convert_OK; 25231 25232 --------------------------------- 25233 -- Number_Of_Elements_In_Array -- 25234 --------------------------------- 25235 25236 function Number_Of_Elements_In_Array (T : Entity_Id) return Int is 25237 Indx : Node_Id; 25238 Typ : Entity_Id; 25239 Low : Node_Id; 25240 High : Node_Id; 25241 Num : Int := 1; 25242 25243 begin 25244 pragma Assert (Is_Array_Type (T)); 25245 25246 Indx := First_Index (T); 25247 while Present (Indx) loop 25248 Typ := Underlying_Type (Etype (Indx)); 25249 25250 -- Never look at junk bounds of a generic type 25251 25252 if Is_Generic_Type (Typ) then 25253 return 0; 25254 end if; 25255 25256 -- Check the array bounds are known at compile time and return zero 25257 -- if they are not. 25258 25259 Low := Type_Low_Bound (Typ); 25260 High := Type_High_Bound (Typ); 25261 25262 if not Compile_Time_Known_Value (Low) then 25263 return 0; 25264 elsif not Compile_Time_Known_Value (High) then 25265 return 0; 25266 else 25267 Num := 25268 Num * UI_To_Int ((Expr_Value (High) - Expr_Value (Low) + 1)); 25269 end if; 25270 25271 Next_Index (Indx); 25272 end loop; 25273 25274 return Num; 25275 end Number_Of_Elements_In_Array; 25276 25277 --------------------------------- 25278 -- Original_Aspect_Pragma_Name -- 25279 --------------------------------- 25280 25281 function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id is 25282 Item : Node_Id; 25283 Item_Nam : Name_Id; 25284 25285 begin 25286 pragma Assert (Nkind (N) in N_Aspect_Specification | N_Pragma); 25287 25288 Item := N; 25289 25290 -- The pragma was generated to emulate an aspect, use the original 25291 -- aspect specification. 25292 25293 if Nkind (Item) = N_Pragma and then From_Aspect_Specification (Item) then 25294 Item := Corresponding_Aspect (Item); 25295 end if; 25296 25297 -- Retrieve the name of the aspect/pragma. As assertion pragmas from 25298 -- a generic instantiation might have been rewritten into pragma Check, 25299 -- we look at the original node for Item. Note also that Pre, Pre_Class, 25300 -- Post and Post_Class rewrite their pragma identifier to preserve the 25301 -- original name, so we look at the original node for the identifier. 25302 -- ??? this is kludgey 25303 25304 if Nkind (Item) = N_Pragma then 25305 Item_Nam := 25306 Chars (Original_Node (Pragma_Identifier (Original_Node (Item)))); 25307 25308 else 25309 pragma Assert (Nkind (Item) = N_Aspect_Specification); 25310 Item_Nam := Chars (Identifier (Item)); 25311 end if; 25312 25313 -- Deal with 'Class by converting the name to its _XXX form 25314 25315 if Class_Present (Item) then 25316 if Item_Nam = Name_Invariant then 25317 Item_Nam := Name_uInvariant; 25318 25319 elsif Item_Nam = Name_Post then 25320 Item_Nam := Name_uPost; 25321 25322 elsif Item_Nam = Name_Pre then 25323 Item_Nam := Name_uPre; 25324 25325 elsif Item_Nam in Name_Type_Invariant | Name_Type_Invariant_Class 25326 then 25327 Item_Nam := Name_uType_Invariant; 25328 25329 -- Nothing to do for other cases (e.g. a Check that derived from 25330 -- Pre_Class and has the flag set). Also we do nothing if the name 25331 -- is already in special _xxx form. 25332 25333 end if; 25334 end if; 25335 25336 return Item_Nam; 25337 end Original_Aspect_Pragma_Name; 25338 25339 -------------------------------------- 25340 -- Original_Corresponding_Operation -- 25341 -------------------------------------- 25342 25343 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id 25344 is 25345 Typ : constant Entity_Id := Find_Dispatching_Type (S); 25346 25347 begin 25348 -- If S is an inherited primitive S2 the original corresponding 25349 -- operation of S is the original corresponding operation of S2 25350 25351 if Present (Alias (S)) 25352 and then Find_Dispatching_Type (Alias (S)) /= Typ 25353 then 25354 return Original_Corresponding_Operation (Alias (S)); 25355 25356 -- If S overrides an inherited subprogram S2 the original corresponding 25357 -- operation of S is the original corresponding operation of S2 25358 25359 elsif Present (Overridden_Operation (S)) then 25360 return Original_Corresponding_Operation (Overridden_Operation (S)); 25361 25362 -- otherwise it is S itself 25363 25364 else 25365 return S; 25366 end if; 25367 end Original_Corresponding_Operation; 25368 25369 ------------------- 25370 -- Output_Entity -- 25371 ------------------- 25372 25373 procedure Output_Entity (Id : Entity_Id) is 25374 Scop : Entity_Id; 25375 25376 begin 25377 Scop := Scope (Id); 25378 25379 -- The entity may lack a scope when it is in the process of being 25380 -- analyzed. Use the current scope as an approximation. 25381 25382 if No (Scop) then 25383 Scop := Current_Scope; 25384 end if; 25385 25386 Output_Name (Chars (Id), Scop); 25387 end Output_Entity; 25388 25389 ----------------- 25390 -- Output_Name -- 25391 ----------------- 25392 25393 procedure Output_Name (Nam : Name_Id; Scop : Entity_Id := Current_Scope) is 25394 begin 25395 Write_Str 25396 (Get_Name_String 25397 (Get_Qualified_Name 25398 (Nam => Nam, 25399 Suffix => No_Name, 25400 Scop => Scop))); 25401 Write_Eol; 25402 end Output_Name; 25403 25404 ------------------ 25405 -- Param_Entity -- 25406 ------------------ 25407 25408 -- This would be trivial, simply a test for an identifier that was a 25409 -- reference to a formal, if it were not for the fact that a previous call 25410 -- to Expand_Entry_Parameter will have modified the reference to the 25411 -- identifier. A formal of a protected entity is rewritten as 25412 25413 -- typ!(recobj).rec.all'Constrained 25414 25415 -- where rec is a selector whose Entry_Formal link points to the formal 25416 25417 -- If the type of the entry parameter has a representation clause, then an 25418 -- extra temp is involved (see below). 25419 25420 -- For a formal of a task entity, the formal is rewritten as a local 25421 -- renaming. 25422 25423 -- In addition, a formal that is marked volatile because it is aliased 25424 -- through an address clause is rewritten as dereference as well. 25425 25426 function Param_Entity (N : Node_Id) return Entity_Id is 25427 Renamed_Obj : Node_Id; 25428 25429 begin 25430 -- Simple reference case 25431 25432 if Nkind (N) in N_Identifier | N_Expanded_Name then 25433 if Is_Formal (Entity (N)) then 25434 return Entity (N); 25435 25436 -- Handle renamings of formal parameters and formals of tasks that 25437 -- are rewritten as renamings. 25438 25439 elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then 25440 Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N))); 25441 25442 if Is_Entity_Name (Renamed_Obj) 25443 and then Is_Formal (Entity (Renamed_Obj)) 25444 then 25445 return Entity (Renamed_Obj); 25446 25447 elsif 25448 Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement 25449 then 25450 return Entity (N); 25451 end if; 25452 end if; 25453 25454 else 25455 if Nkind (N) = N_Explicit_Dereference then 25456 declare 25457 P : Node_Id := Prefix (N); 25458 S : Node_Id; 25459 E : Entity_Id; 25460 Decl : Node_Id; 25461 25462 begin 25463 -- If the type of an entry parameter has a representation 25464 -- clause, then the prefix is not a selected component, but 25465 -- instead a reference to a temp pointing at the selected 25466 -- component. In this case, set P to be the initial value of 25467 -- that temp. 25468 25469 if Nkind (P) = N_Identifier then 25470 E := Entity (P); 25471 25472 if Ekind (E) = E_Constant then 25473 Decl := Parent (E); 25474 25475 if Nkind (Decl) = N_Object_Declaration then 25476 P := Expression (Decl); 25477 end if; 25478 end if; 25479 end if; 25480 25481 if Nkind (P) = N_Selected_Component then 25482 S := Selector_Name (P); 25483 25484 if Present (Entry_Formal (Entity (S))) then 25485 return Entry_Formal (Entity (S)); 25486 end if; 25487 25488 elsif Nkind (Original_Node (N)) = N_Identifier then 25489 return Param_Entity (Original_Node (N)); 25490 end if; 25491 end; 25492 end if; 25493 end if; 25494 25495 return Empty; 25496 end Param_Entity; 25497 25498 ---------------------- 25499 -- Policy_In_Effect -- 25500 ---------------------- 25501 25502 function Policy_In_Effect (Policy : Name_Id) return Name_Id is 25503 function Policy_In_List (List : Node_Id) return Name_Id; 25504 -- Determine the mode of a policy in a N_Pragma list 25505 25506 -------------------- 25507 -- Policy_In_List -- 25508 -------------------- 25509 25510 function Policy_In_List (List : Node_Id) return Name_Id is 25511 Arg1 : Node_Id; 25512 Arg2 : Node_Id; 25513 Prag : Node_Id; 25514 25515 begin 25516 Prag := List; 25517 while Present (Prag) loop 25518 Arg1 := First (Pragma_Argument_Associations (Prag)); 25519 Arg2 := Next (Arg1); 25520 25521 Arg1 := Get_Pragma_Arg (Arg1); 25522 Arg2 := Get_Pragma_Arg (Arg2); 25523 25524 -- The current Check_Policy pragma matches the requested policy or 25525 -- appears in the single argument form (Assertion, policy_id). 25526 25527 if Chars (Arg1) in Name_Assertion | Policy then 25528 return Chars (Arg2); 25529 end if; 25530 25531 Prag := Next_Pragma (Prag); 25532 end loop; 25533 25534 return No_Name; 25535 end Policy_In_List; 25536 25537 -- Local variables 25538 25539 Kind : Name_Id; 25540 25541 -- Start of processing for Policy_In_Effect 25542 25543 begin 25544 if not Is_Valid_Assertion_Kind (Policy) then 25545 raise Program_Error; 25546 end if; 25547 25548 -- Inspect all policy pragmas that appear within scopes (if any) 25549 25550 Kind := Policy_In_List (Check_Policy_List); 25551 25552 -- Inspect all configuration policy pragmas (if any) 25553 25554 if Kind = No_Name then 25555 Kind := Policy_In_List (Check_Policy_List_Config); 25556 end if; 25557 25558 -- The context lacks policy pragmas, determine the mode based on whether 25559 -- assertions are enabled at the configuration level. This ensures that 25560 -- the policy is preserved when analyzing generics. 25561 25562 if Kind = No_Name then 25563 if Assertions_Enabled_Config then 25564 Kind := Name_Check; 25565 else 25566 Kind := Name_Ignore; 25567 end if; 25568 end if; 25569 25570 -- In CodePeer mode and GNATprove mode, we need to consider all 25571 -- assertions, unless they are disabled. Force Name_Check on 25572 -- ignored assertions. 25573 25574 if Kind in Name_Ignore | Name_Off 25575 and then (CodePeer_Mode or GNATprove_Mode) 25576 then 25577 Kind := Name_Check; 25578 end if; 25579 25580 return Kind; 25581 end Policy_In_Effect; 25582 25583 ------------------------------- 25584 -- Preanalyze_Without_Errors -- 25585 ------------------------------- 25586 25587 procedure Preanalyze_Without_Errors (N : Node_Id) is 25588 Status : constant Boolean := Get_Ignore_Errors; 25589 begin 25590 Set_Ignore_Errors (True); 25591 Preanalyze (N); 25592 Set_Ignore_Errors (Status); 25593 end Preanalyze_Without_Errors; 25594 25595 ----------------------- 25596 -- Predicate_Enabled -- 25597 ----------------------- 25598 25599 function Predicate_Enabled (Typ : Entity_Id) return Boolean is 25600 begin 25601 return Present (Predicate_Function (Typ)) 25602 and then not Predicates_Ignored (Typ) 25603 and then not Predicate_Checks_Suppressed (Empty); 25604 end Predicate_Enabled; 25605 25606 ---------------------------------- 25607 -- Predicate_Tests_On_Arguments -- 25608 ---------------------------------- 25609 25610 function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean is 25611 begin 25612 -- Always test predicates on indirect call 25613 25614 if Ekind (Subp) = E_Subprogram_Type then 25615 return True; 25616 25617 -- Do not test predicates on call to generated default Finalize, since 25618 -- we are not interested in whether something we are finalizing (and 25619 -- typically destroying) satisfies its predicates. 25620 25621 elsif Chars (Subp) = Name_Finalize 25622 and then not Comes_From_Source (Subp) 25623 then 25624 return False; 25625 25626 -- Do not test predicates on any internally generated routines 25627 25628 elsif Is_Internal_Name (Chars (Subp)) then 25629 return False; 25630 25631 -- Do not test predicates on call to Init_Proc, since if needed the 25632 -- predicate test will occur at some other point. 25633 25634 elsif Is_Init_Proc (Subp) then 25635 return False; 25636 25637 -- Do not test predicates on call to predicate function, since this 25638 -- would cause infinite recursion. 25639 25640 elsif Ekind (Subp) = E_Function 25641 and then (Is_Predicate_Function (Subp) 25642 or else 25643 Is_Predicate_Function_M (Subp)) 25644 then 25645 return False; 25646 25647 -- For now, no other exceptions 25648 25649 else 25650 return True; 25651 end if; 25652 end Predicate_Tests_On_Arguments; 25653 25654 ----------------------- 25655 -- Private_Component -- 25656 ----------------------- 25657 25658 function Private_Component (Type_Id : Entity_Id) return Entity_Id is 25659 Ancestor : constant Entity_Id := Base_Type (Type_Id); 25660 25661 function Trace_Components 25662 (T : Entity_Id; 25663 Check : Boolean) return Entity_Id; 25664 -- Recursive function that does the work, and checks against circular 25665 -- definition for each subcomponent type. 25666 25667 ---------------------- 25668 -- Trace_Components -- 25669 ---------------------- 25670 25671 function Trace_Components 25672 (T : Entity_Id; 25673 Check : Boolean) return Entity_Id 25674 is 25675 Btype : constant Entity_Id := Base_Type (T); 25676 Component : Entity_Id; 25677 P : Entity_Id; 25678 Candidate : Entity_Id := Empty; 25679 25680 begin 25681 if Check and then Btype = Ancestor then 25682 Error_Msg_N ("circular type definition", Type_Id); 25683 return Any_Type; 25684 end if; 25685 25686 if Is_Private_Type (Btype) and then not Is_Generic_Type (Btype) then 25687 if Present (Full_View (Btype)) 25688 and then Is_Record_Type (Full_View (Btype)) 25689 and then not Is_Frozen (Btype) 25690 then 25691 -- To indicate that the ancestor depends on a private type, the 25692 -- current Btype is sufficient. However, to check for circular 25693 -- definition we must recurse on the full view. 25694 25695 Candidate := Trace_Components (Full_View (Btype), True); 25696 25697 if Candidate = Any_Type then 25698 return Any_Type; 25699 else 25700 return Btype; 25701 end if; 25702 25703 else 25704 return Btype; 25705 end if; 25706 25707 elsif Is_Array_Type (Btype) then 25708 return Trace_Components (Component_Type (Btype), True); 25709 25710 elsif Is_Record_Type (Btype) then 25711 Component := First_Entity (Btype); 25712 while Present (Component) 25713 and then Comes_From_Source (Component) 25714 loop 25715 -- Skip anonymous types generated by constrained components 25716 25717 if not Is_Type (Component) then 25718 P := Trace_Components (Etype (Component), True); 25719 25720 if Present (P) then 25721 if P = Any_Type then 25722 return P; 25723 else 25724 Candidate := P; 25725 end if; 25726 end if; 25727 end if; 25728 25729 Next_Entity (Component); 25730 end loop; 25731 25732 return Candidate; 25733 25734 else 25735 return Empty; 25736 end if; 25737 end Trace_Components; 25738 25739 -- Start of processing for Private_Component 25740 25741 begin 25742 return Trace_Components (Type_Id, False); 25743 end Private_Component; 25744 25745 --------------------------- 25746 -- Primitive_Names_Match -- 25747 --------------------------- 25748 25749 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is 25750 function Non_Internal_Name (E : Entity_Id) return Name_Id; 25751 -- Given an internal name, returns the corresponding non-internal name 25752 25753 ------------------------ 25754 -- Non_Internal_Name -- 25755 ------------------------ 25756 25757 function Non_Internal_Name (E : Entity_Id) return Name_Id is 25758 begin 25759 Get_Name_String (Chars (E)); 25760 Name_Len := Name_Len - 1; 25761 return Name_Find; 25762 end Non_Internal_Name; 25763 25764 -- Start of processing for Primitive_Names_Match 25765 25766 begin 25767 pragma Assert (Present (E1) and then Present (E2)); 25768 25769 return Chars (E1) = Chars (E2) 25770 or else 25771 (not Is_Internal_Name (Chars (E1)) 25772 and then Is_Internal_Name (Chars (E2)) 25773 and then Non_Internal_Name (E2) = Chars (E1)) 25774 or else 25775 (not Is_Internal_Name (Chars (E2)) 25776 and then Is_Internal_Name (Chars (E1)) 25777 and then Non_Internal_Name (E1) = Chars (E2)) 25778 or else 25779 (Is_Predefined_Dispatching_Operation (E1) 25780 and then Is_Predefined_Dispatching_Operation (E2) 25781 and then Same_TSS (E1, E2)) 25782 or else 25783 (Is_Init_Proc (E1) and then Is_Init_Proc (E2)); 25784 end Primitive_Names_Match; 25785 25786 ----------------------- 25787 -- Process_End_Label -- 25788 ----------------------- 25789 25790 procedure Process_End_Label 25791 (N : Node_Id; 25792 Typ : Character; 25793 Ent : Entity_Id) 25794 is 25795 Loc : Source_Ptr; 25796 Nam : Node_Id; 25797 Scop : Entity_Id; 25798 25799 Label_Ref : Boolean; 25800 -- Set True if reference to end label itself is required 25801 25802 Endl : Node_Id; 25803 -- Gets set to the operator symbol or identifier that references the 25804 -- entity Ent. For the child unit case, this is the identifier from the 25805 -- designator. For other cases, this is simply Endl. 25806 25807 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id); 25808 -- N is an identifier node that appears as a parent unit reference in 25809 -- the case where Ent is a child unit. This procedure generates an 25810 -- appropriate cross-reference entry. E is the corresponding entity. 25811 25812 ------------------------- 25813 -- Generate_Parent_Ref -- 25814 ------------------------- 25815 25816 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is 25817 begin 25818 -- If names do not match, something weird, skip reference 25819 25820 if Chars (E) = Chars (N) then 25821 25822 -- Generate the reference. We do NOT consider this as a reference 25823 -- for unreferenced symbol purposes. 25824 25825 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True); 25826 25827 if Style_Check then 25828 Style.Check_Identifier (N, E); 25829 end if; 25830 end if; 25831 end Generate_Parent_Ref; 25832 25833 -- Start of processing for Process_End_Label 25834 25835 begin 25836 -- If no node, ignore. This happens in some error situations, and 25837 -- also for some internally generated structures where no end label 25838 -- references are required in any case. 25839 25840 if No (N) then 25841 return; 25842 end if; 25843 25844 -- Nothing to do if no End_Label, happens for internally generated 25845 -- constructs where we don't want an end label reference anyway. Also 25846 -- nothing to do if Endl is a string literal, which means there was 25847 -- some prior error (bad operator symbol) 25848 25849 Endl := End_Label (N); 25850 25851 if No (Endl) or else Nkind (Endl) = N_String_Literal then 25852 return; 25853 end if; 25854 25855 -- Reference node is not in extended main source unit 25856 25857 if not In_Extended_Main_Source_Unit (N) then 25858 25859 -- Generally we do not collect references except for the extended 25860 -- main source unit. The one exception is the 'e' entry for a 25861 -- package spec, where it is useful for a client to have the 25862 -- ending information to define scopes. 25863 25864 if Typ /= 'e' then 25865 return; 25866 25867 else 25868 Label_Ref := False; 25869 25870 -- For this case, we can ignore any parent references, but we 25871 -- need the package name itself for the 'e' entry. 25872 25873 if Nkind (Endl) = N_Designator then 25874 Endl := Identifier (Endl); 25875 end if; 25876 end if; 25877 25878 -- Reference is in extended main source unit 25879 25880 else 25881 Label_Ref := True; 25882 25883 -- For designator, generate references for the parent entries 25884 25885 if Nkind (Endl) = N_Designator then 25886 25887 -- Generate references for the prefix if the END line comes from 25888 -- source (otherwise we do not need these references) We climb the 25889 -- scope stack to find the expected entities. 25890 25891 if Comes_From_Source (Endl) then 25892 Nam := Name (Endl); 25893 Scop := Current_Scope; 25894 while Nkind (Nam) = N_Selected_Component loop 25895 Scop := Scope (Scop); 25896 exit when No (Scop); 25897 Generate_Parent_Ref (Selector_Name (Nam), Scop); 25898 Nam := Prefix (Nam); 25899 end loop; 25900 25901 if Present (Scop) then 25902 Generate_Parent_Ref (Nam, Scope (Scop)); 25903 end if; 25904 end if; 25905 25906 Endl := Identifier (Endl); 25907 end if; 25908 end if; 25909 25910 -- If the end label is not for the given entity, then either we have 25911 -- some previous error, or this is a generic instantiation for which 25912 -- we do not need to make a cross-reference in this case anyway. In 25913 -- either case we simply ignore the call. 25914 25915 if Chars (Ent) /= Chars (Endl) then 25916 return; 25917 end if; 25918 25919 -- If label was really there, then generate a normal reference and then 25920 -- adjust the location in the end label to point past the name (which 25921 -- should almost always be the semicolon). 25922 25923 Loc := Sloc (Endl); 25924 25925 if Comes_From_Source (Endl) then 25926 25927 -- If a label reference is required, then do the style check and 25928 -- generate an l-type cross-reference entry for the label 25929 25930 if Label_Ref then 25931 if Style_Check then 25932 Style.Check_Identifier (Endl, Ent); 25933 end if; 25934 25935 Generate_Reference (Ent, Endl, 'l', Set_Ref => False); 25936 end if; 25937 25938 -- Set the location to point past the label (normally this will 25939 -- mean the semicolon immediately following the label). This is 25940 -- done for the sake of the 'e' or 't' entry generated below. 25941 25942 Get_Decoded_Name_String (Chars (Endl)); 25943 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len)); 25944 end if; 25945 25946 -- Now generate the e/t reference 25947 25948 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True); 25949 25950 -- Restore Sloc, in case modified above, since we have an identifier 25951 -- and the normal Sloc should be left set in the tree. 25952 25953 Set_Sloc (Endl, Loc); 25954 end Process_End_Label; 25955 25956 -------------------------------- 25957 -- Propagate_Concurrent_Flags -- 25958 -------------------------------- 25959 25960 procedure Propagate_Concurrent_Flags 25961 (Typ : Entity_Id; 25962 Comp_Typ : Entity_Id) 25963 is 25964 begin 25965 if Has_Task (Comp_Typ) then 25966 Set_Has_Task (Typ); 25967 end if; 25968 25969 if Has_Protected (Comp_Typ) then 25970 Set_Has_Protected (Typ); 25971 end if; 25972 25973 if Has_Timing_Event (Comp_Typ) then 25974 Set_Has_Timing_Event (Typ); 25975 end if; 25976 end Propagate_Concurrent_Flags; 25977 25978 ------------------------------ 25979 -- Propagate_DIC_Attributes -- 25980 ------------------------------ 25981 25982 procedure Propagate_DIC_Attributes 25983 (Typ : Entity_Id; 25984 From_Typ : Entity_Id) 25985 is 25986 DIC_Proc : Entity_Id; 25987 Partial_DIC_Proc : Entity_Id; 25988 25989 begin 25990 if Present (Typ) and then Present (From_Typ) then 25991 pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ)); 25992 25993 -- Nothing to do if both the source and the destination denote the 25994 -- same type. 25995 25996 if From_Typ = Typ then 25997 return; 25998 25999 -- Nothing to do when the destination denotes an incomplete type 26000 -- because the DIC is associated with the current instance of a 26001 -- private type, thus it can never apply to an incomplete type. 26002 26003 elsif Is_Incomplete_Type (Typ) then 26004 return; 26005 end if; 26006 26007 DIC_Proc := DIC_Procedure (From_Typ); 26008 Partial_DIC_Proc := Partial_DIC_Procedure (From_Typ); 26009 26010 -- The setting of the attributes is intentionally conservative. This 26011 -- prevents accidental clobbering of enabled attributes. 26012 26013 if Has_Inherited_DIC (From_Typ) then 26014 Set_Has_Inherited_DIC (Typ); 26015 end if; 26016 26017 if Has_Own_DIC (From_Typ) then 26018 Set_Has_Own_DIC (Typ); 26019 end if; 26020 26021 if Present (DIC_Proc) and then No (DIC_Procedure (Typ)) then 26022 Set_DIC_Procedure (Typ, DIC_Proc); 26023 end if; 26024 26025 if Present (Partial_DIC_Proc) 26026 and then No (Partial_DIC_Procedure (Typ)) 26027 then 26028 Set_Partial_DIC_Procedure (Typ, Partial_DIC_Proc); 26029 end if; 26030 end if; 26031 end Propagate_DIC_Attributes; 26032 26033 ------------------------------------ 26034 -- Propagate_Invariant_Attributes -- 26035 ------------------------------------ 26036 26037 procedure Propagate_Invariant_Attributes 26038 (Typ : Entity_Id; 26039 From_Typ : Entity_Id) 26040 is 26041 Full_IP : Entity_Id; 26042 Part_IP : Entity_Id; 26043 26044 begin 26045 if Present (Typ) and then Present (From_Typ) then 26046 pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ)); 26047 26048 -- Nothing to do if both the source and the destination denote the 26049 -- same type. 26050 26051 if From_Typ = Typ then 26052 return; 26053 end if; 26054 26055 Full_IP := Invariant_Procedure (From_Typ); 26056 Part_IP := Partial_Invariant_Procedure (From_Typ); 26057 26058 -- The setting of the attributes is intentionally conservative. This 26059 -- prevents accidental clobbering of enabled attributes. 26060 26061 if Has_Inheritable_Invariants (From_Typ) then 26062 Set_Has_Inheritable_Invariants (Typ); 26063 end if; 26064 26065 if Has_Inherited_Invariants (From_Typ) then 26066 Set_Has_Inherited_Invariants (Typ); 26067 end if; 26068 26069 if Has_Own_Invariants (From_Typ) then 26070 Set_Has_Own_Invariants (Base_Type (Typ)); 26071 end if; 26072 26073 if Present (Full_IP) and then No (Invariant_Procedure (Typ)) then 26074 Set_Invariant_Procedure (Typ, Full_IP); 26075 end if; 26076 26077 if Present (Part_IP) and then No (Partial_Invariant_Procedure (Typ)) 26078 then 26079 Set_Partial_Invariant_Procedure (Typ, Part_IP); 26080 end if; 26081 end if; 26082 end Propagate_Invariant_Attributes; 26083 26084 ------------------------------------ 26085 -- Propagate_Predicate_Attributes -- 26086 ------------------------------------ 26087 26088 procedure Propagate_Predicate_Attributes 26089 (Typ : Entity_Id; 26090 From_Typ : Entity_Id) 26091 is 26092 Pred_Func : Entity_Id; 26093 Pred_Func_M : Entity_Id; 26094 26095 begin 26096 if Present (Typ) and then Present (From_Typ) then 26097 pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ)); 26098 26099 -- Nothing to do if both the source and the destination denote the 26100 -- same type. 26101 26102 if From_Typ = Typ then 26103 return; 26104 end if; 26105 26106 Pred_Func := Predicate_Function (From_Typ); 26107 Pred_Func_M := Predicate_Function_M (From_Typ); 26108 26109 -- The setting of the attributes is intentionally conservative. This 26110 -- prevents accidental clobbering of enabled attributes. 26111 26112 if Has_Predicates (From_Typ) then 26113 Set_Has_Predicates (Typ); 26114 end if; 26115 26116 if Present (Pred_Func) and then No (Predicate_Function (Typ)) then 26117 Set_Predicate_Function (Typ, Pred_Func); 26118 end if; 26119 26120 if Present (Pred_Func_M) and then No (Predicate_Function_M (Typ)) then 26121 Set_Predicate_Function_M (Typ, Pred_Func_M); 26122 end if; 26123 end if; 26124 end Propagate_Predicate_Attributes; 26125 26126 --------------------------------------- 26127 -- Record_Possible_Part_Of_Reference -- 26128 --------------------------------------- 26129 26130 procedure Record_Possible_Part_Of_Reference 26131 (Var_Id : Entity_Id; 26132 Ref : Node_Id) 26133 is 26134 Encap : constant Entity_Id := Encapsulating_State (Var_Id); 26135 Refs : Elist_Id; 26136 26137 begin 26138 -- The variable is a constituent of a single protected/task type. Such 26139 -- a variable acts as a component of the type and must appear within a 26140 -- specific region (SPARK RM 9(3)). Instead of recording the reference, 26141 -- verify its legality now. 26142 26143 if Present (Encap) and then Is_Single_Concurrent_Object (Encap) then 26144 Check_Part_Of_Reference (Var_Id, Ref); 26145 26146 -- The variable is subject to pragma Part_Of and may eventually become a 26147 -- constituent of a single protected/task type. Record the reference to 26148 -- verify its placement when the contract of the variable is analyzed. 26149 26150 elsif Present (Get_Pragma (Var_Id, Pragma_Part_Of)) then 26151 Refs := Part_Of_References (Var_Id); 26152 26153 if No (Refs) then 26154 Refs := New_Elmt_List; 26155 Set_Part_Of_References (Var_Id, Refs); 26156 end if; 26157 26158 Append_Elmt (Ref, Refs); 26159 end if; 26160 end Record_Possible_Part_Of_Reference; 26161 26162 ---------------- 26163 -- Referenced -- 26164 ---------------- 26165 26166 function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is 26167 Seen : Boolean := False; 26168 26169 function Is_Reference (N : Node_Id) return Traverse_Result; 26170 -- Determine whether node N denotes a reference to Id. If this is the 26171 -- case, set global flag Seen to True and stop the traversal. 26172 26173 ------------------ 26174 -- Is_Reference -- 26175 ------------------ 26176 26177 function Is_Reference (N : Node_Id) return Traverse_Result is 26178 begin 26179 if Is_Entity_Name (N) 26180 and then Present (Entity (N)) 26181 and then Entity (N) = Id 26182 then 26183 Seen := True; 26184 return Abandon; 26185 else 26186 return OK; 26187 end if; 26188 end Is_Reference; 26189 26190 procedure Inspect_Expression is new Traverse_Proc (Is_Reference); 26191 26192 -- Start of processing for Referenced 26193 26194 begin 26195 Inspect_Expression (Expr); 26196 return Seen; 26197 end Referenced; 26198 26199 ------------------------------------ 26200 -- References_Generic_Formal_Type -- 26201 ------------------------------------ 26202 26203 function References_Generic_Formal_Type (N : Node_Id) return Boolean is 26204 26205 function Process (N : Node_Id) return Traverse_Result; 26206 -- Process one node in search for generic formal type 26207 26208 ------------- 26209 -- Process -- 26210 ------------- 26211 26212 function Process (N : Node_Id) return Traverse_Result is 26213 begin 26214 if Nkind (N) in N_Has_Entity then 26215 declare 26216 E : constant Entity_Id := Entity (N); 26217 begin 26218 if Present (E) then 26219 if Is_Generic_Type (E) then 26220 return Abandon; 26221 elsif Present (Etype (E)) 26222 and then Is_Generic_Type (Etype (E)) 26223 then 26224 return Abandon; 26225 end if; 26226 end if; 26227 end; 26228 end if; 26229 26230 return Atree.OK; 26231 end Process; 26232 26233 function Traverse is new Traverse_Func (Process); 26234 -- Traverse tree to look for generic type 26235 26236 begin 26237 if Inside_A_Generic then 26238 return Traverse (N) = Abandon; 26239 else 26240 return False; 26241 end if; 26242 end References_Generic_Formal_Type; 26243 26244 ------------------------------- 26245 -- Remove_Entity_And_Homonym -- 26246 ------------------------------- 26247 26248 procedure Remove_Entity_And_Homonym (Id : Entity_Id) is 26249 begin 26250 Remove_Entity (Id); 26251 Remove_Homonym (Id); 26252 end Remove_Entity_And_Homonym; 26253 26254 -------------------- 26255 -- Remove_Homonym -- 26256 -------------------- 26257 26258 procedure Remove_Homonym (Id : Entity_Id) is 26259 Hom : Entity_Id; 26260 Prev : Entity_Id := Empty; 26261 26262 begin 26263 if Id = Current_Entity (Id) then 26264 if Present (Homonym (Id)) then 26265 Set_Current_Entity (Homonym (Id)); 26266 else 26267 Set_Name_Entity_Id (Chars (Id), Empty); 26268 end if; 26269 26270 else 26271 Hom := Current_Entity (Id); 26272 while Present (Hom) and then Hom /= Id loop 26273 Prev := Hom; 26274 Hom := Homonym (Hom); 26275 end loop; 26276 26277 -- If Id is not on the homonym chain, nothing to do 26278 26279 if Present (Hom) then 26280 Set_Homonym (Prev, Homonym (Id)); 26281 end if; 26282 end if; 26283 end Remove_Homonym; 26284 26285 ------------------------------ 26286 -- Remove_Overloaded_Entity -- 26287 ------------------------------ 26288 26289 procedure Remove_Overloaded_Entity (Id : Entity_Id) is 26290 procedure Remove_Primitive_Of (Typ : Entity_Id); 26291 -- Remove primitive subprogram Id from the list of primitives that 26292 -- belong to type Typ. 26293 26294 ------------------------- 26295 -- Remove_Primitive_Of -- 26296 ------------------------- 26297 26298 procedure Remove_Primitive_Of (Typ : Entity_Id) is 26299 Prims : Elist_Id; 26300 26301 begin 26302 if Is_Tagged_Type (Typ) then 26303 Prims := Direct_Primitive_Operations (Typ); 26304 26305 if Present (Prims) then 26306 Remove (Prims, Id); 26307 end if; 26308 end if; 26309 end Remove_Primitive_Of; 26310 26311 -- Local variables 26312 26313 Formal : Entity_Id; 26314 26315 -- Start of processing for Remove_Overloaded_Entity 26316 26317 begin 26318 Remove_Entity_And_Homonym (Id); 26319 26320 -- The entity denotes a primitive subprogram. Remove it from the list of 26321 -- primitives of the associated controlling type. 26322 26323 if Ekind (Id) in E_Function | E_Procedure and then Is_Primitive (Id) then 26324 Formal := First_Formal (Id); 26325 while Present (Formal) loop 26326 if Is_Controlling_Formal (Formal) then 26327 Remove_Primitive_Of (Etype (Formal)); 26328 exit; 26329 end if; 26330 26331 Next_Formal (Formal); 26332 end loop; 26333 26334 if Ekind (Id) = E_Function and then Has_Controlling_Result (Id) then 26335 Remove_Primitive_Of (Etype (Id)); 26336 end if; 26337 end if; 26338 end Remove_Overloaded_Entity; 26339 26340 --------------------- 26341 -- Rep_To_Pos_Flag -- 26342 --------------------- 26343 26344 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is 26345 begin 26346 return New_Occurrence_Of 26347 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc); 26348 end Rep_To_Pos_Flag; 26349 26350 -------------------- 26351 -- Require_Entity -- 26352 -------------------- 26353 26354 procedure Require_Entity (N : Node_Id) is 26355 begin 26356 if Is_Entity_Name (N) and then No (Entity (N)) then 26357 if Total_Errors_Detected /= 0 then 26358 Set_Entity (N, Any_Id); 26359 else 26360 raise Program_Error; 26361 end if; 26362 end if; 26363 end Require_Entity; 26364 26365 ------------------------------ 26366 -- Requires_Transient_Scope -- 26367 ------------------------------ 26368 26369 -- A transient scope is required when variable-sized temporaries are 26370 -- allocated on the secondary stack, or when finalization actions must be 26371 -- generated before the next instruction. 26372 26373 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is 26374 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean; 26375 -- This is called for untagged records and protected types, with 26376 -- nondefaulted discriminants. Returns True if the size of function 26377 -- results is known at the call site, False otherwise. Returns False 26378 -- if there is a variant part that depends on the discriminants of 26379 -- this type, or if there is an array constrained by the discriminants 26380 -- of this type. ???Currently, this is overly conservative (the array 26381 -- could be nested inside some other record that is constrained by 26382 -- nondiscriminants). That is, the recursive calls are too conservative. 26383 26384 procedure Ensure_Minimum_Decoration (Typ : Entity_Id); 26385 -- If Typ is not frozen then add to Typ the minimum decoration required 26386 -- by Requires_Transient_Scope to reliably provide its functionality; 26387 -- otherwise no action is performed. 26388 26389 function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean; 26390 -- Returns True if Typ is a nonlimited record with defaulted 26391 -- discriminants whose max size makes it unsuitable for allocating on 26392 -- the primary stack. 26393 26394 ------------------------------ 26395 -- Caller_Known_Size_Record -- 26396 ------------------------------ 26397 26398 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is 26399 pragma Assert (Typ = Underlying_Type (Typ)); 26400 26401 begin 26402 if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then 26403 return False; 26404 end if; 26405 26406 declare 26407 Comp : Entity_Id; 26408 26409 begin 26410 Comp := First_Component (Typ); 26411 while Present (Comp) loop 26412 26413 -- Only look at E_Component entities. No need to look at 26414 -- E_Discriminant entities, and we must ignore internal 26415 -- subtypes generated for constrained components. 26416 26417 declare 26418 Comp_Type : constant Entity_Id := 26419 Underlying_Type (Etype (Comp)); 26420 26421 begin 26422 if Is_Record_Type (Comp_Type) 26423 or else 26424 Is_Protected_Type (Comp_Type) 26425 then 26426 if not Caller_Known_Size_Record (Comp_Type) then 26427 return False; 26428 end if; 26429 26430 elsif Is_Array_Type (Comp_Type) then 26431 if Size_Depends_On_Discriminant (Comp_Type) then 26432 return False; 26433 end if; 26434 end if; 26435 end; 26436 26437 Next_Component (Comp); 26438 end loop; 26439 end; 26440 26441 return True; 26442 end Caller_Known_Size_Record; 26443 26444 ------------------------------- 26445 -- Ensure_Minimum_Decoration -- 26446 ------------------------------- 26447 26448 procedure Ensure_Minimum_Decoration (Typ : Entity_Id) is 26449 Comp : Entity_Id; 26450 begin 26451 -- Do not set Has_Controlled_Component on a class-wide equivalent 26452 -- type. See Make_CW_Equivalent_Type. 26453 26454 if Present (Typ) 26455 and then not Is_Frozen (Typ) 26456 and then (Is_Record_Type (Typ) 26457 or else Is_Concurrent_Type (Typ) 26458 or else Is_Incomplete_Or_Private_Type (Typ)) 26459 and then not Is_Class_Wide_Equivalent_Type (Typ) 26460 then 26461 Comp := First_Component (Typ); 26462 while Present (Comp) loop 26463 if Has_Controlled_Component (Etype (Comp)) 26464 or else 26465 (Chars (Comp) /= Name_uParent 26466 and then Is_Controlled (Etype (Comp))) 26467 or else 26468 (Is_Protected_Type (Etype (Comp)) 26469 and then 26470 Present (Corresponding_Record_Type (Etype (Comp))) 26471 and then 26472 Has_Controlled_Component 26473 (Corresponding_Record_Type (Etype (Comp)))) 26474 then 26475 Set_Has_Controlled_Component (Typ); 26476 exit; 26477 end if; 26478 26479 Next_Component (Comp); 26480 end loop; 26481 end if; 26482 end Ensure_Minimum_Decoration; 26483 26484 ------------------------------ 26485 -- Large_Max_Size_Mutable -- 26486 ------------------------------ 26487 26488 function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is 26489 pragma Assert (Typ = Underlying_Type (Typ)); 26490 26491 function Is_Large_Discrete_Type (T : Entity_Id) return Boolean; 26492 -- Returns true if the discrete type T has a large range 26493 26494 ---------------------------- 26495 -- Is_Large_Discrete_Type -- 26496 ---------------------------- 26497 26498 function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is 26499 Threshold : constant Int := 16; 26500 -- Arbitrary threshold above which we consider it "large". We want 26501 -- a fairly large threshold, because these large types really 26502 -- shouldn't have default discriminants in the first place, in 26503 -- most cases. 26504 26505 begin 26506 return UI_To_Int (RM_Size (T)) > Threshold; 26507 end Is_Large_Discrete_Type; 26508 26509 -- Start of processing for Large_Max_Size_Mutable 26510 26511 begin 26512 if Is_Record_Type (Typ) 26513 and then not Is_Limited_View (Typ) 26514 and then Has_Defaulted_Discriminants (Typ) 26515 then 26516 -- Loop through the components, looking for an array whose upper 26517 -- bound(s) depends on discriminants, where both the subtype of 26518 -- the discriminant and the index subtype are too large. 26519 26520 declare 26521 Comp : Entity_Id; 26522 26523 begin 26524 Comp := First_Component (Typ); 26525 while Present (Comp) loop 26526 declare 26527 Comp_Type : constant Entity_Id := 26528 Underlying_Type (Etype (Comp)); 26529 26530 Hi : Node_Id; 26531 Indx : Node_Id; 26532 Ityp : Entity_Id; 26533 26534 begin 26535 if Is_Array_Type (Comp_Type) then 26536 Indx := First_Index (Comp_Type); 26537 26538 while Present (Indx) loop 26539 Ityp := Etype (Indx); 26540 Hi := Type_High_Bound (Ityp); 26541 26542 if Nkind (Hi) = N_Identifier 26543 and then Ekind (Entity (Hi)) = E_Discriminant 26544 and then Is_Large_Discrete_Type (Ityp) 26545 and then Is_Large_Discrete_Type 26546 (Etype (Entity (Hi))) 26547 then 26548 return True; 26549 end if; 26550 26551 Next_Index (Indx); 26552 end loop; 26553 end if; 26554 end; 26555 26556 Next_Component (Comp); 26557 end loop; 26558 end; 26559 end if; 26560 26561 return False; 26562 end Large_Max_Size_Mutable; 26563 26564 -- Local declarations 26565 26566 Typ : constant Entity_Id := Underlying_Type (Id); 26567 26568 -- Start of processing for Requires_Transient_Scope 26569 26570 begin 26571 Ensure_Minimum_Decoration (Id); 26572 26573 -- This is a private type which is not completed yet. This can only 26574 -- happen in a default expression (of a formal parameter or of a 26575 -- record component). Do not expand transient scope in this case. 26576 26577 if No (Typ) then 26578 return False; 26579 26580 -- Do not expand transient scope for non-existent procedure return or 26581 -- string literal types. 26582 26583 elsif Typ = Standard_Void_Type 26584 or else Ekind (Typ) = E_String_Literal_Subtype 26585 then 26586 return False; 26587 26588 -- If Typ is a generic formal incomplete type, then we want to look at 26589 -- the actual type. 26590 26591 elsif Ekind (Typ) = E_Record_Subtype 26592 and then Present (Cloned_Subtype (Typ)) 26593 then 26594 return Requires_Transient_Scope (Cloned_Subtype (Typ)); 26595 26596 -- Functions returning specific tagged types may dispatch on result, so 26597 -- their returned value is allocated on the secondary stack, even in the 26598 -- definite case. We must treat nondispatching functions the same way, 26599 -- because access-to-function types can point at both, so the calling 26600 -- conventions must be compatible. Is_Tagged_Type includes controlled 26601 -- types and class-wide types. Controlled type temporaries need 26602 -- finalization. 26603 26604 -- ???It's not clear why we need to return noncontrolled types with 26605 -- controlled components on the secondary stack. 26606 26607 elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then 26608 return True; 26609 26610 -- Untagged definite subtypes are known size. This includes all 26611 -- elementary [sub]types. Tasks are known size even if they have 26612 -- discriminants. So we return False here, with one exception: 26613 -- For a type like: 26614 -- type T (Last : Natural := 0) is 26615 -- X : String (1 .. Last); 26616 -- end record; 26617 -- we return True. That's because for "P(F(...));", where F returns T, 26618 -- we don't know the size of the result at the call site, so if we 26619 -- allocated it on the primary stack, we would have to allocate the 26620 -- maximum size, which is way too big. 26621 26622 elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then 26623 return Large_Max_Size_Mutable (Typ); 26624 26625 -- Indefinite (discriminated) untagged record or protected type 26626 26627 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then 26628 return not Caller_Known_Size_Record (Typ); 26629 26630 -- Unconstrained array 26631 26632 else 26633 pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ)); 26634 return True; 26635 end if; 26636 end Requires_Transient_Scope; 26637 26638 -------------------------- 26639 -- Reset_Analyzed_Flags -- 26640 -------------------------- 26641 26642 procedure Reset_Analyzed_Flags (N : Node_Id) is 26643 function Clear_Analyzed (N : Node_Id) return Traverse_Result; 26644 -- Function used to reset Analyzed flags in tree. Note that we do 26645 -- not reset Analyzed flags in entities, since there is no need to 26646 -- reanalyze entities, and indeed, it is wrong to do so, since it 26647 -- can result in generating auxiliary stuff more than once. 26648 26649 -------------------- 26650 -- Clear_Analyzed -- 26651 -------------------- 26652 26653 function Clear_Analyzed (N : Node_Id) return Traverse_Result is 26654 begin 26655 if Nkind (N) not in N_Entity then 26656 Set_Analyzed (N, False); 26657 end if; 26658 26659 return OK; 26660 end Clear_Analyzed; 26661 26662 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed); 26663 26664 -- Start of processing for Reset_Analyzed_Flags 26665 26666 begin 26667 Reset_Analyzed (N); 26668 end Reset_Analyzed_Flags; 26669 26670 ------------------------ 26671 -- Restore_SPARK_Mode -- 26672 ------------------------ 26673 26674 procedure Restore_SPARK_Mode 26675 (Mode : SPARK_Mode_Type; 26676 Prag : Node_Id) 26677 is 26678 begin 26679 SPARK_Mode := Mode; 26680 SPARK_Mode_Pragma := Prag; 26681 end Restore_SPARK_Mode; 26682 26683 -------------------------------- 26684 -- Returns_Unconstrained_Type -- 26685 -------------------------------- 26686 26687 function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is 26688 begin 26689 return Ekind (Subp) = E_Function 26690 and then not Is_Scalar_Type (Etype (Subp)) 26691 and then not Is_Access_Type (Etype (Subp)) 26692 and then not Is_Constrained (Etype (Subp)); 26693 end Returns_Unconstrained_Type; 26694 26695 ---------------------------- 26696 -- Root_Type_Of_Full_View -- 26697 ---------------------------- 26698 26699 function Root_Type_Of_Full_View (T : Entity_Id) return Entity_Id is 26700 Rtyp : constant Entity_Id := Root_Type (T); 26701 26702 begin 26703 -- The root type of the full view may itself be a private type. Keep 26704 -- looking for the ultimate derivation parent. 26705 26706 if Is_Private_Type (Rtyp) and then Present (Full_View (Rtyp)) then 26707 return Root_Type_Of_Full_View (Full_View (Rtyp)); 26708 else 26709 return Rtyp; 26710 end if; 26711 end Root_Type_Of_Full_View; 26712 26713 --------------------------- 26714 -- Safe_To_Capture_Value -- 26715 --------------------------- 26716 26717 function Safe_To_Capture_Value 26718 (N : Node_Id; 26719 Ent : Entity_Id; 26720 Cond : Boolean := False) return Boolean 26721 is 26722 begin 26723 -- The only entities for which we track constant values are variables 26724 -- which are not renamings, constants and formal parameters, so check 26725 -- if we have this case. 26726 26727 -- Note: it may seem odd to track constant values for constants, but in 26728 -- fact this routine is used for other purposes than simply capturing 26729 -- the value. In particular, the setting of Known[_Non]_Null and 26730 -- Is_Known_Valid. 26731 26732 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent))) 26733 or else 26734 Ekind (Ent) = E_Constant 26735 or else 26736 Is_Formal (Ent) 26737 then 26738 null; 26739 26740 -- For conditionals, we also allow loop parameters 26741 26742 elsif Cond and then Ekind (Ent) = E_Loop_Parameter then 26743 null; 26744 26745 -- For all other cases, not just unsafe, but impossible to capture 26746 -- Current_Value, since the above are the only entities which have 26747 -- Current_Value fields. 26748 26749 else 26750 return False; 26751 end if; 26752 26753 -- Skip if volatile or aliased, since funny things might be going on in 26754 -- these cases which we cannot necessarily track. Also skip any variable 26755 -- for which an address clause is given, or whose address is taken. Also 26756 -- never capture value of library level variables (an attempt to do so 26757 -- can occur in the case of package elaboration code). 26758 26759 if Treat_As_Volatile (Ent) 26760 or else Is_Aliased (Ent) 26761 or else Present (Address_Clause (Ent)) 26762 or else Address_Taken (Ent) 26763 or else (Is_Library_Level_Entity (Ent) 26764 and then Ekind (Ent) = E_Variable) 26765 then 26766 return False; 26767 end if; 26768 26769 -- OK, all above conditions are met. We also require that the scope of 26770 -- the reference be the same as the scope of the entity, not counting 26771 -- packages and blocks and loops. 26772 26773 declare 26774 E_Scope : constant Entity_Id := Scope (Ent); 26775 R_Scope : Entity_Id; 26776 26777 begin 26778 R_Scope := Current_Scope; 26779 while R_Scope /= Standard_Standard loop 26780 exit when R_Scope = E_Scope; 26781 26782 if Ekind (R_Scope) not in E_Package | E_Block | E_Loop then 26783 return False; 26784 else 26785 R_Scope := Scope (R_Scope); 26786 end if; 26787 end loop; 26788 end; 26789 26790 -- We also require that the reference does not appear in a context 26791 -- where it is not sure to be executed (i.e. a conditional context 26792 -- or an exception handler). We skip this if Cond is True, since the 26793 -- capturing of values from conditional tests handles this ok. 26794 26795 if Cond then 26796 return True; 26797 end if; 26798 26799 declare 26800 Desc : Node_Id; 26801 P : Node_Id; 26802 26803 begin 26804 Desc := N; 26805 26806 -- Seems dubious that case expressions are not handled here ??? 26807 26808 P := Parent (N); 26809 while Present (P) loop 26810 if Nkind (P) = N_If_Statement 26811 or else Nkind (P) = N_Case_Statement 26812 or else (Nkind (P) in N_Short_Circuit 26813 and then Desc = Right_Opnd (P)) 26814 or else (Nkind (P) = N_If_Expression 26815 and then Desc /= First (Expressions (P))) 26816 or else Nkind (P) = N_Exception_Handler 26817 or else Nkind (P) = N_Selective_Accept 26818 or else Nkind (P) = N_Conditional_Entry_Call 26819 or else Nkind (P) = N_Timed_Entry_Call 26820 or else Nkind (P) = N_Asynchronous_Select 26821 then 26822 return False; 26823 26824 else 26825 Desc := P; 26826 P := Parent (P); 26827 26828 -- A special Ada 2012 case: the original node may be part 26829 -- of the else_actions of a conditional expression, in which 26830 -- case it might not have been expanded yet, and appears in 26831 -- a non-syntactic list of actions. In that case it is clearly 26832 -- not safe to save a value. 26833 26834 if No (P) 26835 and then Is_List_Member (Desc) 26836 and then No (Parent (List_Containing (Desc))) 26837 then 26838 return False; 26839 end if; 26840 end if; 26841 end loop; 26842 end; 26843 26844 -- OK, looks safe to set value 26845 26846 return True; 26847 end Safe_To_Capture_Value; 26848 26849 --------------- 26850 -- Same_Name -- 26851 --------------- 26852 26853 function Same_Name (N1, N2 : Node_Id) return Boolean is 26854 K1 : constant Node_Kind := Nkind (N1); 26855 K2 : constant Node_Kind := Nkind (N2); 26856 26857 begin 26858 if (K1 = N_Identifier or else K1 = N_Defining_Identifier) 26859 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier) 26860 then 26861 return Chars (N1) = Chars (N2); 26862 26863 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name) 26864 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name) 26865 then 26866 return Same_Name (Selector_Name (N1), Selector_Name (N2)) 26867 and then Same_Name (Prefix (N1), Prefix (N2)); 26868 26869 else 26870 return False; 26871 end if; 26872 end Same_Name; 26873 26874 ----------------- 26875 -- Same_Object -- 26876 ----------------- 26877 26878 function Same_Object (Node1, Node2 : Node_Id) return Boolean is 26879 N1 : constant Node_Id := Original_Node (Node1); 26880 N2 : constant Node_Id := Original_Node (Node2); 26881 -- We do the tests on original nodes, since we are most interested 26882 -- in the original source, not any expansion that got in the way. 26883 26884 K1 : constant Node_Kind := Nkind (N1); 26885 K2 : constant Node_Kind := Nkind (N2); 26886 26887 begin 26888 -- First case, both are entities with same entity 26889 26890 if K1 in N_Has_Entity and then K2 in N_Has_Entity then 26891 declare 26892 EN1 : constant Entity_Id := Entity (N1); 26893 EN2 : constant Entity_Id := Entity (N2); 26894 begin 26895 if Present (EN1) and then Present (EN2) 26896 and then (Ekind (EN1) in E_Variable | E_Constant 26897 or else Is_Formal (EN1)) 26898 and then EN1 = EN2 26899 then 26900 return True; 26901 end if; 26902 end; 26903 end if; 26904 26905 -- Second case, selected component with same selector, same record 26906 26907 if K1 = N_Selected_Component 26908 and then K2 = N_Selected_Component 26909 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2)) 26910 then 26911 return Same_Object (Prefix (N1), Prefix (N2)); 26912 26913 -- Third case, indexed component with same subscripts, same array 26914 26915 elsif K1 = N_Indexed_Component 26916 and then K2 = N_Indexed_Component 26917 and then Same_Object (Prefix (N1), Prefix (N2)) 26918 then 26919 declare 26920 E1, E2 : Node_Id; 26921 begin 26922 E1 := First (Expressions (N1)); 26923 E2 := First (Expressions (N2)); 26924 while Present (E1) loop 26925 if not Same_Value (E1, E2) then 26926 return False; 26927 else 26928 Next (E1); 26929 Next (E2); 26930 end if; 26931 end loop; 26932 26933 return True; 26934 end; 26935 26936 -- Fourth case, slice of same array with same bounds 26937 26938 elsif K1 = N_Slice 26939 and then K2 = N_Slice 26940 and then Nkind (Discrete_Range (N1)) = N_Range 26941 and then Nkind (Discrete_Range (N2)) = N_Range 26942 and then Same_Value (Low_Bound (Discrete_Range (N1)), 26943 Low_Bound (Discrete_Range (N2))) 26944 and then Same_Value (High_Bound (Discrete_Range (N1)), 26945 High_Bound (Discrete_Range (N2))) 26946 then 26947 return Same_Name (Prefix (N1), Prefix (N2)); 26948 26949 -- All other cases, not clearly the same object 26950 26951 else 26952 return False; 26953 end if; 26954 end Same_Object; 26955 26956 --------------------------------- 26957 -- Same_Or_Aliased_Subprograms -- 26958 --------------------------------- 26959 26960 function Same_Or_Aliased_Subprograms 26961 (S : Entity_Id; 26962 E : Entity_Id) return Boolean 26963 is 26964 Subp_Alias : constant Entity_Id := Alias (S); 26965 begin 26966 return S = E or else (Present (Subp_Alias) and then Subp_Alias = E); 26967 end Same_Or_Aliased_Subprograms; 26968 26969 --------------- 26970 -- Same_Type -- 26971 --------------- 26972 26973 function Same_Type (T1, T2 : Entity_Id) return Boolean is 26974 begin 26975 if T1 = T2 then 26976 return True; 26977 26978 elsif not Is_Constrained (T1) 26979 and then not Is_Constrained (T2) 26980 and then Base_Type (T1) = Base_Type (T2) 26981 then 26982 return True; 26983 26984 -- For now don't bother with case of identical constraints, to be 26985 -- fiddled with later on perhaps (this is only used for optimization 26986 -- purposes, so it is not critical to do a best possible job) 26987 26988 else 26989 return False; 26990 end if; 26991 end Same_Type; 26992 26993 ---------------- 26994 -- Same_Value -- 26995 ---------------- 26996 26997 function Same_Value (Node1, Node2 : Node_Id) return Boolean is 26998 begin 26999 if Compile_Time_Known_Value (Node1) 27000 and then Compile_Time_Known_Value (Node2) 27001 then 27002 -- Handle properly compile-time expressions that are not 27003 -- scalar. 27004 27005 if Is_String_Type (Etype (Node1)) then 27006 return Expr_Value_S (Node1) = Expr_Value_S (Node2); 27007 27008 else 27009 return Expr_Value (Node1) = Expr_Value (Node2); 27010 end if; 27011 27012 elsif Same_Object (Node1, Node2) then 27013 return True; 27014 else 27015 return False; 27016 end if; 27017 end Same_Value; 27018 27019 -------------------- 27020 -- Set_SPARK_Mode -- 27021 -------------------- 27022 27023 procedure Set_SPARK_Mode (Context : Entity_Id) is 27024 begin 27025 -- Do not consider illegal or partially decorated constructs 27026 27027 if Ekind (Context) = E_Void or else Error_Posted (Context) then 27028 null; 27029 27030 elsif Present (SPARK_Pragma (Context)) then 27031 Install_SPARK_Mode 27032 (Mode => Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Context)), 27033 Prag => SPARK_Pragma (Context)); 27034 end if; 27035 end Set_SPARK_Mode; 27036 27037 ------------------------- 27038 -- Scalar_Part_Present -- 27039 ------------------------- 27040 27041 function Scalar_Part_Present (Typ : Entity_Id) return Boolean is 27042 Val_Typ : constant Entity_Id := Validated_View (Typ); 27043 Field : Entity_Id; 27044 27045 begin 27046 if Is_Scalar_Type (Val_Typ) then 27047 return True; 27048 27049 elsif Is_Array_Type (Val_Typ) then 27050 return Scalar_Part_Present (Component_Type (Val_Typ)); 27051 27052 elsif Is_Record_Type (Val_Typ) then 27053 Field := First_Component_Or_Discriminant (Val_Typ); 27054 while Present (Field) loop 27055 if Scalar_Part_Present (Etype (Field)) then 27056 return True; 27057 end if; 27058 27059 Next_Component_Or_Discriminant (Field); 27060 end loop; 27061 end if; 27062 27063 return False; 27064 end Scalar_Part_Present; 27065 27066 ------------------------ 27067 -- Scope_Is_Transient -- 27068 ------------------------ 27069 27070 function Scope_Is_Transient return Boolean is 27071 begin 27072 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient; 27073 end Scope_Is_Transient; 27074 27075 ------------------ 27076 -- Scope_Within -- 27077 ------------------ 27078 27079 function Scope_Within 27080 (Inner : Entity_Id; 27081 Outer : Entity_Id) return Boolean 27082 is 27083 Curr : Entity_Id; 27084 27085 begin 27086 Curr := Inner; 27087 while Present (Curr) and then Curr /= Standard_Standard loop 27088 Curr := Scope (Curr); 27089 27090 if Curr = Outer then 27091 return True; 27092 27093 -- A selective accept body appears within a task type, but the 27094 -- enclosing subprogram is the procedure of the task body. 27095 27096 elsif Ekind (Implementation_Base_Type (Curr)) = E_Task_Type 27097 and then 27098 Outer = Task_Body_Procedure (Implementation_Base_Type (Curr)) 27099 then 27100 return True; 27101 27102 -- Ditto for the body of a protected operation 27103 27104 elsif Is_Subprogram (Curr) 27105 and then Outer = Protected_Body_Subprogram (Curr) 27106 then 27107 return True; 27108 27109 -- Outside of its scope, a synchronized type may just be private 27110 27111 elsif Is_Private_Type (Curr) 27112 and then Present (Full_View (Curr)) 27113 and then Is_Concurrent_Type (Full_View (Curr)) 27114 then 27115 return Scope_Within (Full_View (Curr), Outer); 27116 end if; 27117 end loop; 27118 27119 return False; 27120 end Scope_Within; 27121 27122 -------------------------- 27123 -- Scope_Within_Or_Same -- 27124 -------------------------- 27125 27126 function Scope_Within_Or_Same 27127 (Inner : Entity_Id; 27128 Outer : Entity_Id) return Boolean 27129 is 27130 Curr : Entity_Id := Inner; 27131 27132 begin 27133 -- Similar to the above, but check for scope identity first 27134 27135 while Present (Curr) and then Curr /= Standard_Standard loop 27136 if Curr = Outer then 27137 return True; 27138 27139 elsif Ekind (Implementation_Base_Type (Curr)) = E_Task_Type 27140 and then 27141 Outer = Task_Body_Procedure (Implementation_Base_Type (Curr)) 27142 then 27143 return True; 27144 27145 elsif Is_Subprogram (Curr) 27146 and then Outer = Protected_Body_Subprogram (Curr) 27147 then 27148 return True; 27149 27150 elsif Is_Private_Type (Curr) 27151 and then Present (Full_View (Curr)) 27152 then 27153 if Full_View (Curr) = Outer then 27154 return True; 27155 else 27156 return Scope_Within (Full_View (Curr), Outer); 27157 end if; 27158 end if; 27159 27160 Curr := Scope (Curr); 27161 end loop; 27162 27163 return False; 27164 end Scope_Within_Or_Same; 27165 27166 -------------------- 27167 -- Set_Convention -- 27168 -------------------- 27169 27170 procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is 27171 begin 27172 Basic_Set_Convention (E, Val); 27173 27174 if Is_Type (E) 27175 and then Is_Access_Subprogram_Type (Base_Type (E)) 27176 and then Has_Foreign_Convention (E) 27177 then 27178 Set_Can_Use_Internal_Rep (E, False); 27179 end if; 27180 27181 -- If E is an object, including a component, and the type of E is an 27182 -- anonymous access type with no convention set, then also set the 27183 -- convention of the anonymous access type. We do not do this for 27184 -- anonymous protected types, since protected types always have the 27185 -- default convention. 27186 27187 if Present (Etype (E)) 27188 and then (Is_Object (E) 27189 27190 -- Allow E_Void (happens for pragma Convention appearing 27191 -- in the middle of a record applying to a component) 27192 27193 or else Ekind (E) = E_Void) 27194 then 27195 declare 27196 Typ : constant Entity_Id := Etype (E); 27197 27198 begin 27199 if Ekind (Typ) in E_Anonymous_Access_Type 27200 | E_Anonymous_Access_Subprogram_Type 27201 and then not Has_Convention_Pragma (Typ) 27202 then 27203 Basic_Set_Convention (Typ, Val); 27204 Set_Has_Convention_Pragma (Typ); 27205 27206 -- And for the access subprogram type, deal similarly with the 27207 -- designated E_Subprogram_Type, which is always internal. 27208 27209 if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then 27210 declare 27211 Dtype : constant Entity_Id := Designated_Type (Typ); 27212 begin 27213 if Ekind (Dtype) = E_Subprogram_Type 27214 and then not Has_Convention_Pragma (Dtype) 27215 then 27216 Basic_Set_Convention (Dtype, Val); 27217 Set_Has_Convention_Pragma (Dtype); 27218 end if; 27219 end; 27220 end if; 27221 end if; 27222 end; 27223 end if; 27224 end Set_Convention; 27225 27226 ------------------------ 27227 -- Set_Current_Entity -- 27228 ------------------------ 27229 27230 -- The given entity is to be set as the currently visible definition of its 27231 -- associated name (i.e. the Node_Id associated with its name). All we have 27232 -- to do is to get the name from the identifier, and then set the 27233 -- associated Node_Id to point to the given entity. 27234 27235 procedure Set_Current_Entity (E : Entity_Id) is 27236 begin 27237 Set_Name_Entity_Id (Chars (E), E); 27238 end Set_Current_Entity; 27239 27240 --------------------------- 27241 -- Set_Debug_Info_Needed -- 27242 --------------------------- 27243 27244 procedure Set_Debug_Info_Needed (T : Entity_Id) is 27245 27246 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id); 27247 pragma Inline (Set_Debug_Info_Needed_If_Not_Set); 27248 -- Used to set debug info in a related node if not set already 27249 27250 -------------------------------------- 27251 -- Set_Debug_Info_Needed_If_Not_Set -- 27252 -------------------------------------- 27253 27254 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is 27255 begin 27256 if Present (E) and then not Needs_Debug_Info (E) then 27257 Set_Debug_Info_Needed (E); 27258 27259 -- For a private type, indicate that the full view also needs 27260 -- debug information. 27261 27262 if Is_Type (E) 27263 and then Is_Private_Type (E) 27264 and then Present (Full_View (E)) 27265 then 27266 Set_Debug_Info_Needed (Full_View (E)); 27267 end if; 27268 end if; 27269 end Set_Debug_Info_Needed_If_Not_Set; 27270 27271 -- Start of processing for Set_Debug_Info_Needed 27272 27273 begin 27274 -- Nothing to do if there is no available entity 27275 27276 if No (T) then 27277 return; 27278 27279 -- Nothing to do for an entity with suppressed debug information 27280 27281 elsif Debug_Info_Off (T) then 27282 return; 27283 27284 -- Nothing to do for an ignored Ghost entity because the entity will be 27285 -- eliminated from the tree. 27286 27287 elsif Is_Ignored_Ghost_Entity (T) then 27288 return; 27289 27290 -- Nothing to do if entity comes from a predefined file. Library files 27291 -- are compiled without debug information, but inlined bodies of these 27292 -- routines may appear in user code, and debug information on them ends 27293 -- up complicating debugging the user code. 27294 27295 elsif In_Inlined_Body and then In_Predefined_Unit (T) then 27296 Set_Needs_Debug_Info (T, False); 27297 end if; 27298 27299 -- Set flag in entity itself. Note that we will go through the following 27300 -- circuitry even if the flag is already set on T. That's intentional, 27301 -- it makes sure that the flag will be set in subsidiary entities. 27302 27303 Set_Needs_Debug_Info (T); 27304 27305 -- Set flag on subsidiary entities if not set already 27306 27307 if Is_Object (T) then 27308 Set_Debug_Info_Needed_If_Not_Set (Etype (T)); 27309 27310 elsif Is_Type (T) then 27311 Set_Debug_Info_Needed_If_Not_Set (Etype (T)); 27312 27313 if Is_Record_Type (T) then 27314 declare 27315 Ent : Entity_Id := First_Entity (T); 27316 begin 27317 while Present (Ent) loop 27318 Set_Debug_Info_Needed_If_Not_Set (Ent); 27319 Next_Entity (Ent); 27320 end loop; 27321 end; 27322 27323 -- For a class wide subtype, we also need debug information 27324 -- for the equivalent type. 27325 27326 if Ekind (T) = E_Class_Wide_Subtype then 27327 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T)); 27328 end if; 27329 27330 elsif Is_Array_Type (T) then 27331 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T)); 27332 27333 declare 27334 Indx : Node_Id := First_Index (T); 27335 begin 27336 while Present (Indx) loop 27337 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx)); 27338 Next_Index (Indx); 27339 end loop; 27340 end; 27341 27342 -- For a packed array type, we also need debug information for 27343 -- the type used to represent the packed array. Conversely, we 27344 -- also need it for the former if we need it for the latter. 27345 27346 if Is_Packed (T) then 27347 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Impl_Type (T)); 27348 end if; 27349 27350 if Is_Packed_Array_Impl_Type (T) then 27351 Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T)); 27352 end if; 27353 27354 elsif Is_Access_Type (T) then 27355 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T)); 27356 27357 elsif Is_Private_Type (T) then 27358 declare 27359 FV : constant Entity_Id := Full_View (T); 27360 27361 begin 27362 Set_Debug_Info_Needed_If_Not_Set (FV); 27363 27364 -- If the full view is itself a derived private type, we need 27365 -- debug information on its underlying type. 27366 27367 if Present (FV) 27368 and then Is_Private_Type (FV) 27369 and then Present (Underlying_Full_View (FV)) 27370 then 27371 Set_Needs_Debug_Info (Underlying_Full_View (FV)); 27372 end if; 27373 end; 27374 27375 elsif Is_Protected_Type (T) then 27376 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T)); 27377 27378 elsif Is_Scalar_Type (T) then 27379 27380 -- If the subrange bounds are materialized by dedicated constant 27381 -- objects, also include them in the debug info to make sure the 27382 -- debugger can properly use them. 27383 27384 if Present (Scalar_Range (T)) 27385 and then Nkind (Scalar_Range (T)) = N_Range 27386 then 27387 declare 27388 Low_Bnd : constant Node_Id := Type_Low_Bound (T); 27389 High_Bnd : constant Node_Id := Type_High_Bound (T); 27390 27391 begin 27392 if Is_Entity_Name (Low_Bnd) then 27393 Set_Debug_Info_Needed_If_Not_Set (Entity (Low_Bnd)); 27394 end if; 27395 27396 if Is_Entity_Name (High_Bnd) then 27397 Set_Debug_Info_Needed_If_Not_Set (Entity (High_Bnd)); 27398 end if; 27399 end; 27400 end if; 27401 end if; 27402 end if; 27403 end Set_Debug_Info_Needed; 27404 27405 -------------------------------- 27406 -- Set_Debug_Info_Defining_Id -- 27407 -------------------------------- 27408 27409 procedure Set_Debug_Info_Defining_Id (N : Node_Id) is 27410 begin 27411 if Comes_From_Source (Defining_Identifier (N)) then 27412 Set_Debug_Info_Needed (Defining_Identifier (N)); 27413 end if; 27414 end Set_Debug_Info_Defining_Id; 27415 27416 ---------------------------- 27417 -- Set_Entity_With_Checks -- 27418 ---------------------------- 27419 27420 procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id) is 27421 Val_Actual : Entity_Id; 27422 Nod : Node_Id; 27423 Post_Node : Node_Id; 27424 27425 begin 27426 -- Unconditionally set the entity 27427 27428 Set_Entity (N, Val); 27429 27430 -- The node to post on is the selector in the case of an expanded name, 27431 -- and otherwise the node itself. 27432 27433 if Nkind (N) = N_Expanded_Name then 27434 Post_Node := Selector_Name (N); 27435 else 27436 Post_Node := N; 27437 end if; 27438 27439 -- Check for violation of No_Fixed_IO 27440 27441 if Restriction_Check_Required (No_Fixed_IO) 27442 and then 27443 ((RTU_Loaded (Ada_Text_IO) 27444 and then (Is_RTE (Val, RE_Decimal_IO) 27445 or else 27446 Is_RTE (Val, RE_Fixed_IO))) 27447 27448 or else 27449 (RTU_Loaded (Ada_Wide_Text_IO) 27450 and then (Is_RTE (Val, RO_WT_Decimal_IO) 27451 or else 27452 Is_RTE (Val, RO_WT_Fixed_IO))) 27453 27454 or else 27455 (RTU_Loaded (Ada_Wide_Wide_Text_IO) 27456 and then (Is_RTE (Val, RO_WW_Decimal_IO) 27457 or else 27458 Is_RTE (Val, RO_WW_Fixed_IO)))) 27459 27460 -- A special extra check, don't complain about a reference from within 27461 -- the Ada.Interrupts package itself! 27462 27463 and then not In_Same_Extended_Unit (N, Val) 27464 then 27465 Check_Restriction (No_Fixed_IO, Post_Node); 27466 end if; 27467 27468 -- Remaining checks are only done on source nodes. Note that we test 27469 -- for violation of No_Fixed_IO even on non-source nodes, because the 27470 -- cases for checking violations of this restriction are instantiations 27471 -- where the reference in the instance has Comes_From_Source False. 27472 27473 if not Comes_From_Source (N) then 27474 return; 27475 end if; 27476 27477 -- Check for violation of No_Abort_Statements, which is triggered by 27478 -- call to Ada.Task_Identification.Abort_Task. 27479 27480 if Restriction_Check_Required (No_Abort_Statements) 27481 and then (Is_RTE (Val, RE_Abort_Task)) 27482 27483 -- A special extra check, don't complain about a reference from within 27484 -- the Ada.Task_Identification package itself! 27485 27486 and then not In_Same_Extended_Unit (N, Val) 27487 then 27488 Check_Restriction (No_Abort_Statements, Post_Node); 27489 end if; 27490 27491 if Val = Standard_Long_Long_Integer then 27492 Check_Restriction (No_Long_Long_Integers, Post_Node); 27493 end if; 27494 27495 -- Check for violation of No_Dynamic_Attachment 27496 27497 if Restriction_Check_Required (No_Dynamic_Attachment) 27498 and then RTU_Loaded (Ada_Interrupts) 27499 and then (Is_RTE (Val, RE_Is_Reserved) or else 27500 Is_RTE (Val, RE_Is_Attached) or else 27501 Is_RTE (Val, RE_Current_Handler) or else 27502 Is_RTE (Val, RE_Attach_Handler) or else 27503 Is_RTE (Val, RE_Exchange_Handler) or else 27504 Is_RTE (Val, RE_Detach_Handler) or else 27505 Is_RTE (Val, RE_Reference)) 27506 27507 -- A special extra check, don't complain about a reference from within 27508 -- the Ada.Interrupts package itself! 27509 27510 and then not In_Same_Extended_Unit (N, Val) 27511 then 27512 Check_Restriction (No_Dynamic_Attachment, Post_Node); 27513 end if; 27514 27515 -- Check for No_Implementation_Identifiers 27516 27517 if Restriction_Check_Required (No_Implementation_Identifiers) then 27518 27519 -- We have an implementation defined entity if it is marked as 27520 -- implementation defined, or is defined in a package marked as 27521 -- implementation defined. However, library packages themselves 27522 -- are excluded (we don't want to flag Interfaces itself, just 27523 -- the entities within it). 27524 27525 if (Is_Implementation_Defined (Val) 27526 or else 27527 (Present (Scope (Val)) 27528 and then Is_Implementation_Defined (Scope (Val)))) 27529 and then not (Is_Package_Or_Generic_Package (Val) 27530 and then Is_Library_Level_Entity (Val)) 27531 then 27532 Check_Restriction (No_Implementation_Identifiers, Post_Node); 27533 end if; 27534 end if; 27535 27536 -- Do the style check 27537 27538 if Style_Check 27539 and then not Suppress_Style_Checks (Val) 27540 and then not In_Instance 27541 then 27542 if Nkind (N) = N_Identifier then 27543 Nod := N; 27544 elsif Nkind (N) = N_Expanded_Name then 27545 Nod := Selector_Name (N); 27546 else 27547 return; 27548 end if; 27549 27550 -- A special situation arises for derived operations, where we want 27551 -- to do the check against the parent (since the Sloc of the derived 27552 -- operation points to the derived type declaration itself). 27553 27554 Val_Actual := Val; 27555 while not Comes_From_Source (Val_Actual) 27556 and then Nkind (Val_Actual) in N_Entity 27557 and then (Ekind (Val_Actual) = E_Enumeration_Literal 27558 or else Is_Subprogram_Or_Generic_Subprogram (Val_Actual)) 27559 and then Present (Alias (Val_Actual)) 27560 loop 27561 Val_Actual := Alias (Val_Actual); 27562 end loop; 27563 27564 -- Renaming declarations for generic actuals do not come from source, 27565 -- and have a different name from that of the entity they rename, so 27566 -- there is no style check to perform here. 27567 27568 if Chars (Nod) = Chars (Val_Actual) then 27569 Style.Check_Identifier (Nod, Val_Actual); 27570 end if; 27571 end if; 27572 end Set_Entity_With_Checks; 27573 27574 ------------------------------ 27575 -- Set_Invalid_Scalar_Value -- 27576 ------------------------------ 27577 27578 procedure Set_Invalid_Scalar_Value 27579 (Scal_Typ : Float_Scalar_Id; 27580 Value : Ureal) 27581 is 27582 Slot : Ureal renames Invalid_Floats (Scal_Typ); 27583 27584 begin 27585 -- Detect an attempt to set a different value for the same scalar type 27586 27587 pragma Assert (Slot = No_Ureal); 27588 Slot := Value; 27589 end Set_Invalid_Scalar_Value; 27590 27591 ------------------------------ 27592 -- Set_Invalid_Scalar_Value -- 27593 ------------------------------ 27594 27595 procedure Set_Invalid_Scalar_Value 27596 (Scal_Typ : Integer_Scalar_Id; 27597 Value : Uint) 27598 is 27599 Slot : Uint renames Invalid_Integers (Scal_Typ); 27600 27601 begin 27602 -- Detect an attempt to set a different value for the same scalar type 27603 27604 pragma Assert (Slot = No_Uint); 27605 Slot := Value; 27606 end Set_Invalid_Scalar_Value; 27607 27608 ------------------------ 27609 -- Set_Name_Entity_Id -- 27610 ------------------------ 27611 27612 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is 27613 begin 27614 Set_Name_Table_Int (Id, Int (Val)); 27615 end Set_Name_Entity_Id; 27616 27617 --------------------- 27618 -- Set_Next_Actual -- 27619 --------------------- 27620 27621 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is 27622 begin 27623 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then 27624 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id); 27625 end if; 27626 end Set_Next_Actual; 27627 27628 ---------------------------------- 27629 -- Set_Optimize_Alignment_Flags -- 27630 ---------------------------------- 27631 27632 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is 27633 begin 27634 if Optimize_Alignment = 'S' then 27635 Set_Optimize_Alignment_Space (E); 27636 elsif Optimize_Alignment = 'T' then 27637 Set_Optimize_Alignment_Time (E); 27638 end if; 27639 end Set_Optimize_Alignment_Flags; 27640 27641 ----------------------- 27642 -- Set_Public_Status -- 27643 ----------------------- 27644 27645 procedure Set_Public_Status (Id : Entity_Id) is 27646 S : constant Entity_Id := Current_Scope; 27647 27648 function Within_HSS_Or_If (E : Entity_Id) return Boolean; 27649 -- Determines if E is defined within handled statement sequence or 27650 -- an if statement, returns True if so, False otherwise. 27651 27652 ---------------------- 27653 -- Within_HSS_Or_If -- 27654 ---------------------- 27655 27656 function Within_HSS_Or_If (E : Entity_Id) return Boolean is 27657 N : Node_Id; 27658 begin 27659 N := Declaration_Node (E); 27660 loop 27661 N := Parent (N); 27662 27663 if No (N) then 27664 return False; 27665 27666 elsif Nkind (N) in 27667 N_Handled_Sequence_Of_Statements | N_If_Statement 27668 then 27669 return True; 27670 end if; 27671 end loop; 27672 end Within_HSS_Or_If; 27673 27674 -- Start of processing for Set_Public_Status 27675 27676 begin 27677 -- Everything in the scope of Standard is public 27678 27679 if S = Standard_Standard then 27680 Set_Is_Public (Id); 27681 27682 -- Entity is definitely not public if enclosing scope is not public 27683 27684 elsif not Is_Public (S) then 27685 return; 27686 27687 -- An object or function declaration that occurs in a handled sequence 27688 -- of statements or within an if statement is the declaration for a 27689 -- temporary object or local subprogram generated by the expander. It 27690 -- never needs to be made public and furthermore, making it public can 27691 -- cause back end problems. 27692 27693 elsif Nkind (Parent (Id)) in 27694 N_Object_Declaration | N_Function_Specification 27695 and then Within_HSS_Or_If (Id) 27696 then 27697 return; 27698 27699 -- Entities in public packages or records are public 27700 27701 elsif Ekind (S) = E_Package or Is_Record_Type (S) then 27702 Set_Is_Public (Id); 27703 27704 -- The bounds of an entry family declaration can generate object 27705 -- declarations that are visible to the back-end, e.g. in the 27706 -- the declaration of a composite type that contains tasks. 27707 27708 elsif Is_Concurrent_Type (S) 27709 and then not Has_Completion (S) 27710 and then Nkind (Parent (Id)) = N_Object_Declaration 27711 then 27712 Set_Is_Public (Id); 27713 end if; 27714 end Set_Public_Status; 27715 27716 ----------------------------- 27717 -- Set_Referenced_Modified -- 27718 ----------------------------- 27719 27720 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is 27721 Pref : Node_Id; 27722 27723 begin 27724 -- Deal with indexed or selected component where prefix is modified 27725 27726 if Nkind (N) in N_Indexed_Component | N_Selected_Component then 27727 Pref := Prefix (N); 27728 27729 -- If prefix is access type, then it is the designated object that is 27730 -- being modified, which means we have no entity to set the flag on. 27731 27732 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then 27733 return; 27734 27735 -- Otherwise chase the prefix 27736 27737 else 27738 Set_Referenced_Modified (Pref, Out_Param); 27739 end if; 27740 27741 -- Otherwise see if we have an entity name (only other case to process) 27742 27743 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 27744 Set_Referenced_As_LHS (Entity (N), not Out_Param); 27745 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param); 27746 end if; 27747 end Set_Referenced_Modified; 27748 27749 ------------------ 27750 -- Set_Rep_Info -- 27751 ------------------ 27752 27753 procedure Set_Rep_Info (T1 : Entity_Id; T2 : Entity_Id) is 27754 begin 27755 Set_Is_Atomic (T1, Is_Atomic (T2)); 27756 Set_Is_Independent (T1, Is_Independent (T2)); 27757 Set_Is_Volatile_Full_Access (T1, Is_Volatile_Full_Access (T2)); 27758 27759 if Is_Base_Type (T1) then 27760 Set_Is_Volatile (T1, Is_Volatile (T2)); 27761 end if; 27762 end Set_Rep_Info; 27763 27764 ---------------------------- 27765 -- Set_Scope_Is_Transient -- 27766 ---------------------------- 27767 27768 procedure Set_Scope_Is_Transient (V : Boolean := True) is 27769 begin 27770 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V; 27771 end Set_Scope_Is_Transient; 27772 27773 ------------------- 27774 -- Set_Size_Info -- 27775 ------------------- 27776 27777 procedure Set_Size_Info (T1, T2 : Entity_Id) is 27778 begin 27779 -- We copy Esize, but not RM_Size, since in general RM_Size is 27780 -- subtype specific and does not get inherited by all subtypes. 27781 27782 Set_Esize (T1, Esize (T2)); 27783 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2)); 27784 27785 if Is_Discrete_Or_Fixed_Point_Type (T1) 27786 and then 27787 Is_Discrete_Or_Fixed_Point_Type (T2) 27788 then 27789 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2)); 27790 end if; 27791 27792 Set_Alignment (T1, Alignment (T2)); 27793 end Set_Size_Info; 27794 27795 ------------------------------ 27796 -- Should_Ignore_Pragma_Par -- 27797 ------------------------------ 27798 27799 function Should_Ignore_Pragma_Par (Prag_Name : Name_Id) return Boolean is 27800 pragma Assert (Compiler_State = Parsing); 27801 -- This one can't work during semantic analysis, because we don't have a 27802 -- correct Current_Source_File. 27803 27804 Result : constant Boolean := 27805 Get_Name_Table_Boolean3 (Prag_Name) 27806 and then not Is_Internal_File_Name 27807 (File_Name (Current_Source_File)); 27808 begin 27809 return Result; 27810 end Should_Ignore_Pragma_Par; 27811 27812 ------------------------------ 27813 -- Should_Ignore_Pragma_Sem -- 27814 ------------------------------ 27815 27816 function Should_Ignore_Pragma_Sem (N : Node_Id) return Boolean is 27817 pragma Assert (Compiler_State = Analyzing); 27818 Prag_Name : constant Name_Id := Pragma_Name (N); 27819 Result : constant Boolean := 27820 Get_Name_Table_Boolean3 (Prag_Name) 27821 and then not In_Internal_Unit (N); 27822 27823 begin 27824 return Result; 27825 end Should_Ignore_Pragma_Sem; 27826 27827 -------------------- 27828 -- Static_Boolean -- 27829 -------------------- 27830 27831 function Static_Boolean (N : Node_Id) return Uint is 27832 begin 27833 Analyze_And_Resolve (N, Standard_Boolean); 27834 27835 if N = Error 27836 or else Error_Posted (N) 27837 or else Etype (N) = Any_Type 27838 then 27839 return No_Uint; 27840 end if; 27841 27842 if Is_OK_Static_Expression (N) then 27843 if not Raises_Constraint_Error (N) then 27844 return Expr_Value (N); 27845 else 27846 return No_Uint; 27847 end if; 27848 27849 elsif Etype (N) = Any_Type then 27850 return No_Uint; 27851 27852 else 27853 Flag_Non_Static_Expr 27854 ("static boolean expression required here", N); 27855 return No_Uint; 27856 end if; 27857 end Static_Boolean; 27858 27859 -------------------- 27860 -- Static_Integer -- 27861 -------------------- 27862 27863 function Static_Integer (N : Node_Id) return Uint is 27864 begin 27865 Analyze_And_Resolve (N, Any_Integer); 27866 27867 if N = Error 27868 or else Error_Posted (N) 27869 or else Etype (N) = Any_Type 27870 then 27871 return No_Uint; 27872 end if; 27873 27874 if Is_OK_Static_Expression (N) then 27875 if not Raises_Constraint_Error (N) then 27876 return Expr_Value (N); 27877 else 27878 return No_Uint; 27879 end if; 27880 27881 elsif Etype (N) = Any_Type then 27882 return No_Uint; 27883 27884 else 27885 Flag_Non_Static_Expr 27886 ("static integer expression required here", N); 27887 return No_Uint; 27888 end if; 27889 end Static_Integer; 27890 27891 ------------------------------- 27892 -- Statically_Denotes_Entity -- 27893 ------------------------------- 27894 function Statically_Denotes_Entity (N : Node_Id) return Boolean is 27895 E : Entity_Id; 27896 begin 27897 if not Is_Entity_Name (N) then 27898 return False; 27899 else 27900 E := Entity (N); 27901 end if; 27902 27903 return 27904 Nkind (Parent (E)) /= N_Object_Renaming_Declaration 27905 or else Is_Prival (E) 27906 or else Statically_Denotes_Entity (Renamed_Object (E)); 27907 end Statically_Denotes_Entity; 27908 27909 ------------------------------- 27910 -- Statically_Denotes_Object -- 27911 ------------------------------- 27912 27913 function Statically_Denotes_Object (N : Node_Id) return Boolean is 27914 begin 27915 return Statically_Denotes_Entity (N) 27916 and then Is_Object_Reference (N); 27917 end Statically_Denotes_Object; 27918 27919 -------------------------- 27920 -- Statically_Different -- 27921 -------------------------- 27922 27923 function Statically_Different (E1, E2 : Node_Id) return Boolean is 27924 R1 : constant Node_Id := Get_Referenced_Object (E1); 27925 R2 : constant Node_Id := Get_Referenced_Object (E2); 27926 begin 27927 return Is_Entity_Name (R1) 27928 and then Is_Entity_Name (R2) 27929 and then Entity (R1) /= Entity (R2) 27930 and then not Is_Formal (Entity (R1)) 27931 and then not Is_Formal (Entity (R2)); 27932 end Statically_Different; 27933 27934 ----------------------------- 27935 -- Statically_Names_Object -- 27936 ----------------------------- 27937 27938 function Statically_Names_Object (N : Node_Id) return Boolean is 27939 begin 27940 if Statically_Denotes_Object (N) then 27941 return True; 27942 elsif Is_Entity_Name (N) then 27943 declare 27944 E : constant Entity_Id := Entity (N); 27945 begin 27946 return Nkind (Parent (E)) = N_Object_Renaming_Declaration 27947 and then Statically_Names_Object (Renamed_Object (E)); 27948 end; 27949 end if; 27950 27951 case Nkind (N) is 27952 when N_Indexed_Component => 27953 if Is_Access_Type (Etype (Prefix (N))) then 27954 -- treat implicit dereference same as explicit 27955 return False; 27956 end if; 27957 27958 if not Is_Constrained (Etype (Prefix (N))) then 27959 return False; 27960 end if; 27961 27962 declare 27963 Indx : Node_Id := First_Index (Etype (Prefix (N))); 27964 Expr : Node_Id := First (Expressions (N)); 27965 Index_Subtype : Node_Id; 27966 begin 27967 loop 27968 Index_Subtype := Etype (Indx); 27969 27970 if not Is_Static_Subtype (Index_Subtype) then 27971 return False; 27972 end if; 27973 if not Is_OK_Static_Expression (Expr) then 27974 return False; 27975 end if; 27976 27977 declare 27978 Index_Value : constant Uint := Expr_Value (Expr); 27979 Low_Value : constant Uint := 27980 Expr_Value (Type_Low_Bound (Index_Subtype)); 27981 High_Value : constant Uint := 27982 Expr_Value (Type_High_Bound (Index_Subtype)); 27983 begin 27984 if (Index_Value < Low_Value) 27985 or (Index_Value > High_Value) 27986 then 27987 return False; 27988 end if; 27989 end; 27990 27991 Next_Index (Indx); 27992 Expr := Next (Expr); 27993 pragma Assert ((Present (Indx) = Present (Expr)) 27994 or else (Serious_Errors_Detected > 0)); 27995 exit when not (Present (Indx) and Present (Expr)); 27996 end loop; 27997 end; 27998 27999 when N_Selected_Component => 28000 if Is_Access_Type (Etype (Prefix (N))) then 28001 -- treat implicit dereference same as explicit 28002 return False; 28003 end if; 28004 28005 if Ekind (Entity (Selector_Name (N))) not in 28006 E_Component | E_Discriminant 28007 then 28008 return False; 28009 end if; 28010 28011 declare 28012 Comp : constant Entity_Id := 28013 Original_Record_Component (Entity (Selector_Name (N))); 28014 begin 28015 -- AI12-0373 confirms that we should not call 28016 -- Has_Discriminant_Dependent_Constraint here which would be 28017 -- too strong. 28018 28019 if Is_Declared_Within_Variant (Comp) then 28020 return False; 28021 end if; 28022 end; 28023 28024 when others => -- includes N_Slice, N_Explicit_Dereference 28025 return False; 28026 end case; 28027 28028 pragma Assert (Present (Prefix (N))); 28029 28030 return Statically_Names_Object (Prefix (N)); 28031 end Statically_Names_Object; 28032 28033 --------------------------------- 28034 -- String_From_Numeric_Literal -- 28035 --------------------------------- 28036 28037 function String_From_Numeric_Literal (N : Node_Id) return String_Id is 28038 Loc : constant Source_Ptr := Sloc (N); 28039 Sbuffer : constant Source_Buffer_Ptr := 28040 Source_Text (Get_Source_File_Index (Loc)); 28041 Src_Ptr : Source_Ptr := Loc; 28042 28043 C : Character := Sbuffer (Src_Ptr); 28044 -- Current source program character 28045 28046 function Belongs_To_Numeric_Literal (C : Character) return Boolean; 28047 -- Return True if C belongs to the numeric literal 28048 28049 -------------------------------- 28050 -- Belongs_To_Numeric_Literal -- 28051 -------------------------------- 28052 28053 function Belongs_To_Numeric_Literal (C : Character) return Boolean is 28054 begin 28055 case C is 28056 when '0' .. '9' 28057 | '_' | '.' | 'e' | '#' | 'A' | 'B' | 'C' | 'D' | 'E' | 'F' 28058 => 28059 return True; 28060 28061 -- Make sure '+' or '-' is part of an exponent 28062 28063 when '+' | '-' => 28064 declare 28065 Prev_C : constant Character := Sbuffer (Src_Ptr - 1); 28066 begin 28067 return Prev_C = 'e' or else Prev_C = 'E'; 28068 end; 28069 28070 -- Other characters cannot belong to a numeric literal 28071 28072 when others => 28073 return False; 28074 end case; 28075 end Belongs_To_Numeric_Literal; 28076 28077 -- Start of processing for String_From_Numeric_Literal 28078 28079 begin 28080 Start_String; 28081 while Belongs_To_Numeric_Literal (C) loop 28082 Store_String_Char (C); 28083 Src_Ptr := Src_Ptr + 1; 28084 C := Sbuffer (Src_Ptr); 28085 end loop; 28086 28087 return End_String; 28088 end String_From_Numeric_Literal; 28089 28090 -------------------------------------- 28091 -- Subject_To_Loop_Entry_Attributes -- 28092 -------------------------------------- 28093 28094 function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is 28095 Stmt : Node_Id; 28096 28097 begin 28098 Stmt := N; 28099 28100 -- The expansion mechanism transform a loop subject to at least one 28101 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack 28102 -- the conditional part. 28103 28104 if Nkind (Stmt) in N_Block_Statement | N_If_Statement 28105 and then Nkind (Original_Node (N)) = N_Loop_Statement 28106 then 28107 Stmt := Original_Node (N); 28108 end if; 28109 28110 return 28111 Nkind (Stmt) = N_Loop_Statement 28112 and then Present (Identifier (Stmt)) 28113 and then Present (Entity (Identifier (Stmt))) 28114 and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt))); 28115 end Subject_To_Loop_Entry_Attributes; 28116 28117 ----------------------------- 28118 -- Subprogram_Access_Level -- 28119 ----------------------------- 28120 28121 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is 28122 begin 28123 if Present (Alias (Subp)) then 28124 return Subprogram_Access_Level (Alias (Subp)); 28125 else 28126 return Scope_Depth (Enclosing_Dynamic_Scope (Subp)); 28127 end if; 28128 end Subprogram_Access_Level; 28129 28130 --------------------- 28131 -- Subprogram_Name -- 28132 --------------------- 28133 28134 function Subprogram_Name (N : Node_Id) return String is 28135 Buf : Bounded_String; 28136 Ent : Node_Id := N; 28137 Nod : Node_Id; 28138 28139 begin 28140 while Present (Ent) loop 28141 case Nkind (Ent) is 28142 when N_Subprogram_Body => 28143 Ent := Defining_Unit_Name (Specification (Ent)); 28144 exit; 28145 28146 when N_Subprogram_Declaration => 28147 Nod := Corresponding_Body (Ent); 28148 28149 if Present (Nod) then 28150 Ent := Nod; 28151 else 28152 Ent := Defining_Unit_Name (Specification (Ent)); 28153 end if; 28154 28155 exit; 28156 28157 when N_Subprogram_Instantiation 28158 | N_Package_Body 28159 | N_Package_Specification 28160 => 28161 Ent := Defining_Unit_Name (Ent); 28162 exit; 28163 28164 when N_Protected_Type_Declaration => 28165 Ent := Corresponding_Body (Ent); 28166 exit; 28167 28168 when N_Protected_Body 28169 | N_Task_Body 28170 => 28171 Ent := Defining_Identifier (Ent); 28172 exit; 28173 28174 when others => 28175 null; 28176 end case; 28177 28178 Ent := Parent (Ent); 28179 end loop; 28180 28181 if No (Ent) then 28182 return "unknown subprogram:unknown file:0:0"; 28183 end if; 28184 28185 -- If the subprogram is a child unit, use its simple name to start the 28186 -- construction of the fully qualified name. 28187 28188 if Nkind (Ent) = N_Defining_Program_Unit_Name then 28189 Ent := Defining_Identifier (Ent); 28190 end if; 28191 28192 Append_Entity_Name (Buf, Ent); 28193 28194 -- Append homonym number if needed 28195 28196 if Nkind (N) in N_Entity and then Has_Homonym (N) then 28197 declare 28198 H : Entity_Id := Homonym (N); 28199 Nr : Nat := 1; 28200 28201 begin 28202 while Present (H) loop 28203 if Scope (H) = Scope (N) then 28204 Nr := Nr + 1; 28205 end if; 28206 28207 H := Homonym (H); 28208 end loop; 28209 28210 if Nr > 1 then 28211 Append (Buf, '#'); 28212 Append (Buf, Nr); 28213 end if; 28214 end; 28215 end if; 28216 28217 -- Append source location of Ent to Buf so that the string will 28218 -- look like "subp:file:line:col". 28219 28220 declare 28221 Loc : constant Source_Ptr := Sloc (Ent); 28222 begin 28223 Append (Buf, ':'); 28224 Append (Buf, Reference_Name (Get_Source_File_Index (Loc))); 28225 Append (Buf, ':'); 28226 Append (Buf, Nat (Get_Logical_Line_Number (Loc))); 28227 Append (Buf, ':'); 28228 Append (Buf, Nat (Get_Column_Number (Loc))); 28229 end; 28230 28231 return +Buf; 28232 end Subprogram_Name; 28233 28234 ------------------------------- 28235 -- Support_Atomic_Primitives -- 28236 ------------------------------- 28237 28238 function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is 28239 Size : Int; 28240 28241 begin 28242 -- Verify the alignment of Typ is known 28243 28244 if not Known_Alignment (Typ) then 28245 return False; 28246 end if; 28247 28248 if Known_Static_Esize (Typ) then 28249 Size := UI_To_Int (Esize (Typ)); 28250 28251 -- If the Esize (Object_Size) is unknown at compile time, look at the 28252 -- RM_Size (Value_Size) which may have been set by an explicit rep item. 28253 28254 elsif Known_Static_RM_Size (Typ) then 28255 Size := UI_To_Int (RM_Size (Typ)); 28256 28257 -- Otherwise, the size is considered to be unknown. 28258 28259 else 28260 return False; 28261 end if; 28262 28263 -- Check that the size of the component is 8, 16, 32, or 64 bits and 28264 -- that Typ is properly aligned. 28265 28266 case Size is 28267 when 8 | 16 | 32 | 64 => 28268 return Size = UI_To_Int (Alignment (Typ)) * 8; 28269 28270 when others => 28271 return False; 28272 end case; 28273 end Support_Atomic_Primitives; 28274 28275 ----------------- 28276 -- Trace_Scope -- 28277 ----------------- 28278 28279 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is 28280 begin 28281 if Debug_Flag_W then 28282 for J in 0 .. Scope_Stack.Last loop 28283 Write_Str (" "); 28284 end loop; 28285 28286 Write_Str (Msg); 28287 Write_Name (Chars (E)); 28288 Write_Str (" from "); 28289 Write_Location (Sloc (N)); 28290 Write_Eol; 28291 end if; 28292 end Trace_Scope; 28293 28294 ----------------------- 28295 -- Transfer_Entities -- 28296 ----------------------- 28297 28298 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is 28299 procedure Set_Public_Status_Of (Id : Entity_Id); 28300 -- Set the Is_Public attribute of arbitrary entity Id by calling routine 28301 -- Set_Public_Status. If successful and Id denotes a record type, set 28302 -- the Is_Public attribute of its fields. 28303 28304 -------------------------- 28305 -- Set_Public_Status_Of -- 28306 -------------------------- 28307 28308 procedure Set_Public_Status_Of (Id : Entity_Id) is 28309 Field : Entity_Id; 28310 28311 begin 28312 if not Is_Public (Id) then 28313 Set_Public_Status (Id); 28314 28315 -- When the input entity is a public record type, ensure that all 28316 -- its internal fields are also exposed to the linker. The fields 28317 -- of a class-wide type are never made public. 28318 28319 if Is_Public (Id) 28320 and then Is_Record_Type (Id) 28321 and then not Is_Class_Wide_Type (Id) 28322 then 28323 Field := First_Entity (Id); 28324 while Present (Field) loop 28325 Set_Is_Public (Field); 28326 Next_Entity (Field); 28327 end loop; 28328 end if; 28329 end if; 28330 end Set_Public_Status_Of; 28331 28332 -- Local variables 28333 28334 Full_Id : Entity_Id; 28335 Id : Entity_Id; 28336 28337 -- Start of processing for Transfer_Entities 28338 28339 begin 28340 Id := First_Entity (From); 28341 28342 if Present (Id) then 28343 28344 -- Merge the entity chain of the source scope with that of the 28345 -- destination scope. 28346 28347 if Present (Last_Entity (To)) then 28348 Link_Entities (Last_Entity (To), Id); 28349 else 28350 Set_First_Entity (To, Id); 28351 end if; 28352 28353 Set_Last_Entity (To, Last_Entity (From)); 28354 28355 -- Inspect the entities of the source scope and update their Scope 28356 -- attribute. 28357 28358 while Present (Id) loop 28359 Set_Scope (Id, To); 28360 Set_Public_Status_Of (Id); 28361 28362 -- Handle an internally generated full view for a private type 28363 28364 if Is_Private_Type (Id) 28365 and then Present (Full_View (Id)) 28366 and then Is_Itype (Full_View (Id)) 28367 then 28368 Full_Id := Full_View (Id); 28369 28370 Set_Scope (Full_Id, To); 28371 Set_Public_Status_Of (Full_Id); 28372 end if; 28373 28374 Next_Entity (Id); 28375 end loop; 28376 28377 Set_First_Entity (From, Empty); 28378 Set_Last_Entity (From, Empty); 28379 end if; 28380 end Transfer_Entities; 28381 28382 ------------------------ 28383 -- Traverse_More_Func -- 28384 ------------------------ 28385 28386 function Traverse_More_Func (Node : Node_Id) return Traverse_Final_Result is 28387 28388 Processing_Itype : Boolean := False; 28389 -- Set to True while traversing the nodes under an Itype, to prevent 28390 -- looping on Itype handling during that traversal. 28391 28392 function Process_More (N : Node_Id) return Traverse_Result; 28393 -- Wrapper over the Process callback to handle parts of the AST that 28394 -- are not normally traversed as syntactic children. 28395 28396 function Traverse_Rec (N : Node_Id) return Traverse_Final_Result; 28397 -- Main recursive traversal implemented as an instantiation of 28398 -- Traverse_Func over a modified Process callback. 28399 28400 ------------------ 28401 -- Process_More -- 28402 ------------------ 28403 28404 function Process_More (N : Node_Id) return Traverse_Result is 28405 28406 procedure Traverse_More (N : Node_Id; 28407 Res : in out Traverse_Result); 28408 procedure Traverse_More (L : List_Id; 28409 Res : in out Traverse_Result); 28410 -- Traverse a node or list and update the traversal result to value 28411 -- Abandon when needed. 28412 28413 ------------------- 28414 -- Traverse_More -- 28415 ------------------- 28416 28417 procedure Traverse_More (N : Node_Id; 28418 Res : in out Traverse_Result) 28419 is 28420 begin 28421 -- Do not process any more nodes if Abandon was reached 28422 28423 if Res = Abandon then 28424 return; 28425 end if; 28426 28427 if Traverse_Rec (N) = Abandon then 28428 Res := Abandon; 28429 end if; 28430 end Traverse_More; 28431 28432 procedure Traverse_More (L : List_Id; 28433 Res : in out Traverse_Result) 28434 is 28435 N : Node_Id := First (L); 28436 28437 begin 28438 -- Do not process any more nodes if Abandon was reached 28439 28440 if Res = Abandon then 28441 return; 28442 end if; 28443 28444 while Present (N) loop 28445 Traverse_More (N, Res); 28446 Next (N); 28447 end loop; 28448 end Traverse_More; 28449 28450 -- Local variables 28451 28452 Node : Node_Id; 28453 Result : Traverse_Result; 28454 28455 -- Start of processing for Process_More 28456 28457 begin 28458 -- Initial callback to Process. Return immediately on Skip/Abandon. 28459 -- Otherwise update the value of Node for further processing of 28460 -- non-syntactic children. 28461 28462 Result := Process (N); 28463 28464 case Result is 28465 when OK => Node := N; 28466 when OK_Orig => Node := Original_Node (N); 28467 when Skip => return Skip; 28468 when Abandon => return Abandon; 28469 end case; 28470 28471 -- Process the relevant semantic children which are a logical part of 28472 -- the AST under this node before returning for the processing of 28473 -- syntactic children. 28474 28475 -- Start with all non-syntactic lists of action nodes 28476 28477 case Nkind (Node) is 28478 when N_Component_Association => 28479 Traverse_More (Loop_Actions (Node), Result); 28480 28481 when N_Elsif_Part => 28482 Traverse_More (Condition_Actions (Node), Result); 28483 28484 when N_Short_Circuit => 28485 Traverse_More (Actions (Node), Result); 28486 28487 when N_Case_Expression_Alternative => 28488 Traverse_More (Actions (Node), Result); 28489 28490 when N_Iterated_Component_Association => 28491 Traverse_More (Loop_Actions (Node), Result); 28492 28493 when N_Iteration_Scheme => 28494 Traverse_More (Condition_Actions (Node), Result); 28495 28496 when N_If_Expression => 28497 Traverse_More (Then_Actions (Node), Result); 28498 Traverse_More (Else_Actions (Node), Result); 28499 28500 -- Various nodes have a field Actions as a syntactic node, 28501 -- so it will be traversed in the regular syntactic traversal. 28502 28503 when N_Compilation_Unit_Aux 28504 | N_Compound_Statement 28505 | N_Expression_With_Actions 28506 | N_Freeze_Entity 28507 => 28508 null; 28509 28510 when others => 28511 null; 28512 end case; 28513 28514 -- If Process_Itypes is True, process unattached nodes which come 28515 -- from Itypes. This only concerns currently ranges of scalar 28516 -- (possibly as index) types. This traversal is protected against 28517 -- looping with Processing_Itype. 28518 28519 if Process_Itypes 28520 and then not Processing_Itype 28521 and then Nkind (Node) in N_Has_Etype 28522 and then Present (Etype (Node)) 28523 and then Is_Itype (Etype (Node)) 28524 then 28525 declare 28526 Typ : constant Entity_Id := Etype (Node); 28527 begin 28528 Processing_Itype := True; 28529 28530 case Ekind (Typ) is 28531 when Scalar_Kind => 28532 Traverse_More (Scalar_Range (Typ), Result); 28533 28534 when Array_Kind => 28535 declare 28536 Index : Node_Id := First_Index (Typ); 28537 Rng : Node_Id; 28538 begin 28539 while Present (Index) loop 28540 if Nkind (Index) in N_Has_Entity then 28541 Rng := Scalar_Range (Entity (Index)); 28542 else 28543 Rng := Index; 28544 end if; 28545 28546 Traverse_More (Rng, Result); 28547 Next_Index (Index); 28548 end loop; 28549 end; 28550 when others => 28551 null; 28552 end case; 28553 28554 Processing_Itype := False; 28555 end; 28556 end if; 28557 28558 return Result; 28559 end Process_More; 28560 28561 -- Define Traverse_Rec as a renaming of the instantiation, as an 28562 -- instantiation cannot complete a previous spec. 28563 28564 function Traverse_Recursive is new Traverse_Func (Process_More); 28565 function Traverse_Rec (N : Node_Id) return Traverse_Final_Result 28566 renames Traverse_Recursive; 28567 28568 -- Start of processing for Traverse_More_Func 28569 28570 begin 28571 return Traverse_Rec (Node); 28572 end Traverse_More_Func; 28573 28574 ------------------------ 28575 -- Traverse_More_Proc -- 28576 ------------------------ 28577 28578 procedure Traverse_More_Proc (Node : Node_Id) is 28579 function Traverse is new Traverse_More_Func (Process, Process_Itypes); 28580 Discard : Traverse_Final_Result; 28581 pragma Warnings (Off, Discard); 28582 begin 28583 Discard := Traverse (Node); 28584 end Traverse_More_Proc; 28585 28586 ----------------------- 28587 -- Type_Access_Level -- 28588 ----------------------- 28589 28590 function Type_Access_Level (Typ : Entity_Id) return Uint is 28591 Btyp : Entity_Id; 28592 28593 begin 28594 Btyp := Base_Type (Typ); 28595 28596 -- Ada 2005 (AI-230): For most cases of anonymous access types, we 28597 -- simply use the level where the type is declared. This is true for 28598 -- stand-alone object declarations, and for anonymous access types 28599 -- associated with components the level is the same as that of the 28600 -- enclosing composite type. However, special treatment is needed for 28601 -- the cases of access parameters, return objects of an anonymous access 28602 -- type, and, in Ada 95, access discriminants of limited types. 28603 28604 if Is_Access_Type (Btyp) then 28605 if Ekind (Btyp) = E_Anonymous_Access_Type then 28606 28607 -- If the type is a nonlocal anonymous access type (such as for 28608 -- an access parameter) we treat it as being declared at the 28609 -- library level to ensure that names such as X.all'access don't 28610 -- fail static accessibility checks. 28611 28612 if not Is_Local_Anonymous_Access (Typ) then 28613 return Scope_Depth (Standard_Standard); 28614 28615 -- If this is a return object, the accessibility level is that of 28616 -- the result subtype of the enclosing function. The test here is 28617 -- little complicated, because we have to account for extended 28618 -- return statements that have been rewritten as blocks, in which 28619 -- case we have to find and the Is_Return_Object attribute of the 28620 -- itype's associated object. It would be nice to find a way to 28621 -- simplify this test, but it doesn't seem worthwhile to add a new 28622 -- flag just for purposes of this test. ??? 28623 28624 elsif Ekind (Scope (Btyp)) = E_Return_Statement 28625 or else 28626 (Is_Itype (Btyp) 28627 and then Nkind (Associated_Node_For_Itype (Btyp)) = 28628 N_Object_Declaration 28629 and then Is_Return_Object 28630 (Defining_Identifier 28631 (Associated_Node_For_Itype (Btyp)))) 28632 then 28633 declare 28634 Scop : Entity_Id; 28635 28636 begin 28637 Scop := Scope (Scope (Btyp)); 28638 while Present (Scop) loop 28639 exit when Ekind (Scop) = E_Function; 28640 Scop := Scope (Scop); 28641 end loop; 28642 28643 -- Treat the return object's type as having the level of the 28644 -- function's result subtype (as per RM05-6.5(5.3/2)). 28645 28646 return Type_Access_Level (Etype (Scop)); 28647 end; 28648 end if; 28649 end if; 28650 28651 Btyp := Root_Type (Btyp); 28652 28653 -- The accessibility level of anonymous access types associated with 28654 -- discriminants is that of the current instance of the type, and 28655 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)). 28656 28657 -- AI-402: access discriminants have accessibility based on the 28658 -- object rather than the type in Ada 2005, so the above paragraph 28659 -- doesn't apply. 28660 28661 -- ??? Needs completion with rules from AI-416 28662 28663 if Ada_Version <= Ada_95 28664 and then Ekind (Typ) = E_Anonymous_Access_Type 28665 and then Present (Associated_Node_For_Itype (Typ)) 28666 and then Nkind (Associated_Node_For_Itype (Typ)) = 28667 N_Discriminant_Specification 28668 then 28669 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1; 28670 end if; 28671 end if; 28672 28673 -- Return library level for a generic formal type. This is done because 28674 -- RM(10.3.2) says that "The statically deeper relationship does not 28675 -- apply to ... a descendant of a generic formal type". Rather than 28676 -- checking at each point where a static accessibility check is 28677 -- performed to see if we are dealing with a formal type, this rule is 28678 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level 28679 -- return extreme values for a formal type; Deepest_Type_Access_Level 28680 -- returns Int'Last. By calling the appropriate function from among the 28681 -- two, we ensure that the static accessibility check will pass if we 28682 -- happen to run into a formal type. More specifically, we should call 28683 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the 28684 -- call occurs as part of a static accessibility check and the error 28685 -- case is the case where the type's level is too shallow (as opposed 28686 -- to too deep). 28687 28688 if Is_Generic_Type (Root_Type (Btyp)) then 28689 return Scope_Depth (Standard_Standard); 28690 end if; 28691 28692 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); 28693 end Type_Access_Level; 28694 28695 ------------------------------------ 28696 -- Type_Without_Stream_Operation -- 28697 ------------------------------------ 28698 28699 function Type_Without_Stream_Operation 28700 (T : Entity_Id; 28701 Op : TSS_Name_Type := TSS_Null) return Entity_Id 28702 is 28703 BT : constant Entity_Id := Base_Type (T); 28704 Op_Missing : Boolean; 28705 28706 begin 28707 if not Restriction_Active (No_Default_Stream_Attributes) then 28708 return Empty; 28709 end if; 28710 28711 if Is_Elementary_Type (T) then 28712 if Op = TSS_Null then 28713 Op_Missing := 28714 No (TSS (BT, TSS_Stream_Read)) 28715 or else No (TSS (BT, TSS_Stream_Write)); 28716 28717 else 28718 Op_Missing := No (TSS (BT, Op)); 28719 end if; 28720 28721 if Op_Missing then 28722 return T; 28723 else 28724 return Empty; 28725 end if; 28726 28727 elsif Is_Array_Type (T) then 28728 return Type_Without_Stream_Operation (Component_Type (T), Op); 28729 28730 elsif Is_Record_Type (T) then 28731 declare 28732 Comp : Entity_Id; 28733 C_Typ : Entity_Id; 28734 28735 begin 28736 Comp := First_Component (T); 28737 while Present (Comp) loop 28738 C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op); 28739 28740 if Present (C_Typ) then 28741 return C_Typ; 28742 end if; 28743 28744 Next_Component (Comp); 28745 end loop; 28746 28747 return Empty; 28748 end; 28749 28750 elsif Is_Private_Type (T) and then Present (Full_View (T)) then 28751 return Type_Without_Stream_Operation (Full_View (T), Op); 28752 else 28753 return Empty; 28754 end if; 28755 end Type_Without_Stream_Operation; 28756 28757 --------------------- 28758 -- Ultimate_Prefix -- 28759 --------------------- 28760 28761 function Ultimate_Prefix (N : Node_Id) return Node_Id is 28762 Pref : Node_Id; 28763 28764 begin 28765 Pref := N; 28766 while Nkind (Pref) in N_Explicit_Dereference 28767 | N_Indexed_Component 28768 | N_Selected_Component 28769 | N_Slice 28770 loop 28771 Pref := Prefix (Pref); 28772 end loop; 28773 28774 return Pref; 28775 end Ultimate_Prefix; 28776 28777 ---------------------------- 28778 -- Unique_Defining_Entity -- 28779 ---------------------------- 28780 28781 function Unique_Defining_Entity (N : Node_Id) return Entity_Id is 28782 begin 28783 return Unique_Entity (Defining_Entity (N)); 28784 end Unique_Defining_Entity; 28785 28786 ------------------- 28787 -- Unique_Entity -- 28788 ------------------- 28789 28790 function Unique_Entity (E : Entity_Id) return Entity_Id is 28791 U : Entity_Id := E; 28792 P : Node_Id; 28793 28794 begin 28795 case Ekind (E) is 28796 when E_Constant => 28797 if Present (Full_View (E)) then 28798 U := Full_View (E); 28799 end if; 28800 28801 when Entry_Kind => 28802 if Nkind (Parent (E)) = N_Entry_Body then 28803 declare 28804 Prot_Item : Entity_Id; 28805 Prot_Type : Entity_Id; 28806 28807 begin 28808 if Ekind (E) = E_Entry then 28809 Prot_Type := Scope (E); 28810 28811 -- Bodies of entry families are nested within an extra scope 28812 -- that contains an entry index declaration. 28813 28814 else 28815 Prot_Type := Scope (Scope (E)); 28816 end if; 28817 28818 -- A protected type may be declared as a private type, in 28819 -- which case we need to get its full view. 28820 28821 if Is_Private_Type (Prot_Type) then 28822 Prot_Type := Full_View (Prot_Type); 28823 end if; 28824 28825 -- Full view may not be present on error, in which case 28826 -- return E by default. 28827 28828 if Present (Prot_Type) then 28829 pragma Assert (Ekind (Prot_Type) = E_Protected_Type); 28830 28831 -- Traverse the entity list of the protected type and 28832 -- locate an entry declaration which matches the entry 28833 -- body. 28834 28835 Prot_Item := First_Entity (Prot_Type); 28836 while Present (Prot_Item) loop 28837 if Ekind (Prot_Item) in Entry_Kind 28838 and then Corresponding_Body (Parent (Prot_Item)) = E 28839 then 28840 U := Prot_Item; 28841 exit; 28842 end if; 28843 28844 Next_Entity (Prot_Item); 28845 end loop; 28846 end if; 28847 end; 28848 end if; 28849 28850 when Formal_Kind => 28851 if Present (Spec_Entity (E)) then 28852 U := Spec_Entity (E); 28853 end if; 28854 28855 when E_Package_Body => 28856 P := Parent (E); 28857 28858 if Nkind (P) = N_Defining_Program_Unit_Name then 28859 P := Parent (P); 28860 end if; 28861 28862 if Nkind (P) = N_Package_Body 28863 and then Present (Corresponding_Spec (P)) 28864 then 28865 U := Corresponding_Spec (P); 28866 28867 elsif Nkind (P) = N_Package_Body_Stub 28868 and then Present (Corresponding_Spec_Of_Stub (P)) 28869 then 28870 U := Corresponding_Spec_Of_Stub (P); 28871 end if; 28872 28873 when E_Protected_Body => 28874 P := Parent (E); 28875 28876 if Nkind (P) = N_Protected_Body 28877 and then Present (Corresponding_Spec (P)) 28878 then 28879 U := Corresponding_Spec (P); 28880 28881 elsif Nkind (P) = N_Protected_Body_Stub 28882 and then Present (Corresponding_Spec_Of_Stub (P)) 28883 then 28884 U := Corresponding_Spec_Of_Stub (P); 28885 28886 if Is_Single_Protected_Object (U) then 28887 U := Etype (U); 28888 end if; 28889 end if; 28890 28891 if Is_Private_Type (U) then 28892 U := Full_View (U); 28893 end if; 28894 28895 when E_Subprogram_Body => 28896 P := Parent (E); 28897 28898 if Nkind (P) = N_Defining_Program_Unit_Name then 28899 P := Parent (P); 28900 end if; 28901 28902 P := Parent (P); 28903 28904 if Nkind (P) = N_Subprogram_Body 28905 and then Present (Corresponding_Spec (P)) 28906 then 28907 U := Corresponding_Spec (P); 28908 28909 elsif Nkind (P) = N_Subprogram_Body_Stub 28910 and then Present (Corresponding_Spec_Of_Stub (P)) 28911 then 28912 U := Corresponding_Spec_Of_Stub (P); 28913 28914 elsif Nkind (P) = N_Subprogram_Renaming_Declaration then 28915 U := Corresponding_Spec (P); 28916 end if; 28917 28918 when E_Task_Body => 28919 P := Parent (E); 28920 28921 if Nkind (P) = N_Task_Body 28922 and then Present (Corresponding_Spec (P)) 28923 then 28924 U := Corresponding_Spec (P); 28925 28926 elsif Nkind (P) = N_Task_Body_Stub 28927 and then Present (Corresponding_Spec_Of_Stub (P)) 28928 then 28929 U := Corresponding_Spec_Of_Stub (P); 28930 28931 if Is_Single_Task_Object (U) then 28932 U := Etype (U); 28933 end if; 28934 end if; 28935 28936 if Is_Private_Type (U) then 28937 U := Full_View (U); 28938 end if; 28939 28940 when Type_Kind => 28941 if Present (Full_View (E)) then 28942 U := Full_View (E); 28943 end if; 28944 28945 when others => 28946 null; 28947 end case; 28948 28949 return U; 28950 end Unique_Entity; 28951 28952 ----------------- 28953 -- Unique_Name -- 28954 ----------------- 28955 28956 function Unique_Name (E : Entity_Id) return String is 28957 28958 -- Local subprograms 28959 28960 function Add_Homonym_Suffix (E : Entity_Id) return String; 28961 28962 function This_Name return String; 28963 28964 ------------------------ 28965 -- Add_Homonym_Suffix -- 28966 ------------------------ 28967 28968 function Add_Homonym_Suffix (E : Entity_Id) return String is 28969 28970 -- Names in E_Subprogram_Body or E_Package_Body entities are not 28971 -- reliable, as they may not include the overloading suffix. 28972 -- Instead, when looking for the name of E or one of its enclosing 28973 -- scope, we get the name of the corresponding Unique_Entity. 28974 28975 U : constant Entity_Id := Unique_Entity (E); 28976 Nam : constant String := Get_Name_String (Chars (U)); 28977 28978 begin 28979 -- If E has homonyms but is not fully qualified, as done in 28980 -- GNATprove mode, append the homonym number on the fly. Strip the 28981 -- leading space character in the image of natural numbers. Also do 28982 -- not print the homonym value of 1. 28983 28984 if Has_Homonym (U) then 28985 declare 28986 N : constant Pos := Homonym_Number (U); 28987 S : constant String := N'Img; 28988 begin 28989 if N > 1 then 28990 return Nam & "__" & S (2 .. S'Last); 28991 end if; 28992 end; 28993 end if; 28994 28995 return Nam; 28996 end Add_Homonym_Suffix; 28997 28998 --------------- 28999 -- This_Name -- 29000 --------------- 29001 29002 function This_Name return String is 29003 begin 29004 return Add_Homonym_Suffix (E); 29005 end This_Name; 29006 29007 -- Local variables 29008 29009 U : constant Entity_Id := Unique_Entity (E); 29010 29011 -- Start of processing for Unique_Name 29012 29013 begin 29014 if E = Standard_Standard 29015 or else Has_Fully_Qualified_Name (E) 29016 then 29017 return This_Name; 29018 29019 elsif Ekind (E) = E_Enumeration_Literal then 29020 return Unique_Name (Etype (E)) & "__" & This_Name; 29021 29022 else 29023 declare 29024 S : constant Entity_Id := Scope (U); 29025 pragma Assert (Present (S)); 29026 29027 begin 29028 -- Prefix names of predefined types with standard__, but leave 29029 -- names of user-defined packages and subprograms without prefix 29030 -- (even if technically they are nested in the Standard package). 29031 29032 if S = Standard_Standard then 29033 if Ekind (U) = E_Package or else Is_Subprogram (U) then 29034 return This_Name; 29035 else 29036 return Unique_Name (S) & "__" & This_Name; 29037 end if; 29038 29039 -- For intances of generic subprograms use the name of the related 29040 -- instance and skip the scope of its wrapper package. 29041 29042 elsif Is_Wrapper_Package (S) then 29043 pragma Assert (Scope (S) = Scope (Related_Instance (S))); 29044 -- Wrapper package and the instantiation are in the same scope 29045 29046 declare 29047 Related_Name : constant String := 29048 Add_Homonym_Suffix (Related_Instance (S)); 29049 Enclosing_Name : constant String := 29050 Unique_Name (Scope (S)) & "__" & Related_Name; 29051 29052 begin 29053 if Is_Subprogram (U) 29054 and then not Is_Generic_Actual_Subprogram (U) 29055 then 29056 return Enclosing_Name; 29057 else 29058 return Enclosing_Name & "__" & This_Name; 29059 end if; 29060 end; 29061 29062 elsif Is_Child_Unit (U) then 29063 return Child_Prefix & Unique_Name (S) & "__" & This_Name; 29064 else 29065 return Unique_Name (S) & "__" & This_Name; 29066 end if; 29067 end; 29068 end if; 29069 end Unique_Name; 29070 29071 --------------------- 29072 -- Unit_Is_Visible -- 29073 --------------------- 29074 29075 function Unit_Is_Visible (U : Entity_Id) return Boolean is 29076 Curr : constant Node_Id := Cunit (Current_Sem_Unit); 29077 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 29078 29079 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean; 29080 -- For a child unit, check whether unit appears in a with_clause 29081 -- of a parent. 29082 29083 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean; 29084 -- Scan the context clause of one compilation unit looking for a 29085 -- with_clause for the unit in question. 29086 29087 ---------------------------- 29088 -- Unit_In_Parent_Context -- 29089 ---------------------------- 29090 29091 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is 29092 begin 29093 if Unit_In_Context (Par_Unit) then 29094 return True; 29095 29096 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then 29097 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit))); 29098 29099 else 29100 return False; 29101 end if; 29102 end Unit_In_Parent_Context; 29103 29104 --------------------- 29105 -- Unit_In_Context -- 29106 --------------------- 29107 29108 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is 29109 Clause : Node_Id; 29110 29111 begin 29112 Clause := First (Context_Items (Comp_Unit)); 29113 while Present (Clause) loop 29114 if Nkind (Clause) = N_With_Clause then 29115 if Library_Unit (Clause) = U then 29116 return True; 29117 29118 -- The with_clause may denote a renaming of the unit we are 29119 -- looking for, eg. Text_IO which renames Ada.Text_IO. 29120 29121 elsif 29122 Renamed_Entity (Entity (Name (Clause))) = 29123 Defining_Entity (Unit (U)) 29124 then 29125 return True; 29126 end if; 29127 end if; 29128 29129 Next (Clause); 29130 end loop; 29131 29132 return False; 29133 end Unit_In_Context; 29134 29135 -- Start of processing for Unit_Is_Visible 29136 29137 begin 29138 -- The currrent unit is directly visible 29139 29140 if Curr = U then 29141 return True; 29142 29143 elsif Unit_In_Context (Curr) then 29144 return True; 29145 29146 -- If the current unit is a body, check the context of the spec 29147 29148 elsif Nkind (Unit (Curr)) = N_Package_Body 29149 or else 29150 (Nkind (Unit (Curr)) = N_Subprogram_Body 29151 and then not Acts_As_Spec (Unit (Curr))) 29152 then 29153 if Unit_In_Context (Library_Unit (Curr)) then 29154 return True; 29155 end if; 29156 end if; 29157 29158 -- If the spec is a child unit, examine the parents 29159 29160 if Is_Child_Unit (Curr_Entity) then 29161 if Nkind (Unit (Curr)) in N_Unit_Body then 29162 return 29163 Unit_In_Parent_Context 29164 (Parent_Spec (Unit (Library_Unit (Curr)))); 29165 else 29166 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr))); 29167 end if; 29168 29169 else 29170 return False; 29171 end if; 29172 end Unit_Is_Visible; 29173 29174 ------------------------------ 29175 -- Universal_Interpretation -- 29176 ------------------------------ 29177 29178 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is 29179 Index : Interp_Index; 29180 It : Interp; 29181 29182 begin 29183 -- The argument may be a formal parameter of an operator or subprogram 29184 -- with multiple interpretations, or else an expression for an actual. 29185 29186 if Nkind (Opnd) = N_Defining_Identifier 29187 or else not Is_Overloaded (Opnd) 29188 then 29189 if Etype (Opnd) = Universal_Integer 29190 or else Etype (Opnd) = Universal_Real 29191 then 29192 return Etype (Opnd); 29193 else 29194 return Empty; 29195 end if; 29196 29197 else 29198 Get_First_Interp (Opnd, Index, It); 29199 while Present (It.Typ) loop 29200 if It.Typ = Universal_Integer 29201 or else It.Typ = Universal_Real 29202 then 29203 return It.Typ; 29204 end if; 29205 29206 Get_Next_Interp (Index, It); 29207 end loop; 29208 29209 return Empty; 29210 end if; 29211 end Universal_Interpretation; 29212 29213 --------------- 29214 -- Unqualify -- 29215 --------------- 29216 29217 function Unqualify (Expr : Node_Id) return Node_Id is 29218 begin 29219 -- Recurse to handle unlikely case of multiple levels of qualification 29220 29221 if Nkind (Expr) = N_Qualified_Expression then 29222 return Unqualify (Expression (Expr)); 29223 29224 -- Normal case, not a qualified expression 29225 29226 else 29227 return Expr; 29228 end if; 29229 end Unqualify; 29230 29231 ----------------- 29232 -- Unqual_Conv -- 29233 ----------------- 29234 29235 function Unqual_Conv (Expr : Node_Id) return Node_Id is 29236 begin 29237 -- Recurse to handle unlikely case of multiple levels of qualification 29238 -- and/or conversion. 29239 29240 if Nkind (Expr) in N_Qualified_Expression 29241 | N_Type_Conversion 29242 | N_Unchecked_Type_Conversion 29243 then 29244 return Unqual_Conv (Expression (Expr)); 29245 29246 -- Normal case, not a qualified expression 29247 29248 else 29249 return Expr; 29250 end if; 29251 end Unqual_Conv; 29252 29253 -------------------- 29254 -- Validated_View -- 29255 -------------------- 29256 29257 function Validated_View (Typ : Entity_Id) return Entity_Id is 29258 Continue : Boolean; 29259 Val_Typ : Entity_Id; 29260 29261 begin 29262 Continue := True; 29263 Val_Typ := Base_Type (Typ); 29264 29265 -- Obtain the full view of the input type by stripping away concurrency, 29266 -- derivations, and privacy. 29267 29268 while Continue loop 29269 Continue := False; 29270 29271 if Is_Concurrent_Type (Val_Typ) then 29272 if Present (Corresponding_Record_Type (Val_Typ)) then 29273 Continue := True; 29274 Val_Typ := Corresponding_Record_Type (Val_Typ); 29275 end if; 29276 29277 elsif Is_Derived_Type (Val_Typ) then 29278 Continue := True; 29279 Val_Typ := Etype (Val_Typ); 29280 29281 elsif Is_Private_Type (Val_Typ) then 29282 if Present (Underlying_Full_View (Val_Typ)) then 29283 Continue := True; 29284 Val_Typ := Underlying_Full_View (Val_Typ); 29285 29286 elsif Present (Full_View (Val_Typ)) then 29287 Continue := True; 29288 Val_Typ := Full_View (Val_Typ); 29289 end if; 29290 end if; 29291 end loop; 29292 29293 return Val_Typ; 29294 end Validated_View; 29295 29296 ----------------------- 29297 -- Visible_Ancestors -- 29298 ----------------------- 29299 29300 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is 29301 List_1 : Elist_Id; 29302 List_2 : Elist_Id; 29303 Elmt : Elmt_Id; 29304 29305 begin 29306 pragma Assert (Is_Record_Type (Typ) and then Is_Tagged_Type (Typ)); 29307 29308 -- Collect all the parents and progenitors of Typ. If the full-view of 29309 -- private parents and progenitors is available then it is used to 29310 -- generate the list of visible ancestors; otherwise their partial 29311 -- view is added to the resulting list. 29312 29313 Collect_Parents 29314 (T => Typ, 29315 List => List_1, 29316 Use_Full_View => True); 29317 29318 Collect_Interfaces 29319 (T => Typ, 29320 Ifaces_List => List_2, 29321 Exclude_Parents => True, 29322 Use_Full_View => True); 29323 29324 -- Join the two lists. Avoid duplications because an interface may 29325 -- simultaneously be parent and progenitor of a type. 29326 29327 Elmt := First_Elmt (List_2); 29328 while Present (Elmt) loop 29329 Append_Unique_Elmt (Node (Elmt), List_1); 29330 Next_Elmt (Elmt); 29331 end loop; 29332 29333 return List_1; 29334 end Visible_Ancestors; 29335 29336 ---------------------- 29337 -- Within_Init_Proc -- 29338 ---------------------- 29339 29340 function Within_Init_Proc return Boolean is 29341 S : Entity_Id; 29342 29343 begin 29344 S := Current_Scope; 29345 while not Is_Overloadable (S) loop 29346 if S = Standard_Standard then 29347 return False; 29348 else 29349 S := Scope (S); 29350 end if; 29351 end loop; 29352 29353 return Is_Init_Proc (S); 29354 end Within_Init_Proc; 29355 29356 --------------------------- 29357 -- Within_Protected_Type -- 29358 --------------------------- 29359 29360 function Within_Protected_Type (E : Entity_Id) return Boolean is 29361 Scop : Entity_Id := Scope (E); 29362 29363 begin 29364 while Present (Scop) loop 29365 if Ekind (Scop) = E_Protected_Type then 29366 return True; 29367 end if; 29368 29369 Scop := Scope (Scop); 29370 end loop; 29371 29372 return False; 29373 end Within_Protected_Type; 29374 29375 ------------------ 29376 -- Within_Scope -- 29377 ------------------ 29378 29379 function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean is 29380 begin 29381 return Scope_Within_Or_Same (Scope (E), S); 29382 end Within_Scope; 29383 29384 ---------------------------- 29385 -- Within_Subprogram_Call -- 29386 ---------------------------- 29387 29388 function Within_Subprogram_Call (N : Node_Id) return Boolean is 29389 Par : Node_Id; 29390 29391 begin 29392 -- Climb the parent chain looking for a function or procedure call 29393 29394 Par := N; 29395 while Present (Par) loop 29396 if Nkind (Par) in N_Entry_Call_Statement 29397 | N_Function_Call 29398 | N_Procedure_Call_Statement 29399 then 29400 return True; 29401 29402 -- Prevent the search from going too far 29403 29404 elsif Is_Body_Or_Package_Declaration (Par) then 29405 exit; 29406 end if; 29407 29408 Par := Parent (Par); 29409 end loop; 29410 29411 return False; 29412 end Within_Subprogram_Call; 29413 29414 ---------------- 29415 -- Wrong_Type -- 29416 ---------------- 29417 29418 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is 29419 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr)); 29420 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type); 29421 29422 Matching_Field : Entity_Id; 29423 -- Entity to give a more precise suggestion on how to write a one- 29424 -- element positional aggregate. 29425 29426 function Has_One_Matching_Field return Boolean; 29427 -- Determines if Expec_Type is a record type with a single component or 29428 -- discriminant whose type matches the found type or is one dimensional 29429 -- array whose component type matches the found type. In the case of 29430 -- one discriminant, we ignore the variant parts. That's not accurate, 29431 -- but good enough for the warning. 29432 29433 ---------------------------- 29434 -- Has_One_Matching_Field -- 29435 ---------------------------- 29436 29437 function Has_One_Matching_Field return Boolean is 29438 E : Entity_Id; 29439 29440 begin 29441 Matching_Field := Empty; 29442 29443 if Is_Array_Type (Expec_Type) 29444 and then Number_Dimensions (Expec_Type) = 1 29445 and then Covers (Etype (Component_Type (Expec_Type)), Found_Type) 29446 then 29447 -- Use type name if available. This excludes multidimensional 29448 -- arrays and anonymous arrays. 29449 29450 if Comes_From_Source (Expec_Type) then 29451 Matching_Field := Expec_Type; 29452 29453 -- For an assignment, use name of target 29454 29455 elsif Nkind (Parent (Expr)) = N_Assignment_Statement 29456 and then Is_Entity_Name (Name (Parent (Expr))) 29457 then 29458 Matching_Field := Entity (Name (Parent (Expr))); 29459 end if; 29460 29461 return True; 29462 29463 elsif not Is_Record_Type (Expec_Type) then 29464 return False; 29465 29466 else 29467 E := First_Entity (Expec_Type); 29468 loop 29469 if No (E) then 29470 return False; 29471 29472 elsif Ekind (E) not in E_Discriminant | E_Component 29473 or else Chars (E) in Name_uTag | Name_uParent 29474 then 29475 Next_Entity (E); 29476 29477 else 29478 exit; 29479 end if; 29480 end loop; 29481 29482 if not Covers (Etype (E), Found_Type) then 29483 return False; 29484 29485 elsif Present (Next_Entity (E)) 29486 and then (Ekind (E) = E_Component 29487 or else Ekind (Next_Entity (E)) = E_Discriminant) 29488 then 29489 return False; 29490 29491 else 29492 Matching_Field := E; 29493 return True; 29494 end if; 29495 end if; 29496 end Has_One_Matching_Field; 29497 29498 -- Start of processing for Wrong_Type 29499 29500 begin 29501 -- Don't output message if either type is Any_Type, or if a message 29502 -- has already been posted for this node. We need to do the latter 29503 -- check explicitly (it is ordinarily done in Errout), because we 29504 -- are using ! to force the output of the error messages. 29505 29506 if Expec_Type = Any_Type 29507 or else Found_Type = Any_Type 29508 or else Error_Posted (Expr) 29509 then 29510 return; 29511 29512 -- If one of the types is a Taft-Amendment type and the other it its 29513 -- completion, it must be an illegal use of a TAT in the spec, for 29514 -- which an error was already emitted. Avoid cascaded errors. 29515 29516 elsif Is_Incomplete_Type (Expec_Type) 29517 and then Has_Completion_In_Body (Expec_Type) 29518 and then Full_View (Expec_Type) = Etype (Expr) 29519 then 29520 return; 29521 29522 elsif Is_Incomplete_Type (Etype (Expr)) 29523 and then Has_Completion_In_Body (Etype (Expr)) 29524 and then Full_View (Etype (Expr)) = Expec_Type 29525 then 29526 return; 29527 29528 -- In an instance, there is an ongoing problem with completion of 29529 -- types derived from private types. Their structure is what Gigi 29530 -- expects, but the Etype is the parent type rather than the derived 29531 -- private type itself. Do not flag error in this case. The private 29532 -- completion is an entity without a parent, like an Itype. Similarly, 29533 -- full and partial views may be incorrect in the instance. 29534 -- There is no simple way to insure that it is consistent ??? 29535 29536 -- A similar view discrepancy can happen in an inlined body, for the 29537 -- same reason: inserted body may be outside of the original package 29538 -- and only partial views are visible at the point of insertion. 29539 29540 -- If In_Generic_Actual (Expr) is True then we cannot assume that 29541 -- the successful semantic analysis of the generic guarantees anything 29542 -- useful about type checking of this instance, so we ignore 29543 -- In_Instance in that case. There may be cases where this is not 29544 -- right (the symptom would probably be rejecting something 29545 -- that ought to be accepted) but we don't currently have any 29546 -- concrete examples of this. 29547 29548 elsif (In_Instance and then not In_Generic_Actual (Expr)) 29549 or else In_Inlined_Body 29550 then 29551 if Etype (Etype (Expr)) = Etype (Expected_Type) 29552 and then 29553 (Has_Private_Declaration (Expected_Type) 29554 or else Has_Private_Declaration (Etype (Expr))) 29555 and then No (Parent (Expected_Type)) 29556 then 29557 return; 29558 29559 elsif Nkind (Parent (Expr)) = N_Qualified_Expression 29560 and then Entity (Subtype_Mark (Parent (Expr))) = Expected_Type 29561 then 29562 return; 29563 29564 elsif Is_Private_Type (Expected_Type) 29565 and then Present (Full_View (Expected_Type)) 29566 and then Covers (Full_View (Expected_Type), Etype (Expr)) 29567 then 29568 return; 29569 29570 -- Conversely, type of expression may be the private one 29571 29572 elsif Is_Private_Type (Base_Type (Etype (Expr))) 29573 and then Full_View (Base_Type (Etype (Expr))) = Expected_Type 29574 then 29575 return; 29576 end if; 29577 end if; 29578 29579 -- An interesting special check. If the expression is parenthesized 29580 -- and its type corresponds to the type of the sole component of the 29581 -- expected record type, or to the component type of the expected one 29582 -- dimensional array type, then assume we have a bad aggregate attempt. 29583 29584 if Nkind (Expr) in N_Subexpr 29585 and then Paren_Count (Expr) /= 0 29586 and then Has_One_Matching_Field 29587 then 29588 Error_Msg_N ("positional aggregate cannot have one component", Expr); 29589 29590 if Present (Matching_Field) then 29591 if Is_Array_Type (Expec_Type) then 29592 Error_Msg_NE 29593 ("\write instead `&''First ='> ...`", Expr, Matching_Field); 29594 else 29595 Error_Msg_NE 29596 ("\write instead `& ='> ...`", Expr, Matching_Field); 29597 end if; 29598 end if; 29599 29600 -- Another special check, if we are looking for a pool-specific access 29601 -- type and we found an E_Access_Attribute_Type, then we have the case 29602 -- of an Access attribute being used in a context which needs a pool- 29603 -- specific type, which is never allowed. The one extra check we make 29604 -- is that the expected designated type covers the Found_Type. 29605 29606 elsif Is_Access_Type (Expec_Type) 29607 and then Ekind (Found_Type) = E_Access_Attribute_Type 29608 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type 29609 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type 29610 and then Covers 29611 (Designated_Type (Expec_Type), Designated_Type (Found_Type)) 29612 then 29613 Error_Msg_N 29614 ("result must be general access type!", Expr); 29615 Error_Msg_NE -- CODEFIX 29616 ("\add ALL to }!", Expr, Expec_Type); 29617 29618 -- Another special check, if the expected type is an integer type, 29619 -- but the expression is of type System.Address, and the parent is 29620 -- an addition or subtraction operation whose left operand is the 29621 -- expression in question and whose right operand is of an integral 29622 -- type, then this is an attempt at address arithmetic, so give 29623 -- appropriate message. 29624 29625 elsif Is_Integer_Type (Expec_Type) 29626 and then Is_RTE (Found_Type, RE_Address) 29627 and then Nkind (Parent (Expr)) in N_Op_Add | N_Op_Subtract 29628 and then Expr = Left_Opnd (Parent (Expr)) 29629 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr)))) 29630 then 29631 Error_Msg_N 29632 ("address arithmetic not predefined in package System", 29633 Parent (Expr)); 29634 Error_Msg_N 29635 ("\possible missing with/use of System.Storage_Elements", 29636 Parent (Expr)); 29637 return; 29638 29639 -- If the expected type is an anonymous access type, as for access 29640 -- parameters and discriminants, the error is on the designated types. 29641 29642 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then 29643 if Comes_From_Source (Expec_Type) then 29644 Error_Msg_NE ("expected}!", Expr, Expec_Type); 29645 else 29646 Error_Msg_NE 29647 ("expected an access type with designated}", 29648 Expr, Designated_Type (Expec_Type)); 29649 end if; 29650 29651 if Is_Access_Type (Found_Type) 29652 and then not Comes_From_Source (Found_Type) 29653 then 29654 Error_Msg_NE 29655 ("\\found an access type with designated}!", 29656 Expr, Designated_Type (Found_Type)); 29657 else 29658 if From_Limited_With (Found_Type) then 29659 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); 29660 Error_Msg_Qual_Level := 99; 29661 Error_Msg_NE -- CODEFIX 29662 ("\\missing `WITH &;", Expr, Scope (Found_Type)); 29663 Error_Msg_Qual_Level := 0; 29664 else 29665 Error_Msg_NE ("found}!", Expr, Found_Type); 29666 end if; 29667 end if; 29668 29669 -- Normal case of one type found, some other type expected 29670 29671 else 29672 -- If the names of the two types are the same, see if some number 29673 -- of levels of qualification will help. Don't try more than three 29674 -- levels, and if we get to standard, it's no use (and probably 29675 -- represents an error in the compiler) Also do not bother with 29676 -- internal scope names. 29677 29678 declare 29679 Expec_Scope : Entity_Id; 29680 Found_Scope : Entity_Id; 29681 29682 begin 29683 Expec_Scope := Expec_Type; 29684 Found_Scope := Found_Type; 29685 29686 for Levels in Nat range 0 .. 3 loop 29687 if Chars (Expec_Scope) /= Chars (Found_Scope) then 29688 Error_Msg_Qual_Level := Levels; 29689 exit; 29690 end if; 29691 29692 Expec_Scope := Scope (Expec_Scope); 29693 Found_Scope := Scope (Found_Scope); 29694 29695 exit when Expec_Scope = Standard_Standard 29696 or else Found_Scope = Standard_Standard 29697 or else not Comes_From_Source (Expec_Scope) 29698 or else not Comes_From_Source (Found_Scope); 29699 end loop; 29700 end; 29701 29702 if Is_Record_Type (Expec_Type) 29703 and then Present (Corresponding_Remote_Type (Expec_Type)) 29704 then 29705 Error_Msg_NE ("expected}!", Expr, 29706 Corresponding_Remote_Type (Expec_Type)); 29707 else 29708 Error_Msg_NE ("expected}!", Expr, Expec_Type); 29709 end if; 29710 29711 if Is_Entity_Name (Expr) 29712 and then Is_Package_Or_Generic_Package (Entity (Expr)) 29713 then 29714 Error_Msg_N ("\\found package name!", Expr); 29715 29716 elsif Is_Entity_Name (Expr) 29717 and then Ekind (Entity (Expr)) in E_Procedure | E_Generic_Procedure 29718 then 29719 if Ekind (Expec_Type) = E_Access_Subprogram_Type then 29720 Error_Msg_N 29721 ("found procedure name, possibly missing Access attribute!", 29722 Expr); 29723 else 29724 Error_Msg_N 29725 ("\\found procedure name instead of function!", Expr); 29726 end if; 29727 29728 elsif Nkind (Expr) = N_Function_Call 29729 and then Ekind (Expec_Type) = E_Access_Subprogram_Type 29730 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr) 29731 and then No (Parameter_Associations (Expr)) 29732 then 29733 Error_Msg_N 29734 ("found function name, possibly missing Access attribute!", 29735 Expr); 29736 29737 -- Catch common error: a prefix or infix operator which is not 29738 -- directly visible because the type isn't. 29739 29740 elsif Nkind (Expr) in N_Op 29741 and then Is_Overloaded (Expr) 29742 and then not Is_Immediately_Visible (Expec_Type) 29743 and then not Is_Potentially_Use_Visible (Expec_Type) 29744 and then not In_Use (Expec_Type) 29745 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type) 29746 then 29747 Error_Msg_N 29748 ("operator of the type is not directly visible!", Expr); 29749 29750 elsif Ekind (Found_Type) = E_Void 29751 and then Present (Parent (Found_Type)) 29752 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration 29753 then 29754 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type); 29755 29756 else 29757 Error_Msg_NE ("\\found}!", Expr, Found_Type); 29758 end if; 29759 29760 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are 29761 -- of the same modular type, and (M1 and M2) = 0 was intended. 29762 29763 if Expec_Type = Standard_Boolean 29764 and then Is_Modular_Integer_Type (Found_Type) 29765 and then Nkind (Parent (Expr)) in N_Op_And | N_Op_Or | N_Op_Xor 29766 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare 29767 then 29768 declare 29769 Op : constant Node_Id := Right_Opnd (Parent (Expr)); 29770 L : constant Node_Id := Left_Opnd (Op); 29771 R : constant Node_Id := Right_Opnd (Op); 29772 29773 begin 29774 -- The case for the message is when the left operand of the 29775 -- comparison is the same modular type, or when it is an 29776 -- integer literal (or other universal integer expression), 29777 -- which would have been typed as the modular type if the 29778 -- parens had been there. 29779 29780 if (Etype (L) = Found_Type 29781 or else 29782 Etype (L) = Universal_Integer) 29783 and then Is_Integer_Type (Etype (R)) 29784 then 29785 Error_Msg_N 29786 ("\\possible missing parens for modular operation", Expr); 29787 end if; 29788 end; 29789 end if; 29790 29791 -- Reset error message qualification indication 29792 29793 Error_Msg_Qual_Level := 0; 29794 end if; 29795 end Wrong_Type; 29796 29797 -------------------------------- 29798 -- Yields_Synchronized_Object -- 29799 -------------------------------- 29800 29801 function Yields_Synchronized_Object (Typ : Entity_Id) return Boolean is 29802 Has_Sync_Comp : Boolean := False; 29803 Id : Entity_Id; 29804 29805 begin 29806 -- An array type yields a synchronized object if its component type 29807 -- yields a synchronized object. 29808 29809 if Is_Array_Type (Typ) then 29810 return Yields_Synchronized_Object (Component_Type (Typ)); 29811 29812 -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object 29813 -- yields a synchronized object by default. 29814 29815 elsif Is_Descendant_Of_Suspension_Object (Typ) then 29816 return True; 29817 29818 -- A protected type yields a synchronized object by default 29819 29820 elsif Is_Protected_Type (Typ) then 29821 return True; 29822 29823 -- A record type or type extension yields a synchronized object when its 29824 -- discriminants (if any) lack default values and all components are of 29825 -- a type that yields a synchronized object. 29826 29827 elsif Is_Record_Type (Typ) then 29828 29829 -- Inspect all entities defined in the scope of the type, looking for 29830 -- components of a type that does not yield a synchronized object or 29831 -- for discriminants with default values. 29832 29833 Id := First_Entity (Typ); 29834 while Present (Id) loop 29835 if Comes_From_Source (Id) then 29836 if Ekind (Id) = E_Component then 29837 if Yields_Synchronized_Object (Etype (Id)) then 29838 Has_Sync_Comp := True; 29839 29840 -- The component does not yield a synchronized object 29841 29842 else 29843 return False; 29844 end if; 29845 29846 elsif Ekind (Id) = E_Discriminant 29847 and then Present (Expression (Parent (Id))) 29848 then 29849 return False; 29850 end if; 29851 end if; 29852 29853 Next_Entity (Id); 29854 end loop; 29855 29856 -- Ensure that the parent type of a type extension yields a 29857 -- synchronized object. 29858 29859 if Etype (Typ) /= Typ 29860 and then not Is_Private_Type (Etype (Typ)) 29861 and then not Yields_Synchronized_Object (Etype (Typ)) 29862 then 29863 return False; 29864 end if; 29865 29866 -- If we get here, then all discriminants lack default values and all 29867 -- components are of a type that yields a synchronized object. 29868 29869 return Has_Sync_Comp; 29870 29871 -- A synchronized interface type yields a synchronized object by default 29872 29873 elsif Is_Synchronized_Interface (Typ) then 29874 return True; 29875 29876 -- A task type yields a synchronized object by default 29877 29878 elsif Is_Task_Type (Typ) then 29879 return True; 29880 29881 -- A private type yields a synchronized object if its underlying type 29882 -- does. 29883 29884 elsif Is_Private_Type (Typ) 29885 and then Present (Underlying_Type (Typ)) 29886 then 29887 return Yields_Synchronized_Object (Underlying_Type (Typ)); 29888 29889 -- Otherwise the type does not yield a synchronized object 29890 29891 else 29892 return False; 29893 end if; 29894 end Yields_Synchronized_Object; 29895 29896 --------------------------- 29897 -- Yields_Universal_Type -- 29898 --------------------------- 29899 29900 function Yields_Universal_Type (N : Node_Id) return Boolean is 29901 begin 29902 -- Integer and real literals are of a universal type 29903 29904 if Nkind (N) in N_Integer_Literal | N_Real_Literal then 29905 return True; 29906 29907 -- The values of certain attributes are of a universal type 29908 29909 elsif Nkind (N) = N_Attribute_Reference then 29910 return 29911 Universal_Type_Attribute (Get_Attribute_Id (Attribute_Name (N))); 29912 29913 -- ??? There are possibly other cases to consider 29914 29915 else 29916 return False; 29917 end if; 29918 end Yields_Universal_Type; 29919 29920 package body Interval_Lists is 29921 29922 procedure Check_Consistency (Intervals : Discrete_Interval_List); 29923 -- Check that list is sorted, lacks null intervals, and has gaps 29924 -- between intervals. 29925 29926 function Chosen_Interval (Choice : Node_Id) return Discrete_Interval; 29927 -- Given an element of a Discrete_Choices list, a 29928 -- Static_Discrete_Predicate list, or an Others_Discrete_Choices 29929 -- list (but not an N_Others_Choice node) return the corresponding 29930 -- interval. If an element that does not represent a single 29931 -- contiguous interval due to a static predicate (or which 29932 -- represents a single contiguous interval whose bounds depend on 29933 -- a static predicate) is encountered, then that is an error on the 29934 -- part of whoever built the list in question. 29935 29936 function In_Interval 29937 (Value : Uint; Interval : Discrete_Interval) return Boolean; 29938 -- Does the given value lie within the given interval? 29939 29940 procedure Normalize_Interval_List 29941 (List : in out Discrete_Interval_List; Last : out Nat); 29942 -- Perform sorting and merging as required by Check_Consistency. 29943 29944 ------------------------- 29945 -- Aggregate_Intervals -- 29946 ------------------------- 29947 29948 function Aggregate_Intervals (N : Node_Id) return Discrete_Interval_List 29949 is 29950 pragma Assert (Nkind (N) = N_Aggregate 29951 and then Is_Array_Type (Etype (N))); 29952 29953 function Unmerged_Intervals_Count return Nat; 29954 -- Count the number of intervals given in the aggregate N; the others 29955 -- choice (if present) is not taken into account. 29956 29957 function Unmerged_Intervals_Count return Nat is 29958 Count : Nat := 0; 29959 Choice : Node_Id; 29960 Comp : Node_Id; 29961 begin 29962 Comp := First (Component_Associations (N)); 29963 while Present (Comp) loop 29964 Choice := First (Choices (Comp)); 29965 29966 while Present (Choice) loop 29967 if Nkind (Choice) /= N_Others_Choice then 29968 Count := Count + 1; 29969 end if; 29970 29971 Next (Choice); 29972 end loop; 29973 29974 Next (Comp); 29975 end loop; 29976 29977 return Count; 29978 end Unmerged_Intervals_Count; 29979 29980 -- Local variables 29981 29982 Comp : Node_Id; 29983 Max_I : constant Nat := Unmerged_Intervals_Count; 29984 Intervals : Discrete_Interval_List (1 .. Max_I); 29985 Num_I : Nat := 0; 29986 29987 -- Start of processing for Aggregate_Intervals 29988 29989 begin 29990 -- No action needed if there are no intervals 29991 29992 if Max_I = 0 then 29993 return Intervals; 29994 end if; 29995 29996 -- Internally store all the unsorted intervals 29997 29998 Comp := First (Component_Associations (N)); 29999 while Present (Comp) loop 30000 declare 30001 Choice_Intervals : constant Discrete_Interval_List 30002 := Choice_List_Intervals (Choices (Comp)); 30003 begin 30004 for J in Choice_Intervals'Range loop 30005 Num_I := Num_I + 1; 30006 Intervals (Num_I) := Choice_Intervals (J); 30007 end loop; 30008 end; 30009 30010 Next (Comp); 30011 end loop; 30012 30013 -- Normalize the lists sorting and merging the intervals 30014 30015 declare 30016 Aggr_Intervals : Discrete_Interval_List (1 .. Num_I) 30017 := Intervals (1 .. Num_I); 30018 begin 30019 Normalize_Interval_List (Aggr_Intervals, Num_I); 30020 Check_Consistency (Aggr_Intervals (1 .. Num_I)); 30021 return Aggr_Intervals (1 .. Num_I); 30022 end; 30023 end Aggregate_Intervals; 30024 30025 ------------------------ 30026 -- Check_Consistency -- 30027 ------------------------ 30028 30029 procedure Check_Consistency (Intervals : Discrete_Interval_List) is 30030 begin 30031 if Serious_Errors_Detected > 0 then 30032 return; 30033 end if; 30034 30035 -- low bound is 1 and high bound equals length 30036 pragma Assert (Intervals'First = 1 and Intervals'Last >= 0); 30037 for Idx in Intervals'Range loop 30038 -- each interval is non-null 30039 pragma Assert (Intervals (Idx).Low <= Intervals (Idx).High); 30040 if Idx /= Intervals'First then 30041 -- intervals are sorted with non-empty gaps between them 30042 pragma Assert 30043 (Intervals (Idx - 1).High < (Intervals (Idx).Low - 1)); 30044 null; 30045 end if; 30046 end loop; 30047 end Check_Consistency; 30048 30049 --------------------------- 30050 -- Choice_List_Intervals -- 30051 --------------------------- 30052 30053 function Choice_List_Intervals 30054 (Discrete_Choices : List_Id) return Discrete_Interval_List 30055 is 30056 function Unmerged_Choice_Count return Nat; 30057 -- The number of intervals before adjacent intervals are merged. 30058 30059 --------------------------- 30060 -- Unmerged_Choice_Count -- 30061 --------------------------- 30062 30063 function Unmerged_Choice_Count return Nat is 30064 Choice : Node_Id := First (Discrete_Choices); 30065 Count : Nat := 0; 30066 begin 30067 while Present (Choice) loop 30068 -- Non-contiguous choices involving static predicates 30069 -- have already been normalized away. 30070 30071 if Nkind (Choice) = N_Others_Choice then 30072 Count := 30073 Count + List_Length (Others_Discrete_Choices (Choice)); 30074 else 30075 Count := Count + 1; -- an ordinary expression or range 30076 end if; 30077 30078 Next (Choice); 30079 end loop; 30080 return Count; 30081 end Unmerged_Choice_Count; 30082 30083 -- Local variables 30084 30085 Choice : Node_Id := First (Discrete_Choices); 30086 Result : Discrete_Interval_List (1 .. Unmerged_Choice_Count); 30087 Count : Nat := 0; 30088 30089 -- Start of processing for Choice_List_Intervals 30090 30091 begin 30092 while Present (Choice) loop 30093 if Nkind (Choice) = N_Others_Choice then 30094 declare 30095 Others_Choice : Node_Id 30096 := First (Others_Discrete_Choices (Choice)); 30097 begin 30098 while Present (Others_Choice) loop 30099 Count := Count + 1; 30100 Result (Count) := Chosen_Interval (Others_Choice); 30101 Next (Others_Choice); 30102 end loop; 30103 end; 30104 else 30105 Count := Count + 1; 30106 Result (Count) := Chosen_Interval (Choice); 30107 end if; 30108 30109 Next (Choice); 30110 end loop; 30111 30112 pragma Assert (Count = Result'Last); 30113 Normalize_Interval_List (Result, Count); 30114 Check_Consistency (Result (1 .. Count)); 30115 return Result (1 .. Count); 30116 end Choice_List_Intervals; 30117 30118 --------------------- 30119 -- Chosen_Interval -- 30120 --------------------- 30121 30122 function Chosen_Interval (Choice : Node_Id) return Discrete_Interval is 30123 begin 30124 case Nkind (Choice) is 30125 when N_Range => 30126 return (Low => Expr_Value (Low_Bound (Choice)), 30127 High => Expr_Value (High_Bound (Choice))); 30128 30129 when N_Subtype_Indication => 30130 declare 30131 Range_Exp : constant Node_Id 30132 := Range_Expression (Constraint (Choice)); 30133 begin 30134 return (Low => Expr_Value (Low_Bound (Range_Exp)), 30135 High => Expr_Value (High_Bound (Range_Exp))); 30136 end; 30137 30138 when N_Others_Choice => 30139 raise Program_Error; 30140 30141 when others => 30142 if Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)) 30143 then 30144 return 30145 (Low => Expr_Value (Type_Low_Bound (Entity (Choice))), 30146 High => Expr_Value (Type_High_Bound (Entity (Choice)))); 30147 else 30148 -- an expression 30149 return (Low | High => Expr_Value (Choice)); 30150 end if; 30151 end case; 30152 end Chosen_Interval; 30153 30154 ----------------- 30155 -- In_Interval -- 30156 ----------------- 30157 30158 function In_Interval 30159 (Value : Uint; Interval : Discrete_Interval) return Boolean is 30160 begin 30161 return Value >= Interval.Low and then Value <= Interval.High; 30162 end In_Interval; 30163 30164 --------------- 30165 -- Is_Subset -- 30166 --------------- 30167 30168 function Is_Subset 30169 (Subset, Of_Set : Discrete_Interval_List) return Boolean 30170 is 30171 -- Returns True iff for each interval of Subset we can find 30172 -- a single interval of Of_Set which contains the Subset interval. 30173 begin 30174 if Of_Set'Length = 0 then 30175 return Subset'Length = 0; 30176 end if; 30177 30178 declare 30179 Set_Index : Pos range Of_Set'Range := Of_Set'First; 30180 30181 begin 30182 for Ss_Idx in Subset'Range loop 30183 while not In_Interval 30184 (Value => Subset (Ss_Idx).Low, 30185 Interval => Of_Set (Set_Index)) 30186 loop 30187 if Set_Index = Of_Set'Last then 30188 return False; 30189 end if; 30190 30191 Set_Index := Set_Index + 1; 30192 end loop; 30193 30194 if not In_Interval 30195 (Value => Subset (Ss_Idx).High, 30196 Interval => Of_Set (Set_Index)) 30197 then 30198 return False; 30199 end if; 30200 end loop; 30201 end; 30202 30203 return True; 30204 end Is_Subset; 30205 30206 ----------------------------- 30207 -- Normalize_Interval_List -- 30208 ----------------------------- 30209 30210 procedure Normalize_Interval_List 30211 (List : in out Discrete_Interval_List; Last : out Nat) 30212 is 30213 Temp_0 : Discrete_Interval := (others => Uint_0); 30214 -- Cope with Heap_Sort_G idiosyncrasies. 30215 30216 function Is_Null (Idx : Pos) return Boolean; 30217 -- True iff List (Idx) defines a null range 30218 30219 function Lt_Interval (Idx1, Idx2 : Natural) return Boolean; 30220 -- Compare two list elements 30221 30222 procedure Merge_Intervals (Null_Interval_Count : out Nat); 30223 -- Merge contiguous ranges by replacing one with merged range and 30224 -- the other with a null value. Return a count of the null intervals, 30225 -- both preexisting and those introduced by merging. 30226 30227 procedure Move_Interval (From, To : Natural); 30228 -- Copy interval from one location to another 30229 30230 function Read_Interval (From : Natural) return Discrete_Interval; 30231 -- Normal array indexing unless From = 0 30232 30233 ---------------------- 30234 -- Interval_Sorting -- 30235 ---------------------- 30236 30237 package Interval_Sorting is 30238 new Gnat.Heap_Sort_G (Move_Interval, Lt_Interval); 30239 30240 ------------- 30241 -- Is_Null -- 30242 ------------- 30243 30244 function Is_Null (Idx : Pos) return Boolean is 30245 begin 30246 return List (Idx).Low > List (Idx).High; 30247 end Is_Null; 30248 30249 ----------------- 30250 -- Lt_Interval -- 30251 ----------------- 30252 30253 function Lt_Interval (Idx1, Idx2 : Natural) return Boolean is 30254 Elem1 : constant Discrete_Interval := Read_Interval (Idx1); 30255 Elem2 : constant Discrete_Interval := Read_Interval (Idx2); 30256 Null_1 : constant Boolean := Elem1.Low > Elem1.High; 30257 Null_2 : constant Boolean := Elem2.Low > Elem2.High; 30258 begin 30259 if Null_1 /= Null_2 then 30260 -- So that sorting moves null intervals to high end 30261 return Null_2; 30262 30263 elsif Elem1.Low /= Elem2.Low then 30264 return Elem1.Low < Elem2.Low; 30265 30266 else 30267 return Elem1.High < Elem2.High; 30268 end if; 30269 end Lt_Interval; 30270 30271 --------------------- 30272 -- Merge_Intervals -- 30273 --------------------- 30274 30275 procedure Merge_Intervals (Null_Interval_Count : out Nat) is 30276 Not_Null : Pos range List'Range; 30277 -- Index of the most recently examined non-null interval 30278 30279 Null_Interval : constant Discrete_Interval 30280 := (Low => Uint_1, High => Uint_0); -- any null range ok here 30281 begin 30282 if List'Length = 0 or else Is_Null (List'First) then 30283 Null_Interval_Count := List'Length; 30284 -- no non-null elements, so no merge candidates 30285 return; 30286 end if; 30287 30288 Null_Interval_Count := 0; 30289 Not_Null := List'First; 30290 30291 for Idx in List'First + 1 .. List'Last loop 30292 if Is_Null (Idx) then 30293 30294 -- all remaining elements are null 30295 30296 Null_Interval_Count := 30297 Null_Interval_Count + List (Idx .. List'Last)'Length; 30298 return; 30299 30300 elsif List (Idx).Low = List (Not_Null).High + 1 then 30301 30302 -- Merge the two intervals into one; discard the other 30303 30304 List (Not_Null).High := List (Idx).High; 30305 List (Idx) := Null_Interval; 30306 Null_Interval_Count := Null_Interval_Count + 1; 30307 30308 else 30309 if List (Idx).Low <= List (Not_Null).High then 30310 raise Intervals_Error; 30311 end if; 30312 30313 pragma Assert (List (Idx).Low > List (Not_Null).High); 30314 Not_Null := Idx; 30315 end if; 30316 end loop; 30317 end Merge_Intervals; 30318 30319 ------------------- 30320 -- Move_Interval -- 30321 ------------------- 30322 30323 procedure Move_Interval (From, To : Natural) is 30324 Rhs : constant Discrete_Interval := Read_Interval (From); 30325 begin 30326 if To = 0 then 30327 Temp_0 := Rhs; 30328 else 30329 List (Pos (To)) := Rhs; 30330 end if; 30331 end Move_Interval; 30332 30333 ------------------- 30334 -- Read_Interval -- 30335 ------------------- 30336 30337 function Read_Interval (From : Natural) return Discrete_Interval is 30338 begin 30339 if From = 0 then 30340 return Temp_0; 30341 else 30342 return List (Pos (From)); 30343 end if; 30344 end Read_Interval; 30345 30346 -- Start of processing for Normalize_Interval_Lists 30347 30348 begin 30349 Interval_Sorting.Sort (Natural (List'Last)); 30350 30351 declare 30352 Null_Interval_Count : Nat; 30353 30354 begin 30355 Merge_Intervals (Null_Interval_Count); 30356 Last := List'Last - Null_Interval_Count; 30357 30358 if Null_Interval_Count /= 0 then 30359 -- Move null intervals introduced during merging to high end 30360 Interval_Sorting.Sort (Natural (List'Last)); 30361 end if; 30362 end; 30363 end Normalize_Interval_List; 30364 30365 -------------------- 30366 -- Type_Intervals -- 30367 -------------------- 30368 30369 function Type_Intervals (Typ : Entity_Id) return Discrete_Interval_List 30370 is 30371 begin 30372 if Has_Static_Predicate (Typ) then 30373 declare 30374 -- No sorting or merging needed 30375 SDP_List : constant List_Id := Static_Discrete_Predicate (Typ); 30376 Range_Or_Expr : Node_Id := First (SDP_List); 30377 Result : Discrete_Interval_List (1 .. List_Length (SDP_List)); 30378 30379 begin 30380 for Idx in Result'Range loop 30381 Result (Idx) := Chosen_Interval (Range_Or_Expr); 30382 Next (Range_Or_Expr); 30383 end loop; 30384 30385 pragma Assert (not Present (Range_Or_Expr)); 30386 Check_Consistency (Result); 30387 return Result; 30388 end; 30389 else 30390 declare 30391 Low : constant Uint := Expr_Value (Type_Low_Bound (Typ)); 30392 High : constant Uint := Expr_Value (Type_High_Bound (Typ)); 30393 begin 30394 if Low > High then 30395 declare 30396 Null_Array : Discrete_Interval_List (1 .. 0); 30397 begin 30398 return Null_Array; 30399 end; 30400 else 30401 return (1 => (Low => Low, High => High)); 30402 end if; 30403 end; 30404 end if; 30405 end Type_Intervals; 30406 30407 end Interval_Lists; 30408 30409 package body Old_Attr_Util is 30410 package body Conditional_Evaluation is 30411 type Determining_Expr_Context is 30412 (No_Context, If_Expr, Case_Expr, Short_Circuit_Op, Membership_Test); 30413 30414 -- Determining_Expr_Context enumeration elements (except for 30415 -- No_Context) correspond to the list items in RM 6.1.1 definition 30416 -- of "determining expression". 30417 30418 type Determining_Expr 30419 (Context : Determining_Expr_Context := No_Context) 30420 is record 30421 Expr : Node_Id := Empty; 30422 case Context is 30423 when Short_Circuit_Op => 30424 Is_And_Then : Boolean; 30425 when If_Expr => 30426 Is_Then_Part : Boolean; 30427 when Case_Expr => 30428 Alternatives : Node_Id; 30429 when Membership_Test => 30430 -- Given a subexpression of <exp4> in a membership test 30431 -- <exp1> in <exp2> | <exp3> | <exp4> | <exp5> 30432 -- the corresponding determining expression value would 30433 -- have First_Non_Preceding = <exp4> (See RM 6.1.1). 30434 First_Non_Preceding : Node_Id; 30435 when No_Context => 30436 null; 30437 end case; 30438 end record; 30439 30440 type Determining_Expression_List is 30441 array (Positive range <>) of Determining_Expr; 30442 30443 function Determining_Condition (Det : Determining_Expr) 30444 return Node_Id; 30445 -- Given a determining expression, build a Boolean-valued 30446 -- condition that incorporates that expression into condition 30447 -- suitable for deciding whether to initialize a 'Old constant. 30448 -- Polarity is "True => initialize the constant". 30449 30450 function Determining_Expressions 30451 (Expr : Node_Id; Expr_Trailer : Node_Id := Empty) 30452 return Determining_Expression_List; 30453 -- Given a conditionally evaluated expression, return its 30454 -- determining expressions. 30455 -- See RM 6.1.1 for definition of term "determining expressions". 30456 -- Tests should be performed in the order they occur in the 30457 -- array, with short circuiting. 30458 -- A determining expression need not be of a boolean type (e.g., 30459 -- it might be the determining expression of a case expression). 30460 -- The Expr_Trailer parameter should be defaulted for nonrecursive 30461 -- calls. 30462 30463 function Is_Conditionally_Evaluated (Expr : Node_Id) return Boolean; 30464 -- See RM 6.1.1 for definition of term "conditionally evaluated". 30465 30466 function Is_Known_On_Entry (Expr : Node_Id) return Boolean; 30467 -- See RM 6.1.1 for definition of term "known on entry". 30468 30469 -------------------------------------- 30470 -- Conditional_Evaluation_Condition -- 30471 -------------------------------------- 30472 30473 function Conditional_Evaluation_Condition 30474 (Expr : Node_Id) return Node_Id 30475 is 30476 Determiners : constant Determining_Expression_List := 30477 Determining_Expressions (Expr); 30478 Loc : constant Source_Ptr := Sloc (Expr); 30479 Result : Node_Id := 30480 New_Occurrence_Of (Standard_True, Loc); 30481 begin 30482 pragma Assert (Determiners'Length > 0 or else 30483 Is_Anonymous_Access_Type (Etype (Expr))); 30484 30485 for I in Determiners'Range loop 30486 Result := Make_And_Then 30487 (Loc, 30488 Left_Opnd => Result, 30489 Right_Opnd => 30490 Determining_Condition (Determiners (I))); 30491 end loop; 30492 return Result; 30493 end Conditional_Evaluation_Condition; 30494 30495 --------------------------- 30496 -- Determining_Condition -- 30497 --------------------------- 30498 30499 function Determining_Condition (Det : Determining_Expr) return Node_Id 30500 is 30501 Loc : constant Source_Ptr := Sloc (Det.Expr); 30502 begin 30503 case Det.Context is 30504 when Short_Circuit_Op => 30505 if Det.Is_And_Then then 30506 return New_Copy_Tree (Det.Expr); 30507 else 30508 return Make_Op_Not (Loc, New_Copy_Tree (Det.Expr)); 30509 end if; 30510 30511 when If_Expr => 30512 if Det.Is_Then_Part then 30513 return New_Copy_Tree (Det.Expr); 30514 else 30515 return Make_Op_Not (Loc, New_Copy_Tree (Det.Expr)); 30516 end if; 30517 30518 when Case_Expr => 30519 declare 30520 Alts : List_Id := Discrete_Choices (Det.Alternatives); 30521 begin 30522 if Nkind (First (Alts)) = N_Others_Choice then 30523 Alts := Others_Discrete_Choices (First (Alts)); 30524 end if; 30525 30526 return Make_In (Loc, 30527 Left_Opnd => New_Copy_Tree (Det.Expr), 30528 Right_Opnd => Empty, 30529 Alternatives => New_Copy_List (Alts)); 30530 end; 30531 30532 when Membership_Test => 30533 declare 30534 function Copy_Prefix 30535 (List : List_Id; Suffix_Start : Node_Id) 30536 return List_Id; 30537 -- Given a list and a member of that list, returns 30538 -- a copy (similar to Nlists.New_Copy_List) of the 30539 -- prefix of the list up to but not including 30540 -- Suffix_Start. 30541 30542 ----------------- 30543 -- Copy_Prefix -- 30544 ----------------- 30545 30546 function Copy_Prefix 30547 (List : List_Id; Suffix_Start : Node_Id) 30548 return List_Id 30549 is 30550 Result : constant List_Id := New_List; 30551 Elem : Node_Id := First (List); 30552 begin 30553 while Elem /= Suffix_Start loop 30554 Append (New_Copy (Elem), Result); 30555 Next (Elem); 30556 pragma Assert (Present (Elem)); 30557 end loop; 30558 return Result; 30559 end Copy_Prefix; 30560 30561 begin 30562 return Make_In (Loc, 30563 Left_Opnd => New_Copy_Tree (Left_Opnd (Det.Expr)), 30564 Right_Opnd => Empty, 30565 Alternatives => Copy_Prefix 30566 (Alternatives (Det.Expr), 30567 Det.First_Non_Preceding)); 30568 end; 30569 30570 when No_Context => 30571 raise Program_Error; 30572 end case; 30573 end Determining_Condition; 30574 30575 ----------------------------- 30576 -- Determining_Expressions -- 30577 ----------------------------- 30578 30579 function Determining_Expressions 30580 (Expr : Node_Id; Expr_Trailer : Node_Id := Empty) 30581 return Determining_Expression_List 30582 is 30583 Par : Node_Id := Expr; 30584 Trailer : Node_Id := Expr_Trailer; 30585 Next_Element : Determining_Expr; 30586 begin 30587 -- We want to stop climbing up the tree when we reach the 30588 -- postcondition expression. An aspect_specification is 30589 -- transformed into a pragma, so reaching a pragma is our 30590 -- termination condition. This relies on the fact that 30591 -- pragmas are not allowed in declare expressions (or any 30592 -- other kind of expression). 30593 30594 loop 30595 Next_Element.Expr := Empty; 30596 30597 case Nkind (Par) is 30598 when N_Short_Circuit => 30599 if Trailer = Right_Opnd (Par) then 30600 Next_Element := 30601 (Expr => Left_Opnd (Par), 30602 Context => Short_Circuit_Op, 30603 Is_And_Then => Nkind (Par) = N_And_Then); 30604 end if; 30605 30606 when N_If_Expression => 30607 -- For an expression like 30608 -- (if C1 then ... elsif C2 then ... else Foo'Old) 30609 -- the RM says are two determining expressions, 30610 -- C1 and C2. Our treatment here (where we only add 30611 -- one determining expression to the list) is ok because 30612 -- we will see two if-expressions, one within the other. 30613 30614 if Trailer /= First (Expressions (Par)) then 30615 Next_Element := 30616 (Expr => First (Expressions (Par)), 30617 Context => If_Expr, 30618 Is_Then_Part => 30619 Trailer = Next (First (Expressions (Par)))); 30620 end if; 30621 30622 when N_Case_Expression_Alternative => 30623 pragma Assert (Nkind (Parent (Par)) = N_Case_Expression); 30624 30625 Next_Element := 30626 (Expr => Expression (Parent (Par)), 30627 Context => Case_Expr, 30628 Alternatives => Par); 30629 30630 when N_Membership_Test => 30631 if Trailer /= Left_Opnd (Par) 30632 and then Is_Non_Empty_List (Alternatives (Par)) 30633 and then Trailer /= First (Alternatives (Par)) 30634 then 30635 pragma Assert (not Present (Right_Opnd (Par))); 30636 pragma Assert 30637 (Is_List_Member (Trailer) 30638 and then List_Containing (Trailer) 30639 = Alternatives (Par)); 30640 30641 -- This one is different than the others 30642 -- because one element in the array result 30643 -- may represent multiple determining 30644 -- expressions (i.e. every member of the list 30645 -- Alternatives (Par) 30646 -- up to but not including Trailer). 30647 30648 Next_Element := 30649 (Expr => Par, 30650 Context => Membership_Test, 30651 First_Non_Preceding => Trailer); 30652 end if; 30653 30654 when N_Pragma => 30655 declare 30656 Previous : constant Node_Id := Prev (Par); 30657 Prev_Expr : Node_Id; 30658 begin 30659 if Nkind (Previous) = N_Pragma and then 30660 Split_PPC (Previous) 30661 then 30662 -- A source-level postcondition of 30663 -- A and then B and then C 30664 -- results in 30665 -- pragma Postcondition (A); 30666 -- pragma Postcondition (B); 30667 -- pragma Postcondition (C); 30668 -- with Split_PPC set to True on all but the 30669 -- last pragma. We account for that here. 30670 30671 Prev_Expr := 30672 Expression (First 30673 (Pragma_Argument_Associations (Previous))); 30674 30675 -- This Analyze call is needed in the case when 30676 -- Sem_Attr.Analyze_Attribute calls 30677 -- Eligible_For_Conditional_Evaluation. Without 30678 -- it, we end up passing an unanalyzed expression 30679 -- to Is_Known_On_Entry and that doesn't work. 30680 30681 Analyze (Prev_Expr); 30682 30683 Next_Element := 30684 (Expr => Prev_Expr, 30685 Context => Short_Circuit_Op, 30686 Is_And_Then => True); 30687 30688 return Determining_Expressions (Prev_Expr) 30689 & Next_Element; 30690 else 30691 pragma Assert 30692 (Get_Pragma_Id (Pragma_Name (Par)) in 30693 Pragma_Post | Pragma_Postcondition 30694 | Pragma_Post_Class | Pragma_Refined_Post 30695 | Pragma_Check | Pragma_Contract_Cases); 30696 30697 return (1 .. 0 => <>); -- recursion terminates here 30698 end if; 30699 end; 30700 30701 when N_Empty => 30702 -- This case should be impossible, but if it does 30703 -- happen somehow then we don't want an infinite loop. 30704 raise Program_Error; 30705 30706 when others => 30707 null; 30708 end case; 30709 30710 Trailer := Par; 30711 Par := Parent (Par); 30712 30713 if Present (Next_Element.Expr) then 30714 return Determining_Expressions 30715 (Expr => Par, Expr_Trailer => Trailer) 30716 & Next_Element; 30717 end if; 30718 end loop; 30719 end Determining_Expressions; 30720 30721 ----------------------------------------- 30722 -- Eligible_For_Conditional_Evaluation -- 30723 ----------------------------------------- 30724 30725 function Eligible_For_Conditional_Evaluation 30726 (Expr : Node_Id) return Boolean 30727 is 30728 begin 30729 if Is_Anonymous_Access_Type (Etype (Expr)) then 30730 -- The code in exp_attr.adb that also builds declarations 30731 -- for 'Old constants doesn't handle the anonymous access 30732 -- type case correctly, so we avoid that problem by 30733 -- returning True here. 30734 return True; 30735 elsif Ada_Version < Ada_2020 then 30736 return False; 30737 elsif not Is_Conditionally_Evaluated (Expr) then 30738 return False; 30739 else 30740 declare 30741 Determiners : constant Determining_Expression_List := 30742 Determining_Expressions (Expr); 30743 begin 30744 pragma Assert (Determiners'Length > 0); 30745 30746 for Idx in Determiners'Range loop 30747 if not Is_Known_On_Entry (Determiners (Idx).Expr) then 30748 return False; 30749 end if; 30750 end loop; 30751 end; 30752 return True; 30753 end if; 30754 end Eligible_For_Conditional_Evaluation; 30755 30756 -------------------------------- 30757 -- Is_Conditionally_Evaluated -- 30758 -------------------------------- 30759 30760 function Is_Conditionally_Evaluated (Expr : Node_Id) return Boolean 30761 is 30762 -- There are three possibilities - the expression is 30763 -- unconditionally evaluated, repeatedly evaluated, or 30764 -- conditionally evaluated (see RM 6.1.1). So we implement 30765 -- this test by testing for the other two. 30766 30767 function Is_Repeatedly_Evaluated (Expr : Node_Id) return Boolean; 30768 -- See RM 6.1.1 for definition of "repeatedly evaluated". 30769 30770 ----------------------------- 30771 -- Is_Repeatedly_Evaluated -- 30772 ----------------------------- 30773 30774 function Is_Repeatedly_Evaluated (Expr : Node_Id) return Boolean is 30775 Par : Node_Id := Expr; 30776 Trailer : Node_Id := Empty; 30777 30778 -- There are three ways that an expression can be repeatedly 30779 -- evaluated. 30780 begin 30781 -- An aspect_specification is transformed into a pragma, so 30782 -- reaching a pragma is our termination condition. We want to 30783 -- stop when we reach the postcondition expression. 30784 30785 while Nkind (Par) /= N_Pragma loop 30786 pragma Assert (Present (Par)); 30787 30788 -- test for case 1: 30789 -- A subexpression of a predicate of a 30790 -- quantified_expression. 30791 30792 if Nkind (Par) = N_Quantified_Expression 30793 and then Trailer = Condition (Par) 30794 then 30795 return True; 30796 end if; 30797 30798 -- test for cases 2 and 3: 30799 -- A subexpression of the expression of an 30800 -- array_component_association or of 30801 -- a container_element_associatiation. 30802 30803 if Nkind (Par) = N_Component_Association 30804 and then Trailer = Expression (Par) 30805 then 30806 -- determine whether Par is part of an array aggregate 30807 -- or a container aggregate 30808 declare 30809 Rover : Node_Id := Par; 30810 begin 30811 while Nkind (Rover) not in N_Has_Etype loop 30812 pragma Assert (Present (Rover)); 30813 Rover := Parent (Rover); 30814 end loop; 30815 if Present (Etype (Rover)) then 30816 if Is_Array_Type (Etype (Rover)) 30817 or else Is_Container_Aggregate (Rover) 30818 then 30819 return True; 30820 end if; 30821 end if; 30822 end; 30823 end if; 30824 30825 Trailer := Par; 30826 Par := Parent (Par); 30827 end loop; 30828 30829 return False; 30830 end Is_Repeatedly_Evaluated; 30831 30832 begin 30833 if not Is_Potentially_Unevaluated (Expr) then 30834 -- the expression is unconditionally evaluated 30835 return False; 30836 elsif Is_Repeatedly_Evaluated (Expr) then 30837 return False; 30838 end if; 30839 30840 return True; 30841 end Is_Conditionally_Evaluated; 30842 30843 ----------------------- 30844 -- Is_Known_On_Entry -- 30845 ----------------------- 30846 30847 function Is_Known_On_Entry (Expr : Node_Id) return Boolean is 30848 -- ??? This implementation is incomplete. See RM 6.1.1 30849 -- for details. In particular, this function *should* return 30850 -- True for a function call (or a user-defined literal, which 30851 -- is equivalent to a function call) if all actual parameters 30852 -- (including defaulted params) are known on entry and the 30853 -- function has "Globals => null" specified; the current 30854 -- implementation will incorrectly return False in this case. 30855 30856 function All_Exps_Known_On_Entry 30857 (Expr_List : List_Id) return Boolean; 30858 -- Given a list of expressions, returns False iff 30859 -- Is_Known_On_Entry is False for at least one list element. 30860 30861 ----------------------------- 30862 -- All_Exps_Known_On_Entry -- 30863 ----------------------------- 30864 30865 function All_Exps_Known_On_Entry 30866 (Expr_List : List_Id) return Boolean 30867 is 30868 Expr : Node_Id := First (Expr_List); 30869 begin 30870 while Present (Expr) loop 30871 if not Is_Known_On_Entry (Expr) then 30872 return False; 30873 end if; 30874 Next (Expr); 30875 end loop; 30876 return True; 30877 end All_Exps_Known_On_Entry; 30878 30879 begin 30880 if Is_Static_Expression (Expr) then 30881 return True; 30882 end if; 30883 30884 if Is_Attribute_Old (Expr) then 30885 return True; 30886 end if; 30887 30888 declare 30889 Pref : Node_Id := Expr; 30890 begin 30891 loop 30892 case Nkind (Pref) is 30893 when N_Selected_Component => 30894 null; 30895 30896 when N_Indexed_Component => 30897 if not All_Exps_Known_On_Entry (Expressions (Pref)) 30898 then 30899 return False; 30900 end if; 30901 30902 when N_Slice => 30903 return False; -- just to be clear about this case 30904 30905 when others => 30906 exit; 30907 end case; 30908 30909 Pref := Prefix (Pref); 30910 end loop; 30911 30912 if Is_Entity_Name (Pref) 30913 and then Is_Constant_Object (Entity (Pref)) 30914 then 30915 declare 30916 Obj : constant Entity_Id := Entity (Pref); 30917 Obj_Typ : constant Entity_Id := Etype (Obj); 30918 begin 30919 case Ekind (Obj) is 30920 when E_In_Parameter => 30921 if not Is_Elementary_Type (Obj_Typ) then 30922 return False; 30923 elsif Is_Aliased (Obj) then 30924 return False; 30925 end if; 30926 30927 when E_Constant => 30928 -- return False for a deferred constant 30929 if Present (Full_View (Obj)) then 30930 return False; 30931 end if; 30932 30933 -- return False if not "all views are constant". 30934 if Is_Immutably_Limited_Type (Obj_Typ) 30935 or Needs_Finalization (Obj_Typ) 30936 then 30937 return False; 30938 end if; 30939 30940 when others => 30941 null; 30942 end case; 30943 end; 30944 30945 return True; 30946 end if; 30947 30948 -- ??? Cope with a malformed tree. Code to cope with a 30949 -- nonstatic use of an enumeration literal should not be 30950 -- necessary. 30951 if Is_Entity_Name (Pref) 30952 and then Ekind (Entity (Pref)) = E_Enumeration_Literal 30953 then 30954 return True; 30955 end if; 30956 end; 30957 30958 case Nkind (Expr) is 30959 when N_Unary_Op => 30960 return Is_Known_On_Entry (Right_Opnd (Expr)); 30961 30962 when N_Binary_Op => 30963 return Is_Known_On_Entry (Left_Opnd (Expr)) 30964 and then Is_Known_On_Entry (Right_Opnd (Expr)); 30965 30966 when N_Type_Conversion | N_Qualified_Expression => 30967 return Is_Known_On_Entry (Expression (Expr)); 30968 30969 when N_If_Expression => 30970 if not All_Exps_Known_On_Entry (Expressions (Expr)) then 30971 return False; 30972 end if; 30973 30974 when N_Case_Expression => 30975 if not Is_Known_On_Entry (Expression (Expr)) then 30976 return False; 30977 end if; 30978 30979 declare 30980 Alt : Node_Id := First (Alternatives (Expr)); 30981 begin 30982 while Present (Alt) loop 30983 if not Is_Known_On_Entry (Expression (Alt)) then 30984 return False; 30985 end if; 30986 Next (Alt); 30987 end loop; 30988 end; 30989 30990 return True; 30991 30992 when others => 30993 null; 30994 end case; 30995 30996 return False; 30997 end Is_Known_On_Entry; 30998 30999 end Conditional_Evaluation; 31000 31001 package body Indirect_Temps is 31002 31003 Indirect_Temp_Access_Type_Char : constant Character := 'K'; 31004 -- The character passed to Make_Temporary when declaring 31005 -- the access type that is used in the implementation of an 31006 -- indirect temporary. 31007 31008 -------------------------- 31009 -- Indirect_Temp_Needed -- 31010 -------------------------- 31011 31012 function Indirect_Temp_Needed (Typ : Entity_Id) return Boolean is 31013 begin 31014 -- There should be no correctness issues if the only cases where 31015 -- this function returns False are cases where Typ is an 31016 -- anonymous access type and we need to generate a saooaaat (a 31017 -- stand-alone object of an anonymous access type) in order get 31018 -- accessibility right. In other cases where this function 31019 -- returns False, there would be no correctness problems with 31020 -- returning True instead; however, returning False when we can 31021 -- generally results in simpler code. 31022 31023 return False 31024 31025 -- If Typ is not definite, then we cannot generate 31026 -- Temp : Typ; 31027 31028 or else not Is_Definite_Subtype (Typ) 31029 31030 -- If Typ is tagged, then generating 31031 -- Temp : Typ; 31032 -- might generate an object with the wrong tag. If we had 31033 -- a predicate that indicated whether the nominal tag is 31034 -- trustworthy, we could use that predicate here. 31035 31036 or else Is_Tagged_Type (Typ) 31037 31038 -- If Typ needs finalization, then generating an implicit 31039 -- Temp : Typ; 31040 -- declaration could have user-visible side effects. 31041 31042 or else Needs_Finalization (Typ) 31043 31044 -- In the anonymous access type case, we need to 31045 -- generate a saooaaat. We don't want the code in 31046 -- in exp_attr.adb that deals with the case where this 31047 -- function returns False to have to deal with that case 31048 -- (just to avoid code duplication). So we cheat a little 31049 -- bit and return True here for an anonymous access type. 31050 31051 or else Is_Anonymous_Access_Type (Typ); 31052 31053 -- ??? Unimplemented - spec description says: 31054 -- For an unconstrained-but-definite discriminated subtype, 31055 -- returns True if the potential difference in size between an 31056 -- unconstrained object and a constrained object is large. 31057 -- 31058 -- For example, 31059 -- type Typ (Len : Natural := 0) is 31060 -- record F : String (1 .. Len); end record; 31061 -- 31062 -- See Large_Max_Size_Mutable function elsewhere in this 31063 -- file (currently declared inside of 31064 -- Requires_Transient_Scope, so it would have to be 31065 -- moved if we want it to be callable from here). 31066 31067 end Indirect_Temp_Needed; 31068 31069 --------------------------- 31070 -- Declare_Indirect_Temp -- 31071 --------------------------- 31072 31073 procedure Declare_Indirect_Temp 31074 (Attr_Prefix : Node_Id; Indirect_Temp : out Entity_Id) 31075 is 31076 Loc : constant Source_Ptr := Sloc (Attr_Prefix); 31077 Prefix_Type : constant Entity_Id := Etype (Attr_Prefix); 31078 Temp_Id : constant Entity_Id := 31079 Make_Temporary (Loc, 'P', Attr_Prefix); 31080 31081 procedure Declare_Indirect_Temp_Via_Allocation; 31082 -- Handle the usual case. 31083 31084 ------------------------------------------- 31085 -- Declare_Indirect_Temp_Via_Allocation -- 31086 ------------------------------------------- 31087 31088 procedure Declare_Indirect_Temp_Via_Allocation is 31089 Access_Type_Id : constant Entity_Id 31090 := Make_Temporary 31091 (Loc, Indirect_Temp_Access_Type_Char, Attr_Prefix); 31092 31093 Temp_Decl : constant Node_Id := 31094 Make_Object_Declaration (Loc, 31095 Defining_Identifier => Temp_Id, 31096 Object_Definition => 31097 New_Occurrence_Of (Access_Type_Id, Loc)); 31098 31099 Allocate_Class_Wide : constant Boolean := 31100 Is_Specific_Tagged_Type (Prefix_Type); 31101 -- If True then access type designates the class-wide type in 31102 -- order to preserve (at run time) the value of the underlying 31103 -- tag. 31104 -- ??? We could do better here (in the case where Prefix_Type 31105 -- is tagged and specific) if we had a predicate which takes an 31106 -- expression and returns True iff the expression is of 31107 -- a specific tagged type and the underlying tag (at run time) 31108 -- is statically known to match that of the specific type. 31109 -- In that case, Allocate_Class_Wide could safely be False. 31110 31111 function Designated_Subtype_Mark return Node_Id; 31112 -- Usually, a subtype mark indicating the subtype of the 31113 -- attribute prefix. If that subtype is a specific tagged 31114 -- type, then returns the corresponding class-wide type. 31115 -- If the prefix is of an anonymous access type, then returns 31116 -- the designated type of that type. 31117 31118 ----------------------------- 31119 -- Designated_Subtype_Mark -- 31120 ----------------------------- 31121 31122 function Designated_Subtype_Mark return Node_Id is 31123 Typ : Entity_Id := Prefix_Type; 31124 begin 31125 if Allocate_Class_Wide then 31126 if Is_Private_Type (Typ) 31127 and then Present (Full_View (Typ)) 31128 then 31129 Typ := Full_View (Typ); 31130 end if; 31131 Typ := Class_Wide_Type (Typ); 31132 end if; 31133 31134 return New_Occurrence_Of (Typ, Loc); 31135 end Designated_Subtype_Mark; 31136 31137 Access_Type_Def : constant Node_Id 31138 := Make_Access_To_Object_Definition 31139 (Loc, Subtype_Indication => Designated_Subtype_Mark); 31140 31141 Access_Type_Decl : constant Node_Id 31142 := Make_Full_Type_Declaration 31143 (Loc, Access_Type_Id, 31144 Type_Definition => Access_Type_Def); 31145 begin 31146 Set_Ekind (Temp_Id, E_Variable); 31147 Set_Etype (Temp_Id, Access_Type_Id); 31148 Set_Ekind (Access_Type_Id, E_Access_Type); 31149 31150 if Append_Decls_In_Reverse_Order then 31151 Append_Item (Temp_Decl, Is_Eval_Stmt => False); 31152 Append_Item (Access_Type_Decl, Is_Eval_Stmt => False); 31153 else 31154 Append_Item (Access_Type_Decl, Is_Eval_Stmt => False); 31155 Append_Item (Temp_Decl, Is_Eval_Stmt => False); 31156 end if; 31157 31158 -- When a type associated with an indirect temporary gets 31159 -- created for a 'Old attribute reference we need to mark 31160 -- the type as such. This allows, for example, finalization 31161 -- masters associated with them to be finalized in the correct 31162 -- order after postcondition checks. 31163 31164 if Attribute_Name (Parent (Attr_Prefix)) = Name_Old then 31165 Set_Stores_Attribute_Old_Prefix (Access_Type_Id); 31166 end if; 31167 31168 Analyze (Access_Type_Decl); 31169 Analyze (Temp_Decl); 31170 31171 pragma Assert 31172 (Is_Access_Type_For_Indirect_Temp (Access_Type_Id)); 31173 31174 declare 31175 Expression : Node_Id := Attr_Prefix; 31176 Allocator : Node_Id; 31177 begin 31178 if Allocate_Class_Wide then 31179 -- generate T'Class'(T'Class (<prefix>)) 31180 Expression := 31181 Make_Type_Conversion (Loc, 31182 Subtype_Mark => Designated_Subtype_Mark, 31183 Expression => Expression); 31184 end if; 31185 31186 Allocator := 31187 Make_Allocator (Loc, 31188 Make_Qualified_Expression 31189 (Loc, 31190 Subtype_Mark => Designated_Subtype_Mark, 31191 Expression => Expression)); 31192 31193 -- Allocate saved prefix value on the secondary stack 31194 -- in order to avoid introducing a storage leak. This 31195 -- allocated object is never explicitly reclaimed. 31196 -- 31197 -- ??? Emit storage leak warning if RE_SS_Pool 31198 -- unavailable? 31199 31200 if RTE_Available (RE_SS_Pool) then 31201 Set_Storage_Pool (Allocator, RTE (RE_SS_Pool)); 31202 Set_Procedure_To_Call 31203 (Allocator, RTE (RE_SS_Allocate)); 31204 Set_Uses_Sec_Stack (Current_Scope); 31205 end if; 31206 31207 Append_Item 31208 (Make_Assignment_Statement (Loc, 31209 Name => New_Occurrence_Of (Temp_Id, Loc), 31210 Expression => Allocator), 31211 Is_Eval_Stmt => True); 31212 end; 31213 end Declare_Indirect_Temp_Via_Allocation; 31214 31215 begin 31216 Indirect_Temp := Temp_Id; 31217 31218 if Is_Anonymous_Access_Type (Prefix_Type) then 31219 -- In the anonymous access type case, we do not want a level 31220 -- indirection (which would result in declaring an 31221 -- access-to-access type); that would result in correctness 31222 -- problems - the accessibility level of the type of the 31223 -- 'Old constant would be wrong (See 6.1.1.). So in that case, 31224 -- we do not generate an allocator. Instead we generate 31225 -- Temp : access Designated := null; 31226 -- which is unconditionally elaborated and then 31227 -- Temp := <attribute prefix>; 31228 -- which is conditionally executed. 31229 31230 declare 31231 Temp_Decl : constant Node_Id := 31232 Make_Object_Declaration (Loc, 31233 Defining_Identifier => Temp_Id, 31234 Object_Definition => 31235 Make_Access_Definition 31236 (Loc, 31237 Constant_Present => 31238 Is_Access_Constant (Prefix_Type), 31239 Subtype_Mark => 31240 New_Occurrence_Of 31241 (Designated_Type (Prefix_Type), Loc))); 31242 begin 31243 Append_Item (Temp_Decl, Is_Eval_Stmt => False); 31244 Analyze (Temp_Decl); 31245 Append_Item 31246 (Make_Assignment_Statement (Loc, 31247 Name => New_Occurrence_Of (Temp_Id, Loc), 31248 Expression => Attr_Prefix), 31249 Is_Eval_Stmt => True); 31250 end; 31251 else 31252 -- the usual case 31253 Declare_Indirect_Temp_Via_Allocation; 31254 end if; 31255 end Declare_Indirect_Temp; 31256 31257 ------------------------- 31258 -- Indirect_Temp_Value -- 31259 ------------------------- 31260 31261 function Indirect_Temp_Value 31262 (Temp : Entity_Id; 31263 Typ : Entity_Id; 31264 Loc : Source_Ptr) return Node_Id 31265 is 31266 Result : Node_Id; 31267 begin 31268 if Is_Anonymous_Access_Type (Typ) then 31269 -- No indirection in this case; just evaluate the temp. 31270 Result := New_Occurrence_Of (Temp, Loc); 31271 Set_Etype (Result, Etype (Temp)); 31272 31273 else 31274 Result := Make_Explicit_Dereference (Loc, 31275 New_Occurrence_Of (Temp, Loc)); 31276 31277 Set_Etype (Result, Designated_Type (Etype (Temp))); 31278 31279 if Is_Specific_Tagged_Type (Typ) then 31280 -- The designated type of the access type is class-wide, so 31281 -- convert to the specific type. 31282 31283 Result := 31284 Make_Type_Conversion (Loc, 31285 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 31286 Expression => Result); 31287 31288 Set_Etype (Result, Typ); 31289 end if; 31290 end if; 31291 31292 return Result; 31293 end Indirect_Temp_Value; 31294 31295 function Is_Access_Type_For_Indirect_Temp 31296 (T : Entity_Id) return Boolean is 31297 begin 31298 if Is_Access_Type (T) 31299 and then not Comes_From_Source (T) 31300 and then Is_Internal_Name (Chars (T)) 31301 and then Nkind (Scope (T)) in N_Entity 31302 and then Ekind (Scope (T)) 31303 in E_Entry | E_Entry_Family | E_Function | E_Procedure 31304 and then 31305 (Present (Postconditions_Proc (Scope (T))) 31306 or else Present (Contract (Scope (T)))) 31307 then 31308 -- ??? Should define a flag for this. We could incorrectly 31309 -- return True if other clients of Make_Temporary happen to 31310 -- pass in the same character. 31311 declare 31312 Name : constant String := Get_Name_String (Chars (T)); 31313 begin 31314 if Name (Name'First) = Indirect_Temp_Access_Type_Char then 31315 return True; 31316 end if; 31317 end; 31318 end if; 31319 return False; 31320 end Is_Access_Type_For_Indirect_Temp; 31321 31322 end Indirect_Temps; 31323 end Old_Attr_Util; 31324begin 31325 Erroutc.Subprogram_Name_Ptr := Subprogram_Name'Access; 31326end Sem_Util; 31327