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