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