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-2004 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Atree; use Atree; 28with Checks; use Checks; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Elists; use Elists; 32with Expander; use Expander; 33with Exp_Util; use Exp_Util; 34with Exp_Ch3; use Exp_Ch3; 35with Exp_Ch7; use Exp_Ch7; 36with Exp_Ch9; use Exp_Ch9; 37with Freeze; use Freeze; 38with Hostparm; use Hostparm; 39with Itypes; use Itypes; 40with Lib; use Lib; 41with Nmake; use Nmake; 42with Nlists; use Nlists; 43with Restrict; use Restrict; 44with Rtsfind; use Rtsfind; 45with Ttypes; use Ttypes; 46with Sem; use Sem; 47with Sem_Ch3; use Sem_Ch3; 48with Sem_Eval; use Sem_Eval; 49with Sem_Res; use Sem_Res; 50with Sem_Util; use Sem_Util; 51with Sinfo; use Sinfo; 52with Snames; use Snames; 53with Stand; use Stand; 54with Tbuild; use Tbuild; 55with Uintp; use Uintp; 56 57package body Exp_Aggr is 58 59 type Case_Bounds is record 60 Choice_Lo : Node_Id; 61 Choice_Hi : Node_Id; 62 Choice_Node : Node_Id; 63 end record; 64 65 type Case_Table_Type is array (Nat range <>) of Case_Bounds; 66 -- Table type used by Check_Case_Choices procedure 67 68 procedure Sort_Case_Table (Case_Table : in out Case_Table_Type); 69 -- Sort the Case Table using the Lower Bound of each Choice as the key. 70 -- A simple insertion sort is used since the number of choices in a case 71 -- statement of variant part will usually be small and probably in near 72 -- sorted order. 73 74 function Has_Default_Init_Comps (N : Node_Id) return Boolean; 75 -- N is an aggregate (record or array). Checks the presence of default 76 -- initialization (<>) in any component (Ada0Y: AI-287) 77 78 ------------------------------------------------------ 79 -- Local subprograms for Record Aggregate Expansion -- 80 ------------------------------------------------------ 81 82 procedure Expand_Record_Aggregate 83 (N : Node_Id; 84 Orig_Tag : Node_Id := Empty; 85 Parent_Expr : Node_Id := Empty); 86 -- This is the top level procedure for record aggregate expansion. 87 -- Expansion for record aggregates needs expand aggregates for tagged 88 -- record types. Specifically Expand_Record_Aggregate adds the Tag 89 -- field in front of the Component_Association list that was created 90 -- during resolution by Resolve_Record_Aggregate. 91 -- 92 -- N is the record aggregate node. 93 -- Orig_Tag is the value of the Tag that has to be provided for this 94 -- specific aggregate. It carries the tag corresponding to the type 95 -- of the outermost aggregate during the recursive expansion 96 -- Parent_Expr is the ancestor part of the original extension 97 -- aggregate 98 99 procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id); 100 -- N is an N_Aggregate of a N_Extension_Aggregate. Typ is the type of 101 -- the aggregate. Transform the given aggregate into a sequence of 102 -- assignments component per component. 103 104 function Build_Record_Aggr_Code 105 (N : Node_Id; 106 Typ : Entity_Id; 107 Target : Node_Id; 108 Flist : Node_Id := Empty; 109 Obj : Entity_Id := Empty; 110 Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id; 111 -- N is an N_Aggregate or a N_Extension_Aggregate. Typ is the type 112 -- of the aggregate. Target is an expression containing the 113 -- location on which the component by component assignments will 114 -- take place. Returns the list of assignments plus all other 115 -- adjustments needed for tagged and controlled types. Flist is an 116 -- expression representing the finalization list on which to 117 -- attach the controlled components if any. Obj is present in the 118 -- object declaration and dynamic allocation cases, it contains 119 -- an entity that allows to know if the value being created needs to be 120 -- attached to the final list in case of pragma finalize_Storage_Only. 121 -- Is_Limited_Ancestor_Expansion indicates that the function has been 122 -- called recursively to expand the limited ancestor to avoid copying it. 123 124 function Has_Mutable_Components (Typ : Entity_Id) return Boolean; 125 -- Return true if one of the component is of a discriminated type with 126 -- defaults. An aggregate for a type with mutable components must be 127 -- expanded into individual assignments. 128 129 procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id); 130 -- If the type of the aggregate is a type extension with renamed discrimi- 131 -- nants, we must initialize the hidden discriminants of the parent. 132 -- Otherwise, the target object must not be initialized. The discriminants 133 -- are initialized by calling the initialization procedure for the type. 134 -- This is incorrect if the initialization of other components has any 135 -- side effects. We restrict this call to the case where the parent type 136 -- has a variant part, because this is the only case where the hidden 137 -- discriminants are accessed, namely when calling discriminant checking 138 -- functions of the parent type, and when applying a stream attribute to 139 -- an object of the derived type. 140 141 ----------------------------------------------------- 142 -- Local Subprograms for Array Aggregate Expansion -- 143 ----------------------------------------------------- 144 145 procedure Convert_To_Positional 146 (N : Node_Id; 147 Max_Others_Replicate : Nat := 5; 148 Handle_Bit_Packed : Boolean := False); 149 -- If possible, convert named notation to positional notation. This 150 -- conversion is possible only in some static cases. If the conversion 151 -- is possible, then N is rewritten with the analyzed converted 152 -- aggregate. The parameter Max_Others_Replicate controls the maximum 153 -- number of values corresponding to an others choice that will be 154 -- converted to positional notation (the default of 5 is the normal 155 -- limit, and reflects the fact that normally the loop is better than 156 -- a lot of separate assignments). Note that this limit gets overridden 157 -- in any case if either of the restrictions No_Elaboration_Code or 158 -- No_Implicit_Loops is set. The parameter Handle_Bit_Packed is usually 159 -- set False (since we do not expect the back end to handle bit packed 160 -- arrays, so the normal case of conversion is pointless), but in the 161 -- special case of a call from Packed_Array_Aggregate_Handled, we set 162 -- this parameter to True, since these are cases we handle in there. 163 164 procedure Expand_Array_Aggregate (N : Node_Id); 165 -- This is the top-level routine to perform array aggregate expansion. 166 -- N is the N_Aggregate node to be expanded. 167 168 function Backend_Processing_Possible (N : Node_Id) return Boolean; 169 -- This function checks if array aggregate N can be processed directly 170 -- by Gigi. If this is the case True is returned. 171 172 function Build_Array_Aggr_Code 173 (N : Node_Id; 174 Ctype : Entity_Id; 175 Index : Node_Id; 176 Into : Node_Id; 177 Scalar_Comp : Boolean; 178 Indices : List_Id := No_List; 179 Flist : Node_Id := Empty) return List_Id; 180 -- This recursive routine returns a list of statements containing the 181 -- loops and assignments that are needed for the expansion of the array 182 -- aggregate N. 183 -- 184 -- N is the (sub-)aggregate node to be expanded into code. This node 185 -- has been fully analyzed, and its Etype is properly set. 186 -- 187 -- Index is the index node corresponding to the array sub-aggregate N. 188 -- 189 -- Into is the target expression into which we are copying the aggregate. 190 -- Note that this node may not have been analyzed yet, and so the Etype 191 -- field may not be set. 192 -- 193 -- Scalar_Comp is True if the component type of the aggregate is scalar. 194 -- 195 -- Indices is the current list of expressions used to index the 196 -- object we are writing into. 197 -- 198 -- Flist is an expression representing the finalization list on which 199 -- to attach the controlled components if any. 200 201 function Number_Of_Choices (N : Node_Id) return Nat; 202 -- Returns the number of discrete choices (not including the others choice 203 -- if present) contained in (sub-)aggregate N. 204 205 function Late_Expansion 206 (N : Node_Id; 207 Typ : Entity_Id; 208 Target : Node_Id; 209 Flist : Node_Id := Empty; 210 Obj : Entity_Id := Empty) return List_Id; 211 -- N is a nested (record or array) aggregate that has been marked 212 -- with 'Delay_Expansion'. Typ is the expected type of the 213 -- aggregate and Target is a (duplicable) expression that will 214 -- hold the result of the aggregate expansion. Flist is the 215 -- finalization list to be used to attach controlled 216 -- components. 'Obj' when non empty, carries the original object 217 -- being initialized in order to know if it needs to be attached 218 -- to the previous parameter which may not be the case when 219 -- Finalize_Storage_Only is set. Basically this procedure is used 220 -- to implement top-down expansions of nested aggregates. This is 221 -- necessary for avoiding temporaries at each level as well as for 222 -- propagating the right internal finalization list. 223 224 function Make_OK_Assignment_Statement 225 (Sloc : Source_Ptr; 226 Name : Node_Id; 227 Expression : Node_Id) return Node_Id; 228 -- This is like Make_Assignment_Statement, except that Assignment_OK 229 -- is set in the left operand. All assignments built by this unit 230 -- use this routine. This is needed to deal with assignments to 231 -- initialized constants that are done in place. 232 233 function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean; 234 -- Given an array aggregate, this function handles the case of a packed 235 -- array aggregate with all constant values, where the aggregate can be 236 -- evaluated at compile time. If this is possible, then N is rewritten 237 -- to be its proper compile time value with all the components properly 238 -- assembled. The expression is analyzed and resolved and True is 239 -- returned. If this transformation is not possible, N is unchanged 240 -- and False is returned 241 242 function Safe_Slice_Assignment (N : Node_Id) return Boolean; 243 -- If a slice assignment has an aggregate with a single others_choice, 244 -- the assignment can be done in place even if bounds are not static, 245 -- by converting it into a loop over the discrete range of the slice. 246 247 --------------------------------- 248 -- Backend_Processing_Possible -- 249 --------------------------------- 250 251 -- Backend processing by Gigi/gcc is possible only if all the following 252 -- conditions are met: 253 254 -- 1. N is fully positional 255 256 -- 2. N is not a bit-packed array aggregate; 257 258 -- 3. The size of N's array type must be known at compile time. Note 259 -- that this implies that the component size is also known 260 261 -- 4. The array type of N does not follow the Fortran layout convention 262 -- or if it does it must be 1 dimensional. 263 264 -- 5. The array component type is tagged, which may necessitate 265 -- reassignment of proper tags. 266 267 -- 6. The array component type might have unaligned bit components 268 269 function Backend_Processing_Possible (N : Node_Id) return Boolean is 270 Typ : constant Entity_Id := Etype (N); 271 -- Typ is the correct constrained array subtype of the aggregate. 272 273 function Static_Check (N : Node_Id; Index : Node_Id) return Boolean; 274 -- Recursively checks that N is fully positional, returns true if so. 275 276 ------------------ 277 -- Static_Check -- 278 ------------------ 279 280 function Static_Check (N : Node_Id; Index : Node_Id) return Boolean is 281 Expr : Node_Id; 282 283 begin 284 -- Check for component associations 285 286 if Present (Component_Associations (N)) then 287 return False; 288 end if; 289 290 -- Recurse to check subaggregates, which may appear in qualified 291 -- expressions. If delayed, the front-end will have to expand. 292 293 Expr := First (Expressions (N)); 294 295 while Present (Expr) loop 296 297 if Is_Delayed_Aggregate (Expr) then 298 return False; 299 end if; 300 301 if Present (Next_Index (Index)) 302 and then not Static_Check (Expr, Next_Index (Index)) 303 then 304 return False; 305 end if; 306 307 Next (Expr); 308 end loop; 309 310 return True; 311 end Static_Check; 312 313 -- Start of processing for Backend_Processing_Possible 314 315 begin 316 -- Checks 2 (array must not be bit packed) 317 318 if Is_Bit_Packed_Array (Typ) then 319 return False; 320 end if; 321 322 -- Checks 4 (array must not be multi-dimensional Fortran case) 323 324 if Convention (Typ) = Convention_Fortran 325 and then Number_Dimensions (Typ) > 1 326 then 327 return False; 328 end if; 329 330 -- Checks 3 (size of array must be known at compile time) 331 332 if not Size_Known_At_Compile_Time (Typ) then 333 return False; 334 end if; 335 336 -- Checks 1 (aggregate must be fully positional) 337 338 if not Static_Check (N, First_Index (Typ)) then 339 return False; 340 end if; 341 342 -- Checks 5 (if the component type is tagged, then we may need 343 -- to do tag adjustments; perhaps this should be refined to 344 -- check for any component associations that actually 345 -- need tag adjustment, along the lines of the test that's 346 -- done in Has_Delayed_Nested_Aggregate_Or_Tagged_Comps 347 -- for record aggregates with tagged components, but not 348 -- clear whether it's worthwhile ???; in the case of the 349 -- JVM, object tags are handled implicitly) 350 351 if Is_Tagged_Type (Component_Type (Typ)) and then not Java_VM then 352 return False; 353 end if; 354 355 -- Checks 6 (component type must not have bit aligned components) 356 357 if Type_May_Have_Bit_Aligned_Components (Component_Type (Typ)) then 358 return False; 359 end if; 360 361 -- Backend processing is possible 362 363 Set_Compile_Time_Known_Aggregate (N, True); 364 Set_Size_Known_At_Compile_Time (Etype (N), True); 365 return True; 366 end Backend_Processing_Possible; 367 368 --------------------------- 369 -- Build_Array_Aggr_Code -- 370 --------------------------- 371 372 -- The code that we generate from a one dimensional aggregate is 373 374 -- 1. If the sub-aggregate contains discrete choices we 375 376 -- (a) Sort the discrete choices 377 378 -- (b) Otherwise for each discrete choice that specifies a range we 379 -- emit a loop. If a range specifies a maximum of three values, or 380 -- we are dealing with an expression we emit a sequence of 381 -- assignments instead of a loop. 382 383 -- (c) Generate the remaining loops to cover the others choice if any. 384 385 -- 2. If the aggregate contains positional elements we 386 387 -- (a) translate the positional elements in a series of assignments. 388 389 -- (b) Generate a final loop to cover the others choice if any. 390 -- Note that this final loop has to be a while loop since the case 391 392 -- L : Integer := Integer'Last; 393 -- H : Integer := Integer'Last; 394 -- A : array (L .. H) := (1, others =>0); 395 396 -- cannot be handled by a for loop. Thus for the following 397 398 -- array (L .. H) := (.. positional elements.., others =>E); 399 400 -- we always generate something like: 401 402 -- J : Index_Type := Index_Of_Last_Positional_Element; 403 -- while J < H loop 404 -- J := Index_Base'Succ (J) 405 -- Tmp (J) := E; 406 -- end loop; 407 408 function Build_Array_Aggr_Code 409 (N : Node_Id; 410 Ctype : Entity_Id; 411 Index : Node_Id; 412 Into : Node_Id; 413 Scalar_Comp : Boolean; 414 Indices : List_Id := No_List; 415 Flist : Node_Id := Empty) return List_Id 416 is 417 Loc : constant Source_Ptr := Sloc (N); 418 Index_Base : constant Entity_Id := Base_Type (Etype (Index)); 419 Index_Base_L : constant Node_Id := Type_Low_Bound (Index_Base); 420 Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base); 421 422 function Add (Val : Int; To : Node_Id) return Node_Id; 423 -- Returns an expression where Val is added to expression To, 424 -- unless To+Val is provably out of To's base type range. 425 -- To must be an already analyzed expression. 426 427 function Empty_Range (L, H : Node_Id) return Boolean; 428 -- Returns True if the range defined by L .. H is certainly empty. 429 430 function Equal (L, H : Node_Id) return Boolean; 431 -- Returns True if L = H for sure. 432 433 function Index_Base_Name return Node_Id; 434 -- Returns a new reference to the index type name. 435 436 function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id; 437 -- Ind must be a side-effect free expression. If the input aggregate 438 -- N to Build_Loop contains no sub-aggregates, then this function 439 -- returns the assignment statement: 440 -- 441 -- Into (Indices, Ind) := Expr; 442 -- 443 -- Otherwise we call Build_Code recursively. 444 -- 445 -- Ada0Y (AI-287): In case of default initialized component, Expr is 446 -- empty and we generate a call to the corresponding IP subprogram. 447 448 function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id; 449 -- Nodes L and H must be side-effect free expressions. 450 -- If the input aggregate N to Build_Loop contains no sub-aggregates, 451 -- This routine returns the for loop statement 452 -- 453 -- for J in Index_Base'(L) .. Index_Base'(H) loop 454 -- Into (Indices, J) := Expr; 455 -- end loop; 456 -- 457 -- Otherwise we call Build_Code recursively. 458 -- As an optimization if the loop covers 3 or less scalar elements we 459 -- generate a sequence of assignments. 460 461 function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id; 462 -- Nodes L and H must be side-effect free expressions. 463 -- If the input aggregate N to Build_Loop contains no sub-aggregates, 464 -- This routine returns the while loop statement 465 -- 466 -- J : Index_Base := L; 467 -- while J < H loop 468 -- J := Index_Base'Succ (J); 469 -- Into (Indices, J) := Expr; 470 -- end loop; 471 -- 472 -- Otherwise we call Build_Code recursively 473 474 function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean; 475 function Local_Expr_Value (E : Node_Id) return Uint; 476 -- These two Local routines are used to replace the corresponding ones 477 -- in sem_eval because while processing the bounds of an aggregate with 478 -- discrete choices whose index type is an enumeration, we build static 479 -- expressions not recognized by Compile_Time_Known_Value as such since 480 -- they have not yet been analyzed and resolved. All the expressions in 481 -- question are things like Index_Base_Name'Val (Const) which we can 482 -- easily recognize as being constant. 483 484 --------- 485 -- Add -- 486 --------- 487 488 function Add (Val : Int; To : Node_Id) return Node_Id is 489 Expr_Pos : Node_Id; 490 Expr : Node_Id; 491 To_Pos : Node_Id; 492 U_To : Uint; 493 U_Val : constant Uint := UI_From_Int (Val); 494 495 begin 496 -- Note: do not try to optimize the case of Val = 0, because 497 -- we need to build a new node with the proper Sloc value anyway. 498 499 -- First test if we can do constant folding 500 501 if Local_Compile_Time_Known_Value (To) then 502 U_To := Local_Expr_Value (To) + Val; 503 504 -- Determine if our constant is outside the range of the index. 505 -- If so return an Empty node. This empty node will be caught 506 -- by Empty_Range below. 507 508 if Compile_Time_Known_Value (Index_Base_L) 509 and then U_To < Expr_Value (Index_Base_L) 510 then 511 return Empty; 512 513 elsif Compile_Time_Known_Value (Index_Base_H) 514 and then U_To > Expr_Value (Index_Base_H) 515 then 516 return Empty; 517 end if; 518 519 Expr_Pos := Make_Integer_Literal (Loc, U_To); 520 Set_Is_Static_Expression (Expr_Pos); 521 522 if not Is_Enumeration_Type (Index_Base) then 523 Expr := Expr_Pos; 524 525 -- If we are dealing with enumeration return 526 -- Index_Base'Val (Expr_Pos) 527 528 else 529 Expr := 530 Make_Attribute_Reference 531 (Loc, 532 Prefix => Index_Base_Name, 533 Attribute_Name => Name_Val, 534 Expressions => New_List (Expr_Pos)); 535 end if; 536 537 return Expr; 538 end if; 539 540 -- If we are here no constant folding possible 541 542 if not Is_Enumeration_Type (Index_Base) then 543 Expr := 544 Make_Op_Add (Loc, 545 Left_Opnd => Duplicate_Subexpr (To), 546 Right_Opnd => Make_Integer_Literal (Loc, U_Val)); 547 548 -- If we are dealing with enumeration return 549 -- Index_Base'Val (Index_Base'Pos (To) + Val) 550 551 else 552 To_Pos := 553 Make_Attribute_Reference 554 (Loc, 555 Prefix => Index_Base_Name, 556 Attribute_Name => Name_Pos, 557 Expressions => New_List (Duplicate_Subexpr (To))); 558 559 Expr_Pos := 560 Make_Op_Add (Loc, 561 Left_Opnd => To_Pos, 562 Right_Opnd => Make_Integer_Literal (Loc, U_Val)); 563 564 Expr := 565 Make_Attribute_Reference 566 (Loc, 567 Prefix => Index_Base_Name, 568 Attribute_Name => Name_Val, 569 Expressions => New_List (Expr_Pos)); 570 end if; 571 572 return Expr; 573 end Add; 574 575 ----------------- 576 -- Empty_Range -- 577 ----------------- 578 579 function Empty_Range (L, H : Node_Id) return Boolean is 580 Is_Empty : Boolean := False; 581 Low : Node_Id; 582 High : Node_Id; 583 584 begin 585 -- First check if L or H were already detected as overflowing the 586 -- index base range type by function Add above. If this is so Add 587 -- returns the empty node. 588 589 if No (L) or else No (H) then 590 return True; 591 end if; 592 593 for J in 1 .. 3 loop 594 case J is 595 596 -- L > H range is empty 597 598 when 1 => 599 Low := L; 600 High := H; 601 602 -- B_L > H range must be empty 603 604 when 2 => 605 Low := Index_Base_L; 606 High := H; 607 608 -- L > B_H range must be empty 609 610 when 3 => 611 Low := L; 612 High := Index_Base_H; 613 end case; 614 615 if Local_Compile_Time_Known_Value (Low) 616 and then Local_Compile_Time_Known_Value (High) 617 then 618 Is_Empty := 619 UI_Gt (Local_Expr_Value (Low), Local_Expr_Value (High)); 620 end if; 621 622 exit when Is_Empty; 623 end loop; 624 625 return Is_Empty; 626 end Empty_Range; 627 628 ----------- 629 -- Equal -- 630 ----------- 631 632 function Equal (L, H : Node_Id) return Boolean is 633 begin 634 if L = H then 635 return True; 636 637 elsif Local_Compile_Time_Known_Value (L) 638 and then Local_Compile_Time_Known_Value (H) 639 then 640 return UI_Eq (Local_Expr_Value (L), Local_Expr_Value (H)); 641 end if; 642 643 return False; 644 end Equal; 645 646 ---------------- 647 -- Gen_Assign -- 648 ---------------- 649 650 function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is 651 L : constant List_Id := New_List; 652 F : Entity_Id; 653 A : Node_Id; 654 655 New_Indices : List_Id; 656 Indexed_Comp : Node_Id; 657 Expr_Q : Node_Id; 658 Comp_Type : Entity_Id := Empty; 659 660 function Add_Loop_Actions (Lis : List_Id) return List_Id; 661 -- Collect insert_actions generated in the construction of a 662 -- loop, and prepend them to the sequence of assignments to 663 -- complete the eventual body of the loop. 664 665 ---------------------- 666 -- Add_Loop_Actions -- 667 ---------------------- 668 669 function Add_Loop_Actions (Lis : List_Id) return List_Id is 670 Res : List_Id; 671 672 begin 673 -- Ada0Y (AI-287): Do nothing else in case of default initialized 674 -- component 675 676 if not Present (Expr) then 677 return Lis; 678 679 elsif Nkind (Parent (Expr)) = N_Component_Association 680 and then Present (Loop_Actions (Parent (Expr))) 681 then 682 Append_List (Lis, Loop_Actions (Parent (Expr))); 683 Res := Loop_Actions (Parent (Expr)); 684 Set_Loop_Actions (Parent (Expr), No_List); 685 return Res; 686 687 else 688 return Lis; 689 end if; 690 end Add_Loop_Actions; 691 692 -- Start of processing for Gen_Assign 693 694 begin 695 if No (Indices) then 696 New_Indices := New_List; 697 else 698 New_Indices := New_Copy_List_Tree (Indices); 699 end if; 700 701 Append_To (New_Indices, Ind); 702 703 if Present (Flist) then 704 F := New_Copy_Tree (Flist); 705 706 elsif Present (Etype (N)) and then Controlled_Type (Etype (N)) then 707 if Is_Entity_Name (Into) 708 and then Present (Scope (Entity (Into))) 709 then 710 F := Find_Final_List (Scope (Entity (Into))); 711 else 712 F := Find_Final_List (Current_Scope); 713 end if; 714 else 715 F := Empty; 716 end if; 717 718 if Present (Next_Index (Index)) then 719 return 720 Add_Loop_Actions ( 721 Build_Array_Aggr_Code 722 (N => Expr, 723 Ctype => Ctype, 724 Index => Next_Index (Index), 725 Into => Into, 726 Scalar_Comp => Scalar_Comp, 727 Indices => New_Indices, 728 Flist => F)); 729 end if; 730 731 -- If we get here then we are at a bottom-level (sub-)aggregate 732 733 Indexed_Comp := 734 Checks_Off 735 (Make_Indexed_Component (Loc, 736 Prefix => New_Copy_Tree (Into), 737 Expressions => New_Indices)); 738 739 Set_Assignment_OK (Indexed_Comp); 740 741 -- Ada0Y (AI-287): In case of default initialized component, Expr 742 -- is not present (and therefore we also initialize Expr_Q to empty) 743 744 if not Present (Expr) then 745 Expr_Q := Empty; 746 elsif Nkind (Expr) = N_Qualified_Expression then 747 Expr_Q := Expression (Expr); 748 else 749 Expr_Q := Expr; 750 end if; 751 752 if Present (Etype (N)) 753 and then Etype (N) /= Any_Composite 754 then 755 Comp_Type := Component_Type (Etype (N)); 756 pragma Assert (Comp_Type = Ctype); -- AI-287 757 758 elsif Present (Next (First (New_Indices))) then 759 760 -- Ada0Y (AI-287): Do nothing in case of default initialized 761 -- component because we have received the component type in 762 -- the formal parameter Ctype. 763 -- ??? I have added some assert pragmas to check if this new 764 -- formal can be used to replace this code in all cases. 765 766 if Present (Expr) then 767 768 -- This is a multidimensional array. Recover the component 769 -- type from the outermost aggregate, because subaggregates 770 -- do not have an assigned type. 771 772 declare 773 P : Node_Id := Parent (Expr); 774 775 begin 776 while Present (P) loop 777 778 if Nkind (P) = N_Aggregate 779 and then Present (Etype (P)) 780 then 781 Comp_Type := Component_Type (Etype (P)); 782 exit; 783 784 else 785 P := Parent (P); 786 end if; 787 end loop; 788 pragma Assert (Comp_Type = Ctype); -- AI-287 789 end; 790 end if; 791 end if; 792 793 -- Ada0Y (AI-287): We only analyze the expression in case of non 794 -- default initialized components (otherwise Expr_Q is not present) 795 796 if Present (Expr_Q) 797 and then (Nkind (Expr_Q) = N_Aggregate 798 or else Nkind (Expr_Q) = N_Extension_Aggregate) 799 then 800 -- At this stage the Expression may not have been 801 -- analyzed yet because the array aggregate code has not 802 -- been updated to use the Expansion_Delayed flag and 803 -- avoid analysis altogether to solve the same problem 804 -- (see Resolve_Aggr_Expr) so let's do the analysis of 805 -- non-array aggregates now in order to get the value of 806 -- Expansion_Delayed flag for the inner aggregate ??? 807 808 if Present (Comp_Type) and then not Is_Array_Type (Comp_Type) then 809 Analyze_And_Resolve (Expr_Q, Comp_Type); 810 end if; 811 812 if Is_Delayed_Aggregate (Expr_Q) then 813 return 814 Add_Loop_Actions ( 815 Late_Expansion (Expr_Q, Etype (Expr_Q), Indexed_Comp, F)); 816 end if; 817 end if; 818 819 -- Ada0Y (AI-287): In case of default initialized component, call 820 -- the initialization subprogram associated with the component type 821 822 if not Present (Expr) then 823 824 Append_List_To (L, 825 Build_Initialization_Call (Loc, 826 Id_Ref => Indexed_Comp, 827 Typ => Ctype, 828 With_Default_Init => True)); 829 830 else 831 832 -- Now generate the assignment with no associated controlled 833 -- actions since the target of the assignment may not have 834 -- been initialized, it is not possible to Finalize it as 835 -- expected by normal controlled assignment. The rest of the 836 -- controlled actions are done manually with the proper 837 -- finalization list coming from the context. 838 839 A := 840 Make_OK_Assignment_Statement (Loc, 841 Name => Indexed_Comp, 842 Expression => New_Copy_Tree (Expr)); 843 844 if Present (Comp_Type) and then Controlled_Type (Comp_Type) then 845 Set_No_Ctrl_Actions (A); 846 end if; 847 848 Append_To (L, A); 849 850 -- Adjust the tag if tagged (because of possible view 851 -- conversions), unless compiling for the Java VM 852 -- where tags are implicit. 853 854 if Present (Comp_Type) 855 and then Is_Tagged_Type (Comp_Type) 856 and then not Java_VM 857 then 858 A := 859 Make_OK_Assignment_Statement (Loc, 860 Name => 861 Make_Selected_Component (Loc, 862 Prefix => New_Copy_Tree (Indexed_Comp), 863 Selector_Name => 864 New_Reference_To (Tag_Component (Comp_Type), Loc)), 865 866 Expression => 867 Unchecked_Convert_To (RTE (RE_Tag), 868 New_Reference_To ( 869 Access_Disp_Table (Comp_Type), Loc))); 870 871 Append_To (L, A); 872 end if; 873 874 -- Adjust and Attach the component to the proper final list 875 -- which can be the controller of the outer record object or 876 -- the final list associated with the scope 877 878 if Present (Comp_Type) and then Controlled_Type (Comp_Type) then 879 Append_List_To (L, 880 Make_Adjust_Call ( 881 Ref => New_Copy_Tree (Indexed_Comp), 882 Typ => Comp_Type, 883 Flist_Ref => F, 884 With_Attach => Make_Integer_Literal (Loc, 1))); 885 end if; 886 end if; 887 888 return Add_Loop_Actions (L); 889 end Gen_Assign; 890 891 -------------- 892 -- Gen_Loop -- 893 -------------- 894 895 function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is 896 L_J : Node_Id; 897 898 L_Range : Node_Id; 899 -- Index_Base'(L) .. Index_Base'(H) 900 901 L_Iteration_Scheme : Node_Id; 902 -- L_J in Index_Base'(L) .. Index_Base'(H) 903 904 L_Body : List_Id; 905 -- The statements to execute in the loop 906 907 S : constant List_Id := New_List; 908 -- List of statements 909 910 Tcopy : Node_Id; 911 -- Copy of expression tree, used for checking purposes 912 913 begin 914 -- If loop bounds define an empty range return the null statement 915 916 if Empty_Range (L, H) then 917 Append_To (S, Make_Null_Statement (Loc)); 918 919 -- Ada0Y (AI-287): Nothing else need to be done in case of 920 -- default initialized component 921 922 if not Present (Expr) then 923 null; 924 925 else 926 -- The expression must be type-checked even though no component 927 -- of the aggregate will have this value. This is done only for 928 -- actual components of the array, not for subaggregates. Do 929 -- the check on a copy, because the expression may be shared 930 -- among several choices, some of which might be non-null. 931 932 if Present (Etype (N)) 933 and then Is_Array_Type (Etype (N)) 934 and then No (Next_Index (Index)) 935 then 936 Expander_Mode_Save_And_Set (False); 937 Tcopy := New_Copy_Tree (Expr); 938 Set_Parent (Tcopy, N); 939 Analyze_And_Resolve (Tcopy, Component_Type (Etype (N))); 940 Expander_Mode_Restore; 941 end if; 942 end if; 943 944 return S; 945 946 -- If loop bounds are the same then generate an assignment 947 948 elsif Equal (L, H) then 949 return Gen_Assign (New_Copy_Tree (L), Expr); 950 951 -- If H - L <= 2 then generate a sequence of assignments 952 -- when we are processing the bottom most aggregate and it contains 953 -- scalar components. 954 955 elsif No (Next_Index (Index)) 956 and then Scalar_Comp 957 and then Local_Compile_Time_Known_Value (L) 958 and then Local_Compile_Time_Known_Value (H) 959 and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2 960 then 961 962 Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr)); 963 Append_List_To (S, Gen_Assign (Add (1, To => L), Expr)); 964 965 if Local_Expr_Value (H) - Local_Expr_Value (L) = 2 then 966 Append_List_To (S, Gen_Assign (Add (2, To => L), Expr)); 967 end if; 968 969 return S; 970 end if; 971 972 -- Otherwise construct the loop, starting with the loop index L_J 973 974 L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); 975 976 -- Construct "L .. H" 977 978 L_Range := 979 Make_Range 980 (Loc, 981 Low_Bound => Make_Qualified_Expression 982 (Loc, 983 Subtype_Mark => Index_Base_Name, 984 Expression => L), 985 High_Bound => Make_Qualified_Expression 986 (Loc, 987 Subtype_Mark => Index_Base_Name, 988 Expression => H)); 989 990 -- Construct "for L_J in Index_Base range L .. H" 991 992 L_Iteration_Scheme := 993 Make_Iteration_Scheme 994 (Loc, 995 Loop_Parameter_Specification => 996 Make_Loop_Parameter_Specification 997 (Loc, 998 Defining_Identifier => L_J, 999 Discrete_Subtype_Definition => L_Range)); 1000 1001 -- Construct the statements to execute in the loop body 1002 1003 L_Body := Gen_Assign (New_Reference_To (L_J, Loc), Expr); 1004 1005 -- Construct the final loop 1006 1007 Append_To (S, Make_Implicit_Loop_Statement 1008 (Node => N, 1009 Identifier => Empty, 1010 Iteration_Scheme => L_Iteration_Scheme, 1011 Statements => L_Body)); 1012 1013 return S; 1014 end Gen_Loop; 1015 1016 --------------- 1017 -- Gen_While -- 1018 --------------- 1019 1020 -- The code built is 1021 1022 -- W_J : Index_Base := L; 1023 -- while W_J < H loop 1024 -- W_J := Index_Base'Succ (W); 1025 -- L_Body; 1026 -- end loop; 1027 1028 function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id is 1029 W_J : Node_Id; 1030 1031 W_Decl : Node_Id; 1032 -- W_J : Base_Type := L; 1033 1034 W_Iteration_Scheme : Node_Id; 1035 -- while W_J < H 1036 1037 W_Index_Succ : Node_Id; 1038 -- Index_Base'Succ (J) 1039 1040 W_Increment : Node_Id; 1041 -- W_J := Index_Base'Succ (W) 1042 1043 W_Body : constant List_Id := New_List; 1044 -- The statements to execute in the loop 1045 1046 S : constant List_Id := New_List; 1047 -- list of statement 1048 1049 begin 1050 -- If loop bounds define an empty range or are equal return null 1051 1052 if Empty_Range (L, H) or else Equal (L, H) then 1053 Append_To (S, Make_Null_Statement (Loc)); 1054 return S; 1055 end if; 1056 1057 -- Build the decl of W_J 1058 1059 W_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); 1060 W_Decl := 1061 Make_Object_Declaration 1062 (Loc, 1063 Defining_Identifier => W_J, 1064 Object_Definition => Index_Base_Name, 1065 Expression => L); 1066 1067 -- Theoretically we should do a New_Copy_Tree (L) here, but we know 1068 -- that in this particular case L is a fresh Expr generated by 1069 -- Add which we are the only ones to use. 1070 1071 Append_To (S, W_Decl); 1072 1073 -- Construct " while W_J < H" 1074 1075 W_Iteration_Scheme := 1076 Make_Iteration_Scheme 1077 (Loc, 1078 Condition => Make_Op_Lt 1079 (Loc, 1080 Left_Opnd => New_Reference_To (W_J, Loc), 1081 Right_Opnd => New_Copy_Tree (H))); 1082 1083 -- Construct the statements to execute in the loop body 1084 1085 W_Index_Succ := 1086 Make_Attribute_Reference 1087 (Loc, 1088 Prefix => Index_Base_Name, 1089 Attribute_Name => Name_Succ, 1090 Expressions => New_List (New_Reference_To (W_J, Loc))); 1091 1092 W_Increment := 1093 Make_OK_Assignment_Statement 1094 (Loc, 1095 Name => New_Reference_To (W_J, Loc), 1096 Expression => W_Index_Succ); 1097 1098 Append_To (W_Body, W_Increment); 1099 Append_List_To (W_Body, 1100 Gen_Assign (New_Reference_To (W_J, Loc), Expr)); 1101 1102 -- Construct the final loop 1103 1104 Append_To (S, Make_Implicit_Loop_Statement 1105 (Node => N, 1106 Identifier => Empty, 1107 Iteration_Scheme => W_Iteration_Scheme, 1108 Statements => W_Body)); 1109 1110 return S; 1111 end Gen_While; 1112 1113 --------------------- 1114 -- Index_Base_Name -- 1115 --------------------- 1116 1117 function Index_Base_Name return Node_Id is 1118 begin 1119 return New_Reference_To (Index_Base, Sloc (N)); 1120 end Index_Base_Name; 1121 1122 ------------------------------------ 1123 -- Local_Compile_Time_Known_Value -- 1124 ------------------------------------ 1125 1126 function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean is 1127 begin 1128 return Compile_Time_Known_Value (E) 1129 or else 1130 (Nkind (E) = N_Attribute_Reference 1131 and then Attribute_Name (E) = Name_Val 1132 and then Compile_Time_Known_Value (First (Expressions (E)))); 1133 end Local_Compile_Time_Known_Value; 1134 1135 ---------------------- 1136 -- Local_Expr_Value -- 1137 ---------------------- 1138 1139 function Local_Expr_Value (E : Node_Id) return Uint is 1140 begin 1141 if Compile_Time_Known_Value (E) then 1142 return Expr_Value (E); 1143 else 1144 return Expr_Value (First (Expressions (E))); 1145 end if; 1146 end Local_Expr_Value; 1147 1148 -- Build_Array_Aggr_Code Variables 1149 1150 Assoc : Node_Id; 1151 Choice : Node_Id; 1152 Expr : Node_Id; 1153 Typ : Entity_Id; 1154 1155 Others_Expr : Node_Id := Empty; 1156 Others_Mbox_Present : Boolean := False; 1157 1158 Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N)); 1159 Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N)); 1160 -- The aggregate bounds of this specific sub-aggregate. Note that if 1161 -- the code generated by Build_Array_Aggr_Code is executed then these 1162 -- bounds are OK. Otherwise a Constraint_Error would have been raised. 1163 1164 Aggr_Low : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_L); 1165 Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H); 1166 -- After Duplicate_Subexpr these are side-effect free. 1167 1168 Low : Node_Id; 1169 High : Node_Id; 1170 1171 Nb_Choices : Nat := 0; 1172 Table : Case_Table_Type (1 .. Number_Of_Choices (N)); 1173 -- Used to sort all the different choice values 1174 1175 Nb_Elements : Int; 1176 -- Number of elements in the positional aggregate 1177 1178 New_Code : constant List_Id := New_List; 1179 1180 -- Start of processing for Build_Array_Aggr_Code 1181 1182 begin 1183 -- First before we start, a special case. if we have a bit packed 1184 -- array represented as a modular type, then clear the value to 1185 -- zero first, to ensure that unused bits are properly cleared. 1186 1187 Typ := Etype (N); 1188 1189 if Present (Typ) 1190 and then Is_Bit_Packed_Array (Typ) 1191 and then Is_Modular_Integer_Type (Packed_Array_Type (Typ)) 1192 then 1193 Append_To (New_Code, 1194 Make_Assignment_Statement (Loc, 1195 Name => New_Copy_Tree (Into), 1196 Expression => 1197 Unchecked_Convert_To (Typ, 1198 Make_Integer_Literal (Loc, Uint_0)))); 1199 end if; 1200 1201 -- We can skip this 1202 -- STEP 1: Process component associations 1203 -- For those associations that may generate a loop, initialize 1204 -- Loop_Actions to collect inserted actions that may be crated. 1205 1206 if No (Expressions (N)) then 1207 1208 -- STEP 1 (a): Sort the discrete choices 1209 1210 Assoc := First (Component_Associations (N)); 1211 while Present (Assoc) loop 1212 Choice := First (Choices (Assoc)); 1213 while Present (Choice) loop 1214 if Nkind (Choice) = N_Others_Choice then 1215 Set_Loop_Actions (Assoc, New_List); 1216 1217 if Box_Present (Assoc) then 1218 Others_Mbox_Present := True; 1219 else 1220 Others_Expr := Expression (Assoc); 1221 end if; 1222 exit; 1223 end if; 1224 1225 Get_Index_Bounds (Choice, Low, High); 1226 1227 if Low /= High then 1228 Set_Loop_Actions (Assoc, New_List); 1229 end if; 1230 1231 Nb_Choices := Nb_Choices + 1; 1232 if Box_Present (Assoc) then 1233 Table (Nb_Choices) := (Choice_Lo => Low, 1234 Choice_Hi => High, 1235 Choice_Node => Empty); 1236 else 1237 Table (Nb_Choices) := (Choice_Lo => Low, 1238 Choice_Hi => High, 1239 Choice_Node => Expression (Assoc)); 1240 end if; 1241 Next (Choice); 1242 end loop; 1243 1244 Next (Assoc); 1245 end loop; 1246 1247 -- If there is more than one set of choices these must be static 1248 -- and we can therefore sort them. Remember that Nb_Choices does not 1249 -- account for an others choice. 1250 1251 if Nb_Choices > 1 then 1252 Sort_Case_Table (Table); 1253 end if; 1254 1255 -- STEP 1 (b): take care of the whole set of discrete choices. 1256 1257 for J in 1 .. Nb_Choices loop 1258 Low := Table (J).Choice_Lo; 1259 High := Table (J).Choice_Hi; 1260 Expr := Table (J).Choice_Node; 1261 Append_List (Gen_Loop (Low, High, Expr), To => New_Code); 1262 end loop; 1263 1264 -- STEP 1 (c): generate the remaining loops to cover others choice 1265 -- We don't need to generate loops over empty gaps, but if there is 1266 -- a single empty range we must analyze the expression for semantics 1267 1268 if Present (Others_Expr) or else Others_Mbox_Present then 1269 declare 1270 First : Boolean := True; 1271 1272 begin 1273 for J in 0 .. Nb_Choices loop 1274 if J = 0 then 1275 Low := Aggr_Low; 1276 else 1277 Low := Add (1, To => Table (J).Choice_Hi); 1278 end if; 1279 1280 if J = Nb_Choices then 1281 High := Aggr_High; 1282 else 1283 High := Add (-1, To => Table (J + 1).Choice_Lo); 1284 end if; 1285 1286 -- If this is an expansion within an init proc, make 1287 -- sure that discriminant references are replaced by 1288 -- the corresponding discriminal. 1289 1290 if Inside_Init_Proc then 1291 if Is_Entity_Name (Low) 1292 and then Ekind (Entity (Low)) = E_Discriminant 1293 then 1294 Set_Entity (Low, Discriminal (Entity (Low))); 1295 end if; 1296 1297 if Is_Entity_Name (High) 1298 and then Ekind (Entity (High)) = E_Discriminant 1299 then 1300 Set_Entity (High, Discriminal (Entity (High))); 1301 end if; 1302 end if; 1303 1304 if First 1305 or else not Empty_Range (Low, High) 1306 then 1307 First := False; 1308 Append_List 1309 (Gen_Loop (Low, High, Others_Expr), To => New_Code); 1310 end if; 1311 end loop; 1312 end; 1313 end if; 1314 1315 -- STEP 2: Process positional components 1316 1317 else 1318 -- STEP 2 (a): Generate the assignments for each positional element 1319 -- Note that here we have to use Aggr_L rather than Aggr_Low because 1320 -- Aggr_L is analyzed and Add wants an analyzed expression. 1321 1322 Expr := First (Expressions (N)); 1323 Nb_Elements := -1; 1324 1325 while Present (Expr) loop 1326 Nb_Elements := Nb_Elements + 1; 1327 Append_List (Gen_Assign (Add (Nb_Elements, To => Aggr_L), Expr), 1328 To => New_Code); 1329 Next (Expr); 1330 end loop; 1331 1332 -- STEP 2 (b): Generate final loop if an others choice is present 1333 -- Here Nb_Elements gives the offset of the last positional element. 1334 1335 if Present (Component_Associations (N)) then 1336 Assoc := Last (Component_Associations (N)); 1337 1338 -- Ada0Y (AI-287) 1339 if Box_Present (Assoc) then 1340 Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L), 1341 Aggr_High, 1342 Empty), 1343 To => New_Code); 1344 else 1345 Expr := Expression (Assoc); 1346 1347 Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L), 1348 Aggr_High, 1349 Expr), -- AI-287 1350 To => New_Code); 1351 end if; 1352 end if; 1353 end if; 1354 1355 return New_Code; 1356 end Build_Array_Aggr_Code; 1357 1358 ---------------------------- 1359 -- Build_Record_Aggr_Code -- 1360 ---------------------------- 1361 1362 function Build_Record_Aggr_Code 1363 (N : Node_Id; 1364 Typ : Entity_Id; 1365 Target : Node_Id; 1366 Flist : Node_Id := Empty; 1367 Obj : Entity_Id := Empty; 1368 Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id 1369 is 1370 Loc : constant Source_Ptr := Sloc (N); 1371 L : constant List_Id := New_List; 1372 Start_L : constant List_Id := New_List; 1373 N_Typ : constant Entity_Id := Etype (N); 1374 1375 Comp : Node_Id; 1376 Instr : Node_Id; 1377 Ref : Node_Id; 1378 F : Node_Id; 1379 Comp_Type : Entity_Id; 1380 Selector : Entity_Id; 1381 Comp_Expr : Node_Id; 1382 Expr_Q : Node_Id; 1383 1384 Internal_Final_List : Node_Id; 1385 1386 -- If this is an internal aggregate, the External_Final_List is an 1387 -- expression for the controller record of the enclosing type. 1388 -- If the current aggregate has several controlled components, this 1389 -- expression will appear in several calls to attach to the finali- 1390 -- zation list, and it must not be shared. 1391 1392 External_Final_List : Node_Id; 1393 Ancestor_Is_Expression : Boolean := False; 1394 Ancestor_Is_Subtype_Mark : Boolean := False; 1395 1396 Init_Typ : Entity_Id := Empty; 1397 Attach : Node_Id; 1398 1399 function Get_Constraint_Association (T : Entity_Id) return Node_Id; 1400 -- Returns the first discriminant association in the constraint 1401 -- associated with T, if any, otherwise returns Empty. 1402 1403 function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id; 1404 -- Returns the value that the given discriminant of an ancestor 1405 -- type should receive (in the absence of a conflict with the 1406 -- value provided by an ancestor part of an extension aggregate). 1407 1408 procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id); 1409 -- Check that each of the discriminant values defined by the 1410 -- ancestor part of an extension aggregate match the corresponding 1411 -- values provided by either an association of the aggregate or 1412 -- by the constraint imposed by a parent type (RM95-4.3.2(8)). 1413 1414 function Init_Controller 1415 (Target : Node_Id; 1416 Typ : Entity_Id; 1417 F : Node_Id; 1418 Attach : Node_Id; 1419 Init_Pr : Boolean) return List_Id; 1420 -- returns the list of statements necessary to initialize the internal 1421 -- controller of the (possible) ancestor typ into target and attach 1422 -- it to finalization list F. Init_Pr conditions the call to the 1423 -- init proc since it may already be done due to ancestor initialization 1424 1425 --------------------------------- 1426 -- Ancestor_Discriminant_Value -- 1427 --------------------------------- 1428 1429 function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id is 1430 Assoc : Node_Id; 1431 Assoc_Elmt : Elmt_Id; 1432 Aggr_Comp : Entity_Id; 1433 Corresp_Disc : Entity_Id; 1434 Current_Typ : Entity_Id := Base_Type (Typ); 1435 Parent_Typ : Entity_Id; 1436 Parent_Disc : Entity_Id; 1437 Save_Assoc : Node_Id := Empty; 1438 1439 begin 1440 -- First check any discriminant associations to see if 1441 -- any of them provide a value for the discriminant. 1442 1443 if Present (Discriminant_Specifications (Parent (Current_Typ))) then 1444 Assoc := First (Component_Associations (N)); 1445 while Present (Assoc) loop 1446 Aggr_Comp := Entity (First (Choices (Assoc))); 1447 1448 if Ekind (Aggr_Comp) = E_Discriminant then 1449 Save_Assoc := Expression (Assoc); 1450 1451 Corresp_Disc := Corresponding_Discriminant (Aggr_Comp); 1452 while Present (Corresp_Disc) loop 1453 -- If found a corresponding discriminant then return 1454 -- the value given in the aggregate. (Note: this is 1455 -- not correct in the presence of side effects. ???) 1456 1457 if Disc = Corresp_Disc then 1458 return Duplicate_Subexpr (Expression (Assoc)); 1459 end if; 1460 1461 Corresp_Disc := 1462 Corresponding_Discriminant (Corresp_Disc); 1463 end loop; 1464 end if; 1465 1466 Next (Assoc); 1467 end loop; 1468 end if; 1469 1470 -- No match found in aggregate, so chain up parent types to find 1471 -- a constraint that defines the value of the discriminant. 1472 1473 Parent_Typ := Etype (Current_Typ); 1474 while Current_Typ /= Parent_Typ loop 1475 if Has_Discriminants (Parent_Typ) then 1476 Parent_Disc := First_Discriminant (Parent_Typ); 1477 1478 -- We either get the association from the subtype indication 1479 -- of the type definition itself, or from the discriminant 1480 -- constraint associated with the type entity (which is 1481 -- preferable, but it's not always present ???) 1482 1483 if Is_Empty_Elmt_List ( 1484 Discriminant_Constraint (Current_Typ)) 1485 then 1486 Assoc := Get_Constraint_Association (Current_Typ); 1487 Assoc_Elmt := No_Elmt; 1488 else 1489 Assoc_Elmt := 1490 First_Elmt (Discriminant_Constraint (Current_Typ)); 1491 Assoc := Node (Assoc_Elmt); 1492 end if; 1493 1494 -- Traverse the discriminants of the parent type looking 1495 -- for one that corresponds. 1496 1497 while Present (Parent_Disc) and then Present (Assoc) loop 1498 Corresp_Disc := Parent_Disc; 1499 while Present (Corresp_Disc) 1500 and then Disc /= Corresp_Disc 1501 loop 1502 Corresp_Disc := 1503 Corresponding_Discriminant (Corresp_Disc); 1504 end loop; 1505 1506 if Disc = Corresp_Disc then 1507 if Nkind (Assoc) = N_Discriminant_Association then 1508 Assoc := Expression (Assoc); 1509 end if; 1510 1511 -- If the located association directly denotes 1512 -- a discriminant, then use the value of a saved 1513 -- association of the aggregate. This is a kludge 1514 -- to handle certain cases involving multiple 1515 -- discriminants mapped to a single discriminant 1516 -- of a descendant. It's not clear how to locate the 1517 -- appropriate discriminant value for such cases. ??? 1518 1519 if Is_Entity_Name (Assoc) 1520 and then Ekind (Entity (Assoc)) = E_Discriminant 1521 then 1522 Assoc := Save_Assoc; 1523 end if; 1524 1525 return Duplicate_Subexpr (Assoc); 1526 end if; 1527 1528 Next_Discriminant (Parent_Disc); 1529 1530 if No (Assoc_Elmt) then 1531 Next (Assoc); 1532 else 1533 Next_Elmt (Assoc_Elmt); 1534 if Present (Assoc_Elmt) then 1535 Assoc := Node (Assoc_Elmt); 1536 else 1537 Assoc := Empty; 1538 end if; 1539 end if; 1540 end loop; 1541 end if; 1542 1543 Current_Typ := Parent_Typ; 1544 Parent_Typ := Etype (Current_Typ); 1545 end loop; 1546 1547 -- In some cases there's no ancestor value to locate (such as 1548 -- when an ancestor part given by an expression defines the 1549 -- discriminant value). 1550 1551 return Empty; 1552 end Ancestor_Discriminant_Value; 1553 1554 ---------------------------------- 1555 -- Check_Ancestor_Discriminants -- 1556 ---------------------------------- 1557 1558 procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id) is 1559 Discr : Entity_Id := First_Discriminant (Base_Type (Anc_Typ)); 1560 Disc_Value : Node_Id; 1561 Cond : Node_Id; 1562 1563 begin 1564 while Present (Discr) loop 1565 Disc_Value := Ancestor_Discriminant_Value (Discr); 1566 1567 if Present (Disc_Value) then 1568 Cond := Make_Op_Ne (Loc, 1569 Left_Opnd => 1570 Make_Selected_Component (Loc, 1571 Prefix => New_Copy_Tree (Target), 1572 Selector_Name => New_Occurrence_Of (Discr, Loc)), 1573 Right_Opnd => Disc_Value); 1574 1575 Append_To (L, 1576 Make_Raise_Constraint_Error (Loc, 1577 Condition => Cond, 1578 Reason => CE_Discriminant_Check_Failed)); 1579 end if; 1580 1581 Next_Discriminant (Discr); 1582 end loop; 1583 end Check_Ancestor_Discriminants; 1584 1585 -------------------------------- 1586 -- Get_Constraint_Association -- 1587 -------------------------------- 1588 1589 function Get_Constraint_Association (T : Entity_Id) return Node_Id is 1590 Typ_Def : constant Node_Id := Type_Definition (Parent (T)); 1591 Indic : constant Node_Id := Subtype_Indication (Typ_Def); 1592 1593 begin 1594 -- ??? Also need to cover case of a type mark denoting a subtype 1595 -- with constraint. 1596 1597 if Nkind (Indic) = N_Subtype_Indication 1598 and then Present (Constraint (Indic)) 1599 then 1600 return First (Constraints (Constraint (Indic))); 1601 end if; 1602 1603 return Empty; 1604 end Get_Constraint_Association; 1605 1606 --------------------- 1607 -- Init_controller -- 1608 --------------------- 1609 1610 function Init_Controller 1611 (Target : Node_Id; 1612 Typ : Entity_Id; 1613 F : Node_Id; 1614 Attach : Node_Id; 1615 Init_Pr : Boolean) return List_Id 1616 is 1617 L : constant List_Id := New_List; 1618 Ref : Node_Id; 1619 1620 begin 1621 -- Generate: 1622 -- init-proc (target._controller); 1623 -- initialize (target._controller); 1624 -- Attach_to_Final_List (target._controller, F); 1625 1626 Ref := 1627 Make_Selected_Component (Loc, 1628 Prefix => Convert_To (Typ, New_Copy_Tree (Target)), 1629 Selector_Name => Make_Identifier (Loc, Name_uController)); 1630 Set_Assignment_OK (Ref); 1631 1632 -- Ada0Y (AI-287): Give support to default initialization of limited 1633 -- types and components 1634 1635 if (Nkind (Target) = N_Identifier 1636 and then Present (Etype (Target)) 1637 and then Is_Limited_Type (Etype (Target))) 1638 or else (Nkind (Target) = N_Selected_Component 1639 and then Present (Etype (Selector_Name (Target))) 1640 and then Is_Limited_Type (Etype (Selector_Name (Target)))) 1641 or else (Nkind (Target) = N_Unchecked_Type_Conversion 1642 and then Present (Etype (Target)) 1643 and then Is_Limited_Type (Etype (Target))) 1644 or else (Nkind (Target) = N_Unchecked_Expression 1645 and then Nkind (Expression (Target)) = N_Indexed_Component 1646 and then Present (Etype (Prefix (Expression (Target)))) 1647 and then Is_Limited_Type 1648 (Etype (Prefix (Expression (Target))))) 1649 then 1650 1651 if Init_Pr then 1652 Append_List_To (L, 1653 Build_Initialization_Call (Loc, 1654 Id_Ref => Ref, 1655 Typ => RTE (RE_Limited_Record_Controller), 1656 In_Init_Proc => Within_Init_Proc)); 1657 end if; 1658 1659 Append_To (L, 1660 Make_Procedure_Call_Statement (Loc, 1661 Name => 1662 New_Reference_To 1663 (Find_Prim_Op (RTE (RE_Limited_Record_Controller), 1664 Name_Initialize), Loc), 1665 Parameter_Associations => New_List (New_Copy_Tree (Ref)))); 1666 1667 else 1668 if Init_Pr then 1669 Append_List_To (L, 1670 Build_Initialization_Call (Loc, 1671 Id_Ref => Ref, 1672 Typ => RTE (RE_Record_Controller), 1673 In_Init_Proc => Within_Init_Proc)); 1674 end if; 1675 1676 Append_To (L, 1677 Make_Procedure_Call_Statement (Loc, 1678 Name => 1679 New_Reference_To (Find_Prim_Op (RTE (RE_Record_Controller), 1680 Name_Initialize), Loc), 1681 Parameter_Associations => New_List (New_Copy_Tree (Ref)))); 1682 1683 end if; 1684 1685 Append_To (L, 1686 Make_Attach_Call ( 1687 Obj_Ref => New_Copy_Tree (Ref), 1688 Flist_Ref => F, 1689 With_Attach => Attach)); 1690 return L; 1691 end Init_Controller; 1692 1693 -- Start of processing for Build_Record_Aggr_Code 1694 1695 begin 1696 -- Deal with the ancestor part of extension aggregates 1697 -- or with the discriminants of the root type 1698 1699 if Nkind (N) = N_Extension_Aggregate then 1700 declare 1701 A : constant Node_Id := Ancestor_Part (N); 1702 1703 begin 1704 -- If the ancestor part is a subtype mark "T", we generate 1705 1706 -- init-proc (T(tmp)); if T is constrained and 1707 -- init-proc (S(tmp)); where S applies an appropriate 1708 -- constraint if T is unconstrained 1709 1710 if Is_Entity_Name (A) and then Is_Type (Entity (A)) then 1711 Ancestor_Is_Subtype_Mark := True; 1712 1713 if Is_Constrained (Entity (A)) then 1714 Init_Typ := Entity (A); 1715 1716 -- For an ancestor part given by an unconstrained type 1717 -- mark, create a subtype constrained by appropriate 1718 -- corresponding discriminant values coming from either 1719 -- associations of the aggregate or a constraint on 1720 -- a parent type. The subtype will be used to generate 1721 -- the correct default value for the ancestor part. 1722 1723 elsif Has_Discriminants (Entity (A)) then 1724 declare 1725 Anc_Typ : constant Entity_Id := Entity (A); 1726 Anc_Constr : constant List_Id := New_List; 1727 Discrim : Entity_Id; 1728 Disc_Value : Node_Id; 1729 New_Indic : Node_Id; 1730 Subt_Decl : Node_Id; 1731 1732 begin 1733 Discrim := First_Discriminant (Anc_Typ); 1734 while Present (Discrim) loop 1735 Disc_Value := Ancestor_Discriminant_Value (Discrim); 1736 Append_To (Anc_Constr, Disc_Value); 1737 Next_Discriminant (Discrim); 1738 end loop; 1739 1740 New_Indic := 1741 Make_Subtype_Indication (Loc, 1742 Subtype_Mark => New_Occurrence_Of (Anc_Typ, Loc), 1743 Constraint => 1744 Make_Index_Or_Discriminant_Constraint (Loc, 1745 Constraints => Anc_Constr)); 1746 1747 Init_Typ := Create_Itype (Ekind (Anc_Typ), N); 1748 1749 Subt_Decl := 1750 Make_Subtype_Declaration (Loc, 1751 Defining_Identifier => Init_Typ, 1752 Subtype_Indication => New_Indic); 1753 1754 -- Itypes must be analyzed with checks off 1755 -- Declaration must have a parent for proper 1756 -- handling of subsidiary actions. 1757 1758 Set_Parent (Subt_Decl, N); 1759 Analyze (Subt_Decl, Suppress => All_Checks); 1760 end; 1761 end if; 1762 1763 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); 1764 Set_Assignment_OK (Ref); 1765 1766 if Has_Default_Init_Comps (N) 1767 or else Has_Task (Base_Type (Init_Typ)) 1768 then 1769 Append_List_To (Start_L, 1770 Build_Initialization_Call (Loc, 1771 Id_Ref => Ref, 1772 Typ => Init_Typ, 1773 In_Init_Proc => Within_Init_Proc, 1774 With_Default_Init => True)); 1775 else 1776 Append_List_To (Start_L, 1777 Build_Initialization_Call (Loc, 1778 Id_Ref => Ref, 1779 Typ => Init_Typ, 1780 In_Init_Proc => Within_Init_Proc)); 1781 end if; 1782 1783 if Is_Constrained (Entity (A)) 1784 and then Has_Discriminants (Entity (A)) 1785 then 1786 Check_Ancestor_Discriminants (Entity (A)); 1787 end if; 1788 1789 -- Ada0Y (AI-287): If the ancestor part is a limited type, a 1790 -- recursive call expands the ancestor. 1791 1792 elsif Is_Limited_Type (Etype (A)) then 1793 Ancestor_Is_Expression := True; 1794 1795 Append_List_To (Start_L, 1796 Build_Record_Aggr_Code ( 1797 N => Expression (A), 1798 Typ => Etype (Expression (A)), 1799 Target => Target, 1800 Flist => Flist, 1801 Obj => Obj, 1802 Is_Limited_Ancestor_Expansion => True)); 1803 1804 -- If the ancestor part is an expression "E", we generate 1805 -- T(tmp) := E; 1806 1807 else 1808 Ancestor_Is_Expression := True; 1809 Init_Typ := Etype (A); 1810 1811 -- Assign the tag before doing the assignment to make sure 1812 -- that the dispatching call in the subsequent deep_adjust 1813 -- works properly (unless Java_VM, where tags are implicit). 1814 1815 if not Java_VM then 1816 Instr := 1817 Make_OK_Assignment_Statement (Loc, 1818 Name => 1819 Make_Selected_Component (Loc, 1820 Prefix => New_Copy_Tree (Target), 1821 Selector_Name => New_Reference_To ( 1822 Tag_Component (Base_Type (Typ)), Loc)), 1823 1824 Expression => 1825 Unchecked_Convert_To (RTE (RE_Tag), 1826 New_Reference_To ( 1827 Access_Disp_Table (Base_Type (Typ)), Loc))); 1828 1829 Set_Assignment_OK (Name (Instr)); 1830 Append_To (L, Instr); 1831 end if; 1832 1833 -- If the ancestor part is an aggregate, force its full 1834 -- expansion, which was delayed. 1835 1836 if Nkind (A) = N_Qualified_Expression 1837 and then (Nkind (Expression (A)) = N_Aggregate 1838 or else 1839 Nkind (Expression (A)) = N_Extension_Aggregate) 1840 then 1841 Set_Analyzed (A, False); 1842 Set_Analyzed (Expression (A), False); 1843 end if; 1844 1845 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); 1846 Set_Assignment_OK (Ref); 1847 Append_To (L, 1848 Make_Unsuppress_Block (Loc, 1849 Name_Discriminant_Check, 1850 New_List ( 1851 Make_OK_Assignment_Statement (Loc, 1852 Name => Ref, 1853 Expression => A)))); 1854 1855 if Has_Discriminants (Init_Typ) then 1856 Check_Ancestor_Discriminants (Init_Typ); 1857 end if; 1858 end if; 1859 end; 1860 1861 -- Normal case (not an extension aggregate) 1862 1863 else 1864 -- Generate the discriminant expressions, component by component. 1865 -- If the base type is an unchecked union, the discriminants are 1866 -- unknown to the back-end and absent from a value of the type, so 1867 -- assignments for them are not emitted. 1868 1869 if Has_Discriminants (Typ) 1870 and then not Is_Unchecked_Union (Base_Type (Typ)) 1871 then 1872 -- ??? The discriminants of the object not inherited in the type 1873 -- of the object should be initialized here 1874 1875 null; 1876 1877 -- Generate discriminant init values 1878 1879 declare 1880 Discriminant : Entity_Id; 1881 Discriminant_Value : Node_Id; 1882 1883 begin 1884 Discriminant := First_Stored_Discriminant (Typ); 1885 1886 while Present (Discriminant) loop 1887 1888 Comp_Expr := 1889 Make_Selected_Component (Loc, 1890 Prefix => New_Copy_Tree (Target), 1891 Selector_Name => New_Occurrence_Of (Discriminant, Loc)); 1892 1893 Discriminant_Value := 1894 Get_Discriminant_Value ( 1895 Discriminant, 1896 N_Typ, 1897 Discriminant_Constraint (N_Typ)); 1898 1899 Instr := 1900 Make_OK_Assignment_Statement (Loc, 1901 Name => Comp_Expr, 1902 Expression => New_Copy_Tree (Discriminant_Value)); 1903 1904 Set_No_Ctrl_Actions (Instr); 1905 Append_To (L, Instr); 1906 1907 Next_Stored_Discriminant (Discriminant); 1908 end loop; 1909 end; 1910 end if; 1911 end if; 1912 1913 -- Generate the assignments, component by component 1914 1915 -- tmp.comp1 := Expr1_From_Aggr; 1916 -- tmp.comp2 := Expr2_From_Aggr; 1917 -- .... 1918 1919 Comp := First (Component_Associations (N)); 1920 while Present (Comp) loop 1921 Selector := Entity (First (Choices (Comp))); 1922 1923 -- Ada0Y (AI-287): Default initialization of a limited component 1924 1925 if Box_Present (Comp) 1926 and then Is_Limited_Type (Etype (Selector)) 1927 then 1928 1929 -- Ada0Y (AI-287): If the component type has tasks then generate 1930 -- the activation chain and master entities (except in case of an 1931 -- allocator because in that case these entities are generated 1932 -- by Build_Task_Allocate_Block_With_Init_Stmts) 1933 1934 declare 1935 Ctype : constant Entity_Id := Etype (Selector); 1936 Inside_Allocator : Boolean := False; 1937 P : Node_Id := Parent (N); 1938 1939 begin 1940 if Is_Task_Type (Ctype) or else Has_Task (Ctype) then 1941 while Present (P) loop 1942 if Nkind (P) = N_Allocator then 1943 Inside_Allocator := True; 1944 exit; 1945 end if; 1946 1947 P := Parent (P); 1948 end loop; 1949 1950 if not Inside_Init_Proc and not Inside_Allocator then 1951 Build_Activation_Chain_Entity (N); 1952 Build_Master_Entity (Etype (N)); 1953 end if; 1954 end if; 1955 end; 1956 1957 Append_List_To (L, 1958 Build_Initialization_Call (Loc, 1959 Id_Ref => Make_Selected_Component (Loc, 1960 Prefix => New_Copy_Tree (Target), 1961 Selector_Name => New_Occurrence_Of (Selector, 1962 Loc)), 1963 Typ => Etype (Selector), 1964 With_Default_Init => True)); 1965 1966 goto Next_Comp; 1967 end if; 1968 1969 -- ??? 1970 1971 if Ekind (Selector) /= E_Discriminant 1972 or else Nkind (N) = N_Extension_Aggregate 1973 then 1974 Comp_Type := Etype (Selector); 1975 Comp_Expr := 1976 Make_Selected_Component (Loc, 1977 Prefix => New_Copy_Tree (Target), 1978 Selector_Name => New_Occurrence_Of (Selector, Loc)); 1979 1980 if Nkind (Expression (Comp)) = N_Qualified_Expression then 1981 Expr_Q := Expression (Expression (Comp)); 1982 else 1983 Expr_Q := Expression (Comp); 1984 end if; 1985 1986 -- The controller is the one of the parent type defining 1987 -- the component (in case of inherited components). 1988 1989 if Controlled_Type (Comp_Type) then 1990 Internal_Final_List := 1991 Make_Selected_Component (Loc, 1992 Prefix => Convert_To ( 1993 Scope (Original_Record_Component (Selector)), 1994 New_Copy_Tree (Target)), 1995 Selector_Name => 1996 Make_Identifier (Loc, Name_uController)); 1997 1998 Internal_Final_List := 1999 Make_Selected_Component (Loc, 2000 Prefix => Internal_Final_List, 2001 Selector_Name => Make_Identifier (Loc, Name_F)); 2002 2003 -- The internal final list can be part of a constant object 2004 2005 Set_Assignment_OK (Internal_Final_List); 2006 2007 else 2008 Internal_Final_List := Empty; 2009 end if; 2010 2011 -- ??? 2012 2013 if Is_Delayed_Aggregate (Expr_Q) then 2014 Append_List_To (L, 2015 Late_Expansion (Expr_Q, Comp_Type, Comp_Expr, 2016 Internal_Final_List)); 2017 2018 else 2019 Instr := 2020 Make_OK_Assignment_Statement (Loc, 2021 Name => Comp_Expr, 2022 Expression => Expression (Comp)); 2023 2024 Set_No_Ctrl_Actions (Instr); 2025 Append_To (L, Instr); 2026 2027 -- Adjust the tag if tagged (because of possible view 2028 -- conversions), unless compiling for the Java VM 2029 -- where tags are implicit. 2030 2031 -- tmp.comp._tag := comp_typ'tag; 2032 2033 if Is_Tagged_Type (Comp_Type) and then not Java_VM then 2034 Instr := 2035 Make_OK_Assignment_Statement (Loc, 2036 Name => 2037 Make_Selected_Component (Loc, 2038 Prefix => New_Copy_Tree (Comp_Expr), 2039 Selector_Name => 2040 New_Reference_To (Tag_Component (Comp_Type), Loc)), 2041 2042 Expression => 2043 Unchecked_Convert_To (RTE (RE_Tag), 2044 New_Reference_To ( 2045 Access_Disp_Table (Comp_Type), Loc))); 2046 2047 Append_To (L, Instr); 2048 end if; 2049 2050 -- Adjust and Attach the component to the proper controller 2051 -- Adjust (tmp.comp); 2052 -- Attach_To_Final_List (tmp.comp, 2053 -- comp_typ (tmp)._record_controller.f) 2054 2055 if Controlled_Type (Comp_Type) then 2056 Append_List_To (L, 2057 Make_Adjust_Call ( 2058 Ref => New_Copy_Tree (Comp_Expr), 2059 Typ => Comp_Type, 2060 Flist_Ref => Internal_Final_List, 2061 With_Attach => Make_Integer_Literal (Loc, 1))); 2062 end if; 2063 end if; 2064 2065 -- ??? 2066 2067 elsif Ekind (Selector) = E_Discriminant 2068 and then Nkind (N) /= N_Extension_Aggregate 2069 and then Nkind (Parent (N)) = N_Component_Association 2070 and then Is_Constrained (Typ) 2071 then 2072 -- We must check that the discriminant value imposed by the 2073 -- context is the same as the value given in the subaggregate, 2074 -- because after the expansion into assignments there is no 2075 -- record on which to perform a regular discriminant check. 2076 2077 declare 2078 D_Val : Elmt_Id; 2079 Disc : Entity_Id; 2080 2081 begin 2082 D_Val := First_Elmt (Discriminant_Constraint (Typ)); 2083 Disc := First_Discriminant (Typ); 2084 2085 while Chars (Disc) /= Chars (Selector) loop 2086 Next_Discriminant (Disc); 2087 Next_Elmt (D_Val); 2088 end loop; 2089 2090 pragma Assert (Present (D_Val)); 2091 2092 Append_To (L, 2093 Make_Raise_Constraint_Error (Loc, 2094 Condition => 2095 Make_Op_Ne (Loc, 2096 Left_Opnd => New_Copy_Tree (Node (D_Val)), 2097 Right_Opnd => Expression (Comp)), 2098 Reason => CE_Discriminant_Check_Failed)); 2099 end; 2100 end if; 2101 2102 <<Next_Comp>> 2103 2104 Next (Comp); 2105 end loop; 2106 2107 -- If the type is tagged, the tag needs to be initialized (unless 2108 -- compiling for the Java VM where tags are implicit). It is done 2109 -- late in the initialization process because in some cases, we call 2110 -- the init proc of an ancestor which will not leave out the right tag 2111 2112 if Ancestor_Is_Expression then 2113 null; 2114 2115 elsif Is_Tagged_Type (Typ) and then not Java_VM then 2116 Instr := 2117 Make_OK_Assignment_Statement (Loc, 2118 Name => 2119 Make_Selected_Component (Loc, 2120 Prefix => New_Copy_Tree (Target), 2121 Selector_Name => 2122 New_Reference_To (Tag_Component (Base_Type (Typ)), Loc)), 2123 2124 Expression => 2125 Unchecked_Convert_To (RTE (RE_Tag), 2126 New_Reference_To (Access_Disp_Table (Base_Type (Typ)), Loc))); 2127 2128 Append_To (L, Instr); 2129 end if; 2130 2131 -- Now deal with the various controlled type data structure 2132 -- initializations 2133 2134 if Present (Obj) 2135 and then Finalize_Storage_Only (Typ) 2136 and then (Is_Library_Level_Entity (Obj) 2137 or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) 2138 = Standard_True) 2139 then 2140 Attach := Make_Integer_Literal (Loc, 0); 2141 2142 elsif Nkind (Parent (N)) = N_Qualified_Expression 2143 and then Nkind (Parent (Parent (N))) = N_Allocator 2144 then 2145 Attach := Make_Integer_Literal (Loc, 2); 2146 2147 else 2148 Attach := Make_Integer_Literal (Loc, 1); 2149 end if; 2150 2151 -- Determine the external finalization list. It is either the 2152 -- finalization list of the outer-scope or the one coming from 2153 -- an outer aggregate. When the target is not a temporary, the 2154 -- proper scope is the scope of the target rather than the 2155 -- potentially transient current scope. 2156 2157 if Controlled_Type (Typ) then 2158 if Present (Flist) then 2159 External_Final_List := New_Copy_Tree (Flist); 2160 2161 elsif Is_Entity_Name (Target) 2162 and then Present (Scope (Entity (Target))) 2163 then 2164 External_Final_List := Find_Final_List (Scope (Entity (Target))); 2165 2166 else 2167 External_Final_List := Find_Final_List (Current_Scope); 2168 end if; 2169 2170 else 2171 External_Final_List := Empty; 2172 end if; 2173 2174 -- Initialize and attach the outer object in the is_controlled case 2175 2176 if Is_Controlled (Typ) then 2177 if Ancestor_Is_Subtype_Mark then 2178 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); 2179 Set_Assignment_OK (Ref); 2180 Append_To (L, 2181 Make_Procedure_Call_Statement (Loc, 2182 Name => New_Reference_To ( 2183 Find_Prim_Op (Init_Typ, Name_Initialize), Loc), 2184 Parameter_Associations => New_List (New_Copy_Tree (Ref)))); 2185 end if; 2186 2187 if not Has_Controlled_Component (Typ) then 2188 Ref := New_Copy_Tree (Target); 2189 Set_Assignment_OK (Ref); 2190 Append_To (Start_L, 2191 Make_Attach_Call ( 2192 Obj_Ref => Ref, 2193 Flist_Ref => New_Copy_Tree (External_Final_List), 2194 With_Attach => Attach)); 2195 end if; 2196 end if; 2197 2198 -- In the Has_Controlled component case, all the intermediate 2199 -- controllers must be initialized 2200 2201 if Has_Controlled_Component (Typ) 2202 and not Is_Limited_Ancestor_Expansion 2203 then 2204 declare 2205 Inner_Typ : Entity_Id; 2206 Outer_Typ : Entity_Id; 2207 At_Root : Boolean; 2208 2209 begin 2210 2211 Outer_Typ := Base_Type (Typ); 2212 2213 -- Find outer type with a controller 2214 2215 while Outer_Typ /= Init_Typ 2216 and then not Has_New_Controlled_Component (Outer_Typ) 2217 loop 2218 Outer_Typ := Etype (Outer_Typ); 2219 end loop; 2220 2221 -- Attach it to the outer record controller to the 2222 -- external final list 2223 2224 if Outer_Typ = Init_Typ then 2225 Append_List_To (Start_L, 2226 Init_Controller ( 2227 Target => Target, 2228 Typ => Outer_Typ, 2229 F => External_Final_List, 2230 Attach => Attach, 2231 Init_Pr => Ancestor_Is_Expression)); 2232 2233 At_Root := True; 2234 Inner_Typ := Init_Typ; 2235 2236 else 2237 Append_List_To (Start_L, 2238 Init_Controller ( 2239 Target => Target, 2240 Typ => Outer_Typ, 2241 F => External_Final_List, 2242 Attach => Attach, 2243 Init_Pr => True)); 2244 2245 Inner_Typ := Etype (Outer_Typ); 2246 At_Root := 2247 not Is_Tagged_Type (Typ) or else Inner_Typ = Outer_Typ; 2248 end if; 2249 2250 -- The outer object has to be attached as well 2251 2252 if Is_Controlled (Typ) then 2253 Ref := New_Copy_Tree (Target); 2254 Set_Assignment_OK (Ref); 2255 Append_To (Start_L, 2256 Make_Attach_Call ( 2257 Obj_Ref => Ref, 2258 Flist_Ref => New_Copy_Tree (External_Final_List), 2259 With_Attach => New_Copy_Tree (Attach))); 2260 end if; 2261 2262 -- Initialize the internal controllers for tagged types with 2263 -- more than one controller. 2264 2265 while not At_Root and then Inner_Typ /= Init_Typ loop 2266 if Has_New_Controlled_Component (Inner_Typ) then 2267 F := 2268 Make_Selected_Component (Loc, 2269 Prefix => Convert_To (Outer_Typ, New_Copy_Tree (Target)), 2270 Selector_Name => 2271 Make_Identifier (Loc, Name_uController)); 2272 F := 2273 Make_Selected_Component (Loc, 2274 Prefix => F, 2275 Selector_Name => Make_Identifier (Loc, Name_F)); 2276 2277 Append_List_To (Start_L, 2278 Init_Controller ( 2279 Target => Target, 2280 Typ => Inner_Typ, 2281 F => F, 2282 Attach => Make_Integer_Literal (Loc, 1), 2283 Init_Pr => True)); 2284 Outer_Typ := Inner_Typ; 2285 end if; 2286 2287 -- Stop at the root 2288 2289 At_Root := Inner_Typ = Etype (Inner_Typ); 2290 Inner_Typ := Etype (Inner_Typ); 2291 end loop; 2292 2293 -- If not done yet attach the controller of the ancestor part 2294 2295 if Outer_Typ /= Init_Typ 2296 and then Inner_Typ = Init_Typ 2297 and then Has_Controlled_Component (Init_Typ) 2298 then 2299 F := 2300 Make_Selected_Component (Loc, 2301 Prefix => Convert_To (Outer_Typ, New_Copy_Tree (Target)), 2302 Selector_Name => Make_Identifier (Loc, Name_uController)); 2303 F := 2304 Make_Selected_Component (Loc, 2305 Prefix => F, 2306 Selector_Name => Make_Identifier (Loc, Name_F)); 2307 2308 Attach := Make_Integer_Literal (Loc, 1); 2309 Append_List_To (Start_L, 2310 Init_Controller ( 2311 Target => Target, 2312 Typ => Init_Typ, 2313 F => F, 2314 Attach => Attach, 2315 Init_Pr => Ancestor_Is_Expression)); 2316 end if; 2317 end; 2318 end if; 2319 2320 Append_List_To (Start_L, L); 2321 return Start_L; 2322 end Build_Record_Aggr_Code; 2323 2324 ------------------------------- 2325 -- Convert_Aggr_In_Allocator -- 2326 ------------------------------- 2327 2328 procedure Convert_Aggr_In_Allocator (Decl, Aggr : Node_Id) is 2329 Loc : constant Source_Ptr := Sloc (Aggr); 2330 Typ : constant Entity_Id := Etype (Aggr); 2331 Temp : constant Entity_Id := Defining_Identifier (Decl); 2332 2333 Occ : constant Node_Id := 2334 Unchecked_Convert_To (Typ, 2335 Make_Explicit_Dereference (Loc, 2336 New_Reference_To (Temp, Loc))); 2337 2338 Access_Type : constant Entity_Id := Etype (Temp); 2339 2340 begin 2341 if Has_Default_Init_Comps (Aggr) then 2342 declare 2343 L : constant List_Id := New_List; 2344 Init_Stmts : List_Id; 2345 2346 begin 2347 Init_Stmts := Late_Expansion (Aggr, Typ, Occ, 2348 Find_Final_List (Access_Type), 2349 Associated_Final_Chain (Base_Type (Access_Type))); 2350 2351 Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts); 2352 Insert_Actions_After (Decl, L); 2353 end; 2354 2355 else 2356 Insert_Actions_After (Decl, 2357 Late_Expansion (Aggr, Typ, Occ, 2358 Find_Final_List (Access_Type), 2359 Associated_Final_Chain (Base_Type (Access_Type)))); 2360 end if; 2361 end Convert_Aggr_In_Allocator; 2362 2363 -------------------------------- 2364 -- Convert_Aggr_In_Assignment -- 2365 -------------------------------- 2366 2367 procedure Convert_Aggr_In_Assignment (N : Node_Id) is 2368 Aggr : Node_Id := Expression (N); 2369 Typ : constant Entity_Id := Etype (Aggr); 2370 Occ : constant Node_Id := New_Copy_Tree (Name (N)); 2371 2372 begin 2373 if Nkind (Aggr) = N_Qualified_Expression then 2374 Aggr := Expression (Aggr); 2375 end if; 2376 2377 Insert_Actions_After (N, 2378 Late_Expansion (Aggr, Typ, Occ, 2379 Find_Final_List (Typ, New_Copy_Tree (Occ)))); 2380 end Convert_Aggr_In_Assignment; 2381 2382 --------------------------------- 2383 -- Convert_Aggr_In_Object_Decl -- 2384 --------------------------------- 2385 2386 procedure Convert_Aggr_In_Object_Decl (N : Node_Id) is 2387 Obj : constant Entity_Id := Defining_Identifier (N); 2388 Aggr : Node_Id := Expression (N); 2389 Loc : constant Source_Ptr := Sloc (Aggr); 2390 Typ : constant Entity_Id := Etype (Aggr); 2391 Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc); 2392 2393 function Discriminants_Ok return Boolean; 2394 -- If the object type is constrained, the discriminants in the 2395 -- aggregate must be checked against the discriminants of the subtype. 2396 -- This cannot be done using Apply_Discriminant_Checks because after 2397 -- expansion there is no aggregate left to check. 2398 2399 ---------------------- 2400 -- Discriminants_Ok -- 2401 ---------------------- 2402 2403 function Discriminants_Ok return Boolean is 2404 Cond : Node_Id := Empty; 2405 Check : Node_Id; 2406 D : Entity_Id; 2407 Disc1 : Elmt_Id; 2408 Disc2 : Elmt_Id; 2409 Val1 : Node_Id; 2410 Val2 : Node_Id; 2411 2412 begin 2413 D := First_Discriminant (Typ); 2414 Disc1 := First_Elmt (Discriminant_Constraint (Typ)); 2415 Disc2 := First_Elmt (Discriminant_Constraint (Etype (Obj))); 2416 2417 while Present (Disc1) and then Present (Disc2) loop 2418 Val1 := Node (Disc1); 2419 Val2 := Node (Disc2); 2420 2421 if not Is_OK_Static_Expression (Val1) 2422 or else not Is_OK_Static_Expression (Val2) 2423 then 2424 Check := Make_Op_Ne (Loc, 2425 Left_Opnd => Duplicate_Subexpr (Val1), 2426 Right_Opnd => Duplicate_Subexpr (Val2)); 2427 2428 if No (Cond) then 2429 Cond := Check; 2430 2431 else 2432 Cond := Make_Or_Else (Loc, 2433 Left_Opnd => Cond, 2434 Right_Opnd => Check); 2435 end if; 2436 2437 elsif Expr_Value (Val1) /= Expr_Value (Val2) then 2438 Apply_Compile_Time_Constraint_Error (Aggr, 2439 Msg => "incorrect value for discriminant&?", 2440 Reason => CE_Discriminant_Check_Failed, 2441 Ent => D); 2442 return False; 2443 end if; 2444 2445 Next_Discriminant (D); 2446 Next_Elmt (Disc1); 2447 Next_Elmt (Disc2); 2448 end loop; 2449 2450 -- If any discriminant constraint is non-static, emit a check. 2451 2452 if Present (Cond) then 2453 Insert_Action (N, 2454 Make_Raise_Constraint_Error (Loc, 2455 Condition => Cond, 2456 Reason => CE_Discriminant_Check_Failed)); 2457 end if; 2458 2459 return True; 2460 end Discriminants_Ok; 2461 2462 -- Start of processing for Convert_Aggr_In_Object_Decl 2463 2464 begin 2465 Set_Assignment_OK (Occ); 2466 2467 if Nkind (Aggr) = N_Qualified_Expression then 2468 Aggr := Expression (Aggr); 2469 end if; 2470 2471 if Has_Discriminants (Typ) 2472 and then Typ /= Etype (Obj) 2473 and then Is_Constrained (Etype (Obj)) 2474 and then not Discriminants_Ok 2475 then 2476 return; 2477 end if; 2478 2479 Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ, Obj => Obj)); 2480 Set_No_Initialization (N); 2481 Initialize_Discriminants (N, Typ); 2482 end Convert_Aggr_In_Object_Decl; 2483 2484 ---------------------------- 2485 -- Convert_To_Assignments -- 2486 ---------------------------- 2487 2488 procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is 2489 Loc : constant Source_Ptr := Sloc (N); 2490 Temp : Entity_Id; 2491 2492 Instr : Node_Id; 2493 Target_Expr : Node_Id; 2494 Parent_Kind : Node_Kind; 2495 Unc_Decl : Boolean := False; 2496 Parent_Node : Node_Id; 2497 2498 begin 2499 Parent_Node := Parent (N); 2500 Parent_Kind := Nkind (Parent_Node); 2501 2502 if Parent_Kind = N_Qualified_Expression then 2503 2504 -- Check if we are in a unconstrained declaration because in this 2505 -- case the current delayed expansion mechanism doesn't work when 2506 -- the declared object size depend on the initializing expr. 2507 2508 begin 2509 Parent_Node := Parent (Parent_Node); 2510 Parent_Kind := Nkind (Parent_Node); 2511 2512 if Parent_Kind = N_Object_Declaration then 2513 Unc_Decl := 2514 not Is_Entity_Name (Object_Definition (Parent_Node)) 2515 or else Has_Discriminants 2516 (Entity (Object_Definition (Parent_Node))) 2517 or else Is_Class_Wide_Type 2518 (Entity (Object_Definition (Parent_Node))); 2519 end if; 2520 end; 2521 end if; 2522 2523 -- Just set the Delay flag in the following cases where the 2524 -- transformation will be done top down from above 2525 2526 -- - internal aggregate (transformed when expanding the parent) 2527 -- - allocators (see Convert_Aggr_In_Allocator) 2528 -- - object decl (see Convert_Aggr_In_Object_Decl) 2529 -- - safe assignments (see Convert_Aggr_Assignments) 2530 -- so far only the assignments in the init procs are taken 2531 -- into account 2532 2533 if Parent_Kind = N_Aggregate 2534 or else Parent_Kind = N_Extension_Aggregate 2535 or else Parent_Kind = N_Component_Association 2536 or else Parent_Kind = N_Allocator 2537 or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl) 2538 or else (Parent_Kind = N_Assignment_Statement 2539 and then Inside_Init_Proc) 2540 then 2541 Set_Expansion_Delayed (N); 2542 return; 2543 end if; 2544 2545 if Requires_Transient_Scope (Typ) then 2546 Establish_Transient_Scope (N, Sec_Stack => 2547 Is_Controlled (Typ) or else Has_Controlled_Component (Typ)); 2548 end if; 2549 2550 -- Create the temporary 2551 2552 Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); 2553 2554 Instr := 2555 Make_Object_Declaration (Loc, 2556 Defining_Identifier => Temp, 2557 Object_Definition => New_Occurrence_Of (Typ, Loc)); 2558 2559 Set_No_Initialization (Instr); 2560 Insert_Action (N, Instr); 2561 Initialize_Discriminants (Instr, Typ); 2562 Target_Expr := New_Occurrence_Of (Temp, Loc); 2563 2564 Insert_Actions (N, Build_Record_Aggr_Code (N, Typ, Target_Expr)); 2565 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 2566 Analyze_And_Resolve (N, Typ); 2567 end Convert_To_Assignments; 2568 2569 --------------------------- 2570 -- Convert_To_Positional -- 2571 --------------------------- 2572 2573 procedure Convert_To_Positional 2574 (N : Node_Id; 2575 Max_Others_Replicate : Nat := 5; 2576 Handle_Bit_Packed : Boolean := False) 2577 is 2578 Typ : constant Entity_Id := Etype (N); 2579 2580 function Flatten 2581 (N : Node_Id; 2582 Ix : Node_Id; 2583 Ixb : Node_Id) return Boolean; 2584 -- Convert the aggregate into a purely positional form if possible. 2585 2586 function Is_Flat (N : Node_Id; Dims : Int) return Boolean; 2587 -- Non trivial for multidimensional aggregate. 2588 2589 ------------- 2590 -- Flatten -- 2591 ------------- 2592 2593 function Flatten 2594 (N : Node_Id; 2595 Ix : Node_Id; 2596 Ixb : Node_Id) return Boolean 2597 is 2598 Loc : constant Source_Ptr := Sloc (N); 2599 Blo : constant Node_Id := Type_Low_Bound (Etype (Ixb)); 2600 Lo : constant Node_Id := Type_Low_Bound (Etype (Ix)); 2601 Hi : constant Node_Id := Type_High_Bound (Etype (Ix)); 2602 Lov : Uint; 2603 Hiv : Uint; 2604 2605 -- The following constant determines the maximum size of an 2606 -- aggregate produced by converting named to positional 2607 -- notation (e.g. from others clauses). This avoids running 2608 -- away with attempts to convert huge aggregates. 2609 2610 -- The normal limit is 5000, but we increase this limit to 2611 -- 2**24 (about 16 million) if Restrictions (No_Elaboration_Code) 2612 -- or Restrictions (No_Implicit_Loops) is specified, since in 2613 -- either case, we are at risk of declaring the program illegal 2614 -- because of this limit. 2615 2616 Max_Aggr_Size : constant Nat := 2617 5000 + (2 ** 24 - 5000) * Boolean'Pos 2618 (Restrictions (No_Elaboration_Code) 2619 or else 2620 Restrictions (No_Implicit_Loops)); 2621 begin 2622 2623 if Nkind (Original_Node (N)) = N_String_Literal then 2624 return True; 2625 end if; 2626 2627 -- Bounds need to be known at compile time 2628 2629 if not Compile_Time_Known_Value (Lo) 2630 or else not Compile_Time_Known_Value (Hi) 2631 then 2632 return False; 2633 end if; 2634 2635 -- Get bounds and check reasonable size (positive, not too large) 2636 -- Also only handle bounds starting at the base type low bound 2637 -- for now since the compiler isn't able to handle different low 2638 -- bounds yet. Case such as new String'(3..5 => ' ') will get 2639 -- the wrong bounds, though it seems that the aggregate should 2640 -- retain the bounds set on its Etype (see C64103E and CC1311B). 2641 2642 Lov := Expr_Value (Lo); 2643 Hiv := Expr_Value (Hi); 2644 2645 if Hiv < Lov 2646 or else (Hiv - Lov > Max_Aggr_Size) 2647 or else not Compile_Time_Known_Value (Blo) 2648 or else (Lov /= Expr_Value (Blo)) 2649 then 2650 return False; 2651 end if; 2652 2653 -- Bounds must be in integer range (for array Vals below) 2654 2655 if not UI_Is_In_Int_Range (Lov) 2656 or else 2657 not UI_Is_In_Int_Range (Hiv) 2658 then 2659 return False; 2660 end if; 2661 2662 -- Determine if set of alternatives is suitable for conversion 2663 -- and build an array containing the values in sequence. 2664 2665 declare 2666 Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv)) 2667 of Node_Id := (others => Empty); 2668 -- The values in the aggregate sorted appropriately 2669 2670 Vlist : List_Id; 2671 -- Same data as Vals in list form 2672 2673 Rep_Count : Nat; 2674 -- Used to validate Max_Others_Replicate limit 2675 2676 Elmt : Node_Id; 2677 Num : Int := UI_To_Int (Lov); 2678 Choice : Node_Id; 2679 Lo, Hi : Node_Id; 2680 2681 begin 2682 if Present (Expressions (N)) then 2683 Elmt := First (Expressions (N)); 2684 2685 while Present (Elmt) loop 2686 if Nkind (Elmt) = N_Aggregate 2687 and then Present (Next_Index (Ix)) 2688 and then 2689 not Flatten (Elmt, Next_Index (Ix), Next_Index (Ixb)) 2690 then 2691 return False; 2692 end if; 2693 2694 Vals (Num) := Relocate_Node (Elmt); 2695 Num := Num + 1; 2696 2697 Next (Elmt); 2698 end loop; 2699 end if; 2700 2701 if No (Component_Associations (N)) then 2702 return True; 2703 end if; 2704 2705 Elmt := First (Component_Associations (N)); 2706 2707 if Nkind (Expression (Elmt)) = N_Aggregate then 2708 if Present (Next_Index (Ix)) 2709 and then 2710 not Flatten 2711 (Expression (Elmt), Next_Index (Ix), Next_Index (Ixb)) 2712 then 2713 return False; 2714 end if; 2715 end if; 2716 2717 Component_Loop : while Present (Elmt) loop 2718 Choice := First (Choices (Elmt)); 2719 Choice_Loop : while Present (Choice) loop 2720 2721 -- If we have an others choice, fill in the missing elements 2722 -- subject to the limit established by Max_Others_Replicate. 2723 2724 if Nkind (Choice) = N_Others_Choice then 2725 Rep_Count := 0; 2726 2727 for J in Vals'Range loop 2728 if No (Vals (J)) then 2729 Vals (J) := New_Copy_Tree (Expression (Elmt)); 2730 Rep_Count := Rep_Count + 1; 2731 2732 -- Check for maximum others replication. Note that 2733 -- we skip this test if either of the restrictions 2734 -- No_Elaboration_Code or No_Implicit_Loops is 2735 -- active, or if this is a preelaborable unit. 2736 2737 declare 2738 P : constant Entity_Id := 2739 Cunit_Entity (Current_Sem_Unit); 2740 2741 begin 2742 if Restrictions (No_Elaboration_Code) 2743 or else Restrictions (No_Implicit_Loops) 2744 or else Is_Preelaborated (P) 2745 or else (Ekind (P) = E_Package_Body 2746 and then 2747 Is_Preelaborated (Spec_Entity (P))) 2748 then 2749 null; 2750 elsif Rep_Count > Max_Others_Replicate then 2751 return False; 2752 end if; 2753 end; 2754 end if; 2755 end loop; 2756 2757 exit Component_Loop; 2758 2759 -- Case of a subtype mark 2760 2761 elsif Nkind (Choice) = N_Identifier 2762 and then Is_Type (Entity (Choice)) 2763 then 2764 Lo := Type_Low_Bound (Etype (Choice)); 2765 Hi := Type_High_Bound (Etype (Choice)); 2766 2767 -- Case of subtype indication 2768 2769 elsif Nkind (Choice) = N_Subtype_Indication then 2770 Lo := Low_Bound (Range_Expression (Constraint (Choice))); 2771 Hi := High_Bound (Range_Expression (Constraint (Choice))); 2772 2773 -- Case of a range 2774 2775 elsif Nkind (Choice) = N_Range then 2776 Lo := Low_Bound (Choice); 2777 Hi := High_Bound (Choice); 2778 2779 -- Normal subexpression case 2780 2781 else pragma Assert (Nkind (Choice) in N_Subexpr); 2782 if not Compile_Time_Known_Value (Choice) then 2783 return False; 2784 2785 else 2786 Vals (UI_To_Int (Expr_Value (Choice))) := 2787 New_Copy_Tree (Expression (Elmt)); 2788 goto Continue; 2789 end if; 2790 end if; 2791 2792 -- Range cases merge with Lo,Hi said 2793 2794 if not Compile_Time_Known_Value (Lo) 2795 or else 2796 not Compile_Time_Known_Value (Hi) 2797 then 2798 return False; 2799 else 2800 for J in UI_To_Int (Expr_Value (Lo)) .. 2801 UI_To_Int (Expr_Value (Hi)) 2802 loop 2803 Vals (J) := New_Copy_Tree (Expression (Elmt)); 2804 end loop; 2805 end if; 2806 2807 <<Continue>> 2808 Next (Choice); 2809 end loop Choice_Loop; 2810 2811 Next (Elmt); 2812 end loop Component_Loop; 2813 2814 -- If we get here the conversion is possible 2815 2816 Vlist := New_List; 2817 for J in Vals'Range loop 2818 Append (Vals (J), Vlist); 2819 end loop; 2820 2821 Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist)); 2822 Set_Aggregate_Bounds (N, Aggregate_Bounds (Original_Node (N))); 2823 return True; 2824 end; 2825 end Flatten; 2826 2827 ------------- 2828 -- Is_Flat -- 2829 ------------- 2830 2831 function Is_Flat (N : Node_Id; Dims : Int) return Boolean is 2832 Elmt : Node_Id; 2833 2834 begin 2835 if Dims = 0 then 2836 return True; 2837 2838 elsif Nkind (N) = N_Aggregate then 2839 if Present (Component_Associations (N)) then 2840 return False; 2841 2842 else 2843 Elmt := First (Expressions (N)); 2844 2845 while Present (Elmt) loop 2846 if not Is_Flat (Elmt, Dims - 1) then 2847 return False; 2848 end if; 2849 2850 Next (Elmt); 2851 end loop; 2852 2853 return True; 2854 end if; 2855 else 2856 return True; 2857 end if; 2858 end Is_Flat; 2859 2860 -- Start of processing for Convert_To_Positional 2861 2862 begin 2863 -- Ada0Y (AI-287): Do not convert in case of default initialized 2864 -- components because in this case will need to call the corresponding 2865 -- IP procedure. 2866 2867 if Has_Default_Init_Comps (N) then 2868 return; 2869 end if; 2870 2871 if Is_Flat (N, Number_Dimensions (Typ)) then 2872 return; 2873 end if; 2874 2875 if Is_Bit_Packed_Array (Typ) 2876 and then not Handle_Bit_Packed 2877 then 2878 return; 2879 end if; 2880 2881 -- Do not convert to positional if controlled components are 2882 -- involved since these require special processing 2883 2884 if Has_Controlled_Component (Typ) then 2885 return; 2886 end if; 2887 2888 if Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ))) then 2889 Analyze_And_Resolve (N, Typ); 2890 end if; 2891 end Convert_To_Positional; 2892 2893 ---------------------------- 2894 -- Expand_Array_Aggregate -- 2895 ---------------------------- 2896 2897 -- Array aggregate expansion proceeds as follows: 2898 2899 -- 1. If requested we generate code to perform all the array aggregate 2900 -- bound checks, specifically 2901 2902 -- (a) Check that the index range defined by aggregate bounds is 2903 -- compatible with corresponding index subtype. 2904 2905 -- (b) If an others choice is present check that no aggregate 2906 -- index is outside the bounds of the index constraint. 2907 2908 -- (c) For multidimensional arrays make sure that all subaggregates 2909 -- corresponding to the same dimension have the same bounds. 2910 2911 -- 2. Check for packed array aggregate which can be converted to a 2912 -- constant so that the aggregate disappeares completely. 2913 2914 -- 3. Check case of nested aggregate. Generally nested aggregates are 2915 -- handled during the processing of the parent aggregate. 2916 2917 -- 4. Check if the aggregate can be statically processed. If this is the 2918 -- case pass it as is to Gigi. Note that a necessary condition for 2919 -- static processing is that the aggregate be fully positional. 2920 2921 -- 5. If in place aggregate expansion is possible (i.e. no need to create 2922 -- a temporary) then mark the aggregate as such and return. Otherwise 2923 -- create a new temporary and generate the appropriate initialization 2924 -- code. 2925 2926 procedure Expand_Array_Aggregate (N : Node_Id) is 2927 Loc : constant Source_Ptr := Sloc (N); 2928 2929 Typ : constant Entity_Id := Etype (N); 2930 Ctyp : constant Entity_Id := Component_Type (Typ); 2931 -- Typ is the correct constrained array subtype of the aggregate 2932 -- Ctyp is the corresponding component type. 2933 2934 Aggr_Dimension : constant Pos := Number_Dimensions (Typ); 2935 -- Number of aggregate index dimensions. 2936 2937 Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id; 2938 Aggr_High : array (1 .. Aggr_Dimension) of Node_Id; 2939 -- Low and High bounds of the constraint for each aggregate index. 2940 2941 Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id; 2942 -- The type of each index. 2943 2944 Maybe_In_Place_OK : Boolean; 2945 -- If the type is neither controlled nor packed and the aggregate 2946 -- is the expression in an assignment, assignment in place may be 2947 -- possible, provided other conditions are met on the LHS. 2948 2949 Others_Present : array (1 .. Aggr_Dimension) of Boolean := 2950 (others => False); 2951 -- If Others_Present (J) is True, then there is an others choice 2952 -- in one of the sub-aggregates of N at dimension J. 2953 2954 procedure Build_Constrained_Type (Positional : Boolean); 2955 -- If the subtype is not static or unconstrained, build a constrained 2956 -- type using the computable sizes of the aggregate and its sub- 2957 -- aggregates. 2958 2959 procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id); 2960 -- Checks that the bounds of Aggr_Bounds are within the bounds defined 2961 -- by Index_Bounds. 2962 2963 procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos); 2964 -- Checks that in a multi-dimensional array aggregate all subaggregates 2965 -- corresponding to the same dimension have the same bounds. 2966 -- Sub_Aggr is an array sub-aggregate. Dim is the dimension 2967 -- corresponding to the sub-aggregate. 2968 2969 procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos); 2970 -- Computes the values of array Others_Present. Sub_Aggr is the 2971 -- array sub-aggregate we start the computation from. Dim is the 2972 -- dimension corresponding to the sub-aggregate. 2973 2974 function Has_Address_Clause (D : Node_Id) return Boolean; 2975 -- If the aggregate is the expression in an object declaration, it 2976 -- cannot be expanded in place. This function does a lookahead in the 2977 -- current declarative part to find an address clause for the object 2978 -- being declared. 2979 2980 function In_Place_Assign_OK return Boolean; 2981 -- Simple predicate to determine whether an aggregate assignment can 2982 -- be done in place, because none of the new values can depend on the 2983 -- components of the target of the assignment. 2984 2985 function Must_Slide (N : Node_Id; Typ : Entity_Id) return Boolean; 2986 -- A static aggregate in an object declaration can in most cases be 2987 -- expanded in place. The one exception is when the aggregate is given 2988 -- with component associations that specify different bounds from those 2989 -- of the type definition in the object declaration. In this rather 2990 -- pathological case the aggregate must slide, and we must introduce 2991 -- an intermediate temporary to hold it. 2992 2993 procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos); 2994 -- Checks that if an others choice is present in any sub-aggregate no 2995 -- aggregate index is outside the bounds of the index constraint. 2996 -- Sub_Aggr is an array sub-aggregate. Dim is the dimension 2997 -- corresponding to the sub-aggregate. 2998 2999 ---------------------------- 3000 -- Build_Constrained_Type -- 3001 ---------------------------- 3002 3003 procedure Build_Constrained_Type (Positional : Boolean) is 3004 Loc : constant Source_Ptr := Sloc (N); 3005 Agg_Type : Entity_Id; 3006 Comp : Node_Id; 3007 Decl : Node_Id; 3008 Typ : constant Entity_Id := Etype (N); 3009 Indices : constant List_Id := New_List; 3010 Num : Int; 3011 Sub_Agg : Node_Id; 3012 3013 begin 3014 Agg_Type := 3015 Make_Defining_Identifier ( 3016 Loc, New_Internal_Name ('A')); 3017 3018 -- If the aggregate is purely positional, all its subaggregates 3019 -- have the same size. We collect the dimensions from the first 3020 -- subaggregate at each level. 3021 3022 if Positional then 3023 Sub_Agg := N; 3024 3025 for D in 1 .. Number_Dimensions (Typ) loop 3026 Comp := First (Expressions (Sub_Agg)); 3027 3028 Sub_Agg := Comp; 3029 Num := 0; 3030 3031 while Present (Comp) loop 3032 Num := Num + 1; 3033 Next (Comp); 3034 end loop; 3035 3036 Append ( 3037 Make_Range (Loc, 3038 Low_Bound => Make_Integer_Literal (Loc, 1), 3039 High_Bound => 3040 Make_Integer_Literal (Loc, Num)), 3041 Indices); 3042 end loop; 3043 3044 else 3045 -- We know the aggregate type is unconstrained and the 3046 -- aggregate is not processable by the back end, therefore 3047 -- not necessarily positional. Retrieve the bounds of each 3048 -- dimension as computed earlier. 3049 3050 for D in 1 .. Number_Dimensions (Typ) loop 3051 Append ( 3052 Make_Range (Loc, 3053 Low_Bound => Aggr_Low (D), 3054 High_Bound => Aggr_High (D)), 3055 Indices); 3056 end loop; 3057 end if; 3058 3059 Decl := 3060 Make_Full_Type_Declaration (Loc, 3061 Defining_Identifier => Agg_Type, 3062 Type_Definition => 3063 Make_Constrained_Array_Definition (Loc, 3064 Discrete_Subtype_Definitions => Indices, 3065 Component_Definition => 3066 Make_Component_Definition (Loc, 3067 Aliased_Present => False, 3068 Subtype_Indication => 3069 New_Occurrence_Of (Component_Type (Typ), Loc)))); 3070 3071 Insert_Action (N, Decl); 3072 Analyze (Decl); 3073 Set_Etype (N, Agg_Type); 3074 Set_Is_Itype (Agg_Type); 3075 Freeze_Itype (Agg_Type, N); 3076 end Build_Constrained_Type; 3077 3078 ------------------ 3079 -- Check_Bounds -- 3080 ------------------ 3081 3082 procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id) is 3083 Aggr_Lo : Node_Id; 3084 Aggr_Hi : Node_Id; 3085 3086 Ind_Lo : Node_Id; 3087 Ind_Hi : Node_Id; 3088 3089 Cond : Node_Id := Empty; 3090 3091 begin 3092 Get_Index_Bounds (Aggr_Bounds, Aggr_Lo, Aggr_Hi); 3093 Get_Index_Bounds (Index_Bounds, Ind_Lo, Ind_Hi); 3094 3095 -- Generate the following test: 3096 -- 3097 -- [constraint_error when 3098 -- Aggr_Lo <= Aggr_Hi and then 3099 -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)] 3100 -- 3101 -- As an optimization try to see if some tests are trivially vacuos 3102 -- because we are comparing an expression against itself. 3103 3104 if Aggr_Lo = Ind_Lo and then Aggr_Hi = Ind_Hi then 3105 Cond := Empty; 3106 3107 elsif Aggr_Hi = Ind_Hi then 3108 Cond := 3109 Make_Op_Lt (Loc, 3110 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), 3111 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo)); 3112 3113 elsif Aggr_Lo = Ind_Lo then 3114 Cond := 3115 Make_Op_Gt (Loc, 3116 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi), 3117 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Hi)); 3118 3119 else 3120 Cond := 3121 Make_Or_Else (Loc, 3122 Left_Opnd => 3123 Make_Op_Lt (Loc, 3124 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), 3125 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo)), 3126 3127 Right_Opnd => 3128 Make_Op_Gt (Loc, 3129 Left_Opnd => Duplicate_Subexpr (Aggr_Hi), 3130 Right_Opnd => Duplicate_Subexpr (Ind_Hi))); 3131 end if; 3132 3133 if Present (Cond) then 3134 Cond := 3135 Make_And_Then (Loc, 3136 Left_Opnd => 3137 Make_Op_Le (Loc, 3138 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), 3139 Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi)), 3140 3141 Right_Opnd => Cond); 3142 3143 Set_Analyzed (Left_Opnd (Left_Opnd (Cond)), False); 3144 Set_Analyzed (Right_Opnd (Left_Opnd (Cond)), False); 3145 Insert_Action (N, 3146 Make_Raise_Constraint_Error (Loc, 3147 Condition => Cond, 3148 Reason => CE_Length_Check_Failed)); 3149 end if; 3150 end Check_Bounds; 3151 3152 ---------------------------- 3153 -- Check_Same_Aggr_Bounds -- 3154 ---------------------------- 3155 3156 procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos) is 3157 Sub_Lo : constant Node_Id := Low_Bound (Aggregate_Bounds (Sub_Aggr)); 3158 Sub_Hi : constant Node_Id := High_Bound (Aggregate_Bounds (Sub_Aggr)); 3159 -- The bounds of this specific sub-aggregate. 3160 3161 Aggr_Lo : constant Node_Id := Aggr_Low (Dim); 3162 Aggr_Hi : constant Node_Id := Aggr_High (Dim); 3163 -- The bounds of the aggregate for this dimension 3164 3165 Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim); 3166 -- The index type for this dimension. 3167 3168 Cond : Node_Id := Empty; 3169 3170 Assoc : Node_Id; 3171 Expr : Node_Id; 3172 3173 begin 3174 -- If index checks are on generate the test 3175 -- 3176 -- [constraint_error when 3177 -- Aggr_Lo /= Sub_Lo or else Aggr_Hi /= Sub_Hi] 3178 -- 3179 -- As an optimization try to see if some tests are trivially vacuos 3180 -- because we are comparing an expression against itself. Also for 3181 -- the first dimension the test is trivially vacuous because there 3182 -- is just one aggregate for dimension 1. 3183 3184 if Index_Checks_Suppressed (Ind_Typ) then 3185 Cond := Empty; 3186 3187 elsif Dim = 1 3188 or else (Aggr_Lo = Sub_Lo and then Aggr_Hi = Sub_Hi) 3189 then 3190 Cond := Empty; 3191 3192 elsif Aggr_Hi = Sub_Hi then 3193 Cond := 3194 Make_Op_Ne (Loc, 3195 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), 3196 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo)); 3197 3198 elsif Aggr_Lo = Sub_Lo then 3199 Cond := 3200 Make_Op_Ne (Loc, 3201 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi), 3202 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Hi)); 3203 3204 else 3205 Cond := 3206 Make_Or_Else (Loc, 3207 Left_Opnd => 3208 Make_Op_Ne (Loc, 3209 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), 3210 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo)), 3211 3212 Right_Opnd => 3213 Make_Op_Ne (Loc, 3214 Left_Opnd => Duplicate_Subexpr (Aggr_Hi), 3215 Right_Opnd => Duplicate_Subexpr (Sub_Hi))); 3216 end if; 3217 3218 if Present (Cond) then 3219 Insert_Action (N, 3220 Make_Raise_Constraint_Error (Loc, 3221 Condition => Cond, 3222 Reason => CE_Length_Check_Failed)); 3223 end if; 3224 3225 -- Now look inside the sub-aggregate to see if there is more work 3226 3227 if Dim < Aggr_Dimension then 3228 3229 -- Process positional components 3230 3231 if Present (Expressions (Sub_Aggr)) then 3232 Expr := First (Expressions (Sub_Aggr)); 3233 while Present (Expr) loop 3234 Check_Same_Aggr_Bounds (Expr, Dim + 1); 3235 Next (Expr); 3236 end loop; 3237 end if; 3238 3239 -- Process component associations 3240 3241 if Present (Component_Associations (Sub_Aggr)) then 3242 Assoc := First (Component_Associations (Sub_Aggr)); 3243 while Present (Assoc) loop 3244 Expr := Expression (Assoc); 3245 Check_Same_Aggr_Bounds (Expr, Dim + 1); 3246 Next (Assoc); 3247 end loop; 3248 end if; 3249 end if; 3250 end Check_Same_Aggr_Bounds; 3251 3252 ---------------------------- 3253 -- Compute_Others_Present -- 3254 ---------------------------- 3255 3256 procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos) is 3257 Assoc : Node_Id; 3258 Expr : Node_Id; 3259 3260 begin 3261 if Present (Component_Associations (Sub_Aggr)) then 3262 Assoc := Last (Component_Associations (Sub_Aggr)); 3263 3264 if Nkind (First (Choices (Assoc))) = N_Others_Choice then 3265 Others_Present (Dim) := True; 3266 end if; 3267 end if; 3268 3269 -- Now look inside the sub-aggregate to see if there is more work 3270 3271 if Dim < Aggr_Dimension then 3272 3273 -- Process positional components 3274 3275 if Present (Expressions (Sub_Aggr)) then 3276 Expr := First (Expressions (Sub_Aggr)); 3277 while Present (Expr) loop 3278 Compute_Others_Present (Expr, Dim + 1); 3279 Next (Expr); 3280 end loop; 3281 end if; 3282 3283 -- Process component associations 3284 3285 if Present (Component_Associations (Sub_Aggr)) then 3286 Assoc := First (Component_Associations (Sub_Aggr)); 3287 while Present (Assoc) loop 3288 Expr := Expression (Assoc); 3289 Compute_Others_Present (Expr, Dim + 1); 3290 Next (Assoc); 3291 end loop; 3292 end if; 3293 end if; 3294 end Compute_Others_Present; 3295 3296 ------------------------ 3297 -- Has_Address_Clause -- 3298 ------------------------ 3299 3300 function Has_Address_Clause (D : Node_Id) return Boolean is 3301 Id : constant Entity_Id := Defining_Identifier (D); 3302 Decl : Node_Id := Next (D); 3303 3304 begin 3305 while Present (Decl) loop 3306 if Nkind (Decl) = N_At_Clause 3307 and then Chars (Identifier (Decl)) = Chars (Id) 3308 then 3309 return True; 3310 3311 elsif Nkind (Decl) = N_Attribute_Definition_Clause 3312 and then Chars (Decl) = Name_Address 3313 and then Chars (Name (Decl)) = Chars (Id) 3314 then 3315 return True; 3316 end if; 3317 3318 Next (Decl); 3319 end loop; 3320 3321 return False; 3322 end Has_Address_Clause; 3323 3324 ------------------------ 3325 -- In_Place_Assign_OK -- 3326 ------------------------ 3327 3328 function In_Place_Assign_OK return Boolean is 3329 Aggr_In : Node_Id; 3330 Aggr_Lo : Node_Id; 3331 Aggr_Hi : Node_Id; 3332 Obj_In : Node_Id; 3333 Obj_Lo : Node_Id; 3334 Obj_Hi : Node_Id; 3335 3336 function Is_Others_Aggregate (Aggr : Node_Id) return Boolean; 3337 -- Aggregates that consist of a single Others choice are safe 3338 -- if the single expression is. 3339 3340 function Safe_Aggregate (Aggr : Node_Id) return Boolean; 3341 -- Check recursively that each component of a (sub)aggregate does 3342 -- not depend on the variable being assigned to. 3343 3344 function Safe_Component (Expr : Node_Id) return Boolean; 3345 -- Verify that an expression cannot depend on the variable being 3346 -- assigned to. Room for improvement here (but less than before). 3347 3348 ------------------------- 3349 -- Is_Others_Aggregate -- 3350 ------------------------- 3351 3352 function Is_Others_Aggregate (Aggr : Node_Id) return Boolean is 3353 begin 3354 return No (Expressions (Aggr)) 3355 and then Nkind 3356 (First (Choices (First (Component_Associations (Aggr))))) 3357 = N_Others_Choice; 3358 end Is_Others_Aggregate; 3359 3360 -------------------- 3361 -- Safe_Aggregate -- 3362 -------------------- 3363 3364 function Safe_Aggregate (Aggr : Node_Id) return Boolean is 3365 Expr : Node_Id; 3366 3367 begin 3368 if Present (Expressions (Aggr)) then 3369 Expr := First (Expressions (Aggr)); 3370 3371 while Present (Expr) loop 3372 if Nkind (Expr) = N_Aggregate then 3373 if not Safe_Aggregate (Expr) then 3374 return False; 3375 end if; 3376 3377 elsif not Safe_Component (Expr) then 3378 return False; 3379 end if; 3380 3381 Next (Expr); 3382 end loop; 3383 end if; 3384 3385 if Present (Component_Associations (Aggr)) then 3386 Expr := First (Component_Associations (Aggr)); 3387 3388 while Present (Expr) loop 3389 if Nkind (Expression (Expr)) = N_Aggregate then 3390 if not Safe_Aggregate (Expression (Expr)) then 3391 return False; 3392 end if; 3393 3394 elsif not Safe_Component (Expression (Expr)) then 3395 return False; 3396 end if; 3397 3398 Next (Expr); 3399 end loop; 3400 end if; 3401 3402 return True; 3403 end Safe_Aggregate; 3404 3405 -------------------- 3406 -- Safe_Component -- 3407 -------------------- 3408 3409 function Safe_Component (Expr : Node_Id) return Boolean is 3410 Comp : Node_Id := Expr; 3411 3412 function Check_Component (Comp : Node_Id) return Boolean; 3413 -- Do the recursive traversal, after copy. 3414 3415 --------------------- 3416 -- Check_Component -- 3417 --------------------- 3418 3419 function Check_Component (Comp : Node_Id) return Boolean is 3420 begin 3421 if Is_Overloaded (Comp) then 3422 return False; 3423 end if; 3424 3425 return Compile_Time_Known_Value (Comp) 3426 3427 or else (Is_Entity_Name (Comp) 3428 and then Present (Entity (Comp)) 3429 and then No (Renamed_Object (Entity (Comp)))) 3430 3431 or else (Nkind (Comp) = N_Attribute_Reference 3432 and then Check_Component (Prefix (Comp))) 3433 3434 or else (Nkind (Comp) in N_Binary_Op 3435 and then Check_Component (Left_Opnd (Comp)) 3436 and then Check_Component (Right_Opnd (Comp))) 3437 3438 or else (Nkind (Comp) in N_Unary_Op 3439 and then Check_Component (Right_Opnd (Comp))) 3440 3441 or else (Nkind (Comp) = N_Selected_Component 3442 and then Check_Component (Prefix (Comp))); 3443 end Check_Component; 3444 3445 -- Start of processing for Safe_Component 3446 3447 begin 3448 -- If the component appears in an association that may 3449 -- correspond to more than one element, it is not analyzed 3450 -- before the expansion into assignments, to avoid side effects. 3451 -- We analyze, but do not resolve the copy, to obtain sufficient 3452 -- entity information for the checks that follow. If component is 3453 -- overloaded we assume an unsafe function call. 3454 3455 if not Analyzed (Comp) then 3456 if Is_Overloaded (Expr) then 3457 return False; 3458 3459 elsif Nkind (Expr) = N_Aggregate 3460 and then not Is_Others_Aggregate (Expr) 3461 then 3462 return False; 3463 3464 elsif Nkind (Expr) = N_Allocator then 3465 -- For now, too complex to analyze. 3466 3467 return False; 3468 end if; 3469 3470 Comp := New_Copy_Tree (Expr); 3471 Set_Parent (Comp, Parent (Expr)); 3472 Analyze (Comp); 3473 end if; 3474 3475 if Nkind (Comp) = N_Aggregate then 3476 return Safe_Aggregate (Comp); 3477 else 3478 return Check_Component (Comp); 3479 end if; 3480 end Safe_Component; 3481 3482 -- Start of processing for In_Place_Assign_OK 3483 3484 begin 3485 if Present (Component_Associations (N)) then 3486 3487 -- On assignment, sliding can take place, so we cannot do the 3488 -- assignment in place unless the bounds of the aggregate are 3489 -- statically equal to those of the target. 3490 3491 -- If the aggregate is given by an others choice, the bounds 3492 -- are derived from the left-hand side, and the assignment is 3493 -- safe if the expression is. 3494 3495 if Is_Others_Aggregate (N) then 3496 return 3497 Safe_Component 3498 (Expression (First (Component_Associations (N)))); 3499 end if; 3500 3501 Aggr_In := First_Index (Etype (N)); 3502 Obj_In := First_Index (Etype (Name (Parent (N)))); 3503 3504 while Present (Aggr_In) loop 3505 Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi); 3506 Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi); 3507 3508 if not Compile_Time_Known_Value (Aggr_Lo) 3509 or else not Compile_Time_Known_Value (Aggr_Hi) 3510 or else not Compile_Time_Known_Value (Obj_Lo) 3511 or else not Compile_Time_Known_Value (Obj_Hi) 3512 or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo) 3513 or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi) 3514 then 3515 return False; 3516 end if; 3517 3518 Next_Index (Aggr_In); 3519 Next_Index (Obj_In); 3520 end loop; 3521 end if; 3522 3523 -- Now check the component values themselves. 3524 3525 return Safe_Aggregate (N); 3526 end In_Place_Assign_OK; 3527 3528 ---------------- 3529 -- Must_Slide -- 3530 ---------------- 3531 3532 function Must_Slide (N : Node_Id; Typ : Entity_Id) return Boolean 3533 is 3534 Obj_Type : constant Entity_Id := 3535 Etype (Defining_Identifier (Parent (N))); 3536 3537 L1, L2, H1, H2 : Node_Id; 3538 3539 begin 3540 -- No sliding if the type of the object is not established yet, if 3541 -- it is an unconstrained type whose actual subtype comes from the 3542 -- aggregate, or if the two types are identical. 3543 3544 if not Is_Array_Type (Obj_Type) then 3545 return False; 3546 3547 elsif not Is_Constrained (Obj_Type) then 3548 return False; 3549 3550 elsif Typ = Obj_Type then 3551 return False; 3552 3553 else 3554 -- Sliding can only occur along the first dimension 3555 3556 Get_Index_Bounds (First_Index (Typ), L1, H1); 3557 Get_Index_Bounds (First_Index (Obj_Type), L2, H2); 3558 3559 if not Is_Static_Expression (L1) 3560 or else not Is_Static_Expression (L2) 3561 or else not Is_Static_Expression (H1) 3562 or else not Is_Static_Expression (H2) 3563 then 3564 return False; 3565 else 3566 return Expr_Value (L1) /= Expr_Value (L2) 3567 or else Expr_Value (H1) /= Expr_Value (H2); 3568 end if; 3569 end if; 3570 end Must_Slide; 3571 3572 ------------------ 3573 -- Others_Check -- 3574 ------------------ 3575 3576 procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos) is 3577 Aggr_Lo : constant Node_Id := Aggr_Low (Dim); 3578 Aggr_Hi : constant Node_Id := Aggr_High (Dim); 3579 -- The bounds of the aggregate for this dimension. 3580 3581 Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim); 3582 -- The index type for this dimension. 3583 3584 Need_To_Check : Boolean := False; 3585 3586 Choices_Lo : Node_Id := Empty; 3587 Choices_Hi : Node_Id := Empty; 3588 -- The lowest and highest discrete choices for a named sub-aggregate 3589 3590 Nb_Choices : Int := -1; 3591 -- The number of discrete non-others choices in this sub-aggregate 3592 3593 Nb_Elements : Uint := Uint_0; 3594 -- The number of elements in a positional aggregate 3595 3596 Cond : Node_Id := Empty; 3597 3598 Assoc : Node_Id; 3599 Choice : Node_Id; 3600 Expr : Node_Id; 3601 3602 begin 3603 -- Check if we have an others choice. If we do make sure that this 3604 -- sub-aggregate contains at least one element in addition to the 3605 -- others choice. 3606 3607 if Range_Checks_Suppressed (Ind_Typ) then 3608 Need_To_Check := False; 3609 3610 elsif Present (Expressions (Sub_Aggr)) 3611 and then Present (Component_Associations (Sub_Aggr)) 3612 then 3613 Need_To_Check := True; 3614 3615 elsif Present (Component_Associations (Sub_Aggr)) then 3616 Assoc := Last (Component_Associations (Sub_Aggr)); 3617 3618 if Nkind (First (Choices (Assoc))) /= N_Others_Choice then 3619 Need_To_Check := False; 3620 3621 else 3622 -- Count the number of discrete choices. Start with -1 3623 -- because the others choice does not count. 3624 3625 Nb_Choices := -1; 3626 Assoc := First (Component_Associations (Sub_Aggr)); 3627 while Present (Assoc) loop 3628 Choice := First (Choices (Assoc)); 3629 while Present (Choice) loop 3630 Nb_Choices := Nb_Choices + 1; 3631 Next (Choice); 3632 end loop; 3633 3634 Next (Assoc); 3635 end loop; 3636 3637 -- If there is only an others choice nothing to do 3638 3639 Need_To_Check := (Nb_Choices > 0); 3640 end if; 3641 3642 else 3643 Need_To_Check := False; 3644 end if; 3645 3646 -- If we are dealing with a positional sub-aggregate with an 3647 -- others choice then compute the number or positional elements. 3648 3649 if Need_To_Check and then Present (Expressions (Sub_Aggr)) then 3650 Expr := First (Expressions (Sub_Aggr)); 3651 Nb_Elements := Uint_0; 3652 while Present (Expr) loop 3653 Nb_Elements := Nb_Elements + 1; 3654 Next (Expr); 3655 end loop; 3656 3657 -- If the aggregate contains discrete choices and an others choice 3658 -- compute the smallest and largest discrete choice values. 3659 3660 elsif Need_To_Check then 3661 Compute_Choices_Lo_And_Choices_Hi : declare 3662 3663 Table : Case_Table_Type (1 .. Nb_Choices); 3664 -- Used to sort all the different choice values 3665 3666 J : Pos := 1; 3667 Low : Node_Id; 3668 High : Node_Id; 3669 3670 begin 3671 Assoc := First (Component_Associations (Sub_Aggr)); 3672 while Present (Assoc) loop 3673 Choice := First (Choices (Assoc)); 3674 while Present (Choice) loop 3675 if Nkind (Choice) = N_Others_Choice then 3676 exit; 3677 end if; 3678 3679 Get_Index_Bounds (Choice, Low, High); 3680 Table (J).Choice_Lo := Low; 3681 Table (J).Choice_Hi := High; 3682 3683 J := J + 1; 3684 Next (Choice); 3685 end loop; 3686 3687 Next (Assoc); 3688 end loop; 3689 3690 -- Sort the discrete choices 3691 3692 Sort_Case_Table (Table); 3693 3694 Choices_Lo := Table (1).Choice_Lo; 3695 Choices_Hi := Table (Nb_Choices).Choice_Hi; 3696 end Compute_Choices_Lo_And_Choices_Hi; 3697 end if; 3698 3699 -- If no others choice in this sub-aggregate, or the aggregate 3700 -- comprises only an others choice, nothing to do. 3701 3702 if not Need_To_Check then 3703 Cond := Empty; 3704 3705 -- If we are dealing with an aggregate containing an others 3706 -- choice and positional components, we generate the following test: 3707 -- 3708 -- if Ind_Typ'Pos (Aggr_Lo) + (Nb_Elements - 1) > 3709 -- Ind_Typ'Pos (Aggr_Hi) 3710 -- then 3711 -- raise Constraint_Error; 3712 -- end if; 3713 3714 elsif Nb_Elements > Uint_0 then 3715 Cond := 3716 Make_Op_Gt (Loc, 3717 Left_Opnd => 3718 Make_Op_Add (Loc, 3719 Left_Opnd => 3720 Make_Attribute_Reference (Loc, 3721 Prefix => New_Reference_To (Ind_Typ, Loc), 3722 Attribute_Name => Name_Pos, 3723 Expressions => 3724 New_List 3725 (Duplicate_Subexpr_Move_Checks (Aggr_Lo))), 3726 Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)), 3727 3728 Right_Opnd => 3729 Make_Attribute_Reference (Loc, 3730 Prefix => New_Reference_To (Ind_Typ, Loc), 3731 Attribute_Name => Name_Pos, 3732 Expressions => New_List ( 3733 Duplicate_Subexpr_Move_Checks (Aggr_Hi)))); 3734 3735 -- If we are dealing with an aggregate containing an others 3736 -- choice and discrete choices we generate the following test: 3737 -- 3738 -- [constraint_error when 3739 -- Choices_Lo < Aggr_Lo or else Choices_Hi > Aggr_Hi]; 3740 3741 else 3742 Cond := 3743 Make_Or_Else (Loc, 3744 Left_Opnd => 3745 Make_Op_Lt (Loc, 3746 Left_Opnd => 3747 Duplicate_Subexpr_Move_Checks (Choices_Lo), 3748 Right_Opnd => 3749 Duplicate_Subexpr_Move_Checks (Aggr_Lo)), 3750 3751 Right_Opnd => 3752 Make_Op_Gt (Loc, 3753 Left_Opnd => 3754 Duplicate_Subexpr (Choices_Hi), 3755 Right_Opnd => 3756 Duplicate_Subexpr (Aggr_Hi))); 3757 end if; 3758 3759 if Present (Cond) then 3760 Insert_Action (N, 3761 Make_Raise_Constraint_Error (Loc, 3762 Condition => Cond, 3763 Reason => CE_Length_Check_Failed)); 3764 end if; 3765 3766 -- Now look inside the sub-aggregate to see if there is more work 3767 3768 if Dim < Aggr_Dimension then 3769 3770 -- Process positional components 3771 3772 if Present (Expressions (Sub_Aggr)) then 3773 Expr := First (Expressions (Sub_Aggr)); 3774 while Present (Expr) loop 3775 Others_Check (Expr, Dim + 1); 3776 Next (Expr); 3777 end loop; 3778 end if; 3779 3780 -- Process component associations 3781 3782 if Present (Component_Associations (Sub_Aggr)) then 3783 Assoc := First (Component_Associations (Sub_Aggr)); 3784 while Present (Assoc) loop 3785 Expr := Expression (Assoc); 3786 Others_Check (Expr, Dim + 1); 3787 Next (Assoc); 3788 end loop; 3789 end if; 3790 end if; 3791 end Others_Check; 3792 3793 -- Remaining Expand_Array_Aggregate variables 3794 3795 Tmp : Entity_Id; 3796 -- Holds the temporary aggregate value 3797 3798 Tmp_Decl : Node_Id; 3799 -- Holds the declaration of Tmp 3800 3801 Aggr_Code : List_Id; 3802 Parent_Node : Node_Id; 3803 Parent_Kind : Node_Kind; 3804 3805 -- Start of processing for Expand_Array_Aggregate 3806 3807 begin 3808 -- Do not touch the special aggregates of attributes used for Asm calls 3809 3810 if Is_RTE (Ctyp, RE_Asm_Input_Operand) 3811 or else Is_RTE (Ctyp, RE_Asm_Output_Operand) 3812 then 3813 return; 3814 end if; 3815 3816 -- If the semantic analyzer has determined that aggregate N will raise 3817 -- Constraint_Error at run-time, then the aggregate node has been 3818 -- replaced with an N_Raise_Constraint_Error node and we should 3819 -- never get here. 3820 3821 pragma Assert (not Raises_Constraint_Error (N)); 3822 3823 -- STEP 1a. 3824 3825 -- Check that the index range defined by aggregate bounds is 3826 -- compatible with corresponding index subtype. 3827 3828 Index_Compatibility_Check : declare 3829 Aggr_Index_Range : Node_Id := First_Index (Typ); 3830 -- The current aggregate index range 3831 3832 Index_Constraint : Node_Id := First_Index (Etype (Typ)); 3833 -- The corresponding index constraint against which we have to 3834 -- check the above aggregate index range. 3835 3836 begin 3837 Compute_Others_Present (N, 1); 3838 3839 for J in 1 .. Aggr_Dimension loop 3840 -- There is no need to emit a check if an others choice is 3841 -- present for this array aggregate dimension since in this 3842 -- case one of N's sub-aggregates has taken its bounds from the 3843 -- context and these bounds must have been checked already. In 3844 -- addition all sub-aggregates corresponding to the same 3845 -- dimension must all have the same bounds (checked in (c) below). 3846 3847 if not Range_Checks_Suppressed (Etype (Index_Constraint)) 3848 and then not Others_Present (J) 3849 then 3850 -- We don't use Checks.Apply_Range_Check here because it 3851 -- emits a spurious check. Namely it checks that the range 3852 -- defined by the aggregate bounds is non empty. But we know 3853 -- this already if we get here. 3854 3855 Check_Bounds (Aggr_Index_Range, Index_Constraint); 3856 end if; 3857 3858 -- Save the low and high bounds of the aggregate index as well 3859 -- as the index type for later use in checks (b) and (c) below. 3860 3861 Aggr_Low (J) := Low_Bound (Aggr_Index_Range); 3862 Aggr_High (J) := High_Bound (Aggr_Index_Range); 3863 3864 Aggr_Index_Typ (J) := Etype (Index_Constraint); 3865 3866 Next_Index (Aggr_Index_Range); 3867 Next_Index (Index_Constraint); 3868 end loop; 3869 end Index_Compatibility_Check; 3870 3871 -- STEP 1b. 3872 3873 -- If an others choice is present check that no aggregate 3874 -- index is outside the bounds of the index constraint. 3875 3876 Others_Check (N, 1); 3877 3878 -- STEP 1c. 3879 3880 -- For multidimensional arrays make sure that all subaggregates 3881 -- corresponding to the same dimension have the same bounds. 3882 3883 if Aggr_Dimension > 1 then 3884 Check_Same_Aggr_Bounds (N, 1); 3885 end if; 3886 3887 -- STEP 2. 3888 3889 -- Here we test for is packed array aggregate that we can handle 3890 -- at compile time. If so, return with transformation done. Note 3891 -- that we do this even if the aggregate is nested, because once 3892 -- we have done this processing, there is no more nested aggregate! 3893 3894 if Packed_Array_Aggregate_Handled (N) then 3895 return; 3896 end if; 3897 3898 -- At this point we try to convert to positional form 3899 3900 Convert_To_Positional (N); 3901 3902 -- if the result is no longer an aggregate (e.g. it may be a string 3903 -- literal, or a temporary which has the needed value), then we are 3904 -- done, since there is no longer a nested aggregate. 3905 3906 if Nkind (N) /= N_Aggregate then 3907 return; 3908 3909 -- We are also done if the result is an analyzed aggregate 3910 -- This case could use more comments ??? 3911 3912 elsif Analyzed (N) 3913 and then N /= Original_Node (N) 3914 then 3915 return; 3916 end if; 3917 3918 -- Now see if back end processing is possible 3919 3920 if Backend_Processing_Possible (N) then 3921 3922 -- If the aggregate is static but the constraints are not, build 3923 -- a static subtype for the aggregate, so that Gigi can place it 3924 -- in static memory. Perform an unchecked_conversion to the non- 3925 -- static type imposed by the context. 3926 3927 declare 3928 Itype : constant Entity_Id := Etype (N); 3929 Index : Node_Id; 3930 Needs_Type : Boolean := False; 3931 3932 begin 3933 Index := First_Index (Itype); 3934 3935 while Present (Index) loop 3936 if not Is_Static_Subtype (Etype (Index)) then 3937 Needs_Type := True; 3938 exit; 3939 else 3940 Next_Index (Index); 3941 end if; 3942 end loop; 3943 3944 if Needs_Type then 3945 Build_Constrained_Type (Positional => True); 3946 Rewrite (N, Unchecked_Convert_To (Itype, N)); 3947 Analyze (N); 3948 end if; 3949 end; 3950 3951 return; 3952 end if; 3953 3954 -- STEP 3. 3955 3956 -- Delay expansion for nested aggregates it will be taken care of 3957 -- when the parent aggregate is expanded 3958 3959 Parent_Node := Parent (N); 3960 Parent_Kind := Nkind (Parent_Node); 3961 3962 if Parent_Kind = N_Qualified_Expression then 3963 Parent_Node := Parent (Parent_Node); 3964 Parent_Kind := Nkind (Parent_Node); 3965 end if; 3966 3967 if Parent_Kind = N_Aggregate 3968 or else Parent_Kind = N_Extension_Aggregate 3969 or else Parent_Kind = N_Component_Association 3970 or else (Parent_Kind = N_Object_Declaration 3971 and then Controlled_Type (Typ)) 3972 or else (Parent_Kind = N_Assignment_Statement 3973 and then Inside_Init_Proc) 3974 then 3975 Set_Expansion_Delayed (N); 3976 return; 3977 end if; 3978 3979 -- STEP 4. 3980 3981 -- Look if in place aggregate expansion is possible 3982 3983 -- For object declarations we build the aggregate in place, unless 3984 -- the array is bit-packed or the component is controlled. 3985 3986 -- For assignments we do the assignment in place if all the component 3987 -- associations have compile-time known values. For other cases we 3988 -- create a temporary. The analysis for safety of on-line assignment 3989 -- is delicate, i.e. we don't know how to do it fully yet ??? 3990 3991 if Requires_Transient_Scope (Typ) then 3992 Establish_Transient_Scope 3993 (N, Sec_Stack => Has_Controlled_Component (Typ)); 3994 end if; 3995 3996 if Has_Default_Init_Comps (N) then 3997 Maybe_In_Place_OK := False; 3998 else 3999 Maybe_In_Place_OK := 4000 Comes_From_Source (N) 4001 and then Nkind (Parent (N)) = N_Assignment_Statement 4002 and then not Is_Bit_Packed_Array (Typ) 4003 and then not Has_Controlled_Component (Typ) 4004 and then In_Place_Assign_OK; 4005 end if; 4006 4007 if not Has_Default_Init_Comps (N) 4008 and then Comes_From_Source (Parent (N)) 4009 and then Nkind (Parent (N)) = N_Object_Declaration 4010 and then not Must_Slide (N, Typ) 4011 and then N = Expression (Parent (N)) 4012 and then not Is_Bit_Packed_Array (Typ) 4013 and then not Has_Controlled_Component (Typ) 4014 and then not Has_Address_Clause (Parent (N)) 4015 then 4016 Tmp := Defining_Identifier (Parent (N)); 4017 Set_No_Initialization (Parent (N)); 4018 Set_Expression (Parent (N), Empty); 4019 4020 -- Set the type of the entity, for use in the analysis of the 4021 -- subsequent indexed assignments. If the nominal type is not 4022 -- constrained, build a subtype from the known bounds of the 4023 -- aggregate. If the declaration has a subtype mark, use it, 4024 -- otherwise use the itype of the aggregate. 4025 4026 if not Is_Constrained (Typ) then 4027 Build_Constrained_Type (Positional => False); 4028 elsif Is_Entity_Name (Object_Definition (Parent (N))) 4029 and then Is_Constrained (Entity (Object_Definition (Parent (N)))) 4030 then 4031 Set_Etype (Tmp, Entity (Object_Definition (Parent (N)))); 4032 else 4033 Set_Size_Known_At_Compile_Time (Typ, False); 4034 Set_Etype (Tmp, Typ); 4035 end if; 4036 4037 elsif Maybe_In_Place_OK 4038 and then Is_Entity_Name (Name (Parent (N))) 4039 then 4040 Tmp := Entity (Name (Parent (N))); 4041 4042 if Etype (Tmp) /= Etype (N) then 4043 Apply_Length_Check (N, Etype (Tmp)); 4044 4045 if Nkind (N) = N_Raise_Constraint_Error then 4046 4047 -- Static error, nothing further to expand 4048 4049 return; 4050 end if; 4051 end if; 4052 4053 elsif Maybe_In_Place_OK 4054 and then Nkind (Name (Parent (N))) = N_Explicit_Dereference 4055 and then Is_Entity_Name (Prefix (Name (Parent (N)))) 4056 then 4057 Tmp := Name (Parent (N)); 4058 4059 if Etype (Tmp) /= Etype (N) then 4060 Apply_Length_Check (N, Etype (Tmp)); 4061 end if; 4062 4063 elsif Maybe_In_Place_OK 4064 and then Nkind (Name (Parent (N))) = N_Slice 4065 and then Safe_Slice_Assignment (N) 4066 then 4067 -- Safe_Slice_Assignment rewrites assignment as a loop 4068 4069 return; 4070 4071 -- Step 5 4072 4073 -- In place aggregate expansion is not possible 4074 4075 else 4076 Maybe_In_Place_OK := False; 4077 Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); 4078 Tmp_Decl := 4079 Make_Object_Declaration 4080 (Loc, 4081 Defining_Identifier => Tmp, 4082 Object_Definition => New_Occurrence_Of (Typ, Loc)); 4083 Set_No_Initialization (Tmp_Decl, True); 4084 4085 -- If we are within a loop, the temporary will be pushed on the 4086 -- stack at each iteration. If the aggregate is the expression for 4087 -- an allocator, it will be immediately copied to the heap and can 4088 -- be reclaimed at once. We create a transient scope around the 4089 -- aggregate for this purpose. 4090 4091 if Ekind (Current_Scope) = E_Loop 4092 and then Nkind (Parent (Parent (N))) = N_Allocator 4093 then 4094 Establish_Transient_Scope (N, False); 4095 end if; 4096 4097 Insert_Action (N, Tmp_Decl); 4098 end if; 4099 4100 -- Construct and insert the aggregate code. We can safely suppress 4101 -- index checks because this code is guaranteed not to raise CE 4102 -- on index checks. However we should *not* suppress all checks. 4103 4104 declare 4105 Target : Node_Id; 4106 4107 begin 4108 if Nkind (Tmp) = N_Defining_Identifier then 4109 Target := New_Reference_To (Tmp, Loc); 4110 4111 else 4112 4113 if Has_Default_Init_Comps (N) then 4114 4115 -- Ada0Y (AI-287): This case has not been analyzed??? 4116 4117 pragma Assert (False); 4118 null; 4119 end if; 4120 4121 -- Name in assignment is explicit dereference. 4122 4123 Target := New_Copy (Tmp); 4124 end if; 4125 4126 Aggr_Code := 4127 Build_Array_Aggr_Code (N, 4128 Ctype => Ctyp, 4129 Index => First_Index (Typ), 4130 Into => Target, 4131 Scalar_Comp => Is_Scalar_Type (Ctyp)); 4132 end; 4133 4134 if Comes_From_Source (Tmp) then 4135 Insert_Actions_After (Parent (N), Aggr_Code); 4136 4137 else 4138 Insert_Actions (N, Aggr_Code); 4139 end if; 4140 4141 -- If the aggregate has been assigned in place, remove the original 4142 -- assignment. 4143 4144 if Nkind (Parent (N)) = N_Assignment_Statement 4145 and then Maybe_In_Place_OK 4146 then 4147 Rewrite (Parent (N), Make_Null_Statement (Loc)); 4148 4149 elsif Nkind (Parent (N)) /= N_Object_Declaration 4150 or else Tmp /= Defining_Identifier (Parent (N)) 4151 then 4152 Rewrite (N, New_Occurrence_Of (Tmp, Loc)); 4153 Analyze_And_Resolve (N, Typ); 4154 end if; 4155 end Expand_Array_Aggregate; 4156 4157 ------------------------ 4158 -- Expand_N_Aggregate -- 4159 ------------------------ 4160 4161 procedure Expand_N_Aggregate (N : Node_Id) is 4162 begin 4163 if Is_Record_Type (Etype (N)) then 4164 Expand_Record_Aggregate (N); 4165 else 4166 Expand_Array_Aggregate (N); 4167 end if; 4168 4169 exception 4170 when RE_Not_Available => 4171 return; 4172 end Expand_N_Aggregate; 4173 4174 ---------------------------------- 4175 -- Expand_N_Extension_Aggregate -- 4176 ---------------------------------- 4177 4178 -- If the ancestor part is an expression, add a component association for 4179 -- the parent field. If the type of the ancestor part is not the direct 4180 -- parent of the expected type, build recursively the needed ancestors. 4181 -- If the ancestor part is a subtype_mark, replace aggregate with a decla- 4182 -- ration for a temporary of the expected type, followed by individual 4183 -- assignments to the given components. 4184 4185 procedure Expand_N_Extension_Aggregate (N : Node_Id) is 4186 Loc : constant Source_Ptr := Sloc (N); 4187 A : constant Node_Id := Ancestor_Part (N); 4188 Typ : constant Entity_Id := Etype (N); 4189 4190 begin 4191 -- If the ancestor is a subtype mark, an init proc must be called 4192 -- on the resulting object which thus has to be materialized in 4193 -- the front-end 4194 4195 if Is_Entity_Name (A) and then Is_Type (Entity (A)) then 4196 Convert_To_Assignments (N, Typ); 4197 4198 -- The extension aggregate is transformed into a record aggregate 4199 -- of the following form (c1 and c2 are inherited components) 4200 4201 -- (Exp with c3 => a, c4 => b) 4202 -- ==> (c1 => Exp.c1, c2 => Exp.c2, c1 => a, c2 => b) 4203 4204 else 4205 Set_Etype (N, Typ); 4206 4207 -- No tag is needed in the case of Java_VM 4208 4209 if Java_VM then 4210 Expand_Record_Aggregate (N, 4211 Parent_Expr => A); 4212 else 4213 Expand_Record_Aggregate (N, 4214 Orig_Tag => New_Occurrence_Of (Access_Disp_Table (Typ), Loc), 4215 Parent_Expr => A); 4216 end if; 4217 end if; 4218 4219 exception 4220 when RE_Not_Available => 4221 return; 4222 end Expand_N_Extension_Aggregate; 4223 4224 ----------------------------- 4225 -- Expand_Record_Aggregate -- 4226 ----------------------------- 4227 4228 procedure Expand_Record_Aggregate 4229 (N : Node_Id; 4230 Orig_Tag : Node_Id := Empty; 4231 Parent_Expr : Node_Id := Empty) 4232 is 4233 Loc : constant Source_Ptr := Sloc (N); 4234 Comps : constant List_Id := Component_Associations (N); 4235 Typ : constant Entity_Id := Etype (N); 4236 Base_Typ : constant Entity_Id := Base_Type (Typ); 4237 4238 function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean; 4239 -- Checks the presence of a nested aggregate which needs Late_Expansion 4240 -- or the presence of tagged components which may need tag adjustment. 4241 4242 -------------------------------------------------- 4243 -- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps -- 4244 -------------------------------------------------- 4245 4246 function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean is 4247 C : Node_Id; 4248 Expr_Q : Node_Id; 4249 4250 begin 4251 if No (Comps) then 4252 return False; 4253 end if; 4254 4255 C := First (Comps); 4256 while Present (C) loop 4257 if Nkind (Expression (C)) = N_Qualified_Expression then 4258 Expr_Q := Expression (Expression (C)); 4259 else 4260 Expr_Q := Expression (C); 4261 end if; 4262 4263 -- Return true if the aggregate has any associations for 4264 -- tagged components that may require tag adjustment. 4265 -- These are cases where the source expression may have 4266 -- a tag that could differ from the component tag (e.g., 4267 -- can occur for type conversions and formal parameters). 4268 -- (Tag adjustment is not needed if Java_VM because object 4269 -- tags are implicit in the JVM.) 4270 4271 if Is_Tagged_Type (Etype (Expr_Q)) 4272 and then (Nkind (Expr_Q) = N_Type_Conversion 4273 or else (Is_Entity_Name (Expr_Q) 4274 and then Ekind (Entity (Expr_Q)) in Formal_Kind)) 4275 and then not Java_VM 4276 then 4277 return True; 4278 end if; 4279 4280 if Is_Delayed_Aggregate (Expr_Q) then 4281 return True; 4282 end if; 4283 4284 Next (C); 4285 end loop; 4286 4287 return False; 4288 end Has_Delayed_Nested_Aggregate_Or_Tagged_Comps; 4289 4290 -- Remaining Expand_Record_Aggregate variables 4291 4292 Tag_Value : Node_Id; 4293 Comp : Entity_Id; 4294 New_Comp : Node_Id; 4295 4296 -- Start of processing for Expand_Record_Aggregate 4297 4298 begin 4299 -- If the aggregate is to be assigned to an atomic variable, we 4300 -- have to prevent a piecemeal assignment even if the aggregate 4301 -- is to be expanded. We create a temporary for the aggregate, and 4302 -- assign the temporary instead, so that the back end can generate 4303 -- an atomic move for it. 4304 4305 if Is_Atomic (Typ) 4306 and then (Nkind (Parent (N)) = N_Object_Declaration 4307 or else Nkind (Parent (N)) = N_Assignment_Statement) 4308 and then Comes_From_Source (Parent (N)) 4309 then 4310 Expand_Atomic_Aggregate (N, Typ); 4311 return; 4312 end if; 4313 4314 -- Gigi doesn't handle properly temporaries of variable size 4315 -- so we generate it in the front-end 4316 4317 if not Size_Known_At_Compile_Time (Typ) then 4318 Convert_To_Assignments (N, Typ); 4319 4320 -- Temporaries for controlled aggregates need to be attached to a 4321 -- final chain in order to be properly finalized, so it has to 4322 -- be created in the front-end 4323 4324 elsif Is_Controlled (Typ) 4325 or else Has_Controlled_Component (Base_Type (Typ)) 4326 then 4327 Convert_To_Assignments (N, Typ); 4328 4329 -- Ada0Y (AI-287): In case of default initialized components we convert 4330 -- the aggregate into assignments. 4331 4332 elsif Has_Default_Init_Comps (N) then 4333 Convert_To_Assignments (N, Typ); 4334 4335 elsif Has_Delayed_Nested_Aggregate_Or_Tagged_Comps then 4336 Convert_To_Assignments (N, Typ); 4337 4338 -- If an ancestor is private, some components are not inherited and 4339 -- we cannot expand into a record aggregate 4340 4341 elsif Has_Private_Ancestor (Typ) then 4342 Convert_To_Assignments (N, Typ); 4343 4344 -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi 4345 -- is not able to handle the aggregate for Late_Request. 4346 4347 elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then 4348 Convert_To_Assignments (N, Typ); 4349 4350 -- If some components are mutable, the size of the aggregate component 4351 -- may be disctinct from the default size of the type component, so 4352 -- we need to expand to insure that the back-end copies the proper 4353 -- size of the data. 4354 4355 elsif Has_Mutable_Components (Typ) then 4356 Convert_To_Assignments (N, Typ); 4357 4358 -- If the type involved has any non-bit aligned components, then 4359 -- we are not sure that the back end can handle this case correctly. 4360 4361 elsif Type_May_Have_Bit_Aligned_Components (Typ) then 4362 Convert_To_Assignments (N, Typ); 4363 4364 -- In all other cases we generate a proper aggregate that 4365 -- can be handled by gigi. 4366 4367 else 4368 -- If no discriminants, nothing special to do 4369 4370 if not Has_Discriminants (Typ) then 4371 null; 4372 4373 -- Case of discriminants present 4374 4375 elsif Is_Derived_Type (Typ) then 4376 4377 -- For untagged types, non-stored discriminants are replaced 4378 -- with stored discriminants, which are the ones that gigi uses 4379 -- to describe the type and its components. 4380 4381 Generate_Aggregate_For_Derived_Type : declare 4382 Constraints : constant List_Id := New_List; 4383 First_Comp : Node_Id; 4384 Discriminant : Entity_Id; 4385 Decl : Node_Id; 4386 Num_Disc : Int := 0; 4387 Num_Gird : Int := 0; 4388 4389 procedure Prepend_Stored_Values (T : Entity_Id); 4390 -- Scan the list of stored discriminants of the type, and 4391 -- add their values to the aggregate being built. 4392 4393 --------------------------- 4394 -- Prepend_Stored_Values -- 4395 --------------------------- 4396 4397 procedure Prepend_Stored_Values (T : Entity_Id) is 4398 begin 4399 Discriminant := First_Stored_Discriminant (T); 4400 4401 while Present (Discriminant) loop 4402 New_Comp := 4403 Make_Component_Association (Loc, 4404 Choices => 4405 New_List (New_Occurrence_Of (Discriminant, Loc)), 4406 4407 Expression => 4408 New_Copy_Tree ( 4409 Get_Discriminant_Value ( 4410 Discriminant, 4411 Typ, 4412 Discriminant_Constraint (Typ)))); 4413 4414 if No (First_Comp) then 4415 Prepend_To (Component_Associations (N), New_Comp); 4416 else 4417 Insert_After (First_Comp, New_Comp); 4418 end if; 4419 4420 First_Comp := New_Comp; 4421 Next_Stored_Discriminant (Discriminant); 4422 end loop; 4423 end Prepend_Stored_Values; 4424 4425 -- Start of processing for Generate_Aggregate_For_Derived_Type 4426 4427 begin 4428 -- Remove the associations for the discriminant of 4429 -- the derived type. 4430 4431 First_Comp := First (Component_Associations (N)); 4432 4433 while Present (First_Comp) loop 4434 Comp := First_Comp; 4435 Next (First_Comp); 4436 4437 if Ekind (Entity (First (Choices (Comp)))) = 4438 E_Discriminant 4439 then 4440 Remove (Comp); 4441 Num_Disc := Num_Disc + 1; 4442 end if; 4443 end loop; 4444 4445 -- Insert stored discriminant associations in the correct 4446 -- order. If there are more stored discriminants than new 4447 -- discriminants, there is at least one new discriminant 4448 -- that constrains more than one of the stored discriminants. 4449 -- In this case we need to construct a proper subtype of 4450 -- the parent type, in order to supply values to all the 4451 -- components. Otherwise there is one-one correspondence 4452 -- between the constraints and the stored discriminants. 4453 4454 First_Comp := Empty; 4455 4456 Discriminant := First_Stored_Discriminant (Base_Type (Typ)); 4457 4458 while Present (Discriminant) loop 4459 Num_Gird := Num_Gird + 1; 4460 Next_Stored_Discriminant (Discriminant); 4461 end loop; 4462 4463 -- Case of more stored discriminants than new discriminants 4464 4465 if Num_Gird > Num_Disc then 4466 4467 -- Create a proper subtype of the parent type, which is 4468 -- the proper implementation type for the aggregate, and 4469 -- convert it to the intended target type. 4470 4471 Discriminant := First_Stored_Discriminant (Base_Type (Typ)); 4472 4473 while Present (Discriminant) loop 4474 New_Comp := 4475 New_Copy_Tree ( 4476 Get_Discriminant_Value ( 4477 Discriminant, 4478 Typ, 4479 Discriminant_Constraint (Typ))); 4480 Append (New_Comp, Constraints); 4481 Next_Stored_Discriminant (Discriminant); 4482 end loop; 4483 4484 Decl := 4485 Make_Subtype_Declaration (Loc, 4486 Defining_Identifier => 4487 Make_Defining_Identifier (Loc, 4488 New_Internal_Name ('T')), 4489 Subtype_Indication => 4490 Make_Subtype_Indication (Loc, 4491 Subtype_Mark => 4492 New_Occurrence_Of (Etype (Base_Type (Typ)), Loc), 4493 Constraint => 4494 Make_Index_Or_Discriminant_Constraint 4495 (Loc, Constraints))); 4496 4497 Insert_Action (N, Decl); 4498 Prepend_Stored_Values (Base_Type (Typ)); 4499 4500 Set_Etype (N, Defining_Identifier (Decl)); 4501 Set_Analyzed (N); 4502 4503 Rewrite (N, Unchecked_Convert_To (Typ, N)); 4504 Analyze (N); 4505 4506 -- Case where we do not have fewer new discriminants than 4507 -- stored discriminants, so in this case we can simply 4508 -- use the stored discriminants of the subtype. 4509 4510 else 4511 Prepend_Stored_Values (Typ); 4512 end if; 4513 end Generate_Aggregate_For_Derived_Type; 4514 end if; 4515 4516 if Is_Tagged_Type (Typ) then 4517 4518 -- The tagged case, _parent and _tag component must be created. 4519 4520 -- Reset null_present unconditionally. tagged records always have 4521 -- at least one field (the tag or the parent) 4522 4523 Set_Null_Record_Present (N, False); 4524 4525 -- When the current aggregate comes from the expansion of an 4526 -- extension aggregate, the parent expr is replaced by an 4527 -- aggregate formed by selected components of this expr 4528 4529 if Present (Parent_Expr) 4530 and then Is_Empty_List (Comps) 4531 then 4532 Comp := First_Entity (Typ); 4533 while Present (Comp) loop 4534 4535 -- Skip all entities that aren't discriminants or components 4536 4537 if Ekind (Comp) /= E_Discriminant 4538 and then Ekind (Comp) /= E_Component 4539 then 4540 null; 4541 4542 -- Skip all expander-generated components 4543 4544 elsif 4545 not Comes_From_Source (Original_Record_Component (Comp)) 4546 then 4547 null; 4548 4549 else 4550 New_Comp := 4551 Make_Selected_Component (Loc, 4552 Prefix => 4553 Unchecked_Convert_To (Typ, 4554 Duplicate_Subexpr (Parent_Expr, True)), 4555 4556 Selector_Name => New_Occurrence_Of (Comp, Loc)); 4557 4558 Append_To (Comps, 4559 Make_Component_Association (Loc, 4560 Choices => 4561 New_List (New_Occurrence_Of (Comp, Loc)), 4562 Expression => 4563 New_Comp)); 4564 4565 Analyze_And_Resolve (New_Comp, Etype (Comp)); 4566 end if; 4567 4568 Next_Entity (Comp); 4569 end loop; 4570 end if; 4571 4572 -- Compute the value for the Tag now, if the type is a root it 4573 -- will be included in the aggregate right away, otherwise it will 4574 -- be propagated to the parent aggregate 4575 4576 if Present (Orig_Tag) then 4577 Tag_Value := Orig_Tag; 4578 elsif Java_VM then 4579 Tag_Value := Empty; 4580 else 4581 Tag_Value := New_Occurrence_Of (Access_Disp_Table (Typ), Loc); 4582 end if; 4583 4584 -- For a derived type, an aggregate for the parent is formed with 4585 -- all the inherited components. 4586 4587 if Is_Derived_Type (Typ) then 4588 4589 declare 4590 First_Comp : Node_Id; 4591 Parent_Comps : List_Id; 4592 Parent_Aggr : Node_Id; 4593 Parent_Name : Node_Id; 4594 4595 begin 4596 -- Remove the inherited component association from the 4597 -- aggregate and store them in the parent aggregate 4598 4599 First_Comp := First (Component_Associations (N)); 4600 Parent_Comps := New_List; 4601 4602 while Present (First_Comp) 4603 and then Scope (Original_Record_Component ( 4604 Entity (First (Choices (First_Comp))))) /= Base_Typ 4605 loop 4606 Comp := First_Comp; 4607 Next (First_Comp); 4608 Remove (Comp); 4609 Append (Comp, Parent_Comps); 4610 end loop; 4611 4612 Parent_Aggr := Make_Aggregate (Loc, 4613 Component_Associations => Parent_Comps); 4614 Set_Etype (Parent_Aggr, Etype (Base_Type (Typ))); 4615 4616 -- Find the _parent component 4617 4618 Comp := First_Component (Typ); 4619 while Chars (Comp) /= Name_uParent loop 4620 Comp := Next_Component (Comp); 4621 end loop; 4622 4623 Parent_Name := New_Occurrence_Of (Comp, Loc); 4624 4625 -- Insert the parent aggregate 4626 4627 Prepend_To (Component_Associations (N), 4628 Make_Component_Association (Loc, 4629 Choices => New_List (Parent_Name), 4630 Expression => Parent_Aggr)); 4631 4632 -- Expand recursively the parent propagating the right Tag 4633 4634 Expand_Record_Aggregate ( 4635 Parent_Aggr, Tag_Value, Parent_Expr); 4636 end; 4637 4638 -- For a root type, the tag component is added (unless compiling 4639 -- for the Java VM, where tags are implicit). 4640 4641 elsif not Java_VM then 4642 declare 4643 Tag_Name : constant Node_Id := 4644 New_Occurrence_Of (Tag_Component (Typ), Loc); 4645 Typ_Tag : constant Entity_Id := RTE (RE_Tag); 4646 Conv_Node : constant Node_Id := 4647 Unchecked_Convert_To (Typ_Tag, Tag_Value); 4648 4649 begin 4650 Set_Etype (Conv_Node, Typ_Tag); 4651 Prepend_To (Component_Associations (N), 4652 Make_Component_Association (Loc, 4653 Choices => New_List (Tag_Name), 4654 Expression => Conv_Node)); 4655 end; 4656 end if; 4657 end if; 4658 end if; 4659 end Expand_Record_Aggregate; 4660 4661 ---------------------------- 4662 -- Has_Default_Init_Comps -- 4663 ---------------------------- 4664 4665 function Has_Default_Init_Comps (N : Node_Id) return Boolean is 4666 Comps : constant List_Id := Component_Associations (N); 4667 C : Node_Id; 4668 Expr : Node_Id; 4669 begin 4670 pragma Assert (Nkind (N) = N_Aggregate 4671 or else Nkind (N) = N_Extension_Aggregate); 4672 4673 if No (Comps) then 4674 return False; 4675 end if; 4676 4677 -- Check if any direct component has default initialized components 4678 4679 C := First (Comps); 4680 while Present (C) loop 4681 if Box_Present (C) then 4682 return True; 4683 end if; 4684 4685 Next (C); 4686 end loop; 4687 4688 -- Recursive call in case of aggregate expression 4689 4690 C := First (Comps); 4691 while Present (C) loop 4692 Expr := Expression (C); 4693 4694 if Present (Expr) 4695 and then (Nkind (Expr) = N_Aggregate 4696 or else Nkind (Expr) = N_Extension_Aggregate) 4697 and then Has_Default_Init_Comps (Expr) 4698 then 4699 return True; 4700 end if; 4701 4702 Next (C); 4703 end loop; 4704 4705 return False; 4706 end Has_Default_Init_Comps; 4707 4708 -------------------------- 4709 -- Is_Delayed_Aggregate -- 4710 -------------------------- 4711 4712 function Is_Delayed_Aggregate (N : Node_Id) return Boolean is 4713 Node : Node_Id := N; 4714 Kind : Node_Kind := Nkind (Node); 4715 4716 begin 4717 if Kind = N_Qualified_Expression then 4718 Node := Expression (Node); 4719 Kind := Nkind (Node); 4720 end if; 4721 4722 if Kind /= N_Aggregate and then Kind /= N_Extension_Aggregate then 4723 return False; 4724 else 4725 return Expansion_Delayed (Node); 4726 end if; 4727 end Is_Delayed_Aggregate; 4728 4729 -------------------- 4730 -- Late_Expansion -- 4731 -------------------- 4732 4733 function Late_Expansion 4734 (N : Node_Id; 4735 Typ : Entity_Id; 4736 Target : Node_Id; 4737 Flist : Node_Id := Empty; 4738 Obj : Entity_Id := Empty) return List_Id is 4739 begin 4740 if Is_Record_Type (Etype (N)) then 4741 return Build_Record_Aggr_Code (N, Typ, Target, Flist, Obj); 4742 elsif Is_Array_Type (Etype (N)) then 4743 return 4744 Build_Array_Aggr_Code 4745 (N => N, 4746 Ctype => Component_Type (Etype (N)), 4747 Index => First_Index (Typ), 4748 Into => Target, 4749 Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)), 4750 Indices => No_List, 4751 Flist => Flist); 4752 else 4753 pragma Assert (False); 4754 return New_List; 4755 end if; 4756 end Late_Expansion; 4757 4758 ---------------------------------- 4759 -- Make_OK_Assignment_Statement -- 4760 ---------------------------------- 4761 4762 function Make_OK_Assignment_Statement 4763 (Sloc : Source_Ptr; 4764 Name : Node_Id; 4765 Expression : Node_Id) return Node_Id 4766 is 4767 begin 4768 Set_Assignment_OK (Name); 4769 return Make_Assignment_Statement (Sloc, Name, Expression); 4770 end Make_OK_Assignment_Statement; 4771 4772 ----------------------- 4773 -- Number_Of_Choices -- 4774 ----------------------- 4775 4776 function Number_Of_Choices (N : Node_Id) return Nat is 4777 Assoc : Node_Id; 4778 Choice : Node_Id; 4779 4780 Nb_Choices : Nat := 0; 4781 4782 begin 4783 if Present (Expressions (N)) then 4784 return 0; 4785 end if; 4786 4787 Assoc := First (Component_Associations (N)); 4788 while Present (Assoc) loop 4789 4790 Choice := First (Choices (Assoc)); 4791 while Present (Choice) loop 4792 4793 if Nkind (Choice) /= N_Others_Choice then 4794 Nb_Choices := Nb_Choices + 1; 4795 end if; 4796 4797 Next (Choice); 4798 end loop; 4799 4800 Next (Assoc); 4801 end loop; 4802 4803 return Nb_Choices; 4804 end Number_Of_Choices; 4805 4806 ------------------------------------ 4807 -- Packed_Array_Aggregate_Handled -- 4808 ------------------------------------ 4809 4810 -- The current version of this procedure will handle at compile time 4811 -- any array aggregate that meets these conditions: 4812 4813 -- One dimensional, bit packed 4814 -- Underlying packed type is modular type 4815 -- Bounds are within 32-bit Int range 4816 -- All bounds and values are static 4817 4818 function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean is 4819 Loc : constant Source_Ptr := Sloc (N); 4820 Typ : constant Entity_Id := Etype (N); 4821 Ctyp : constant Entity_Id := Component_Type (Typ); 4822 4823 Not_Handled : exception; 4824 -- Exception raised if this aggregate cannot be handled 4825 4826 begin 4827 -- For now, handle only one dimensional bit packed arrays 4828 4829 if not Is_Bit_Packed_Array (Typ) 4830 or else Number_Dimensions (Typ) > 1 4831 or else not Is_Modular_Integer_Type (Packed_Array_Type (Typ)) 4832 then 4833 return False; 4834 end if; 4835 4836 declare 4837 Csiz : constant Nat := UI_To_Int (Component_Size (Typ)); 4838 4839 Lo : Node_Id; 4840 Hi : Node_Id; 4841 -- Bounds of index type 4842 4843 Lob : Uint; 4844 Hib : Uint; 4845 -- Values of bounds if compile time known 4846 4847 function Get_Component_Val (N : Node_Id) return Uint; 4848 -- Given a expression value N of the component type Ctyp, returns 4849 -- A value of Csiz (component size) bits representing this value. 4850 -- If the value is non-static or any other reason exists why the 4851 -- value cannot be returned, then Not_Handled is raised. 4852 4853 ----------------------- 4854 -- Get_Component_Val -- 4855 ----------------------- 4856 4857 function Get_Component_Val (N : Node_Id) return Uint is 4858 Val : Uint; 4859 4860 begin 4861 -- We have to analyze the expression here before doing any further 4862 -- processing here. The analysis of such expressions is deferred 4863 -- till expansion to prevent some problems of premature analysis. 4864 4865 Analyze_And_Resolve (N, Ctyp); 4866 4867 -- Must have a compile time value 4868 4869 if not Compile_Time_Known_Value (N) then 4870 raise Not_Handled; 4871 end if; 4872 4873 Val := Expr_Rep_Value (N); 4874 4875 -- Adjust for bias, and strip proper number of bits 4876 4877 if Has_Biased_Representation (Ctyp) then 4878 Val := Val - Expr_Value (Type_Low_Bound (Ctyp)); 4879 end if; 4880 4881 return Val mod Uint_2 ** Csiz; 4882 end Get_Component_Val; 4883 4884 -- Here we know we have a one dimensional bit packed array 4885 4886 begin 4887 Get_Index_Bounds (First_Index (Typ), Lo, Hi); 4888 4889 -- Cannot do anything if bounds are dynamic 4890 4891 if not Compile_Time_Known_Value (Lo) 4892 or else 4893 not Compile_Time_Known_Value (Hi) 4894 then 4895 return False; 4896 end if; 4897 4898 -- Or are silly out of range of int bounds 4899 4900 Lob := Expr_Value (Lo); 4901 Hib := Expr_Value (Hi); 4902 4903 if not UI_Is_In_Int_Range (Lob) 4904 or else 4905 not UI_Is_In_Int_Range (Hib) 4906 then 4907 return False; 4908 end if; 4909 4910 -- At this stage we have a suitable aggregate for handling 4911 -- at compile time (the only remaining checks, are that the 4912 -- values of expressions in the aggregate are compile time 4913 -- known (check performed by Get_Component_Val), and that 4914 -- any subtypes or ranges are statically known. 4915 4916 -- If the aggregate is not fully positional at this stage, 4917 -- then convert it to positional form. Either this will fail, 4918 -- in which case we can do nothing, or it will succeed, in 4919 -- which case we have succeeded in handling the aggregate, 4920 -- or it will stay an aggregate, in which case we have failed 4921 -- to handle this case. 4922 4923 if Present (Component_Associations (N)) then 4924 Convert_To_Positional 4925 (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True); 4926 return Nkind (N) /= N_Aggregate; 4927 end if; 4928 4929 -- Otherwise we are all positional, so convert to proper value 4930 4931 declare 4932 Lov : constant Nat := UI_To_Int (Lob); 4933 Hiv : constant Nat := UI_To_Int (Hib); 4934 4935 Len : constant Nat := Int'Max (0, Hiv - Lov + 1); 4936 -- The length of the array (number of elements) 4937 4938 Aggregate_Val : Uint; 4939 -- Value of aggregate. The value is set in the low order 4940 -- bits of this value. For the little-endian case, the 4941 -- values are stored from low-order to high-order and 4942 -- for the big-endian case the values are stored from 4943 -- high-order to low-order. Note that gigi will take care 4944 -- of the conversions to left justify the value in the big 4945 -- endian case (because of left justified modular type 4946 -- processing), so we do not have to worry about that here. 4947 4948 Lit : Node_Id; 4949 -- Integer literal for resulting constructed value 4950 4951 Shift : Nat; 4952 -- Shift count from low order for next value 4953 4954 Incr : Int; 4955 -- Shift increment for loop 4956 4957 Expr : Node_Id; 4958 -- Next expression from positional parameters of aggregate 4959 4960 begin 4961 -- For little endian, we fill up the low order bits of the 4962 -- target value. For big endian we fill up the high order 4963 -- bits of the target value (which is a left justified 4964 -- modular value). 4965 4966 if Bytes_Big_Endian xor Debug_Flag_8 then 4967 Shift := Csiz * (Len - 1); 4968 Incr := -Csiz; 4969 else 4970 Shift := 0; 4971 Incr := +Csiz; 4972 end if; 4973 4974 -- Loop to set the values 4975 4976 if Len = 0 then 4977 Aggregate_Val := Uint_0; 4978 else 4979 Expr := First (Expressions (N)); 4980 Aggregate_Val := Get_Component_Val (Expr) * Uint_2 ** Shift; 4981 4982 for J in 2 .. Len loop 4983 Shift := Shift + Incr; 4984 Next (Expr); 4985 Aggregate_Val := 4986 Aggregate_Val + Get_Component_Val (Expr) * Uint_2 ** Shift; 4987 end loop; 4988 end if; 4989 4990 -- Now we can rewrite with the proper value 4991 4992 Lit := 4993 Make_Integer_Literal (Loc, 4994 Intval => Aggregate_Val); 4995 Set_Print_In_Hex (Lit); 4996 4997 -- Construct the expression using this literal. Note that it is 4998 -- important to qualify the literal with its proper modular type 4999 -- since universal integer does not have the required range and 5000 -- also this is a left justified modular type, which is important 5001 -- in the big-endian case. 5002 5003 Rewrite (N, 5004 Unchecked_Convert_To (Typ, 5005 Make_Qualified_Expression (Loc, 5006 Subtype_Mark => 5007 New_Occurrence_Of (Packed_Array_Type (Typ), Loc), 5008 Expression => Lit))); 5009 5010 Analyze_And_Resolve (N, Typ); 5011 return True; 5012 end; 5013 end; 5014 5015 exception 5016 when Not_Handled => 5017 return False; 5018 end Packed_Array_Aggregate_Handled; 5019 5020 ---------------------------- 5021 -- Has_Mutable_Components -- 5022 ---------------------------- 5023 5024 function Has_Mutable_Components (Typ : Entity_Id) return Boolean is 5025 Comp : Entity_Id; 5026 5027 begin 5028 Comp := First_Component (Typ); 5029 5030 while Present (Comp) loop 5031 if Is_Record_Type (Etype (Comp)) 5032 and then Has_Discriminants (Etype (Comp)) 5033 and then not Is_Constrained (Etype (Comp)) 5034 then 5035 return True; 5036 end if; 5037 5038 Next_Component (Comp); 5039 end loop; 5040 5041 return False; 5042 end Has_Mutable_Components; 5043 5044 ------------------------------ 5045 -- Initialize_Discriminants -- 5046 ------------------------------ 5047 5048 procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id) is 5049 Loc : constant Source_Ptr := Sloc (N); 5050 Bas : constant Entity_Id := Base_Type (Typ); 5051 Par : constant Entity_Id := Etype (Bas); 5052 Decl : constant Node_Id := Parent (Par); 5053 Ref : Node_Id; 5054 5055 begin 5056 if Is_Tagged_Type (Bas) 5057 and then Is_Derived_Type (Bas) 5058 and then Has_Discriminants (Par) 5059 and then Has_Discriminants (Bas) 5060 and then Number_Discriminants (Bas) /= Number_Discriminants (Par) 5061 and then Nkind (Decl) = N_Full_Type_Declaration 5062 and then Nkind (Type_Definition (Decl)) = N_Record_Definition 5063 and then Present 5064 (Variant_Part (Component_List (Type_Definition (Decl)))) 5065 and then Nkind (N) /= N_Extension_Aggregate 5066 then 5067 5068 -- Call init proc to set discriminants. 5069 -- There should eventually be a special procedure for this ??? 5070 5071 Ref := New_Reference_To (Defining_Identifier (N), Loc); 5072 Insert_Actions_After (N, 5073 Build_Initialization_Call (Sloc (N), Ref, Typ)); 5074 end if; 5075 end Initialize_Discriminants; 5076 5077 --------------------------- 5078 -- Safe_Slice_Assignment -- 5079 --------------------------- 5080 5081 function Safe_Slice_Assignment (N : Node_Id) return Boolean is 5082 Loc : constant Source_Ptr := Sloc (Parent (N)); 5083 Pref : constant Node_Id := Prefix (Name (Parent (N))); 5084 Range_Node : constant Node_Id := Discrete_Range (Name (Parent (N))); 5085 Expr : Node_Id; 5086 L_J : Entity_Id; 5087 L_Iter : Node_Id; 5088 L_Body : Node_Id; 5089 Stat : Node_Id; 5090 5091 begin 5092 -- Generate: for J in Range loop Pref (J) := Expr; end loop; 5093 5094 if Comes_From_Source (N) 5095 and then No (Expressions (N)) 5096 and then Nkind (First (Choices (First (Component_Associations (N))))) 5097 = N_Others_Choice 5098 then 5099 Expr := 5100 Expression (First (Component_Associations (N))); 5101 L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); 5102 5103 L_Iter := 5104 Make_Iteration_Scheme (Loc, 5105 Loop_Parameter_Specification => 5106 Make_Loop_Parameter_Specification 5107 (Loc, 5108 Defining_Identifier => L_J, 5109 Discrete_Subtype_Definition => Relocate_Node (Range_Node))); 5110 5111 L_Body := 5112 Make_Assignment_Statement (Loc, 5113 Name => 5114 Make_Indexed_Component (Loc, 5115 Prefix => Relocate_Node (Pref), 5116 Expressions => New_List (New_Occurrence_Of (L_J, Loc))), 5117 Expression => Relocate_Node (Expr)); 5118 5119 -- Construct the final loop 5120 5121 Stat := 5122 Make_Implicit_Loop_Statement 5123 (Node => Parent (N), 5124 Identifier => Empty, 5125 Iteration_Scheme => L_Iter, 5126 Statements => New_List (L_Body)); 5127 5128 -- Set type of aggregate to be type of lhs in assignment, 5129 -- to suppress redundant length checks. 5130 5131 Set_Etype (N, Etype (Name (Parent (N)))); 5132 5133 Rewrite (Parent (N), Stat); 5134 Analyze (Parent (N)); 5135 return True; 5136 5137 else 5138 return False; 5139 end if; 5140 end Safe_Slice_Assignment; 5141 5142 --------------------- 5143 -- Sort_Case_Table -- 5144 --------------------- 5145 5146 procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is 5147 L : constant Int := Case_Table'First; 5148 U : constant Int := Case_Table'Last; 5149 K : Int; 5150 J : Int; 5151 T : Case_Bounds; 5152 5153 begin 5154 K := L; 5155 5156 while K /= U loop 5157 T := Case_Table (K + 1); 5158 J := K + 1; 5159 5160 while J /= L 5161 and then Expr_Value (Case_Table (J - 1).Choice_Lo) > 5162 Expr_Value (T.Choice_Lo) 5163 loop 5164 Case_Table (J) := Case_Table (J - 1); 5165 J := J - 1; 5166 end loop; 5167 5168 Case_Table (J) := T; 5169 K := K + 1; 5170 end loop; 5171 end Sort_Case_Table; 5172 5173end Exp_Aggr; 5174