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