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-2013, 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 Fname; use Fname; 41with Freeze; use Freeze; 42with Itypes; use Itypes; 43with Lib; use Lib; 44with Namet; use Namet; 45with Nmake; use Nmake; 46with Nlists; use Nlists; 47with Opt; use Opt; 48with Restrict; use Restrict; 49with Rident; use Rident; 50with Rtsfind; use Rtsfind; 51with Ttypes; use Ttypes; 52with Sem; use Sem; 53with Sem_Aggr; use Sem_Aggr; 54with Sem_Aux; use Sem_Aux; 55with Sem_Ch3; use Sem_Ch3; 56with Sem_Eval; use Sem_Eval; 57with Sem_Res; use Sem_Res; 58with Sem_Util; use Sem_Util; 59with Sinfo; use Sinfo; 60with Snames; use Snames; 61with Stand; use Stand; 62with Stringt; use Stringt; 63with Targparm; use Targparm; 64with Tbuild; use Tbuild; 65with Uintp; use Uintp; 66 67package body Exp_Aggr is 68 69 type Case_Bounds is record 70 Choice_Lo : Node_Id; 71 Choice_Hi : Node_Id; 72 Choice_Node : Node_Id; 73 end record; 74 75 type Case_Table_Type is array (Nat range <>) of Case_Bounds; 76 -- Table type used by Check_Case_Choices procedure 77 78 function Has_Default_Init_Comps (N : Node_Id) return Boolean; 79 -- N is an aggregate (record or array). Checks the presence of default 80 -- initialization (<>) in any component (Ada 2005: AI-287). 81 82 function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean; 83 -- Returns true if N is an aggregate used to initialize the components 84 -- of a statically allocated dispatch table. 85 86 function Must_Slide 87 (Obj_Type : Entity_Id; 88 Typ : Entity_Id) return Boolean; 89 -- A static array aggregate in an object declaration can in most cases be 90 -- expanded in place. The one exception is when the aggregate is given 91 -- with component associations that specify different bounds from those of 92 -- the type definition in the object declaration. In this pathological 93 -- case the aggregate must slide, and we must introduce an intermediate 94 -- temporary to hold it. 95 -- 96 -- The same holds in an assignment to one-dimensional array of arrays, 97 -- when a component may be given with bounds that differ from those of the 98 -- component type. 99 100 procedure Sort_Case_Table (Case_Table : in out Case_Table_Type); 101 -- Sort the Case Table using the Lower Bound of each Choice as the key. 102 -- A simple insertion sort is used since the number of choices in a case 103 -- statement of variant part will usually be small and probably in near 104 -- sorted order. 105 106 procedure Collect_Initialization_Statements 107 (Obj : Entity_Id; 108 N : Node_Id; 109 Node_After : Node_Id); 110 -- If Obj is not frozen, collect actions inserted after N until, but not 111 -- including, Node_After, for initialization of Obj, and move them to an 112 -- expression with actions, which becomes the Initialization_Statements for 113 -- Obj. 114 115 ------------------------------------------------------ 116 -- Local subprograms for Record Aggregate Expansion -- 117 ------------------------------------------------------ 118 119 function Build_Record_Aggr_Code 120 (N : Node_Id; 121 Typ : Entity_Id; 122 Lhs : Node_Id) return List_Id; 123 -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the 124 -- aggregate. Target is an expression containing the location on which the 125 -- component by component assignments will take place. Returns the list of 126 -- assignments plus all other adjustments needed for tagged and controlled 127 -- types. 128 129 procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id); 130 -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the 131 -- aggregate (which can only be a record type, this procedure is only used 132 -- for record types). Transform the given aggregate into a sequence of 133 -- assignments performed component by component. 134 135 procedure Expand_Record_Aggregate 136 (N : Node_Id; 137 Orig_Tag : Node_Id := Empty; 138 Parent_Expr : Node_Id := Empty); 139 -- This is the top level procedure for record aggregate expansion. 140 -- Expansion for record aggregates needs expand aggregates for tagged 141 -- record types. Specifically Expand_Record_Aggregate adds the Tag 142 -- field in front of the Component_Association list that was created 143 -- during resolution by Resolve_Record_Aggregate. 144 -- 145 -- N is the record aggregate node. 146 -- Orig_Tag is the value of the Tag that has to be provided for this 147 -- specific aggregate. It carries the tag corresponding to the type 148 -- of the outermost aggregate during the recursive expansion 149 -- Parent_Expr is the ancestor part of the original extension 150 -- aggregate 151 152 function Has_Mutable_Components (Typ : Entity_Id) return Boolean; 153 -- Return true if one of the components is of a discriminated type with 154 -- defaults. An aggregate for a type with mutable components must be 155 -- expanded into individual assignments. 156 157 procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id); 158 -- If the type of the aggregate is a type extension with renamed discrimi- 159 -- nants, we must initialize the hidden discriminants of the parent. 160 -- Otherwise, the target object must not be initialized. The discriminants 161 -- are initialized by calling the initialization procedure for the type. 162 -- This is incorrect if the initialization of other components has any 163 -- side effects. We restrict this call to the case where the parent type 164 -- has a variant part, because this is the only case where the hidden 165 -- discriminants are accessed, namely when calling discriminant checking 166 -- functions of the parent type, and when applying a stream attribute to 167 -- an object of the derived type. 168 169 ----------------------------------------------------- 170 -- Local Subprograms for Array Aggregate Expansion -- 171 ----------------------------------------------------- 172 173 function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean; 174 -- Very large static aggregates present problems to the back-end, and are 175 -- transformed into assignments and loops. This function verifies that the 176 -- total number of components of an aggregate is acceptable for rewriting 177 -- into a purely positional static form. Aggr_Size_OK must be called before 178 -- calling Flatten. 179 -- 180 -- This function also detects and warns about one-component aggregates that 181 -- appear in a non-static context. Even if the component value is static, 182 -- such an aggregate must be expanded into an assignment. 183 184 function Backend_Processing_Possible (N : Node_Id) return Boolean; 185 -- This function checks if array aggregate N can be processed directly 186 -- by the backend. If this is the case, True is returned. 187 188 function Build_Array_Aggr_Code 189 (N : Node_Id; 190 Ctype : Entity_Id; 191 Index : Node_Id; 192 Into : Node_Id; 193 Scalar_Comp : Boolean; 194 Indexes : List_Id := No_List) return List_Id; 195 -- This recursive routine returns a list of statements containing the 196 -- loops and assignments that are needed for the expansion of the array 197 -- aggregate N. 198 -- 199 -- N is the (sub-)aggregate node to be expanded into code. This node has 200 -- been fully analyzed, and its Etype is properly set. 201 -- 202 -- Index is the index node corresponding to the array sub-aggregate N 203 -- 204 -- Into is the target expression into which we are copying the aggregate. 205 -- Note that this node may not have been analyzed yet, and so the Etype 206 -- field may not be set. 207 -- 208 -- Scalar_Comp is True if the component type of the aggregate is scalar 209 -- 210 -- Indexes is the current list of expressions used to index the object we 211 -- are writing into. 212 213 procedure Convert_Array_Aggr_In_Allocator 214 (Decl : Node_Id; 215 Aggr : Node_Id; 216 Target : Node_Id); 217 -- If the aggregate appears within an allocator and can be expanded in 218 -- place, this routine generates the individual assignments to components 219 -- of the designated object. This is an optimization over the general 220 -- case, where a temporary is first created on the stack and then used to 221 -- construct the allocated object on the heap. 222 223 procedure Convert_To_Positional 224 (N : Node_Id; 225 Max_Others_Replicate : Nat := 5; 226 Handle_Bit_Packed : Boolean := False); 227 -- If possible, convert named notation to positional notation. This 228 -- conversion is possible only in some static cases. If the conversion is 229 -- possible, then N is rewritten with the analyzed converted aggregate. 230 -- The parameter Max_Others_Replicate controls the maximum number of 231 -- values corresponding to an others choice that will be converted to 232 -- positional notation (the default of 5 is the normal limit, and reflects 233 -- the fact that normally the loop is better than a lot of separate 234 -- assignments). Note that this limit gets overridden in any case if 235 -- either of the restrictions No_Elaboration_Code or No_Implicit_Loops is 236 -- set. The parameter Handle_Bit_Packed is usually set False (since we do 237 -- not expect the back end to handle bit packed arrays, so the normal case 238 -- of conversion is pointless), but in the special case of a call from 239 -- Packed_Array_Aggregate_Handled, we set this parameter to True, since 240 -- these are cases we handle in there. 241 242 -- It would seem worthwhile to have a higher default value for Max_Others_ 243 -- replicate, but aggregates in the compiler make this impossible: the 244 -- compiler bootstrap fails if Max_Others_Replicate is greater than 25. 245 -- This is unexpected ??? 246 247 procedure Expand_Array_Aggregate (N : Node_Id); 248 -- This is the top-level routine to perform array aggregate expansion. 249 -- N is the N_Aggregate node to be expanded. 250 251 function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean; 252 -- For two-dimensional packed aggregates with constant bounds and constant 253 -- components, it is preferable to pack the inner aggregates because the 254 -- whole matrix can then be presented to the back-end as a one-dimensional 255 -- list of literals. This is much more efficient than expanding into single 256 -- component assignments. This function determines if the type Typ is for 257 -- an array that is suitable for this optimization: it returns True if Typ 258 -- is a two dimensional bit packed array with component size 1, 2, or 4. 259 260 function Late_Expansion 261 (N : Node_Id; 262 Typ : Entity_Id; 263 Target : Node_Id) return List_Id; 264 -- This routine implements top-down expansion of nested aggregates. In 265 -- doing so, it avoids the generation of temporaries at each level. N is 266 -- a nested record or array aggregate with the Expansion_Delayed flag. 267 -- Typ is the expected type of the aggregate. Target is a (duplicatable) 268 -- expression that will hold the result of the aggregate expansion. 269 270 function Make_OK_Assignment_Statement 271 (Sloc : Source_Ptr; 272 Name : Node_Id; 273 Expression : Node_Id) return Node_Id; 274 -- This is like Make_Assignment_Statement, except that Assignment_OK 275 -- is set in the left operand. All assignments built by this unit use 276 -- this routine. This is needed to deal with assignments to initialized 277 -- constants that are done in place. 278 279 function Number_Of_Choices (N : Node_Id) return Nat; 280 -- Returns the number of discrete choices (not including the others choice 281 -- if present) contained in (sub-)aggregate N. 282 283 function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean; 284 -- Given an array aggregate, this function handles the case of a packed 285 -- array aggregate with all constant values, where the aggregate can be 286 -- evaluated at compile time. If this is possible, then N is rewritten 287 -- to be its proper compile time value with all the components properly 288 -- assembled. The expression is analyzed and resolved and True is returned. 289 -- If this transformation is not possible, N is unchanged and False is 290 -- returned. 291 292 function Safe_Slice_Assignment (N : Node_Id) return Boolean; 293 -- If a slice assignment has an aggregate with a single others_choice, 294 -- the assignment can be done in place even if bounds are not static, 295 -- by converting it into a loop over the discrete range of the slice. 296 297 function Two_Dim_Packed_Array_Handled (N : Node_Id) return Boolean; 298 -- If the type of the aggregate is a two-dimensional bit_packed array 299 -- it may be transformed into an array of bytes with constant values, 300 -- and presented to the back-end as a static value. The function returns 301 -- false if this transformation cannot be performed. THis is similar to, 302 -- and reuses part of the machinery in Packed_Array_Aggregate_Handled. 303 304 ------------------ 305 -- Aggr_Size_OK -- 306 ------------------ 307 308 function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean is 309 Lo : Node_Id; 310 Hi : Node_Id; 311 Indx : Node_Id; 312 Siz : Int; 313 Lov : Uint; 314 Hiv : Uint; 315 316 Max_Aggr_Size : Nat; 317 -- Determines the maximum size of an array aggregate produced by 318 -- converting named to positional notation (e.g. from others clauses). 319 -- This avoids running away with attempts to convert huge aggregates, 320 -- which hit memory limits in the backend. 321 322 function Component_Count (T : Entity_Id) return Int; 323 -- The limit is applied to the total number of components that the 324 -- aggregate will have, which is the number of static expressions 325 -- that will appear in the flattened array. This requires a recursive 326 -- computation of the number of scalar components of the structure. 327 328 --------------------- 329 -- Component_Count -- 330 --------------------- 331 332 function Component_Count (T : Entity_Id) return Int is 333 Res : Int := 0; 334 Comp : Entity_Id; 335 336 begin 337 if Is_Scalar_Type (T) then 338 return 1; 339 340 elsif Is_Record_Type (T) then 341 Comp := First_Component (T); 342 while Present (Comp) loop 343 Res := Res + Component_Count (Etype (Comp)); 344 Next_Component (Comp); 345 end loop; 346 347 return Res; 348 349 elsif Is_Array_Type (T) then 350 declare 351 Lo : constant Node_Id := 352 Type_Low_Bound (Etype (First_Index (T))); 353 Hi : constant Node_Id := 354 Type_High_Bound (Etype (First_Index (T))); 355 356 Siz : constant Int := Component_Count (Component_Type (T)); 357 358 begin 359 if not Compile_Time_Known_Value (Lo) 360 or else not Compile_Time_Known_Value (Hi) 361 then 362 return 0; 363 else 364 return 365 Siz * UI_To_Int (Expr_Value (Hi) - Expr_Value (Lo) + 1); 366 end if; 367 end; 368 369 else 370 -- Can only be a null for an access type 371 372 return 1; 373 end if; 374 end Component_Count; 375 376 -- Start of processing for Aggr_Size_OK 377 378 begin 379 -- The normal aggregate limit is 50000, but we increase this limit to 380 -- 2**24 (about 16 million) if Restrictions (No_Elaboration_Code) or 381 -- Restrictions (No_Implicit_Loops) is specified, since in either case 382 -- we are at risk of declaring the program illegal because of this 383 -- limit. We also increase the limit when Static_Elaboration_Desired, 384 -- given that this means that objects are intended to be placed in data 385 -- memory. 386 387 -- We also increase the limit if the aggregate is for a packed two- 388 -- dimensional array, because if components are static it is much more 389 -- efficient to construct a one-dimensional equivalent array with static 390 -- components. 391 392 -- Conversely, we decrease the maximum size if none of the above 393 -- requirements apply, and if the aggregate has a single component 394 -- association, which will be more efficient if implemented with a loop. 395 396 -- Finally, we use a small limit in CodePeer mode where we favor loops 397 -- instead of thousands of single assignments (from large aggregates). 398 399 Max_Aggr_Size := 50000; 400 401 if CodePeer_Mode then 402 Max_Aggr_Size := 100; 403 404 elsif Restriction_Active (No_Elaboration_Code) 405 or else Restriction_Active (No_Implicit_Loops) 406 or else Is_Two_Dim_Packed_Array (Typ) 407 or else ((Ekind (Current_Scope) = E_Package 408 and then Static_Elaboration_Desired (Current_Scope))) 409 then 410 Max_Aggr_Size := 2 ** 24; 411 412 elsif No (Expressions (N)) 413 and then No (Next (First (Component_Associations (N)))) 414 then 415 Max_Aggr_Size := 5000; 416 end if; 417 418 Siz := Component_Count (Component_Type (Typ)); 419 420 Indx := First_Index (Typ); 421 while Present (Indx) loop 422 Lo := Type_Low_Bound (Etype (Indx)); 423 Hi := Type_High_Bound (Etype (Indx)); 424 425 -- Bounds need to be known at compile time 426 427 if not Compile_Time_Known_Value (Lo) 428 or else not Compile_Time_Known_Value (Hi) 429 then 430 return False; 431 end if; 432 433 Lov := Expr_Value (Lo); 434 Hiv := Expr_Value (Hi); 435 436 -- A flat array is always safe 437 438 if Hiv < Lov then 439 return True; 440 end if; 441 442 -- One-component aggregates are suspicious, and if the context type 443 -- is an object declaration with non-static bounds it will trip gcc; 444 -- such an aggregate must be expanded into a single assignment. 445 446 if Hiv = Lov 447 and then Nkind (Parent (N)) = N_Object_Declaration 448 then 449 declare 450 Index_Type : constant Entity_Id := 451 Etype 452 (First_Index (Etype (Defining_Identifier (Parent (N))))); 453 Indx : Node_Id; 454 455 begin 456 if not Compile_Time_Known_Value (Type_Low_Bound (Index_Type)) 457 or else not Compile_Time_Known_Value 458 (Type_High_Bound (Index_Type)) 459 then 460 if Present (Component_Associations (N)) then 461 Indx := 462 First (Choices (First (Component_Associations (N)))); 463 464 if Is_Entity_Name (Indx) 465 and then not Is_Type (Entity (Indx)) 466 then 467 Error_Msg_N 468 ("single component aggregate in " 469 & "non-static context??", Indx); 470 Error_Msg_N ("\maybe subtype name was meant??", Indx); 471 end if; 472 end if; 473 474 return False; 475 end if; 476 end; 477 end if; 478 479 declare 480 Rng : constant Uint := Hiv - Lov + 1; 481 482 begin 483 -- Check if size is too large 484 485 if not UI_Is_In_Int_Range (Rng) then 486 return False; 487 end if; 488 489 Siz := Siz * UI_To_Int (Rng); 490 end; 491 492 if Siz <= 0 493 or else Siz > Max_Aggr_Size 494 then 495 return False; 496 end if; 497 498 -- Bounds must be in integer range, for later array construction 499 500 if not UI_Is_In_Int_Range (Lov) 501 or else 502 not UI_Is_In_Int_Range (Hiv) 503 then 504 return False; 505 end if; 506 507 Next_Index (Indx); 508 end loop; 509 510 return True; 511 end Aggr_Size_OK; 512 513 --------------------------------- 514 -- Backend_Processing_Possible -- 515 --------------------------------- 516 517 -- Backend processing by Gigi/gcc is possible only if all the following 518 -- conditions are met: 519 520 -- 1. N is fully positional 521 522 -- 2. N is not a bit-packed array aggregate; 523 524 -- 3. The size of N's array type must be known at compile time. Note 525 -- that this implies that the component size is also known 526 527 -- 4. The array type of N does not follow the Fortran layout convention 528 -- or if it does it must be 1 dimensional. 529 530 -- 5. The array component type may not be tagged (which could necessitate 531 -- reassignment of proper tags). 532 533 -- 6. The array component type must not have unaligned bit components 534 535 -- 7. None of the components of the aggregate may be bit unaligned 536 -- components. 537 538 -- 8. There cannot be delayed components, since we do not know enough 539 -- at this stage to know if back end processing is possible. 540 541 -- 9. There cannot be any discriminated record components, since the 542 -- back end cannot handle this complex case. 543 544 -- 10. No controlled actions need to be generated for components 545 546 -- 11. For a VM back end, the array should have no aliased components 547 548 function Backend_Processing_Possible (N : Node_Id) return Boolean is 549 Typ : constant Entity_Id := Etype (N); 550 -- Typ is the correct constrained array subtype of the aggregate 551 552 function Component_Check (N : Node_Id; Index : Node_Id) return Boolean; 553 -- This routine checks components of aggregate N, enforcing checks 554 -- 1, 7, 8, and 9. In the multi-dimensional case, these checks are 555 -- performed on subaggregates. The Index value is the current index 556 -- being checked in the multi-dimensional case. 557 558 --------------------- 559 -- Component_Check -- 560 --------------------- 561 562 function Component_Check (N : Node_Id; Index : Node_Id) return Boolean is 563 Expr : Node_Id; 564 565 begin 566 -- Checks 1: (no component associations) 567 568 if Present (Component_Associations (N)) then 569 return False; 570 end if; 571 572 -- Checks on components 573 574 -- Recurse to check subaggregates, which may appear in qualified 575 -- expressions. If delayed, the front-end will have to expand. 576 -- If the component is a discriminated record, treat as non-static, 577 -- as the back-end cannot handle this properly. 578 579 Expr := First (Expressions (N)); 580 while Present (Expr) loop 581 582 -- Checks 8: (no delayed components) 583 584 if Is_Delayed_Aggregate (Expr) then 585 return False; 586 end if; 587 588 -- Checks 9: (no discriminated records) 589 590 if Present (Etype (Expr)) 591 and then Is_Record_Type (Etype (Expr)) 592 and then Has_Discriminants (Etype (Expr)) 593 then 594 return False; 595 end if; 596 597 -- Checks 7. Component must not be bit aligned component 598 599 if Possible_Bit_Aligned_Component (Expr) then 600 return False; 601 end if; 602 603 -- Recursion to following indexes for multiple dimension case 604 605 if Present (Next_Index (Index)) 606 and then not Component_Check (Expr, Next_Index (Index)) 607 then 608 return False; 609 end if; 610 611 -- All checks for that component finished, on to next 612 613 Next (Expr); 614 end loop; 615 616 return True; 617 end Component_Check; 618 619 -- Start of processing for Backend_Processing_Possible 620 621 begin 622 -- Checks 2 (array not bit packed) and 10 (no controlled actions) 623 624 if Is_Bit_Packed_Array (Typ) or else Needs_Finalization (Typ) then 625 return False; 626 end if; 627 628 -- If component is limited, aggregate must be expanded because each 629 -- component assignment must be built in place. 630 631 if Is_Limited_View (Component_Type (Typ)) then 632 return False; 633 end if; 634 635 -- Checks 4 (array must not be multi-dimensional Fortran case) 636 637 if Convention (Typ) = Convention_Fortran 638 and then Number_Dimensions (Typ) > 1 639 then 640 return False; 641 end if; 642 643 -- Checks 3 (size of array must be known at compile time) 644 645 if not Size_Known_At_Compile_Time (Typ) then 646 return False; 647 end if; 648 649 -- Checks on components 650 651 if not Component_Check (N, First_Index (Typ)) then 652 return False; 653 end if; 654 655 -- Checks 5 (if the component type is tagged, then we may need to do 656 -- tag adjustments. Perhaps this should be refined to check for any 657 -- component associations that actually need tag adjustment, similar 658 -- to the test in Component_Not_OK_For_Backend for record aggregates 659 -- with tagged components, but not clear whether it's worthwhile ???; 660 -- in the case of the JVM, object tags are handled implicitly) 661 662 if Is_Tagged_Type (Component_Type (Typ)) 663 and then Tagged_Type_Expansion 664 then 665 return False; 666 end if; 667 668 -- Checks 6 (component type must not have bit aligned components) 669 670 if Type_May_Have_Bit_Aligned_Components (Component_Type (Typ)) then 671 return False; 672 end if; 673 674 -- Checks 11: Array aggregates with aliased components are currently 675 -- not well supported by the VM backend; disable temporarily this 676 -- backend processing until it is definitely supported. 677 678 if VM_Target /= No_VM 679 and then Has_Aliased_Components (Base_Type (Typ)) 680 then 681 return False; 682 end if; 683 684 -- Backend processing is possible 685 686 Set_Size_Known_At_Compile_Time (Etype (N), True); 687 return True; 688 end Backend_Processing_Possible; 689 690 --------------------------- 691 -- Build_Array_Aggr_Code -- 692 --------------------------- 693 694 -- The code that we generate from a one dimensional aggregate is 695 696 -- 1. If the sub-aggregate contains discrete choices we 697 698 -- (a) Sort the discrete choices 699 700 -- (b) Otherwise for each discrete choice that specifies a range we 701 -- emit a loop. If a range specifies a maximum of three values, or 702 -- we are dealing with an expression we emit a sequence of 703 -- assignments instead of a loop. 704 705 -- (c) Generate the remaining loops to cover the others choice if any 706 707 -- 2. If the aggregate contains positional elements we 708 709 -- (a) translate the positional elements in a series of assignments 710 711 -- (b) Generate a final loop to cover the others choice if any. 712 -- Note that this final loop has to be a while loop since the case 713 714 -- L : Integer := Integer'Last; 715 -- H : Integer := Integer'Last; 716 -- A : array (L .. H) := (1, others =>0); 717 718 -- cannot be handled by a for loop. Thus for the following 719 720 -- array (L .. H) := (.. positional elements.., others =>E); 721 722 -- we always generate something like: 723 724 -- J : Index_Type := Index_Of_Last_Positional_Element; 725 -- while J < H loop 726 -- J := Index_Base'Succ (J) 727 -- Tmp (J) := E; 728 -- end loop; 729 730 function Build_Array_Aggr_Code 731 (N : Node_Id; 732 Ctype : Entity_Id; 733 Index : Node_Id; 734 Into : Node_Id; 735 Scalar_Comp : Boolean; 736 Indexes : List_Id := No_List) return List_Id 737 is 738 Loc : constant Source_Ptr := Sloc (N); 739 Index_Base : constant Entity_Id := Base_Type (Etype (Index)); 740 Index_Base_L : constant Node_Id := Type_Low_Bound (Index_Base); 741 Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base); 742 743 function Add (Val : Int; To : Node_Id) return Node_Id; 744 -- Returns an expression where Val is added to expression To, unless 745 -- To+Val is provably out of To's base type range. To must be an 746 -- already analyzed expression. 747 748 function Empty_Range (L, H : Node_Id) return Boolean; 749 -- Returns True if the range defined by L .. H is certainly empty 750 751 function Equal (L, H : Node_Id) return Boolean; 752 -- Returns True if L = H for sure 753 754 function Index_Base_Name return Node_Id; 755 -- Returns a new reference to the index type name 756 757 function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id; 758 -- Ind must be a side-effect free expression. If the input aggregate 759 -- N to Build_Loop contains no sub-aggregates, then this function 760 -- returns the assignment statement: 761 -- 762 -- Into (Indexes, Ind) := Expr; 763 -- 764 -- Otherwise we call Build_Code recursively 765 -- 766 -- Ada 2005 (AI-287): In case of default initialized component, Expr 767 -- is empty and we generate a call to the corresponding IP subprogram. 768 769 function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id; 770 -- Nodes L and H must be side-effect free expressions. 771 -- If the input aggregate N to Build_Loop contains no sub-aggregates, 772 -- This routine returns the for loop statement 773 -- 774 -- for J in Index_Base'(L) .. Index_Base'(H) loop 775 -- Into (Indexes, J) := Expr; 776 -- end loop; 777 -- 778 -- Otherwise we call Build_Code recursively. 779 -- As an optimization if the loop covers 3 or less scalar elements we 780 -- generate a sequence of assignments. 781 782 function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id; 783 -- Nodes L and H must be side-effect free expressions. 784 -- If the input aggregate N to Build_Loop contains no sub-aggregates, 785 -- This routine returns the while loop statement 786 -- 787 -- J : Index_Base := L; 788 -- while J < H loop 789 -- J := Index_Base'Succ (J); 790 -- Into (Indexes, J) := Expr; 791 -- end loop; 792 -- 793 -- Otherwise we call Build_Code recursively 794 795 function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean; 796 function Local_Expr_Value (E : Node_Id) return Uint; 797 -- These two Local routines are used to replace the corresponding ones 798 -- in sem_eval because while processing the bounds of an aggregate with 799 -- discrete choices whose index type is an enumeration, we build static 800 -- expressions not recognized by Compile_Time_Known_Value as such since 801 -- they have not yet been analyzed and resolved. All the expressions in 802 -- question are things like Index_Base_Name'Val (Const) which we can 803 -- easily recognize as being constant. 804 805 --------- 806 -- Add -- 807 --------- 808 809 function Add (Val : Int; To : Node_Id) return Node_Id is 810 Expr_Pos : Node_Id; 811 Expr : Node_Id; 812 To_Pos : Node_Id; 813 U_To : Uint; 814 U_Val : constant Uint := UI_From_Int (Val); 815 816 begin 817 -- Note: do not try to optimize the case of Val = 0, because 818 -- we need to build a new node with the proper Sloc value anyway. 819 820 -- First test if we can do constant folding 821 822 if Local_Compile_Time_Known_Value (To) then 823 U_To := Local_Expr_Value (To) + Val; 824 825 -- Determine if our constant is outside the range of the index. 826 -- If so return an Empty node. This empty node will be caught 827 -- by Empty_Range below. 828 829 if Compile_Time_Known_Value (Index_Base_L) 830 and then U_To < Expr_Value (Index_Base_L) 831 then 832 return Empty; 833 834 elsif Compile_Time_Known_Value (Index_Base_H) 835 and then U_To > Expr_Value (Index_Base_H) 836 then 837 return Empty; 838 end if; 839 840 Expr_Pos := Make_Integer_Literal (Loc, U_To); 841 Set_Is_Static_Expression (Expr_Pos); 842 843 if not Is_Enumeration_Type (Index_Base) then 844 Expr := Expr_Pos; 845 846 -- If we are dealing with enumeration return 847 -- Index_Base'Val (Expr_Pos) 848 849 else 850 Expr := 851 Make_Attribute_Reference 852 (Loc, 853 Prefix => Index_Base_Name, 854 Attribute_Name => Name_Val, 855 Expressions => New_List (Expr_Pos)); 856 end if; 857 858 return Expr; 859 end if; 860 861 -- If we are here no constant folding possible 862 863 if not Is_Enumeration_Type (Index_Base) then 864 Expr := 865 Make_Op_Add (Loc, 866 Left_Opnd => Duplicate_Subexpr (To), 867 Right_Opnd => Make_Integer_Literal (Loc, U_Val)); 868 869 -- If we are dealing with enumeration return 870 -- Index_Base'Val (Index_Base'Pos (To) + Val) 871 872 else 873 To_Pos := 874 Make_Attribute_Reference 875 (Loc, 876 Prefix => Index_Base_Name, 877 Attribute_Name => Name_Pos, 878 Expressions => New_List (Duplicate_Subexpr (To))); 879 880 Expr_Pos := 881 Make_Op_Add (Loc, 882 Left_Opnd => To_Pos, 883 Right_Opnd => Make_Integer_Literal (Loc, U_Val)); 884 885 Expr := 886 Make_Attribute_Reference 887 (Loc, 888 Prefix => Index_Base_Name, 889 Attribute_Name => Name_Val, 890 Expressions => New_List (Expr_Pos)); 891 end if; 892 893 return Expr; 894 end Add; 895 896 ----------------- 897 -- Empty_Range -- 898 ----------------- 899 900 function Empty_Range (L, H : Node_Id) return Boolean is 901 Is_Empty : Boolean := False; 902 Low : Node_Id; 903 High : Node_Id; 904 905 begin 906 -- First check if L or H were already detected as overflowing the 907 -- index base range type by function Add above. If this is so Add 908 -- returns the empty node. 909 910 if No (L) or else No (H) then 911 return True; 912 end if; 913 914 for J in 1 .. 3 loop 915 case J is 916 917 -- L > H range is empty 918 919 when 1 => 920 Low := L; 921 High := H; 922 923 -- B_L > H range must be empty 924 925 when 2 => 926 Low := Index_Base_L; 927 High := H; 928 929 -- L > B_H range must be empty 930 931 when 3 => 932 Low := L; 933 High := Index_Base_H; 934 end case; 935 936 if Local_Compile_Time_Known_Value (Low) 937 and then Local_Compile_Time_Known_Value (High) 938 then 939 Is_Empty := 940 UI_Gt (Local_Expr_Value (Low), Local_Expr_Value (High)); 941 end if; 942 943 exit when Is_Empty; 944 end loop; 945 946 return Is_Empty; 947 end Empty_Range; 948 949 ----------- 950 -- Equal -- 951 ----------- 952 953 function Equal (L, H : Node_Id) return Boolean is 954 begin 955 if L = H then 956 return True; 957 958 elsif Local_Compile_Time_Known_Value (L) 959 and then Local_Compile_Time_Known_Value (H) 960 then 961 return UI_Eq (Local_Expr_Value (L), Local_Expr_Value (H)); 962 end if; 963 964 return False; 965 end Equal; 966 967 ---------------- 968 -- Gen_Assign -- 969 ---------------- 970 971 function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is 972 L : constant List_Id := New_List; 973 A : Node_Id; 974 975 New_Indexes : List_Id; 976 Indexed_Comp : Node_Id; 977 Expr_Q : Node_Id; 978 Comp_Type : Entity_Id := Empty; 979 980 function Add_Loop_Actions (Lis : List_Id) return List_Id; 981 -- Collect insert_actions generated in the construction of a 982 -- loop, and prepend them to the sequence of assignments to 983 -- complete the eventual body of the loop. 984 985 ---------------------- 986 -- Add_Loop_Actions -- 987 ---------------------- 988 989 function Add_Loop_Actions (Lis : List_Id) return List_Id is 990 Res : List_Id; 991 992 begin 993 -- Ada 2005 (AI-287): Do nothing else in case of default 994 -- initialized component. 995 996 if No (Expr) then 997 return Lis; 998 999 elsif Nkind (Parent (Expr)) = N_Component_Association 1000 and then Present (Loop_Actions (Parent (Expr))) 1001 then 1002 Append_List (Lis, Loop_Actions (Parent (Expr))); 1003 Res := Loop_Actions (Parent (Expr)); 1004 Set_Loop_Actions (Parent (Expr), No_List); 1005 return Res; 1006 1007 else 1008 return Lis; 1009 end if; 1010 end Add_Loop_Actions; 1011 1012 -- Start of processing for Gen_Assign 1013 1014 begin 1015 if No (Indexes) then 1016 New_Indexes := New_List; 1017 else 1018 New_Indexes := New_Copy_List_Tree (Indexes); 1019 end if; 1020 1021 Append_To (New_Indexes, Ind); 1022 1023 if Present (Next_Index (Index)) then 1024 return 1025 Add_Loop_Actions ( 1026 Build_Array_Aggr_Code 1027 (N => Expr, 1028 Ctype => Ctype, 1029 Index => Next_Index (Index), 1030 Into => Into, 1031 Scalar_Comp => Scalar_Comp, 1032 Indexes => New_Indexes)); 1033 end if; 1034 1035 -- If we get here then we are at a bottom-level (sub-)aggregate 1036 1037 Indexed_Comp := 1038 Checks_Off 1039 (Make_Indexed_Component (Loc, 1040 Prefix => New_Copy_Tree (Into), 1041 Expressions => New_Indexes)); 1042 1043 Set_Assignment_OK (Indexed_Comp); 1044 1045 -- Ada 2005 (AI-287): In case of default initialized component, Expr 1046 -- is not present (and therefore we also initialize Expr_Q to empty). 1047 1048 if No (Expr) then 1049 Expr_Q := Empty; 1050 elsif Nkind (Expr) = N_Qualified_Expression then 1051 Expr_Q := Expression (Expr); 1052 else 1053 Expr_Q := Expr; 1054 end if; 1055 1056 if Present (Etype (N)) 1057 and then Etype (N) /= Any_Composite 1058 then 1059 Comp_Type := Component_Type (Etype (N)); 1060 pragma Assert (Comp_Type = Ctype); -- AI-287 1061 1062 elsif Present (Next (First (New_Indexes))) then 1063 1064 -- Ada 2005 (AI-287): Do nothing in case of default initialized 1065 -- component because we have received the component type in 1066 -- the formal parameter Ctype. 1067 1068 -- ??? Some assert pragmas have been added to check if this new 1069 -- formal can be used to replace this code in all cases. 1070 1071 if Present (Expr) then 1072 1073 -- This is a multidimensional array. Recover the component 1074 -- type from the outermost aggregate, because subaggregates 1075 -- do not have an assigned type. 1076 1077 declare 1078 P : Node_Id; 1079 1080 begin 1081 P := Parent (Expr); 1082 while Present (P) loop 1083 if Nkind (P) = N_Aggregate 1084 and then Present (Etype (P)) 1085 then 1086 Comp_Type := Component_Type (Etype (P)); 1087 exit; 1088 1089 else 1090 P := Parent (P); 1091 end if; 1092 end loop; 1093 1094 pragma Assert (Comp_Type = Ctype); -- AI-287 1095 end; 1096 end if; 1097 end if; 1098 1099 -- Ada 2005 (AI-287): We only analyze the expression in case of non- 1100 -- default initialized components (otherwise Expr_Q is not present). 1101 1102 if Present (Expr_Q) 1103 and then Nkind_In (Expr_Q, N_Aggregate, N_Extension_Aggregate) 1104 then 1105 -- At this stage the Expression may not have been analyzed yet 1106 -- because the array aggregate code has not been updated to use 1107 -- the Expansion_Delayed flag and avoid analysis altogether to 1108 -- solve the same problem (see Resolve_Aggr_Expr). So let us do 1109 -- the analysis of non-array aggregates now in order to get the 1110 -- value of Expansion_Delayed flag for the inner aggregate ??? 1111 1112 if Present (Comp_Type) and then not Is_Array_Type (Comp_Type) then 1113 Analyze_And_Resolve (Expr_Q, Comp_Type); 1114 end if; 1115 1116 if Is_Delayed_Aggregate (Expr_Q) then 1117 1118 -- This is either a subaggregate of a multidimensional array, 1119 -- or a component of an array type whose component type is 1120 -- also an array. In the latter case, the expression may have 1121 -- component associations that provide different bounds from 1122 -- those of the component type, and sliding must occur. Instead 1123 -- of decomposing the current aggregate assignment, force the 1124 -- re-analysis of the assignment, so that a temporary will be 1125 -- generated in the usual fashion, and sliding will take place. 1126 1127 if Nkind (Parent (N)) = N_Assignment_Statement 1128 and then Is_Array_Type (Comp_Type) 1129 and then Present (Component_Associations (Expr_Q)) 1130 and then Must_Slide (Comp_Type, Etype (Expr_Q)) 1131 then 1132 Set_Expansion_Delayed (Expr_Q, False); 1133 Set_Analyzed (Expr_Q, False); 1134 1135 else 1136 return 1137 Add_Loop_Actions ( 1138 Late_Expansion (Expr_Q, Etype (Expr_Q), Indexed_Comp)); 1139 end if; 1140 end if; 1141 end if; 1142 1143 -- Ada 2005 (AI-287): In case of default initialized component, call 1144 -- the initialization subprogram associated with the component type. 1145 -- If the component type is an access type, add an explicit null 1146 -- assignment, because for the back-end there is an initialization 1147 -- present for the whole aggregate, and no default initialization 1148 -- will take place. 1149 1150 -- In addition, if the component type is controlled, we must call 1151 -- its Initialize procedure explicitly, because there is no explicit 1152 -- object creation that will invoke it otherwise. 1153 1154 if No (Expr) then 1155 if Present (Base_Init_Proc (Base_Type (Ctype))) 1156 or else Has_Task (Base_Type (Ctype)) 1157 then 1158 Append_List_To (L, 1159 Build_Initialization_Call (Loc, 1160 Id_Ref => Indexed_Comp, 1161 Typ => Ctype, 1162 With_Default_Init => True)); 1163 1164 elsif Is_Access_Type (Ctype) then 1165 Append_To (L, 1166 Make_Assignment_Statement (Loc, 1167 Name => Indexed_Comp, 1168 Expression => Make_Null (Loc))); 1169 end if; 1170 1171 if Needs_Finalization (Ctype) then 1172 Append_To (L, 1173 Make_Init_Call ( 1174 Obj_Ref => New_Copy_Tree (Indexed_Comp), 1175 Typ => Ctype)); 1176 end if; 1177 1178 else 1179 A := 1180 Make_OK_Assignment_Statement (Loc, 1181 Name => Indexed_Comp, 1182 Expression => New_Copy_Tree (Expr)); 1183 1184 -- The target of the assignment may not have been initialized, 1185 -- so it is not possible to call Finalize as expected in normal 1186 -- controlled assignments. We must also avoid using the primitive 1187 -- _assign (which depends on a valid target, and may for example 1188 -- perform discriminant checks on it). 1189 1190 -- Both Finalize and usage of _assign are disabled by setting 1191 -- No_Ctrl_Actions on the assignment. The rest of the controlled 1192 -- actions are done manually with the proper finalization list 1193 -- coming from the context. 1194 1195 Set_No_Ctrl_Actions (A); 1196 1197 -- If this is an aggregate for an array of arrays, each 1198 -- sub-aggregate will be expanded as well, and even with 1199 -- No_Ctrl_Actions the assignments of inner components will 1200 -- require attachment in their assignments to temporaries. These 1201 -- temporaries must be finalized for each subaggregate, to prevent 1202 -- multiple attachments of the same temporary location to same 1203 -- finalization chain (and consequently circular lists). To ensure 1204 -- that finalization takes place for each subaggregate we wrap the 1205 -- assignment in a block. 1206 1207 if Present (Comp_Type) 1208 and then Needs_Finalization (Comp_Type) 1209 and then Is_Array_Type (Comp_Type) 1210 and then Present (Expr) 1211 then 1212 A := 1213 Make_Block_Statement (Loc, 1214 Handled_Statement_Sequence => 1215 Make_Handled_Sequence_Of_Statements (Loc, 1216 Statements => New_List (A))); 1217 end if; 1218 1219 Append_To (L, A); 1220 1221 -- Adjust the tag if tagged (because of possible view 1222 -- conversions), unless compiling for a VM where tags 1223 -- are implicit. 1224 1225 if Present (Comp_Type) 1226 and then Is_Tagged_Type (Comp_Type) 1227 and then Tagged_Type_Expansion 1228 then 1229 declare 1230 Full_Typ : constant Entity_Id := Underlying_Type (Comp_Type); 1231 1232 begin 1233 A := 1234 Make_OK_Assignment_Statement (Loc, 1235 Name => 1236 Make_Selected_Component (Loc, 1237 Prefix => New_Copy_Tree (Indexed_Comp), 1238 Selector_Name => 1239 New_Occurrence_Of 1240 (First_Tag_Component (Full_Typ), Loc)), 1241 1242 Expression => 1243 Unchecked_Convert_To (RTE (RE_Tag), 1244 New_Occurrence_Of 1245 (Node (First_Elmt (Access_Disp_Table (Full_Typ))), 1246 Loc))); 1247 1248 Append_To (L, A); 1249 end; 1250 end if; 1251 1252 -- Adjust and attach the component to the proper final list, which 1253 -- can be the controller of the outer record object or the final 1254 -- list associated with the scope. 1255 1256 -- If the component is itself an array of controlled types, whose 1257 -- value is given by a sub-aggregate, then the attach calls have 1258 -- been generated when individual subcomponent are assigned, and 1259 -- must not be done again to prevent malformed finalization chains 1260 -- (see comments above, concerning the creation of a block to hold 1261 -- inner finalization actions). 1262 1263 if Present (Comp_Type) 1264 and then Needs_Finalization (Comp_Type) 1265 and then not Is_Limited_Type (Comp_Type) 1266 and then not 1267 (Is_Array_Type (Comp_Type) 1268 and then Is_Controlled (Component_Type (Comp_Type)) 1269 and then Nkind (Expr) = N_Aggregate) 1270 then 1271 Append_To (L, 1272 Make_Adjust_Call ( 1273 Obj_Ref => New_Copy_Tree (Indexed_Comp), 1274 Typ => Comp_Type)); 1275 end if; 1276 end if; 1277 1278 return Add_Loop_Actions (L); 1279 end Gen_Assign; 1280 1281 -------------- 1282 -- Gen_Loop -- 1283 -------------- 1284 1285 function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is 1286 L_J : Node_Id; 1287 1288 L_L : Node_Id; 1289 -- Index_Base'(L) 1290 1291 L_H : Node_Id; 1292 -- Index_Base'(H) 1293 1294 L_Range : Node_Id; 1295 -- Index_Base'(L) .. Index_Base'(H) 1296 1297 L_Iteration_Scheme : Node_Id; 1298 -- L_J in Index_Base'(L) .. Index_Base'(H) 1299 1300 L_Body : List_Id; 1301 -- The statements to execute in the loop 1302 1303 S : constant List_Id := New_List; 1304 -- List of statements 1305 1306 Tcopy : Node_Id; 1307 -- Copy of expression tree, used for checking purposes 1308 1309 begin 1310 -- If loop bounds define an empty range return the null statement 1311 1312 if Empty_Range (L, H) then 1313 Append_To (S, Make_Null_Statement (Loc)); 1314 1315 -- Ada 2005 (AI-287): Nothing else need to be done in case of 1316 -- default initialized component. 1317 1318 if No (Expr) then 1319 null; 1320 1321 else 1322 -- The expression must be type-checked even though no component 1323 -- of the aggregate will have this value. This is done only for 1324 -- actual components of the array, not for subaggregates. Do 1325 -- the check on a copy, because the expression may be shared 1326 -- among several choices, some of which might be non-null. 1327 1328 if Present (Etype (N)) 1329 and then Is_Array_Type (Etype (N)) 1330 and then No (Next_Index (Index)) 1331 then 1332 Expander_Mode_Save_And_Set (False); 1333 Tcopy := New_Copy_Tree (Expr); 1334 Set_Parent (Tcopy, N); 1335 Analyze_And_Resolve (Tcopy, Component_Type (Etype (N))); 1336 Expander_Mode_Restore; 1337 end if; 1338 end if; 1339 1340 return S; 1341 1342 -- If loop bounds are the same then generate an assignment 1343 1344 elsif Equal (L, H) then 1345 return Gen_Assign (New_Copy_Tree (L), Expr); 1346 1347 -- If H - L <= 2 then generate a sequence of assignments when we are 1348 -- processing the bottom most aggregate and it contains scalar 1349 -- components. 1350 1351 elsif No (Next_Index (Index)) 1352 and then Scalar_Comp 1353 and then Local_Compile_Time_Known_Value (L) 1354 and then Local_Compile_Time_Known_Value (H) 1355 and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2 1356 then 1357 1358 Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr)); 1359 Append_List_To (S, Gen_Assign (Add (1, To => L), Expr)); 1360 1361 if Local_Expr_Value (H) - Local_Expr_Value (L) = 2 then 1362 Append_List_To (S, Gen_Assign (Add (2, To => L), Expr)); 1363 end if; 1364 1365 return S; 1366 end if; 1367 1368 -- Otherwise construct the loop, starting with the loop index L_J 1369 1370 L_J := Make_Temporary (Loc, 'J', L); 1371 1372 -- Construct "L .. H" in Index_Base. We use a qualified expression 1373 -- for the bound to convert to the index base, but we don't need 1374 -- to do that if we already have the base type at hand. 1375 1376 if Etype (L) = Index_Base then 1377 L_L := L; 1378 else 1379 L_L := 1380 Make_Qualified_Expression (Loc, 1381 Subtype_Mark => Index_Base_Name, 1382 Expression => L); 1383 end if; 1384 1385 if Etype (H) = Index_Base then 1386 L_H := H; 1387 else 1388 L_H := 1389 Make_Qualified_Expression (Loc, 1390 Subtype_Mark => Index_Base_Name, 1391 Expression => H); 1392 end if; 1393 1394 L_Range := 1395 Make_Range (Loc, 1396 Low_Bound => L_L, 1397 High_Bound => L_H); 1398 1399 -- Construct "for L_J in Index_Base range L .. H" 1400 1401 L_Iteration_Scheme := 1402 Make_Iteration_Scheme 1403 (Loc, 1404 Loop_Parameter_Specification => 1405 Make_Loop_Parameter_Specification 1406 (Loc, 1407 Defining_Identifier => L_J, 1408 Discrete_Subtype_Definition => L_Range)); 1409 1410 -- Construct the statements to execute in the loop body 1411 1412 L_Body := Gen_Assign (New_Occurrence_Of (L_J, Loc), Expr); 1413 1414 -- Construct the final loop 1415 1416 Append_To (S, Make_Implicit_Loop_Statement 1417 (Node => N, 1418 Identifier => Empty, 1419 Iteration_Scheme => L_Iteration_Scheme, 1420 Statements => L_Body)); 1421 1422 -- A small optimization: if the aggregate is initialized with a box 1423 -- and the component type has no initialization procedure, remove the 1424 -- useless empty loop. 1425 1426 if Nkind (First (S)) = N_Loop_Statement 1427 and then Is_Empty_List (Statements (First (S))) 1428 then 1429 return New_List (Make_Null_Statement (Loc)); 1430 else 1431 return S; 1432 end if; 1433 end Gen_Loop; 1434 1435 --------------- 1436 -- Gen_While -- 1437 --------------- 1438 1439 -- The code built is 1440 1441 -- W_J : Index_Base := L; 1442 -- while W_J < H loop 1443 -- W_J := Index_Base'Succ (W); 1444 -- L_Body; 1445 -- end loop; 1446 1447 function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id is 1448 W_J : Node_Id; 1449 1450 W_Decl : Node_Id; 1451 -- W_J : Base_Type := L; 1452 1453 W_Iteration_Scheme : Node_Id; 1454 -- while W_J < H 1455 1456 W_Index_Succ : Node_Id; 1457 -- Index_Base'Succ (J) 1458 1459 W_Increment : Node_Id; 1460 -- W_J := Index_Base'Succ (W) 1461 1462 W_Body : constant List_Id := New_List; 1463 -- The statements to execute in the loop 1464 1465 S : constant List_Id := New_List; 1466 -- list of statement 1467 1468 begin 1469 -- If loop bounds define an empty range or are equal return null 1470 1471 if Empty_Range (L, H) or else Equal (L, H) then 1472 Append_To (S, Make_Null_Statement (Loc)); 1473 return S; 1474 end if; 1475 1476 -- Build the decl of W_J 1477 1478 W_J := Make_Temporary (Loc, 'J', L); 1479 W_Decl := 1480 Make_Object_Declaration 1481 (Loc, 1482 Defining_Identifier => W_J, 1483 Object_Definition => Index_Base_Name, 1484 Expression => L); 1485 1486 -- Theoretically we should do a New_Copy_Tree (L) here, but we know 1487 -- that in this particular case L is a fresh Expr generated by 1488 -- Add which we are the only ones to use. 1489 1490 Append_To (S, W_Decl); 1491 1492 -- Construct " while W_J < H" 1493 1494 W_Iteration_Scheme := 1495 Make_Iteration_Scheme 1496 (Loc, 1497 Condition => Make_Op_Lt 1498 (Loc, 1499 Left_Opnd => New_Occurrence_Of (W_J, Loc), 1500 Right_Opnd => New_Copy_Tree (H))); 1501 1502 -- Construct the statements to execute in the loop body 1503 1504 W_Index_Succ := 1505 Make_Attribute_Reference 1506 (Loc, 1507 Prefix => Index_Base_Name, 1508 Attribute_Name => Name_Succ, 1509 Expressions => New_List (New_Occurrence_Of (W_J, Loc))); 1510 1511 W_Increment := 1512 Make_OK_Assignment_Statement 1513 (Loc, 1514 Name => New_Occurrence_Of (W_J, Loc), 1515 Expression => W_Index_Succ); 1516 1517 Append_To (W_Body, W_Increment); 1518 Append_List_To (W_Body, 1519 Gen_Assign (New_Occurrence_Of (W_J, Loc), Expr)); 1520 1521 -- Construct the final loop 1522 1523 Append_To (S, Make_Implicit_Loop_Statement 1524 (Node => N, 1525 Identifier => Empty, 1526 Iteration_Scheme => W_Iteration_Scheme, 1527 Statements => W_Body)); 1528 1529 return S; 1530 end Gen_While; 1531 1532 --------------------- 1533 -- Index_Base_Name -- 1534 --------------------- 1535 1536 function Index_Base_Name return Node_Id is 1537 begin 1538 return New_Occurrence_Of (Index_Base, Sloc (N)); 1539 end Index_Base_Name; 1540 1541 ------------------------------------ 1542 -- Local_Compile_Time_Known_Value -- 1543 ------------------------------------ 1544 1545 function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean is 1546 begin 1547 return Compile_Time_Known_Value (E) 1548 or else 1549 (Nkind (E) = N_Attribute_Reference 1550 and then Attribute_Name (E) = Name_Val 1551 and then Compile_Time_Known_Value (First (Expressions (E)))); 1552 end Local_Compile_Time_Known_Value; 1553 1554 ---------------------- 1555 -- Local_Expr_Value -- 1556 ---------------------- 1557 1558 function Local_Expr_Value (E : Node_Id) return Uint is 1559 begin 1560 if Compile_Time_Known_Value (E) then 1561 return Expr_Value (E); 1562 else 1563 return Expr_Value (First (Expressions (E))); 1564 end if; 1565 end Local_Expr_Value; 1566 1567 -- Build_Array_Aggr_Code Variables 1568 1569 Assoc : Node_Id; 1570 Choice : Node_Id; 1571 Expr : Node_Id; 1572 Typ : Entity_Id; 1573 1574 Others_Expr : Node_Id := Empty; 1575 Others_Box_Present : Boolean := False; 1576 1577 Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N)); 1578 Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N)); 1579 -- The aggregate bounds of this specific sub-aggregate. Note that if 1580 -- the code generated by Build_Array_Aggr_Code is executed then these 1581 -- bounds are OK. Otherwise a Constraint_Error would have been raised. 1582 1583 Aggr_Low : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_L); 1584 Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H); 1585 -- After Duplicate_Subexpr these are side-effect free 1586 1587 Low : Node_Id; 1588 High : Node_Id; 1589 1590 Nb_Choices : Nat := 0; 1591 Table : Case_Table_Type (1 .. Number_Of_Choices (N)); 1592 -- Used to sort all the different choice values 1593 1594 Nb_Elements : Int; 1595 -- Number of elements in the positional aggregate 1596 1597 New_Code : constant List_Id := New_List; 1598 1599 -- Start of processing for Build_Array_Aggr_Code 1600 1601 begin 1602 -- First before we start, a special case. if we have a bit packed 1603 -- array represented as a modular type, then clear the value to 1604 -- zero first, to ensure that unused bits are properly cleared. 1605 1606 Typ := Etype (N); 1607 1608 if Present (Typ) 1609 and then Is_Bit_Packed_Array (Typ) 1610 and then Is_Modular_Integer_Type (Packed_Array_Type (Typ)) 1611 then 1612 Append_To (New_Code, 1613 Make_Assignment_Statement (Loc, 1614 Name => New_Copy_Tree (Into), 1615 Expression => 1616 Unchecked_Convert_To (Typ, 1617 Make_Integer_Literal (Loc, Uint_0)))); 1618 end if; 1619 1620 -- If the component type contains tasks, we need to build a Master 1621 -- entity in the current scope, because it will be needed if build- 1622 -- in-place functions are called in the expanded code. 1623 1624 if Nkind (Parent (N)) = N_Object_Declaration 1625 and then Has_Task (Typ) 1626 then 1627 Build_Master_Entity (Defining_Identifier (Parent (N))); 1628 end if; 1629 1630 -- STEP 1: Process component associations 1631 1632 -- For those associations that may generate a loop, initialize 1633 -- Loop_Actions to collect inserted actions that may be crated. 1634 1635 -- Skip this if no component associations 1636 1637 if No (Expressions (N)) then 1638 1639 -- STEP 1 (a): Sort the discrete choices 1640 1641 Assoc := First (Component_Associations (N)); 1642 while Present (Assoc) loop 1643 Choice := First (Choices (Assoc)); 1644 while Present (Choice) loop 1645 if Nkind (Choice) = N_Others_Choice then 1646 Set_Loop_Actions (Assoc, New_List); 1647 1648 if Box_Present (Assoc) then 1649 Others_Box_Present := True; 1650 else 1651 Others_Expr := Expression (Assoc); 1652 end if; 1653 exit; 1654 end if; 1655 1656 Get_Index_Bounds (Choice, Low, High); 1657 1658 if Low /= High then 1659 Set_Loop_Actions (Assoc, New_List); 1660 end if; 1661 1662 Nb_Choices := Nb_Choices + 1; 1663 if Box_Present (Assoc) then 1664 Table (Nb_Choices) := (Choice_Lo => Low, 1665 Choice_Hi => High, 1666 Choice_Node => Empty); 1667 else 1668 Table (Nb_Choices) := (Choice_Lo => Low, 1669 Choice_Hi => High, 1670 Choice_Node => Expression (Assoc)); 1671 end if; 1672 Next (Choice); 1673 end loop; 1674 1675 Next (Assoc); 1676 end loop; 1677 1678 -- If there is more than one set of choices these must be static 1679 -- and we can therefore sort them. Remember that Nb_Choices does not 1680 -- account for an others choice. 1681 1682 if Nb_Choices > 1 then 1683 Sort_Case_Table (Table); 1684 end if; 1685 1686 -- STEP 1 (b): take care of the whole set of discrete choices 1687 1688 for J in 1 .. Nb_Choices loop 1689 Low := Table (J).Choice_Lo; 1690 High := Table (J).Choice_Hi; 1691 Expr := Table (J).Choice_Node; 1692 Append_List (Gen_Loop (Low, High, Expr), To => New_Code); 1693 end loop; 1694 1695 -- STEP 1 (c): generate the remaining loops to cover others choice 1696 -- We don't need to generate loops over empty gaps, but if there is 1697 -- a single empty range we must analyze the expression for semantics 1698 1699 if Present (Others_Expr) or else Others_Box_Present then 1700 declare 1701 First : Boolean := True; 1702 1703 begin 1704 for J in 0 .. Nb_Choices loop 1705 if J = 0 then 1706 Low := Aggr_Low; 1707 else 1708 Low := Add (1, To => Table (J).Choice_Hi); 1709 end if; 1710 1711 if J = Nb_Choices then 1712 High := Aggr_High; 1713 else 1714 High := Add (-1, To => Table (J + 1).Choice_Lo); 1715 end if; 1716 1717 -- If this is an expansion within an init proc, make 1718 -- sure that discriminant references are replaced by 1719 -- the corresponding discriminal. 1720 1721 if Inside_Init_Proc then 1722 if Is_Entity_Name (Low) 1723 and then Ekind (Entity (Low)) = E_Discriminant 1724 then 1725 Set_Entity (Low, Discriminal (Entity (Low))); 1726 end if; 1727 1728 if Is_Entity_Name (High) 1729 and then Ekind (Entity (High)) = E_Discriminant 1730 then 1731 Set_Entity (High, Discriminal (Entity (High))); 1732 end if; 1733 end if; 1734 1735 if First 1736 or else not Empty_Range (Low, High) 1737 then 1738 First := False; 1739 Append_List 1740 (Gen_Loop (Low, High, Others_Expr), To => New_Code); 1741 end if; 1742 end loop; 1743 end; 1744 end if; 1745 1746 -- STEP 2: Process positional components 1747 1748 else 1749 -- STEP 2 (a): Generate the assignments for each positional element 1750 -- Note that here we have to use Aggr_L rather than Aggr_Low because 1751 -- Aggr_L is analyzed and Add wants an analyzed expression. 1752 1753 Expr := First (Expressions (N)); 1754 Nb_Elements := -1; 1755 while Present (Expr) loop 1756 Nb_Elements := Nb_Elements + 1; 1757 Append_List (Gen_Assign (Add (Nb_Elements, To => Aggr_L), Expr), 1758 To => New_Code); 1759 Next (Expr); 1760 end loop; 1761 1762 -- STEP 2 (b): Generate final loop if an others choice is present 1763 -- Here Nb_Elements gives the offset of the last positional element. 1764 1765 if Present (Component_Associations (N)) then 1766 Assoc := Last (Component_Associations (N)); 1767 1768 -- Ada 2005 (AI-287) 1769 1770 if Box_Present (Assoc) then 1771 Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L), 1772 Aggr_High, 1773 Empty), 1774 To => New_Code); 1775 else 1776 Expr := Expression (Assoc); 1777 1778 Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L), 1779 Aggr_High, 1780 Expr), -- AI-287 1781 To => New_Code); 1782 end if; 1783 end if; 1784 end if; 1785 1786 return New_Code; 1787 end Build_Array_Aggr_Code; 1788 1789 ---------------------------- 1790 -- Build_Record_Aggr_Code -- 1791 ---------------------------- 1792 1793 function Build_Record_Aggr_Code 1794 (N : Node_Id; 1795 Typ : Entity_Id; 1796 Lhs : Node_Id) return List_Id 1797 is 1798 Loc : constant Source_Ptr := Sloc (N); 1799 L : constant List_Id := New_List; 1800 N_Typ : constant Entity_Id := Etype (N); 1801 1802 Comp : Node_Id; 1803 Instr : Node_Id; 1804 Ref : Node_Id; 1805 Target : Entity_Id; 1806 Comp_Type : Entity_Id; 1807 Selector : Entity_Id; 1808 Comp_Expr : Node_Id; 1809 Expr_Q : Node_Id; 1810 1811 -- If this is an internal aggregate, the External_Final_List is an 1812 -- expression for the controller record of the enclosing type. 1813 1814 -- If the current aggregate has several controlled components, this 1815 -- expression will appear in several calls to attach to the finali- 1816 -- zation list, and it must not be shared. 1817 1818 Ancestor_Is_Expression : Boolean := False; 1819 Ancestor_Is_Subtype_Mark : Boolean := False; 1820 1821 Init_Typ : Entity_Id := Empty; 1822 1823 Finalization_Done : Boolean := False; 1824 -- True if Generate_Finalization_Actions has already been called; calls 1825 -- after the first do nothing. 1826 1827 function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id; 1828 -- Returns the value that the given discriminant of an ancestor type 1829 -- should receive (in the absence of a conflict with the value provided 1830 -- by an ancestor part of an extension aggregate). 1831 1832 procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id); 1833 -- Check that each of the discriminant values defined by the ancestor 1834 -- part of an extension aggregate match the corresponding values 1835 -- provided by either an association of the aggregate or by the 1836 -- constraint imposed by a parent type (RM95-4.3.2(8)). 1837 1838 function Compatible_Int_Bounds 1839 (Agg_Bounds : Node_Id; 1840 Typ_Bounds : Node_Id) return Boolean; 1841 -- Return true if Agg_Bounds are equal or within Typ_Bounds. It is 1842 -- assumed that both bounds are integer ranges. 1843 1844 procedure Generate_Finalization_Actions; 1845 -- Deal with the various controlled type data structure initializations 1846 -- (but only if it hasn't been done already). 1847 1848 function Get_Constraint_Association (T : Entity_Id) return Node_Id; 1849 -- Returns the first discriminant association in the constraint 1850 -- associated with T, if any, otherwise returns Empty. 1851 1852 procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id); 1853 -- If Typ is derived, and constrains discriminants of the parent type, 1854 -- these discriminants are not components of the aggregate, and must be 1855 -- initialized. The assignments are appended to List. 1856 1857 function Get_Explicit_Discriminant_Value (D : Entity_Id) return Node_Id; 1858 -- If the ancestor part is an unconstrained type and further ancestors 1859 -- do not provide discriminants for it, check aggregate components for 1860 -- values of the discriminants. 1861 1862 function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean; 1863 -- Check whether Bounds is a range node and its lower and higher bounds 1864 -- are integers literals. 1865 1866 --------------------------------- 1867 -- Ancestor_Discriminant_Value -- 1868 --------------------------------- 1869 1870 function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id is 1871 Assoc : Node_Id; 1872 Assoc_Elmt : Elmt_Id; 1873 Aggr_Comp : Entity_Id; 1874 Corresp_Disc : Entity_Id; 1875 Current_Typ : Entity_Id := Base_Type (Typ); 1876 Parent_Typ : Entity_Id; 1877 Parent_Disc : Entity_Id; 1878 Save_Assoc : Node_Id := Empty; 1879 1880 begin 1881 -- First check any discriminant associations to see if any of them 1882 -- provide a value for the discriminant. 1883 1884 if Present (Discriminant_Specifications (Parent (Current_Typ))) then 1885 Assoc := First (Component_Associations (N)); 1886 while Present (Assoc) loop 1887 Aggr_Comp := Entity (First (Choices (Assoc))); 1888 1889 if Ekind (Aggr_Comp) = E_Discriminant then 1890 Save_Assoc := Expression (Assoc); 1891 1892 Corresp_Disc := Corresponding_Discriminant (Aggr_Comp); 1893 while Present (Corresp_Disc) loop 1894 1895 -- If found a corresponding discriminant then return the 1896 -- value given in the aggregate. (Note: this is not 1897 -- correct in the presence of side effects. ???) 1898 1899 if Disc = Corresp_Disc then 1900 return Duplicate_Subexpr (Expression (Assoc)); 1901 end if; 1902 1903 Corresp_Disc := 1904 Corresponding_Discriminant (Corresp_Disc); 1905 end loop; 1906 end if; 1907 1908 Next (Assoc); 1909 end loop; 1910 end if; 1911 1912 -- No match found in aggregate, so chain up parent types to find 1913 -- a constraint that defines the value of the discriminant. 1914 1915 Parent_Typ := Etype (Current_Typ); 1916 while Current_Typ /= Parent_Typ loop 1917 if Has_Discriminants (Parent_Typ) 1918 and then not Has_Unknown_Discriminants (Parent_Typ) 1919 then 1920 Parent_Disc := First_Discriminant (Parent_Typ); 1921 1922 -- We either get the association from the subtype indication 1923 -- of the type definition itself, or from the discriminant 1924 -- constraint associated with the type entity (which is 1925 -- preferable, but it's not always present ???) 1926 1927 if Is_Empty_Elmt_List ( 1928 Discriminant_Constraint (Current_Typ)) 1929 then 1930 Assoc := Get_Constraint_Association (Current_Typ); 1931 Assoc_Elmt := No_Elmt; 1932 else 1933 Assoc_Elmt := 1934 First_Elmt (Discriminant_Constraint (Current_Typ)); 1935 Assoc := Node (Assoc_Elmt); 1936 end if; 1937 1938 -- Traverse the discriminants of the parent type looking 1939 -- for one that corresponds. 1940 1941 while Present (Parent_Disc) and then Present (Assoc) loop 1942 Corresp_Disc := Parent_Disc; 1943 while Present (Corresp_Disc) 1944 and then Disc /= Corresp_Disc 1945 loop 1946 Corresp_Disc := 1947 Corresponding_Discriminant (Corresp_Disc); 1948 end loop; 1949 1950 if Disc = Corresp_Disc then 1951 if Nkind (Assoc) = N_Discriminant_Association then 1952 Assoc := Expression (Assoc); 1953 end if; 1954 1955 -- If the located association directly denotes a 1956 -- discriminant, then use the value of a saved 1957 -- association of the aggregate. This is a kludge to 1958 -- handle certain cases involving multiple discriminants 1959 -- mapped to a single discriminant of a descendant. It's 1960 -- not clear how to locate the appropriate discriminant 1961 -- value for such cases. ??? 1962 1963 if Is_Entity_Name (Assoc) 1964 and then Ekind (Entity (Assoc)) = E_Discriminant 1965 then 1966 Assoc := Save_Assoc; 1967 end if; 1968 1969 return Duplicate_Subexpr (Assoc); 1970 end if; 1971 1972 Next_Discriminant (Parent_Disc); 1973 1974 if No (Assoc_Elmt) then 1975 Next (Assoc); 1976 else 1977 Next_Elmt (Assoc_Elmt); 1978 if Present (Assoc_Elmt) then 1979 Assoc := Node (Assoc_Elmt); 1980 else 1981 Assoc := Empty; 1982 end if; 1983 end if; 1984 end loop; 1985 end if; 1986 1987 Current_Typ := Parent_Typ; 1988 Parent_Typ := Etype (Current_Typ); 1989 end loop; 1990 1991 -- In some cases there's no ancestor value to locate (such as 1992 -- when an ancestor part given by an expression defines the 1993 -- discriminant value). 1994 1995 return Empty; 1996 end Ancestor_Discriminant_Value; 1997 1998 ---------------------------------- 1999 -- Check_Ancestor_Discriminants -- 2000 ---------------------------------- 2001 2002 procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id) is 2003 Discr : Entity_Id; 2004 Disc_Value : Node_Id; 2005 Cond : Node_Id; 2006 2007 begin 2008 Discr := First_Discriminant (Base_Type (Anc_Typ)); 2009 while Present (Discr) loop 2010 Disc_Value := Ancestor_Discriminant_Value (Discr); 2011 2012 if Present (Disc_Value) then 2013 Cond := Make_Op_Ne (Loc, 2014 Left_Opnd => 2015 Make_Selected_Component (Loc, 2016 Prefix => New_Copy_Tree (Target), 2017 Selector_Name => New_Occurrence_Of (Discr, Loc)), 2018 Right_Opnd => Disc_Value); 2019 2020 Append_To (L, 2021 Make_Raise_Constraint_Error (Loc, 2022 Condition => Cond, 2023 Reason => CE_Discriminant_Check_Failed)); 2024 end if; 2025 2026 Next_Discriminant (Discr); 2027 end loop; 2028 end Check_Ancestor_Discriminants; 2029 2030 --------------------------- 2031 -- Compatible_Int_Bounds -- 2032 --------------------------- 2033 2034 function Compatible_Int_Bounds 2035 (Agg_Bounds : Node_Id; 2036 Typ_Bounds : Node_Id) return Boolean 2037 is 2038 Agg_Lo : constant Uint := Intval (Low_Bound (Agg_Bounds)); 2039 Agg_Hi : constant Uint := Intval (High_Bound (Agg_Bounds)); 2040 Typ_Lo : constant Uint := Intval (Low_Bound (Typ_Bounds)); 2041 Typ_Hi : constant Uint := Intval (High_Bound (Typ_Bounds)); 2042 begin 2043 return Typ_Lo <= Agg_Lo and then Agg_Hi <= Typ_Hi; 2044 end Compatible_Int_Bounds; 2045 2046 -------------------------------- 2047 -- Get_Constraint_Association -- 2048 -------------------------------- 2049 2050 function Get_Constraint_Association (T : Entity_Id) return Node_Id is 2051 Indic : Node_Id; 2052 Typ : Entity_Id; 2053 2054 begin 2055 Typ := T; 2056 2057 -- Handle private types in instances 2058 2059 if In_Instance 2060 and then Is_Private_Type (Typ) 2061 and then Present (Full_View (Typ)) 2062 then 2063 Typ := Full_View (Typ); 2064 end if; 2065 2066 Indic := Subtype_Indication (Type_Definition (Parent (Typ))); 2067 2068 -- ??? Also need to cover case of a type mark denoting a subtype 2069 -- with constraint. 2070 2071 if Nkind (Indic) = N_Subtype_Indication 2072 and then Present (Constraint (Indic)) 2073 then 2074 return First (Constraints (Constraint (Indic))); 2075 end if; 2076 2077 return Empty; 2078 end Get_Constraint_Association; 2079 2080 ------------------------------------- 2081 -- Get_Explicit_Discriminant_Value -- 2082 ------------------------------------- 2083 2084 function Get_Explicit_Discriminant_Value 2085 (D : Entity_Id) return Node_Id 2086 is 2087 Assoc : Node_Id; 2088 Choice : Node_Id; 2089 Val : Node_Id; 2090 2091 begin 2092 -- The aggregate has been normalized and all associations have a 2093 -- single choice. 2094 2095 Assoc := First (Component_Associations (N)); 2096 while Present (Assoc) loop 2097 Choice := First (Choices (Assoc)); 2098 2099 if Chars (Choice) = Chars (D) then 2100 Val := Expression (Assoc); 2101 Remove (Assoc); 2102 return Val; 2103 end if; 2104 2105 Next (Assoc); 2106 end loop; 2107 2108 return Empty; 2109 end Get_Explicit_Discriminant_Value; 2110 2111 ------------------------------- 2112 -- Init_Hidden_Discriminants -- 2113 ------------------------------- 2114 2115 procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id) is 2116 Btype : Entity_Id; 2117 Parent_Type : Entity_Id; 2118 Disc : Entity_Id; 2119 Discr_Val : Elmt_Id; 2120 2121 begin 2122 Btype := Base_Type (Typ); 2123 while Is_Derived_Type (Btype) 2124 and then Present (Stored_Constraint (Btype)) 2125 loop 2126 Parent_Type := Etype (Btype); 2127 2128 Disc := First_Discriminant (Parent_Type); 2129 Discr_Val := First_Elmt (Stored_Constraint (Base_Type (Typ))); 2130 while Present (Discr_Val) loop 2131 2132 -- Only those discriminants of the parent that are not 2133 -- renamed by discriminants of the derived type need to 2134 -- be added explicitly. 2135 2136 if not Is_Entity_Name (Node (Discr_Val)) 2137 or else Ekind (Entity (Node (Discr_Val))) /= E_Discriminant 2138 then 2139 Comp_Expr := 2140 Make_Selected_Component (Loc, 2141 Prefix => New_Copy_Tree (Target), 2142 Selector_Name => New_Occurrence_Of (Disc, Loc)); 2143 2144 Instr := 2145 Make_OK_Assignment_Statement (Loc, 2146 Name => Comp_Expr, 2147 Expression => New_Copy_Tree (Node (Discr_Val))); 2148 2149 Set_No_Ctrl_Actions (Instr); 2150 Append_To (List, Instr); 2151 end if; 2152 2153 Next_Discriminant (Disc); 2154 Next_Elmt (Discr_Val); 2155 end loop; 2156 2157 Btype := Base_Type (Parent_Type); 2158 end loop; 2159 end Init_Hidden_Discriminants; 2160 2161 ------------------------- 2162 -- Is_Int_Range_Bounds -- 2163 ------------------------- 2164 2165 function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean is 2166 begin 2167 return Nkind (Bounds) = N_Range 2168 and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal 2169 and then Nkind (High_Bound (Bounds)) = N_Integer_Literal; 2170 end Is_Int_Range_Bounds; 2171 2172 ----------------------------------- 2173 -- Generate_Finalization_Actions -- 2174 ----------------------------------- 2175 2176 procedure Generate_Finalization_Actions is 2177 begin 2178 -- Do the work only the first time this is called 2179 2180 if Finalization_Done then 2181 return; 2182 end if; 2183 2184 Finalization_Done := True; 2185 2186 -- Determine the external finalization list. It is either the 2187 -- finalization list of the outer-scope or the one coming from 2188 -- an outer aggregate. When the target is not a temporary, the 2189 -- proper scope is the scope of the target rather than the 2190 -- potentially transient current scope. 2191 2192 if Is_Controlled (Typ) 2193 and then Ancestor_Is_Subtype_Mark 2194 then 2195 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); 2196 Set_Assignment_OK (Ref); 2197 2198 Append_To (L, 2199 Make_Procedure_Call_Statement (Loc, 2200 Name => 2201 New_Occurrence_Of 2202 (Find_Prim_Op (Init_Typ, Name_Initialize), Loc), 2203 Parameter_Associations => New_List (New_Copy_Tree (Ref)))); 2204 end if; 2205 end Generate_Finalization_Actions; 2206 2207 function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result; 2208 -- If default expression of a component mentions a discriminant of the 2209 -- type, it must be rewritten as the discriminant of the target object. 2210 2211 function Replace_Type (Expr : Node_Id) return Traverse_Result; 2212 -- If the aggregate contains a self-reference, traverse each expression 2213 -- to replace a possible self-reference with a reference to the proper 2214 -- component of the target of the assignment. 2215 2216 -------------------------- 2217 -- Rewrite_Discriminant -- 2218 -------------------------- 2219 2220 function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is 2221 begin 2222 if Is_Entity_Name (Expr) 2223 and then Present (Entity (Expr)) 2224 and then Ekind (Entity (Expr)) = E_In_Parameter 2225 and then Present (Discriminal_Link (Entity (Expr))) 2226 and then Scope (Discriminal_Link (Entity (Expr))) 2227 = Base_Type (Etype (N)) 2228 then 2229 Rewrite (Expr, 2230 Make_Selected_Component (Loc, 2231 Prefix => New_Copy_Tree (Lhs), 2232 Selector_Name => Make_Identifier (Loc, Chars (Expr)))); 2233 end if; 2234 return OK; 2235 end Rewrite_Discriminant; 2236 2237 ------------------ 2238 -- Replace_Type -- 2239 ------------------ 2240 2241 function Replace_Type (Expr : Node_Id) return Traverse_Result is 2242 begin 2243 -- Note regarding the Root_Type test below: Aggregate components for 2244 -- self-referential types include attribute references to the current 2245 -- instance, of the form: Typ'access, etc.. These references are 2246 -- rewritten as references to the target of the aggregate: the 2247 -- left-hand side of an assignment, the entity in a declaration, 2248 -- or a temporary. Without this test, we would improperly extended 2249 -- this rewriting to attribute references whose prefix was not the 2250 -- type of the aggregate. 2251 2252 if Nkind (Expr) = N_Attribute_Reference 2253 and then Is_Entity_Name (Prefix (Expr)) 2254 and then Is_Type (Entity (Prefix (Expr))) 2255 and then Root_Type (Etype (N)) = Root_Type (Entity (Prefix (Expr))) 2256 then 2257 if Is_Entity_Name (Lhs) then 2258 Rewrite (Prefix (Expr), 2259 New_Occurrence_Of (Entity (Lhs), Loc)); 2260 2261 elsif Nkind (Lhs) = N_Selected_Component then 2262 Rewrite (Expr, 2263 Make_Attribute_Reference (Loc, 2264 Attribute_Name => Name_Unrestricted_Access, 2265 Prefix => New_Copy_Tree (Lhs))); 2266 Set_Analyzed (Parent (Expr), False); 2267 2268 else 2269 Rewrite (Expr, 2270 Make_Attribute_Reference (Loc, 2271 Attribute_Name => Name_Unrestricted_Access, 2272 Prefix => New_Copy_Tree (Lhs))); 2273 Set_Analyzed (Parent (Expr), False); 2274 end if; 2275 end if; 2276 2277 return OK; 2278 end Replace_Type; 2279 2280 procedure Replace_Self_Reference is 2281 new Traverse_Proc (Replace_Type); 2282 2283 procedure Replace_Discriminants is 2284 new Traverse_Proc (Rewrite_Discriminant); 2285 2286 -- Start of processing for Build_Record_Aggr_Code 2287 2288 begin 2289 if Has_Self_Reference (N) then 2290 Replace_Self_Reference (N); 2291 end if; 2292 2293 -- If the target of the aggregate is class-wide, we must convert it 2294 -- to the actual type of the aggregate, so that the proper components 2295 -- are visible. We know already that the types are compatible. 2296 2297 if Present (Etype (Lhs)) 2298 and then Is_Class_Wide_Type (Etype (Lhs)) 2299 then 2300 Target := Unchecked_Convert_To (Typ, Lhs); 2301 else 2302 Target := Lhs; 2303 end if; 2304 2305 -- Deal with the ancestor part of extension aggregates or with the 2306 -- discriminants of the root type. 2307 2308 if Nkind (N) = N_Extension_Aggregate then 2309 declare 2310 Ancestor : constant Node_Id := Ancestor_Part (N); 2311 Assign : List_Id; 2312 2313 begin 2314 -- If the ancestor part is a subtype mark "T", we generate 2315 2316 -- init-proc (T (tmp)); if T is constrained and 2317 -- init-proc (S (tmp)); where S applies an appropriate 2318 -- constraint if T is unconstrained 2319 2320 if Is_Entity_Name (Ancestor) 2321 and then Is_Type (Entity (Ancestor)) 2322 then 2323 Ancestor_Is_Subtype_Mark := True; 2324 2325 if Is_Constrained (Entity (Ancestor)) then 2326 Init_Typ := Entity (Ancestor); 2327 2328 -- For an ancestor part given by an unconstrained type mark, 2329 -- create a subtype constrained by appropriate corresponding 2330 -- discriminant values coming from either associations of the 2331 -- aggregate or a constraint on a parent type. The subtype will 2332 -- be used to generate the correct default value for the 2333 -- ancestor part. 2334 2335 elsif Has_Discriminants (Entity (Ancestor)) then 2336 declare 2337 Anc_Typ : constant Entity_Id := Entity (Ancestor); 2338 Anc_Constr : constant List_Id := New_List; 2339 Discrim : Entity_Id; 2340 Disc_Value : Node_Id; 2341 New_Indic : Node_Id; 2342 Subt_Decl : Node_Id; 2343 2344 begin 2345 Discrim := First_Discriminant (Anc_Typ); 2346 while Present (Discrim) loop 2347 Disc_Value := Ancestor_Discriminant_Value (Discrim); 2348 2349 -- If no usable discriminant in ancestors, check 2350 -- whether aggregate has an explicit value for it. 2351 2352 if No (Disc_Value) then 2353 Disc_Value := 2354 Get_Explicit_Discriminant_Value (Discrim); 2355 end if; 2356 2357 Append_To (Anc_Constr, Disc_Value); 2358 Next_Discriminant (Discrim); 2359 end loop; 2360 2361 New_Indic := 2362 Make_Subtype_Indication (Loc, 2363 Subtype_Mark => New_Occurrence_Of (Anc_Typ, Loc), 2364 Constraint => 2365 Make_Index_Or_Discriminant_Constraint (Loc, 2366 Constraints => Anc_Constr)); 2367 2368 Init_Typ := Create_Itype (Ekind (Anc_Typ), N); 2369 2370 Subt_Decl := 2371 Make_Subtype_Declaration (Loc, 2372 Defining_Identifier => Init_Typ, 2373 Subtype_Indication => New_Indic); 2374 2375 -- Itypes must be analyzed with checks off Declaration 2376 -- must have a parent for proper handling of subsidiary 2377 -- actions. 2378 2379 Set_Parent (Subt_Decl, N); 2380 Analyze (Subt_Decl, Suppress => All_Checks); 2381 end; 2382 end if; 2383 2384 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); 2385 Set_Assignment_OK (Ref); 2386 2387 if not Is_Interface (Init_Typ) then 2388 Append_List_To (L, 2389 Build_Initialization_Call (Loc, 2390 Id_Ref => Ref, 2391 Typ => Init_Typ, 2392 In_Init_Proc => Within_Init_Proc, 2393 With_Default_Init => Has_Default_Init_Comps (N) 2394 or else 2395 Has_Task (Base_Type (Init_Typ)))); 2396 2397 if Is_Constrained (Entity (Ancestor)) 2398 and then Has_Discriminants (Entity (Ancestor)) 2399 then 2400 Check_Ancestor_Discriminants (Entity (Ancestor)); 2401 end if; 2402 end if; 2403 2404 -- Handle calls to C++ constructors 2405 2406 elsif Is_CPP_Constructor_Call (Ancestor) then 2407 Init_Typ := Etype (Ancestor); 2408 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); 2409 Set_Assignment_OK (Ref); 2410 2411 Append_List_To (L, 2412 Build_Initialization_Call (Loc, 2413 Id_Ref => Ref, 2414 Typ => Init_Typ, 2415 In_Init_Proc => Within_Init_Proc, 2416 With_Default_Init => Has_Default_Init_Comps (N), 2417 Constructor_Ref => Ancestor)); 2418 2419 -- Ada 2005 (AI-287): If the ancestor part is an aggregate of 2420 -- limited type, a recursive call expands the ancestor. Note that 2421 -- in the limited case, the ancestor part must be either a 2422 -- function call (possibly qualified, or wrapped in an unchecked 2423 -- conversion) or aggregate (definitely qualified). 2424 -- The ancestor part can also be a function call (that may be 2425 -- transformed into an explicit dereference) or a qualification 2426 -- of one such. 2427 2428 elsif Is_Limited_Type (Etype (Ancestor)) 2429 and then Nkind_In (Unqualify (Ancestor), N_Aggregate, 2430 N_Extension_Aggregate) 2431 then 2432 Ancestor_Is_Expression := True; 2433 2434 -- Set up finalization data for enclosing record, because 2435 -- controlled subcomponents of the ancestor part will be 2436 -- attached to it. 2437 2438 Generate_Finalization_Actions; 2439 2440 Append_List_To (L, 2441 Build_Record_Aggr_Code 2442 (N => Unqualify (Ancestor), 2443 Typ => Etype (Unqualify (Ancestor)), 2444 Lhs => Target)); 2445 2446 -- If the ancestor part is an expression "E", we generate 2447 2448 -- T (tmp) := E; 2449 2450 -- In Ada 2005, this includes the case of a (possibly qualified) 2451 -- limited function call. The assignment will turn into a 2452 -- build-in-place function call (for further details, see 2453 -- Make_Build_In_Place_Call_In_Assignment). 2454 2455 else 2456 Ancestor_Is_Expression := True; 2457 Init_Typ := Etype (Ancestor); 2458 2459 -- If the ancestor part is an aggregate, force its full 2460 -- expansion, which was delayed. 2461 2462 if Nkind_In (Unqualify (Ancestor), N_Aggregate, 2463 N_Extension_Aggregate) 2464 then 2465 Set_Analyzed (Ancestor, False); 2466 Set_Analyzed (Expression (Ancestor), False); 2467 end if; 2468 2469 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); 2470 Set_Assignment_OK (Ref); 2471 2472 -- Make the assignment without usual controlled actions, since 2473 -- we only want to Adjust afterwards, but not to Finalize 2474 -- beforehand. Add manual Adjust when necessary. 2475 2476 Assign := New_List ( 2477 Make_OK_Assignment_Statement (Loc, 2478 Name => Ref, 2479 Expression => Ancestor)); 2480 Set_No_Ctrl_Actions (First (Assign)); 2481 2482 -- Assign the tag now to make sure that the dispatching call in 2483 -- the subsequent deep_adjust works properly (unless VM_Target, 2484 -- where tags are implicit). 2485 2486 if Tagged_Type_Expansion then 2487 Instr := 2488 Make_OK_Assignment_Statement (Loc, 2489 Name => 2490 Make_Selected_Component (Loc, 2491 Prefix => New_Copy_Tree (Target), 2492 Selector_Name => 2493 New_Occurrence_Of 2494 (First_Tag_Component (Base_Type (Typ)), Loc)), 2495 2496 Expression => 2497 Unchecked_Convert_To (RTE (RE_Tag), 2498 New_Occurrence_Of 2499 (Node (First_Elmt 2500 (Access_Disp_Table (Base_Type (Typ)))), 2501 Loc))); 2502 2503 Set_Assignment_OK (Name (Instr)); 2504 Append_To (Assign, Instr); 2505 2506 -- Ada 2005 (AI-251): If tagged type has progenitors we must 2507 -- also initialize tags of the secondary dispatch tables. 2508 2509 if Has_Interfaces (Base_Type (Typ)) then 2510 Init_Secondary_Tags 2511 (Typ => Base_Type (Typ), 2512 Target => Target, 2513 Stmts_List => Assign); 2514 end if; 2515 end if; 2516 2517 -- Call Adjust manually 2518 2519 if Needs_Finalization (Etype (Ancestor)) 2520 and then not Is_Limited_Type (Etype (Ancestor)) 2521 then 2522 Append_To (Assign, 2523 Make_Adjust_Call ( 2524 Obj_Ref => New_Copy_Tree (Ref), 2525 Typ => Etype (Ancestor))); 2526 end if; 2527 2528 Append_To (L, 2529 Make_Unsuppress_Block (Loc, Name_Discriminant_Check, Assign)); 2530 2531 if Has_Discriminants (Init_Typ) then 2532 Check_Ancestor_Discriminants (Init_Typ); 2533 end if; 2534 end if; 2535 end; 2536 2537 -- Generate assignments of hidden discriminants. If the base type is 2538 -- an unchecked union, the discriminants are unknown to the back-end 2539 -- and absent from a value of the type, so assignments for them are 2540 -- not emitted. 2541 2542 if Has_Discriminants (Typ) 2543 and then not Is_Unchecked_Union (Base_Type (Typ)) 2544 then 2545 Init_Hidden_Discriminants (Typ, L); 2546 end if; 2547 2548 -- Normal case (not an extension aggregate) 2549 2550 else 2551 -- Generate the discriminant expressions, component by component. 2552 -- If the base type is an unchecked union, the discriminants are 2553 -- unknown to the back-end and absent from a value of the type, so 2554 -- assignments for them are not emitted. 2555 2556 if Has_Discriminants (Typ) 2557 and then not Is_Unchecked_Union (Base_Type (Typ)) 2558 then 2559 Init_Hidden_Discriminants (Typ, L); 2560 2561 -- Generate discriminant init values for the visible discriminants 2562 2563 declare 2564 Discriminant : Entity_Id; 2565 Discriminant_Value : Node_Id; 2566 2567 begin 2568 Discriminant := First_Stored_Discriminant (Typ); 2569 while Present (Discriminant) loop 2570 Comp_Expr := 2571 Make_Selected_Component (Loc, 2572 Prefix => New_Copy_Tree (Target), 2573 Selector_Name => New_Occurrence_Of (Discriminant, Loc)); 2574 2575 Discriminant_Value := 2576 Get_Discriminant_Value ( 2577 Discriminant, 2578 N_Typ, 2579 Discriminant_Constraint (N_Typ)); 2580 2581 Instr := 2582 Make_OK_Assignment_Statement (Loc, 2583 Name => Comp_Expr, 2584 Expression => New_Copy_Tree (Discriminant_Value)); 2585 2586 Set_No_Ctrl_Actions (Instr); 2587 Append_To (L, Instr); 2588 2589 Next_Stored_Discriminant (Discriminant); 2590 end loop; 2591 end; 2592 end if; 2593 end if; 2594 2595 -- For CPP types we generate an implicit call to the C++ default 2596 -- constructor to ensure the proper initialization of the _Tag 2597 -- component. 2598 2599 if Is_CPP_Class (Root_Type (Typ)) 2600 and then CPP_Num_Prims (Typ) > 0 2601 then 2602 Invoke_Constructor : declare 2603 CPP_Parent : constant Entity_Id := Enclosing_CPP_Parent (Typ); 2604 2605 procedure Invoke_IC_Proc (T : Entity_Id); 2606 -- Recursive routine used to climb to parents. Required because 2607 -- parents must be initialized before descendants to ensure 2608 -- propagation of inherited C++ slots. 2609 2610 -------------------- 2611 -- Invoke_IC_Proc -- 2612 -------------------- 2613 2614 procedure Invoke_IC_Proc (T : Entity_Id) is 2615 begin 2616 -- Avoid generating extra calls. Initialization required 2617 -- only for types defined from the level of derivation of 2618 -- type of the constructor and the type of the aggregate. 2619 2620 if T = CPP_Parent then 2621 return; 2622 end if; 2623 2624 Invoke_IC_Proc (Etype (T)); 2625 2626 -- Generate call to the IC routine 2627 2628 if Present (CPP_Init_Proc (T)) then 2629 Append_To (L, 2630 Make_Procedure_Call_Statement (Loc, 2631 New_Occurrence_Of (CPP_Init_Proc (T), Loc))); 2632 end if; 2633 end Invoke_IC_Proc; 2634 2635 -- Start of processing for Invoke_Constructor 2636 2637 begin 2638 -- Implicit invocation of the C++ constructor 2639 2640 if Nkind (N) = N_Aggregate then 2641 Append_To (L, 2642 Make_Procedure_Call_Statement (Loc, 2643 Name => 2644 New_Occurrence_Of 2645 (Base_Init_Proc (CPP_Parent), Loc), 2646 Parameter_Associations => New_List ( 2647 Unchecked_Convert_To (CPP_Parent, 2648 New_Copy_Tree (Lhs))))); 2649 end if; 2650 2651 Invoke_IC_Proc (Typ); 2652 end Invoke_Constructor; 2653 end if; 2654 2655 -- Generate the assignments, component by component 2656 2657 -- tmp.comp1 := Expr1_From_Aggr; 2658 -- tmp.comp2 := Expr2_From_Aggr; 2659 -- .... 2660 2661 Comp := First (Component_Associations (N)); 2662 while Present (Comp) loop 2663 Selector := Entity (First (Choices (Comp))); 2664 2665 -- C++ constructors 2666 2667 if Is_CPP_Constructor_Call (Expression (Comp)) then 2668 Append_List_To (L, 2669 Build_Initialization_Call (Loc, 2670 Id_Ref => Make_Selected_Component (Loc, 2671 Prefix => New_Copy_Tree (Target), 2672 Selector_Name => 2673 New_Occurrence_Of (Selector, Loc)), 2674 Typ => Etype (Selector), 2675 Enclos_Type => Typ, 2676 With_Default_Init => True, 2677 Constructor_Ref => Expression (Comp))); 2678 2679 -- Ada 2005 (AI-287): For each default-initialized component generate 2680 -- a call to the corresponding IP subprogram if available. 2681 2682 elsif Box_Present (Comp) 2683 and then Has_Non_Null_Base_Init_Proc (Etype (Selector)) 2684 then 2685 if Ekind (Selector) /= E_Discriminant then 2686 Generate_Finalization_Actions; 2687 end if; 2688 2689 -- Ada 2005 (AI-287): If the component type has tasks then 2690 -- generate the activation chain and master entities (except 2691 -- in case of an allocator because in that case these entities 2692 -- are generated by Build_Task_Allocate_Block_With_Init_Stmts). 2693 2694 declare 2695 Ctype : constant Entity_Id := Etype (Selector); 2696 Inside_Allocator : Boolean := False; 2697 P : Node_Id := Parent (N); 2698 2699 begin 2700 if Is_Task_Type (Ctype) or else Has_Task (Ctype) then 2701 while Present (P) loop 2702 if Nkind (P) = N_Allocator then 2703 Inside_Allocator := True; 2704 exit; 2705 end if; 2706 2707 P := Parent (P); 2708 end loop; 2709 2710 if not Inside_Init_Proc and not Inside_Allocator then 2711 Build_Activation_Chain_Entity (N); 2712 end if; 2713 end if; 2714 end; 2715 2716 Append_List_To (L, 2717 Build_Initialization_Call (Loc, 2718 Id_Ref => Make_Selected_Component (Loc, 2719 Prefix => New_Copy_Tree (Target), 2720 Selector_Name => 2721 New_Occurrence_Of (Selector, Loc)), 2722 Typ => Etype (Selector), 2723 Enclos_Type => Typ, 2724 With_Default_Init => True)); 2725 2726 -- Prepare for component assignment 2727 2728 elsif Ekind (Selector) /= E_Discriminant 2729 or else Nkind (N) = N_Extension_Aggregate 2730 then 2731 -- All the discriminants have now been assigned 2732 2733 -- This is now a good moment to initialize and attach all the 2734 -- controllers. Their position may depend on the discriminants. 2735 2736 if Ekind (Selector) /= E_Discriminant then 2737 Generate_Finalization_Actions; 2738 end if; 2739 2740 Comp_Type := Underlying_Type (Etype (Selector)); 2741 Comp_Expr := 2742 Make_Selected_Component (Loc, 2743 Prefix => New_Copy_Tree (Target), 2744 Selector_Name => New_Occurrence_Of (Selector, Loc)); 2745 2746 if Nkind (Expression (Comp)) = N_Qualified_Expression then 2747 Expr_Q := Expression (Expression (Comp)); 2748 else 2749 Expr_Q := Expression (Comp); 2750 end if; 2751 2752 -- Now either create the assignment or generate the code for the 2753 -- inner aggregate top-down. 2754 2755 if Is_Delayed_Aggregate (Expr_Q) then 2756 2757 -- We have the following case of aggregate nesting inside 2758 -- an object declaration: 2759 2760 -- type Arr_Typ is array (Integer range <>) of ...; 2761 2762 -- type Rec_Typ (...) is record 2763 -- Obj_Arr_Typ : Arr_Typ (A .. B); 2764 -- end record; 2765 2766 -- Obj_Rec_Typ : Rec_Typ := (..., 2767 -- Obj_Arr_Typ => (X => (...), Y => (...))); 2768 2769 -- The length of the ranges of the aggregate and Obj_Add_Typ 2770 -- are equal (B - A = Y - X), but they do not coincide (X /= 2771 -- A and B /= Y). This case requires array sliding which is 2772 -- performed in the following manner: 2773 2774 -- subtype Arr_Sub is Arr_Typ (X .. Y); 2775 -- Temp : Arr_Sub; 2776 -- Temp (X) := (...); 2777 -- ... 2778 -- Temp (Y) := (...); 2779 -- Obj_Rec_Typ.Obj_Arr_Typ := Temp; 2780 2781 if Ekind (Comp_Type) = E_Array_Subtype 2782 and then Is_Int_Range_Bounds (Aggregate_Bounds (Expr_Q)) 2783 and then Is_Int_Range_Bounds (First_Index (Comp_Type)) 2784 and then not 2785 Compatible_Int_Bounds 2786 (Agg_Bounds => Aggregate_Bounds (Expr_Q), 2787 Typ_Bounds => First_Index (Comp_Type)) 2788 then 2789 -- Create the array subtype with bounds equal to those of 2790 -- the corresponding aggregate. 2791 2792 declare 2793 SubE : constant Entity_Id := Make_Temporary (Loc, 'T'); 2794 2795 SubD : constant Node_Id := 2796 Make_Subtype_Declaration (Loc, 2797 Defining_Identifier => SubE, 2798 Subtype_Indication => 2799 Make_Subtype_Indication (Loc, 2800 Subtype_Mark => 2801 New_Occurrence_Of (Etype (Comp_Type), Loc), 2802 Constraint => 2803 Make_Index_Or_Discriminant_Constraint 2804 (Loc, 2805 Constraints => New_List ( 2806 New_Copy_Tree 2807 (Aggregate_Bounds (Expr_Q)))))); 2808 2809 -- Create a temporary array of the above subtype which 2810 -- will be used to capture the aggregate assignments. 2811 2812 TmpE : constant Entity_Id := Make_Temporary (Loc, 'A', N); 2813 2814 TmpD : constant Node_Id := 2815 Make_Object_Declaration (Loc, 2816 Defining_Identifier => TmpE, 2817 Object_Definition => New_Occurrence_Of (SubE, Loc)); 2818 2819 begin 2820 Set_No_Initialization (TmpD); 2821 Append_To (L, SubD); 2822 Append_To (L, TmpD); 2823 2824 -- Expand aggregate into assignments to the temp array 2825 2826 Append_List_To (L, 2827 Late_Expansion (Expr_Q, Comp_Type, 2828 New_Occurrence_Of (TmpE, Loc))); 2829 2830 -- Slide 2831 2832 Append_To (L, 2833 Make_Assignment_Statement (Loc, 2834 Name => New_Copy_Tree (Comp_Expr), 2835 Expression => New_Occurrence_Of (TmpE, Loc))); 2836 end; 2837 2838 -- Normal case (sliding not required) 2839 2840 else 2841 Append_List_To (L, 2842 Late_Expansion (Expr_Q, Comp_Type, Comp_Expr)); 2843 end if; 2844 2845 -- Expr_Q is not delayed aggregate 2846 2847 else 2848 if Has_Discriminants (Typ) then 2849 Replace_Discriminants (Expr_Q); 2850 end if; 2851 2852 Instr := 2853 Make_OK_Assignment_Statement (Loc, 2854 Name => Comp_Expr, 2855 Expression => Expr_Q); 2856 2857 Set_No_Ctrl_Actions (Instr); 2858 Append_To (L, Instr); 2859 2860 -- Adjust the tag if tagged (because of possible view 2861 -- conversions), unless compiling for a VM where tags are 2862 -- implicit. 2863 2864 -- tmp.comp._tag := comp_typ'tag; 2865 2866 if Is_Tagged_Type (Comp_Type) 2867 and then Tagged_Type_Expansion 2868 then 2869 Instr := 2870 Make_OK_Assignment_Statement (Loc, 2871 Name => 2872 Make_Selected_Component (Loc, 2873 Prefix => New_Copy_Tree (Comp_Expr), 2874 Selector_Name => 2875 New_Occurrence_Of 2876 (First_Tag_Component (Comp_Type), Loc)), 2877 2878 Expression => 2879 Unchecked_Convert_To (RTE (RE_Tag), 2880 New_Occurrence_Of 2881 (Node (First_Elmt (Access_Disp_Table (Comp_Type))), 2882 Loc))); 2883 2884 Append_To (L, Instr); 2885 end if; 2886 2887 -- Generate: 2888 -- Adjust (tmp.comp); 2889 2890 if Needs_Finalization (Comp_Type) 2891 and then not Is_Limited_Type (Comp_Type) 2892 then 2893 Append_To (L, 2894 Make_Adjust_Call ( 2895 Obj_Ref => New_Copy_Tree (Comp_Expr), 2896 Typ => Comp_Type)); 2897 end if; 2898 end if; 2899 2900 -- ??? 2901 2902 elsif Ekind (Selector) = E_Discriminant 2903 and then Nkind (N) /= N_Extension_Aggregate 2904 and then Nkind (Parent (N)) = N_Component_Association 2905 and then Is_Constrained (Typ) 2906 then 2907 -- We must check that the discriminant value imposed by the 2908 -- context is the same as the value given in the subaggregate, 2909 -- because after the expansion into assignments there is no 2910 -- record on which to perform a regular discriminant check. 2911 2912 declare 2913 D_Val : Elmt_Id; 2914 Disc : Entity_Id; 2915 2916 begin 2917 D_Val := First_Elmt (Discriminant_Constraint (Typ)); 2918 Disc := First_Discriminant (Typ); 2919 while Chars (Disc) /= Chars (Selector) loop 2920 Next_Discriminant (Disc); 2921 Next_Elmt (D_Val); 2922 end loop; 2923 2924 pragma Assert (Present (D_Val)); 2925 2926 -- This check cannot performed for components that are 2927 -- constrained by a current instance, because this is not a 2928 -- value that can be compared with the actual constraint. 2929 2930 if Nkind (Node (D_Val)) /= N_Attribute_Reference 2931 or else not Is_Entity_Name (Prefix (Node (D_Val))) 2932 or else not Is_Type (Entity (Prefix (Node (D_Val)))) 2933 then 2934 Append_To (L, 2935 Make_Raise_Constraint_Error (Loc, 2936 Condition => 2937 Make_Op_Ne (Loc, 2938 Left_Opnd => New_Copy_Tree (Node (D_Val)), 2939 Right_Opnd => Expression (Comp)), 2940 Reason => CE_Discriminant_Check_Failed)); 2941 2942 else 2943 -- Find self-reference in previous discriminant assignment, 2944 -- and replace with proper expression. 2945 2946 declare 2947 Ass : Node_Id; 2948 2949 begin 2950 Ass := First (L); 2951 while Present (Ass) loop 2952 if Nkind (Ass) = N_Assignment_Statement 2953 and then Nkind (Name (Ass)) = N_Selected_Component 2954 and then Chars (Selector_Name (Name (Ass))) = 2955 Chars (Disc) 2956 then 2957 Set_Expression 2958 (Ass, New_Copy_Tree (Expression (Comp))); 2959 exit; 2960 end if; 2961 Next (Ass); 2962 end loop; 2963 end; 2964 end if; 2965 end; 2966 end if; 2967 2968 Next (Comp); 2969 end loop; 2970 2971 -- If the type is tagged, the tag needs to be initialized (unless 2972 -- compiling for the Java VM where tags are implicit). It is done 2973 -- late in the initialization process because in some cases, we call 2974 -- the init proc of an ancestor which will not leave out the right tag 2975 2976 if Ancestor_Is_Expression then 2977 null; 2978 2979 -- For CPP types we generated a call to the C++ default constructor 2980 -- before the components have been initialized to ensure the proper 2981 -- initialization of the _Tag component (see above). 2982 2983 elsif Is_CPP_Class (Typ) then 2984 null; 2985 2986 elsif Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then 2987 Instr := 2988 Make_OK_Assignment_Statement (Loc, 2989 Name => 2990 Make_Selected_Component (Loc, 2991 Prefix => New_Copy_Tree (Target), 2992 Selector_Name => 2993 New_Occurrence_Of 2994 (First_Tag_Component (Base_Type (Typ)), Loc)), 2995 2996 Expression => 2997 Unchecked_Convert_To (RTE (RE_Tag), 2998 New_Occurrence_Of 2999 (Node (First_Elmt (Access_Disp_Table (Base_Type (Typ)))), 3000 Loc))); 3001 3002 Append_To (L, Instr); 3003 3004 -- Ada 2005 (AI-251): If the tagged type has been derived from 3005 -- abstract interfaces we must also initialize the tags of the 3006 -- secondary dispatch tables. 3007 3008 if Has_Interfaces (Base_Type (Typ)) then 3009 Init_Secondary_Tags 3010 (Typ => Base_Type (Typ), 3011 Target => Target, 3012 Stmts_List => L); 3013 end if; 3014 end if; 3015 3016 -- If the controllers have not been initialized yet (by lack of non- 3017 -- discriminant components), let's do it now. 3018 3019 Generate_Finalization_Actions; 3020 3021 return L; 3022 end Build_Record_Aggr_Code; 3023 3024 --------------------------------------- 3025 -- Collect_Initialization_Statements -- 3026 --------------------------------------- 3027 3028 procedure Collect_Initialization_Statements 3029 (Obj : Entity_Id; 3030 N : Node_Id; 3031 Node_After : Node_Id) 3032 is 3033 Loc : constant Source_Ptr := Sloc (N); 3034 Init_Actions : constant List_Id := New_List; 3035 Init_Node : Node_Id; 3036 EA : Node_Id; 3037 3038 begin 3039 -- Nothing to do if Obj is already frozen, as in this case we known we 3040 -- won't need to move the initialization statements about later on. 3041 3042 if Is_Frozen (Obj) then 3043 return; 3044 end if; 3045 3046 Init_Node := N; 3047 while Next (Init_Node) /= Node_After loop 3048 Append_To (Init_Actions, Remove_Next (Init_Node)); 3049 end loop; 3050 3051 if not Is_Empty_List (Init_Actions) then 3052 EA := 3053 Make_Expression_With_Actions (Loc, 3054 Actions => Init_Actions, 3055 Expression => Make_Null_Statement (Loc)); 3056 Insert_Action_After (Init_Node, EA); 3057 Set_Initialization_Statements (Obj, EA); 3058 end if; 3059 end Collect_Initialization_Statements; 3060 3061 ------------------------------- 3062 -- Convert_Aggr_In_Allocator -- 3063 ------------------------------- 3064 3065 procedure Convert_Aggr_In_Allocator 3066 (Alloc : Node_Id; 3067 Decl : Node_Id; 3068 Aggr : Node_Id) 3069 is 3070 Loc : constant Source_Ptr := Sloc (Aggr); 3071 Typ : constant Entity_Id := Etype (Aggr); 3072 Temp : constant Entity_Id := Defining_Identifier (Decl); 3073 3074 Occ : constant Node_Id := 3075 Unchecked_Convert_To (Typ, 3076 Make_Explicit_Dereference (Loc, New_Occurrence_Of (Temp, Loc))); 3077 3078 begin 3079 if Is_Array_Type (Typ) then 3080 Convert_Array_Aggr_In_Allocator (Decl, Aggr, Occ); 3081 3082 elsif Has_Default_Init_Comps (Aggr) then 3083 declare 3084 L : constant List_Id := New_List; 3085 Init_Stmts : List_Id; 3086 3087 begin 3088 Init_Stmts := Late_Expansion (Aggr, Typ, Occ); 3089 3090 if Has_Task (Typ) then 3091 Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts); 3092 Insert_Actions (Alloc, L); 3093 else 3094 Insert_Actions (Alloc, Init_Stmts); 3095 end if; 3096 end; 3097 3098 else 3099 Insert_Actions (Alloc, Late_Expansion (Aggr, Typ, Occ)); 3100 end if; 3101 end Convert_Aggr_In_Allocator; 3102 3103 -------------------------------- 3104 -- Convert_Aggr_In_Assignment -- 3105 -------------------------------- 3106 3107 procedure Convert_Aggr_In_Assignment (N : Node_Id) is 3108 Aggr : Node_Id := Expression (N); 3109 Typ : constant Entity_Id := Etype (Aggr); 3110 Occ : constant Node_Id := New_Copy_Tree (Name (N)); 3111 3112 begin 3113 if Nkind (Aggr) = N_Qualified_Expression then 3114 Aggr := Expression (Aggr); 3115 end if; 3116 3117 Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ)); 3118 end Convert_Aggr_In_Assignment; 3119 3120 --------------------------------- 3121 -- Convert_Aggr_In_Object_Decl -- 3122 --------------------------------- 3123 3124 procedure Convert_Aggr_In_Object_Decl (N : Node_Id) is 3125 Obj : constant Entity_Id := Defining_Identifier (N); 3126 Aggr : Node_Id := Expression (N); 3127 Loc : constant Source_Ptr := Sloc (Aggr); 3128 Typ : constant Entity_Id := Etype (Aggr); 3129 Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc); 3130 3131 function Discriminants_Ok return Boolean; 3132 -- If the object type is constrained, the discriminants in the 3133 -- aggregate must be checked against the discriminants of the subtype. 3134 -- This cannot be done using Apply_Discriminant_Checks because after 3135 -- expansion there is no aggregate left to check. 3136 3137 ---------------------- 3138 -- Discriminants_Ok -- 3139 ---------------------- 3140 3141 function Discriminants_Ok return Boolean is 3142 Cond : Node_Id := Empty; 3143 Check : Node_Id; 3144 D : Entity_Id; 3145 Disc1 : Elmt_Id; 3146 Disc2 : Elmt_Id; 3147 Val1 : Node_Id; 3148 Val2 : Node_Id; 3149 3150 begin 3151 D := First_Discriminant (Typ); 3152 Disc1 := First_Elmt (Discriminant_Constraint (Typ)); 3153 Disc2 := First_Elmt (Discriminant_Constraint (Etype (Obj))); 3154 while Present (Disc1) and then Present (Disc2) loop 3155 Val1 := Node (Disc1); 3156 Val2 := Node (Disc2); 3157 3158 if not Is_OK_Static_Expression (Val1) 3159 or else not Is_OK_Static_Expression (Val2) 3160 then 3161 Check := Make_Op_Ne (Loc, 3162 Left_Opnd => Duplicate_Subexpr (Val1), 3163 Right_Opnd => Duplicate_Subexpr (Val2)); 3164 3165 if No (Cond) then 3166 Cond := Check; 3167 3168 else 3169 Cond := Make_Or_Else (Loc, 3170 Left_Opnd => Cond, 3171 Right_Opnd => Check); 3172 end if; 3173 3174 elsif Expr_Value (Val1) /= Expr_Value (Val2) then 3175 Apply_Compile_Time_Constraint_Error (Aggr, 3176 Msg => "incorrect value for discriminant&??", 3177 Reason => CE_Discriminant_Check_Failed, 3178 Ent => D); 3179 return False; 3180 end if; 3181 3182 Next_Discriminant (D); 3183 Next_Elmt (Disc1); 3184 Next_Elmt (Disc2); 3185 end loop; 3186 3187 -- If any discriminant constraint is non-static, emit a check 3188 3189 if Present (Cond) then 3190 Insert_Action (N, 3191 Make_Raise_Constraint_Error (Loc, 3192 Condition => Cond, 3193 Reason => CE_Discriminant_Check_Failed)); 3194 end if; 3195 3196 return True; 3197 end Discriminants_Ok; 3198 3199 -- Start of processing for Convert_Aggr_In_Object_Decl 3200 3201 begin 3202 Set_Assignment_OK (Occ); 3203 3204 if Nkind (Aggr) = N_Qualified_Expression then 3205 Aggr := Expression (Aggr); 3206 end if; 3207 3208 if Has_Discriminants (Typ) 3209 and then Typ /= Etype (Obj) 3210 and then Is_Constrained (Etype (Obj)) 3211 and then not Discriminants_Ok 3212 then 3213 return; 3214 end if; 3215 3216 -- If the context is an extended return statement, it has its own 3217 -- finalization machinery (i.e. works like a transient scope) and 3218 -- we do not want to create an additional one, because objects on 3219 -- the finalization list of the return must be moved to the caller's 3220 -- finalization list to complete the return. 3221 3222 -- However, if the aggregate is limited, it is built in place, and the 3223 -- controlled components are not assigned to intermediate temporaries 3224 -- so there is no need for a transient scope in this case either. 3225 3226 if Requires_Transient_Scope (Typ) 3227 and then Ekind (Current_Scope) /= E_Return_Statement 3228 and then not Is_Limited_Type (Typ) 3229 then 3230 Establish_Transient_Scope 3231 (Aggr, 3232 Sec_Stack => 3233 Is_Controlled (Typ) or else Has_Controlled_Component (Typ)); 3234 end if; 3235 3236 declare 3237 Node_After : constant Node_Id := Next (N); 3238 begin 3239 Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ)); 3240 Collect_Initialization_Statements (Obj, N, Node_After); 3241 end; 3242 Set_No_Initialization (N); 3243 Initialize_Discriminants (N, Typ); 3244 end Convert_Aggr_In_Object_Decl; 3245 3246 ------------------------------------- 3247 -- Convert_Array_Aggr_In_Allocator -- 3248 ------------------------------------- 3249 3250 procedure Convert_Array_Aggr_In_Allocator 3251 (Decl : Node_Id; 3252 Aggr : Node_Id; 3253 Target : Node_Id) 3254 is 3255 Aggr_Code : List_Id; 3256 Typ : constant Entity_Id := Etype (Aggr); 3257 Ctyp : constant Entity_Id := Component_Type (Typ); 3258 3259 begin 3260 -- The target is an explicit dereference of the allocated object. 3261 -- Generate component assignments to it, as for an aggregate that 3262 -- appears on the right-hand side of an assignment statement. 3263 3264 Aggr_Code := 3265 Build_Array_Aggr_Code (Aggr, 3266 Ctype => Ctyp, 3267 Index => First_Index (Typ), 3268 Into => Target, 3269 Scalar_Comp => Is_Scalar_Type (Ctyp)); 3270 3271 Insert_Actions_After (Decl, Aggr_Code); 3272 end Convert_Array_Aggr_In_Allocator; 3273 3274 ---------------------------- 3275 -- Convert_To_Assignments -- 3276 ---------------------------- 3277 3278 procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is 3279 Loc : constant Source_Ptr := Sloc (N); 3280 T : Entity_Id; 3281 Temp : Entity_Id; 3282 3283 Aggr_Code : List_Id; 3284 Instr : Node_Id; 3285 Target_Expr : Node_Id; 3286 Parent_Kind : Node_Kind; 3287 Unc_Decl : Boolean := False; 3288 Parent_Node : Node_Id; 3289 3290 begin 3291 pragma Assert (not Is_Static_Dispatch_Table_Aggregate (N)); 3292 pragma Assert (Is_Record_Type (Typ)); 3293 3294 Parent_Node := Parent (N); 3295 Parent_Kind := Nkind (Parent_Node); 3296 3297 if Parent_Kind = N_Qualified_Expression then 3298 3299 -- Check if we are in a unconstrained declaration because in this 3300 -- case the current delayed expansion mechanism doesn't work when 3301 -- the declared object size depend on the initializing expr. 3302 3303 begin 3304 Parent_Node := Parent (Parent_Node); 3305 Parent_Kind := Nkind (Parent_Node); 3306 3307 if Parent_Kind = N_Object_Declaration then 3308 Unc_Decl := 3309 not Is_Entity_Name (Object_Definition (Parent_Node)) 3310 or else Has_Discriminants 3311 (Entity (Object_Definition (Parent_Node))) 3312 or else Is_Class_Wide_Type 3313 (Entity (Object_Definition (Parent_Node))); 3314 end if; 3315 end; 3316 end if; 3317 3318 -- Just set the Delay flag in the cases where the transformation will be 3319 -- done top down from above. 3320 3321 if False 3322 3323 -- Internal aggregate (transformed when expanding the parent) 3324 3325 or else Parent_Kind = N_Aggregate 3326 or else Parent_Kind = N_Extension_Aggregate 3327 or else Parent_Kind = N_Component_Association 3328 3329 -- Allocator (see Convert_Aggr_In_Allocator) 3330 3331 or else Parent_Kind = N_Allocator 3332 3333 -- Object declaration (see Convert_Aggr_In_Object_Decl) 3334 3335 or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl) 3336 3337 -- Safe assignment (see Convert_Aggr_Assignments). So far only the 3338 -- assignments in init procs are taken into account. 3339 3340 or else (Parent_Kind = N_Assignment_Statement 3341 and then Inside_Init_Proc) 3342 3343 -- (Ada 2005) An inherently limited type in a return statement, 3344 -- which will be handled in a build-in-place fashion, and may be 3345 -- rewritten as an extended return and have its own finalization 3346 -- machinery. In the case of a simple return, the aggregate needs 3347 -- to be delayed until the scope for the return statement has been 3348 -- created, so that any finalization chain will be associated with 3349 -- that scope. For extended returns, we delay expansion to avoid the 3350 -- creation of an unwanted transient scope that could result in 3351 -- premature finalization of the return object (which is built in 3352 -- in place within the caller's scope). 3353 3354 or else 3355 (Is_Limited_View (Typ) 3356 and then 3357 (Nkind (Parent (Parent_Node)) = N_Extended_Return_Statement 3358 or else Nkind (Parent_Node) = N_Simple_Return_Statement)) 3359 then 3360 Set_Expansion_Delayed (N); 3361 return; 3362 end if; 3363 3364 if Requires_Transient_Scope (Typ) then 3365 Establish_Transient_Scope (N, Sec_Stack => Needs_Finalization (Typ)); 3366 end if; 3367 3368 -- If the aggregate is non-limited, create a temporary. If it is limited 3369 -- and the context is an assignment, this is a subaggregate for an 3370 -- enclosing aggregate being expanded. It must be built in place, so use 3371 -- the target of the current assignment. 3372 3373 if Is_Limited_Type (Typ) 3374 and then Nkind (Parent (N)) = N_Assignment_Statement 3375 then 3376 Target_Expr := New_Copy_Tree (Name (Parent (N))); 3377 Insert_Actions (Parent (N), 3378 Build_Record_Aggr_Code (N, Typ, Target_Expr)); 3379 Rewrite (Parent (N), Make_Null_Statement (Loc)); 3380 3381 else 3382 Temp := Make_Temporary (Loc, 'A', N); 3383 3384 -- If the type inherits unknown discriminants, use the view with 3385 -- known discriminants if available. 3386 3387 if Has_Unknown_Discriminants (Typ) 3388 and then Present (Underlying_Record_View (Typ)) 3389 then 3390 T := Underlying_Record_View (Typ); 3391 else 3392 T := Typ; 3393 end if; 3394 3395 Instr := 3396 Make_Object_Declaration (Loc, 3397 Defining_Identifier => Temp, 3398 Object_Definition => New_Occurrence_Of (T, Loc)); 3399 3400 Set_No_Initialization (Instr); 3401 Insert_Action (N, Instr); 3402 Initialize_Discriminants (Instr, T); 3403 3404 Target_Expr := New_Occurrence_Of (Temp, Loc); 3405 Aggr_Code := Build_Record_Aggr_Code (N, T, Target_Expr); 3406 3407 -- Save the last assignment statement associated with the aggregate 3408 -- when building a controlled object. This reference is utilized by 3409 -- the finalization machinery when marking an object as successfully 3410 -- initialized. 3411 3412 if Needs_Finalization (T) then 3413 Set_Last_Aggregate_Assignment (Temp, Last (Aggr_Code)); 3414 end if; 3415 3416 Insert_Actions (N, Aggr_Code); 3417 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 3418 Analyze_And_Resolve (N, T); 3419 end if; 3420 end Convert_To_Assignments; 3421 3422 --------------------------- 3423 -- Convert_To_Positional -- 3424 --------------------------- 3425 3426 procedure Convert_To_Positional 3427 (N : Node_Id; 3428 Max_Others_Replicate : Nat := 5; 3429 Handle_Bit_Packed : Boolean := False) 3430 is 3431 Typ : constant Entity_Id := Etype (N); 3432 3433 Static_Components : Boolean := True; 3434 3435 procedure Check_Static_Components; 3436 -- Check whether all components of the aggregate are compile-time known 3437 -- values, and can be passed as is to the back-end without further 3438 -- expansion. 3439 3440 function Flatten 3441 (N : Node_Id; 3442 Ix : Node_Id; 3443 Ixb : Node_Id) return Boolean; 3444 -- Convert the aggregate into a purely positional form if possible. On 3445 -- entry the bounds of all dimensions are known to be static, and the 3446 -- total number of components is safe enough to expand. 3447 3448 function Is_Flat (N : Node_Id; Dims : Int) return Boolean; 3449 -- Return True iff the array N is flat (which is not trivial in the case 3450 -- of multidimensional aggregates). 3451 3452 ----------------------------- 3453 -- Check_Static_Components -- 3454 ----------------------------- 3455 3456 procedure Check_Static_Components is 3457 Expr : Node_Id; 3458 3459 begin 3460 Static_Components := True; 3461 3462 if Nkind (N) = N_String_Literal then 3463 null; 3464 3465 elsif Present (Expressions (N)) then 3466 Expr := First (Expressions (N)); 3467 while Present (Expr) loop 3468 if Nkind (Expr) /= N_Aggregate 3469 or else not Compile_Time_Known_Aggregate (Expr) 3470 or else Expansion_Delayed (Expr) 3471 then 3472 Static_Components := False; 3473 exit; 3474 end if; 3475 3476 Next (Expr); 3477 end loop; 3478 end if; 3479 3480 if Nkind (N) = N_Aggregate 3481 and then Present (Component_Associations (N)) 3482 then 3483 Expr := First (Component_Associations (N)); 3484 while Present (Expr) loop 3485 if Nkind_In (Expression (Expr), N_Integer_Literal, 3486 N_Real_Literal) 3487 then 3488 null; 3489 3490 elsif Is_Entity_Name (Expression (Expr)) 3491 and then Present (Entity (Expression (Expr))) 3492 and then Ekind (Entity (Expression (Expr))) = 3493 E_Enumeration_Literal 3494 then 3495 null; 3496 3497 elsif Nkind (Expression (Expr)) /= N_Aggregate 3498 or else not Compile_Time_Known_Aggregate (Expression (Expr)) 3499 or else Expansion_Delayed (Expression (Expr)) 3500 then 3501 Static_Components := False; 3502 exit; 3503 end if; 3504 3505 Next (Expr); 3506 end loop; 3507 end if; 3508 end Check_Static_Components; 3509 3510 ------------- 3511 -- Flatten -- 3512 ------------- 3513 3514 function Flatten 3515 (N : Node_Id; 3516 Ix : Node_Id; 3517 Ixb : Node_Id) return Boolean 3518 is 3519 Loc : constant Source_Ptr := Sloc (N); 3520 Blo : constant Node_Id := Type_Low_Bound (Etype (Ixb)); 3521 Lo : constant Node_Id := Type_Low_Bound (Etype (Ix)); 3522 Hi : constant Node_Id := Type_High_Bound (Etype (Ix)); 3523 Lov : Uint; 3524 Hiv : Uint; 3525 3526 Others_Present : Boolean := False; 3527 3528 begin 3529 if Nkind (Original_Node (N)) = N_String_Literal then 3530 return True; 3531 end if; 3532 3533 if not Compile_Time_Known_Value (Lo) 3534 or else not Compile_Time_Known_Value (Hi) 3535 then 3536 return False; 3537 end if; 3538 3539 Lov := Expr_Value (Lo); 3540 Hiv := Expr_Value (Hi); 3541 3542 -- Check if there is an others choice 3543 3544 if Present (Component_Associations (N)) then 3545 declare 3546 Assoc : Node_Id; 3547 Choice : Node_Id; 3548 3549 begin 3550 Assoc := First (Component_Associations (N)); 3551 while Present (Assoc) loop 3552 3553 -- If this is a box association, flattening is in general 3554 -- not possible because at this point we cannot tell if the 3555 -- default is static or even exists. 3556 3557 if Box_Present (Assoc) then 3558 return False; 3559 end if; 3560 3561 Choice := First (Choices (Assoc)); 3562 3563 while Present (Choice) loop 3564 if Nkind (Choice) = N_Others_Choice then 3565 Others_Present := True; 3566 end if; 3567 3568 Next (Choice); 3569 end loop; 3570 3571 Next (Assoc); 3572 end loop; 3573 end; 3574 end if; 3575 3576 -- If the low bound is not known at compile time and others is not 3577 -- present we can proceed since the bounds can be obtained from the 3578 -- aggregate. 3579 3580 -- Note: This case is required in VM platforms since their backends 3581 -- normalize array indexes in the range 0 .. N-1. Hence, if we do 3582 -- not flat an array whose bounds cannot be obtained from the type 3583 -- of the index the backend has no way to properly generate the code. 3584 -- See ACATS c460010 for an example. 3585 3586 if Hiv < Lov 3587 or else (not Compile_Time_Known_Value (Blo) 3588 and then Others_Present) 3589 then 3590 return False; 3591 end if; 3592 3593 -- Determine if set of alternatives is suitable for conversion and 3594 -- build an array containing the values in sequence. 3595 3596 declare 3597 Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv)) 3598 of Node_Id := (others => Empty); 3599 -- The values in the aggregate sorted appropriately 3600 3601 Vlist : List_Id; 3602 -- Same data as Vals in list form 3603 3604 Rep_Count : Nat; 3605 -- Used to validate Max_Others_Replicate limit 3606 3607 Elmt : Node_Id; 3608 Num : Int := UI_To_Int (Lov); 3609 Choice_Index : Int; 3610 Choice : Node_Id; 3611 Lo, Hi : Node_Id; 3612 3613 begin 3614 if Present (Expressions (N)) then 3615 Elmt := First (Expressions (N)); 3616 while Present (Elmt) loop 3617 if Nkind (Elmt) = N_Aggregate 3618 and then Present (Next_Index (Ix)) 3619 and then 3620 not Flatten (Elmt, Next_Index (Ix), Next_Index (Ixb)) 3621 then 3622 return False; 3623 end if; 3624 3625 Vals (Num) := Relocate_Node (Elmt); 3626 Num := Num + 1; 3627 3628 Next (Elmt); 3629 end loop; 3630 end if; 3631 3632 if No (Component_Associations (N)) then 3633 return True; 3634 end if; 3635 3636 Elmt := First (Component_Associations (N)); 3637 3638 if Nkind (Expression (Elmt)) = N_Aggregate then 3639 if Present (Next_Index (Ix)) 3640 and then 3641 not Flatten 3642 (Expression (Elmt), Next_Index (Ix), Next_Index (Ixb)) 3643 then 3644 return False; 3645 end if; 3646 end if; 3647 3648 Component_Loop : while Present (Elmt) loop 3649 Choice := First (Choices (Elmt)); 3650 Choice_Loop : while Present (Choice) loop 3651 3652 -- If we have an others choice, fill in the missing elements 3653 -- subject to the limit established by Max_Others_Replicate. 3654 3655 if Nkind (Choice) = N_Others_Choice then 3656 Rep_Count := 0; 3657 3658 for J in Vals'Range loop 3659 if No (Vals (J)) then 3660 Vals (J) := New_Copy_Tree (Expression (Elmt)); 3661 Rep_Count := Rep_Count + 1; 3662 3663 -- Check for maximum others replication. Note that 3664 -- we skip this test if either of the restrictions 3665 -- No_Elaboration_Code or No_Implicit_Loops is 3666 -- active, if this is a preelaborable unit or 3667 -- a predefined unit, or if the unit must be 3668 -- placed in data memory. This also ensures that 3669 -- predefined units get the same level of constant 3670 -- folding in Ada 95 and Ada 2005, where their 3671 -- categorization has changed. 3672 3673 declare 3674 P : constant Entity_Id := 3675 Cunit_Entity (Current_Sem_Unit); 3676 3677 begin 3678 -- Check if duplication OK and if so continue 3679 -- processing. 3680 3681 if Restriction_Active (No_Elaboration_Code) 3682 or else Restriction_Active (No_Implicit_Loops) 3683 or else 3684 (Ekind (Current_Scope) = E_Package 3685 and then 3686 Static_Elaboration_Desired 3687 (Current_Scope)) 3688 or else Is_Preelaborated (P) 3689 or else (Ekind (P) = E_Package_Body 3690 and then 3691 Is_Preelaborated (Spec_Entity (P))) 3692 or else 3693 Is_Predefined_File_Name 3694 (Unit_File_Name (Get_Source_Unit (P))) 3695 then 3696 null; 3697 3698 -- If duplication not OK, then we return False 3699 -- if the replication count is too high 3700 3701 elsif Rep_Count > Max_Others_Replicate then 3702 return False; 3703 3704 -- Continue on if duplication not OK, but the 3705 -- replication count is not excessive. 3706 3707 else 3708 null; 3709 end if; 3710 end; 3711 end if; 3712 end loop; 3713 3714 exit Component_Loop; 3715 3716 -- Case of a subtype mark, identifier or expanded name 3717 3718 elsif Is_Entity_Name (Choice) 3719 and then Is_Type (Entity (Choice)) 3720 then 3721 Lo := Type_Low_Bound (Etype (Choice)); 3722 Hi := Type_High_Bound (Etype (Choice)); 3723 3724 -- Case of subtype indication 3725 3726 elsif Nkind (Choice) = N_Subtype_Indication then 3727 Lo := Low_Bound (Range_Expression (Constraint (Choice))); 3728 Hi := High_Bound (Range_Expression (Constraint (Choice))); 3729 3730 -- Case of a range 3731 3732 elsif Nkind (Choice) = N_Range then 3733 Lo := Low_Bound (Choice); 3734 Hi := High_Bound (Choice); 3735 3736 -- Normal subexpression case 3737 3738 else pragma Assert (Nkind (Choice) in N_Subexpr); 3739 if not Compile_Time_Known_Value (Choice) then 3740 return False; 3741 3742 else 3743 Choice_Index := UI_To_Int (Expr_Value (Choice)); 3744 if Choice_Index in Vals'Range then 3745 Vals (Choice_Index) := 3746 New_Copy_Tree (Expression (Elmt)); 3747 goto Continue; 3748 3749 else 3750 -- Choice is statically out-of-range, will be 3751 -- rewritten to raise Constraint_Error. 3752 3753 return False; 3754 end if; 3755 end if; 3756 end if; 3757 3758 -- Range cases merge with Lo,Hi set 3759 3760 if not Compile_Time_Known_Value (Lo) 3761 or else 3762 not Compile_Time_Known_Value (Hi) 3763 then 3764 return False; 3765 else 3766 for J in UI_To_Int (Expr_Value (Lo)) .. 3767 UI_To_Int (Expr_Value (Hi)) 3768 loop 3769 Vals (J) := New_Copy_Tree (Expression (Elmt)); 3770 end loop; 3771 end if; 3772 3773 <<Continue>> 3774 Next (Choice); 3775 end loop Choice_Loop; 3776 3777 Next (Elmt); 3778 end loop Component_Loop; 3779 3780 -- If we get here the conversion is possible 3781 3782 Vlist := New_List; 3783 for J in Vals'Range loop 3784 Append (Vals (J), Vlist); 3785 end loop; 3786 3787 Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist)); 3788 Set_Aggregate_Bounds (N, Aggregate_Bounds (Original_Node (N))); 3789 return True; 3790 end; 3791 end Flatten; 3792 3793 ------------- 3794 -- Is_Flat -- 3795 ------------- 3796 3797 function Is_Flat (N : Node_Id; Dims : Int) return Boolean is 3798 Elmt : Node_Id; 3799 3800 begin 3801 if Dims = 0 then 3802 return True; 3803 3804 elsif Nkind (N) = N_Aggregate then 3805 if Present (Component_Associations (N)) then 3806 return False; 3807 3808 else 3809 Elmt := First (Expressions (N)); 3810 while Present (Elmt) loop 3811 if not Is_Flat (Elmt, Dims - 1) then 3812 return False; 3813 end if; 3814 3815 Next (Elmt); 3816 end loop; 3817 3818 return True; 3819 end if; 3820 else 3821 return True; 3822 end if; 3823 end Is_Flat; 3824 3825 -- Start of processing for Convert_To_Positional 3826 3827 begin 3828 -- Ada 2005 (AI-287): Do not convert in case of default initialized 3829 -- components because in this case will need to call the corresponding 3830 -- IP procedure. 3831 3832 if Has_Default_Init_Comps (N) then 3833 return; 3834 end if; 3835 3836 if Is_Flat (N, Number_Dimensions (Typ)) then 3837 return; 3838 end if; 3839 3840 if Is_Bit_Packed_Array (Typ) 3841 and then not Handle_Bit_Packed 3842 then 3843 return; 3844 end if; 3845 3846 -- Do not convert to positional if controlled components are involved 3847 -- since these require special processing 3848 3849 if Has_Controlled_Component (Typ) then 3850 return; 3851 end if; 3852 3853 Check_Static_Components; 3854 3855 -- If the size is known, or all the components are static, try to 3856 -- build a fully positional aggregate. 3857 3858 -- The size of the type may not be known for an aggregate with 3859 -- discriminated array components, but if the components are static 3860 -- it is still possible to verify statically that the length is 3861 -- compatible with the upper bound of the type, and therefore it is 3862 -- worth flattening such aggregates as well. 3863 3864 -- For now the back-end expands these aggregates into individual 3865 -- assignments to the target anyway, but it is conceivable that 3866 -- it will eventually be able to treat such aggregates statically??? 3867 3868 if Aggr_Size_OK (N, Typ) 3869 and then Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ))) 3870 then 3871 if Static_Components then 3872 Set_Compile_Time_Known_Aggregate (N); 3873 Set_Expansion_Delayed (N, False); 3874 end if; 3875 3876 Analyze_And_Resolve (N, Typ); 3877 end if; 3878 3879 -- Is Static_Eaboration_Desired has been specified, diagnose aggregates 3880 -- that will still require initialization code. 3881 3882 if (Ekind (Current_Scope) = E_Package 3883 and then Static_Elaboration_Desired (Current_Scope)) 3884 and then Nkind (Parent (N)) = N_Object_Declaration 3885 then 3886 declare 3887 Expr : Node_Id; 3888 3889 begin 3890 if Nkind (N) = N_Aggregate and then Present (Expressions (N)) then 3891 Expr := First (Expressions (N)); 3892 while Present (Expr) loop 3893 if Nkind_In (Expr, N_Integer_Literal, N_Real_Literal) 3894 or else 3895 (Is_Entity_Name (Expr) 3896 and then Ekind (Entity (Expr)) = E_Enumeration_Literal) 3897 then 3898 null; 3899 3900 else 3901 Error_Msg_N 3902 ("non-static object requires elaboration code??", N); 3903 exit; 3904 end if; 3905 3906 Next (Expr); 3907 end loop; 3908 3909 if Present (Component_Associations (N)) then 3910 Error_Msg_N ("object requires elaboration code??", N); 3911 end if; 3912 end if; 3913 end; 3914 end if; 3915 end Convert_To_Positional; 3916 3917 ---------------------------- 3918 -- Expand_Array_Aggregate -- 3919 ---------------------------- 3920 3921 -- Array aggregate expansion proceeds as follows: 3922 3923 -- 1. If requested we generate code to perform all the array aggregate 3924 -- bound checks, specifically 3925 3926 -- (a) Check that the index range defined by aggregate bounds is 3927 -- compatible with corresponding index subtype. 3928 3929 -- (b) If an others choice is present check that no aggregate 3930 -- index is outside the bounds of the index constraint. 3931 3932 -- (c) For multidimensional arrays make sure that all subaggregates 3933 -- corresponding to the same dimension have the same bounds. 3934 3935 -- 2. Check for packed array aggregate which can be converted to a 3936 -- constant so that the aggregate disappears completely. 3937 3938 -- 3. Check case of nested aggregate. Generally nested aggregates are 3939 -- handled during the processing of the parent aggregate. 3940 3941 -- 4. Check if the aggregate can be statically processed. If this is the 3942 -- case pass it as is to Gigi. Note that a necessary condition for 3943 -- static processing is that the aggregate be fully positional. 3944 3945 -- 5. If in place aggregate expansion is possible (i.e. no need to create 3946 -- a temporary) then mark the aggregate as such and return. Otherwise 3947 -- create a new temporary and generate the appropriate initialization 3948 -- code. 3949 3950 procedure Expand_Array_Aggregate (N : Node_Id) is 3951 Loc : constant Source_Ptr := Sloc (N); 3952 3953 Typ : constant Entity_Id := Etype (N); 3954 Ctyp : constant Entity_Id := Component_Type (Typ); 3955 -- Typ is the correct constrained array subtype of the aggregate 3956 -- Ctyp is the corresponding component type. 3957 3958 Aggr_Dimension : constant Pos := Number_Dimensions (Typ); 3959 -- Number of aggregate index dimensions 3960 3961 Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id; 3962 Aggr_High : array (1 .. Aggr_Dimension) of Node_Id; 3963 -- Low and High bounds of the constraint for each aggregate index 3964 3965 Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id; 3966 -- The type of each index 3967 3968 Maybe_In_Place_OK : Boolean; 3969 -- If the type is neither controlled nor packed and the aggregate 3970 -- is the expression in an assignment, assignment in place may be 3971 -- possible, provided other conditions are met on the LHS. 3972 3973 Others_Present : array (1 .. Aggr_Dimension) of Boolean := 3974 (others => False); 3975 -- If Others_Present (J) is True, then there is an others choice 3976 -- in one of the sub-aggregates of N at dimension J. 3977 3978 procedure Build_Constrained_Type (Positional : Boolean); 3979 -- If the subtype is not static or unconstrained, build a constrained 3980 -- type using the computable sizes of the aggregate and its sub- 3981 -- aggregates. 3982 3983 procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id); 3984 -- Checks that the bounds of Aggr_Bounds are within the bounds defined 3985 -- by Index_Bounds. 3986 3987 procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos); 3988 -- Checks that in a multi-dimensional array aggregate all subaggregates 3989 -- corresponding to the same dimension have the same bounds. 3990 -- Sub_Aggr is an array sub-aggregate. Dim is the dimension 3991 -- corresponding to the sub-aggregate. 3992 3993 procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos); 3994 -- Computes the values of array Others_Present. Sub_Aggr is the 3995 -- array sub-aggregate we start the computation from. Dim is the 3996 -- dimension corresponding to the sub-aggregate. 3997 3998 function In_Place_Assign_OK return Boolean; 3999 -- Simple predicate to determine whether an aggregate assignment can 4000 -- be done in place, because none of the new values can depend on the 4001 -- components of the target of the assignment. 4002 4003 procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos); 4004 -- Checks that if an others choice is present in any sub-aggregate no 4005 -- aggregate index is outside the bounds of the index constraint. 4006 -- Sub_Aggr is an array sub-aggregate. Dim is the dimension 4007 -- corresponding to the sub-aggregate. 4008 4009 function Safe_Left_Hand_Side (N : Node_Id) return Boolean; 4010 -- In addition to Maybe_In_Place_OK, in order for an aggregate to be 4011 -- built directly into the target of the assignment it must be free 4012 -- of side-effects. 4013 4014 ---------------------------- 4015 -- Build_Constrained_Type -- 4016 ---------------------------- 4017 4018 procedure Build_Constrained_Type (Positional : Boolean) is 4019 Loc : constant Source_Ptr := Sloc (N); 4020 Agg_Type : constant Entity_Id := Make_Temporary (Loc, 'A'); 4021 Comp : Node_Id; 4022 Decl : Node_Id; 4023 Typ : constant Entity_Id := Etype (N); 4024 Indexes : constant List_Id := New_List; 4025 Num : Int; 4026 Sub_Agg : Node_Id; 4027 4028 begin 4029 -- If the aggregate is purely positional, all its subaggregates 4030 -- have the same size. We collect the dimensions from the first 4031 -- subaggregate at each level. 4032 4033 if Positional then 4034 Sub_Agg := N; 4035 4036 for D in 1 .. Number_Dimensions (Typ) loop 4037 Sub_Agg := First (Expressions (Sub_Agg)); 4038 4039 Comp := Sub_Agg; 4040 Num := 0; 4041 while Present (Comp) loop 4042 Num := Num + 1; 4043 Next (Comp); 4044 end loop; 4045 4046 Append_To (Indexes, 4047 Make_Range (Loc, 4048 Low_Bound => Make_Integer_Literal (Loc, 1), 4049 High_Bound => Make_Integer_Literal (Loc, Num))); 4050 end loop; 4051 4052 else 4053 -- We know the aggregate type is unconstrained and the aggregate 4054 -- is not processable by the back end, therefore not necessarily 4055 -- positional. Retrieve each dimension bounds (computed earlier). 4056 4057 for D in 1 .. Number_Dimensions (Typ) loop 4058 Append ( 4059 Make_Range (Loc, 4060 Low_Bound => Aggr_Low (D), 4061 High_Bound => Aggr_High (D)), 4062 Indexes); 4063 end loop; 4064 end if; 4065 4066 Decl := 4067 Make_Full_Type_Declaration (Loc, 4068 Defining_Identifier => Agg_Type, 4069 Type_Definition => 4070 Make_Constrained_Array_Definition (Loc, 4071 Discrete_Subtype_Definitions => Indexes, 4072 Component_Definition => 4073 Make_Component_Definition (Loc, 4074 Aliased_Present => False, 4075 Subtype_Indication => 4076 New_Occurrence_Of (Component_Type (Typ), Loc)))); 4077 4078 Insert_Action (N, Decl); 4079 Analyze (Decl); 4080 Set_Etype (N, Agg_Type); 4081 Set_Is_Itype (Agg_Type); 4082 Freeze_Itype (Agg_Type, N); 4083 end Build_Constrained_Type; 4084 4085 ------------------ 4086 -- Check_Bounds -- 4087 ------------------ 4088 4089 procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id) is 4090 Aggr_Lo : Node_Id; 4091 Aggr_Hi : Node_Id; 4092 4093 Ind_Lo : Node_Id; 4094 Ind_Hi : Node_Id; 4095 4096 Cond : Node_Id := Empty; 4097 4098 begin 4099 Get_Index_Bounds (Aggr_Bounds, Aggr_Lo, Aggr_Hi); 4100 Get_Index_Bounds (Index_Bounds, Ind_Lo, Ind_Hi); 4101 4102 -- Generate the following test: 4103 -- 4104 -- [constraint_error when 4105 -- Aggr_Lo <= Aggr_Hi and then 4106 -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)] 4107 4108 -- As an optimization try to see if some tests are trivially vacuous 4109 -- because we are comparing an expression against itself. 4110 4111 if Aggr_Lo = Ind_Lo and then Aggr_Hi = Ind_Hi then 4112 Cond := Empty; 4113 4114 elsif Aggr_Hi = Ind_Hi then 4115 Cond := 4116 Make_Op_Lt (Loc, 4117 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), 4118 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo)); 4119 4120 elsif Aggr_Lo = Ind_Lo then 4121 Cond := 4122 Make_Op_Gt (Loc, 4123 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi), 4124 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Hi)); 4125 4126 else 4127 Cond := 4128 Make_Or_Else (Loc, 4129 Left_Opnd => 4130 Make_Op_Lt (Loc, 4131 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), 4132 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo)), 4133 4134 Right_Opnd => 4135 Make_Op_Gt (Loc, 4136 Left_Opnd => Duplicate_Subexpr (Aggr_Hi), 4137 Right_Opnd => Duplicate_Subexpr (Ind_Hi))); 4138 end if; 4139 4140 if Present (Cond) then 4141 Cond := 4142 Make_And_Then (Loc, 4143 Left_Opnd => 4144 Make_Op_Le (Loc, 4145 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), 4146 Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi)), 4147 4148 Right_Opnd => Cond); 4149 4150 Set_Analyzed (Left_Opnd (Left_Opnd (Cond)), False); 4151 Set_Analyzed (Right_Opnd (Left_Opnd (Cond)), False); 4152 Insert_Action (N, 4153 Make_Raise_Constraint_Error (Loc, 4154 Condition => Cond, 4155 Reason => CE_Range_Check_Failed)); 4156 end if; 4157 end Check_Bounds; 4158 4159 ---------------------------- 4160 -- Check_Same_Aggr_Bounds -- 4161 ---------------------------- 4162 4163 procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos) is 4164 Sub_Lo : constant Node_Id := Low_Bound (Aggregate_Bounds (Sub_Aggr)); 4165 Sub_Hi : constant Node_Id := High_Bound (Aggregate_Bounds (Sub_Aggr)); 4166 -- The bounds of this specific sub-aggregate 4167 4168 Aggr_Lo : constant Node_Id := Aggr_Low (Dim); 4169 Aggr_Hi : constant Node_Id := Aggr_High (Dim); 4170 -- The bounds of the aggregate for this dimension 4171 4172 Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim); 4173 -- The index type for this dimension.xxx 4174 4175 Cond : Node_Id := Empty; 4176 Assoc : Node_Id; 4177 Expr : Node_Id; 4178 4179 begin 4180 -- If index checks are on generate the test 4181 4182 -- [constraint_error when 4183 -- Aggr_Lo /= Sub_Lo or else Aggr_Hi /= Sub_Hi] 4184 4185 -- As an optimization try to see if some tests are trivially vacuos 4186 -- because we are comparing an expression against itself. Also for 4187 -- the first dimension the test is trivially vacuous because there 4188 -- is just one aggregate for dimension 1. 4189 4190 if Index_Checks_Suppressed (Ind_Typ) then 4191 Cond := Empty; 4192 4193 elsif Dim = 1 4194 or else (Aggr_Lo = Sub_Lo and then Aggr_Hi = Sub_Hi) 4195 then 4196 Cond := Empty; 4197 4198 elsif Aggr_Hi = Sub_Hi then 4199 Cond := 4200 Make_Op_Ne (Loc, 4201 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), 4202 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo)); 4203 4204 elsif Aggr_Lo = Sub_Lo then 4205 Cond := 4206 Make_Op_Ne (Loc, 4207 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi), 4208 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Hi)); 4209 4210 else 4211 Cond := 4212 Make_Or_Else (Loc, 4213 Left_Opnd => 4214 Make_Op_Ne (Loc, 4215 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), 4216 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo)), 4217 4218 Right_Opnd => 4219 Make_Op_Ne (Loc, 4220 Left_Opnd => Duplicate_Subexpr (Aggr_Hi), 4221 Right_Opnd => Duplicate_Subexpr (Sub_Hi))); 4222 end if; 4223 4224 if Present (Cond) then 4225 Insert_Action (N, 4226 Make_Raise_Constraint_Error (Loc, 4227 Condition => Cond, 4228 Reason => CE_Length_Check_Failed)); 4229 end if; 4230 4231 -- Now look inside the sub-aggregate to see if there is more work 4232 4233 if Dim < Aggr_Dimension then 4234 4235 -- Process positional components 4236 4237 if Present (Expressions (Sub_Aggr)) then 4238 Expr := First (Expressions (Sub_Aggr)); 4239 while Present (Expr) loop 4240 Check_Same_Aggr_Bounds (Expr, Dim + 1); 4241 Next (Expr); 4242 end loop; 4243 end if; 4244 4245 -- Process component associations 4246 4247 if Present (Component_Associations (Sub_Aggr)) then 4248 Assoc := First (Component_Associations (Sub_Aggr)); 4249 while Present (Assoc) loop 4250 Expr := Expression (Assoc); 4251 Check_Same_Aggr_Bounds (Expr, Dim + 1); 4252 Next (Assoc); 4253 end loop; 4254 end if; 4255 end if; 4256 end Check_Same_Aggr_Bounds; 4257 4258 ---------------------------- 4259 -- Compute_Others_Present -- 4260 ---------------------------- 4261 4262 procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos) is 4263 Assoc : Node_Id; 4264 Expr : Node_Id; 4265 4266 begin 4267 if Present (Component_Associations (Sub_Aggr)) then 4268 Assoc := Last (Component_Associations (Sub_Aggr)); 4269 4270 if Nkind (First (Choices (Assoc))) = N_Others_Choice then 4271 Others_Present (Dim) := True; 4272 end if; 4273 end if; 4274 4275 -- Now look inside the sub-aggregate to see if there is more work 4276 4277 if Dim < Aggr_Dimension then 4278 4279 -- Process positional components 4280 4281 if Present (Expressions (Sub_Aggr)) then 4282 Expr := First (Expressions (Sub_Aggr)); 4283 while Present (Expr) loop 4284 Compute_Others_Present (Expr, Dim + 1); 4285 Next (Expr); 4286 end loop; 4287 end if; 4288 4289 -- Process component associations 4290 4291 if Present (Component_Associations (Sub_Aggr)) then 4292 Assoc := First (Component_Associations (Sub_Aggr)); 4293 while Present (Assoc) loop 4294 Expr := Expression (Assoc); 4295 Compute_Others_Present (Expr, Dim + 1); 4296 Next (Assoc); 4297 end loop; 4298 end if; 4299 end if; 4300 end Compute_Others_Present; 4301 4302 ------------------------ 4303 -- In_Place_Assign_OK -- 4304 ------------------------ 4305 4306 function In_Place_Assign_OK return Boolean is 4307 Aggr_In : Node_Id; 4308 Aggr_Lo : Node_Id; 4309 Aggr_Hi : Node_Id; 4310 Obj_In : Node_Id; 4311 Obj_Lo : Node_Id; 4312 Obj_Hi : Node_Id; 4313 4314 function Safe_Aggregate (Aggr : Node_Id) return Boolean; 4315 -- Check recursively that each component of a (sub)aggregate does 4316 -- not depend on the variable being assigned to. 4317 4318 function Safe_Component (Expr : Node_Id) return Boolean; 4319 -- Verify that an expression cannot depend on the variable being 4320 -- assigned to. Room for improvement here (but less than before). 4321 4322 -------------------- 4323 -- Safe_Aggregate -- 4324 -------------------- 4325 4326 function Safe_Aggregate (Aggr : Node_Id) return Boolean is 4327 Expr : Node_Id; 4328 4329 begin 4330 if Present (Expressions (Aggr)) then 4331 Expr := First (Expressions (Aggr)); 4332 while Present (Expr) loop 4333 if Nkind (Expr) = N_Aggregate then 4334 if not Safe_Aggregate (Expr) then 4335 return False; 4336 end if; 4337 4338 elsif not Safe_Component (Expr) then 4339 return False; 4340 end if; 4341 4342 Next (Expr); 4343 end loop; 4344 end if; 4345 4346 if Present (Component_Associations (Aggr)) then 4347 Expr := First (Component_Associations (Aggr)); 4348 while Present (Expr) loop 4349 if Nkind (Expression (Expr)) = N_Aggregate then 4350 if not Safe_Aggregate (Expression (Expr)) then 4351 return False; 4352 end if; 4353 4354 -- If association has a box, no way to determine yet 4355 -- whether default can be assigned in place. 4356 4357 elsif Box_Present (Expr) then 4358 return False; 4359 4360 elsif not Safe_Component (Expression (Expr)) then 4361 return False; 4362 end if; 4363 4364 Next (Expr); 4365 end loop; 4366 end if; 4367 4368 return True; 4369 end Safe_Aggregate; 4370 4371 -------------------- 4372 -- Safe_Component -- 4373 -------------------- 4374 4375 function Safe_Component (Expr : Node_Id) return Boolean is 4376 Comp : Node_Id := Expr; 4377 4378 function Check_Component (Comp : Node_Id) return Boolean; 4379 -- Do the recursive traversal, after copy 4380 4381 --------------------- 4382 -- Check_Component -- 4383 --------------------- 4384 4385 function Check_Component (Comp : Node_Id) return Boolean is 4386 begin 4387 if Is_Overloaded (Comp) then 4388 return False; 4389 end if; 4390 4391 return Compile_Time_Known_Value (Comp) 4392 4393 or else (Is_Entity_Name (Comp) 4394 and then Present (Entity (Comp)) 4395 and then No (Renamed_Object (Entity (Comp)))) 4396 4397 or else (Nkind (Comp) = N_Attribute_Reference 4398 and then Check_Component (Prefix (Comp))) 4399 4400 or else (Nkind (Comp) in N_Binary_Op 4401 and then Check_Component (Left_Opnd (Comp)) 4402 and then Check_Component (Right_Opnd (Comp))) 4403 4404 or else (Nkind (Comp) in N_Unary_Op 4405 and then Check_Component (Right_Opnd (Comp))) 4406 4407 or else (Nkind (Comp) = N_Selected_Component 4408 and then Check_Component (Prefix (Comp))) 4409 4410 or else (Nkind (Comp) = N_Unchecked_Type_Conversion 4411 and then Check_Component (Expression (Comp))); 4412 end Check_Component; 4413 4414 -- Start of processing for Safe_Component 4415 4416 begin 4417 -- If the component appears in an association that may 4418 -- correspond to more than one element, it is not analyzed 4419 -- before the expansion into assignments, to avoid side effects. 4420 -- We analyze, but do not resolve the copy, to obtain sufficient 4421 -- entity information for the checks that follow. If component is 4422 -- overloaded we assume an unsafe function call. 4423 4424 if not Analyzed (Comp) then 4425 if Is_Overloaded (Expr) then 4426 return False; 4427 4428 elsif Nkind (Expr) = N_Aggregate 4429 and then not Is_Others_Aggregate (Expr) 4430 then 4431 return False; 4432 4433 elsif Nkind (Expr) = N_Allocator then 4434 4435 -- For now, too complex to analyze 4436 4437 return False; 4438 end if; 4439 4440 Comp := New_Copy_Tree (Expr); 4441 Set_Parent (Comp, Parent (Expr)); 4442 Analyze (Comp); 4443 end if; 4444 4445 if Nkind (Comp) = N_Aggregate then 4446 return Safe_Aggregate (Comp); 4447 else 4448 return Check_Component (Comp); 4449 end if; 4450 end Safe_Component; 4451 4452 -- Start of processing for In_Place_Assign_OK 4453 4454 begin 4455 if Present (Component_Associations (N)) then 4456 4457 -- On assignment, sliding can take place, so we cannot do the 4458 -- assignment in place unless the bounds of the aggregate are 4459 -- statically equal to those of the target. 4460 4461 -- If the aggregate is given by an others choice, the bounds 4462 -- are derived from the left-hand side, and the assignment is 4463 -- safe if the expression is. 4464 4465 if Is_Others_Aggregate (N) then 4466 return 4467 Safe_Component 4468 (Expression (First (Component_Associations (N)))); 4469 end if; 4470 4471 Aggr_In := First_Index (Etype (N)); 4472 4473 if Nkind (Parent (N)) = N_Assignment_Statement then 4474 Obj_In := First_Index (Etype (Name (Parent (N)))); 4475 4476 else 4477 -- Context is an allocator. Check bounds of aggregate 4478 -- against given type in qualified expression. 4479 4480 pragma Assert (Nkind (Parent (Parent (N))) = N_Allocator); 4481 Obj_In := 4482 First_Index (Etype (Entity (Subtype_Mark (Parent (N))))); 4483 end if; 4484 4485 while Present (Aggr_In) loop 4486 Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi); 4487 Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi); 4488 4489 if not Compile_Time_Known_Value (Aggr_Lo) 4490 or else not Compile_Time_Known_Value (Aggr_Hi) 4491 or else not Compile_Time_Known_Value (Obj_Lo) 4492 or else not Compile_Time_Known_Value (Obj_Hi) 4493 or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo) 4494 or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi) 4495 then 4496 return False; 4497 end if; 4498 4499 Next_Index (Aggr_In); 4500 Next_Index (Obj_In); 4501 end loop; 4502 end if; 4503 4504 -- Now check the component values themselves 4505 4506 return Safe_Aggregate (N); 4507 end In_Place_Assign_OK; 4508 4509 ------------------ 4510 -- Others_Check -- 4511 ------------------ 4512 4513 procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos) is 4514 Aggr_Lo : constant Node_Id := Aggr_Low (Dim); 4515 Aggr_Hi : constant Node_Id := Aggr_High (Dim); 4516 -- The bounds of the aggregate for this dimension 4517 4518 Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim); 4519 -- The index type for this dimension 4520 4521 Need_To_Check : Boolean := False; 4522 4523 Choices_Lo : Node_Id := Empty; 4524 Choices_Hi : Node_Id := Empty; 4525 -- The lowest and highest discrete choices for a named sub-aggregate 4526 4527 Nb_Choices : Int := -1; 4528 -- The number of discrete non-others choices in this sub-aggregate 4529 4530 Nb_Elements : Uint := Uint_0; 4531 -- The number of elements in a positional aggregate 4532 4533 Cond : Node_Id := Empty; 4534 4535 Assoc : Node_Id; 4536 Choice : Node_Id; 4537 Expr : Node_Id; 4538 4539 begin 4540 -- Check if we have an others choice. If we do make sure that this 4541 -- sub-aggregate contains at least one element in addition to the 4542 -- others choice. 4543 4544 if Range_Checks_Suppressed (Ind_Typ) then 4545 Need_To_Check := False; 4546 4547 elsif Present (Expressions (Sub_Aggr)) 4548 and then Present (Component_Associations (Sub_Aggr)) 4549 then 4550 Need_To_Check := True; 4551 4552 elsif Present (Component_Associations (Sub_Aggr)) then 4553 Assoc := Last (Component_Associations (Sub_Aggr)); 4554 4555 if Nkind (First (Choices (Assoc))) /= N_Others_Choice then 4556 Need_To_Check := False; 4557 4558 else 4559 -- Count the number of discrete choices. Start with -1 because 4560 -- the others choice does not count. 4561 4562 Nb_Choices := -1; 4563 Assoc := First (Component_Associations (Sub_Aggr)); 4564 while Present (Assoc) loop 4565 Choice := First (Choices (Assoc)); 4566 while Present (Choice) loop 4567 Nb_Choices := Nb_Choices + 1; 4568 Next (Choice); 4569 end loop; 4570 4571 Next (Assoc); 4572 end loop; 4573 4574 -- If there is only an others choice nothing to do 4575 4576 Need_To_Check := (Nb_Choices > 0); 4577 end if; 4578 4579 else 4580 Need_To_Check := False; 4581 end if; 4582 4583 -- If we are dealing with a positional sub-aggregate with an others 4584 -- choice then compute the number or positional elements. 4585 4586 if Need_To_Check and then Present (Expressions (Sub_Aggr)) then 4587 Expr := First (Expressions (Sub_Aggr)); 4588 Nb_Elements := Uint_0; 4589 while Present (Expr) loop 4590 Nb_Elements := Nb_Elements + 1; 4591 Next (Expr); 4592 end loop; 4593 4594 -- If the aggregate contains discrete choices and an others choice 4595 -- compute the smallest and largest discrete choice values. 4596 4597 elsif Need_To_Check then 4598 Compute_Choices_Lo_And_Choices_Hi : declare 4599 4600 Table : Case_Table_Type (1 .. Nb_Choices); 4601 -- Used to sort all the different choice values 4602 4603 J : Pos := 1; 4604 Low : Node_Id; 4605 High : Node_Id; 4606 4607 begin 4608 Assoc := First (Component_Associations (Sub_Aggr)); 4609 while Present (Assoc) loop 4610 Choice := First (Choices (Assoc)); 4611 while Present (Choice) loop 4612 if Nkind (Choice) = N_Others_Choice then 4613 exit; 4614 end if; 4615 4616 Get_Index_Bounds (Choice, Low, High); 4617 Table (J).Choice_Lo := Low; 4618 Table (J).Choice_Hi := High; 4619 4620 J := J + 1; 4621 Next (Choice); 4622 end loop; 4623 4624 Next (Assoc); 4625 end loop; 4626 4627 -- Sort the discrete choices 4628 4629 Sort_Case_Table (Table); 4630 4631 Choices_Lo := Table (1).Choice_Lo; 4632 Choices_Hi := Table (Nb_Choices).Choice_Hi; 4633 end Compute_Choices_Lo_And_Choices_Hi; 4634 end if; 4635 4636 -- If no others choice in this sub-aggregate, or the aggregate 4637 -- comprises only an others choice, nothing to do. 4638 4639 if not Need_To_Check then 4640 Cond := Empty; 4641 4642 -- If we are dealing with an aggregate containing an others choice 4643 -- and positional components, we generate the following test: 4644 4645 -- if Ind_Typ'Pos (Aggr_Lo) + (Nb_Elements - 1) > 4646 -- Ind_Typ'Pos (Aggr_Hi) 4647 -- then 4648 -- raise Constraint_Error; 4649 -- end if; 4650 4651 elsif Nb_Elements > Uint_0 then 4652 Cond := 4653 Make_Op_Gt (Loc, 4654 Left_Opnd => 4655 Make_Op_Add (Loc, 4656 Left_Opnd => 4657 Make_Attribute_Reference (Loc, 4658 Prefix => New_Occurrence_Of (Ind_Typ, Loc), 4659 Attribute_Name => Name_Pos, 4660 Expressions => 4661 New_List 4662 (Duplicate_Subexpr_Move_Checks (Aggr_Lo))), 4663 Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)), 4664 4665 Right_Opnd => 4666 Make_Attribute_Reference (Loc, 4667 Prefix => New_Occurrence_Of (Ind_Typ, Loc), 4668 Attribute_Name => Name_Pos, 4669 Expressions => New_List ( 4670 Duplicate_Subexpr_Move_Checks (Aggr_Hi)))); 4671 4672 -- If we are dealing with an aggregate containing an others choice 4673 -- and discrete choices we generate the following test: 4674 4675 -- [constraint_error when 4676 -- Choices_Lo < Aggr_Lo or else Choices_Hi > Aggr_Hi]; 4677 4678 else 4679 Cond := 4680 Make_Or_Else (Loc, 4681 Left_Opnd => 4682 Make_Op_Lt (Loc, 4683 Left_Opnd => 4684 Duplicate_Subexpr_Move_Checks (Choices_Lo), 4685 Right_Opnd => 4686 Duplicate_Subexpr_Move_Checks (Aggr_Lo)), 4687 4688 Right_Opnd => 4689 Make_Op_Gt (Loc, 4690 Left_Opnd => 4691 Duplicate_Subexpr (Choices_Hi), 4692 Right_Opnd => 4693 Duplicate_Subexpr (Aggr_Hi))); 4694 end if; 4695 4696 if Present (Cond) then 4697 Insert_Action (N, 4698 Make_Raise_Constraint_Error (Loc, 4699 Condition => Cond, 4700 Reason => CE_Length_Check_Failed)); 4701 -- Questionable reason code, shouldn't that be a 4702 -- CE_Range_Check_Failed ??? 4703 end if; 4704 4705 -- Now look inside the sub-aggregate to see if there is more work 4706 4707 if Dim < Aggr_Dimension then 4708 4709 -- Process positional components 4710 4711 if Present (Expressions (Sub_Aggr)) then 4712 Expr := First (Expressions (Sub_Aggr)); 4713 while Present (Expr) loop 4714 Others_Check (Expr, Dim + 1); 4715 Next (Expr); 4716 end loop; 4717 end if; 4718 4719 -- Process component associations 4720 4721 if Present (Component_Associations (Sub_Aggr)) then 4722 Assoc := First (Component_Associations (Sub_Aggr)); 4723 while Present (Assoc) loop 4724 Expr := Expression (Assoc); 4725 Others_Check (Expr, Dim + 1); 4726 Next (Assoc); 4727 end loop; 4728 end if; 4729 end if; 4730 end Others_Check; 4731 4732 ------------------------- 4733 -- Safe_Left_Hand_Side -- 4734 ------------------------- 4735 4736 function Safe_Left_Hand_Side (N : Node_Id) return Boolean is 4737 function Is_Safe_Index (Indx : Node_Id) return Boolean; 4738 -- If the left-hand side includes an indexed component, check that 4739 -- the indexes are free of side-effect. 4740 4741 ------------------- 4742 -- Is_Safe_Index -- 4743 ------------------- 4744 4745 function Is_Safe_Index (Indx : Node_Id) return Boolean is 4746 begin 4747 if Is_Entity_Name (Indx) then 4748 return True; 4749 4750 elsif Nkind (Indx) = N_Integer_Literal then 4751 return True; 4752 4753 elsif Nkind (Indx) = N_Function_Call 4754 and then Is_Entity_Name (Name (Indx)) 4755 and then 4756 Has_Pragma_Pure_Function (Entity (Name (Indx))) 4757 then 4758 return True; 4759 4760 elsif Nkind (Indx) = N_Type_Conversion 4761 and then Is_Safe_Index (Expression (Indx)) 4762 then 4763 return True; 4764 4765 else 4766 return False; 4767 end if; 4768 end Is_Safe_Index; 4769 4770 -- Start of processing for Safe_Left_Hand_Side 4771 4772 begin 4773 if Is_Entity_Name (N) then 4774 return True; 4775 4776 elsif Nkind_In (N, N_Explicit_Dereference, N_Selected_Component) 4777 and then Safe_Left_Hand_Side (Prefix (N)) 4778 then 4779 return True; 4780 4781 elsif Nkind (N) = N_Indexed_Component 4782 and then Safe_Left_Hand_Side (Prefix (N)) 4783 and then 4784 Is_Safe_Index (First (Expressions (N))) 4785 then 4786 return True; 4787 4788 elsif Nkind (N) = N_Unchecked_Type_Conversion then 4789 return Safe_Left_Hand_Side (Expression (N)); 4790 4791 else 4792 return False; 4793 end if; 4794 end Safe_Left_Hand_Side; 4795 4796 -- Local variables 4797 4798 Tmp : Entity_Id; 4799 -- Holds the temporary aggregate value 4800 4801 Tmp_Decl : Node_Id; 4802 -- Holds the declaration of Tmp 4803 4804 Aggr_Code : List_Id; 4805 Parent_Node : Node_Id; 4806 Parent_Kind : Node_Kind; 4807 4808 -- Start of processing for Expand_Array_Aggregate 4809 4810 begin 4811 -- Do not touch the special aggregates of attributes used for Asm calls 4812 4813 if Is_RTE (Ctyp, RE_Asm_Input_Operand) 4814 or else Is_RTE (Ctyp, RE_Asm_Output_Operand) 4815 then 4816 return; 4817 4818 -- Do not expand an aggregate for an array type which contains tasks if 4819 -- the aggregate is associated with an unexpanded return statement of a 4820 -- build-in-place function. The aggregate is expanded when the related 4821 -- return statement (rewritten into an extended return) is processed. 4822 -- This delay ensures that any temporaries and initialization code 4823 -- generated for the aggregate appear in the proper return block and 4824 -- use the correct _chain and _master. 4825 4826 elsif Has_Task (Base_Type (Etype (N))) 4827 and then Nkind (Parent (N)) = N_Simple_Return_Statement 4828 and then Is_Build_In_Place_Function 4829 (Return_Applies_To (Return_Statement_Entity (Parent (N)))) 4830 then 4831 return; 4832 end if; 4833 4834 -- If the semantic analyzer has determined that aggregate N will raise 4835 -- Constraint_Error at run time, then the aggregate node has been 4836 -- replaced with an N_Raise_Constraint_Error node and we should 4837 -- never get here. 4838 4839 pragma Assert (not Raises_Constraint_Error (N)); 4840 4841 -- STEP 1a 4842 4843 -- Check that the index range defined by aggregate bounds is 4844 -- compatible with corresponding index subtype. 4845 4846 Index_Compatibility_Check : declare 4847 Aggr_Index_Range : Node_Id := First_Index (Typ); 4848 -- The current aggregate index range 4849 4850 Index_Constraint : Node_Id := First_Index (Etype (Typ)); 4851 -- The corresponding index constraint against which we have to 4852 -- check the above aggregate index range. 4853 4854 begin 4855 Compute_Others_Present (N, 1); 4856 4857 for J in 1 .. Aggr_Dimension loop 4858 -- There is no need to emit a check if an others choice is 4859 -- present for this array aggregate dimension since in this 4860 -- case one of N's sub-aggregates has taken its bounds from the 4861 -- context and these bounds must have been checked already. In 4862 -- addition all sub-aggregates corresponding to the same 4863 -- dimension must all have the same bounds (checked in (c) below). 4864 4865 if not Range_Checks_Suppressed (Etype (Index_Constraint)) 4866 and then not Others_Present (J) 4867 then 4868 -- We don't use Checks.Apply_Range_Check here because it emits 4869 -- a spurious check. Namely it checks that the range defined by 4870 -- the aggregate bounds is non empty. But we know this already 4871 -- if we get here. 4872 4873 Check_Bounds (Aggr_Index_Range, Index_Constraint); 4874 end if; 4875 4876 -- Save the low and high bounds of the aggregate index as well as 4877 -- the index type for later use in checks (b) and (c) below. 4878 4879 Aggr_Low (J) := Low_Bound (Aggr_Index_Range); 4880 Aggr_High (J) := High_Bound (Aggr_Index_Range); 4881 4882 Aggr_Index_Typ (J) := Etype (Index_Constraint); 4883 4884 Next_Index (Aggr_Index_Range); 4885 Next_Index (Index_Constraint); 4886 end loop; 4887 end Index_Compatibility_Check; 4888 4889 -- STEP 1b 4890 4891 -- If an others choice is present check that no aggregate index is 4892 -- outside the bounds of the index constraint. 4893 4894 Others_Check (N, 1); 4895 4896 -- STEP 1c 4897 4898 -- For multidimensional arrays make sure that all subaggregates 4899 -- corresponding to the same dimension have the same bounds. 4900 4901 if Aggr_Dimension > 1 then 4902 Check_Same_Aggr_Bounds (N, 1); 4903 end if; 4904 4905 -- STEP 1d 4906 4907 -- If we have a default component value, or simple initialization is 4908 -- required for the component type, then we replace <> in component 4909 -- associations by the required default value. 4910 4911 declare 4912 Default_Val : Node_Id; 4913 Assoc : Node_Id; 4914 4915 begin 4916 if (Present (Default_Aspect_Component_Value (Typ)) 4917 or else Needs_Simple_Initialization (Ctyp)) 4918 and then Present (Component_Associations (N)) 4919 then 4920 Assoc := First (Component_Associations (N)); 4921 while Present (Assoc) loop 4922 if Nkind (Assoc) = N_Component_Association 4923 and then Box_Present (Assoc) 4924 then 4925 Set_Box_Present (Assoc, False); 4926 4927 if Present (Default_Aspect_Component_Value (Typ)) then 4928 Default_Val := Default_Aspect_Component_Value (Typ); 4929 else 4930 Default_Val := Get_Simple_Init_Val (Ctyp, N); 4931 end if; 4932 4933 Set_Expression (Assoc, New_Copy_Tree (Default_Val)); 4934 Analyze_And_Resolve (Expression (Assoc), Ctyp); 4935 end if; 4936 4937 Next (Assoc); 4938 end loop; 4939 end if; 4940 end; 4941 4942 -- STEP 2 4943 4944 -- Here we test for is packed array aggregate that we can handle at 4945 -- compile time. If so, return with transformation done. Note that we do 4946 -- this even if the aggregate is nested, because once we have done this 4947 -- processing, there is no more nested aggregate. 4948 4949 if Packed_Array_Aggregate_Handled (N) then 4950 return; 4951 end if; 4952 4953 -- At this point we try to convert to positional form 4954 4955 if Ekind (Current_Scope) = E_Package 4956 and then Static_Elaboration_Desired (Current_Scope) 4957 then 4958 Convert_To_Positional (N, Max_Others_Replicate => 100); 4959 else 4960 Convert_To_Positional (N); 4961 end if; 4962 4963 -- if the result is no longer an aggregate (e.g. it may be a string 4964 -- literal, or a temporary which has the needed value), then we are 4965 -- done, since there is no longer a nested aggregate. 4966 4967 if Nkind (N) /= N_Aggregate then 4968 return; 4969 4970 -- We are also done if the result is an analyzed aggregate, indicating 4971 -- that Convert_To_Positional succeeded and reanalyzed the rewritten 4972 -- aggregate. 4973 4974 elsif Analyzed (N) 4975 and then N /= Original_Node (N) 4976 then 4977 return; 4978 end if; 4979 4980 -- If all aggregate components are compile-time known and the aggregate 4981 -- has been flattened, nothing left to do. The same occurs if the 4982 -- aggregate is used to initialize the components of a statically 4983 -- allocated dispatch table. 4984 4985 if Compile_Time_Known_Aggregate (N) 4986 or else Is_Static_Dispatch_Table_Aggregate (N) 4987 then 4988 Set_Expansion_Delayed (N, False); 4989 return; 4990 end if; 4991 4992 -- Now see if back end processing is possible 4993 4994 if Backend_Processing_Possible (N) then 4995 4996 -- If the aggregate is static but the constraints are not, build 4997 -- a static subtype for the aggregate, so that Gigi can place it 4998 -- in static memory. Perform an unchecked_conversion to the non- 4999 -- static type imposed by the context. 5000 5001 declare 5002 Itype : constant Entity_Id := Etype (N); 5003 Index : Node_Id; 5004 Needs_Type : Boolean := False; 5005 5006 begin 5007 Index := First_Index (Itype); 5008 while Present (Index) loop 5009 if not Is_Static_Subtype (Etype (Index)) then 5010 Needs_Type := True; 5011 exit; 5012 else 5013 Next_Index (Index); 5014 end if; 5015 end loop; 5016 5017 if Needs_Type then 5018 Build_Constrained_Type (Positional => True); 5019 Rewrite (N, Unchecked_Convert_To (Itype, N)); 5020 Analyze (N); 5021 end if; 5022 end; 5023 5024 return; 5025 end if; 5026 5027 -- STEP 3 5028 5029 -- Delay expansion for nested aggregates: it will be taken care of 5030 -- when the parent aggregate is expanded. 5031 5032 Parent_Node := Parent (N); 5033 Parent_Kind := Nkind (Parent_Node); 5034 5035 if Parent_Kind = N_Qualified_Expression then 5036 Parent_Node := Parent (Parent_Node); 5037 Parent_Kind := Nkind (Parent_Node); 5038 end if; 5039 5040 if Parent_Kind = N_Aggregate 5041 or else Parent_Kind = N_Extension_Aggregate 5042 or else Parent_Kind = N_Component_Association 5043 or else (Parent_Kind = N_Object_Declaration 5044 and then Needs_Finalization (Typ)) 5045 or else (Parent_Kind = N_Assignment_Statement 5046 and then Inside_Init_Proc) 5047 then 5048 if Static_Array_Aggregate (N) 5049 or else Compile_Time_Known_Aggregate (N) 5050 then 5051 Set_Expansion_Delayed (N, False); 5052 return; 5053 else 5054 Set_Expansion_Delayed (N); 5055 return; 5056 end if; 5057 end if; 5058 5059 -- STEP 4 5060 5061 -- Look if in place aggregate expansion is possible 5062 5063 -- For object declarations we build the aggregate in place, unless 5064 -- the array is bit-packed or the component is controlled. 5065 5066 -- For assignments we do the assignment in place if all the component 5067 -- associations have compile-time known values. For other cases we 5068 -- create a temporary. The analysis for safety of on-line assignment 5069 -- is delicate, i.e. we don't know how to do it fully yet ??? 5070 5071 -- For allocators we assign to the designated object in place if the 5072 -- aggregate meets the same conditions as other in-place assignments. 5073 -- In this case the aggregate may not come from source but was created 5074 -- for default initialization, e.g. with Initialize_Scalars. 5075 5076 if Requires_Transient_Scope (Typ) then 5077 Establish_Transient_Scope 5078 (N, Sec_Stack => Has_Controlled_Component (Typ)); 5079 end if; 5080 5081 if Has_Default_Init_Comps (N) then 5082 Maybe_In_Place_OK := False; 5083 5084 elsif Is_Bit_Packed_Array (Typ) 5085 or else Has_Controlled_Component (Typ) 5086 then 5087 Maybe_In_Place_OK := False; 5088 5089 else 5090 Maybe_In_Place_OK := 5091 (Nkind (Parent (N)) = N_Assignment_Statement 5092 and then Comes_From_Source (N) 5093 and then In_Place_Assign_OK) 5094 5095 or else 5096 (Nkind (Parent (Parent (N))) = N_Allocator 5097 and then In_Place_Assign_OK); 5098 end if; 5099 5100 -- If this is an array of tasks, it will be expanded into build-in-place 5101 -- assignments. Build an activation chain for the tasks now. 5102 5103 if Has_Task (Etype (N)) then 5104 Build_Activation_Chain_Entity (N); 5105 end if; 5106 5107 -- Perform in-place expansion of aggregate in an object declaration. 5108 -- Note: actions generated for the aggregate will be captured in an 5109 -- expression-with-actions statement so that they can be transferred 5110 -- to freeze actions later if there is an address clause for the 5111 -- object. (Note: we don't use a block statement because this would 5112 -- cause generated freeze nodes to be elaborated in the wrong scope). 5113 5114 -- Should document these individual tests ??? 5115 5116 if not Has_Default_Init_Comps (N) 5117 and then Comes_From_Source (Parent_Node) 5118 and then Parent_Kind = N_Object_Declaration 5119 and then not 5120 Must_Slide (Etype (Defining_Identifier (Parent_Node)), Typ) 5121 and then N = Expression (Parent_Node) 5122 and then not Is_Bit_Packed_Array (Typ) 5123 and then not Has_Controlled_Component (Typ) 5124 then 5125 Tmp := Defining_Identifier (Parent (N)); 5126 Set_No_Initialization (Parent (N)); 5127 Set_Expression (Parent (N), Empty); 5128 5129 -- Set the type of the entity, for use in the analysis of the 5130 -- subsequent indexed assignments. If the nominal type is not 5131 -- constrained, build a subtype from the known bounds of the 5132 -- aggregate. If the declaration has a subtype mark, use it, 5133 -- otherwise use the itype of the aggregate. 5134 5135 if not Is_Constrained (Typ) then 5136 Build_Constrained_Type (Positional => False); 5137 elsif Is_Entity_Name (Object_Definition (Parent (N))) 5138 and then Is_Constrained (Entity (Object_Definition (Parent (N)))) 5139 then 5140 Set_Etype (Tmp, Entity (Object_Definition (Parent (N)))); 5141 else 5142 Set_Size_Known_At_Compile_Time (Typ, False); 5143 Set_Etype (Tmp, Typ); 5144 end if; 5145 5146 elsif Maybe_In_Place_OK 5147 and then Nkind (Parent (N)) = N_Qualified_Expression 5148 and then Nkind (Parent (Parent (N))) = N_Allocator 5149 then 5150 Set_Expansion_Delayed (N); 5151 return; 5152 5153 -- In the remaining cases the aggregate is the RHS of an assignment 5154 5155 elsif Maybe_In_Place_OK 5156 and then Safe_Left_Hand_Side (Name (Parent (N))) 5157 then 5158 Tmp := Name (Parent (N)); 5159 5160 if Etype (Tmp) /= Etype (N) then 5161 Apply_Length_Check (N, Etype (Tmp)); 5162 5163 if Nkind (N) = N_Raise_Constraint_Error then 5164 5165 -- Static error, nothing further to expand 5166 5167 return; 5168 end if; 5169 end if; 5170 5171 elsif Maybe_In_Place_OK 5172 and then Nkind (Name (Parent (N))) = N_Slice 5173 and then Safe_Slice_Assignment (N) 5174 then 5175 -- Safe_Slice_Assignment rewrites assignment as a loop 5176 5177 return; 5178 5179 -- Step 5 5180 5181 -- In place aggregate expansion is not possible 5182 5183 else 5184 Maybe_In_Place_OK := False; 5185 Tmp := Make_Temporary (Loc, 'A', N); 5186 Tmp_Decl := 5187 Make_Object_Declaration 5188 (Loc, 5189 Defining_Identifier => Tmp, 5190 Object_Definition => New_Occurrence_Of (Typ, Loc)); 5191 Set_No_Initialization (Tmp_Decl, True); 5192 5193 -- If we are within a loop, the temporary will be pushed on the 5194 -- stack at each iteration. If the aggregate is the expression for an 5195 -- allocator, it will be immediately copied to the heap and can 5196 -- be reclaimed at once. We create a transient scope around the 5197 -- aggregate for this purpose. 5198 5199 if Ekind (Current_Scope) = E_Loop 5200 and then Nkind (Parent (Parent (N))) = N_Allocator 5201 then 5202 Establish_Transient_Scope (N, False); 5203 end if; 5204 5205 Insert_Action (N, Tmp_Decl); 5206 end if; 5207 5208 -- Construct and insert the aggregate code. We can safely suppress index 5209 -- checks because this code is guaranteed not to raise CE on index 5210 -- checks. However we should *not* suppress all checks. 5211 5212 declare 5213 Target : Node_Id; 5214 5215 begin 5216 if Nkind (Tmp) = N_Defining_Identifier then 5217 Target := New_Occurrence_Of (Tmp, Loc); 5218 5219 else 5220 5221 if Has_Default_Init_Comps (N) then 5222 5223 -- Ada 2005 (AI-287): This case has not been analyzed??? 5224 5225 raise Program_Error; 5226 end if; 5227 5228 -- Name in assignment is explicit dereference 5229 5230 Target := New_Copy (Tmp); 5231 end if; 5232 5233 Aggr_Code := 5234 Build_Array_Aggr_Code (N, 5235 Ctype => Ctyp, 5236 Index => First_Index (Typ), 5237 Into => Target, 5238 Scalar_Comp => Is_Scalar_Type (Ctyp)); 5239 end; 5240 5241 if Comes_From_Source (Tmp) then 5242 declare 5243 Node_After : constant Node_Id := Next (Parent_Node); 5244 5245 begin 5246 Insert_Actions_After (Parent_Node, Aggr_Code); 5247 5248 if Parent_Kind = N_Object_Declaration then 5249 Collect_Initialization_Statements 5250 (Obj => Tmp, N => Parent_Node, Node_After => Node_After); 5251 end if; 5252 end; 5253 5254 else 5255 Insert_Actions (N, Aggr_Code); 5256 end if; 5257 5258 -- If the aggregate has been assigned in place, remove the original 5259 -- assignment. 5260 5261 if Nkind (Parent (N)) = N_Assignment_Statement 5262 and then Maybe_In_Place_OK 5263 then 5264 Rewrite (Parent (N), Make_Null_Statement (Loc)); 5265 5266 elsif Nkind (Parent (N)) /= N_Object_Declaration 5267 or else Tmp /= Defining_Identifier (Parent (N)) 5268 then 5269 Rewrite (N, New_Occurrence_Of (Tmp, Loc)); 5270 Analyze_And_Resolve (N, Typ); 5271 end if; 5272 end Expand_Array_Aggregate; 5273 5274 ------------------------ 5275 -- Expand_N_Aggregate -- 5276 ------------------------ 5277 5278 procedure Expand_N_Aggregate (N : Node_Id) is 5279 begin 5280 -- Record aggregate case 5281 5282 if Is_Record_Type (Etype (N)) then 5283 Expand_Record_Aggregate (N); 5284 5285 -- Array aggregate case 5286 5287 else 5288 -- A special case, if we have a string subtype with bounds 1 .. N, 5289 -- where N is known at compile time, and the aggregate is of the 5290 -- form (others => 'x'), with a single choice and no expressions, 5291 -- and N is less than 80 (an arbitrary limit for now), then replace 5292 -- the aggregate by the equivalent string literal (but do not mark 5293 -- it as static since it is not). 5294 5295 -- Note: this entire circuit is redundant with respect to code in 5296 -- Expand_Array_Aggregate that collapses others choices to positional 5297 -- form, but there are two problems with that circuit: 5298 5299 -- a) It is limited to very small cases due to ill-understood 5300 -- interactions with bootstrapping. That limit is removed by 5301 -- use of the No_Implicit_Loops restriction. 5302 5303 -- b) It erroneously ends up with the resulting expressions being 5304 -- considered static when they are not. For example, the 5305 -- following test should fail: 5306 5307 -- pragma Restrictions (No_Implicit_Loops); 5308 -- package NonSOthers4 is 5309 -- B : constant String (1 .. 6) := (others => 'A'); 5310 -- DH : constant String (1 .. 8) := B & "BB"; 5311 -- X : Integer; 5312 -- pragma Export (C, X, Link_Name => DH); 5313 -- end; 5314 5315 -- But it succeeds (DH looks static to pragma Export) 5316 5317 -- To be sorted out ??? 5318 5319 if Present (Component_Associations (N)) then 5320 declare 5321 CA : constant Node_Id := First (Component_Associations (N)); 5322 MX : constant := 80; 5323 5324 begin 5325 if Nkind (First (Choices (CA))) = N_Others_Choice 5326 and then Nkind (Expression (CA)) = N_Character_Literal 5327 and then No (Expressions (N)) 5328 then 5329 declare 5330 T : constant Entity_Id := Etype (N); 5331 X : constant Node_Id := First_Index (T); 5332 EC : constant Node_Id := Expression (CA); 5333 CV : constant Uint := Char_Literal_Value (EC); 5334 CC : constant Int := UI_To_Int (CV); 5335 5336 begin 5337 if Nkind (X) = N_Range 5338 and then Compile_Time_Known_Value (Low_Bound (X)) 5339 and then Expr_Value (Low_Bound (X)) = 1 5340 and then Compile_Time_Known_Value (High_Bound (X)) 5341 then 5342 declare 5343 Hi : constant Uint := Expr_Value (High_Bound (X)); 5344 5345 begin 5346 if Hi <= MX then 5347 Start_String; 5348 5349 for J in 1 .. UI_To_Int (Hi) loop 5350 Store_String_Char (Char_Code (CC)); 5351 end loop; 5352 5353 Rewrite (N, 5354 Make_String_Literal (Sloc (N), 5355 Strval => End_String)); 5356 5357 if CC >= Int (2 ** 16) then 5358 Set_Has_Wide_Wide_Character (N); 5359 elsif CC >= Int (2 ** 8) then 5360 Set_Has_Wide_Character (N); 5361 end if; 5362 5363 Analyze_And_Resolve (N, T); 5364 Set_Is_Static_Expression (N, False); 5365 return; 5366 end if; 5367 end; 5368 end if; 5369 end; 5370 end if; 5371 end; 5372 end if; 5373 5374 -- Not that special case, so normal expansion of array aggregate 5375 5376 Expand_Array_Aggregate (N); 5377 end if; 5378 exception 5379 when RE_Not_Available => 5380 return; 5381 end Expand_N_Aggregate; 5382 5383 ---------------------------------- 5384 -- Expand_N_Extension_Aggregate -- 5385 ---------------------------------- 5386 5387 -- If the ancestor part is an expression, add a component association for 5388 -- the parent field. If the type of the ancestor part is not the direct 5389 -- parent of the expected type, build recursively the needed ancestors. 5390 -- If the ancestor part is a subtype_mark, replace aggregate with a decla- 5391 -- ration for a temporary of the expected type, followed by individual 5392 -- assignments to the given components. 5393 5394 procedure Expand_N_Extension_Aggregate (N : Node_Id) is 5395 Loc : constant Source_Ptr := Sloc (N); 5396 A : constant Node_Id := Ancestor_Part (N); 5397 Typ : constant Entity_Id := Etype (N); 5398 5399 begin 5400 -- If the ancestor is a subtype mark, an init proc must be called 5401 -- on the resulting object which thus has to be materialized in 5402 -- the front-end 5403 5404 if Is_Entity_Name (A) and then Is_Type (Entity (A)) then 5405 Convert_To_Assignments (N, Typ); 5406 5407 -- The extension aggregate is transformed into a record aggregate 5408 -- of the following form (c1 and c2 are inherited components) 5409 5410 -- (Exp with c3 => a, c4 => b) 5411 -- ==> (c1 => Exp.c1, c2 => Exp.c2, c3 => a, c4 => b) 5412 5413 else 5414 Set_Etype (N, Typ); 5415 5416 if Tagged_Type_Expansion then 5417 Expand_Record_Aggregate (N, 5418 Orig_Tag => 5419 New_Occurrence_Of 5420 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc), 5421 Parent_Expr => A); 5422 5423 -- No tag is needed in the case of a VM 5424 5425 else 5426 Expand_Record_Aggregate (N, Parent_Expr => A); 5427 end if; 5428 end if; 5429 5430 exception 5431 when RE_Not_Available => 5432 return; 5433 end Expand_N_Extension_Aggregate; 5434 5435 ----------------------------- 5436 -- Expand_Record_Aggregate -- 5437 ----------------------------- 5438 5439 procedure Expand_Record_Aggregate 5440 (N : Node_Id; 5441 Orig_Tag : Node_Id := Empty; 5442 Parent_Expr : Node_Id := Empty) 5443 is 5444 Loc : constant Source_Ptr := Sloc (N); 5445 Comps : constant List_Id := Component_Associations (N); 5446 Typ : constant Entity_Id := Etype (N); 5447 Base_Typ : constant Entity_Id := Base_Type (Typ); 5448 5449 Static_Components : Boolean := True; 5450 -- Flag to indicate whether all components are compile-time known, 5451 -- and the aggregate can be constructed statically and handled by 5452 -- the back-end. 5453 5454 function Compile_Time_Known_Composite_Value (N : Node_Id) return Boolean; 5455 -- Returns true if N is an expression of composite type which can be 5456 -- fully evaluated at compile time without raising constraint error. 5457 -- Such expressions can be passed as is to Gigi without any expansion. 5458 -- 5459 -- This returns true for N_Aggregate with Compile_Time_Known_Aggregate 5460 -- set and constants whose expression is such an aggregate, recursively. 5461 5462 function Component_Not_OK_For_Backend return Boolean; 5463 -- Check for presence of a component which makes it impossible for the 5464 -- backend to process the aggregate, thus requiring the use of a series 5465 -- of assignment statements. Cases checked for are a nested aggregate 5466 -- needing Late_Expansion, the presence of a tagged component which may 5467 -- need tag adjustment, and a bit unaligned component reference. 5468 -- 5469 -- We also force expansion into assignments if a component is of a 5470 -- mutable type (including a private type with discriminants) because 5471 -- in that case the size of the component to be copied may be smaller 5472 -- than the side of the target, and there is no simple way for gigi 5473 -- to compute the size of the object to be copied. 5474 -- 5475 -- NOTE: This is part of the ongoing work to define precisely the 5476 -- interface between front-end and back-end handling of aggregates. 5477 -- In general it is desirable to pass aggregates as they are to gigi, 5478 -- in order to minimize elaboration code. This is one case where the 5479 -- semantics of Ada complicate the analysis and lead to anomalies in 5480 -- the gcc back-end if the aggregate is not expanded into assignments. 5481 5482 function Has_Visible_Private_Ancestor (Id : E) return Boolean; 5483 -- If any ancestor of the current type is private, the aggregate 5484 -- cannot be built in place. We cannot rely on Has_Private_Ancestor, 5485 -- because it will not be set when type and its parent are in the 5486 -- same scope, and the parent component needs expansion. 5487 5488 function Top_Level_Aggregate (N : Node_Id) return Node_Id; 5489 -- For nested aggregates return the ultimate enclosing aggregate; for 5490 -- non-nested aggregates return N. 5491 5492 ---------------------------------------- 5493 -- Compile_Time_Known_Composite_Value -- 5494 ---------------------------------------- 5495 5496 function Compile_Time_Known_Composite_Value 5497 (N : Node_Id) return Boolean 5498 is 5499 begin 5500 -- If we have an entity name, then see if it is the name of a 5501 -- constant and if so, test the corresponding constant value. 5502 5503 if Is_Entity_Name (N) then 5504 declare 5505 E : constant Entity_Id := Entity (N); 5506 V : Node_Id; 5507 begin 5508 if Ekind (E) /= E_Constant then 5509 return False; 5510 else 5511 V := Constant_Value (E); 5512 return Present (V) 5513 and then Compile_Time_Known_Composite_Value (V); 5514 end if; 5515 end; 5516 5517 -- We have a value, see if it is compile time known 5518 5519 else 5520 if Nkind (N) = N_Aggregate then 5521 return Compile_Time_Known_Aggregate (N); 5522 end if; 5523 5524 -- All other types of values are not known at compile time 5525 5526 return False; 5527 end if; 5528 5529 end Compile_Time_Known_Composite_Value; 5530 5531 ---------------------------------- 5532 -- Component_Not_OK_For_Backend -- 5533 ---------------------------------- 5534 5535 function Component_Not_OK_For_Backend return Boolean is 5536 C : Node_Id; 5537 Expr_Q : Node_Id; 5538 5539 begin 5540 if No (Comps) then 5541 return False; 5542 end if; 5543 5544 C := First (Comps); 5545 while Present (C) loop 5546 5547 -- If the component has box initialization, expansion is needed 5548 -- and component is not ready for backend. 5549 5550 if Box_Present (C) then 5551 return True; 5552 end if; 5553 5554 if Nkind (Expression (C)) = N_Qualified_Expression then 5555 Expr_Q := Expression (Expression (C)); 5556 else 5557 Expr_Q := Expression (C); 5558 end if; 5559 5560 -- Return true if the aggregate has any associations for tagged 5561 -- components that may require tag adjustment. 5562 5563 -- These are cases where the source expression may have a tag that 5564 -- could differ from the component tag (e.g., can occur for type 5565 -- conversions and formal parameters). (Tag adjustment not needed 5566 -- if VM_Target because object tags are implicit in the machine.) 5567 5568 if Is_Tagged_Type (Etype (Expr_Q)) 5569 and then (Nkind (Expr_Q) = N_Type_Conversion 5570 or else (Is_Entity_Name (Expr_Q) 5571 and then 5572 Ekind (Entity (Expr_Q)) in Formal_Kind)) 5573 and then Tagged_Type_Expansion 5574 then 5575 Static_Components := False; 5576 return True; 5577 5578 elsif Is_Delayed_Aggregate (Expr_Q) then 5579 Static_Components := False; 5580 return True; 5581 5582 elsif Possible_Bit_Aligned_Component (Expr_Q) then 5583 Static_Components := False; 5584 return True; 5585 end if; 5586 5587 if Is_Elementary_Type (Etype (Expr_Q)) then 5588 if not Compile_Time_Known_Value (Expr_Q) then 5589 Static_Components := False; 5590 end if; 5591 5592 elsif not Compile_Time_Known_Composite_Value (Expr_Q) then 5593 Static_Components := False; 5594 5595 if Is_Private_Type (Etype (Expr_Q)) 5596 and then Has_Discriminants (Etype (Expr_Q)) 5597 then 5598 return True; 5599 end if; 5600 end if; 5601 5602 Next (C); 5603 end loop; 5604 5605 return False; 5606 end Component_Not_OK_For_Backend; 5607 5608 ----------------------------------- 5609 -- Has_Visible_Private_Ancestor -- 5610 ----------------------------------- 5611 5612 function Has_Visible_Private_Ancestor (Id : E) return Boolean is 5613 R : constant Entity_Id := Root_Type (Id); 5614 T1 : Entity_Id := Id; 5615 5616 begin 5617 loop 5618 if Is_Private_Type (T1) then 5619 return True; 5620 5621 elsif T1 = R then 5622 return False; 5623 5624 else 5625 T1 := Etype (T1); 5626 end if; 5627 end loop; 5628 end Has_Visible_Private_Ancestor; 5629 5630 ------------------------- 5631 -- Top_Level_Aggregate -- 5632 ------------------------- 5633 5634 function Top_Level_Aggregate (N : Node_Id) return Node_Id is 5635 Aggr : Node_Id; 5636 5637 begin 5638 Aggr := N; 5639 while Present (Parent (Aggr)) 5640 and then Nkind_In (Parent (Aggr), N_Component_Association, 5641 N_Aggregate) 5642 loop 5643 Aggr := Parent (Aggr); 5644 end loop; 5645 5646 return Aggr; 5647 end Top_Level_Aggregate; 5648 5649 -- Local variables 5650 5651 Top_Level_Aggr : constant Node_Id := Top_Level_Aggregate (N); 5652 Tag_Value : Node_Id; 5653 Comp : Entity_Id; 5654 New_Comp : Node_Id; 5655 5656 -- Start of processing for Expand_Record_Aggregate 5657 5658 begin 5659 -- If the aggregate is to be assigned to an atomic variable, we 5660 -- have to prevent a piecemeal assignment even if the aggregate 5661 -- is to be expanded. We create a temporary for the aggregate, and 5662 -- assign the temporary instead, so that the back end can generate 5663 -- an atomic move for it. 5664 5665 if Is_Atomic (Typ) 5666 and then Comes_From_Source (Parent (N)) 5667 and then Is_Atomic_Aggregate (N, Typ) 5668 then 5669 return; 5670 5671 -- No special management required for aggregates used to initialize 5672 -- statically allocated dispatch tables 5673 5674 elsif Is_Static_Dispatch_Table_Aggregate (N) then 5675 return; 5676 end if; 5677 5678 -- Ada 2005 (AI-318-2): We need to convert to assignments if components 5679 -- are build-in-place function calls. The assignments will each turn 5680 -- into a build-in-place function call. If components are all static, 5681 -- we can pass the aggregate to the backend regardless of limitedness. 5682 5683 -- Extension aggregates, aggregates in extended return statements, and 5684 -- aggregates for C++ imported types must be expanded. 5685 5686 if Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then 5687 if not Nkind_In (Parent (N), N_Object_Declaration, 5688 N_Component_Association) 5689 then 5690 Convert_To_Assignments (N, Typ); 5691 5692 elsif Nkind (N) = N_Extension_Aggregate 5693 or else Convention (Typ) = Convention_CPP 5694 then 5695 Convert_To_Assignments (N, Typ); 5696 5697 elsif not Size_Known_At_Compile_Time (Typ) 5698 or else Component_Not_OK_For_Backend 5699 or else not Static_Components 5700 then 5701 Convert_To_Assignments (N, Typ); 5702 5703 else 5704 Set_Compile_Time_Known_Aggregate (N); 5705 Set_Expansion_Delayed (N, False); 5706 end if; 5707 5708 -- Gigi doesn't properly handle temporaries of variable size so we 5709 -- generate it in the front-end 5710 5711 elsif not Size_Known_At_Compile_Time (Typ) 5712 and then Tagged_Type_Expansion 5713 then 5714 Convert_To_Assignments (N, Typ); 5715 5716 -- An aggregate used to initialize a controlled object must be turned 5717 -- into component assignments as the components themselves may require 5718 -- finalization actions such as adjustment. 5719 5720 elsif Needs_Finalization (Typ) then 5721 Convert_To_Assignments (N, Typ); 5722 5723 -- Ada 2005 (AI-287): In case of default initialized components we 5724 -- convert the aggregate into assignments. 5725 5726 elsif Has_Default_Init_Comps (N) then 5727 Convert_To_Assignments (N, Typ); 5728 5729 -- Check components 5730 5731 elsif Component_Not_OK_For_Backend then 5732 Convert_To_Assignments (N, Typ); 5733 5734 -- If an ancestor is private, some components are not inherited and we 5735 -- cannot expand into a record aggregate. 5736 5737 elsif Has_Visible_Private_Ancestor (Typ) then 5738 Convert_To_Assignments (N, Typ); 5739 5740 -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi 5741 -- is not able to handle the aggregate for Late_Request. 5742 5743 elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then 5744 Convert_To_Assignments (N, Typ); 5745 5746 -- If the tagged types covers interface types we need to initialize all 5747 -- hidden components containing pointers to secondary dispatch tables. 5748 5749 elsif Is_Tagged_Type (Typ) and then Has_Interfaces (Typ) then 5750 Convert_To_Assignments (N, Typ); 5751 5752 -- If some components are mutable, the size of the aggregate component 5753 -- may be distinct from the default size of the type component, so 5754 -- we need to expand to insure that the back-end copies the proper 5755 -- size of the data. However, if the aggregate is the initial value of 5756 -- a constant, the target is immutable and might be built statically 5757 -- if components are appropriate. 5758 5759 elsif Has_Mutable_Components (Typ) 5760 and then 5761 (Nkind (Parent (Top_Level_Aggr)) /= N_Object_Declaration 5762 or else not Constant_Present (Parent (Top_Level_Aggr)) 5763 or else not Static_Components) 5764 then 5765 Convert_To_Assignments (N, Typ); 5766 5767 -- If the type involved has bit aligned components, then we are not sure 5768 -- that the back end can handle this case correctly. 5769 5770 elsif Type_May_Have_Bit_Aligned_Components (Typ) then 5771 Convert_To_Assignments (N, Typ); 5772 5773 -- In all other cases, build a proper aggregate to be handled by gigi 5774 5775 else 5776 if Nkind (N) = N_Aggregate then 5777 5778 -- If the aggregate is static and can be handled by the back-end, 5779 -- nothing left to do. 5780 5781 if Static_Components then 5782 Set_Compile_Time_Known_Aggregate (N); 5783 Set_Expansion_Delayed (N, False); 5784 end if; 5785 end if; 5786 5787 -- If no discriminants, nothing special to do 5788 5789 if not Has_Discriminants (Typ) then 5790 null; 5791 5792 -- Case of discriminants present 5793 5794 elsif Is_Derived_Type (Typ) then 5795 5796 -- For untagged types, non-stored discriminants are replaced 5797 -- with stored discriminants, which are the ones that gigi uses 5798 -- to describe the type and its components. 5799 5800 Generate_Aggregate_For_Derived_Type : declare 5801 Constraints : constant List_Id := New_List; 5802 First_Comp : Node_Id; 5803 Discriminant : Entity_Id; 5804 Decl : Node_Id; 5805 Num_Disc : Int := 0; 5806 Num_Gird : Int := 0; 5807 5808 procedure Prepend_Stored_Values (T : Entity_Id); 5809 -- Scan the list of stored discriminants of the type, and add 5810 -- their values to the aggregate being built. 5811 5812 --------------------------- 5813 -- Prepend_Stored_Values -- 5814 --------------------------- 5815 5816 procedure Prepend_Stored_Values (T : Entity_Id) is 5817 begin 5818 Discriminant := First_Stored_Discriminant (T); 5819 while Present (Discriminant) loop 5820 New_Comp := 5821 Make_Component_Association (Loc, 5822 Choices => 5823 New_List (New_Occurrence_Of (Discriminant, Loc)), 5824 5825 Expression => 5826 New_Copy_Tree ( 5827 Get_Discriminant_Value ( 5828 Discriminant, 5829 Typ, 5830 Discriminant_Constraint (Typ)))); 5831 5832 if No (First_Comp) then 5833 Prepend_To (Component_Associations (N), New_Comp); 5834 else 5835 Insert_After (First_Comp, New_Comp); 5836 end if; 5837 5838 First_Comp := New_Comp; 5839 Next_Stored_Discriminant (Discriminant); 5840 end loop; 5841 end Prepend_Stored_Values; 5842 5843 -- Start of processing for Generate_Aggregate_For_Derived_Type 5844 5845 begin 5846 -- Remove the associations for the discriminant of derived type 5847 5848 First_Comp := First (Component_Associations (N)); 5849 while Present (First_Comp) loop 5850 Comp := First_Comp; 5851 Next (First_Comp); 5852 5853 if Ekind (Entity 5854 (First (Choices (Comp)))) = E_Discriminant 5855 then 5856 Remove (Comp); 5857 Num_Disc := Num_Disc + 1; 5858 end if; 5859 end loop; 5860 5861 -- Insert stored discriminant associations in the correct 5862 -- order. If there are more stored discriminants than new 5863 -- discriminants, there is at least one new discriminant that 5864 -- constrains more than one of the stored discriminants. In 5865 -- this case we need to construct a proper subtype of the 5866 -- parent type, in order to supply values to all the 5867 -- components. Otherwise there is one-one correspondence 5868 -- between the constraints and the stored discriminants. 5869 5870 First_Comp := Empty; 5871 5872 Discriminant := First_Stored_Discriminant (Base_Type (Typ)); 5873 while Present (Discriminant) loop 5874 Num_Gird := Num_Gird + 1; 5875 Next_Stored_Discriminant (Discriminant); 5876 end loop; 5877 5878 -- Case of more stored discriminants than new discriminants 5879 5880 if Num_Gird > Num_Disc then 5881 5882 -- Create a proper subtype of the parent type, which is the 5883 -- proper implementation type for the aggregate, and convert 5884 -- it to the intended target type. 5885 5886 Discriminant := First_Stored_Discriminant (Base_Type (Typ)); 5887 while Present (Discriminant) loop 5888 New_Comp := 5889 New_Copy_Tree ( 5890 Get_Discriminant_Value ( 5891 Discriminant, 5892 Typ, 5893 Discriminant_Constraint (Typ))); 5894 Append (New_Comp, Constraints); 5895 Next_Stored_Discriminant (Discriminant); 5896 end loop; 5897 5898 Decl := 5899 Make_Subtype_Declaration (Loc, 5900 Defining_Identifier => Make_Temporary (Loc, 'T'), 5901 Subtype_Indication => 5902 Make_Subtype_Indication (Loc, 5903 Subtype_Mark => 5904 New_Occurrence_Of (Etype (Base_Type (Typ)), Loc), 5905 Constraint => 5906 Make_Index_Or_Discriminant_Constraint 5907 (Loc, Constraints))); 5908 5909 Insert_Action (N, Decl); 5910 Prepend_Stored_Values (Base_Type (Typ)); 5911 5912 Set_Etype (N, Defining_Identifier (Decl)); 5913 Set_Analyzed (N); 5914 5915 Rewrite (N, Unchecked_Convert_To (Typ, N)); 5916 Analyze (N); 5917 5918 -- Case where we do not have fewer new discriminants than 5919 -- stored discriminants, so in this case we can simply use the 5920 -- stored discriminants of the subtype. 5921 5922 else 5923 Prepend_Stored_Values (Typ); 5924 end if; 5925 end Generate_Aggregate_For_Derived_Type; 5926 end if; 5927 5928 if Is_Tagged_Type (Typ) then 5929 5930 -- In the tagged case, _parent and _tag component must be created 5931 5932 -- Reset Null_Present unconditionally. Tagged records always have 5933 -- at least one field (the tag or the parent). 5934 5935 Set_Null_Record_Present (N, False); 5936 5937 -- When the current aggregate comes from the expansion of an 5938 -- extension aggregate, the parent expr is replaced by an 5939 -- aggregate formed by selected components of this expr. 5940 5941 if Present (Parent_Expr) 5942 and then Is_Empty_List (Comps) 5943 then 5944 Comp := First_Component_Or_Discriminant (Typ); 5945 while Present (Comp) loop 5946 5947 -- Skip all expander-generated components 5948 5949 if 5950 not Comes_From_Source (Original_Record_Component (Comp)) 5951 then 5952 null; 5953 5954 else 5955 New_Comp := 5956 Make_Selected_Component (Loc, 5957 Prefix => 5958 Unchecked_Convert_To (Typ, 5959 Duplicate_Subexpr (Parent_Expr, True)), 5960 5961 Selector_Name => New_Occurrence_Of (Comp, Loc)); 5962 5963 Append_To (Comps, 5964 Make_Component_Association (Loc, 5965 Choices => 5966 New_List (New_Occurrence_Of (Comp, Loc)), 5967 Expression => 5968 New_Comp)); 5969 5970 Analyze_And_Resolve (New_Comp, Etype (Comp)); 5971 end if; 5972 5973 Next_Component_Or_Discriminant (Comp); 5974 end loop; 5975 end if; 5976 5977 -- Compute the value for the Tag now, if the type is a root it 5978 -- will be included in the aggregate right away, otherwise it will 5979 -- be propagated to the parent aggregate. 5980 5981 if Present (Orig_Tag) then 5982 Tag_Value := Orig_Tag; 5983 elsif not Tagged_Type_Expansion then 5984 Tag_Value := Empty; 5985 else 5986 Tag_Value := 5987 New_Occurrence_Of 5988 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc); 5989 end if; 5990 5991 -- For a derived type, an aggregate for the parent is formed with 5992 -- all the inherited components. 5993 5994 if Is_Derived_Type (Typ) then 5995 5996 declare 5997 First_Comp : Node_Id; 5998 Parent_Comps : List_Id; 5999 Parent_Aggr : Node_Id; 6000 Parent_Name : Node_Id; 6001 6002 begin 6003 -- Remove the inherited component association from the 6004 -- aggregate and store them in the parent aggregate 6005 6006 First_Comp := First (Component_Associations (N)); 6007 Parent_Comps := New_List; 6008 while Present (First_Comp) 6009 and then Scope (Original_Record_Component ( 6010 Entity (First (Choices (First_Comp))))) /= Base_Typ 6011 loop 6012 Comp := First_Comp; 6013 Next (First_Comp); 6014 Remove (Comp); 6015 Append (Comp, Parent_Comps); 6016 end loop; 6017 6018 Parent_Aggr := Make_Aggregate (Loc, 6019 Component_Associations => Parent_Comps); 6020 Set_Etype (Parent_Aggr, Etype (Base_Type (Typ))); 6021 6022 -- Find the _parent component 6023 6024 Comp := First_Component (Typ); 6025 while Chars (Comp) /= Name_uParent loop 6026 Comp := Next_Component (Comp); 6027 end loop; 6028 6029 Parent_Name := New_Occurrence_Of (Comp, Loc); 6030 6031 -- Insert the parent aggregate 6032 6033 Prepend_To (Component_Associations (N), 6034 Make_Component_Association (Loc, 6035 Choices => New_List (Parent_Name), 6036 Expression => Parent_Aggr)); 6037 6038 -- Expand recursively the parent propagating the right Tag 6039 6040 Expand_Record_Aggregate 6041 (Parent_Aggr, Tag_Value, Parent_Expr); 6042 6043 -- The ancestor part may be a nested aggregate that has 6044 -- delayed expansion: recheck now. 6045 6046 if Component_Not_OK_For_Backend then 6047 Convert_To_Assignments (N, Typ); 6048 end if; 6049 end; 6050 6051 -- For a root type, the tag component is added (unless compiling 6052 -- for the VMs, where tags are implicit). 6053 6054 elsif Tagged_Type_Expansion then 6055 declare 6056 Tag_Name : constant Node_Id := 6057 New_Occurrence_Of (First_Tag_Component (Typ), Loc); 6058 Typ_Tag : constant Entity_Id := RTE (RE_Tag); 6059 Conv_Node : constant Node_Id := 6060 Unchecked_Convert_To (Typ_Tag, Tag_Value); 6061 6062 begin 6063 Set_Etype (Conv_Node, Typ_Tag); 6064 Prepend_To (Component_Associations (N), 6065 Make_Component_Association (Loc, 6066 Choices => New_List (Tag_Name), 6067 Expression => Conv_Node)); 6068 end; 6069 end if; 6070 end if; 6071 end if; 6072 6073 end Expand_Record_Aggregate; 6074 6075 ---------------------------- 6076 -- Has_Default_Init_Comps -- 6077 ---------------------------- 6078 6079 function Has_Default_Init_Comps (N : Node_Id) return Boolean is 6080 Comps : constant List_Id := Component_Associations (N); 6081 C : Node_Id; 6082 Expr : Node_Id; 6083 begin 6084 pragma Assert (Nkind_In (N, N_Aggregate, N_Extension_Aggregate)); 6085 6086 if No (Comps) then 6087 return False; 6088 end if; 6089 6090 if Has_Self_Reference (N) then 6091 return True; 6092 end if; 6093 6094 -- Check if any direct component has default initialized components 6095 6096 C := First (Comps); 6097 while Present (C) loop 6098 if Box_Present (C) then 6099 return True; 6100 end if; 6101 6102 Next (C); 6103 end loop; 6104 6105 -- Recursive call in case of aggregate expression 6106 6107 C := First (Comps); 6108 while Present (C) loop 6109 Expr := Expression (C); 6110 6111 if Present (Expr) 6112 and then 6113 Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate) 6114 and then Has_Default_Init_Comps (Expr) 6115 then 6116 return True; 6117 end if; 6118 6119 Next (C); 6120 end loop; 6121 6122 return False; 6123 end Has_Default_Init_Comps; 6124 6125 -------------------------- 6126 -- Is_Delayed_Aggregate -- 6127 -------------------------- 6128 6129 function Is_Delayed_Aggregate (N : Node_Id) return Boolean is 6130 Node : Node_Id := N; 6131 Kind : Node_Kind := Nkind (Node); 6132 6133 begin 6134 if Kind = N_Qualified_Expression then 6135 Node := Expression (Node); 6136 Kind := Nkind (Node); 6137 end if; 6138 6139 if Kind /= N_Aggregate and then Kind /= N_Extension_Aggregate then 6140 return False; 6141 else 6142 return Expansion_Delayed (Node); 6143 end if; 6144 end Is_Delayed_Aggregate; 6145 6146 ---------------------------------------- 6147 -- Is_Static_Dispatch_Table_Aggregate -- 6148 ---------------------------------------- 6149 6150 function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean is 6151 Typ : constant Entity_Id := Base_Type (Etype (N)); 6152 6153 begin 6154 return Static_Dispatch_Tables 6155 and then Tagged_Type_Expansion 6156 and then RTU_Loaded (Ada_Tags) 6157 6158 -- Avoid circularity when rebuilding the compiler 6159 6160 and then Cunit_Entity (Get_Source_Unit (N)) /= RTU_Entity (Ada_Tags) 6161 and then (Typ = RTE (RE_Dispatch_Table_Wrapper) 6162 or else 6163 Typ = RTE (RE_Address_Array) 6164 or else 6165 Typ = RTE (RE_Type_Specific_Data) 6166 or else 6167 Typ = RTE (RE_Tag_Table) 6168 or else 6169 (RTE_Available (RE_Interface_Data) 6170 and then Typ = RTE (RE_Interface_Data)) 6171 or else 6172 (RTE_Available (RE_Interfaces_Array) 6173 and then Typ = RTE (RE_Interfaces_Array)) 6174 or else 6175 (RTE_Available (RE_Interface_Data_Element) 6176 and then Typ = RTE (RE_Interface_Data_Element))); 6177 end Is_Static_Dispatch_Table_Aggregate; 6178 6179 ----------------------------- 6180 -- Is_Two_Dim_Packed_Array -- 6181 ----------------------------- 6182 6183 function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean is 6184 C : constant Int := UI_To_Int (Component_Size (Typ)); 6185 begin 6186 return Number_Dimensions (Typ) = 2 6187 and then Is_Bit_Packed_Array (Typ) 6188 and then (C = 1 or else C = 2 or else C = 4); 6189 end Is_Two_Dim_Packed_Array; 6190 6191 -------------------- 6192 -- Late_Expansion -- 6193 -------------------- 6194 6195 function Late_Expansion 6196 (N : Node_Id; 6197 Typ : Entity_Id; 6198 Target : Node_Id) return List_Id 6199 is 6200 Aggr_Code : List_Id; 6201 6202 begin 6203 if Is_Record_Type (Etype (N)) then 6204 Aggr_Code := Build_Record_Aggr_Code (N, Typ, Target); 6205 6206 -- Save the last assignment statement associated with the aggregate 6207 -- when building a controlled object. This reference is utilized by 6208 -- the finalization machinery when marking an object as successfully 6209 -- initialized. 6210 6211 if Needs_Finalization (Typ) 6212 and then Is_Entity_Name (Target) 6213 and then Present (Entity (Target)) 6214 and then Ekind (Entity (Target)) = E_Variable 6215 then 6216 Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code)); 6217 end if; 6218 6219 return Aggr_Code; 6220 6221 else pragma Assert (Is_Array_Type (Etype (N))); 6222 return 6223 Build_Array_Aggr_Code 6224 (N => N, 6225 Ctype => Component_Type (Etype (N)), 6226 Index => First_Index (Typ), 6227 Into => Target, 6228 Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)), 6229 Indexes => No_List); 6230 end if; 6231 end Late_Expansion; 6232 6233 ---------------------------------- 6234 -- Make_OK_Assignment_Statement -- 6235 ---------------------------------- 6236 6237 function Make_OK_Assignment_Statement 6238 (Sloc : Source_Ptr; 6239 Name : Node_Id; 6240 Expression : Node_Id) return Node_Id 6241 is 6242 begin 6243 Set_Assignment_OK (Name); 6244 6245 return Make_Assignment_Statement (Sloc, Name, Expression); 6246 end Make_OK_Assignment_Statement; 6247 6248 ----------------------- 6249 -- Number_Of_Choices -- 6250 ----------------------- 6251 6252 function Number_Of_Choices (N : Node_Id) return Nat is 6253 Assoc : Node_Id; 6254 Choice : Node_Id; 6255 6256 Nb_Choices : Nat := 0; 6257 6258 begin 6259 if Present (Expressions (N)) then 6260 return 0; 6261 end if; 6262 6263 Assoc := First (Component_Associations (N)); 6264 while Present (Assoc) loop 6265 Choice := First (Choices (Assoc)); 6266 while Present (Choice) loop 6267 if Nkind (Choice) /= N_Others_Choice then 6268 Nb_Choices := Nb_Choices + 1; 6269 end if; 6270 6271 Next (Choice); 6272 end loop; 6273 6274 Next (Assoc); 6275 end loop; 6276 6277 return Nb_Choices; 6278 end Number_Of_Choices; 6279 6280 ------------------------------------ 6281 -- Packed_Array_Aggregate_Handled -- 6282 ------------------------------------ 6283 6284 -- The current version of this procedure will handle at compile time 6285 -- any array aggregate that meets these conditions: 6286 6287 -- One and two dimensional, bit packed 6288 -- Underlying packed type is modular type 6289 -- Bounds are within 32-bit Int range 6290 -- All bounds and values are static 6291 6292 -- Note: for now, in the 2-D case, we only handle component sizes of 6293 -- 1, 2, 4 (cases where an integral number of elements occupies a byte). 6294 6295 function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean is 6296 Loc : constant Source_Ptr := Sloc (N); 6297 Typ : constant Entity_Id := Etype (N); 6298 Ctyp : constant Entity_Id := Component_Type (Typ); 6299 6300 Not_Handled : exception; 6301 -- Exception raised if this aggregate cannot be handled 6302 6303 begin 6304 -- Handle one- or two dimensional bit packed array 6305 6306 if not Is_Bit_Packed_Array (Typ) 6307 or else Number_Dimensions (Typ) > 2 6308 then 6309 return False; 6310 end if; 6311 6312 -- If two-dimensional, check whether it can be folded, and transformed 6313 -- into a one-dimensional aggregate for the Packed_Array_Type of the 6314 -- original type. 6315 6316 if Number_Dimensions (Typ) = 2 then 6317 return Two_Dim_Packed_Array_Handled (N); 6318 end if; 6319 6320 if not Is_Modular_Integer_Type (Packed_Array_Type (Typ)) then 6321 return False; 6322 end if; 6323 6324 if not Is_Scalar_Type (Component_Type (Typ)) 6325 and then Has_Non_Standard_Rep (Component_Type (Typ)) 6326 then 6327 return False; 6328 end if; 6329 6330 declare 6331 Csiz : constant Nat := UI_To_Int (Component_Size (Typ)); 6332 6333 Lo : Node_Id; 6334 Hi : Node_Id; 6335 -- Bounds of index type 6336 6337 Lob : Uint; 6338 Hib : Uint; 6339 -- Values of bounds if compile time known 6340 6341 function Get_Component_Val (N : Node_Id) return Uint; 6342 -- Given a expression value N of the component type Ctyp, returns a 6343 -- value of Csiz (component size) bits representing this value. If 6344 -- the value is non-static or any other reason exists why the value 6345 -- cannot be returned, then Not_Handled is raised. 6346 6347 ----------------------- 6348 -- Get_Component_Val -- 6349 ----------------------- 6350 6351 function Get_Component_Val (N : Node_Id) return Uint is 6352 Val : Uint; 6353 6354 begin 6355 -- We have to analyze the expression here before doing any further 6356 -- processing here. The analysis of such expressions is deferred 6357 -- till expansion to prevent some problems of premature analysis. 6358 6359 Analyze_And_Resolve (N, Ctyp); 6360 6361 -- Must have a compile time value. String literals have to be 6362 -- converted into temporaries as well, because they cannot easily 6363 -- be converted into their bit representation. 6364 6365 if not Compile_Time_Known_Value (N) 6366 or else Nkind (N) = N_String_Literal 6367 then 6368 raise Not_Handled; 6369 end if; 6370 6371 Val := Expr_Rep_Value (N); 6372 6373 -- Adjust for bias, and strip proper number of bits 6374 6375 if Has_Biased_Representation (Ctyp) then 6376 Val := Val - Expr_Value (Type_Low_Bound (Ctyp)); 6377 end if; 6378 6379 return Val mod Uint_2 ** Csiz; 6380 end Get_Component_Val; 6381 6382 -- Here we know we have a one dimensional bit packed array 6383 6384 begin 6385 Get_Index_Bounds (First_Index (Typ), Lo, Hi); 6386 6387 -- Cannot do anything if bounds are dynamic 6388 6389 if not Compile_Time_Known_Value (Lo) 6390 or else 6391 not Compile_Time_Known_Value (Hi) 6392 then 6393 return False; 6394 end if; 6395 6396 -- Or are silly out of range of int bounds 6397 6398 Lob := Expr_Value (Lo); 6399 Hib := Expr_Value (Hi); 6400 6401 if not UI_Is_In_Int_Range (Lob) 6402 or else 6403 not UI_Is_In_Int_Range (Hib) 6404 then 6405 return False; 6406 end if; 6407 6408 -- At this stage we have a suitable aggregate for handling at compile 6409 -- time. The only remaining checks are that the values of expressions 6410 -- in the aggregate are compile-time known (checks are performed by 6411 -- Get_Component_Val), and that any subtypes or ranges are statically 6412 -- known. 6413 6414 -- If the aggregate is not fully positional at this stage, then 6415 -- convert it to positional form. Either this will fail, in which 6416 -- case we can do nothing, or it will succeed, in which case we have 6417 -- succeeded in handling the aggregate and transforming it into a 6418 -- modular value, or it will stay an aggregate, in which case we 6419 -- have failed to create a packed value for it. 6420 6421 if Present (Component_Associations (N)) then 6422 Convert_To_Positional 6423 (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True); 6424 return Nkind (N) /= N_Aggregate; 6425 end if; 6426 6427 -- Otherwise we are all positional, so convert to proper value 6428 6429 declare 6430 Lov : constant Int := UI_To_Int (Lob); 6431 Hiv : constant Int := UI_To_Int (Hib); 6432 6433 Len : constant Nat := Int'Max (0, Hiv - Lov + 1); 6434 -- The length of the array (number of elements) 6435 6436 Aggregate_Val : Uint; 6437 -- Value of aggregate. The value is set in the low order bits of 6438 -- this value. For the little-endian case, the values are stored 6439 -- from low-order to high-order and for the big-endian case the 6440 -- values are stored from high-order to low-order. Note that gigi 6441 -- will take care of the conversions to left justify the value in 6442 -- the big endian case (because of left justified modular type 6443 -- processing), so we do not have to worry about that here. 6444 6445 Lit : Node_Id; 6446 -- Integer literal for resulting constructed value 6447 6448 Shift : Nat; 6449 -- Shift count from low order for next value 6450 6451 Incr : Int; 6452 -- Shift increment for loop 6453 6454 Expr : Node_Id; 6455 -- Next expression from positional parameters of aggregate 6456 6457 Left_Justified : Boolean; 6458 -- Set True if we are filling the high order bits of the target 6459 -- value (i.e. the value is left justified). 6460 6461 begin 6462 -- For little endian, we fill up the low order bits of the target 6463 -- value. For big endian we fill up the high order bits of the 6464 -- target value (which is a left justified modular value). 6465 6466 Left_Justified := Bytes_Big_Endian; 6467 6468 -- Switch justification if using -gnatd8 6469 6470 if Debug_Flag_8 then 6471 Left_Justified := not Left_Justified; 6472 end if; 6473 6474 -- Switch justfification if reverse storage order 6475 6476 if Reverse_Storage_Order (Base_Type (Typ)) then 6477 Left_Justified := not Left_Justified; 6478 end if; 6479 6480 if Left_Justified then 6481 Shift := Csiz * (Len - 1); 6482 Incr := -Csiz; 6483 else 6484 Shift := 0; 6485 Incr := +Csiz; 6486 end if; 6487 6488 -- Loop to set the values 6489 6490 if Len = 0 then 6491 Aggregate_Val := Uint_0; 6492 else 6493 Expr := First (Expressions (N)); 6494 Aggregate_Val := Get_Component_Val (Expr) * Uint_2 ** Shift; 6495 6496 for J in 2 .. Len loop 6497 Shift := Shift + Incr; 6498 Next (Expr); 6499 Aggregate_Val := 6500 Aggregate_Val + Get_Component_Val (Expr) * Uint_2 ** Shift; 6501 end loop; 6502 end if; 6503 6504 -- Now we can rewrite with the proper value 6505 6506 Lit := Make_Integer_Literal (Loc, Intval => Aggregate_Val); 6507 Set_Print_In_Hex (Lit); 6508 6509 -- Construct the expression using this literal. Note that it is 6510 -- important to qualify the literal with its proper modular type 6511 -- since universal integer does not have the required range and 6512 -- also this is a left justified modular type, which is important 6513 -- in the big-endian case. 6514 6515 Rewrite (N, 6516 Unchecked_Convert_To (Typ, 6517 Make_Qualified_Expression (Loc, 6518 Subtype_Mark => 6519 New_Occurrence_Of (Packed_Array_Type (Typ), Loc), 6520 Expression => Lit))); 6521 6522 Analyze_And_Resolve (N, Typ); 6523 return True; 6524 end; 6525 end; 6526 6527 exception 6528 when Not_Handled => 6529 return False; 6530 end Packed_Array_Aggregate_Handled; 6531 6532 ---------------------------- 6533 -- Has_Mutable_Components -- 6534 ---------------------------- 6535 6536 function Has_Mutable_Components (Typ : Entity_Id) return Boolean is 6537 Comp : Entity_Id; 6538 6539 begin 6540 Comp := First_Component (Typ); 6541 while Present (Comp) loop 6542 if Is_Record_Type (Etype (Comp)) 6543 and then Has_Discriminants (Etype (Comp)) 6544 and then not Is_Constrained (Etype (Comp)) 6545 then 6546 return True; 6547 end if; 6548 6549 Next_Component (Comp); 6550 end loop; 6551 6552 return False; 6553 end Has_Mutable_Components; 6554 6555 ------------------------------ 6556 -- Initialize_Discriminants -- 6557 ------------------------------ 6558 6559 procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id) is 6560 Loc : constant Source_Ptr := Sloc (N); 6561 Bas : constant Entity_Id := Base_Type (Typ); 6562 Par : constant Entity_Id := Etype (Bas); 6563 Decl : constant Node_Id := Parent (Par); 6564 Ref : Node_Id; 6565 6566 begin 6567 if Is_Tagged_Type (Bas) 6568 and then Is_Derived_Type (Bas) 6569 and then Has_Discriminants (Par) 6570 and then Has_Discriminants (Bas) 6571 and then Number_Discriminants (Bas) /= Number_Discriminants (Par) 6572 and then Nkind (Decl) = N_Full_Type_Declaration 6573 and then Nkind (Type_Definition (Decl)) = N_Record_Definition 6574 and then Present 6575 (Variant_Part (Component_List (Type_Definition (Decl)))) 6576 and then Nkind (N) /= N_Extension_Aggregate 6577 then 6578 6579 -- Call init proc to set discriminants. 6580 -- There should eventually be a special procedure for this ??? 6581 6582 Ref := New_Occurrence_Of (Defining_Identifier (N), Loc); 6583 Insert_Actions_After (N, 6584 Build_Initialization_Call (Sloc (N), Ref, Typ)); 6585 end if; 6586 end Initialize_Discriminants; 6587 6588 ---------------- 6589 -- Must_Slide -- 6590 ---------------- 6591 6592 function Must_Slide 6593 (Obj_Type : Entity_Id; 6594 Typ : Entity_Id) return Boolean 6595 is 6596 L1, L2, H1, H2 : Node_Id; 6597 begin 6598 -- No sliding if the type of the object is not established yet, if it is 6599 -- an unconstrained type whose actual subtype comes from the aggregate, 6600 -- or if the two types are identical. 6601 6602 if not Is_Array_Type (Obj_Type) then 6603 return False; 6604 6605 elsif not Is_Constrained (Obj_Type) then 6606 return False; 6607 6608 elsif Typ = Obj_Type then 6609 return False; 6610 6611 else 6612 -- Sliding can only occur along the first dimension 6613 6614 Get_Index_Bounds (First_Index (Typ), L1, H1); 6615 Get_Index_Bounds (First_Index (Obj_Type), L2, H2); 6616 6617 if not Is_Static_Expression (L1) 6618 or else not Is_Static_Expression (L2) 6619 or else not Is_Static_Expression (H1) 6620 or else not Is_Static_Expression (H2) 6621 then 6622 return False; 6623 else 6624 return Expr_Value (L1) /= Expr_Value (L2) 6625 or else 6626 Expr_Value (H1) /= Expr_Value (H2); 6627 end if; 6628 end if; 6629 end Must_Slide; 6630 6631 --------------------------- 6632 -- Safe_Slice_Assignment -- 6633 --------------------------- 6634 6635 function Safe_Slice_Assignment (N : Node_Id) return Boolean is 6636 Loc : constant Source_Ptr := Sloc (Parent (N)); 6637 Pref : constant Node_Id := Prefix (Name (Parent (N))); 6638 Range_Node : constant Node_Id := Discrete_Range (Name (Parent (N))); 6639 Expr : Node_Id; 6640 L_J : Entity_Id; 6641 L_Iter : Node_Id; 6642 L_Body : Node_Id; 6643 Stat : Node_Id; 6644 6645 begin 6646 -- Generate: for J in Range loop Pref (J) := Expr; end loop; 6647 6648 if Comes_From_Source (N) 6649 and then No (Expressions (N)) 6650 and then Nkind (First (Choices (First (Component_Associations (N))))) 6651 = N_Others_Choice 6652 then 6653 Expr := Expression (First (Component_Associations (N))); 6654 L_J := Make_Temporary (Loc, 'J'); 6655 6656 L_Iter := 6657 Make_Iteration_Scheme (Loc, 6658 Loop_Parameter_Specification => 6659 Make_Loop_Parameter_Specification 6660 (Loc, 6661 Defining_Identifier => L_J, 6662 Discrete_Subtype_Definition => Relocate_Node (Range_Node))); 6663 6664 L_Body := 6665 Make_Assignment_Statement (Loc, 6666 Name => 6667 Make_Indexed_Component (Loc, 6668 Prefix => Relocate_Node (Pref), 6669 Expressions => New_List (New_Occurrence_Of (L_J, Loc))), 6670 Expression => Relocate_Node (Expr)); 6671 6672 -- Construct the final loop 6673 6674 Stat := 6675 Make_Implicit_Loop_Statement 6676 (Node => Parent (N), 6677 Identifier => Empty, 6678 Iteration_Scheme => L_Iter, 6679 Statements => New_List (L_Body)); 6680 6681 -- Set type of aggregate to be type of lhs in assignment, 6682 -- to suppress redundant length checks. 6683 6684 Set_Etype (N, Etype (Name (Parent (N)))); 6685 6686 Rewrite (Parent (N), Stat); 6687 Analyze (Parent (N)); 6688 return True; 6689 6690 else 6691 return False; 6692 end if; 6693 end Safe_Slice_Assignment; 6694 6695 ---------------------------------- 6696 -- Two_Dim_Packed_Array_Handled -- 6697 ---------------------------------- 6698 6699 function Two_Dim_Packed_Array_Handled (N : Node_Id) return Boolean is 6700 Loc : constant Source_Ptr := Sloc (N); 6701 Typ : constant Entity_Id := Etype (N); 6702 Ctyp : constant Entity_Id := Component_Type (Typ); 6703 Comp_Size : constant Int := UI_To_Int (Component_Size (Typ)); 6704 Packed_Array : constant Entity_Id := Packed_Array_Type (Base_Type (Typ)); 6705 6706 One_Comp : Node_Id; 6707 -- Expression in original aggregate 6708 6709 One_Dim : Node_Id; 6710 -- One-dimensional subaggregate 6711 6712 begin 6713 6714 -- For now, only deal with cases where an integral number of elements 6715 -- fit in a single byte. This includes the most common boolean case. 6716 6717 if not (Comp_Size = 1 or else 6718 Comp_Size = 2 or else 6719 Comp_Size = 4) 6720 then 6721 return False; 6722 end if; 6723 6724 Convert_To_Positional 6725 (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True); 6726 6727 -- Verify that all components are static 6728 6729 if Nkind (N) = N_Aggregate 6730 and then Compile_Time_Known_Aggregate (N) 6731 then 6732 null; 6733 6734 -- The aggregate may have been re-analyzed and converted already 6735 6736 elsif Nkind (N) /= N_Aggregate then 6737 return True; 6738 6739 -- If component associations remain, the aggregate is not static 6740 6741 elsif Present (Component_Associations (N)) then 6742 return False; 6743 6744 else 6745 One_Dim := First (Expressions (N)); 6746 while Present (One_Dim) loop 6747 if Present (Component_Associations (One_Dim)) then 6748 return False; 6749 end if; 6750 6751 One_Comp := First (Expressions (One_Dim)); 6752 while Present (One_Comp) loop 6753 if not Is_OK_Static_Expression (One_Comp) then 6754 return False; 6755 end if; 6756 6757 Next (One_Comp); 6758 end loop; 6759 6760 Next (One_Dim); 6761 end loop; 6762 end if; 6763 6764 -- Two-dimensional aggregate is now fully positional so pack one 6765 -- dimension to create a static one-dimensional array, and rewrite 6766 -- as an unchecked conversion to the original type. 6767 6768 declare 6769 Byte_Size : constant Int := UI_To_Int (Component_Size (Packed_Array)); 6770 -- The packed array type is a byte array 6771 6772 Packed_Num : Int; 6773 -- Number of components accumulated in current byte 6774 6775 Comps : List_Id; 6776 -- Assembled list of packed values for equivalent aggregate 6777 6778 Comp_Val : Uint; 6779 -- integer value of component 6780 6781 Incr : Int; 6782 -- Step size for packing 6783 6784 Init_Shift : Int; 6785 -- Endian-dependent start position for packing 6786 6787 Shift : Int; 6788 -- Current insertion position 6789 6790 Val : Int; 6791 -- Component of packed array being assembled. 6792 6793 begin 6794 Comps := New_List; 6795 Val := 0; 6796 Packed_Num := 0; 6797 6798 -- Account for endianness. See corresponding comment in 6799 -- Packed_Array_Aggregate_Handled concerning the following. 6800 6801 if Bytes_Big_Endian 6802 xor Debug_Flag_8 6803 xor Reverse_Storage_Order (Base_Type (Typ)) 6804 then 6805 Init_Shift := Byte_Size - Comp_Size; 6806 Incr := -Comp_Size; 6807 else 6808 Init_Shift := 0; 6809 Incr := +Comp_Size; 6810 end if; 6811 6812 Shift := Init_Shift; 6813 One_Dim := First (Expressions (N)); 6814 6815 -- Iterate over each subaggregate 6816 6817 while Present (One_Dim) loop 6818 One_Comp := First (Expressions (One_Dim)); 6819 6820 while Present (One_Comp) loop 6821 if Packed_Num = Byte_Size / Comp_Size then 6822 6823 -- Byte is complete, add to list of expressions 6824 6825 Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps); 6826 Val := 0; 6827 Shift := Init_Shift; 6828 Packed_Num := 0; 6829 6830 else 6831 Comp_Val := Expr_Rep_Value (One_Comp); 6832 6833 -- Adjust for bias, and strip proper number of bits 6834 6835 if Has_Biased_Representation (Ctyp) then 6836 Comp_Val := Comp_Val - Expr_Value (Type_Low_Bound (Ctyp)); 6837 end if; 6838 6839 Comp_Val := Comp_Val mod Uint_2 ** Comp_Size; 6840 Val := UI_To_Int (Val + Comp_Val * Uint_2 ** Shift); 6841 Shift := Shift + Incr; 6842 One_Comp := Next (One_Comp); 6843 Packed_Num := Packed_Num + 1; 6844 end if; 6845 end loop; 6846 6847 One_Dim := Next (One_Dim); 6848 end loop; 6849 6850 if Packed_Num > 0 then 6851 6852 -- Add final incomplete byte if present 6853 6854 Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps); 6855 end if; 6856 6857 Rewrite (N, 6858 Unchecked_Convert_To (Typ, 6859 Make_Qualified_Expression (Loc, 6860 Subtype_Mark => New_Occurrence_Of (Packed_Array, Loc), 6861 Expression => 6862 Make_Aggregate (Loc, Expressions => Comps)))); 6863 Analyze_And_Resolve (N); 6864 return True; 6865 end; 6866 end Two_Dim_Packed_Array_Handled; 6867 6868 --------------------- 6869 -- Sort_Case_Table -- 6870 --------------------- 6871 6872 procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is 6873 L : constant Int := Case_Table'First; 6874 U : constant Int := Case_Table'Last; 6875 K : Int; 6876 J : Int; 6877 T : Case_Bounds; 6878 6879 begin 6880 K := L; 6881 while K /= U loop 6882 T := Case_Table (K + 1); 6883 6884 J := K + 1; 6885 while J /= L 6886 and then Expr_Value (Case_Table (J - 1).Choice_Lo) > 6887 Expr_Value (T.Choice_Lo) 6888 loop 6889 Case_Table (J) := Case_Table (J - 1); 6890 J := J - 1; 6891 end loop; 6892 6893 Case_Table (J) := T; 6894 K := K + 1; 6895 end loop; 6896 end Sort_Case_Table; 6897 6898 ---------------------------- 6899 -- Static_Array_Aggregate -- 6900 ---------------------------- 6901 6902 function Static_Array_Aggregate (N : Node_Id) return Boolean is 6903 Bounds : constant Node_Id := Aggregate_Bounds (N); 6904 6905 Typ : constant Entity_Id := Etype (N); 6906 Comp_Type : constant Entity_Id := Component_Type (Typ); 6907 Agg : Node_Id; 6908 Expr : Node_Id; 6909 Lo : Node_Id; 6910 Hi : Node_Id; 6911 6912 begin 6913 if Is_Tagged_Type (Typ) 6914 or else Is_Controlled (Typ) 6915 or else Is_Packed (Typ) 6916 then 6917 return False; 6918 end if; 6919 6920 if Present (Bounds) 6921 and then Nkind (Bounds) = N_Range 6922 and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal 6923 and then Nkind (High_Bound (Bounds)) = N_Integer_Literal 6924 then 6925 Lo := Low_Bound (Bounds); 6926 Hi := High_Bound (Bounds); 6927 6928 if No (Component_Associations (N)) then 6929 6930 -- Verify that all components are static integers 6931 6932 Expr := First (Expressions (N)); 6933 while Present (Expr) loop 6934 if Nkind (Expr) /= N_Integer_Literal then 6935 return False; 6936 end if; 6937 6938 Next (Expr); 6939 end loop; 6940 6941 return True; 6942 6943 else 6944 -- We allow only a single named association, either a static 6945 -- range or an others_clause, with a static expression. 6946 6947 Expr := First (Component_Associations (N)); 6948 6949 if Present (Expressions (N)) then 6950 return False; 6951 6952 elsif Present (Next (Expr)) then 6953 return False; 6954 6955 elsif Present (Next (First (Choices (Expr)))) then 6956 return False; 6957 6958 else 6959 -- The aggregate is static if all components are literals, 6960 -- or else all its components are static aggregates for the 6961 -- component type. We also limit the size of a static aggregate 6962 -- to prevent runaway static expressions. 6963 6964 if Is_Array_Type (Comp_Type) 6965 or else Is_Record_Type (Comp_Type) 6966 then 6967 if Nkind (Expression (Expr)) /= N_Aggregate 6968 or else 6969 not Compile_Time_Known_Aggregate (Expression (Expr)) 6970 then 6971 return False; 6972 end if; 6973 6974 elsif Nkind (Expression (Expr)) /= N_Integer_Literal then 6975 return False; 6976 end if; 6977 6978 if not Aggr_Size_OK (N, Typ) then 6979 return False; 6980 end if; 6981 6982 -- Create a positional aggregate with the right number of 6983 -- copies of the expression. 6984 6985 Agg := Make_Aggregate (Sloc (N), New_List, No_List); 6986 6987 for I in UI_To_Int (Intval (Lo)) .. UI_To_Int (Intval (Hi)) 6988 loop 6989 Append_To 6990 (Expressions (Agg), New_Copy (Expression (Expr))); 6991 6992 -- The copied expression must be analyzed and resolved. 6993 -- Besides setting the type, this ensures that static 6994 -- expressions are appropriately marked as such. 6995 6996 Analyze_And_Resolve 6997 (Last (Expressions (Agg)), Component_Type (Typ)); 6998 end loop; 6999 7000 Set_Aggregate_Bounds (Agg, Bounds); 7001 Set_Etype (Agg, Typ); 7002 Set_Analyzed (Agg); 7003 Rewrite (N, Agg); 7004 Set_Compile_Time_Known_Aggregate (N); 7005 7006 return True; 7007 end if; 7008 end if; 7009 7010 else 7011 return False; 7012 end if; 7013 end Static_Array_Aggregate; 7014 7015end Exp_Aggr; 7016