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