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