1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ U T I L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Aspects; use Aspects; 27with Atree; use Atree; 28with Casing; use Casing; 29with Checks; use Checks; 30with Debug; use Debug; 31with Einfo; use Einfo; 32with Elists; use Elists; 33with Errout; use Errout; 34with Exp_Aggr; use Exp_Aggr; 35with Exp_Ch2; use Exp_Ch2; 36with Exp_Ch6; use Exp_Ch6; 37with Exp_Ch7; use Exp_Ch7; 38with Exp_Ch11; use Exp_Ch11; 39with Ghost; use Ghost; 40with Inline; use Inline; 41with Itypes; use Itypes; 42with Lib; use Lib; 43with Nlists; use Nlists; 44with Nmake; use Nmake; 45with Opt; use Opt; 46with Restrict; use Restrict; 47with Rident; use Rident; 48with Sem; use Sem; 49with Sem_Aux; use Sem_Aux; 50with Sem_Ch3; use Sem_Ch3; 51with Sem_Ch6; use Sem_Ch6; 52with Sem_Ch8; use Sem_Ch8; 53with Sem_Ch12; use Sem_Ch12; 54with Sem_Ch13; use Sem_Ch13; 55with Sem_Disp; use Sem_Disp; 56with Sem_Elab; use Sem_Elab; 57with Sem_Eval; use Sem_Eval; 58with Sem_Res; use Sem_Res; 59with Sem_Type; use Sem_Type; 60with Sem_Util; use Sem_Util; 61with Snames; use Snames; 62with Stand; use Stand; 63with Stringt; use Stringt; 64with Targparm; use Targparm; 65with Tbuild; use Tbuild; 66with Ttypes; use Ttypes; 67with Urealp; use Urealp; 68with Validsw; use Validsw; 69 70with GNAT.HTable; 71package body Exp_Util is 72 73 --------------------------------------------------------- 74 -- Handling of inherited class-wide pre/postconditions -- 75 --------------------------------------------------------- 76 77 -- Following AI12-0113, the expression for a class-wide condition is 78 -- transformed for a subprogram that inherits it, by replacing calls 79 -- to primitive operations of the original controlling type into the 80 -- corresponding overriding operations of the derived type. The following 81 -- hash table manages this mapping, and is expanded on demand whenever 82 -- such inherited expression needs to be constructed. 83 84 -- The mapping is also used to check whether an inherited operation has 85 -- a condition that depends on overridden operations. For such an 86 -- operation we must create a wrapper that is then treated as a normal 87 -- overriding. In SPARK mode such operations are illegal. 88 89 -- For a given root type there may be several type extensions with their 90 -- own overriding operations, so at various times a given operation of 91 -- the root will be mapped into different overridings. The root type is 92 -- also mapped into the current type extension to indicate that its 93 -- operations are mapped into the overriding operations of that current 94 -- type extension. 95 96 -- The contents of the map are as follows: 97 98 -- Key Value 99 100 -- Discriminant (Entity_Id) Discriminant (Entity_Id) 101 -- Discriminant (Entity_Id) Non-discriminant name (Entity_Id) 102 -- Discriminant (Entity_Id) Expression (Node_Id) 103 -- Primitive subprogram (Entity_Id) Primitive subprogram (Entity_Id) 104 -- Type (Entity_Id) Type (Entity_Id) 105 106 Type_Map_Size : constant := 511; 107 108 subtype Type_Map_Header is Integer range 0 .. Type_Map_Size - 1; 109 function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header; 110 111 package Type_Map is new GNAT.HTable.Simple_HTable 112 (Header_Num => Type_Map_Header, 113 Key => Entity_Id, 114 Element => Node_Or_Entity_Id, 115 No_element => Empty, 116 Hash => Type_Map_Hash, 117 Equal => "="); 118 119 ----------------------- 120 -- Local Subprograms -- 121 ----------------------- 122 123 function Build_Task_Array_Image 124 (Loc : Source_Ptr; 125 Id_Ref : Node_Id; 126 A_Type : Entity_Id; 127 Dyn : Boolean := False) return Node_Id; 128 -- Build function to generate the image string for a task that is an array 129 -- component, concatenating the images of each index. To avoid storage 130 -- leaks, the string is built with successive slice assignments. The flag 131 -- Dyn indicates whether this is called for the initialization procedure of 132 -- an array of tasks, or for the name of a dynamically created task that is 133 -- assigned to an indexed component. 134 135 function Build_Task_Image_Function 136 (Loc : Source_Ptr; 137 Decls : List_Id; 138 Stats : List_Id; 139 Res : Entity_Id) return Node_Id; 140 -- Common processing for Task_Array_Image and Task_Record_Image. Build 141 -- function body that computes image. 142 143 procedure Build_Task_Image_Prefix 144 (Loc : Source_Ptr; 145 Len : out Entity_Id; 146 Res : out Entity_Id; 147 Pos : out Entity_Id; 148 Prefix : Entity_Id; 149 Sum : Node_Id; 150 Decls : List_Id; 151 Stats : List_Id); 152 -- Common processing for Task_Array_Image and Task_Record_Image. Create 153 -- local variables and assign prefix of name to result string. 154 155 function Build_Task_Record_Image 156 (Loc : Source_Ptr; 157 Id_Ref : Node_Id; 158 Dyn : Boolean := False) return Node_Id; 159 -- Build function to generate the image string for a task that is a record 160 -- component. Concatenate name of variable with that of selector. The flag 161 -- Dyn indicates whether this is called for the initialization procedure of 162 -- record with task components, or for a dynamically created task that is 163 -- assigned to a selected component. 164 165 procedure Evaluate_Slice_Bounds (Slice : Node_Id); 166 -- Force evaluation of bounds of a slice, which may be given by a range 167 -- or by a subtype indication with or without a constraint. 168 169 function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean; 170 -- Determine whether pragma Default_Initial_Condition denoted by Prag has 171 -- an assertion expression that should be verified at run time. 172 173 function Make_CW_Equivalent_Type 174 (T : Entity_Id; 175 E : Node_Id) return Entity_Id; 176 -- T is a class-wide type entity, E is the initial expression node that 177 -- constrains T in case such as: " X: T := E" or "new T'(E)". This function 178 -- returns the entity of the Equivalent type and inserts on the fly the 179 -- necessary declaration such as: 180 -- 181 -- type anon is record 182 -- _parent : Root_Type (T); constrained with E discriminants (if any) 183 -- Extension : String (1 .. expr to match size of E); 184 -- end record; 185 -- 186 -- This record is compatible with any object of the class of T thanks to 187 -- the first field and has the same size as E thanks to the second. 188 189 function Make_Literal_Range 190 (Loc : Source_Ptr; 191 Literal_Typ : Entity_Id) return Node_Id; 192 -- Produce a Range node whose bounds are: 193 -- Low_Bound (Literal_Type) .. 194 -- Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1) 195 -- this is used for expanding declarations like X : String := "sdfgdfg"; 196 -- 197 -- If the index type of the target array is not integer, we generate: 198 -- Low_Bound (Literal_Type) .. 199 -- Literal_Type'Val 200 -- (Literal_Type'Pos (Low_Bound (Literal_Type)) 201 -- + (Length (Literal_Typ) -1)) 202 203 function Make_Non_Empty_Check 204 (Loc : Source_Ptr; 205 N : Node_Id) return Node_Id; 206 -- Produce a boolean expression checking that the unidimensional array 207 -- node N is not empty. 208 209 function New_Class_Wide_Subtype 210 (CW_Typ : Entity_Id; 211 N : Node_Id) return Entity_Id; 212 -- Create an implicit subtype of CW_Typ attached to node N 213 214 function Requires_Cleanup_Actions 215 (L : List_Id; 216 Lib_Level : Boolean; 217 Nested_Constructs : Boolean) return Boolean; 218 -- Given a list L, determine whether it contains one of the following: 219 -- 220 -- 1) controlled objects 221 -- 2) library-level tagged types 222 -- 223 -- Lib_Level is True when the list comes from a construct at the library 224 -- level, and False otherwise. Nested_Constructs is True when any nested 225 -- packages declared in L must be processed, and False otherwise. 226 227 ------------------------------------- 228 -- Activate_Atomic_Synchronization -- 229 ------------------------------------- 230 231 procedure Activate_Atomic_Synchronization (N : Node_Id) is 232 Msg_Node : Node_Id; 233 234 begin 235 case Nkind (Parent (N)) is 236 237 -- Check for cases of appearing in the prefix of a construct where we 238 -- don't need atomic synchronization for this kind of usage. 239 240 when 241 -- Nothing to do if we are the prefix of an attribute, since we 242 -- do not want an atomic sync operation for things like 'Size. 243 244 N_Attribute_Reference 245 246 -- The N_Reference node is like an attribute 247 248 | N_Reference 249 250 -- Nothing to do for a reference to a component (or components) 251 -- of a composite object. Only reads and updates of the object 252 -- as a whole require atomic synchronization (RM C.6 (15)). 253 254 | N_Indexed_Component 255 | N_Selected_Component 256 | N_Slice 257 => 258 -- For all the above cases, nothing to do if we are the prefix 259 260 if Prefix (Parent (N)) = N then 261 return; 262 end if; 263 264 when others => 265 null; 266 end case; 267 268 -- Nothing to do for the identifier in an object renaming declaration, 269 -- the renaming itself does not need atomic synchronization. 270 271 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then 272 return; 273 end if; 274 275 -- Go ahead and set the flag 276 277 Set_Atomic_Sync_Required (N); 278 279 -- Generate info message if requested 280 281 if Warn_On_Atomic_Synchronization then 282 case Nkind (N) is 283 when N_Identifier => 284 Msg_Node := N; 285 286 when N_Expanded_Name 287 | N_Selected_Component 288 => 289 Msg_Node := Selector_Name (N); 290 291 when N_Explicit_Dereference 292 | N_Indexed_Component 293 => 294 Msg_Node := Empty; 295 296 when others => 297 pragma Assert (False); 298 return; 299 end case; 300 301 if Present (Msg_Node) then 302 Error_Msg_N 303 ("info: atomic synchronization set for &?N?", Msg_Node); 304 else 305 Error_Msg_N 306 ("info: atomic synchronization set?N?", N); 307 end if; 308 end if; 309 end Activate_Atomic_Synchronization; 310 311 ---------------------- 312 -- Adjust_Condition -- 313 ---------------------- 314 315 procedure Adjust_Condition (N : Node_Id) is 316 begin 317 if No (N) then 318 return; 319 end if; 320 321 declare 322 Loc : constant Source_Ptr := Sloc (N); 323 T : constant Entity_Id := Etype (N); 324 Ti : Entity_Id; 325 326 begin 327 -- Defend against a call where the argument has no type, or has a 328 -- type that is not Boolean. This can occur because of prior errors. 329 330 if No (T) or else not Is_Boolean_Type (T) then 331 return; 332 end if; 333 334 -- Apply validity checking if needed 335 336 if Validity_Checks_On and Validity_Check_Tests then 337 Ensure_Valid (N); 338 end if; 339 340 -- Immediate return if standard boolean, the most common case, 341 -- where nothing needs to be done. 342 343 if Base_Type (T) = Standard_Boolean then 344 return; 345 end if; 346 347 -- Case of zero/nonzero semantics or nonstandard enumeration 348 -- representation. In each case, we rewrite the node as: 349 350 -- ityp!(N) /= False'Enum_Rep 351 352 -- where ityp is an integer type with large enough size to hold any 353 -- value of type T. 354 355 if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then 356 if Esize (T) <= Esize (Standard_Integer) then 357 Ti := Standard_Integer; 358 else 359 Ti := Standard_Long_Long_Integer; 360 end if; 361 362 Rewrite (N, 363 Make_Op_Ne (Loc, 364 Left_Opnd => Unchecked_Convert_To (Ti, N), 365 Right_Opnd => 366 Make_Attribute_Reference (Loc, 367 Attribute_Name => Name_Enum_Rep, 368 Prefix => 369 New_Occurrence_Of (First_Literal (T), Loc)))); 370 Analyze_And_Resolve (N, Standard_Boolean); 371 372 else 373 Rewrite (N, Convert_To (Standard_Boolean, N)); 374 Analyze_And_Resolve (N, Standard_Boolean); 375 end if; 376 end; 377 end Adjust_Condition; 378 379 ------------------------ 380 -- Adjust_Result_Type -- 381 ------------------------ 382 383 procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is 384 begin 385 -- Ignore call if current type is not Standard.Boolean 386 387 if Etype (N) /= Standard_Boolean then 388 return; 389 end if; 390 391 -- If result is already of correct type, nothing to do. Note that 392 -- this will get the most common case where everything has a type 393 -- of Standard.Boolean. 394 395 if Base_Type (T) = Standard_Boolean then 396 return; 397 398 else 399 declare 400 KP : constant Node_Kind := Nkind (Parent (N)); 401 402 begin 403 -- If result is to be used as a Condition in the syntax, no need 404 -- to convert it back, since if it was changed to Standard.Boolean 405 -- using Adjust_Condition, that is just fine for this usage. 406 407 if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then 408 return; 409 410 -- If result is an operand of another logical operation, no need 411 -- to reset its type, since Standard.Boolean is just fine, and 412 -- such operations always do Adjust_Condition on their operands. 413 414 elsif KP in N_Op_Boolean 415 or else KP in N_Short_Circuit 416 or else KP = N_Op_Not 417 then 418 return; 419 420 -- Otherwise we perform a conversion from the current type, which 421 -- must be Standard.Boolean, to the desired type. Use the base 422 -- type to prevent spurious constraint checks that are extraneous 423 -- to the transformation. The type and its base have the same 424 -- representation, standard or otherwise. 425 426 else 427 Set_Analyzed (N); 428 Rewrite (N, Convert_To (Base_Type (T), N)); 429 Analyze_And_Resolve (N, Base_Type (T)); 430 end if; 431 end; 432 end if; 433 end Adjust_Result_Type; 434 435 -------------------------- 436 -- Append_Freeze_Action -- 437 -------------------------- 438 439 procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is 440 Fnode : Node_Id; 441 442 begin 443 Ensure_Freeze_Node (T); 444 Fnode := Freeze_Node (T); 445 446 if No (Actions (Fnode)) then 447 Set_Actions (Fnode, New_List (N)); 448 else 449 Append (N, Actions (Fnode)); 450 end if; 451 452 end Append_Freeze_Action; 453 454 --------------------------- 455 -- Append_Freeze_Actions -- 456 --------------------------- 457 458 procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is 459 Fnode : Node_Id; 460 461 begin 462 if No (L) then 463 return; 464 end if; 465 466 Ensure_Freeze_Node (T); 467 Fnode := Freeze_Node (T); 468 469 if No (Actions (Fnode)) then 470 Set_Actions (Fnode, L); 471 else 472 Append_List (L, Actions (Fnode)); 473 end if; 474 end Append_Freeze_Actions; 475 476 -------------------------------------- 477 -- Attr_Constrained_Statically_True -- 478 -------------------------------------- 479 480 function Attribute_Constrained_Static_Value (Pref : Node_Id) return Boolean 481 is 482 Ptyp : constant Entity_Id := Etype (Pref); 483 Formal_Ent : constant Entity_Id := Param_Entity (Pref); 484 485 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean; 486 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a 487 -- view of an aliased object whose subtype is constrained. 488 489 --------------------------------- 490 -- Is_Constrained_Aliased_View -- 491 --------------------------------- 492 493 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is 494 E : Entity_Id; 495 496 begin 497 if Is_Entity_Name (Obj) then 498 E := Entity (Obj); 499 500 if Present (Renamed_Object (E)) then 501 return Is_Constrained_Aliased_View (Renamed_Object (E)); 502 else 503 return Is_Aliased (E) and then Is_Constrained (Etype (E)); 504 end if; 505 506 else 507 return Is_Aliased_View (Obj) 508 and then 509 (Is_Constrained (Etype (Obj)) 510 or else 511 (Nkind (Obj) = N_Explicit_Dereference 512 and then 513 not Object_Type_Has_Constrained_Partial_View 514 (Typ => Base_Type (Etype (Obj)), 515 Scop => Current_Scope))); 516 end if; 517 end Is_Constrained_Aliased_View; 518 519 -- Start of processing for Attribute_Constrained_Static_Value 520 521 begin 522 -- We are in a case where the attribute is known statically, and 523 -- implicit dereferences have been rewritten. 524 525 pragma Assert 526 (not (Present (Formal_Ent) 527 and then Ekind (Formal_Ent) /= E_Constant 528 and then Present (Extra_Constrained (Formal_Ent))) 529 and then 530 not (Is_Access_Type (Etype (Pref)) 531 and then (not Is_Entity_Name (Pref) 532 or else Is_Object (Entity (Pref)))) 533 and then 534 not (Nkind (Pref) = N_Identifier 535 and then Ekind (Entity (Pref)) = E_Variable 536 and then Present (Extra_Constrained (Entity (Pref))))); 537 538 if Is_Entity_Name (Pref) then 539 declare 540 Ent : constant Entity_Id := Entity (Pref); 541 Res : Boolean; 542 543 begin 544 -- (RM J.4) obsolescent cases 545 546 if Is_Type (Ent) then 547 548 -- Private type 549 550 if Is_Private_Type (Ent) then 551 Res := not Has_Discriminants (Ent) 552 or else Is_Constrained (Ent); 553 554 -- It not a private type, must be a generic actual type 555 -- that corresponded to a private type. We know that this 556 -- correspondence holds, since otherwise the reference 557 -- within the generic template would have been illegal. 558 559 else 560 if Is_Composite_Type (Underlying_Type (Ent)) then 561 Res := Is_Constrained (Ent); 562 else 563 Res := True; 564 end if; 565 end if; 566 567 else 568 569 -- If the prefix is not a variable or is aliased, then 570 -- definitely true; if it's a formal parameter without an 571 -- associated extra formal, then treat it as constrained. 572 573 -- Ada 2005 (AI-363): An aliased prefix must be known to be 574 -- constrained in order to set the attribute to True. 575 576 if not Is_Variable (Pref) 577 or else Present (Formal_Ent) 578 or else (Ada_Version < Ada_2005 579 and then Is_Aliased_View (Pref)) 580 or else (Ada_Version >= Ada_2005 581 and then Is_Constrained_Aliased_View (Pref)) 582 then 583 Res := True; 584 585 -- Variable case, look at type to see if it is constrained. 586 -- Note that the one case where this is not accurate (the 587 -- procedure formal case), has been handled above. 588 589 -- We use the Underlying_Type here (and below) in case the 590 -- type is private without discriminants, but the full type 591 -- has discriminants. This case is illegal, but we generate 592 -- it internally for passing to the Extra_Constrained 593 -- parameter. 594 595 else 596 -- In Ada 2012, test for case of a limited tagged type, 597 -- in which case the attribute is always required to 598 -- return True. The underlying type is tested, to make 599 -- sure we also return True for cases where there is an 600 -- unconstrained object with an untagged limited partial 601 -- view which has defaulted discriminants (such objects 602 -- always produce a False in earlier versions of 603 -- Ada). (Ada 2012: AI05-0214) 604 605 Res := 606 Is_Constrained (Underlying_Type (Etype (Ent))) 607 or else 608 (Ada_Version >= Ada_2012 609 and then Is_Tagged_Type (Underlying_Type (Ptyp)) 610 and then Is_Limited_Type (Ptyp)); 611 end if; 612 end if; 613 614 return Res; 615 end; 616 617 -- Prefix is not an entity name. These are also cases where we can 618 -- always tell at compile time by looking at the form and type of the 619 -- prefix. If an explicit dereference of an object with constrained 620 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the 621 -- underlying type is a limited tagged type, then Constrained is 622 -- required to always return True (Ada 2012: AI05-0214). 623 624 else 625 return not Is_Variable (Pref) 626 or else 627 (Nkind (Pref) = N_Explicit_Dereference 628 and then 629 not Object_Type_Has_Constrained_Partial_View 630 (Typ => Base_Type (Ptyp), 631 Scop => Current_Scope)) 632 or else Is_Constrained (Underlying_Type (Ptyp)) 633 or else (Ada_Version >= Ada_2012 634 and then Is_Tagged_Type (Underlying_Type (Ptyp)) 635 and then Is_Limited_Type (Ptyp)); 636 end if; 637 end Attribute_Constrained_Static_Value; 638 639 ------------------------------------ 640 -- Build_Allocate_Deallocate_Proc -- 641 ------------------------------------ 642 643 procedure Build_Allocate_Deallocate_Proc 644 (N : Node_Id; 645 Is_Allocate : Boolean) 646 is 647 function Find_Object (E : Node_Id) return Node_Id; 648 -- Given an arbitrary expression of an allocator, try to find an object 649 -- reference in it, otherwise return the original expression. 650 651 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean; 652 -- Determine whether subprogram Subp denotes a custom allocate or 653 -- deallocate. 654 655 ----------------- 656 -- Find_Object -- 657 ----------------- 658 659 function Find_Object (E : Node_Id) return Node_Id is 660 Expr : Node_Id; 661 662 begin 663 pragma Assert (Is_Allocate); 664 665 Expr := E; 666 loop 667 if Nkind (Expr) = N_Explicit_Dereference then 668 Expr := Prefix (Expr); 669 670 elsif Nkind (Expr) = N_Qualified_Expression then 671 Expr := Expression (Expr); 672 673 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then 674 675 -- When interface class-wide types are involved in allocation, 676 -- the expander introduces several levels of address arithmetic 677 -- to perform dispatch table displacement. In this scenario the 678 -- object appears as: 679 680 -- Tag_Ptr (Base_Address (<object>'Address)) 681 682 -- Detect this case and utilize the whole expression as the 683 -- "object" since it now points to the proper dispatch table. 684 685 if Is_RTE (Etype (Expr), RE_Tag_Ptr) then 686 exit; 687 688 -- Continue to strip the object 689 690 else 691 Expr := Expression (Expr); 692 end if; 693 694 else 695 exit; 696 end if; 697 end loop; 698 699 return Expr; 700 end Find_Object; 701 702 --------------------------------- 703 -- Is_Allocate_Deallocate_Proc -- 704 --------------------------------- 705 706 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is 707 begin 708 -- Look for a subprogram body with only one statement which is a 709 -- call to Allocate_Any_Controlled / Deallocate_Any_Controlled. 710 711 if Ekind (Subp) = E_Procedure 712 and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body 713 then 714 declare 715 HSS : constant Node_Id := 716 Handled_Statement_Sequence (Parent (Parent (Subp))); 717 Proc : Entity_Id; 718 719 begin 720 if Present (Statements (HSS)) 721 and then Nkind (First (Statements (HSS))) = 722 N_Procedure_Call_Statement 723 then 724 Proc := Entity (Name (First (Statements (HSS)))); 725 726 return 727 Is_RTE (Proc, RE_Allocate_Any_Controlled) 728 or else Is_RTE (Proc, RE_Deallocate_Any_Controlled); 729 end if; 730 end; 731 end if; 732 733 return False; 734 end Is_Allocate_Deallocate_Proc; 735 736 -- Local variables 737 738 Desig_Typ : Entity_Id; 739 Expr : Node_Id; 740 Needs_Fin : Boolean; 741 Pool_Id : Entity_Id; 742 Proc_To_Call : Node_Id := Empty; 743 Ptr_Typ : Entity_Id; 744 745 -- Start of processing for Build_Allocate_Deallocate_Proc 746 747 begin 748 -- Obtain the attributes of the allocation / deallocation 749 750 if Nkind (N) = N_Free_Statement then 751 Expr := Expression (N); 752 Ptr_Typ := Base_Type (Etype (Expr)); 753 Proc_To_Call := Procedure_To_Call (N); 754 755 else 756 if Nkind (N) = N_Object_Declaration then 757 Expr := Expression (N); 758 else 759 Expr := N; 760 end if; 761 762 -- In certain cases an allocator with a qualified expression may 763 -- be relocated and used as the initialization expression of a 764 -- temporary: 765 766 -- before: 767 -- Obj : Ptr_Typ := new Desig_Typ'(...); 768 769 -- after: 770 -- Tmp : Ptr_Typ := new Desig_Typ'(...); 771 -- Obj : Ptr_Typ := Tmp; 772 773 -- Since the allocator is always marked as analyzed to avoid infinite 774 -- expansion, it will never be processed by this routine given that 775 -- the designated type needs finalization actions. Detect this case 776 -- and complete the expansion of the allocator. 777 778 if Nkind (Expr) = N_Identifier 779 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration 780 and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator 781 then 782 Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True); 783 return; 784 end if; 785 786 -- The allocator may have been rewritten into something else in which 787 -- case the expansion performed by this routine does not apply. 788 789 if Nkind (Expr) /= N_Allocator then 790 return; 791 end if; 792 793 Ptr_Typ := Base_Type (Etype (Expr)); 794 Proc_To_Call := Procedure_To_Call (Expr); 795 end if; 796 797 Pool_Id := Associated_Storage_Pool (Ptr_Typ); 798 Desig_Typ := Available_View (Designated_Type (Ptr_Typ)); 799 800 -- Handle concurrent types 801 802 if Is_Concurrent_Type (Desig_Typ) 803 and then Present (Corresponding_Record_Type (Desig_Typ)) 804 then 805 Desig_Typ := Corresponding_Record_Type (Desig_Typ); 806 end if; 807 808 -- Do not process allocations / deallocations without a pool 809 810 if No (Pool_Id) then 811 return; 812 813 -- Do not process allocations on / deallocations from the secondary 814 -- stack. 815 816 elsif Is_RTE (Pool_Id, RE_SS_Pool) 817 or else (Nkind (Expr) = N_Allocator 818 and then Is_RTE (Storage_Pool (Expr), RE_SS_Pool)) 819 then 820 return; 821 822 -- Optimize the case where we are using the default Global_Pool_Object, 823 -- and we don't need the heavy finalization machinery. 824 825 elsif Pool_Id = RTE (RE_Global_Pool_Object) 826 and then not Needs_Finalization (Desig_Typ) 827 then 828 return; 829 830 -- Do not replicate the machinery if the allocator / free has already 831 -- been expanded and has a custom Allocate / Deallocate. 832 833 elsif Present (Proc_To_Call) 834 and then Is_Allocate_Deallocate_Proc (Proc_To_Call) 835 then 836 return; 837 end if; 838 839 -- Finalization actions are required when the object to be allocated or 840 -- deallocated needs these actions and the associated access type is not 841 -- subject to pragma No_Heap_Finalization. 842 843 Needs_Fin := 844 Needs_Finalization (Desig_Typ) 845 and then not No_Heap_Finalization (Ptr_Typ); 846 847 if Needs_Fin then 848 849 -- Do nothing if the access type may never allocate / deallocate 850 -- objects. 851 852 if No_Pool_Assigned (Ptr_Typ) then 853 return; 854 end if; 855 856 -- The allocation / deallocation of a controlled object must be 857 -- chained on / detached from a finalization master. 858 859 pragma Assert (Present (Finalization_Master (Ptr_Typ))); 860 861 -- The only other kind of allocation / deallocation supported by this 862 -- routine is on / from a subpool. 863 864 elsif Nkind (Expr) = N_Allocator 865 and then No (Subpool_Handle_Name (Expr)) 866 then 867 return; 868 end if; 869 870 declare 871 Loc : constant Source_Ptr := Sloc (N); 872 Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A'); 873 Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L'); 874 Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P'); 875 Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S'); 876 877 Actuals : List_Id; 878 Fin_Addr_Id : Entity_Id; 879 Fin_Mas_Act : Node_Id; 880 Fin_Mas_Id : Entity_Id; 881 Proc_To_Call : Entity_Id; 882 Subpool : Node_Id := Empty; 883 884 begin 885 -- Step 1: Construct all the actuals for the call to library routine 886 -- Allocate_Any_Controlled / Deallocate_Any_Controlled. 887 888 -- a) Storage pool 889 890 Actuals := New_List (New_Occurrence_Of (Pool_Id, Loc)); 891 892 if Is_Allocate then 893 894 -- b) Subpool 895 896 if Nkind (Expr) = N_Allocator then 897 Subpool := Subpool_Handle_Name (Expr); 898 end if; 899 900 -- If a subpool is present it can be an arbitrary name, so make 901 -- the actual by copying the tree. 902 903 if Present (Subpool) then 904 Append_To (Actuals, New_Copy_Tree (Subpool, New_Sloc => Loc)); 905 else 906 Append_To (Actuals, Make_Null (Loc)); 907 end if; 908 909 -- c) Finalization master 910 911 if Needs_Fin then 912 Fin_Mas_Id := Finalization_Master (Ptr_Typ); 913 Fin_Mas_Act := New_Occurrence_Of (Fin_Mas_Id, Loc); 914 915 -- Handle the case where the master is actually a pointer to a 916 -- master. This case arises in build-in-place functions. 917 918 if Is_Access_Type (Etype (Fin_Mas_Id)) then 919 Append_To (Actuals, Fin_Mas_Act); 920 else 921 Append_To (Actuals, 922 Make_Attribute_Reference (Loc, 923 Prefix => Fin_Mas_Act, 924 Attribute_Name => Name_Unrestricted_Access)); 925 end if; 926 else 927 Append_To (Actuals, Make_Null (Loc)); 928 end if; 929 930 -- d) Finalize_Address 931 932 -- Primitive Finalize_Address is never generated in CodePeer mode 933 -- since it contains an Unchecked_Conversion. 934 935 if Needs_Fin and then not CodePeer_Mode then 936 Fin_Addr_Id := Finalize_Address (Desig_Typ); 937 pragma Assert (Present (Fin_Addr_Id)); 938 939 Append_To (Actuals, 940 Make_Attribute_Reference (Loc, 941 Prefix => New_Occurrence_Of (Fin_Addr_Id, Loc), 942 Attribute_Name => Name_Unrestricted_Access)); 943 else 944 Append_To (Actuals, Make_Null (Loc)); 945 end if; 946 end if; 947 948 -- e) Address 949 -- f) Storage_Size 950 -- g) Alignment 951 952 Append_To (Actuals, New_Occurrence_Of (Addr_Id, Loc)); 953 Append_To (Actuals, New_Occurrence_Of (Size_Id, Loc)); 954 955 if Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ) then 956 Append_To (Actuals, New_Occurrence_Of (Alig_Id, Loc)); 957 958 -- For deallocation of class-wide types we obtain the value of 959 -- alignment from the Type Specific Record of the deallocated object. 960 -- This is needed because the frontend expansion of class-wide types 961 -- into equivalent types confuses the back end. 962 963 else 964 -- Generate: 965 -- Obj.all'Alignment 966 967 -- ... because 'Alignment applied to class-wide types is expanded 968 -- into the code that reads the value of alignment from the TSD 969 -- (see Expand_N_Attribute_Reference) 970 971 Append_To (Actuals, 972 Unchecked_Convert_To (RTE (RE_Storage_Offset), 973 Make_Attribute_Reference (Loc, 974 Prefix => 975 Make_Explicit_Dereference (Loc, Relocate_Node (Expr)), 976 Attribute_Name => Name_Alignment))); 977 end if; 978 979 -- h) Is_Controlled 980 981 if Needs_Fin then 982 Is_Controlled : declare 983 Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F'); 984 Flag_Expr : Node_Id; 985 Param : Node_Id; 986 Pref : Node_Id; 987 Temp : Node_Id; 988 989 begin 990 if Is_Allocate then 991 Temp := Find_Object (Expression (Expr)); 992 else 993 Temp := Expr; 994 end if; 995 996 -- Processing for allocations where the expression is a subtype 997 -- indication. 998 999 if Is_Allocate 1000 and then Is_Entity_Name (Temp) 1001 and then Is_Type (Entity (Temp)) 1002 then 1003 Flag_Expr := 1004 New_Occurrence_Of 1005 (Boolean_Literals 1006 (Needs_Finalization (Entity (Temp))), Loc); 1007 1008 -- The allocation / deallocation of a class-wide object relies 1009 -- on a runtime check to determine whether the object is truly 1010 -- controlled or not. Depending on this check, the finalization 1011 -- machinery will request or reclaim extra storage reserved for 1012 -- a list header. 1013 1014 elsif Is_Class_Wide_Type (Desig_Typ) then 1015 1016 -- Detect a special case where interface class-wide types 1017 -- are involved as the object appears as: 1018 1019 -- Tag_Ptr (Base_Address (<object>'Address)) 1020 1021 -- The expression already yields the proper tag, generate: 1022 1023 -- Temp.all 1024 1025 if Is_RTE (Etype (Temp), RE_Tag_Ptr) then 1026 Param := 1027 Make_Explicit_Dereference (Loc, 1028 Prefix => Relocate_Node (Temp)); 1029 1030 -- In the default case, obtain the tag of the object about 1031 -- to be allocated / deallocated. Generate: 1032 1033 -- Temp'Tag 1034 1035 -- If the object is an unchecked conversion (typically to 1036 -- an access to class-wide type), we must preserve the 1037 -- conversion to ensure that the object is seen as tagged 1038 -- in the code that follows. 1039 1040 else 1041 Pref := Temp; 1042 1043 if Nkind (Parent (Pref)) = N_Unchecked_Type_Conversion 1044 then 1045 Pref := Parent (Pref); 1046 end if; 1047 1048 Param := 1049 Make_Attribute_Reference (Loc, 1050 Prefix => Relocate_Node (Pref), 1051 Attribute_Name => Name_Tag); 1052 end if; 1053 1054 -- Generate: 1055 -- Needs_Finalization (<Param>) 1056 1057 Flag_Expr := 1058 Make_Function_Call (Loc, 1059 Name => 1060 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc), 1061 Parameter_Associations => New_List (Param)); 1062 1063 -- Processing for generic actuals 1064 1065 elsif Is_Generic_Actual_Type (Desig_Typ) then 1066 Flag_Expr := 1067 New_Occurrence_Of (Boolean_Literals 1068 (Needs_Finalization (Base_Type (Desig_Typ))), Loc); 1069 1070 -- The object does not require any specialized checks, it is 1071 -- known to be controlled. 1072 1073 else 1074 Flag_Expr := New_Occurrence_Of (Standard_True, Loc); 1075 end if; 1076 1077 -- Create the temporary which represents the finalization state 1078 -- of the expression. Generate: 1079 -- 1080 -- F : constant Boolean := <Flag_Expr>; 1081 1082 Insert_Action (N, 1083 Make_Object_Declaration (Loc, 1084 Defining_Identifier => Flag_Id, 1085 Constant_Present => True, 1086 Object_Definition => 1087 New_Occurrence_Of (Standard_Boolean, Loc), 1088 Expression => Flag_Expr)); 1089 1090 Append_To (Actuals, New_Occurrence_Of (Flag_Id, Loc)); 1091 end Is_Controlled; 1092 1093 -- The object is not controlled 1094 1095 else 1096 Append_To (Actuals, New_Occurrence_Of (Standard_False, Loc)); 1097 end if; 1098 1099 -- i) On_Subpool 1100 1101 if Is_Allocate then 1102 Append_To (Actuals, 1103 New_Occurrence_Of (Boolean_Literals (Present (Subpool)), Loc)); 1104 end if; 1105 1106 -- Step 2: Build a wrapper Allocate / Deallocate which internally 1107 -- calls Allocate_Any_Controlled / Deallocate_Any_Controlled. 1108 1109 -- Select the proper routine to call 1110 1111 if Is_Allocate then 1112 Proc_To_Call := RTE (RE_Allocate_Any_Controlled); 1113 else 1114 Proc_To_Call := RTE (RE_Deallocate_Any_Controlled); 1115 end if; 1116 1117 -- Create a custom Allocate / Deallocate routine which has identical 1118 -- profile to that of System.Storage_Pools. 1119 1120 Insert_Action (N, 1121 Make_Subprogram_Body (Loc, 1122 Specification => 1123 1124 -- procedure Pnn 1125 1126 Make_Procedure_Specification (Loc, 1127 Defining_Unit_Name => Proc_Id, 1128 Parameter_Specifications => New_List ( 1129 1130 -- P : Root_Storage_Pool 1131 1132 Make_Parameter_Specification (Loc, 1133 Defining_Identifier => Make_Temporary (Loc, 'P'), 1134 Parameter_Type => 1135 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc)), 1136 1137 -- A : [out] Address 1138 1139 Make_Parameter_Specification (Loc, 1140 Defining_Identifier => Addr_Id, 1141 Out_Present => Is_Allocate, 1142 Parameter_Type => 1143 New_Occurrence_Of (RTE (RE_Address), Loc)), 1144 1145 -- S : Storage_Count 1146 1147 Make_Parameter_Specification (Loc, 1148 Defining_Identifier => Size_Id, 1149 Parameter_Type => 1150 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)), 1151 1152 -- L : Storage_Count 1153 1154 Make_Parameter_Specification (Loc, 1155 Defining_Identifier => Alig_Id, 1156 Parameter_Type => 1157 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)))), 1158 1159 Declarations => No_List, 1160 1161 Handled_Statement_Sequence => 1162 Make_Handled_Sequence_Of_Statements (Loc, 1163 Statements => New_List ( 1164 Make_Procedure_Call_Statement (Loc, 1165 Name => 1166 New_Occurrence_Of (Proc_To_Call, Loc), 1167 Parameter_Associations => Actuals)))), 1168 Suppress => All_Checks); 1169 1170 -- The newly generated Allocate / Deallocate becomes the default 1171 -- procedure to call when the back end processes the allocation / 1172 -- deallocation. 1173 1174 if Is_Allocate then 1175 Set_Procedure_To_Call (Expr, Proc_Id); 1176 else 1177 Set_Procedure_To_Call (N, Proc_Id); 1178 end if; 1179 end; 1180 end Build_Allocate_Deallocate_Proc; 1181 1182 ------------------------------- 1183 -- Build_Abort_Undefer_Block -- 1184 ------------------------------- 1185 1186 function Build_Abort_Undefer_Block 1187 (Loc : Source_Ptr; 1188 Stmts : List_Id; 1189 Context : Node_Id) return Node_Id 1190 is 1191 Exceptions_OK : constant Boolean := 1192 not Restriction_Active (No_Exception_Propagation); 1193 1194 AUD : Entity_Id; 1195 Blk : Node_Id; 1196 Blk_Id : Entity_Id; 1197 HSS : Node_Id; 1198 1199 begin 1200 -- The block should be generated only when undeferring abort in the 1201 -- context of a potential exception. 1202 1203 pragma Assert (Abort_Allowed and Exceptions_OK); 1204 1205 -- Generate: 1206 -- begin 1207 -- <Stmts> 1208 -- at end 1209 -- Abort_Undefer_Direct; 1210 -- end; 1211 1212 AUD := RTE (RE_Abort_Undefer_Direct); 1213 1214 HSS := 1215 Make_Handled_Sequence_Of_Statements (Loc, 1216 Statements => Stmts, 1217 At_End_Proc => New_Occurrence_Of (AUD, Loc)); 1218 1219 Blk := 1220 Make_Block_Statement (Loc, 1221 Handled_Statement_Sequence => HSS); 1222 Set_Is_Abort_Block (Blk); 1223 1224 Add_Block_Identifier (Blk, Blk_Id); 1225 Expand_At_End_Handler (HSS, Blk_Id); 1226 1227 -- Present the Abort_Undefer_Direct function to the back end to inline 1228 -- the call to the routine. 1229 1230 Add_Inlined_Body (AUD, Context); 1231 1232 return Blk; 1233 end Build_Abort_Undefer_Block; 1234 1235 --------------------------------- 1236 -- Build_Class_Wide_Expression -- 1237 --------------------------------- 1238 1239 procedure Build_Class_Wide_Expression 1240 (Prag : Node_Id; 1241 Subp : Entity_Id; 1242 Par_Subp : Entity_Id; 1243 Adjust_Sloc : Boolean; 1244 Needs_Wrapper : out Boolean) 1245 is 1246 function Replace_Entity (N : Node_Id) return Traverse_Result; 1247 -- Replace reference to formal of inherited operation or to primitive 1248 -- operation of root type, with corresponding entity for derived type, 1249 -- when constructing the class-wide condition of an overriding 1250 -- subprogram. 1251 1252 -------------------- 1253 -- Replace_Entity -- 1254 -------------------- 1255 1256 function Replace_Entity (N : Node_Id) return Traverse_Result is 1257 New_E : Entity_Id; 1258 1259 begin 1260 if Adjust_Sloc then 1261 Adjust_Inherited_Pragma_Sloc (N); 1262 end if; 1263 1264 if Nkind (N) = N_Identifier 1265 and then Present (Entity (N)) 1266 and then 1267 (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N))) 1268 and then 1269 (Nkind (Parent (N)) /= N_Attribute_Reference 1270 or else Attribute_Name (Parent (N)) /= Name_Class) 1271 then 1272 -- The replacement does not apply to dispatching calls within the 1273 -- condition, but only to calls whose static tag is that of the 1274 -- parent type. 1275 1276 if Is_Subprogram (Entity (N)) 1277 and then Nkind (Parent (N)) = N_Function_Call 1278 and then Present (Controlling_Argument (Parent (N))) 1279 then 1280 return OK; 1281 end if; 1282 1283 -- Determine whether entity has a renaming 1284 1285 New_E := Type_Map.Get (Entity (N)); 1286 1287 if Present (New_E) then 1288 Rewrite (N, New_Occurrence_Of (New_E, Sloc (N))); 1289 1290 -- AI12-0166: a precondition for a protected operation 1291 -- cannot include an internal call to a protected function 1292 -- of the type. In the case of an inherited condition for an 1293 -- overriding operation, both the operation and the function 1294 -- are given by primitive wrappers. 1295 1296 if Ekind (New_E) = E_Function 1297 and then Is_Primitive_Wrapper (New_E) 1298 and then Is_Primitive_Wrapper (Subp) 1299 and then Scope (Subp) = Scope (New_E) 1300 then 1301 Error_Msg_Node_2 := Wrapped_Entity (Subp); 1302 Error_Msg_NE 1303 ("internal call to& cannot appear in inherited " 1304 & "precondition of protected operation&", 1305 N, Wrapped_Entity (New_E)); 1306 end if; 1307 1308 -- If the entity is an overridden primitive and we are not 1309 -- in GNATprove mode, we must build a wrapper for the current 1310 -- inherited operation. If the reference is the prefix of an 1311 -- attribute such as 'Result (or others ???) there is no need 1312 -- for a wrapper: the condition is just rewritten in terms of 1313 -- the inherited subprogram. 1314 1315 if Is_Subprogram (New_E) 1316 and then Nkind (Parent (N)) /= N_Attribute_Reference 1317 and then not GNATprove_Mode 1318 then 1319 Needs_Wrapper := True; 1320 end if; 1321 end if; 1322 1323 -- Check that there are no calls left to abstract operations if 1324 -- the current subprogram is not abstract. 1325 1326 if Nkind (Parent (N)) = N_Function_Call 1327 and then N = Name (Parent (N)) 1328 then 1329 if not Is_Abstract_Subprogram (Subp) 1330 and then Is_Abstract_Subprogram (Entity (N)) 1331 then 1332 Error_Msg_Sloc := Sloc (Current_Scope); 1333 Error_Msg_Node_2 := Subp; 1334 if Comes_From_Source (Subp) then 1335 Error_Msg_NE 1336 ("cannot call abstract subprogram & in inherited " 1337 & "condition for&#", Subp, Entity (N)); 1338 else 1339 Error_Msg_NE 1340 ("cannot call abstract subprogram & in inherited " 1341 & "condition for inherited&#", Subp, Entity (N)); 1342 end if; 1343 1344 -- In SPARK mode, reject an inherited condition for an 1345 -- inherited operation if it contains a call to an overriding 1346 -- operation, because this implies that the pre/postconditions 1347 -- of the inherited operation have changed silently. 1348 1349 elsif SPARK_Mode = On 1350 and then Warn_On_Suspicious_Contract 1351 and then Present (Alias (Subp)) 1352 and then Present (New_E) 1353 and then Comes_From_Source (New_E) 1354 then 1355 Error_Msg_N 1356 ("cannot modify inherited condition (SPARK RM 6.1.1(1))", 1357 Parent (Subp)); 1358 Error_Msg_Sloc := Sloc (New_E); 1359 Error_Msg_Node_2 := Subp; 1360 Error_Msg_NE 1361 ("\overriding of&# forces overriding of&", 1362 Parent (Subp), New_E); 1363 end if; 1364 end if; 1365 1366 -- Update type of function call node, which should be the same as 1367 -- the function's return type. 1368 1369 if Is_Subprogram (Entity (N)) 1370 and then Nkind (Parent (N)) = N_Function_Call 1371 then 1372 Set_Etype (Parent (N), Etype (Entity (N))); 1373 end if; 1374 1375 -- The whole expression will be reanalyzed 1376 1377 elsif Nkind (N) in N_Has_Etype then 1378 Set_Analyzed (N, False); 1379 end if; 1380 1381 return OK; 1382 end Replace_Entity; 1383 1384 procedure Replace_Condition_Entities is 1385 new Traverse_Proc (Replace_Entity); 1386 1387 -- Local variables 1388 1389 Par_Formal : Entity_Id; 1390 Subp_Formal : Entity_Id; 1391 1392 -- Start of processing for Build_Class_Wide_Expression 1393 1394 begin 1395 Needs_Wrapper := False; 1396 1397 -- Add mapping from old formals to new formals 1398 1399 Par_Formal := First_Formal (Par_Subp); 1400 Subp_Formal := First_Formal (Subp); 1401 1402 while Present (Par_Formal) and then Present (Subp_Formal) loop 1403 Type_Map.Set (Par_Formal, Subp_Formal); 1404 Next_Formal (Par_Formal); 1405 Next_Formal (Subp_Formal); 1406 end loop; 1407 1408 Replace_Condition_Entities (Prag); 1409 end Build_Class_Wide_Expression; 1410 1411 -------------------- 1412 -- Build_DIC_Call -- 1413 -------------------- 1414 1415 function Build_DIC_Call 1416 (Loc : Source_Ptr; 1417 Obj_Id : Entity_Id; 1418 Typ : Entity_Id) return Node_Id 1419 is 1420 Proc_Id : constant Entity_Id := DIC_Procedure (Typ); 1421 Formal_Typ : constant Entity_Id := Etype (First_Formal (Proc_Id)); 1422 1423 begin 1424 return 1425 Make_Procedure_Call_Statement (Loc, 1426 Name => New_Occurrence_Of (Proc_Id, Loc), 1427 Parameter_Associations => New_List ( 1428 Make_Unchecked_Type_Conversion (Loc, 1429 Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc), 1430 Expression => New_Occurrence_Of (Obj_Id, Loc)))); 1431 end Build_DIC_Call; 1432 1433 ------------------------------ 1434 -- Build_DIC_Procedure_Body -- 1435 ------------------------------ 1436 1437 -- WARNING: This routine manages Ghost regions. Return statements must be 1438 -- replaced by gotos which jump to the end of the routine and restore the 1439 -- Ghost mode. 1440 1441 procedure Build_DIC_Procedure_Body 1442 (Typ : Entity_Id; 1443 For_Freeze : Boolean := False) 1444 is 1445 procedure Add_DIC_Check 1446 (DIC_Prag : Node_Id; 1447 DIC_Expr : Node_Id; 1448 Stmts : in out List_Id); 1449 -- Subsidiary to all Add_xxx_DIC routines. Add a runtime check to verify 1450 -- assertion expression DIC_Expr of pragma DIC_Prag. All generated code 1451 -- is added to list Stmts. 1452 1453 procedure Add_Inherited_DIC 1454 (DIC_Prag : Node_Id; 1455 Par_Typ : Entity_Id; 1456 Deriv_Typ : Entity_Id; 1457 Stmts : in out List_Id); 1458 -- Add a runtime check to verify the assertion expression of inherited 1459 -- pragma DIC_Prag. Par_Typ is parent type, which is also the owner of 1460 -- the DIC pragma. Deriv_Typ is the derived type inheriting the DIC 1461 -- pragma. All generated code is added to list Stmts. 1462 1463 procedure Add_Inherited_Tagged_DIC 1464 (DIC_Prag : Node_Id; 1465 Par_Typ : Entity_Id; 1466 Deriv_Typ : Entity_Id; 1467 Stmts : in out List_Id); 1468 -- Add a runtime check to verify assertion expression DIC_Expr of 1469 -- inherited pragma DIC_Prag. This routine applies class-wide pre- and 1470 -- postcondition-like runtime semantics to the check. Par_Typ is the 1471 -- parent type whose DIC pragma is being inherited. Deriv_Typ is the 1472 -- derived type inheriting the DIC pragma. All generated code is added 1473 -- to list Stmts. 1474 1475 procedure Add_Own_DIC 1476 (DIC_Prag : Node_Id; 1477 DIC_Typ : Entity_Id; 1478 Stmts : in out List_Id); 1479 -- Add a runtime check to verify the assertion expression of pragma 1480 -- DIC_Prag. DIC_Typ is the owner of the DIC pragma. All generated code 1481 -- is added to list Stmts. 1482 1483 ------------------- 1484 -- Add_DIC_Check -- 1485 ------------------- 1486 1487 procedure Add_DIC_Check 1488 (DIC_Prag : Node_Id; 1489 DIC_Expr : Node_Id; 1490 Stmts : in out List_Id) 1491 is 1492 Loc : constant Source_Ptr := Sloc (DIC_Prag); 1493 Nam : constant Name_Id := Original_Aspect_Pragma_Name (DIC_Prag); 1494 1495 begin 1496 -- The DIC pragma is ignored, nothing left to do 1497 1498 if Is_Ignored (DIC_Prag) then 1499 null; 1500 1501 -- Otherwise the DIC expression must be checked at run time. 1502 -- Generate: 1503 1504 -- pragma Check (<Nam>, <DIC_Expr>); 1505 1506 else 1507 Append_New_To (Stmts, 1508 Make_Pragma (Loc, 1509 Pragma_Identifier => 1510 Make_Identifier (Loc, Name_Check), 1511 1512 Pragma_Argument_Associations => New_List ( 1513 Make_Pragma_Argument_Association (Loc, 1514 Expression => Make_Identifier (Loc, Nam)), 1515 1516 Make_Pragma_Argument_Association (Loc, 1517 Expression => DIC_Expr)))); 1518 end if; 1519 end Add_DIC_Check; 1520 1521 ----------------------- 1522 -- Add_Inherited_DIC -- 1523 ----------------------- 1524 1525 procedure Add_Inherited_DIC 1526 (DIC_Prag : Node_Id; 1527 Par_Typ : Entity_Id; 1528 Deriv_Typ : Entity_Id; 1529 Stmts : in out List_Id) 1530 is 1531 Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ); 1532 Deriv_Obj : constant Entity_Id := First_Entity (Deriv_Proc); 1533 Par_Proc : constant Entity_Id := DIC_Procedure (Par_Typ); 1534 Par_Obj : constant Entity_Id := First_Entity (Par_Proc); 1535 Loc : constant Source_Ptr := Sloc (DIC_Prag); 1536 1537 begin 1538 pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc)); 1539 1540 -- Verify the inherited DIC assertion expression by calling the DIC 1541 -- procedure of the parent type. 1542 1543 -- Generate: 1544 -- <Par_Typ>DIC (Par_Typ (_object)); 1545 1546 Append_New_To (Stmts, 1547 Make_Procedure_Call_Statement (Loc, 1548 Name => New_Occurrence_Of (Par_Proc, Loc), 1549 Parameter_Associations => New_List ( 1550 Convert_To 1551 (Typ => Etype (Par_Obj), 1552 Expr => New_Occurrence_Of (Deriv_Obj, Loc))))); 1553 end Add_Inherited_DIC; 1554 1555 ------------------------------ 1556 -- Add_Inherited_Tagged_DIC -- 1557 ------------------------------ 1558 1559 procedure Add_Inherited_Tagged_DIC 1560 (DIC_Prag : Node_Id; 1561 Par_Typ : Entity_Id; 1562 Deriv_Typ : Entity_Id; 1563 Stmts : in out List_Id) 1564 is 1565 Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ); 1566 DIC_Args : constant List_Id := 1567 Pragma_Argument_Associations (DIC_Prag); 1568 DIC_Arg : constant Node_Id := First (DIC_Args); 1569 DIC_Expr : constant Node_Id := Expression_Copy (DIC_Arg); 1570 Par_Proc : constant Entity_Id := DIC_Procedure (Par_Typ); 1571 1572 Expr : Node_Id; 1573 1574 begin 1575 -- The processing of an inherited DIC assertion expression starts off 1576 -- with a copy of the original parent expression where all references 1577 -- to the parent type have already been replaced with references to 1578 -- the _object formal parameter of the parent type's DIC procedure. 1579 1580 pragma Assert (Present (DIC_Expr)); 1581 Expr := New_Copy_Tree (DIC_Expr); 1582 1583 -- Perform the following substitutions: 1584 1585 -- * Replace a reference to the _object parameter of the parent 1586 -- type's DIC procedure with a reference to the _object parameter 1587 -- of the derived types' DIC procedure. 1588 1589 -- * Replace a reference to a discriminant of the parent type with 1590 -- a suitable value from the point of view of the derived type. 1591 1592 -- * Replace a call to an overridden parent primitive with a call 1593 -- to the overriding derived type primitive. 1594 1595 -- * Replace a call to an inherited parent primitive with a call to 1596 -- the internally-generated inherited derived type primitive. 1597 1598 -- Note that primitives defined in the private part are automatically 1599 -- handled by the overriding/inheritance mechanism and do not require 1600 -- an extra replacement pass. 1601 1602 pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc)); 1603 1604 Replace_References 1605 (Expr => Expr, 1606 Par_Typ => Par_Typ, 1607 Deriv_Typ => Deriv_Typ, 1608 Par_Obj => First_Formal (Par_Proc), 1609 Deriv_Obj => First_Formal (Deriv_Proc)); 1610 1611 -- Once the DIC assertion expression is fully processed, add a check 1612 -- to the statements of the DIC procedure. 1613 1614 Add_DIC_Check 1615 (DIC_Prag => DIC_Prag, 1616 DIC_Expr => Expr, 1617 Stmts => Stmts); 1618 end Add_Inherited_Tagged_DIC; 1619 1620 ----------------- 1621 -- Add_Own_DIC -- 1622 ----------------- 1623 1624 procedure Add_Own_DIC 1625 (DIC_Prag : Node_Id; 1626 DIC_Typ : Entity_Id; 1627 Stmts : in out List_Id) 1628 is 1629 DIC_Args : constant List_Id := 1630 Pragma_Argument_Associations (DIC_Prag); 1631 DIC_Arg : constant Node_Id := First (DIC_Args); 1632 DIC_Asp : constant Node_Id := Corresponding_Aspect (DIC_Prag); 1633 DIC_Expr : constant Node_Id := Get_Pragma_Arg (DIC_Arg); 1634 DIC_Proc : constant Entity_Id := DIC_Procedure (DIC_Typ); 1635 Obj_Id : constant Entity_Id := First_Formal (DIC_Proc); 1636 1637 procedure Preanalyze_Own_DIC_For_ASIS; 1638 -- Preanalyze the original DIC expression of an aspect or a source 1639 -- pragma for ASIS. 1640 1641 --------------------------------- 1642 -- Preanalyze_Own_DIC_For_ASIS -- 1643 --------------------------------- 1644 1645 procedure Preanalyze_Own_DIC_For_ASIS is 1646 Expr : Node_Id := Empty; 1647 1648 begin 1649 -- The DIC pragma is a source construct, preanalyze the original 1650 -- expression of the pragma. 1651 1652 if Comes_From_Source (DIC_Prag) then 1653 Expr := DIC_Expr; 1654 1655 -- Otherwise preanalyze the expression of the corresponding aspect 1656 1657 elsif Present (DIC_Asp) then 1658 Expr := Expression (DIC_Asp); 1659 end if; 1660 1661 -- The expression must be subjected to the same substitutions as 1662 -- the copy used in the generation of the runtime check. 1663 1664 if Present (Expr) then 1665 Replace_Type_References 1666 (Expr => Expr, 1667 Typ => DIC_Typ, 1668 Obj_Id => Obj_Id); 1669 1670 Preanalyze_Assert_Expression (Expr, Any_Boolean); 1671 end if; 1672 end Preanalyze_Own_DIC_For_ASIS; 1673 1674 -- Local variables 1675 1676 Typ_Decl : constant Node_Id := Declaration_Node (DIC_Typ); 1677 1678 Expr : Node_Id; 1679 1680 -- Start of processing for Add_Own_DIC 1681 1682 begin 1683 pragma Assert (Present (DIC_Expr)); 1684 Expr := New_Copy_Tree (DIC_Expr); 1685 1686 -- Perform the following substitution: 1687 1688 -- * Replace the current instance of DIC_Typ with a reference to 1689 -- the _object formal parameter of the DIC procedure. 1690 1691 Replace_Type_References 1692 (Expr => Expr, 1693 Typ => DIC_Typ, 1694 Obj_Id => Obj_Id); 1695 1696 -- Preanalyze the DIC expression to detect errors and at the same 1697 -- time capture the visibility of the proper package part. 1698 1699 Set_Parent (Expr, Typ_Decl); 1700 Preanalyze_Assert_Expression (Expr, Any_Boolean); 1701 1702 -- Save a copy of the expression with all replacements and analysis 1703 -- already taken place in case a derived type inherits the pragma. 1704 -- The copy will be used as the foundation of the derived type's own 1705 -- version of the DIC assertion expression. 1706 1707 if Is_Tagged_Type (DIC_Typ) then 1708 Set_Expression_Copy (DIC_Arg, New_Copy_Tree (Expr)); 1709 end if; 1710 1711 -- If the pragma comes from an aspect specification, replace the 1712 -- saved expression because all type references must be substituted 1713 -- for the call to Preanalyze_Spec_Expression in Check_Aspect_At_xxx 1714 -- routines. 1715 1716 if Present (DIC_Asp) then 1717 Set_Entity (Identifier (DIC_Asp), New_Copy_Tree (Expr)); 1718 end if; 1719 1720 -- Preanalyze the original DIC expression for ASIS 1721 1722 if ASIS_Mode then 1723 Preanalyze_Own_DIC_For_ASIS; 1724 end if; 1725 1726 -- Once the DIC assertion expression is fully processed, add a check 1727 -- to the statements of the DIC procedure. 1728 1729 Add_DIC_Check 1730 (DIC_Prag => DIC_Prag, 1731 DIC_Expr => Expr, 1732 Stmts => Stmts); 1733 end Add_Own_DIC; 1734 1735 -- Local variables 1736 1737 Loc : constant Source_Ptr := Sloc (Typ); 1738 1739 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 1740 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 1741 -- Save the Ghost-related attributes to restore on exit 1742 1743 DIC_Prag : Node_Id; 1744 DIC_Typ : Entity_Id; 1745 Dummy_1 : Entity_Id; 1746 Dummy_2 : Entity_Id; 1747 Proc_Body : Node_Id; 1748 Proc_Body_Id : Entity_Id; 1749 Proc_Decl : Node_Id; 1750 Proc_Id : Entity_Id; 1751 Stmts : List_Id := No_List; 1752 1753 Build_Body : Boolean := False; 1754 -- Flag set when the type requires a DIC procedure body to be built 1755 1756 Work_Typ : Entity_Id; 1757 -- The working type 1758 1759 -- Start of processing for Build_DIC_Procedure_Body 1760 1761 begin 1762 Work_Typ := Base_Type (Typ); 1763 1764 -- Do not process class-wide types as these are Itypes, but lack a first 1765 -- subtype (see below). 1766 1767 if Is_Class_Wide_Type (Work_Typ) then 1768 return; 1769 1770 -- Do not process the underlying full view of a private type. There is 1771 -- no way to get back to the partial view, plus the body will be built 1772 -- by the full view or the base type. 1773 1774 elsif Is_Underlying_Full_View (Work_Typ) then 1775 return; 1776 1777 -- Use the first subtype when dealing with various base types 1778 1779 elsif Is_Itype (Work_Typ) then 1780 Work_Typ := First_Subtype (Work_Typ); 1781 1782 -- The input denotes the corresponding record type of a protected or a 1783 -- task type. Work with the concurrent type because the corresponding 1784 -- record type may not be visible to clients of the type. 1785 1786 elsif Ekind (Work_Typ) = E_Record_Type 1787 and then Is_Concurrent_Record_Type (Work_Typ) 1788 then 1789 Work_Typ := Corresponding_Concurrent_Type (Work_Typ); 1790 end if; 1791 1792 -- The working type may be subject to pragma Ghost. Set the mode now to 1793 -- ensure that the DIC procedure is properly marked as Ghost. 1794 1795 Set_Ghost_Mode (Work_Typ); 1796 1797 -- The working type must be either define a DIC pragma of its own or 1798 -- inherit one from a parent type. 1799 1800 pragma Assert (Has_DIC (Work_Typ)); 1801 1802 -- Recover the type which defines the DIC pragma. This is either the 1803 -- working type itself or a parent type when the pragma is inherited. 1804 1805 DIC_Typ := Find_DIC_Type (Work_Typ); 1806 pragma Assert (Present (DIC_Typ)); 1807 1808 DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition); 1809 pragma Assert (Present (DIC_Prag)); 1810 1811 -- Nothing to do if pragma DIC appears without an argument or its sole 1812 -- argument is "null". 1813 1814 if not Is_Verifiable_DIC_Pragma (DIC_Prag) then 1815 goto Leave; 1816 end if; 1817 1818 -- The working type may lack a DIC procedure declaration. This may be 1819 -- due to several reasons: 1820 1821 -- * The working type's own DIC pragma does not contain a verifiable 1822 -- assertion expression. In this case there is no need to build a 1823 -- DIC procedure because there is nothing to check. 1824 1825 -- * The working type derives from a parent type. In this case a DIC 1826 -- procedure should be built only when the inherited DIC pragma has 1827 -- a verifiable assertion expression. 1828 1829 Proc_Id := DIC_Procedure (Work_Typ); 1830 1831 -- Build a DIC procedure declaration when the working type derives from 1832 -- a parent type. 1833 1834 if No (Proc_Id) then 1835 Build_DIC_Procedure_Declaration (Work_Typ); 1836 Proc_Id := DIC_Procedure (Work_Typ); 1837 end if; 1838 1839 -- At this point there should be a DIC procedure declaration 1840 1841 pragma Assert (Present (Proc_Id)); 1842 Proc_Decl := Unit_Declaration_Node (Proc_Id); 1843 1844 -- Nothing to do if the DIC procedure already has a body 1845 1846 if Present (Corresponding_Body (Proc_Decl)) then 1847 goto Leave; 1848 end if; 1849 1850 -- Emulate the environment of the DIC procedure by installing its scope 1851 -- and formal parameters. 1852 1853 Push_Scope (Proc_Id); 1854 Install_Formals (Proc_Id); 1855 1856 -- The working type defines its own DIC pragma. Replace the current 1857 -- instance of the working type with the formal of the DIC procedure. 1858 -- Note that there is no need to consider inherited DIC pragmas from 1859 -- parent types because the working type's DIC pragma "hides" all 1860 -- inherited DIC pragmas. 1861 1862 if Has_Own_DIC (Work_Typ) then 1863 pragma Assert (DIC_Typ = Work_Typ); 1864 1865 Add_Own_DIC 1866 (DIC_Prag => DIC_Prag, 1867 DIC_Typ => DIC_Typ, 1868 Stmts => Stmts); 1869 1870 Build_Body := True; 1871 1872 -- Otherwise the working type inherits a DIC pragma from a parent type. 1873 -- This processing is carried out when the type is frozen because the 1874 -- state of all parent discriminants is known at that point. Note that 1875 -- it is semantically sound to delay the creation of the DIC procedure 1876 -- body till the freeze point. If the type has a DIC pragma of its own, 1877 -- then the DIC procedure body would have already been constructed at 1878 -- the end of the visible declarations and all parent DIC pragmas are 1879 -- effectively "hidden" and irrelevant. 1880 1881 elsif For_Freeze then 1882 pragma Assert (Has_Inherited_DIC (Work_Typ)); 1883 pragma Assert (DIC_Typ /= Work_Typ); 1884 1885 -- The working type is tagged. The verification of the assertion 1886 -- expression is subject to the same semantics as class-wide pre- 1887 -- and postconditions. 1888 1889 if Is_Tagged_Type (Work_Typ) then 1890 Add_Inherited_Tagged_DIC 1891 (DIC_Prag => DIC_Prag, 1892 Par_Typ => DIC_Typ, 1893 Deriv_Typ => Work_Typ, 1894 Stmts => Stmts); 1895 1896 -- Otherwise the working type is not tagged. Verify the assertion 1897 -- expression of the inherited DIC pragma by directly calling the 1898 -- DIC procedure of the parent type. 1899 1900 else 1901 Add_Inherited_DIC 1902 (DIC_Prag => DIC_Prag, 1903 Par_Typ => DIC_Typ, 1904 Deriv_Typ => Work_Typ, 1905 Stmts => Stmts); 1906 end if; 1907 1908 Build_Body := True; 1909 end if; 1910 1911 End_Scope; 1912 1913 if Build_Body then 1914 1915 -- Produce an empty completing body in the following cases: 1916 -- * Assertions are disabled 1917 -- * The DIC Assertion_Policy is Ignore 1918 1919 if No (Stmts) then 1920 Stmts := New_List (Make_Null_Statement (Loc)); 1921 end if; 1922 1923 -- Generate: 1924 -- procedure <Work_Typ>DIC (_object : <Work_Typ>) is 1925 -- begin 1926 -- <Stmts> 1927 -- end <Work_Typ>DIC; 1928 1929 Proc_Body := 1930 Make_Subprogram_Body (Loc, 1931 Specification => 1932 Copy_Subprogram_Spec (Parent (Proc_Id)), 1933 Declarations => Empty_List, 1934 Handled_Statement_Sequence => 1935 Make_Handled_Sequence_Of_Statements (Loc, 1936 Statements => Stmts)); 1937 Proc_Body_Id := Defining_Entity (Proc_Body); 1938 1939 -- Perform minor decoration in case the body is not analyzed 1940 1941 Set_Ekind (Proc_Body_Id, E_Subprogram_Body); 1942 Set_Etype (Proc_Body_Id, Standard_Void_Type); 1943 Set_Scope (Proc_Body_Id, Current_Scope); 1944 Set_SPARK_Pragma (Proc_Body_Id, SPARK_Pragma (Proc_Id)); 1945 Set_SPARK_Pragma_Inherited 1946 (Proc_Body_Id, SPARK_Pragma_Inherited (Proc_Id)); 1947 1948 -- Link both spec and body to avoid generating duplicates 1949 1950 Set_Corresponding_Body (Proc_Decl, Proc_Body_Id); 1951 Set_Corresponding_Spec (Proc_Body, Proc_Id); 1952 1953 -- The body should not be inserted into the tree when the context 1954 -- is ASIS or a generic unit because it is not part of the template. 1955 -- Note that the body must still be generated in order to resolve the 1956 -- DIC assertion expression. 1957 1958 if ASIS_Mode or Inside_A_Generic then 1959 null; 1960 1961 -- Semi-insert the body into the tree for GNATprove by setting its 1962 -- Parent field. This allows for proper upstream tree traversals. 1963 1964 elsif GNATprove_Mode then 1965 Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ))); 1966 1967 -- Otherwise the body is part of the freezing actions of the working 1968 -- type. 1969 1970 else 1971 Append_Freeze_Action (Work_Typ, Proc_Body); 1972 end if; 1973 end if; 1974 1975 <<Leave>> 1976 Restore_Ghost_Region (Saved_GM, Saved_IGR); 1977 end Build_DIC_Procedure_Body; 1978 1979 ------------------------------------- 1980 -- Build_DIC_Procedure_Declaration -- 1981 ------------------------------------- 1982 1983 -- WARNING: This routine manages Ghost regions. Return statements must be 1984 -- replaced by gotos which jump to the end of the routine and restore the 1985 -- Ghost mode. 1986 1987 procedure Build_DIC_Procedure_Declaration (Typ : Entity_Id) is 1988 Loc : constant Source_Ptr := Sloc (Typ); 1989 1990 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 1991 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 1992 -- Save the Ghost-related attributes to restore on exit 1993 1994 DIC_Prag : Node_Id; 1995 DIC_Typ : Entity_Id; 1996 Proc_Decl : Node_Id; 1997 Proc_Id : Entity_Id; 1998 Typ_Decl : Node_Id; 1999 2000 CRec_Typ : Entity_Id; 2001 -- The corresponding record type of Full_Typ 2002 2003 Full_Base : Entity_Id; 2004 -- The base type of Full_Typ 2005 2006 Full_Typ : Entity_Id; 2007 -- The full view of working type 2008 2009 Obj_Id : Entity_Id; 2010 -- The _object formal parameter of the DIC procedure 2011 2012 Priv_Typ : Entity_Id; 2013 -- The partial view of working type 2014 2015 Work_Typ : Entity_Id; 2016 -- The working type 2017 2018 begin 2019 Work_Typ := Base_Type (Typ); 2020 2021 -- Do not process class-wide types as these are Itypes, but lack a first 2022 -- subtype (see below). 2023 2024 if Is_Class_Wide_Type (Work_Typ) then 2025 return; 2026 2027 -- Do not process the underlying full view of a private type. There is 2028 -- no way to get back to the partial view, plus the body will be built 2029 -- by the full view or the base type. 2030 2031 elsif Is_Underlying_Full_View (Work_Typ) then 2032 return; 2033 2034 -- Use the first subtype when dealing with various base types 2035 2036 elsif Is_Itype (Work_Typ) then 2037 Work_Typ := First_Subtype (Work_Typ); 2038 2039 -- The input denotes the corresponding record type of a protected or a 2040 -- task type. Work with the concurrent type because the corresponding 2041 -- record type may not be visible to clients of the type. 2042 2043 elsif Ekind (Work_Typ) = E_Record_Type 2044 and then Is_Concurrent_Record_Type (Work_Typ) 2045 then 2046 Work_Typ := Corresponding_Concurrent_Type (Work_Typ); 2047 end if; 2048 2049 -- The working type may be subject to pragma Ghost. Set the mode now to 2050 -- ensure that the DIC procedure is properly marked as Ghost. 2051 2052 Set_Ghost_Mode (Work_Typ); 2053 2054 -- The type must be either subject to a DIC pragma or inherit one from a 2055 -- parent type. 2056 2057 pragma Assert (Has_DIC (Work_Typ)); 2058 2059 -- Recover the type which defines the DIC pragma. This is either the 2060 -- working type itself or a parent type when the pragma is inherited. 2061 2062 DIC_Typ := Find_DIC_Type (Work_Typ); 2063 pragma Assert (Present (DIC_Typ)); 2064 2065 DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition); 2066 pragma Assert (Present (DIC_Prag)); 2067 2068 -- Nothing to do if pragma DIC appears without an argument or its sole 2069 -- argument is "null". 2070 2071 if not Is_Verifiable_DIC_Pragma (DIC_Prag) then 2072 goto Leave; 2073 2074 -- Nothing to do if the type already has a DIC procedure 2075 2076 elsif Present (DIC_Procedure (Work_Typ)) then 2077 goto Leave; 2078 end if; 2079 2080 Proc_Id := 2081 Make_Defining_Identifier (Loc, 2082 Chars => 2083 New_External_Name (Chars (Work_Typ), "Default_Initial_Condition")); 2084 2085 -- Perform minor decoration in case the declaration is not analyzed 2086 2087 Set_Ekind (Proc_Id, E_Procedure); 2088 Set_Etype (Proc_Id, Standard_Void_Type); 2089 Set_Is_DIC_Procedure (Proc_Id); 2090 Set_Scope (Proc_Id, Current_Scope); 2091 Set_SPARK_Pragma (Proc_Id, SPARK_Mode_Pragma); 2092 Set_SPARK_Pragma_Inherited (Proc_Id); 2093 2094 Set_DIC_Procedure (Work_Typ, Proc_Id); 2095 2096 -- The DIC procedure requires debug info when the assertion expression 2097 -- is subject to Source Coverage Obligations. 2098 2099 if Generate_SCO then 2100 Set_Debug_Info_Needed (Proc_Id); 2101 end if; 2102 2103 -- Obtain all views of the input type 2104 2105 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ); 2106 2107 -- Associate the DIC procedure and various relevant flags with all views 2108 2109 Propagate_DIC_Attributes (Priv_Typ, From_Typ => Work_Typ); 2110 Propagate_DIC_Attributes (Full_Typ, From_Typ => Work_Typ); 2111 Propagate_DIC_Attributes (Full_Base, From_Typ => Work_Typ); 2112 Propagate_DIC_Attributes (CRec_Typ, From_Typ => Work_Typ); 2113 2114 -- The declaration of the DIC procedure must be inserted after the 2115 -- declaration of the partial view as this allows for proper external 2116 -- visibility. 2117 2118 if Present (Priv_Typ) then 2119 Typ_Decl := Declaration_Node (Priv_Typ); 2120 2121 -- Derived types with the full view as parent do not have a partial 2122 -- view. Insert the DIC procedure after the derived type. 2123 2124 else 2125 Typ_Decl := Declaration_Node (Full_Typ); 2126 end if; 2127 2128 -- The type should have a declarative node 2129 2130 pragma Assert (Present (Typ_Decl)); 2131 2132 -- Create the formal parameter which emulates the variable-like behavior 2133 -- of the type's current instance. 2134 2135 Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject); 2136 2137 -- Perform minor decoration in case the declaration is not analyzed 2138 2139 Set_Ekind (Obj_Id, E_In_Parameter); 2140 Set_Etype (Obj_Id, Work_Typ); 2141 Set_Scope (Obj_Id, Proc_Id); 2142 2143 Set_First_Entity (Proc_Id, Obj_Id); 2144 Set_Last_Entity (Proc_Id, Obj_Id); 2145 2146 -- Generate: 2147 -- procedure <Work_Typ>DIC (_object : <Work_Typ>); 2148 2149 Proc_Decl := 2150 Make_Subprogram_Declaration (Loc, 2151 Specification => 2152 Make_Procedure_Specification (Loc, 2153 Defining_Unit_Name => Proc_Id, 2154 Parameter_Specifications => New_List ( 2155 Make_Parameter_Specification (Loc, 2156 Defining_Identifier => Obj_Id, 2157 Parameter_Type => 2158 New_Occurrence_Of (Work_Typ, Loc))))); 2159 2160 -- The declaration should not be inserted into the tree when the context 2161 -- is ASIS or a generic unit because it is not part of the template. 2162 2163 if ASIS_Mode or Inside_A_Generic then 2164 null; 2165 2166 -- Semi-insert the declaration into the tree for GNATprove by setting 2167 -- its Parent field. This allows for proper upstream tree traversals. 2168 2169 elsif GNATprove_Mode then 2170 Set_Parent (Proc_Decl, Parent (Typ_Decl)); 2171 2172 -- Otherwise insert the declaration 2173 2174 else 2175 Insert_After_And_Analyze (Typ_Decl, Proc_Decl); 2176 end if; 2177 2178 <<Leave>> 2179 Restore_Ghost_Region (Saved_GM, Saved_IGR); 2180 end Build_DIC_Procedure_Declaration; 2181 2182 ------------------------------------ 2183 -- Build_Invariant_Procedure_Body -- 2184 ------------------------------------ 2185 2186 -- WARNING: This routine manages Ghost regions. Return statements must be 2187 -- replaced by gotos which jump to the end of the routine and restore the 2188 -- Ghost mode. 2189 2190 procedure Build_Invariant_Procedure_Body 2191 (Typ : Entity_Id; 2192 Partial_Invariant : Boolean := False) 2193 is 2194 Loc : constant Source_Ptr := Sloc (Typ); 2195 2196 Pragmas_Seen : Elist_Id := No_Elist; 2197 -- This list contains all invariant pragmas processed so far. The list 2198 -- is used to avoid generating redundant invariant checks. 2199 2200 Produced_Check : Boolean := False; 2201 -- This flag tracks whether the type has produced at least one invariant 2202 -- check. The flag is used as a sanity check at the end of the routine. 2203 2204 -- NOTE: most of the routines in Build_Invariant_Procedure_Body are 2205 -- intentionally unnested to avoid deep indentation of code. 2206 2207 -- NOTE: all Add_xxx_Invariants routines are reactive. In other words 2208 -- they emit checks, loops (for arrays) and case statements (for record 2209 -- variant parts) only when there are invariants to verify. This keeps 2210 -- the body of the invariant procedure free of useless code. 2211 2212 procedure Add_Array_Component_Invariants 2213 (T : Entity_Id; 2214 Obj_Id : Entity_Id; 2215 Checks : in out List_Id); 2216 -- Generate an invariant check for each component of array type T. 2217 -- Obj_Id denotes the entity of the _object formal parameter of the 2218 -- invariant procedure. All created checks are added to list Checks. 2219 2220 procedure Add_Inherited_Invariants 2221 (T : Entity_Id; 2222 Priv_Typ : Entity_Id; 2223 Full_Typ : Entity_Id; 2224 Obj_Id : Entity_Id; 2225 Checks : in out List_Id); 2226 -- Generate an invariant check for each inherited class-wide invariant 2227 -- coming from all parent types of type T. Priv_Typ and Full_Typ denote 2228 -- the partial and full view of the parent type. Obj_Id denotes the 2229 -- entity of the _object formal parameter of the invariant procedure. 2230 -- All created checks are added to list Checks. 2231 2232 procedure Add_Interface_Invariants 2233 (T : Entity_Id; 2234 Obj_Id : Entity_Id; 2235 Checks : in out List_Id); 2236 -- Generate an invariant check for each inherited class-wide invariant 2237 -- coming from all interfaces implemented by type T. Obj_Id denotes the 2238 -- entity of the _object formal parameter of the invariant procedure. 2239 -- All created checks are added to list Checks. 2240 2241 procedure Add_Invariant_Check 2242 (Prag : Node_Id; 2243 Expr : Node_Id; 2244 Checks : in out List_Id; 2245 Inherited : Boolean := False); 2246 -- Subsidiary to all Add_xxx_Invariant routines. Add a runtime check to 2247 -- verify assertion expression Expr of pragma Prag. All generated code 2248 -- is added to list Checks. Flag Inherited should be set when the pragma 2249 -- is inherited from a parent or interface type. 2250 2251 procedure Add_Own_Invariants 2252 (T : Entity_Id; 2253 Obj_Id : Entity_Id; 2254 Checks : in out List_Id; 2255 Priv_Item : Node_Id := Empty); 2256 -- Generate an invariant check for each invariant found for type T. 2257 -- Obj_Id denotes the entity of the _object formal parameter of the 2258 -- invariant procedure. All created checks are added to list Checks. 2259 -- Priv_Item denotes the first rep item of the private type. 2260 2261 procedure Add_Parent_Invariants 2262 (T : Entity_Id; 2263 Obj_Id : Entity_Id; 2264 Checks : in out List_Id); 2265 -- Generate an invariant check for each inherited class-wide invariant 2266 -- coming from all parent types of type T. Obj_Id denotes the entity of 2267 -- the _object formal parameter of the invariant procedure. All created 2268 -- checks are added to list Checks. 2269 2270 procedure Add_Record_Component_Invariants 2271 (T : Entity_Id; 2272 Obj_Id : Entity_Id; 2273 Checks : in out List_Id); 2274 -- Generate an invariant check for each component of record type T. 2275 -- Obj_Id denotes the entity of the _object formal parameter of the 2276 -- invariant procedure. All created checks are added to list Checks. 2277 2278 ------------------------------------ 2279 -- Add_Array_Component_Invariants -- 2280 ------------------------------------ 2281 2282 procedure Add_Array_Component_Invariants 2283 (T : Entity_Id; 2284 Obj_Id : Entity_Id; 2285 Checks : in out List_Id) 2286 is 2287 Comp_Typ : constant Entity_Id := Component_Type (T); 2288 Dims : constant Pos := Number_Dimensions (T); 2289 2290 procedure Process_Array_Component 2291 (Indices : List_Id; 2292 Comp_Checks : in out List_Id); 2293 -- Generate an invariant check for an array component identified by 2294 -- the indices in list Indices. All created checks are added to list 2295 -- Comp_Checks. 2296 2297 procedure Process_One_Dimension 2298 (Dim : Pos; 2299 Indices : List_Id; 2300 Dim_Checks : in out List_Id); 2301 -- Generate a loop over the Nth dimension Dim of an array type. List 2302 -- Indices contains all array indices for the dimension. All created 2303 -- checks are added to list Dim_Checks. 2304 2305 ----------------------------- 2306 -- Process_Array_Component -- 2307 ----------------------------- 2308 2309 procedure Process_Array_Component 2310 (Indices : List_Id; 2311 Comp_Checks : in out List_Id) 2312 is 2313 Proc_Id : Entity_Id; 2314 2315 begin 2316 if Has_Invariants (Comp_Typ) then 2317 2318 -- In GNATprove mode, the component invariants are checked by 2319 -- other means. They should not be added to the array type 2320 -- invariant procedure, so that the procedure can be used to 2321 -- check the array type invariants if any. 2322 2323 if GNATprove_Mode then 2324 null; 2325 2326 else 2327 Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ)); 2328 2329 -- The component type should have an invariant procedure 2330 -- if it has invariants of its own or inherits class-wide 2331 -- invariants from parent or interface types. 2332 2333 pragma Assert (Present (Proc_Id)); 2334 2335 -- Generate: 2336 -- <Comp_Typ>Invariant (_object (<Indices>)); 2337 2338 -- Note that the invariant procedure may have a null body if 2339 -- assertions are disabled or Assertion_Policy Ignore is in 2340 -- effect. 2341 2342 if not Has_Null_Body (Proc_Id) then 2343 Append_New_To (Comp_Checks, 2344 Make_Procedure_Call_Statement (Loc, 2345 Name => 2346 New_Occurrence_Of (Proc_Id, Loc), 2347 Parameter_Associations => New_List ( 2348 Make_Indexed_Component (Loc, 2349 Prefix => New_Occurrence_Of (Obj_Id, Loc), 2350 Expressions => New_Copy_List (Indices))))); 2351 end if; 2352 end if; 2353 2354 Produced_Check := True; 2355 end if; 2356 end Process_Array_Component; 2357 2358 --------------------------- 2359 -- Process_One_Dimension -- 2360 --------------------------- 2361 2362 procedure Process_One_Dimension 2363 (Dim : Pos; 2364 Indices : List_Id; 2365 Dim_Checks : in out List_Id) 2366 is 2367 Comp_Checks : List_Id := No_List; 2368 Index : Entity_Id; 2369 2370 begin 2371 -- Generate the invariant checks for the array component after all 2372 -- dimensions have produced their respective loops. 2373 2374 if Dim > Dims then 2375 Process_Array_Component 2376 (Indices => Indices, 2377 Comp_Checks => Dim_Checks); 2378 2379 -- Otherwise create a loop for the current dimension 2380 2381 else 2382 -- Create a new loop variable for each dimension 2383 2384 Index := 2385 Make_Defining_Identifier (Loc, 2386 Chars => New_External_Name ('I', Dim)); 2387 Append_To (Indices, New_Occurrence_Of (Index, Loc)); 2388 2389 Process_One_Dimension 2390 (Dim => Dim + 1, 2391 Indices => Indices, 2392 Dim_Checks => Comp_Checks); 2393 2394 -- Generate: 2395 -- for I<Dim> in _object'Range (<Dim>) loop 2396 -- <Comp_Checks> 2397 -- end loop; 2398 2399 -- Note that the invariant procedure may have a null body if 2400 -- assertions are disabled or Assertion_Policy Ignore is in 2401 -- effect. 2402 2403 if Present (Comp_Checks) then 2404 Append_New_To (Dim_Checks, 2405 Make_Implicit_Loop_Statement (T, 2406 Identifier => Empty, 2407 Iteration_Scheme => 2408 Make_Iteration_Scheme (Loc, 2409 Loop_Parameter_Specification => 2410 Make_Loop_Parameter_Specification (Loc, 2411 Defining_Identifier => Index, 2412 Discrete_Subtype_Definition => 2413 Make_Attribute_Reference (Loc, 2414 Prefix => 2415 New_Occurrence_Of (Obj_Id, Loc), 2416 Attribute_Name => Name_Range, 2417 Expressions => New_List ( 2418 Make_Integer_Literal (Loc, Dim))))), 2419 Statements => Comp_Checks)); 2420 end if; 2421 end if; 2422 end Process_One_Dimension; 2423 2424 -- Start of processing for Add_Array_Component_Invariants 2425 2426 begin 2427 Process_One_Dimension 2428 (Dim => 1, 2429 Indices => New_List, 2430 Dim_Checks => Checks); 2431 end Add_Array_Component_Invariants; 2432 2433 ------------------------------ 2434 -- Add_Inherited_Invariants -- 2435 ------------------------------ 2436 2437 procedure Add_Inherited_Invariants 2438 (T : Entity_Id; 2439 Priv_Typ : Entity_Id; 2440 Full_Typ : Entity_Id; 2441 Obj_Id : Entity_Id; 2442 Checks : in out List_Id) 2443 is 2444 Deriv_Typ : Entity_Id; 2445 Expr : Node_Id; 2446 Prag : Node_Id; 2447 Prag_Expr : Node_Id; 2448 Prag_Expr_Arg : Node_Id; 2449 Prag_Typ : Node_Id; 2450 Prag_Typ_Arg : Node_Id; 2451 2452 Par_Proc : Entity_Id; 2453 -- The "partial" invariant procedure of Par_Typ 2454 2455 Par_Typ : Entity_Id; 2456 -- The suitable view of the parent type used in the substitution of 2457 -- type attributes. 2458 2459 begin 2460 if not Present (Priv_Typ) and then not Present (Full_Typ) then 2461 return; 2462 end if; 2463 2464 -- When the type inheriting the class-wide invariant is a concurrent 2465 -- type, use the corresponding record type because it contains all 2466 -- primitive operations of the concurrent type and allows for proper 2467 -- substitution. 2468 2469 if Is_Concurrent_Type (T) then 2470 Deriv_Typ := Corresponding_Record_Type (T); 2471 else 2472 Deriv_Typ := T; 2473 end if; 2474 2475 pragma Assert (Present (Deriv_Typ)); 2476 2477 -- Determine which rep item chain to use. Precedence is given to that 2478 -- of the parent type's partial view since it usually carries all the 2479 -- class-wide invariants. 2480 2481 if Present (Priv_Typ) then 2482 Prag := First_Rep_Item (Priv_Typ); 2483 else 2484 Prag := First_Rep_Item (Full_Typ); 2485 end if; 2486 2487 while Present (Prag) loop 2488 if Nkind (Prag) = N_Pragma 2489 and then Pragma_Name (Prag) = Name_Invariant 2490 then 2491 -- Nothing to do if the pragma was already processed 2492 2493 if Contains (Pragmas_Seen, Prag) then 2494 return; 2495 2496 -- Nothing to do when the caller requests the processing of all 2497 -- inherited class-wide invariants, but the pragma does not 2498 -- fall in this category. 2499 2500 elsif not Class_Present (Prag) then 2501 return; 2502 end if; 2503 2504 -- Extract the arguments of the invariant pragma 2505 2506 Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag)); 2507 Prag_Expr_Arg := Next (Prag_Typ_Arg); 2508 Prag_Expr := Expression_Copy (Prag_Expr_Arg); 2509 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg); 2510 2511 -- The pragma applies to the partial view of the parent type 2512 2513 if Present (Priv_Typ) 2514 and then Entity (Prag_Typ) = Priv_Typ 2515 then 2516 Par_Typ := Priv_Typ; 2517 2518 -- The pragma applies to the full view of the parent type 2519 2520 elsif Present (Full_Typ) 2521 and then Entity (Prag_Typ) = Full_Typ 2522 then 2523 Par_Typ := Full_Typ; 2524 2525 -- Otherwise the pragma does not belong to the parent type and 2526 -- should not be considered. 2527 2528 else 2529 return; 2530 end if; 2531 2532 -- Perform the following substitutions: 2533 2534 -- * Replace a reference to the _object parameter of the 2535 -- parent type's partial invariant procedure with a 2536 -- reference to the _object parameter of the derived 2537 -- type's full invariant procedure. 2538 2539 -- * Replace a reference to a discriminant of the parent type 2540 -- with a suitable value from the point of view of the 2541 -- derived type. 2542 2543 -- * Replace a call to an overridden parent primitive with a 2544 -- call to the overriding derived type primitive. 2545 2546 -- * Replace a call to an inherited parent primitive with a 2547 -- call to the internally-generated inherited derived type 2548 -- primitive. 2549 2550 Expr := New_Copy_Tree (Prag_Expr); 2551 2552 -- The parent type must have a "partial" invariant procedure 2553 -- because class-wide invariants are captured exclusively by 2554 -- it. 2555 2556 Par_Proc := Partial_Invariant_Procedure (Par_Typ); 2557 pragma Assert (Present (Par_Proc)); 2558 2559 Replace_References 2560 (Expr => Expr, 2561 Par_Typ => Par_Typ, 2562 Deriv_Typ => Deriv_Typ, 2563 Par_Obj => First_Formal (Par_Proc), 2564 Deriv_Obj => Obj_Id); 2565 2566 Add_Invariant_Check (Prag, Expr, Checks, Inherited => True); 2567 end if; 2568 2569 Next_Rep_Item (Prag); 2570 end loop; 2571 end Add_Inherited_Invariants; 2572 2573 ------------------------------ 2574 -- Add_Interface_Invariants -- 2575 ------------------------------ 2576 2577 procedure Add_Interface_Invariants 2578 (T : Entity_Id; 2579 Obj_Id : Entity_Id; 2580 Checks : in out List_Id) 2581 is 2582 Iface_Elmt : Elmt_Id; 2583 Ifaces : Elist_Id; 2584 2585 begin 2586 -- Generate an invariant check for each class-wide invariant coming 2587 -- from all interfaces implemented by type T. 2588 2589 if Is_Tagged_Type (T) then 2590 Collect_Interfaces (T, Ifaces); 2591 2592 -- Process the class-wide invariants of all implemented interfaces 2593 2594 Iface_Elmt := First_Elmt (Ifaces); 2595 while Present (Iface_Elmt) loop 2596 2597 -- The Full_Typ parameter is intentionally left Empty because 2598 -- interfaces are treated as the partial view of a private type 2599 -- in order to achieve uniformity with the general case. 2600 2601 Add_Inherited_Invariants 2602 (T => T, 2603 Priv_Typ => Node (Iface_Elmt), 2604 Full_Typ => Empty, 2605 Obj_Id => Obj_Id, 2606 Checks => Checks); 2607 2608 Next_Elmt (Iface_Elmt); 2609 end loop; 2610 end if; 2611 end Add_Interface_Invariants; 2612 2613 ------------------------- 2614 -- Add_Invariant_Check -- 2615 ------------------------- 2616 2617 procedure Add_Invariant_Check 2618 (Prag : Node_Id; 2619 Expr : Node_Id; 2620 Checks : in out List_Id; 2621 Inherited : Boolean := False) 2622 is 2623 Args : constant List_Id := Pragma_Argument_Associations (Prag); 2624 Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag); 2625 Ploc : constant Source_Ptr := Sloc (Prag); 2626 Str_Arg : constant Node_Id := Next (Next (First (Args))); 2627 2628 Assoc : List_Id; 2629 Str : String_Id; 2630 2631 begin 2632 -- The invariant is ignored, nothing left to do 2633 2634 if Is_Ignored (Prag) then 2635 null; 2636 2637 -- Otherwise the invariant is checked. Build a pragma Check to verify 2638 -- the expression at run time. 2639 2640 else 2641 Assoc := New_List ( 2642 Make_Pragma_Argument_Association (Ploc, 2643 Expression => Make_Identifier (Ploc, Nam)), 2644 Make_Pragma_Argument_Association (Ploc, 2645 Expression => Expr)); 2646 2647 -- Handle the String argument (if any) 2648 2649 if Present (Str_Arg) then 2650 Str := Strval (Get_Pragma_Arg (Str_Arg)); 2651 2652 -- When inheriting an invariant, modify the message from 2653 -- "failed invariant" to "failed inherited invariant". 2654 2655 if Inherited then 2656 String_To_Name_Buffer (Str); 2657 2658 if Name_Buffer (1 .. 16) = "failed invariant" then 2659 Insert_Str_In_Name_Buffer ("inherited ", 8); 2660 Str := String_From_Name_Buffer; 2661 end if; 2662 end if; 2663 2664 Append_To (Assoc, 2665 Make_Pragma_Argument_Association (Ploc, 2666 Expression => Make_String_Literal (Ploc, Str))); 2667 end if; 2668 2669 -- Generate: 2670 -- pragma Check (<Nam>, <Expr>, <Str>); 2671 2672 Append_New_To (Checks, 2673 Make_Pragma (Ploc, 2674 Chars => Name_Check, 2675 Pragma_Argument_Associations => Assoc)); 2676 end if; 2677 2678 -- Output an info message when inheriting an invariant and the 2679 -- listing option is enabled. 2680 2681 if Inherited and Opt.List_Inherited_Aspects then 2682 Error_Msg_Sloc := Sloc (Prag); 2683 Error_Msg_N 2684 ("info: & inherits `Invariant''Class` aspect from #?L?", Typ); 2685 end if; 2686 2687 -- Add the pragma to the list of processed pragmas 2688 2689 Append_New_Elmt (Prag, Pragmas_Seen); 2690 Produced_Check := True; 2691 end Add_Invariant_Check; 2692 2693 --------------------------- 2694 -- Add_Parent_Invariants -- 2695 --------------------------- 2696 2697 procedure Add_Parent_Invariants 2698 (T : Entity_Id; 2699 Obj_Id : Entity_Id; 2700 Checks : in out List_Id) 2701 is 2702 Dummy_1 : Entity_Id; 2703 Dummy_2 : Entity_Id; 2704 2705 Curr_Typ : Entity_Id; 2706 -- The entity of the current type being examined 2707 2708 Full_Typ : Entity_Id; 2709 -- The full view of Par_Typ 2710 2711 Par_Typ : Entity_Id; 2712 -- The entity of the parent type 2713 2714 Priv_Typ : Entity_Id; 2715 -- The partial view of Par_Typ 2716 2717 begin 2718 -- Do not process array types because they cannot have true parent 2719 -- types. This also prevents the generation of a duplicate invariant 2720 -- check when the input type is an array base type because its Etype 2721 -- denotes the first subtype, both of which share the same component 2722 -- type. 2723 2724 if Is_Array_Type (T) then 2725 return; 2726 end if; 2727 2728 -- Climb the parent type chain 2729 2730 Curr_Typ := T; 2731 loop 2732 -- Do not consider subtypes as they inherit the invariants 2733 -- from their base types. 2734 2735 Par_Typ := Base_Type (Etype (Curr_Typ)); 2736 2737 -- Stop the climb once the root of the parent chain is 2738 -- reached. 2739 2740 exit when Curr_Typ = Par_Typ; 2741 2742 -- Process the class-wide invariants of the parent type 2743 2744 Get_Views (Par_Typ, Priv_Typ, Full_Typ, Dummy_1, Dummy_2); 2745 2746 -- Process the elements of an array type 2747 2748 if Is_Array_Type (Full_Typ) then 2749 Add_Array_Component_Invariants (Full_Typ, Obj_Id, Checks); 2750 2751 -- Process the components of a record type 2752 2753 elsif Ekind (Full_Typ) = E_Record_Type then 2754 Add_Record_Component_Invariants (Full_Typ, Obj_Id, Checks); 2755 end if; 2756 2757 Add_Inherited_Invariants 2758 (T => T, 2759 Priv_Typ => Priv_Typ, 2760 Full_Typ => Full_Typ, 2761 Obj_Id => Obj_Id, 2762 Checks => Checks); 2763 2764 Curr_Typ := Par_Typ; 2765 end loop; 2766 end Add_Parent_Invariants; 2767 2768 ------------------------ 2769 -- Add_Own_Invariants -- 2770 ------------------------ 2771 2772 procedure Add_Own_Invariants 2773 (T : Entity_Id; 2774 Obj_Id : Entity_Id; 2775 Checks : in out List_Id; 2776 Priv_Item : Node_Id := Empty) 2777 is 2778 ASIS_Expr : Node_Id; 2779 Expr : Node_Id; 2780 Prag : Node_Id; 2781 Prag_Asp : Node_Id; 2782 Prag_Expr : Node_Id; 2783 Prag_Expr_Arg : Node_Id; 2784 Prag_Typ : Node_Id; 2785 Prag_Typ_Arg : Node_Id; 2786 2787 begin 2788 if not Present (T) then 2789 return; 2790 end if; 2791 2792 Prag := First_Rep_Item (T); 2793 while Present (Prag) loop 2794 if Nkind (Prag) = N_Pragma 2795 and then Pragma_Name (Prag) = Name_Invariant 2796 then 2797 -- Stop the traversal of the rep item chain once a specific 2798 -- item is encountered. 2799 2800 if Present (Priv_Item) and then Prag = Priv_Item then 2801 exit; 2802 end if; 2803 2804 -- Nothing to do if the pragma was already processed 2805 2806 if Contains (Pragmas_Seen, Prag) then 2807 return; 2808 end if; 2809 2810 -- Extract the arguments of the invariant pragma 2811 2812 Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag)); 2813 Prag_Expr_Arg := Next (Prag_Typ_Arg); 2814 Prag_Expr := Get_Pragma_Arg (Prag_Expr_Arg); 2815 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg); 2816 Prag_Asp := Corresponding_Aspect (Prag); 2817 2818 -- Verify the pragma belongs to T, otherwise the pragma applies 2819 -- to a parent type in which case it will be processed later by 2820 -- Add_Parent_Invariants or Add_Interface_Invariants. 2821 2822 if Entity (Prag_Typ) /= T then 2823 return; 2824 end if; 2825 2826 Expr := New_Copy_Tree (Prag_Expr); 2827 2828 -- Substitute all references to type T with references to the 2829 -- _object formal parameter. 2830 2831 Replace_Type_References (Expr, T, Obj_Id); 2832 2833 -- Preanalyze the invariant expression to detect errors and at 2834 -- the same time capture the visibility of the proper package 2835 -- part. 2836 2837 Set_Parent (Expr, Parent (Prag_Expr)); 2838 Preanalyze_Assert_Expression (Expr, Any_Boolean); 2839 2840 -- Save a copy of the expression when T is tagged to detect 2841 -- errors and capture the visibility of the proper package part 2842 -- for the generation of inherited type invariants. 2843 2844 if Is_Tagged_Type (T) then 2845 Set_Expression_Copy (Prag_Expr_Arg, New_Copy_Tree (Expr)); 2846 end if; 2847 2848 -- If the pragma comes from an aspect specification, replace 2849 -- the saved expression because all type references must be 2850 -- substituted for the call to Preanalyze_Spec_Expression in 2851 -- Check_Aspect_At_xxx routines. 2852 2853 if Present (Prag_Asp) then 2854 Set_Entity (Identifier (Prag_Asp), New_Copy_Tree (Expr)); 2855 end if; 2856 2857 -- Analyze the original invariant expression for ASIS 2858 2859 if ASIS_Mode then 2860 ASIS_Expr := Empty; 2861 2862 if Comes_From_Source (Prag) then 2863 ASIS_Expr := Prag_Expr; 2864 elsif Present (Prag_Asp) then 2865 ASIS_Expr := Expression (Prag_Asp); 2866 end if; 2867 2868 if Present (ASIS_Expr) then 2869 Replace_Type_References (ASIS_Expr, T, Obj_Id); 2870 Preanalyze_Assert_Expression (ASIS_Expr, Any_Boolean); 2871 end if; 2872 end if; 2873 2874 Add_Invariant_Check (Prag, Expr, Checks); 2875 end if; 2876 2877 Next_Rep_Item (Prag); 2878 end loop; 2879 end Add_Own_Invariants; 2880 2881 ------------------------------------- 2882 -- Add_Record_Component_Invariants -- 2883 ------------------------------------- 2884 2885 procedure Add_Record_Component_Invariants 2886 (T : Entity_Id; 2887 Obj_Id : Entity_Id; 2888 Checks : in out List_Id) 2889 is 2890 procedure Process_Component_List 2891 (Comp_List : Node_Id; 2892 CL_Checks : in out List_Id); 2893 -- Generate invariant checks for all record components found in 2894 -- component list Comp_List, including variant parts. All created 2895 -- checks are added to list CL_Checks. 2896 2897 procedure Process_Record_Component 2898 (Comp_Id : Entity_Id; 2899 Comp_Checks : in out List_Id); 2900 -- Generate an invariant check for a record component identified by 2901 -- Comp_Id. All created checks are added to list Comp_Checks. 2902 2903 ---------------------------- 2904 -- Process_Component_List -- 2905 ---------------------------- 2906 2907 procedure Process_Component_List 2908 (Comp_List : Node_Id; 2909 CL_Checks : in out List_Id) 2910 is 2911 Comp : Node_Id; 2912 Var : Node_Id; 2913 Var_Alts : List_Id := No_List; 2914 Var_Checks : List_Id := No_List; 2915 Var_Stmts : List_Id; 2916 2917 Produced_Variant_Check : Boolean := False; 2918 -- This flag tracks whether the component has produced at least 2919 -- one invariant check. 2920 2921 begin 2922 -- Traverse the component items 2923 2924 Comp := First (Component_Items (Comp_List)); 2925 while Present (Comp) loop 2926 if Nkind (Comp) = N_Component_Declaration then 2927 2928 -- Generate the component invariant check 2929 2930 Process_Record_Component 2931 (Comp_Id => Defining_Entity (Comp), 2932 Comp_Checks => CL_Checks); 2933 end if; 2934 2935 Next (Comp); 2936 end loop; 2937 2938 -- Traverse the variant part 2939 2940 if Present (Variant_Part (Comp_List)) then 2941 Var := First (Variants (Variant_Part (Comp_List))); 2942 while Present (Var) loop 2943 Var_Checks := No_List; 2944 2945 -- Generate invariant checks for all components and variant 2946 -- parts that qualify. 2947 2948 Process_Component_List 2949 (Comp_List => Component_List (Var), 2950 CL_Checks => Var_Checks); 2951 2952 -- The components of the current variant produced at least 2953 -- one invariant check. 2954 2955 if Present (Var_Checks) then 2956 Var_Stmts := Var_Checks; 2957 Produced_Variant_Check := True; 2958 2959 -- Otherwise there are either no components with invariants, 2960 -- assertions are disabled, or Assertion_Policy Ignore is in 2961 -- effect. 2962 2963 else 2964 Var_Stmts := New_List (Make_Null_Statement (Loc)); 2965 end if; 2966 2967 Append_New_To (Var_Alts, 2968 Make_Case_Statement_Alternative (Loc, 2969 Discrete_Choices => 2970 New_Copy_List (Discrete_Choices (Var)), 2971 Statements => Var_Stmts)); 2972 2973 Next (Var); 2974 end loop; 2975 2976 -- Create a case statement which verifies the invariant checks 2977 -- of a particular component list depending on the discriminant 2978 -- values only when there is at least one real invariant check. 2979 2980 if Produced_Variant_Check then 2981 Append_New_To (CL_Checks, 2982 Make_Case_Statement (Loc, 2983 Expression => 2984 Make_Selected_Component (Loc, 2985 Prefix => New_Occurrence_Of (Obj_Id, Loc), 2986 Selector_Name => 2987 New_Occurrence_Of 2988 (Entity (Name (Variant_Part (Comp_List))), Loc)), 2989 Alternatives => Var_Alts)); 2990 end if; 2991 end if; 2992 end Process_Component_List; 2993 2994 ------------------------------ 2995 -- Process_Record_Component -- 2996 ------------------------------ 2997 2998 procedure Process_Record_Component 2999 (Comp_Id : Entity_Id; 3000 Comp_Checks : in out List_Id) 3001 is 3002 Comp_Typ : constant Entity_Id := Etype (Comp_Id); 3003 Proc_Id : Entity_Id; 3004 3005 Produced_Component_Check : Boolean := False; 3006 -- This flag tracks whether the component has produced at least 3007 -- one invariant check. 3008 3009 begin 3010 -- Nothing to do for internal component _parent. Note that it is 3011 -- not desirable to check whether the component comes from source 3012 -- because protected type components are relocated to an internal 3013 -- corresponding record, but still need processing. 3014 3015 if Chars (Comp_Id) = Name_uParent then 3016 return; 3017 end if; 3018 3019 -- Verify the invariant of the component. Note that an access 3020 -- type may have an invariant when it acts as the full view of a 3021 -- private type and the invariant appears on the partial view. In 3022 -- this case verify the access value itself. 3023 3024 if Has_Invariants (Comp_Typ) then 3025 3026 -- In GNATprove mode, the component invariants are checked by 3027 -- other means. They should not be added to the record type 3028 -- invariant procedure, so that the procedure can be used to 3029 -- check the record type invariants if any. 3030 3031 if GNATprove_Mode then 3032 null; 3033 3034 else 3035 Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ)); 3036 3037 -- The component type should have an invariant procedure 3038 -- if it has invariants of its own or inherits class-wide 3039 -- invariants from parent or interface types. 3040 3041 pragma Assert (Present (Proc_Id)); 3042 3043 -- Generate: 3044 -- <Comp_Typ>Invariant (T (_object).<Comp_Id>); 3045 3046 -- Note that the invariant procedure may have a null body if 3047 -- assertions are disabled or Assertion_Policy Ignore is in 3048 -- effect. 3049 3050 if not Has_Null_Body (Proc_Id) then 3051 Append_New_To (Comp_Checks, 3052 Make_Procedure_Call_Statement (Loc, 3053 Name => 3054 New_Occurrence_Of (Proc_Id, Loc), 3055 Parameter_Associations => New_List ( 3056 Make_Selected_Component (Loc, 3057 Prefix => 3058 Unchecked_Convert_To 3059 (T, New_Occurrence_Of (Obj_Id, Loc)), 3060 Selector_Name => 3061 New_Occurrence_Of (Comp_Id, Loc))))); 3062 end if; 3063 end if; 3064 3065 Produced_Check := True; 3066 Produced_Component_Check := True; 3067 end if; 3068 3069 if Produced_Component_Check and then Has_Unchecked_Union (T) then 3070 Error_Msg_NE 3071 ("invariants cannot be checked on components of " 3072 & "unchecked_union type &?", Comp_Id, T); 3073 end if; 3074 end Process_Record_Component; 3075 3076 -- Local variables 3077 3078 Comps : Node_Id; 3079 Def : Node_Id; 3080 3081 -- Start of processing for Add_Record_Component_Invariants 3082 3083 begin 3084 -- An untagged derived type inherits the components of its parent 3085 -- type. In order to avoid creating redundant invariant checks, do 3086 -- not process the components now. Instead wait until the ultimate 3087 -- parent of the untagged derivation chain is reached. 3088 3089 if not Is_Untagged_Derivation (T) then 3090 Def := Type_Definition (Parent (T)); 3091 3092 if Nkind (Def) = N_Derived_Type_Definition then 3093 Def := Record_Extension_Part (Def); 3094 end if; 3095 3096 pragma Assert (Nkind (Def) = N_Record_Definition); 3097 Comps := Component_List (Def); 3098 3099 if Present (Comps) then 3100 Process_Component_List 3101 (Comp_List => Comps, 3102 CL_Checks => Checks); 3103 end if; 3104 end if; 3105 end Add_Record_Component_Invariants; 3106 3107 -- Local variables 3108 3109 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 3110 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 3111 -- Save the Ghost-related attributes to restore on exit 3112 3113 Dummy : Entity_Id; 3114 Priv_Item : Node_Id; 3115 Proc_Body : Node_Id; 3116 Proc_Body_Id : Entity_Id; 3117 Proc_Decl : Node_Id; 3118 Proc_Id : Entity_Id; 3119 Stmts : List_Id := No_List; 3120 3121 CRec_Typ : Entity_Id := Empty; 3122 -- The corresponding record type of Full_Typ 3123 3124 Full_Proc : Entity_Id := Empty; 3125 -- The entity of the "full" invariant procedure 3126 3127 Full_Typ : Entity_Id := Empty; 3128 -- The full view of the working type 3129 3130 Obj_Id : Entity_Id := Empty; 3131 -- The _object formal parameter of the invariant procedure 3132 3133 Part_Proc : Entity_Id := Empty; 3134 -- The entity of the "partial" invariant procedure 3135 3136 Priv_Typ : Entity_Id := Empty; 3137 -- The partial view of the working type 3138 3139 Work_Typ : Entity_Id := Empty; 3140 -- The working type 3141 3142 -- Start of processing for Build_Invariant_Procedure_Body 3143 3144 begin 3145 Work_Typ := Typ; 3146 3147 -- The input type denotes the implementation base type of a constrained 3148 -- array type. Work with the first subtype as all invariant pragmas are 3149 -- on its rep item chain. 3150 3151 if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then 3152 Work_Typ := First_Subtype (Work_Typ); 3153 3154 -- The input type denotes the corresponding record type of a protected 3155 -- or task type. Work with the concurrent type because the corresponding 3156 -- record type may not be visible to clients of the type. 3157 3158 elsif Ekind (Work_Typ) = E_Record_Type 3159 and then Is_Concurrent_Record_Type (Work_Typ) 3160 then 3161 Work_Typ := Corresponding_Concurrent_Type (Work_Typ); 3162 end if; 3163 3164 -- The working type may be subject to pragma Ghost. Set the mode now to 3165 -- ensure that the invariant procedure is properly marked as Ghost. 3166 3167 Set_Ghost_Mode (Work_Typ); 3168 3169 -- The type must either have invariants of its own, inherit class-wide 3170 -- invariants from parent types or interfaces, or be an array or record 3171 -- type whose components have invariants. 3172 3173 pragma Assert (Has_Invariants (Work_Typ)); 3174 3175 -- Interfaces are treated as the partial view of a private type in order 3176 -- to achieve uniformity with the general case. 3177 3178 if Is_Interface (Work_Typ) then 3179 Priv_Typ := Work_Typ; 3180 3181 -- Otherwise obtain both views of the type 3182 3183 else 3184 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy, CRec_Typ); 3185 end if; 3186 3187 -- The caller requests a body for the partial invariant procedure 3188 3189 if Partial_Invariant then 3190 Full_Proc := Invariant_Procedure (Work_Typ); 3191 Proc_Id := Partial_Invariant_Procedure (Work_Typ); 3192 3193 -- The "full" invariant procedure body was already created 3194 3195 if Present (Full_Proc) 3196 and then Present 3197 (Corresponding_Body (Unit_Declaration_Node (Full_Proc))) 3198 then 3199 -- This scenario happens only when the type is an untagged 3200 -- derivation from a private parent and the underlying full 3201 -- view was processed before the partial view. 3202 3203 pragma Assert 3204 (Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ)); 3205 3206 -- Nothing to do because the processing of the underlying full 3207 -- view already checked the invariants of the partial view. 3208 3209 goto Leave; 3210 end if; 3211 3212 -- Create a declaration for the "partial" invariant procedure if it 3213 -- is not available. 3214 3215 if No (Proc_Id) then 3216 Build_Invariant_Procedure_Declaration 3217 (Typ => Work_Typ, 3218 Partial_Invariant => True); 3219 3220 Proc_Id := Partial_Invariant_Procedure (Work_Typ); 3221 end if; 3222 3223 -- The caller requests a body for the "full" invariant procedure 3224 3225 else 3226 Proc_Id := Invariant_Procedure (Work_Typ); 3227 Part_Proc := Partial_Invariant_Procedure (Work_Typ); 3228 3229 -- Create a declaration for the "full" invariant procedure if it is 3230 -- not available. 3231 3232 if No (Proc_Id) then 3233 Build_Invariant_Procedure_Declaration (Work_Typ); 3234 Proc_Id := Invariant_Procedure (Work_Typ); 3235 end if; 3236 end if; 3237 3238 -- At this point there should be an invariant procedure declaration 3239 3240 pragma Assert (Present (Proc_Id)); 3241 Proc_Decl := Unit_Declaration_Node (Proc_Id); 3242 3243 -- Nothing to do if the invariant procedure already has a body 3244 3245 if Present (Corresponding_Body (Proc_Decl)) then 3246 goto Leave; 3247 end if; 3248 3249 -- Emulate the environment of the invariant procedure by installing its 3250 -- scope and formal parameters. Note that this is not needed, but having 3251 -- the scope installed helps with the detection of invariant-related 3252 -- errors. 3253 3254 Push_Scope (Proc_Id); 3255 Install_Formals (Proc_Id); 3256 3257 Obj_Id := First_Formal (Proc_Id); 3258 pragma Assert (Present (Obj_Id)); 3259 3260 -- The "partial" invariant procedure verifies the invariants of the 3261 -- partial view only. 3262 3263 if Partial_Invariant then 3264 pragma Assert (Present (Priv_Typ)); 3265 3266 Add_Own_Invariants 3267 (T => Priv_Typ, 3268 Obj_Id => Obj_Id, 3269 Checks => Stmts); 3270 3271 -- Otherwise the "full" invariant procedure verifies the invariants of 3272 -- the full view, all array or record components, as well as class-wide 3273 -- invariants inherited from parent types or interfaces. In addition, it 3274 -- indirectly verifies the invariants of the partial view by calling the 3275 -- "partial" invariant procedure. 3276 3277 else 3278 pragma Assert (Present (Full_Typ)); 3279 3280 -- Check the invariants of the partial view by calling the "partial" 3281 -- invariant procedure. Generate: 3282 3283 -- <Work_Typ>Partial_Invariant (_object); 3284 3285 if Present (Part_Proc) then 3286 Append_New_To (Stmts, 3287 Make_Procedure_Call_Statement (Loc, 3288 Name => New_Occurrence_Of (Part_Proc, Loc), 3289 Parameter_Associations => New_List ( 3290 New_Occurrence_Of (Obj_Id, Loc)))); 3291 3292 Produced_Check := True; 3293 end if; 3294 3295 Priv_Item := Empty; 3296 3297 -- Derived subtypes do not have a partial view 3298 3299 if Present (Priv_Typ) then 3300 3301 -- The processing of the "full" invariant procedure intentionally 3302 -- skips the partial view because a) this may result in changes of 3303 -- visibility and b) lead to duplicate checks. However, when the 3304 -- full view is the underlying full view of an untagged derived 3305 -- type whose parent type is private, partial invariants appear on 3306 -- the rep item chain of the partial view only. 3307 3308 -- package Pack_1 is 3309 -- type Root ... is private; 3310 -- private 3311 -- <full view of Root> 3312 -- end Pack_1; 3313 3314 -- with Pack_1; 3315 -- package Pack_2 is 3316 -- type Child is new Pack_1.Root with Type_Invariant => ...; 3317 -- <underlying full view of Child> 3318 -- end Pack_2; 3319 3320 -- As a result, the processing of the full view must also consider 3321 -- all invariants of the partial view. 3322 3323 if Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ) then 3324 null; 3325 3326 -- Otherwise the invariants of the partial view are ignored 3327 3328 else 3329 -- Note that the rep item chain is shared between the partial 3330 -- and full views of a type. To avoid processing the invariants 3331 -- of the partial view, signal the logic to stop when the first 3332 -- rep item of the partial view has been reached. 3333 3334 Priv_Item := First_Rep_Item (Priv_Typ); 3335 3336 -- Ignore the invariants of the partial view by eliminating the 3337 -- view. 3338 3339 Priv_Typ := Empty; 3340 end if; 3341 end if; 3342 3343 -- Process the invariants of the full view and in certain cases those 3344 -- of the partial view. This also handles any invariants on array or 3345 -- record components. 3346 3347 Add_Own_Invariants 3348 (T => Priv_Typ, 3349 Obj_Id => Obj_Id, 3350 Checks => Stmts, 3351 Priv_Item => Priv_Item); 3352 3353 Add_Own_Invariants 3354 (T => Full_Typ, 3355 Obj_Id => Obj_Id, 3356 Checks => Stmts, 3357 Priv_Item => Priv_Item); 3358 3359 -- Process the elements of an array type 3360 3361 if Is_Array_Type (Full_Typ) then 3362 Add_Array_Component_Invariants (Full_Typ, Obj_Id, Stmts); 3363 3364 -- Process the components of a record type 3365 3366 elsif Ekind (Full_Typ) = E_Record_Type then 3367 Add_Record_Component_Invariants (Full_Typ, Obj_Id, Stmts); 3368 3369 -- Process the components of a corresponding record 3370 3371 elsif Present (CRec_Typ) then 3372 Add_Record_Component_Invariants (CRec_Typ, Obj_Id, Stmts); 3373 end if; 3374 3375 -- Process the inherited class-wide invariants of all parent types. 3376 -- This also handles any invariants on record components. 3377 3378 Add_Parent_Invariants (Full_Typ, Obj_Id, Stmts); 3379 3380 -- Process the inherited class-wide invariants of all implemented 3381 -- interface types. 3382 3383 Add_Interface_Invariants (Full_Typ, Obj_Id, Stmts); 3384 end if; 3385 3386 End_Scope; 3387 3388 -- At this point there should be at least one invariant check. If this 3389 -- is not the case, then the invariant-related flags were not properly 3390 -- set, or there is a missing invariant procedure on one of the array 3391 -- or record components. 3392 3393 pragma Assert (Produced_Check); 3394 3395 -- Account for the case where assertions are disabled or all invariant 3396 -- checks are subject to Assertion_Policy Ignore. Produce a completing 3397 -- empty body. 3398 3399 if No (Stmts) then 3400 Stmts := New_List (Make_Null_Statement (Loc)); 3401 end if; 3402 3403 -- Generate: 3404 -- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>) is 3405 -- begin 3406 -- <Stmts> 3407 -- end <Work_Typ>[Partial_]Invariant; 3408 3409 Proc_Body := 3410 Make_Subprogram_Body (Loc, 3411 Specification => 3412 Copy_Subprogram_Spec (Parent (Proc_Id)), 3413 Declarations => Empty_List, 3414 Handled_Statement_Sequence => 3415 Make_Handled_Sequence_Of_Statements (Loc, 3416 Statements => Stmts)); 3417 Proc_Body_Id := Defining_Entity (Proc_Body); 3418 3419 -- Perform minor decoration in case the body is not analyzed 3420 3421 Set_Ekind (Proc_Body_Id, E_Subprogram_Body); 3422 Set_Etype (Proc_Body_Id, Standard_Void_Type); 3423 Set_Scope (Proc_Body_Id, Current_Scope); 3424 3425 -- Link both spec and body to avoid generating duplicates 3426 3427 Set_Corresponding_Body (Proc_Decl, Proc_Body_Id); 3428 Set_Corresponding_Spec (Proc_Body, Proc_Id); 3429 3430 -- The body should not be inserted into the tree when the context is 3431 -- ASIS or a generic unit because it is not part of the template. Note 3432 -- that the body must still be generated in order to resolve the 3433 -- invariants. 3434 3435 if ASIS_Mode or Inside_A_Generic then 3436 null; 3437 3438 -- Semi-insert the body into the tree for GNATprove by setting its 3439 -- Parent field. This allows for proper upstream tree traversals. 3440 3441 elsif GNATprove_Mode then 3442 Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ))); 3443 3444 -- Otherwise the body is part of the freezing actions of the type 3445 3446 else 3447 Append_Freeze_Action (Work_Typ, Proc_Body); 3448 end if; 3449 3450 <<Leave>> 3451 Restore_Ghost_Region (Saved_GM, Saved_IGR); 3452 end Build_Invariant_Procedure_Body; 3453 3454 ------------------------------------------- 3455 -- Build_Invariant_Procedure_Declaration -- 3456 ------------------------------------------- 3457 3458 -- WARNING: This routine manages Ghost regions. Return statements must be 3459 -- replaced by gotos which jump to the end of the routine and restore the 3460 -- Ghost mode. 3461 3462 procedure Build_Invariant_Procedure_Declaration 3463 (Typ : Entity_Id; 3464 Partial_Invariant : Boolean := False) 3465 is 3466 Loc : constant Source_Ptr := Sloc (Typ); 3467 3468 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 3469 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 3470 -- Save the Ghost-related attributes to restore on exit 3471 3472 Proc_Decl : Node_Id; 3473 Proc_Id : Entity_Id; 3474 Proc_Nam : Name_Id; 3475 Typ_Decl : Node_Id; 3476 3477 CRec_Typ : Entity_Id; 3478 -- The corresponding record type of Full_Typ 3479 3480 Full_Base : Entity_Id; 3481 -- The base type of Full_Typ 3482 3483 Full_Typ : Entity_Id; 3484 -- The full view of working type 3485 3486 Obj_Id : Entity_Id; 3487 -- The _object formal parameter of the invariant procedure 3488 3489 Obj_Typ : Entity_Id; 3490 -- The type of the _object formal parameter 3491 3492 Priv_Typ : Entity_Id; 3493 -- The partial view of working type 3494 3495 Work_Typ : Entity_Id; 3496 -- The working type 3497 3498 begin 3499 Work_Typ := Typ; 3500 3501 -- The input type denotes the implementation base type of a constrained 3502 -- array type. Work with the first subtype as all invariant pragmas are 3503 -- on its rep item chain. 3504 3505 if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then 3506 Work_Typ := First_Subtype (Work_Typ); 3507 3508 -- The input denotes the corresponding record type of a protected or a 3509 -- task type. Work with the concurrent type because the corresponding 3510 -- record type may not be visible to clients of the type. 3511 3512 elsif Ekind (Work_Typ) = E_Record_Type 3513 and then Is_Concurrent_Record_Type (Work_Typ) 3514 then 3515 Work_Typ := Corresponding_Concurrent_Type (Work_Typ); 3516 end if; 3517 3518 -- The working type may be subject to pragma Ghost. Set the mode now to 3519 -- ensure that the invariant procedure is properly marked as Ghost. 3520 3521 Set_Ghost_Mode (Work_Typ); 3522 3523 -- The type must either have invariants of its own, inherit class-wide 3524 -- invariants from parent or interface types, or be an array or record 3525 -- type whose components have invariants. 3526 3527 pragma Assert (Has_Invariants (Work_Typ)); 3528 3529 -- Nothing to do if the type already has a "partial" invariant procedure 3530 3531 if Partial_Invariant then 3532 if Present (Partial_Invariant_Procedure (Work_Typ)) then 3533 goto Leave; 3534 end if; 3535 3536 -- Nothing to do if the type already has a "full" invariant procedure 3537 3538 elsif Present (Invariant_Procedure (Work_Typ)) then 3539 goto Leave; 3540 end if; 3541 3542 -- The caller requests the declaration of the "partial" invariant 3543 -- procedure. 3544 3545 if Partial_Invariant then 3546 Proc_Nam := New_External_Name (Chars (Work_Typ), "Partial_Invariant"); 3547 3548 -- Otherwise the caller requests the declaration of the "full" invariant 3549 -- procedure. 3550 3551 else 3552 Proc_Nam := New_External_Name (Chars (Work_Typ), "Invariant"); 3553 end if; 3554 3555 Proc_Id := Make_Defining_Identifier (Loc, Chars => Proc_Nam); 3556 3557 -- Perform minor decoration in case the declaration is not analyzed 3558 3559 Set_Ekind (Proc_Id, E_Procedure); 3560 Set_Etype (Proc_Id, Standard_Void_Type); 3561 Set_Scope (Proc_Id, Current_Scope); 3562 3563 if Partial_Invariant then 3564 Set_Is_Partial_Invariant_Procedure (Proc_Id); 3565 Set_Partial_Invariant_Procedure (Work_Typ, Proc_Id); 3566 else 3567 Set_Is_Invariant_Procedure (Proc_Id); 3568 Set_Invariant_Procedure (Work_Typ, Proc_Id); 3569 end if; 3570 3571 -- The invariant procedure requires debug info when the invariants are 3572 -- subject to Source Coverage Obligations. 3573 3574 if Generate_SCO then 3575 Set_Debug_Info_Needed (Proc_Id); 3576 end if; 3577 3578 -- Obtain all views of the input type 3579 3580 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ); 3581 3582 -- Associate the invariant procedure with all views 3583 3584 Propagate_Invariant_Attributes (Priv_Typ, From_Typ => Work_Typ); 3585 Propagate_Invariant_Attributes (Full_Typ, From_Typ => Work_Typ); 3586 Propagate_Invariant_Attributes (Full_Base, From_Typ => Work_Typ); 3587 Propagate_Invariant_Attributes (CRec_Typ, From_Typ => Work_Typ); 3588 3589 -- The declaration of the invariant procedure is inserted after the 3590 -- declaration of the partial view as this allows for proper external 3591 -- visibility. 3592 3593 if Present (Priv_Typ) then 3594 Typ_Decl := Declaration_Node (Priv_Typ); 3595 3596 -- Anonymous arrays in object declarations have no explicit declaration 3597 -- so use the related object declaration as the insertion point. 3598 3599 elsif Is_Itype (Work_Typ) and then Is_Array_Type (Work_Typ) then 3600 Typ_Decl := Associated_Node_For_Itype (Work_Typ); 3601 3602 -- Derived types with the full view as parent do not have a partial 3603 -- view. Insert the invariant procedure after the derived type. 3604 3605 else 3606 Typ_Decl := Declaration_Node (Full_Typ); 3607 end if; 3608 3609 -- The type should have a declarative node 3610 3611 pragma Assert (Present (Typ_Decl)); 3612 3613 -- Create the formal parameter which emulates the variable-like behavior 3614 -- of the current type instance. 3615 3616 Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject); 3617 3618 -- When generating an invariant procedure declaration for an abstract 3619 -- type (including interfaces), use the class-wide type as the _object 3620 -- type. This has several desirable effects: 3621 3622 -- * The invariant procedure does not become a primitive of the type. 3623 -- This eliminates the need to either special case the treatment of 3624 -- invariant procedures, or to make it a predefined primitive and 3625 -- force every derived type to potentially provide an empty body. 3626 3627 -- * The invariant procedure does not need to be declared as abstract. 3628 -- This allows for a proper body, which in turn avoids redundant 3629 -- processing of the same invariants for types with multiple views. 3630 3631 -- * The class-wide type allows for calls to abstract primitives 3632 -- within a nonabstract subprogram. The calls are treated as 3633 -- dispatching and require additional processing when they are 3634 -- remapped to call primitives of derived types. See routine 3635 -- Replace_References for details. 3636 3637 if Is_Abstract_Type (Work_Typ) then 3638 Obj_Typ := Class_Wide_Type (Work_Typ); 3639 else 3640 Obj_Typ := Work_Typ; 3641 end if; 3642 3643 -- Perform minor decoration in case the declaration is not analyzed 3644 3645 Set_Ekind (Obj_Id, E_In_Parameter); 3646 Set_Etype (Obj_Id, Obj_Typ); 3647 Set_Scope (Obj_Id, Proc_Id); 3648 3649 Set_First_Entity (Proc_Id, Obj_Id); 3650 Set_Last_Entity (Proc_Id, Obj_Id); 3651 3652 -- Generate: 3653 -- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>); 3654 3655 Proc_Decl := 3656 Make_Subprogram_Declaration (Loc, 3657 Specification => 3658 Make_Procedure_Specification (Loc, 3659 Defining_Unit_Name => Proc_Id, 3660 Parameter_Specifications => New_List ( 3661 Make_Parameter_Specification (Loc, 3662 Defining_Identifier => Obj_Id, 3663 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc))))); 3664 3665 -- The declaration should not be inserted into the tree when the context 3666 -- is ASIS or a generic unit because it is not part of the template. 3667 3668 if ASIS_Mode or Inside_A_Generic then 3669 null; 3670 3671 -- Semi-insert the declaration into the tree for GNATprove by setting 3672 -- its Parent field. This allows for proper upstream tree traversals. 3673 3674 elsif GNATprove_Mode then 3675 Set_Parent (Proc_Decl, Parent (Typ_Decl)); 3676 3677 -- Otherwise insert the declaration 3678 3679 else 3680 pragma Assert (Present (Typ_Decl)); 3681 Insert_After_And_Analyze (Typ_Decl, Proc_Decl); 3682 end if; 3683 3684 <<Leave>> 3685 Restore_Ghost_Region (Saved_GM, Saved_IGR); 3686 end Build_Invariant_Procedure_Declaration; 3687 3688 -------------------------- 3689 -- Build_Procedure_Form -- 3690 -------------------------- 3691 3692 procedure Build_Procedure_Form (N : Node_Id) is 3693 Loc : constant Source_Ptr := Sloc (N); 3694 Subp : constant Entity_Id := Defining_Entity (N); 3695 3696 Func_Formal : Entity_Id; 3697 Proc_Formals : List_Id; 3698 Proc_Decl : Node_Id; 3699 3700 begin 3701 -- No action needed if this transformation was already done, or in case 3702 -- of subprogram renaming declarations. 3703 3704 if Nkind (Specification (N)) = N_Procedure_Specification 3705 or else Nkind (N) = N_Subprogram_Renaming_Declaration 3706 then 3707 return; 3708 end if; 3709 3710 -- Ditto when dealing with an expression function, where both the 3711 -- original expression and the generated declaration end up being 3712 -- expanded here. 3713 3714 if Rewritten_For_C (Subp) then 3715 return; 3716 end if; 3717 3718 Proc_Formals := New_List; 3719 3720 -- Create a list of formal parameters with the same types as the 3721 -- function. 3722 3723 Func_Formal := First_Formal (Subp); 3724 while Present (Func_Formal) loop 3725 Append_To (Proc_Formals, 3726 Make_Parameter_Specification (Loc, 3727 Defining_Identifier => 3728 Make_Defining_Identifier (Loc, Chars (Func_Formal)), 3729 Parameter_Type => 3730 New_Occurrence_Of (Etype (Func_Formal), Loc))); 3731 3732 Next_Formal (Func_Formal); 3733 end loop; 3734 3735 -- Add an extra out parameter to carry the function result 3736 3737 Name_Len := 6; 3738 Name_Buffer (1 .. Name_Len) := "RESULT"; 3739 Append_To (Proc_Formals, 3740 Make_Parameter_Specification (Loc, 3741 Defining_Identifier => 3742 Make_Defining_Identifier (Loc, Chars => Name_Find), 3743 Out_Present => True, 3744 Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc))); 3745 3746 -- The new procedure declaration is inserted immediately after the 3747 -- function declaration. The processing in Build_Procedure_Body_Form 3748 -- relies on this order. 3749 3750 Proc_Decl := 3751 Make_Subprogram_Declaration (Loc, 3752 Specification => 3753 Make_Procedure_Specification (Loc, 3754 Defining_Unit_Name => 3755 Make_Defining_Identifier (Loc, Chars (Subp)), 3756 Parameter_Specifications => Proc_Formals)); 3757 3758 Insert_After_And_Analyze (Unit_Declaration_Node (Subp), Proc_Decl); 3759 3760 -- Entity of procedure must remain invisible so that it does not 3761 -- overload subsequent references to the original function. 3762 3763 Set_Is_Immediately_Visible (Defining_Entity (Proc_Decl), False); 3764 3765 -- Mark the function as having a procedure form and link the function 3766 -- and its internally built procedure. 3767 3768 Set_Rewritten_For_C (Subp); 3769 Set_Corresponding_Procedure (Subp, Defining_Entity (Proc_Decl)); 3770 Set_Corresponding_Function (Defining_Entity (Proc_Decl), Subp); 3771 end Build_Procedure_Form; 3772 3773 ------------------------ 3774 -- Build_Runtime_Call -- 3775 ------------------------ 3776 3777 function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is 3778 begin 3779 -- If entity is not available, we can skip making the call (this avoids 3780 -- junk duplicated error messages in a number of cases). 3781 3782 if not RTE_Available (RE) then 3783 return Make_Null_Statement (Loc); 3784 else 3785 return 3786 Make_Procedure_Call_Statement (Loc, 3787 Name => New_Occurrence_Of (RTE (RE), Loc)); 3788 end if; 3789 end Build_Runtime_Call; 3790 3791 ------------------------ 3792 -- Build_SS_Mark_Call -- 3793 ------------------------ 3794 3795 function Build_SS_Mark_Call 3796 (Loc : Source_Ptr; 3797 Mark : Entity_Id) return Node_Id 3798 is 3799 begin 3800 -- Generate: 3801 -- Mark : constant Mark_Id := SS_Mark; 3802 3803 return 3804 Make_Object_Declaration (Loc, 3805 Defining_Identifier => Mark, 3806 Constant_Present => True, 3807 Object_Definition => 3808 New_Occurrence_Of (RTE (RE_Mark_Id), Loc), 3809 Expression => 3810 Make_Function_Call (Loc, 3811 Name => New_Occurrence_Of (RTE (RE_SS_Mark), Loc))); 3812 end Build_SS_Mark_Call; 3813 3814 --------------------------- 3815 -- Build_SS_Release_Call -- 3816 --------------------------- 3817 3818 function Build_SS_Release_Call 3819 (Loc : Source_Ptr; 3820 Mark : Entity_Id) return Node_Id 3821 is 3822 begin 3823 -- Generate: 3824 -- SS_Release (Mark); 3825 3826 return 3827 Make_Procedure_Call_Statement (Loc, 3828 Name => 3829 New_Occurrence_Of (RTE (RE_SS_Release), Loc), 3830 Parameter_Associations => New_List ( 3831 New_Occurrence_Of (Mark, Loc))); 3832 end Build_SS_Release_Call; 3833 3834 ---------------------------- 3835 -- Build_Task_Array_Image -- 3836 ---------------------------- 3837 3838 -- This function generates the body for a function that constructs the 3839 -- image string for a task that is an array component. The function is 3840 -- local to the init proc for the array type, and is called for each one 3841 -- of the components. The constructed image has the form of an indexed 3842 -- component, whose prefix is the outer variable of the array type. 3843 -- The n-dimensional array type has known indexes Index, Index2... 3844 3845 -- Id_Ref is an indexed component form created by the enclosing init proc. 3846 -- Its successive indexes are Val1, Val2, ... which are the loop variables 3847 -- in the loops that call the individual task init proc on each component. 3848 3849 -- The generated function has the following structure: 3850 3851 -- function F return String is 3852 -- Pref : string renames Task_Name; 3853 -- T1 : String := Index1'Image (Val1); 3854 -- ... 3855 -- Tn : String := indexn'image (Valn); 3856 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1; 3857 -- -- Len includes commas and the end parentheses. 3858 -- Res : String (1..Len); 3859 -- Pos : Integer := Pref'Length; 3860 -- 3861 -- begin 3862 -- Res (1 .. Pos) := Pref; 3863 -- Pos := Pos + 1; 3864 -- Res (Pos) := '('; 3865 -- Pos := Pos + 1; 3866 -- Res (Pos .. Pos + T1'Length - 1) := T1; 3867 -- Pos := Pos + T1'Length; 3868 -- Res (Pos) := '.'; 3869 -- Pos := Pos + 1; 3870 -- ... 3871 -- Res (Pos .. Pos + Tn'Length - 1) := Tn; 3872 -- Res (Len) := ')'; 3873 -- 3874 -- return Res; 3875 -- end F; 3876 -- 3877 -- Needless to say, multidimensional arrays of tasks are rare enough that 3878 -- the bulkiness of this code is not really a concern. 3879 3880 function Build_Task_Array_Image 3881 (Loc : Source_Ptr; 3882 Id_Ref : Node_Id; 3883 A_Type : Entity_Id; 3884 Dyn : Boolean := False) return Node_Id 3885 is 3886 Dims : constant Nat := Number_Dimensions (A_Type); 3887 -- Number of dimensions for array of tasks 3888 3889 Temps : array (1 .. Dims) of Entity_Id; 3890 -- Array of temporaries to hold string for each index 3891 3892 Indx : Node_Id; 3893 -- Index expression 3894 3895 Len : Entity_Id; 3896 -- Total length of generated name 3897 3898 Pos : Entity_Id; 3899 -- Running index for substring assignments 3900 3901 Pref : constant Entity_Id := Make_Temporary (Loc, 'P'); 3902 -- Name of enclosing variable, prefix of resulting name 3903 3904 Res : Entity_Id; 3905 -- String to hold result 3906 3907 Val : Node_Id; 3908 -- Value of successive indexes 3909 3910 Sum : Node_Id; 3911 -- Expression to compute total size of string 3912 3913 T : Entity_Id; 3914 -- Entity for name at one index position 3915 3916 Decls : constant List_Id := New_List; 3917 Stats : constant List_Id := New_List; 3918 3919 begin 3920 -- For a dynamic task, the name comes from the target variable. For a 3921 -- static one it is a formal of the enclosing init proc. 3922 3923 if Dyn then 3924 Get_Name_String (Chars (Entity (Prefix (Id_Ref)))); 3925 Append_To (Decls, 3926 Make_Object_Declaration (Loc, 3927 Defining_Identifier => Pref, 3928 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 3929 Expression => 3930 Make_String_Literal (Loc, 3931 Strval => String_From_Name_Buffer))); 3932 3933 else 3934 Append_To (Decls, 3935 Make_Object_Renaming_Declaration (Loc, 3936 Defining_Identifier => Pref, 3937 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), 3938 Name => Make_Identifier (Loc, Name_uTask_Name))); 3939 end if; 3940 3941 Indx := First_Index (A_Type); 3942 Val := First (Expressions (Id_Ref)); 3943 3944 for J in 1 .. Dims loop 3945 T := Make_Temporary (Loc, 'T'); 3946 Temps (J) := T; 3947 3948 Append_To (Decls, 3949 Make_Object_Declaration (Loc, 3950 Defining_Identifier => T, 3951 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 3952 Expression => 3953 Make_Attribute_Reference (Loc, 3954 Attribute_Name => Name_Image, 3955 Prefix => New_Occurrence_Of (Etype (Indx), Loc), 3956 Expressions => New_List (New_Copy_Tree (Val))))); 3957 3958 Next_Index (Indx); 3959 Next (Val); 3960 end loop; 3961 3962 Sum := Make_Integer_Literal (Loc, Dims + 1); 3963 3964 Sum := 3965 Make_Op_Add (Loc, 3966 Left_Opnd => Sum, 3967 Right_Opnd => 3968 Make_Attribute_Reference (Loc, 3969 Attribute_Name => Name_Length, 3970 Prefix => New_Occurrence_Of (Pref, Loc), 3971 Expressions => New_List (Make_Integer_Literal (Loc, 1)))); 3972 3973 for J in 1 .. Dims loop 3974 Sum := 3975 Make_Op_Add (Loc, 3976 Left_Opnd => Sum, 3977 Right_Opnd => 3978 Make_Attribute_Reference (Loc, 3979 Attribute_Name => Name_Length, 3980 Prefix => 3981 New_Occurrence_Of (Temps (J), Loc), 3982 Expressions => New_List (Make_Integer_Literal (Loc, 1)))); 3983 end loop; 3984 3985 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats); 3986 3987 Set_Character_Literal_Name (Char_Code (Character'Pos ('('))); 3988 3989 Append_To (Stats, 3990 Make_Assignment_Statement (Loc, 3991 Name => 3992 Make_Indexed_Component (Loc, 3993 Prefix => New_Occurrence_Of (Res, Loc), 3994 Expressions => New_List (New_Occurrence_Of (Pos, Loc))), 3995 Expression => 3996 Make_Character_Literal (Loc, 3997 Chars => Name_Find, 3998 Char_Literal_Value => UI_From_Int (Character'Pos ('('))))); 3999 4000 Append_To (Stats, 4001 Make_Assignment_Statement (Loc, 4002 Name => New_Occurrence_Of (Pos, Loc), 4003 Expression => 4004 Make_Op_Add (Loc, 4005 Left_Opnd => New_Occurrence_Of (Pos, Loc), 4006 Right_Opnd => Make_Integer_Literal (Loc, 1)))); 4007 4008 for J in 1 .. Dims loop 4009 4010 Append_To (Stats, 4011 Make_Assignment_Statement (Loc, 4012 Name => 4013 Make_Slice (Loc, 4014 Prefix => New_Occurrence_Of (Res, Loc), 4015 Discrete_Range => 4016 Make_Range (Loc, 4017 Low_Bound => New_Occurrence_Of (Pos, Loc), 4018 High_Bound => 4019 Make_Op_Subtract (Loc, 4020 Left_Opnd => 4021 Make_Op_Add (Loc, 4022 Left_Opnd => New_Occurrence_Of (Pos, Loc), 4023 Right_Opnd => 4024 Make_Attribute_Reference (Loc, 4025 Attribute_Name => Name_Length, 4026 Prefix => 4027 New_Occurrence_Of (Temps (J), Loc), 4028 Expressions => 4029 New_List (Make_Integer_Literal (Loc, 1)))), 4030 Right_Opnd => Make_Integer_Literal (Loc, 1)))), 4031 4032 Expression => New_Occurrence_Of (Temps (J), Loc))); 4033 4034 if J < Dims then 4035 Append_To (Stats, 4036 Make_Assignment_Statement (Loc, 4037 Name => New_Occurrence_Of (Pos, Loc), 4038 Expression => 4039 Make_Op_Add (Loc, 4040 Left_Opnd => New_Occurrence_Of (Pos, Loc), 4041 Right_Opnd => 4042 Make_Attribute_Reference (Loc, 4043 Attribute_Name => Name_Length, 4044 Prefix => New_Occurrence_Of (Temps (J), Loc), 4045 Expressions => 4046 New_List (Make_Integer_Literal (Loc, 1)))))); 4047 4048 Set_Character_Literal_Name (Char_Code (Character'Pos (','))); 4049 4050 Append_To (Stats, 4051 Make_Assignment_Statement (Loc, 4052 Name => Make_Indexed_Component (Loc, 4053 Prefix => New_Occurrence_Of (Res, Loc), 4054 Expressions => New_List (New_Occurrence_Of (Pos, Loc))), 4055 Expression => 4056 Make_Character_Literal (Loc, 4057 Chars => Name_Find, 4058 Char_Literal_Value => UI_From_Int (Character'Pos (','))))); 4059 4060 Append_To (Stats, 4061 Make_Assignment_Statement (Loc, 4062 Name => New_Occurrence_Of (Pos, Loc), 4063 Expression => 4064 Make_Op_Add (Loc, 4065 Left_Opnd => New_Occurrence_Of (Pos, Loc), 4066 Right_Opnd => Make_Integer_Literal (Loc, 1)))); 4067 end if; 4068 end loop; 4069 4070 Set_Character_Literal_Name (Char_Code (Character'Pos (')'))); 4071 4072 Append_To (Stats, 4073 Make_Assignment_Statement (Loc, 4074 Name => 4075 Make_Indexed_Component (Loc, 4076 Prefix => New_Occurrence_Of (Res, Loc), 4077 Expressions => New_List (New_Occurrence_Of (Len, Loc))), 4078 Expression => 4079 Make_Character_Literal (Loc, 4080 Chars => Name_Find, 4081 Char_Literal_Value => UI_From_Int (Character'Pos (')'))))); 4082 return Build_Task_Image_Function (Loc, Decls, Stats, Res); 4083 end Build_Task_Array_Image; 4084 4085 ---------------------------- 4086 -- Build_Task_Image_Decls -- 4087 ---------------------------- 4088 4089 function Build_Task_Image_Decls 4090 (Loc : Source_Ptr; 4091 Id_Ref : Node_Id; 4092 A_Type : Entity_Id; 4093 In_Init_Proc : Boolean := False) return List_Id 4094 is 4095 Decls : constant List_Id := New_List; 4096 T_Id : Entity_Id := Empty; 4097 Decl : Node_Id; 4098 Expr : Node_Id := Empty; 4099 Fun : Node_Id := Empty; 4100 Is_Dyn : constant Boolean := 4101 Nkind (Parent (Id_Ref)) = N_Assignment_Statement 4102 and then 4103 Nkind (Expression (Parent (Id_Ref))) = N_Allocator; 4104 4105 begin 4106 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect, 4107 -- generate a dummy declaration only. 4108 4109 if Restriction_Active (No_Implicit_Heap_Allocations) 4110 or else Global_Discard_Names 4111 then 4112 T_Id := Make_Temporary (Loc, 'J'); 4113 Name_Len := 0; 4114 4115 return 4116 New_List ( 4117 Make_Object_Declaration (Loc, 4118 Defining_Identifier => T_Id, 4119 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 4120 Expression => 4121 Make_String_Literal (Loc, 4122 Strval => String_From_Name_Buffer))); 4123 4124 else 4125 if Nkind (Id_Ref) = N_Identifier 4126 or else Nkind (Id_Ref) = N_Defining_Identifier 4127 then 4128 -- For a simple variable, the image of the task is built from 4129 -- the name of the variable. To avoid possible conflict with the 4130 -- anonymous type created for a single protected object, add a 4131 -- numeric suffix. 4132 4133 T_Id := 4134 Make_Defining_Identifier (Loc, 4135 New_External_Name (Chars (Id_Ref), 'T', 1)); 4136 4137 Get_Name_String (Chars (Id_Ref)); 4138 4139 Expr := 4140 Make_String_Literal (Loc, 4141 Strval => String_From_Name_Buffer); 4142 4143 elsif Nkind (Id_Ref) = N_Selected_Component then 4144 T_Id := 4145 Make_Defining_Identifier (Loc, 4146 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T')); 4147 Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn); 4148 4149 elsif Nkind (Id_Ref) = N_Indexed_Component then 4150 T_Id := 4151 Make_Defining_Identifier (Loc, 4152 New_External_Name (Chars (A_Type), 'N')); 4153 4154 Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn); 4155 end if; 4156 end if; 4157 4158 if Present (Fun) then 4159 Append (Fun, Decls); 4160 Expr := Make_Function_Call (Loc, 4161 Name => New_Occurrence_Of (Defining_Entity (Fun), Loc)); 4162 4163 if not In_Init_Proc then 4164 Set_Uses_Sec_Stack (Defining_Entity (Fun)); 4165 end if; 4166 end if; 4167 4168 Decl := Make_Object_Declaration (Loc, 4169 Defining_Identifier => T_Id, 4170 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 4171 Constant_Present => True, 4172 Expression => Expr); 4173 4174 Append (Decl, Decls); 4175 return Decls; 4176 end Build_Task_Image_Decls; 4177 4178 ------------------------------- 4179 -- Build_Task_Image_Function -- 4180 ------------------------------- 4181 4182 function Build_Task_Image_Function 4183 (Loc : Source_Ptr; 4184 Decls : List_Id; 4185 Stats : List_Id; 4186 Res : Entity_Id) return Node_Id 4187 is 4188 Spec : Node_Id; 4189 4190 begin 4191 Append_To (Stats, 4192 Make_Simple_Return_Statement (Loc, 4193 Expression => New_Occurrence_Of (Res, Loc))); 4194 4195 Spec := Make_Function_Specification (Loc, 4196 Defining_Unit_Name => Make_Temporary (Loc, 'F'), 4197 Result_Definition => New_Occurrence_Of (Standard_String, Loc)); 4198 4199 -- Calls to 'Image use the secondary stack, which must be cleaned up 4200 -- after the task name is built. 4201 4202 return Make_Subprogram_Body (Loc, 4203 Specification => Spec, 4204 Declarations => Decls, 4205 Handled_Statement_Sequence => 4206 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats)); 4207 end Build_Task_Image_Function; 4208 4209 ----------------------------- 4210 -- Build_Task_Image_Prefix -- 4211 ----------------------------- 4212 4213 procedure Build_Task_Image_Prefix 4214 (Loc : Source_Ptr; 4215 Len : out Entity_Id; 4216 Res : out Entity_Id; 4217 Pos : out Entity_Id; 4218 Prefix : Entity_Id; 4219 Sum : Node_Id; 4220 Decls : List_Id; 4221 Stats : List_Id) 4222 is 4223 begin 4224 Len := Make_Temporary (Loc, 'L', Sum); 4225 4226 Append_To (Decls, 4227 Make_Object_Declaration (Loc, 4228 Defining_Identifier => Len, 4229 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 4230 Expression => Sum)); 4231 4232 Res := Make_Temporary (Loc, 'R'); 4233 4234 Append_To (Decls, 4235 Make_Object_Declaration (Loc, 4236 Defining_Identifier => Res, 4237 Object_Definition => 4238 Make_Subtype_Indication (Loc, 4239 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), 4240 Constraint => 4241 Make_Index_Or_Discriminant_Constraint (Loc, 4242 Constraints => 4243 New_List ( 4244 Make_Range (Loc, 4245 Low_Bound => Make_Integer_Literal (Loc, 1), 4246 High_Bound => New_Occurrence_Of (Len, Loc))))))); 4247 4248 -- Indicate that the result is an internal temporary, so it does not 4249 -- receive a bogus initialization when declaration is expanded. This 4250 -- is both efficient, and prevents anomalies in the handling of 4251 -- dynamic objects on the secondary stack. 4252 4253 Set_Is_Internal (Res); 4254 Pos := Make_Temporary (Loc, 'P'); 4255 4256 Append_To (Decls, 4257 Make_Object_Declaration (Loc, 4258 Defining_Identifier => Pos, 4259 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc))); 4260 4261 -- Pos := Prefix'Length; 4262 4263 Append_To (Stats, 4264 Make_Assignment_Statement (Loc, 4265 Name => New_Occurrence_Of (Pos, Loc), 4266 Expression => 4267 Make_Attribute_Reference (Loc, 4268 Attribute_Name => Name_Length, 4269 Prefix => New_Occurrence_Of (Prefix, Loc), 4270 Expressions => New_List (Make_Integer_Literal (Loc, 1))))); 4271 4272 -- Res (1 .. Pos) := Prefix; 4273 4274 Append_To (Stats, 4275 Make_Assignment_Statement (Loc, 4276 Name => 4277 Make_Slice (Loc, 4278 Prefix => New_Occurrence_Of (Res, Loc), 4279 Discrete_Range => 4280 Make_Range (Loc, 4281 Low_Bound => Make_Integer_Literal (Loc, 1), 4282 High_Bound => New_Occurrence_Of (Pos, Loc))), 4283 4284 Expression => New_Occurrence_Of (Prefix, Loc))); 4285 4286 Append_To (Stats, 4287 Make_Assignment_Statement (Loc, 4288 Name => New_Occurrence_Of (Pos, Loc), 4289 Expression => 4290 Make_Op_Add (Loc, 4291 Left_Opnd => New_Occurrence_Of (Pos, Loc), 4292 Right_Opnd => Make_Integer_Literal (Loc, 1)))); 4293 end Build_Task_Image_Prefix; 4294 4295 ----------------------------- 4296 -- Build_Task_Record_Image -- 4297 ----------------------------- 4298 4299 function Build_Task_Record_Image 4300 (Loc : Source_Ptr; 4301 Id_Ref : Node_Id; 4302 Dyn : Boolean := False) return Node_Id 4303 is 4304 Len : Entity_Id; 4305 -- Total length of generated name 4306 4307 Pos : Entity_Id; 4308 -- Index into result 4309 4310 Res : Entity_Id; 4311 -- String to hold result 4312 4313 Pref : constant Entity_Id := Make_Temporary (Loc, 'P'); 4314 -- Name of enclosing variable, prefix of resulting name 4315 4316 Sum : Node_Id; 4317 -- Expression to compute total size of string 4318 4319 Sel : Entity_Id; 4320 -- Entity for selector name 4321 4322 Decls : constant List_Id := New_List; 4323 Stats : constant List_Id := New_List; 4324 4325 begin 4326 -- For a dynamic task, the name comes from the target variable. For a 4327 -- static one it is a formal of the enclosing init proc. 4328 4329 if Dyn then 4330 Get_Name_String (Chars (Entity (Prefix (Id_Ref)))); 4331 Append_To (Decls, 4332 Make_Object_Declaration (Loc, 4333 Defining_Identifier => Pref, 4334 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 4335 Expression => 4336 Make_String_Literal (Loc, 4337 Strval => String_From_Name_Buffer))); 4338 4339 else 4340 Append_To (Decls, 4341 Make_Object_Renaming_Declaration (Loc, 4342 Defining_Identifier => Pref, 4343 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), 4344 Name => Make_Identifier (Loc, Name_uTask_Name))); 4345 end if; 4346 4347 Sel := Make_Temporary (Loc, 'S'); 4348 4349 Get_Name_String (Chars (Selector_Name (Id_Ref))); 4350 4351 Append_To (Decls, 4352 Make_Object_Declaration (Loc, 4353 Defining_Identifier => Sel, 4354 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 4355 Expression => 4356 Make_String_Literal (Loc, 4357 Strval => String_From_Name_Buffer))); 4358 4359 Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1)); 4360 4361 Sum := 4362 Make_Op_Add (Loc, 4363 Left_Opnd => Sum, 4364 Right_Opnd => 4365 Make_Attribute_Reference (Loc, 4366 Attribute_Name => Name_Length, 4367 Prefix => 4368 New_Occurrence_Of (Pref, Loc), 4369 Expressions => New_List (Make_Integer_Literal (Loc, 1)))); 4370 4371 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats); 4372 4373 Set_Character_Literal_Name (Char_Code (Character'Pos ('.'))); 4374 4375 -- Res (Pos) := '.'; 4376 4377 Append_To (Stats, 4378 Make_Assignment_Statement (Loc, 4379 Name => Make_Indexed_Component (Loc, 4380 Prefix => New_Occurrence_Of (Res, Loc), 4381 Expressions => New_List (New_Occurrence_Of (Pos, Loc))), 4382 Expression => 4383 Make_Character_Literal (Loc, 4384 Chars => Name_Find, 4385 Char_Literal_Value => 4386 UI_From_Int (Character'Pos ('.'))))); 4387 4388 Append_To (Stats, 4389 Make_Assignment_Statement (Loc, 4390 Name => New_Occurrence_Of (Pos, Loc), 4391 Expression => 4392 Make_Op_Add (Loc, 4393 Left_Opnd => New_Occurrence_Of (Pos, Loc), 4394 Right_Opnd => Make_Integer_Literal (Loc, 1)))); 4395 4396 -- Res (Pos .. Len) := Selector; 4397 4398 Append_To (Stats, 4399 Make_Assignment_Statement (Loc, 4400 Name => Make_Slice (Loc, 4401 Prefix => New_Occurrence_Of (Res, Loc), 4402 Discrete_Range => 4403 Make_Range (Loc, 4404 Low_Bound => New_Occurrence_Of (Pos, Loc), 4405 High_Bound => New_Occurrence_Of (Len, Loc))), 4406 Expression => New_Occurrence_Of (Sel, Loc))); 4407 4408 return Build_Task_Image_Function (Loc, Decls, Stats, Res); 4409 end Build_Task_Record_Image; 4410 4411 --------------------------------------- 4412 -- Build_Transient_Object_Statements -- 4413 --------------------------------------- 4414 4415 procedure Build_Transient_Object_Statements 4416 (Obj_Decl : Node_Id; 4417 Fin_Call : out Node_Id; 4418 Hook_Assign : out Node_Id; 4419 Hook_Clear : out Node_Id; 4420 Hook_Decl : out Node_Id; 4421 Ptr_Decl : out Node_Id; 4422 Finalize_Obj : Boolean := True) 4423 is 4424 Loc : constant Source_Ptr := Sloc (Obj_Decl); 4425 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); 4426 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); 4427 4428 Desig_Typ : Entity_Id; 4429 Hook_Expr : Node_Id; 4430 Hook_Id : Entity_Id; 4431 Obj_Ref : Node_Id; 4432 Ptr_Typ : Entity_Id; 4433 4434 begin 4435 -- Recover the type of the object 4436 4437 Desig_Typ := Obj_Typ; 4438 4439 if Is_Access_Type (Desig_Typ) then 4440 Desig_Typ := Available_View (Designated_Type (Desig_Typ)); 4441 end if; 4442 4443 -- Create an access type which provides a reference to the transient 4444 -- object. Generate: 4445 4446 -- type Ptr_Typ is access all Desig_Typ; 4447 4448 Ptr_Typ := Make_Temporary (Loc, 'A'); 4449 Set_Ekind (Ptr_Typ, E_General_Access_Type); 4450 Set_Directly_Designated_Type (Ptr_Typ, Desig_Typ); 4451 4452 Ptr_Decl := 4453 Make_Full_Type_Declaration (Loc, 4454 Defining_Identifier => Ptr_Typ, 4455 Type_Definition => 4456 Make_Access_To_Object_Definition (Loc, 4457 All_Present => True, 4458 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))); 4459 4460 -- Create a temporary check which acts as a hook to the transient 4461 -- object. Generate: 4462 4463 -- Hook : Ptr_Typ := null; 4464 4465 Hook_Id := Make_Temporary (Loc, 'T'); 4466 Set_Ekind (Hook_Id, E_Variable); 4467 Set_Etype (Hook_Id, Ptr_Typ); 4468 4469 Hook_Decl := 4470 Make_Object_Declaration (Loc, 4471 Defining_Identifier => Hook_Id, 4472 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), 4473 Expression => Make_Null (Loc)); 4474 4475 -- Mark the temporary as a hook. This signals the machinery in 4476 -- Build_Finalizer to recognize this special case. 4477 4478 Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl); 4479 4480 -- Hook the transient object to the temporary. Generate: 4481 4482 -- Hook := Ptr_Typ (Obj_Id); 4483 -- <or> 4484 -- Hool := Obj_Id'Unrestricted_Access; 4485 4486 if Is_Access_Type (Obj_Typ) then 4487 Hook_Expr := 4488 Unchecked_Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc)); 4489 else 4490 Hook_Expr := 4491 Make_Attribute_Reference (Loc, 4492 Prefix => New_Occurrence_Of (Obj_Id, Loc), 4493 Attribute_Name => Name_Unrestricted_Access); 4494 end if; 4495 4496 Hook_Assign := 4497 Make_Assignment_Statement (Loc, 4498 Name => New_Occurrence_Of (Hook_Id, Loc), 4499 Expression => Hook_Expr); 4500 4501 -- Crear the hook prior to finalizing the object. Generate: 4502 4503 -- Hook := null; 4504 4505 Hook_Clear := 4506 Make_Assignment_Statement (Loc, 4507 Name => New_Occurrence_Of (Hook_Id, Loc), 4508 Expression => Make_Null (Loc)); 4509 4510 -- Finalize the object. Generate: 4511 4512 -- [Deep_]Finalize (Obj_Ref[.all]); 4513 4514 if Finalize_Obj then 4515 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc); 4516 4517 if Is_Access_Type (Obj_Typ) then 4518 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); 4519 Set_Etype (Obj_Ref, Desig_Typ); 4520 end if; 4521 4522 Fin_Call := 4523 Make_Final_Call 4524 (Obj_Ref => Obj_Ref, 4525 Typ => Desig_Typ); 4526 4527 -- Otherwise finalize the hook. Generate: 4528 4529 -- [Deep_]Finalize (Hook.all); 4530 4531 else 4532 Fin_Call := 4533 Make_Final_Call ( 4534 Obj_Ref => 4535 Make_Explicit_Dereference (Loc, 4536 Prefix => New_Occurrence_Of (Hook_Id, Loc)), 4537 Typ => Desig_Typ); 4538 end if; 4539 end Build_Transient_Object_Statements; 4540 4541 ----------------------------- 4542 -- Check_Float_Op_Overflow -- 4543 ----------------------------- 4544 4545 procedure Check_Float_Op_Overflow (N : Node_Id) is 4546 begin 4547 -- Return if no check needed 4548 4549 if not Is_Floating_Point_Type (Etype (N)) 4550 or else not (Do_Overflow_Check (N) and then Check_Float_Overflow) 4551 4552 -- In CodePeer_Mode, rely on the overflow check flag being set instead 4553 -- and do not expand the code for float overflow checking. 4554 4555 or else CodePeer_Mode 4556 then 4557 return; 4558 end if; 4559 4560 -- Otherwise we replace the expression by 4561 4562 -- do Tnn : constant ftype := expression; 4563 -- constraint_error when not Tnn'Valid; 4564 -- in Tnn; 4565 4566 declare 4567 Loc : constant Source_Ptr := Sloc (N); 4568 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); 4569 Typ : constant Entity_Id := Etype (N); 4570 4571 begin 4572 -- Turn off the Do_Overflow_Check flag, since we are doing that work 4573 -- right here. We also set the node as analyzed to prevent infinite 4574 -- recursion from repeating the operation in the expansion. 4575 4576 Set_Do_Overflow_Check (N, False); 4577 Set_Analyzed (N, True); 4578 4579 -- Do the rewrite to include the check 4580 4581 Rewrite (N, 4582 Make_Expression_With_Actions (Loc, 4583 Actions => New_List ( 4584 Make_Object_Declaration (Loc, 4585 Defining_Identifier => Tnn, 4586 Object_Definition => New_Occurrence_Of (Typ, Loc), 4587 Constant_Present => True, 4588 Expression => Relocate_Node (N)), 4589 Make_Raise_Constraint_Error (Loc, 4590 Condition => 4591 Make_Op_Not (Loc, 4592 Right_Opnd => 4593 Make_Attribute_Reference (Loc, 4594 Prefix => New_Occurrence_Of (Tnn, Loc), 4595 Attribute_Name => Name_Valid)), 4596 Reason => CE_Overflow_Check_Failed)), 4597 Expression => New_Occurrence_Of (Tnn, Loc))); 4598 4599 Analyze_And_Resolve (N, Typ); 4600 end; 4601 end Check_Float_Op_Overflow; 4602 4603 ---------------------------------- 4604 -- Component_May_Be_Bit_Aligned -- 4605 ---------------------------------- 4606 4607 function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is 4608 UT : Entity_Id; 4609 4610 begin 4611 -- If no component clause, then everything is fine, since the back end 4612 -- never misaligns from byte boundaries by default, even if there is a 4613 -- pragma Pack for the record. 4614 4615 if No (Comp) or else No (Component_Clause (Comp)) then 4616 return False; 4617 end if; 4618 4619 UT := Underlying_Type (Etype (Comp)); 4620 4621 -- It is only array and record types that cause trouble 4622 4623 if not Is_Record_Type (UT) and then not Is_Array_Type (UT) then 4624 return False; 4625 4626 -- If we know that we have a small (64 bits or less) record or small 4627 -- bit-packed array, then everything is fine, since the back end can 4628 -- handle these cases correctly. 4629 4630 elsif Esize (Comp) <= 64 4631 and then (Is_Record_Type (UT) or else Is_Bit_Packed_Array (UT)) 4632 then 4633 return False; 4634 4635 -- Otherwise if the component is not byte aligned, we know we have the 4636 -- nasty unaligned case. 4637 4638 elsif Normalized_First_Bit (Comp) /= Uint_0 4639 or else Esize (Comp) mod System_Storage_Unit /= Uint_0 4640 then 4641 return True; 4642 4643 -- If we are large and byte aligned, then OK at this level 4644 4645 else 4646 return False; 4647 end if; 4648 end Component_May_Be_Bit_Aligned; 4649 4650 ---------------------------------------- 4651 -- Containing_Package_With_Ext_Axioms -- 4652 ---------------------------------------- 4653 4654 function Containing_Package_With_Ext_Axioms 4655 (E : Entity_Id) return Entity_Id 4656 is 4657 begin 4658 -- E is the package or generic package which is externally axiomatized 4659 4660 if Is_Package_Or_Generic_Package (E) 4661 and then Has_Annotate_Pragma_For_External_Axiomatization (E) 4662 then 4663 return E; 4664 end if; 4665 4666 -- If E's scope is axiomatized, E is axiomatized 4667 4668 if Present (Scope (E)) then 4669 declare 4670 First_Ax_Parent_Scope : constant Entity_Id := 4671 Containing_Package_With_Ext_Axioms (Scope (E)); 4672 begin 4673 if Present (First_Ax_Parent_Scope) then 4674 return First_Ax_Parent_Scope; 4675 end if; 4676 end; 4677 end if; 4678 4679 -- Otherwise, if E is a package instance, it is axiomatized if the 4680 -- corresponding generic package is axiomatized. 4681 4682 if Ekind (E) = E_Package then 4683 declare 4684 Par : constant Node_Id := Parent (E); 4685 Decl : Node_Id; 4686 4687 begin 4688 if Nkind (Par) = N_Defining_Program_Unit_Name then 4689 Decl := Parent (Par); 4690 else 4691 Decl := Par; 4692 end if; 4693 4694 if Present (Generic_Parent (Decl)) then 4695 return 4696 Containing_Package_With_Ext_Axioms (Generic_Parent (Decl)); 4697 end if; 4698 end; 4699 end if; 4700 4701 return Empty; 4702 end Containing_Package_With_Ext_Axioms; 4703 4704 ------------------------------- 4705 -- Convert_To_Actual_Subtype -- 4706 ------------------------------- 4707 4708 procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is 4709 Act_ST : Entity_Id; 4710 4711 begin 4712 Act_ST := Get_Actual_Subtype (Exp); 4713 4714 if Act_ST = Etype (Exp) then 4715 return; 4716 else 4717 Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp))); 4718 Analyze_And_Resolve (Exp, Act_ST); 4719 end if; 4720 end Convert_To_Actual_Subtype; 4721 4722 ----------------------------------- 4723 -- Corresponding_Runtime_Package -- 4724 ----------------------------------- 4725 4726 function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is 4727 function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean; 4728 -- Return True if protected type T has one entry and the maximum queue 4729 -- length is one. 4730 4731 -------------------------------- 4732 -- Has_One_Entry_And_No_Queue -- 4733 -------------------------------- 4734 4735 function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean is 4736 Item : Entity_Id; 4737 Is_First : Boolean := True; 4738 4739 begin 4740 Item := First_Entity (T); 4741 while Present (Item) loop 4742 if Is_Entry (Item) then 4743 4744 -- The protected type has more than one entry 4745 4746 if not Is_First then 4747 return False; 4748 end if; 4749 4750 -- The queue length is not one 4751 4752 if not Restriction_Active (No_Entry_Queue) 4753 and then Get_Max_Queue_Length (Item) /= Uint_1 4754 then 4755 return False; 4756 end if; 4757 4758 Is_First := False; 4759 end if; 4760 4761 Next_Entity (Item); 4762 end loop; 4763 4764 return True; 4765 end Has_One_Entry_And_No_Queue; 4766 4767 -- Local variables 4768 4769 Pkg_Id : RTU_Id := RTU_Null; 4770 4771 -- Start of processing for Corresponding_Runtime_Package 4772 4773 begin 4774 pragma Assert (Is_Concurrent_Type (Typ)); 4775 4776 if Is_Protected_Type (Typ) then 4777 if Has_Entries (Typ) 4778 4779 -- A protected type without entries that covers an interface and 4780 -- overrides the abstract routines with protected procedures is 4781 -- considered equivalent to a protected type with entries in the 4782 -- context of dispatching select statements. It is sufficient to 4783 -- check for the presence of an interface list in the declaration 4784 -- node to recognize this case. 4785 4786 or else Present (Interface_List (Parent (Typ))) 4787 4788 -- Protected types with interrupt handlers (when not using a 4789 -- restricted profile) are also considered equivalent to 4790 -- protected types with entries. The types which are used 4791 -- (Static_Interrupt_Protection and Dynamic_Interrupt_Protection) 4792 -- are derived from Protection_Entries. 4793 4794 or else (Has_Attach_Handler (Typ) and then not Restricted_Profile) 4795 or else Has_Interrupt_Handler (Typ) 4796 then 4797 if Abort_Allowed 4798 or else Restriction_Active (No_Select_Statements) = False 4799 or else not Has_One_Entry_And_No_Queue (Typ) 4800 or else (Has_Attach_Handler (Typ) 4801 and then not Restricted_Profile) 4802 then 4803 Pkg_Id := System_Tasking_Protected_Objects_Entries; 4804 else 4805 Pkg_Id := System_Tasking_Protected_Objects_Single_Entry; 4806 end if; 4807 4808 else 4809 Pkg_Id := System_Tasking_Protected_Objects; 4810 end if; 4811 end if; 4812 4813 return Pkg_Id; 4814 end Corresponding_Runtime_Package; 4815 4816 ----------------------------------- 4817 -- Current_Sem_Unit_Declarations -- 4818 ----------------------------------- 4819 4820 function Current_Sem_Unit_Declarations return List_Id is 4821 U : Node_Id := Unit (Cunit (Current_Sem_Unit)); 4822 Decls : List_Id; 4823 4824 begin 4825 -- If the current unit is a package body, locate the visible 4826 -- declarations of the package spec. 4827 4828 if Nkind (U) = N_Package_Body then 4829 U := Unit (Library_Unit (Cunit (Current_Sem_Unit))); 4830 end if; 4831 4832 if Nkind (U) = N_Package_Declaration then 4833 U := Specification (U); 4834 Decls := Visible_Declarations (U); 4835 4836 if No (Decls) then 4837 Decls := New_List; 4838 Set_Visible_Declarations (U, Decls); 4839 end if; 4840 4841 else 4842 Decls := Declarations (U); 4843 4844 if No (Decls) then 4845 Decls := New_List; 4846 Set_Declarations (U, Decls); 4847 end if; 4848 end if; 4849 4850 return Decls; 4851 end Current_Sem_Unit_Declarations; 4852 4853 ----------------------- 4854 -- Duplicate_Subexpr -- 4855 ----------------------- 4856 4857 function Duplicate_Subexpr 4858 (Exp : Node_Id; 4859 Name_Req : Boolean := False; 4860 Renaming_Req : Boolean := False) return Node_Id 4861 is 4862 begin 4863 Remove_Side_Effects (Exp, Name_Req, Renaming_Req); 4864 return New_Copy_Tree (Exp); 4865 end Duplicate_Subexpr; 4866 4867 --------------------------------- 4868 -- Duplicate_Subexpr_No_Checks -- 4869 --------------------------------- 4870 4871 function Duplicate_Subexpr_No_Checks 4872 (Exp : Node_Id; 4873 Name_Req : Boolean := False; 4874 Renaming_Req : Boolean := False; 4875 Related_Id : Entity_Id := Empty; 4876 Is_Low_Bound : Boolean := False; 4877 Is_High_Bound : Boolean := False) return Node_Id 4878 is 4879 New_Exp : Node_Id; 4880 4881 begin 4882 Remove_Side_Effects 4883 (Exp => Exp, 4884 Name_Req => Name_Req, 4885 Renaming_Req => Renaming_Req, 4886 Related_Id => Related_Id, 4887 Is_Low_Bound => Is_Low_Bound, 4888 Is_High_Bound => Is_High_Bound); 4889 4890 New_Exp := New_Copy_Tree (Exp); 4891 Remove_Checks (New_Exp); 4892 return New_Exp; 4893 end Duplicate_Subexpr_No_Checks; 4894 4895 ----------------------------------- 4896 -- Duplicate_Subexpr_Move_Checks -- 4897 ----------------------------------- 4898 4899 function Duplicate_Subexpr_Move_Checks 4900 (Exp : Node_Id; 4901 Name_Req : Boolean := False; 4902 Renaming_Req : Boolean := False) return Node_Id 4903 is 4904 New_Exp : Node_Id; 4905 4906 begin 4907 Remove_Side_Effects (Exp, Name_Req, Renaming_Req); 4908 New_Exp := New_Copy_Tree (Exp); 4909 Remove_Checks (Exp); 4910 return New_Exp; 4911 end Duplicate_Subexpr_Move_Checks; 4912 4913 ------------------------- 4914 -- Enclosing_Init_Proc -- 4915 ------------------------- 4916 4917 function Enclosing_Init_Proc return Entity_Id is 4918 S : Entity_Id; 4919 4920 begin 4921 S := Current_Scope; 4922 while Present (S) and then S /= Standard_Standard loop 4923 if Is_Init_Proc (S) then 4924 return S; 4925 else 4926 S := Scope (S); 4927 end if; 4928 end loop; 4929 4930 return Empty; 4931 end Enclosing_Init_Proc; 4932 4933 -------------------- 4934 -- Ensure_Defined -- 4935 -------------------- 4936 4937 procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is 4938 IR : Node_Id; 4939 4940 begin 4941 -- An itype reference must only be created if this is a local itype, so 4942 -- that gigi can elaborate it on the proper objstack. 4943 4944 if Is_Itype (Typ) and then Scope (Typ) = Current_Scope then 4945 IR := Make_Itype_Reference (Sloc (N)); 4946 Set_Itype (IR, Typ); 4947 Insert_Action (N, IR); 4948 end if; 4949 end Ensure_Defined; 4950 4951 -------------------- 4952 -- Entry_Names_OK -- 4953 -------------------- 4954 4955 function Entry_Names_OK return Boolean is 4956 begin 4957 return 4958 not Restricted_Profile 4959 and then not Global_Discard_Names 4960 and then not Restriction_Active (No_Implicit_Heap_Allocations) 4961 and then not Restriction_Active (No_Local_Allocators); 4962 end Entry_Names_OK; 4963 4964 ------------------- 4965 -- Evaluate_Name -- 4966 ------------------- 4967 4968 procedure Evaluate_Name (Nam : Node_Id) is 4969 begin 4970 -- For an attribute reference or an indexed component, evaluate the 4971 -- prefix, which is itself a name, recursively, and then force the 4972 -- evaluation of all the subscripts (or attribute expressions). 4973 4974 case Nkind (Nam) is 4975 when N_Attribute_Reference 4976 | N_Indexed_Component 4977 => 4978 Evaluate_Name (Prefix (Nam)); 4979 4980 declare 4981 E : Node_Id; 4982 4983 begin 4984 E := First (Expressions (Nam)); 4985 while Present (E) loop 4986 Force_Evaluation (E); 4987 4988 if Is_Rewrite_Substitution (E) then 4989 Set_Do_Range_Check 4990 (E, Do_Range_Check (Original_Node (E))); 4991 end if; 4992 4993 Next (E); 4994 end loop; 4995 end; 4996 4997 -- For an explicit dereference, we simply force the evaluation of 4998 -- the name expression. The dereference provides a value that is the 4999 -- address for the renamed object, and it is precisely this value 5000 -- that we want to preserve. 5001 5002 when N_Explicit_Dereference => 5003 Force_Evaluation (Prefix (Nam)); 5004 5005 -- For a function call, we evaluate the call 5006 5007 when N_Function_Call => 5008 Force_Evaluation (Nam); 5009 5010 -- For a qualified expression, we evaluate the underlying object 5011 -- name if any, otherwise we force the evaluation of the underlying 5012 -- expression. 5013 5014 when N_Qualified_Expression => 5015 if Is_Object_Reference (Expression (Nam)) then 5016 Evaluate_Name (Expression (Nam)); 5017 else 5018 Force_Evaluation (Expression (Nam)); 5019 end if; 5020 5021 -- For a selected component, we simply evaluate the prefix 5022 5023 when N_Selected_Component => 5024 Evaluate_Name (Prefix (Nam)); 5025 5026 -- For a slice, we evaluate the prefix, as for the indexed component 5027 -- case and then, if there is a range present, either directly or as 5028 -- the constraint of a discrete subtype indication, we evaluate the 5029 -- two bounds of this range. 5030 5031 when N_Slice => 5032 Evaluate_Name (Prefix (Nam)); 5033 Evaluate_Slice_Bounds (Nam); 5034 5035 -- For a type conversion, the expression of the conversion must be 5036 -- the name of an object, and we simply need to evaluate this name. 5037 5038 when N_Type_Conversion => 5039 Evaluate_Name (Expression (Nam)); 5040 5041 -- The remaining cases are direct name, operator symbol and character 5042 -- literal. In all these cases, we do nothing, since we want to 5043 -- reevaluate each time the renamed object is used. 5044 5045 when others => 5046 null; 5047 end case; 5048 end Evaluate_Name; 5049 5050 --------------------------- 5051 -- Evaluate_Slice_Bounds -- 5052 --------------------------- 5053 5054 procedure Evaluate_Slice_Bounds (Slice : Node_Id) is 5055 DR : constant Node_Id := Discrete_Range (Slice); 5056 Constr : Node_Id; 5057 Rexpr : Node_Id; 5058 5059 begin 5060 if Nkind (DR) = N_Range then 5061 Force_Evaluation (Low_Bound (DR)); 5062 Force_Evaluation (High_Bound (DR)); 5063 5064 elsif Nkind (DR) = N_Subtype_Indication then 5065 Constr := Constraint (DR); 5066 5067 if Nkind (Constr) = N_Range_Constraint then 5068 Rexpr := Range_Expression (Constr); 5069 5070 Force_Evaluation (Low_Bound (Rexpr)); 5071 Force_Evaluation (High_Bound (Rexpr)); 5072 end if; 5073 end if; 5074 end Evaluate_Slice_Bounds; 5075 5076 --------------------- 5077 -- Evolve_And_Then -- 5078 --------------------- 5079 5080 procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is 5081 begin 5082 if No (Cond) then 5083 Cond := Cond1; 5084 else 5085 Cond := 5086 Make_And_Then (Sloc (Cond1), 5087 Left_Opnd => Cond, 5088 Right_Opnd => Cond1); 5089 end if; 5090 end Evolve_And_Then; 5091 5092 -------------------- 5093 -- Evolve_Or_Else -- 5094 -------------------- 5095 5096 procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is 5097 begin 5098 if No (Cond) then 5099 Cond := Cond1; 5100 else 5101 Cond := 5102 Make_Or_Else (Sloc (Cond1), 5103 Left_Opnd => Cond, 5104 Right_Opnd => Cond1); 5105 end if; 5106 end Evolve_Or_Else; 5107 5108 ----------------------------------------- 5109 -- Expand_Static_Predicates_In_Choices -- 5110 ----------------------------------------- 5111 5112 procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is 5113 pragma Assert (Nkind_In (N, N_Case_Statement_Alternative, N_Variant)); 5114 5115 Choices : constant List_Id := Discrete_Choices (N); 5116 5117 Choice : Node_Id; 5118 Next_C : Node_Id; 5119 P : Node_Id; 5120 C : Node_Id; 5121 5122 begin 5123 Choice := First (Choices); 5124 while Present (Choice) loop 5125 Next_C := Next (Choice); 5126 5127 -- Check for name of subtype with static predicate 5128 5129 if Is_Entity_Name (Choice) 5130 and then Is_Type (Entity (Choice)) 5131 and then Has_Predicates (Entity (Choice)) 5132 then 5133 -- Loop through entries in predicate list, converting to choices 5134 -- and inserting in the list before the current choice. Note that 5135 -- if the list is empty, corresponding to a False predicate, then 5136 -- no choices are inserted. 5137 5138 P := First (Static_Discrete_Predicate (Entity (Choice))); 5139 while Present (P) loop 5140 5141 -- If low bound and high bounds are equal, copy simple choice 5142 5143 if Expr_Value (Low_Bound (P)) = Expr_Value (High_Bound (P)) then 5144 C := New_Copy (Low_Bound (P)); 5145 5146 -- Otherwise copy a range 5147 5148 else 5149 C := New_Copy (P); 5150 end if; 5151 5152 -- Change Sloc to referencing choice (rather than the Sloc of 5153 -- the predicate declaration element itself). 5154 5155 Set_Sloc (C, Sloc (Choice)); 5156 Insert_Before (Choice, C); 5157 Next (P); 5158 end loop; 5159 5160 -- Delete the predicated entry 5161 5162 Remove (Choice); 5163 end if; 5164 5165 -- Move to next choice to check 5166 5167 Choice := Next_C; 5168 end loop; 5169 5170 Set_Has_SP_Choice (N, False); 5171 end Expand_Static_Predicates_In_Choices; 5172 5173 ------------------------------ 5174 -- Expand_Subtype_From_Expr -- 5175 ------------------------------ 5176 5177 -- This function is applicable for both static and dynamic allocation of 5178 -- objects which are constrained by an initial expression. Basically it 5179 -- transforms an unconstrained subtype indication into a constrained one. 5180 5181 -- The expression may also be transformed in certain cases in order to 5182 -- avoid multiple evaluation. In the static allocation case, the general 5183 -- scheme is: 5184 5185 -- Val : T := Expr; 5186 5187 -- is transformed into 5188 5189 -- Val : Constrained_Subtype_Of_T := Maybe_Modified_Expr; 5190 -- 5191 -- Here are the main cases : 5192 -- 5193 -- <if Expr is a Slice> 5194 -- Val : T ([Index_Subtype (Expr)]) := Expr; 5195 -- 5196 -- <elsif Expr is a String Literal> 5197 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr; 5198 -- 5199 -- <elsif Expr is Constrained> 5200 -- subtype T is Type_Of_Expr 5201 -- Val : T := Expr; 5202 -- 5203 -- <elsif Expr is an entity_name> 5204 -- Val : T (constraints taken from Expr) := Expr; 5205 -- 5206 -- <else> 5207 -- type Axxx is access all T; 5208 -- Rval : Axxx := Expr'ref; 5209 -- Val : T (constraints taken from Rval) := Rval.all; 5210 5211 -- ??? note: when the Expression is allocated in the secondary stack 5212 -- we could use it directly instead of copying it by declaring 5213 -- Val : T (...) renames Rval.all 5214 5215 procedure Expand_Subtype_From_Expr 5216 (N : Node_Id; 5217 Unc_Type : Entity_Id; 5218 Subtype_Indic : Node_Id; 5219 Exp : Node_Id; 5220 Related_Id : Entity_Id := Empty) 5221 is 5222 Loc : constant Source_Ptr := Sloc (N); 5223 Exp_Typ : constant Entity_Id := Etype (Exp); 5224 T : Entity_Id; 5225 5226 begin 5227 -- In general we cannot build the subtype if expansion is disabled, 5228 -- because internal entities may not have been defined. However, to 5229 -- avoid some cascaded errors, we try to continue when the expression is 5230 -- an array (or string), because it is safe to compute the bounds. It is 5231 -- in fact required to do so even in a generic context, because there 5232 -- may be constants that depend on the bounds of a string literal, both 5233 -- standard string types and more generally arrays of characters. 5234 5235 -- In GNATprove mode, these extra subtypes are not needed, unless Exp is 5236 -- a static expression. In that case, the subtype will be constrained 5237 -- while the original type might be unconstrained, so expanding the type 5238 -- is necessary both for passing legality checks in GNAT and for precise 5239 -- analysis in GNATprove. 5240 5241 if GNATprove_Mode and then not Is_Static_Expression (Exp) then 5242 return; 5243 end if; 5244 5245 if not Expander_Active 5246 and then (No (Etype (Exp)) or else not Is_String_Type (Etype (Exp))) 5247 then 5248 return; 5249 end if; 5250 5251 if Nkind (Exp) = N_Slice then 5252 declare 5253 Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ)); 5254 5255 begin 5256 Rewrite (Subtype_Indic, 5257 Make_Subtype_Indication (Loc, 5258 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc), 5259 Constraint => 5260 Make_Index_Or_Discriminant_Constraint (Loc, 5261 Constraints => New_List 5262 (New_Occurrence_Of (Slice_Type, Loc))))); 5263 5264 -- This subtype indication may be used later for constraint checks 5265 -- we better make sure that if a variable was used as a bound of 5266 -- the original slice, its value is frozen. 5267 5268 Evaluate_Slice_Bounds (Exp); 5269 end; 5270 5271 elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then 5272 Rewrite (Subtype_Indic, 5273 Make_Subtype_Indication (Loc, 5274 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc), 5275 Constraint => 5276 Make_Index_Or_Discriminant_Constraint (Loc, 5277 Constraints => New_List ( 5278 Make_Literal_Range (Loc, 5279 Literal_Typ => Exp_Typ))))); 5280 5281 -- If the type of the expression is an internally generated type it 5282 -- may not be necessary to create a new subtype. However there are two 5283 -- exceptions: references to the current instances, and aliased array 5284 -- object declarations for which the back end has to create a template. 5285 5286 elsif Is_Constrained (Exp_Typ) 5287 and then not Is_Class_Wide_Type (Unc_Type) 5288 and then 5289 (Nkind (N) /= N_Object_Declaration 5290 or else not Is_Entity_Name (Expression (N)) 5291 or else not Comes_From_Source (Entity (Expression (N))) 5292 or else not Is_Array_Type (Exp_Typ) 5293 or else not Aliased_Present (N)) 5294 then 5295 if Is_Itype (Exp_Typ) then 5296 5297 -- Within an initialization procedure, a selected component 5298 -- denotes a component of the enclosing record, and it appears as 5299 -- an actual in a call to its own initialization procedure. If 5300 -- this component depends on the outer discriminant, we must 5301 -- generate the proper actual subtype for it. 5302 5303 if Nkind (Exp) = N_Selected_Component 5304 and then Within_Init_Proc 5305 then 5306 declare 5307 Decl : constant Node_Id := 5308 Build_Actual_Subtype_Of_Component (Exp_Typ, Exp); 5309 begin 5310 if Present (Decl) then 5311 Insert_Action (N, Decl); 5312 T := Defining_Identifier (Decl); 5313 else 5314 T := Exp_Typ; 5315 end if; 5316 end; 5317 5318 -- No need to generate a new subtype 5319 5320 else 5321 T := Exp_Typ; 5322 end if; 5323 5324 else 5325 T := Make_Temporary (Loc, 'T'); 5326 5327 Insert_Action (N, 5328 Make_Subtype_Declaration (Loc, 5329 Defining_Identifier => T, 5330 Subtype_Indication => New_Occurrence_Of (Exp_Typ, Loc))); 5331 5332 -- This type is marked as an itype even though it has an explicit 5333 -- declaration since otherwise Is_Generic_Actual_Type can get 5334 -- set, resulting in the generation of spurious errors. (See 5335 -- sem_ch8.Analyze_Package_Renaming and sem_type.covers) 5336 5337 Set_Is_Itype (T); 5338 Set_Associated_Node_For_Itype (T, Exp); 5339 end if; 5340 5341 Rewrite (Subtype_Indic, New_Occurrence_Of (T, Loc)); 5342 5343 -- Nothing needs to be done for private types with unknown discriminants 5344 -- if the underlying type is not an unconstrained composite type or it 5345 -- is an unchecked union. 5346 5347 elsif Is_Private_Type (Unc_Type) 5348 and then Has_Unknown_Discriminants (Unc_Type) 5349 and then (not Is_Composite_Type (Underlying_Type (Unc_Type)) 5350 or else Is_Constrained (Underlying_Type (Unc_Type)) 5351 or else Is_Unchecked_Union (Underlying_Type (Unc_Type))) 5352 then 5353 null; 5354 5355 -- Case of derived type with unknown discriminants where the parent type 5356 -- also has unknown discriminants. 5357 5358 elsif Is_Record_Type (Unc_Type) 5359 and then not Is_Class_Wide_Type (Unc_Type) 5360 and then Has_Unknown_Discriminants (Unc_Type) 5361 and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type)) 5362 then 5363 -- Nothing to be done if no underlying record view available 5364 5365 -- If this is a limited type derived from a type with unknown 5366 -- discriminants, do not expand either, so that subsequent expansion 5367 -- of the call can add build-in-place parameters to call. 5368 5369 if No (Underlying_Record_View (Unc_Type)) 5370 or else Is_Limited_Type (Unc_Type) 5371 then 5372 null; 5373 5374 -- Otherwise use the Underlying_Record_View to create the proper 5375 -- constrained subtype for an object of a derived type with unknown 5376 -- discriminants. 5377 5378 else 5379 Remove_Side_Effects (Exp); 5380 Rewrite (Subtype_Indic, 5381 Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type))); 5382 end if; 5383 5384 -- Renamings of class-wide interface types require no equivalent 5385 -- constrained type declarations because we only need to reference 5386 -- the tag component associated with the interface. The same is 5387 -- presumably true for class-wide types in general, so this test 5388 -- is broadened to include all class-wide renamings, which also 5389 -- avoids cases of unbounded recursion in Remove_Side_Effects. 5390 -- (Is this really correct, or are there some cases of class-wide 5391 -- renamings that require action in this procedure???) 5392 5393 elsif Present (N) 5394 and then Nkind (N) = N_Object_Renaming_Declaration 5395 and then Is_Class_Wide_Type (Unc_Type) 5396 then 5397 null; 5398 5399 -- In Ada 95 nothing to be done if the type of the expression is limited 5400 -- because in this case the expression cannot be copied, and its use can 5401 -- only be by reference. 5402 5403 -- In Ada 2005 the context can be an object declaration whose expression 5404 -- is a function that returns in place. If the nominal subtype has 5405 -- unknown discriminants, the call still provides constraints on the 5406 -- object, and we have to create an actual subtype from it. 5407 5408 -- If the type is class-wide, the expression is dynamically tagged and 5409 -- we do not create an actual subtype either. Ditto for an interface. 5410 -- For now this applies only if the type is immutably limited, and the 5411 -- function being called is build-in-place. This will have to be revised 5412 -- when build-in-place functions are generalized to other types. 5413 5414 elsif Is_Limited_View (Exp_Typ) 5415 and then 5416 (Is_Class_Wide_Type (Exp_Typ) 5417 or else Is_Interface (Exp_Typ) 5418 or else not Has_Unknown_Discriminants (Exp_Typ) 5419 or else not Is_Composite_Type (Unc_Type)) 5420 then 5421 null; 5422 5423 -- For limited objects initialized with build in place function calls, 5424 -- nothing to be done; otherwise we prematurely introduce an N_Reference 5425 -- node in the expression initializing the object, which breaks the 5426 -- circuitry that detects and adds the additional arguments to the 5427 -- called function. 5428 5429 elsif Is_Build_In_Place_Function_Call (Exp) then 5430 null; 5431 5432 else 5433 Remove_Side_Effects (Exp); 5434 Rewrite (Subtype_Indic, 5435 Make_Subtype_From_Expr (Exp, Unc_Type, Related_Id)); 5436 end if; 5437 end Expand_Subtype_From_Expr; 5438 5439 --------------------------------------------- 5440 -- Expression_Contains_Primitives_Calls_Of -- 5441 --------------------------------------------- 5442 5443 function Expression_Contains_Primitives_Calls_Of 5444 (Expr : Node_Id; 5445 Typ : Entity_Id) return Boolean 5446 is 5447 U_Typ : constant Entity_Id := Unique_Entity (Typ); 5448 5449 Calls_OK : Boolean := False; 5450 -- This flag is set to True when expression Expr contains at least one 5451 -- call to a nondispatching primitive function of Typ. 5452 5453 function Search_Primitive_Calls (N : Node_Id) return Traverse_Result; 5454 -- Search for nondispatching calls to primitive functions of type Typ 5455 5456 ---------------------------- 5457 -- Search_Primitive_Calls -- 5458 ---------------------------- 5459 5460 function Search_Primitive_Calls (N : Node_Id) return Traverse_Result is 5461 Disp_Typ : Entity_Id; 5462 Subp : Entity_Id; 5463 5464 begin 5465 -- Detect a function call that could denote a nondispatching 5466 -- primitive of the input type. 5467 5468 if Nkind (N) = N_Function_Call 5469 and then Is_Entity_Name (Name (N)) 5470 then 5471 Subp := Entity (Name (N)); 5472 5473 -- Do not consider function calls with a controlling argument, as 5474 -- those are always dispatching calls. 5475 5476 if Is_Dispatching_Operation (Subp) 5477 and then No (Controlling_Argument (N)) 5478 then 5479 Disp_Typ := Find_Dispatching_Type (Subp); 5480 5481 -- To qualify as a suitable primitive, the dispatching type of 5482 -- the function must be the input type. 5483 5484 if Present (Disp_Typ) 5485 and then Unique_Entity (Disp_Typ) = U_Typ 5486 then 5487 Calls_OK := True; 5488 5489 -- There is no need to continue the traversal, as one such 5490 -- call suffices. 5491 5492 return Abandon; 5493 end if; 5494 end if; 5495 end if; 5496 5497 return OK; 5498 end Search_Primitive_Calls; 5499 5500 procedure Search_Calls is new Traverse_Proc (Search_Primitive_Calls); 5501 5502 -- Start of processing for Expression_Contains_Primitives_Calls_Of_Type 5503 5504 begin 5505 Search_Calls (Expr); 5506 return Calls_OK; 5507 end Expression_Contains_Primitives_Calls_Of; 5508 5509 ---------------------- 5510 -- Finalize_Address -- 5511 ---------------------- 5512 5513 function Finalize_Address (Typ : Entity_Id) return Entity_Id is 5514 Btyp : constant Entity_Id := Base_Type (Typ); 5515 Utyp : Entity_Id := Typ; 5516 5517 begin 5518 -- Handle protected class-wide or task class-wide types 5519 5520 if Is_Class_Wide_Type (Utyp) then 5521 if Is_Concurrent_Type (Root_Type (Utyp)) then 5522 Utyp := Root_Type (Utyp); 5523 5524 elsif Is_Private_Type (Root_Type (Utyp)) 5525 and then Present (Full_View (Root_Type (Utyp))) 5526 and then Is_Concurrent_Type (Full_View (Root_Type (Utyp))) 5527 then 5528 Utyp := Full_View (Root_Type (Utyp)); 5529 end if; 5530 end if; 5531 5532 -- Handle private types 5533 5534 if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then 5535 Utyp := Full_View (Utyp); 5536 end if; 5537 5538 -- Handle protected and task types 5539 5540 if Is_Concurrent_Type (Utyp) 5541 and then Present (Corresponding_Record_Type (Utyp)) 5542 then 5543 Utyp := Corresponding_Record_Type (Utyp); 5544 end if; 5545 5546 Utyp := Underlying_Type (Base_Type (Utyp)); 5547 5548 -- Deal with untagged derivation of private views. If the parent is 5549 -- now known to be protected, the finalization routine is the one 5550 -- defined on the corresponding record of the ancestor (corresponding 5551 -- records do not automatically inherit operations, but maybe they 5552 -- should???) 5553 5554 if Is_Untagged_Derivation (Btyp) then 5555 if Is_Protected_Type (Btyp) then 5556 Utyp := Corresponding_Record_Type (Root_Type (Btyp)); 5557 5558 else 5559 Utyp := Underlying_Type (Root_Type (Btyp)); 5560 5561 if Is_Protected_Type (Utyp) then 5562 Utyp := Corresponding_Record_Type (Utyp); 5563 end if; 5564 end if; 5565 end if; 5566 5567 -- If the underlying_type is a subtype, we are dealing with the 5568 -- completion of a private type. We need to access the base type and 5569 -- generate a conversion to it. 5570 5571 if Utyp /= Base_Type (Utyp) then 5572 pragma Assert (Is_Private_Type (Typ)); 5573 5574 Utyp := Base_Type (Utyp); 5575 end if; 5576 5577 -- When dealing with an internally built full view for a type with 5578 -- unknown discriminants, use the original record type. 5579 5580 if Is_Underlying_Record_View (Utyp) then 5581 Utyp := Etype (Utyp); 5582 end if; 5583 5584 return TSS (Utyp, TSS_Finalize_Address); 5585 end Finalize_Address; 5586 5587 ------------------------ 5588 -- Find_Interface_ADT -- 5589 ------------------------ 5590 5591 function Find_Interface_ADT 5592 (T : Entity_Id; 5593 Iface : Entity_Id) return Elmt_Id 5594 is 5595 ADT : Elmt_Id; 5596 Typ : Entity_Id := T; 5597 5598 begin 5599 pragma Assert (Is_Interface (Iface)); 5600 5601 -- Handle private types 5602 5603 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then 5604 Typ := Full_View (Typ); 5605 end if; 5606 5607 -- Handle access types 5608 5609 if Is_Access_Type (Typ) then 5610 Typ := Designated_Type (Typ); 5611 end if; 5612 5613 -- Handle task and protected types implementing interfaces 5614 5615 if Is_Concurrent_Type (Typ) then 5616 Typ := Corresponding_Record_Type (Typ); 5617 end if; 5618 5619 pragma Assert 5620 (not Is_Class_Wide_Type (Typ) 5621 and then Ekind (Typ) /= E_Incomplete_Type); 5622 5623 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then 5624 return First_Elmt (Access_Disp_Table (Typ)); 5625 5626 else 5627 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); 5628 while Present (ADT) 5629 and then Present (Related_Type (Node (ADT))) 5630 and then Related_Type (Node (ADT)) /= Iface 5631 and then not Is_Ancestor (Iface, Related_Type (Node (ADT)), 5632 Use_Full_View => True) 5633 loop 5634 Next_Elmt (ADT); 5635 end loop; 5636 5637 pragma Assert (Present (Related_Type (Node (ADT)))); 5638 return ADT; 5639 end if; 5640 end Find_Interface_ADT; 5641 5642 ------------------------ 5643 -- Find_Interface_Tag -- 5644 ------------------------ 5645 5646 function Find_Interface_Tag 5647 (T : Entity_Id; 5648 Iface : Entity_Id) return Entity_Id 5649 is 5650 AI_Tag : Entity_Id := Empty; 5651 Found : Boolean := False; 5652 Typ : Entity_Id := T; 5653 5654 procedure Find_Tag (Typ : Entity_Id); 5655 -- Internal subprogram used to recursively climb to the ancestors 5656 5657 -------------- 5658 -- Find_Tag -- 5659 -------------- 5660 5661 procedure Find_Tag (Typ : Entity_Id) is 5662 AI_Elmt : Elmt_Id; 5663 AI : Node_Id; 5664 5665 begin 5666 -- This routine does not handle the case in which the interface is an 5667 -- ancestor of Typ. That case is handled by the enclosing subprogram. 5668 5669 pragma Assert (Typ /= Iface); 5670 5671 -- Climb to the root type handling private types 5672 5673 if Present (Full_View (Etype (Typ))) then 5674 if Full_View (Etype (Typ)) /= Typ then 5675 Find_Tag (Full_View (Etype (Typ))); 5676 end if; 5677 5678 elsif Etype (Typ) /= Typ then 5679 Find_Tag (Etype (Typ)); 5680 end if; 5681 5682 -- Traverse the list of interfaces implemented by the type 5683 5684 if not Found 5685 and then Present (Interfaces (Typ)) 5686 and then not (Is_Empty_Elmt_List (Interfaces (Typ))) 5687 then 5688 -- Skip the tag associated with the primary table 5689 5690 AI_Tag := Next_Tag_Component (First_Tag_Component (Typ)); 5691 pragma Assert (Present (AI_Tag)); 5692 5693 AI_Elmt := First_Elmt (Interfaces (Typ)); 5694 while Present (AI_Elmt) loop 5695 AI := Node (AI_Elmt); 5696 5697 if AI = Iface 5698 or else Is_Ancestor (Iface, AI, Use_Full_View => True) 5699 then 5700 Found := True; 5701 return; 5702 end if; 5703 5704 AI_Tag := Next_Tag_Component (AI_Tag); 5705 Next_Elmt (AI_Elmt); 5706 end loop; 5707 end if; 5708 end Find_Tag; 5709 5710 -- Start of processing for Find_Interface_Tag 5711 5712 begin 5713 pragma Assert (Is_Interface (Iface)); 5714 5715 -- Handle access types 5716 5717 if Is_Access_Type (Typ) then 5718 Typ := Designated_Type (Typ); 5719 end if; 5720 5721 -- Handle class-wide types 5722 5723 if Is_Class_Wide_Type (Typ) then 5724 Typ := Root_Type (Typ); 5725 end if; 5726 5727 -- Handle private types 5728 5729 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then 5730 Typ := Full_View (Typ); 5731 end if; 5732 5733 -- Handle entities from the limited view 5734 5735 if Ekind (Typ) = E_Incomplete_Type then 5736 pragma Assert (Present (Non_Limited_View (Typ))); 5737 Typ := Non_Limited_View (Typ); 5738 end if; 5739 5740 -- Handle task and protected types implementing interfaces 5741 5742 if Is_Concurrent_Type (Typ) then 5743 Typ := Corresponding_Record_Type (Typ); 5744 end if; 5745 5746 -- If the interface is an ancestor of the type, then it shared the 5747 -- primary dispatch table. 5748 5749 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then 5750 return First_Tag_Component (Typ); 5751 5752 -- Otherwise we need to search for its associated tag component 5753 5754 else 5755 Find_Tag (Typ); 5756 return AI_Tag; 5757 end if; 5758 end Find_Interface_Tag; 5759 5760 --------------------------- 5761 -- Find_Optional_Prim_Op -- 5762 --------------------------- 5763 5764 function Find_Optional_Prim_Op 5765 (T : Entity_Id; Name : Name_Id) return Entity_Id 5766 is 5767 Prim : Elmt_Id; 5768 Typ : Entity_Id := T; 5769 Op : Entity_Id; 5770 5771 begin 5772 if Is_Class_Wide_Type (Typ) then 5773 Typ := Root_Type (Typ); 5774 end if; 5775 5776 Typ := Underlying_Type (Typ); 5777 5778 -- Loop through primitive operations 5779 5780 Prim := First_Elmt (Primitive_Operations (Typ)); 5781 while Present (Prim) loop 5782 Op := Node (Prim); 5783 5784 -- We can retrieve primitive operations by name if it is an internal 5785 -- name. For equality we must check that both of its operands have 5786 -- the same type, to avoid confusion with user-defined equalities 5787 -- than may have a asymmetric signature. 5788 5789 exit when Chars (Op) = Name 5790 and then 5791 (Name /= Name_Op_Eq 5792 or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op))); 5793 5794 Next_Elmt (Prim); 5795 end loop; 5796 5797 return Node (Prim); -- Empty if not found 5798 end Find_Optional_Prim_Op; 5799 5800 --------------------------- 5801 -- Find_Optional_Prim_Op -- 5802 --------------------------- 5803 5804 function Find_Optional_Prim_Op 5805 (T : Entity_Id; 5806 Name : TSS_Name_Type) return Entity_Id 5807 is 5808 Inher_Op : Entity_Id := Empty; 5809 Own_Op : Entity_Id := Empty; 5810 Prim_Elmt : Elmt_Id; 5811 Prim_Id : Entity_Id; 5812 Typ : Entity_Id := T; 5813 5814 begin 5815 if Is_Class_Wide_Type (Typ) then 5816 Typ := Root_Type (Typ); 5817 end if; 5818 5819 Typ := Underlying_Type (Typ); 5820 5821 -- This search is based on the assertion that the dispatching version 5822 -- of the TSS routine always precedes the real primitive. 5823 5824 Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); 5825 while Present (Prim_Elmt) loop 5826 Prim_Id := Node (Prim_Elmt); 5827 5828 if Is_TSS (Prim_Id, Name) then 5829 if Present (Alias (Prim_Id)) then 5830 Inher_Op := Prim_Id; 5831 else 5832 Own_Op := Prim_Id; 5833 end if; 5834 end if; 5835 5836 Next_Elmt (Prim_Elmt); 5837 end loop; 5838 5839 if Present (Own_Op) then 5840 return Own_Op; 5841 elsif Present (Inher_Op) then 5842 return Inher_Op; 5843 else 5844 return Empty; 5845 end if; 5846 end Find_Optional_Prim_Op; 5847 5848 ------------------ 5849 -- Find_Prim_Op -- 5850 ------------------ 5851 5852 function Find_Prim_Op 5853 (T : Entity_Id; Name : Name_Id) return Entity_Id 5854 is 5855 Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name); 5856 begin 5857 if No (Result) then 5858 raise Program_Error; 5859 end if; 5860 5861 return Result; 5862 end Find_Prim_Op; 5863 5864 ------------------ 5865 -- Find_Prim_Op -- 5866 ------------------ 5867 5868 function Find_Prim_Op 5869 (T : Entity_Id; 5870 Name : TSS_Name_Type) return Entity_Id 5871 is 5872 Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name); 5873 begin 5874 if No (Result) then 5875 raise Program_Error; 5876 end if; 5877 5878 return Result; 5879 end Find_Prim_Op; 5880 5881 ---------------------------- 5882 -- Find_Protection_Object -- 5883 ---------------------------- 5884 5885 function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is 5886 S : Entity_Id; 5887 5888 begin 5889 S := Scop; 5890 while Present (S) loop 5891 if Ekind_In (S, E_Entry, E_Entry_Family, E_Function, E_Procedure) 5892 and then Present (Protection_Object (S)) 5893 then 5894 return Protection_Object (S); 5895 end if; 5896 5897 S := Scope (S); 5898 end loop; 5899 5900 -- If we do not find a Protection object in the scope chain, then 5901 -- something has gone wrong, most likely the object was never created. 5902 5903 raise Program_Error; 5904 end Find_Protection_Object; 5905 5906 -------------------------- 5907 -- Find_Protection_Type -- 5908 -------------------------- 5909 5910 function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is 5911 Comp : Entity_Id; 5912 Typ : Entity_Id := Conc_Typ; 5913 5914 begin 5915 if Is_Concurrent_Type (Typ) then 5916 Typ := Corresponding_Record_Type (Typ); 5917 end if; 5918 5919 -- Since restriction violations are not considered serious errors, the 5920 -- expander remains active, but may leave the corresponding record type 5921 -- malformed. In such cases, component _object is not available so do 5922 -- not look for it. 5923 5924 if not Analyzed (Typ) then 5925 return Empty; 5926 end if; 5927 5928 Comp := First_Component (Typ); 5929 while Present (Comp) loop 5930 if Chars (Comp) = Name_uObject then 5931 return Base_Type (Etype (Comp)); 5932 end if; 5933 5934 Next_Component (Comp); 5935 end loop; 5936 5937 -- The corresponding record of a protected type should always have an 5938 -- _object field. 5939 5940 raise Program_Error; 5941 end Find_Protection_Type; 5942 5943 ----------------------- 5944 -- Find_Hook_Context -- 5945 ----------------------- 5946 5947 function Find_Hook_Context (N : Node_Id) return Node_Id is 5948 Par : Node_Id; 5949 Top : Node_Id; 5950 5951 Wrapped_Node : Node_Id; 5952 -- Note: if we are in a transient scope, we want to reuse it as 5953 -- the context for actions insertion, if possible. But if N is itself 5954 -- part of the stored actions for the current transient scope, 5955 -- then we need to insert at the appropriate (inner) location in 5956 -- the not as an action on Node_To_Be_Wrapped. 5957 5958 In_Cond_Expr : constant Boolean := Within_Case_Or_If_Expression (N); 5959 5960 begin 5961 -- When the node is inside a case/if expression, the lifetime of any 5962 -- temporary controlled object is extended. Find a suitable insertion 5963 -- node by locating the topmost case or if expressions. 5964 5965 if In_Cond_Expr then 5966 Par := N; 5967 Top := N; 5968 while Present (Par) loop 5969 if Nkind_In (Original_Node (Par), N_Case_Expression, 5970 N_If_Expression) 5971 then 5972 Top := Par; 5973 5974 -- Prevent the search from going too far 5975 5976 elsif Is_Body_Or_Package_Declaration (Par) then 5977 exit; 5978 end if; 5979 5980 Par := Parent (Par); 5981 end loop; 5982 5983 -- The topmost case or if expression is now recovered, but it may 5984 -- still not be the correct place to add generated code. Climb to 5985 -- find a parent that is part of a declarative or statement list, 5986 -- and is not a list of actuals in a call. 5987 5988 Par := Top; 5989 while Present (Par) loop 5990 if Is_List_Member (Par) 5991 and then not Nkind_In (Par, N_Component_Association, 5992 N_Discriminant_Association, 5993 N_Parameter_Association, 5994 N_Pragma_Argument_Association) 5995 and then not Nkind_In (Parent (Par), N_Function_Call, 5996 N_Procedure_Call_Statement, 5997 N_Entry_Call_Statement) 5998 5999 then 6000 return Par; 6001 6002 -- Prevent the search from going too far 6003 6004 elsif Is_Body_Or_Package_Declaration (Par) then 6005 exit; 6006 end if; 6007 6008 Par := Parent (Par); 6009 end loop; 6010 6011 return Par; 6012 6013 else 6014 Par := N; 6015 while Present (Par) loop 6016 6017 -- Keep climbing past various operators 6018 6019 if Nkind (Parent (Par)) in N_Op 6020 or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else) 6021 then 6022 Par := Parent (Par); 6023 else 6024 exit; 6025 end if; 6026 end loop; 6027 6028 Top := Par; 6029 6030 -- The node may be located in a pragma in which case return the 6031 -- pragma itself: 6032 6033 -- pragma Precondition (... and then Ctrl_Func_Call ...); 6034 6035 -- Similar case occurs when the node is related to an object 6036 -- declaration or assignment: 6037 6038 -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...; 6039 6040 -- Another case to consider is when the node is part of a return 6041 -- statement: 6042 6043 -- return ... and then Ctrl_Func_Call ...; 6044 6045 -- Another case is when the node acts as a formal in a procedure 6046 -- call statement: 6047 6048 -- Proc (... and then Ctrl_Func_Call ...); 6049 6050 if Scope_Is_Transient then 6051 Wrapped_Node := Node_To_Be_Wrapped; 6052 else 6053 Wrapped_Node := Empty; 6054 end if; 6055 6056 while Present (Par) loop 6057 if Par = Wrapped_Node 6058 or else Nkind_In (Par, N_Assignment_Statement, 6059 N_Object_Declaration, 6060 N_Pragma, 6061 N_Procedure_Call_Statement, 6062 N_Simple_Return_Statement) 6063 then 6064 return Par; 6065 6066 -- Prevent the search from going too far 6067 6068 elsif Is_Body_Or_Package_Declaration (Par) then 6069 exit; 6070 end if; 6071 6072 Par := Parent (Par); 6073 end loop; 6074 6075 -- Return the topmost short circuit operator 6076 6077 return Top; 6078 end if; 6079 end Find_Hook_Context; 6080 6081 ------------------------------ 6082 -- Following_Address_Clause -- 6083 ------------------------------ 6084 6085 function Following_Address_Clause (D : Node_Id) return Node_Id is 6086 Id : constant Entity_Id := Defining_Identifier (D); 6087 Result : Node_Id; 6088 Par : Node_Id; 6089 6090 function Check_Decls (D : Node_Id) return Node_Id; 6091 -- This internal function differs from the main function in that it 6092 -- gets called to deal with a following package private part, and 6093 -- it checks declarations starting with D (the main function checks 6094 -- declarations following D). If D is Empty, then Empty is returned. 6095 6096 ----------------- 6097 -- Check_Decls -- 6098 ----------------- 6099 6100 function Check_Decls (D : Node_Id) return Node_Id is 6101 Decl : Node_Id; 6102 6103 begin 6104 Decl := D; 6105 while Present (Decl) loop 6106 if Nkind (Decl) = N_At_Clause 6107 and then Chars (Identifier (Decl)) = Chars (Id) 6108 then 6109 return Decl; 6110 6111 elsif Nkind (Decl) = N_Attribute_Definition_Clause 6112 and then Chars (Decl) = Name_Address 6113 and then Chars (Name (Decl)) = Chars (Id) 6114 then 6115 return Decl; 6116 end if; 6117 6118 Next (Decl); 6119 end loop; 6120 6121 -- Otherwise not found, return Empty 6122 6123 return Empty; 6124 end Check_Decls; 6125 6126 -- Start of processing for Following_Address_Clause 6127 6128 begin 6129 -- If parser detected no address clause for the identifier in question, 6130 -- then the answer is a quick NO, without the need for a search. 6131 6132 if not Get_Name_Table_Boolean1 (Chars (Id)) then 6133 return Empty; 6134 end if; 6135 6136 -- Otherwise search current declarative unit 6137 6138 Result := Check_Decls (Next (D)); 6139 6140 if Present (Result) then 6141 return Result; 6142 end if; 6143 6144 -- Check for possible package private part following 6145 6146 Par := Parent (D); 6147 6148 if Nkind (Par) = N_Package_Specification 6149 and then Visible_Declarations (Par) = List_Containing (D) 6150 and then Present (Private_Declarations (Par)) 6151 then 6152 -- Private part present, check declarations there 6153 6154 return Check_Decls (First (Private_Declarations (Par))); 6155 6156 else 6157 -- No private part, clause not found, return Empty 6158 6159 return Empty; 6160 end if; 6161 end Following_Address_Clause; 6162 6163 ---------------------- 6164 -- Force_Evaluation -- 6165 ---------------------- 6166 6167 procedure Force_Evaluation 6168 (Exp : Node_Id; 6169 Name_Req : Boolean := False; 6170 Related_Id : Entity_Id := Empty; 6171 Is_Low_Bound : Boolean := False; 6172 Is_High_Bound : Boolean := False; 6173 Mode : Force_Evaluation_Mode := Relaxed) 6174 is 6175 begin 6176 Remove_Side_Effects 6177 (Exp => Exp, 6178 Name_Req => Name_Req, 6179 Variable_Ref => True, 6180 Renaming_Req => False, 6181 Related_Id => Related_Id, 6182 Is_Low_Bound => Is_Low_Bound, 6183 Is_High_Bound => Is_High_Bound, 6184 Check_Side_Effects => 6185 Is_Static_Expression (Exp) 6186 or else Mode = Relaxed); 6187 end Force_Evaluation; 6188 6189 --------------------------------- 6190 -- Fully_Qualified_Name_String -- 6191 --------------------------------- 6192 6193 function Fully_Qualified_Name_String 6194 (E : Entity_Id; 6195 Append_NUL : Boolean := True) return String_Id 6196 is 6197 procedure Internal_Full_Qualified_Name (E : Entity_Id); 6198 -- Compute recursively the qualified name without NUL at the end, adding 6199 -- it to the currently started string being generated 6200 6201 ---------------------------------- 6202 -- Internal_Full_Qualified_Name -- 6203 ---------------------------------- 6204 6205 procedure Internal_Full_Qualified_Name (E : Entity_Id) is 6206 Ent : Entity_Id; 6207 6208 begin 6209 -- Deal properly with child units 6210 6211 if Nkind (E) = N_Defining_Program_Unit_Name then 6212 Ent := Defining_Identifier (E); 6213 else 6214 Ent := E; 6215 end if; 6216 6217 -- Compute qualification recursively (only "Standard" has no scope) 6218 6219 if Present (Scope (Scope (Ent))) then 6220 Internal_Full_Qualified_Name (Scope (Ent)); 6221 Store_String_Char (Get_Char_Code ('.')); 6222 end if; 6223 6224 -- Every entity should have a name except some expanded blocks 6225 -- don't bother about those. 6226 6227 if Chars (Ent) = No_Name then 6228 return; 6229 end if; 6230 6231 -- Generates the entity name in upper case 6232 6233 Get_Decoded_Name_String (Chars (Ent)); 6234 Set_All_Upper_Case; 6235 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 6236 return; 6237 end Internal_Full_Qualified_Name; 6238 6239 -- Start of processing for Full_Qualified_Name 6240 6241 begin 6242 Start_String; 6243 Internal_Full_Qualified_Name (E); 6244 6245 if Append_NUL then 6246 Store_String_Char (Get_Char_Code (ASCII.NUL)); 6247 end if; 6248 6249 return End_String; 6250 end Fully_Qualified_Name_String; 6251 6252 ------------------------ 6253 -- Generate_Poll_Call -- 6254 ------------------------ 6255 6256 procedure Generate_Poll_Call (N : Node_Id) is 6257 begin 6258 -- No poll call if polling not active 6259 6260 if not Polling_Required then 6261 return; 6262 6263 -- Otherwise generate require poll call 6264 6265 else 6266 Insert_Before_And_Analyze (N, 6267 Make_Procedure_Call_Statement (Sloc (N), 6268 Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N)))); 6269 end if; 6270 end Generate_Poll_Call; 6271 6272 --------------------------------- 6273 -- Get_Current_Value_Condition -- 6274 --------------------------------- 6275 6276 -- Note: the implementation of this procedure is very closely tied to the 6277 -- implementation of Set_Current_Value_Condition. In the Get procedure, we 6278 -- interpret Current_Value fields set by the Set procedure, so the two 6279 -- procedures need to be closely coordinated. 6280 6281 procedure Get_Current_Value_Condition 6282 (Var : Node_Id; 6283 Op : out Node_Kind; 6284 Val : out Node_Id) 6285 is 6286 Loc : constant Source_Ptr := Sloc (Var); 6287 Ent : constant Entity_Id := Entity (Var); 6288 6289 procedure Process_Current_Value_Condition 6290 (N : Node_Id; 6291 S : Boolean); 6292 -- N is an expression which holds either True (S = True) or False (S = 6293 -- False) in the condition. This procedure digs out the expression and 6294 -- if it refers to Ent, sets Op and Val appropriately. 6295 6296 ------------------------------------- 6297 -- Process_Current_Value_Condition -- 6298 ------------------------------------- 6299 6300 procedure Process_Current_Value_Condition 6301 (N : Node_Id; 6302 S : Boolean) 6303 is 6304 Cond : Node_Id; 6305 Prev_Cond : Node_Id; 6306 Sens : Boolean; 6307 6308 begin 6309 Cond := N; 6310 Sens := S; 6311 6312 loop 6313 Prev_Cond := Cond; 6314 6315 -- Deal with NOT operators, inverting sense 6316 6317 while Nkind (Cond) = N_Op_Not loop 6318 Cond := Right_Opnd (Cond); 6319 Sens := not Sens; 6320 end loop; 6321 6322 -- Deal with conversions, qualifications, and expressions with 6323 -- actions. 6324 6325 while Nkind_In (Cond, 6326 N_Type_Conversion, 6327 N_Qualified_Expression, 6328 N_Expression_With_Actions) 6329 loop 6330 Cond := Expression (Cond); 6331 end loop; 6332 6333 exit when Cond = Prev_Cond; 6334 end loop; 6335 6336 -- Deal with AND THEN and AND cases 6337 6338 if Nkind_In (Cond, N_And_Then, N_Op_And) then 6339 6340 -- Don't ever try to invert a condition that is of the form of an 6341 -- AND or AND THEN (since we are not doing sufficiently general 6342 -- processing to allow this). 6343 6344 if Sens = False then 6345 Op := N_Empty; 6346 Val := Empty; 6347 return; 6348 end if; 6349 6350 -- Recursively process AND and AND THEN branches 6351 6352 Process_Current_Value_Condition (Left_Opnd (Cond), True); 6353 6354 if Op /= N_Empty then 6355 return; 6356 end if; 6357 6358 Process_Current_Value_Condition (Right_Opnd (Cond), True); 6359 return; 6360 6361 -- Case of relational operator 6362 6363 elsif Nkind (Cond) in N_Op_Compare then 6364 Op := Nkind (Cond); 6365 6366 -- Invert sense of test if inverted test 6367 6368 if Sens = False then 6369 case Op is 6370 when N_Op_Eq => Op := N_Op_Ne; 6371 when N_Op_Ne => Op := N_Op_Eq; 6372 when N_Op_Lt => Op := N_Op_Ge; 6373 when N_Op_Gt => Op := N_Op_Le; 6374 when N_Op_Le => Op := N_Op_Gt; 6375 when N_Op_Ge => Op := N_Op_Lt; 6376 when others => raise Program_Error; 6377 end case; 6378 end if; 6379 6380 -- Case of entity op value 6381 6382 if Is_Entity_Name (Left_Opnd (Cond)) 6383 and then Ent = Entity (Left_Opnd (Cond)) 6384 and then Compile_Time_Known_Value (Right_Opnd (Cond)) 6385 then 6386 Val := Right_Opnd (Cond); 6387 6388 -- Case of value op entity 6389 6390 elsif Is_Entity_Name (Right_Opnd (Cond)) 6391 and then Ent = Entity (Right_Opnd (Cond)) 6392 and then Compile_Time_Known_Value (Left_Opnd (Cond)) 6393 then 6394 Val := Left_Opnd (Cond); 6395 6396 -- We are effectively swapping operands 6397 6398 case Op is 6399 when N_Op_Eq => null; 6400 when N_Op_Ne => null; 6401 when N_Op_Lt => Op := N_Op_Gt; 6402 when N_Op_Gt => Op := N_Op_Lt; 6403 when N_Op_Le => Op := N_Op_Ge; 6404 when N_Op_Ge => Op := N_Op_Le; 6405 when others => raise Program_Error; 6406 end case; 6407 6408 else 6409 Op := N_Empty; 6410 end if; 6411 6412 return; 6413 6414 elsif Nkind_In (Cond, 6415 N_Type_Conversion, 6416 N_Qualified_Expression, 6417 N_Expression_With_Actions) 6418 then 6419 Cond := Expression (Cond); 6420 6421 -- Case of Boolean variable reference, return as though the 6422 -- reference had said var = True. 6423 6424 else 6425 if Is_Entity_Name (Cond) and then Ent = Entity (Cond) then 6426 Val := New_Occurrence_Of (Standard_True, Sloc (Cond)); 6427 6428 if Sens = False then 6429 Op := N_Op_Ne; 6430 else 6431 Op := N_Op_Eq; 6432 end if; 6433 end if; 6434 end if; 6435 end Process_Current_Value_Condition; 6436 6437 -- Start of processing for Get_Current_Value_Condition 6438 6439 begin 6440 Op := N_Empty; 6441 Val := Empty; 6442 6443 -- Immediate return, nothing doing, if this is not an object 6444 6445 if Ekind (Ent) not in Object_Kind then 6446 return; 6447 end if; 6448 6449 -- Otherwise examine current value 6450 6451 declare 6452 CV : constant Node_Id := Current_Value (Ent); 6453 Sens : Boolean; 6454 Stm : Node_Id; 6455 6456 begin 6457 -- If statement. Condition is known true in THEN section, known False 6458 -- in any ELSIF or ELSE part, and unknown outside the IF statement. 6459 6460 if Nkind (CV) = N_If_Statement then 6461 6462 -- Before start of IF statement 6463 6464 if Loc < Sloc (CV) then 6465 return; 6466 6467 -- After end of IF statement 6468 6469 elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then 6470 return; 6471 end if; 6472 6473 -- At this stage we know that we are within the IF statement, but 6474 -- unfortunately, the tree does not record the SLOC of the ELSE so 6475 -- we cannot use a simple SLOC comparison to distinguish between 6476 -- the then/else statements, so we have to climb the tree. 6477 6478 declare 6479 N : Node_Id; 6480 6481 begin 6482 N := Parent (Var); 6483 while Parent (N) /= CV loop 6484 N := Parent (N); 6485 6486 -- If we fall off the top of the tree, then that's odd, but 6487 -- perhaps it could occur in some error situation, and the 6488 -- safest response is simply to assume that the outcome of 6489 -- the condition is unknown. No point in bombing during an 6490 -- attempt to optimize things. 6491 6492 if No (N) then 6493 return; 6494 end if; 6495 end loop; 6496 6497 -- Now we have N pointing to a node whose parent is the IF 6498 -- statement in question, so now we can tell if we are within 6499 -- the THEN statements. 6500 6501 if Is_List_Member (N) 6502 and then List_Containing (N) = Then_Statements (CV) 6503 then 6504 Sens := True; 6505 6506 -- If the variable reference does not come from source, we 6507 -- cannot reliably tell whether it appears in the else part. 6508 -- In particular, if it appears in generated code for a node 6509 -- that requires finalization, it may be attached to a list 6510 -- that has not been yet inserted into the code. For now, 6511 -- treat it as unknown. 6512 6513 elsif not Comes_From_Source (N) then 6514 return; 6515 6516 -- Otherwise we must be in ELSIF or ELSE part 6517 6518 else 6519 Sens := False; 6520 end if; 6521 end; 6522 6523 -- ELSIF part. Condition is known true within the referenced 6524 -- ELSIF, known False in any subsequent ELSIF or ELSE part, 6525 -- and unknown before the ELSE part or after the IF statement. 6526 6527 elsif Nkind (CV) = N_Elsif_Part then 6528 6529 -- if the Elsif_Part had condition_actions, the elsif has been 6530 -- rewritten as a nested if, and the original elsif_part is 6531 -- detached from the tree, so there is no way to obtain useful 6532 -- information on the current value of the variable. 6533 -- Can this be improved ??? 6534 6535 if No (Parent (CV)) then 6536 return; 6537 end if; 6538 6539 Stm := Parent (CV); 6540 6541 -- If the tree has been otherwise rewritten there is nothing 6542 -- else to be done either. 6543 6544 if Nkind (Stm) /= N_If_Statement then 6545 return; 6546 end if; 6547 6548 -- Before start of ELSIF part 6549 6550 if Loc < Sloc (CV) then 6551 return; 6552 6553 -- After end of IF statement 6554 6555 elsif Loc >= Sloc (Stm) + 6556 Text_Ptr (UI_To_Int (End_Span (Stm))) 6557 then 6558 return; 6559 end if; 6560 6561 -- Again we lack the SLOC of the ELSE, so we need to climb the 6562 -- tree to see if we are within the ELSIF part in question. 6563 6564 declare 6565 N : Node_Id; 6566 6567 begin 6568 N := Parent (Var); 6569 while Parent (N) /= Stm loop 6570 N := Parent (N); 6571 6572 -- If we fall off the top of the tree, then that's odd, but 6573 -- perhaps it could occur in some error situation, and the 6574 -- safest response is simply to assume that the outcome of 6575 -- the condition is unknown. No point in bombing during an 6576 -- attempt to optimize things. 6577 6578 if No (N) then 6579 return; 6580 end if; 6581 end loop; 6582 6583 -- Now we have N pointing to a node whose parent is the IF 6584 -- statement in question, so see if is the ELSIF part we want. 6585 -- the THEN statements. 6586 6587 if N = CV then 6588 Sens := True; 6589 6590 -- Otherwise we must be in subsequent ELSIF or ELSE part 6591 6592 else 6593 Sens := False; 6594 end if; 6595 end; 6596 6597 -- Iteration scheme of while loop. The condition is known to be 6598 -- true within the body of the loop. 6599 6600 elsif Nkind (CV) = N_Iteration_Scheme then 6601 declare 6602 Loop_Stmt : constant Node_Id := Parent (CV); 6603 6604 begin 6605 -- Before start of body of loop 6606 6607 if Loc < Sloc (Loop_Stmt) then 6608 return; 6609 6610 -- After end of LOOP statement 6611 6612 elsif Loc >= Sloc (End_Label (Loop_Stmt)) then 6613 return; 6614 6615 -- We are within the body of the loop 6616 6617 else 6618 Sens := True; 6619 end if; 6620 end; 6621 6622 -- All other cases of Current_Value settings 6623 6624 else 6625 return; 6626 end if; 6627 6628 -- If we fall through here, then we have a reportable condition, Sens 6629 -- is True if the condition is true and False if it needs inverting. 6630 6631 Process_Current_Value_Condition (Condition (CV), Sens); 6632 end; 6633 end Get_Current_Value_Condition; 6634 6635 --------------------- 6636 -- Get_Stream_Size -- 6637 --------------------- 6638 6639 function Get_Stream_Size (E : Entity_Id) return Uint is 6640 begin 6641 -- If we have a Stream_Size clause for this type use it 6642 6643 if Has_Stream_Size_Clause (E) then 6644 return Static_Integer (Expression (Stream_Size_Clause (E))); 6645 6646 -- Otherwise the Stream_Size if the size of the type 6647 6648 else 6649 return Esize (E); 6650 end if; 6651 end Get_Stream_Size; 6652 6653 --------------------------- 6654 -- Has_Access_Constraint -- 6655 --------------------------- 6656 6657 function Has_Access_Constraint (E : Entity_Id) return Boolean is 6658 Disc : Entity_Id; 6659 T : constant Entity_Id := Etype (E); 6660 6661 begin 6662 if Has_Per_Object_Constraint (E) and then Has_Discriminants (T) then 6663 Disc := First_Discriminant (T); 6664 while Present (Disc) loop 6665 if Is_Access_Type (Etype (Disc)) then 6666 return True; 6667 end if; 6668 6669 Next_Discriminant (Disc); 6670 end loop; 6671 6672 return False; 6673 else 6674 return False; 6675 end if; 6676 end Has_Access_Constraint; 6677 6678 ----------------------------------------------------- 6679 -- Has_Annotate_Pragma_For_External_Axiomatization -- 6680 ----------------------------------------------------- 6681 6682 function Has_Annotate_Pragma_For_External_Axiomatization 6683 (E : Entity_Id) return Boolean 6684 is 6685 function Is_Annotate_Pragma_For_External_Axiomatization 6686 (N : Node_Id) return Boolean; 6687 -- Returns whether N is 6688 -- pragma Annotate (GNATprove, External_Axiomatization); 6689 6690 ---------------------------------------------------- 6691 -- Is_Annotate_Pragma_For_External_Axiomatization -- 6692 ---------------------------------------------------- 6693 6694 -- The general form of pragma Annotate is 6695 6696 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]); 6697 -- ARG ::= NAME | EXPRESSION 6698 6699 -- The first two arguments are by convention intended to refer to an 6700 -- external tool and a tool-specific function. These arguments are 6701 -- not analyzed. 6702 6703 -- The following is used to annotate a package specification which 6704 -- GNATprove should treat specially, because the axiomatization of 6705 -- this unit is given by the user instead of being automatically 6706 -- generated. 6707 6708 -- pragma Annotate (GNATprove, External_Axiomatization); 6709 6710 function Is_Annotate_Pragma_For_External_Axiomatization 6711 (N : Node_Id) return Boolean 6712 is 6713 Name_GNATprove : constant String := 6714 "gnatprove"; 6715 Name_External_Axiomatization : constant String := 6716 "external_axiomatization"; 6717 -- Special names 6718 6719 begin 6720 if Nkind (N) = N_Pragma 6721 and then Get_Pragma_Id (N) = Pragma_Annotate 6722 and then List_Length (Pragma_Argument_Associations (N)) = 2 6723 then 6724 declare 6725 Arg1 : constant Node_Id := 6726 First (Pragma_Argument_Associations (N)); 6727 Arg2 : constant Node_Id := Next (Arg1); 6728 Nam1 : Name_Id; 6729 Nam2 : Name_Id; 6730 6731 begin 6732 -- Fill in Name_Buffer with Name_GNATprove first, and then with 6733 -- Name_External_Axiomatization so that Name_Find returns the 6734 -- corresponding name. This takes care of all possible casings. 6735 6736 Name_Len := 0; 6737 Add_Str_To_Name_Buffer (Name_GNATprove); 6738 Nam1 := Name_Find; 6739 6740 Name_Len := 0; 6741 Add_Str_To_Name_Buffer (Name_External_Axiomatization); 6742 Nam2 := Name_Find; 6743 6744 return Chars (Get_Pragma_Arg (Arg1)) = Nam1 6745 and then 6746 Chars (Get_Pragma_Arg (Arg2)) = Nam2; 6747 end; 6748 6749 else 6750 return False; 6751 end if; 6752 end Is_Annotate_Pragma_For_External_Axiomatization; 6753 6754 -- Local variables 6755 6756 Decl : Node_Id; 6757 Vis_Decls : List_Id; 6758 N : Node_Id; 6759 6760 -- Start of processing for Has_Annotate_Pragma_For_External_Axiomatization 6761 6762 begin 6763 if Nkind (Parent (E)) = N_Defining_Program_Unit_Name then 6764 Decl := Parent (Parent (E)); 6765 else 6766 Decl := Parent (E); 6767 end if; 6768 6769 Vis_Decls := Visible_Declarations (Decl); 6770 6771 N := First (Vis_Decls); 6772 while Present (N) loop 6773 6774 -- Skip declarations generated by the frontend. Skip all pragmas 6775 -- that are not the desired Annotate pragma. Stop the search on 6776 -- the first non-pragma source declaration. 6777 6778 if Comes_From_Source (N) then 6779 if Nkind (N) = N_Pragma then 6780 if Is_Annotate_Pragma_For_External_Axiomatization (N) then 6781 return True; 6782 end if; 6783 else 6784 return False; 6785 end if; 6786 end if; 6787 6788 Next (N); 6789 end loop; 6790 6791 return False; 6792 end Has_Annotate_Pragma_For_External_Axiomatization; 6793 6794 -------------------- 6795 -- Homonym_Number -- 6796 -------------------- 6797 6798 function Homonym_Number (Subp : Entity_Id) return Pos is 6799 Hom : Entity_Id := Homonym (Subp); 6800 Count : Pos := 1; 6801 6802 begin 6803 while Present (Hom) loop 6804 if Scope (Hom) = Scope (Subp) then 6805 Count := Count + 1; 6806 end if; 6807 6808 Hom := Homonym (Hom); 6809 end loop; 6810 6811 return Count; 6812 end Homonym_Number; 6813 6814 ----------------------------------- 6815 -- In_Library_Level_Package_Body -- 6816 ----------------------------------- 6817 6818 function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is 6819 begin 6820 -- First determine whether the entity appears at the library level, then 6821 -- look at the containing unit. 6822 6823 if Is_Library_Level_Entity (Id) then 6824 declare 6825 Container : constant Node_Id := Cunit (Get_Source_Unit (Id)); 6826 6827 begin 6828 return Nkind (Unit (Container)) = N_Package_Body; 6829 end; 6830 end if; 6831 6832 return False; 6833 end In_Library_Level_Package_Body; 6834 6835 ------------------------------ 6836 -- In_Unconditional_Context -- 6837 ------------------------------ 6838 6839 function In_Unconditional_Context (Node : Node_Id) return Boolean is 6840 P : Node_Id; 6841 6842 begin 6843 P := Node; 6844 while Present (P) loop 6845 case Nkind (P) is 6846 when N_Subprogram_Body => return True; 6847 when N_If_Statement => return False; 6848 when N_Loop_Statement => return False; 6849 when N_Case_Statement => return False; 6850 when others => P := Parent (P); 6851 end case; 6852 end loop; 6853 6854 return False; 6855 end In_Unconditional_Context; 6856 6857 ------------------- 6858 -- Insert_Action -- 6859 ------------------- 6860 6861 procedure Insert_Action 6862 (Assoc_Node : Node_Id; 6863 Ins_Action : Node_Id; 6864 Spec_Expr_OK : Boolean := False) 6865 is 6866 begin 6867 if Present (Ins_Action) then 6868 Insert_Actions 6869 (Assoc_Node => Assoc_Node, 6870 Ins_Actions => New_List (Ins_Action), 6871 Spec_Expr_OK => Spec_Expr_OK); 6872 end if; 6873 end Insert_Action; 6874 6875 -- Version with check(s) suppressed 6876 6877 procedure Insert_Action 6878 (Assoc_Node : Node_Id; 6879 Ins_Action : Node_Id; 6880 Suppress : Check_Id; 6881 Spec_Expr_OK : Boolean := False) 6882 is 6883 begin 6884 Insert_Actions 6885 (Assoc_Node => Assoc_Node, 6886 Ins_Actions => New_List (Ins_Action), 6887 Suppress => Suppress, 6888 Spec_Expr_OK => Spec_Expr_OK); 6889 end Insert_Action; 6890 6891 ------------------------- 6892 -- Insert_Action_After -- 6893 ------------------------- 6894 6895 procedure Insert_Action_After 6896 (Assoc_Node : Node_Id; 6897 Ins_Action : Node_Id) 6898 is 6899 begin 6900 Insert_Actions_After (Assoc_Node, New_List (Ins_Action)); 6901 end Insert_Action_After; 6902 6903 -------------------- 6904 -- Insert_Actions -- 6905 -------------------- 6906 6907 procedure Insert_Actions 6908 (Assoc_Node : Node_Id; 6909 Ins_Actions : List_Id; 6910 Spec_Expr_OK : Boolean := False) 6911 is 6912 N : Node_Id; 6913 P : Node_Id; 6914 6915 Wrapped_Node : Node_Id := Empty; 6916 6917 begin 6918 if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then 6919 return; 6920 end if; 6921 6922 -- Insert the action when the context is "Handling of Default and Per- 6923 -- Object Expressions" only when requested by the caller. 6924 6925 if Spec_Expr_OK then 6926 null; 6927 6928 -- Ignore insert of actions from inside default expression (or other 6929 -- similar "spec expression") in the special spec-expression analyze 6930 -- mode. Any insertions at this point have no relevance, since we are 6931 -- only doing the analyze to freeze the types of any static expressions. 6932 -- See section "Handling of Default and Per-Object Expressions" in the 6933 -- spec of package Sem for further details. 6934 6935 elsif In_Spec_Expression then 6936 return; 6937 end if; 6938 6939 -- If the action derives from stuff inside a record, then the actions 6940 -- are attached to the current scope, to be inserted and analyzed on 6941 -- exit from the scope. The reason for this is that we may also be 6942 -- generating freeze actions at the same time, and they must eventually 6943 -- be elaborated in the correct order. 6944 6945 if Is_Record_Type (Current_Scope) 6946 and then not Is_Frozen (Current_Scope) 6947 then 6948 if No (Scope_Stack.Table 6949 (Scope_Stack.Last).Pending_Freeze_Actions) 6950 then 6951 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions := 6952 Ins_Actions; 6953 else 6954 Append_List 6955 (Ins_Actions, 6956 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions); 6957 end if; 6958 6959 return; 6960 end if; 6961 6962 -- We now intend to climb up the tree to find the right point to 6963 -- insert the actions. We start at Assoc_Node, unless this node is a 6964 -- subexpression in which case we start with its parent. We do this for 6965 -- two reasons. First it speeds things up. Second, if Assoc_Node is 6966 -- itself one of the special nodes like N_And_Then, then we assume that 6967 -- an initial request to insert actions for such a node does not expect 6968 -- the actions to get deposited in the node for later handling when the 6969 -- node is expanded, since clearly the node is being dealt with by the 6970 -- caller. Note that in the subexpression case, N is always the child we 6971 -- came from. 6972 6973 -- N_Raise_xxx_Error is an annoying special case, it is a statement 6974 -- if it has type Standard_Void_Type, and a subexpression otherwise. 6975 -- Procedure calls, and similarly procedure attribute references, are 6976 -- also statements. 6977 6978 if Nkind (Assoc_Node) in N_Subexpr 6979 and then (Nkind (Assoc_Node) not in N_Raise_xxx_Error 6980 or else Etype (Assoc_Node) /= Standard_Void_Type) 6981 and then Nkind (Assoc_Node) /= N_Procedure_Call_Statement 6982 and then (Nkind (Assoc_Node) /= N_Attribute_Reference 6983 or else not Is_Procedure_Attribute_Name 6984 (Attribute_Name (Assoc_Node))) 6985 then 6986 N := Assoc_Node; 6987 P := Parent (Assoc_Node); 6988 6989 -- Nonsubexpression case. Note that N is initially Empty in this case 6990 -- (N is only guaranteed non-Empty in the subexpr case). 6991 6992 else 6993 N := Empty; 6994 P := Assoc_Node; 6995 end if; 6996 6997 -- Capture root of the transient scope 6998 6999 if Scope_Is_Transient then 7000 Wrapped_Node := Node_To_Be_Wrapped; 7001 end if; 7002 7003 loop 7004 pragma Assert (Present (P)); 7005 7006 -- Make sure that inserted actions stay in the transient scope 7007 7008 if Present (Wrapped_Node) and then N = Wrapped_Node then 7009 Store_Before_Actions_In_Scope (Ins_Actions); 7010 return; 7011 end if; 7012 7013 case Nkind (P) is 7014 7015 -- Case of right operand of AND THEN or OR ELSE. Put the actions 7016 -- in the Actions field of the right operand. They will be moved 7017 -- out further when the AND THEN or OR ELSE operator is expanded. 7018 -- Nothing special needs to be done for the left operand since 7019 -- in that case the actions are executed unconditionally. 7020 7021 when N_Short_Circuit => 7022 if N = Right_Opnd (P) then 7023 7024 -- We are now going to either append the actions to the 7025 -- actions field of the short-circuit operation. We will 7026 -- also analyze the actions now. 7027 7028 -- This analysis is really too early, the proper thing would 7029 -- be to just park them there now, and only analyze them if 7030 -- we find we really need them, and to it at the proper 7031 -- final insertion point. However attempting to this proved 7032 -- tricky, so for now we just kill current values before and 7033 -- after the analyze call to make sure we avoid peculiar 7034 -- optimizations from this out of order insertion. 7035 7036 Kill_Current_Values; 7037 7038 -- If P has already been expanded, we can't park new actions 7039 -- on it, so we need to expand them immediately, introducing 7040 -- an Expression_With_Actions. N can't be an expression 7041 -- with actions, or else then the actions would have been 7042 -- inserted at an inner level. 7043 7044 if Analyzed (P) then 7045 pragma Assert (Nkind (N) /= N_Expression_With_Actions); 7046 Rewrite (N, 7047 Make_Expression_With_Actions (Sloc (N), 7048 Actions => Ins_Actions, 7049 Expression => Relocate_Node (N))); 7050 Analyze_And_Resolve (N); 7051 7052 elsif Present (Actions (P)) then 7053 Insert_List_After_And_Analyze 7054 (Last (Actions (P)), Ins_Actions); 7055 else 7056 Set_Actions (P, Ins_Actions); 7057 Analyze_List (Actions (P)); 7058 end if; 7059 7060 Kill_Current_Values; 7061 7062 return; 7063 end if; 7064 7065 -- Then or Else dependent expression of an if expression. Add 7066 -- actions to Then_Actions or Else_Actions field as appropriate. 7067 -- The actions will be moved further out when the if is expanded. 7068 7069 when N_If_Expression => 7070 declare 7071 ThenX : constant Node_Id := Next (First (Expressions (P))); 7072 ElseX : constant Node_Id := Next (ThenX); 7073 7074 begin 7075 -- If the enclosing expression is already analyzed, as 7076 -- is the case for nested elaboration checks, insert the 7077 -- conditional further out. 7078 7079 if Analyzed (P) then 7080 null; 7081 7082 -- Actions belong to the then expression, temporarily place 7083 -- them as Then_Actions of the if expression. They will be 7084 -- moved to the proper place later when the if expression 7085 -- is expanded. 7086 7087 elsif N = ThenX then 7088 if Present (Then_Actions (P)) then 7089 Insert_List_After_And_Analyze 7090 (Last (Then_Actions (P)), Ins_Actions); 7091 else 7092 Set_Then_Actions (P, Ins_Actions); 7093 Analyze_List (Then_Actions (P)); 7094 end if; 7095 7096 return; 7097 7098 -- Actions belong to the else expression, temporarily place 7099 -- them as Else_Actions of the if expression. They will be 7100 -- moved to the proper place later when the if expression 7101 -- is expanded. 7102 7103 elsif N = ElseX then 7104 if Present (Else_Actions (P)) then 7105 Insert_List_After_And_Analyze 7106 (Last (Else_Actions (P)), Ins_Actions); 7107 else 7108 Set_Else_Actions (P, Ins_Actions); 7109 Analyze_List (Else_Actions (P)); 7110 end if; 7111 7112 return; 7113 7114 -- Actions belong to the condition. In this case they are 7115 -- unconditionally executed, and so we can continue the 7116 -- search for the proper insert point. 7117 7118 else 7119 null; 7120 end if; 7121 end; 7122 7123 -- Alternative of case expression, we place the action in the 7124 -- Actions field of the case expression alternative, this will 7125 -- be handled when the case expression is expanded. 7126 7127 when N_Case_Expression_Alternative => 7128 if Present (Actions (P)) then 7129 Insert_List_After_And_Analyze 7130 (Last (Actions (P)), Ins_Actions); 7131 else 7132 Set_Actions (P, Ins_Actions); 7133 Analyze_List (Actions (P)); 7134 end if; 7135 7136 return; 7137 7138 -- Case of appearing within an Expressions_With_Actions node. When 7139 -- the new actions come from the expression of the expression with 7140 -- actions, they must be added to the existing actions. The other 7141 -- alternative is when the new actions are related to one of the 7142 -- existing actions of the expression with actions, and should 7143 -- never reach here: if actions are inserted on a statement 7144 -- within the Actions of an expression with actions, or on some 7145 -- subexpression of such a statement, then the outermost proper 7146 -- insertion point is right before the statement, and we should 7147 -- never climb up as far as the N_Expression_With_Actions itself. 7148 7149 when N_Expression_With_Actions => 7150 if N = Expression (P) then 7151 if Is_Empty_List (Actions (P)) then 7152 Append_List_To (Actions (P), Ins_Actions); 7153 Analyze_List (Actions (P)); 7154 else 7155 Insert_List_After_And_Analyze 7156 (Last (Actions (P)), Ins_Actions); 7157 end if; 7158 7159 return; 7160 7161 else 7162 raise Program_Error; 7163 end if; 7164 7165 -- Case of appearing in the condition of a while expression or 7166 -- elsif. We insert the actions into the Condition_Actions field. 7167 -- They will be moved further out when the while loop or elsif 7168 -- is analyzed. 7169 7170 when N_Elsif_Part 7171 | N_Iteration_Scheme 7172 => 7173 if N = Condition (P) then 7174 if Present (Condition_Actions (P)) then 7175 Insert_List_After_And_Analyze 7176 (Last (Condition_Actions (P)), Ins_Actions); 7177 else 7178 Set_Condition_Actions (P, Ins_Actions); 7179 7180 -- Set the parent of the insert actions explicitly. This 7181 -- is not a syntactic field, but we need the parent field 7182 -- set, in particular so that freeze can understand that 7183 -- it is dealing with condition actions, and properly 7184 -- insert the freezing actions. 7185 7186 Set_Parent (Ins_Actions, P); 7187 Analyze_List (Condition_Actions (P)); 7188 end if; 7189 7190 return; 7191 end if; 7192 7193 -- Statements, declarations, pragmas, representation clauses 7194 7195 when 7196 -- Statements 7197 7198 N_Procedure_Call_Statement 7199 | N_Statement_Other_Than_Procedure_Call 7200 7201 -- Pragmas 7202 7203 | N_Pragma 7204 7205 -- Representation_Clause 7206 7207 | N_At_Clause 7208 | N_Attribute_Definition_Clause 7209 | N_Enumeration_Representation_Clause 7210 | N_Record_Representation_Clause 7211 7212 -- Declarations 7213 7214 | N_Abstract_Subprogram_Declaration 7215 | N_Entry_Body 7216 | N_Exception_Declaration 7217 | N_Exception_Renaming_Declaration 7218 | N_Expression_Function 7219 | N_Formal_Abstract_Subprogram_Declaration 7220 | N_Formal_Concrete_Subprogram_Declaration 7221 | N_Formal_Object_Declaration 7222 | N_Formal_Type_Declaration 7223 | N_Full_Type_Declaration 7224 | N_Function_Instantiation 7225 | N_Generic_Function_Renaming_Declaration 7226 | N_Generic_Package_Declaration 7227 | N_Generic_Package_Renaming_Declaration 7228 | N_Generic_Procedure_Renaming_Declaration 7229 | N_Generic_Subprogram_Declaration 7230 | N_Implicit_Label_Declaration 7231 | N_Incomplete_Type_Declaration 7232 | N_Number_Declaration 7233 | N_Object_Declaration 7234 | N_Object_Renaming_Declaration 7235 | N_Package_Body 7236 | N_Package_Body_Stub 7237 | N_Package_Declaration 7238 | N_Package_Instantiation 7239 | N_Package_Renaming_Declaration 7240 | N_Private_Extension_Declaration 7241 | N_Private_Type_Declaration 7242 | N_Procedure_Instantiation 7243 | N_Protected_Body 7244 | N_Protected_Body_Stub 7245 | N_Single_Task_Declaration 7246 | N_Subprogram_Body 7247 | N_Subprogram_Body_Stub 7248 | N_Subprogram_Declaration 7249 | N_Subprogram_Renaming_Declaration 7250 | N_Subtype_Declaration 7251 | N_Task_Body 7252 | N_Task_Body_Stub 7253 7254 -- Use clauses can appear in lists of declarations 7255 7256 | N_Use_Package_Clause 7257 | N_Use_Type_Clause 7258 7259 -- Freeze entity behaves like a declaration or statement 7260 7261 | N_Freeze_Entity 7262 | N_Freeze_Generic_Entity 7263 => 7264 -- Do not insert here if the item is not a list member (this 7265 -- happens for example with a triggering statement, and the 7266 -- proper approach is to insert before the entire select). 7267 7268 if not Is_List_Member (P) then 7269 null; 7270 7271 -- Do not insert if parent of P is an N_Component_Association 7272 -- node (i.e. we are in the context of an N_Aggregate or 7273 -- N_Extension_Aggregate node. In this case we want to insert 7274 -- before the entire aggregate. 7275 7276 elsif Nkind (Parent (P)) = N_Component_Association then 7277 null; 7278 7279 -- Do not insert if the parent of P is either an N_Variant node 7280 -- or an N_Record_Definition node, meaning in either case that 7281 -- P is a member of a component list, and that therefore the 7282 -- actions should be inserted outside the complete record 7283 -- declaration. 7284 7285 elsif Nkind_In (Parent (P), N_Variant, N_Record_Definition) then 7286 null; 7287 7288 -- Do not insert freeze nodes within the loop generated for 7289 -- an aggregate, because they may be elaborated too late for 7290 -- subsequent use in the back end: within a package spec the 7291 -- loop is part of the elaboration procedure and is only 7292 -- elaborated during the second pass. 7293 7294 -- If the loop comes from source, or the entity is local to the 7295 -- loop itself it must remain within. 7296 7297 elsif Nkind (Parent (P)) = N_Loop_Statement 7298 and then not Comes_From_Source (Parent (P)) 7299 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity 7300 and then 7301 Scope (Entity (First (Ins_Actions))) /= Current_Scope 7302 then 7303 null; 7304 7305 -- Otherwise we can go ahead and do the insertion 7306 7307 elsif P = Wrapped_Node then 7308 Store_Before_Actions_In_Scope (Ins_Actions); 7309 return; 7310 7311 else 7312 Insert_List_Before_And_Analyze (P, Ins_Actions); 7313 return; 7314 end if; 7315 7316 -- the expansion of Task and protected type declarations can 7317 -- create declarations for temporaries which, like other actions 7318 -- are inserted and analyzed before the current declaraation. 7319 -- However, the current scope is the synchronized type, and 7320 -- for unnesting it is critical that the proper scope for these 7321 -- generated entities be the enclosing one. 7322 7323 when N_Task_Type_Declaration 7324 | N_Protected_Type_Declaration => 7325 7326 Push_Scope (Scope (Current_Scope)); 7327 Insert_List_Before_And_Analyze (P, Ins_Actions); 7328 Pop_Scope; 7329 return; 7330 7331 -- A special case, N_Raise_xxx_Error can act either as a statement 7332 -- or a subexpression. We tell the difference by looking at the 7333 -- Etype. It is set to Standard_Void_Type in the statement case. 7334 7335 when N_Raise_xxx_Error => 7336 if Etype (P) = Standard_Void_Type then 7337 if P = Wrapped_Node then 7338 Store_Before_Actions_In_Scope (Ins_Actions); 7339 else 7340 Insert_List_Before_And_Analyze (P, Ins_Actions); 7341 end if; 7342 7343 return; 7344 7345 -- In the subexpression case, keep climbing 7346 7347 else 7348 null; 7349 end if; 7350 7351 -- If a component association appears within a loop created for 7352 -- an array aggregate, attach the actions to the association so 7353 -- they can be subsequently inserted within the loop. For other 7354 -- component associations insert outside of the aggregate. For 7355 -- an association that will generate a loop, its Loop_Actions 7356 -- attribute is already initialized (see exp_aggr.adb). 7357 7358 -- The list of Loop_Actions can in turn generate additional ones, 7359 -- that are inserted before the associated node. If the associated 7360 -- node is outside the aggregate, the new actions are collected 7361 -- at the end of the Loop_Actions, to respect the order in which 7362 -- they are to be elaborated. 7363 7364 when N_Component_Association 7365 | N_Iterated_Component_Association 7366 => 7367 if Nkind (Parent (P)) = N_Aggregate 7368 and then Present (Loop_Actions (P)) 7369 then 7370 if Is_Empty_List (Loop_Actions (P)) then 7371 Set_Loop_Actions (P, Ins_Actions); 7372 Analyze_List (Ins_Actions); 7373 else 7374 declare 7375 Decl : Node_Id; 7376 7377 begin 7378 -- Check whether these actions were generated by a 7379 -- declaration that is part of the Loop_Actions for 7380 -- the component_association. 7381 7382 Decl := Assoc_Node; 7383 while Present (Decl) loop 7384 exit when Parent (Decl) = P 7385 and then Is_List_Member (Decl) 7386 and then 7387 List_Containing (Decl) = Loop_Actions (P); 7388 Decl := Parent (Decl); 7389 end loop; 7390 7391 if Present (Decl) then 7392 Insert_List_Before_And_Analyze 7393 (Decl, Ins_Actions); 7394 else 7395 Insert_List_After_And_Analyze 7396 (Last (Loop_Actions (P)), Ins_Actions); 7397 end if; 7398 end; 7399 end if; 7400 7401 return; 7402 7403 else 7404 null; 7405 end if; 7406 7407 -- Special case: an attribute denoting a procedure call 7408 7409 when N_Attribute_Reference => 7410 if Is_Procedure_Attribute_Name (Attribute_Name (P)) then 7411 if P = Wrapped_Node then 7412 Store_Before_Actions_In_Scope (Ins_Actions); 7413 else 7414 Insert_List_Before_And_Analyze (P, Ins_Actions); 7415 end if; 7416 7417 return; 7418 7419 -- In the subexpression case, keep climbing 7420 7421 else 7422 null; 7423 end if; 7424 7425 -- Special case: a marker 7426 7427 when N_Call_Marker 7428 | N_Variable_Reference_Marker 7429 => 7430 if Is_List_Member (P) then 7431 Insert_List_Before_And_Analyze (P, Ins_Actions); 7432 return; 7433 end if; 7434 7435 -- A contract node should not belong to the tree 7436 7437 when N_Contract => 7438 raise Program_Error; 7439 7440 -- For all other node types, keep climbing tree 7441 7442 when N_Abortable_Part 7443 | N_Accept_Alternative 7444 | N_Access_Definition 7445 | N_Access_Function_Definition 7446 | N_Access_Procedure_Definition 7447 | N_Access_To_Object_Definition 7448 | N_Aggregate 7449 | N_Allocator 7450 | N_Aspect_Specification 7451 | N_Case_Expression 7452 | N_Case_Statement_Alternative 7453 | N_Character_Literal 7454 | N_Compilation_Unit 7455 | N_Compilation_Unit_Aux 7456 | N_Component_Clause 7457 | N_Component_Declaration 7458 | N_Component_Definition 7459 | N_Component_List 7460 | N_Constrained_Array_Definition 7461 | N_Decimal_Fixed_Point_Definition 7462 | N_Defining_Character_Literal 7463 | N_Defining_Identifier 7464 | N_Defining_Operator_Symbol 7465 | N_Defining_Program_Unit_Name 7466 | N_Delay_Alternative 7467 | N_Delta_Aggregate 7468 | N_Delta_Constraint 7469 | N_Derived_Type_Definition 7470 | N_Designator 7471 | N_Digits_Constraint 7472 | N_Discriminant_Association 7473 | N_Discriminant_Specification 7474 | N_Empty 7475 | N_Entry_Body_Formal_Part 7476 | N_Entry_Call_Alternative 7477 | N_Entry_Declaration 7478 | N_Entry_Index_Specification 7479 | N_Enumeration_Type_Definition 7480 | N_Error 7481 | N_Exception_Handler 7482 | N_Expanded_Name 7483 | N_Explicit_Dereference 7484 | N_Extension_Aggregate 7485 | N_Floating_Point_Definition 7486 | N_Formal_Decimal_Fixed_Point_Definition 7487 | N_Formal_Derived_Type_Definition 7488 | N_Formal_Discrete_Type_Definition 7489 | N_Formal_Floating_Point_Definition 7490 | N_Formal_Modular_Type_Definition 7491 | N_Formal_Ordinary_Fixed_Point_Definition 7492 | N_Formal_Package_Declaration 7493 | N_Formal_Private_Type_Definition 7494 | N_Formal_Incomplete_Type_Definition 7495 | N_Formal_Signed_Integer_Type_Definition 7496 | N_Function_Call 7497 | N_Function_Specification 7498 | N_Generic_Association 7499 | N_Handled_Sequence_Of_Statements 7500 | N_Identifier 7501 | N_In 7502 | N_Index_Or_Discriminant_Constraint 7503 | N_Indexed_Component 7504 | N_Integer_Literal 7505 | N_Iterator_Specification 7506 | N_Itype_Reference 7507 | N_Label 7508 | N_Loop_Parameter_Specification 7509 | N_Mod_Clause 7510 | N_Modular_Type_Definition 7511 | N_Not_In 7512 | N_Null 7513 | N_Op_Abs 7514 | N_Op_Add 7515 | N_Op_And 7516 | N_Op_Concat 7517 | N_Op_Divide 7518 | N_Op_Eq 7519 | N_Op_Expon 7520 | N_Op_Ge 7521 | N_Op_Gt 7522 | N_Op_Le 7523 | N_Op_Lt 7524 | N_Op_Minus 7525 | N_Op_Mod 7526 | N_Op_Multiply 7527 | N_Op_Ne 7528 | N_Op_Not 7529 | N_Op_Or 7530 | N_Op_Plus 7531 | N_Op_Rem 7532 | N_Op_Rotate_Left 7533 | N_Op_Rotate_Right 7534 | N_Op_Shift_Left 7535 | N_Op_Shift_Right 7536 | N_Op_Shift_Right_Arithmetic 7537 | N_Op_Subtract 7538 | N_Op_Xor 7539 | N_Operator_Symbol 7540 | N_Ordinary_Fixed_Point_Definition 7541 | N_Others_Choice 7542 | N_Package_Specification 7543 | N_Parameter_Association 7544 | N_Parameter_Specification 7545 | N_Pop_Constraint_Error_Label 7546 | N_Pop_Program_Error_Label 7547 | N_Pop_Storage_Error_Label 7548 | N_Pragma_Argument_Association 7549 | N_Procedure_Specification 7550 | N_Protected_Definition 7551 | N_Push_Constraint_Error_Label 7552 | N_Push_Program_Error_Label 7553 | N_Push_Storage_Error_Label 7554 | N_Qualified_Expression 7555 | N_Quantified_Expression 7556 | N_Raise_Expression 7557 | N_Range 7558 | N_Range_Constraint 7559 | N_Real_Literal 7560 | N_Real_Range_Specification 7561 | N_Record_Definition 7562 | N_Reference 7563 | N_SCIL_Dispatch_Table_Tag_Init 7564 | N_SCIL_Dispatching_Call 7565 | N_SCIL_Membership_Test 7566 | N_Selected_Component 7567 | N_Signed_Integer_Type_Definition 7568 | N_Single_Protected_Declaration 7569 | N_Slice 7570 | N_String_Literal 7571 | N_Subtype_Indication 7572 | N_Subunit 7573 | N_Target_Name 7574 | N_Task_Definition 7575 | N_Terminate_Alternative 7576 | N_Triggering_Alternative 7577 | N_Type_Conversion 7578 | N_Unchecked_Expression 7579 | N_Unchecked_Type_Conversion 7580 | N_Unconstrained_Array_Definition 7581 | N_Unused_At_End 7582 | N_Unused_At_Start 7583 | N_Variant 7584 | N_Variant_Part 7585 | N_Validate_Unchecked_Conversion 7586 | N_With_Clause 7587 => 7588 null; 7589 end case; 7590 7591 -- If we fall through above tests, keep climbing tree 7592 7593 N := P; 7594 7595 if Nkind (Parent (N)) = N_Subunit then 7596 7597 -- This is the proper body corresponding to a stub. Insertion must 7598 -- be done at the point of the stub, which is in the declarative 7599 -- part of the parent unit. 7600 7601 P := Corresponding_Stub (Parent (N)); 7602 7603 else 7604 P := Parent (N); 7605 end if; 7606 end loop; 7607 end Insert_Actions; 7608 7609 -- Version with check(s) suppressed 7610 7611 procedure Insert_Actions 7612 (Assoc_Node : Node_Id; 7613 Ins_Actions : List_Id; 7614 Suppress : Check_Id; 7615 Spec_Expr_OK : Boolean := False) 7616 is 7617 begin 7618 if Suppress = All_Checks then 7619 declare 7620 Sva : constant Suppress_Array := Scope_Suppress.Suppress; 7621 begin 7622 Scope_Suppress.Suppress := (others => True); 7623 Insert_Actions (Assoc_Node, Ins_Actions, Spec_Expr_OK); 7624 Scope_Suppress.Suppress := Sva; 7625 end; 7626 7627 else 7628 declare 7629 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); 7630 begin 7631 Scope_Suppress.Suppress (Suppress) := True; 7632 Insert_Actions (Assoc_Node, Ins_Actions, Spec_Expr_OK); 7633 Scope_Suppress.Suppress (Suppress) := Svg; 7634 end; 7635 end if; 7636 end Insert_Actions; 7637 7638 -------------------------- 7639 -- Insert_Actions_After -- 7640 -------------------------- 7641 7642 procedure Insert_Actions_After 7643 (Assoc_Node : Node_Id; 7644 Ins_Actions : List_Id) 7645 is 7646 begin 7647 if Scope_Is_Transient and then Assoc_Node = Node_To_Be_Wrapped then 7648 Store_After_Actions_In_Scope (Ins_Actions); 7649 else 7650 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions); 7651 end if; 7652 end Insert_Actions_After; 7653 7654 ------------------------ 7655 -- Insert_Declaration -- 7656 ------------------------ 7657 7658 procedure Insert_Declaration (N : Node_Id; Decl : Node_Id) is 7659 P : Node_Id; 7660 7661 begin 7662 pragma Assert (Nkind (N) in N_Subexpr); 7663 7664 -- Climb until we find a procedure or a package 7665 7666 P := N; 7667 loop 7668 pragma Assert (Present (Parent (P))); 7669 P := Parent (P); 7670 7671 if Is_List_Member (P) then 7672 exit when Nkind_In (Parent (P), N_Package_Specification, 7673 N_Subprogram_Body); 7674 7675 -- Special handling for handled sequence of statements, we must 7676 -- insert in the statements not the exception handlers! 7677 7678 if Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements then 7679 P := First (Statements (Parent (P))); 7680 exit; 7681 end if; 7682 end if; 7683 end loop; 7684 7685 -- Now do the insertion 7686 7687 Insert_Before (P, Decl); 7688 Analyze (Decl); 7689 end Insert_Declaration; 7690 7691 --------------------------------- 7692 -- Insert_Library_Level_Action -- 7693 --------------------------------- 7694 7695 procedure Insert_Library_Level_Action (N : Node_Id) is 7696 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit)); 7697 7698 begin 7699 Push_Scope (Cunit_Entity (Current_Sem_Unit)); 7700 -- And not Main_Unit as previously. If the main unit is a body, 7701 -- the scope needed to analyze the actions is the entity of the 7702 -- corresponding declaration. 7703 7704 if No (Actions (Aux)) then 7705 Set_Actions (Aux, New_List (N)); 7706 else 7707 Append (N, Actions (Aux)); 7708 end if; 7709 7710 Analyze (N); 7711 Pop_Scope; 7712 end Insert_Library_Level_Action; 7713 7714 ---------------------------------- 7715 -- Insert_Library_Level_Actions -- 7716 ---------------------------------- 7717 7718 procedure Insert_Library_Level_Actions (L : List_Id) is 7719 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit)); 7720 7721 begin 7722 if Is_Non_Empty_List (L) then 7723 Push_Scope (Cunit_Entity (Main_Unit)); 7724 -- ??? should this be Current_Sem_Unit instead of Main_Unit? 7725 7726 if No (Actions (Aux)) then 7727 Set_Actions (Aux, L); 7728 Analyze_List (L); 7729 else 7730 Insert_List_After_And_Analyze (Last (Actions (Aux)), L); 7731 end if; 7732 7733 Pop_Scope; 7734 end if; 7735 end Insert_Library_Level_Actions; 7736 7737 ---------------------- 7738 -- Inside_Init_Proc -- 7739 ---------------------- 7740 7741 function Inside_Init_Proc return Boolean is 7742 Proc : constant Entity_Id := Enclosing_Init_Proc; 7743 7744 begin 7745 return Proc /= Empty; 7746 end Inside_Init_Proc; 7747 7748 ---------------------------- 7749 -- Is_All_Null_Statements -- 7750 ---------------------------- 7751 7752 function Is_All_Null_Statements (L : List_Id) return Boolean is 7753 Stm : Node_Id; 7754 7755 begin 7756 Stm := First (L); 7757 while Present (Stm) loop 7758 if Nkind (Stm) /= N_Null_Statement then 7759 return False; 7760 end if; 7761 7762 Next (Stm); 7763 end loop; 7764 7765 return True; 7766 end Is_All_Null_Statements; 7767 7768 -------------------------------------------------- 7769 -- Is_Displacement_Of_Object_Or_Function_Result -- 7770 -------------------------------------------------- 7771 7772 function Is_Displacement_Of_Object_Or_Function_Result 7773 (Obj_Id : Entity_Id) return Boolean 7774 is 7775 function Is_Controlled_Function_Call (N : Node_Id) return Boolean; 7776 -- Determine whether node N denotes a controlled function call 7777 7778 function Is_Controlled_Indexing (N : Node_Id) return Boolean; 7779 -- Determine whether node N denotes a generalized indexing form which 7780 -- involves a controlled result. 7781 7782 function Is_Displace_Call (N : Node_Id) return Boolean; 7783 -- Determine whether node N denotes a call to Ada.Tags.Displace 7784 7785 function Is_Source_Object (N : Node_Id) return Boolean; 7786 -- Determine whether a particular node denotes a source object 7787 7788 function Strip (N : Node_Id) return Node_Id; 7789 -- Examine arbitrary node N by stripping various indirections and return 7790 -- the "real" node. 7791 7792 --------------------------------- 7793 -- Is_Controlled_Function_Call -- 7794 --------------------------------- 7795 7796 function Is_Controlled_Function_Call (N : Node_Id) return Boolean is 7797 Expr : Node_Id; 7798 7799 begin 7800 -- When a function call appears in Object.Operation format, the 7801 -- original representation has several possible forms depending on 7802 -- the availability and form of actual parameters: 7803 7804 -- Obj.Func N_Selected_Component 7805 -- Obj.Func (Actual) N_Indexed_Component 7806 -- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an 7807 -- N_Selected_Component 7808 7809 Expr := Original_Node (N); 7810 loop 7811 if Nkind (Expr) = N_Function_Call then 7812 Expr := Name (Expr); 7813 7814 -- "Obj.Func (Actual)" case 7815 7816 elsif Nkind (Expr) = N_Indexed_Component then 7817 Expr := Prefix (Expr); 7818 7819 -- "Obj.Func" or "Obj.Func (Formal => Actual) case 7820 7821 elsif Nkind (Expr) = N_Selected_Component then 7822 Expr := Selector_Name (Expr); 7823 7824 else 7825 exit; 7826 end if; 7827 end loop; 7828 7829 return 7830 Nkind (Expr) in N_Has_Entity 7831 and then Present (Entity (Expr)) 7832 and then Ekind (Entity (Expr)) = E_Function 7833 and then Needs_Finalization (Etype (Entity (Expr))); 7834 end Is_Controlled_Function_Call; 7835 7836 ---------------------------- 7837 -- Is_Controlled_Indexing -- 7838 ---------------------------- 7839 7840 function Is_Controlled_Indexing (N : Node_Id) return Boolean is 7841 Expr : constant Node_Id := Original_Node (N); 7842 7843 begin 7844 return 7845 Nkind (Expr) = N_Indexed_Component 7846 and then Present (Generalized_Indexing (Expr)) 7847 and then Needs_Finalization (Etype (Expr)); 7848 end Is_Controlled_Indexing; 7849 7850 ---------------------- 7851 -- Is_Displace_Call -- 7852 ---------------------- 7853 7854 function Is_Displace_Call (N : Node_Id) return Boolean is 7855 Call : constant Node_Id := Strip (N); 7856 7857 begin 7858 return 7859 Present (Call) 7860 and then Nkind (Call) = N_Function_Call 7861 and then Nkind (Name (Call)) in N_Has_Entity 7862 and then Is_RTE (Entity (Name (Call)), RE_Displace); 7863 end Is_Displace_Call; 7864 7865 ---------------------- 7866 -- Is_Source_Object -- 7867 ---------------------- 7868 7869 function Is_Source_Object (N : Node_Id) return Boolean is 7870 Obj : constant Node_Id := Strip (N); 7871 7872 begin 7873 return 7874 Present (Obj) 7875 and then Comes_From_Source (Obj) 7876 and then Nkind (Obj) in N_Has_Entity 7877 and then Is_Object (Entity (Obj)); 7878 end Is_Source_Object; 7879 7880 ----------- 7881 -- Strip -- 7882 ----------- 7883 7884 function Strip (N : Node_Id) return Node_Id is 7885 Result : Node_Id; 7886 7887 begin 7888 Result := N; 7889 loop 7890 if Nkind (Result) = N_Explicit_Dereference then 7891 Result := Prefix (Result); 7892 7893 elsif Nkind_In (Result, N_Type_Conversion, 7894 N_Unchecked_Type_Conversion) 7895 then 7896 Result := Expression (Result); 7897 7898 else 7899 exit; 7900 end if; 7901 end loop; 7902 7903 return Result; 7904 end Strip; 7905 7906 -- Local variables 7907 7908 Obj_Decl : constant Node_Id := Declaration_Node (Obj_Id); 7909 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); 7910 Orig_Decl : constant Node_Id := Original_Node (Obj_Decl); 7911 Orig_Expr : Node_Id; 7912 7913 -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result 7914 7915 begin 7916 -- Case 1: 7917 7918 -- Obj : CW_Type := Function_Call (...); 7919 7920 -- is rewritten into: 7921 7922 -- Temp : ... := Function_Call (...)'reference; 7923 -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp)); 7924 7925 -- where the return type of the function and the class-wide type require 7926 -- dispatch table pointer displacement. 7927 7928 -- Case 2: 7929 7930 -- Obj : CW_Type := Container (...); 7931 7932 -- is rewritten into: 7933 7934 -- Temp : ... := Function_Call (Container, ...)'reference; 7935 -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp)); 7936 7937 -- where the container element type and the class-wide type require 7938 -- dispatch table pointer dispacement. 7939 7940 -- Case 3: 7941 7942 -- Obj : CW_Type := Src_Obj; 7943 7944 -- is rewritten into: 7945 7946 -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj)); 7947 7948 -- where the type of the source object and the class-wide type require 7949 -- dispatch table pointer displacement. 7950 7951 if Nkind (Obj_Decl) = N_Object_Renaming_Declaration 7952 and then Is_Class_Wide_Type (Obj_Typ) 7953 and then Is_Displace_Call (Renamed_Object (Obj_Id)) 7954 and then Nkind (Orig_Decl) = N_Object_Declaration 7955 and then Comes_From_Source (Orig_Decl) 7956 then 7957 Orig_Expr := Expression (Orig_Decl); 7958 7959 return 7960 Is_Controlled_Function_Call (Orig_Expr) 7961 or else Is_Controlled_Indexing (Orig_Expr) 7962 or else Is_Source_Object (Orig_Expr); 7963 end if; 7964 7965 return False; 7966 end Is_Displacement_Of_Object_Or_Function_Result; 7967 7968 ------------------------------ 7969 -- Is_Finalizable_Transient -- 7970 ------------------------------ 7971 7972 function Is_Finalizable_Transient 7973 (Decl : Node_Id; 7974 Rel_Node : Node_Id) return Boolean 7975 is 7976 Obj_Id : constant Entity_Id := Defining_Identifier (Decl); 7977 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); 7978 7979 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean; 7980 -- Determine whether transient object Trans_Id is initialized either 7981 -- by a function call which returns an access type or simply renames 7982 -- another pointer. 7983 7984 function Initialized_By_Aliased_BIP_Func_Call 7985 (Trans_Id : Entity_Id) return Boolean; 7986 -- Determine whether transient object Trans_Id is initialized by a 7987 -- build-in-place function call where the BIPalloc parameter is of 7988 -- value 1 and BIPaccess is not null. This case creates an aliasing 7989 -- between the returned value and the value denoted by BIPaccess. 7990 7991 function Is_Aliased 7992 (Trans_Id : Entity_Id; 7993 First_Stmt : Node_Id) return Boolean; 7994 -- Determine whether transient object Trans_Id has been renamed or 7995 -- aliased through 'reference in the statement list starting from 7996 -- First_Stmt. 7997 7998 function Is_Allocated (Trans_Id : Entity_Id) return Boolean; 7999 -- Determine whether transient object Trans_Id is allocated on the heap 8000 8001 function Is_Iterated_Container 8002 (Trans_Id : Entity_Id; 8003 First_Stmt : Node_Id) return Boolean; 8004 -- Determine whether transient object Trans_Id denotes a container which 8005 -- is in the process of being iterated in the statement list starting 8006 -- from First_Stmt. 8007 8008 --------------------------- 8009 -- Initialized_By_Access -- 8010 --------------------------- 8011 8012 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is 8013 Expr : constant Node_Id := Expression (Parent (Trans_Id)); 8014 8015 begin 8016 return 8017 Present (Expr) 8018 and then Nkind (Expr) /= N_Reference 8019 and then Is_Access_Type (Etype (Expr)); 8020 end Initialized_By_Access; 8021 8022 ------------------------------------------ 8023 -- Initialized_By_Aliased_BIP_Func_Call -- 8024 ------------------------------------------ 8025 8026 function Initialized_By_Aliased_BIP_Func_Call 8027 (Trans_Id : Entity_Id) return Boolean 8028 is 8029 Call : Node_Id := Expression (Parent (Trans_Id)); 8030 8031 begin 8032 -- Build-in-place calls usually appear in 'reference format 8033 8034 if Nkind (Call) = N_Reference then 8035 Call := Prefix (Call); 8036 end if; 8037 8038 Call := Unqual_Conv (Call); 8039 8040 if Is_Build_In_Place_Function_Call (Call) then 8041 declare 8042 Access_Nam : Name_Id := No_Name; 8043 Access_OK : Boolean := False; 8044 Actual : Node_Id; 8045 Alloc_Nam : Name_Id := No_Name; 8046 Alloc_OK : Boolean := False; 8047 Formal : Node_Id; 8048 Func_Id : Entity_Id; 8049 Param : Node_Id; 8050 8051 begin 8052 -- Examine all parameter associations of the function call 8053 8054 Param := First (Parameter_Associations (Call)); 8055 while Present (Param) loop 8056 if Nkind (Param) = N_Parameter_Association 8057 and then Nkind (Selector_Name (Param)) = N_Identifier 8058 then 8059 Actual := Explicit_Actual_Parameter (Param); 8060 Formal := Selector_Name (Param); 8061 8062 -- Construct the names of formals BIPaccess and BIPalloc 8063 -- using the function name retrieved from an arbitrary 8064 -- formal. 8065 8066 if Access_Nam = No_Name 8067 and then Alloc_Nam = No_Name 8068 and then Present (Entity (Formal)) 8069 then 8070 Func_Id := Scope (Entity (Formal)); 8071 8072 Access_Nam := 8073 New_External_Name (Chars (Func_Id), 8074 BIP_Formal_Suffix (BIP_Object_Access)); 8075 8076 Alloc_Nam := 8077 New_External_Name (Chars (Func_Id), 8078 BIP_Formal_Suffix (BIP_Alloc_Form)); 8079 end if; 8080 8081 -- A match for BIPaccess => Temp has been found 8082 8083 if Chars (Formal) = Access_Nam 8084 and then Nkind (Actual) /= N_Null 8085 then 8086 Access_OK := True; 8087 end if; 8088 8089 -- A match for BIPalloc => 1 has been found 8090 8091 if Chars (Formal) = Alloc_Nam 8092 and then Nkind (Actual) = N_Integer_Literal 8093 and then Intval (Actual) = Uint_1 8094 then 8095 Alloc_OK := True; 8096 end if; 8097 end if; 8098 8099 Next (Param); 8100 end loop; 8101 8102 return Access_OK and Alloc_OK; 8103 end; 8104 end if; 8105 8106 return False; 8107 end Initialized_By_Aliased_BIP_Func_Call; 8108 8109 ---------------- 8110 -- Is_Aliased -- 8111 ---------------- 8112 8113 function Is_Aliased 8114 (Trans_Id : Entity_Id; 8115 First_Stmt : Node_Id) return Boolean 8116 is 8117 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id; 8118 -- Given an object renaming declaration, retrieve the entity of the 8119 -- renamed name. Return Empty if the renamed name is anything other 8120 -- than a variable or a constant. 8121 8122 ------------------------- 8123 -- Find_Renamed_Object -- 8124 ------------------------- 8125 8126 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is 8127 Ren_Obj : Node_Id := Empty; 8128 8129 function Find_Object (N : Node_Id) return Traverse_Result; 8130 -- Try to detect an object which is either a constant or a 8131 -- variable. 8132 8133 ----------------- 8134 -- Find_Object -- 8135 ----------------- 8136 8137 function Find_Object (N : Node_Id) return Traverse_Result is 8138 begin 8139 -- Stop the search once a constant or a variable has been 8140 -- detected. 8141 8142 if Nkind (N) = N_Identifier 8143 and then Present (Entity (N)) 8144 and then Ekind_In (Entity (N), E_Constant, E_Variable) 8145 then 8146 Ren_Obj := Entity (N); 8147 return Abandon; 8148 end if; 8149 8150 return OK; 8151 end Find_Object; 8152 8153 procedure Search is new Traverse_Proc (Find_Object); 8154 8155 -- Local variables 8156 8157 Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl)); 8158 8159 -- Start of processing for Find_Renamed_Object 8160 8161 begin 8162 -- Actions related to dispatching calls may appear as renamings of 8163 -- tags. Do not process this type of renaming because it does not 8164 -- use the actual value of the object. 8165 8166 if not Is_RTE (Typ, RE_Tag_Ptr) then 8167 Search (Name (Ren_Decl)); 8168 end if; 8169 8170 return Ren_Obj; 8171 end Find_Renamed_Object; 8172 8173 -- Local variables 8174 8175 Expr : Node_Id; 8176 Ren_Obj : Entity_Id; 8177 Stmt : Node_Id; 8178 8179 -- Start of processing for Is_Aliased 8180 8181 begin 8182 -- A controlled transient object is not considered aliased when it 8183 -- appears inside an expression_with_actions node even when there are 8184 -- explicit aliases of it: 8185 8186 -- do 8187 -- Trans_Id : Ctrl_Typ ...; -- transient object 8188 -- Alias : ... := Trans_Id; -- object is aliased 8189 -- Val : constant Boolean := 8190 -- ... Alias ...; -- aliasing ends 8191 -- <finalize Trans_Id> -- object safe to finalize 8192 -- in Val end; 8193 8194 -- Expansion ensures that all aliases are encapsulated in the actions 8195 -- list and do not leak to the expression by forcing the evaluation 8196 -- of the expression. 8197 8198 if Nkind (Rel_Node) = N_Expression_With_Actions then 8199 return False; 8200 8201 -- Otherwise examine the statements after the controlled transient 8202 -- object and look for various forms of aliasing. 8203 8204 else 8205 Stmt := First_Stmt; 8206 while Present (Stmt) loop 8207 if Nkind (Stmt) = N_Object_Declaration then 8208 Expr := Expression (Stmt); 8209 8210 -- Aliasing of the form: 8211 -- Obj : ... := Trans_Id'reference; 8212 8213 if Present (Expr) 8214 and then Nkind (Expr) = N_Reference 8215 and then Nkind (Prefix (Expr)) = N_Identifier 8216 and then Entity (Prefix (Expr)) = Trans_Id 8217 then 8218 return True; 8219 end if; 8220 8221 elsif Nkind (Stmt) = N_Object_Renaming_Declaration then 8222 Ren_Obj := Find_Renamed_Object (Stmt); 8223 8224 -- Aliasing of the form: 8225 -- Obj : ... renames ... Trans_Id ...; 8226 8227 if Present (Ren_Obj) and then Ren_Obj = Trans_Id then 8228 return True; 8229 end if; 8230 end if; 8231 8232 Next (Stmt); 8233 end loop; 8234 8235 return False; 8236 end if; 8237 end Is_Aliased; 8238 8239 ------------------ 8240 -- Is_Allocated -- 8241 ------------------ 8242 8243 function Is_Allocated (Trans_Id : Entity_Id) return Boolean is 8244 Expr : constant Node_Id := Expression (Parent (Trans_Id)); 8245 begin 8246 return 8247 Is_Access_Type (Etype (Trans_Id)) 8248 and then Present (Expr) 8249 and then Nkind (Expr) = N_Allocator; 8250 end Is_Allocated; 8251 8252 --------------------------- 8253 -- Is_Iterated_Container -- 8254 --------------------------- 8255 8256 function Is_Iterated_Container 8257 (Trans_Id : Entity_Id; 8258 First_Stmt : Node_Id) return Boolean 8259 is 8260 Aspect : Node_Id; 8261 Call : Node_Id; 8262 Iter : Entity_Id; 8263 Param : Node_Id; 8264 Stmt : Node_Id; 8265 Typ : Entity_Id; 8266 8267 begin 8268 -- It is not possible to iterate over containers in non-Ada 2012 code 8269 8270 if Ada_Version < Ada_2012 then 8271 return False; 8272 end if; 8273 8274 Typ := Etype (Trans_Id); 8275 8276 -- Handle access type created for secondary stack use 8277 8278 if Is_Access_Type (Typ) then 8279 Typ := Designated_Type (Typ); 8280 end if; 8281 8282 -- Look for aspect Default_Iterator. It may be part of a type 8283 -- declaration for a container, or inherited from a base type 8284 -- or parent type. 8285 8286 Aspect := Find_Value_Of_Aspect (Typ, Aspect_Default_Iterator); 8287 8288 if Present (Aspect) then 8289 Iter := Entity (Aspect); 8290 8291 -- Examine the statements following the container object and 8292 -- look for a call to the default iterate routine where the 8293 -- first parameter is the transient. Such a call appears as: 8294 8295 -- It : Access_To_CW_Iterator := 8296 -- Iterate (Tran_Id.all, ...)'reference; 8297 8298 Stmt := First_Stmt; 8299 while Present (Stmt) loop 8300 8301 -- Detect an object declaration which is initialized by a 8302 -- secondary stack function call. 8303 8304 if Nkind (Stmt) = N_Object_Declaration 8305 and then Present (Expression (Stmt)) 8306 and then Nkind (Expression (Stmt)) = N_Reference 8307 and then Nkind (Prefix (Expression (Stmt))) = N_Function_Call 8308 then 8309 Call := Prefix (Expression (Stmt)); 8310 8311 -- The call must invoke the default iterate routine of 8312 -- the container and the transient object must appear as 8313 -- the first actual parameter. Skip any calls whose names 8314 -- are not entities. 8315 8316 if Is_Entity_Name (Name (Call)) 8317 and then Entity (Name (Call)) = Iter 8318 and then Present (Parameter_Associations (Call)) 8319 then 8320 Param := First (Parameter_Associations (Call)); 8321 8322 if Nkind (Param) = N_Explicit_Dereference 8323 and then Entity (Prefix (Param)) = Trans_Id 8324 then 8325 return True; 8326 end if; 8327 end if; 8328 end if; 8329 8330 Next (Stmt); 8331 end loop; 8332 end if; 8333 8334 return False; 8335 end Is_Iterated_Container; 8336 8337 -- Local variables 8338 8339 Desig : Entity_Id := Obj_Typ; 8340 8341 -- Start of processing for Is_Finalizable_Transient 8342 8343 begin 8344 -- Handle access types 8345 8346 if Is_Access_Type (Desig) then 8347 Desig := Available_View (Designated_Type (Desig)); 8348 end if; 8349 8350 return 8351 Ekind_In (Obj_Id, E_Constant, E_Variable) 8352 and then Needs_Finalization (Desig) 8353 and then Requires_Transient_Scope (Desig) 8354 and then Nkind (Rel_Node) /= N_Simple_Return_Statement 8355 8356 -- Do not consider a transient object that was already processed 8357 8358 and then not Is_Finalized_Transient (Obj_Id) 8359 8360 -- Do not consider renamed or 'reference-d transient objects because 8361 -- the act of renaming extends the object's lifetime. 8362 8363 and then not Is_Aliased (Obj_Id, Decl) 8364 8365 -- Do not consider transient objects allocated on the heap since 8366 -- they are attached to a finalization master. 8367 8368 and then not Is_Allocated (Obj_Id) 8369 8370 -- If the transient object is a pointer, check that it is not 8371 -- initialized by a function that returns a pointer or acts as a 8372 -- renaming of another pointer. 8373 8374 and then 8375 (not Is_Access_Type (Obj_Typ) 8376 or else not Initialized_By_Access (Obj_Id)) 8377 8378 -- Do not consider transient objects which act as indirect aliases 8379 -- of build-in-place function results. 8380 8381 and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id) 8382 8383 -- Do not consider conversions of tags to class-wide types 8384 8385 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id) 8386 8387 -- Do not consider iterators because those are treated as normal 8388 -- controlled objects and are processed by the usual finalization 8389 -- machinery. This avoids the double finalization of an iterator. 8390 8391 and then not Is_Iterator (Desig) 8392 8393 -- Do not consider containers in the context of iterator loops. Such 8394 -- transient objects must exist for as long as the loop is around, 8395 -- otherwise any operation carried out by the iterator will fail. 8396 8397 and then not Is_Iterated_Container (Obj_Id, Decl); 8398 end Is_Finalizable_Transient; 8399 8400 --------------------------------- 8401 -- Is_Fully_Repped_Tagged_Type -- 8402 --------------------------------- 8403 8404 function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is 8405 U : constant Entity_Id := Underlying_Type (T); 8406 Comp : Entity_Id; 8407 8408 begin 8409 if No (U) or else not Is_Tagged_Type (U) then 8410 return False; 8411 elsif Has_Discriminants (U) then 8412 return False; 8413 elsif not Has_Specified_Layout (U) then 8414 return False; 8415 end if; 8416 8417 -- Here we have a tagged type, see if it has any component (other than 8418 -- tag and parent) with no component_clause. If so, we return False. 8419 8420 Comp := First_Component (U); 8421 while Present (Comp) loop 8422 if not Is_Tag (Comp) 8423 and then Chars (Comp) /= Name_uParent 8424 and then No (Component_Clause (Comp)) 8425 then 8426 return False; 8427 else 8428 Next_Component (Comp); 8429 end if; 8430 end loop; 8431 8432 -- All components have clauses 8433 8434 return True; 8435 end Is_Fully_Repped_Tagged_Type; 8436 8437 ---------------------------------- 8438 -- Is_Library_Level_Tagged_Type -- 8439 ---------------------------------- 8440 8441 function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is 8442 begin 8443 return Is_Tagged_Type (Typ) and then Is_Library_Level_Entity (Typ); 8444 end Is_Library_Level_Tagged_Type; 8445 8446 -------------------------- 8447 -- Is_Non_BIP_Func_Call -- 8448 -------------------------- 8449 8450 function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is 8451 begin 8452 -- The expected call is of the format 8453 -- 8454 -- Func_Call'reference 8455 8456 return 8457 Nkind (Expr) = N_Reference 8458 and then Nkind (Prefix (Expr)) = N_Function_Call 8459 and then not Is_Build_In_Place_Function_Call (Prefix (Expr)); 8460 end Is_Non_BIP_Func_Call; 8461 8462 ---------------------------------- 8463 -- Is_Possibly_Unaligned_Object -- 8464 ---------------------------------- 8465 8466 function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is 8467 T : constant Entity_Id := Etype (N); 8468 8469 begin 8470 -- If renamed object, apply test to underlying object 8471 8472 if Is_Entity_Name (N) 8473 and then Is_Object (Entity (N)) 8474 and then Present (Renamed_Object (Entity (N))) 8475 then 8476 return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N))); 8477 end if; 8478 8479 -- Tagged and controlled types and aliased types are always aligned, as 8480 -- are concurrent types. 8481 8482 if Is_Aliased (T) 8483 or else Has_Controlled_Component (T) 8484 or else Is_Concurrent_Type (T) 8485 or else Is_Tagged_Type (T) 8486 or else Is_Controlled (T) 8487 then 8488 return False; 8489 end if; 8490 8491 -- If this is an element of a packed array, may be unaligned 8492 8493 if Is_Ref_To_Bit_Packed_Array (N) then 8494 return True; 8495 end if; 8496 8497 -- Case of indexed component reference: test whether prefix is unaligned 8498 8499 if Nkind (N) = N_Indexed_Component then 8500 return Is_Possibly_Unaligned_Object (Prefix (N)); 8501 8502 -- Case of selected component reference 8503 8504 elsif Nkind (N) = N_Selected_Component then 8505 declare 8506 P : constant Node_Id := Prefix (N); 8507 C : constant Entity_Id := Entity (Selector_Name (N)); 8508 M : Nat; 8509 S : Nat; 8510 8511 begin 8512 -- If component reference is for an array with nonstatic bounds, 8513 -- then it is always aligned: we can only process unaligned arrays 8514 -- with static bounds (more precisely compile time known bounds). 8515 8516 if Is_Array_Type (T) 8517 and then not Compile_Time_Known_Bounds (T) 8518 then 8519 return False; 8520 end if; 8521 8522 -- If component is aliased, it is definitely properly aligned 8523 8524 if Is_Aliased (C) then 8525 return False; 8526 end if; 8527 8528 -- If component is for a type implemented as a scalar, and the 8529 -- record is packed, and the component is other than the first 8530 -- component of the record, then the component may be unaligned. 8531 8532 if Is_Packed (Etype (P)) 8533 and then Represented_As_Scalar (Etype (C)) 8534 and then First_Entity (Scope (C)) /= C 8535 then 8536 return True; 8537 end if; 8538 8539 -- Compute maximum possible alignment for T 8540 8541 -- If alignment is known, then that settles things 8542 8543 if Known_Alignment (T) then 8544 M := UI_To_Int (Alignment (T)); 8545 8546 -- If alignment is not known, tentatively set max alignment 8547 8548 else 8549 M := Ttypes.Maximum_Alignment; 8550 8551 -- We can reduce this if the Esize is known since the default 8552 -- alignment will never be more than the smallest power of 2 8553 -- that does not exceed this Esize value. 8554 8555 if Known_Esize (T) then 8556 S := UI_To_Int (Esize (T)); 8557 8558 while (M / 2) >= S loop 8559 M := M / 2; 8560 end loop; 8561 end if; 8562 end if; 8563 8564 -- The following code is historical, it used to be present but it 8565 -- is too cautious, because the front-end does not know the proper 8566 -- default alignments for the target. Also, if the alignment is 8567 -- not known, the front end can't know in any case. If a copy is 8568 -- needed, the back-end will take care of it. This whole section 8569 -- including this comment can be removed later ??? 8570 8571 -- If the component reference is for a record that has a specified 8572 -- alignment, and we either know it is too small, or cannot tell, 8573 -- then the component may be unaligned. 8574 8575 -- What is the following commented out code ??? 8576 8577 -- if Known_Alignment (Etype (P)) 8578 -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment 8579 -- and then M > Alignment (Etype (P)) 8580 -- then 8581 -- return True; 8582 -- end if; 8583 8584 -- Case of component clause present which may specify an 8585 -- unaligned position. 8586 8587 if Present (Component_Clause (C)) then 8588 8589 -- Otherwise we can do a test to make sure that the actual 8590 -- start position in the record, and the length, are both 8591 -- consistent with the required alignment. If not, we know 8592 -- that we are unaligned. 8593 8594 declare 8595 Align_In_Bits : constant Nat := M * System_Storage_Unit; 8596 Comp : Entity_Id; 8597 8598 begin 8599 Comp := C; 8600 8601 -- For a component inherited in a record extension, the 8602 -- clause is inherited but position and size are not set. 8603 8604 if Is_Base_Type (Etype (P)) 8605 and then Is_Tagged_Type (Etype (P)) 8606 and then Present (Original_Record_Component (Comp)) 8607 then 8608 Comp := Original_Record_Component (Comp); 8609 end if; 8610 8611 if Component_Bit_Offset (Comp) mod Align_In_Bits /= 0 8612 or else Esize (Comp) mod Align_In_Bits /= 0 8613 then 8614 return True; 8615 end if; 8616 end; 8617 end if; 8618 8619 -- Otherwise, for a component reference, test prefix 8620 8621 return Is_Possibly_Unaligned_Object (P); 8622 end; 8623 8624 -- If not a component reference, must be aligned 8625 8626 else 8627 return False; 8628 end if; 8629 end Is_Possibly_Unaligned_Object; 8630 8631 --------------------------------- 8632 -- Is_Possibly_Unaligned_Slice -- 8633 --------------------------------- 8634 8635 function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is 8636 begin 8637 -- Go to renamed object 8638 8639 if Is_Entity_Name (N) 8640 and then Is_Object (Entity (N)) 8641 and then Present (Renamed_Object (Entity (N))) 8642 then 8643 return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N))); 8644 end if; 8645 8646 -- The reference must be a slice 8647 8648 if Nkind (N) /= N_Slice then 8649 return False; 8650 end if; 8651 8652 -- If it is a slice, then look at the array type being sliced 8653 8654 declare 8655 Sarr : constant Node_Id := Prefix (N); 8656 -- Prefix of the slice, i.e. the array being sliced 8657 8658 Styp : constant Entity_Id := Etype (Prefix (N)); 8659 -- Type of the array being sliced 8660 8661 Pref : Node_Id; 8662 Ptyp : Entity_Id; 8663 8664 begin 8665 -- The problems arise if the array object that is being sliced 8666 -- is a component of a record or array, and we cannot guarantee 8667 -- the alignment of the array within its containing object. 8668 8669 -- To investigate this, we look at successive prefixes to see 8670 -- if we have a worrisome indexed or selected component. 8671 8672 Pref := Sarr; 8673 loop 8674 -- Case of array is part of an indexed component reference 8675 8676 if Nkind (Pref) = N_Indexed_Component then 8677 Ptyp := Etype (Prefix (Pref)); 8678 8679 -- The only problematic case is when the array is packed, in 8680 -- which case we really know nothing about the alignment of 8681 -- individual components. 8682 8683 if Is_Bit_Packed_Array (Ptyp) then 8684 return True; 8685 end if; 8686 8687 -- Case of array is part of a selected component reference 8688 8689 elsif Nkind (Pref) = N_Selected_Component then 8690 Ptyp := Etype (Prefix (Pref)); 8691 8692 -- We are definitely in trouble if the record in question 8693 -- has an alignment, and either we know this alignment is 8694 -- inconsistent with the alignment of the slice, or we don't 8695 -- know what the alignment of the slice should be. But this 8696 -- really matters only if the target has strict alignment. 8697 8698 if Target_Strict_Alignment 8699 and then Known_Alignment (Ptyp) 8700 and then (Unknown_Alignment (Styp) 8701 or else Alignment (Styp) > Alignment (Ptyp)) 8702 then 8703 return True; 8704 end if; 8705 8706 -- We are in potential trouble if the record type is packed. 8707 -- We could special case when we know that the array is the 8708 -- first component, but that's not such a simple case ??? 8709 8710 if Is_Packed (Ptyp) then 8711 return True; 8712 end if; 8713 8714 -- We are in trouble if there is a component clause, and 8715 -- either we do not know the alignment of the slice, or 8716 -- the alignment of the slice is inconsistent with the 8717 -- bit position specified by the component clause. 8718 8719 declare 8720 Field : constant Entity_Id := Entity (Selector_Name (Pref)); 8721 begin 8722 if Present (Component_Clause (Field)) 8723 and then 8724 (Unknown_Alignment (Styp) 8725 or else 8726 (Component_Bit_Offset (Field) mod 8727 (System_Storage_Unit * Alignment (Styp))) /= 0) 8728 then 8729 return True; 8730 end if; 8731 end; 8732 8733 -- For cases other than selected or indexed components we know we 8734 -- are OK, since no issues arise over alignment. 8735 8736 else 8737 return False; 8738 end if; 8739 8740 -- We processed an indexed component or selected component 8741 -- reference that looked safe, so keep checking prefixes. 8742 8743 Pref := Prefix (Pref); 8744 end loop; 8745 end; 8746 end Is_Possibly_Unaligned_Slice; 8747 8748 ------------------------------- 8749 -- Is_Related_To_Func_Return -- 8750 ------------------------------- 8751 8752 function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is 8753 Expr : constant Node_Id := Related_Expression (Id); 8754 begin 8755 return 8756 Present (Expr) 8757 and then Nkind (Expr) = N_Explicit_Dereference 8758 and then Nkind (Parent (Expr)) = N_Simple_Return_Statement; 8759 end Is_Related_To_Func_Return; 8760 8761 -------------------------------- 8762 -- Is_Ref_To_Bit_Packed_Array -- 8763 -------------------------------- 8764 8765 function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is 8766 Result : Boolean; 8767 Expr : Node_Id; 8768 8769 begin 8770 if Is_Entity_Name (N) 8771 and then Is_Object (Entity (N)) 8772 and then Present (Renamed_Object (Entity (N))) 8773 then 8774 return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N))); 8775 end if; 8776 8777 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then 8778 if Is_Bit_Packed_Array (Etype (Prefix (N))) then 8779 Result := True; 8780 else 8781 Result := Is_Ref_To_Bit_Packed_Array (Prefix (N)); 8782 end if; 8783 8784 if Result and then Nkind (N) = N_Indexed_Component then 8785 Expr := First (Expressions (N)); 8786 while Present (Expr) loop 8787 Force_Evaluation (Expr); 8788 Next (Expr); 8789 end loop; 8790 end if; 8791 8792 return Result; 8793 8794 else 8795 return False; 8796 end if; 8797 end Is_Ref_To_Bit_Packed_Array; 8798 8799 -------------------------------- 8800 -- Is_Ref_To_Bit_Packed_Slice -- 8801 -------------------------------- 8802 8803 function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is 8804 begin 8805 if Nkind (N) = N_Type_Conversion then 8806 return Is_Ref_To_Bit_Packed_Slice (Expression (N)); 8807 8808 elsif Is_Entity_Name (N) 8809 and then Is_Object (Entity (N)) 8810 and then Present (Renamed_Object (Entity (N))) 8811 then 8812 return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N))); 8813 8814 elsif Nkind (N) = N_Slice 8815 and then Is_Bit_Packed_Array (Etype (Prefix (N))) 8816 then 8817 return True; 8818 8819 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then 8820 return Is_Ref_To_Bit_Packed_Slice (Prefix (N)); 8821 8822 else 8823 return False; 8824 end if; 8825 end Is_Ref_To_Bit_Packed_Slice; 8826 8827 ----------------------- 8828 -- Is_Renamed_Object -- 8829 ----------------------- 8830 8831 function Is_Renamed_Object (N : Node_Id) return Boolean is 8832 Pnod : constant Node_Id := Parent (N); 8833 Kind : constant Node_Kind := Nkind (Pnod); 8834 begin 8835 if Kind = N_Object_Renaming_Declaration then 8836 return True; 8837 elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then 8838 return Is_Renamed_Object (Pnod); 8839 else 8840 return False; 8841 end if; 8842 end Is_Renamed_Object; 8843 8844 -------------------------------------- 8845 -- Is_Secondary_Stack_BIP_Func_Call -- 8846 -------------------------------------- 8847 8848 function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is 8849 Alloc_Nam : Name_Id := No_Name; 8850 Actual : Node_Id; 8851 Call : Node_Id := Expr; 8852 Formal : Node_Id; 8853 Param : Node_Id; 8854 8855 begin 8856 -- Build-in-place calls usually appear in 'reference format. Note that 8857 -- the accessibility check machinery may add an extra 'reference due to 8858 -- side effect removal. 8859 8860 while Nkind (Call) = N_Reference loop 8861 Call := Prefix (Call); 8862 end loop; 8863 8864 Call := Unqual_Conv (Call); 8865 8866 if Is_Build_In_Place_Function_Call (Call) then 8867 8868 -- Examine all parameter associations of the function call 8869 8870 Param := First (Parameter_Associations (Call)); 8871 while Present (Param) loop 8872 if Nkind (Param) = N_Parameter_Association then 8873 Formal := Selector_Name (Param); 8874 Actual := Explicit_Actual_Parameter (Param); 8875 8876 -- Construct the name of formal BIPalloc. It is much easier to 8877 -- extract the name of the function using an arbitrary formal's 8878 -- scope rather than the Name field of Call. 8879 8880 if Alloc_Nam = No_Name and then Present (Entity (Formal)) then 8881 Alloc_Nam := 8882 New_External_Name 8883 (Chars (Scope (Entity (Formal))), 8884 BIP_Formal_Suffix (BIP_Alloc_Form)); 8885 end if; 8886 8887 -- A match for BIPalloc => 2 has been found 8888 8889 if Chars (Formal) = Alloc_Nam 8890 and then Nkind (Actual) = N_Integer_Literal 8891 and then Intval (Actual) = Uint_2 8892 then 8893 return True; 8894 end if; 8895 end if; 8896 8897 Next (Param); 8898 end loop; 8899 end if; 8900 8901 return False; 8902 end Is_Secondary_Stack_BIP_Func_Call; 8903 8904 ------------------------------------- 8905 -- Is_Tag_To_Class_Wide_Conversion -- 8906 ------------------------------------- 8907 8908 function Is_Tag_To_Class_Wide_Conversion 8909 (Obj_Id : Entity_Id) return Boolean 8910 is 8911 Expr : constant Node_Id := Expression (Parent (Obj_Id)); 8912 8913 begin 8914 return 8915 Is_Class_Wide_Type (Etype (Obj_Id)) 8916 and then Present (Expr) 8917 and then Nkind (Expr) = N_Unchecked_Type_Conversion 8918 and then Etype (Expression (Expr)) = RTE (RE_Tag); 8919 end Is_Tag_To_Class_Wide_Conversion; 8920 8921 ---------------------------- 8922 -- Is_Untagged_Derivation -- 8923 ---------------------------- 8924 8925 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is 8926 begin 8927 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T)) 8928 or else 8929 (Is_Private_Type (T) and then Present (Full_View (T)) 8930 and then not Is_Tagged_Type (Full_View (T)) 8931 and then Is_Derived_Type (Full_View (T)) 8932 and then Etype (Full_View (T)) /= T); 8933 end Is_Untagged_Derivation; 8934 8935 ------------------------------------ 8936 -- Is_Untagged_Private_Derivation -- 8937 ------------------------------------ 8938 8939 function Is_Untagged_Private_Derivation 8940 (Priv_Typ : Entity_Id; 8941 Full_Typ : Entity_Id) return Boolean 8942 is 8943 begin 8944 return 8945 Present (Priv_Typ) 8946 and then Is_Untagged_Derivation (Priv_Typ) 8947 and then Is_Private_Type (Etype (Priv_Typ)) 8948 and then Present (Full_Typ) 8949 and then Is_Itype (Full_Typ); 8950 end Is_Untagged_Private_Derivation; 8951 8952 ------------------------------ 8953 -- Is_Verifiable_DIC_Pragma -- 8954 ------------------------------ 8955 8956 function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean is 8957 Args : constant List_Id := Pragma_Argument_Associations (Prag); 8958 8959 begin 8960 -- To qualify as verifiable, a DIC pragma must have a non-null argument 8961 8962 return 8963 Present (Args) 8964 and then Nkind (Get_Pragma_Arg (First (Args))) /= N_Null; 8965 end Is_Verifiable_DIC_Pragma; 8966 8967 --------------------------- 8968 -- Is_Volatile_Reference -- 8969 --------------------------- 8970 8971 function Is_Volatile_Reference (N : Node_Id) return Boolean is 8972 begin 8973 -- Only source references are to be treated as volatile, internally 8974 -- generated stuff cannot have volatile external effects. 8975 8976 if not Comes_From_Source (N) then 8977 return False; 8978 8979 -- Never true for reference to a type 8980 8981 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then 8982 return False; 8983 8984 -- Never true for a compile time known constant 8985 8986 elsif Compile_Time_Known_Value (N) then 8987 return False; 8988 8989 -- True if object reference with volatile type 8990 8991 elsif Is_Volatile_Object (N) then 8992 return True; 8993 8994 -- True if reference to volatile entity 8995 8996 elsif Is_Entity_Name (N) then 8997 return Treat_As_Volatile (Entity (N)); 8998 8999 -- True for slice of volatile array 9000 9001 elsif Nkind (N) = N_Slice then 9002 return Is_Volatile_Reference (Prefix (N)); 9003 9004 -- True if volatile component 9005 9006 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then 9007 if (Is_Entity_Name (Prefix (N)) 9008 and then Has_Volatile_Components (Entity (Prefix (N)))) 9009 or else (Present (Etype (Prefix (N))) 9010 and then Has_Volatile_Components (Etype (Prefix (N)))) 9011 then 9012 return True; 9013 else 9014 return Is_Volatile_Reference (Prefix (N)); 9015 end if; 9016 9017 -- Otherwise false 9018 9019 else 9020 return False; 9021 end if; 9022 end Is_Volatile_Reference; 9023 9024 -------------------- 9025 -- Kill_Dead_Code -- 9026 -------------------- 9027 9028 procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is 9029 W : Boolean := Warn; 9030 -- Set False if warnings suppressed 9031 9032 begin 9033 if Present (N) then 9034 Remove_Warning_Messages (N); 9035 9036 -- Update the internal structures of the ABE mechanism in case the 9037 -- dead node is an elaboration scenario. 9038 9039 Kill_Elaboration_Scenario (N); 9040 9041 -- Generate warning if appropriate 9042 9043 if W then 9044 9045 -- We suppress the warning if this code is under control of an 9046 -- if statement, whose condition is a simple identifier, and 9047 -- either we are in an instance, or warnings off is set for this 9048 -- identifier. The reason for killing it in the instance case is 9049 -- that it is common and reasonable for code to be deleted in 9050 -- instances for various reasons. 9051 9052 -- Could we use Is_Statically_Unevaluated here??? 9053 9054 if Nkind (Parent (N)) = N_If_Statement then 9055 declare 9056 C : constant Node_Id := Condition (Parent (N)); 9057 begin 9058 if Nkind (C) = N_Identifier 9059 and then 9060 (In_Instance 9061 or else (Present (Entity (C)) 9062 and then Has_Warnings_Off (Entity (C)))) 9063 then 9064 W := False; 9065 end if; 9066 end; 9067 end if; 9068 9069 -- Generate warning if not suppressed 9070 9071 if W then 9072 Error_Msg_F 9073 ("?t?this code can never be executed and has been deleted!", 9074 N); 9075 end if; 9076 end if; 9077 9078 -- Recurse into block statements and bodies to process declarations 9079 -- and statements. 9080 9081 if Nkind (N) = N_Block_Statement 9082 or else Nkind (N) = N_Subprogram_Body 9083 or else Nkind (N) = N_Package_Body 9084 then 9085 Kill_Dead_Code (Declarations (N), False); 9086 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N))); 9087 9088 if Nkind (N) = N_Subprogram_Body then 9089 Set_Is_Eliminated (Defining_Entity (N)); 9090 end if; 9091 9092 elsif Nkind (N) = N_Package_Declaration then 9093 Kill_Dead_Code (Visible_Declarations (Specification (N))); 9094 Kill_Dead_Code (Private_Declarations (Specification (N))); 9095 9096 -- ??? After this point, Delete_Tree has been called on all 9097 -- declarations in Specification (N), so references to entities 9098 -- therein look suspicious. 9099 9100 declare 9101 E : Entity_Id := First_Entity (Defining_Entity (N)); 9102 9103 begin 9104 while Present (E) loop 9105 if Ekind (E) = E_Operator then 9106 Set_Is_Eliminated (E); 9107 end if; 9108 9109 Next_Entity (E); 9110 end loop; 9111 end; 9112 9113 -- Recurse into composite statement to kill individual statements in 9114 -- particular instantiations. 9115 9116 elsif Nkind (N) = N_If_Statement then 9117 Kill_Dead_Code (Then_Statements (N)); 9118 Kill_Dead_Code (Elsif_Parts (N)); 9119 Kill_Dead_Code (Else_Statements (N)); 9120 9121 elsif Nkind (N) = N_Loop_Statement then 9122 Kill_Dead_Code (Statements (N)); 9123 9124 elsif Nkind (N) = N_Case_Statement then 9125 declare 9126 Alt : Node_Id; 9127 begin 9128 Alt := First (Alternatives (N)); 9129 while Present (Alt) loop 9130 Kill_Dead_Code (Statements (Alt)); 9131 Next (Alt); 9132 end loop; 9133 end; 9134 9135 elsif Nkind (N) = N_Case_Statement_Alternative then 9136 Kill_Dead_Code (Statements (N)); 9137 9138 -- Deal with dead instances caused by deleting instantiations 9139 9140 elsif Nkind (N) in N_Generic_Instantiation then 9141 Remove_Dead_Instance (N); 9142 end if; 9143 end if; 9144 end Kill_Dead_Code; 9145 9146 -- Case where argument is a list of nodes to be killed 9147 9148 procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is 9149 N : Node_Id; 9150 W : Boolean; 9151 9152 begin 9153 W := Warn; 9154 9155 if Is_Non_Empty_List (L) then 9156 N := First (L); 9157 while Present (N) loop 9158 Kill_Dead_Code (N, W); 9159 W := False; 9160 Next (N); 9161 end loop; 9162 end if; 9163 end Kill_Dead_Code; 9164 9165 ------------------------ 9166 -- Known_Non_Negative -- 9167 ------------------------ 9168 9169 function Known_Non_Negative (Opnd : Node_Id) return Boolean is 9170 begin 9171 if Is_OK_Static_Expression (Opnd) and then Expr_Value (Opnd) >= 0 then 9172 return True; 9173 9174 else 9175 declare 9176 Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd)); 9177 begin 9178 return 9179 Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0; 9180 end; 9181 end if; 9182 end Known_Non_Negative; 9183 9184 ----------------------------- 9185 -- Make_CW_Equivalent_Type -- 9186 ----------------------------- 9187 9188 -- Create a record type used as an equivalent of any member of the class 9189 -- which takes its size from exp. 9190 9191 -- Generate the following code: 9192 9193 -- type Equiv_T is record 9194 -- _parent : T (List of discriminant constraints taken from Exp); 9195 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8); 9196 -- end Equiv_T; 9197 -- 9198 -- ??? Note that this type does not guarantee same alignment as all 9199 -- derived types 9200 -- 9201 -- Note: for the freezing circuitry, this looks like a record extension, 9202 -- and so we need to make sure that the scalar storage order is the same 9203 -- as that of the parent type. (This does not change anything for the 9204 -- representation of the extension part.) 9205 9206 function Make_CW_Equivalent_Type 9207 (T : Entity_Id; 9208 E : Node_Id) return Entity_Id 9209 is 9210 Loc : constant Source_Ptr := Sloc (E); 9211 Root_Typ : constant Entity_Id := Root_Type (T); 9212 Root_Utyp : constant Entity_Id := Underlying_Type (Root_Typ); 9213 List_Def : constant List_Id := Empty_List; 9214 Comp_List : constant List_Id := New_List; 9215 Equiv_Type : Entity_Id; 9216 Range_Type : Entity_Id; 9217 Str_Type : Entity_Id; 9218 Constr_Root : Entity_Id; 9219 Sizexpr : Node_Id; 9220 9221 begin 9222 -- If the root type is already constrained, there are no discriminants 9223 -- in the expression. 9224 9225 if not Has_Discriminants (Root_Typ) 9226 or else Is_Constrained (Root_Typ) 9227 then 9228 Constr_Root := Root_Typ; 9229 9230 -- At this point in the expansion, nonlimited view of the type 9231 -- must be available, otherwise the error will be reported later. 9232 9233 if From_Limited_With (Constr_Root) 9234 and then Present (Non_Limited_View (Constr_Root)) 9235 then 9236 Constr_Root := Non_Limited_View (Constr_Root); 9237 end if; 9238 9239 else 9240 Constr_Root := Make_Temporary (Loc, 'R'); 9241 9242 -- subtype cstr__n is T (List of discr constraints taken from Exp) 9243 9244 Append_To (List_Def, 9245 Make_Subtype_Declaration (Loc, 9246 Defining_Identifier => Constr_Root, 9247 Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ))); 9248 end if; 9249 9250 -- Generate the range subtype declaration 9251 9252 Range_Type := Make_Temporary (Loc, 'G'); 9253 9254 if not Is_Interface (Root_Typ) then 9255 9256 -- subtype rg__xx is 9257 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit 9258 9259 Sizexpr := 9260 Make_Op_Subtract (Loc, 9261 Left_Opnd => 9262 Make_Attribute_Reference (Loc, 9263 Prefix => 9264 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)), 9265 Attribute_Name => Name_Size), 9266 Right_Opnd => 9267 Make_Attribute_Reference (Loc, 9268 Prefix => New_Occurrence_Of (Constr_Root, Loc), 9269 Attribute_Name => Name_Object_Size)); 9270 else 9271 -- subtype rg__xx is 9272 -- Storage_Offset range 1 .. Expr'size / Storage_Unit 9273 9274 Sizexpr := 9275 Make_Attribute_Reference (Loc, 9276 Prefix => 9277 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)), 9278 Attribute_Name => Name_Size); 9279 end if; 9280 9281 Set_Paren_Count (Sizexpr, 1); 9282 9283 Append_To (List_Def, 9284 Make_Subtype_Declaration (Loc, 9285 Defining_Identifier => Range_Type, 9286 Subtype_Indication => 9287 Make_Subtype_Indication (Loc, 9288 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc), 9289 Constraint => Make_Range_Constraint (Loc, 9290 Range_Expression => 9291 Make_Range (Loc, 9292 Low_Bound => Make_Integer_Literal (Loc, 1), 9293 High_Bound => 9294 Make_Op_Divide (Loc, 9295 Left_Opnd => Sizexpr, 9296 Right_Opnd => Make_Integer_Literal (Loc, 9297 Intval => System_Storage_Unit))))))); 9298 9299 -- subtype str__nn is Storage_Array (rg__x); 9300 9301 Str_Type := Make_Temporary (Loc, 'S'); 9302 Append_To (List_Def, 9303 Make_Subtype_Declaration (Loc, 9304 Defining_Identifier => Str_Type, 9305 Subtype_Indication => 9306 Make_Subtype_Indication (Loc, 9307 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Array), Loc), 9308 Constraint => 9309 Make_Index_Or_Discriminant_Constraint (Loc, 9310 Constraints => 9311 New_List (New_Occurrence_Of (Range_Type, Loc)))))); 9312 9313 -- type Equiv_T is record 9314 -- [ _parent : Tnn; ] 9315 -- E : Str_Type; 9316 -- end Equiv_T; 9317 9318 Equiv_Type := Make_Temporary (Loc, 'T'); 9319 Set_Ekind (Equiv_Type, E_Record_Type); 9320 Set_Parent_Subtype (Equiv_Type, Constr_Root); 9321 9322 -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special 9323 -- treatment for this type. In particular, even though _parent's type 9324 -- is a controlled type or contains controlled components, we do not 9325 -- want to set Has_Controlled_Component on it to avoid making it gain 9326 -- an unwanted _controller component. 9327 9328 Set_Is_Class_Wide_Equivalent_Type (Equiv_Type); 9329 9330 -- A class-wide equivalent type does not require initialization 9331 9332 Set_Suppress_Initialization (Equiv_Type); 9333 9334 if not Is_Interface (Root_Typ) then 9335 Append_To (Comp_List, 9336 Make_Component_Declaration (Loc, 9337 Defining_Identifier => 9338 Make_Defining_Identifier (Loc, Name_uParent), 9339 Component_Definition => 9340 Make_Component_Definition (Loc, 9341 Aliased_Present => False, 9342 Subtype_Indication => New_Occurrence_Of (Constr_Root, Loc)))); 9343 9344 Set_Reverse_Storage_Order 9345 (Equiv_Type, Reverse_Storage_Order (Base_Type (Root_Utyp))); 9346 Set_Reverse_Bit_Order 9347 (Equiv_Type, Reverse_Bit_Order (Base_Type (Root_Utyp))); 9348 end if; 9349 9350 Append_To (Comp_List, 9351 Make_Component_Declaration (Loc, 9352 Defining_Identifier => Make_Temporary (Loc, 'C'), 9353 Component_Definition => 9354 Make_Component_Definition (Loc, 9355 Aliased_Present => False, 9356 Subtype_Indication => New_Occurrence_Of (Str_Type, Loc)))); 9357 9358 Append_To (List_Def, 9359 Make_Full_Type_Declaration (Loc, 9360 Defining_Identifier => Equiv_Type, 9361 Type_Definition => 9362 Make_Record_Definition (Loc, 9363 Component_List => 9364 Make_Component_List (Loc, 9365 Component_Items => Comp_List, 9366 Variant_Part => Empty)))); 9367 9368 -- Suppress all checks during the analysis of the expanded code to avoid 9369 -- the generation of spurious warnings under ZFP run-time. 9370 9371 Insert_Actions (E, List_Def, Suppress => All_Checks); 9372 return Equiv_Type; 9373 end Make_CW_Equivalent_Type; 9374 9375 ------------------------- 9376 -- Make_Invariant_Call -- 9377 ------------------------- 9378 9379 function Make_Invariant_Call (Expr : Node_Id) return Node_Id is 9380 Loc : constant Source_Ptr := Sloc (Expr); 9381 Typ : constant Entity_Id := Base_Type (Etype (Expr)); 9382 9383 Proc_Id : Entity_Id; 9384 9385 begin 9386 pragma Assert (Has_Invariants (Typ)); 9387 9388 Proc_Id := Invariant_Procedure (Typ); 9389 pragma Assert (Present (Proc_Id)); 9390 9391 -- Ignore the invariant if that policy is in effect 9392 9393 if Invariants_Ignored (Typ) then 9394 return Make_Null_Statement (Loc); 9395 else 9396 return 9397 Make_Procedure_Call_Statement (Loc, 9398 Name => New_Occurrence_Of (Proc_Id, Loc), 9399 Parameter_Associations => New_List (Relocate_Node (Expr))); 9400 end if; 9401 end Make_Invariant_Call; 9402 9403 ------------------------ 9404 -- Make_Literal_Range -- 9405 ------------------------ 9406 9407 function Make_Literal_Range 9408 (Loc : Source_Ptr; 9409 Literal_Typ : Entity_Id) return Node_Id 9410 is 9411 Lo : constant Node_Id := 9412 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ)); 9413 Index : constant Entity_Id := Etype (Lo); 9414 Length_Expr : constant Node_Id := 9415 Make_Op_Subtract (Loc, 9416 Left_Opnd => 9417 Make_Integer_Literal (Loc, 9418 Intval => String_Literal_Length (Literal_Typ)), 9419 Right_Opnd => Make_Integer_Literal (Loc, 1)); 9420 9421 Hi : Node_Id; 9422 9423 begin 9424 Set_Analyzed (Lo, False); 9425 9426 if Is_Integer_Type (Index) then 9427 Hi := 9428 Make_Op_Add (Loc, 9429 Left_Opnd => New_Copy_Tree (Lo), 9430 Right_Opnd => Length_Expr); 9431 else 9432 Hi := 9433 Make_Attribute_Reference (Loc, 9434 Attribute_Name => Name_Val, 9435 Prefix => New_Occurrence_Of (Index, Loc), 9436 Expressions => New_List ( 9437 Make_Op_Add (Loc, 9438 Left_Opnd => 9439 Make_Attribute_Reference (Loc, 9440 Attribute_Name => Name_Pos, 9441 Prefix => New_Occurrence_Of (Index, Loc), 9442 Expressions => New_List (New_Copy_Tree (Lo))), 9443 Right_Opnd => Length_Expr))); 9444 end if; 9445 9446 return 9447 Make_Range (Loc, 9448 Low_Bound => Lo, 9449 High_Bound => Hi); 9450 end Make_Literal_Range; 9451 9452 -------------------------- 9453 -- Make_Non_Empty_Check -- 9454 -------------------------- 9455 9456 function Make_Non_Empty_Check 9457 (Loc : Source_Ptr; 9458 N : Node_Id) return Node_Id 9459 is 9460 begin 9461 return 9462 Make_Op_Ne (Loc, 9463 Left_Opnd => 9464 Make_Attribute_Reference (Loc, 9465 Attribute_Name => Name_Length, 9466 Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)), 9467 Right_Opnd => 9468 Make_Integer_Literal (Loc, 0)); 9469 end Make_Non_Empty_Check; 9470 9471 ------------------------- 9472 -- Make_Predicate_Call -- 9473 ------------------------- 9474 9475 -- WARNING: This routine manages Ghost regions. Return statements must be 9476 -- replaced by gotos which jump to the end of the routine and restore the 9477 -- Ghost mode. 9478 9479 function Make_Predicate_Call 9480 (Typ : Entity_Id; 9481 Expr : Node_Id; 9482 Mem : Boolean := False) return Node_Id 9483 is 9484 Loc : constant Source_Ptr := Sloc (Expr); 9485 9486 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 9487 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 9488 -- Save the Ghost-related attributes to restore on exit 9489 9490 Call : Node_Id; 9491 Func_Id : Entity_Id; 9492 9493 begin 9494 Func_Id := Predicate_Function (Typ); 9495 pragma Assert (Present (Func_Id)); 9496 9497 -- The related type may be subject to pragma Ghost. Set the mode now to 9498 -- ensure that the call is properly marked as Ghost. 9499 9500 Set_Ghost_Mode (Typ); 9501 9502 -- Call special membership version if requested and available 9503 9504 if Mem and then Present (Predicate_Function_M (Typ)) then 9505 Func_Id := Predicate_Function_M (Typ); 9506 end if; 9507 9508 -- Case of calling normal predicate function 9509 9510 -- If the type is tagged, the expression may be class-wide, in which 9511 -- case it has to be converted to its root type, given that the 9512 -- generated predicate function is not dispatching. The conversion is 9513 -- type-safe and does not need validation, which matters when private 9514 -- extensions are involved. 9515 9516 if Is_Tagged_Type (Typ) then 9517 Call := 9518 Make_Function_Call (Loc, 9519 Name => New_Occurrence_Of (Func_Id, Loc), 9520 Parameter_Associations => 9521 New_List (OK_Convert_To (Typ, Relocate_Node (Expr)))); 9522 else 9523 Call := 9524 Make_Function_Call (Loc, 9525 Name => New_Occurrence_Of (Func_Id, Loc), 9526 Parameter_Associations => New_List (Relocate_Node (Expr))); 9527 end if; 9528 9529 Restore_Ghost_Region (Saved_GM, Saved_IGR); 9530 9531 return Call; 9532 end Make_Predicate_Call; 9533 9534 -------------------------- 9535 -- Make_Predicate_Check -- 9536 -------------------------- 9537 9538 function Make_Predicate_Check 9539 (Typ : Entity_Id; 9540 Expr : Node_Id) return Node_Id 9541 is 9542 Loc : constant Source_Ptr := Sloc (Expr); 9543 9544 procedure Add_Failure_Expression (Args : List_Id); 9545 -- Add the failure expression of pragma Predicate_Failure (if any) to 9546 -- list Args. 9547 9548 ---------------------------- 9549 -- Add_Failure_Expression -- 9550 ---------------------------- 9551 9552 procedure Add_Failure_Expression (Args : List_Id) is 9553 function Failure_Expression return Node_Id; 9554 pragma Inline (Failure_Expression); 9555 -- Find aspect or pragma Predicate_Failure that applies to type Typ 9556 -- and return its expression. Return Empty if no such annotation is 9557 -- available. 9558 9559 function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean; 9560 pragma Inline (Is_OK_PF_Aspect); 9561 -- Determine whether aspect Asp is a suitable Predicate_Failure 9562 -- aspect that applies to type Typ. 9563 9564 function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean; 9565 pragma Inline (Is_OK_PF_Pragma); 9566 -- Determine whether pragma Prag is a suitable Predicate_Failure 9567 -- pragma that applies to type Typ. 9568 9569 procedure Replace_Subtype_Reference (N : Node_Id); 9570 -- Replace the current instance of type Typ denoted by N with 9571 -- expression Expr. 9572 9573 ------------------------ 9574 -- Failure_Expression -- 9575 ------------------------ 9576 9577 function Failure_Expression return Node_Id is 9578 Item : Node_Id; 9579 9580 begin 9581 -- The management of the rep item chain involves "inheritance" of 9582 -- parent type chains. If a parent [sub]type is already subject to 9583 -- pragma Predicate_Failure, then the pragma will also appear in 9584 -- the chain of the child [sub]type, which in turn may possess a 9585 -- pragma of its own. Avoid order-dependent issues by inspecting 9586 -- the rep item chain directly. Note that routine Get_Pragma may 9587 -- return a parent pragma. 9588 9589 Item := First_Rep_Item (Typ); 9590 while Present (Item) loop 9591 9592 -- Predicate_Failure appears as an aspect 9593 9594 if Nkind (Item) = N_Aspect_Specification 9595 and then Is_OK_PF_Aspect (Item) 9596 then 9597 return Expression (Item); 9598 9599 -- Predicate_Failure appears as a pragma 9600 9601 elsif Nkind (Item) = N_Pragma 9602 and then Is_OK_PF_Pragma (Item) 9603 then 9604 return 9605 Get_Pragma_Arg 9606 (Next (First (Pragma_Argument_Associations (Item)))); 9607 end if; 9608 9609 Item := Next_Rep_Item (Item); 9610 end loop; 9611 9612 return Empty; 9613 end Failure_Expression; 9614 9615 --------------------- 9616 -- Is_OK_PF_Aspect -- 9617 --------------------- 9618 9619 function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean is 9620 begin 9621 -- To qualify, the aspect must apply to the type subjected to the 9622 -- predicate check. 9623 9624 return 9625 Chars (Identifier (Asp)) = Name_Predicate_Failure 9626 and then Present (Entity (Asp)) 9627 and then Entity (Asp) = Typ; 9628 end Is_OK_PF_Aspect; 9629 9630 --------------------- 9631 -- Is_OK_PF_Pragma -- 9632 --------------------- 9633 9634 function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean is 9635 Args : constant List_Id := Pragma_Argument_Associations (Prag); 9636 Typ_Arg : Node_Id; 9637 9638 begin 9639 -- Nothing to do when the pragma does not denote Predicate_Failure 9640 9641 if Pragma_Name (Prag) /= Name_Predicate_Failure then 9642 return False; 9643 9644 -- Nothing to do when the pragma lacks arguments, in which case it 9645 -- is illegal. 9646 9647 elsif No (Args) or else Is_Empty_List (Args) then 9648 return False; 9649 end if; 9650 9651 Typ_Arg := Get_Pragma_Arg (First (Args)); 9652 9653 -- To qualify, the local name argument of the pragma must denote 9654 -- the type subjected to the predicate check. 9655 9656 return 9657 Is_Entity_Name (Typ_Arg) 9658 and then Present (Entity (Typ_Arg)) 9659 and then Entity (Typ_Arg) = Typ; 9660 end Is_OK_PF_Pragma; 9661 9662 -------------------------------- 9663 -- Replace_Subtype_Reference -- 9664 -------------------------------- 9665 9666 procedure Replace_Subtype_Reference (N : Node_Id) is 9667 begin 9668 Rewrite (N, New_Copy_Tree (Expr)); 9669 9670 -- We want to treat the node as if it comes from source, so that 9671 -- ASIS will not ignore it. 9672 9673 Set_Comes_From_Source (N, True); 9674 end Replace_Subtype_Reference; 9675 9676 procedure Replace_Subtype_References is 9677 new Replace_Type_References_Generic (Replace_Subtype_Reference); 9678 9679 -- Local variables 9680 9681 PF_Expr : constant Node_Id := Failure_Expression; 9682 Expr : Node_Id; 9683 9684 -- Start of processing for Add_Failure_Expression 9685 9686 begin 9687 if Present (PF_Expr) then 9688 9689 -- Replace any occurrences of the current instance of the type 9690 -- with the object subjected to the predicate check. 9691 9692 Expr := New_Copy_Tree (PF_Expr); 9693 Replace_Subtype_References (Expr, Typ); 9694 9695 -- The failure expression appears as the third argument of the 9696 -- Check pragma. 9697 9698 Append_To (Args, 9699 Make_Pragma_Argument_Association (Loc, 9700 Expression => Expr)); 9701 end if; 9702 end Add_Failure_Expression; 9703 9704 -- Local variables 9705 9706 Args : List_Id; 9707 Nam : Name_Id; 9708 9709 -- Start of processing for Make_Predicate_Check 9710 9711 begin 9712 -- If predicate checks are suppressed, then return a null statement. For 9713 -- this call, we check only the scope setting. If the caller wants to 9714 -- check a specific entity's setting, they must do it manually. 9715 9716 if Predicate_Checks_Suppressed (Empty) then 9717 return Make_Null_Statement (Loc); 9718 end if; 9719 9720 -- Do not generate a check within an internal subprogram (stream 9721 -- functions and the like, including predicate functions). 9722 9723 if Within_Internal_Subprogram then 9724 return Make_Null_Statement (Loc); 9725 end if; 9726 9727 -- Compute proper name to use, we need to get this right so that the 9728 -- right set of check policies apply to the Check pragma we are making. 9729 9730 if Has_Dynamic_Predicate_Aspect (Typ) then 9731 Nam := Name_Dynamic_Predicate; 9732 elsif Has_Static_Predicate_Aspect (Typ) then 9733 Nam := Name_Static_Predicate; 9734 else 9735 Nam := Name_Predicate; 9736 end if; 9737 9738 Args := New_List ( 9739 Make_Pragma_Argument_Association (Loc, 9740 Expression => Make_Identifier (Loc, Nam)), 9741 Make_Pragma_Argument_Association (Loc, 9742 Expression => Make_Predicate_Call (Typ, Expr))); 9743 9744 -- If the subtype is subject to pragma Predicate_Failure, add the 9745 -- failure expression as an additional parameter. 9746 9747 Add_Failure_Expression (Args); 9748 9749 return 9750 Make_Pragma (Loc, 9751 Chars => Name_Check, 9752 Pragma_Argument_Associations => Args); 9753 end Make_Predicate_Check; 9754 9755 ---------------------------- 9756 -- Make_Subtype_From_Expr -- 9757 ---------------------------- 9758 9759 -- 1. If Expr is an unconstrained array expression, creates 9760 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n)) 9761 9762 -- 2. If Expr is a unconstrained discriminated type expression, creates 9763 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n) 9764 9765 -- 3. If Expr is class-wide, creates an implicit class-wide subtype 9766 9767 function Make_Subtype_From_Expr 9768 (E : Node_Id; 9769 Unc_Typ : Entity_Id; 9770 Related_Id : Entity_Id := Empty) return Node_Id 9771 is 9772 List_Constr : constant List_Id := New_List; 9773 Loc : constant Source_Ptr := Sloc (E); 9774 D : Entity_Id; 9775 Full_Exp : Node_Id; 9776 Full_Subtyp : Entity_Id; 9777 High_Bound : Entity_Id; 9778 Index_Typ : Entity_Id; 9779 Low_Bound : Entity_Id; 9780 Priv_Subtyp : Entity_Id; 9781 Utyp : Entity_Id; 9782 9783 begin 9784 if Is_Private_Type (Unc_Typ) 9785 and then Has_Unknown_Discriminants (Unc_Typ) 9786 then 9787 -- The caller requests a unique external name for both the private 9788 -- and the full subtype. 9789 9790 if Present (Related_Id) then 9791 Full_Subtyp := 9792 Make_Defining_Identifier (Loc, 9793 Chars => New_External_Name (Chars (Related_Id), 'C')); 9794 Priv_Subtyp := 9795 Make_Defining_Identifier (Loc, 9796 Chars => New_External_Name (Chars (Related_Id), 'P')); 9797 9798 else 9799 Full_Subtyp := Make_Temporary (Loc, 'C'); 9800 Priv_Subtyp := Make_Temporary (Loc, 'P'); 9801 end if; 9802 9803 -- Prepare the subtype completion. Use the base type to find the 9804 -- underlying type because the type may be a generic actual or an 9805 -- explicit subtype. 9806 9807 Utyp := Underlying_Type (Base_Type (Unc_Typ)); 9808 9809 Full_Exp := 9810 Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E)); 9811 Set_Parent (Full_Exp, Parent (E)); 9812 9813 Insert_Action (E, 9814 Make_Subtype_Declaration (Loc, 9815 Defining_Identifier => Full_Subtyp, 9816 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp))); 9817 9818 -- Define the dummy private subtype 9819 9820 Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ))); 9821 Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ)); 9822 Set_Scope (Priv_Subtyp, Full_Subtyp); 9823 Set_Is_Constrained (Priv_Subtyp); 9824 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ)); 9825 Set_Is_Itype (Priv_Subtyp); 9826 Set_Associated_Node_For_Itype (Priv_Subtyp, E); 9827 9828 if Is_Tagged_Type (Priv_Subtyp) then 9829 Set_Class_Wide_Type 9830 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ)); 9831 Set_Direct_Primitive_Operations (Priv_Subtyp, 9832 Direct_Primitive_Operations (Unc_Typ)); 9833 end if; 9834 9835 Set_Full_View (Priv_Subtyp, Full_Subtyp); 9836 9837 return New_Occurrence_Of (Priv_Subtyp, Loc); 9838 9839 elsif Is_Array_Type (Unc_Typ) then 9840 Index_Typ := First_Index (Unc_Typ); 9841 for J in 1 .. Number_Dimensions (Unc_Typ) loop 9842 9843 -- Capture the bounds of each index constraint in case the context 9844 -- is an object declaration of an unconstrained type initialized 9845 -- by a function call: 9846 9847 -- Obj : Unconstr_Typ := Func_Call; 9848 9849 -- This scenario requires secondary scope management and the index 9850 -- constraint cannot depend on the temporary used to capture the 9851 -- result of the function call. 9852 9853 -- SS_Mark; 9854 -- Temp : Unconstr_Typ_Ptr := Func_Call'reference; 9855 -- subtype S is Unconstr_Typ (Temp.all'First .. Temp.all'Last); 9856 -- Obj : S := Temp.all; 9857 -- SS_Release; -- Temp is gone at this point, bounds of S are 9858 -- -- non existent. 9859 9860 -- Generate: 9861 -- Low_Bound : constant Base_Type (Index_Typ) := E'First (J); 9862 9863 Low_Bound := Make_Temporary (Loc, 'B'); 9864 Insert_Action (E, 9865 Make_Object_Declaration (Loc, 9866 Defining_Identifier => Low_Bound, 9867 Object_Definition => 9868 New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc), 9869 Constant_Present => True, 9870 Expression => 9871 Make_Attribute_Reference (Loc, 9872 Prefix => Duplicate_Subexpr_No_Checks (E), 9873 Attribute_Name => Name_First, 9874 Expressions => New_List ( 9875 Make_Integer_Literal (Loc, J))))); 9876 9877 -- Generate: 9878 -- High_Bound : constant Base_Type (Index_Typ) := E'Last (J); 9879 9880 High_Bound := Make_Temporary (Loc, 'B'); 9881 Insert_Action (E, 9882 Make_Object_Declaration (Loc, 9883 Defining_Identifier => High_Bound, 9884 Object_Definition => 9885 New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc), 9886 Constant_Present => True, 9887 Expression => 9888 Make_Attribute_Reference (Loc, 9889 Prefix => Duplicate_Subexpr_No_Checks (E), 9890 Attribute_Name => Name_Last, 9891 Expressions => New_List ( 9892 Make_Integer_Literal (Loc, J))))); 9893 9894 Append_To (List_Constr, 9895 Make_Range (Loc, 9896 Low_Bound => New_Occurrence_Of (Low_Bound, Loc), 9897 High_Bound => New_Occurrence_Of (High_Bound, Loc))); 9898 9899 Index_Typ := Next_Index (Index_Typ); 9900 end loop; 9901 9902 elsif Is_Class_Wide_Type (Unc_Typ) then 9903 declare 9904 CW_Subtype : Entity_Id; 9905 EQ_Typ : Entity_Id := Empty; 9906 9907 begin 9908 -- A class-wide equivalent type is not needed on VM targets 9909 -- because the VM back-ends handle the class-wide object 9910 -- initialization itself (and doesn't need or want the 9911 -- additional intermediate type to handle the assignment). 9912 9913 if Expander_Active and then Tagged_Type_Expansion then 9914 9915 -- If this is the class-wide type of a completion that is a 9916 -- record subtype, set the type of the class-wide type to be 9917 -- the full base type, for use in the expanded code for the 9918 -- equivalent type. Should this be done earlier when the 9919 -- completion is analyzed ??? 9920 9921 if Is_Private_Type (Etype (Unc_Typ)) 9922 and then 9923 Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype 9924 then 9925 Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ)))); 9926 end if; 9927 9928 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E); 9929 end if; 9930 9931 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E); 9932 Set_Equivalent_Type (CW_Subtype, EQ_Typ); 9933 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ)); 9934 9935 return New_Occurrence_Of (CW_Subtype, Loc); 9936 end; 9937 9938 -- Indefinite record type with discriminants 9939 9940 else 9941 D := First_Discriminant (Unc_Typ); 9942 while Present (D) loop 9943 Append_To (List_Constr, 9944 Make_Selected_Component (Loc, 9945 Prefix => Duplicate_Subexpr_No_Checks (E), 9946 Selector_Name => New_Occurrence_Of (D, Loc))); 9947 9948 Next_Discriminant (D); 9949 end loop; 9950 end if; 9951 9952 return 9953 Make_Subtype_Indication (Loc, 9954 Subtype_Mark => New_Occurrence_Of (Unc_Typ, Loc), 9955 Constraint => 9956 Make_Index_Or_Discriminant_Constraint (Loc, 9957 Constraints => List_Constr)); 9958 end Make_Subtype_From_Expr; 9959 9960 --------------- 9961 -- Map_Types -- 9962 --------------- 9963 9964 procedure Map_Types (Parent_Type : Entity_Id; Derived_Type : Entity_Id) is 9965 9966 -- NOTE: Most of the routines in Map_Types are intentionally unnested to 9967 -- avoid deep indentation of code. 9968 9969 -- NOTE: Routines which deal with discriminant mapping operate on the 9970 -- [underlying/record] full view of various types because those views 9971 -- contain all discriminants and stored constraints. 9972 9973 procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id); 9974 -- Subsidiary to Map_Primitives. Find a primitive in the inheritance or 9975 -- overriding chain starting from Prim whose dispatching type is parent 9976 -- type Par_Typ and add a mapping between the result and primitive Prim. 9977 9978 function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id; 9979 -- Subsidiary to Map_Primitives. Return the next ancestor primitive in 9980 -- the inheritance or overriding chain of subprogram Subp. Return Empty 9981 -- if no such primitive is available. 9982 9983 function Build_Chain 9984 (Par_Typ : Entity_Id; 9985 Deriv_Typ : Entity_Id) return Elist_Id; 9986 -- Subsidiary to Map_Discriminants. Recreate the derivation chain from 9987 -- parent type Par_Typ leading down towards derived type Deriv_Typ. The 9988 -- list has the form: 9989 -- 9990 -- head tail 9991 -- v v 9992 -- <Ancestor_N> -> <Ancestor_N-1> -> <Ancestor_1> -> Deriv_Typ 9993 -- 9994 -- Note that Par_Typ is not part of the resulting derivation chain 9995 9996 function Discriminated_View (Typ : Entity_Id) return Entity_Id; 9997 -- Return the view of type Typ which could potentially contains either 9998 -- the discriminants or stored constraints of the type. 9999 10000 function Find_Discriminant_Value 10001 (Discr : Entity_Id; 10002 Par_Typ : Entity_Id; 10003 Deriv_Typ : Entity_Id; 10004 Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id; 10005 -- Subsidiary to Map_Discriminants. Find the value of discriminant Discr 10006 -- in the derivation chain starting from parent type Par_Typ leading to 10007 -- derived type Deriv_Typ. The returned value is one of the following: 10008 -- 10009 -- * An entity which is either a discriminant or a nondiscriminant 10010 -- name, and renames/constraints Discr. 10011 -- 10012 -- * An expression which constraints Discr 10013 -- 10014 -- Typ_Elmt is an element of the derivation chain created by routine 10015 -- Build_Chain and denotes the current ancestor being examined. 10016 10017 procedure Map_Discriminants 10018 (Par_Typ : Entity_Id; 10019 Deriv_Typ : Entity_Id); 10020 -- Map each discriminant of type Par_Typ to a meaningful constraint 10021 -- from the point of view of type Deriv_Typ. 10022 10023 procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id); 10024 -- Map each primitive of type Par_Typ to a corresponding primitive of 10025 -- type Deriv_Typ. 10026 10027 ------------------- 10028 -- Add_Primitive -- 10029 ------------------- 10030 10031 procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id) is 10032 Par_Prim : Entity_Id; 10033 10034 begin 10035 -- Inspect the inheritance chain through the Alias attribute and the 10036 -- overriding chain through the Overridden_Operation looking for an 10037 -- ancestor primitive with the appropriate dispatching type. 10038 10039 Par_Prim := Prim; 10040 while Present (Par_Prim) loop 10041 exit when Find_Dispatching_Type (Par_Prim) = Par_Typ; 10042 Par_Prim := Ancestor_Primitive (Par_Prim); 10043 end loop; 10044 10045 -- Create a mapping of the form: 10046 10047 -- parent type primitive -> derived type primitive 10048 10049 if Present (Par_Prim) then 10050 Type_Map.Set (Par_Prim, Prim); 10051 end if; 10052 end Add_Primitive; 10053 10054 ------------------------ 10055 -- Ancestor_Primitive -- 10056 ------------------------ 10057 10058 function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id is 10059 Inher_Prim : constant Entity_Id := Alias (Subp); 10060 Over_Prim : constant Entity_Id := Overridden_Operation (Subp); 10061 10062 begin 10063 -- The current subprogram overrides an ancestor primitive 10064 10065 if Present (Over_Prim) then 10066 return Over_Prim; 10067 10068 -- The current subprogram is an internally generated alias of an 10069 -- inherited ancestor primitive. 10070 10071 elsif Present (Inher_Prim) then 10072 return Inher_Prim; 10073 10074 -- Otherwise the current subprogram is the root of the inheritance or 10075 -- overriding chain. 10076 10077 else 10078 return Empty; 10079 end if; 10080 end Ancestor_Primitive; 10081 10082 ----------------- 10083 -- Build_Chain -- 10084 ----------------- 10085 10086 function Build_Chain 10087 (Par_Typ : Entity_Id; 10088 Deriv_Typ : Entity_Id) return Elist_Id 10089 is 10090 Anc_Typ : Entity_Id; 10091 Chain : Elist_Id; 10092 Curr_Typ : Entity_Id; 10093 10094 begin 10095 Chain := New_Elmt_List; 10096 10097 -- Add the derived type to the derivation chain 10098 10099 Prepend_Elmt (Deriv_Typ, Chain); 10100 10101 -- Examine all ancestors starting from the derived type climbing 10102 -- towards parent type Par_Typ. 10103 10104 Curr_Typ := Deriv_Typ; 10105 loop 10106 -- Handle the case where the current type is a record which 10107 -- derives from a subtype. 10108 10109 -- subtype Sub_Typ is Par_Typ ... 10110 -- type Deriv_Typ is Sub_Typ ... 10111 10112 if Ekind (Curr_Typ) = E_Record_Type 10113 and then Present (Parent_Subtype (Curr_Typ)) 10114 then 10115 Anc_Typ := Parent_Subtype (Curr_Typ); 10116 10117 -- Handle the case where the current type is a record subtype of 10118 -- another subtype. 10119 10120 -- subtype Sub_Typ1 is Par_Typ ... 10121 -- subtype Sub_Typ2 is Sub_Typ1 ... 10122 10123 elsif Ekind (Curr_Typ) = E_Record_Subtype 10124 and then Present (Cloned_Subtype (Curr_Typ)) 10125 then 10126 Anc_Typ := Cloned_Subtype (Curr_Typ); 10127 10128 -- Otherwise use the direct parent type 10129 10130 else 10131 Anc_Typ := Etype (Curr_Typ); 10132 end if; 10133 10134 -- Use the first subtype when dealing with itypes 10135 10136 if Is_Itype (Anc_Typ) then 10137 Anc_Typ := First_Subtype (Anc_Typ); 10138 end if; 10139 10140 -- Work with the view which contains the discriminants and stored 10141 -- constraints. 10142 10143 Anc_Typ := Discriminated_View (Anc_Typ); 10144 10145 -- Stop the climb when either the parent type has been reached or 10146 -- there are no more ancestors left to examine. 10147 10148 exit when Anc_Typ = Curr_Typ or else Anc_Typ = Par_Typ; 10149 10150 Prepend_Unique_Elmt (Anc_Typ, Chain); 10151 Curr_Typ := Anc_Typ; 10152 end loop; 10153 10154 return Chain; 10155 end Build_Chain; 10156 10157 ------------------------ 10158 -- Discriminated_View -- 10159 ------------------------ 10160 10161 function Discriminated_View (Typ : Entity_Id) return Entity_Id is 10162 T : Entity_Id; 10163 10164 begin 10165 T := Typ; 10166 10167 -- Use the [underlying] full view when dealing with private types 10168 -- because the view contains all inherited discriminants or stored 10169 -- constraints. 10170 10171 if Is_Private_Type (T) then 10172 if Present (Underlying_Full_View (T)) then 10173 T := Underlying_Full_View (T); 10174 10175 elsif Present (Full_View (T)) then 10176 T := Full_View (T); 10177 end if; 10178 end if; 10179 10180 -- Use the underlying record view when the type is an extenstion of 10181 -- a parent type with unknown discriminants because the view contains 10182 -- all inherited discriminants or stored constraints. 10183 10184 if Ekind (T) = E_Record_Type 10185 and then Present (Underlying_Record_View (T)) 10186 then 10187 T := Underlying_Record_View (T); 10188 end if; 10189 10190 return T; 10191 end Discriminated_View; 10192 10193 ----------------------------- 10194 -- Find_Discriminant_Value -- 10195 ----------------------------- 10196 10197 function Find_Discriminant_Value 10198 (Discr : Entity_Id; 10199 Par_Typ : Entity_Id; 10200 Deriv_Typ : Entity_Id; 10201 Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id 10202 is 10203 Discr_Pos : constant Uint := Discriminant_Number (Discr); 10204 Typ : constant Entity_Id := Node (Typ_Elmt); 10205 10206 function Find_Constraint_Value 10207 (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id; 10208 -- Given constraint Constr, find what it denotes. This is either: 10209 -- 10210 -- * An entity which is either a discriminant or a name 10211 -- 10212 -- * An expression 10213 10214 --------------------------- 10215 -- Find_Constraint_Value -- 10216 --------------------------- 10217 10218 function Find_Constraint_Value 10219 (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id 10220 is 10221 begin 10222 if Nkind (Constr) in N_Entity then 10223 10224 -- The constraint denotes a discriminant of the curren type 10225 -- which renames the ancestor discriminant: 10226 10227 -- vv 10228 -- type Typ (D1 : ...; DN : ...) is 10229 -- new Anc (Discr => D1) with ... 10230 -- ^^ 10231 10232 if Ekind (Constr) = E_Discriminant then 10233 10234 -- The discriminant belongs to derived type Deriv_Typ. This 10235 -- is the final value for the ancestor discriminant as the 10236 -- derivations chain has been fully exhausted. 10237 10238 if Typ = Deriv_Typ then 10239 return Constr; 10240 10241 -- Otherwise the discriminant may be renamed or constrained 10242 -- at a lower level. Continue looking down the derivation 10243 -- chain. 10244 10245 else 10246 return 10247 Find_Discriminant_Value 10248 (Discr => Constr, 10249 Par_Typ => Par_Typ, 10250 Deriv_Typ => Deriv_Typ, 10251 Typ_Elmt => Next_Elmt (Typ_Elmt)); 10252 end if; 10253 10254 -- Otherwise the constraint denotes a reference to some name 10255 -- which results in a Girder discriminant: 10256 10257 -- vvvv 10258 -- Name : ...; 10259 -- type Typ (D1 : ...; DN : ...) is 10260 -- new Anc (Discr => Name) with ... 10261 -- ^^^^ 10262 10263 -- Return the name as this is the proper constraint of the 10264 -- discriminant. 10265 10266 else 10267 return Constr; 10268 end if; 10269 10270 -- The constraint denotes a reference to a name 10271 10272 elsif Is_Entity_Name (Constr) then 10273 return Find_Constraint_Value (Entity (Constr)); 10274 10275 -- Otherwise the current constraint is an expression which yields 10276 -- a Girder discriminant: 10277 10278 -- type Typ (D1 : ...; DN : ...) is 10279 -- new Anc (Discr => <expression>) with ... 10280 -- ^^^^^^^^^^ 10281 10282 -- Return the expression as this is the proper constraint of the 10283 -- discriminant. 10284 10285 else 10286 return Constr; 10287 end if; 10288 end Find_Constraint_Value; 10289 10290 -- Local variables 10291 10292 Constrs : constant Elist_Id := Stored_Constraint (Typ); 10293 10294 Constr_Elmt : Elmt_Id; 10295 Pos : Uint; 10296 Typ_Discr : Entity_Id; 10297 10298 -- Start of processing for Find_Discriminant_Value 10299 10300 begin 10301 -- The algorithm for finding the value of a discriminant works as 10302 -- follows. First, it recreates the derivation chain from Par_Typ 10303 -- to Deriv_Typ as a list: 10304 10305 -- Par_Typ (shown for completeness) 10306 -- v 10307 -- Ancestor_N <-- head of chain 10308 -- v 10309 -- Ancestor_1 10310 -- v 10311 -- Deriv_Typ <-- tail of chain 10312 10313 -- The algorithm then traces the fate of a parent discriminant down 10314 -- the derivation chain. At each derivation level, the discriminant 10315 -- may be either inherited or constrained. 10316 10317 -- 1) Discriminant is inherited: there are two cases, depending on 10318 -- which type is inheriting. 10319 10320 -- 1.1) Deriv_Typ is inheriting: 10321 10322 -- type Ancestor (D_1 : ...) is tagged ... 10323 -- type Deriv_Typ is new Ancestor ... 10324 10325 -- In this case the inherited discriminant is the final value of 10326 -- the parent discriminant because the end of the derivation chain 10327 -- has been reached. 10328 10329 -- 1.2) Some other type is inheriting: 10330 10331 -- type Ancestor_1 (D_1 : ...) is tagged ... 10332 -- type Ancestor_2 is new Ancestor_1 ... 10333 10334 -- In this case the algorithm continues to trace the fate of the 10335 -- inherited discriminant down the derivation chain because it may 10336 -- be further inherited or constrained. 10337 10338 -- 2) Discriminant is constrained: there are three cases, depending 10339 -- on what the constraint is. 10340 10341 -- 2.1) The constraint is another discriminant (aka renaming): 10342 10343 -- type Ancestor_1 (D_1 : ...) is tagged ... 10344 -- type Ancestor_2 (D_2 : ...) is new Ancestor_1 (D_1 => D_2) ... 10345 10346 -- In this case the constraining discriminant becomes the one to 10347 -- track down the derivation chain. The algorithm already knows 10348 -- that D_2 constrains D_1, therefore if the algorithm finds the 10349 -- value of D_2, then this would also be the value for D_1. 10350 10351 -- 2.2) The constraint is a name (aka Girder): 10352 10353 -- Name : ... 10354 -- type Ancestor_1 (D_1 : ...) is tagged ... 10355 -- type Ancestor_2 is new Ancestor_1 (D_1 => Name) ... 10356 10357 -- In this case the name is the final value of D_1 because the 10358 -- discriminant cannot be further constrained. 10359 10360 -- 2.3) The constraint is an expression (aka Girder): 10361 10362 -- type Ancestor_1 (D_1 : ...) is tagged ... 10363 -- type Ancestor_2 is new Ancestor_1 (D_1 => 1 + 2) ... 10364 10365 -- Similar to 2.2, the expression is the final value of D_1 10366 10367 Pos := Uint_1; 10368 10369 -- When a derived type constrains its parent type, all constaints 10370 -- appear in the Stored_Constraint list. Examine the list looking 10371 -- for a positional match. 10372 10373 if Present (Constrs) then 10374 Constr_Elmt := First_Elmt (Constrs); 10375 while Present (Constr_Elmt) loop 10376 10377 -- The position of the current constraint matches that of the 10378 -- ancestor discriminant. 10379 10380 if Pos = Discr_Pos then 10381 return Find_Constraint_Value (Node (Constr_Elmt)); 10382 end if; 10383 10384 Next_Elmt (Constr_Elmt); 10385 Pos := Pos + 1; 10386 end loop; 10387 10388 -- Otherwise the derived type does not constraint its parent type in 10389 -- which case it inherits the parent discriminants. 10390 10391 else 10392 Typ_Discr := First_Discriminant (Typ); 10393 while Present (Typ_Discr) loop 10394 10395 -- The position of the current discriminant matches that of the 10396 -- ancestor discriminant. 10397 10398 if Pos = Discr_Pos then 10399 return Find_Constraint_Value (Typ_Discr); 10400 end if; 10401 10402 Next_Discriminant (Typ_Discr); 10403 Pos := Pos + 1; 10404 end loop; 10405 end if; 10406 10407 -- A discriminant must always have a corresponding value. This is 10408 -- either another discriminant, a name, or an expression. If this 10409 -- point is reached, them most likely the derivation chain employs 10410 -- the wrong views of types. 10411 10412 pragma Assert (False); 10413 10414 return Empty; 10415 end Find_Discriminant_Value; 10416 10417 ----------------------- 10418 -- Map_Discriminants -- 10419 ----------------------- 10420 10421 procedure Map_Discriminants 10422 (Par_Typ : Entity_Id; 10423 Deriv_Typ : Entity_Id) 10424 is 10425 Deriv_Chain : constant Elist_Id := Build_Chain (Par_Typ, Deriv_Typ); 10426 10427 Discr : Entity_Id; 10428 Discr_Val : Node_Or_Entity_Id; 10429 10430 begin 10431 -- Examine each discriminant of parent type Par_Typ and find a 10432 -- suitable value for it from the point of view of derived type 10433 -- Deriv_Typ. 10434 10435 if Has_Discriminants (Par_Typ) then 10436 Discr := First_Discriminant (Par_Typ); 10437 while Present (Discr) loop 10438 Discr_Val := 10439 Find_Discriminant_Value 10440 (Discr => Discr, 10441 Par_Typ => Par_Typ, 10442 Deriv_Typ => Deriv_Typ, 10443 Typ_Elmt => First_Elmt (Deriv_Chain)); 10444 10445 -- Create a mapping of the form: 10446 10447 -- parent type discriminant -> value 10448 10449 Type_Map.Set (Discr, Discr_Val); 10450 10451 Next_Discriminant (Discr); 10452 end loop; 10453 end if; 10454 end Map_Discriminants; 10455 10456 -------------------- 10457 -- Map_Primitives -- 10458 -------------------- 10459 10460 procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id) is 10461 Deriv_Prim : Entity_Id; 10462 Par_Prim : Entity_Id; 10463 Par_Prims : Elist_Id; 10464 Prim_Elmt : Elmt_Id; 10465 10466 begin 10467 -- Inspect the primitives of the derived type and determine whether 10468 -- they relate to the primitives of the parent type. If there is a 10469 -- meaningful relation, create a mapping of the form: 10470 10471 -- parent type primitive -> perived type primitive 10472 10473 if Present (Direct_Primitive_Operations (Deriv_Typ)) then 10474 Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ)); 10475 while Present (Prim_Elmt) loop 10476 Deriv_Prim := Node (Prim_Elmt); 10477 10478 if Is_Subprogram (Deriv_Prim) 10479 and then Find_Dispatching_Type (Deriv_Prim) = Deriv_Typ 10480 then 10481 Add_Primitive (Deriv_Prim, Par_Typ); 10482 end if; 10483 10484 Next_Elmt (Prim_Elmt); 10485 end loop; 10486 end if; 10487 10488 -- If the parent operation is an interface operation, the overriding 10489 -- indicator is not present. Instead, we get from the interface 10490 -- operation the primitive of the current type that implements it. 10491 10492 if Is_Interface (Par_Typ) then 10493 Par_Prims := Collect_Primitive_Operations (Par_Typ); 10494 10495 if Present (Par_Prims) then 10496 Prim_Elmt := First_Elmt (Par_Prims); 10497 10498 while Present (Prim_Elmt) loop 10499 Par_Prim := Node (Prim_Elmt); 10500 Deriv_Prim := 10501 Find_Primitive_Covering_Interface (Deriv_Typ, Par_Prim); 10502 10503 if Present (Deriv_Prim) then 10504 Type_Map.Set (Par_Prim, Deriv_Prim); 10505 end if; 10506 10507 Next_Elmt (Prim_Elmt); 10508 end loop; 10509 end if; 10510 end if; 10511 end Map_Primitives; 10512 10513 -- Start of processing for Map_Types 10514 10515 begin 10516 -- Nothing to do if there are no types to work with 10517 10518 if No (Parent_Type) or else No (Derived_Type) then 10519 return; 10520 10521 -- Nothing to do if the mapping already exists 10522 10523 elsif Type_Map.Get (Parent_Type) = Derived_Type then 10524 return; 10525 10526 -- Nothing to do if both types are not tagged. Note that untagged types 10527 -- do not have primitive operations and their discriminants are already 10528 -- handled by gigi. 10529 10530 elsif not Is_Tagged_Type (Parent_Type) 10531 or else not Is_Tagged_Type (Derived_Type) 10532 then 10533 return; 10534 end if; 10535 10536 -- Create a mapping of the form 10537 10538 -- parent type -> derived type 10539 10540 -- to prevent any subsequent attempts to produce the same relations 10541 10542 Type_Map.Set (Parent_Type, Derived_Type); 10543 10544 -- Create mappings of the form 10545 10546 -- parent type discriminant -> derived type discriminant 10547 -- <or> 10548 -- parent type discriminant -> constraint 10549 10550 -- Note that mapping of discriminants breaks privacy because it needs to 10551 -- work with those views which contains the discriminants and any stored 10552 -- constraints. 10553 10554 Map_Discriminants 10555 (Par_Typ => Discriminated_View (Parent_Type), 10556 Deriv_Typ => Discriminated_View (Derived_Type)); 10557 10558 -- Create mappings of the form 10559 10560 -- parent type primitive -> derived type primitive 10561 10562 Map_Primitives 10563 (Par_Typ => Parent_Type, 10564 Deriv_Typ => Derived_Type); 10565 end Map_Types; 10566 10567 ---------------------------- 10568 -- Matching_Standard_Type -- 10569 ---------------------------- 10570 10571 function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id is 10572 pragma Assert (Is_Scalar_Type (Typ)); 10573 Siz : constant Uint := Esize (Typ); 10574 10575 begin 10576 -- Floating-point cases 10577 10578 if Is_Floating_Point_Type (Typ) then 10579 if Siz <= Esize (Standard_Short_Float) then 10580 return Standard_Short_Float; 10581 elsif Siz <= Esize (Standard_Float) then 10582 return Standard_Float; 10583 elsif Siz <= Esize (Standard_Long_Float) then 10584 return Standard_Long_Float; 10585 elsif Siz <= Esize (Standard_Long_Long_Float) then 10586 return Standard_Long_Long_Float; 10587 else 10588 raise Program_Error; 10589 end if; 10590 10591 -- Integer cases (includes fixed-point types) 10592 10593 -- Unsigned integer cases (includes normal enumeration types) 10594 10595 elsif Is_Unsigned_Type (Typ) then 10596 if Siz <= Esize (Standard_Short_Short_Unsigned) then 10597 return Standard_Short_Short_Unsigned; 10598 elsif Siz <= Esize (Standard_Short_Unsigned) then 10599 return Standard_Short_Unsigned; 10600 elsif Siz <= Esize (Standard_Unsigned) then 10601 return Standard_Unsigned; 10602 elsif Siz <= Esize (Standard_Long_Unsigned) then 10603 return Standard_Long_Unsigned; 10604 elsif Siz <= Esize (Standard_Long_Long_Unsigned) then 10605 return Standard_Long_Long_Unsigned; 10606 else 10607 raise Program_Error; 10608 end if; 10609 10610 -- Signed integer cases 10611 10612 else 10613 if Siz <= Esize (Standard_Short_Short_Integer) then 10614 return Standard_Short_Short_Integer; 10615 elsif Siz <= Esize (Standard_Short_Integer) then 10616 return Standard_Short_Integer; 10617 elsif Siz <= Esize (Standard_Integer) then 10618 return Standard_Integer; 10619 elsif Siz <= Esize (Standard_Long_Integer) then 10620 return Standard_Long_Integer; 10621 elsif Siz <= Esize (Standard_Long_Long_Integer) then 10622 return Standard_Long_Long_Integer; 10623 else 10624 raise Program_Error; 10625 end if; 10626 end if; 10627 end Matching_Standard_Type; 10628 10629 ----------------------------- 10630 -- May_Generate_Large_Temp -- 10631 ----------------------------- 10632 10633 -- At the current time, the only types that we return False for (i.e. where 10634 -- we decide we know they cannot generate large temps) are ones where we 10635 -- know the size is 256 bits or less at compile time, and we are still not 10636 -- doing a thorough job on arrays and records ??? 10637 10638 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is 10639 begin 10640 if not Size_Known_At_Compile_Time (Typ) then 10641 return False; 10642 10643 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then 10644 return False; 10645 10646 elsif Is_Array_Type (Typ) 10647 and then Present (Packed_Array_Impl_Type (Typ)) 10648 then 10649 return May_Generate_Large_Temp (Packed_Array_Impl_Type (Typ)); 10650 10651 -- We could do more here to find other small types ??? 10652 10653 else 10654 return True; 10655 end if; 10656 end May_Generate_Large_Temp; 10657 10658 -------------------------------------------- 10659 -- Needs_Conditional_Null_Excluding_Check -- 10660 -------------------------------------------- 10661 10662 function Needs_Conditional_Null_Excluding_Check 10663 (Typ : Entity_Id) return Boolean 10664 is 10665 begin 10666 return 10667 Is_Array_Type (Typ) and then Can_Never_Be_Null (Component_Type (Typ)); 10668 end Needs_Conditional_Null_Excluding_Check; 10669 10670 ---------------------------- 10671 -- Needs_Constant_Address -- 10672 ---------------------------- 10673 10674 function Needs_Constant_Address 10675 (Decl : Node_Id; 10676 Typ : Entity_Id) return Boolean 10677 is 10678 begin 10679 -- If we have no initialization of any kind, then we don't need to place 10680 -- any restrictions on the address clause, because the object will be 10681 -- elaborated after the address clause is evaluated. This happens if the 10682 -- declaration has no initial expression, or the type has no implicit 10683 -- initialization, or the object is imported. 10684 10685 -- The same holds for all initialized scalar types and all access types. 10686 -- Packed bit arrays of size up to 64 are represented using a modular 10687 -- type with an initialization (to zero) and can be processed like other 10688 -- initialized scalar types. 10689 10690 -- If the type is controlled, code to attach the object to a 10691 -- finalization chain is generated at the point of declaration, and 10692 -- therefore the elaboration of the object cannot be delayed: the 10693 -- address expression must be a constant. 10694 10695 if No (Expression (Decl)) 10696 and then not Needs_Finalization (Typ) 10697 and then 10698 (not Has_Non_Null_Base_Init_Proc (Typ) 10699 or else Is_Imported (Defining_Identifier (Decl))) 10700 then 10701 return False; 10702 10703 elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ)) 10704 or else Is_Access_Type (Typ) 10705 or else 10706 (Is_Bit_Packed_Array (Typ) 10707 and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ))) 10708 then 10709 return False; 10710 10711 else 10712 -- Otherwise, we require the address clause to be constant because 10713 -- the call to the initialization procedure (or the attach code) has 10714 -- to happen at the point of the declaration. 10715 10716 -- Actually the IP call has been moved to the freeze actions anyway, 10717 -- so maybe we can relax this restriction??? 10718 10719 return True; 10720 end if; 10721 end Needs_Constant_Address; 10722 10723 ---------------------------- 10724 -- New_Class_Wide_Subtype -- 10725 ---------------------------- 10726 10727 function New_Class_Wide_Subtype 10728 (CW_Typ : Entity_Id; 10729 N : Node_Id) return Entity_Id 10730 is 10731 Res : constant Entity_Id := Create_Itype (E_Void, N); 10732 10733 -- Capture relevant attributes of the class-wide subtype which must be 10734 -- restored after the copy. 10735 10736 Res_Chars : constant Name_Id := Chars (Res); 10737 Res_Is_CGE : constant Boolean := Is_Checked_Ghost_Entity (Res); 10738 Res_Is_IGE : constant Boolean := Is_Ignored_Ghost_Entity (Res); 10739 Res_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (Res); 10740 Res_Scope : constant Entity_Id := Scope (Res); 10741 10742 begin 10743 Copy_Node (CW_Typ, Res); 10744 10745 -- Restore the relevant attributes of the class-wide subtype 10746 10747 Set_Chars (Res, Res_Chars); 10748 Set_Is_Checked_Ghost_Entity (Res, Res_Is_CGE); 10749 Set_Is_Ignored_Ghost_Entity (Res, Res_Is_IGE); 10750 Set_Is_Ignored_Ghost_Node (Res, Res_Is_IGN); 10751 Set_Scope (Res, Res_Scope); 10752 10753 -- Decorate the class-wide subtype 10754 10755 Set_Associated_Node_For_Itype (Res, N); 10756 Set_Comes_From_Source (Res, False); 10757 Set_Ekind (Res, E_Class_Wide_Subtype); 10758 Set_Etype (Res, Base_Type (CW_Typ)); 10759 Set_Freeze_Node (Res, Empty); 10760 Set_Is_Frozen (Res, False); 10761 Set_Is_Itype (Res); 10762 Set_Is_Public (Res, False); 10763 Set_Next_Entity (Res, Empty); 10764 Set_Prev_Entity (Res, Empty); 10765 Set_Sloc (Res, Sloc (N)); 10766 10767 Set_Public_Status (Res); 10768 10769 return Res; 10770 end New_Class_Wide_Subtype; 10771 10772 -------------------------------- 10773 -- Non_Limited_Designated_Type -- 10774 --------------------------------- 10775 10776 function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is 10777 Desig : constant Entity_Id := Designated_Type (T); 10778 begin 10779 if Has_Non_Limited_View (Desig) then 10780 return Non_Limited_View (Desig); 10781 else 10782 return Desig; 10783 end if; 10784 end Non_Limited_Designated_Type; 10785 10786 ----------------------------------- 10787 -- OK_To_Do_Constant_Replacement -- 10788 ----------------------------------- 10789 10790 function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is 10791 ES : constant Entity_Id := Scope (E); 10792 CS : Entity_Id; 10793 10794 begin 10795 -- Do not replace statically allocated objects, because they may be 10796 -- modified outside the current scope. 10797 10798 if Is_Statically_Allocated (E) then 10799 return False; 10800 10801 -- Do not replace aliased or volatile objects, since we don't know what 10802 -- else might change the value. 10803 10804 elsif Is_Aliased (E) or else Treat_As_Volatile (E) then 10805 return False; 10806 10807 -- Debug flag -gnatdM disconnects this optimization 10808 10809 elsif Debug_Flag_MM then 10810 return False; 10811 10812 -- Otherwise check scopes 10813 10814 else 10815 CS := Current_Scope; 10816 10817 loop 10818 -- If we are in right scope, replacement is safe 10819 10820 if CS = ES then 10821 return True; 10822 10823 -- Packages do not affect the determination of safety 10824 10825 elsif Ekind (CS) = E_Package then 10826 exit when CS = Standard_Standard; 10827 CS := Scope (CS); 10828 10829 -- Blocks do not affect the determination of safety 10830 10831 elsif Ekind (CS) = E_Block then 10832 CS := Scope (CS); 10833 10834 -- Loops do not affect the determination of safety. Note that we 10835 -- kill all current values on entry to a loop, so we are just 10836 -- talking about processing within a loop here. 10837 10838 elsif Ekind (CS) = E_Loop then 10839 CS := Scope (CS); 10840 10841 -- Otherwise, the reference is dubious, and we cannot be sure that 10842 -- it is safe to do the replacement. 10843 10844 else 10845 exit; 10846 end if; 10847 end loop; 10848 10849 return False; 10850 end if; 10851 end OK_To_Do_Constant_Replacement; 10852 10853 ------------------------------------ 10854 -- Possible_Bit_Aligned_Component -- 10855 ------------------------------------ 10856 10857 function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is 10858 begin 10859 -- Do not process an unanalyzed node because it is not yet decorated and 10860 -- most checks performed below will fail. 10861 10862 if not Analyzed (N) then 10863 return False; 10864 end if; 10865 10866 -- There are never alignment issues in CodePeer mode 10867 10868 if CodePeer_Mode then 10869 return False; 10870 end if; 10871 10872 case Nkind (N) is 10873 10874 -- Case of indexed component 10875 10876 when N_Indexed_Component => 10877 declare 10878 P : constant Node_Id := Prefix (N); 10879 Ptyp : constant Entity_Id := Etype (P); 10880 10881 begin 10882 -- If we know the component size and it is not larger than 64, 10883 -- then we are definitely OK. The back end does the assignment 10884 -- of misaligned small objects correctly. 10885 10886 if Known_Static_Component_Size (Ptyp) 10887 and then Component_Size (Ptyp) <= 64 10888 then 10889 return False; 10890 10891 -- Otherwise, we need to test the prefix, to see if we are 10892 -- indexing from a possibly unaligned component. 10893 10894 else 10895 return Possible_Bit_Aligned_Component (P); 10896 end if; 10897 end; 10898 10899 -- Case of selected component 10900 10901 when N_Selected_Component => 10902 declare 10903 P : constant Node_Id := Prefix (N); 10904 Comp : constant Entity_Id := Entity (Selector_Name (N)); 10905 10906 begin 10907 -- This is the crucial test: if the component itself causes 10908 -- trouble, then we can stop and return True. 10909 10910 if Component_May_Be_Bit_Aligned (Comp) then 10911 return True; 10912 10913 -- Otherwise, we need to test the prefix, to see if we are 10914 -- selecting from a possibly unaligned component. 10915 10916 else 10917 return Possible_Bit_Aligned_Component (P); 10918 end if; 10919 end; 10920 10921 -- For a slice, test the prefix, if that is possibly misaligned, 10922 -- then for sure the slice is. 10923 10924 when N_Slice => 10925 return Possible_Bit_Aligned_Component (Prefix (N)); 10926 10927 -- For an unchecked conversion, check whether the expression may 10928 -- be bit aligned. 10929 10930 when N_Unchecked_Type_Conversion => 10931 return Possible_Bit_Aligned_Component (Expression (N)); 10932 10933 -- If we have none of the above, it means that we have fallen off the 10934 -- top testing prefixes recursively, and we now have a stand alone 10935 -- object, where we don't have a problem, unless this is a renaming, 10936 -- in which case we need to look into the renamed object. 10937 10938 when others => 10939 if Is_Entity_Name (N) 10940 and then Present (Renamed_Object (Entity (N))) 10941 then 10942 return 10943 Possible_Bit_Aligned_Component (Renamed_Object (Entity (N))); 10944 else 10945 return False; 10946 end if; 10947 end case; 10948 end Possible_Bit_Aligned_Component; 10949 10950 ----------------------------------------------- 10951 -- Process_Statements_For_Controlled_Objects -- 10952 ----------------------------------------------- 10953 10954 procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is 10955 Loc : constant Source_Ptr := Sloc (N); 10956 10957 function Are_Wrapped (L : List_Id) return Boolean; 10958 -- Determine whether list L contains only one statement which is a block 10959 10960 function Wrap_Statements_In_Block 10961 (L : List_Id; 10962 Scop : Entity_Id := Current_Scope) return Node_Id; 10963 -- Given a list of statements L, wrap it in a block statement and return 10964 -- the generated node. Scop is either the current scope or the scope of 10965 -- the context (if applicable). 10966 10967 ----------------- 10968 -- Are_Wrapped -- 10969 ----------------- 10970 10971 function Are_Wrapped (L : List_Id) return Boolean is 10972 Stmt : constant Node_Id := First (L); 10973 begin 10974 return 10975 Present (Stmt) 10976 and then No (Next (Stmt)) 10977 and then Nkind (Stmt) = N_Block_Statement; 10978 end Are_Wrapped; 10979 10980 ------------------------------ 10981 -- Wrap_Statements_In_Block -- 10982 ------------------------------ 10983 10984 function Wrap_Statements_In_Block 10985 (L : List_Id; 10986 Scop : Entity_Id := Current_Scope) return Node_Id 10987 is 10988 Block_Id : Entity_Id; 10989 Block_Nod : Node_Id; 10990 Iter_Loop : Entity_Id; 10991 10992 begin 10993 Block_Nod := 10994 Make_Block_Statement (Loc, 10995 Declarations => No_List, 10996 Handled_Statement_Sequence => 10997 Make_Handled_Sequence_Of_Statements (Loc, 10998 Statements => L)); 10999 11000 -- Create a label for the block in case the block needs to manage the 11001 -- secondary stack. A label allows for flag Uses_Sec_Stack to be set. 11002 11003 Add_Block_Identifier (Block_Nod, Block_Id); 11004 11005 -- When wrapping the statements of an iterator loop, check whether 11006 -- the loop requires secondary stack management and if so, propagate 11007 -- the appropriate flags to the block. This ensures that the cursor 11008 -- is properly cleaned up at each iteration of the loop. 11009 11010 Iter_Loop := Find_Enclosing_Iterator_Loop (Scop); 11011 11012 if Present (Iter_Loop) then 11013 Set_Uses_Sec_Stack (Block_Id, Uses_Sec_Stack (Iter_Loop)); 11014 11015 -- Secondary stack reclamation is suppressed when the associated 11016 -- iterator loop contains a return statement which uses the stack. 11017 11018 Set_Sec_Stack_Needed_For_Return 11019 (Block_Id, Sec_Stack_Needed_For_Return (Iter_Loop)); 11020 end if; 11021 11022 return Block_Nod; 11023 end Wrap_Statements_In_Block; 11024 11025 -- Local variables 11026 11027 Block : Node_Id; 11028 11029 -- Start of processing for Process_Statements_For_Controlled_Objects 11030 11031 begin 11032 -- Whenever a non-handled statement list is wrapped in a block, the 11033 -- block must be explicitly analyzed to redecorate all entities in the 11034 -- list and ensure that a finalizer is properly built. 11035 11036 case Nkind (N) is 11037 when N_Conditional_Entry_Call 11038 | N_Elsif_Part 11039 | N_If_Statement 11040 | N_Selective_Accept 11041 => 11042 -- Check the "then statements" for elsif parts and if statements 11043 11044 if Nkind_In (N, N_Elsif_Part, N_If_Statement) 11045 and then not Is_Empty_List (Then_Statements (N)) 11046 and then not Are_Wrapped (Then_Statements (N)) 11047 and then Requires_Cleanup_Actions 11048 (L => Then_Statements (N), 11049 Lib_Level => False, 11050 Nested_Constructs => False) 11051 then 11052 Block := Wrap_Statements_In_Block (Then_Statements (N)); 11053 Set_Then_Statements (N, New_List (Block)); 11054 11055 Analyze (Block); 11056 end if; 11057 11058 -- Check the "else statements" for conditional entry calls, if 11059 -- statements and selective accepts. 11060 11061 if Nkind_In (N, N_Conditional_Entry_Call, 11062 N_If_Statement, 11063 N_Selective_Accept) 11064 and then not Is_Empty_List (Else_Statements (N)) 11065 and then not Are_Wrapped (Else_Statements (N)) 11066 and then Requires_Cleanup_Actions 11067 (L => Else_Statements (N), 11068 Lib_Level => False, 11069 Nested_Constructs => False) 11070 then 11071 Block := Wrap_Statements_In_Block (Else_Statements (N)); 11072 Set_Else_Statements (N, New_List (Block)); 11073 11074 Analyze (Block); 11075 end if; 11076 11077 when N_Abortable_Part 11078 | N_Accept_Alternative 11079 | N_Case_Statement_Alternative 11080 | N_Delay_Alternative 11081 | N_Entry_Call_Alternative 11082 | N_Exception_Handler 11083 | N_Loop_Statement 11084 | N_Triggering_Alternative 11085 => 11086 if not Is_Empty_List (Statements (N)) 11087 and then not Are_Wrapped (Statements (N)) 11088 and then Requires_Cleanup_Actions 11089 (L => Statements (N), 11090 Lib_Level => False, 11091 Nested_Constructs => False) 11092 then 11093 if Nkind (N) = N_Loop_Statement 11094 and then Present (Identifier (N)) 11095 then 11096 Block := 11097 Wrap_Statements_In_Block 11098 (L => Statements (N), 11099 Scop => Entity (Identifier (N))); 11100 else 11101 Block := Wrap_Statements_In_Block (Statements (N)); 11102 end if; 11103 11104 Set_Statements (N, New_List (Block)); 11105 Analyze (Block); 11106 end if; 11107 11108 -- Could be e.g. a loop that was transformed into a block or null 11109 -- statement. Do nothing for terminate alternatives. 11110 11111 when N_Block_Statement 11112 | N_Null_Statement 11113 | N_Terminate_Alternative 11114 => 11115 null; 11116 11117 when others => 11118 raise Program_Error; 11119 end case; 11120 end Process_Statements_For_Controlled_Objects; 11121 11122 ------------------ 11123 -- Power_Of_Two -- 11124 ------------------ 11125 11126 function Power_Of_Two (N : Node_Id) return Nat is 11127 Typ : constant Entity_Id := Etype (N); 11128 pragma Assert (Is_Integer_Type (Typ)); 11129 11130 Siz : constant Nat := UI_To_Int (Esize (Typ)); 11131 Val : Uint; 11132 11133 begin 11134 if not Compile_Time_Known_Value (N) then 11135 return 0; 11136 11137 else 11138 Val := Expr_Value (N); 11139 for J in 1 .. Siz - 1 loop 11140 if Val = Uint_2 ** J then 11141 return J; 11142 end if; 11143 end loop; 11144 11145 return 0; 11146 end if; 11147 end Power_Of_Two; 11148 11149 ---------------------- 11150 -- Remove_Init_Call -- 11151 ---------------------- 11152 11153 function Remove_Init_Call 11154 (Var : Entity_Id; 11155 Rep_Clause : Node_Id) return Node_Id 11156 is 11157 Par : constant Node_Id := Parent (Var); 11158 Typ : constant Entity_Id := Etype (Var); 11159 11160 Init_Proc : Entity_Id; 11161 -- Initialization procedure for Typ 11162 11163 function Find_Init_Call_In_List (From : Node_Id) return Node_Id; 11164 -- Look for init call for Var starting at From and scanning the 11165 -- enclosing list until Rep_Clause or the end of the list is reached. 11166 11167 ---------------------------- 11168 -- Find_Init_Call_In_List -- 11169 ---------------------------- 11170 11171 function Find_Init_Call_In_List (From : Node_Id) return Node_Id is 11172 Init_Call : Node_Id; 11173 11174 begin 11175 Init_Call := From; 11176 while Present (Init_Call) and then Init_Call /= Rep_Clause loop 11177 if Nkind (Init_Call) = N_Procedure_Call_Statement 11178 and then Is_Entity_Name (Name (Init_Call)) 11179 and then Entity (Name (Init_Call)) = Init_Proc 11180 then 11181 return Init_Call; 11182 end if; 11183 11184 Next (Init_Call); 11185 end loop; 11186 11187 return Empty; 11188 end Find_Init_Call_In_List; 11189 11190 Init_Call : Node_Id; 11191 11192 -- Start of processing for Find_Init_Call 11193 11194 begin 11195 if Present (Initialization_Statements (Var)) then 11196 Init_Call := Initialization_Statements (Var); 11197 Set_Initialization_Statements (Var, Empty); 11198 11199 elsif not Has_Non_Null_Base_Init_Proc (Typ) then 11200 11201 -- No init proc for the type, so obviously no call to be found 11202 11203 return Empty; 11204 11205 else 11206 -- We might be able to handle other cases below by just properly 11207 -- setting Initialization_Statements at the point where the init proc 11208 -- call is generated??? 11209 11210 Init_Proc := Base_Init_Proc (Typ); 11211 11212 -- First scan the list containing the declaration of Var 11213 11214 Init_Call := Find_Init_Call_In_List (From => Next (Par)); 11215 11216 -- If not found, also look on Var's freeze actions list, if any, 11217 -- since the init call may have been moved there (case of an address 11218 -- clause applying to Var). 11219 11220 if No (Init_Call) and then Present (Freeze_Node (Var)) then 11221 Init_Call := 11222 Find_Init_Call_In_List (First (Actions (Freeze_Node (Var)))); 11223 end if; 11224 11225 -- If the initialization call has actuals that use the secondary 11226 -- stack, the call may have been wrapped into a temporary block, in 11227 -- which case the block itself has to be removed. 11228 11229 if No (Init_Call) and then Nkind (Next (Par)) = N_Block_Statement then 11230 declare 11231 Blk : constant Node_Id := Next (Par); 11232 begin 11233 if Present 11234 (Find_Init_Call_In_List 11235 (First (Statements (Handled_Statement_Sequence (Blk))))) 11236 then 11237 Init_Call := Blk; 11238 end if; 11239 end; 11240 end if; 11241 end if; 11242 11243 if Present (Init_Call) then 11244 Remove (Init_Call); 11245 end if; 11246 return Init_Call; 11247 end Remove_Init_Call; 11248 11249 ------------------------- 11250 -- Remove_Side_Effects -- 11251 ------------------------- 11252 11253 procedure Remove_Side_Effects 11254 (Exp : Node_Id; 11255 Name_Req : Boolean := False; 11256 Renaming_Req : Boolean := False; 11257 Variable_Ref : Boolean := False; 11258 Related_Id : Entity_Id := Empty; 11259 Is_Low_Bound : Boolean := False; 11260 Is_High_Bound : Boolean := False; 11261 Check_Side_Effects : Boolean := True) 11262 is 11263 function Build_Temporary 11264 (Loc : Source_Ptr; 11265 Id : Character; 11266 Related_Nod : Node_Id := Empty) return Entity_Id; 11267 -- Create an external symbol of the form xxx_FIRST/_LAST if Related_Nod 11268 -- is present (xxx is taken from the Chars field of Related_Nod), 11269 -- otherwise it generates an internal temporary. The created temporary 11270 -- entity is marked as internal. 11271 11272 --------------------- 11273 -- Build_Temporary -- 11274 --------------------- 11275 11276 function Build_Temporary 11277 (Loc : Source_Ptr; 11278 Id : Character; 11279 Related_Nod : Node_Id := Empty) return Entity_Id 11280 is 11281 Temp_Id : Entity_Id; 11282 Temp_Nam : Name_Id; 11283 11284 begin 11285 -- The context requires an external symbol 11286 11287 if Present (Related_Id) then 11288 if Is_Low_Bound then 11289 Temp_Nam := New_External_Name (Chars (Related_Id), "_FIRST"); 11290 else pragma Assert (Is_High_Bound); 11291 Temp_Nam := New_External_Name (Chars (Related_Id), "_LAST"); 11292 end if; 11293 11294 Temp_Id := Make_Defining_Identifier (Loc, Temp_Nam); 11295 11296 -- Otherwise generate an internal temporary 11297 11298 else 11299 Temp_Id := Make_Temporary (Loc, Id, Related_Nod); 11300 end if; 11301 11302 Set_Is_Internal (Temp_Id); 11303 11304 return Temp_Id; 11305 end Build_Temporary; 11306 11307 -- Local variables 11308 11309 Loc : constant Source_Ptr := Sloc (Exp); 11310 Exp_Type : constant Entity_Id := Etype (Exp); 11311 Svg_Suppress : constant Suppress_Record := Scope_Suppress; 11312 Def_Id : Entity_Id; 11313 E : Node_Id; 11314 New_Exp : Node_Id; 11315 Ptr_Typ_Decl : Node_Id; 11316 Ref_Type : Entity_Id; 11317 Res : Node_Id; 11318 11319 -- Start of processing for Remove_Side_Effects 11320 11321 begin 11322 -- Handle cases in which there is nothing to do. In GNATprove mode, 11323 -- removal of side effects is useful for the light expansion of 11324 -- renamings. This removal should only occur when not inside a 11325 -- generic and not doing a preanalysis. 11326 11327 if not Expander_Active 11328 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode) 11329 then 11330 return; 11331 11332 -- Cannot generate temporaries if the invocation to remove side effects 11333 -- was issued too early and the type of the expression is not resolved 11334 -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke 11335 -- Remove_Side_Effects). 11336 11337 elsif No (Exp_Type) 11338 or else Ekind (Exp_Type) = E_Access_Attribute_Type 11339 then 11340 return; 11341 11342 -- Nothing to do if prior expansion determined that a function call does 11343 -- not require side effect removal. 11344 11345 elsif Nkind (Exp) = N_Function_Call 11346 and then No_Side_Effect_Removal (Exp) 11347 then 11348 return; 11349 11350 -- No action needed for side-effect free expressions 11351 11352 elsif Check_Side_Effects 11353 and then Side_Effect_Free (Exp, Name_Req, Variable_Ref) 11354 then 11355 return; 11356 11357 -- Generating C code we cannot remove side effect of function returning 11358 -- class-wide types since there is no secondary stack (required to use 11359 -- 'reference). 11360 11361 elsif Modify_Tree_For_C 11362 and then Nkind (Exp) = N_Function_Call 11363 and then Is_Class_Wide_Type (Etype (Exp)) 11364 then 11365 return; 11366 end if; 11367 11368 -- The remaining processing is done with all checks suppressed 11369 11370 -- Note: from now on, don't use return statements, instead do a goto 11371 -- Leave, to ensure that we properly restore Scope_Suppress.Suppress. 11372 11373 Scope_Suppress.Suppress := (others => True); 11374 11375 -- If this is an elementary or a small not-by-reference record type, and 11376 -- we need to capture the value, just make a constant; this is cheap and 11377 -- objects of both kinds of types can be bit aligned, so it might not be 11378 -- possible to generate a reference to them. Likewise if this is not a 11379 -- name reference, except for a type conversion, because we would enter 11380 -- an infinite recursion with Checks.Apply_Predicate_Check if the target 11381 -- type has predicates (and type conversions need a specific treatment 11382 -- anyway, see below). Also do it if we have a volatile reference and 11383 -- Name_Req is not set (see comments for Side_Effect_Free). 11384 11385 if (Is_Elementary_Type (Exp_Type) 11386 or else (Is_Record_Type (Exp_Type) 11387 and then Known_Static_RM_Size (Exp_Type) 11388 and then RM_Size (Exp_Type) <= 64 11389 and then not Has_Discriminants (Exp_Type) 11390 and then not Is_By_Reference_Type (Exp_Type))) 11391 and then (Variable_Ref 11392 or else (not Is_Name_Reference (Exp) 11393 and then Nkind (Exp) /= N_Type_Conversion) 11394 or else (not Name_Req 11395 and then Is_Volatile_Reference (Exp))) 11396 then 11397 Def_Id := Build_Temporary (Loc, 'R', Exp); 11398 Set_Etype (Def_Id, Exp_Type); 11399 Res := New_Occurrence_Of (Def_Id, Loc); 11400 11401 -- If the expression is a packed reference, it must be reanalyzed and 11402 -- expanded, depending on context. This is the case for actuals where 11403 -- a constraint check may capture the actual before expansion of the 11404 -- call is complete. 11405 11406 if Nkind (Exp) = N_Indexed_Component 11407 and then Is_Packed (Etype (Prefix (Exp))) 11408 then 11409 Set_Analyzed (Exp, False); 11410 Set_Analyzed (Prefix (Exp), False); 11411 end if; 11412 11413 -- Generate: 11414 -- Rnn : Exp_Type renames Expr; 11415 11416 -- In GNATprove mode, we prefer to use renamings for intermediate 11417 -- variables to definition of constants, due to the implicit move 11418 -- operation that such a constant definition causes as part of the 11419 -- support in GNATprove for ownership pointers. Hence, we generate 11420 -- a renaming for a reference to an object of a nonscalar type. 11421 11422 if Renaming_Req 11423 or else (GNATprove_Mode 11424 and then Is_Object_Reference (Exp) 11425 and then not Is_Scalar_Type (Exp_Type)) 11426 then 11427 E := 11428 Make_Object_Renaming_Declaration (Loc, 11429 Defining_Identifier => Def_Id, 11430 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc), 11431 Name => Relocate_Node (Exp)); 11432 11433 -- Generate: 11434 -- Rnn : constant Exp_Type := Expr; 11435 11436 else 11437 E := 11438 Make_Object_Declaration (Loc, 11439 Defining_Identifier => Def_Id, 11440 Object_Definition => New_Occurrence_Of (Exp_Type, Loc), 11441 Constant_Present => True, 11442 Expression => Relocate_Node (Exp)); 11443 11444 Set_Assignment_OK (E); 11445 end if; 11446 11447 Insert_Action (Exp, E); 11448 11449 -- If the expression has the form v.all then we can just capture the 11450 -- pointer, and then do an explicit dereference on the result, but 11451 -- this is not right if this is a volatile reference. 11452 11453 elsif Nkind (Exp) = N_Explicit_Dereference 11454 and then not Is_Volatile_Reference (Exp) 11455 then 11456 Def_Id := Build_Temporary (Loc, 'R', Exp); 11457 Res := 11458 Make_Explicit_Dereference (Loc, New_Occurrence_Of (Def_Id, Loc)); 11459 11460 Insert_Action (Exp, 11461 Make_Object_Declaration (Loc, 11462 Defining_Identifier => Def_Id, 11463 Object_Definition => 11464 New_Occurrence_Of (Etype (Prefix (Exp)), Loc), 11465 Constant_Present => True, 11466 Expression => Relocate_Node (Prefix (Exp)))); 11467 11468 -- Similar processing for an unchecked conversion of an expression of 11469 -- the form v.all, where we want the same kind of treatment. 11470 11471 elsif Nkind (Exp) = N_Unchecked_Type_Conversion 11472 and then Nkind (Expression (Exp)) = N_Explicit_Dereference 11473 then 11474 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref); 11475 goto Leave; 11476 11477 -- If this is a type conversion, leave the type conversion and remove 11478 -- the side effects in the expression. This is important in several 11479 -- circumstances: for change of representations, and also when this is a 11480 -- view conversion to a smaller object, where gigi can end up creating 11481 -- its own temporary of the wrong size. 11482 11483 elsif Nkind (Exp) = N_Type_Conversion then 11484 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref); 11485 11486 -- Generating C code the type conversion of an access to constrained 11487 -- array type into an access to unconstrained array type involves 11488 -- initializing a fat pointer and the expression must be free of 11489 -- side effects to safely compute its bounds. 11490 11491 if Modify_Tree_For_C 11492 and then Is_Access_Type (Etype (Exp)) 11493 and then Is_Array_Type (Designated_Type (Etype (Exp))) 11494 and then not Is_Constrained (Designated_Type (Etype (Exp))) 11495 then 11496 Def_Id := Build_Temporary (Loc, 'R', Exp); 11497 Set_Etype (Def_Id, Exp_Type); 11498 Res := New_Occurrence_Of (Def_Id, Loc); 11499 11500 Insert_Action (Exp, 11501 Make_Object_Declaration (Loc, 11502 Defining_Identifier => Def_Id, 11503 Object_Definition => New_Occurrence_Of (Exp_Type, Loc), 11504 Constant_Present => True, 11505 Expression => Relocate_Node (Exp))); 11506 else 11507 goto Leave; 11508 end if; 11509 11510 -- If this is an unchecked conversion that Gigi can't handle, make 11511 -- a copy or a use a renaming to capture the value. 11512 11513 elsif Nkind (Exp) = N_Unchecked_Type_Conversion 11514 and then not Safe_Unchecked_Type_Conversion (Exp) 11515 then 11516 if CW_Or_Has_Controlled_Part (Exp_Type) then 11517 11518 -- Use a renaming to capture the expression, rather than create 11519 -- a controlled temporary. 11520 11521 Def_Id := Build_Temporary (Loc, 'R', Exp); 11522 Res := New_Occurrence_Of (Def_Id, Loc); 11523 11524 Insert_Action (Exp, 11525 Make_Object_Renaming_Declaration (Loc, 11526 Defining_Identifier => Def_Id, 11527 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc), 11528 Name => Relocate_Node (Exp))); 11529 11530 else 11531 Def_Id := Build_Temporary (Loc, 'R', Exp); 11532 Set_Etype (Def_Id, Exp_Type); 11533 Res := New_Occurrence_Of (Def_Id, Loc); 11534 11535 E := 11536 Make_Object_Declaration (Loc, 11537 Defining_Identifier => Def_Id, 11538 Object_Definition => New_Occurrence_Of (Exp_Type, Loc), 11539 Constant_Present => not Is_Variable (Exp), 11540 Expression => Relocate_Node (Exp)); 11541 11542 Set_Assignment_OK (E); 11543 Insert_Action (Exp, E); 11544 end if; 11545 11546 -- For expressions that denote names, we can use a renaming scheme. 11547 -- This is needed for correctness in the case of a volatile object of 11548 -- a nonvolatile type because the Make_Reference call of the "default" 11549 -- approach would generate an illegal access value (an access value 11550 -- cannot designate such an object - see Analyze_Reference). 11551 11552 elsif Is_Name_Reference (Exp) 11553 11554 -- We skip using this scheme if we have an object of a volatile 11555 -- type and we do not have Name_Req set true (see comments for 11556 -- Side_Effect_Free). 11557 11558 and then (Name_Req or else not Treat_As_Volatile (Exp_Type)) 11559 then 11560 Def_Id := Build_Temporary (Loc, 'R', Exp); 11561 Res := New_Occurrence_Of (Def_Id, Loc); 11562 11563 Insert_Action (Exp, 11564 Make_Object_Renaming_Declaration (Loc, 11565 Defining_Identifier => Def_Id, 11566 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc), 11567 Name => Relocate_Node (Exp))); 11568 11569 -- If this is a packed reference, or a selected component with 11570 -- a nonstandard representation, a reference to the temporary 11571 -- will be replaced by a copy of the original expression (see 11572 -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be 11573 -- elaborated by gigi, and is of course not to be replaced in-line 11574 -- by the expression it renames, which would defeat the purpose of 11575 -- removing the side effect. 11576 11577 if Nkind_In (Exp, N_Selected_Component, N_Indexed_Component) 11578 and then Has_Non_Standard_Rep (Etype (Prefix (Exp))) 11579 then 11580 null; 11581 else 11582 Set_Is_Renaming_Of_Object (Def_Id, False); 11583 end if; 11584 11585 -- Avoid generating a variable-sized temporary, by generating the 11586 -- reference just for the function call. The transformation could be 11587 -- refined to apply only when the array component is constrained by a 11588 -- discriminant??? 11589 11590 elsif Nkind (Exp) = N_Selected_Component 11591 and then Nkind (Prefix (Exp)) = N_Function_Call 11592 and then Is_Array_Type (Exp_Type) 11593 then 11594 Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref); 11595 goto Leave; 11596 11597 -- Otherwise we generate a reference to the expression 11598 11599 else 11600 -- An expression which is in SPARK mode is considered side effect 11601 -- free if the resulting value is captured by a variable or a 11602 -- constant. 11603 11604 if GNATprove_Mode 11605 and then Nkind (Parent (Exp)) = N_Object_Declaration 11606 then 11607 goto Leave; 11608 11609 -- When generating C code we cannot consider side effect free object 11610 -- declarations that have discriminants and are initialized by means 11611 -- of a function call since on this target there is no secondary 11612 -- stack to store the return value and the expander may generate an 11613 -- extra call to the function to compute the discriminant value. In 11614 -- addition, for targets that have secondary stack, the expansion of 11615 -- functions with side effects involves the generation of an access 11616 -- type to capture the return value stored in the secondary stack; 11617 -- by contrast when generating C code such expansion generates an 11618 -- internal object declaration (no access type involved) which must 11619 -- be identified here to avoid entering into a never-ending loop 11620 -- generating internal object declarations. 11621 11622 elsif Modify_Tree_For_C 11623 and then Nkind (Parent (Exp)) = N_Object_Declaration 11624 and then 11625 (Nkind (Exp) /= N_Function_Call 11626 or else not Has_Discriminants (Exp_Type) 11627 or else Is_Internal_Name 11628 (Chars (Defining_Identifier (Parent (Exp))))) 11629 then 11630 goto Leave; 11631 end if; 11632 11633 -- Special processing for function calls that return a limited type. 11634 -- We need to build a declaration that will enable build-in-place 11635 -- expansion of the call. This is not done if the context is already 11636 -- an object declaration, to prevent infinite recursion. 11637 11638 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have 11639 -- to accommodate functions returning limited objects by reference. 11640 11641 if Ada_Version >= Ada_2005 11642 and then Nkind (Exp) = N_Function_Call 11643 and then Is_Limited_View (Etype (Exp)) 11644 and then Nkind (Parent (Exp)) /= N_Object_Declaration 11645 then 11646 declare 11647 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp); 11648 Decl : Node_Id; 11649 11650 begin 11651 Decl := 11652 Make_Object_Declaration (Loc, 11653 Defining_Identifier => Obj, 11654 Object_Definition => New_Occurrence_Of (Exp_Type, Loc), 11655 Expression => Relocate_Node (Exp)); 11656 11657 Insert_Action (Exp, Decl); 11658 Set_Etype (Obj, Exp_Type); 11659 Rewrite (Exp, New_Occurrence_Of (Obj, Loc)); 11660 goto Leave; 11661 end; 11662 end if; 11663 11664 Def_Id := Build_Temporary (Loc, 'R', Exp); 11665 11666 -- The regular expansion of functions with side effects involves the 11667 -- generation of an access type to capture the return value found on 11668 -- the secondary stack. Since SPARK (and why) cannot process access 11669 -- types, use a different approach which ignores the secondary stack 11670 -- and "copies" the returned object. 11671 -- When generating C code, no need for a 'reference since the 11672 -- secondary stack is not supported. 11673 11674 if GNATprove_Mode or Modify_Tree_For_C then 11675 Res := New_Occurrence_Of (Def_Id, Loc); 11676 Ref_Type := Exp_Type; 11677 11678 -- Regular expansion utilizing an access type and 'reference 11679 11680 else 11681 Res := 11682 Make_Explicit_Dereference (Loc, 11683 Prefix => New_Occurrence_Of (Def_Id, Loc)); 11684 11685 -- Generate: 11686 -- type Ann is access all <Exp_Type>; 11687 11688 Ref_Type := Make_Temporary (Loc, 'A'); 11689 11690 Ptr_Typ_Decl := 11691 Make_Full_Type_Declaration (Loc, 11692 Defining_Identifier => Ref_Type, 11693 Type_Definition => 11694 Make_Access_To_Object_Definition (Loc, 11695 All_Present => True, 11696 Subtype_Indication => 11697 New_Occurrence_Of (Exp_Type, Loc))); 11698 11699 Insert_Action (Exp, Ptr_Typ_Decl); 11700 end if; 11701 11702 E := Exp; 11703 if Nkind (E) = N_Explicit_Dereference then 11704 New_Exp := Relocate_Node (Prefix (E)); 11705 11706 else 11707 E := Relocate_Node (E); 11708 11709 -- Do not generate a 'reference in SPARK mode or C generation 11710 -- since the access type is not created in the first place. 11711 11712 if GNATprove_Mode or Modify_Tree_For_C then 11713 New_Exp := E; 11714 11715 -- Otherwise generate reference, marking the value as non-null 11716 -- since we know it cannot be null and we don't want a check. 11717 11718 else 11719 New_Exp := Make_Reference (Loc, E); 11720 Set_Is_Known_Non_Null (Def_Id); 11721 end if; 11722 end if; 11723 11724 if Is_Delayed_Aggregate (E) then 11725 11726 -- The expansion of nested aggregates is delayed until the 11727 -- enclosing aggregate is expanded. As aggregates are often 11728 -- qualified, the predicate applies to qualified expressions as 11729 -- well, indicating that the enclosing aggregate has not been 11730 -- expanded yet. At this point the aggregate is part of a 11731 -- stand-alone declaration, and must be fully expanded. 11732 11733 if Nkind (E) = N_Qualified_Expression then 11734 Set_Expansion_Delayed (Expression (E), False); 11735 Set_Analyzed (Expression (E), False); 11736 else 11737 Set_Expansion_Delayed (E, False); 11738 end if; 11739 11740 Set_Analyzed (E, False); 11741 end if; 11742 11743 -- Generating C code of object declarations that have discriminants 11744 -- and are initialized by means of a function call we propagate the 11745 -- discriminants of the parent type to the internally built object. 11746 -- This is needed to avoid generating an extra call to the called 11747 -- function. 11748 11749 -- For example, if we generate here the following declaration, it 11750 -- will be expanded later adding an extra call to evaluate the value 11751 -- of the discriminant (needed to compute the size of the object). 11752 -- 11753 -- type Rec (D : Integer) is ... 11754 -- Obj : constant Rec := SomeFunc; 11755 11756 if Modify_Tree_For_C 11757 and then Nkind (Parent (Exp)) = N_Object_Declaration 11758 and then Has_Discriminants (Exp_Type) 11759 and then Nkind (Exp) = N_Function_Call 11760 then 11761 Insert_Action (Exp, 11762 Make_Object_Declaration (Loc, 11763 Defining_Identifier => Def_Id, 11764 Object_Definition => New_Copy_Tree 11765 (Object_Definition (Parent (Exp))), 11766 Constant_Present => True, 11767 Expression => New_Exp)); 11768 else 11769 Insert_Action (Exp, 11770 Make_Object_Declaration (Loc, 11771 Defining_Identifier => Def_Id, 11772 Object_Definition => New_Occurrence_Of (Ref_Type, Loc), 11773 Constant_Present => True, 11774 Expression => New_Exp)); 11775 end if; 11776 end if; 11777 11778 -- Preserve the Assignment_OK flag in all copies, since at least one 11779 -- copy may be used in a context where this flag must be set (otherwise 11780 -- why would the flag be set in the first place). 11781 11782 Set_Assignment_OK (Res, Assignment_OK (Exp)); 11783 11784 -- Preserve the Do_Range_Check flag in all copies 11785 11786 Set_Do_Range_Check (Res, Do_Range_Check (Exp)); 11787 11788 -- Finally rewrite the original expression and we are done 11789 11790 Rewrite (Exp, Res); 11791 Analyze_And_Resolve (Exp, Exp_Type); 11792 11793 <<Leave>> 11794 Scope_Suppress := Svg_Suppress; 11795 end Remove_Side_Effects; 11796 11797 ------------------------ 11798 -- Replace_References -- 11799 ------------------------ 11800 11801 procedure Replace_References 11802 (Expr : Node_Id; 11803 Par_Typ : Entity_Id; 11804 Deriv_Typ : Entity_Id; 11805 Par_Obj : Entity_Id := Empty; 11806 Deriv_Obj : Entity_Id := Empty) 11807 is 11808 function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean; 11809 -- Determine whether node Ref denotes some component of Deriv_Obj 11810 11811 function Replace_Ref (Ref : Node_Id) return Traverse_Result; 11812 -- Substitute a reference to an entity with the corresponding value 11813 -- stored in table Type_Map. 11814 11815 function Type_Of_Formal 11816 (Call : Node_Id; 11817 Actual : Node_Id) return Entity_Id; 11818 -- Find the type of the formal parameter which corresponds to actual 11819 -- parameter Actual in subprogram call Call. 11820 11821 ---------------------- 11822 -- Is_Deriv_Obj_Ref -- 11823 ---------------------- 11824 11825 function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean is 11826 Par : constant Node_Id := Parent (Ref); 11827 11828 begin 11829 -- Detect the folowing selected component form: 11830 11831 -- Deriv_Obj.(something) 11832 11833 return 11834 Nkind (Par) = N_Selected_Component 11835 and then Is_Entity_Name (Prefix (Par)) 11836 and then Entity (Prefix (Par)) = Deriv_Obj; 11837 end Is_Deriv_Obj_Ref; 11838 11839 ----------------- 11840 -- Replace_Ref -- 11841 ----------------- 11842 11843 function Replace_Ref (Ref : Node_Id) return Traverse_Result is 11844 procedure Remove_Controlling_Arguments (From_Arg : Node_Id); 11845 -- Reset the Controlling_Argument of all function calls that 11846 -- encapsulate node From_Arg. 11847 11848 ---------------------------------- 11849 -- Remove_Controlling_Arguments -- 11850 ---------------------------------- 11851 11852 procedure Remove_Controlling_Arguments (From_Arg : Node_Id) is 11853 Par : Node_Id; 11854 11855 begin 11856 Par := From_Arg; 11857 while Present (Par) loop 11858 if Nkind (Par) = N_Function_Call 11859 and then Present (Controlling_Argument (Par)) 11860 then 11861 Set_Controlling_Argument (Par, Empty); 11862 11863 -- Prevent the search from going too far 11864 11865 elsif Is_Body_Or_Package_Declaration (Par) then 11866 exit; 11867 end if; 11868 11869 Par := Parent (Par); 11870 end loop; 11871 end Remove_Controlling_Arguments; 11872 11873 -- Local variables 11874 11875 Context : constant Node_Id := Parent (Ref); 11876 Loc : constant Source_Ptr := Sloc (Ref); 11877 Ref_Id : Entity_Id; 11878 Result : Traverse_Result; 11879 11880 New_Ref : Node_Id; 11881 -- The new reference which is intended to substitute the old one 11882 11883 Old_Ref : Node_Id; 11884 -- The reference designated for replacement. In certain cases this 11885 -- may be a node other than Ref. 11886 11887 Val : Node_Or_Entity_Id; 11888 -- The corresponding value of Ref from the type map 11889 11890 -- Start of processing for Replace_Ref 11891 11892 begin 11893 -- Assume that the input reference is to be replaced and that the 11894 -- traversal should examine the children of the reference. 11895 11896 Old_Ref := Ref; 11897 Result := OK; 11898 11899 -- The input denotes a meaningful reference 11900 11901 if Nkind (Ref) in N_Has_Entity and then Present (Entity (Ref)) then 11902 Ref_Id := Entity (Ref); 11903 Val := Type_Map.Get (Ref_Id); 11904 11905 -- The reference has a corresponding value in the type map, a 11906 -- substitution is possible. 11907 11908 if Present (Val) then 11909 11910 -- The reference denotes a discriminant 11911 11912 if Ekind (Ref_Id) = E_Discriminant then 11913 if Nkind (Val) in N_Entity then 11914 11915 -- The value denotes another discriminant. Replace as 11916 -- follows: 11917 11918 -- _object.Discr -> _object.Val 11919 11920 if Ekind (Val) = E_Discriminant then 11921 New_Ref := New_Occurrence_Of (Val, Loc); 11922 11923 -- Otherwise the value denotes the entity of a name which 11924 -- constraints the discriminant. Replace as follows: 11925 11926 -- _object.Discr -> Val 11927 11928 else 11929 pragma Assert (Is_Deriv_Obj_Ref (Old_Ref)); 11930 11931 New_Ref := New_Occurrence_Of (Val, Loc); 11932 Old_Ref := Parent (Old_Ref); 11933 end if; 11934 11935 -- Otherwise the value denotes an arbitrary expression which 11936 -- constraints the discriminant. Replace as follows: 11937 11938 -- _object.Discr -> Val 11939 11940 else 11941 pragma Assert (Is_Deriv_Obj_Ref (Old_Ref)); 11942 11943 New_Ref := New_Copy_Tree (Val); 11944 Old_Ref := Parent (Old_Ref); 11945 end if; 11946 11947 -- Otherwise the reference denotes a primitive. Replace as 11948 -- follows: 11949 11950 -- Primitive -> Val 11951 11952 else 11953 pragma Assert (Nkind (Val) in N_Entity); 11954 New_Ref := New_Occurrence_Of (Val, Loc); 11955 end if; 11956 11957 -- The reference mentions the _object parameter of the parent 11958 -- type's DIC or type invariant procedure. Replace as follows: 11959 11960 -- _object -> _object 11961 11962 elsif Present (Par_Obj) 11963 and then Present (Deriv_Obj) 11964 and then Ref_Id = Par_Obj 11965 then 11966 New_Ref := New_Occurrence_Of (Deriv_Obj, Loc); 11967 11968 -- The type of the _object parameter is class-wide when the 11969 -- expression comes from an assertion pragma that applies to 11970 -- an abstract parent type or an interface. The class-wide type 11971 -- facilitates the preanalysis of the expression by treating 11972 -- calls to abstract primitives that mention the current 11973 -- instance of the type as dispatching. Once the calls are 11974 -- remapped to invoke overriding or inherited primitives, the 11975 -- calls no longer need to be dispatching. Examine all function 11976 -- calls that encapsulate the _object parameter and reset their 11977 -- Controlling_Argument attribute. 11978 11979 if Is_Class_Wide_Type (Etype (Par_Obj)) 11980 and then Is_Abstract_Type (Root_Type (Etype (Par_Obj))) 11981 then 11982 Remove_Controlling_Arguments (Old_Ref); 11983 end if; 11984 11985 -- The reference to _object acts as an actual parameter in a 11986 -- subprogram call which may be invoking a primitive of the 11987 -- parent type: 11988 11989 -- Primitive (... _object ...); 11990 11991 -- The parent type primitive may not be overridden nor 11992 -- inherited when it is declared after the derived type 11993 -- definition: 11994 11995 -- type Parent is tagged private; 11996 -- type Child is new Parent with private; 11997 -- procedure Primitive (Obj : Parent); 11998 11999 -- In this scenario the _object parameter is converted to the 12000 -- parent type. Due to complications with partial/full views 12001 -- and view swaps, the parent type is taken from the formal 12002 -- parameter of the subprogram being called. 12003 12004 if Nkind_In (Context, N_Function_Call, 12005 N_Procedure_Call_Statement) 12006 and then No (Type_Map.Get (Entity (Name (Context)))) 12007 then 12008 New_Ref := 12009 Convert_To (Type_Of_Formal (Context, Old_Ref), New_Ref); 12010 12011 -- Do not process the generated type conversion because 12012 -- both the parent type and the derived type are in the 12013 -- Type_Map table. This will clobber the type conversion 12014 -- by resetting its subtype mark. 12015 12016 Result := Skip; 12017 end if; 12018 12019 -- Otherwise there is nothing to replace 12020 12021 else 12022 New_Ref := Empty; 12023 end if; 12024 12025 if Present (New_Ref) then 12026 Rewrite (Old_Ref, New_Ref); 12027 12028 -- Update the return type when the context of the reference 12029 -- acts as the name of a function call. Note that the update 12030 -- should not be performed when the reference appears as an 12031 -- actual in the call. 12032 12033 if Nkind (Context) = N_Function_Call 12034 and then Name (Context) = Old_Ref 12035 then 12036 Set_Etype (Context, Etype (Val)); 12037 end if; 12038 end if; 12039 end if; 12040 12041 -- Reanalyze the reference due to potential replacements 12042 12043 if Nkind (Old_Ref) in N_Has_Etype then 12044 Set_Analyzed (Old_Ref, False); 12045 end if; 12046 12047 return Result; 12048 end Replace_Ref; 12049 12050 procedure Replace_Refs is new Traverse_Proc (Replace_Ref); 12051 12052 -------------------- 12053 -- Type_Of_Formal -- 12054 -------------------- 12055 12056 function Type_Of_Formal 12057 (Call : Node_Id; 12058 Actual : Node_Id) return Entity_Id 12059 is 12060 A : Node_Id; 12061 F : Entity_Id; 12062 12063 begin 12064 -- Examine the list of actual and formal parameters in parallel 12065 12066 A := First (Parameter_Associations (Call)); 12067 F := First_Formal (Entity (Name (Call))); 12068 while Present (A) and then Present (F) loop 12069 if A = Actual then 12070 return Etype (F); 12071 end if; 12072 12073 Next (A); 12074 Next_Formal (F); 12075 end loop; 12076 12077 -- The actual parameter must always have a corresponding formal 12078 12079 pragma Assert (False); 12080 12081 return Empty; 12082 end Type_Of_Formal; 12083 12084 -- Start of processing for Replace_References 12085 12086 begin 12087 -- Map the attributes of the parent type to the proper corresponding 12088 -- attributes of the derived type. 12089 12090 Map_Types 12091 (Parent_Type => Par_Typ, 12092 Derived_Type => Deriv_Typ); 12093 12094 -- Inspect the input expression and perform substitutions where 12095 -- necessary. 12096 12097 Replace_Refs (Expr); 12098 end Replace_References; 12099 12100 ----------------------------- 12101 -- Replace_Type_References -- 12102 ----------------------------- 12103 12104 procedure Replace_Type_References 12105 (Expr : Node_Id; 12106 Typ : Entity_Id; 12107 Obj_Id : Entity_Id) 12108 is 12109 procedure Replace_Type_Ref (N : Node_Id); 12110 -- Substitute a single reference of the current instance of type Typ 12111 -- with a reference to Obj_Id. 12112 12113 ---------------------- 12114 -- Replace_Type_Ref -- 12115 ---------------------- 12116 12117 procedure Replace_Type_Ref (N : Node_Id) is 12118 begin 12119 -- Decorate the reference to Typ even though it may be rewritten 12120 -- further down. This is done for two reasons: 12121 12122 -- * ASIS has all necessary semantic information in the original 12123 -- tree. 12124 12125 -- * Routines which examine properties of the Original_Node have 12126 -- some semantic information. 12127 12128 if Nkind (N) = N_Identifier then 12129 Set_Entity (N, Typ); 12130 Set_Etype (N, Typ); 12131 12132 elsif Nkind (N) = N_Selected_Component then 12133 Analyze (Prefix (N)); 12134 Set_Entity (Selector_Name (N), Typ); 12135 Set_Etype (Selector_Name (N), Typ); 12136 end if; 12137 12138 -- Perform the following substitution: 12139 12140 -- Typ --> _object 12141 12142 Rewrite (N, New_Occurrence_Of (Obj_Id, Sloc (N))); 12143 Set_Comes_From_Source (N, True); 12144 end Replace_Type_Ref; 12145 12146 procedure Replace_Type_Refs is 12147 new Replace_Type_References_Generic (Replace_Type_Ref); 12148 12149 -- Start of processing for Replace_Type_References 12150 12151 begin 12152 Replace_Type_Refs (Expr, Typ); 12153 end Replace_Type_References; 12154 12155 --------------------------- 12156 -- Represented_As_Scalar -- 12157 --------------------------- 12158 12159 function Represented_As_Scalar (T : Entity_Id) return Boolean is 12160 UT : constant Entity_Id := Underlying_Type (T); 12161 begin 12162 return Is_Scalar_Type (UT) 12163 or else (Is_Bit_Packed_Array (UT) 12164 and then Is_Scalar_Type (Packed_Array_Impl_Type (UT))); 12165 end Represented_As_Scalar; 12166 12167 ------------------------------ 12168 -- Requires_Cleanup_Actions -- 12169 ------------------------------ 12170 12171 function Requires_Cleanup_Actions 12172 (N : Node_Id; 12173 Lib_Level : Boolean) return Boolean 12174 is 12175 At_Lib_Level : constant Boolean := 12176 Lib_Level 12177 and then Nkind_In (N, N_Package_Body, 12178 N_Package_Specification); 12179 -- N is at the library level if the top-most context is a package and 12180 -- the path taken to reach N does not include nonpackage constructs. 12181 12182 begin 12183 case Nkind (N) is 12184 when N_Accept_Statement 12185 | N_Block_Statement 12186 | N_Entry_Body 12187 | N_Package_Body 12188 | N_Protected_Body 12189 | N_Subprogram_Body 12190 | N_Task_Body 12191 => 12192 return 12193 Requires_Cleanup_Actions 12194 (L => Declarations (N), 12195 Lib_Level => At_Lib_Level, 12196 Nested_Constructs => True) 12197 or else 12198 (Present (Handled_Statement_Sequence (N)) 12199 and then 12200 Requires_Cleanup_Actions 12201 (L => 12202 Statements (Handled_Statement_Sequence (N)), 12203 Lib_Level => At_Lib_Level, 12204 Nested_Constructs => True)); 12205 12206 -- Extended return statements are the same as the above, except that 12207 -- there is no Declarations field. We do not want to clean up the 12208 -- Return_Object_Declarations. 12209 12210 when N_Extended_Return_Statement => 12211 return 12212 Present (Handled_Statement_Sequence (N)) 12213 and then Requires_Cleanup_Actions 12214 (L => 12215 Statements (Handled_Statement_Sequence (N)), 12216 Lib_Level => At_Lib_Level, 12217 Nested_Constructs => True); 12218 12219 when N_Package_Specification => 12220 return 12221 Requires_Cleanup_Actions 12222 (L => Visible_Declarations (N), 12223 Lib_Level => At_Lib_Level, 12224 Nested_Constructs => True) 12225 or else 12226 Requires_Cleanup_Actions 12227 (L => Private_Declarations (N), 12228 Lib_Level => At_Lib_Level, 12229 Nested_Constructs => True); 12230 12231 when others => 12232 raise Program_Error; 12233 end case; 12234 end Requires_Cleanup_Actions; 12235 12236 ------------------------------ 12237 -- Requires_Cleanup_Actions -- 12238 ------------------------------ 12239 12240 function Requires_Cleanup_Actions 12241 (L : List_Id; 12242 Lib_Level : Boolean; 12243 Nested_Constructs : Boolean) return Boolean 12244 is 12245 Decl : Node_Id; 12246 Expr : Node_Id; 12247 Obj_Id : Entity_Id; 12248 Obj_Typ : Entity_Id; 12249 Pack_Id : Entity_Id; 12250 Typ : Entity_Id; 12251 12252 begin 12253 if No (L) or else Is_Empty_List (L) then 12254 return False; 12255 end if; 12256 12257 Decl := First (L); 12258 while Present (Decl) loop 12259 12260 -- Library-level tagged types 12261 12262 if Nkind (Decl) = N_Full_Type_Declaration then 12263 Typ := Defining_Identifier (Decl); 12264 12265 -- Ignored Ghost types do not need any cleanup actions because 12266 -- they will not appear in the final tree. 12267 12268 if Is_Ignored_Ghost_Entity (Typ) then 12269 null; 12270 12271 elsif Is_Tagged_Type (Typ) 12272 and then Is_Library_Level_Entity (Typ) 12273 and then Convention (Typ) = Convention_Ada 12274 and then Present (Access_Disp_Table (Typ)) 12275 and then RTE_Available (RE_Unregister_Tag) 12276 and then not Is_Abstract_Type (Typ) 12277 and then not No_Run_Time_Mode 12278 then 12279 return True; 12280 end if; 12281 12282 -- Regular object declarations 12283 12284 elsif Nkind (Decl) = N_Object_Declaration then 12285 Obj_Id := Defining_Identifier (Decl); 12286 Obj_Typ := Base_Type (Etype (Obj_Id)); 12287 Expr := Expression (Decl); 12288 12289 -- Bypass any form of processing for objects which have their 12290 -- finalization disabled. This applies only to objects at the 12291 -- library level. 12292 12293 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then 12294 null; 12295 12296 -- Finalization of transient objects are treated separately in 12297 -- order to handle sensitive cases. These include: 12298 12299 -- * Aggregate expansion 12300 -- * If, case, and expression with actions expansion 12301 -- * Transient scopes 12302 12303 -- If one of those contexts has marked the transient object as 12304 -- ignored, do not generate finalization actions for it. 12305 12306 elsif Is_Finalized_Transient (Obj_Id) 12307 or else Is_Ignored_Transient (Obj_Id) 12308 then 12309 null; 12310 12311 -- Ignored Ghost objects do not need any cleanup actions because 12312 -- they will not appear in the final tree. 12313 12314 elsif Is_Ignored_Ghost_Entity (Obj_Id) then 12315 null; 12316 12317 -- The object is of the form: 12318 -- Obj : [constant] Typ [:= Expr]; 12319 -- 12320 -- Do not process tag-to-class-wide conversions because they do 12321 -- not yield an object. Do not process the incomplete view of a 12322 -- deferred constant. Note that an object initialized by means 12323 -- of a build-in-place function call may appear as a deferred 12324 -- constant after expansion activities. These kinds of objects 12325 -- must be finalized. 12326 12327 elsif not Is_Imported (Obj_Id) 12328 and then Needs_Finalization (Obj_Typ) 12329 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id) 12330 and then not (Ekind (Obj_Id) = E_Constant 12331 and then not Has_Completion (Obj_Id) 12332 and then No (BIP_Initialization_Call (Obj_Id))) 12333 then 12334 return True; 12335 12336 -- The object is of the form: 12337 -- Obj : Access_Typ := Non_BIP_Function_Call'reference; 12338 -- 12339 -- Obj : Access_Typ := 12340 -- BIP_Function_Call (BIPalloc => 2, ...)'reference; 12341 12342 elsif Is_Access_Type (Obj_Typ) 12343 and then Needs_Finalization 12344 (Available_View (Designated_Type (Obj_Typ))) 12345 and then Present (Expr) 12346 and then 12347 (Is_Secondary_Stack_BIP_Func_Call (Expr) 12348 or else 12349 (Is_Non_BIP_Func_Call (Expr) 12350 and then not Is_Related_To_Func_Return (Obj_Id))) 12351 then 12352 return True; 12353 12354 -- Processing for "hook" objects generated for transient objects 12355 -- declared inside an Expression_With_Actions. 12356 12357 elsif Is_Access_Type (Obj_Typ) 12358 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) 12359 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = 12360 N_Object_Declaration 12361 then 12362 return True; 12363 12364 -- Processing for intermediate results of if expressions where 12365 -- one of the alternatives uses a controlled function call. 12366 12367 elsif Is_Access_Type (Obj_Typ) 12368 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) 12369 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = 12370 N_Defining_Identifier 12371 and then Present (Expr) 12372 and then Nkind (Expr) = N_Null 12373 then 12374 return True; 12375 12376 -- Simple protected objects which use type System.Tasking. 12377 -- Protected_Objects.Protection to manage their locks should be 12378 -- treated as controlled since they require manual cleanup. 12379 12380 elsif Ekind (Obj_Id) = E_Variable 12381 and then (Is_Simple_Protected_Type (Obj_Typ) 12382 or else Has_Simple_Protected_Object (Obj_Typ)) 12383 then 12384 return True; 12385 end if; 12386 12387 -- Specific cases of object renamings 12388 12389 elsif Nkind (Decl) = N_Object_Renaming_Declaration then 12390 Obj_Id := Defining_Identifier (Decl); 12391 Obj_Typ := Base_Type (Etype (Obj_Id)); 12392 12393 -- Bypass any form of processing for objects which have their 12394 -- finalization disabled. This applies only to objects at the 12395 -- library level. 12396 12397 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then 12398 null; 12399 12400 -- Ignored Ghost object renamings do not need any cleanup actions 12401 -- because they will not appear in the final tree. 12402 12403 elsif Is_Ignored_Ghost_Entity (Obj_Id) then 12404 null; 12405 12406 -- Return object of a build-in-place function. This case is 12407 -- recognized and marked by the expansion of an extended return 12408 -- statement (see Expand_N_Extended_Return_Statement). 12409 12410 elsif Needs_Finalization (Obj_Typ) 12411 and then Is_Return_Object (Obj_Id) 12412 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) 12413 then 12414 return True; 12415 12416 -- Detect a case where a source object has been initialized by 12417 -- a controlled function call or another object which was later 12418 -- rewritten as a class-wide conversion of Ada.Tags.Displace. 12419 12420 -- Obj1 : CW_Type := Src_Obj; 12421 -- Obj2 : CW_Type := Function_Call (...); 12422 12423 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj)); 12424 -- Tmp : ... := Function_Call (...)'reference; 12425 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp)); 12426 12427 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then 12428 return True; 12429 end if; 12430 12431 -- Inspect the freeze node of an access-to-controlled type and look 12432 -- for a delayed finalization master. This case arises when the 12433 -- freeze actions are inserted at a later time than the expansion of 12434 -- the context. Since Build_Finalizer is never called on a single 12435 -- construct twice, the master will be ultimately left out and never 12436 -- finalized. This is also needed for freeze actions of designated 12437 -- types themselves, since in some cases the finalization master is 12438 -- associated with a designated type's freeze node rather than that 12439 -- of the access type (see handling for freeze actions in 12440 -- Build_Finalization_Master). 12441 12442 elsif Nkind (Decl) = N_Freeze_Entity 12443 and then Present (Actions (Decl)) 12444 then 12445 Typ := Entity (Decl); 12446 12447 -- Freeze nodes for ignored Ghost types do not need cleanup 12448 -- actions because they will never appear in the final tree. 12449 12450 if Is_Ignored_Ghost_Entity (Typ) then 12451 null; 12452 12453 elsif ((Is_Access_Type (Typ) 12454 and then not Is_Access_Subprogram_Type (Typ) 12455 and then Needs_Finalization 12456 (Available_View (Designated_Type (Typ)))) 12457 or else (Is_Type (Typ) and then Needs_Finalization (Typ))) 12458 and then Requires_Cleanup_Actions 12459 (Actions (Decl), Lib_Level, Nested_Constructs) 12460 then 12461 return True; 12462 end if; 12463 12464 -- Nested package declarations 12465 12466 elsif Nested_Constructs 12467 and then Nkind (Decl) = N_Package_Declaration 12468 then 12469 Pack_Id := Defining_Entity (Decl); 12470 12471 -- Do not inspect an ignored Ghost package because all code found 12472 -- within will not appear in the final tree. 12473 12474 if Is_Ignored_Ghost_Entity (Pack_Id) then 12475 null; 12476 12477 elsif Ekind (Pack_Id) /= E_Generic_Package 12478 and then Requires_Cleanup_Actions 12479 (Specification (Decl), Lib_Level) 12480 then 12481 return True; 12482 end if; 12483 12484 -- Nested package bodies 12485 12486 elsif Nested_Constructs and then Nkind (Decl) = N_Package_Body then 12487 12488 -- Do not inspect an ignored Ghost package body because all code 12489 -- found within will not appear in the final tree. 12490 12491 if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then 12492 null; 12493 12494 elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package 12495 and then Requires_Cleanup_Actions (Decl, Lib_Level) 12496 then 12497 return True; 12498 end if; 12499 12500 elsif Nkind (Decl) = N_Block_Statement 12501 and then 12502 12503 -- Handle a rare case caused by a controlled transient object 12504 -- created as part of a record init proc. The variable is wrapped 12505 -- in a block, but the block is not associated with a transient 12506 -- scope. 12507 12508 (Inside_Init_Proc 12509 12510 -- Handle the case where the original context has been wrapped in 12511 -- a block to avoid interference between exception handlers and 12512 -- At_End handlers. Treat the block as transparent and process its 12513 -- contents. 12514 12515 or else Is_Finalization_Wrapper (Decl)) 12516 then 12517 if Requires_Cleanup_Actions (Decl, Lib_Level) then 12518 return True; 12519 end if; 12520 end if; 12521 12522 Next (Decl); 12523 end loop; 12524 12525 return False; 12526 end Requires_Cleanup_Actions; 12527 12528 ------------------------------------ 12529 -- Safe_Unchecked_Type_Conversion -- 12530 ------------------------------------ 12531 12532 -- Note: this function knows quite a bit about the exact requirements of 12533 -- Gigi with respect to unchecked type conversions, and its code must be 12534 -- coordinated with any changes in Gigi in this area. 12535 12536 -- The above requirements should be documented in Sinfo ??? 12537 12538 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is 12539 Otyp : Entity_Id; 12540 Ityp : Entity_Id; 12541 Oalign : Uint; 12542 Ialign : Uint; 12543 Pexp : constant Node_Id := Parent (Exp); 12544 12545 begin 12546 -- If the expression is the RHS of an assignment or object declaration 12547 -- we are always OK because there will always be a target. 12548 12549 -- Object renaming declarations, (generated for view conversions of 12550 -- actuals in inlined calls), like object declarations, provide an 12551 -- explicit type, and are safe as well. 12552 12553 if (Nkind (Pexp) = N_Assignment_Statement 12554 and then Expression (Pexp) = Exp) 12555 or else Nkind_In (Pexp, N_Object_Declaration, 12556 N_Object_Renaming_Declaration) 12557 then 12558 return True; 12559 12560 -- If the expression is the prefix of an N_Selected_Component we should 12561 -- also be OK because GCC knows to look inside the conversion except if 12562 -- the type is discriminated. We assume that we are OK anyway if the 12563 -- type is not set yet or if it is controlled since we can't afford to 12564 -- introduce a temporary in this case. 12565 12566 elsif Nkind (Pexp) = N_Selected_Component 12567 and then Prefix (Pexp) = Exp 12568 then 12569 if No (Etype (Pexp)) then 12570 return True; 12571 else 12572 return 12573 not Has_Discriminants (Etype (Pexp)) 12574 or else Is_Constrained (Etype (Pexp)); 12575 end if; 12576 end if; 12577 12578 -- Set the output type, this comes from Etype if it is set, otherwise we 12579 -- take it from the subtype mark, which we assume was already fully 12580 -- analyzed. 12581 12582 if Present (Etype (Exp)) then 12583 Otyp := Etype (Exp); 12584 else 12585 Otyp := Entity (Subtype_Mark (Exp)); 12586 end if; 12587 12588 -- The input type always comes from the expression, and we assume this 12589 -- is indeed always analyzed, so we can simply get the Etype. 12590 12591 Ityp := Etype (Expression (Exp)); 12592 12593 -- Initialize alignments to unknown so far 12594 12595 Oalign := No_Uint; 12596 Ialign := No_Uint; 12597 12598 -- Replace a concurrent type by its corresponding record type and each 12599 -- type by its underlying type and do the tests on those. The original 12600 -- type may be a private type whose completion is a concurrent type, so 12601 -- find the underlying type first. 12602 12603 if Present (Underlying_Type (Otyp)) then 12604 Otyp := Underlying_Type (Otyp); 12605 end if; 12606 12607 if Present (Underlying_Type (Ityp)) then 12608 Ityp := Underlying_Type (Ityp); 12609 end if; 12610 12611 if Is_Concurrent_Type (Otyp) then 12612 Otyp := Corresponding_Record_Type (Otyp); 12613 end if; 12614 12615 if Is_Concurrent_Type (Ityp) then 12616 Ityp := Corresponding_Record_Type (Ityp); 12617 end if; 12618 12619 -- If the base types are the same, we know there is no problem since 12620 -- this conversion will be a noop. 12621 12622 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then 12623 return True; 12624 12625 -- Same if this is an upwards conversion of an untagged type, and there 12626 -- are no constraints involved (could be more general???) 12627 12628 elsif Etype (Ityp) = Otyp 12629 and then not Is_Tagged_Type (Ityp) 12630 and then not Has_Discriminants (Ityp) 12631 and then No (First_Rep_Item (Base_Type (Ityp))) 12632 then 12633 return True; 12634 12635 -- If the expression has an access type (object or subprogram) we assume 12636 -- that the conversion is safe, because the size of the target is safe, 12637 -- even if it is a record (which might be treated as having unknown size 12638 -- at this point). 12639 12640 elsif Is_Access_Type (Ityp) then 12641 return True; 12642 12643 -- If the size of output type is known at compile time, there is never 12644 -- a problem. Note that unconstrained records are considered to be of 12645 -- known size, but we can't consider them that way here, because we are 12646 -- talking about the actual size of the object. 12647 12648 -- We also make sure that in addition to the size being known, we do not 12649 -- have a case which might generate an embarrassingly large temp in 12650 -- stack checking mode. 12651 12652 elsif Size_Known_At_Compile_Time (Otyp) 12653 and then 12654 (not Stack_Checking_Enabled 12655 or else not May_Generate_Large_Temp (Otyp)) 12656 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp)) 12657 then 12658 return True; 12659 12660 -- If either type is tagged, then we know the alignment is OK so Gigi 12661 -- will be able to use pointer punning. 12662 12663 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then 12664 return True; 12665 12666 -- If either type is a limited record type, we cannot do a copy, so say 12667 -- safe since there's nothing else we can do. 12668 12669 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then 12670 return True; 12671 12672 -- Conversions to and from packed array types are always ignored and 12673 -- hence are safe. 12674 12675 elsif Is_Packed_Array_Impl_Type (Otyp) 12676 or else Is_Packed_Array_Impl_Type (Ityp) 12677 then 12678 return True; 12679 end if; 12680 12681 -- The only other cases known to be safe is if the input type's 12682 -- alignment is known to be at least the maximum alignment for the 12683 -- target or if both alignments are known and the output type's 12684 -- alignment is no stricter than the input's. We can use the component 12685 -- type alignment for an array if a type is an unpacked array type. 12686 12687 if Present (Alignment_Clause (Otyp)) then 12688 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp))); 12689 12690 elsif Is_Array_Type (Otyp) 12691 and then Present (Alignment_Clause (Component_Type (Otyp))) 12692 then 12693 Oalign := Expr_Value (Expression (Alignment_Clause 12694 (Component_Type (Otyp)))); 12695 end if; 12696 12697 if Present (Alignment_Clause (Ityp)) then 12698 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp))); 12699 12700 elsif Is_Array_Type (Ityp) 12701 and then Present (Alignment_Clause (Component_Type (Ityp))) 12702 then 12703 Ialign := Expr_Value (Expression (Alignment_Clause 12704 (Component_Type (Ityp)))); 12705 end if; 12706 12707 if Ialign /= No_Uint and then Ialign > Maximum_Alignment then 12708 return True; 12709 12710 elsif Ialign /= No_Uint 12711 and then Oalign /= No_Uint 12712 and then Ialign <= Oalign 12713 then 12714 return True; 12715 12716 -- Otherwise, Gigi cannot handle this and we must make a temporary 12717 12718 else 12719 return False; 12720 end if; 12721 end Safe_Unchecked_Type_Conversion; 12722 12723 --------------------------------- 12724 -- Set_Current_Value_Condition -- 12725 --------------------------------- 12726 12727 -- Note: the implementation of this procedure is very closely tied to the 12728 -- implementation of Get_Current_Value_Condition. Here we set required 12729 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret 12730 -- them, so they must have a consistent view. 12731 12732 procedure Set_Current_Value_Condition (Cnode : Node_Id) is 12733 12734 procedure Set_Entity_Current_Value (N : Node_Id); 12735 -- If N is an entity reference, where the entity is of an appropriate 12736 -- kind, then set the current value of this entity to Cnode, unless 12737 -- there is already a definite value set there. 12738 12739 procedure Set_Expression_Current_Value (N : Node_Id); 12740 -- If N is of an appropriate form, sets an appropriate entry in current 12741 -- value fields of relevant entities. Multiple entities can be affected 12742 -- in the case of an AND or AND THEN. 12743 12744 ------------------------------ 12745 -- Set_Entity_Current_Value -- 12746 ------------------------------ 12747 12748 procedure Set_Entity_Current_Value (N : Node_Id) is 12749 begin 12750 if Is_Entity_Name (N) then 12751 declare 12752 Ent : constant Entity_Id := Entity (N); 12753 12754 begin 12755 -- Don't capture if not safe to do so 12756 12757 if not Safe_To_Capture_Value (N, Ent, Cond => True) then 12758 return; 12759 end if; 12760 12761 -- Here we have a case where the Current_Value field may need 12762 -- to be set. We set it if it is not already set to a compile 12763 -- time expression value. 12764 12765 -- Note that this represents a decision that one condition 12766 -- blots out another previous one. That's certainly right if 12767 -- they occur at the same level. If the second one is nested, 12768 -- then the decision is neither right nor wrong (it would be 12769 -- equally OK to leave the outer one in place, or take the new 12770 -- inner one. Really we should record both, but our data 12771 -- structures are not that elaborate. 12772 12773 if Nkind (Current_Value (Ent)) not in N_Subexpr then 12774 Set_Current_Value (Ent, Cnode); 12775 end if; 12776 end; 12777 end if; 12778 end Set_Entity_Current_Value; 12779 12780 ---------------------------------- 12781 -- Set_Expression_Current_Value -- 12782 ---------------------------------- 12783 12784 procedure Set_Expression_Current_Value (N : Node_Id) is 12785 Cond : Node_Id; 12786 12787 begin 12788 Cond := N; 12789 12790 -- Loop to deal with (ignore for now) any NOT operators present. The 12791 -- presence of NOT operators will be handled properly when we call 12792 -- Get_Current_Value_Condition. 12793 12794 while Nkind (Cond) = N_Op_Not loop 12795 Cond := Right_Opnd (Cond); 12796 end loop; 12797 12798 -- For an AND or AND THEN, recursively process operands 12799 12800 if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then 12801 Set_Expression_Current_Value (Left_Opnd (Cond)); 12802 Set_Expression_Current_Value (Right_Opnd (Cond)); 12803 return; 12804 end if; 12805 12806 -- Check possible relational operator 12807 12808 if Nkind (Cond) in N_Op_Compare then 12809 if Compile_Time_Known_Value (Right_Opnd (Cond)) then 12810 Set_Entity_Current_Value (Left_Opnd (Cond)); 12811 elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then 12812 Set_Entity_Current_Value (Right_Opnd (Cond)); 12813 end if; 12814 12815 elsif Nkind_In (Cond, 12816 N_Type_Conversion, 12817 N_Qualified_Expression, 12818 N_Expression_With_Actions) 12819 then 12820 Set_Expression_Current_Value (Expression (Cond)); 12821 12822 -- Check possible boolean variable reference 12823 12824 else 12825 Set_Entity_Current_Value (Cond); 12826 end if; 12827 end Set_Expression_Current_Value; 12828 12829 -- Start of processing for Set_Current_Value_Condition 12830 12831 begin 12832 Set_Expression_Current_Value (Condition (Cnode)); 12833 end Set_Current_Value_Condition; 12834 12835 -------------------------- 12836 -- Set_Elaboration_Flag -- 12837 -------------------------- 12838 12839 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is 12840 Loc : constant Source_Ptr := Sloc (N); 12841 Ent : constant Entity_Id := Elaboration_Entity (Spec_Id); 12842 Asn : Node_Id; 12843 12844 begin 12845 if Present (Ent) then 12846 12847 -- Nothing to do if at the compilation unit level, because in this 12848 -- case the flag is set by the binder generated elaboration routine. 12849 12850 if Nkind (Parent (N)) = N_Compilation_Unit then 12851 null; 12852 12853 -- Here we do need to generate an assignment statement 12854 12855 else 12856 Check_Restriction (No_Elaboration_Code, N); 12857 12858 Asn := 12859 Make_Assignment_Statement (Loc, 12860 Name => New_Occurrence_Of (Ent, Loc), 12861 Expression => Make_Integer_Literal (Loc, Uint_1)); 12862 12863 -- Mark the assignment statement as elaboration code. This allows 12864 -- the early call region mechanism (see Sem_Elab) to properly 12865 -- ignore such assignments even though they are nonpreelaborable 12866 -- code. 12867 12868 Set_Is_Elaboration_Code (Asn); 12869 12870 if Nkind (Parent (N)) = N_Subunit then 12871 Insert_After (Corresponding_Stub (Parent (N)), Asn); 12872 else 12873 Insert_After (N, Asn); 12874 end if; 12875 12876 Analyze (Asn); 12877 12878 -- Kill current value indication. This is necessary because the 12879 -- tests of this flag are inserted out of sequence and must not 12880 -- pick up bogus indications of the wrong constant value. 12881 12882 Set_Current_Value (Ent, Empty); 12883 12884 -- If the subprogram is in the current declarative part and 12885 -- 'access has been applied to it, generate an elaboration 12886 -- check at the beginning of the declarations of the body. 12887 12888 if Nkind (N) = N_Subprogram_Body 12889 and then Address_Taken (Spec_Id) 12890 and then 12891 Ekind_In (Scope (Spec_Id), E_Block, E_Procedure, E_Function) 12892 then 12893 declare 12894 Loc : constant Source_Ptr := Sloc (N); 12895 Decls : constant List_Id := Declarations (N); 12896 Chk : Node_Id; 12897 12898 begin 12899 -- No need to generate this check if first entry in the 12900 -- declaration list is a raise of Program_Error now. 12901 12902 if Present (Decls) 12903 and then Nkind (First (Decls)) = N_Raise_Program_Error 12904 then 12905 return; 12906 end if; 12907 12908 -- Otherwise generate the check 12909 12910 Chk := 12911 Make_Raise_Program_Error (Loc, 12912 Condition => 12913 Make_Op_Eq (Loc, 12914 Left_Opnd => New_Occurrence_Of (Ent, Loc), 12915 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), 12916 Reason => PE_Access_Before_Elaboration); 12917 12918 if No (Decls) then 12919 Set_Declarations (N, New_List (Chk)); 12920 else 12921 Prepend (Chk, Decls); 12922 end if; 12923 12924 Analyze (Chk); 12925 end; 12926 end if; 12927 end if; 12928 end if; 12929 end Set_Elaboration_Flag; 12930 12931 ---------------------------- 12932 -- Set_Renamed_Subprogram -- 12933 ---------------------------- 12934 12935 procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is 12936 begin 12937 -- If input node is an identifier, we can just reset it 12938 12939 if Nkind (N) = N_Identifier then 12940 Set_Chars (N, Chars (E)); 12941 Set_Entity (N, E); 12942 12943 -- Otherwise we have to do a rewrite, preserving Comes_From_Source 12944 12945 else 12946 declare 12947 CS : constant Boolean := Comes_From_Source (N); 12948 begin 12949 Rewrite (N, Make_Identifier (Sloc (N), Chars (E))); 12950 Set_Entity (N, E); 12951 Set_Comes_From_Source (N, CS); 12952 Set_Analyzed (N, True); 12953 end; 12954 end if; 12955 end Set_Renamed_Subprogram; 12956 12957 ---------------------- 12958 -- Side_Effect_Free -- 12959 ---------------------- 12960 12961 function Side_Effect_Free 12962 (N : Node_Id; 12963 Name_Req : Boolean := False; 12964 Variable_Ref : Boolean := False) return Boolean 12965 is 12966 Typ : constant Entity_Id := Etype (N); 12967 -- Result type of the expression 12968 12969 function Safe_Prefixed_Reference (N : Node_Id) return Boolean; 12970 -- The argument N is a construct where the Prefix is dereferenced if it 12971 -- is an access type and the result is a variable. The call returns True 12972 -- if the construct is side effect free (not considering side effects in 12973 -- other than the prefix which are to be tested by the caller). 12974 12975 function Within_In_Parameter (N : Node_Id) return Boolean; 12976 -- Determines if N is a subcomponent of a composite in-parameter. If so, 12977 -- N is not side-effect free when the actual is global and modifiable 12978 -- indirectly from within a subprogram, because it may be passed by 12979 -- reference. The front-end must be conservative here and assume that 12980 -- this may happen with any array or record type. On the other hand, we 12981 -- cannot create temporaries for all expressions for which this 12982 -- condition is true, for various reasons that might require clearing up 12983 -- ??? For example, discriminant references that appear out of place, or 12984 -- spurious type errors with class-wide expressions. As a result, we 12985 -- limit the transformation to loop bounds, which is so far the only 12986 -- case that requires it. 12987 12988 ----------------------------- 12989 -- Safe_Prefixed_Reference -- 12990 ----------------------------- 12991 12992 function Safe_Prefixed_Reference (N : Node_Id) return Boolean is 12993 begin 12994 -- If prefix is not side effect free, definitely not safe 12995 12996 if not Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref) then 12997 return False; 12998 12999 -- If the prefix is of an access type that is not access-to-constant, 13000 -- then this construct is a variable reference, which means it is to 13001 -- be considered to have side effects if Variable_Ref is set True. 13002 13003 elsif Is_Access_Type (Etype (Prefix (N))) 13004 and then not Is_Access_Constant (Etype (Prefix (N))) 13005 and then Variable_Ref 13006 then 13007 -- Exception is a prefix that is the result of a previous removal 13008 -- of side effects. 13009 13010 return Is_Entity_Name (Prefix (N)) 13011 and then not Comes_From_Source (Prefix (N)) 13012 and then Ekind (Entity (Prefix (N))) = E_Constant 13013 and then Is_Internal_Name (Chars (Entity (Prefix (N)))); 13014 13015 -- If the prefix is an explicit dereference then this construct is a 13016 -- variable reference, which means it is to be considered to have 13017 -- side effects if Variable_Ref is True. 13018 13019 -- We do NOT exclude dereferences of access-to-constant types because 13020 -- we handle them as constant view of variables. 13021 13022 elsif Nkind (Prefix (N)) = N_Explicit_Dereference 13023 and then Variable_Ref 13024 then 13025 return False; 13026 13027 -- Note: The following test is the simplest way of solving a complex 13028 -- problem uncovered by the following test (Side effect on loop bound 13029 -- that is a subcomponent of a global variable: 13030 13031 -- with Text_Io; use Text_Io; 13032 -- procedure Tloop is 13033 -- type X is 13034 -- record 13035 -- V : Natural := 4; 13036 -- S : String (1..5) := (others => 'a'); 13037 -- end record; 13038 -- X1 : X; 13039 13040 -- procedure Modi; 13041 13042 -- generic 13043 -- with procedure Action; 13044 -- procedure Loop_G (Arg : X; Msg : String) 13045 13046 -- procedure Loop_G (Arg : X; Msg : String) is 13047 -- begin 13048 -- Put_Line ("begin loop_g " & Msg & " will loop till: " 13049 -- & Natural'Image (Arg.V)); 13050 -- for Index in 1 .. Arg.V loop 13051 -- Text_Io.Put_Line 13052 -- (Natural'Image (Index) & " " & Arg.S (Index)); 13053 -- if Index > 2 then 13054 -- Modi; 13055 -- end if; 13056 -- end loop; 13057 -- Put_Line ("end loop_g " & Msg); 13058 -- end; 13059 13060 -- procedure Loop1 is new Loop_G (Modi); 13061 -- procedure Modi is 13062 -- begin 13063 -- X1.V := 1; 13064 -- Loop1 (X1, "from modi"); 13065 -- end; 13066 -- 13067 -- begin 13068 -- Loop1 (X1, "initial"); 13069 -- end; 13070 13071 -- The output of the above program should be: 13072 13073 -- begin loop_g initial will loop till: 4 13074 -- 1 a 13075 -- 2 a 13076 -- 3 a 13077 -- begin loop_g from modi will loop till: 1 13078 -- 1 a 13079 -- end loop_g from modi 13080 -- 4 a 13081 -- begin loop_g from modi will loop till: 1 13082 -- 1 a 13083 -- end loop_g from modi 13084 -- end loop_g initial 13085 13086 -- If a loop bound is a subcomponent of a global variable, a 13087 -- modification of that variable within the loop may incorrectly 13088 -- affect the execution of the loop. 13089 13090 elsif Nkind (Parent (Parent (N))) = N_Loop_Parameter_Specification 13091 and then Within_In_Parameter (Prefix (N)) 13092 and then Variable_Ref 13093 then 13094 return False; 13095 13096 -- All other cases are side effect free 13097 13098 else 13099 return True; 13100 end if; 13101 end Safe_Prefixed_Reference; 13102 13103 ------------------------- 13104 -- Within_In_Parameter -- 13105 ------------------------- 13106 13107 function Within_In_Parameter (N : Node_Id) return Boolean is 13108 begin 13109 if not Comes_From_Source (N) then 13110 return False; 13111 13112 elsif Is_Entity_Name (N) then 13113 return Ekind (Entity (N)) = E_In_Parameter; 13114 13115 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then 13116 return Within_In_Parameter (Prefix (N)); 13117 13118 else 13119 return False; 13120 end if; 13121 end Within_In_Parameter; 13122 13123 -- Start of processing for Side_Effect_Free 13124 13125 begin 13126 -- If volatile reference, always consider it to have side effects 13127 13128 if Is_Volatile_Reference (N) then 13129 return False; 13130 end if; 13131 13132 -- Note on checks that could raise Constraint_Error. Strictly, if we 13133 -- take advantage of 11.6, these checks do not count as side effects. 13134 -- However, we would prefer to consider that they are side effects, 13135 -- since the back end CSE does not work very well on expressions which 13136 -- can raise Constraint_Error. On the other hand if we don't consider 13137 -- them to be side effect free, then we get some awkward expansions 13138 -- in -gnato mode, resulting in code insertions at a point where we 13139 -- do not have a clear model for performing the insertions. 13140 13141 -- Special handling for entity names 13142 13143 if Is_Entity_Name (N) then 13144 13145 -- A type reference is always side effect free 13146 13147 if Is_Type (Entity (N)) then 13148 return True; 13149 13150 -- Variables are considered to be a side effect if Variable_Ref 13151 -- is set or if we have a volatile reference and Name_Req is off. 13152 -- If Name_Req is True then we can't help returning a name which 13153 -- effectively allows multiple references in any case. 13154 13155 elsif Is_Variable (N, Use_Original_Node => False) then 13156 return not Variable_Ref 13157 and then (not Is_Volatile_Reference (N) or else Name_Req); 13158 13159 -- Any other entity (e.g. a subtype name) is definitely side 13160 -- effect free. 13161 13162 else 13163 return True; 13164 end if; 13165 13166 -- A value known at compile time is always side effect free 13167 13168 elsif Compile_Time_Known_Value (N) then 13169 return True; 13170 13171 -- A variable renaming is not side-effect free, because the renaming 13172 -- will function like a macro in the front-end in some cases, and an 13173 -- assignment can modify the component designated by N, so we need to 13174 -- create a temporary for it. 13175 13176 -- The guard testing for Entity being present is needed at least in 13177 -- the case of rewritten predicate expressions, and may well also be 13178 -- appropriate elsewhere. Obviously we can't go testing the entity 13179 -- field if it does not exist, so it's reasonable to say that this is 13180 -- not the renaming case if it does not exist. 13181 13182 elsif Is_Entity_Name (Original_Node (N)) 13183 and then Present (Entity (Original_Node (N))) 13184 and then Is_Renaming_Of_Object (Entity (Original_Node (N))) 13185 and then Ekind (Entity (Original_Node (N))) /= E_Constant 13186 then 13187 declare 13188 RO : constant Node_Id := 13189 Renamed_Object (Entity (Original_Node (N))); 13190 13191 begin 13192 -- If the renamed object is an indexed component, or an 13193 -- explicit dereference, then the designated object could 13194 -- be modified by an assignment. 13195 13196 if Nkind_In (RO, N_Indexed_Component, 13197 N_Explicit_Dereference) 13198 then 13199 return False; 13200 13201 -- A selected component must have a safe prefix 13202 13203 elsif Nkind (RO) = N_Selected_Component then 13204 return Safe_Prefixed_Reference (RO); 13205 13206 -- In all other cases, designated object cannot be changed so 13207 -- we are side effect free. 13208 13209 else 13210 return True; 13211 end if; 13212 end; 13213 13214 -- Remove_Side_Effects generates an object renaming declaration to 13215 -- capture the expression of a class-wide expression. In VM targets 13216 -- the frontend performs no expansion for dispatching calls to 13217 -- class- wide types since they are handled by the VM. Hence, we must 13218 -- locate here if this node corresponds to a previous invocation of 13219 -- Remove_Side_Effects to avoid a never ending loop in the frontend. 13220 13221 elsif not Tagged_Type_Expansion 13222 and then not Comes_From_Source (N) 13223 and then Nkind (Parent (N)) = N_Object_Renaming_Declaration 13224 and then Is_Class_Wide_Type (Typ) 13225 then 13226 return True; 13227 13228 -- Generating C the type conversion of an access to constrained array 13229 -- type into an access to unconstrained array type involves initializing 13230 -- a fat pointer and the expression cannot be assumed to be free of side 13231 -- effects since it must referenced several times to compute its bounds. 13232 13233 elsif Modify_Tree_For_C 13234 and then Nkind (N) = N_Type_Conversion 13235 and then Is_Access_Type (Typ) 13236 and then Is_Array_Type (Designated_Type (Typ)) 13237 and then not Is_Constrained (Designated_Type (Typ)) 13238 then 13239 return False; 13240 end if; 13241 13242 -- For other than entity names and compile time known values, 13243 -- check the node kind for special processing. 13244 13245 case Nkind (N) is 13246 13247 -- An attribute reference is side effect free if its expressions 13248 -- are side effect free and its prefix is side effect free or 13249 -- is an entity reference. 13250 13251 -- Is this right? what about x'first where x is a variable??? 13252 13253 when N_Attribute_Reference => 13254 Attribute_Reference : declare 13255 13256 function Side_Effect_Free_Attribute 13257 (Attribute_Name : Name_Id) return Boolean; 13258 -- Returns True if evaluation of the given attribute is 13259 -- considered side-effect free (independent of prefix and 13260 -- arguments). 13261 13262 -------------------------------- 13263 -- Side_Effect_Free_Attribute -- 13264 -------------------------------- 13265 13266 function Side_Effect_Free_Attribute 13267 (Attribute_Name : Name_Id) return Boolean 13268 is 13269 begin 13270 case Attribute_Name is 13271 when Name_Input => 13272 return False; 13273 13274 when Name_Image 13275 | Name_Img 13276 | Name_Wide_Image 13277 | Name_Wide_Wide_Image 13278 => 13279 -- CodePeer doesn't want to see replicated copies of 13280 -- 'Image calls. 13281 13282 return not CodePeer_Mode; 13283 13284 when others => 13285 return True; 13286 end case; 13287 end Side_Effect_Free_Attribute; 13288 13289 -- Start of processing for Attribute_Reference 13290 13291 begin 13292 return 13293 Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref) 13294 and then Side_Effect_Free_Attribute (Attribute_Name (N)) 13295 and then (Is_Entity_Name (Prefix (N)) 13296 or else Side_Effect_Free 13297 (Prefix (N), Name_Req, Variable_Ref)); 13298 end Attribute_Reference; 13299 13300 -- A binary operator is side effect free if and both operands are 13301 -- side effect free. For this purpose binary operators include 13302 -- membership tests and short circuit forms. 13303 13304 when N_Binary_Op 13305 | N_Membership_Test 13306 | N_Short_Circuit 13307 => 13308 return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref) 13309 and then 13310 Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref); 13311 13312 -- An explicit dereference is side effect free only if it is 13313 -- a side effect free prefixed reference. 13314 13315 when N_Explicit_Dereference => 13316 return Safe_Prefixed_Reference (N); 13317 13318 -- An expression with action is side effect free if its expression 13319 -- is side effect free and it has no actions. 13320 13321 when N_Expression_With_Actions => 13322 return 13323 Is_Empty_List (Actions (N)) 13324 and then Side_Effect_Free 13325 (Expression (N), Name_Req, Variable_Ref); 13326 13327 -- A call to _rep_to_pos is side effect free, since we generate 13328 -- this pure function call ourselves. Moreover it is critically 13329 -- important to make this exception, since otherwise we can have 13330 -- discriminants in array components which don't look side effect 13331 -- free in the case of an array whose index type is an enumeration 13332 -- type with an enumeration rep clause. 13333 13334 -- All other function calls are not side effect free 13335 13336 when N_Function_Call => 13337 return 13338 Nkind (Name (N)) = N_Identifier 13339 and then Is_TSS (Name (N), TSS_Rep_To_Pos) 13340 and then Side_Effect_Free 13341 (First (Parameter_Associations (N)), 13342 Name_Req, Variable_Ref); 13343 13344 -- An IF expression is side effect free if it's of a scalar type, and 13345 -- all its components are all side effect free (conditions and then 13346 -- actions and else actions). We restrict to scalar types, since it 13347 -- is annoying to deal with things like (if A then B else C)'First 13348 -- where the type involved is a string type. 13349 13350 when N_If_Expression => 13351 return 13352 Is_Scalar_Type (Typ) 13353 and then Side_Effect_Free 13354 (Expressions (N), Name_Req, Variable_Ref); 13355 13356 -- An indexed component is side effect free if it is a side 13357 -- effect free prefixed reference and all the indexing 13358 -- expressions are side effect free. 13359 13360 when N_Indexed_Component => 13361 return 13362 Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref) 13363 and then Safe_Prefixed_Reference (N); 13364 13365 -- A type qualification, type conversion, or unchecked expression is 13366 -- side effect free if the expression is side effect free. 13367 13368 when N_Qualified_Expression 13369 | N_Type_Conversion 13370 | N_Unchecked_Expression 13371 => 13372 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref); 13373 13374 -- A selected component is side effect free only if it is a side 13375 -- effect free prefixed reference. 13376 13377 when N_Selected_Component => 13378 return Safe_Prefixed_Reference (N); 13379 13380 -- A range is side effect free if the bounds are side effect free 13381 13382 when N_Range => 13383 return Side_Effect_Free (Low_Bound (N), Name_Req, Variable_Ref) 13384 and then 13385 Side_Effect_Free (High_Bound (N), Name_Req, Variable_Ref); 13386 13387 -- A slice is side effect free if it is a side effect free 13388 -- prefixed reference and the bounds are side effect free. 13389 13390 when N_Slice => 13391 return 13392 Side_Effect_Free (Discrete_Range (N), Name_Req, Variable_Ref) 13393 and then Safe_Prefixed_Reference (N); 13394 13395 -- A unary operator is side effect free if the operand 13396 -- is side effect free. 13397 13398 when N_Unary_Op => 13399 return Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref); 13400 13401 -- An unchecked type conversion is side effect free only if it 13402 -- is safe and its argument is side effect free. 13403 13404 when N_Unchecked_Type_Conversion => 13405 return 13406 Safe_Unchecked_Type_Conversion (N) 13407 and then Side_Effect_Free 13408 (Expression (N), Name_Req, Variable_Ref); 13409 13410 -- A literal is side effect free 13411 13412 when N_Character_Literal 13413 | N_Integer_Literal 13414 | N_Real_Literal 13415 | N_String_Literal 13416 => 13417 return True; 13418 13419 -- We consider that anything else has side effects. This is a bit 13420 -- crude, but we are pretty close for most common cases, and we 13421 -- are certainly correct (i.e. we never return True when the 13422 -- answer should be False). 13423 13424 when others => 13425 return False; 13426 end case; 13427 end Side_Effect_Free; 13428 13429 -- A list is side effect free if all elements of the list are side 13430 -- effect free. 13431 13432 function Side_Effect_Free 13433 (L : List_Id; 13434 Name_Req : Boolean := False; 13435 Variable_Ref : Boolean := False) return Boolean 13436 is 13437 N : Node_Id; 13438 13439 begin 13440 if L = No_List or else L = Error_List then 13441 return True; 13442 13443 else 13444 N := First (L); 13445 while Present (N) loop 13446 if not Side_Effect_Free (N, Name_Req, Variable_Ref) then 13447 return False; 13448 else 13449 Next (N); 13450 end if; 13451 end loop; 13452 13453 return True; 13454 end if; 13455 end Side_Effect_Free; 13456 13457 ---------------------------------- 13458 -- Silly_Boolean_Array_Not_Test -- 13459 ---------------------------------- 13460 13461 -- This procedure implements an odd and silly test. We explicitly check 13462 -- for the case where the 'First of the component type is equal to the 13463 -- 'Last of this component type, and if this is the case, we make sure 13464 -- that constraint error is raised. The reason is that the NOT is bound 13465 -- to cause CE in this case, and we will not otherwise catch it. 13466 13467 -- No such check is required for AND and OR, since for both these cases 13468 -- False op False = False, and True op True = True. For the XOR case, 13469 -- see Silly_Boolean_Array_Xor_Test. 13470 13471 -- Believe it or not, this was reported as a bug. Note that nearly always, 13472 -- the test will evaluate statically to False, so the code will be 13473 -- statically removed, and no extra overhead caused. 13474 13475 procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is 13476 Loc : constant Source_Ptr := Sloc (N); 13477 CT : constant Entity_Id := Component_Type (T); 13478 13479 begin 13480 -- The check we install is 13481 13482 -- constraint_error when 13483 -- component_type'first = component_type'last 13484 -- and then array_type'Length /= 0) 13485 13486 -- We need the last guard because we don't want to raise CE for empty 13487 -- arrays since no out of range values result. (Empty arrays with a 13488 -- component type of True .. True -- very useful -- even the ACATS 13489 -- does not test that marginal case). 13490 13491 Insert_Action (N, 13492 Make_Raise_Constraint_Error (Loc, 13493 Condition => 13494 Make_And_Then (Loc, 13495 Left_Opnd => 13496 Make_Op_Eq (Loc, 13497 Left_Opnd => 13498 Make_Attribute_Reference (Loc, 13499 Prefix => New_Occurrence_Of (CT, Loc), 13500 Attribute_Name => Name_First), 13501 13502 Right_Opnd => 13503 Make_Attribute_Reference (Loc, 13504 Prefix => New_Occurrence_Of (CT, Loc), 13505 Attribute_Name => Name_Last)), 13506 13507 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))), 13508 Reason => CE_Range_Check_Failed)); 13509 end Silly_Boolean_Array_Not_Test; 13510 13511 ---------------------------------- 13512 -- Silly_Boolean_Array_Xor_Test -- 13513 ---------------------------------- 13514 13515 -- This procedure implements an odd and silly test. We explicitly check 13516 -- for the XOR case where the component type is True .. True, since this 13517 -- will raise constraint error. A special check is required since CE 13518 -- will not be generated otherwise (cf Expand_Packed_Not). 13519 13520 -- No such check is required for AND and OR, since for both these cases 13521 -- False op False = False, and True op True = True, and no check is 13522 -- required for the case of False .. False, since False xor False = False. 13523 -- See also Silly_Boolean_Array_Not_Test 13524 13525 procedure Silly_Boolean_Array_Xor_Test 13526 (N : Node_Id; 13527 R : Node_Id; 13528 T : Entity_Id) 13529 is 13530 Loc : constant Source_Ptr := Sloc (N); 13531 CT : constant Entity_Id := Component_Type (T); 13532 13533 begin 13534 -- The check we install is 13535 13536 -- constraint_error when 13537 -- Boolean (component_type'First) 13538 -- and then Boolean (component_type'Last) 13539 -- and then array_type'Length /= 0) 13540 13541 -- We need the last guard because we don't want to raise CE for empty 13542 -- arrays since no out of range values result (Empty arrays with a 13543 -- component type of True .. True -- very useful -- even the ACATS 13544 -- does not test that marginal case). 13545 13546 Insert_Action (N, 13547 Make_Raise_Constraint_Error (Loc, 13548 Condition => 13549 Make_And_Then (Loc, 13550 Left_Opnd => 13551 Make_And_Then (Loc, 13552 Left_Opnd => 13553 Convert_To (Standard_Boolean, 13554 Make_Attribute_Reference (Loc, 13555 Prefix => New_Occurrence_Of (CT, Loc), 13556 Attribute_Name => Name_First)), 13557 13558 Right_Opnd => 13559 Convert_To (Standard_Boolean, 13560 Make_Attribute_Reference (Loc, 13561 Prefix => New_Occurrence_Of (CT, Loc), 13562 Attribute_Name => Name_Last))), 13563 13564 Right_Opnd => Make_Non_Empty_Check (Loc, R)), 13565 Reason => CE_Range_Check_Failed)); 13566 end Silly_Boolean_Array_Xor_Test; 13567 13568 -------------------------- 13569 -- Target_Has_Fixed_Ops -- 13570 -------------------------- 13571 13572 Integer_Sized_Small : Ureal; 13573 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this function is 13574 -- called (we don't want to compute it more than once). 13575 13576 Long_Integer_Sized_Small : Ureal; 13577 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function 13578 -- is called (we don't want to compute it more than once) 13579 13580 First_Time_For_THFO : Boolean := True; 13581 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target) 13582 13583 function Target_Has_Fixed_Ops 13584 (Left_Typ : Entity_Id; 13585 Right_Typ : Entity_Id; 13586 Result_Typ : Entity_Id) return Boolean 13587 is 13588 function Is_Fractional_Type (Typ : Entity_Id) return Boolean; 13589 -- Return True if the given type is a fixed-point type with a small 13590 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have 13591 -- an absolute value less than 1.0. This is currently limited to 13592 -- fixed-point types that map to Integer or Long_Integer. 13593 13594 ------------------------ 13595 -- Is_Fractional_Type -- 13596 ------------------------ 13597 13598 function Is_Fractional_Type (Typ : Entity_Id) return Boolean is 13599 begin 13600 if Esize (Typ) = Standard_Integer_Size then 13601 return Small_Value (Typ) = Integer_Sized_Small; 13602 13603 elsif Esize (Typ) = Standard_Long_Integer_Size then 13604 return Small_Value (Typ) = Long_Integer_Sized_Small; 13605 13606 else 13607 return False; 13608 end if; 13609 end Is_Fractional_Type; 13610 13611 -- Start of processing for Target_Has_Fixed_Ops 13612 13613 begin 13614 -- Return False if Fractional_Fixed_Ops_On_Target is false 13615 13616 if not Fractional_Fixed_Ops_On_Target then 13617 return False; 13618 end if; 13619 13620 -- Here the target has Fractional_Fixed_Ops, if first time, compute 13621 -- standard constants used by Is_Fractional_Type. 13622 13623 if First_Time_For_THFO then 13624 First_Time_For_THFO := False; 13625 13626 Integer_Sized_Small := 13627 UR_From_Components 13628 (Num => Uint_1, 13629 Den => UI_From_Int (Standard_Integer_Size - 1), 13630 Rbase => 2); 13631 13632 Long_Integer_Sized_Small := 13633 UR_From_Components 13634 (Num => Uint_1, 13635 Den => UI_From_Int (Standard_Long_Integer_Size - 1), 13636 Rbase => 2); 13637 end if; 13638 13639 -- Return True if target supports fixed-by-fixed multiply/divide for 13640 -- fractional fixed-point types (see Is_Fractional_Type) and the operand 13641 -- and result types are equivalent fractional types. 13642 13643 return Is_Fractional_Type (Base_Type (Left_Typ)) 13644 and then Is_Fractional_Type (Base_Type (Right_Typ)) 13645 and then Is_Fractional_Type (Base_Type (Result_Typ)) 13646 and then Esize (Left_Typ) = Esize (Right_Typ) 13647 and then Esize (Left_Typ) = Esize (Result_Typ); 13648 end Target_Has_Fixed_Ops; 13649 13650 ------------------- 13651 -- Type_Map_Hash -- 13652 ------------------- 13653 13654 function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header is 13655 begin 13656 return Type_Map_Header (Id mod Type_Map_Size); 13657 end Type_Map_Hash; 13658 13659 ------------------------------------------ 13660 -- Type_May_Have_Bit_Aligned_Components -- 13661 ------------------------------------------ 13662 13663 function Type_May_Have_Bit_Aligned_Components 13664 (Typ : Entity_Id) return Boolean 13665 is 13666 begin 13667 -- Array type, check component type 13668 13669 if Is_Array_Type (Typ) then 13670 return 13671 Type_May_Have_Bit_Aligned_Components (Component_Type (Typ)); 13672 13673 -- Record type, check components 13674 13675 elsif Is_Record_Type (Typ) then 13676 declare 13677 E : Entity_Id; 13678 13679 begin 13680 E := First_Component_Or_Discriminant (Typ); 13681 while Present (E) loop 13682 -- This is the crucial test: if the component itself causes 13683 -- trouble, then we can stop and return True. 13684 13685 if Component_May_Be_Bit_Aligned (E) then 13686 return True; 13687 end if; 13688 13689 -- Otherwise, we need to test its type, to see if it may 13690 -- itself contain a troublesome component. 13691 13692 if Type_May_Have_Bit_Aligned_Components (Etype (E)) then 13693 return True; 13694 end if; 13695 13696 Next_Component_Or_Discriminant (E); 13697 end loop; 13698 13699 return False; 13700 end; 13701 13702 -- Type other than array or record is always OK 13703 13704 else 13705 return False; 13706 end if; 13707 end Type_May_Have_Bit_Aligned_Components; 13708 13709 ------------------------------- 13710 -- Update_Primitives_Mapping -- 13711 ------------------------------- 13712 13713 procedure Update_Primitives_Mapping 13714 (Inher_Id : Entity_Id; 13715 Subp_Id : Entity_Id) 13716 is 13717 begin 13718 Map_Types 13719 (Parent_Type => Find_Dispatching_Type (Inher_Id), 13720 Derived_Type => Find_Dispatching_Type (Subp_Id)); 13721 end Update_Primitives_Mapping; 13722 13723 ---------------------------------- 13724 -- Within_Case_Or_If_Expression -- 13725 ---------------------------------- 13726 13727 function Within_Case_Or_If_Expression (N : Node_Id) return Boolean is 13728 Par : Node_Id; 13729 13730 begin 13731 -- Locate an enclosing case or if expression. Note that these constructs 13732 -- can be expanded into Expression_With_Actions, hence the test of the 13733 -- original node. 13734 13735 Par := Parent (N); 13736 while Present (Par) loop 13737 if Nkind_In (Original_Node (Par), N_Case_Expression, 13738 N_If_Expression) 13739 then 13740 return True; 13741 13742 -- Prevent the search from going too far 13743 13744 elsif Is_Body_Or_Package_Declaration (Par) then 13745 return False; 13746 end if; 13747 13748 Par := Parent (Par); 13749 end loop; 13750 13751 return False; 13752 end Within_Case_Or_If_Expression; 13753 13754 -------------------------------- 13755 -- Within_Internal_Subprogram -- 13756 -------------------------------- 13757 13758 function Within_Internal_Subprogram return Boolean is 13759 S : Entity_Id; 13760 13761 begin 13762 S := Current_Scope; 13763 while Present (S) and then not Is_Subprogram (S) loop 13764 S := Scope (S); 13765 end loop; 13766 13767 return Present (S) 13768 and then Get_TSS_Name (S) /= TSS_Null 13769 and then not Is_Predicate_Function (S) 13770 and then not Is_Predicate_Function_M (S); 13771 end Within_Internal_Subprogram; 13772 13773end Exp_Util; 13774