1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ A G G R -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Aspects; use Aspects; 27with Atree; use Atree; 28with Checks; use Checks; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Einfo.Entities; use Einfo.Entities; 32with Einfo.Utils; use Einfo.Utils; 33with Elists; use Elists; 34with Errout; use Errout; 35with Expander; use Expander; 36with Exp_Util; use Exp_Util; 37with Exp_Ch3; use Exp_Ch3; 38with Exp_Ch6; use Exp_Ch6; 39with Exp_Ch7; use Exp_Ch7; 40with Exp_Ch9; use Exp_Ch9; 41with Exp_Disp; use Exp_Disp; 42with Exp_Tss; use Exp_Tss; 43with Freeze; use Freeze; 44with Itypes; use Itypes; 45with Lib; use Lib; 46with Namet; use Namet; 47with Nmake; use Nmake; 48with Nlists; use Nlists; 49with Opt; use Opt; 50with Restrict; use Restrict; 51with Rident; use Rident; 52with Rtsfind; use Rtsfind; 53with Ttypes; use Ttypes; 54with Sem; use Sem; 55with Sem_Aggr; use Sem_Aggr; 56with Sem_Aux; use Sem_Aux; 57with Sem_Case; use Sem_Case; 58with Sem_Ch3; use Sem_Ch3; 59with Sem_Ch8; use Sem_Ch8; 60with Sem_Ch13; use Sem_Ch13; 61with Sem_Eval; use Sem_Eval; 62with Sem_Mech; use Sem_Mech; 63with Sem_Res; use Sem_Res; 64with Sem_Util; use Sem_Util; 65with Sinfo; use Sinfo; 66with Sinfo.Nodes; use Sinfo.Nodes; 67with Sinfo.Utils; use Sinfo.Utils; 68with Snames; use Snames; 69with Stand; use Stand; 70with Stringt; use Stringt; 71with Tbuild; use Tbuild; 72with Uintp; use Uintp; 73with Urealp; use Urealp; 74 75package body Exp_Aggr is 76 77 type Case_Bounds is record 78 Choice_Lo : Node_Id; 79 Choice_Hi : Node_Id; 80 Choice_Node : Node_Id; 81 end record; 82 83 type Case_Table_Type is array (Nat range <>) of Case_Bounds; 84 -- Table type used by Check_Case_Choices procedure 85 86 procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id); 87 procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id); 88 procedure Expand_Container_Aggregate (N : Node_Id); 89 90 function Get_Base_Object (N : Node_Id) return Entity_Id; 91 -- Return the base object, i.e. the outermost prefix object, that N refers 92 -- to statically, or Empty if it cannot be determined. The assumption is 93 -- that all dereferences are explicit in the tree rooted at N. 94 95 function Has_Default_Init_Comps (N : Node_Id) return Boolean; 96 -- N is an aggregate (record or array). Checks the presence of default 97 -- initialization (<>) in any component (Ada 2005: AI-287). 98 99 function Is_CCG_Supported_Aggregate (N : Node_Id) return Boolean; 100 -- Return True if aggregate N is located in a context supported by the 101 -- CCG backend; False otherwise. 102 103 function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean; 104 -- Returns true if N is an aggregate used to initialize the components 105 -- of a statically allocated dispatch table. 106 107 function Late_Expansion 108 (N : Node_Id; 109 Typ : Entity_Id; 110 Target : Node_Id) return List_Id; 111 -- This routine implements top-down expansion of nested aggregates. In 112 -- doing so, it avoids the generation of temporaries at each level. N is 113 -- a nested record or array aggregate with the Expansion_Delayed flag. 114 -- Typ is the expected type of the aggregate. Target is a (duplicatable) 115 -- expression that will hold the result of the aggregate expansion. 116 117 function Make_OK_Assignment_Statement 118 (Sloc : Source_Ptr; 119 Name : Node_Id; 120 Expression : Node_Id) return Node_Id; 121 -- This is like Make_Assignment_Statement, except that Assignment_OK 122 -- is set in the left operand. All assignments built by this unit use 123 -- this routine. This is needed to deal with assignments to initialized 124 -- constants that are done in place. 125 126 function Must_Slide 127 (Aggr : Node_Id; 128 Obj_Type : Entity_Id; 129 Typ : Entity_Id) return Boolean; 130 -- A static array aggregate in an object declaration can in most cases be 131 -- expanded in place. The one exception is when the aggregate is given 132 -- with component associations that specify different bounds from those of 133 -- the type definition in the object declaration. In this pathological 134 -- case the aggregate must slide, and we must introduce an intermediate 135 -- temporary to hold it. 136 -- 137 -- The same holds in an assignment to one-dimensional array of arrays, 138 -- when a component may be given with bounds that differ from those of the 139 -- component type. 140 141 function Number_Of_Choices (N : Node_Id) return Nat; 142 -- Returns the number of discrete choices (not including the others choice 143 -- if present) contained in (sub-)aggregate N. 144 145 procedure Process_Transient_Component 146 (Loc : Source_Ptr; 147 Comp_Typ : Entity_Id; 148 Init_Expr : Node_Id; 149 Fin_Call : out Node_Id; 150 Hook_Clear : out Node_Id; 151 Aggr : Node_Id := Empty; 152 Stmts : List_Id := No_List); 153 -- Subsidiary to the expansion of array and record aggregates. Generate 154 -- part of the necessary code to finalize a transient component. Comp_Typ 155 -- is the component type. Init_Expr is the initialization expression of the 156 -- component which is always a function call. Fin_Call is the finalization 157 -- call used to clean up the transient function result. Hook_Clear is the 158 -- hook reset statement. Aggr and Stmts both control the placement of the 159 -- generated code. Aggr is the related aggregate. If present, all code is 160 -- inserted prior to Aggr using Insert_Action. Stmts is the initialization 161 -- statements of the component. If present, all code is added to Stmts. 162 163 procedure Process_Transient_Component_Completion 164 (Loc : Source_Ptr; 165 Aggr : Node_Id; 166 Fin_Call : Node_Id; 167 Hook_Clear : Node_Id; 168 Stmts : List_Id); 169 -- Subsidiary to the expansion of array and record aggregates. Generate 170 -- part of the necessary code to finalize a transient component. Aggr is 171 -- the related aggregate. Fin_Clear is the finalization call used to clean 172 -- up the transient component. Hook_Clear is the hook reset statment. Stmts 173 -- is the initialization statement list for the component. All generated 174 -- code is added to Stmts. 175 176 procedure Sort_Case_Table (Case_Table : in out Case_Table_Type); 177 -- Sort the Case Table using the Lower Bound of each Choice as the key. 178 -- A simple insertion sort is used since the number of choices in a case 179 -- statement of variant part will usually be small and probably in near 180 -- sorted order. 181 182 ------------------------------------------------------ 183 -- Local subprograms for Record Aggregate Expansion -- 184 ------------------------------------------------------ 185 186 function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean; 187 -- True if N is an aggregate (possibly qualified or converted) that is 188 -- being returned from a build-in-place function. 189 190 function Build_Record_Aggr_Code 191 (N : Node_Id; 192 Typ : Entity_Id; 193 Lhs : Node_Id) return List_Id; 194 -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the 195 -- aggregate. Target is an expression containing the location on which the 196 -- component by component assignments will take place. Returns the list of 197 -- assignments plus all other adjustments needed for tagged and controlled 198 -- types. 199 200 procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id); 201 -- Transform a record aggregate into a sequence of assignments performed 202 -- component by component. N is an N_Aggregate or N_Extension_Aggregate. 203 -- Typ is the type of the record aggregate. 204 205 procedure Expand_Record_Aggregate 206 (N : Node_Id; 207 Orig_Tag : Node_Id := Empty; 208 Parent_Expr : Node_Id := Empty); 209 -- This is the top level procedure for record aggregate expansion. 210 -- Expansion for record aggregates needs expand aggregates for tagged 211 -- record types. Specifically Expand_Record_Aggregate adds the Tag 212 -- field in front of the Component_Association list that was created 213 -- during resolution by Resolve_Record_Aggregate. 214 -- 215 -- N is the record aggregate node. 216 -- Orig_Tag is the value of the Tag that has to be provided for this 217 -- specific aggregate. It carries the tag corresponding to the type 218 -- of the outermost aggregate during the recursive expansion 219 -- Parent_Expr is the ancestor part of the original extension 220 -- aggregate 221 222 function Has_Mutable_Components (Typ : Entity_Id) return Boolean; 223 -- Return true if one of the components is of a discriminated type with 224 -- defaults. An aggregate for a type with mutable components must be 225 -- expanded into individual assignments. 226 227 function In_Place_Assign_OK 228 (N : Node_Id; 229 Target_Object : Entity_Id := Empty) return Boolean; 230 -- Predicate to determine whether an aggregate assignment can be done in 231 -- place, because none of the new values can depend on the components of 232 -- the target of the assignment. 233 234 procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id); 235 -- If the type of the aggregate is a type extension with renamed discrimi- 236 -- nants, we must initialize the hidden discriminants of the parent. 237 -- Otherwise, the target object must not be initialized. The discriminants 238 -- are initialized by calling the initialization procedure for the type. 239 -- This is incorrect if the initialization of other components has any 240 -- side effects. We restrict this call to the case where the parent type 241 -- has a variant part, because this is the only case where the hidden 242 -- discriminants are accessed, namely when calling discriminant checking 243 -- functions of the parent type, and when applying a stream attribute to 244 -- an object of the derived type. 245 246 ----------------------------------------------------- 247 -- Local Subprograms for Array Aggregate Expansion -- 248 ----------------------------------------------------- 249 250 function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean; 251 -- Returns true if an aggregate assignment can be done by the back end 252 253 function Aggr_Size_OK (N : Node_Id) return Boolean; 254 -- Very large static aggregates present problems to the back-end, and are 255 -- transformed into assignments and loops. This function verifies that the 256 -- total number of components of an aggregate is acceptable for rewriting 257 -- into a purely positional static form. Aggr_Size_OK must be called before 258 -- calling Flatten. 259 -- 260 -- This function also detects and warns about one-component aggregates that 261 -- appear in a nonstatic context. Even if the component value is static, 262 -- such an aggregate must be expanded into an assignment. 263 264 function Backend_Processing_Possible (N : Node_Id) return Boolean; 265 -- This function checks if array aggregate N can be processed directly 266 -- by the backend. If this is the case, True is returned. 267 268 function Build_Array_Aggr_Code 269 (N : Node_Id; 270 Ctype : Entity_Id; 271 Index : Node_Id; 272 Into : Node_Id; 273 Scalar_Comp : Boolean; 274 Indexes : List_Id := No_List) return List_Id; 275 -- This recursive routine returns a list of statements containing the 276 -- loops and assignments that are needed for the expansion of the array 277 -- aggregate N. 278 -- 279 -- N is the (sub-)aggregate node to be expanded into code. This node has 280 -- been fully analyzed, and its Etype is properly set. 281 -- 282 -- Index is the index node corresponding to the array subaggregate N 283 -- 284 -- Into is the target expression into which we are copying the aggregate. 285 -- Note that this node may not have been analyzed yet, and so the Etype 286 -- field may not be set. 287 -- 288 -- Scalar_Comp is True if the component type of the aggregate is scalar 289 -- 290 -- Indexes is the current list of expressions used to index the object we 291 -- are writing into. 292 293 procedure Convert_Array_Aggr_In_Allocator 294 (Decl : Node_Id; 295 Aggr : Node_Id; 296 Target : Node_Id); 297 -- If the aggregate appears within an allocator and can be expanded in 298 -- place, this routine generates the individual assignments to components 299 -- of the designated object. This is an optimization over the general 300 -- case, where a temporary is first created on the stack and then used to 301 -- construct the allocated object on the heap. 302 303 procedure Convert_To_Positional 304 (N : Node_Id; 305 Handle_Bit_Packed : Boolean := False); 306 -- If possible, convert named notation to positional notation. This 307 -- conversion is possible only in some static cases. If the conversion is 308 -- possible, then N is rewritten with the analyzed converted aggregate. 309 -- The parameter Handle_Bit_Packed is usually set False (since we do 310 -- not expect the back end to handle bit packed arrays, so the normal case 311 -- of conversion is pointless), but in the special case of a call from 312 -- Packed_Array_Aggregate_Handled, we set this parameter to True, since 313 -- these are cases we handle in there. 314 315 procedure Expand_Array_Aggregate (N : Node_Id); 316 -- This is the top-level routine to perform array aggregate expansion. 317 -- N is the N_Aggregate node to be expanded. 318 319 function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean; 320 -- For two-dimensional packed aggregates with constant bounds and constant 321 -- components, it is preferable to pack the inner aggregates because the 322 -- whole matrix can then be presented to the back-end as a one-dimensional 323 -- list of literals. This is much more efficient than expanding into single 324 -- component assignments. This function determines if the type Typ is for 325 -- an array that is suitable for this optimization: it returns True if Typ 326 -- is a two dimensional bit packed array with component size 1, 2, or 4. 327 328 function Max_Aggregate_Size 329 (N : Node_Id; 330 Default_Size : Nat := 5000) return Nat; 331 -- Return the max size for a static aggregate N. Return Default_Size if no 332 -- other special criteria trigger. 333 334 function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean; 335 -- Given an array aggregate, this function handles the case of a packed 336 -- array aggregate with all constant values, where the aggregate can be 337 -- evaluated at compile time. If this is possible, then N is rewritten 338 -- to be its proper compile time value with all the components properly 339 -- assembled. The expression is analyzed and resolved and True is returned. 340 -- If this transformation is not possible, N is unchanged and False is 341 -- returned. 342 343 function Two_Dim_Packed_Array_Handled (N : Node_Id) return Boolean; 344 -- If the type of the aggregate is a two-dimensional bit_packed array 345 -- it may be transformed into an array of bytes with constant values, 346 -- and presented to the back-end as a static value. The function returns 347 -- false if this transformation cannot be performed. THis is similar to, 348 -- and reuses part of the machinery in Packed_Array_Aggregate_Handled. 349 350 ------------------------------------ 351 -- Aggr_Assignment_OK_For_Backend -- 352 ------------------------------------ 353 354 -- Back-end processing by Gigi/gcc is possible only if all the following 355 -- conditions are met: 356 357 -- 1. N consists of a single OTHERS choice, possibly recursively, or 358 -- of a single choice, possibly recursively, if it is surrounded by 359 -- a qualified expression whose subtype mark is unconstrained. 360 361 -- 2. The array type has no null ranges (the purpose of this is to 362 -- avoid a bogus warning for an out-of-range value). 363 364 -- 3. The array type has no atomic components 365 366 -- 4. The component type is elementary 367 368 -- 5. The component size is a multiple of Storage_Unit 369 370 -- 6. The component size is Storage_Unit or the value is of the form 371 -- M * (1 + A**1 + A**2 + .. A**(K-1)) where A = 2**(Storage_Unit) 372 -- and M in 0 .. A-1. This can also be viewed as K occurrences of 373 -- the Storage_Unit value M, concatenated together. 374 375 -- The ultimate goal is to generate a call to a fast memset routine 376 -- specifically optimized for the target. 377 378 function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean is 379 380 function Is_OK_Aggregate (Aggr : Node_Id) return Boolean; 381 -- Return true if Aggr is suitable for back-end assignment 382 383 --------------------- 384 -- Is_OK_Aggregate -- 385 --------------------- 386 387 function Is_OK_Aggregate (Aggr : Node_Id) return Boolean is 388 Assoc : constant List_Id := Component_Associations (Aggr); 389 390 begin 391 -- An "others" aggregate is most likely OK, but see below 392 393 if Is_Others_Aggregate (Aggr) then 394 null; 395 396 -- An aggregate with a single choice requires a qualified expression 397 -- whose subtype mark is an unconstrained type because we need it to 398 -- have the semantics of an "others" aggregate. 399 400 elsif Nkind (Parent (N)) = N_Qualified_Expression 401 and then not Is_Constrained (Entity (Subtype_Mark (Parent (N)))) 402 and then Is_Single_Aggregate (Aggr) 403 then 404 null; 405 406 -- The other cases are not OK 407 408 else 409 return False; 410 end if; 411 412 -- In any case we do not support an iterated association 413 414 return Nkind (First (Assoc)) /= N_Iterated_Component_Association; 415 end Is_OK_Aggregate; 416 417 Bounds : Range_Nodes; 418 Csiz : Uint := No_Uint; 419 Ctyp : Entity_Id; 420 Expr : Node_Id; 421 Index : Entity_Id; 422 Nunits : Int; 423 Remainder : Uint; 424 Value : Uint; 425 426 -- Start of processing for Aggr_Assignment_OK_For_Backend 427 428 begin 429 -- Back end doesn't know about <> 430 431 if Has_Default_Init_Comps (N) then 432 return False; 433 end if; 434 435 -- Recurse as far as possible to find the innermost component type 436 437 Ctyp := Etype (N); 438 Expr := N; 439 while Is_Array_Type (Ctyp) loop 440 if Nkind (Expr) /= N_Aggregate 441 or else not Is_OK_Aggregate (Expr) 442 then 443 return False; 444 end if; 445 446 Index := First_Index (Ctyp); 447 while Present (Index) loop 448 Bounds := Get_Index_Bounds (Index); 449 450 if Is_Null_Range (Bounds.First, Bounds.Last) then 451 return False; 452 end if; 453 454 Next_Index (Index); 455 end loop; 456 457 Expr := Expression (First (Component_Associations (Expr))); 458 459 for J in 1 .. Number_Dimensions (Ctyp) - 1 loop 460 if Nkind (Expr) /= N_Aggregate 461 or else not Is_OK_Aggregate (Expr) 462 then 463 return False; 464 end if; 465 466 Expr := Expression (First (Component_Associations (Expr))); 467 end loop; 468 469 if Has_Atomic_Components (Ctyp) then 470 return False; 471 end if; 472 473 Csiz := Component_Size (Ctyp); 474 Ctyp := Component_Type (Ctyp); 475 476 if Is_Full_Access (Ctyp) then 477 return False; 478 end if; 479 end loop; 480 481 -- Access types need to be dealt with specially 482 483 if Is_Access_Type (Ctyp) then 484 485 -- Component_Size is not set by Layout_Type if the component 486 -- type is an access type ??? 487 488 Csiz := Esize (Ctyp); 489 490 -- Fat pointers are rejected as they are not really elementary 491 -- for the backend. 492 493 if No (Csiz) or else Csiz /= System_Address_Size then 494 return False; 495 end if; 496 497 -- The supported expressions are NULL and constants, others are 498 -- rejected upfront to avoid being analyzed below, which can be 499 -- problematic for some of them, for example allocators. 500 501 if Nkind (Expr) /= N_Null and then not Is_Entity_Name (Expr) then 502 return False; 503 end if; 504 505 -- Scalar types are OK if their size is a multiple of Storage_Unit 506 507 elsif Is_Scalar_Type (Ctyp) and then Present (Csiz) then 508 509 if Csiz mod System_Storage_Unit /= 0 then 510 return False; 511 end if; 512 513 -- Composite types are rejected 514 515 else 516 return False; 517 end if; 518 519 -- If the expression has side effects (e.g. contains calls with 520 -- potential side effects) reject as well. We only preanalyze the 521 -- expression to prevent the removal of intended side effects. 522 523 Preanalyze_And_Resolve (Expr, Ctyp); 524 525 if not Side_Effect_Free (Expr) then 526 return False; 527 end if; 528 529 -- The expression needs to be analyzed if True is returned 530 531 Analyze_And_Resolve (Expr, Ctyp); 532 533 -- Strip away any conversions from the expression as they simply 534 -- qualify the real expression. 535 536 while Nkind (Expr) in N_Unchecked_Type_Conversion | N_Type_Conversion 537 loop 538 Expr := Expression (Expr); 539 end loop; 540 541 Nunits := UI_To_Int (Csiz) / System_Storage_Unit; 542 543 if Nunits = 1 then 544 return True; 545 end if; 546 547 if not Compile_Time_Known_Value (Expr) then 548 return False; 549 end if; 550 551 -- The only supported value for floating point is 0.0 552 553 if Is_Floating_Point_Type (Ctyp) then 554 return Expr_Value_R (Expr) = Ureal_0; 555 end if; 556 557 -- For other types, we can look into the value as an integer, which 558 -- means the representation value for enumeration literals. 559 560 Value := Expr_Rep_Value (Expr); 561 562 if Has_Biased_Representation (Ctyp) then 563 Value := Value - Expr_Value (Type_Low_Bound (Ctyp)); 564 end if; 565 566 -- Values 0 and -1 immediately satisfy the last check 567 568 if Value = Uint_0 or else Value = Uint_Minus_1 then 569 return True; 570 end if; 571 572 -- We need to work with an unsigned value 573 574 if Value < 0 then 575 Value := Value + 2**(System_Storage_Unit * Nunits); 576 end if; 577 578 Remainder := Value rem 2**System_Storage_Unit; 579 580 for J in 1 .. Nunits - 1 loop 581 Value := Value / 2**System_Storage_Unit; 582 583 if Value rem 2**System_Storage_Unit /= Remainder then 584 return False; 585 end if; 586 end loop; 587 588 return True; 589 end Aggr_Assignment_OK_For_Backend; 590 591 ------------------ 592 -- Aggr_Size_OK -- 593 ------------------ 594 595 function Aggr_Size_OK (N : Node_Id) return Boolean is 596 Typ : constant Entity_Id := Etype (N); 597 Lo : Node_Id; 598 Hi : Node_Id; 599 Indx : Node_Id; 600 Size : Uint; 601 Lov : Uint; 602 Hiv : Uint; 603 604 Max_Aggr_Size : Nat; 605 -- Determines the maximum size of an array aggregate produced by 606 -- converting named to positional notation (e.g. from others clauses). 607 -- This avoids running away with attempts to convert huge aggregates, 608 -- which hit memory limits in the backend. 609 610 function Component_Count (T : Entity_Id) return Nat; 611 -- The limit is applied to the total number of subcomponents that the 612 -- aggregate will have, which is the number of static expressions 613 -- that will appear in the flattened array. This requires a recursive 614 -- computation of the number of scalar components of the structure. 615 616 --------------------- 617 -- Component_Count -- 618 --------------------- 619 620 function Component_Count (T : Entity_Id) return Nat is 621 Res : Nat := 0; 622 Comp : Entity_Id; 623 624 begin 625 if Is_Scalar_Type (T) then 626 return 1; 627 628 elsif Is_Record_Type (T) then 629 Comp := First_Component (T); 630 while Present (Comp) loop 631 Res := Res + Component_Count (Etype (Comp)); 632 Next_Component (Comp); 633 end loop; 634 635 return Res; 636 637 elsif Is_Array_Type (T) then 638 declare 639 Lo : constant Node_Id := 640 Type_Low_Bound (Etype (First_Index (T))); 641 Hi : constant Node_Id := 642 Type_High_Bound (Etype (First_Index (T))); 643 644 Siz : constant Nat := Component_Count (Component_Type (T)); 645 646 begin 647 -- Check for superflat arrays, i.e. arrays with such bounds 648 -- as 4 .. 2, to insure that this function never returns a 649 -- meaningless negative value. 650 651 if not Compile_Time_Known_Value (Lo) 652 or else not Compile_Time_Known_Value (Hi) 653 or else Expr_Value (Hi) < Expr_Value (Lo) 654 then 655 return 0; 656 657 else 658 -- If the number of components is greater than Int'Last, 659 -- then return Int'Last, so caller will return False (Aggr 660 -- size is not OK). Otherwise, UI_To_Int will crash. 661 662 declare 663 UI : constant Uint := 664 Expr_Value (Hi) - Expr_Value (Lo) + 1; 665 begin 666 if UI_Is_In_Int_Range (UI) then 667 return Siz * UI_To_Int (UI); 668 else 669 return Int'Last; 670 end if; 671 end; 672 end if; 673 end; 674 675 else 676 -- Can only be a null for an access type 677 678 return 1; 679 end if; 680 end Component_Count; 681 682 -- Start of processing for Aggr_Size_OK 683 684 begin 685 -- We bump the maximum size unless the aggregate has a single component 686 -- association, which will be more efficient if implemented with a loop. 687 -- The -gnatd_g switch disables this bumping. 688 689 if (No (Expressions (N)) 690 and then No (Next (First (Component_Associations (N))))) 691 or else Debug_Flag_Underscore_G 692 then 693 Max_Aggr_Size := Max_Aggregate_Size (N); 694 else 695 Max_Aggr_Size := Max_Aggregate_Size (N, 500_000); 696 end if; 697 698 Size := UI_From_Int (Component_Count (Component_Type (Typ))); 699 700 Indx := First_Index (Typ); 701 while Present (Indx) loop 702 Lo := Type_Low_Bound (Etype (Indx)); 703 Hi := Type_High_Bound (Etype (Indx)); 704 705 -- Bounds need to be known at compile time 706 707 if not Compile_Time_Known_Value (Lo) 708 or else not Compile_Time_Known_Value (Hi) 709 then 710 return False; 711 end if; 712 713 Lov := Expr_Value (Lo); 714 Hiv := Expr_Value (Hi); 715 716 -- A flat array is always safe 717 718 if Hiv < Lov then 719 return True; 720 end if; 721 722 -- One-component aggregates are suspicious, and if the context type 723 -- is an object declaration with nonstatic bounds it will trip gcc; 724 -- such an aggregate must be expanded into a single assignment. 725 726 if Hiv = Lov and then Nkind (Parent (N)) = N_Object_Declaration then 727 declare 728 Index_Type : constant Entity_Id := 729 Etype 730 (First_Index (Etype (Defining_Identifier (Parent (N))))); 731 Indx : Node_Id; 732 733 begin 734 if not Compile_Time_Known_Value (Type_Low_Bound (Index_Type)) 735 or else not Compile_Time_Known_Value 736 (Type_High_Bound (Index_Type)) 737 then 738 if Present (Component_Associations (N)) then 739 Indx := 740 First 741 (Choice_List (First (Component_Associations (N)))); 742 743 if Is_Entity_Name (Indx) 744 and then not Is_Type (Entity (Indx)) 745 then 746 Error_Msg_N 747 ("single component aggregate in " 748 & "non-static context??", Indx); 749 Error_Msg_N ("\maybe subtype name was meant??", Indx); 750 end if; 751 end if; 752 753 return False; 754 end if; 755 end; 756 end if; 757 758 declare 759 Rng : constant Uint := Hiv - Lov + 1; 760 761 begin 762 -- Check if size is too large 763 764 if not UI_Is_In_Int_Range (Rng) then 765 return False; 766 end if; 767 768 -- Compute the size using universal arithmetic to avoid the 769 -- possibility of overflow on very large aggregates. 770 771 Size := Size * Rng; 772 773 if Size <= 0 774 or else Size > Max_Aggr_Size 775 then 776 return False; 777 end if; 778 end; 779 780 -- Bounds must be in integer range, for later array construction 781 782 if not UI_Is_In_Int_Range (Lov) 783 or else 784 not UI_Is_In_Int_Range (Hiv) 785 then 786 return False; 787 end if; 788 789 Next_Index (Indx); 790 end loop; 791 792 return True; 793 end Aggr_Size_OK; 794 795 --------------------------------- 796 -- Backend_Processing_Possible -- 797 --------------------------------- 798 799 -- Backend processing by Gigi/gcc is possible only if all the following 800 -- conditions are met: 801 802 -- 1. N is fully positional 803 804 -- 2. N is not a bit-packed array aggregate; 805 806 -- 3. The size of N's array type must be known at compile time. Note 807 -- that this implies that the component size is also known 808 809 -- 4. The array type of N does not follow the Fortran layout convention 810 -- or if it does it must be 1 dimensional. 811 812 -- 5. The array component type may not be tagged (which could necessitate 813 -- reassignment of proper tags). 814 815 -- 6. The array component type must not have unaligned bit components 816 817 -- 7. None of the components of the aggregate may be bit unaligned 818 -- components. 819 820 -- 8. There cannot be delayed components, since we do not know enough 821 -- at this stage to know if back end processing is possible. 822 823 -- 9. There cannot be any discriminated record components, since the 824 -- back end cannot handle this complex case. 825 826 -- 10. No controlled actions need to be generated for components 827 828 -- 11. When generating C code, N must be part of a N_Object_Declaration 829 830 -- 12. When generating C code, N must not include function calls 831 832 function Backend_Processing_Possible (N : Node_Id) return Boolean is 833 Typ : constant Entity_Id := Etype (N); 834 -- Typ is the correct constrained array subtype of the aggregate 835 836 function Component_Check (N : Node_Id; Index : Node_Id) return Boolean; 837 -- This routine checks components of aggregate N, enforcing checks 838 -- 1, 7, 8, 9, 11, and 12. In the multidimensional case, these checks 839 -- are performed on subaggregates. The Index value is the current index 840 -- being checked in the multidimensional case. 841 842 --------------------- 843 -- Component_Check -- 844 --------------------- 845 846 function Component_Check (N : Node_Id; Index : Node_Id) return Boolean is 847 function Ultimate_Original_Expression (N : Node_Id) return Node_Id; 848 -- Given a type conversion or an unchecked type conversion N, return 849 -- its innermost original expression. 850 851 ---------------------------------- 852 -- Ultimate_Original_Expression -- 853 ---------------------------------- 854 855 function Ultimate_Original_Expression (N : Node_Id) return Node_Id is 856 Expr : Node_Id := Original_Node (N); 857 858 begin 859 while Nkind (Expr) in 860 N_Type_Conversion | N_Unchecked_Type_Conversion 861 loop 862 Expr := Original_Node (Expression (Expr)); 863 end loop; 864 865 return Expr; 866 end Ultimate_Original_Expression; 867 868 -- Local variables 869 870 Expr : Node_Id; 871 872 -- Start of processing for Component_Check 873 874 begin 875 -- Checks 1: (no component associations) 876 877 if Present (Component_Associations (N)) then 878 return False; 879 end if; 880 881 -- Checks 11: The C code generator cannot handle aggregates that are 882 -- not part of an object declaration. 883 884 if Modify_Tree_For_C and then not Is_CCG_Supported_Aggregate (N) then 885 return False; 886 end if; 887 888 -- Checks on components 889 890 -- Recurse to check subaggregates, which may appear in qualified 891 -- expressions. If delayed, the front-end will have to expand. 892 -- If the component is a discriminated record, treat as nonstatic, 893 -- as the back-end cannot handle this properly. 894 895 Expr := First (Expressions (N)); 896 while Present (Expr) loop 897 898 -- Checks 8: (no delayed components) 899 900 if Is_Delayed_Aggregate (Expr) then 901 return False; 902 end if; 903 904 -- Checks 9: (no discriminated records) 905 906 if Present (Etype (Expr)) 907 and then Is_Record_Type (Etype (Expr)) 908 and then Has_Discriminants (Etype (Expr)) 909 then 910 return False; 911 end if; 912 913 -- Checks 7. Component must not be bit aligned component 914 915 if Possible_Bit_Aligned_Component (Expr) then 916 return False; 917 end if; 918 919 -- Checks 12: (no function call) 920 921 if Modify_Tree_For_C 922 and then 923 Nkind (Ultimate_Original_Expression (Expr)) = N_Function_Call 924 then 925 return False; 926 end if; 927 928 -- Recursion to following indexes for multiple dimension case 929 930 if Present (Next_Index (Index)) 931 and then not Component_Check (Expr, Next_Index (Index)) 932 then 933 return False; 934 end if; 935 936 -- All checks for that component finished, on to next 937 938 Next (Expr); 939 end loop; 940 941 return True; 942 end Component_Check; 943 944 -- Start of processing for Backend_Processing_Possible 945 946 begin 947 -- Checks 2 (array not bit packed) and 10 (no controlled actions) 948 949 if Is_Bit_Packed_Array (Typ) or else Needs_Finalization (Typ) then 950 return False; 951 end if; 952 953 -- If component is limited, aggregate must be expanded because each 954 -- component assignment must be built in place. 955 956 if Is_Limited_View (Component_Type (Typ)) then 957 return False; 958 end if; 959 960 -- Checks 4 (array must not be multidimensional Fortran case) 961 962 if Convention (Typ) = Convention_Fortran 963 and then Number_Dimensions (Typ) > 1 964 then 965 return False; 966 end if; 967 968 -- Checks 3 (size of array must be known at compile time) 969 970 if not Size_Known_At_Compile_Time (Typ) then 971 return False; 972 end if; 973 974 -- Checks on components 975 976 if not Component_Check (N, First_Index (Typ)) then 977 return False; 978 end if; 979 980 -- Checks 5 (if the component type is tagged, then we may need to do 981 -- tag adjustments. Perhaps this should be refined to check for any 982 -- component associations that actually need tag adjustment, similar 983 -- to the test in Component_OK_For_Backend for record aggregates with 984 -- tagged components, but not clear whether it's worthwhile ???; in the 985 -- case of virtual machines (no Tagged_Type_Expansion), object tags are 986 -- handled implicitly). 987 988 if Is_Tagged_Type (Component_Type (Typ)) 989 and then Tagged_Type_Expansion 990 then 991 return False; 992 end if; 993 994 -- Checks 6 (component type must not have bit aligned components) 995 996 if Type_May_Have_Bit_Aligned_Components (Component_Type (Typ)) then 997 return False; 998 end if; 999 1000 -- Backend processing is possible 1001 1002 return True; 1003 end Backend_Processing_Possible; 1004 1005 --------------------------- 1006 -- Build_Array_Aggr_Code -- 1007 --------------------------- 1008 1009 -- The code that we generate from a one dimensional aggregate is 1010 1011 -- 1. If the subaggregate contains discrete choices we 1012 1013 -- (a) Sort the discrete choices 1014 1015 -- (b) Otherwise for each discrete choice that specifies a range we 1016 -- emit a loop. If a range specifies a maximum of three values, or 1017 -- we are dealing with an expression we emit a sequence of 1018 -- assignments instead of a loop. 1019 1020 -- (c) Generate the remaining loops to cover the others choice if any 1021 1022 -- 2. If the aggregate contains positional elements we 1023 1024 -- (a) translate the positional elements in a series of assignments 1025 1026 -- (b) Generate a final loop to cover the others choice if any. 1027 -- Note that this final loop has to be a while loop since the case 1028 1029 -- L : Integer := Integer'Last; 1030 -- H : Integer := Integer'Last; 1031 -- A : array (L .. H) := (1, others =>0); 1032 1033 -- cannot be handled by a for loop. Thus for the following 1034 1035 -- array (L .. H) := (.. positional elements.., others =>E); 1036 1037 -- we always generate something like: 1038 1039 -- J : Index_Type := Index_Of_Last_Positional_Element; 1040 -- while J < H loop 1041 -- J := Index_Base'Succ (J) 1042 -- Tmp (J) := E; 1043 -- end loop; 1044 1045 function Build_Array_Aggr_Code 1046 (N : Node_Id; 1047 Ctype : Entity_Id; 1048 Index : Node_Id; 1049 Into : Node_Id; 1050 Scalar_Comp : Boolean; 1051 Indexes : List_Id := No_List) return List_Id 1052 is 1053 Loc : constant Source_Ptr := Sloc (N); 1054 Index_Base : constant Entity_Id := Base_Type (Etype (Index)); 1055 Index_Base_L : constant Node_Id := Type_Low_Bound (Index_Base); 1056 Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base); 1057 1058 function Add (Val : Int; To : Node_Id) return Node_Id; 1059 -- Returns an expression where Val is added to expression To, unless 1060 -- To+Val is provably out of To's base type range. To must be an 1061 -- already analyzed expression. 1062 1063 function Empty_Range (L, H : Node_Id) return Boolean; 1064 -- Returns True if the range defined by L .. H is certainly empty 1065 1066 function Equal (L, H : Node_Id) return Boolean; 1067 -- Returns True if L = H for sure 1068 1069 function Index_Base_Name return Node_Id; 1070 -- Returns a new reference to the index type name 1071 1072 function Gen_Assign 1073 (Ind : Node_Id; 1074 Expr : Node_Id; 1075 In_Loop : Boolean := False) return List_Id; 1076 -- Ind must be a side-effect-free expression. If the input aggregate N 1077 -- to Build_Loop contains no subaggregates, then this function returns 1078 -- the assignment statement: 1079 -- 1080 -- Into (Indexes, Ind) := Expr; 1081 -- 1082 -- Otherwise we call Build_Code recursively. Flag In_Loop should be set 1083 -- when the assignment appears within a generated loop. 1084 -- 1085 -- Ada 2005 (AI-287): In case of default initialized component, Expr 1086 -- is empty and we generate a call to the corresponding IP subprogram. 1087 1088 function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id; 1089 -- Nodes L and H must be side-effect-free expressions. If the input 1090 -- aggregate N to Build_Loop contains no subaggregates, this routine 1091 -- returns the for loop statement: 1092 -- 1093 -- for J in Index_Base'(L) .. Index_Base'(H) loop 1094 -- Into (Indexes, J) := Expr; 1095 -- end loop; 1096 -- 1097 -- Otherwise we call Build_Code recursively. As an optimization if the 1098 -- loop covers 3 or fewer scalar elements we generate a sequence of 1099 -- assignments. 1100 -- If the component association that generates the loop comes from an 1101 -- Iterated_Component_Association, the loop parameter has the name of 1102 -- the corresponding parameter in the original construct. 1103 1104 function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id; 1105 -- Nodes L and H must be side-effect-free expressions. If the input 1106 -- aggregate N to Build_Loop contains no subaggregates, this routine 1107 -- returns the while loop statement: 1108 -- 1109 -- J : Index_Base := L; 1110 -- while J < H loop 1111 -- J := Index_Base'Succ (J); 1112 -- Into (Indexes, J) := Expr; 1113 -- end loop; 1114 -- 1115 -- Otherwise we call Build_Code recursively 1116 1117 function Get_Assoc_Expr (Assoc : Node_Id) return Node_Id; 1118 -- For an association with a box, use value given by aspect 1119 -- Default_Component_Value of array type if specified, else use 1120 -- value given by aspect Default_Value for component type itself 1121 -- if specified, else return Empty. 1122 1123 function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean; 1124 function Local_Expr_Value (E : Node_Id) return Uint; 1125 -- These two Local routines are used to replace the corresponding ones 1126 -- in sem_eval because while processing the bounds of an aggregate with 1127 -- discrete choices whose index type is an enumeration, we build static 1128 -- expressions not recognized by Compile_Time_Known_Value as such since 1129 -- they have not yet been analyzed and resolved. All the expressions in 1130 -- question are things like Index_Base_Name'Val (Const) which we can 1131 -- easily recognize as being constant. 1132 1133 --------- 1134 -- Add -- 1135 --------- 1136 1137 function Add (Val : Int; To : Node_Id) return Node_Id is 1138 Expr_Pos : Node_Id; 1139 Expr : Node_Id; 1140 To_Pos : Node_Id; 1141 U_To : Uint; 1142 U_Val : constant Uint := UI_From_Int (Val); 1143 1144 begin 1145 -- Note: do not try to optimize the case of Val = 0, because 1146 -- we need to build a new node with the proper Sloc value anyway. 1147 1148 -- First test if we can do constant folding 1149 1150 if Local_Compile_Time_Known_Value (To) then 1151 U_To := Local_Expr_Value (To) + Val; 1152 1153 -- Determine if our constant is outside the range of the index. 1154 -- If so return an Empty node. This empty node will be caught 1155 -- by Empty_Range below. 1156 1157 if Compile_Time_Known_Value (Index_Base_L) 1158 and then U_To < Expr_Value (Index_Base_L) 1159 then 1160 return Empty; 1161 1162 elsif Compile_Time_Known_Value (Index_Base_H) 1163 and then U_To > Expr_Value (Index_Base_H) 1164 then 1165 return Empty; 1166 end if; 1167 1168 Expr_Pos := Make_Integer_Literal (Loc, U_To); 1169 Set_Is_Static_Expression (Expr_Pos); 1170 1171 if not Is_Enumeration_Type (Index_Base) then 1172 Expr := Expr_Pos; 1173 1174 -- If we are dealing with enumeration return 1175 -- Index_Base'Val (Expr_Pos) 1176 1177 else 1178 Expr := 1179 Make_Attribute_Reference 1180 (Loc, 1181 Prefix => Index_Base_Name, 1182 Attribute_Name => Name_Val, 1183 Expressions => New_List (Expr_Pos)); 1184 end if; 1185 1186 return Expr; 1187 end if; 1188 1189 -- If we are here no constant folding possible 1190 1191 if not Is_Enumeration_Type (Index_Base) then 1192 Expr := 1193 Make_Op_Add (Loc, 1194 Left_Opnd => Duplicate_Subexpr (To), 1195 Right_Opnd => Make_Integer_Literal (Loc, U_Val)); 1196 1197 -- If we are dealing with enumeration return 1198 -- Index_Base'Val (Index_Base'Pos (To) + Val) 1199 1200 else 1201 To_Pos := 1202 Make_Attribute_Reference 1203 (Loc, 1204 Prefix => Index_Base_Name, 1205 Attribute_Name => Name_Pos, 1206 Expressions => New_List (Duplicate_Subexpr (To))); 1207 1208 Expr_Pos := 1209 Make_Op_Add (Loc, 1210 Left_Opnd => To_Pos, 1211 Right_Opnd => Make_Integer_Literal (Loc, U_Val)); 1212 1213 Expr := 1214 Make_Attribute_Reference 1215 (Loc, 1216 Prefix => Index_Base_Name, 1217 Attribute_Name => Name_Val, 1218 Expressions => New_List (Expr_Pos)); 1219 end if; 1220 1221 return Expr; 1222 end Add; 1223 1224 ----------------- 1225 -- Empty_Range -- 1226 ----------------- 1227 1228 function Empty_Range (L, H : Node_Id) return Boolean is 1229 Is_Empty : Boolean := False; 1230 Low : Node_Id; 1231 High : Node_Id; 1232 1233 begin 1234 -- First check if L or H were already detected as overflowing the 1235 -- index base range type by function Add above. If this is so Add 1236 -- returns the empty node. 1237 1238 if No (L) or else No (H) then 1239 return True; 1240 end if; 1241 1242 for J in 1 .. 3 loop 1243 case J is 1244 1245 -- L > H range is empty 1246 1247 when 1 => 1248 Low := L; 1249 High := H; 1250 1251 -- B_L > H range must be empty 1252 1253 when 2 => 1254 Low := Index_Base_L; 1255 High := H; 1256 1257 -- L > B_H range must be empty 1258 1259 when 3 => 1260 Low := L; 1261 High := Index_Base_H; 1262 end case; 1263 1264 if Local_Compile_Time_Known_Value (Low) 1265 and then 1266 Local_Compile_Time_Known_Value (High) 1267 then 1268 Is_Empty := 1269 UI_Gt (Local_Expr_Value (Low), Local_Expr_Value (High)); 1270 end if; 1271 1272 exit when Is_Empty; 1273 end loop; 1274 1275 return Is_Empty; 1276 end Empty_Range; 1277 1278 ----------- 1279 -- Equal -- 1280 ----------- 1281 1282 function Equal (L, H : Node_Id) return Boolean is 1283 begin 1284 if L = H then 1285 return True; 1286 1287 elsif Local_Compile_Time_Known_Value (L) 1288 and then 1289 Local_Compile_Time_Known_Value (H) 1290 then 1291 return UI_Eq (Local_Expr_Value (L), Local_Expr_Value (H)); 1292 end if; 1293 1294 return False; 1295 end Equal; 1296 1297 ---------------- 1298 -- Gen_Assign -- 1299 ---------------- 1300 1301 function Gen_Assign 1302 (Ind : Node_Id; 1303 Expr : Node_Id; 1304 In_Loop : Boolean := False) return List_Id 1305 is 1306 function Add_Loop_Actions (Lis : List_Id) return List_Id; 1307 -- Collect insert_actions generated in the construction of a loop, 1308 -- and prepend them to the sequence of assignments to complete the 1309 -- eventual body of the loop. 1310 1311 procedure Initialize_Array_Component 1312 (Arr_Comp : Node_Id; 1313 Comp_Typ : Node_Id; 1314 Init_Expr : Node_Id; 1315 Stmts : List_Id); 1316 -- Perform the initialization of array component Arr_Comp with 1317 -- expected type Comp_Typ. Init_Expr denotes the initialization 1318 -- expression of the array component. All generated code is added 1319 -- to list Stmts. 1320 1321 procedure Initialize_Ctrl_Array_Component 1322 (Arr_Comp : Node_Id; 1323 Comp_Typ : Entity_Id; 1324 Init_Expr : Node_Id; 1325 Stmts : List_Id); 1326 -- Perform the initialization of array component Arr_Comp when its 1327 -- expected type Comp_Typ needs finalization actions. Init_Expr is 1328 -- the initialization expression of the array component. All hook- 1329 -- related declarations are inserted prior to aggregate N. Remaining 1330 -- code is added to list Stmts. 1331 1332 ---------------------- 1333 -- Add_Loop_Actions -- 1334 ---------------------- 1335 1336 function Add_Loop_Actions (Lis : List_Id) return List_Id is 1337 Res : List_Id; 1338 1339 begin 1340 -- Ada 2005 (AI-287): Do nothing else in case of default 1341 -- initialized component. 1342 1343 if No (Expr) then 1344 return Lis; 1345 1346 elsif Nkind (Parent (Expr)) = N_Component_Association 1347 and then Present (Loop_Actions (Parent (Expr))) 1348 then 1349 Append_List (Lis, Loop_Actions (Parent (Expr))); 1350 Res := Loop_Actions (Parent (Expr)); 1351 Set_Loop_Actions (Parent (Expr), No_List); 1352 return Res; 1353 1354 else 1355 return Lis; 1356 end if; 1357 end Add_Loop_Actions; 1358 1359 -------------------------------- 1360 -- Initialize_Array_Component -- 1361 -------------------------------- 1362 1363 procedure Initialize_Array_Component 1364 (Arr_Comp : Node_Id; 1365 Comp_Typ : Node_Id; 1366 Init_Expr : Node_Id; 1367 Stmts : List_Id) 1368 is 1369 Exceptions_OK : constant Boolean := 1370 not Restriction_Active 1371 (No_Exception_Propagation); 1372 1373 Finalization_OK : constant Boolean := 1374 Present (Comp_Typ) 1375 and then Needs_Finalization (Comp_Typ); 1376 1377 Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ); 1378 Adj_Call : Node_Id; 1379 Blk_Stmts : List_Id; 1380 Init_Stmt : Node_Id; 1381 1382 begin 1383 -- Protect the initialization statements from aborts. Generate: 1384 1385 -- Abort_Defer; 1386 1387 if Finalization_OK and Abort_Allowed then 1388 if Exceptions_OK then 1389 Blk_Stmts := New_List; 1390 else 1391 Blk_Stmts := Stmts; 1392 end if; 1393 1394 Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); 1395 1396 -- Otherwise aborts are not allowed. All generated code is added 1397 -- directly to the input list. 1398 1399 else 1400 Blk_Stmts := Stmts; 1401 end if; 1402 1403 -- Initialize the array element. Generate: 1404 1405 -- Arr_Comp := Init_Expr; 1406 1407 -- Note that the initialization expression is replicated because 1408 -- it has to be reevaluated within a generated loop. 1409 1410 Init_Stmt := 1411 Make_OK_Assignment_Statement (Loc, 1412 Name => New_Copy_Tree (Arr_Comp), 1413 Expression => New_Copy_Tree (Init_Expr)); 1414 Set_No_Ctrl_Actions (Init_Stmt); 1415 1416 -- If this is an aggregate for an array of arrays, each 1417 -- subaggregate will be expanded as well, and even with 1418 -- No_Ctrl_Actions the assignments of inner components will 1419 -- require attachment in their assignments to temporaries. These 1420 -- temporaries must be finalized for each subaggregate. Generate: 1421 1422 -- begin 1423 -- Arr_Comp := Init_Expr; 1424 -- end; 1425 1426 if Finalization_OK and then Is_Array_Type (Comp_Typ) then 1427 Init_Stmt := 1428 Make_Block_Statement (Loc, 1429 Handled_Statement_Sequence => 1430 Make_Handled_Sequence_Of_Statements (Loc, 1431 Statements => New_List (Init_Stmt))); 1432 end if; 1433 1434 Append_To (Blk_Stmts, Init_Stmt); 1435 1436 -- Adjust the tag due to a possible view conversion. Generate: 1437 1438 -- Arr_Comp._tag := Full_TypP; 1439 1440 if Tagged_Type_Expansion 1441 and then Present (Comp_Typ) 1442 and then Is_Tagged_Type (Comp_Typ) 1443 then 1444 Append_To (Blk_Stmts, 1445 Make_OK_Assignment_Statement (Loc, 1446 Name => 1447 Make_Selected_Component (Loc, 1448 Prefix => New_Copy_Tree (Arr_Comp), 1449 Selector_Name => 1450 New_Occurrence_Of 1451 (First_Tag_Component (Full_Typ), Loc)), 1452 1453 Expression => 1454 Unchecked_Convert_To (RTE (RE_Tag), 1455 New_Occurrence_Of 1456 (Node (First_Elmt (Access_Disp_Table (Full_Typ))), 1457 Loc)))); 1458 end if; 1459 1460 -- Adjust the array component. Controlled subaggregates are not 1461 -- considered because each of their individual elements will 1462 -- receive an adjustment of its own. Generate: 1463 1464 -- [Deep_]Adjust (Arr_Comp); 1465 1466 if Finalization_OK 1467 and then not Is_Limited_Type (Comp_Typ) 1468 and then not Is_Build_In_Place_Function_Call (Init_Expr) 1469 and then not 1470 (Is_Array_Type (Comp_Typ) 1471 and then Is_Controlled (Component_Type (Comp_Typ)) 1472 and then Nkind (Expr) = N_Aggregate) 1473 then 1474 Adj_Call := 1475 Make_Adjust_Call 1476 (Obj_Ref => New_Copy_Tree (Arr_Comp), 1477 Typ => Comp_Typ); 1478 1479 -- Guard against a missing [Deep_]Adjust when the component 1480 -- type was not frozen properly. 1481 1482 if Present (Adj_Call) then 1483 Append_To (Blk_Stmts, Adj_Call); 1484 end if; 1485 end if; 1486 1487 -- Complete the protection of the initialization statements 1488 1489 if Finalization_OK and Abort_Allowed then 1490 1491 -- Wrap the initialization statements in a block to catch a 1492 -- potential exception. Generate: 1493 1494 -- begin 1495 -- Abort_Defer; 1496 -- Arr_Comp := Init_Expr; 1497 -- Arr_Comp._tag := Full_TypP; 1498 -- [Deep_]Adjust (Arr_Comp); 1499 -- at end 1500 -- Abort_Undefer_Direct; 1501 -- end; 1502 1503 if Exceptions_OK then 1504 Append_To (Stmts, 1505 Build_Abort_Undefer_Block (Loc, 1506 Stmts => Blk_Stmts, 1507 Context => N)); 1508 1509 -- Otherwise exceptions are not propagated. Generate: 1510 1511 -- Abort_Defer; 1512 -- Arr_Comp := Init_Expr; 1513 -- Arr_Comp._tag := Full_TypP; 1514 -- [Deep_]Adjust (Arr_Comp); 1515 -- Abort_Undefer; 1516 1517 else 1518 Append_To (Blk_Stmts, 1519 Build_Runtime_Call (Loc, RE_Abort_Undefer)); 1520 end if; 1521 end if; 1522 end Initialize_Array_Component; 1523 1524 ------------------------------------- 1525 -- Initialize_Ctrl_Array_Component -- 1526 ------------------------------------- 1527 1528 procedure Initialize_Ctrl_Array_Component 1529 (Arr_Comp : Node_Id; 1530 Comp_Typ : Entity_Id; 1531 Init_Expr : Node_Id; 1532 Stmts : List_Id) 1533 is 1534 Act_Aggr : Node_Id; 1535 Act_Stmts : List_Id; 1536 Expr : Node_Id; 1537 Fin_Call : Node_Id; 1538 Hook_Clear : Node_Id; 1539 1540 In_Place_Expansion : Boolean; 1541 -- Flag set when a nonlimited controlled function call requires 1542 -- in-place expansion. 1543 1544 begin 1545 -- Duplicate the initialization expression in case the context is 1546 -- a multi choice list or an "others" choice which plugs various 1547 -- holes in the aggregate. As a result the expression is no longer 1548 -- shared between the various components and is reevaluated for 1549 -- each such component. 1550 1551 Expr := New_Copy_Tree (Init_Expr); 1552 Set_Parent (Expr, Parent (Init_Expr)); 1553 1554 -- Perform a preliminary analysis and resolution to determine what 1555 -- the initialization expression denotes. An unanalyzed function 1556 -- call may appear as an identifier or an indexed component. 1557 1558 if Nkind (Expr) in N_Function_Call 1559 | N_Identifier 1560 | N_Indexed_Component 1561 and then not Analyzed (Expr) 1562 then 1563 Preanalyze_And_Resolve (Expr, Comp_Typ); 1564 end if; 1565 1566 In_Place_Expansion := 1567 Nkind (Expr) = N_Function_Call 1568 and then not Is_Build_In_Place_Result_Type (Comp_Typ); 1569 1570 -- The initialization expression is a controlled function call. 1571 -- Perform in-place removal of side effects to avoid creating a 1572 -- transient scope, which leads to premature finalization. 1573 1574 -- This in-place expansion is not performed for limited transient 1575 -- objects, because the initialization is already done in place. 1576 1577 if In_Place_Expansion then 1578 1579 -- Suppress the removal of side effects by general analysis, 1580 -- because this behavior is emulated here. This avoids the 1581 -- generation of a transient scope, which leads to out-of-order 1582 -- adjustment and finalization. 1583 1584 Set_No_Side_Effect_Removal (Expr); 1585 1586 -- When the transient component initialization is related to a 1587 -- range or an "others", keep all generated statements within 1588 -- the enclosing loop. This way the controlled function call 1589 -- will be evaluated at each iteration, and its result will be 1590 -- finalized at the end of each iteration. 1591 1592 if In_Loop then 1593 Act_Aggr := Empty; 1594 Act_Stmts := Stmts; 1595 1596 -- Otherwise this is a single component initialization. Hook- 1597 -- related statements are inserted prior to the aggregate. 1598 1599 else 1600 Act_Aggr := N; 1601 Act_Stmts := No_List; 1602 end if; 1603 1604 -- Install all hook-related declarations and prepare the clean 1605 -- up statements. 1606 1607 Process_Transient_Component 1608 (Loc => Loc, 1609 Comp_Typ => Comp_Typ, 1610 Init_Expr => Expr, 1611 Fin_Call => Fin_Call, 1612 Hook_Clear => Hook_Clear, 1613 Aggr => Act_Aggr, 1614 Stmts => Act_Stmts); 1615 end if; 1616 1617 -- Use the noncontrolled component initialization circuitry to 1618 -- assign the result of the function call to the array element. 1619 -- This also performs subaggregate wrapping, tag adjustment, and 1620 -- [deep] adjustment of the array element. 1621 1622 Initialize_Array_Component 1623 (Arr_Comp => Arr_Comp, 1624 Comp_Typ => Comp_Typ, 1625 Init_Expr => Expr, 1626 Stmts => Stmts); 1627 1628 -- At this point the array element is fully initialized. Complete 1629 -- the processing of the controlled array component by finalizing 1630 -- the transient function result. 1631 1632 if In_Place_Expansion then 1633 Process_Transient_Component_Completion 1634 (Loc => Loc, 1635 Aggr => N, 1636 Fin_Call => Fin_Call, 1637 Hook_Clear => Hook_Clear, 1638 Stmts => Stmts); 1639 end if; 1640 end Initialize_Ctrl_Array_Component; 1641 1642 -- Local variables 1643 1644 Stmts : constant List_Id := New_List; 1645 1646 Comp_Typ : Entity_Id := Empty; 1647 Expr_Q : Node_Id; 1648 Indexed_Comp : Node_Id; 1649 Init_Call : Node_Id; 1650 New_Indexes : List_Id; 1651 1652 -- Start of processing for Gen_Assign 1653 1654 begin 1655 if No (Indexes) then 1656 New_Indexes := New_List; 1657 else 1658 New_Indexes := New_Copy_List_Tree (Indexes); 1659 end if; 1660 1661 Append_To (New_Indexes, Ind); 1662 1663 if Present (Next_Index (Index)) then 1664 return 1665 Add_Loop_Actions ( 1666 Build_Array_Aggr_Code 1667 (N => Expr, 1668 Ctype => Ctype, 1669 Index => Next_Index (Index), 1670 Into => Into, 1671 Scalar_Comp => Scalar_Comp, 1672 Indexes => New_Indexes)); 1673 end if; 1674 1675 -- If we get here then we are at a bottom-level (sub-)aggregate 1676 1677 Indexed_Comp := 1678 Checks_Off 1679 (Make_Indexed_Component (Loc, 1680 Prefix => New_Copy_Tree (Into), 1681 Expressions => New_Indexes)); 1682 1683 Set_Assignment_OK (Indexed_Comp); 1684 1685 -- Ada 2005 (AI-287): In case of default initialized component, Expr 1686 -- is not present (and therefore we also initialize Expr_Q to empty). 1687 1688 if No (Expr) then 1689 Expr_Q := Empty; 1690 elsif Nkind (Expr) = N_Qualified_Expression then 1691 Expr_Q := Expression (Expr); 1692 else 1693 Expr_Q := Expr; 1694 end if; 1695 1696 if Present (Etype (N)) and then Etype (N) /= Any_Composite then 1697 Comp_Typ := Component_Type (Etype (N)); 1698 pragma Assert (Comp_Typ = Ctype); -- AI-287 1699 1700 elsif Present (Next (First (New_Indexes))) then 1701 1702 -- Ada 2005 (AI-287): Do nothing in case of default initialized 1703 -- component because we have received the component type in 1704 -- the formal parameter Ctype. 1705 1706 -- ??? Some assert pragmas have been added to check if this new 1707 -- formal can be used to replace this code in all cases. 1708 1709 if Present (Expr) then 1710 1711 -- This is a multidimensional array. Recover the component type 1712 -- from the outermost aggregate, because subaggregates do not 1713 -- have an assigned type. 1714 1715 declare 1716 P : Node_Id; 1717 1718 begin 1719 P := Parent (Expr); 1720 while Present (P) loop 1721 if Nkind (P) = N_Aggregate 1722 and then Present (Etype (P)) 1723 then 1724 Comp_Typ := Component_Type (Etype (P)); 1725 exit; 1726 1727 else 1728 P := Parent (P); 1729 end if; 1730 end loop; 1731 1732 pragma Assert (Comp_Typ = Ctype); -- AI-287 1733 end; 1734 end if; 1735 end if; 1736 1737 -- Ada 2005 (AI-287): We only analyze the expression in case of non- 1738 -- default initialized components (otherwise Expr_Q is not present). 1739 1740 if Present (Expr_Q) 1741 and then Nkind (Expr_Q) in N_Aggregate | N_Extension_Aggregate 1742 then 1743 -- At this stage the Expression may not have been analyzed yet 1744 -- because the array aggregate code has not been updated to use 1745 -- the Expansion_Delayed flag and avoid analysis altogether to 1746 -- solve the same problem (see Resolve_Aggr_Expr). So let us do 1747 -- the analysis of non-array aggregates now in order to get the 1748 -- value of Expansion_Delayed flag for the inner aggregate ??? 1749 1750 -- In the case of an iterated component association, the analysis 1751 -- of the generated loop will analyze the expression in the 1752 -- proper context, in which the loop parameter is visible. 1753 1754 if Present (Comp_Typ) and then not Is_Array_Type (Comp_Typ) then 1755 if Nkind (Parent (Expr_Q)) = N_Iterated_Component_Association 1756 or else Nkind (Parent (Parent ((Expr_Q)))) = 1757 N_Iterated_Component_Association 1758 then 1759 null; 1760 else 1761 Analyze_And_Resolve (Expr_Q, Comp_Typ); 1762 end if; 1763 end if; 1764 1765 if Is_Delayed_Aggregate (Expr_Q) then 1766 1767 -- This is either a subaggregate of a multidimensional array, 1768 -- or a component of an array type whose component type is 1769 -- also an array. In the latter case, the expression may have 1770 -- component associations that provide different bounds from 1771 -- those of the component type, and sliding must occur. Instead 1772 -- of decomposing the current aggregate assignment, force the 1773 -- reanalysis of the assignment, so that a temporary will be 1774 -- generated in the usual fashion, and sliding will take place. 1775 1776 if Nkind (Parent (N)) = N_Assignment_Statement 1777 and then Is_Array_Type (Comp_Typ) 1778 and then Present (Component_Associations (Expr_Q)) 1779 and then Must_Slide (N, Comp_Typ, Etype (Expr_Q)) 1780 then 1781 Set_Expansion_Delayed (Expr_Q, False); 1782 Set_Analyzed (Expr_Q, False); 1783 1784 else 1785 return 1786 Add_Loop_Actions ( 1787 Late_Expansion (Expr_Q, Etype (Expr_Q), Indexed_Comp)); 1788 end if; 1789 end if; 1790 end if; 1791 1792 if Present (Expr) then 1793 1794 -- Handle an initialization expression of a controlled type in 1795 -- case it denotes a function call. In general such a scenario 1796 -- will produce a transient scope, but this will lead to wrong 1797 -- order of initialization, adjustment, and finalization in the 1798 -- context of aggregates. 1799 1800 -- Target (1) := Ctrl_Func_Call; 1801 1802 -- begin -- scope 1803 -- Trans_Obj : ... := Ctrl_Func_Call; -- object 1804 -- Target (1) := Trans_Obj; 1805 -- Finalize (Trans_Obj); 1806 -- end; 1807 -- Target (1)._tag := ...; 1808 -- Adjust (Target (1)); 1809 1810 -- In the example above, the call to Finalize occurs too early 1811 -- and as a result it may leave the array component in a bad 1812 -- state. Finalization of the transient object should really 1813 -- happen after adjustment. 1814 1815 -- To avoid this scenario, perform in-place side-effect removal 1816 -- of the function call. This eliminates the transient property 1817 -- of the function result and ensures correct order of actions. 1818 1819 -- Res : ... := Ctrl_Func_Call; 1820 -- Target (1) := Res; 1821 -- Target (1)._tag := ...; 1822 -- Adjust (Target (1)); 1823 -- Finalize (Res); 1824 1825 if Present (Comp_Typ) 1826 and then Needs_Finalization (Comp_Typ) 1827 and then Nkind (Expr) /= N_Aggregate 1828 then 1829 Initialize_Ctrl_Array_Component 1830 (Arr_Comp => Indexed_Comp, 1831 Comp_Typ => Comp_Typ, 1832 Init_Expr => Expr, 1833 Stmts => Stmts); 1834 1835 -- Otherwise perform simple component initialization 1836 1837 else 1838 Initialize_Array_Component 1839 (Arr_Comp => Indexed_Comp, 1840 Comp_Typ => Comp_Typ, 1841 Init_Expr => Expr, 1842 Stmts => Stmts); 1843 end if; 1844 1845 -- Ada 2005 (AI-287): In case of default initialized component, call 1846 -- the initialization subprogram associated with the component type. 1847 -- If the component type is an access type, add an explicit null 1848 -- assignment, because for the back-end there is an initialization 1849 -- present for the whole aggregate, and no default initialization 1850 -- will take place. 1851 1852 -- In addition, if the component type is controlled, we must call 1853 -- its Initialize procedure explicitly, because there is no explicit 1854 -- object creation that will invoke it otherwise. 1855 1856 else 1857 if Present (Base_Init_Proc (Base_Type (Ctype))) 1858 or else Has_Task (Base_Type (Ctype)) 1859 then 1860 Append_List_To (Stmts, 1861 Build_Initialization_Call (Loc, 1862 Id_Ref => Indexed_Comp, 1863 Typ => Ctype, 1864 With_Default_Init => True)); 1865 1866 -- If the component type has invariants, add an invariant 1867 -- check after the component is default-initialized. It will 1868 -- be analyzed and resolved before the code for initialization 1869 -- of other components. 1870 1871 if Has_Invariants (Ctype) then 1872 Set_Etype (Indexed_Comp, Ctype); 1873 Append_To (Stmts, Make_Invariant_Call (Indexed_Comp)); 1874 end if; 1875 1876 elsif Is_Access_Type (Ctype) then 1877 Append_To (Stmts, 1878 Make_Assignment_Statement (Loc, 1879 Name => New_Copy_Tree (Indexed_Comp), 1880 Expression => Make_Null (Loc))); 1881 end if; 1882 1883 if Needs_Finalization (Ctype) then 1884 Init_Call := 1885 Make_Init_Call 1886 (Obj_Ref => New_Copy_Tree (Indexed_Comp), 1887 Typ => Ctype); 1888 1889 -- Guard against a missing [Deep_]Initialize when the component 1890 -- type was not properly frozen. 1891 1892 if Present (Init_Call) then 1893 Append_To (Stmts, Init_Call); 1894 end if; 1895 end if; 1896 1897 -- If Default_Initial_Condition applies to the component type, 1898 -- add a DIC check after the component is default-initialized, 1899 -- as well as after an Initialize procedure is called, in the 1900 -- case of components of a controlled type. It will be analyzed 1901 -- and resolved before the code for initialization of other 1902 -- components. 1903 1904 -- Theoretically this might also be needed for cases where Expr 1905 -- is not empty, but a default init still applies, such as for 1906 -- Default_Value cases, in which case we won't get here. ??? 1907 1908 if Has_DIC (Ctype) and then Present (DIC_Procedure (Ctype)) then 1909 Append_To (Stmts, 1910 Build_DIC_Call (Loc, New_Copy_Tree (Indexed_Comp), Ctype)); 1911 end if; 1912 end if; 1913 1914 return Add_Loop_Actions (Stmts); 1915 end Gen_Assign; 1916 1917 -------------- 1918 -- Gen_Loop -- 1919 -------------- 1920 1921 function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is 1922 Is_Iterated_Component : constant Boolean := 1923 Parent_Kind (Expr) = N_Iterated_Component_Association; 1924 1925 L_J : Node_Id; 1926 1927 L_L : Node_Id; 1928 -- Index_Base'(L) 1929 1930 L_H : Node_Id; 1931 -- Index_Base'(H) 1932 1933 L_Range : Node_Id; 1934 -- Index_Base'(L) .. Index_Base'(H) 1935 1936 L_Iteration_Scheme : Node_Id; 1937 -- L_J in Index_Base'(L) .. Index_Base'(H) 1938 1939 L_Body : List_Id; 1940 -- The statements to execute in the loop 1941 1942 S : constant List_Id := New_List; 1943 -- List of statements 1944 1945 Tcopy : Node_Id; 1946 -- Copy of expression tree, used for checking purposes 1947 1948 begin 1949 -- If loop bounds define an empty range return the null statement 1950 1951 if Empty_Range (L, H) then 1952 Append_To (S, Make_Null_Statement (Loc)); 1953 1954 -- Ada 2005 (AI-287): Nothing else need to be done in case of 1955 -- default initialized component. 1956 1957 if No (Expr) then 1958 null; 1959 1960 else 1961 -- The expression must be type-checked even though no component 1962 -- of the aggregate will have this value. This is done only for 1963 -- actual components of the array, not for subaggregates. Do 1964 -- the check on a copy, because the expression may be shared 1965 -- among several choices, some of which might be non-null. 1966 1967 if Present (Etype (N)) 1968 and then Is_Array_Type (Etype (N)) 1969 and then No (Next_Index (Index)) 1970 then 1971 Expander_Mode_Save_And_Set (False); 1972 Tcopy := New_Copy_Tree (Expr); 1973 Set_Parent (Tcopy, N); 1974 1975 -- For iterated_component_association analyze and resolve 1976 -- the expression with name of the index parameter visible. 1977 -- To manipulate scopes, we use entity of the implicit loop. 1978 1979 if Is_Iterated_Component then 1980 declare 1981 Index_Parameter : constant Entity_Id := 1982 Defining_Identifier (Parent (Expr)); 1983 begin 1984 Push_Scope (Scope (Index_Parameter)); 1985 Enter_Name (Index_Parameter); 1986 Analyze_And_Resolve 1987 (Tcopy, Component_Type (Etype (N))); 1988 End_Scope; 1989 end; 1990 1991 -- For ordinary component association, just analyze and 1992 -- resolve the expression. 1993 1994 else 1995 Analyze_And_Resolve (Tcopy, Component_Type (Etype (N))); 1996 end if; 1997 1998 Expander_Mode_Restore; 1999 end if; 2000 end if; 2001 2002 return S; 2003 2004 -- If loop bounds are the same then generate an assignment, unless 2005 -- the parent construct is an Iterated_Component_Association. 2006 2007 elsif Equal (L, H) and then not Is_Iterated_Component then 2008 return Gen_Assign (New_Copy_Tree (L), Expr); 2009 2010 -- If H - L <= 2 then generate a sequence of assignments when we are 2011 -- processing the bottom most aggregate and it contains scalar 2012 -- components. 2013 2014 elsif No (Next_Index (Index)) 2015 and then Scalar_Comp 2016 and then Local_Compile_Time_Known_Value (L) 2017 and then Local_Compile_Time_Known_Value (H) 2018 and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2 2019 and then not Is_Iterated_Component 2020 then 2021 Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr)); 2022 Append_List_To (S, Gen_Assign (Add (1, To => L), Expr)); 2023 2024 if Local_Expr_Value (H) - Local_Expr_Value (L) = 2 then 2025 Append_List_To (S, Gen_Assign (Add (2, To => L), Expr)); 2026 end if; 2027 2028 return S; 2029 end if; 2030 2031 -- Otherwise construct the loop, starting with the loop index L_J 2032 2033 if Is_Iterated_Component then 2034 L_J := 2035 Make_Defining_Identifier (Loc, 2036 Chars => (Chars (Defining_Identifier (Parent (Expr))))); 2037 2038 else 2039 L_J := Make_Temporary (Loc, 'J', L); 2040 end if; 2041 2042 -- Construct "L .. H" in Index_Base. We use a qualified expression 2043 -- for the bound to convert to the index base, but we don't need 2044 -- to do that if we already have the base type at hand. 2045 2046 if Etype (L) = Index_Base then 2047 L_L := L; 2048 else 2049 L_L := 2050 Make_Qualified_Expression (Loc, 2051 Subtype_Mark => Index_Base_Name, 2052 Expression => New_Copy_Tree (L)); 2053 end if; 2054 2055 if Etype (H) = Index_Base then 2056 L_H := H; 2057 else 2058 L_H := 2059 Make_Qualified_Expression (Loc, 2060 Subtype_Mark => Index_Base_Name, 2061 Expression => New_Copy_Tree (H)); 2062 end if; 2063 2064 L_Range := 2065 Make_Range (Loc, 2066 Low_Bound => L_L, 2067 High_Bound => L_H); 2068 2069 -- Construct "for L_J in Index_Base range L .. H" 2070 2071 L_Iteration_Scheme := 2072 Make_Iteration_Scheme 2073 (Loc, 2074 Loop_Parameter_Specification => 2075 Make_Loop_Parameter_Specification 2076 (Loc, 2077 Defining_Identifier => L_J, 2078 Discrete_Subtype_Definition => L_Range)); 2079 2080 -- Construct the statements to execute in the loop body 2081 2082 L_Body := 2083 Gen_Assign (New_Occurrence_Of (L_J, Loc), Expr, In_Loop => True); 2084 2085 -- Construct the final loop 2086 2087 Append_To (S, 2088 Make_Implicit_Loop_Statement 2089 (Node => N, 2090 Identifier => Empty, 2091 Iteration_Scheme => L_Iteration_Scheme, 2092 Statements => L_Body)); 2093 2094 -- A small optimization: if the aggregate is initialized with a box 2095 -- and the component type has no initialization procedure, remove the 2096 -- useless empty loop. 2097 2098 if Nkind (First (S)) = N_Loop_Statement 2099 and then Is_Empty_List (Statements (First (S))) 2100 then 2101 return New_List (Make_Null_Statement (Loc)); 2102 else 2103 return S; 2104 end if; 2105 end Gen_Loop; 2106 2107 --------------- 2108 -- Gen_While -- 2109 --------------- 2110 2111 -- The code built is 2112 2113 -- W_J : Index_Base := L; 2114 -- while W_J < H loop 2115 -- W_J := Index_Base'Succ (W); 2116 -- L_Body; 2117 -- end loop; 2118 2119 function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id is 2120 W_J : Node_Id; 2121 2122 W_Decl : Node_Id; 2123 -- W_J : Base_Type := L; 2124 2125 W_Iteration_Scheme : Node_Id; 2126 -- while W_J < H 2127 2128 W_Index_Succ : Node_Id; 2129 -- Index_Base'Succ (J) 2130 2131 W_Increment : Node_Id; 2132 -- W_J := Index_Base'Succ (W) 2133 2134 W_Body : constant List_Id := New_List; 2135 -- The statements to execute in the loop 2136 2137 S : constant List_Id := New_List; 2138 -- list of statement 2139 2140 begin 2141 -- If loop bounds define an empty range or are equal return null 2142 2143 if Empty_Range (L, H) or else Equal (L, H) then 2144 Append_To (S, Make_Null_Statement (Loc)); 2145 return S; 2146 end if; 2147 2148 -- Build the decl of W_J 2149 2150 W_J := Make_Temporary (Loc, 'J', L); 2151 W_Decl := 2152 Make_Object_Declaration 2153 (Loc, 2154 Defining_Identifier => W_J, 2155 Object_Definition => Index_Base_Name, 2156 Expression => L); 2157 2158 -- Theoretically we should do a New_Copy_Tree (L) here, but we know 2159 -- that in this particular case L is a fresh Expr generated by 2160 -- Add which we are the only ones to use. 2161 2162 Append_To (S, W_Decl); 2163 2164 -- Construct " while W_J < H" 2165 2166 W_Iteration_Scheme := 2167 Make_Iteration_Scheme 2168 (Loc, 2169 Condition => Make_Op_Lt 2170 (Loc, 2171 Left_Opnd => New_Occurrence_Of (W_J, Loc), 2172 Right_Opnd => New_Copy_Tree (H))); 2173 2174 -- Construct the statements to execute in the loop body 2175 2176 W_Index_Succ := 2177 Make_Attribute_Reference 2178 (Loc, 2179 Prefix => Index_Base_Name, 2180 Attribute_Name => Name_Succ, 2181 Expressions => New_List (New_Occurrence_Of (W_J, Loc))); 2182 2183 W_Increment := 2184 Make_OK_Assignment_Statement 2185 (Loc, 2186 Name => New_Occurrence_Of (W_J, Loc), 2187 Expression => W_Index_Succ); 2188 2189 Append_To (W_Body, W_Increment); 2190 2191 Append_List_To (W_Body, 2192 Gen_Assign (New_Occurrence_Of (W_J, Loc), Expr, In_Loop => True)); 2193 2194 -- Construct the final loop 2195 2196 Append_To (S, 2197 Make_Implicit_Loop_Statement 2198 (Node => N, 2199 Identifier => Empty, 2200 Iteration_Scheme => W_Iteration_Scheme, 2201 Statements => W_Body)); 2202 2203 return S; 2204 end Gen_While; 2205 2206 -------------------- 2207 -- Get_Assoc_Expr -- 2208 -------------------- 2209 2210 function Get_Assoc_Expr (Assoc : Node_Id) return Node_Id is 2211 Typ : constant Entity_Id := Base_Type (Etype (N)); 2212 2213 begin 2214 if Box_Present (Assoc) then 2215 if Is_Scalar_Type (Ctype) then 2216 if Present (Default_Aspect_Component_Value (Typ)) then 2217 return Default_Aspect_Component_Value (Typ); 2218 elsif Present (Default_Aspect_Value (Ctype)) then 2219 return Default_Aspect_Value (Ctype); 2220 else 2221 return Empty; 2222 end if; 2223 2224 else 2225 return Empty; 2226 end if; 2227 2228 else 2229 return Expression (Assoc); 2230 end if; 2231 end Get_Assoc_Expr; 2232 2233 --------------------- 2234 -- Index_Base_Name -- 2235 --------------------- 2236 2237 function Index_Base_Name return Node_Id is 2238 begin 2239 return New_Occurrence_Of (Index_Base, Sloc (N)); 2240 end Index_Base_Name; 2241 2242 ------------------------------------ 2243 -- Local_Compile_Time_Known_Value -- 2244 ------------------------------------ 2245 2246 function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean is 2247 begin 2248 return Compile_Time_Known_Value (E) 2249 or else 2250 (Nkind (E) = N_Attribute_Reference 2251 and then Attribute_Name (E) = Name_Val 2252 and then Compile_Time_Known_Value (First (Expressions (E)))); 2253 end Local_Compile_Time_Known_Value; 2254 2255 ---------------------- 2256 -- Local_Expr_Value -- 2257 ---------------------- 2258 2259 function Local_Expr_Value (E : Node_Id) return Uint is 2260 begin 2261 if Compile_Time_Known_Value (E) then 2262 return Expr_Value (E); 2263 else 2264 return Expr_Value (First (Expressions (E))); 2265 end if; 2266 end Local_Expr_Value; 2267 2268 -- Local variables 2269 2270 New_Code : constant List_Id := New_List; 2271 2272 Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N)); 2273 Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N)); 2274 -- The aggregate bounds of this specific subaggregate. Note that if the 2275 -- code generated by Build_Array_Aggr_Code is executed then these bounds 2276 -- are OK. Otherwise a Constraint_Error would have been raised. 2277 2278 Aggr_Low : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_L); 2279 Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H); 2280 -- After Duplicate_Subexpr these are side-effect free 2281 2282 Assoc : Node_Id; 2283 Choice : Node_Id; 2284 Expr : Node_Id; 2285 Typ : Entity_Id; 2286 2287 Bounds : Range_Nodes; 2288 Low : Node_Id renames Bounds.First; 2289 High : Node_Id renames Bounds.Last; 2290 2291 Nb_Choices : Nat := 0; 2292 Table : Case_Table_Type (1 .. Number_Of_Choices (N)); 2293 -- Used to sort all the different choice values 2294 2295 Nb_Elements : Int; 2296 -- Number of elements in the positional aggregate 2297 2298 Others_Assoc : Node_Id := Empty; 2299 2300 -- Start of processing for Build_Array_Aggr_Code 2301 2302 begin 2303 -- First before we start, a special case. if we have a bit packed 2304 -- array represented as a modular type, then clear the value to 2305 -- zero first, to ensure that unused bits are properly cleared. 2306 2307 Typ := Etype (N); 2308 2309 if Present (Typ) 2310 and then Is_Bit_Packed_Array (Typ) 2311 and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)) 2312 then 2313 declare 2314 Zero : constant Node_Id := Make_Integer_Literal (Loc, Uint_0); 2315 begin 2316 Analyze_And_Resolve (Zero, Packed_Array_Impl_Type (Typ)); 2317 Append_To (New_Code, 2318 Make_Assignment_Statement (Loc, 2319 Name => New_Copy_Tree (Into), 2320 Expression => Unchecked_Convert_To (Typ, Zero))); 2321 end; 2322 end if; 2323 2324 -- If the component type contains tasks, we need to build a Master 2325 -- entity in the current scope, because it will be needed if build- 2326 -- in-place functions are called in the expanded code. 2327 2328 if Nkind (Parent (N)) = N_Object_Declaration and then Has_Task (Typ) then 2329 Build_Master_Entity (Defining_Identifier (Parent (N))); 2330 end if; 2331 2332 -- STEP 1: Process component associations 2333 2334 -- For those associations that may generate a loop, initialize 2335 -- Loop_Actions to collect inserted actions that may be crated. 2336 2337 -- Skip this if no component associations 2338 2339 if No (Expressions (N)) then 2340 2341 -- STEP 1 (a): Sort the discrete choices 2342 2343 Assoc := First (Component_Associations (N)); 2344 while Present (Assoc) loop 2345 Choice := First (Choice_List (Assoc)); 2346 while Present (Choice) loop 2347 if Nkind (Choice) = N_Others_Choice then 2348 Others_Assoc := Assoc; 2349 exit; 2350 end if; 2351 2352 Bounds := Get_Index_Bounds (Choice); 2353 2354 if Low /= High then 2355 Set_Loop_Actions (Assoc, New_List); 2356 end if; 2357 2358 Nb_Choices := Nb_Choices + 1; 2359 2360 Table (Nb_Choices) := 2361 (Choice_Lo => Low, 2362 Choice_Hi => High, 2363 Choice_Node => Get_Assoc_Expr (Assoc)); 2364 2365 Next (Choice); 2366 end loop; 2367 2368 Next (Assoc); 2369 end loop; 2370 2371 -- If there is more than one set of choices these must be static 2372 -- and we can therefore sort them. Remember that Nb_Choices does not 2373 -- account for an others choice. 2374 2375 if Nb_Choices > 1 then 2376 Sort_Case_Table (Table); 2377 end if; 2378 2379 -- STEP 1 (b): take care of the whole set of discrete choices 2380 2381 for J in 1 .. Nb_Choices loop 2382 Low := Table (J).Choice_Lo; 2383 High := Table (J).Choice_Hi; 2384 Expr := Table (J).Choice_Node; 2385 Append_List (Gen_Loop (Low, High, Expr), To => New_Code); 2386 end loop; 2387 2388 -- STEP 1 (c): generate the remaining loops to cover others choice 2389 -- We don't need to generate loops over empty gaps, but if there is 2390 -- a single empty range we must analyze the expression for semantics 2391 2392 if Present (Others_Assoc) then 2393 declare 2394 First : Boolean := True; 2395 Dup_Expr : Node_Id; 2396 2397 begin 2398 for J in 0 .. Nb_Choices loop 2399 if J = 0 then 2400 Low := Aggr_Low; 2401 else 2402 Low := Add (1, To => Table (J).Choice_Hi); 2403 end if; 2404 2405 if J = Nb_Choices then 2406 High := Aggr_High; 2407 else 2408 High := Add (-1, To => Table (J + 1).Choice_Lo); 2409 end if; 2410 2411 -- If this is an expansion within an init proc, make 2412 -- sure that discriminant references are replaced by 2413 -- the corresponding discriminal. 2414 2415 if Inside_Init_Proc then 2416 if Is_Entity_Name (Low) 2417 and then Ekind (Entity (Low)) = E_Discriminant 2418 then 2419 Set_Entity (Low, Discriminal (Entity (Low))); 2420 end if; 2421 2422 if Is_Entity_Name (High) 2423 and then Ekind (Entity (High)) = E_Discriminant 2424 then 2425 Set_Entity (High, Discriminal (Entity (High))); 2426 end if; 2427 end if; 2428 2429 if First 2430 or else not Empty_Range (Low, High) 2431 then 2432 First := False; 2433 2434 -- Duplicate the expression in case we will be generating 2435 -- several loops. As a result the expression is no longer 2436 -- shared between the loops and is reevaluated for each 2437 -- such loop. 2438 2439 Expr := Get_Assoc_Expr (Others_Assoc); 2440 Dup_Expr := New_Copy_Tree (Expr); 2441 Copy_Parent (To => Dup_Expr, From => Expr); 2442 2443 Set_Loop_Actions (Others_Assoc, New_List); 2444 Append_List 2445 (Gen_Loop (Low, High, Dup_Expr), To => New_Code); 2446 end if; 2447 end loop; 2448 end; 2449 end if; 2450 2451 -- STEP 2: Process positional components 2452 2453 else 2454 -- STEP 2 (a): Generate the assignments for each positional element 2455 -- Note that here we have to use Aggr_L rather than Aggr_Low because 2456 -- Aggr_L is analyzed and Add wants an analyzed expression. 2457 2458 Expr := First (Expressions (N)); 2459 Nb_Elements := -1; 2460 while Present (Expr) loop 2461 Nb_Elements := Nb_Elements + 1; 2462 Append_List (Gen_Assign (Add (Nb_Elements, To => Aggr_L), Expr), 2463 To => New_Code); 2464 Next (Expr); 2465 end loop; 2466 2467 -- STEP 2 (b): Generate final loop if an others choice is present. 2468 -- Here Nb_Elements gives the offset of the last positional element. 2469 2470 if Present (Component_Associations (N)) then 2471 Assoc := Last (Component_Associations (N)); 2472 2473 if Nkind (Assoc) = N_Iterated_Component_Association then 2474 -- Ada 2022: generate a loop to have a proper scope for 2475 -- the identifier that typically appears in the expression. 2476 -- The lower bound of the loop is the position after all 2477 -- previous positional components. 2478 2479 Append_List (Gen_Loop (Add (Nb_Elements + 1, To => Aggr_L), 2480 Aggr_High, 2481 Expression (Assoc)), 2482 To => New_Code); 2483 else 2484 -- Ada 2005 (AI-287) 2485 2486 Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L), 2487 Aggr_High, 2488 Get_Assoc_Expr (Assoc)), 2489 To => New_Code); 2490 end if; 2491 end if; 2492 end if; 2493 2494 return New_Code; 2495 end Build_Array_Aggr_Code; 2496 2497 ---------------------------- 2498 -- Build_Record_Aggr_Code -- 2499 ---------------------------- 2500 2501 function Build_Record_Aggr_Code 2502 (N : Node_Id; 2503 Typ : Entity_Id; 2504 Lhs : Node_Id) return List_Id 2505 is 2506 Loc : constant Source_Ptr := Sloc (N); 2507 L : constant List_Id := New_List; 2508 N_Typ : constant Entity_Id := Etype (N); 2509 2510 Comp : Node_Id; 2511 Instr : Node_Id; 2512 Ref : Node_Id; 2513 Target : Entity_Id; 2514 Comp_Type : Entity_Id; 2515 Selector : Entity_Id; 2516 Comp_Expr : Node_Id; 2517 Expr_Q : Node_Id; 2518 2519 -- If this is an internal aggregate, the External_Final_List is an 2520 -- expression for the controller record of the enclosing type. 2521 2522 -- If the current aggregate has several controlled components, this 2523 -- expression will appear in several calls to attach to the finali- 2524 -- zation list, and it must not be shared. 2525 2526 Ancestor_Is_Expression : Boolean := False; 2527 Ancestor_Is_Subtype_Mark : Boolean := False; 2528 2529 Init_Typ : Entity_Id := Empty; 2530 2531 Finalization_Done : Boolean := False; 2532 -- True if Generate_Finalization_Actions has already been called; calls 2533 -- after the first do nothing. 2534 2535 function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id; 2536 -- Returns the value that the given discriminant of an ancestor type 2537 -- should receive (in the absence of a conflict with the value provided 2538 -- by an ancestor part of an extension aggregate). 2539 2540 procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id); 2541 -- Check that each of the discriminant values defined by the ancestor 2542 -- part of an extension aggregate match the corresponding values 2543 -- provided by either an association of the aggregate or by the 2544 -- constraint imposed by a parent type (RM95-4.3.2(8)). 2545 2546 function Compatible_Int_Bounds 2547 (Agg_Bounds : Node_Id; 2548 Typ_Bounds : Node_Id) return Boolean; 2549 -- Return true if Agg_Bounds are equal or within Typ_Bounds. It is 2550 -- assumed that both bounds are integer ranges. 2551 2552 procedure Generate_Finalization_Actions; 2553 -- Deal with the various controlled type data structure initializations 2554 -- (but only if it hasn't been done already). 2555 2556 function Get_Constraint_Association (T : Entity_Id) return Node_Id; 2557 -- Returns the first discriminant association in the constraint 2558 -- associated with T, if any, otherwise returns Empty. 2559 2560 function Get_Explicit_Discriminant_Value (D : Entity_Id) return Node_Id; 2561 -- If the ancestor part is an unconstrained type and further ancestors 2562 -- do not provide discriminants for it, check aggregate components for 2563 -- values of the discriminants. 2564 2565 procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id); 2566 -- If Typ is derived, and constrains discriminants of the parent type, 2567 -- these discriminants are not components of the aggregate, and must be 2568 -- initialized. The assignments are appended to List. The same is done 2569 -- if Typ derives fron an already constrained subtype of a discriminated 2570 -- parent type. 2571 2572 procedure Init_Stored_Discriminants; 2573 -- If the type is derived and has inherited discriminants, generate 2574 -- explicit assignments for each, using the store constraint of the 2575 -- type. Note that both visible and stored discriminants must be 2576 -- initialized in case the derived type has some renamed and some 2577 -- constrained discriminants. 2578 2579 procedure Init_Visible_Discriminants; 2580 -- If type has discriminants, retrieve their values from aggregate, 2581 -- and generate explicit assignments for each. This does not include 2582 -- discriminants inherited from ancestor, which are handled above. 2583 -- The type of the aggregate is a subtype created ealier using the 2584 -- given values of the discriminant components of the aggregate. 2585 2586 procedure Initialize_Ctrl_Record_Component 2587 (Rec_Comp : Node_Id; 2588 Comp_Typ : Entity_Id; 2589 Init_Expr : Node_Id; 2590 Stmts : List_Id); 2591 -- Perform the initialization of controlled record component Rec_Comp. 2592 -- Comp_Typ is the component type. Init_Expr is the initialization 2593 -- expression for the record component. Hook-related declarations are 2594 -- inserted prior to aggregate N using Insert_Action. All remaining 2595 -- generated code is added to list Stmts. 2596 2597 procedure Initialize_Record_Component 2598 (Rec_Comp : Node_Id; 2599 Comp_Typ : Entity_Id; 2600 Init_Expr : Node_Id; 2601 Stmts : List_Id); 2602 -- Perform the initialization of record component Rec_Comp. Comp_Typ 2603 -- is the component type. Init_Expr is the initialization expression 2604 -- of the record component. All generated code is added to list Stmts. 2605 2606 function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean; 2607 -- Check whether Bounds is a range node and its lower and higher bounds 2608 -- are integers literals. 2609 2610 function Replace_Type (Expr : Node_Id) return Traverse_Result; 2611 -- If the aggregate contains a self-reference, traverse each expression 2612 -- to replace a possible self-reference with a reference to the proper 2613 -- component of the target of the assignment. 2614 2615 function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result; 2616 -- If default expression of a component mentions a discriminant of the 2617 -- type, it must be rewritten as the discriminant of the target object. 2618 2619 --------------------------------- 2620 -- Ancestor_Discriminant_Value -- 2621 --------------------------------- 2622 2623 function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id is 2624 Assoc : Node_Id; 2625 Assoc_Elmt : Elmt_Id; 2626 Aggr_Comp : Entity_Id; 2627 Corresp_Disc : Entity_Id; 2628 Current_Typ : Entity_Id := Base_Type (Typ); 2629 Parent_Typ : Entity_Id; 2630 Parent_Disc : Entity_Id; 2631 Save_Assoc : Node_Id := Empty; 2632 2633 begin 2634 -- First check any discriminant associations to see if any of them 2635 -- provide a value for the discriminant. 2636 2637 if Present (Discriminant_Specifications (Parent (Current_Typ))) then 2638 Assoc := First (Component_Associations (N)); 2639 while Present (Assoc) loop 2640 Aggr_Comp := Entity (First (Choices (Assoc))); 2641 2642 if Ekind (Aggr_Comp) = E_Discriminant then 2643 Save_Assoc := Expression (Assoc); 2644 2645 Corresp_Disc := Corresponding_Discriminant (Aggr_Comp); 2646 while Present (Corresp_Disc) loop 2647 2648 -- If found a corresponding discriminant then return the 2649 -- value given in the aggregate. (Note: this is not 2650 -- correct in the presence of side effects. ???) 2651 2652 if Disc = Corresp_Disc then 2653 return Duplicate_Subexpr (Expression (Assoc)); 2654 end if; 2655 2656 Corresp_Disc := Corresponding_Discriminant (Corresp_Disc); 2657 end loop; 2658 end if; 2659 2660 Next (Assoc); 2661 end loop; 2662 end if; 2663 2664 -- No match found in aggregate, so chain up parent types to find 2665 -- a constraint that defines the value of the discriminant. 2666 2667 Parent_Typ := Etype (Current_Typ); 2668 while Current_Typ /= Parent_Typ loop 2669 if Has_Discriminants (Parent_Typ) 2670 and then not Has_Unknown_Discriminants (Parent_Typ) 2671 then 2672 Parent_Disc := First_Discriminant (Parent_Typ); 2673 2674 -- We either get the association from the subtype indication 2675 -- of the type definition itself, or from the discriminant 2676 -- constraint associated with the type entity (which is 2677 -- preferable, but it's not always present ???) 2678 2679 if Is_Empty_Elmt_List (Discriminant_Constraint (Current_Typ)) 2680 then 2681 Assoc := Get_Constraint_Association (Current_Typ); 2682 Assoc_Elmt := No_Elmt; 2683 else 2684 Assoc_Elmt := 2685 First_Elmt (Discriminant_Constraint (Current_Typ)); 2686 Assoc := Node (Assoc_Elmt); 2687 end if; 2688 2689 -- Traverse the discriminants of the parent type looking 2690 -- for one that corresponds. 2691 2692 while Present (Parent_Disc) and then Present (Assoc) loop 2693 Corresp_Disc := Parent_Disc; 2694 while Present (Corresp_Disc) 2695 and then Disc /= Corresp_Disc 2696 loop 2697 Corresp_Disc := Corresponding_Discriminant (Corresp_Disc); 2698 end loop; 2699 2700 if Disc = Corresp_Disc then 2701 if Nkind (Assoc) = N_Discriminant_Association then 2702 Assoc := Expression (Assoc); 2703 end if; 2704 2705 -- If the located association directly denotes 2706 -- a discriminant, then use the value of a saved 2707 -- association of the aggregate. This is an approach 2708 -- used to handle certain cases involving multiple 2709 -- discriminants mapped to a single discriminant of 2710 -- a descendant. It's not clear how to locate the 2711 -- appropriate discriminant value for such cases. ??? 2712 2713 if Is_Entity_Name (Assoc) 2714 and then Ekind (Entity (Assoc)) = E_Discriminant 2715 then 2716 Assoc := Save_Assoc; 2717 end if; 2718 2719 return Duplicate_Subexpr (Assoc); 2720 end if; 2721 2722 Next_Discriminant (Parent_Disc); 2723 2724 if No (Assoc_Elmt) then 2725 Next (Assoc); 2726 2727 else 2728 Next_Elmt (Assoc_Elmt); 2729 2730 if Present (Assoc_Elmt) then 2731 Assoc := Node (Assoc_Elmt); 2732 else 2733 Assoc := Empty; 2734 end if; 2735 end if; 2736 end loop; 2737 end if; 2738 2739 Current_Typ := Parent_Typ; 2740 Parent_Typ := Etype (Current_Typ); 2741 end loop; 2742 2743 -- In some cases there's no ancestor value to locate (such as 2744 -- when an ancestor part given by an expression defines the 2745 -- discriminant value). 2746 2747 return Empty; 2748 end Ancestor_Discriminant_Value; 2749 2750 ---------------------------------- 2751 -- Check_Ancestor_Discriminants -- 2752 ---------------------------------- 2753 2754 procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id) is 2755 Discr : Entity_Id; 2756 Disc_Value : Node_Id; 2757 Cond : Node_Id; 2758 2759 begin 2760 Discr := First_Discriminant (Base_Type (Anc_Typ)); 2761 while Present (Discr) loop 2762 Disc_Value := Ancestor_Discriminant_Value (Discr); 2763 2764 if Present (Disc_Value) then 2765 Cond := Make_Op_Ne (Loc, 2766 Left_Opnd => 2767 Make_Selected_Component (Loc, 2768 Prefix => New_Copy_Tree (Target), 2769 Selector_Name => New_Occurrence_Of (Discr, Loc)), 2770 Right_Opnd => Disc_Value); 2771 2772 Append_To (L, 2773 Make_Raise_Constraint_Error (Loc, 2774 Condition => Cond, 2775 Reason => CE_Discriminant_Check_Failed)); 2776 end if; 2777 2778 Next_Discriminant (Discr); 2779 end loop; 2780 end Check_Ancestor_Discriminants; 2781 2782 --------------------------- 2783 -- Compatible_Int_Bounds -- 2784 --------------------------- 2785 2786 function Compatible_Int_Bounds 2787 (Agg_Bounds : Node_Id; 2788 Typ_Bounds : Node_Id) return Boolean 2789 is 2790 Agg_Lo : constant Uint := Intval (Low_Bound (Agg_Bounds)); 2791 Agg_Hi : constant Uint := Intval (High_Bound (Agg_Bounds)); 2792 Typ_Lo : constant Uint := Intval (Low_Bound (Typ_Bounds)); 2793 Typ_Hi : constant Uint := Intval (High_Bound (Typ_Bounds)); 2794 begin 2795 return Typ_Lo <= Agg_Lo and then Agg_Hi <= Typ_Hi; 2796 end Compatible_Int_Bounds; 2797 2798 ----------------------------------- 2799 -- Generate_Finalization_Actions -- 2800 ----------------------------------- 2801 2802 procedure Generate_Finalization_Actions is 2803 begin 2804 -- Do the work only the first time this is called 2805 2806 if Finalization_Done then 2807 return; 2808 end if; 2809 2810 Finalization_Done := True; 2811 2812 -- Determine the external finalization list. It is either the 2813 -- finalization list of the outer scope or the one coming from an 2814 -- outer aggregate. When the target is not a temporary, the proper 2815 -- scope is the scope of the target rather than the potentially 2816 -- transient current scope. 2817 2818 if Is_Controlled (Typ) and then Ancestor_Is_Subtype_Mark then 2819 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); 2820 Set_Assignment_OK (Ref); 2821 2822 Append_To (L, 2823 Make_Procedure_Call_Statement (Loc, 2824 Name => 2825 New_Occurrence_Of 2826 (Find_Prim_Op (Init_Typ, Name_Initialize), Loc), 2827 Parameter_Associations => New_List (New_Copy_Tree (Ref)))); 2828 end if; 2829 end Generate_Finalization_Actions; 2830 2831 -------------------------------- 2832 -- Get_Constraint_Association -- 2833 -------------------------------- 2834 2835 function Get_Constraint_Association (T : Entity_Id) return Node_Id is 2836 Indic : Node_Id; 2837 Typ : Entity_Id; 2838 2839 begin 2840 Typ := T; 2841 2842 -- If type is private, get constraint from full view. This was 2843 -- previously done in an instance context, but is needed whenever 2844 -- the ancestor part has a discriminant, possibly inherited through 2845 -- multiple derivations. 2846 2847 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 2848 Typ := Full_View (Typ); 2849 end if; 2850 2851 Indic := Subtype_Indication (Type_Definition (Parent (Typ))); 2852 2853 -- Verify that the subtype indication carries a constraint 2854 2855 if Nkind (Indic) = N_Subtype_Indication 2856 and then Present (Constraint (Indic)) 2857 then 2858 return First (Constraints (Constraint (Indic))); 2859 end if; 2860 2861 return Empty; 2862 end Get_Constraint_Association; 2863 2864 ------------------------------------- 2865 -- Get_Explicit_Discriminant_Value -- 2866 ------------------------------------- 2867 2868 function Get_Explicit_Discriminant_Value 2869 (D : Entity_Id) return Node_Id 2870 is 2871 Assoc : Node_Id; 2872 Choice : Node_Id; 2873 Val : Node_Id; 2874 2875 begin 2876 -- The aggregate has been normalized and all associations have a 2877 -- single choice. 2878 2879 Assoc := First (Component_Associations (N)); 2880 while Present (Assoc) loop 2881 Choice := First (Choices (Assoc)); 2882 2883 if Chars (Choice) = Chars (D) then 2884 Val := Expression (Assoc); 2885 Remove (Assoc); 2886 return Val; 2887 end if; 2888 2889 Next (Assoc); 2890 end loop; 2891 2892 return Empty; 2893 end Get_Explicit_Discriminant_Value; 2894 2895 ------------------------------- 2896 -- Init_Hidden_Discriminants -- 2897 ------------------------------- 2898 2899 procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id) is 2900 function Is_Completely_Hidden_Discriminant 2901 (Discr : Entity_Id) return Boolean; 2902 -- Determine whether Discr is a completely hidden discriminant of 2903 -- type Typ. 2904 2905 --------------------------------------- 2906 -- Is_Completely_Hidden_Discriminant -- 2907 --------------------------------------- 2908 2909 function Is_Completely_Hidden_Discriminant 2910 (Discr : Entity_Id) return Boolean 2911 is 2912 Item : Entity_Id; 2913 2914 begin 2915 -- Use First/Next_Entity as First/Next_Discriminant do not yield 2916 -- completely hidden discriminants. 2917 2918 Item := First_Entity (Typ); 2919 while Present (Item) loop 2920 if Ekind (Item) = E_Discriminant 2921 and then Is_Completely_Hidden (Item) 2922 and then Chars (Original_Record_Component (Item)) = 2923 Chars (Discr) 2924 then 2925 return True; 2926 end if; 2927 2928 Next_Entity (Item); 2929 end loop; 2930 2931 return False; 2932 end Is_Completely_Hidden_Discriminant; 2933 2934 -- Local variables 2935 2936 Base_Typ : Entity_Id; 2937 Discr : Entity_Id; 2938 Discr_Constr : Elmt_Id; 2939 Discr_Init : Node_Id; 2940 Discr_Val : Node_Id; 2941 In_Aggr_Type : Boolean; 2942 Par_Typ : Entity_Id; 2943 2944 -- Start of processing for Init_Hidden_Discriminants 2945 2946 begin 2947 -- The constraints on the hidden discriminants, if present, are kept 2948 -- in the Stored_Constraint list of the type itself, or in that of 2949 -- the base type. If not in the constraints of the aggregate itself, 2950 -- we examine ancestors to find discriminants that are not renamed 2951 -- by other discriminants but constrained explicitly. 2952 2953 In_Aggr_Type := True; 2954 2955 Base_Typ := Base_Type (Typ); 2956 while Is_Derived_Type (Base_Typ) 2957 and then 2958 (Present (Stored_Constraint (Base_Typ)) 2959 or else 2960 (In_Aggr_Type and then Present (Stored_Constraint (Typ)))) 2961 loop 2962 Par_Typ := Etype (Base_Typ); 2963 2964 if not Has_Discriminants (Par_Typ) then 2965 return; 2966 end if; 2967 2968 Discr := First_Discriminant (Par_Typ); 2969 2970 -- We know that one of the stored-constraint lists is present 2971 2972 if Present (Stored_Constraint (Base_Typ)) then 2973 Discr_Constr := First_Elmt (Stored_Constraint (Base_Typ)); 2974 2975 -- For private extension, stored constraint may be on full view 2976 2977 elsif Is_Private_Type (Base_Typ) 2978 and then Present (Full_View (Base_Typ)) 2979 and then Present (Stored_Constraint (Full_View (Base_Typ))) 2980 then 2981 Discr_Constr := 2982 First_Elmt (Stored_Constraint (Full_View (Base_Typ))); 2983 2984 -- Otherwise, no discriminant to process 2985 2986 else 2987 Discr_Constr := No_Elmt; 2988 end if; 2989 2990 while Present (Discr) and then Present (Discr_Constr) loop 2991 Discr_Val := Node (Discr_Constr); 2992 2993 -- The parent discriminant is renamed in the derived type, 2994 -- nothing to initialize. 2995 2996 -- type Deriv_Typ (Discr : ...) 2997 -- is new Parent_Typ (Discr => Discr); 2998 2999 if Is_Entity_Name (Discr_Val) 3000 and then Ekind (Entity (Discr_Val)) = E_Discriminant 3001 then 3002 null; 3003 3004 -- When the parent discriminant is constrained at the type 3005 -- extension level, it does not appear in the derived type. 3006 3007 -- type Deriv_Typ (Discr : ...) 3008 -- is new Parent_Typ (Discr => Discr, 3009 -- Hidden_Discr => Expression); 3010 3011 elsif Is_Completely_Hidden_Discriminant (Discr) then 3012 null; 3013 3014 -- Otherwise initialize the discriminant 3015 3016 else 3017 Discr_Init := 3018 Make_OK_Assignment_Statement (Loc, 3019 Name => 3020 Make_Selected_Component (Loc, 3021 Prefix => New_Copy_Tree (Target), 3022 Selector_Name => New_Occurrence_Of (Discr, Loc)), 3023 Expression => New_Copy_Tree (Discr_Val)); 3024 3025 Append_To (List, Discr_Init); 3026 end if; 3027 3028 Next_Elmt (Discr_Constr); 3029 Next_Discriminant (Discr); 3030 end loop; 3031 3032 In_Aggr_Type := False; 3033 Base_Typ := Base_Type (Par_Typ); 3034 end loop; 3035 end Init_Hidden_Discriminants; 3036 3037 -------------------------------- 3038 -- Init_Visible_Discriminants -- 3039 -------------------------------- 3040 3041 procedure Init_Visible_Discriminants is 3042 Discriminant : Entity_Id; 3043 Discriminant_Value : Node_Id; 3044 3045 begin 3046 Discriminant := First_Discriminant (Typ); 3047 while Present (Discriminant) loop 3048 Comp_Expr := 3049 Make_Selected_Component (Loc, 3050 Prefix => New_Copy_Tree (Target), 3051 Selector_Name => New_Occurrence_Of (Discriminant, Loc)); 3052 3053 Discriminant_Value := 3054 Get_Discriminant_Value 3055 (Discriminant, Typ, Discriminant_Constraint (N_Typ)); 3056 3057 Instr := 3058 Make_OK_Assignment_Statement (Loc, 3059 Name => Comp_Expr, 3060 Expression => New_Copy_Tree (Discriminant_Value)); 3061 3062 Append_To (L, Instr); 3063 3064 Next_Discriminant (Discriminant); 3065 end loop; 3066 end Init_Visible_Discriminants; 3067 3068 ------------------------------- 3069 -- Init_Stored_Discriminants -- 3070 ------------------------------- 3071 3072 procedure Init_Stored_Discriminants is 3073 Discriminant : Entity_Id; 3074 Discriminant_Value : Node_Id; 3075 3076 begin 3077 Discriminant := First_Stored_Discriminant (Typ); 3078 while Present (Discriminant) loop 3079 Comp_Expr := 3080 Make_Selected_Component (Loc, 3081 Prefix => New_Copy_Tree (Target), 3082 Selector_Name => New_Occurrence_Of (Discriminant, Loc)); 3083 3084 Discriminant_Value := 3085 Get_Discriminant_Value 3086 (Discriminant, N_Typ, Discriminant_Constraint (N_Typ)); 3087 3088 Instr := 3089 Make_OK_Assignment_Statement (Loc, 3090 Name => Comp_Expr, 3091 Expression => New_Copy_Tree (Discriminant_Value)); 3092 3093 Append_To (L, Instr); 3094 3095 Next_Stored_Discriminant (Discriminant); 3096 end loop; 3097 end Init_Stored_Discriminants; 3098 3099 -------------------------------------- 3100 -- Initialize_Ctrl_Record_Component -- 3101 -------------------------------------- 3102 3103 procedure Initialize_Ctrl_Record_Component 3104 (Rec_Comp : Node_Id; 3105 Comp_Typ : Entity_Id; 3106 Init_Expr : Node_Id; 3107 Stmts : List_Id) 3108 is 3109 Fin_Call : Node_Id; 3110 Hook_Clear : Node_Id; 3111 3112 In_Place_Expansion : Boolean; 3113 -- Flag set when a nonlimited controlled function call requires 3114 -- in-place expansion. 3115 3116 begin 3117 -- Perform a preliminary analysis and resolution to determine what 3118 -- the initialization expression denotes. Unanalyzed function calls 3119 -- may appear as identifiers or indexed components. 3120 3121 if Nkind (Init_Expr) in N_Function_Call 3122 | N_Identifier 3123 | N_Indexed_Component 3124 and then not Analyzed (Init_Expr) 3125 then 3126 Preanalyze_And_Resolve (Init_Expr, Comp_Typ); 3127 end if; 3128 3129 In_Place_Expansion := 3130 Nkind (Init_Expr) = N_Function_Call 3131 and then not Is_Build_In_Place_Result_Type (Comp_Typ); 3132 3133 -- The initialization expression is a controlled function call. 3134 -- Perform in-place removal of side effects to avoid creating a 3135 -- transient scope. 3136 3137 -- This in-place expansion is not performed for limited transient 3138 -- objects because the initialization is already done in place. 3139 3140 if In_Place_Expansion then 3141 3142 -- Suppress the removal of side effects by general analysis 3143 -- because this behavior is emulated here. This avoids the 3144 -- generation of a transient scope, which leads to out-of-order 3145 -- adjustment and finalization. 3146 3147 Set_No_Side_Effect_Removal (Init_Expr); 3148 3149 -- Install all hook-related declarations and prepare the clean up 3150 -- statements. The generated code follows the initialization order 3151 -- of individual components and discriminants, rather than being 3152 -- inserted prior to the aggregate. This ensures that a transient 3153 -- component which mentions a discriminant has proper visibility 3154 -- of the discriminant. 3155 3156 Process_Transient_Component 3157 (Loc => Loc, 3158 Comp_Typ => Comp_Typ, 3159 Init_Expr => Init_Expr, 3160 Fin_Call => Fin_Call, 3161 Hook_Clear => Hook_Clear, 3162 Stmts => Stmts); 3163 end if; 3164 3165 -- Use the noncontrolled component initialization circuitry to 3166 -- assign the result of the function call to the record component. 3167 -- This also performs tag adjustment and [deep] adjustment of the 3168 -- record component. 3169 3170 Initialize_Record_Component 3171 (Rec_Comp => Rec_Comp, 3172 Comp_Typ => Comp_Typ, 3173 Init_Expr => Init_Expr, 3174 Stmts => Stmts); 3175 3176 -- At this point the record component is fully initialized. Complete 3177 -- the processing of the controlled record component by finalizing 3178 -- the transient function result. 3179 3180 if In_Place_Expansion then 3181 Process_Transient_Component_Completion 3182 (Loc => Loc, 3183 Aggr => N, 3184 Fin_Call => Fin_Call, 3185 Hook_Clear => Hook_Clear, 3186 Stmts => Stmts); 3187 end if; 3188 end Initialize_Ctrl_Record_Component; 3189 3190 --------------------------------- 3191 -- Initialize_Record_Component -- 3192 --------------------------------- 3193 3194 procedure Initialize_Record_Component 3195 (Rec_Comp : Node_Id; 3196 Comp_Typ : Entity_Id; 3197 Init_Expr : Node_Id; 3198 Stmts : List_Id) 3199 is 3200 Exceptions_OK : constant Boolean := 3201 not Restriction_Active (No_Exception_Propagation); 3202 3203 Finalization_OK : constant Boolean := Needs_Finalization (Comp_Typ); 3204 3205 Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ); 3206 Adj_Call : Node_Id; 3207 Blk_Stmts : List_Id; 3208 Init_Stmt : Node_Id; 3209 3210 begin 3211 pragma Assert (Nkind (Init_Expr) in N_Subexpr); 3212 3213 -- Protect the initialization statements from aborts. Generate: 3214 3215 -- Abort_Defer; 3216 3217 if Finalization_OK and Abort_Allowed then 3218 if Exceptions_OK then 3219 Blk_Stmts := New_List; 3220 else 3221 Blk_Stmts := Stmts; 3222 end if; 3223 3224 Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); 3225 3226 -- Otherwise aborts are not allowed. All generated code is added 3227 -- directly to the input list. 3228 3229 else 3230 Blk_Stmts := Stmts; 3231 end if; 3232 3233 -- Initialize the record component. Generate: 3234 3235 -- Rec_Comp := Init_Expr; 3236 3237 -- Note that the initialization expression is NOT replicated because 3238 -- only a single component may be initialized by it. 3239 3240 Init_Stmt := 3241 Make_OK_Assignment_Statement (Loc, 3242 Name => New_Copy_Tree (Rec_Comp), 3243 Expression => Init_Expr); 3244 Set_No_Ctrl_Actions (Init_Stmt); 3245 3246 Append_To (Blk_Stmts, Init_Stmt); 3247 3248 -- Adjust the tag due to a possible view conversion. Generate: 3249 3250 -- Rec_Comp._tag := Full_TypeP; 3251 3252 if Tagged_Type_Expansion and then Is_Tagged_Type (Comp_Typ) then 3253 Append_To (Blk_Stmts, 3254 Make_OK_Assignment_Statement (Loc, 3255 Name => 3256 Make_Selected_Component (Loc, 3257 Prefix => New_Copy_Tree (Rec_Comp), 3258 Selector_Name => 3259 New_Occurrence_Of 3260 (First_Tag_Component (Full_Typ), Loc)), 3261 3262 Expression => 3263 Unchecked_Convert_To (RTE (RE_Tag), 3264 New_Occurrence_Of 3265 (Node (First_Elmt (Access_Disp_Table (Full_Typ))), 3266 Loc)))); 3267 end if; 3268 3269 -- Adjust the component. Generate: 3270 3271 -- [Deep_]Adjust (Rec_Comp); 3272 3273 if Finalization_OK 3274 and then not Is_Limited_Type (Comp_Typ) 3275 and then not Is_Build_In_Place_Function_Call (Init_Expr) 3276 then 3277 Adj_Call := 3278 Make_Adjust_Call 3279 (Obj_Ref => New_Copy_Tree (Rec_Comp), 3280 Typ => Comp_Typ); 3281 3282 -- Guard against a missing [Deep_]Adjust when the component type 3283 -- was not properly frozen. 3284 3285 if Present (Adj_Call) then 3286 Append_To (Blk_Stmts, Adj_Call); 3287 end if; 3288 end if; 3289 3290 -- Complete the protection of the initialization statements 3291 3292 if Finalization_OK and Abort_Allowed then 3293 3294 -- Wrap the initialization statements in a block to catch a 3295 -- potential exception. Generate: 3296 3297 -- begin 3298 -- Abort_Defer; 3299 -- Rec_Comp := Init_Expr; 3300 -- Rec_Comp._tag := Full_TypP; 3301 -- [Deep_]Adjust (Rec_Comp); 3302 -- at end 3303 -- Abort_Undefer_Direct; 3304 -- end; 3305 3306 if Exceptions_OK then 3307 Append_To (Stmts, 3308 Build_Abort_Undefer_Block (Loc, 3309 Stmts => Blk_Stmts, 3310 Context => N)); 3311 3312 -- Otherwise exceptions are not propagated. Generate: 3313 3314 -- Abort_Defer; 3315 -- Rec_Comp := Init_Expr; 3316 -- Rec_Comp._tag := Full_TypP; 3317 -- [Deep_]Adjust (Rec_Comp); 3318 -- Abort_Undefer; 3319 3320 else 3321 Append_To (Blk_Stmts, 3322 Build_Runtime_Call (Loc, RE_Abort_Undefer)); 3323 end if; 3324 end if; 3325 end Initialize_Record_Component; 3326 3327 ------------------------- 3328 -- Is_Int_Range_Bounds -- 3329 ------------------------- 3330 3331 function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean is 3332 begin 3333 return Nkind (Bounds) = N_Range 3334 and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal 3335 and then Nkind (High_Bound (Bounds)) = N_Integer_Literal; 3336 end Is_Int_Range_Bounds; 3337 3338 ------------------ 3339 -- Replace_Type -- 3340 ------------------ 3341 3342 function Replace_Type (Expr : Node_Id) return Traverse_Result is 3343 begin 3344 -- Note regarding the Root_Type test below: Aggregate components for 3345 -- self-referential types include attribute references to the current 3346 -- instance, of the form: Typ'access, etc.. These references are 3347 -- rewritten as references to the target of the aggregate: the 3348 -- left-hand side of an assignment, the entity in a declaration, 3349 -- or a temporary. Without this test, we would improperly extended 3350 -- this rewriting to attribute references whose prefix was not the 3351 -- type of the aggregate. 3352 3353 if Nkind (Expr) = N_Attribute_Reference 3354 and then Is_Entity_Name (Prefix (Expr)) 3355 and then Is_Type (Entity (Prefix (Expr))) 3356 and then Root_Type (Etype (N)) = Root_Type (Entity (Prefix (Expr))) 3357 then 3358 if Is_Entity_Name (Lhs) then 3359 Rewrite (Prefix (Expr), New_Occurrence_Of (Entity (Lhs), Loc)); 3360 3361 else 3362 Rewrite (Expr, 3363 Make_Attribute_Reference (Loc, 3364 Attribute_Name => Name_Unrestricted_Access, 3365 Prefix => New_Copy_Tree (Lhs))); 3366 Set_Analyzed (Parent (Expr), False); 3367 end if; 3368 end if; 3369 3370 return OK; 3371 end Replace_Type; 3372 3373 -------------------------- 3374 -- Rewrite_Discriminant -- 3375 -------------------------- 3376 3377 function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is 3378 begin 3379 if Is_Entity_Name (Expr) 3380 and then Present (Entity (Expr)) 3381 and then Ekind (Entity (Expr)) = E_In_Parameter 3382 and then Present (Discriminal_Link (Entity (Expr))) 3383 and then Scope (Discriminal_Link (Entity (Expr))) = 3384 Base_Type (Etype (N)) 3385 then 3386 Rewrite (Expr, 3387 Make_Selected_Component (Loc, 3388 Prefix => New_Copy_Tree (Lhs), 3389 Selector_Name => Make_Identifier (Loc, Chars (Expr)))); 3390 3391 -- The generated code will be reanalyzed, but if the reference 3392 -- to the discriminant appears within an already analyzed 3393 -- expression (e.g. a conditional) we must set its proper entity 3394 -- now. Context is an initialization procedure. 3395 3396 Analyze (Expr); 3397 end if; 3398 3399 return OK; 3400 end Rewrite_Discriminant; 3401 3402 procedure Replace_Discriminants is 3403 new Traverse_Proc (Rewrite_Discriminant); 3404 3405 procedure Replace_Self_Reference is 3406 new Traverse_Proc (Replace_Type); 3407 3408 -- Start of processing for Build_Record_Aggr_Code 3409 3410 begin 3411 if Has_Self_Reference (N) then 3412 Replace_Self_Reference (N); 3413 end if; 3414 3415 -- If the target of the aggregate is class-wide, we must convert it 3416 -- to the actual type of the aggregate, so that the proper components 3417 -- are visible. We know already that the types are compatible. 3418 3419 if Present (Etype (Lhs)) 3420 and then Is_Class_Wide_Type (Etype (Lhs)) 3421 then 3422 Target := Unchecked_Convert_To (Typ, Lhs); 3423 else 3424 Target := Lhs; 3425 end if; 3426 3427 -- Deal with the ancestor part of extension aggregates or with the 3428 -- discriminants of the root type. 3429 3430 if Nkind (N) = N_Extension_Aggregate then 3431 declare 3432 Ancestor : constant Node_Id := Ancestor_Part (N); 3433 Adj_Call : Node_Id; 3434 Assign : List_Id; 3435 3436 begin 3437 -- If the ancestor part is a subtype mark "T", we generate 3438 3439 -- init-proc (T (tmp)); if T is constrained and 3440 -- init-proc (S (tmp)); where S applies an appropriate 3441 -- constraint if T is unconstrained 3442 3443 if Is_Entity_Name (Ancestor) 3444 and then Is_Type (Entity (Ancestor)) 3445 then 3446 Ancestor_Is_Subtype_Mark := True; 3447 3448 if Is_Constrained (Entity (Ancestor)) then 3449 Init_Typ := Entity (Ancestor); 3450 3451 -- For an ancestor part given by an unconstrained type mark, 3452 -- create a subtype constrained by appropriate corresponding 3453 -- discriminant values coming from either associations of the 3454 -- aggregate or a constraint on a parent type. The subtype will 3455 -- be used to generate the correct default value for the 3456 -- ancestor part. 3457 3458 elsif Has_Discriminants (Entity (Ancestor)) then 3459 declare 3460 Anc_Typ : constant Entity_Id := Entity (Ancestor); 3461 Anc_Constr : constant List_Id := New_List; 3462 Discrim : Entity_Id; 3463 Disc_Value : Node_Id; 3464 New_Indic : Node_Id; 3465 Subt_Decl : Node_Id; 3466 3467 begin 3468 Discrim := First_Discriminant (Anc_Typ); 3469 while Present (Discrim) loop 3470 Disc_Value := Ancestor_Discriminant_Value (Discrim); 3471 3472 -- If no usable discriminant in ancestors, check 3473 -- whether aggregate has an explicit value for it. 3474 3475 if No (Disc_Value) then 3476 Disc_Value := 3477 Get_Explicit_Discriminant_Value (Discrim); 3478 end if; 3479 3480 Append_To (Anc_Constr, Disc_Value); 3481 Next_Discriminant (Discrim); 3482 end loop; 3483 3484 New_Indic := 3485 Make_Subtype_Indication (Loc, 3486 Subtype_Mark => New_Occurrence_Of (Anc_Typ, Loc), 3487 Constraint => 3488 Make_Index_Or_Discriminant_Constraint (Loc, 3489 Constraints => Anc_Constr)); 3490 3491 Init_Typ := Create_Itype (Ekind (Anc_Typ), N); 3492 3493 Subt_Decl := 3494 Make_Subtype_Declaration (Loc, 3495 Defining_Identifier => Init_Typ, 3496 Subtype_Indication => New_Indic); 3497 3498 -- Itypes must be analyzed with checks off Declaration 3499 -- must have a parent for proper handling of subsidiary 3500 -- actions. 3501 3502 Set_Parent (Subt_Decl, N); 3503 Analyze (Subt_Decl, Suppress => All_Checks); 3504 end; 3505 end if; 3506 3507 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); 3508 Set_Assignment_OK (Ref); 3509 3510 if not Is_Interface (Init_Typ) then 3511 Append_List_To (L, 3512 Build_Initialization_Call (Loc, 3513 Id_Ref => Ref, 3514 Typ => Init_Typ, 3515 In_Init_Proc => Within_Init_Proc, 3516 With_Default_Init => Has_Default_Init_Comps (N) 3517 or else 3518 Has_Task (Base_Type (Init_Typ)))); 3519 3520 if Is_Constrained (Entity (Ancestor)) 3521 and then Has_Discriminants (Entity (Ancestor)) 3522 then 3523 Check_Ancestor_Discriminants (Entity (Ancestor)); 3524 end if; 3525 3526 -- If ancestor type has Default_Initialization_Condition, 3527 -- add a DIC check after the ancestor object is initialized 3528 -- by default. 3529 3530 if Has_DIC (Entity (Ancestor)) 3531 and then Present (DIC_Procedure (Entity (Ancestor))) 3532 then 3533 Append_To (L, 3534 Build_DIC_Call 3535 (Loc, New_Copy_Tree (Ref), Entity (Ancestor))); 3536 end if; 3537 end if; 3538 3539 -- Handle calls to C++ constructors 3540 3541 elsif Is_CPP_Constructor_Call (Ancestor) then 3542 Init_Typ := Etype (Ancestor); 3543 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); 3544 Set_Assignment_OK (Ref); 3545 3546 Append_List_To (L, 3547 Build_Initialization_Call (Loc, 3548 Id_Ref => Ref, 3549 Typ => Init_Typ, 3550 In_Init_Proc => Within_Init_Proc, 3551 With_Default_Init => Has_Default_Init_Comps (N), 3552 Constructor_Ref => Ancestor)); 3553 3554 -- Ada 2005 (AI-287): If the ancestor part is an aggregate of 3555 -- limited type, a recursive call expands the ancestor. Note that 3556 -- in the limited case, the ancestor part must be either a 3557 -- function call (possibly qualified) or aggregate (definitely 3558 -- qualified). 3559 3560 elsif Is_Limited_Type (Etype (Ancestor)) 3561 and then Nkind (Unqualify (Ancestor)) in 3562 N_Aggregate | N_Extension_Aggregate 3563 then 3564 Ancestor_Is_Expression := True; 3565 3566 -- Set up finalization data for enclosing record, because 3567 -- controlled subcomponents of the ancestor part will be 3568 -- attached to it. 3569 3570 Generate_Finalization_Actions; 3571 3572 Append_List_To (L, 3573 Build_Record_Aggr_Code 3574 (N => Unqualify (Ancestor), 3575 Typ => Etype (Unqualify (Ancestor)), 3576 Lhs => Target)); 3577 3578 -- If the ancestor part is an expression "E", we generate 3579 3580 -- T (tmp) := E; 3581 3582 -- In Ada 2005, this includes the case of a (possibly qualified) 3583 -- limited function call. The assignment will turn into a 3584 -- build-in-place function call (for further details, see 3585 -- Make_Build_In_Place_Call_In_Assignment). 3586 3587 else 3588 Ancestor_Is_Expression := True; 3589 Init_Typ := Etype (Ancestor); 3590 3591 -- If the ancestor part is an aggregate, force its full 3592 -- expansion, which was delayed. 3593 3594 if Nkind (Unqualify (Ancestor)) in 3595 N_Aggregate | N_Extension_Aggregate 3596 then 3597 Set_Analyzed (Ancestor, False); 3598 Set_Analyzed (Expression (Ancestor), False); 3599 end if; 3600 3601 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); 3602 Set_Assignment_OK (Ref); 3603 3604 -- Make the assignment without usual controlled actions, since 3605 -- we only want to Adjust afterwards, but not to Finalize 3606 -- beforehand. Add manual Adjust when necessary. 3607 3608 Assign := New_List ( 3609 Make_OK_Assignment_Statement (Loc, 3610 Name => Ref, 3611 Expression => Ancestor)); 3612 Set_No_Ctrl_Actions (First (Assign)); 3613 3614 -- Assign the tag now to make sure that the dispatching call in 3615 -- the subsequent deep_adjust works properly (unless 3616 -- Tagged_Type_Expansion where tags are implicit). 3617 3618 if Tagged_Type_Expansion then 3619 Instr := 3620 Make_OK_Assignment_Statement (Loc, 3621 Name => 3622 Make_Selected_Component (Loc, 3623 Prefix => New_Copy_Tree (Target), 3624 Selector_Name => 3625 New_Occurrence_Of 3626 (First_Tag_Component (Base_Type (Typ)), Loc)), 3627 3628 Expression => 3629 Unchecked_Convert_To (RTE (RE_Tag), 3630 New_Occurrence_Of 3631 (Node (First_Elmt 3632 (Access_Disp_Table (Base_Type (Typ)))), 3633 Loc))); 3634 3635 Set_Assignment_OK (Name (Instr)); 3636 Append_To (Assign, Instr); 3637 3638 -- Ada 2005 (AI-251): If tagged type has progenitors we must 3639 -- also initialize tags of the secondary dispatch tables. 3640 3641 if Has_Interfaces (Base_Type (Typ)) then 3642 Init_Secondary_Tags 3643 (Typ => Base_Type (Typ), 3644 Target => Target, 3645 Stmts_List => Assign, 3646 Init_Tags_List => Assign); 3647 end if; 3648 end if; 3649 3650 -- Call Adjust manually 3651 3652 if Needs_Finalization (Etype (Ancestor)) 3653 and then not Is_Limited_Type (Etype (Ancestor)) 3654 and then not Is_Build_In_Place_Function_Call (Ancestor) 3655 then 3656 Adj_Call := 3657 Make_Adjust_Call 3658 (Obj_Ref => New_Copy_Tree (Ref), 3659 Typ => Etype (Ancestor)); 3660 3661 -- Guard against a missing [Deep_]Adjust when the ancestor 3662 -- type was not properly frozen. 3663 3664 if Present (Adj_Call) then 3665 Append_To (Assign, Adj_Call); 3666 end if; 3667 end if; 3668 3669 Append_To (L, 3670 Make_Unsuppress_Block (Loc, Name_Discriminant_Check, Assign)); 3671 3672 if Has_Discriminants (Init_Typ) then 3673 Check_Ancestor_Discriminants (Init_Typ); 3674 end if; 3675 end if; 3676 3677 pragma Assert (Nkind (N) = N_Extension_Aggregate); 3678 pragma Assert 3679 (not (Ancestor_Is_Expression and Ancestor_Is_Subtype_Mark)); 3680 end; 3681 3682 -- Generate assignments of hidden discriminants. If the base type is 3683 -- an unchecked union, the discriminants are unknown to the back-end 3684 -- and absent from a value of the type, so assignments for them are 3685 -- not emitted. 3686 3687 if Has_Discriminants (Typ) 3688 and then not Is_Unchecked_Union (Base_Type (Typ)) 3689 then 3690 Init_Hidden_Discriminants (Typ, L); 3691 end if; 3692 3693 -- Normal case (not an extension aggregate) 3694 3695 else 3696 -- Generate the discriminant expressions, component by component. 3697 -- If the base type is an unchecked union, the discriminants are 3698 -- unknown to the back-end and absent from a value of the type, so 3699 -- assignments for them are not emitted. 3700 3701 if Has_Discriminants (Typ) 3702 and then not Is_Unchecked_Union (Base_Type (Typ)) 3703 then 3704 Init_Hidden_Discriminants (Typ, L); 3705 3706 -- Generate discriminant init values for the visible discriminants 3707 3708 Init_Visible_Discriminants; 3709 3710 if Is_Derived_Type (N_Typ) then 3711 Init_Stored_Discriminants; 3712 end if; 3713 end if; 3714 end if; 3715 3716 -- For CPP types we generate an implicit call to the C++ default 3717 -- constructor to ensure the proper initialization of the _Tag 3718 -- component. 3719 3720 if Is_CPP_Class (Root_Type (Typ)) and then CPP_Num_Prims (Typ) > 0 then 3721 Invoke_Constructor : declare 3722 CPP_Parent : constant Entity_Id := Enclosing_CPP_Parent (Typ); 3723 3724 procedure Invoke_IC_Proc (T : Entity_Id); 3725 -- Recursive routine used to climb to parents. Required because 3726 -- parents must be initialized before descendants to ensure 3727 -- propagation of inherited C++ slots. 3728 3729 -------------------- 3730 -- Invoke_IC_Proc -- 3731 -------------------- 3732 3733 procedure Invoke_IC_Proc (T : Entity_Id) is 3734 begin 3735 -- Avoid generating extra calls. Initialization required 3736 -- only for types defined from the level of derivation of 3737 -- type of the constructor and the type of the aggregate. 3738 3739 if T = CPP_Parent then 3740 return; 3741 end if; 3742 3743 Invoke_IC_Proc (Etype (T)); 3744 3745 -- Generate call to the IC routine 3746 3747 if Present (CPP_Init_Proc (T)) then 3748 Append_To (L, 3749 Make_Procedure_Call_Statement (Loc, 3750 Name => New_Occurrence_Of (CPP_Init_Proc (T), Loc))); 3751 end if; 3752 end Invoke_IC_Proc; 3753 3754 -- Start of processing for Invoke_Constructor 3755 3756 begin 3757 -- Implicit invocation of the C++ constructor 3758 3759 if Nkind (N) = N_Aggregate then 3760 Append_To (L, 3761 Make_Procedure_Call_Statement (Loc, 3762 Name => 3763 New_Occurrence_Of (Base_Init_Proc (CPP_Parent), Loc), 3764 Parameter_Associations => New_List ( 3765 Unchecked_Convert_To (CPP_Parent, 3766 New_Copy_Tree (Lhs))))); 3767 end if; 3768 3769 Invoke_IC_Proc (Typ); 3770 end Invoke_Constructor; 3771 end if; 3772 3773 -- Generate the assignments, component by component 3774 3775 -- tmp.comp1 := Expr1_From_Aggr; 3776 -- tmp.comp2 := Expr2_From_Aggr; 3777 -- .... 3778 3779 Comp := First (Component_Associations (N)); 3780 while Present (Comp) loop 3781 Selector := Entity (First (Choices (Comp))); 3782 3783 -- C++ constructors 3784 3785 if Is_CPP_Constructor_Call (Expression (Comp)) then 3786 Append_List_To (L, 3787 Build_Initialization_Call (Loc, 3788 Id_Ref => 3789 Make_Selected_Component (Loc, 3790 Prefix => New_Copy_Tree (Target), 3791 Selector_Name => New_Occurrence_Of (Selector, Loc)), 3792 Typ => Etype (Selector), 3793 Enclos_Type => Typ, 3794 With_Default_Init => True, 3795 Constructor_Ref => Expression (Comp))); 3796 3797 elsif Box_Present (Comp) 3798 and then Needs_Simple_Initialization (Etype (Selector)) 3799 then 3800 Comp_Expr := 3801 Make_Selected_Component (Loc, 3802 Prefix => New_Copy_Tree (Target), 3803 Selector_Name => New_Occurrence_Of (Selector, Loc)); 3804 3805 Initialize_Record_Component 3806 (Rec_Comp => Comp_Expr, 3807 Comp_Typ => Etype (Selector), 3808 Init_Expr => Get_Simple_Init_Val 3809 (Typ => Etype (Selector), 3810 N => Comp, 3811 Size => 3812 (if Known_Esize (Selector) 3813 then Esize (Selector) 3814 else Uint_0)), 3815 Stmts => L); 3816 3817 -- Ada 2005 (AI-287): For each default-initialized component generate 3818 -- a call to the corresponding IP subprogram if available. 3819 3820 elsif Box_Present (Comp) 3821 and then Has_Non_Null_Base_Init_Proc (Etype (Selector)) 3822 then 3823 if Ekind (Selector) /= E_Discriminant then 3824 Generate_Finalization_Actions; 3825 end if; 3826 3827 -- Ada 2005 (AI-287): If the component type has tasks then 3828 -- generate the activation chain and master entities (except 3829 -- in case of an allocator because in that case these entities 3830 -- are generated by Build_Task_Allocate_Block_With_Init_Stmts). 3831 3832 declare 3833 Ctype : constant Entity_Id := Etype (Selector); 3834 Inside_Allocator : Boolean := False; 3835 P : Node_Id := Parent (N); 3836 3837 begin 3838 if Is_Task_Type (Ctype) or else Has_Task (Ctype) then 3839 while Present (P) loop 3840 if Nkind (P) = N_Allocator then 3841 Inside_Allocator := True; 3842 exit; 3843 end if; 3844 3845 P := Parent (P); 3846 end loop; 3847 3848 if not Inside_Init_Proc and not Inside_Allocator then 3849 Build_Activation_Chain_Entity (N); 3850 end if; 3851 end if; 3852 end; 3853 3854 Append_List_To (L, 3855 Build_Initialization_Call (Loc, 3856 Id_Ref => Make_Selected_Component (Loc, 3857 Prefix => New_Copy_Tree (Target), 3858 Selector_Name => 3859 New_Occurrence_Of (Selector, Loc)), 3860 Typ => Etype (Selector), 3861 Enclos_Type => Typ, 3862 With_Default_Init => True)); 3863 3864 -- Prepare for component assignment 3865 3866 elsif Ekind (Selector) /= E_Discriminant 3867 or else Nkind (N) = N_Extension_Aggregate 3868 then 3869 -- All the discriminants have now been assigned 3870 3871 -- This is now a good moment to initialize and attach all the 3872 -- controllers. Their position may depend on the discriminants. 3873 3874 if Ekind (Selector) /= E_Discriminant then 3875 Generate_Finalization_Actions; 3876 end if; 3877 3878 Comp_Type := Underlying_Type (Etype (Selector)); 3879 Comp_Expr := 3880 Make_Selected_Component (Loc, 3881 Prefix => New_Copy_Tree (Target), 3882 Selector_Name => New_Occurrence_Of (Selector, Loc)); 3883 3884 if Nkind (Expression (Comp)) = N_Qualified_Expression then 3885 Expr_Q := Expression (Expression (Comp)); 3886 else 3887 Expr_Q := Expression (Comp); 3888 end if; 3889 3890 -- Now either create the assignment or generate the code for the 3891 -- inner aggregate top-down. 3892 3893 if Is_Delayed_Aggregate (Expr_Q) then 3894 3895 -- We have the following case of aggregate nesting inside 3896 -- an object declaration: 3897 3898 -- type Arr_Typ is array (Integer range <>) of ...; 3899 3900 -- type Rec_Typ (...) is record 3901 -- Obj_Arr_Typ : Arr_Typ (A .. B); 3902 -- end record; 3903 3904 -- Obj_Rec_Typ : Rec_Typ := (..., 3905 -- Obj_Arr_Typ => (X => (...), Y => (...))); 3906 3907 -- The length of the ranges of the aggregate and Obj_Add_Typ 3908 -- are equal (B - A = Y - X), but they do not coincide (X /= 3909 -- A and B /= Y). This case requires array sliding which is 3910 -- performed in the following manner: 3911 3912 -- subtype Arr_Sub is Arr_Typ (X .. Y); 3913 -- Temp : Arr_Sub; 3914 -- Temp (X) := (...); 3915 -- ... 3916 -- Temp (Y) := (...); 3917 -- Obj_Rec_Typ.Obj_Arr_Typ := Temp; 3918 3919 if Ekind (Comp_Type) = E_Array_Subtype 3920 and then Is_Int_Range_Bounds (Aggregate_Bounds (Expr_Q)) 3921 and then Is_Int_Range_Bounds (First_Index (Comp_Type)) 3922 and then not 3923 Compatible_Int_Bounds 3924 (Agg_Bounds => Aggregate_Bounds (Expr_Q), 3925 Typ_Bounds => First_Index (Comp_Type)) 3926 then 3927 -- Create the array subtype with bounds equal to those of 3928 -- the corresponding aggregate. 3929 3930 declare 3931 SubE : constant Entity_Id := Make_Temporary (Loc, 'T'); 3932 3933 SubD : constant Node_Id := 3934 Make_Subtype_Declaration (Loc, 3935 Defining_Identifier => SubE, 3936 Subtype_Indication => 3937 Make_Subtype_Indication (Loc, 3938 Subtype_Mark => 3939 New_Occurrence_Of (Etype (Comp_Type), Loc), 3940 Constraint => 3941 Make_Index_Or_Discriminant_Constraint 3942 (Loc, 3943 Constraints => New_List ( 3944 New_Copy_Tree 3945 (Aggregate_Bounds (Expr_Q)))))); 3946 3947 -- Create a temporary array of the above subtype which 3948 -- will be used to capture the aggregate assignments. 3949 3950 TmpE : constant Entity_Id := Make_Temporary (Loc, 'A', N); 3951 3952 TmpD : constant Node_Id := 3953 Make_Object_Declaration (Loc, 3954 Defining_Identifier => TmpE, 3955 Object_Definition => New_Occurrence_Of (SubE, Loc)); 3956 3957 begin 3958 Set_No_Initialization (TmpD); 3959 Append_To (L, SubD); 3960 Append_To (L, TmpD); 3961 3962 -- Expand aggregate into assignments to the temp array 3963 3964 Append_List_To (L, 3965 Late_Expansion (Expr_Q, Comp_Type, 3966 New_Occurrence_Of (TmpE, Loc))); 3967 3968 -- Slide 3969 3970 Append_To (L, 3971 Make_Assignment_Statement (Loc, 3972 Name => New_Copy_Tree (Comp_Expr), 3973 Expression => New_Occurrence_Of (TmpE, Loc))); 3974 end; 3975 3976 -- Normal case (sliding not required) 3977 3978 else 3979 Append_List_To (L, 3980 Late_Expansion (Expr_Q, Comp_Type, Comp_Expr)); 3981 end if; 3982 3983 -- Expr_Q is not delayed aggregate 3984 3985 else 3986 if Has_Discriminants (Typ) then 3987 Replace_Discriminants (Expr_Q); 3988 3989 -- If the component is an array type that depends on 3990 -- discriminants, and the expression is a single Others 3991 -- clause, create an explicit subtype for it because the 3992 -- backend has troubles recovering the actual bounds. 3993 3994 if Nkind (Expr_Q) = N_Aggregate 3995 and then Is_Array_Type (Comp_Type) 3996 and then Present (Component_Associations (Expr_Q)) 3997 then 3998 declare 3999 Assoc : constant Node_Id := 4000 First (Component_Associations (Expr_Q)); 4001 Decl : Node_Id; 4002 4003 begin 4004 if Nkind (First (Choices (Assoc))) = N_Others_Choice 4005 then 4006 Decl := 4007 Build_Actual_Subtype_Of_Component 4008 (Comp_Type, Comp_Expr); 4009 4010 -- If the component type does not in fact depend on 4011 -- discriminants, the subtype declaration is empty. 4012 4013 if Present (Decl) then 4014 Append_To (L, Decl); 4015 Set_Etype (Comp_Expr, Defining_Entity (Decl)); 4016 end if; 4017 end if; 4018 end; 4019 end if; 4020 end if; 4021 4022 if Modify_Tree_For_C 4023 and then Nkind (Expr_Q) = N_Aggregate 4024 and then Is_Array_Type (Etype (Expr_Q)) 4025 and then Present (First_Index (Etype (Expr_Q))) 4026 then 4027 declare 4028 Expr_Q_Type : constant Entity_Id := Etype (Expr_Q); 4029 begin 4030 Append_List_To (L, 4031 Build_Array_Aggr_Code 4032 (N => Expr_Q, 4033 Ctype => Component_Type (Expr_Q_Type), 4034 Index => First_Index (Expr_Q_Type), 4035 Into => Comp_Expr, 4036 Scalar_Comp => 4037 Is_Scalar_Type (Component_Type (Expr_Q_Type)))); 4038 end; 4039 4040 else 4041 -- Handle an initialization expression of a controlled type 4042 -- in case it denotes a function call. In general such a 4043 -- scenario will produce a transient scope, but this will 4044 -- lead to wrong order of initialization, adjustment, and 4045 -- finalization in the context of aggregates. 4046 4047 -- Target.Comp := Ctrl_Func_Call; 4048 4049 -- begin -- scope 4050 -- Trans_Obj : ... := Ctrl_Func_Call; -- object 4051 -- Target.Comp := Trans_Obj; 4052 -- Finalize (Trans_Obj); 4053 -- end 4054 -- Target.Comp._tag := ...; 4055 -- Adjust (Target.Comp); 4056 4057 -- In the example above, the call to Finalize occurs too 4058 -- early and as a result it may leave the record component 4059 -- in a bad state. Finalization of the transient object 4060 -- should really happen after adjustment. 4061 4062 -- To avoid this scenario, perform in-place side-effect 4063 -- removal of the function call. This eliminates the 4064 -- transient property of the function result and ensures 4065 -- correct order of actions. 4066 4067 -- Res : ... := Ctrl_Func_Call; 4068 -- Target.Comp := Res; 4069 -- Target.Comp._tag := ...; 4070 -- Adjust (Target.Comp); 4071 -- Finalize (Res); 4072 4073 if Needs_Finalization (Comp_Type) 4074 and then Nkind (Expr_Q) /= N_Aggregate 4075 then 4076 Initialize_Ctrl_Record_Component 4077 (Rec_Comp => Comp_Expr, 4078 Comp_Typ => Etype (Selector), 4079 Init_Expr => Expr_Q, 4080 Stmts => L); 4081 4082 -- Otherwise perform single component initialization 4083 4084 else 4085 Initialize_Record_Component 4086 (Rec_Comp => Comp_Expr, 4087 Comp_Typ => Etype (Selector), 4088 Init_Expr => Expr_Q, 4089 Stmts => L); 4090 end if; 4091 end if; 4092 end if; 4093 4094 -- comment would be good here ??? 4095 4096 elsif Ekind (Selector) = E_Discriminant 4097 and then Nkind (N) /= N_Extension_Aggregate 4098 and then Nkind (Parent (N)) = N_Component_Association 4099 and then Is_Constrained (Typ) 4100 then 4101 -- We must check that the discriminant value imposed by the 4102 -- context is the same as the value given in the subaggregate, 4103 -- because after the expansion into assignments there is no 4104 -- record on which to perform a regular discriminant check. 4105 4106 declare 4107 D_Val : Elmt_Id; 4108 Disc : Entity_Id; 4109 4110 begin 4111 D_Val := First_Elmt (Discriminant_Constraint (Typ)); 4112 Disc := First_Discriminant (Typ); 4113 while Chars (Disc) /= Chars (Selector) loop 4114 Next_Discriminant (Disc); 4115 Next_Elmt (D_Val); 4116 end loop; 4117 4118 pragma Assert (Present (D_Val)); 4119 4120 -- This check cannot performed for components that are 4121 -- constrained by a current instance, because this is not a 4122 -- value that can be compared with the actual constraint. 4123 4124 if Nkind (Node (D_Val)) /= N_Attribute_Reference 4125 or else not Is_Entity_Name (Prefix (Node (D_Val))) 4126 or else not Is_Type (Entity (Prefix (Node (D_Val)))) 4127 then 4128 Append_To (L, 4129 Make_Raise_Constraint_Error (Loc, 4130 Condition => 4131 Make_Op_Ne (Loc, 4132 Left_Opnd => New_Copy_Tree (Node (D_Val)), 4133 Right_Opnd => Expression (Comp)), 4134 Reason => CE_Discriminant_Check_Failed)); 4135 4136 else 4137 -- Find self-reference in previous discriminant assignment, 4138 -- and replace with proper expression. 4139 4140 declare 4141 Ass : Node_Id; 4142 4143 begin 4144 Ass := First (L); 4145 while Present (Ass) loop 4146 if Nkind (Ass) = N_Assignment_Statement 4147 and then Nkind (Name (Ass)) = N_Selected_Component 4148 and then Chars (Selector_Name (Name (Ass))) = 4149 Chars (Disc) 4150 then 4151 Set_Expression 4152 (Ass, New_Copy_Tree (Expression (Comp))); 4153 exit; 4154 end if; 4155 Next (Ass); 4156 end loop; 4157 end; 4158 end if; 4159 end; 4160 end if; 4161 4162 -- If the component association was specified with a box and the 4163 -- component type has a Default_Initial_Condition, then generate 4164 -- a call to the DIC procedure. 4165 4166 if Has_DIC (Etype (Selector)) 4167 and then Was_Default_Init_Box_Association (Comp) 4168 and then Present (DIC_Procedure (Etype (Selector))) 4169 then 4170 Append_To (L, 4171 Build_DIC_Call (Loc, 4172 Make_Selected_Component (Loc, 4173 Prefix => New_Copy_Tree (Target), 4174 Selector_Name => New_Occurrence_Of (Selector, Loc)), 4175 Etype (Selector))); 4176 end if; 4177 4178 Next (Comp); 4179 end loop; 4180 4181 -- If the type is tagged, the tag needs to be initialized (unless we 4182 -- are in VM-mode where tags are implicit). It is done late in the 4183 -- initialization process because in some cases, we call the init 4184 -- proc of an ancestor which will not leave out the right tag. 4185 4186 if Ancestor_Is_Expression then 4187 null; 4188 4189 -- For CPP types we generated a call to the C++ default constructor 4190 -- before the components have been initialized to ensure the proper 4191 -- initialization of the _Tag component (see above). 4192 4193 elsif Is_CPP_Class (Typ) then 4194 null; 4195 4196 elsif Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then 4197 Instr := 4198 Make_OK_Assignment_Statement (Loc, 4199 Name => 4200 Make_Selected_Component (Loc, 4201 Prefix => New_Copy_Tree (Target), 4202 Selector_Name => 4203 New_Occurrence_Of 4204 (First_Tag_Component (Base_Type (Typ)), Loc)), 4205 4206 Expression => 4207 Unchecked_Convert_To (RTE (RE_Tag), 4208 New_Occurrence_Of 4209 (Node (First_Elmt (Access_Disp_Table (Base_Type (Typ)))), 4210 Loc))); 4211 4212 Append_To (L, Instr); 4213 4214 -- Ada 2005 (AI-251): If the tagged type has been derived from an 4215 -- abstract interfaces we must also initialize the tags of the 4216 -- secondary dispatch tables. 4217 4218 if Has_Interfaces (Base_Type (Typ)) then 4219 Init_Secondary_Tags 4220 (Typ => Base_Type (Typ), 4221 Target => Target, 4222 Stmts_List => L, 4223 Init_Tags_List => L); 4224 end if; 4225 end if; 4226 4227 -- If the controllers have not been initialized yet (by lack of non- 4228 -- discriminant components), let's do it now. 4229 4230 Generate_Finalization_Actions; 4231 4232 return L; 4233 end Build_Record_Aggr_Code; 4234 4235 ------------------------------- 4236 -- Convert_Aggr_In_Allocator -- 4237 ------------------------------- 4238 4239 procedure Convert_Aggr_In_Allocator 4240 (Alloc : Node_Id; 4241 Decl : Node_Id; 4242 Aggr : Node_Id) 4243 is 4244 Loc : constant Source_Ptr := Sloc (Aggr); 4245 Typ : constant Entity_Id := Etype (Aggr); 4246 Temp : constant Entity_Id := Defining_Identifier (Decl); 4247 4248 Occ : constant Node_Id := 4249 Unchecked_Convert_To (Typ, 4250 Make_Explicit_Dereference (Loc, New_Occurrence_Of (Temp, Loc))); 4251 4252 begin 4253 if Is_Array_Type (Typ) then 4254 Convert_Array_Aggr_In_Allocator (Decl, Aggr, Occ); 4255 4256 elsif Has_Default_Init_Comps (Aggr) then 4257 declare 4258 L : constant List_Id := New_List; 4259 Init_Stmts : List_Id; 4260 4261 begin 4262 Init_Stmts := Late_Expansion (Aggr, Typ, Occ); 4263 4264 if Has_Task (Typ) then 4265 Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts); 4266 Insert_Actions (Alloc, L); 4267 else 4268 Insert_Actions (Alloc, Init_Stmts); 4269 end if; 4270 end; 4271 4272 else 4273 Insert_Actions (Alloc, Late_Expansion (Aggr, Typ, Occ)); 4274 end if; 4275 end Convert_Aggr_In_Allocator; 4276 4277 -------------------------------- 4278 -- Convert_Aggr_In_Assignment -- 4279 -------------------------------- 4280 4281 procedure Convert_Aggr_In_Assignment (N : Node_Id) is 4282 Aggr : Node_Id := Expression (N); 4283 Typ : constant Entity_Id := Etype (Aggr); 4284 Occ : constant Node_Id := New_Copy_Tree (Name (N)); 4285 4286 begin 4287 if Nkind (Aggr) = N_Qualified_Expression then 4288 Aggr := Expression (Aggr); 4289 end if; 4290 4291 Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ)); 4292 end Convert_Aggr_In_Assignment; 4293 4294 --------------------------------- 4295 -- Convert_Aggr_In_Object_Decl -- 4296 --------------------------------- 4297 4298 procedure Convert_Aggr_In_Object_Decl (N : Node_Id) is 4299 Obj : constant Entity_Id := Defining_Identifier (N); 4300 Aggr : Node_Id := Expression (N); 4301 Loc : constant Source_Ptr := Sloc (Aggr); 4302 Typ : constant Entity_Id := Etype (Aggr); 4303 Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc); 4304 4305 Has_Transient_Scope : Boolean := False; 4306 4307 function Discriminants_Ok return Boolean; 4308 -- If the object type is constrained, the discriminants in the 4309 -- aggregate must be checked against the discriminants of the subtype. 4310 -- This cannot be done using Apply_Discriminant_Checks because after 4311 -- expansion there is no aggregate left to check. 4312 4313 ---------------------- 4314 -- Discriminants_Ok -- 4315 ---------------------- 4316 4317 function Discriminants_Ok return Boolean is 4318 Cond : Node_Id := Empty; 4319 Check : Node_Id; 4320 D : Entity_Id; 4321 Disc1 : Elmt_Id; 4322 Disc2 : Elmt_Id; 4323 Val1 : Node_Id; 4324 Val2 : Node_Id; 4325 4326 begin 4327 D := First_Discriminant (Typ); 4328 Disc1 := First_Elmt (Discriminant_Constraint (Typ)); 4329 Disc2 := First_Elmt (Discriminant_Constraint (Etype (Obj))); 4330 while Present (Disc1) and then Present (Disc2) loop 4331 Val1 := Node (Disc1); 4332 Val2 := Node (Disc2); 4333 4334 if not Is_OK_Static_Expression (Val1) 4335 or else not Is_OK_Static_Expression (Val2) 4336 then 4337 Check := Make_Op_Ne (Loc, 4338 Left_Opnd => Duplicate_Subexpr (Val1), 4339 Right_Opnd => Duplicate_Subexpr (Val2)); 4340 4341 if No (Cond) then 4342 Cond := Check; 4343 4344 else 4345 Cond := Make_Or_Else (Loc, 4346 Left_Opnd => Cond, 4347 Right_Opnd => Check); 4348 end if; 4349 4350 elsif Expr_Value (Val1) /= Expr_Value (Val2) then 4351 Apply_Compile_Time_Constraint_Error (Aggr, 4352 Msg => "incorrect value for discriminant&??", 4353 Reason => CE_Discriminant_Check_Failed, 4354 Ent => D); 4355 return False; 4356 end if; 4357 4358 Next_Discriminant (D); 4359 Next_Elmt (Disc1); 4360 Next_Elmt (Disc2); 4361 end loop; 4362 4363 -- If any discriminant constraint is nonstatic, emit a check 4364 4365 if Present (Cond) then 4366 Insert_Action (N, 4367 Make_Raise_Constraint_Error (Loc, 4368 Condition => Cond, 4369 Reason => CE_Discriminant_Check_Failed)); 4370 end if; 4371 4372 return True; 4373 end Discriminants_Ok; 4374 4375 -- Start of processing for Convert_Aggr_In_Object_Decl 4376 4377 begin 4378 Set_Assignment_OK (Occ); 4379 4380 if Nkind (Aggr) = N_Qualified_Expression then 4381 Aggr := Expression (Aggr); 4382 end if; 4383 4384 if Has_Discriminants (Typ) 4385 and then Typ /= Etype (Obj) 4386 and then Is_Constrained (Etype (Obj)) 4387 and then not Discriminants_Ok 4388 then 4389 return; 4390 end if; 4391 4392 -- If the context is an extended return statement, it has its own 4393 -- finalization machinery (i.e. works like a transient scope) and 4394 -- we do not want to create an additional one, because objects on 4395 -- the finalization list of the return must be moved to the caller's 4396 -- finalization list to complete the return. 4397 4398 -- Similarly if the aggregate is limited, it is built in place, and the 4399 -- controlled components are not assigned to intermediate temporaries 4400 -- so there is no need for a transient scope in this case either. 4401 4402 if Requires_Transient_Scope (Typ) 4403 and then Ekind (Current_Scope) /= E_Return_Statement 4404 and then not Is_Limited_Type (Typ) 4405 then 4406 Establish_Transient_Scope (Aggr, Manage_Sec_Stack => False); 4407 Has_Transient_Scope := True; 4408 end if; 4409 4410 declare 4411 Stmts : constant List_Id := Late_Expansion (Aggr, Typ, Occ); 4412 Stmt : Node_Id; 4413 Param : Node_Id; 4414 4415 begin 4416 -- If Obj is already frozen or if N is wrapped in a transient scope, 4417 -- Stmts do not need to be saved in Initialization_Statements since 4418 -- there is no freezing issue. 4419 4420 if Is_Frozen (Obj) or else Has_Transient_Scope then 4421 Insert_Actions_After (N, Stmts); 4422 else 4423 Stmt := Make_Compound_Statement (Sloc (N), Actions => Stmts); 4424 Insert_Action_After (N, Stmt); 4425 4426 -- Insert_Action_After may freeze Obj in which case we should 4427 -- remove the compound statement just created and simply insert 4428 -- Stmts after N. 4429 4430 if Is_Frozen (Obj) then 4431 Remove (Stmt); 4432 Insert_Actions_After (N, Stmts); 4433 else 4434 Set_Initialization_Statements (Obj, Stmt); 4435 end if; 4436 end if; 4437 4438 -- If Typ has controlled components and a call to a Slice_Assign 4439 -- procedure is part of the initialization statements, then we 4440 -- need to initialize the array component since Slice_Assign will 4441 -- need to adjust it. 4442 4443 if Has_Controlled_Component (Typ) then 4444 Stmt := First (Stmts); 4445 4446 while Present (Stmt) loop 4447 if Nkind (Stmt) = N_Procedure_Call_Statement 4448 and then Get_TSS_Name (Entity (Name (Stmt))) 4449 = TSS_Slice_Assign 4450 then 4451 Param := First (Parameter_Associations (Stmt)); 4452 Insert_Actions 4453 (Stmt, 4454 Build_Initialization_Call 4455 (Sloc (N), New_Copy_Tree (Param), Etype (Param))); 4456 end if; 4457 4458 Next (Stmt); 4459 end loop; 4460 end if; 4461 end; 4462 4463 Set_No_Initialization (N); 4464 4465 -- After expansion the expression can be removed from the declaration 4466 -- except if the object is class-wide, in which case the aggregate 4467 -- provides the actual type. 4468 4469 if not Is_Class_Wide_Type (Etype (Obj)) then 4470 Set_Expression (N, Empty); 4471 end if; 4472 4473 Initialize_Discriminants (N, Typ); 4474 end Convert_Aggr_In_Object_Decl; 4475 4476 ------------------------------------- 4477 -- Convert_Array_Aggr_In_Allocator -- 4478 ------------------------------------- 4479 4480 procedure Convert_Array_Aggr_In_Allocator 4481 (Decl : Node_Id; 4482 Aggr : Node_Id; 4483 Target : Node_Id) 4484 is 4485 Typ : constant Entity_Id := Etype (Aggr); 4486 Ctyp : constant Entity_Id := Component_Type (Typ); 4487 Aggr_Code : List_Id; 4488 New_Aggr : Node_Id; 4489 4490 begin 4491 -- The target is an explicit dereference of the allocated object 4492 4493 -- If the assignment can be done directly by the back end, then 4494 -- reset Set_Expansion_Delayed and do not expand further. 4495 4496 if not CodePeer_Mode 4497 and then not Modify_Tree_For_C 4498 and then Aggr_Assignment_OK_For_Backend (Aggr) 4499 then 4500 New_Aggr := New_Copy_Tree (Aggr); 4501 Set_Expansion_Delayed (New_Aggr, False); 4502 4503 Aggr_Code := 4504 New_List ( 4505 Make_OK_Assignment_Statement (Sloc (New_Aggr), 4506 Name => Target, 4507 Expression => New_Aggr)); 4508 4509 -- Or else, generate component assignments to it, as for an aggregate 4510 -- that appears on the right-hand side of an assignment statement. 4511 4512 else 4513 Aggr_Code := 4514 Build_Array_Aggr_Code (Aggr, 4515 Ctype => Ctyp, 4516 Index => First_Index (Typ), 4517 Into => Target, 4518 Scalar_Comp => Is_Scalar_Type (Ctyp)); 4519 end if; 4520 4521 Insert_Actions_After (Decl, Aggr_Code); 4522 end Convert_Array_Aggr_In_Allocator; 4523 4524 ------------------------ 4525 -- In_Place_Assign_OK -- 4526 ------------------------ 4527 4528 function In_Place_Assign_OK 4529 (N : Node_Id; 4530 Target_Object : Entity_Id := Empty) return Boolean 4531 is 4532 Is_Array : constant Boolean := Is_Array_Type (Etype (N)); 4533 4534 Aggr_In : Node_Id; 4535 Aggr_Bounds : Range_Nodes; 4536 Obj_In : Node_Id; 4537 Obj_Bounds : Range_Nodes; 4538 Parent_Kind : Node_Kind; 4539 Parent_Node : Node_Id; 4540 4541 function Safe_Aggregate (Aggr : Node_Id) return Boolean; 4542 -- Check recursively that each component of a (sub)aggregate does not 4543 -- depend on the variable being assigned to. 4544 4545 function Safe_Component (Expr : Node_Id) return Boolean; 4546 -- Verify that an expression cannot depend on the target being assigned 4547 -- to. Return true for compile-time known values, stand-alone objects, 4548 -- parameters passed by copy, calls to functions that return by copy, 4549 -- selected components thereof only if the aggregate's type is an array, 4550 -- indexed components and slices thereof only if the aggregate's type is 4551 -- a record, and simple expressions involving only these as operands. 4552 -- This is OK whatever the target because, for a component to overlap 4553 -- with the target, it must be either a direct reference to a component 4554 -- of the target, in which case there must be a matching selection or 4555 -- indexation or slicing, or an indirect reference to such a component, 4556 -- which is excluded by the above condition. Additionally, if the target 4557 -- is statically known, return true for arbitrarily nested selections, 4558 -- indexations or slicings, provided that their ultimate prefix is not 4559 -- the target itself. 4560 4561 -------------------- 4562 -- Safe_Aggregate -- 4563 -------------------- 4564 4565 function Safe_Aggregate (Aggr : Node_Id) return Boolean is 4566 Expr : Node_Id; 4567 4568 begin 4569 if Nkind (Parent (Aggr)) = N_Iterated_Component_Association then 4570 return False; 4571 end if; 4572 4573 if Present (Expressions (Aggr)) then 4574 Expr := First (Expressions (Aggr)); 4575 while Present (Expr) loop 4576 if Nkind (Expr) = N_Aggregate then 4577 if not Safe_Aggregate (Expr) then 4578 return False; 4579 end if; 4580 4581 elsif not Safe_Component (Expr) then 4582 return False; 4583 end if; 4584 4585 Next (Expr); 4586 end loop; 4587 end if; 4588 4589 if Present (Component_Associations (Aggr)) then 4590 Expr := First (Component_Associations (Aggr)); 4591 while Present (Expr) loop 4592 if Nkind (Expression (Expr)) = N_Aggregate then 4593 if not Safe_Aggregate (Expression (Expr)) then 4594 return False; 4595 end if; 4596 4597 -- If association has a box, no way to determine yet whether 4598 -- default can be assigned in place. 4599 4600 elsif Box_Present (Expr) then 4601 return False; 4602 4603 elsif not Safe_Component (Expression (Expr)) then 4604 return False; 4605 end if; 4606 4607 Next (Expr); 4608 end loop; 4609 end if; 4610 4611 return True; 4612 end Safe_Aggregate; 4613 4614 -------------------- 4615 -- Safe_Component -- 4616 -------------------- 4617 4618 function Safe_Component (Expr : Node_Id) return Boolean is 4619 Comp : Node_Id := Expr; 4620 4621 function Check_Component (C : Node_Id; T_OK : Boolean) return Boolean; 4622 -- Do the recursive traversal, after copy. If T_OK is True, return 4623 -- True for a stand-alone object only if the target is statically 4624 -- known and distinct from the object. At the top level, we start 4625 -- with T_OK set to False and set it to True at a deeper level only 4626 -- if we cannot disambiguate the component here without statically 4627 -- knowing the target. Note that this is not optimal, we should do 4628 -- something along the lines of Denotes_Same_Prefix for that. 4629 4630 --------------------- 4631 -- Check_Component -- 4632 --------------------- 4633 4634 function Check_Component (C : Node_Id; T_OK : Boolean) return Boolean 4635 is 4636 4637 function SDO (E : Entity_Id) return Uint; 4638 -- Return the Scope Depth Of the enclosing dynamic scope of E 4639 4640 --------- 4641 -- SDO -- 4642 --------- 4643 4644 function SDO (E : Entity_Id) return Uint is 4645 begin 4646 return Scope_Depth (Enclosing_Dynamic_Scope (E)); 4647 end SDO; 4648 4649 -- Start of processing for Check_Component 4650 4651 begin 4652 if Is_Overloaded (C) then 4653 return False; 4654 4655 elsif Compile_Time_Known_Value (C) then 4656 return True; 4657 end if; 4658 4659 case Nkind (C) is 4660 when N_Attribute_Reference => 4661 return Check_Component (Prefix (C), T_OK); 4662 4663 when N_Function_Call => 4664 if Nkind (Name (C)) = N_Explicit_Dereference then 4665 return not Returns_By_Ref (Etype (Name (C))); 4666 else 4667 return not Returns_By_Ref (Entity (Name (C))); 4668 end if; 4669 4670 when N_Indexed_Component | N_Slice => 4671 -- In a target record, these operations cannot determine 4672 -- alone a component so we can recurse whatever the target. 4673 return Check_Component (Prefix (C), T_OK or else Is_Array); 4674 4675 when N_Selected_Component => 4676 -- In a target array, this operation cannot determine alone 4677 -- a component so we can recurse whatever the target. 4678 return 4679 Check_Component (Prefix (C), T_OK or else not Is_Array); 4680 4681 when N_Type_Conversion | N_Unchecked_Type_Conversion => 4682 return Check_Component (Expression (C), T_OK); 4683 4684 when N_Binary_Op => 4685 return Check_Component (Left_Opnd (C), T_OK) 4686 and then Check_Component (Right_Opnd (C), T_OK); 4687 4688 when N_Unary_Op => 4689 return Check_Component (Right_Opnd (C), T_OK); 4690 4691 when others => 4692 if Is_Entity_Name (C) and then Is_Object (Entity (C)) then 4693 -- Case of a formal parameter component. It's either 4694 -- trivial if passed by copy or very annoying if not, 4695 -- because in the latter case it's almost equivalent 4696 -- to a dereference, so the path-based disambiguation 4697 -- logic is totally off and we always need the target. 4698 4699 if Is_Formal (Entity (C)) then 4700 4701 -- If it is passed by copy, then this is safe 4702 4703 if Mechanism (Entity (C)) = By_Copy then 4704 return True; 4705 4706 -- Otherwise, this is safe if the target is present 4707 -- and is at least as deeply nested as the component. 4708 4709 else 4710 return Present (Target_Object) 4711 and then not Is_Formal (Target_Object) 4712 and then SDO (Target_Object) >= SDO (Entity (C)); 4713 end if; 4714 4715 -- For a renamed object, recurse 4716 4717 elsif Present (Renamed_Object (Entity (C))) then 4718 return 4719 Check_Component (Renamed_Object (Entity (C)), T_OK); 4720 4721 -- If this is safe whatever the target, we are done 4722 4723 elsif not T_OK then 4724 return True; 4725 4726 -- If there is no target or the component is the target, 4727 -- this is not safe. 4728 4729 elsif No (Target_Object) 4730 or else Entity (C) = Target_Object 4731 then 4732 return False; 4733 4734 -- Case of a formal parameter target. This is safe if it 4735 -- is at most as deeply nested as the component. 4736 4737 elsif Is_Formal (Target_Object) then 4738 return SDO (Target_Object) <= SDO (Entity (C)); 4739 4740 -- For distinct stand-alone objects, this is safe 4741 4742 else 4743 return True; 4744 end if; 4745 4746 -- For anything else than an object, this is not safe 4747 4748 else 4749 return False; 4750 end if; 4751 end case; 4752 end Check_Component; 4753 4754 -- Start of processing for Safe_Component 4755 4756 begin 4757 -- If the component appears in an association that may correspond 4758 -- to more than one element, it is not analyzed before expansion 4759 -- into assignments, to avoid side effects. We analyze, but do not 4760 -- resolve the copy, to obtain sufficient entity information for 4761 -- the checks that follow. If component is overloaded we assume 4762 -- an unsafe function call. 4763 4764 if not Analyzed (Comp) then 4765 if Is_Overloaded (Expr) then 4766 return False; 4767 4768 elsif Nkind (Expr) = N_Allocator then 4769 4770 -- For now, too complex to analyze 4771 4772 return False; 4773 4774 elsif Nkind (Parent (Expr)) = N_Iterated_Component_Association then 4775 4776 -- Ditto for iterated component associations, which in general 4777 -- require an enclosing loop and involve nonstatic expressions. 4778 4779 return False; 4780 end if; 4781 4782 Comp := New_Copy_Tree (Expr); 4783 Set_Parent (Comp, Parent (Expr)); 4784 Analyze (Comp); 4785 end if; 4786 4787 if Nkind (Comp) = N_Aggregate then 4788 return Safe_Aggregate (Comp); 4789 else 4790 return Check_Component (Comp, False); 4791 end if; 4792 end Safe_Component; 4793 4794 -- Start of processing for In_Place_Assign_OK 4795 4796 begin 4797 -- By-copy semantic cannot be guaranteed for controlled objects 4798 4799 if Needs_Finalization (Etype (N)) then 4800 return False; 4801 end if; 4802 4803 Parent_Node := Parent (N); 4804 Parent_Kind := Nkind (Parent_Node); 4805 4806 if Parent_Kind = N_Qualified_Expression then 4807 Parent_Node := Parent (Parent_Node); 4808 Parent_Kind := Nkind (Parent_Node); 4809 end if; 4810 4811 -- On assignment, sliding can take place, so we cannot do the 4812 -- assignment in place unless the bounds of the aggregate are 4813 -- statically equal to those of the target. 4814 4815 -- If the aggregate is given by an others choice, the bounds are 4816 -- derived from the left-hand side, and the assignment is safe if 4817 -- the expression is. 4818 4819 if Is_Array 4820 and then Present (Component_Associations (N)) 4821 and then not Is_Others_Aggregate (N) 4822 then 4823 Aggr_In := First_Index (Etype (N)); 4824 4825 -- Context is an assignment 4826 4827 if Parent_Kind = N_Assignment_Statement then 4828 Obj_In := First_Index (Etype (Name (Parent_Node))); 4829 4830 -- Context is an allocator. Check the bounds of the aggregate against 4831 -- those of the designated type, except in the case where the type is 4832 -- unconstrained (and then we can directly return true, see below). 4833 4834 else pragma Assert (Parent_Kind = N_Allocator); 4835 declare 4836 Desig_Typ : constant Entity_Id := 4837 Designated_Type (Etype (Parent_Node)); 4838 begin 4839 if not Is_Constrained (Desig_Typ) then 4840 return True; 4841 end if; 4842 4843 Obj_In := First_Index (Desig_Typ); 4844 end; 4845 end if; 4846 4847 while Present (Aggr_In) loop 4848 Aggr_Bounds := Get_Index_Bounds (Aggr_In); 4849 Obj_Bounds := Get_Index_Bounds (Obj_In); 4850 4851 -- We require static bounds for the target and a static matching 4852 -- of low bound for the aggregate. 4853 4854 if not Compile_Time_Known_Value (Obj_Bounds.First) 4855 or else not Compile_Time_Known_Value (Obj_Bounds.Last) 4856 or else not Compile_Time_Known_Value (Aggr_Bounds.First) 4857 or else Expr_Value (Aggr_Bounds.First) /= 4858 Expr_Value (Obj_Bounds.First) 4859 then 4860 return False; 4861 4862 -- For an assignment statement we require static matching of 4863 -- bounds. Ditto for an allocator whose qualified expression 4864 -- is a constrained type. If the expression in the allocator 4865 -- is an unconstrained array, we accept an upper bound that 4866 -- is not static, to allow for nonstatic expressions of the 4867 -- base type. Clearly there are further possibilities (with 4868 -- diminishing returns) for safely building arrays in place 4869 -- here. 4870 4871 elsif Parent_Kind = N_Assignment_Statement 4872 or else Is_Constrained (Etype (Parent_Node)) 4873 then 4874 if not Compile_Time_Known_Value (Aggr_Bounds.Last) 4875 or else Expr_Value (Aggr_Bounds.Last) /= 4876 Expr_Value (Obj_Bounds.Last) 4877 then 4878 return False; 4879 end if; 4880 end if; 4881 4882 Next_Index (Aggr_In); 4883 Next_Index (Obj_In); 4884 end loop; 4885 end if; 4886 4887 -- Now check the component values themselves, except for an allocator 4888 -- for which the target is newly allocated memory. 4889 4890 if Parent_Kind = N_Allocator then 4891 return True; 4892 else 4893 return Safe_Aggregate (N); 4894 end if; 4895 end In_Place_Assign_OK; 4896 4897 ---------------------------- 4898 -- Convert_To_Assignments -- 4899 ---------------------------- 4900 4901 procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is 4902 Loc : constant Source_Ptr := Sloc (N); 4903 T : Entity_Id; 4904 Temp : Entity_Id; 4905 4906 Aggr_Code : List_Id; 4907 Instr : Node_Id; 4908 Target_Expr : Node_Id; 4909 Parent_Kind : Node_Kind; 4910 Unc_Decl : Boolean := False; 4911 Parent_Node : Node_Id; 4912 4913 begin 4914 pragma Assert (Nkind (N) in N_Aggregate | N_Extension_Aggregate); 4915 pragma Assert (not Is_Static_Dispatch_Table_Aggregate (N)); 4916 pragma Assert (Is_Record_Type (Typ)); 4917 4918 Parent_Node := Parent (N); 4919 Parent_Kind := Nkind (Parent_Node); 4920 4921 if Parent_Kind = N_Qualified_Expression then 4922 -- Check if we are in an unconstrained declaration because in this 4923 -- case the current delayed expansion mechanism doesn't work when 4924 -- the declared object size depends on the initializing expr. 4925 4926 Parent_Node := Parent (Parent_Node); 4927 Parent_Kind := Nkind (Parent_Node); 4928 4929 if Parent_Kind = N_Object_Declaration then 4930 Unc_Decl := 4931 not Is_Entity_Name (Object_Definition (Parent_Node)) 4932 or else (Nkind (N) = N_Aggregate 4933 and then 4934 Has_Discriminants 4935 (Entity (Object_Definition (Parent_Node)))) 4936 or else Is_Class_Wide_Type 4937 (Entity (Object_Definition (Parent_Node))); 4938 end if; 4939 end if; 4940 4941 -- Just set the Delay flag in the cases where the transformation will be 4942 -- done top down from above. 4943 4944 if 4945 -- Internal aggregate (transformed when expanding the parent) 4946 4947 Parent_Kind in 4948 N_Aggregate | N_Extension_Aggregate | N_Component_Association 4949 4950 -- Allocator (see Convert_Aggr_In_Allocator) 4951 4952 or else Parent_Kind = N_Allocator 4953 4954 -- Object declaration (see Convert_Aggr_In_Object_Decl) 4955 4956 or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl) 4957 4958 -- Safe assignment (see Convert_Aggr_Assignments). So far only the 4959 -- assignments in init procs are taken into account. 4960 4961 or else (Parent_Kind = N_Assignment_Statement 4962 and then Inside_Init_Proc) 4963 4964 -- (Ada 2005) An inherently limited type in a return statement, which 4965 -- will be handled in a build-in-place fashion, and may be rewritten 4966 -- as an extended return and have its own finalization machinery. 4967 -- In the case of a simple return, the aggregate needs to be delayed 4968 -- until the scope for the return statement has been created, so 4969 -- that any finalization chain will be associated with that scope. 4970 -- For extended returns, we delay expansion to avoid the creation 4971 -- of an unwanted transient scope that could result in premature 4972 -- finalization of the return object (which is built in place 4973 -- within the caller's scope). 4974 4975 or else Is_Build_In_Place_Aggregate_Return (N) 4976 then 4977 Set_Expansion_Delayed (N); 4978 return; 4979 end if; 4980 4981 -- Otherwise, if a transient scope is required, create it now. If we 4982 -- are within an initialization procedure do not create such, because 4983 -- the target of the assignment must not be declared within a local 4984 -- block, and because cleanup will take place on return from the 4985 -- initialization procedure. 4986 4987 -- Should the condition be more restrictive ??? 4988 4989 if Requires_Transient_Scope (Typ) and then not Inside_Init_Proc then 4990 Establish_Transient_Scope (N, Manage_Sec_Stack => False); 4991 end if; 4992 4993 -- If the aggregate is nonlimited, create a temporary, since aggregates 4994 -- have "by copy" semantics. If it is limited and context is an 4995 -- assignment, this is a subaggregate for an enclosing aggregate being 4996 -- expanded. It must be built in place, so use target of the current 4997 -- assignment. 4998 4999 if Is_Limited_Type (Typ) 5000 and then Parent_Kind = N_Assignment_Statement 5001 then 5002 Target_Expr := New_Copy_Tree (Name (Parent_Node)); 5003 Insert_Actions (Parent_Node, 5004 Build_Record_Aggr_Code (N, Typ, Target_Expr)); 5005 Rewrite (Parent_Node, Make_Null_Statement (Loc)); 5006 5007 -- Do not declare a temporary to initialize an aggregate assigned to 5008 -- a target when in-place assignment is possible, i.e. preserving the 5009 -- by-copy semantic of aggregates. This avoids large stack usage and 5010 -- generates more efficient code. 5011 5012 elsif Parent_Kind = N_Assignment_Statement 5013 and then In_Place_Assign_OK (N, Get_Base_Object (Name (Parent_Node))) 5014 then 5015 declare 5016 Lhs : constant Node_Id := Name (Parent_Node); 5017 begin 5018 -- Apply discriminant check if required 5019 5020 if Has_Discriminants (Etype (N)) then 5021 Apply_Discriminant_Check (N, Etype (Lhs), Lhs); 5022 end if; 5023 5024 -- The check just above may have replaced the aggregate with a CE 5025 5026 if Nkind (N) in N_Aggregate | N_Extension_Aggregate then 5027 Target_Expr := New_Copy_Tree (Lhs); 5028 Insert_Actions (Parent_Node, 5029 Build_Record_Aggr_Code (N, Typ, Target_Expr)); 5030 Rewrite (Parent_Node, Make_Null_Statement (Loc)); 5031 end if; 5032 end; 5033 5034 else 5035 Temp := Make_Temporary (Loc, 'A', N); 5036 5037 -- If the type inherits unknown discriminants, use the view with 5038 -- known discriminants if available. 5039 5040 if Has_Unknown_Discriminants (Typ) 5041 and then Present (Underlying_Record_View (Typ)) 5042 then 5043 T := Underlying_Record_View (Typ); 5044 else 5045 T := Typ; 5046 end if; 5047 5048 Instr := 5049 Make_Object_Declaration (Loc, 5050 Defining_Identifier => Temp, 5051 Object_Definition => New_Occurrence_Of (T, Loc)); 5052 5053 Set_No_Initialization (Instr); 5054 Insert_Action (N, Instr); 5055 Initialize_Discriminants (Instr, T); 5056 5057 Target_Expr := New_Occurrence_Of (Temp, Loc); 5058 Aggr_Code := Build_Record_Aggr_Code (N, T, Target_Expr); 5059 5060 -- Save the last assignment statement associated with the aggregate 5061 -- when building a controlled object. This reference is utilized by 5062 -- the finalization machinery when marking an object as successfully 5063 -- initialized. 5064 5065 if Needs_Finalization (T) then 5066 Set_Last_Aggregate_Assignment (Temp, Last (Aggr_Code)); 5067 end if; 5068 5069 Insert_Actions (N, Aggr_Code); 5070 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 5071 Analyze_And_Resolve (N, T); 5072 end if; 5073 end Convert_To_Assignments; 5074 5075 --------------------------- 5076 -- Convert_To_Positional -- 5077 --------------------------- 5078 5079 procedure Convert_To_Positional 5080 (N : Node_Id; 5081 Handle_Bit_Packed : Boolean := False) 5082 is 5083 Typ : constant Entity_Id := Etype (N); 5084 Dims : constant Nat := Number_Dimensions (Typ); 5085 Max_Others_Replicate : constant Nat := Max_Aggregate_Size (N); 5086 5087 Static_Components : Boolean := True; 5088 5089 procedure Check_Static_Components; 5090 -- Check whether all components of the aggregate are compile-time known 5091 -- values, and can be passed as is to the back-end without further 5092 -- expansion. 5093 5094 function Flatten 5095 (N : Node_Id; 5096 Dims : Nat; 5097 Ix : Node_Id; 5098 Ixb : Node_Id) return Boolean; 5099 -- Convert the aggregate into a purely positional form if possible after 5100 -- checking that the bounds of all dimensions are known to be static. 5101 5102 function Is_Flat (N : Node_Id; Dims : Nat) return Boolean; 5103 -- Return True if the aggregate N is flat (which is not trivial in the 5104 -- case of multidimensional aggregates). 5105 5106 function Is_Static_Element (N : Node_Id; Dims : Nat) return Boolean; 5107 -- Return True if N, an element of a component association list, i.e. 5108 -- N_Component_Association or N_Iterated_Component_Association, has a 5109 -- compile-time known value and can be passed as is to the back-end 5110 -- without further expansion. 5111 -- An Iterated_Component_Association is treated as nonstatic in most 5112 -- cases for now, so there are possibilities for optimization. 5113 5114 ----------------------------- 5115 -- Check_Static_Components -- 5116 ----------------------------- 5117 5118 -- Could use some comments in this body ??? 5119 5120 procedure Check_Static_Components is 5121 Assoc : Node_Id; 5122 Expr : Node_Id; 5123 5124 begin 5125 Static_Components := True; 5126 5127 if Nkind (N) = N_String_Literal then 5128 null; 5129 5130 elsif Present (Expressions (N)) then 5131 Expr := First (Expressions (N)); 5132 while Present (Expr) loop 5133 if Nkind (Expr) /= N_Aggregate 5134 or else not Compile_Time_Known_Aggregate (Expr) 5135 or else Expansion_Delayed (Expr) 5136 then 5137 Static_Components := False; 5138 exit; 5139 end if; 5140 5141 Next (Expr); 5142 end loop; 5143 end if; 5144 5145 if Nkind (N) = N_Aggregate 5146 and then Present (Component_Associations (N)) 5147 then 5148 Assoc := First (Component_Associations (N)); 5149 while Present (Assoc) loop 5150 if not Is_Static_Element (Assoc, Dims) then 5151 Static_Components := False; 5152 exit; 5153 end if; 5154 5155 Next (Assoc); 5156 end loop; 5157 end if; 5158 end Check_Static_Components; 5159 5160 ------------- 5161 -- Flatten -- 5162 ------------- 5163 5164 function Flatten 5165 (N : Node_Id; 5166 Dims : Nat; 5167 Ix : Node_Id; 5168 Ixb : Node_Id) return Boolean 5169 is 5170 Loc : constant Source_Ptr := Sloc (N); 5171 Blo : constant Node_Id := Type_Low_Bound (Etype (Ixb)); 5172 Lo : constant Node_Id := Type_Low_Bound (Etype (Ix)); 5173 Hi : constant Node_Id := Type_High_Bound (Etype (Ix)); 5174 5175 function Cannot_Flatten_Next_Aggr (Expr : Node_Id) return Boolean; 5176 -- Return true if Expr is an aggregate for the next dimension that 5177 -- cannot be recursively flattened. 5178 5179 ------------------------------ 5180 -- Cannot_Flatten_Next_Aggr -- 5181 ------------------------------ 5182 5183 function Cannot_Flatten_Next_Aggr (Expr : Node_Id) return Boolean is 5184 begin 5185 return Nkind (Expr) = N_Aggregate 5186 and then Present (Next_Index (Ix)) 5187 and then not 5188 Flatten (Expr, Dims - 1, Next_Index (Ix), Next_Index (Ixb)); 5189 end Cannot_Flatten_Next_Aggr; 5190 5191 -- Local variables 5192 5193 Lov : Uint; 5194 Hiv : Uint; 5195 Others_Present : Boolean; 5196 5197 -- Start of processing for Flatten 5198 5199 begin 5200 if Nkind (Original_Node (N)) = N_String_Literal then 5201 return True; 5202 end if; 5203 5204 if not Compile_Time_Known_Value (Lo) 5205 or else not Compile_Time_Known_Value (Hi) 5206 then 5207 return False; 5208 end if; 5209 5210 Lov := Expr_Value (Lo); 5211 Hiv := Expr_Value (Hi); 5212 5213 -- Check if there is an others choice 5214 5215 Others_Present := False; 5216 5217 if Present (Component_Associations (N)) then 5218 declare 5219 Assoc : Node_Id; 5220 Choice : Node_Id; 5221 5222 begin 5223 Assoc := First (Component_Associations (N)); 5224 while Present (Assoc) loop 5225 5226 -- If this is a box association, flattening is in general 5227 -- not possible because at this point we cannot tell if the 5228 -- default is static or even exists. 5229 5230 if Box_Present (Assoc) then 5231 return False; 5232 5233 elsif Nkind (Assoc) = N_Iterated_Component_Association then 5234 return False; 5235 end if; 5236 5237 Choice := First (Choice_List (Assoc)); 5238 5239 while Present (Choice) loop 5240 if Nkind (Choice) = N_Others_Choice then 5241 Others_Present := True; 5242 end if; 5243 5244 Next (Choice); 5245 end loop; 5246 5247 Next (Assoc); 5248 end loop; 5249 end; 5250 end if; 5251 5252 -- If the low bound is not known at compile time and others is not 5253 -- present we can proceed since the bounds can be obtained from the 5254 -- aggregate. 5255 5256 if Hiv < Lov 5257 or else (not Compile_Time_Known_Value (Blo) and then Others_Present) 5258 then 5259 return False; 5260 end if; 5261 5262 -- Determine if set of alternatives is suitable for conversion and 5263 -- build an array containing the values in sequence. 5264 5265 declare 5266 Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv)) 5267 of Node_Id := (others => Empty); 5268 -- The values in the aggregate sorted appropriately 5269 5270 Vlist : List_Id; 5271 -- Same data as Vals in list form 5272 5273 Rep_Count : Nat; 5274 -- Used to validate Max_Others_Replicate limit 5275 5276 Elmt : Node_Id; 5277 Expr : Node_Id; 5278 Num : Int := UI_To_Int (Lov); 5279 Choice_Index : Int; 5280 Choice : Node_Id; 5281 Lo, Hi : Node_Id; 5282 5283 begin 5284 if Present (Expressions (N)) then 5285 Elmt := First (Expressions (N)); 5286 while Present (Elmt) loop 5287 -- In the case of a multidimensional array, check that the 5288 -- aggregate can be recursively flattened. 5289 5290 if Cannot_Flatten_Next_Aggr (Elmt) then 5291 return False; 5292 end if; 5293 5294 -- Duplicate expression for each index it covers 5295 5296 Vals (Num) := New_Copy_Tree (Elmt); 5297 Num := Num + 1; 5298 5299 Next (Elmt); 5300 end loop; 5301 end if; 5302 5303 if No (Component_Associations (N)) then 5304 return True; 5305 end if; 5306 5307 Elmt := First (Component_Associations (N)); 5308 5309 Component_Loop : while Present (Elmt) loop 5310 Expr := Expression (Elmt); 5311 5312 -- In the case of a multidimensional array, check that the 5313 -- aggregate can be recursively flattened. 5314 5315 if Cannot_Flatten_Next_Aggr (Expr) then 5316 return False; 5317 end if; 5318 5319 Choice := First (Choice_List (Elmt)); 5320 Choice_Loop : while Present (Choice) loop 5321 5322 -- If we have an others choice, fill in the missing elements 5323 -- subject to the limit established by Max_Others_Replicate. 5324 5325 if Nkind (Choice) = N_Others_Choice then 5326 Rep_Count := 0; 5327 5328 -- If the expression involves a construct that generates 5329 -- a loop, we must generate individual assignments and 5330 -- no flattening is possible. 5331 5332 if Nkind (Expr) = N_Quantified_Expression then 5333 return False; 5334 end if; 5335 5336 for J in Vals'Range loop 5337 if No (Vals (J)) then 5338 Vals (J) := New_Copy_Tree (Expr); 5339 Rep_Count := Rep_Count + 1; 5340 5341 -- Check for maximum others replication. Note that 5342 -- we skip this test if either of the restrictions 5343 -- No_Implicit_Loops or No_Elaboration_Code is 5344 -- active, if this is a preelaborable unit or 5345 -- a predefined unit, or if the unit must be 5346 -- placed in data memory. This also ensures that 5347 -- predefined units get the same level of constant 5348 -- folding in Ada 95 and Ada 2005, where their 5349 -- categorization has changed. 5350 5351 declare 5352 P : constant Entity_Id := 5353 Cunit_Entity (Current_Sem_Unit); 5354 5355 begin 5356 -- Check if duplication is always OK and, if so, 5357 -- continue processing. 5358 5359 if Restriction_Active (No_Implicit_Loops) then 5360 null; 5361 5362 -- If duplication is not always OK, continue 5363 -- only if either the element is static or is 5364 -- an aggregate (we already know it is OK). 5365 5366 elsif not Is_Static_Element (Elmt, Dims) 5367 and then Nkind (Expr) /= N_Aggregate 5368 then 5369 return False; 5370 5371 -- Check if duplication is OK for elaboration 5372 -- purposes and, if so, continue processing. 5373 5374 elsif Restriction_Active (No_Elaboration_Code) 5375 or else 5376 (Ekind (Current_Scope) = E_Package 5377 and then 5378 Static_Elaboration_Desired (Current_Scope)) 5379 or else Is_Preelaborated (P) 5380 or else (Ekind (P) = E_Package_Body 5381 and then 5382 Is_Preelaborated (Spec_Entity (P))) 5383 or else 5384 Is_Predefined_Unit (Get_Source_Unit (P)) 5385 then 5386 null; 5387 5388 -- Otherwise, check that the replication count 5389 -- is not too high. 5390 5391 elsif Rep_Count > Max_Others_Replicate then 5392 return False; 5393 end if; 5394 end; 5395 end if; 5396 end loop; 5397 5398 if Rep_Count = 0 5399 and then Warn_On_Redundant_Constructs 5400 then 5401 Error_Msg_N ("there are no others?r?", Elmt); 5402 end if; 5403 5404 exit Component_Loop; 5405 5406 -- Case of a subtype mark, identifier or expanded name 5407 5408 elsif Is_Entity_Name (Choice) 5409 and then Is_Type (Entity (Choice)) 5410 then 5411 Lo := Type_Low_Bound (Etype (Choice)); 5412 Hi := Type_High_Bound (Etype (Choice)); 5413 5414 -- Case of subtype indication 5415 5416 elsif Nkind (Choice) = N_Subtype_Indication then 5417 Lo := Low_Bound (Range_Expression (Constraint (Choice))); 5418 Hi := High_Bound (Range_Expression (Constraint (Choice))); 5419 5420 -- Case of a range 5421 5422 elsif Nkind (Choice) = N_Range then 5423 Lo := Low_Bound (Choice); 5424 Hi := High_Bound (Choice); 5425 5426 -- Normal subexpression case 5427 5428 else pragma Assert (Nkind (Choice) in N_Subexpr); 5429 if not Compile_Time_Known_Value (Choice) then 5430 return False; 5431 5432 else 5433 Choice_Index := UI_To_Int (Expr_Value (Choice)); 5434 5435 if Choice_Index in Vals'Range then 5436 Vals (Choice_Index) := New_Copy_Tree (Expr); 5437 goto Continue; 5438 5439 -- Choice is statically out-of-range, will be 5440 -- rewritten to raise Constraint_Error. 5441 5442 else 5443 return False; 5444 end if; 5445 end if; 5446 end if; 5447 5448 -- Range cases merge with Lo,Hi set 5449 5450 if not Compile_Time_Known_Value (Lo) 5451 or else 5452 not Compile_Time_Known_Value (Hi) 5453 then 5454 return False; 5455 5456 else 5457 for J in UI_To_Int (Expr_Value (Lo)) .. 5458 UI_To_Int (Expr_Value (Hi)) 5459 loop 5460 Vals (J) := New_Copy_Tree (Expr); 5461 end loop; 5462 end if; 5463 5464 <<Continue>> 5465 Next (Choice); 5466 end loop Choice_Loop; 5467 5468 Next (Elmt); 5469 end loop Component_Loop; 5470 5471 -- If we get here the conversion is possible 5472 5473 Vlist := New_List; 5474 for J in Vals'Range loop 5475 Append (Vals (J), Vlist); 5476 end loop; 5477 5478 Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist)); 5479 Set_Aggregate_Bounds (N, Aggregate_Bounds (Original_Node (N))); 5480 return True; 5481 end; 5482 end Flatten; 5483 5484 ------------- 5485 -- Is_Flat -- 5486 ------------- 5487 5488 function Is_Flat (N : Node_Id; Dims : Nat) return Boolean is 5489 Elmt : Node_Id; 5490 5491 begin 5492 if Dims = 0 then 5493 return True; 5494 5495 elsif Nkind (N) = N_Aggregate then 5496 if Present (Component_Associations (N)) then 5497 return False; 5498 5499 else 5500 Elmt := First (Expressions (N)); 5501 while Present (Elmt) loop 5502 if not Is_Flat (Elmt, Dims - 1) then 5503 return False; 5504 end if; 5505 5506 Next (Elmt); 5507 end loop; 5508 5509 return True; 5510 end if; 5511 else 5512 return True; 5513 end if; 5514 end Is_Flat; 5515 5516 ------------------------- 5517 -- Is_Static_Element -- 5518 ------------------------- 5519 5520 function Is_Static_Element (N : Node_Id; Dims : Nat) return Boolean is 5521 Expr : constant Node_Id := Expression (N); 5522 5523 begin 5524 -- In most cases the interesting expressions are unambiguously static 5525 5526 if Compile_Time_Known_Value (Expr) then 5527 return True; 5528 5529 elsif Nkind (N) = N_Iterated_Component_Association then 5530 return False; 5531 5532 elsif Nkind (Expr) = N_Aggregate 5533 and then Compile_Time_Known_Aggregate (Expr) 5534 and then not Expansion_Delayed (Expr) 5535 then 5536 return True; 5537 5538 -- However, one may write static expressions that are syntactically 5539 -- ambiguous, so preanalyze the expression before checking it again, 5540 -- but only at the innermost level for a multidimensional array. 5541 5542 elsif Dims = 1 then 5543 Preanalyze_And_Resolve (Expr, Component_Type (Typ)); 5544 return Compile_Time_Known_Value (Expr); 5545 5546 else 5547 return False; 5548 end if; 5549 end Is_Static_Element; 5550 5551 -- Start of processing for Convert_To_Positional 5552 5553 begin 5554 -- Only convert to positional when generating C in case of an 5555 -- object declaration, this is the only case where aggregates are 5556 -- supported in C. 5557 5558 if Modify_Tree_For_C and then not Is_CCG_Supported_Aggregate (N) then 5559 return; 5560 end if; 5561 5562 -- Ada 2005 (AI-287): Do not convert in case of default initialized 5563 -- components because in this case will need to call the corresponding 5564 -- IP procedure. 5565 5566 if Has_Default_Init_Comps (N) then 5567 return; 5568 end if; 5569 5570 -- A subaggregate may have been flattened but is not known to be 5571 -- Compile_Time_Known. Set that flag in cases that cannot require 5572 -- elaboration code, so that the aggregate can be used as the 5573 -- initial value of a thread-local variable. 5574 5575 if Is_Flat (N, Dims) then 5576 if Static_Array_Aggregate (N) then 5577 Set_Compile_Time_Known_Aggregate (N); 5578 end if; 5579 5580 return; 5581 end if; 5582 5583 if Is_Bit_Packed_Array (Typ) and then not Handle_Bit_Packed then 5584 return; 5585 end if; 5586 5587 -- Do not convert to positional if controlled components are involved 5588 -- since these require special processing 5589 5590 if Has_Controlled_Component (Typ) then 5591 return; 5592 end if; 5593 5594 Check_Static_Components; 5595 5596 -- If the size is known, or all the components are static, try to 5597 -- build a fully positional aggregate. 5598 5599 -- The size of the type may not be known for an aggregate with 5600 -- discriminated array components, but if the components are static 5601 -- it is still possible to verify statically that the length is 5602 -- compatible with the upper bound of the type, and therefore it is 5603 -- worth flattening such aggregates as well. 5604 5605 if Aggr_Size_OK (N) 5606 and then 5607 Flatten (N, Dims, First_Index (Typ), First_Index (Base_Type (Typ))) 5608 then 5609 if Static_Components then 5610 Set_Compile_Time_Known_Aggregate (N); 5611 Set_Expansion_Delayed (N, False); 5612 end if; 5613 5614 Analyze_And_Resolve (N, Typ); 5615 end if; 5616 5617 -- If Static_Elaboration_Desired has been specified, diagnose aggregates 5618 -- that will still require initialization code. 5619 5620 if (Ekind (Current_Scope) = E_Package 5621 and then Static_Elaboration_Desired (Current_Scope)) 5622 and then Nkind (Parent (N)) = N_Object_Declaration 5623 then 5624 declare 5625 Expr : Node_Id; 5626 5627 begin 5628 if Nkind (N) = N_Aggregate and then Present (Expressions (N)) then 5629 Expr := First (Expressions (N)); 5630 while Present (Expr) loop 5631 if not Compile_Time_Known_Value (Expr) then 5632 Error_Msg_N 5633 ("non-static object requires elaboration code??", N); 5634 exit; 5635 end if; 5636 5637 Next (Expr); 5638 end loop; 5639 5640 if Present (Component_Associations (N)) then 5641 Error_Msg_N ("object requires elaboration code??", N); 5642 end if; 5643 end if; 5644 end; 5645 end if; 5646 end Convert_To_Positional; 5647 5648 ---------------------------- 5649 -- Expand_Array_Aggregate -- 5650 ---------------------------- 5651 5652 -- Array aggregate expansion proceeds as follows: 5653 5654 -- 1. If requested we generate code to perform all the array aggregate 5655 -- bound checks, specifically 5656 5657 -- (a) Check that the index range defined by aggregate bounds is 5658 -- compatible with corresponding index subtype. 5659 5660 -- (b) If an others choice is present check that no aggregate 5661 -- index is outside the bounds of the index constraint. 5662 5663 -- (c) For multidimensional arrays make sure that all subaggregates 5664 -- corresponding to the same dimension have the same bounds. 5665 5666 -- 2. Check for packed array aggregate which can be converted to a 5667 -- constant so that the aggregate disappears completely. 5668 5669 -- 3. Check case of nested aggregate. Generally nested aggregates are 5670 -- handled during the processing of the parent aggregate. 5671 5672 -- 4. Check if the aggregate can be statically processed. If this is the 5673 -- case pass it as is to Gigi. Note that a necessary condition for 5674 -- static processing is that the aggregate be fully positional. 5675 5676 -- 5. If in-place aggregate expansion is possible (i.e. no need to create 5677 -- a temporary) then mark the aggregate as such and return. Otherwise 5678 -- create a new temporary and generate the appropriate initialization 5679 -- code. 5680 5681 procedure Expand_Array_Aggregate (N : Node_Id) is 5682 Loc : constant Source_Ptr := Sloc (N); 5683 5684 Typ : constant Entity_Id := Etype (N); 5685 Ctyp : constant Entity_Id := Component_Type (Typ); 5686 -- Typ is the correct constrained array subtype of the aggregate 5687 -- Ctyp is the corresponding component type. 5688 5689 Aggr_Dimension : constant Pos := Number_Dimensions (Typ); 5690 -- Number of aggregate index dimensions 5691 5692 Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id; 5693 Aggr_High : array (1 .. Aggr_Dimension) of Node_Id; 5694 -- Low and High bounds of the constraint for each aggregate index 5695 5696 Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id; 5697 -- The type of each index 5698 5699 In_Place_Assign_OK_For_Declaration : Boolean := False; 5700 -- True if we are to generate an in-place assignment for a declaration 5701 5702 Maybe_In_Place_OK : Boolean; 5703 -- If the type is neither controlled nor packed and the aggregate 5704 -- is the expression in an assignment, assignment in place may be 5705 -- possible, provided other conditions are met on the LHS. 5706 5707 Others_Present : array (1 .. Aggr_Dimension) of Boolean := 5708 (others => False); 5709 -- If Others_Present (J) is True, then there is an others choice in one 5710 -- of the subaggregates of N at dimension J. 5711 5712 procedure Build_Constrained_Type (Positional : Boolean); 5713 -- If the subtype is not static or unconstrained, build a constrained 5714 -- type using the computable sizes of the aggregate and its sub- 5715 -- aggregates. 5716 5717 procedure Check_Bounds (Aggr_Bounds_Node, Index_Bounds_Node : Node_Id); 5718 -- Checks that the bounds of Aggr_Bounds are within the bounds defined 5719 -- by Index_Bounds. 5720 5721 procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos); 5722 -- Checks that in a multidimensional array aggregate all subaggregates 5723 -- corresponding to the same dimension have the same bounds. Sub_Aggr is 5724 -- an array subaggregate. Dim is the dimension corresponding to the 5725 -- subaggregate. 5726 5727 procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos); 5728 -- Computes the values of array Others_Present. Sub_Aggr is the array 5729 -- subaggregate we start the computation from. Dim is the dimension 5730 -- corresponding to the subaggregate. 5731 5732 procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos); 5733 -- Checks that if an others choice is present in any subaggregate, no 5734 -- aggregate index is outside the bounds of the index constraint. 5735 -- Sub_Aggr is an array subaggregate. Dim is the dimension corresponding 5736 -- to the subaggregate. 5737 5738 function Safe_Left_Hand_Side (N : Node_Id) return Boolean; 5739 -- In addition to Maybe_In_Place_OK, in order for an aggregate to be 5740 -- built directly into the target of the assignment it must be free 5741 -- of side effects. N is the LHS of an assignment. 5742 5743 procedure Two_Pass_Aggregate_Expansion (N : Node_Id); 5744 -- If the aggregate consists only of iterated associations then the 5745 -- aggregate is constructed in two steps: 5746 -- a) Build an expression to compute the number of elements 5747 -- generated by each iterator, and use the expression to allocate 5748 -- the destination aggregate. 5749 -- b) Generate the loops corresponding to each iterator to insert 5750 -- the elements in their proper positions. 5751 5752 ---------------------------- 5753 -- Build_Constrained_Type -- 5754 ---------------------------- 5755 5756 procedure Build_Constrained_Type (Positional : Boolean) is 5757 Loc : constant Source_Ptr := Sloc (N); 5758 Agg_Type : constant Entity_Id := Make_Temporary (Loc, 'A'); 5759 Comp : Node_Id; 5760 Decl : Node_Id; 5761 Typ : constant Entity_Id := Etype (N); 5762 Indexes : constant List_Id := New_List; 5763 Num : Nat; 5764 Sub_Agg : Node_Id; 5765 5766 begin 5767 -- If the aggregate is purely positional, all its subaggregates 5768 -- have the same size. We collect the dimensions from the first 5769 -- subaggregate at each level. 5770 5771 if Positional then 5772 Sub_Agg := N; 5773 5774 for D in 1 .. Number_Dimensions (Typ) loop 5775 Sub_Agg := First (Expressions (Sub_Agg)); 5776 5777 Comp := Sub_Agg; 5778 Num := 0; 5779 while Present (Comp) loop 5780 Num := Num + 1; 5781 Next (Comp); 5782 end loop; 5783 5784 Append_To (Indexes, 5785 Make_Range (Loc, 5786 Low_Bound => Make_Integer_Literal (Loc, 1), 5787 High_Bound => Make_Integer_Literal (Loc, Num))); 5788 end loop; 5789 5790 else 5791 -- We know the aggregate type is unconstrained and the aggregate 5792 -- is not processable by the back end, therefore not necessarily 5793 -- positional. Retrieve each dimension bounds (computed earlier). 5794 5795 for D in 1 .. Number_Dimensions (Typ) loop 5796 Append_To (Indexes, 5797 Make_Range (Loc, 5798 Low_Bound => Aggr_Low (D), 5799 High_Bound => Aggr_High (D))); 5800 end loop; 5801 end if; 5802 5803 Decl := 5804 Make_Full_Type_Declaration (Loc, 5805 Defining_Identifier => Agg_Type, 5806 Type_Definition => 5807 Make_Constrained_Array_Definition (Loc, 5808 Discrete_Subtype_Definitions => Indexes, 5809 Component_Definition => 5810 Make_Component_Definition (Loc, 5811 Aliased_Present => False, 5812 Subtype_Indication => 5813 New_Occurrence_Of (Component_Type (Typ), Loc)))); 5814 5815 Insert_Action (N, Decl); 5816 Analyze (Decl); 5817 Set_Etype (N, Agg_Type); 5818 Set_Is_Itype (Agg_Type); 5819 Freeze_Itype (Agg_Type, N); 5820 end Build_Constrained_Type; 5821 5822 ------------------ 5823 -- Check_Bounds -- 5824 ------------------ 5825 5826 procedure Check_Bounds (Aggr_Bounds_Node, Index_Bounds_Node : Node_Id) is 5827 Aggr_Bounds : constant Range_Nodes := 5828 Get_Index_Bounds (Aggr_Bounds_Node); 5829 Ind_Bounds : constant Range_Nodes := 5830 Get_Index_Bounds (Index_Bounds_Node); 5831 5832 Cond : Node_Id := Empty; 5833 5834 begin 5835 -- Generate the following test: 5836 5837 -- [constraint_error when 5838 -- Aggr_Bounds.First <= Aggr_Bounds.Last and then 5839 -- (Aggr_Bounds.First < Ind_Bounds.First 5840 -- or else Aggr_Bounds.Last > Ind_Bounds.Last)] 5841 5842 -- As an optimization try to see if some tests are trivially vacuous 5843 -- because we are comparing an expression against itself. 5844 5845 if Aggr_Bounds.First = Ind_Bounds.First 5846 and then Aggr_Bounds.Last = Ind_Bounds.Last 5847 then 5848 Cond := Empty; 5849 5850 elsif Aggr_Bounds.Last = Ind_Bounds.Last then 5851 Cond := 5852 Make_Op_Lt (Loc, 5853 Left_Opnd => 5854 Duplicate_Subexpr_Move_Checks (Aggr_Bounds.First), 5855 Right_Opnd => 5856 Duplicate_Subexpr_Move_Checks (Ind_Bounds.First)); 5857 5858 elsif Aggr_Bounds.First = Ind_Bounds.First then 5859 Cond := 5860 Make_Op_Gt (Loc, 5861 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Bounds.Last), 5862 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Bounds.Last)); 5863 5864 else 5865 Cond := 5866 Make_Or_Else (Loc, 5867 Left_Opnd => 5868 Make_Op_Lt (Loc, 5869 Left_Opnd => 5870 Duplicate_Subexpr_Move_Checks (Aggr_Bounds.First), 5871 Right_Opnd => 5872 Duplicate_Subexpr_Move_Checks (Ind_Bounds.First)), 5873 5874 Right_Opnd => 5875 Make_Op_Gt (Loc, 5876 Left_Opnd => Duplicate_Subexpr (Aggr_Bounds.Last), 5877 Right_Opnd => Duplicate_Subexpr (Ind_Bounds.Last))); 5878 end if; 5879 5880 if Present (Cond) then 5881 Cond := 5882 Make_And_Then (Loc, 5883 Left_Opnd => 5884 Make_Op_Le (Loc, 5885 Left_Opnd => 5886 Duplicate_Subexpr_Move_Checks (Aggr_Bounds.First), 5887 Right_Opnd => 5888 Duplicate_Subexpr_Move_Checks (Aggr_Bounds.Last)), 5889 5890 Right_Opnd => Cond); 5891 5892 Set_Analyzed (Left_Opnd (Left_Opnd (Cond)), False); 5893 Set_Analyzed (Right_Opnd (Left_Opnd (Cond)), False); 5894 Insert_Action (N, 5895 Make_Raise_Constraint_Error (Loc, 5896 Condition => Cond, 5897 Reason => CE_Range_Check_Failed)); 5898 end if; 5899 end Check_Bounds; 5900 5901 ---------------------------- 5902 -- Check_Same_Aggr_Bounds -- 5903 ---------------------------- 5904 5905 procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos) is 5906 Sub_Lo : constant Node_Id := Low_Bound (Aggregate_Bounds (Sub_Aggr)); 5907 Sub_Hi : constant Node_Id := High_Bound (Aggregate_Bounds (Sub_Aggr)); 5908 -- The bounds of this specific subaggregate 5909 5910 Aggr_Lo : constant Node_Id := Aggr_Low (Dim); 5911 Aggr_Hi : constant Node_Id := Aggr_High (Dim); 5912 -- The bounds of the aggregate for this dimension 5913 5914 Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim); 5915 -- The index type for this dimension.xxx 5916 5917 Cond : Node_Id := Empty; 5918 Assoc : Node_Id; 5919 Expr : Node_Id; 5920 5921 begin 5922 -- If index checks are on generate the test 5923 5924 -- [constraint_error when 5925 -- Aggr_Lo /= Sub_Lo or else Aggr_Hi /= Sub_Hi] 5926 5927 -- As an optimization try to see if some tests are trivially vacuos 5928 -- because we are comparing an expression against itself. Also for 5929 -- the first dimension the test is trivially vacuous because there 5930 -- is just one aggregate for dimension 1. 5931 5932 if Index_Checks_Suppressed (Ind_Typ) then 5933 Cond := Empty; 5934 5935 elsif Dim = 1 or else (Aggr_Lo = Sub_Lo and then Aggr_Hi = Sub_Hi) 5936 then 5937 Cond := Empty; 5938 5939 elsif Aggr_Hi = Sub_Hi then 5940 Cond := 5941 Make_Op_Ne (Loc, 5942 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), 5943 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo)); 5944 5945 elsif Aggr_Lo = Sub_Lo then 5946 Cond := 5947 Make_Op_Ne (Loc, 5948 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi), 5949 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Hi)); 5950 5951 else 5952 Cond := 5953 Make_Or_Else (Loc, 5954 Left_Opnd => 5955 Make_Op_Ne (Loc, 5956 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), 5957 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo)), 5958 5959 Right_Opnd => 5960 Make_Op_Ne (Loc, 5961 Left_Opnd => Duplicate_Subexpr (Aggr_Hi), 5962 Right_Opnd => Duplicate_Subexpr (Sub_Hi))); 5963 end if; 5964 5965 if Present (Cond) then 5966 Insert_Action (N, 5967 Make_Raise_Constraint_Error (Loc, 5968 Condition => Cond, 5969 Reason => CE_Length_Check_Failed)); 5970 end if; 5971 5972 -- Now look inside the subaggregate to see if there is more work 5973 5974 if Dim < Aggr_Dimension then 5975 5976 -- Process positional components 5977 5978 if Present (Expressions (Sub_Aggr)) then 5979 Expr := First (Expressions (Sub_Aggr)); 5980 while Present (Expr) loop 5981 Check_Same_Aggr_Bounds (Expr, Dim + 1); 5982 Next (Expr); 5983 end loop; 5984 end if; 5985 5986 -- Process component associations 5987 5988 if Present (Component_Associations (Sub_Aggr)) then 5989 Assoc := First (Component_Associations (Sub_Aggr)); 5990 while Present (Assoc) loop 5991 Expr := Expression (Assoc); 5992 Check_Same_Aggr_Bounds (Expr, Dim + 1); 5993 Next (Assoc); 5994 end loop; 5995 end if; 5996 end if; 5997 end Check_Same_Aggr_Bounds; 5998 5999 ---------------------------- 6000 -- Compute_Others_Present -- 6001 ---------------------------- 6002 6003 procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos) is 6004 Assoc : Node_Id; 6005 Expr : Node_Id; 6006 6007 begin 6008 if Present (Component_Associations (Sub_Aggr)) then 6009 Assoc := Last (Component_Associations (Sub_Aggr)); 6010 6011 if Nkind (First (Choice_List (Assoc))) = N_Others_Choice then 6012 Others_Present (Dim) := True; 6013 6014 -- An others_clause may be superfluous if previous components 6015 -- cover the full given range of a constrained array. In such 6016 -- a case an others_clause does not contribute any additional 6017 -- components and has not been analyzed. We analyze it now to 6018 -- detect type errors in the expression, even though no code 6019 -- will be generated for it. 6020 6021 if Dim = Aggr_Dimension 6022 and then Nkind (Assoc) /= N_Iterated_Component_Association 6023 and then not Analyzed (Expression (Assoc)) 6024 and then not Box_Present (Assoc) 6025 then 6026 Preanalyze_And_Resolve (Expression (Assoc), Ctyp); 6027 end if; 6028 end if; 6029 end if; 6030 6031 -- Now look inside the subaggregate to see if there is more work 6032 6033 if Dim < Aggr_Dimension then 6034 6035 -- Process positional components 6036 6037 if Present (Expressions (Sub_Aggr)) then 6038 Expr := First (Expressions (Sub_Aggr)); 6039 while Present (Expr) loop 6040 Compute_Others_Present (Expr, Dim + 1); 6041 Next (Expr); 6042 end loop; 6043 end if; 6044 6045 -- Process component associations 6046 6047 if Present (Component_Associations (Sub_Aggr)) then 6048 Assoc := First (Component_Associations (Sub_Aggr)); 6049 while Present (Assoc) loop 6050 Expr := Expression (Assoc); 6051 Compute_Others_Present (Expr, Dim + 1); 6052 Next (Assoc); 6053 end loop; 6054 end if; 6055 end if; 6056 end Compute_Others_Present; 6057 6058 ------------------ 6059 -- Others_Check -- 6060 ------------------ 6061 6062 procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos) is 6063 Aggr_Lo : constant Node_Id := Aggr_Low (Dim); 6064 Aggr_Hi : constant Node_Id := Aggr_High (Dim); 6065 -- The bounds of the aggregate for this dimension 6066 6067 Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim); 6068 -- The index type for this dimension 6069 6070 Need_To_Check : Boolean := False; 6071 6072 Choices_Lo : Node_Id := Empty; 6073 Choices_Hi : Node_Id := Empty; 6074 -- The lowest and highest discrete choices for a named subaggregate 6075 6076 Nb_Choices : Int := -1; 6077 -- The number of discrete non-others choices in this subaggregate 6078 6079 Nb_Elements : Uint := Uint_0; 6080 -- The number of elements in a positional aggregate 6081 6082 Cond : Node_Id := Empty; 6083 6084 Assoc : Node_Id; 6085 Choice : Node_Id; 6086 Expr : Node_Id; 6087 6088 begin 6089 -- Check if we have an others choice. If we do make sure that this 6090 -- subaggregate contains at least one element in addition to the 6091 -- others choice. 6092 6093 if Range_Checks_Suppressed (Ind_Typ) then 6094 Need_To_Check := False; 6095 6096 elsif Present (Expressions (Sub_Aggr)) 6097 and then Present (Component_Associations (Sub_Aggr)) 6098 then 6099 Need_To_Check := True; 6100 6101 elsif Present (Component_Associations (Sub_Aggr)) then 6102 Assoc := Last (Component_Associations (Sub_Aggr)); 6103 6104 if Nkind (First (Choice_List (Assoc))) /= N_Others_Choice then 6105 Need_To_Check := False; 6106 6107 else 6108 -- Count the number of discrete choices. Start with -1 because 6109 -- the others choice does not count. 6110 6111 -- Is there some reason we do not use List_Length here ??? 6112 6113 Nb_Choices := -1; 6114 Assoc := First (Component_Associations (Sub_Aggr)); 6115 while Present (Assoc) loop 6116 Choice := First (Choice_List (Assoc)); 6117 while Present (Choice) loop 6118 Nb_Choices := Nb_Choices + 1; 6119 Next (Choice); 6120 end loop; 6121 6122 Next (Assoc); 6123 end loop; 6124 6125 -- If there is only an others choice nothing to do 6126 6127 Need_To_Check := (Nb_Choices > 0); 6128 end if; 6129 6130 else 6131 Need_To_Check := False; 6132 end if; 6133 6134 -- If we are dealing with a positional subaggregate with an others 6135 -- choice then compute the number or positional elements. 6136 6137 if Need_To_Check and then Present (Expressions (Sub_Aggr)) then 6138 Expr := First (Expressions (Sub_Aggr)); 6139 Nb_Elements := Uint_0; 6140 while Present (Expr) loop 6141 Nb_Elements := Nb_Elements + 1; 6142 Next (Expr); 6143 end loop; 6144 6145 -- If the aggregate contains discrete choices and an others choice 6146 -- compute the smallest and largest discrete choice values. 6147 6148 elsif Need_To_Check then 6149 Compute_Choices_Lo_And_Choices_Hi : declare 6150 6151 Table : Case_Table_Type (1 .. Nb_Choices); 6152 -- Used to sort all the different choice values 6153 6154 J : Pos := 1; 6155 6156 begin 6157 Assoc := First (Component_Associations (Sub_Aggr)); 6158 while Present (Assoc) loop 6159 Choice := First (Choice_List (Assoc)); 6160 while Present (Choice) loop 6161 if Nkind (Choice) = N_Others_Choice then 6162 exit; 6163 end if; 6164 6165 declare 6166 Bounds : constant Range_Nodes := 6167 Get_Index_Bounds (Choice); 6168 begin 6169 Table (J).Choice_Lo := Bounds.First; 6170 Table (J).Choice_Hi := Bounds.Last; 6171 end; 6172 6173 J := J + 1; 6174 Next (Choice); 6175 end loop; 6176 6177 Next (Assoc); 6178 end loop; 6179 6180 -- Sort the discrete choices 6181 6182 Sort_Case_Table (Table); 6183 6184 Choices_Lo := Table (1).Choice_Lo; 6185 Choices_Hi := Table (Nb_Choices).Choice_Hi; 6186 end Compute_Choices_Lo_And_Choices_Hi; 6187 end if; 6188 6189 -- If no others choice in this subaggregate, or the aggregate 6190 -- comprises only an others choice, nothing to do. 6191 6192 if not Need_To_Check then 6193 Cond := Empty; 6194 6195 -- If we are dealing with an aggregate containing an others choice 6196 -- and positional components, we generate the following test: 6197 6198 -- if Ind_Typ'Pos (Aggr_Lo) + (Nb_Elements - 1) > 6199 -- Ind_Typ'Pos (Aggr_Hi) 6200 -- then 6201 -- raise Constraint_Error; 6202 -- end if; 6203 6204 -- in the general case, but the following simpler test: 6205 6206 -- [constraint_error when 6207 -- Aggr_Lo + (Nb_Elements - 1) > Aggr_Hi]; 6208 6209 -- instead if the index type is a signed integer. 6210 6211 elsif Nb_Elements > Uint_0 then 6212 if Nb_Elements = Uint_1 then 6213 Cond := 6214 Make_Op_Gt (Loc, 6215 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), 6216 Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi)); 6217 6218 elsif Is_Signed_Integer_Type (Ind_Typ) then 6219 Cond := 6220 Make_Op_Gt (Loc, 6221 Left_Opnd => 6222 Make_Op_Add (Loc, 6223 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), 6224 Right_Opnd => 6225 Make_Integer_Literal (Loc, Nb_Elements - 1)), 6226 Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi)); 6227 6228 else 6229 Cond := 6230 Make_Op_Gt (Loc, 6231 Left_Opnd => 6232 Make_Op_Add (Loc, 6233 Left_Opnd => 6234 Make_Attribute_Reference (Loc, 6235 Prefix => New_Occurrence_Of (Ind_Typ, Loc), 6236 Attribute_Name => Name_Pos, 6237 Expressions => 6238 New_List 6239 (Duplicate_Subexpr_Move_Checks (Aggr_Lo))), 6240 Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)), 6241 6242 Right_Opnd => 6243 Make_Attribute_Reference (Loc, 6244 Prefix => New_Occurrence_Of (Ind_Typ, Loc), 6245 Attribute_Name => Name_Pos, 6246 Expressions => New_List ( 6247 Duplicate_Subexpr_Move_Checks (Aggr_Hi)))); 6248 end if; 6249 6250 -- If we are dealing with an aggregate containing an others choice 6251 -- and discrete choices we generate the following test: 6252 6253 -- [constraint_error when 6254 -- Choices_Lo < Aggr_Lo or else Choices_Hi > Aggr_Hi]; 6255 6256 else 6257 Cond := 6258 Make_Or_Else (Loc, 6259 Left_Opnd => 6260 Make_Op_Lt (Loc, 6261 Left_Opnd => Duplicate_Subexpr_Move_Checks (Choices_Lo), 6262 Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo)), 6263 6264 Right_Opnd => 6265 Make_Op_Gt (Loc, 6266 Left_Opnd => Duplicate_Subexpr (Choices_Hi), 6267 Right_Opnd => Duplicate_Subexpr (Aggr_Hi))); 6268 end if; 6269 6270 if Present (Cond) then 6271 Insert_Action (N, 6272 Make_Raise_Constraint_Error (Loc, 6273 Condition => Cond, 6274 Reason => CE_Length_Check_Failed)); 6275 -- Questionable reason code, shouldn't that be a 6276 -- CE_Range_Check_Failed ??? 6277 end if; 6278 6279 -- Now look inside the subaggregate to see if there is more work 6280 6281 if Dim < Aggr_Dimension then 6282 6283 -- Process positional components 6284 6285 if Present (Expressions (Sub_Aggr)) then 6286 Expr := First (Expressions (Sub_Aggr)); 6287 while Present (Expr) loop 6288 Others_Check (Expr, Dim + 1); 6289 Next (Expr); 6290 end loop; 6291 end if; 6292 6293 -- Process component associations 6294 6295 if Present (Component_Associations (Sub_Aggr)) then 6296 Assoc := First (Component_Associations (Sub_Aggr)); 6297 while Present (Assoc) loop 6298 Expr := Expression (Assoc); 6299 Others_Check (Expr, Dim + 1); 6300 Next (Assoc); 6301 end loop; 6302 end if; 6303 end if; 6304 end Others_Check; 6305 6306 ------------------------- 6307 -- Safe_Left_Hand_Side -- 6308 ------------------------- 6309 6310 function Safe_Left_Hand_Side (N : Node_Id) return Boolean is 6311 function Is_Safe_Index (Indx : Node_Id) return Boolean; 6312 -- If the left-hand side includes an indexed component, check that 6313 -- the indexes are free of side effects. 6314 6315 ------------------- 6316 -- Is_Safe_Index -- 6317 ------------------- 6318 6319 function Is_Safe_Index (Indx : Node_Id) return Boolean is 6320 begin 6321 if Is_Entity_Name (Indx) then 6322 return True; 6323 6324 elsif Nkind (Indx) = N_Integer_Literal then 6325 return True; 6326 6327 elsif Nkind (Indx) = N_Function_Call 6328 and then Is_Entity_Name (Name (Indx)) 6329 and then Has_Pragma_Pure_Function (Entity (Name (Indx))) 6330 then 6331 return True; 6332 6333 elsif Nkind (Indx) = N_Type_Conversion 6334 and then Is_Safe_Index (Expression (Indx)) 6335 then 6336 return True; 6337 6338 else 6339 return False; 6340 end if; 6341 end Is_Safe_Index; 6342 6343 -- Start of processing for Safe_Left_Hand_Side 6344 6345 begin 6346 if Is_Entity_Name (N) then 6347 return True; 6348 6349 elsif Nkind (N) in N_Explicit_Dereference | N_Selected_Component 6350 and then Safe_Left_Hand_Side (Prefix (N)) 6351 then 6352 return True; 6353 6354 elsif Nkind (N) = N_Indexed_Component 6355 and then Safe_Left_Hand_Side (Prefix (N)) 6356 and then Is_Safe_Index (First (Expressions (N))) 6357 then 6358 return True; 6359 6360 elsif Nkind (N) = N_Unchecked_Type_Conversion then 6361 return Safe_Left_Hand_Side (Expression (N)); 6362 6363 else 6364 return False; 6365 end if; 6366 end Safe_Left_Hand_Side; 6367 6368 ---------------------------------- 6369 -- Two_Pass_Aggregate_Expansion -- 6370 ---------------------------------- 6371 6372 procedure Two_Pass_Aggregate_Expansion (N : Node_Id) is 6373 Loc : constant Source_Ptr := Sloc (N); 6374 Comp_Type : constant Entity_Id := Etype (N); 6375 Index_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); 6376 Index_Type : constant Entity_Id := Etype (First_Index (Etype (N))); 6377 Size_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); 6378 TmpE : constant Entity_Id := Make_Temporary (Loc, 'A', N); 6379 6380 Assoc : Node_Id := First (Component_Associations (N)); 6381 Incr : Node_Id; 6382 Iter : Node_Id; 6383 New_Comp : Node_Id; 6384 One_Loop : Node_Id; 6385 6386 Size_Expr_Code : List_Id; 6387 Insertion_Code : List_Id := New_List; 6388 6389 begin 6390 Size_Expr_Code := New_List ( 6391 Make_Object_Declaration (Loc, 6392 Defining_Identifier => Size_Id, 6393 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 6394 Expression => Make_Integer_Literal (Loc, 0))); 6395 6396 -- First pass: execute the iterators to count the number of elements 6397 -- that will be generated. 6398 6399 while Present (Assoc) loop 6400 Iter := Iterator_Specification (Assoc); 6401 Incr := Make_Assignment_Statement (Loc, 6402 Name => New_Occurrence_Of (Size_Id, Loc), 6403 Expression => 6404 Make_Op_Add (Loc, 6405 Left_Opnd => New_Occurrence_Of (Size_Id, Loc), 6406 Right_Opnd => Make_Integer_Literal (Loc, 1))); 6407 6408 One_Loop := Make_Loop_Statement (Loc, 6409 Iteration_Scheme => 6410 Make_Iteration_Scheme (Loc, 6411 Iterator_Specification => New_Copy_Tree (Iter)), 6412 Statements => New_List (Incr)); 6413 6414 Append (One_Loop, Size_Expr_Code); 6415 Next (Assoc); 6416 end loop; 6417 6418 Insert_Actions (N, Size_Expr_Code); 6419 6420 -- Build a constrained subtype with the calculated length 6421 -- and declare the proper bounded aggregate object. 6422 -- The index type is some discrete type, so the bounds of the 6423 -- constructed array are computed as T'Val (T'Pos (ineger bound)); 6424 6425 declare 6426 Pos_Lo : constant Node_Id := 6427 Make_Attribute_Reference (Loc, 6428 Prefix => New_Occurrence_Of (Index_Type, Loc), 6429 Attribute_Name => Name_Pos, 6430 Expressions => New_List ( 6431 Make_Attribute_Reference (Loc, 6432 Prefix => New_Occurrence_Of (Index_Type, Loc), 6433 Attribute_Name => Name_First))); 6434 6435 Aggr_Lo : constant Node_Id := 6436 Make_Attribute_Reference (Loc, 6437 Prefix => New_Occurrence_Of (Index_Type, Loc), 6438 Attribute_Name => Name_Val, 6439 Expressions => New_List (New_Copy_Tree (Pos_Lo))); 6440 6441 -- Hi = Index_type'Pos (Lo + Size -1). 6442 6443 Pos_Hi : constant Node_Id := 6444 Make_Op_Add (Loc, 6445 Left_Opnd => New_Copy_Tree (Pos_Lo), 6446 Right_Opnd => 6447 Make_Op_Subtract (Loc, 6448 Left_Opnd => New_Occurrence_Of (Size_Id, Loc), 6449 Right_Opnd => Make_Integer_Literal (Loc, 1))); 6450 6451 -- Corresponding index value 6452 6453 Aggr_Hi : constant Node_Id := 6454 Make_Attribute_Reference (Loc, 6455 Prefix => New_Occurrence_Of (Index_Type, Loc), 6456 Attribute_Name => Name_Val, 6457 Expressions => New_List (New_Copy_Tree (Pos_Hi))); 6458 6459 SubE : constant Entity_Id := Make_Temporary (Loc, 'T'); 6460 SubD : constant Node_Id := 6461 Make_Subtype_Declaration (Loc, 6462 Defining_Identifier => SubE, 6463 Subtype_Indication => 6464 Make_Subtype_Indication (Loc, 6465 Subtype_Mark => 6466 New_Occurrence_Of (Etype (Comp_Type), Loc), 6467 Constraint => 6468 Make_Index_Or_Discriminant_Constraint 6469 (Loc, 6470 Constraints => 6471 New_List (Make_Range (Loc, Aggr_Lo, Aggr_Hi))))); 6472 6473 -- Create a temporary array of the above subtype which 6474 -- will be used to capture the aggregate assignments. 6475 6476 TmpD : constant Node_Id := 6477 Make_Object_Declaration (Loc, 6478 Defining_Identifier => TmpE, 6479 Object_Definition => New_Occurrence_Of (SubE, Loc)); 6480 begin 6481 Insert_Actions (N, New_List (SubD, TmpD)); 6482 end; 6483 6484 -- Second pass: use the iterators to generate the elements of the 6485 -- aggregate. Insertion index starts at Index_Type'First. We 6486 -- assume that the second evaluation of each iterator generates 6487 -- the same number of elements as the first pass, and consider 6488 -- that the execution is erroneous (even if the RM does not state 6489 -- this explicitly) if the number of elements generated differs 6490 -- between first and second pass. 6491 6492 Assoc := First (Component_Associations (N)); 6493 6494 -- Initialize insertion position to first array component. 6495 6496 Insertion_Code := New_List ( 6497 Make_Object_Declaration (Loc, 6498 Defining_Identifier => Index_Id, 6499 Object_Definition => 6500 New_Occurrence_Of (Index_Type, Loc), 6501 Expression => 6502 Make_Attribute_Reference (Loc, 6503 Prefix => New_Occurrence_Of (Index_Type, Loc), 6504 Attribute_Name => Name_First))); 6505 6506 while Present (Assoc) loop 6507 Iter := Iterator_Specification (Assoc); 6508 New_Comp := Make_Assignment_Statement (Loc, 6509 Name => 6510 Make_Indexed_Component (Loc, 6511 Prefix => New_Occurrence_Of (TmpE, Loc), 6512 Expressions => 6513 New_List (New_Occurrence_Of (Index_Id, Loc))), 6514 Expression => New_Copy_Tree (Expression (Assoc))); 6515 6516 -- Advance index position for insertion. 6517 6518 Incr := Make_Assignment_Statement (Loc, 6519 Name => New_Occurrence_Of (Index_Id, Loc), 6520 Expression => 6521 Make_Attribute_Reference (Loc, 6522 Prefix => 6523 New_Occurrence_Of (Index_Type, Loc), 6524 Attribute_Name => Name_Succ, 6525 Expressions => 6526 New_List (New_Occurrence_Of (Index_Id, Loc)))); 6527 6528 -- Add guard to skip last increment when upper bound is reached. 6529 6530 Incr := Make_If_Statement (Loc, 6531 Condition => 6532 Make_Op_Ne (Loc, 6533 Left_Opnd => New_Occurrence_Of (Index_Id, Loc), 6534 Right_Opnd => 6535 Make_Attribute_Reference (Loc, 6536 Prefix => New_Occurrence_Of (Index_Type, Loc), 6537 Attribute_Name => Name_Last)), 6538 Then_Statements => New_List (Incr)); 6539 6540 One_Loop := Make_Loop_Statement (Loc, 6541 Iteration_Scheme => 6542 Make_Iteration_Scheme (Loc, 6543 Iterator_Specification => Copy_Separate_Tree (Iter)), 6544 Statements => New_List (New_Comp, Incr)); 6545 6546 Append (One_Loop, Insertion_Code); 6547 Next (Assoc); 6548 end loop; 6549 6550 Insert_Actions (N, Insertion_Code); 6551 6552 -- Depending on context this may not work for build-in-place 6553 -- arrays ??? 6554 6555 Rewrite (N, New_Occurrence_Of (TmpE, Loc)); 6556 6557 end Two_Pass_Aggregate_Expansion; 6558 6559 -- Local variables 6560 6561 Tmp : Entity_Id; 6562 -- Holds the temporary aggregate value 6563 6564 Tmp_Decl : Node_Id; 6565 -- Holds the declaration of Tmp 6566 6567 Aggr_Code : List_Id; 6568 Parent_Node : Node_Id; 6569 Parent_Kind : Node_Kind; 6570 6571 -- Start of processing for Expand_Array_Aggregate 6572 6573 begin 6574 -- Do not touch the special aggregates of attributes used for Asm calls 6575 6576 if Is_RTE (Ctyp, RE_Asm_Input_Operand) 6577 or else Is_RTE (Ctyp, RE_Asm_Output_Operand) 6578 then 6579 return; 6580 6581 -- Do not expand an aggregate for an array type which contains tasks if 6582 -- the aggregate is associated with an unexpanded return statement of a 6583 -- build-in-place function. The aggregate is expanded when the related 6584 -- return statement (rewritten into an extended return) is processed. 6585 -- This delay ensures that any temporaries and initialization code 6586 -- generated for the aggregate appear in the proper return block and 6587 -- use the correct _chain and _master. 6588 6589 elsif Has_Task (Base_Type (Etype (N))) 6590 and then Nkind (Parent (N)) = N_Simple_Return_Statement 6591 and then Is_Build_In_Place_Function 6592 (Return_Applies_To (Return_Statement_Entity (Parent (N)))) 6593 then 6594 return; 6595 6596 elsif Present (Component_Associations (N)) 6597 and then Nkind (First (Component_Associations (N))) = 6598 N_Iterated_Component_Association 6599 and then 6600 Present (Iterator_Specification (First (Component_Associations (N)))) 6601 then 6602 Two_Pass_Aggregate_Expansion (N); 6603 return; 6604 6605 -- Do not attempt expansion if error already detected. We may reach this 6606 -- point in spite of previous errors when compiling with -gnatq, to 6607 -- force all possible errors (this is the usual ACATS mode). 6608 6609 elsif Error_Posted (N) then 6610 return; 6611 end if; 6612 6613 -- If the semantic analyzer has determined that aggregate N will raise 6614 -- Constraint_Error at run time, then the aggregate node has been 6615 -- replaced with an N_Raise_Constraint_Error node and we should 6616 -- never get here. 6617 6618 pragma Assert (not Raises_Constraint_Error (N)); 6619 6620 -- STEP 1a 6621 6622 -- Check that the index range defined by aggregate bounds is 6623 -- compatible with corresponding index subtype. 6624 6625 Index_Compatibility_Check : declare 6626 Aggr_Index_Range : Node_Id := First_Index (Typ); 6627 -- The current aggregate index range 6628 6629 Index_Constraint : Node_Id := First_Index (Etype (Typ)); 6630 -- The corresponding index constraint against which we have to 6631 -- check the above aggregate index range. 6632 6633 begin 6634 Compute_Others_Present (N, 1); 6635 6636 for J in 1 .. Aggr_Dimension loop 6637 -- There is no need to emit a check if an others choice is present 6638 -- for this array aggregate dimension since in this case one of 6639 -- N's subaggregates has taken its bounds from the context and 6640 -- these bounds must have been checked already. In addition all 6641 -- subaggregates corresponding to the same dimension must all have 6642 -- the same bounds (checked in (c) below). 6643 6644 if not Range_Checks_Suppressed (Etype (Index_Constraint)) 6645 and then not Others_Present (J) 6646 then 6647 -- We don't use Checks.Apply_Range_Check here because it emits 6648 -- a spurious check. Namely it checks that the range defined by 6649 -- the aggregate bounds is nonempty. But we know this already 6650 -- if we get here. 6651 6652 Check_Bounds (Aggr_Index_Range, Index_Constraint); 6653 end if; 6654 6655 -- Save the low and high bounds of the aggregate index as well as 6656 -- the index type for later use in checks (b) and (c) below. 6657 6658 Aggr_Low (J) := Low_Bound (Aggr_Index_Range); 6659 Aggr_High (J) := High_Bound (Aggr_Index_Range); 6660 6661 Aggr_Index_Typ (J) := Etype (Index_Constraint); 6662 6663 Next_Index (Aggr_Index_Range); 6664 Next_Index (Index_Constraint); 6665 end loop; 6666 end Index_Compatibility_Check; 6667 6668 -- STEP 1b 6669 6670 -- If an others choice is present check that no aggregate index is 6671 -- outside the bounds of the index constraint. 6672 6673 Others_Check (N, 1); 6674 6675 -- STEP 1c 6676 6677 -- For multidimensional arrays make sure that all subaggregates 6678 -- corresponding to the same dimension have the same bounds. 6679 6680 if Aggr_Dimension > 1 then 6681 Check_Same_Aggr_Bounds (N, 1); 6682 end if; 6683 6684 -- STEP 1d 6685 6686 -- If we have a default component value, or simple initialization is 6687 -- required for the component type, then we replace <> in component 6688 -- associations by the required default value. 6689 6690 declare 6691 Default_Val : Node_Id; 6692 Assoc : Node_Id; 6693 6694 begin 6695 if (Present (Default_Aspect_Component_Value (Typ)) 6696 or else Needs_Simple_Initialization (Ctyp)) 6697 and then Present (Component_Associations (N)) 6698 then 6699 Assoc := First (Component_Associations (N)); 6700 while Present (Assoc) loop 6701 if Nkind (Assoc) = N_Component_Association 6702 and then Box_Present (Assoc) 6703 then 6704 Set_Box_Present (Assoc, False); 6705 6706 if Present (Default_Aspect_Component_Value (Typ)) then 6707 Default_Val := Default_Aspect_Component_Value (Typ); 6708 else 6709 Default_Val := Get_Simple_Init_Val (Ctyp, N); 6710 end if; 6711 6712 Set_Expression (Assoc, New_Copy_Tree (Default_Val)); 6713 Analyze_And_Resolve (Expression (Assoc), Ctyp); 6714 end if; 6715 6716 Next (Assoc); 6717 end loop; 6718 end if; 6719 end; 6720 6721 -- STEP 2 6722 6723 -- Here we test for is packed array aggregate that we can handle at 6724 -- compile time. If so, return with transformation done. Note that we do 6725 -- this even if the aggregate is nested, because once we have done this 6726 -- processing, there is no more nested aggregate. 6727 6728 if Packed_Array_Aggregate_Handled (N) then 6729 return; 6730 end if; 6731 6732 -- At this point we try to convert to positional form 6733 6734 Convert_To_Positional (N); 6735 6736 -- If the result is no longer an aggregate (e.g. it may be a string 6737 -- literal, or a temporary which has the needed value), then we are 6738 -- done, since there is no longer a nested aggregate. 6739 6740 if Nkind (N) /= N_Aggregate then 6741 return; 6742 6743 -- We are also done if the result is an analyzed aggregate, indicating 6744 -- that Convert_To_Positional succeeded and reanalyzed the rewritten 6745 -- aggregate. 6746 6747 elsif Analyzed (N) and then Is_Rewrite_Substitution (N) then 6748 return; 6749 end if; 6750 6751 -- If all aggregate components are compile-time known and the aggregate 6752 -- has been flattened, nothing left to do. The same occurs if the 6753 -- aggregate is used to initialize the components of a statically 6754 -- allocated dispatch table. 6755 6756 if Compile_Time_Known_Aggregate (N) 6757 or else Is_Static_Dispatch_Table_Aggregate (N) 6758 then 6759 Set_Expansion_Delayed (N, False); 6760 return; 6761 end if; 6762 6763 -- Now see if back end processing is possible 6764 6765 if Backend_Processing_Possible (N) then 6766 6767 -- If the aggregate is static but the constraints are not, build 6768 -- a static subtype for the aggregate, so that Gigi can place it 6769 -- in static memory. Perform an unchecked_conversion to the non- 6770 -- static type imposed by the context. 6771 6772 declare 6773 Itype : constant Entity_Id := Etype (N); 6774 Index : Node_Id; 6775 Needs_Type : Boolean := False; 6776 6777 begin 6778 Index := First_Index (Itype); 6779 while Present (Index) loop 6780 if not Is_OK_Static_Subtype (Etype (Index)) then 6781 Needs_Type := True; 6782 exit; 6783 else 6784 Next_Index (Index); 6785 end if; 6786 end loop; 6787 6788 if Needs_Type then 6789 Build_Constrained_Type (Positional => True); 6790 Rewrite (N, Unchecked_Convert_To (Itype, N)); 6791 Analyze (N); 6792 end if; 6793 end; 6794 6795 return; 6796 end if; 6797 6798 -- STEP 3 6799 6800 -- Delay expansion for nested aggregates: it will be taken care of when 6801 -- the parent aggregate is expanded. 6802 6803 Parent_Node := Parent (N); 6804 Parent_Kind := Nkind (Parent_Node); 6805 6806 if Parent_Kind = N_Qualified_Expression then 6807 Parent_Node := Parent (Parent_Node); 6808 Parent_Kind := Nkind (Parent_Node); 6809 end if; 6810 6811 if Parent_Kind = N_Aggregate 6812 or else Parent_Kind = N_Extension_Aggregate 6813 or else Parent_Kind = N_Component_Association 6814 or else (Parent_Kind = N_Object_Declaration 6815 and then Needs_Finalization (Typ)) 6816 or else (Parent_Kind = N_Assignment_Statement 6817 and then Inside_Init_Proc) 6818 then 6819 Set_Expansion_Delayed (N, not Static_Array_Aggregate (N)); 6820 return; 6821 end if; 6822 6823 -- STEP 4 6824 6825 -- Check whether in-place aggregate expansion is possible 6826 6827 -- For object declarations we build the aggregate in place, unless 6828 -- the array is bit-packed. 6829 6830 -- For assignments we do the assignment in place if all the component 6831 -- associations have compile-time known values, or are default- 6832 -- initialized limited components, e.g. tasks. For other cases we 6833 -- create a temporary. A full analysis for safety of in-place assignment 6834 -- is delicate. 6835 6836 -- For allocators we assign to the designated object in place if the 6837 -- aggregate meets the same conditions as other in-place assignments. 6838 -- In this case the aggregate may not come from source but was created 6839 -- for default initialization, e.g. with Initialize_Scalars. 6840 6841 if Requires_Transient_Scope (Typ) then 6842 Establish_Transient_Scope (N, Manage_Sec_Stack => False); 6843 end if; 6844 6845 -- An array of limited components is built in place 6846 6847 if Is_Limited_Type (Typ) then 6848 Maybe_In_Place_OK := True; 6849 6850 elsif Has_Default_Init_Comps (N) then 6851 Maybe_In_Place_OK := False; 6852 6853 elsif Is_Bit_Packed_Array (Typ) 6854 or else Has_Controlled_Component (Typ) 6855 then 6856 Maybe_In_Place_OK := False; 6857 6858 elsif Parent_Kind = N_Assignment_Statement then 6859 Maybe_In_Place_OK := 6860 In_Place_Assign_OK (N, Get_Base_Object (Name (Parent_Node))); 6861 6862 elsif Parent_Kind = N_Allocator then 6863 Maybe_In_Place_OK := In_Place_Assign_OK (N); 6864 6865 else 6866 Maybe_In_Place_OK := False; 6867 end if; 6868 6869 -- If this is an array of tasks, it will be expanded into build-in-place 6870 -- assignments. Build an activation chain for the tasks now. 6871 6872 if Has_Task (Etype (N)) then 6873 Build_Activation_Chain_Entity (N); 6874 end if; 6875 6876 -- Perform in-place expansion of aggregate in an object declaration. 6877 -- Note: actions generated for the aggregate will be captured in an 6878 -- expression-with-actions statement so that they can be transferred 6879 -- to freeze actions later if there is an address clause for the 6880 -- object. (Note: we don't use a block statement because this would 6881 -- cause generated freeze nodes to be elaborated in the wrong scope). 6882 6883 -- Arrays of limited components must be built in place. The code 6884 -- previously excluded controlled components but this is an old 6885 -- oversight: the rules in 7.6 (17) are clear. 6886 6887 if Comes_From_Source (Parent_Node) 6888 and then Parent_Kind = N_Object_Declaration 6889 and then Present (Expression (Parent_Node)) 6890 and then not 6891 Must_Slide (N, Etype (Defining_Identifier (Parent_Node)), Typ) 6892 and then not Is_Bit_Packed_Array (Typ) 6893 then 6894 In_Place_Assign_OK_For_Declaration := True; 6895 Tmp := Defining_Identifier (Parent_Node); 6896 Set_No_Initialization (Parent_Node); 6897 Set_Expression (Parent_Node, Empty); 6898 6899 -- Set kind and type of the entity, for use in the analysis 6900 -- of the subsequent assignments. If the nominal type is not 6901 -- constrained, build a subtype from the known bounds of the 6902 -- aggregate. If the declaration has a subtype mark, use it, 6903 -- otherwise use the itype of the aggregate. 6904 6905 Mutate_Ekind (Tmp, E_Variable); 6906 6907 if not Is_Constrained (Typ) then 6908 Build_Constrained_Type (Positional => False); 6909 6910 elsif Is_Entity_Name (Object_Definition (Parent_Node)) 6911 and then Is_Constrained (Entity (Object_Definition (Parent_Node))) 6912 then 6913 Set_Etype (Tmp, Entity (Object_Definition (Parent_Node))); 6914 6915 else 6916 Set_Size_Known_At_Compile_Time (Typ, False); 6917 Set_Etype (Tmp, Typ); 6918 end if; 6919 6920 elsif Maybe_In_Place_OK and then Parent_Kind = N_Allocator then 6921 Set_Expansion_Delayed (N); 6922 return; 6923 6924 -- Limited arrays in return statements are expanded when 6925 -- enclosing construct is expanded. 6926 6927 elsif Maybe_In_Place_OK 6928 and then Parent_Kind = N_Simple_Return_Statement 6929 then 6930 Set_Expansion_Delayed (N); 6931 return; 6932 6933 -- In the remaining cases the aggregate appears in the RHS of an 6934 -- assignment, which may be part of the expansion of an object 6935 -- delaration. If the aggregate is an actual in a call, itself 6936 -- possibly in a RHS, building it in the target is not possible. 6937 6938 elsif Maybe_In_Place_OK 6939 and then Nkind (Parent_Node) not in N_Subprogram_Call 6940 and then Safe_Left_Hand_Side (Name (Parent_Node)) 6941 then 6942 Tmp := Name (Parent_Node); 6943 6944 if Etype (Tmp) /= Etype (N) then 6945 Apply_Length_Check (N, Etype (Tmp)); 6946 6947 if Nkind (N) = N_Raise_Constraint_Error then 6948 6949 -- Static error, nothing further to expand 6950 6951 return; 6952 end if; 6953 end if; 6954 6955 -- If a slice assignment has an aggregate with a single others_choice, 6956 -- the assignment can be done in place even if bounds are not static, 6957 -- by converting it into a loop over the discrete range of the slice. 6958 6959 elsif Maybe_In_Place_OK 6960 and then Nkind (Name (Parent_Node)) = N_Slice 6961 and then Is_Others_Aggregate (N) 6962 then 6963 Tmp := Name (Parent_Node); 6964 6965 -- Set type of aggregate to be type of lhs in assignment, in order 6966 -- to suppress redundant length checks. 6967 6968 Set_Etype (N, Etype (Tmp)); 6969 6970 -- Step 5 6971 6972 -- In-place aggregate expansion is not possible 6973 6974 else 6975 Maybe_In_Place_OK := False; 6976 Tmp := Make_Temporary (Loc, 'A', N); 6977 Tmp_Decl := 6978 Make_Object_Declaration (Loc, 6979 Defining_Identifier => Tmp, 6980 Object_Definition => New_Occurrence_Of (Typ, Loc)); 6981 Set_No_Initialization (Tmp_Decl, True); 6982 Set_Warnings_Off (Tmp); 6983 6984 -- If we are within a loop, the temporary will be pushed on the 6985 -- stack at each iteration. If the aggregate is the expression 6986 -- for an allocator, it will be immediately copied to the heap 6987 -- and can be reclaimed at once. We create a transient scope 6988 -- around the aggregate for this purpose. 6989 6990 if Ekind (Current_Scope) = E_Loop 6991 and then Parent_Kind = N_Allocator 6992 then 6993 Establish_Transient_Scope (N, Manage_Sec_Stack => False); 6994 end if; 6995 6996 Insert_Action (N, Tmp_Decl); 6997 end if; 6998 6999 -- Construct and insert the aggregate code. We can safely suppress index 7000 -- checks because this code is guaranteed not to raise CE on index 7001 -- checks. However we should *not* suppress all checks. 7002 7003 declare 7004 Target : Node_Id; 7005 7006 begin 7007 if Nkind (Tmp) = N_Defining_Identifier then 7008 Target := New_Occurrence_Of (Tmp, Loc); 7009 7010 else 7011 if Has_Default_Init_Comps (N) 7012 and then not Maybe_In_Place_OK 7013 then 7014 -- Ada 2005 (AI-287): This case has not been analyzed??? 7015 7016 raise Program_Error; 7017 end if; 7018 7019 -- Name in assignment is explicit dereference 7020 7021 Target := New_Copy (Tmp); 7022 end if; 7023 7024 -- If we are to generate an in-place assignment for a declaration or 7025 -- an assignment statement, and the assignment can be done directly 7026 -- by the back end, then do not expand further. 7027 7028 -- ??? We can also do that if in-place expansion is not possible but 7029 -- then we could go into an infinite recursion. 7030 7031 if (In_Place_Assign_OK_For_Declaration or else Maybe_In_Place_OK) 7032 and then not CodePeer_Mode 7033 and then not Modify_Tree_For_C 7034 and then not Possible_Bit_Aligned_Component (Target) 7035 and then not Is_Possibly_Unaligned_Slice (Target) 7036 and then Aggr_Assignment_OK_For_Backend (N) 7037 then 7038 if Maybe_In_Place_OK then 7039 return; 7040 end if; 7041 7042 Aggr_Code := 7043 New_List ( 7044 Make_Assignment_Statement (Loc, 7045 Name => Target, 7046 Expression => New_Copy_Tree (N))); 7047 7048 else 7049 Aggr_Code := 7050 Build_Array_Aggr_Code (N, 7051 Ctype => Ctyp, 7052 Index => First_Index (Typ), 7053 Into => Target, 7054 Scalar_Comp => Is_Scalar_Type (Ctyp)); 7055 end if; 7056 7057 -- Save the last assignment statement associated with the aggregate 7058 -- when building a controlled object. This reference is utilized by 7059 -- the finalization machinery when marking an object as successfully 7060 -- initialized. 7061 7062 if Needs_Finalization (Typ) 7063 and then Is_Entity_Name (Target) 7064 and then Present (Entity (Target)) 7065 and then Ekind (Entity (Target)) in E_Constant | E_Variable 7066 then 7067 Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code)); 7068 end if; 7069 end; 7070 7071 -- If the aggregate is the expression in a declaration, the expanded 7072 -- code must be inserted after it. The defining entity might not come 7073 -- from source if this is part of an inlined body, but the declaration 7074 -- itself will. 7075 -- The test below looks very specialized and kludgy??? 7076 7077 if Comes_From_Source (Tmp) 7078 or else 7079 (Nkind (Parent (N)) = N_Object_Declaration 7080 and then Comes_From_Source (Parent (N)) 7081 and then Tmp = Defining_Entity (Parent (N))) 7082 then 7083 if Parent_Kind /= N_Object_Declaration or else Is_Frozen (Tmp) then 7084 Insert_Actions_After (Parent_Node, Aggr_Code); 7085 else 7086 declare 7087 Comp_Stmt : constant Node_Id := 7088 Make_Compound_Statement 7089 (Sloc (Parent_Node), Actions => Aggr_Code); 7090 begin 7091 Insert_Action_After (Parent_Node, Comp_Stmt); 7092 Set_Initialization_Statements (Tmp, Comp_Stmt); 7093 end; 7094 end if; 7095 else 7096 Insert_Actions (N, Aggr_Code); 7097 end if; 7098 7099 -- If the aggregate has been assigned in place, remove the original 7100 -- assignment. 7101 7102 if Parent_Kind = N_Assignment_Statement and then Maybe_In_Place_OK then 7103 Rewrite (Parent_Node, Make_Null_Statement (Loc)); 7104 7105 -- Or else, if a temporary was created, replace the aggregate with it 7106 7107 elsif Parent_Kind /= N_Object_Declaration 7108 or else Tmp /= Defining_Identifier (Parent_Node) 7109 then 7110 Rewrite (N, New_Occurrence_Of (Tmp, Loc)); 7111 Analyze_And_Resolve (N, Typ); 7112 end if; 7113 end Expand_Array_Aggregate; 7114 7115 ------------------------ 7116 -- Expand_N_Aggregate -- 7117 ------------------------ 7118 7119 procedure Expand_N_Aggregate (N : Node_Id) is 7120 T : constant Entity_Id := Etype (N); 7121 begin 7122 -- Record aggregate case 7123 7124 if Is_Record_Type (T) 7125 and then not Is_Private_Type (T) 7126 then 7127 Expand_Record_Aggregate (N); 7128 7129 elsif Has_Aspect (T, Aspect_Aggregate) then 7130 Expand_Container_Aggregate (N); 7131 7132 -- Array aggregate case 7133 7134 else 7135 -- A special case, if we have a string subtype with bounds 1 .. N, 7136 -- where N is known at compile time, and the aggregate is of the 7137 -- form (others => 'x'), with a single choice and no expressions, 7138 -- and N is less than 80 (an arbitrary limit for now), then replace 7139 -- the aggregate by the equivalent string literal (but do not mark 7140 -- it as static since it is not). 7141 7142 -- Note: this entire circuit is redundant with respect to code in 7143 -- Expand_Array_Aggregate that collapses others choices to positional 7144 -- form, but there are two problems with that circuit: 7145 7146 -- a) It is limited to very small cases due to ill-understood 7147 -- interactions with bootstrapping. That limit is removed by 7148 -- use of the No_Implicit_Loops restriction. 7149 7150 -- b) It incorrectly ends up with the resulting expressions being 7151 -- considered static when they are not. For example, the 7152 -- following test should fail: 7153 7154 -- pragma Restrictions (No_Implicit_Loops); 7155 -- package NonSOthers4 is 7156 -- B : constant String (1 .. 6) := (others => 'A'); 7157 -- DH : constant String (1 .. 8) := B & "BB"; 7158 -- X : Integer; 7159 -- pragma Export (C, X, Link_Name => DH); 7160 -- end; 7161 7162 -- But it succeeds (DH looks static to pragma Export) 7163 7164 -- To be sorted out ??? 7165 7166 if Present (Component_Associations (N)) then 7167 declare 7168 CA : constant Node_Id := First (Component_Associations (N)); 7169 MX : constant := 80; 7170 7171 begin 7172 if Nkind (First (Choice_List (CA))) = N_Others_Choice 7173 and then Nkind (Expression (CA)) = N_Character_Literal 7174 and then No (Expressions (N)) 7175 then 7176 declare 7177 X : constant Node_Id := First_Index (T); 7178 EC : constant Node_Id := Expression (CA); 7179 CV : constant Uint := Char_Literal_Value (EC); 7180 CC : constant Int := UI_To_Int (CV); 7181 7182 begin 7183 if Nkind (X) = N_Range 7184 and then Compile_Time_Known_Value (Low_Bound (X)) 7185 and then Expr_Value (Low_Bound (X)) = 1 7186 and then Compile_Time_Known_Value (High_Bound (X)) 7187 then 7188 declare 7189 Hi : constant Uint := Expr_Value (High_Bound (X)); 7190 7191 begin 7192 if Hi <= MX then 7193 Start_String; 7194 7195 for J in 1 .. UI_To_Int (Hi) loop 7196 Store_String_Char (Char_Code (CC)); 7197 end loop; 7198 7199 Rewrite (N, 7200 Make_String_Literal (Sloc (N), 7201 Strval => End_String)); 7202 7203 if CC >= Int (2 ** 16) then 7204 Set_Has_Wide_Wide_Character (N); 7205 elsif CC >= Int (2 ** 8) then 7206 Set_Has_Wide_Character (N); 7207 end if; 7208 7209 Analyze_And_Resolve (N, T); 7210 Set_Is_Static_Expression (N, False); 7211 return; 7212 end if; 7213 end; 7214 end if; 7215 end; 7216 end if; 7217 end; 7218 end if; 7219 7220 -- Not that special case, so normal expansion of array aggregate 7221 7222 Expand_Array_Aggregate (N); 7223 end if; 7224 7225 exception 7226 when RE_Not_Available => 7227 return; 7228 end Expand_N_Aggregate; 7229 7230 -------------------------------- 7231 -- Expand_Container_Aggregate -- 7232 -------------------------------- 7233 7234 procedure Expand_Container_Aggregate (N : Node_Id) is 7235 Loc : constant Source_Ptr := Sloc (N); 7236 Typ : constant Entity_Id := Etype (N); 7237 Asp : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Aggregate); 7238 7239 Empty_Subp : Node_Id := Empty; 7240 Add_Named_Subp : Node_Id := Empty; 7241 Add_Unnamed_Subp : Node_Id := Empty; 7242 New_Indexed_Subp : Node_Id := Empty; 7243 Assign_Indexed_Subp : Node_Id := Empty; 7244 7245 Aggr_Code : constant List_Id := New_List; 7246 Temp : constant Entity_Id := Make_Temporary (Loc, 'C', N); 7247 7248 Comp : Node_Id; 7249 Decl : Node_Id; 7250 Default : Node_Id; 7251 Init_Stat : Node_Id; 7252 Siz : Int; 7253 7254 -- The following are used when the size of the aggregate is not 7255 -- static and requires a dynamic evaluation. 7256 Siz_Decl : Node_Id; 7257 Siz_Exp : Node_Id := Empty; 7258 Count_Type : Entity_Id; 7259 7260 function Aggregate_Size return Int; 7261 -- Compute number of entries in aggregate, including choices 7262 -- that cover a range or subtype, as well as iterated constructs. 7263 -- Return -1 if the size is not known statically, in which case 7264 -- allocate a default size for the aggregate, or build an expression 7265 -- to estimate the size dynamically. 7266 7267 function Build_Siz_Exp (Comp : Node_Id) return Int; 7268 -- When the aggregate contains a single Iterated_Component_Association 7269 -- or Element_Association with non-static bounds, build an expression 7270 -- to be used as the allocated size of the container. This may be an 7271 -- overestimate if a filter is present, but is a safe approximation. 7272 -- If bounds are dynamic the aggregate is created in two passes, and 7273 -- the first generates a loop for the sole purpose of computing the 7274 -- number of elements that will be generated on the seocnd pass. 7275 7276 procedure Expand_Iterated_Component (Comp : Node_Id); 7277 -- Handle iterated_component_association and iterated_Element 7278 -- association by generating a loop over the specified range, 7279 -- given either by a loop parameter specification or an iterator 7280 -- specification. 7281 7282 -------------------- 7283 -- Aggregate_Size -- 7284 -------------------- 7285 7286 function Aggregate_Size return Int is 7287 Comp : Node_Id; 7288 Choice : Node_Id; 7289 Lo, Hi : Node_Id; 7290 Siz : Int := 0; 7291 7292 procedure Add_Range_Size; 7293 -- Compute number of components specified by a component association 7294 -- given by a range or subtype name. 7295 7296 -------------------- 7297 -- Add_Range_Size -- 7298 -------------------- 7299 7300 procedure Add_Range_Size is 7301 begin 7302 -- The bounds of the discrete range are integers or enumeration 7303 -- literals 7304 7305 if Nkind (Lo) = N_Integer_Literal then 7306 Siz := Siz + UI_To_Int (Intval (Hi)) 7307 - UI_To_Int (Intval (Lo)) + 1; 7308 else 7309 Siz := Siz + UI_To_Int (Enumeration_Pos (Hi)) 7310 - UI_To_Int (Enumeration_Pos (Lo)) + 1; 7311 end if; 7312 end Add_Range_Size; 7313 7314 begin 7315 -- Aggregate is either all positional or all named. 7316 7317 if Present (Expressions (N)) then 7318 Siz := List_Length (Expressions (N)); 7319 end if; 7320 7321 if Present (Component_Associations (N)) then 7322 Comp := First (Component_Associations (N)); 7323 -- If there is a single component association it can be 7324 -- an iterated component with dynamic bounds or an element 7325 -- iterator over an iterable object. If it is an array 7326 -- we can use the attribute Length to get its size; 7327 -- for a predefined container the function Length plays 7328 -- the same role. There is no available mechanism for 7329 -- user-defined containers. For now we treat all of these 7330 -- as dynamic. 7331 7332 if List_Length (Component_Associations (N)) = 1 7333 and then Nkind (Comp) in N_Iterated_Component_Association | 7334 N_Iterated_Element_Association 7335 then 7336 return Build_Siz_Exp (Comp); 7337 end if; 7338 7339 -- Otherwise all associations must specify static sizes. 7340 7341 while Present (Comp) loop 7342 Choice := First (Choice_List (Comp)); 7343 7344 while Present (Choice) loop 7345 Analyze (Choice); 7346 7347 if Nkind (Choice) = N_Range then 7348 Lo := Low_Bound (Choice); 7349 Hi := High_Bound (Choice); 7350 Add_Range_Size; 7351 7352 elsif Is_Entity_Name (Choice) 7353 and then Is_Type (Entity (Choice)) 7354 then 7355 Lo := Type_Low_Bound (Entity (Choice)); 7356 Hi := Type_High_Bound (Entity (Choice)); 7357 Add_Range_Size; 7358 7359 Rewrite (Choice, 7360 Make_Range (Loc, 7361 New_Copy_Tree (Lo), 7362 New_Copy_Tree (Hi))); 7363 7364 else 7365 -- Single choice (syntax excludes a subtype 7366 -- indication). 7367 7368 Siz := Siz + 1; 7369 end if; 7370 7371 Next (Choice); 7372 end loop; 7373 Next (Comp); 7374 end loop; 7375 end if; 7376 7377 return Siz; 7378 end Aggregate_Size; 7379 7380 ------------------- 7381 -- Build_Siz_Exp -- 7382 ------------------- 7383 7384 function Build_Siz_Exp (Comp : Node_Id) return Int is 7385 Lo, Hi : Node_Id; 7386 begin 7387 if Nkind (Comp) = N_Range then 7388 Lo := Low_Bound (Comp); 7389 Hi := High_Bound (Comp); 7390 Analyze (Lo); 7391 Analyze (Hi); 7392 7393 -- Compute static size when possible. 7394 7395 if Is_Static_Expression (Lo) 7396 and then Is_Static_Expression (Hi) 7397 then 7398 if Nkind (Lo) = N_Integer_Literal then 7399 Siz := UI_To_Int (Intval (Hi)) - UI_To_Int (Intval (Lo)) + 1; 7400 else 7401 Siz := UI_To_Int (Enumeration_Pos (Hi)) 7402 - UI_To_Int (Enumeration_Pos (Lo)) + 1; 7403 end if; 7404 return Siz; 7405 7406 else 7407 Siz_Exp := 7408 Make_Op_Add (Sloc (Comp), 7409 Left_Opnd => 7410 Make_Op_Subtract (Sloc (Comp), 7411 Left_Opnd => New_Copy_Tree (Hi), 7412 Right_Opnd => New_Copy_Tree (Lo)), 7413 Right_Opnd => 7414 Make_Integer_Literal (Loc, 1)); 7415 return -1; 7416 end if; 7417 7418 elsif Nkind (Comp) = N_Iterated_Component_Association then 7419 return Build_Siz_Exp (First (Discrete_Choices (Comp))); 7420 7421 elsif Nkind (Comp) = N_Iterated_Element_Association then 7422 return -1; 7423 7424 -- ??? Need to create code for a loop and add to generated code, 7425 -- as is done for array aggregates with iterated element 7426 -- associations, instead of using Append operations. 7427 7428 else 7429 return -1; 7430 end if; 7431 end Build_Siz_Exp; 7432 7433 ------------------------------- 7434 -- Expand_Iterated_Component -- 7435 ------------------------------- 7436 7437 procedure Expand_Iterated_Component (Comp : Node_Id) is 7438 Expr : constant Node_Id := Expression (Comp); 7439 7440 Key_Expr : Node_Id := Empty; 7441 Loop_Id : Entity_Id; 7442 L_Range : Node_Id; 7443 L_Iteration_Scheme : Node_Id; 7444 Loop_Stat : Node_Id; 7445 Params : List_Id; 7446 Stats : List_Id; 7447 7448 begin 7449 if Nkind (Comp) = N_Iterated_Element_Association then 7450 Key_Expr := Key_Expression (Comp); 7451 7452 -- We create a new entity as loop identifier in all cases, 7453 -- as is done for generated loops elsewhere, as the loop 7454 -- structure has been previously analyzed. 7455 7456 if Present (Iterator_Specification (Comp)) then 7457 7458 -- Either an Iterator_Specification or a Loop_Parameter_ 7459 -- Specification is present. 7460 7461 L_Iteration_Scheme := 7462 Make_Iteration_Scheme (Loc, 7463 Iterator_Specification => Iterator_Specification (Comp)); 7464 Loop_Id := 7465 Make_Defining_Identifier (Loc, 7466 Chars => Chars (Defining_Identifier 7467 (Iterator_Specification (Comp)))); 7468 Set_Defining_Identifier 7469 (Iterator_Specification (L_Iteration_Scheme), Loop_Id); 7470 7471 else 7472 L_Iteration_Scheme := 7473 Make_Iteration_Scheme (Loc, 7474 Loop_Parameter_Specification => 7475 Loop_Parameter_Specification (Comp)); 7476 Loop_Id := 7477 Make_Defining_Identifier (Loc, 7478 Chars => Chars (Defining_Identifier 7479 (Loop_Parameter_Specification (Comp)))); 7480 Set_Defining_Identifier 7481 (Loop_Parameter_Specification 7482 (L_Iteration_Scheme), Loop_Id); 7483 end if; 7484 else 7485 7486 -- Iterated_Component_Association. 7487 7488 Loop_Id := 7489 Make_Defining_Identifier (Loc, 7490 Chars => Chars (Defining_Identifier (Comp))); 7491 7492 if Present (Iterator_Specification (Comp)) then 7493 L_Iteration_Scheme := 7494 Make_Iteration_Scheme (Loc, 7495 Iterator_Specification => Iterator_Specification (Comp)); 7496 7497 else 7498 -- Loop_Parameter_Specifcation is parsed with a choice list. 7499 -- where the range is the first (and only) choice. 7500 7501 L_Range := Relocate_Node (First (Discrete_Choices (Comp))); 7502 7503 L_Iteration_Scheme := 7504 Make_Iteration_Scheme (Loc, 7505 Loop_Parameter_Specification => 7506 Make_Loop_Parameter_Specification (Loc, 7507 Defining_Identifier => Loop_Id, 7508 Discrete_Subtype_Definition => L_Range)); 7509 end if; 7510 end if; 7511 7512 -- Build insertion statement. For a positional aggregate, only the 7513 -- expression is needed. For a named aggregate, the loop variable, 7514 -- whose type is that of the key, is an additional parameter for 7515 -- the insertion operation. 7516 -- If a Key_Expression is present, it serves as the additional 7517 -- parameter. Otherwise the key is given by the loop parameter 7518 -- itself. 7519 7520 if Present (Add_Unnamed_Subp) 7521 and then No (Add_Named_Subp) 7522 then 7523 Stats := New_List 7524 (Make_Procedure_Call_Statement (Loc, 7525 Name => New_Occurrence_Of (Entity (Add_Unnamed_Subp), Loc), 7526 Parameter_Associations => 7527 New_List (New_Occurrence_Of (Temp, Loc), 7528 New_Copy_Tree (Expr)))); 7529 else 7530 -- Named or indexed aggregate, for which a key is present, 7531 -- possibly with a specified key_expression. 7532 7533 if Present (Key_Expr) then 7534 Params := New_List (New_Occurrence_Of (Temp, Loc), 7535 New_Copy_Tree (Key_Expr), 7536 New_Copy_Tree (Expr)); 7537 else 7538 Params := New_List (New_Occurrence_Of (Temp, Loc), 7539 New_Occurrence_Of (Loop_Id, Loc), 7540 New_Copy_Tree (Expr)); 7541 end if; 7542 7543 Stats := New_List 7544 (Make_Procedure_Call_Statement (Loc, 7545 Name => New_Occurrence_Of (Entity (Add_Named_Subp), Loc), 7546 Parameter_Associations => Params)); 7547 end if; 7548 7549 Loop_Stat := Make_Implicit_Loop_Statement 7550 (Node => N, 7551 Identifier => Empty, 7552 Iteration_Scheme => L_Iteration_Scheme, 7553 Statements => Stats); 7554 Append (Loop_Stat, Aggr_Code); 7555 7556 end Expand_Iterated_Component; 7557 7558 -- Start of processing for Expand_Container_Aggregate 7559 7560 begin 7561 Parse_Aspect_Aggregate (Asp, 7562 Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp, 7563 New_Indexed_Subp, Assign_Indexed_Subp); 7564 7565 -- The constructor for bounded containers is a function with 7566 -- a parameter that sets the size of the container. If the 7567 -- size cannot be determined statically we use a default value 7568 -- or a dynamic expression. 7569 7570 Siz := Aggregate_Size; 7571 7572 if Ekind (Entity (Empty_Subp)) = E_Function 7573 and then Present (First_Formal (Entity (Empty_Subp))) 7574 then 7575 Default := Default_Value (First_Formal (Entity (Empty_Subp))); 7576 7577 -- If aggregate size is not static, we can use default value 7578 -- of formal parameter for allocation. We assume that this 7579 -- (implementation-dependent) value is static, even though 7580 -- the AI does not require it. 7581 7582 -- Create declaration for size: a constant literal in the simple 7583 -- case, an expression if iterated component associations may be 7584 -- involved, the default otherwise. 7585 7586 Count_Type := Etype (First_Formal (Entity (Empty_Subp))); 7587 if Siz = -1 then 7588 if No (Siz_Exp) then 7589 Siz := UI_To_Int (Intval (Default)); 7590 Siz_Exp := Make_Integer_Literal (Loc, Siz); 7591 7592 else 7593 Siz_Exp := Make_Type_Conversion (Loc, 7594 Subtype_Mark => 7595 New_Occurrence_Of (Count_Type, Loc), 7596 Expression => Siz_Exp); 7597 end if; 7598 7599 else 7600 Siz_Exp := Make_Integer_Literal (Loc, Siz); 7601 end if; 7602 7603 Siz_Decl := Make_Object_Declaration (Loc, 7604 Defining_Identifier => Make_Temporary (Loc, 'S', N), 7605 Object_Definition => 7606 New_Occurrence_Of (Count_Type, Loc), 7607 Expression => Siz_Exp); 7608 Append (Siz_Decl, Aggr_Code); 7609 7610 if Nkind (Siz_Exp) = N_Integer_Literal then 7611 Init_Stat := 7612 Make_Object_Declaration (Loc, 7613 Defining_Identifier => Temp, 7614 Object_Definition => New_Occurrence_Of (Typ, Loc), 7615 Expression => Make_Function_Call (Loc, 7616 Name => New_Occurrence_Of (Entity (Empty_Subp), Loc), 7617 Parameter_Associations => 7618 New_List 7619 (New_Occurrence_Of 7620 (Defining_Identifier (Siz_Decl), Loc)))); 7621 7622 else 7623 Init_Stat := 7624 Make_Object_Declaration (Loc, 7625 Defining_Identifier => Temp, 7626 Object_Definition => New_Occurrence_Of (Typ, Loc), 7627 Expression => Make_Function_Call (Loc, 7628 Name => 7629 New_Occurrence_Of (Entity (New_Indexed_Subp), Loc), 7630 Parameter_Associations => 7631 New_List ( 7632 Make_Integer_Literal (Loc, 1), 7633 New_Occurrence_Of 7634 (Defining_Identifier (Siz_Decl), Loc)))); 7635 end if; 7636 7637 Append (Init_Stat, Aggr_Code); 7638 7639 -- Size is dynamic: Create declaration for object, and intitialize 7640 -- with a call to the null container, or an assignment to it. 7641 7642 else 7643 Decl := 7644 Make_Object_Declaration (Loc, 7645 Defining_Identifier => Temp, 7646 Object_Definition => New_Occurrence_Of (Typ, Loc)); 7647 7648 Insert_Action (N, Decl); 7649 7650 -- The Empty entity is either a parameterless function, or 7651 -- a constant. 7652 7653 if Ekind (Entity (Empty_Subp)) = E_Function then 7654 Init_Stat := Make_Assignment_Statement (Loc, 7655 Name => New_Occurrence_Of (Temp, Loc), 7656 Expression => Make_Function_Call (Loc, 7657 Name => New_Occurrence_Of (Entity (Empty_Subp), Loc))); 7658 7659 else 7660 Init_Stat := Make_Assignment_Statement (Loc, 7661 Name => New_Occurrence_Of (Temp, Loc), 7662 Expression => New_Occurrence_Of (Entity (Empty_Subp), Loc)); 7663 end if; 7664 7665 Append (Init_Stat, Aggr_Code); 7666 end if; 7667 7668 --------------------------- 7669 -- Positional aggregate -- 7670 --------------------------- 7671 7672 -- If the aggregate is positional the aspect must include 7673 -- an Add_Unnamed subprogram. 7674 7675 if Present (Add_Unnamed_Subp) then 7676 if Present (Expressions (N)) then 7677 declare 7678 Insert : constant Entity_Id := Entity (Add_Unnamed_Subp); 7679 Comp : Node_Id; 7680 Stat : Node_Id; 7681 7682 begin 7683 Comp := First (Expressions (N)); 7684 while Present (Comp) loop 7685 Stat := Make_Procedure_Call_Statement (Loc, 7686 Name => New_Occurrence_Of (Insert, Loc), 7687 Parameter_Associations => 7688 New_List (New_Occurrence_Of (Temp, Loc), 7689 New_Copy_Tree (Comp))); 7690 Append (Stat, Aggr_Code); 7691 Next (Comp); 7692 end loop; 7693 end; 7694 end if; 7695 7696 -- Indexed aggregates are handled below. Unnamed aggregates 7697 -- such as sets may include iterated component associations. 7698 7699 if No (New_Indexed_Subp) then 7700 Comp := First (Component_Associations (N)); 7701 while Present (Comp) loop 7702 if Nkind (Comp) = N_Iterated_Component_Association then 7703 Expand_Iterated_Component (Comp); 7704 end if; 7705 Next (Comp); 7706 end loop; 7707 end if; 7708 7709 --------------------- 7710 -- Named_Aggregate -- 7711 --------------------- 7712 7713 elsif Present (Add_Named_Subp) then 7714 declare 7715 Insert : constant Entity_Id := Entity (Add_Named_Subp); 7716 Stat : Node_Id; 7717 Key : Node_Id; 7718 begin 7719 Comp := First (Component_Associations (N)); 7720 7721 -- Each component association may contain several choices; 7722 -- generate an insertion statement for each. 7723 7724 while Present (Comp) loop 7725 if Nkind (Comp) in N_Iterated_Component_Association 7726 | N_Iterated_Element_Association 7727 then 7728 Expand_Iterated_Component (Comp); 7729 else 7730 Key := First (Choices (Comp)); 7731 7732 while Present (Key) loop 7733 Stat := Make_Procedure_Call_Statement (Loc, 7734 Name => New_Occurrence_Of (Insert, Loc), 7735 Parameter_Associations => 7736 New_List (New_Occurrence_Of (Temp, Loc), 7737 New_Copy_Tree (Key), 7738 New_Copy_Tree (Expression (Comp)))); 7739 Append (Stat, Aggr_Code); 7740 7741 Next (Key); 7742 end loop; 7743 end if; 7744 7745 Next (Comp); 7746 end loop; 7747 end; 7748 end if; 7749 7750 ----------------------- 7751 -- Indexed_Aggregate -- 7752 ----------------------- 7753 7754 -- For an indexed aggregate there must be an Assigned_Indexeed 7755 -- subprogram. Note that unlike array aggregates, a container 7756 -- aggregate must be fully positional or fully indexed. In the 7757 -- first case the expansion has already taken place. 7758 -- TBA: the keys for an indexed aggregate must provide a dense 7759 -- range with no repetitions. 7760 7761 if Present (Assign_Indexed_Subp) 7762 and then Present (Component_Associations (N)) 7763 then 7764 declare 7765 Insert : constant Entity_Id := Entity (Assign_Indexed_Subp); 7766 Index_Type : constant Entity_Id := 7767 Etype (Next_Formal (First_Formal (Insert))); 7768 7769 function Expand_Range_Component 7770 (Rng : Node_Id; 7771 Expr : Node_Id) return Node_Id; 7772 -- Transform a component assoication with a range into an 7773 -- explicit loop. If the choice is a subtype name, it is 7774 -- rewritten as a range with the corresponding bounds, which 7775 -- are known to be static. 7776 7777 Comp : Node_Id; 7778 Index : Node_Id; 7779 Pos : Int := 0; 7780 Stat : Node_Id; 7781 Key : Node_Id; 7782 7783 ----------------------------- 7784 -- Expand_Raange_Component -- 7785 ----------------------------- 7786 7787 function Expand_Range_Component 7788 (Rng : Node_Id; 7789 Expr : Node_Id) return Node_Id 7790 is 7791 Loop_Id : constant Entity_Id := 7792 Make_Temporary (Loc, 'T'); 7793 7794 L_Iteration_Scheme : Node_Id; 7795 Stats : List_Id; 7796 7797 begin 7798 L_Iteration_Scheme := 7799 Make_Iteration_Scheme (Loc, 7800 Loop_Parameter_Specification => 7801 Make_Loop_Parameter_Specification (Loc, 7802 Defining_Identifier => Loop_Id, 7803 Discrete_Subtype_Definition => New_Copy_Tree (Rng))); 7804 7805 Stats := New_List 7806 (Make_Procedure_Call_Statement (Loc, 7807 Name => 7808 New_Occurrence_Of (Entity (Assign_Indexed_Subp), Loc), 7809 Parameter_Associations => 7810 New_List (New_Occurrence_Of (Temp, Loc), 7811 New_Occurrence_Of (Loop_Id, Loc), 7812 New_Copy_Tree (Expr)))); 7813 7814 return Make_Implicit_Loop_Statement 7815 (Node => N, 7816 Identifier => Empty, 7817 Iteration_Scheme => L_Iteration_Scheme, 7818 Statements => Stats); 7819 end Expand_Range_Component; 7820 7821 begin 7822 if Siz > 0 then 7823 7824 -- Modify the call to the constructor to allocate the 7825 -- required size for the aggregwte : call the provided 7826 -- constructor rather than the Empty aggregate. 7827 7828 Index := Make_Op_Add (Loc, 7829 Left_Opnd => New_Copy_Tree (Type_Low_Bound (Index_Type)), 7830 Right_Opnd => Make_Integer_Literal (Loc, Siz - 1)); 7831 7832 Set_Expression (Init_Stat, 7833 Make_Function_Call (Loc, 7834 Name => 7835 New_Occurrence_Of (Entity (New_Indexed_Subp), Loc), 7836 Parameter_Associations => 7837 New_List ( 7838 New_Copy_Tree (Type_Low_Bound (Index_Type)), 7839 Index))); 7840 end if; 7841 7842 if Present (Expressions (N)) then 7843 Comp := First (Expressions (N)); 7844 7845 while Present (Comp) loop 7846 7847 -- Compute index position for successive components 7848 -- in the list of expressions, and use the indexed 7849 -- assignment procedure for each. 7850 7851 Index := Make_Op_Add (Loc, 7852 Left_Opnd => Type_Low_Bound (Index_Type), 7853 Right_Opnd => Make_Integer_Literal (Loc, Pos)); 7854 7855 Stat := Make_Procedure_Call_Statement (Loc, 7856 Name => New_Occurrence_Of (Insert, Loc), 7857 Parameter_Associations => 7858 New_List (New_Occurrence_Of (Temp, Loc), 7859 Index, 7860 New_Copy_Tree (Comp))); 7861 7862 Pos := Pos + 1; 7863 7864 Append (Stat, Aggr_Code); 7865 Next (Comp); 7866 end loop; 7867 end if; 7868 7869 if Present (Component_Associations (N)) then 7870 Comp := First (Component_Associations (N)); 7871 7872 -- The choice may be a static value, or a range with 7873 -- static bounds. 7874 7875 while Present (Comp) loop 7876 if Nkind (Comp) = N_Component_Association then 7877 Key := First (Choices (Comp)); 7878 while Present (Key) loop 7879 7880 -- If the expression is a box, the corresponding 7881 -- component (s) is left uninitialized. 7882 7883 if Box_Present (Comp) then 7884 goto Next_Key; 7885 7886 elsif Nkind (Key) = N_Range then 7887 7888 -- Create loop for tne specified range, 7889 -- with copies of the expression. 7890 7891 Stat := 7892 Expand_Range_Component (Key, Expression (Comp)); 7893 7894 else 7895 Stat := Make_Procedure_Call_Statement (Loc, 7896 Name => New_Occurrence_Of 7897 (Entity (Assign_Indexed_Subp), Loc), 7898 Parameter_Associations => 7899 New_List (New_Occurrence_Of (Temp, Loc), 7900 New_Copy_Tree (Key), 7901 New_Copy_Tree (Expression (Comp)))); 7902 end if; 7903 7904 Append (Stat, Aggr_Code); 7905 7906 <<Next_Key>> 7907 Next (Key); 7908 end loop; 7909 7910 else 7911 -- Iterated component association. Discard 7912 -- positional insertion procedure. 7913 7914 Add_Named_Subp := Assign_Indexed_Subp; 7915 Add_Unnamed_Subp := Empty; 7916 Expand_Iterated_Component (Comp); 7917 end if; 7918 7919 Next (Comp); 7920 end loop; 7921 end if; 7922 end; 7923 end if; 7924 7925 Insert_Actions (N, Aggr_Code); 7926 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 7927 Analyze_And_Resolve (N, Typ); 7928 end Expand_Container_Aggregate; 7929 7930 ------------------------------ 7931 -- Expand_N_Delta_Aggregate -- 7932 ------------------------------ 7933 7934 procedure Expand_N_Delta_Aggregate (N : Node_Id) is 7935 Loc : constant Source_Ptr := Sloc (N); 7936 Typ : constant Entity_Id := Etype (Expression (N)); 7937 Decl : Node_Id; 7938 7939 begin 7940 Decl := 7941 Make_Object_Declaration (Loc, 7942 Defining_Identifier => Make_Temporary (Loc, 'T'), 7943 Object_Definition => New_Occurrence_Of (Typ, Loc), 7944 Expression => New_Copy_Tree (Expression (N))); 7945 7946 if Is_Array_Type (Etype (N)) then 7947 Expand_Delta_Array_Aggregate (N, New_List (Decl)); 7948 else 7949 Expand_Delta_Record_Aggregate (N, New_List (Decl)); 7950 end if; 7951 end Expand_N_Delta_Aggregate; 7952 7953 ---------------------------------- 7954 -- Expand_Delta_Array_Aggregate -- 7955 ---------------------------------- 7956 7957 procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id) is 7958 Loc : constant Source_Ptr := Sloc (N); 7959 Temp : constant Entity_Id := Defining_Identifier (First (Deltas)); 7960 Assoc : Node_Id; 7961 7962 function Generate_Loop (C : Node_Id) return Node_Id; 7963 -- Generate a loop containing individual component assignments for 7964 -- choices that are ranges, subtype indications, subtype names, and 7965 -- iterated component associations. 7966 7967 ------------------- 7968 -- Generate_Loop -- 7969 ------------------- 7970 7971 function Generate_Loop (C : Node_Id) return Node_Id is 7972 Sl : constant Source_Ptr := Sloc (C); 7973 Ix : Entity_Id; 7974 7975 begin 7976 if Nkind (Parent (C)) = N_Iterated_Component_Association then 7977 Ix := 7978 Make_Defining_Identifier (Loc, 7979 Chars => (Chars (Defining_Identifier (Parent (C))))); 7980 else 7981 Ix := Make_Temporary (Sl, 'I'); 7982 end if; 7983 7984 return 7985 Make_Loop_Statement (Loc, 7986 Iteration_Scheme => 7987 Make_Iteration_Scheme (Sl, 7988 Loop_Parameter_Specification => 7989 Make_Loop_Parameter_Specification (Sl, 7990 Defining_Identifier => Ix, 7991 Discrete_Subtype_Definition => New_Copy_Tree (C))), 7992 7993 Statements => New_List ( 7994 Make_Assignment_Statement (Sl, 7995 Name => 7996 Make_Indexed_Component (Sl, 7997 Prefix => New_Occurrence_Of (Temp, Sl), 7998 Expressions => New_List (New_Occurrence_Of (Ix, Sl))), 7999 Expression => New_Copy_Tree (Expression (Assoc)))), 8000 End_Label => Empty); 8001 end Generate_Loop; 8002 8003 -- Local variables 8004 8005 Choice : Node_Id; 8006 8007 -- Start of processing for Expand_Delta_Array_Aggregate 8008 8009 begin 8010 Assoc := First (Component_Associations (N)); 8011 while Present (Assoc) loop 8012 Choice := First (Choice_List (Assoc)); 8013 if Nkind (Assoc) = N_Iterated_Component_Association then 8014 while Present (Choice) loop 8015 Append_To (Deltas, Generate_Loop (Choice)); 8016 Next (Choice); 8017 end loop; 8018 8019 else 8020 while Present (Choice) loop 8021 8022 -- Choice can be given by a range, a subtype indication, a 8023 -- subtype name, a scalar value, or an entity. 8024 8025 if Nkind (Choice) = N_Range 8026 or else (Is_Entity_Name (Choice) 8027 and then Is_Type (Entity (Choice))) 8028 then 8029 Append_To (Deltas, Generate_Loop (Choice)); 8030 8031 elsif Nkind (Choice) = N_Subtype_Indication then 8032 Append_To (Deltas, 8033 Generate_Loop (Range_Expression (Constraint (Choice)))); 8034 8035 else 8036 Append_To (Deltas, 8037 Make_Assignment_Statement (Sloc (Choice), 8038 Name => 8039 Make_Indexed_Component (Sloc (Choice), 8040 Prefix => New_Occurrence_Of (Temp, Loc), 8041 Expressions => New_List (New_Copy_Tree (Choice))), 8042 Expression => New_Copy_Tree (Expression (Assoc)))); 8043 end if; 8044 8045 Next (Choice); 8046 end loop; 8047 end if; 8048 8049 Next (Assoc); 8050 end loop; 8051 8052 Insert_Actions (N, Deltas); 8053 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 8054 end Expand_Delta_Array_Aggregate; 8055 8056 ----------------------------------- 8057 -- Expand_Delta_Record_Aggregate -- 8058 ----------------------------------- 8059 8060 procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id) is 8061 Loc : constant Source_Ptr := Sloc (N); 8062 Temp : constant Entity_Id := Defining_Identifier (First (Deltas)); 8063 Assoc : Node_Id; 8064 Choice : Node_Id; 8065 8066 begin 8067 Assoc := First (Component_Associations (N)); 8068 8069 while Present (Assoc) loop 8070 Choice := First (Choice_List (Assoc)); 8071 while Present (Choice) loop 8072 Append_To (Deltas, 8073 Make_Assignment_Statement (Sloc (Choice), 8074 Name => 8075 Make_Selected_Component (Sloc (Choice), 8076 Prefix => New_Occurrence_Of (Temp, Loc), 8077 Selector_Name => Make_Identifier (Loc, Chars (Choice))), 8078 Expression => New_Copy_Tree (Expression (Assoc)))); 8079 Next (Choice); 8080 end loop; 8081 8082 Next (Assoc); 8083 end loop; 8084 8085 Insert_Actions (N, Deltas); 8086 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 8087 end Expand_Delta_Record_Aggregate; 8088 8089 ---------------------------------- 8090 -- Expand_N_Extension_Aggregate -- 8091 ---------------------------------- 8092 8093 -- If the ancestor part is an expression, add a component association for 8094 -- the parent field. If the type of the ancestor part is not the direct 8095 -- parent of the expected type, build recursively the needed ancestors. 8096 -- If the ancestor part is a subtype_mark, replace aggregate with a 8097 -- declaration for a temporary of the expected type, followed by 8098 -- individual assignments to the given components. 8099 8100 procedure Expand_N_Extension_Aggregate (N : Node_Id) is 8101 A : constant Node_Id := Ancestor_Part (N); 8102 Loc : constant Source_Ptr := Sloc (N); 8103 Typ : constant Entity_Id := Etype (N); 8104 8105 begin 8106 -- If the ancestor is a subtype mark, an init proc must be called 8107 -- on the resulting object which thus has to be materialized in 8108 -- the front-end 8109 8110 if Is_Entity_Name (A) and then Is_Type (Entity (A)) then 8111 Convert_To_Assignments (N, Typ); 8112 8113 -- The extension aggregate is transformed into a record aggregate 8114 -- of the following form (c1 and c2 are inherited components) 8115 8116 -- (Exp with c3 => a, c4 => b) 8117 -- ==> (c1 => Exp.c1, c2 => Exp.c2, c3 => a, c4 => b) 8118 8119 else 8120 Set_Etype (N, Typ); 8121 8122 if Tagged_Type_Expansion then 8123 Expand_Record_Aggregate (N, 8124 Orig_Tag => 8125 New_Occurrence_Of 8126 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc), 8127 Parent_Expr => A); 8128 8129 -- No tag is needed in the case of a VM 8130 8131 else 8132 Expand_Record_Aggregate (N, Parent_Expr => A); 8133 end if; 8134 end if; 8135 8136 exception 8137 when RE_Not_Available => 8138 return; 8139 end Expand_N_Extension_Aggregate; 8140 8141 ----------------------------- 8142 -- Expand_Record_Aggregate -- 8143 ----------------------------- 8144 8145 procedure Expand_Record_Aggregate 8146 (N : Node_Id; 8147 Orig_Tag : Node_Id := Empty; 8148 Parent_Expr : Node_Id := Empty) 8149 is 8150 Loc : constant Source_Ptr := Sloc (N); 8151 Comps : constant List_Id := Component_Associations (N); 8152 Typ : constant Entity_Id := Etype (N); 8153 Base_Typ : constant Entity_Id := Base_Type (Typ); 8154 8155 Static_Components : Boolean := True; 8156 -- Flag to indicate whether all components are compile-time known, 8157 -- and the aggregate can be constructed statically and handled by 8158 -- the back-end. Set to False by Component_OK_For_Backend. 8159 8160 procedure Build_Back_End_Aggregate; 8161 -- Build a proper aggregate to be handled by the back-end 8162 8163 function Compile_Time_Known_Composite_Value (N : Node_Id) return Boolean; 8164 -- Returns true if N is an expression of composite type which can be 8165 -- fully evaluated at compile time without raising constraint error. 8166 -- Such expressions can be passed as is to Gigi without any expansion. 8167 -- 8168 -- This returns true for N_Aggregate with Compile_Time_Known_Aggregate 8169 -- set and constants whose expression is such an aggregate, recursively. 8170 8171 function Component_OK_For_Backend return Boolean; 8172 -- Check for presence of a component which makes it impossible for the 8173 -- backend to process the aggregate, thus requiring the use of a series 8174 -- of assignment statements. Cases checked for are a nested aggregate 8175 -- needing Late_Expansion, the presence of a tagged component which may 8176 -- need tag adjustment, and a bit unaligned component reference. 8177 -- 8178 -- We also force expansion into assignments if a component is of a 8179 -- mutable type (including a private type with discriminants) because 8180 -- in that case the size of the component to be copied may be smaller 8181 -- than the side of the target, and there is no simple way for gigi 8182 -- to compute the size of the object to be copied. 8183 -- 8184 -- NOTE: This is part of the ongoing work to define precisely the 8185 -- interface between front-end and back-end handling of aggregates. 8186 -- In general it is desirable to pass aggregates as they are to gigi, 8187 -- in order to minimize elaboration code. This is one case where the 8188 -- semantics of Ada complicate the analysis and lead to anomalies in 8189 -- the gcc back-end if the aggregate is not expanded into assignments. 8190 -- 8191 -- NOTE: This sets the global Static_Components to False in most, but 8192 -- not all, cases when it returns False. 8193 8194 function Has_Per_Object_Constraint (L : List_Id) return Boolean; 8195 -- Return True if any element of L has Has_Per_Object_Constraint set. 8196 -- L should be the Choices component of an N_Component_Association. 8197 8198 function Has_Visible_Private_Ancestor (Id : E) return Boolean; 8199 -- If any ancestor of the current type is private, the aggregate 8200 -- cannot be built in place. We cannot rely on Has_Private_Ancestor, 8201 -- because it will not be set when type and its parent are in the 8202 -- same scope, and the parent component needs expansion. 8203 8204 function Top_Level_Aggregate (N : Node_Id) return Node_Id; 8205 -- For nested aggregates return the ultimate enclosing aggregate; for 8206 -- non-nested aggregates return N. 8207 8208 ------------------------------ 8209 -- Build_Back_End_Aggregate -- 8210 ------------------------------ 8211 8212 procedure Build_Back_End_Aggregate is 8213 Comp : Entity_Id; 8214 New_Comp : Node_Id; 8215 Tag_Value : Node_Id; 8216 8217 begin 8218 if Nkind (N) = N_Aggregate then 8219 8220 -- If the aggregate is static and can be handled by the back-end, 8221 -- nothing left to do. 8222 8223 if Static_Components then 8224 Set_Compile_Time_Known_Aggregate (N); 8225 Set_Expansion_Delayed (N, False); 8226 end if; 8227 end if; 8228 8229 -- If no discriminants, nothing special to do 8230 8231 if not Has_Discriminants (Typ) then 8232 null; 8233 8234 -- Case of discriminants present 8235 8236 elsif Is_Derived_Type (Typ) then 8237 8238 -- For untagged types, non-stored discriminants are replaced with 8239 -- stored discriminants, which are the ones that gigi uses to 8240 -- describe the type and its components. 8241 8242 Generate_Aggregate_For_Derived_Type : declare 8243 procedure Prepend_Stored_Values (T : Entity_Id); 8244 -- Scan the list of stored discriminants of the type, and add 8245 -- their values to the aggregate being built. 8246 8247 --------------------------- 8248 -- Prepend_Stored_Values -- 8249 --------------------------- 8250 8251 procedure Prepend_Stored_Values (T : Entity_Id) is 8252 Discr : Entity_Id; 8253 First_Comp : Node_Id := Empty; 8254 8255 begin 8256 Discr := First_Stored_Discriminant (T); 8257 while Present (Discr) loop 8258 New_Comp := 8259 Make_Component_Association (Loc, 8260 Choices => New_List ( 8261 New_Occurrence_Of (Discr, Loc)), 8262 Expression => 8263 New_Copy_Tree 8264 (Get_Discriminant_Value 8265 (Discr, 8266 Typ, 8267 Discriminant_Constraint (Typ)))); 8268 8269 if No (First_Comp) then 8270 Prepend_To (Component_Associations (N), New_Comp); 8271 else 8272 Insert_After (First_Comp, New_Comp); 8273 end if; 8274 8275 First_Comp := New_Comp; 8276 Next_Stored_Discriminant (Discr); 8277 end loop; 8278 end Prepend_Stored_Values; 8279 8280 -- Local variables 8281 8282 Constraints : constant List_Id := New_List; 8283 8284 Discr : Entity_Id; 8285 Decl : Node_Id; 8286 Num_Disc : Nat := 0; 8287 Num_Stor : Nat := 0; 8288 8289 -- Start of processing for Generate_Aggregate_For_Derived_Type 8290 8291 begin 8292 -- Remove the associations for the discriminant of derived type 8293 8294 declare 8295 First_Comp : Node_Id; 8296 8297 begin 8298 First_Comp := First (Component_Associations (N)); 8299 while Present (First_Comp) loop 8300 Comp := First_Comp; 8301 Next (First_Comp); 8302 8303 if Ekind (Entity (First (Choices (Comp)))) = 8304 E_Discriminant 8305 then 8306 Remove (Comp); 8307 Num_Disc := Num_Disc + 1; 8308 end if; 8309 end loop; 8310 end; 8311 8312 -- Insert stored discriminant associations in the correct 8313 -- order. If there are more stored discriminants than new 8314 -- discriminants, there is at least one new discriminant that 8315 -- constrains more than one of the stored discriminants. In 8316 -- this case we need to construct a proper subtype of the 8317 -- parent type, in order to supply values to all the 8318 -- components. Otherwise there is one-one correspondence 8319 -- between the constraints and the stored discriminants. 8320 8321 Discr := First_Stored_Discriminant (Base_Type (Typ)); 8322 while Present (Discr) loop 8323 Num_Stor := Num_Stor + 1; 8324 Next_Stored_Discriminant (Discr); 8325 end loop; 8326 8327 -- Case of more stored discriminants than new discriminants 8328 8329 if Num_Stor > Num_Disc then 8330 8331 -- Create a proper subtype of the parent type, which is the 8332 -- proper implementation type for the aggregate, and convert 8333 -- it to the intended target type. 8334 8335 Discr := First_Stored_Discriminant (Base_Type (Typ)); 8336 while Present (Discr) loop 8337 New_Comp := 8338 New_Copy_Tree 8339 (Get_Discriminant_Value 8340 (Discr, 8341 Typ, 8342 Discriminant_Constraint (Typ))); 8343 8344 Append (New_Comp, Constraints); 8345 Next_Stored_Discriminant (Discr); 8346 end loop; 8347 8348 Decl := 8349 Make_Subtype_Declaration (Loc, 8350 Defining_Identifier => Make_Temporary (Loc, 'T'), 8351 Subtype_Indication => 8352 Make_Subtype_Indication (Loc, 8353 Subtype_Mark => 8354 New_Occurrence_Of (Etype (Base_Type (Typ)), Loc), 8355 Constraint => 8356 Make_Index_Or_Discriminant_Constraint 8357 (Loc, Constraints))); 8358 8359 Insert_Action (N, Decl); 8360 Prepend_Stored_Values (Base_Type (Typ)); 8361 8362 Set_Etype (N, Defining_Identifier (Decl)); 8363 Set_Analyzed (N); 8364 8365 Rewrite (N, Unchecked_Convert_To (Typ, N)); 8366 Analyze (N); 8367 8368 -- Case where we do not have fewer new discriminants than 8369 -- stored discriminants, so in this case we can simply use the 8370 -- stored discriminants of the subtype. 8371 8372 else 8373 Prepend_Stored_Values (Typ); 8374 end if; 8375 end Generate_Aggregate_For_Derived_Type; 8376 end if; 8377 8378 if Is_Tagged_Type (Typ) then 8379 8380 -- In the tagged case, _parent and _tag component must be created 8381 8382 -- Reset Null_Present unconditionally. Tagged records always have 8383 -- at least one field (the tag or the parent). 8384 8385 Set_Null_Record_Present (N, False); 8386 8387 -- When the current aggregate comes from the expansion of an 8388 -- extension aggregate, the parent expr is replaced by an 8389 -- aggregate formed by selected components of this expr. 8390 8391 if Present (Parent_Expr) and then Is_Empty_List (Comps) then 8392 Comp := First_Component_Or_Discriminant (Typ); 8393 while Present (Comp) loop 8394 8395 -- Skip all expander-generated components 8396 8397 if not Comes_From_Source (Original_Record_Component (Comp)) 8398 then 8399 null; 8400 8401 else 8402 New_Comp := 8403 Make_Selected_Component (Loc, 8404 Prefix => 8405 Unchecked_Convert_To (Typ, 8406 Duplicate_Subexpr (Parent_Expr, True)), 8407 Selector_Name => New_Occurrence_Of (Comp, Loc)); 8408 8409 Append_To (Comps, 8410 Make_Component_Association (Loc, 8411 Choices => New_List ( 8412 New_Occurrence_Of (Comp, Loc)), 8413 Expression => New_Comp)); 8414 8415 Analyze_And_Resolve (New_Comp, Etype (Comp)); 8416 end if; 8417 8418 Next_Component_Or_Discriminant (Comp); 8419 end loop; 8420 end if; 8421 8422 -- Compute the value for the Tag now, if the type is a root it 8423 -- will be included in the aggregate right away, otherwise it will 8424 -- be propagated to the parent aggregate. 8425 8426 if Present (Orig_Tag) then 8427 Tag_Value := Orig_Tag; 8428 8429 elsif not Tagged_Type_Expansion then 8430 Tag_Value := Empty; 8431 8432 else 8433 Tag_Value := 8434 New_Occurrence_Of 8435 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc); 8436 end if; 8437 8438 -- For a derived type, an aggregate for the parent is formed with 8439 -- all the inherited components. 8440 8441 if Is_Derived_Type (Typ) then 8442 declare 8443 First_Comp : Node_Id; 8444 Parent_Comps : List_Id; 8445 Parent_Aggr : Node_Id; 8446 Parent_Name : Node_Id; 8447 8448 begin 8449 -- Remove the inherited component association from the 8450 -- aggregate and store them in the parent aggregate 8451 8452 First_Comp := First (Component_Associations (N)); 8453 Parent_Comps := New_List; 8454 while Present (First_Comp) 8455 and then 8456 Scope (Original_Record_Component 8457 (Entity (First (Choices (First_Comp))))) /= 8458 Base_Typ 8459 loop 8460 Comp := First_Comp; 8461 Next (First_Comp); 8462 Remove (Comp); 8463 Append (Comp, Parent_Comps); 8464 end loop; 8465 8466 Parent_Aggr := 8467 Make_Aggregate (Loc, 8468 Component_Associations => Parent_Comps); 8469 Set_Etype (Parent_Aggr, Etype (Base_Type (Typ))); 8470 8471 -- Find the _parent component 8472 8473 Comp := First_Component (Typ); 8474 while Chars (Comp) /= Name_uParent loop 8475 Next_Component (Comp); 8476 end loop; 8477 8478 Parent_Name := New_Occurrence_Of (Comp, Loc); 8479 8480 -- Insert the parent aggregate 8481 8482 Prepend_To (Component_Associations (N), 8483 Make_Component_Association (Loc, 8484 Choices => New_List (Parent_Name), 8485 Expression => Parent_Aggr)); 8486 8487 -- Expand recursively the parent propagating the right Tag 8488 8489 Expand_Record_Aggregate 8490 (Parent_Aggr, Tag_Value, Parent_Expr); 8491 8492 -- The ancestor part may be a nested aggregate that has 8493 -- delayed expansion: recheck now. 8494 8495 if not Component_OK_For_Backend then 8496 Convert_To_Assignments (N, Typ); 8497 end if; 8498 end; 8499 8500 -- For a root type, the tag component is added (unless compiling 8501 -- for the VMs, where tags are implicit). 8502 8503 elsif Tagged_Type_Expansion then 8504 declare 8505 Tag_Name : constant Node_Id := 8506 New_Occurrence_Of 8507 (First_Tag_Component (Typ), Loc); 8508 Typ_Tag : constant Entity_Id := RTE (RE_Tag); 8509 Conv_Node : constant Node_Id := 8510 Unchecked_Convert_To (Typ_Tag, Tag_Value); 8511 8512 begin 8513 Set_Etype (Conv_Node, Typ_Tag); 8514 Prepend_To (Component_Associations (N), 8515 Make_Component_Association (Loc, 8516 Choices => New_List (Tag_Name), 8517 Expression => Conv_Node)); 8518 end; 8519 end if; 8520 end if; 8521 end Build_Back_End_Aggregate; 8522 8523 ---------------------------------------- 8524 -- Compile_Time_Known_Composite_Value -- 8525 ---------------------------------------- 8526 8527 function Compile_Time_Known_Composite_Value 8528 (N : Node_Id) return Boolean 8529 is 8530 begin 8531 -- If we have an entity name, then see if it is the name of a 8532 -- constant and if so, test the corresponding constant value. 8533 8534 if Is_Entity_Name (N) then 8535 declare 8536 E : constant Entity_Id := Entity (N); 8537 V : Node_Id; 8538 begin 8539 if Ekind (E) /= E_Constant then 8540 return False; 8541 else 8542 V := Constant_Value (E); 8543 return Present (V) 8544 and then Compile_Time_Known_Composite_Value (V); 8545 end if; 8546 end; 8547 8548 -- We have a value, see if it is compile time known 8549 8550 else 8551 if Nkind (N) = N_Aggregate then 8552 return Compile_Time_Known_Aggregate (N); 8553 end if; 8554 8555 -- All other types of values are not known at compile time 8556 8557 return False; 8558 end if; 8559 8560 end Compile_Time_Known_Composite_Value; 8561 8562 ------------------------------ 8563 -- Component_OK_For_Backend -- 8564 ------------------------------ 8565 8566 function Component_OK_For_Backend return Boolean is 8567 C : Node_Id; 8568 Expr_Q : Node_Id; 8569 8570 begin 8571 C := First (Comps); 8572 while Present (C) loop 8573 8574 -- If the component has box initialization, expansion is needed 8575 -- and component is not ready for backend. 8576 8577 if Box_Present (C) then 8578 return False; 8579 end if; 8580 8581 if Nkind (Expression (C)) = N_Qualified_Expression then 8582 Expr_Q := Expression (Expression (C)); 8583 else 8584 Expr_Q := Expression (C); 8585 end if; 8586 8587 -- Return False for array components whose bounds raise 8588 -- constraint error. 8589 8590 declare 8591 Comp : constant Entity_Id := First (Choices (C)); 8592 Indx : Node_Id; 8593 8594 begin 8595 if Present (Etype (Comp)) 8596 and then Is_Array_Type (Etype (Comp)) 8597 then 8598 Indx := First_Index (Etype (Comp)); 8599 while Present (Indx) loop 8600 if Nkind (Type_Low_Bound (Etype (Indx))) = 8601 N_Raise_Constraint_Error 8602 or else Nkind (Type_High_Bound (Etype (Indx))) = 8603 N_Raise_Constraint_Error 8604 then 8605 return False; 8606 end if; 8607 8608 Next_Index (Indx); 8609 end loop; 8610 end if; 8611 end; 8612 8613 -- Return False if the aggregate has any associations for tagged 8614 -- components that may require tag adjustment. 8615 8616 -- These are cases where the source expression may have a tag that 8617 -- could differ from the component tag (e.g., can occur for type 8618 -- conversions and formal parameters). (Tag adjustment not needed 8619 -- if Tagged_Type_Expansion because object tags are implicit in 8620 -- the machine.) 8621 8622 if Is_Tagged_Type (Etype (Expr_Q)) 8623 and then 8624 (Nkind (Expr_Q) = N_Type_Conversion 8625 or else 8626 (Is_Entity_Name (Expr_Q) 8627 and then Is_Formal (Entity (Expr_Q)))) 8628 and then Tagged_Type_Expansion 8629 then 8630 Static_Components := False; 8631 return False; 8632 8633 elsif Is_Delayed_Aggregate (Expr_Q) then 8634 Static_Components := False; 8635 return False; 8636 8637 elsif Nkind (Expr_Q) = N_Quantified_Expression then 8638 Static_Components := False; 8639 return False; 8640 8641 elsif Possible_Bit_Aligned_Component (Expr_Q) then 8642 Static_Components := False; 8643 return False; 8644 8645 elsif Modify_Tree_For_C 8646 and then Nkind (C) = N_Component_Association 8647 and then Has_Per_Object_Constraint (Choices (C)) 8648 then 8649 Static_Components := False; 8650 return False; 8651 8652 elsif Modify_Tree_For_C 8653 and then Nkind (Expr_Q) = N_Identifier 8654 and then Is_Array_Type (Etype (Expr_Q)) 8655 then 8656 Static_Components := False; 8657 return False; 8658 8659 elsif Modify_Tree_For_C 8660 and then Nkind (Expr_Q) = N_Type_Conversion 8661 and then Is_Array_Type (Etype (Expr_Q)) 8662 then 8663 Static_Components := False; 8664 return False; 8665 end if; 8666 8667 if Is_Elementary_Type (Etype (Expr_Q)) then 8668 if not Compile_Time_Known_Value (Expr_Q) then 8669 Static_Components := False; 8670 end if; 8671 8672 elsif not Compile_Time_Known_Composite_Value (Expr_Q) then 8673 Static_Components := False; 8674 8675 if Is_Private_Type (Etype (Expr_Q)) 8676 and then Has_Discriminants (Etype (Expr_Q)) 8677 then 8678 return False; 8679 end if; 8680 end if; 8681 8682 Next (C); 8683 end loop; 8684 8685 return True; 8686 end Component_OK_For_Backend; 8687 8688 ------------------------------- 8689 -- Has_Per_Object_Constraint -- 8690 ------------------------------- 8691 8692 function Has_Per_Object_Constraint (L : List_Id) return Boolean is 8693 N : Node_Id := First (L); 8694 begin 8695 while Present (N) loop 8696 if Is_Entity_Name (N) 8697 and then Present (Entity (N)) 8698 and then Has_Per_Object_Constraint (Entity (N)) 8699 then 8700 return True; 8701 end if; 8702 8703 Next (N); 8704 end loop; 8705 8706 return False; 8707 end Has_Per_Object_Constraint; 8708 8709 ----------------------------------- 8710 -- Has_Visible_Private_Ancestor -- 8711 ----------------------------------- 8712 8713 function Has_Visible_Private_Ancestor (Id : E) return Boolean is 8714 R : constant Entity_Id := Root_Type (Id); 8715 T1 : Entity_Id := Id; 8716 8717 begin 8718 loop 8719 if Is_Private_Type (T1) then 8720 return True; 8721 8722 elsif T1 = R then 8723 return False; 8724 8725 else 8726 T1 := Etype (T1); 8727 end if; 8728 end loop; 8729 end Has_Visible_Private_Ancestor; 8730 8731 ------------------------- 8732 -- Top_Level_Aggregate -- 8733 ------------------------- 8734 8735 function Top_Level_Aggregate (N : Node_Id) return Node_Id is 8736 Aggr : Node_Id; 8737 8738 begin 8739 Aggr := N; 8740 while Present (Parent (Aggr)) 8741 and then Nkind (Parent (Aggr)) in 8742 N_Aggregate | N_Component_Association 8743 loop 8744 Aggr := Parent (Aggr); 8745 end loop; 8746 8747 return Aggr; 8748 end Top_Level_Aggregate; 8749 8750 -- Local variables 8751 8752 Top_Level_Aggr : constant Node_Id := Top_Level_Aggregate (N); 8753 8754 -- Start of processing for Expand_Record_Aggregate 8755 8756 begin 8757 -- If the aggregate is to be assigned to a full access variable, we have 8758 -- to prevent a piecemeal assignment even if the aggregate is to be 8759 -- expanded. We create a temporary for the aggregate, and assign the 8760 -- temporary instead, so that the back end can generate an atomic move 8761 -- for it. 8762 8763 if Is_Full_Access_Aggregate (N) then 8764 return; 8765 8766 -- No special management required for aggregates used to initialize 8767 -- statically allocated dispatch tables 8768 8769 elsif Is_Static_Dispatch_Table_Aggregate (N) then 8770 return; 8771 8772 -- Case pattern aggregates need to remain as aggregates 8773 8774 elsif Is_Case_Choice_Pattern (N) then 8775 return; 8776 end if; 8777 8778 -- If the pragma Aggregate_Individually_Assign is set, always convert to 8779 -- assignments. 8780 8781 if Aggregate_Individually_Assign then 8782 Convert_To_Assignments (N, Typ); 8783 8784 -- Ada 2005 (AI-318-2): We need to convert to assignments if components 8785 -- are build-in-place function calls. The assignments will each turn 8786 -- into a build-in-place function call. If components are all static, 8787 -- we can pass the aggregate to the back end regardless of limitedness. 8788 8789 -- Extension aggregates, aggregates in extended return statements, and 8790 -- aggregates for C++ imported types must be expanded. 8791 8792 elsif Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then 8793 if Nkind (Parent (N)) not in 8794 N_Component_Association | N_Object_Declaration 8795 then 8796 Convert_To_Assignments (N, Typ); 8797 8798 elsif Nkind (N) = N_Extension_Aggregate 8799 or else Convention (Typ) = Convention_CPP 8800 then 8801 Convert_To_Assignments (N, Typ); 8802 8803 elsif not Size_Known_At_Compile_Time (Typ) 8804 or else not Component_OK_For_Backend 8805 or else not Static_Components 8806 then 8807 Convert_To_Assignments (N, Typ); 8808 8809 -- In all other cases, build a proper aggregate to be handled by 8810 -- the back-end. 8811 8812 else 8813 Build_Back_End_Aggregate; 8814 end if; 8815 8816 -- Gigi doesn't properly handle temporaries of variable size so we 8817 -- generate it in the front-end 8818 8819 elsif not Size_Known_At_Compile_Time (Typ) 8820 and then Tagged_Type_Expansion 8821 then 8822 Convert_To_Assignments (N, Typ); 8823 8824 -- An aggregate used to initialize a controlled object must be turned 8825 -- into component assignments as the components themselves may require 8826 -- finalization actions such as adjustment. 8827 8828 elsif Needs_Finalization (Typ) then 8829 Convert_To_Assignments (N, Typ); 8830 8831 -- Ada 2005 (AI-287): In case of default initialized components we 8832 -- convert the aggregate into assignments. 8833 8834 elsif Has_Default_Init_Comps (N) then 8835 Convert_To_Assignments (N, Typ); 8836 8837 -- Check components 8838 8839 elsif not Component_OK_For_Backend then 8840 Convert_To_Assignments (N, Typ); 8841 8842 -- If an ancestor is private, some components are not inherited and we 8843 -- cannot expand into a record aggregate. 8844 8845 elsif Has_Visible_Private_Ancestor (Typ) then 8846 Convert_To_Assignments (N, Typ); 8847 8848 -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi 8849 -- is not able to handle the aggregate for Late_Request. 8850 8851 elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then 8852 Convert_To_Assignments (N, Typ); 8853 8854 -- If the tagged types covers interface types we need to initialize all 8855 -- hidden components containing pointers to secondary dispatch tables. 8856 8857 elsif Is_Tagged_Type (Typ) and then Has_Interfaces (Typ) then 8858 Convert_To_Assignments (N, Typ); 8859 8860 -- If some components are mutable, the size of the aggregate component 8861 -- may be distinct from the default size of the type component, so 8862 -- we need to expand to insure that the back-end copies the proper 8863 -- size of the data. However, if the aggregate is the initial value of 8864 -- a constant, the target is immutable and might be built statically 8865 -- if components are appropriate. 8866 8867 elsif Has_Mutable_Components (Typ) 8868 and then 8869 (Nkind (Parent (Top_Level_Aggr)) /= N_Object_Declaration 8870 or else not Constant_Present (Parent (Top_Level_Aggr)) 8871 or else not Static_Components) 8872 then 8873 Convert_To_Assignments (N, Typ); 8874 8875 -- If the type involved has bit aligned components, then we are not sure 8876 -- that the back end can handle this case correctly. 8877 8878 elsif Type_May_Have_Bit_Aligned_Components (Typ) then 8879 Convert_To_Assignments (N, Typ); 8880 8881 -- When generating C, only generate an aggregate when declaring objects 8882 -- since C does not support aggregates in e.g. assignment statements. 8883 8884 elsif Modify_Tree_For_C and then not Is_CCG_Supported_Aggregate (N) then 8885 Convert_To_Assignments (N, Typ); 8886 8887 -- In all other cases, build a proper aggregate to be handled by gigi 8888 8889 else 8890 Build_Back_End_Aggregate; 8891 end if; 8892 end Expand_Record_Aggregate; 8893 8894 --------------------- 8895 -- Get_Base_Object -- 8896 --------------------- 8897 8898 function Get_Base_Object (N : Node_Id) return Entity_Id is 8899 R : Node_Id; 8900 8901 begin 8902 R := Get_Referenced_Object (N); 8903 8904 while Nkind (R) in N_Indexed_Component | N_Selected_Component | N_Slice 8905 loop 8906 R := Get_Referenced_Object (Prefix (R)); 8907 end loop; 8908 8909 if Is_Entity_Name (R) and then Is_Object (Entity (R)) then 8910 return Entity (R); 8911 else 8912 return Empty; 8913 end if; 8914 end Get_Base_Object; 8915 8916 ---------------------------- 8917 -- Has_Default_Init_Comps -- 8918 ---------------------------- 8919 8920 function Has_Default_Init_Comps (N : Node_Id) return Boolean is 8921 Assoc : Node_Id; 8922 Expr : Node_Id; 8923 -- Component association and expression, respectively 8924 8925 begin 8926 pragma Assert (Nkind (N) in N_Aggregate | N_Extension_Aggregate); 8927 8928 if Has_Self_Reference (N) then 8929 return True; 8930 end if; 8931 8932 Assoc := First (Component_Associations (N)); 8933 while Present (Assoc) loop 8934 -- Each component association has either a box or an expression 8935 8936 pragma Assert (Box_Present (Assoc) xor Present (Expression (Assoc))); 8937 8938 -- Check if any direct component has default initialized components 8939 8940 if Box_Present (Assoc) then 8941 return True; 8942 8943 -- Recursive call in case of aggregate expression 8944 8945 else 8946 Expr := Expression (Assoc); 8947 8948 if Nkind (Expr) in N_Aggregate | N_Extension_Aggregate 8949 and then Has_Default_Init_Comps (Expr) 8950 then 8951 return True; 8952 end if; 8953 end if; 8954 8955 Next (Assoc); 8956 end loop; 8957 8958 return False; 8959 end Has_Default_Init_Comps; 8960 8961 ---------------------------------------- 8962 -- Is_Build_In_Place_Aggregate_Return -- 8963 ---------------------------------------- 8964 8965 function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean is 8966 P : Node_Id := Parent (N); 8967 8968 begin 8969 while Nkind (P) = N_Qualified_Expression loop 8970 P := Parent (P); 8971 end loop; 8972 8973 if Nkind (P) = N_Simple_Return_Statement then 8974 null; 8975 8976 elsif Nkind (Parent (P)) = N_Extended_Return_Statement then 8977 P := Parent (P); 8978 8979 else 8980 return False; 8981 end if; 8982 8983 return 8984 Is_Build_In_Place_Function 8985 (Return_Applies_To (Return_Statement_Entity (P))); 8986 end Is_Build_In_Place_Aggregate_Return; 8987 8988 -------------------------- 8989 -- Is_Delayed_Aggregate -- 8990 -------------------------- 8991 8992 function Is_Delayed_Aggregate (N : Node_Id) return Boolean is 8993 Node : Node_Id := N; 8994 Kind : Node_Kind := Nkind (Node); 8995 8996 begin 8997 if Kind = N_Qualified_Expression then 8998 Node := Expression (Node); 8999 Kind := Nkind (Node); 9000 end if; 9001 9002 return Kind in N_Aggregate | N_Extension_Aggregate 9003 and then Expansion_Delayed (Node); 9004 end Is_Delayed_Aggregate; 9005 9006 -------------------------------- 9007 -- Is_CCG_Supported_Aggregate -- 9008 -------------------------------- 9009 9010 function Is_CCG_Supported_Aggregate 9011 (N : Node_Id) return Boolean 9012 is 9013 P : Node_Id := Parent (N); 9014 9015 begin 9016 -- Aggregates are not supported for nonstandard rep clauses, since they 9017 -- may lead to extra padding fields in CCG. 9018 9019 if Is_Record_Type (Etype (N)) 9020 and then Has_Non_Standard_Rep (Etype (N)) 9021 then 9022 return False; 9023 end if; 9024 9025 while Present (P) and then Nkind (P) = N_Aggregate loop 9026 P := Parent (P); 9027 end loop; 9028 9029 -- Check cases where aggregates are supported by the CCG backend 9030 9031 if Nkind (P) = N_Object_Declaration then 9032 declare 9033 P_Typ : constant Entity_Id := Etype (Defining_Identifier (P)); 9034 9035 begin 9036 if Is_Record_Type (P_Typ) then 9037 return True; 9038 else 9039 return Compile_Time_Known_Bounds (P_Typ); 9040 end if; 9041 end; 9042 9043 elsif Nkind (P) = N_Qualified_Expression then 9044 if Nkind (Parent (P)) = N_Object_Declaration then 9045 declare 9046 P_Typ : constant Entity_Id := 9047 Etype (Defining_Identifier (Parent (P))); 9048 begin 9049 if Is_Record_Type (P_Typ) then 9050 return True; 9051 else 9052 return Compile_Time_Known_Bounds (P_Typ); 9053 end if; 9054 end; 9055 9056 elsif Nkind (Parent (P)) = N_Allocator then 9057 return True; 9058 end if; 9059 end if; 9060 9061 return False; 9062 end Is_CCG_Supported_Aggregate; 9063 9064 ---------------------------------------- 9065 -- Is_Static_Dispatch_Table_Aggregate -- 9066 ---------------------------------------- 9067 9068 function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean is 9069 Typ : constant Entity_Id := Base_Type (Etype (N)); 9070 9071 begin 9072 return Building_Static_Dispatch_Tables 9073 and then Tagged_Type_Expansion 9074 9075 -- Avoid circularity when rebuilding the compiler 9076 9077 and then not Is_RTU (Cunit_Entity (Get_Source_Unit (N)), Ada_Tags) 9078 and then (Is_RTE (Typ, RE_Dispatch_Table_Wrapper) 9079 or else 9080 Is_RTE (Typ, RE_Address_Array) 9081 or else 9082 Is_RTE (Typ, RE_Type_Specific_Data) 9083 or else 9084 Is_RTE (Typ, RE_Tag_Table) 9085 or else 9086 Is_RTE (Typ, RE_Object_Specific_Data) 9087 or else 9088 Is_RTE (Typ, RE_Interface_Data) 9089 or else 9090 Is_RTE (Typ, RE_Interfaces_Array) 9091 or else 9092 Is_RTE (Typ, RE_Interface_Data_Element)); 9093 end Is_Static_Dispatch_Table_Aggregate; 9094 9095 ----------------------------- 9096 -- Is_Two_Dim_Packed_Array -- 9097 ----------------------------- 9098 9099 function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean is 9100 C : constant Uint := Component_Size (Typ); 9101 begin 9102 return Number_Dimensions (Typ) = 2 9103 and then Is_Bit_Packed_Array (Typ) 9104 and then C in Uint_1 | Uint_2 | Uint_4; -- False if No_Uint 9105 end Is_Two_Dim_Packed_Array; 9106 9107 -------------------- 9108 -- Late_Expansion -- 9109 -------------------- 9110 9111 function Late_Expansion 9112 (N : Node_Id; 9113 Typ : Entity_Id; 9114 Target : Node_Id) return List_Id 9115 is 9116 Aggr_Code : List_Id; 9117 New_Aggr : Node_Id; 9118 9119 begin 9120 if Is_Array_Type (Typ) then 9121 -- If the assignment can be done directly by the back end, then 9122 -- reset Set_Expansion_Delayed and do not expand further. 9123 9124 if not CodePeer_Mode 9125 and then not Modify_Tree_For_C 9126 and then not Possible_Bit_Aligned_Component (Target) 9127 and then not Is_Possibly_Unaligned_Slice (Target) 9128 and then Aggr_Assignment_OK_For_Backend (N) 9129 then 9130 New_Aggr := New_Copy_Tree (N); 9131 Set_Expansion_Delayed (New_Aggr, False); 9132 9133 Aggr_Code := 9134 New_List ( 9135 Make_OK_Assignment_Statement (Sloc (New_Aggr), 9136 Name => Target, 9137 Expression => New_Aggr)); 9138 9139 -- Or else, generate component assignments to it 9140 9141 else 9142 Aggr_Code := 9143 Build_Array_Aggr_Code 9144 (N => N, 9145 Ctype => Component_Type (Typ), 9146 Index => First_Index (Typ), 9147 Into => Target, 9148 Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)), 9149 Indexes => No_List); 9150 end if; 9151 9152 -- Directly or indirectly (e.g. access protected procedure) a record 9153 9154 else 9155 Aggr_Code := Build_Record_Aggr_Code (N, Typ, Target); 9156 end if; 9157 9158 -- Save the last assignment statement associated with the aggregate 9159 -- when building a controlled object. This reference is utilized by 9160 -- the finalization machinery when marking an object as successfully 9161 -- initialized. 9162 9163 if Needs_Finalization (Typ) 9164 and then Is_Entity_Name (Target) 9165 and then Present (Entity (Target)) 9166 and then Ekind (Entity (Target)) in E_Constant | E_Variable 9167 then 9168 Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code)); 9169 end if; 9170 9171 return Aggr_Code; 9172 end Late_Expansion; 9173 9174 ---------------------------------- 9175 -- Make_OK_Assignment_Statement -- 9176 ---------------------------------- 9177 9178 function Make_OK_Assignment_Statement 9179 (Sloc : Source_Ptr; 9180 Name : Node_Id; 9181 Expression : Node_Id) return Node_Id 9182 is 9183 begin 9184 Set_Assignment_OK (Name); 9185 return Make_Assignment_Statement (Sloc, Name, Expression); 9186 end Make_OK_Assignment_Statement; 9187 9188 ------------------------ 9189 -- Max_Aggregate_Size -- 9190 ------------------------ 9191 9192 function Max_Aggregate_Size 9193 (N : Node_Id; 9194 Default_Size : Nat := 5000) return Nat 9195 is 9196 function Use_Small_Size (N : Node_Id) return Boolean; 9197 -- True if we should return a very small size, which means large 9198 -- aggregates will be implemented as a loop when possible (potentially 9199 -- transformed to memset calls). 9200 9201 function Aggr_Context (N : Node_Id) return Node_Id; 9202 -- Return the context in which the aggregate appears, not counting 9203 -- qualified expressions and similar. 9204 9205 ------------------ 9206 -- Aggr_Context -- 9207 ------------------ 9208 9209 function Aggr_Context (N : Node_Id) return Node_Id is 9210 Result : Node_Id := Parent (N); 9211 begin 9212 if Nkind (Result) in N_Qualified_Expression 9213 | N_Type_Conversion 9214 | N_Unchecked_Type_Conversion 9215 | N_If_Expression 9216 | N_Case_Expression 9217 | N_Component_Association 9218 | N_Aggregate 9219 then 9220 Result := Aggr_Context (Result); 9221 end if; 9222 9223 return Result; 9224 end Aggr_Context; 9225 9226 -------------------- 9227 -- Use_Small_Size -- 9228 -------------------- 9229 9230 function Use_Small_Size (N : Node_Id) return Boolean is 9231 C : constant Node_Id := Aggr_Context (N); 9232 -- The decision depends on the context in which the aggregate occurs, 9233 -- and for variable declarations, whether we are nested inside a 9234 -- subprogram. 9235 begin 9236 case Nkind (C) is 9237 -- True for assignment statements and similar 9238 9239 when N_Assignment_Statement 9240 | N_Simple_Return_Statement 9241 | N_Allocator 9242 | N_Attribute_Reference 9243 => 9244 return True; 9245 9246 -- True for nested variable declarations. False for library level 9247 -- variables, and for constants (whether or not nested). 9248 9249 when N_Object_Declaration => 9250 return not Constant_Present (C) 9251 and then Is_Subprogram (Current_Scope); 9252 9253 -- False for all other contexts 9254 9255 when others => 9256 return False; 9257 end case; 9258 end Use_Small_Size; 9259 9260 -- Local variables 9261 9262 Typ : constant Entity_Id := Etype (N); 9263 9264 -- Start of processing for Max_Aggregate_Size 9265 9266 begin 9267 -- We use a small limit in CodePeer mode where we favor loops instead of 9268 -- thousands of single assignments (from large aggregates). 9269 9270 -- We also increase the limit to 2**24 (about 16 million) if 9271 -- Restrictions (No_Elaboration_Code) or Restrictions 9272 -- (No_Implicit_Loops) is specified, since in either case we are at risk 9273 -- of declaring the program illegal because of this limit. We also 9274 -- increase the limit when Static_Elaboration_Desired, given that this 9275 -- means that objects are intended to be placed in data memory. 9276 9277 -- Same if the aggregate is for a packed two-dimensional array, because 9278 -- if components are static it is much more efficient to construct a 9279 -- one-dimensional equivalent array with static components. 9280 9281 if CodePeer_Mode then 9282 return 100; 9283 elsif Restriction_Active (No_Elaboration_Code) 9284 or else Restriction_Active (No_Implicit_Loops) 9285 or else Is_Two_Dim_Packed_Array (Typ) 9286 or else (Ekind (Current_Scope) = E_Package 9287 and then Static_Elaboration_Desired (Current_Scope)) 9288 then 9289 return 2 ** 24; 9290 elsif Use_Small_Size (N) then 9291 return 64; 9292 end if; 9293 9294 return Default_Size; 9295 end Max_Aggregate_Size; 9296 9297 ----------------------- 9298 -- Number_Of_Choices -- 9299 ----------------------- 9300 9301 function Number_Of_Choices (N : Node_Id) return Nat is 9302 Assoc : Node_Id; 9303 Choice : Node_Id; 9304 9305 Nb_Choices : Nat := 0; 9306 9307 begin 9308 if Present (Expressions (N)) then 9309 return 0; 9310 end if; 9311 9312 Assoc := First (Component_Associations (N)); 9313 while Present (Assoc) loop 9314 Choice := First (Choice_List (Assoc)); 9315 while Present (Choice) loop 9316 if Nkind (Choice) /= N_Others_Choice then 9317 Nb_Choices := Nb_Choices + 1; 9318 end if; 9319 9320 Next (Choice); 9321 end loop; 9322 9323 Next (Assoc); 9324 end loop; 9325 9326 return Nb_Choices; 9327 end Number_Of_Choices; 9328 9329 ------------------------------------ 9330 -- Packed_Array_Aggregate_Handled -- 9331 ------------------------------------ 9332 9333 -- The current version of this procedure will handle at compile time 9334 -- any array aggregate that meets these conditions: 9335 9336 -- One and two dimensional, bit packed 9337 -- Underlying packed type is modular type 9338 -- Bounds are within 32-bit Int range 9339 -- All bounds and values are static 9340 9341 -- Note: for now, in the 2-D case, we only handle component sizes of 9342 -- 1, 2, 4 (cases where an integral number of elements occupies a byte). 9343 9344 function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean is 9345 Loc : constant Source_Ptr := Sloc (N); 9346 Typ : constant Entity_Id := Etype (N); 9347 Ctyp : constant Entity_Id := Component_Type (Typ); 9348 9349 Not_Handled : exception; 9350 -- Exception raised if this aggregate cannot be handled 9351 9352 begin 9353 -- Handle one- or two dimensional bit packed array 9354 9355 if not Is_Bit_Packed_Array (Typ) 9356 or else Number_Dimensions (Typ) > 2 9357 then 9358 return False; 9359 end if; 9360 9361 -- If two-dimensional, check whether it can be folded, and transformed 9362 -- into a one-dimensional aggregate for the Packed_Array_Impl_Type of 9363 -- the original type. 9364 9365 if Number_Dimensions (Typ) = 2 then 9366 return Two_Dim_Packed_Array_Handled (N); 9367 end if; 9368 9369 if not Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)) then 9370 return False; 9371 end if; 9372 9373 if not Is_Scalar_Type (Ctyp) then 9374 return False; 9375 end if; 9376 9377 declare 9378 Csiz : constant Nat := UI_To_Int (Component_Size (Typ)); 9379 9380 function Get_Component_Val (N : Node_Id) return Uint; 9381 -- Given a expression value N of the component type Ctyp, returns a 9382 -- value of Csiz (component size) bits representing this value. If 9383 -- the value is nonstatic or any other reason exists why the value 9384 -- cannot be returned, then Not_Handled is raised. 9385 9386 ----------------------- 9387 -- Get_Component_Val -- 9388 ----------------------- 9389 9390 function Get_Component_Val (N : Node_Id) return Uint is 9391 Val : Uint; 9392 9393 begin 9394 -- We have to analyze the expression here before doing any further 9395 -- processing here. The analysis of such expressions is deferred 9396 -- till expansion to prevent some problems of premature analysis. 9397 9398 Analyze_And_Resolve (N, Ctyp); 9399 9400 -- Must have a compile time value. String literals have to be 9401 -- converted into temporaries as well, because they cannot easily 9402 -- be converted into their bit representation. 9403 9404 if not Compile_Time_Known_Value (N) 9405 or else Nkind (N) = N_String_Literal 9406 then 9407 raise Not_Handled; 9408 end if; 9409 9410 Val := Expr_Rep_Value (N); 9411 9412 -- Adjust for bias, and strip proper number of bits 9413 9414 if Has_Biased_Representation (Ctyp) then 9415 Val := Val - Expr_Value (Type_Low_Bound (Ctyp)); 9416 end if; 9417 9418 return Val mod Uint_2 ** Csiz; 9419 end Get_Component_Val; 9420 9421 Bounds : constant Range_Nodes := Get_Index_Bounds (First_Index (Typ)); 9422 9423 -- Here we know we have a one dimensional bit packed array 9424 9425 begin 9426 -- Cannot do anything if bounds are dynamic 9427 9428 if not (Compile_Time_Known_Value (Bounds.First) 9429 and then 9430 Compile_Time_Known_Value (Bounds.Last)) 9431 then 9432 return False; 9433 end if; 9434 9435 declare 9436 Bounds_Vals : Range_Values; 9437 -- Compile-time known values of bounds 9438 begin 9439 -- Or are silly out of range of int bounds 9440 9441 Bounds_Vals.First := Expr_Value (Bounds.First); 9442 Bounds_Vals.Last := Expr_Value (Bounds.Last); 9443 9444 if not UI_Is_In_Int_Range (Bounds_Vals.First) 9445 or else 9446 not UI_Is_In_Int_Range (Bounds_Vals.Last) 9447 then 9448 return False; 9449 end if; 9450 9451 -- At this stage we have a suitable aggregate for handling at 9452 -- compile time. The only remaining checks are that the values of 9453 -- expressions in the aggregate are compile-time known (checks are 9454 -- performed by Get_Component_Val), and that any subtypes or 9455 -- ranges are statically known. 9456 9457 -- If the aggregate is not fully positional at this stage, then 9458 -- convert it to positional form. Either this will fail, in which 9459 -- case we can do nothing, or it will succeed, in which case we 9460 -- have succeeded in handling the aggregate and transforming it 9461 -- into a modular value, or it will stay an aggregate, in which 9462 -- case we have failed to create a packed value for it. 9463 9464 if Present (Component_Associations (N)) then 9465 Convert_To_Positional (N, Handle_Bit_Packed => True); 9466 return Nkind (N) /= N_Aggregate; 9467 end if; 9468 9469 -- Otherwise we are all positional, so convert to proper value 9470 9471 declare 9472 Len : constant Nat := 9473 Int'Max (0, UI_To_Int (Bounds_Vals.Last) - 9474 UI_To_Int (Bounds_Vals.First) + 1); 9475 -- The length of the array (number of elements) 9476 9477 Aggregate_Val : Uint; 9478 -- Value of aggregate. The value is set in the low order bits 9479 -- of this value. For the little-endian case, the values are 9480 -- stored from low-order to high-order and for the big-endian 9481 -- case the values are stored from high order to low order. 9482 -- Note that gigi will take care of the conversions to left 9483 -- justify the value in the big endian case (because of left 9484 -- justified modular type processing), so we do not have to 9485 -- worry about that here. 9486 9487 Lit : Node_Id; 9488 -- Integer literal for resulting constructed value 9489 9490 Shift : Nat; 9491 -- Shift count from low order for next value 9492 9493 Incr : Int; 9494 -- Shift increment for loop 9495 9496 Expr : Node_Id; 9497 -- Next expression from positional parameters of aggregate 9498 9499 Left_Justified : Boolean; 9500 -- Set True if we are filling the high order bits of the target 9501 -- value (i.e. the value is left justified). 9502 9503 begin 9504 -- For little endian, we fill up the low order bits of the 9505 -- target value. For big endian we fill up the high order bits 9506 -- of the target value (which is a left justified modular 9507 -- value). 9508 9509 Left_Justified := Bytes_Big_Endian; 9510 9511 -- Switch justification if using -gnatd8 9512 9513 if Debug_Flag_8 then 9514 Left_Justified := not Left_Justified; 9515 end if; 9516 9517 -- Switch justfification if reverse storage order 9518 9519 if Reverse_Storage_Order (Base_Type (Typ)) then 9520 Left_Justified := not Left_Justified; 9521 end if; 9522 9523 if Left_Justified then 9524 Shift := Csiz * (Len - 1); 9525 Incr := -Csiz; 9526 else 9527 Shift := 0; 9528 Incr := +Csiz; 9529 end if; 9530 9531 -- Loop to set the values 9532 9533 if Len = 0 then 9534 Aggregate_Val := Uint_0; 9535 else 9536 Expr := First (Expressions (N)); 9537 Aggregate_Val := Get_Component_Val (Expr) * Uint_2 ** Shift; 9538 9539 for J in 2 .. Len loop 9540 Shift := Shift + Incr; 9541 Next (Expr); 9542 Aggregate_Val := 9543 Aggregate_Val + 9544 Get_Component_Val (Expr) * Uint_2 ** Shift; 9545 end loop; 9546 end if; 9547 9548 -- Now we can rewrite with the proper value 9549 9550 Lit := Make_Integer_Literal (Loc, Intval => Aggregate_Val); 9551 Set_Print_In_Hex (Lit); 9552 9553 -- Construct the expression using this literal. Note that it 9554 -- is important to qualify the literal with its proper modular 9555 -- type since universal integer does not have the required 9556 -- range and also this is a left justified modular type, 9557 -- which is important in the big-endian case. 9558 9559 Rewrite (N, 9560 Unchecked_Convert_To (Typ, 9561 Make_Qualified_Expression (Loc, 9562 Subtype_Mark => 9563 New_Occurrence_Of (Packed_Array_Impl_Type (Typ), Loc), 9564 Expression => Lit))); 9565 9566 Analyze_And_Resolve (N, Typ); 9567 return True; 9568 end; 9569 end; 9570 end; 9571 9572 exception 9573 when Not_Handled => 9574 return False; 9575 end Packed_Array_Aggregate_Handled; 9576 9577 ---------------------------- 9578 -- Has_Mutable_Components -- 9579 ---------------------------- 9580 9581 function Has_Mutable_Components (Typ : Entity_Id) return Boolean is 9582 Comp : Entity_Id; 9583 Ctyp : Entity_Id; 9584 9585 begin 9586 Comp := First_Component (Typ); 9587 while Present (Comp) loop 9588 Ctyp := Underlying_Type (Etype (Comp)); 9589 if Is_Record_Type (Ctyp) 9590 and then Has_Discriminants (Ctyp) 9591 and then not Is_Constrained (Ctyp) 9592 then 9593 return True; 9594 end if; 9595 9596 Next_Component (Comp); 9597 end loop; 9598 9599 return False; 9600 end Has_Mutable_Components; 9601 9602 ------------------------------ 9603 -- Initialize_Discriminants -- 9604 ------------------------------ 9605 9606 procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id) is 9607 Loc : constant Source_Ptr := Sloc (N); 9608 Bas : constant Entity_Id := Base_Type (Typ); 9609 Par : constant Entity_Id := Etype (Bas); 9610 Decl : constant Node_Id := Parent (Par); 9611 Ref : Node_Id; 9612 9613 begin 9614 if Is_Tagged_Type (Bas) 9615 and then Is_Derived_Type (Bas) 9616 and then Has_Discriminants (Par) 9617 and then Has_Discriminants (Bas) 9618 and then Number_Discriminants (Bas) /= Number_Discriminants (Par) 9619 and then Nkind (Decl) = N_Full_Type_Declaration 9620 and then Nkind (Type_Definition (Decl)) = N_Record_Definition 9621 and then 9622 Present (Variant_Part (Component_List (Type_Definition (Decl)))) 9623 and then Nkind (N) /= N_Extension_Aggregate 9624 then 9625 9626 -- Call init proc to set discriminants. 9627 -- There should eventually be a special procedure for this ??? 9628 9629 Ref := New_Occurrence_Of (Defining_Identifier (N), Loc); 9630 Insert_Actions_After (N, 9631 Build_Initialization_Call (Sloc (N), Ref, Typ)); 9632 end if; 9633 end Initialize_Discriminants; 9634 9635 ---------------- 9636 -- Must_Slide -- 9637 ---------------- 9638 9639 function Must_Slide 9640 (Aggr : Node_Id; 9641 Obj_Type : Entity_Id; 9642 Typ : Entity_Id) return Boolean 9643 is 9644 begin 9645 -- No sliding if the type of the object is not established yet, if it is 9646 -- an unconstrained type whose actual subtype comes from the aggregate, 9647 -- or if the two types are identical. If the aggregate contains only 9648 -- an Others_Clause it gets its type from the context and no sliding 9649 -- is involved either. 9650 9651 if not Is_Array_Type (Obj_Type) then 9652 return False; 9653 9654 elsif not Is_Constrained (Obj_Type) then 9655 return False; 9656 9657 elsif Typ = Obj_Type then 9658 return False; 9659 9660 elsif Is_Others_Aggregate (Aggr) then 9661 return False; 9662 9663 else 9664 -- Sliding can only occur along the first dimension 9665 -- If any the bounds of non-static sliding is required 9666 -- to force potential range checks. 9667 9668 declare 9669 Bounds1 : constant Range_Nodes := 9670 Get_Index_Bounds (First_Index (Typ)); 9671 Bounds2 : constant Range_Nodes := 9672 Get_Index_Bounds (First_Index (Obj_Type)); 9673 9674 begin 9675 if not Is_OK_Static_Expression (Bounds1.First) or else 9676 not Is_OK_Static_Expression (Bounds2.First) or else 9677 not Is_OK_Static_Expression (Bounds1.Last) or else 9678 not Is_OK_Static_Expression (Bounds2.Last) 9679 then 9680 return True; 9681 9682 else 9683 return Expr_Value (Bounds1.First) /= Expr_Value (Bounds2.First) 9684 or else 9685 Expr_Value (Bounds1.Last) /= Expr_Value (Bounds2.Last); 9686 end if; 9687 end; 9688 end if; 9689 end Must_Slide; 9690 9691 --------------------------------- 9692 -- Process_Transient_Component -- 9693 --------------------------------- 9694 9695 procedure Process_Transient_Component 9696 (Loc : Source_Ptr; 9697 Comp_Typ : Entity_Id; 9698 Init_Expr : Node_Id; 9699 Fin_Call : out Node_Id; 9700 Hook_Clear : out Node_Id; 9701 Aggr : Node_Id := Empty; 9702 Stmts : List_Id := No_List) 9703 is 9704 procedure Add_Item (Item : Node_Id); 9705 -- Insert arbitrary node Item into the tree depending on the values of 9706 -- Aggr and Stmts. 9707 9708 -------------- 9709 -- Add_Item -- 9710 -------------- 9711 9712 procedure Add_Item (Item : Node_Id) is 9713 begin 9714 if Present (Aggr) then 9715 Insert_Action (Aggr, Item); 9716 else 9717 pragma Assert (Present (Stmts)); 9718 Append_To (Stmts, Item); 9719 end if; 9720 end Add_Item; 9721 9722 -- Local variables 9723 9724 Hook_Assign : Node_Id; 9725 Hook_Decl : Node_Id; 9726 Ptr_Decl : Node_Id; 9727 Res_Decl : Node_Id; 9728 Res_Id : Entity_Id; 9729 Res_Typ : Entity_Id; 9730 9731 -- Start of processing for Process_Transient_Component 9732 9733 begin 9734 -- Add the access type, which provides a reference to the function 9735 -- result. Generate: 9736 9737 -- type Res_Typ is access all Comp_Typ; 9738 9739 Res_Typ := Make_Temporary (Loc, 'A'); 9740 Mutate_Ekind (Res_Typ, E_General_Access_Type); 9741 Set_Directly_Designated_Type (Res_Typ, Comp_Typ); 9742 9743 Add_Item 9744 (Make_Full_Type_Declaration (Loc, 9745 Defining_Identifier => Res_Typ, 9746 Type_Definition => 9747 Make_Access_To_Object_Definition (Loc, 9748 All_Present => True, 9749 Subtype_Indication => New_Occurrence_Of (Comp_Typ, Loc)))); 9750 9751 -- Add the temporary which captures the result of the function call. 9752 -- Generate: 9753 9754 -- Res : constant Res_Typ := Init_Expr'Reference; 9755 9756 -- Note that this temporary is effectively a transient object because 9757 -- its lifetime is bounded by the current array or record component. 9758 9759 Res_Id := Make_Temporary (Loc, 'R'); 9760 Mutate_Ekind (Res_Id, E_Constant); 9761 Set_Etype (Res_Id, Res_Typ); 9762 9763 -- Mark the transient object as successfully processed to avoid double 9764 -- finalization. 9765 9766 Set_Is_Finalized_Transient (Res_Id); 9767 9768 -- Signal the general finalization machinery that this transient object 9769 -- should not be considered for finalization actions because its cleanup 9770 -- will be performed by Process_Transient_Component_Completion. 9771 9772 Set_Is_Ignored_Transient (Res_Id); 9773 9774 Res_Decl := 9775 Make_Object_Declaration (Loc, 9776 Defining_Identifier => Res_Id, 9777 Constant_Present => True, 9778 Object_Definition => New_Occurrence_Of (Res_Typ, Loc), 9779 Expression => 9780 Make_Reference (Loc, New_Copy_Tree (Init_Expr))); 9781 9782 Add_Item (Res_Decl); 9783 9784 -- Construct all pieces necessary to hook and finalize the transient 9785 -- result. 9786 9787 Build_Transient_Object_Statements 9788 (Obj_Decl => Res_Decl, 9789 Fin_Call => Fin_Call, 9790 Hook_Assign => Hook_Assign, 9791 Hook_Clear => Hook_Clear, 9792 Hook_Decl => Hook_Decl, 9793 Ptr_Decl => Ptr_Decl); 9794 9795 -- Add the access type which provides a reference to the transient 9796 -- result. Generate: 9797 9798 -- type Ptr_Typ is access all Comp_Typ; 9799 9800 Add_Item (Ptr_Decl); 9801 9802 -- Add the temporary which acts as a hook to the transient result. 9803 -- Generate: 9804 9805 -- Hook : Ptr_Typ := null; 9806 9807 Add_Item (Hook_Decl); 9808 9809 -- Attach the transient result to the hook. Generate: 9810 9811 -- Hook := Ptr_Typ (Res); 9812 9813 Add_Item (Hook_Assign); 9814 9815 -- The original initialization expression now references the value of 9816 -- the temporary function result. Generate: 9817 9818 -- Res.all 9819 9820 Rewrite (Init_Expr, 9821 Make_Explicit_Dereference (Loc, 9822 Prefix => New_Occurrence_Of (Res_Id, Loc))); 9823 end Process_Transient_Component; 9824 9825 -------------------------------------------- 9826 -- Process_Transient_Component_Completion -- 9827 -------------------------------------------- 9828 9829 procedure Process_Transient_Component_Completion 9830 (Loc : Source_Ptr; 9831 Aggr : Node_Id; 9832 Fin_Call : Node_Id; 9833 Hook_Clear : Node_Id; 9834 Stmts : List_Id) 9835 is 9836 Exceptions_OK : constant Boolean := 9837 not Restriction_Active (No_Exception_Propagation); 9838 9839 begin 9840 pragma Assert (Present (Hook_Clear)); 9841 9842 -- Generate the following code if exception propagation is allowed: 9843 9844 -- declare 9845 -- Abort : constant Boolean := Triggered_By_Abort; 9846 -- <or> 9847 -- Abort : constant Boolean := False; -- no abort 9848 9849 -- E : Exception_Occurrence; 9850 -- Raised : Boolean := False; 9851 9852 -- begin 9853 -- [Abort_Defer;] 9854 9855 -- begin 9856 -- Hook := null; 9857 -- [Deep_]Finalize (Res.all); 9858 9859 -- exception 9860 -- when others => 9861 -- if not Raised then 9862 -- Raised := True; 9863 -- Save_Occurrence (E, 9864 -- Get_Curent_Excep.all.all); 9865 -- end if; 9866 -- end; 9867 9868 -- [Abort_Undefer;] 9869 9870 -- if Raised and then not Abort then 9871 -- Raise_From_Controlled_Operation (E); 9872 -- end if; 9873 -- end; 9874 9875 if Exceptions_OK then 9876 Abort_And_Exception : declare 9877 Blk_Decls : constant List_Id := New_List; 9878 Blk_Stmts : constant List_Id := New_List; 9879 Fin_Stmts : constant List_Id := New_List; 9880 9881 Fin_Data : Finalization_Exception_Data; 9882 9883 begin 9884 -- Create the declarations of the two flags and the exception 9885 -- occurrence. 9886 9887 Build_Object_Declarations (Fin_Data, Blk_Decls, Loc); 9888 9889 -- Generate: 9890 -- Abort_Defer; 9891 9892 if Abort_Allowed then 9893 Append_To (Blk_Stmts, 9894 Build_Runtime_Call (Loc, RE_Abort_Defer)); 9895 end if; 9896 9897 -- Wrap the hook clear and the finalization call in order to trap 9898 -- a potential exception. 9899 9900 Append_To (Fin_Stmts, Hook_Clear); 9901 9902 if Present (Fin_Call) then 9903 Append_To (Fin_Stmts, Fin_Call); 9904 end if; 9905 9906 Append_To (Blk_Stmts, 9907 Make_Block_Statement (Loc, 9908 Handled_Statement_Sequence => 9909 Make_Handled_Sequence_Of_Statements (Loc, 9910 Statements => Fin_Stmts, 9911 Exception_Handlers => New_List ( 9912 Build_Exception_Handler (Fin_Data))))); 9913 9914 -- Generate: 9915 -- Abort_Undefer; 9916 9917 if Abort_Allowed then 9918 Append_To (Blk_Stmts, 9919 Build_Runtime_Call (Loc, RE_Abort_Undefer)); 9920 end if; 9921 9922 -- Reraise the potential exception with a proper "upgrade" to 9923 -- Program_Error if needed. 9924 9925 Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data)); 9926 9927 -- Wrap everything in a block 9928 9929 Append_To (Stmts, 9930 Make_Block_Statement (Loc, 9931 Declarations => Blk_Decls, 9932 Handled_Statement_Sequence => 9933 Make_Handled_Sequence_Of_Statements (Loc, 9934 Statements => Blk_Stmts))); 9935 end Abort_And_Exception; 9936 9937 -- Generate the following code if exception propagation is not allowed 9938 -- and aborts are allowed: 9939 9940 -- begin 9941 -- Abort_Defer; 9942 -- Hook := null; 9943 -- [Deep_]Finalize (Res.all); 9944 -- at end 9945 -- Abort_Undefer_Direct; 9946 -- end; 9947 9948 elsif Abort_Allowed then 9949 Abort_Only : declare 9950 Blk_Stmts : constant List_Id := New_List; 9951 9952 begin 9953 Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); 9954 Append_To (Blk_Stmts, Hook_Clear); 9955 9956 if Present (Fin_Call) then 9957 Append_To (Blk_Stmts, Fin_Call); 9958 end if; 9959 9960 Append_To (Stmts, 9961 Build_Abort_Undefer_Block (Loc, 9962 Stmts => Blk_Stmts, 9963 Context => Aggr)); 9964 end Abort_Only; 9965 9966 -- Otherwise generate: 9967 9968 -- Hook := null; 9969 -- [Deep_]Finalize (Res.all); 9970 9971 else 9972 Append_To (Stmts, Hook_Clear); 9973 9974 if Present (Fin_Call) then 9975 Append_To (Stmts, Fin_Call); 9976 end if; 9977 end if; 9978 end Process_Transient_Component_Completion; 9979 9980 --------------------- 9981 -- Sort_Case_Table -- 9982 --------------------- 9983 9984 procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is 9985 L : constant Int := Case_Table'First; 9986 U : constant Int := Case_Table'Last; 9987 K : Int; 9988 J : Int; 9989 T : Case_Bounds; 9990 9991 begin 9992 K := L; 9993 while K /= U loop 9994 T := Case_Table (K + 1); 9995 9996 J := K + 1; 9997 while J /= L 9998 and then Expr_Value (Case_Table (J - 1).Choice_Lo) > 9999 Expr_Value (T.Choice_Lo) 10000 loop 10001 Case_Table (J) := Case_Table (J - 1); 10002 J := J - 1; 10003 end loop; 10004 10005 Case_Table (J) := T; 10006 K := K + 1; 10007 end loop; 10008 end Sort_Case_Table; 10009 10010 ---------------------------- 10011 -- Static_Array_Aggregate -- 10012 ---------------------------- 10013 10014 function Static_Array_Aggregate (N : Node_Id) return Boolean is 10015 function Is_Static_Component (Nod : Node_Id) return Boolean; 10016 -- Return True if Nod has a compile-time known value and can be passed 10017 -- as is to the back-end without further expansion. 10018 10019 --------------------------- 10020 -- Is_Static_Component -- 10021 --------------------------- 10022 10023 function Is_Static_Component (Nod : Node_Id) return Boolean is 10024 begin 10025 if Nkind (Nod) in N_Integer_Literal | N_Real_Literal then 10026 return True; 10027 10028 elsif Is_Entity_Name (Nod) 10029 and then Present (Entity (Nod)) 10030 and then Ekind (Entity (Nod)) = E_Enumeration_Literal 10031 then 10032 return True; 10033 10034 elsif Nkind (Nod) = N_Aggregate 10035 and then Compile_Time_Known_Aggregate (Nod) 10036 then 10037 return True; 10038 10039 else 10040 return False; 10041 end if; 10042 end Is_Static_Component; 10043 10044 -- Local variables 10045 10046 Bounds : constant Node_Id := Aggregate_Bounds (N); 10047 Typ : constant Entity_Id := Etype (N); 10048 10049 Agg : Node_Id; 10050 Expr : Node_Id; 10051 Lo : Node_Id; 10052 Hi : Node_Id; 10053 10054 -- Start of processing for Static_Array_Aggregate 10055 10056 begin 10057 if Is_Packed (Typ) or else Has_Discriminants (Component_Type (Typ)) then 10058 return False; 10059 end if; 10060 10061 if Present (Bounds) 10062 and then Nkind (Bounds) = N_Range 10063 and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal 10064 and then Nkind (High_Bound (Bounds)) = N_Integer_Literal 10065 then 10066 Lo := Low_Bound (Bounds); 10067 Hi := High_Bound (Bounds); 10068 10069 if No (Component_Associations (N)) then 10070 10071 -- Verify that all components are static 10072 10073 Expr := First (Expressions (N)); 10074 while Present (Expr) loop 10075 if not Is_Static_Component (Expr) then 10076 return False; 10077 end if; 10078 10079 Next (Expr); 10080 end loop; 10081 10082 return True; 10083 10084 else 10085 -- We allow only a single named association, either a static 10086 -- range or an others_clause, with a static expression. 10087 10088 Expr := First (Component_Associations (N)); 10089 10090 if Present (Expressions (N)) then 10091 return False; 10092 10093 elsif Present (Next (Expr)) then 10094 return False; 10095 10096 elsif Present (Next (First (Choice_List (Expr)))) then 10097 return False; 10098 10099 else 10100 -- The aggregate is static if all components are literals, 10101 -- or else all its components are static aggregates for the 10102 -- component type. We also limit the size of a static aggregate 10103 -- to prevent runaway static expressions. 10104 10105 if not Is_Static_Component (Expression (Expr)) then 10106 return False; 10107 end if; 10108 10109 if not Aggr_Size_OK (N) then 10110 return False; 10111 end if; 10112 10113 -- Create a positional aggregate with the right number of 10114 -- copies of the expression. 10115 10116 Agg := Make_Aggregate (Sloc (N), New_List, No_List); 10117 10118 for I in UI_To_Int (Intval (Lo)) .. UI_To_Int (Intval (Hi)) 10119 loop 10120 Append_To (Expressions (Agg), New_Copy (Expression (Expr))); 10121 10122 -- The copied expression must be analyzed and resolved. 10123 -- Besides setting the type, this ensures that static 10124 -- expressions are appropriately marked as such. 10125 10126 Analyze_And_Resolve 10127 (Last (Expressions (Agg)), Component_Type (Typ)); 10128 end loop; 10129 10130 Set_Aggregate_Bounds (Agg, Bounds); 10131 Set_Etype (Agg, Typ); 10132 Set_Analyzed (Agg); 10133 Rewrite (N, Agg); 10134 Set_Compile_Time_Known_Aggregate (N); 10135 10136 return True; 10137 end if; 10138 end if; 10139 10140 else 10141 return False; 10142 end if; 10143 end Static_Array_Aggregate; 10144 10145 ---------------------------------- 10146 -- Two_Dim_Packed_Array_Handled -- 10147 ---------------------------------- 10148 10149 function Two_Dim_Packed_Array_Handled (N : Node_Id) return Boolean is 10150 Loc : constant Source_Ptr := Sloc (N); 10151 Typ : constant Entity_Id := Etype (N); 10152 Ctyp : constant Entity_Id := Component_Type (Typ); 10153 Comp_Size : constant Int := UI_To_Int (Component_Size (Typ)); 10154 Packed_Array : constant Entity_Id := 10155 Packed_Array_Impl_Type (Base_Type (Typ)); 10156 10157 One_Comp : Node_Id; 10158 -- Expression in original aggregate 10159 10160 One_Dim : Node_Id; 10161 -- One-dimensional subaggregate 10162 10163 begin 10164 10165 -- For now, only deal with cases where an integral number of elements 10166 -- fit in a single byte. This includes the most common boolean case. 10167 10168 if not (Comp_Size = 1 or else 10169 Comp_Size = 2 or else 10170 Comp_Size = 4) 10171 then 10172 return False; 10173 end if; 10174 10175 Convert_To_Positional (N, Handle_Bit_Packed => True); 10176 10177 -- Verify that all components are static 10178 10179 if Nkind (N) = N_Aggregate 10180 and then Compile_Time_Known_Aggregate (N) 10181 then 10182 null; 10183 10184 -- The aggregate may have been reanalyzed and converted already 10185 10186 elsif Nkind (N) /= N_Aggregate then 10187 return True; 10188 10189 -- If component associations remain, the aggregate is not static 10190 10191 elsif Present (Component_Associations (N)) then 10192 return False; 10193 10194 else 10195 One_Dim := First (Expressions (N)); 10196 while Present (One_Dim) loop 10197 if Present (Component_Associations (One_Dim)) then 10198 return False; 10199 end if; 10200 10201 One_Comp := First (Expressions (One_Dim)); 10202 while Present (One_Comp) loop 10203 if not Is_OK_Static_Expression (One_Comp) then 10204 return False; 10205 end if; 10206 10207 Next (One_Comp); 10208 end loop; 10209 10210 Next (One_Dim); 10211 end loop; 10212 end if; 10213 10214 -- Two-dimensional aggregate is now fully positional so pack one 10215 -- dimension to create a static one-dimensional array, and rewrite 10216 -- as an unchecked conversion to the original type. 10217 10218 declare 10219 Byte_Size : constant Int := UI_To_Int (Component_Size (Packed_Array)); 10220 -- The packed array type is a byte array 10221 10222 Packed_Num : Nat; 10223 -- Number of components accumulated in current byte 10224 10225 Comps : List_Id; 10226 -- Assembled list of packed values for equivalent aggregate 10227 10228 Comp_Val : Uint; 10229 -- Integer value of component 10230 10231 Incr : Int; 10232 -- Step size for packing 10233 10234 Init_Shift : Int; 10235 -- Endian-dependent start position for packing 10236 10237 Shift : Int; 10238 -- Current insertion position 10239 10240 Val : Int; 10241 -- Component of packed array being assembled 10242 10243 begin 10244 Comps := New_List; 10245 Val := 0; 10246 Packed_Num := 0; 10247 10248 -- Account for endianness. See corresponding comment in 10249 -- Packed_Array_Aggregate_Handled concerning the following. 10250 10251 if Bytes_Big_Endian 10252 xor Debug_Flag_8 10253 xor Reverse_Storage_Order (Base_Type (Typ)) 10254 then 10255 Init_Shift := Byte_Size - Comp_Size; 10256 Incr := -Comp_Size; 10257 else 10258 Init_Shift := 0; 10259 Incr := +Comp_Size; 10260 end if; 10261 10262 -- Iterate over each subaggregate 10263 10264 Shift := Init_Shift; 10265 One_Dim := First (Expressions (N)); 10266 while Present (One_Dim) loop 10267 One_Comp := First (Expressions (One_Dim)); 10268 while Present (One_Comp) loop 10269 if Packed_Num = Byte_Size / Comp_Size then 10270 10271 -- Byte is complete, add to list of expressions 10272 10273 Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps); 10274 Val := 0; 10275 Shift := Init_Shift; 10276 Packed_Num := 0; 10277 10278 else 10279 Comp_Val := Expr_Rep_Value (One_Comp); 10280 10281 -- Adjust for bias, and strip proper number of bits 10282 10283 if Has_Biased_Representation (Ctyp) then 10284 Comp_Val := Comp_Val - Expr_Value (Type_Low_Bound (Ctyp)); 10285 end if; 10286 10287 Comp_Val := Comp_Val mod Uint_2 ** Comp_Size; 10288 Val := UI_To_Int (Val + Comp_Val * Uint_2 ** Shift); 10289 Shift := Shift + Incr; 10290 Next (One_Comp); 10291 Packed_Num := Packed_Num + 1; 10292 end if; 10293 end loop; 10294 10295 Next (One_Dim); 10296 end loop; 10297 10298 if Packed_Num > 0 then 10299 10300 -- Add final incomplete byte if present 10301 10302 Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps); 10303 end if; 10304 10305 Rewrite (N, 10306 Unchecked_Convert_To (Typ, 10307 Make_Qualified_Expression (Loc, 10308 Subtype_Mark => New_Occurrence_Of (Packed_Array, Loc), 10309 Expression => Make_Aggregate (Loc, Expressions => Comps)))); 10310 Analyze_And_Resolve (N); 10311 return True; 10312 end; 10313 end Two_Dim_Packed_Array_Handled; 10314 10315end Exp_Aggr; 10316