1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ A G G R -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Aspects; use Aspects; 27with Atree; use Atree; 28with Checks; use Checks; 29with Einfo; use Einfo; 30with Einfo.Entities; use Einfo.Entities; 31with Einfo.Utils; use Einfo.Utils; 32with Elists; use Elists; 33with Errout; use Errout; 34with Expander; use Expander; 35with Exp_Ch6; use Exp_Ch6; 36with Exp_Tss; use Exp_Tss; 37with Exp_Util; use Exp_Util; 38with Freeze; use Freeze; 39with Itypes; use Itypes; 40with Lib; use Lib; 41with Lib.Xref; use Lib.Xref; 42with Namet; use Namet; 43with Namet.Sp; use Namet.Sp; 44with Nmake; use Nmake; 45with Nlists; use Nlists; 46with Opt; use Opt; 47with Restrict; use Restrict; 48with Rident; use Rident; 49with Sem; use Sem; 50with Sem_Aux; use Sem_Aux; 51with Sem_Case; use Sem_Case; 52with Sem_Cat; use Sem_Cat; 53with Sem_Ch3; use Sem_Ch3; 54with Sem_Ch5; use Sem_Ch5; 55with Sem_Ch8; use Sem_Ch8; 56with Sem_Ch13; use Sem_Ch13; 57with Sem_Dim; use Sem_Dim; 58with Sem_Eval; use Sem_Eval; 59with Sem_Res; use Sem_Res; 60with Sem_Util; use Sem_Util; 61with Sem_Type; use Sem_Type; 62with Sem_Warn; use Sem_Warn; 63with Sinfo; use Sinfo; 64with Sinfo.Nodes; use Sinfo.Nodes; 65with Sinfo.Utils; use Sinfo.Utils; 66with Snames; use Snames; 67with Stringt; use Stringt; 68with Stand; use Stand; 69with Style; use Style; 70with Targparm; use Targparm; 71with Tbuild; use Tbuild; 72with Ttypes; use Ttypes; 73with Uintp; use Uintp; 74 75package body Sem_Aggr is 76 77 type Case_Bounds is record 78 Lo : Node_Id; 79 -- Low bound of choice. Once we sort the Case_Table, then entries 80 -- will be in order of ascending Choice_Lo values. 81 82 Hi : Node_Id; 83 -- High Bound of choice. The sort does not pay any attention to the 84 -- high bound, so choices 1 .. 4 and 1 .. 5 could be in either order. 85 86 Highest : Uint; 87 -- If there are duplicates or missing entries, then in the sorted 88 -- table, this records the highest value among Choice_Hi values 89 -- seen so far, including this entry. 90 91 Choice : Node_Id; 92 -- The node of the choice 93 end record; 94 95 type Case_Table_Type is array (Pos range <>) of Case_Bounds; 96 -- Table type used by Check_Case_Choices procedure 97 98 ----------------------- 99 -- Local Subprograms -- 100 ----------------------- 101 102 procedure Sort_Case_Table (Case_Table : in out Case_Table_Type); 103 -- Sort the Case Table using the Lower Bound of each Choice as the key. A 104 -- simple insertion sort is used since the choices in a case statement will 105 -- usually be in near sorted order. 106 107 procedure Check_Can_Never_Be_Null (Typ : Entity_Id; Expr : Node_Id); 108 -- Ada 2005 (AI-231): Check bad usage of null for a component for which 109 -- null exclusion (NOT NULL) is specified. Typ can be an E_Array_Type for 110 -- the array case (the component type of the array will be used) or an 111 -- E_Component/E_Discriminant entity in the record case, in which case the 112 -- type of the component will be used for the test. If Typ is any other 113 -- kind of entity, the call is ignored. Expr is the component node in the 114 -- aggregate which is known to have a null value. A warning message will be 115 -- issued if the component is null excluding. 116 -- 117 -- It would be better to pass the proper type for Typ ??? 118 119 procedure Check_Expr_OK_In_Limited_Aggregate (Expr : Node_Id); 120 -- Check that Expr is either not limited or else is one of the cases of 121 -- expressions allowed for a limited component association (namely, an 122 -- aggregate, function call, or <> notation). Report error for violations. 123 -- Expression is also OK in an instance or inlining context, because we 124 -- have already preanalyzed and it is known to be type correct. 125 126 ------------------------------------------------------ 127 -- Subprograms used for RECORD AGGREGATE Processing -- 128 ------------------------------------------------------ 129 130 procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id); 131 -- This procedure performs all the semantic checks required for record 132 -- aggregates. Note that for aggregates analysis and resolution go 133 -- hand in hand. Aggregate analysis has been delayed up to here and 134 -- it is done while resolving the aggregate. 135 -- 136 -- N is the N_Aggregate node. 137 -- Typ is the record type for the aggregate resolution 138 -- 139 -- While performing the semantic checks, this procedure builds a new 140 -- Component_Association_List where each record field appears alone in a 141 -- Component_Choice_List along with its corresponding expression. The 142 -- record fields in the Component_Association_List appear in the same order 143 -- in which they appear in the record type Typ. 144 -- 145 -- Once this new Component_Association_List is built and all the semantic 146 -- checks performed, the original aggregate subtree is replaced with the 147 -- new named record aggregate just built. This new record aggregate has no 148 -- positional associations, so its Expressions field is set to No_List. 149 -- Note that subtree substitution is performed with Rewrite so as to be 150 -- able to retrieve the original aggregate. 151 -- 152 -- The aggregate subtree manipulation performed by Resolve_Record_Aggregate 153 -- yields the aggregate format expected by Gigi. Typically, this kind of 154 -- tree manipulations are done in the expander. However, because the 155 -- semantic checks that need to be performed on record aggregates really go 156 -- hand in hand with the record aggregate normalization, the aggregate 157 -- subtree transformation is performed during resolution rather than 158 -- expansion. Had we decided otherwise we would have had to duplicate most 159 -- of the code in the expansion procedure Expand_Record_Aggregate. Note, 160 -- however, that all the expansion concerning aggregates for tagged records 161 -- is done in Expand_Record_Aggregate. 162 -- 163 -- The algorithm of Resolve_Record_Aggregate proceeds as follows: 164 -- 165 -- 1. Make sure that the record type against which the record aggregate 166 -- has to be resolved is not abstract. Furthermore if the type is a 167 -- null aggregate make sure the input aggregate N is also null. 168 -- 169 -- 2. Verify that the structure of the aggregate is that of a record 170 -- aggregate. Specifically, look for component associations and ensure 171 -- that each choice list only has identifiers or the N_Others_Choice 172 -- node. Also make sure that if present, the N_Others_Choice occurs 173 -- last and by itself. 174 -- 175 -- 3. If Typ contains discriminants, the values for each discriminant is 176 -- looked for. If the record type Typ has variants, we check that the 177 -- expressions corresponding to each discriminant ruling the (possibly 178 -- nested) variant parts of Typ, are static. This allows us to determine 179 -- the variant parts to which the rest of the aggregate must conform. 180 -- The names of discriminants with their values are saved in a new 181 -- association list, New_Assoc_List which is later augmented with the 182 -- names and values of the remaining components in the record type. 183 -- 184 -- During this phase we also make sure that every discriminant is 185 -- assigned exactly one value. Note that when several values for a given 186 -- discriminant are found, semantic processing continues looking for 187 -- further errors. In this case it's the first discriminant value found 188 -- which we will be recorded. 189 -- 190 -- IMPORTANT NOTE: For derived tagged types this procedure expects 191 -- First_Discriminant and Next_Discriminant to give the correct list 192 -- of discriminants, in the correct order. 193 -- 194 -- 4. After all the discriminant values have been gathered, we can set the 195 -- Etype of the record aggregate. If Typ contains no discriminants this 196 -- is straightforward: the Etype of N is just Typ, otherwise a new 197 -- implicit constrained subtype of Typ is built to be the Etype of N. 198 -- 199 -- 5. Gather the remaining record components according to the discriminant 200 -- values. This involves recursively traversing the record type 201 -- structure to see what variants are selected by the given discriminant 202 -- values. This processing is a little more convoluted if Typ is a 203 -- derived tagged types since we need to retrieve the record structure 204 -- of all the ancestors of Typ. 205 -- 206 -- 6. After gathering the record components we look for their values in the 207 -- record aggregate and emit appropriate error messages should we not 208 -- find such values or should they be duplicated. 209 -- 210 -- 7. We then make sure no illegal component names appear in the record 211 -- aggregate and make sure that the type of the record components 212 -- appearing in a same choice list is the same. Finally we ensure that 213 -- the others choice, if present, is used to provide the value of at 214 -- least a record component. 215 -- 216 -- 8. The original aggregate node is replaced with the new named aggregate 217 -- built in steps 3 through 6, as explained earlier. 218 -- 219 -- Given the complexity of record aggregate resolution, the primary goal of 220 -- this routine is clarity and simplicity rather than execution and storage 221 -- efficiency. If there are only positional components in the aggregate the 222 -- running time is linear. If there are associations the running time is 223 -- still linear as long as the order of the associations is not too far off 224 -- the order of the components in the record type. If this is not the case 225 -- the running time is at worst quadratic in the size of the association 226 -- list. 227 228 procedure Check_Misspelled_Component 229 (Elements : Elist_Id; 230 Component : Node_Id); 231 -- Give possible misspelling diagnostic if Component is likely to be a 232 -- misspelling of one of the components of the Assoc_List. This is called 233 -- by Resolve_Aggr_Expr after producing an invalid component error message. 234 235 ----------------------------------------------------- 236 -- Subprograms used for ARRAY AGGREGATE Processing -- 237 ----------------------------------------------------- 238 239 function Resolve_Array_Aggregate 240 (N : Node_Id; 241 Index : Node_Id; 242 Index_Constr : Node_Id; 243 Component_Typ : Entity_Id; 244 Others_Allowed : Boolean) return Boolean; 245 -- This procedure performs the semantic checks for an array aggregate. 246 -- True is returned if the aggregate resolution succeeds. 247 -- 248 -- The procedure works by recursively checking each nested aggregate. 249 -- Specifically, after checking a sub-aggregate nested at the i-th level 250 -- we recursively check all the subaggregates at the i+1-st level (if any). 251 -- Note that aggregates analysis and resolution go hand in hand. 252 -- Aggregate analysis has been delayed up to here and it is done while 253 -- resolving the aggregate. 254 -- 255 -- N is the current N_Aggregate node to be checked. 256 -- 257 -- Index is the index node corresponding to the array sub-aggregate that 258 -- we are currently checking (RM 4.3.3 (8)). Its Etype is the 259 -- corresponding index type (or subtype). 260 -- 261 -- Index_Constr is the node giving the applicable index constraint if 262 -- any (RM 4.3.3 (10)). It "is a constraint provided by certain 263 -- contexts [...] that can be used to determine the bounds of the array 264 -- value specified by the aggregate". If Others_Allowed below is False 265 -- there is no applicable index constraint and this node is set to Index. 266 -- 267 -- Component_Typ is the array component type. 268 -- 269 -- Others_Allowed indicates whether an others choice is allowed 270 -- in the context where the top-level aggregate appeared. 271 -- 272 -- The algorithm of Resolve_Array_Aggregate proceeds as follows: 273 -- 274 -- 1. Make sure that the others choice, if present, is by itself and 275 -- appears last in the sub-aggregate. Check that we do not have 276 -- positional and named components in the array sub-aggregate (unless 277 -- the named association is an others choice). Finally if an others 278 -- choice is present, make sure it is allowed in the aggregate context. 279 -- 280 -- 2. If the array sub-aggregate contains discrete_choices: 281 -- 282 -- (A) Verify their validity. Specifically verify that: 283 -- 284 -- (a) If a null range is present it must be the only possible 285 -- choice in the array aggregate. 286 -- 287 -- (b) Ditto for a non static range. 288 -- 289 -- (c) Ditto for a non static expression. 290 -- 291 -- In addition this step analyzes and resolves each discrete_choice, 292 -- making sure that its type is the type of the corresponding Index. 293 -- If we are not at the lowest array aggregate level (in the case of 294 -- multi-dimensional aggregates) then invoke Resolve_Array_Aggregate 295 -- recursively on each component expression. Otherwise, resolve the 296 -- bottom level component expressions against the expected component 297 -- type ONLY IF the component corresponds to a single discrete choice 298 -- which is not an others choice (to see why read the DELAYED 299 -- COMPONENT RESOLUTION below). 300 -- 301 -- (B) Determine the bounds of the sub-aggregate and lowest and 302 -- highest choice values. 303 -- 304 -- 3. For positional aggregates: 305 -- 306 -- (A) Loop over the component expressions either recursively invoking 307 -- Resolve_Array_Aggregate on each of these for multi-dimensional 308 -- array aggregates or resolving the bottom level component 309 -- expressions against the expected component type. 310 -- 311 -- (B) Determine the bounds of the positional sub-aggregates. 312 -- 313 -- 4. Try to determine statically whether the evaluation of the array 314 -- sub-aggregate raises Constraint_Error. If yes emit proper 315 -- warnings. The precise checks are the following: 316 -- 317 -- (A) Check that the index range defined by aggregate bounds is 318 -- compatible with corresponding index subtype. 319 -- We also check against the base type. In fact it could be that 320 -- Low/High bounds of the base type are static whereas those of 321 -- the index subtype are not. Thus if we can statically catch 322 -- a problem with respect to the base type we are guaranteed 323 -- that the same problem will arise with the index subtype 324 -- 325 -- (B) If we are dealing with a named aggregate containing an others 326 -- choice and at least one discrete choice then make sure the range 327 -- specified by the discrete choices does not overflow the 328 -- aggregate bounds. We also check against the index type and base 329 -- type bounds for the same reasons given in (A). 330 -- 331 -- (C) If we are dealing with a positional aggregate with an others 332 -- choice make sure the number of positional elements specified 333 -- does not overflow the aggregate bounds. We also check against 334 -- the index type and base type bounds as mentioned in (A). 335 -- 336 -- Finally construct an N_Range node giving the sub-aggregate bounds. 337 -- Set the Aggregate_Bounds field of the sub-aggregate to be this 338 -- N_Range. The routine Array_Aggr_Subtype below uses such N_Ranges 339 -- to build the appropriate aggregate subtype. Aggregate_Bounds 340 -- information is needed during expansion. 341 -- 342 -- DELAYED COMPONENT RESOLUTION: The resolution of bottom level component 343 -- expressions in an array aggregate may call Duplicate_Subexpr or some 344 -- other routine that inserts code just outside the outermost aggregate. 345 -- If the array aggregate contains discrete choices or an others choice, 346 -- this may be wrong. Consider for instance the following example. 347 -- 348 -- type Rec is record 349 -- V : Integer := 0; 350 -- end record; 351 -- 352 -- type Acc_Rec is access Rec; 353 -- Arr : array (1..3) of Acc_Rec := (1 .. 3 => new Rec); 354 -- 355 -- Then the transformation of "new Rec" that occurs during resolution 356 -- entails the following code modifications 357 -- 358 -- P7b : constant Acc_Rec := new Rec; 359 -- RecIP (P7b.all); 360 -- Arr : array (1..3) of Acc_Rec := (1 .. 3 => P7b); 361 -- 362 -- This code transformation is clearly wrong, since we need to call 363 -- "new Rec" for each of the 3 array elements. To avoid this problem we 364 -- delay resolution of the components of non positional array aggregates 365 -- to the expansion phase. As an optimization, if the discrete choice 366 -- specifies a single value we do not delay resolution. 367 368 function Array_Aggr_Subtype (N : Node_Id; Typ : Entity_Id) return Entity_Id; 369 -- This routine returns the type or subtype of an array aggregate. 370 -- 371 -- N is the array aggregate node whose type we return. 372 -- 373 -- Typ is the context type in which N occurs. 374 -- 375 -- This routine creates an implicit array subtype whose bounds are 376 -- those defined by the aggregate. When this routine is invoked 377 -- Resolve_Array_Aggregate has already processed aggregate N. Thus the 378 -- Aggregate_Bounds of each sub-aggregate, is an N_Range node giving the 379 -- sub-aggregate bounds. When building the aggregate itype, this function 380 -- traverses the array aggregate N collecting such Aggregate_Bounds and 381 -- constructs the proper array aggregate itype. 382 -- 383 -- Note that in the case of multidimensional aggregates each inner 384 -- sub-aggregate corresponding to a given array dimension, may provide a 385 -- different bounds. If it is possible to determine statically that 386 -- some sub-aggregates corresponding to the same index do not have the 387 -- same bounds, then a warning is emitted. If such check is not possible 388 -- statically (because some sub-aggregate bounds are dynamic expressions) 389 -- then this job is left to the expander. In all cases the particular 390 -- bounds that this function will chose for a given dimension is the first 391 -- N_Range node for a sub-aggregate corresponding to that dimension. 392 -- 393 -- Note that the Raises_Constraint_Error flag of an array aggregate 394 -- whose evaluation is determined to raise CE by Resolve_Array_Aggregate, 395 -- is set in Resolve_Array_Aggregate but the aggregate is not 396 -- immediately replaced with a raise CE. In fact, Array_Aggr_Subtype must 397 -- first construct the proper itype for the aggregate (Gigi needs 398 -- this). After constructing the proper itype we will eventually replace 399 -- the top-level aggregate with a raise CE (done in Resolve_Aggregate). 400 -- Of course in cases such as: 401 -- 402 -- type Arr is array (integer range <>) of Integer; 403 -- A : Arr := (positive range -1 .. 2 => 0); 404 -- 405 -- The bounds of the aggregate itype are cooked up to look reasonable 406 -- (in this particular case the bounds will be 1 .. 2). 407 408 procedure Make_String_Into_Aggregate (N : Node_Id); 409 -- A string literal can appear in a context in which a one dimensional 410 -- array of characters is expected. This procedure simply rewrites the 411 -- string as an aggregate, prior to resolution. 412 413 --------------------------------- 414 -- Delta aggregate processing -- 415 --------------------------------- 416 417 procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id); 418 procedure Resolve_Delta_Record_Aggregate (N : Node_Id; Typ : Entity_Id); 419 420 ------------------------ 421 -- Array_Aggr_Subtype -- 422 ------------------------ 423 424 function Array_Aggr_Subtype 425 (N : Node_Id; 426 Typ : Entity_Id) return Entity_Id 427 is 428 Aggr_Dimension : constant Pos := Number_Dimensions (Typ); 429 -- Number of aggregate index dimensions 430 431 Aggr_Range : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty); 432 -- Constrained N_Range of each index dimension in our aggregate itype 433 434 Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty); 435 Aggr_High : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty); 436 -- Low and High bounds for each index dimension in our aggregate itype 437 438 Is_Fully_Positional : Boolean := True; 439 440 procedure Collect_Aggr_Bounds (N : Node_Id; Dim : Pos); 441 -- N is an array (sub-)aggregate. Dim is the dimension corresponding 442 -- to (sub-)aggregate N. This procedure collects and removes the side 443 -- effects of the constrained N_Range nodes corresponding to each index 444 -- dimension of our aggregate itype. These N_Range nodes are collected 445 -- in Aggr_Range above. 446 -- 447 -- Likewise collect in Aggr_Low & Aggr_High above the low and high 448 -- bounds of each index dimension. If, when collecting, two bounds 449 -- corresponding to the same dimension are static and found to differ, 450 -- then emit a warning, and mark N as raising Constraint_Error. 451 452 ------------------------- 453 -- Collect_Aggr_Bounds -- 454 ------------------------- 455 456 procedure Collect_Aggr_Bounds (N : Node_Id; Dim : Pos) is 457 This_Range : constant Node_Id := Aggregate_Bounds (N); 458 -- The aggregate range node of this specific sub-aggregate 459 460 This_Low : constant Node_Id := Low_Bound (Aggregate_Bounds (N)); 461 This_High : constant Node_Id := High_Bound (Aggregate_Bounds (N)); 462 -- The aggregate bounds of this specific sub-aggregate 463 464 Assoc : Node_Id; 465 Expr : Node_Id; 466 467 begin 468 Remove_Side_Effects (This_Low, Variable_Ref => True); 469 Remove_Side_Effects (This_High, Variable_Ref => True); 470 471 -- Collect the first N_Range for a given dimension that you find. 472 -- For a given dimension they must be all equal anyway. 473 474 if No (Aggr_Range (Dim)) then 475 Aggr_Low (Dim) := This_Low; 476 Aggr_High (Dim) := This_High; 477 Aggr_Range (Dim) := This_Range; 478 479 else 480 if Compile_Time_Known_Value (This_Low) then 481 if not Compile_Time_Known_Value (Aggr_Low (Dim)) then 482 Aggr_Low (Dim) := This_Low; 483 484 elsif Expr_Value (This_Low) /= Expr_Value (Aggr_Low (Dim)) then 485 Set_Raises_Constraint_Error (N); 486 Error_Msg_Warn := SPARK_Mode /= On; 487 Error_Msg_N ("sub-aggregate low bound mismatch<<", N); 488 Error_Msg_N ("\Constraint_Error [<<", N); 489 end if; 490 end if; 491 492 if Compile_Time_Known_Value (This_High) then 493 if not Compile_Time_Known_Value (Aggr_High (Dim)) then 494 Aggr_High (Dim) := This_High; 495 496 elsif 497 Expr_Value (This_High) /= Expr_Value (Aggr_High (Dim)) 498 then 499 Set_Raises_Constraint_Error (N); 500 Error_Msg_Warn := SPARK_Mode /= On; 501 Error_Msg_N ("sub-aggregate high bound mismatch<<", N); 502 Error_Msg_N ("\Constraint_Error [<<", N); 503 end if; 504 end if; 505 end if; 506 507 if Dim < Aggr_Dimension then 508 509 -- Process positional components 510 511 if Present (Expressions (N)) then 512 Expr := First (Expressions (N)); 513 while Present (Expr) loop 514 Collect_Aggr_Bounds (Expr, Dim + 1); 515 Next (Expr); 516 end loop; 517 end if; 518 519 -- Process component associations 520 521 if Present (Component_Associations (N)) then 522 Is_Fully_Positional := False; 523 524 Assoc := First (Component_Associations (N)); 525 while Present (Assoc) loop 526 Expr := Expression (Assoc); 527 Collect_Aggr_Bounds (Expr, Dim + 1); 528 Next (Assoc); 529 end loop; 530 end if; 531 end if; 532 end Collect_Aggr_Bounds; 533 534 -- Array_Aggr_Subtype variables 535 536 Itype : Entity_Id; 537 -- The final itype of the overall aggregate 538 539 Index_Constraints : constant List_Id := New_List; 540 -- The list of index constraints of the aggregate itype 541 542 -- Start of processing for Array_Aggr_Subtype 543 544 begin 545 -- Make sure that the list of index constraints is properly attached to 546 -- the tree, and then collect the aggregate bounds. 547 548 -- If no aggregaate bounds have been set, this is an aggregate with 549 -- iterator specifications and a dynamic size to be determined by 550 -- first pass of expanded code. 551 552 if No (Aggregate_Bounds (N)) then 553 return Typ; 554 end if; 555 556 Set_Parent (Index_Constraints, N); 557 Collect_Aggr_Bounds (N, 1); 558 559 -- Build the list of constrained indexes of our aggregate itype 560 561 for J in 1 .. Aggr_Dimension loop 562 Create_Index : declare 563 Index_Base : constant Entity_Id := 564 Base_Type (Etype (Aggr_Range (J))); 565 Index_Typ : Entity_Id; 566 567 begin 568 -- Construct the Index subtype, and associate it with the range 569 -- construct that generates it. 570 571 Index_Typ := 572 Create_Itype (Subtype_Kind (Ekind (Index_Base)), Aggr_Range (J)); 573 574 Set_Etype (Index_Typ, Index_Base); 575 576 if Is_Character_Type (Index_Base) then 577 Set_Is_Character_Type (Index_Typ); 578 end if; 579 580 Set_Size_Info (Index_Typ, (Index_Base)); 581 Set_RM_Size (Index_Typ, RM_Size (Index_Base)); 582 Set_First_Rep_Item (Index_Typ, First_Rep_Item (Index_Base)); 583 Set_Scalar_Range (Index_Typ, Aggr_Range (J)); 584 585 if Is_Discrete_Or_Fixed_Point_Type (Index_Typ) then 586 Set_RM_Size (Index_Typ, UI_From_Int (Minimum_Size (Index_Typ))); 587 end if; 588 589 Set_Etype (Aggr_Range (J), Index_Typ); 590 591 Append (Aggr_Range (J), To => Index_Constraints); 592 end Create_Index; 593 end loop; 594 595 -- Now build the Itype 596 597 Itype := Create_Itype (E_Array_Subtype, N); 598 599 Set_First_Rep_Item (Itype, First_Rep_Item (Typ)); 600 Set_Convention (Itype, Convention (Typ)); 601 Set_Depends_On_Private (Itype, Has_Private_Component (Typ)); 602 Set_Etype (Itype, Base_Type (Typ)); 603 Set_Has_Alignment_Clause (Itype, Has_Alignment_Clause (Typ)); 604 Set_Is_Aliased (Itype, Is_Aliased (Typ)); 605 Set_Is_Independent (Itype, Is_Independent (Typ)); 606 Set_Depends_On_Private (Itype, Depends_On_Private (Typ)); 607 608 Copy_Suppress_Status (Index_Check, Typ, Itype); 609 Copy_Suppress_Status (Length_Check, Typ, Itype); 610 611 Set_First_Index (Itype, First (Index_Constraints)); 612 Set_Is_Constrained (Itype, True); 613 Set_Is_Internal (Itype, True); 614 615 if Has_Predicates (Typ) then 616 Set_Has_Predicates (Itype); 617 618 -- If the base type has a predicate, capture the predicated parent 619 -- or the existing predicate function for SPARK use. 620 621 if Present (Predicate_Function (Typ)) then 622 Set_Predicate_Function (Itype, Predicate_Function (Typ)); 623 624 elsif Is_Itype (Typ) then 625 Set_Predicated_Parent (Itype, Predicated_Parent (Typ)); 626 627 else 628 Set_Predicated_Parent (Itype, Typ); 629 end if; 630 end if; 631 632 -- A simple optimization: purely positional aggregates of static 633 -- components should be passed to gigi unexpanded whenever possible, and 634 -- regardless of the staticness of the bounds themselves. Subsequent 635 -- checks in exp_aggr verify that type is not packed, etc. 636 637 Set_Size_Known_At_Compile_Time 638 (Itype, 639 Is_Fully_Positional 640 and then Comes_From_Source (N) 641 and then Size_Known_At_Compile_Time (Component_Type (Typ))); 642 643 -- We always need a freeze node for a packed array subtype, so that we 644 -- can build the Packed_Array_Impl_Type corresponding to the subtype. If 645 -- expansion is disabled, the packed array subtype is not built, and we 646 -- must not generate a freeze node for the type, or else it will appear 647 -- incomplete to gigi. 648 649 if Is_Packed (Itype) 650 and then not In_Spec_Expression 651 and then Expander_Active 652 then 653 Freeze_Itype (Itype, N); 654 end if; 655 656 return Itype; 657 end Array_Aggr_Subtype; 658 659 -------------------------------- 660 -- Check_Misspelled_Component -- 661 -------------------------------- 662 663 procedure Check_Misspelled_Component 664 (Elements : Elist_Id; 665 Component : Node_Id) 666 is 667 Max_Suggestions : constant := 2; 668 669 Nr_Of_Suggestions : Natural := 0; 670 Suggestion_1 : Entity_Id := Empty; 671 Suggestion_2 : Entity_Id := Empty; 672 Component_Elmt : Elmt_Id; 673 674 begin 675 -- All the components of List are matched against Component and a count 676 -- is maintained of possible misspellings. When at the end of the 677 -- analysis there are one or two (not more) possible misspellings, 678 -- these misspellings will be suggested as possible corrections. 679 680 Component_Elmt := First_Elmt (Elements); 681 while Nr_Of_Suggestions <= Max_Suggestions 682 and then Present (Component_Elmt) 683 loop 684 if Is_Bad_Spelling_Of 685 (Chars (Node (Component_Elmt)), 686 Chars (Component)) 687 then 688 Nr_Of_Suggestions := Nr_Of_Suggestions + 1; 689 690 case Nr_Of_Suggestions is 691 when 1 => Suggestion_1 := Node (Component_Elmt); 692 when 2 => Suggestion_2 := Node (Component_Elmt); 693 when others => null; 694 end case; 695 end if; 696 697 Next_Elmt (Component_Elmt); 698 end loop; 699 700 -- Report at most two suggestions 701 702 if Nr_Of_Suggestions = 1 then 703 Error_Msg_NE -- CODEFIX 704 ("\possible misspelling of&", Component, Suggestion_1); 705 706 elsif Nr_Of_Suggestions = 2 then 707 Error_Msg_Node_2 := Suggestion_2; 708 Error_Msg_NE -- CODEFIX 709 ("\possible misspelling of& or&", Component, Suggestion_1); 710 end if; 711 end Check_Misspelled_Component; 712 713 ---------------------------------------- 714 -- Check_Expr_OK_In_Limited_Aggregate -- 715 ---------------------------------------- 716 717 procedure Check_Expr_OK_In_Limited_Aggregate (Expr : Node_Id) is 718 begin 719 if Is_Limited_Type (Etype (Expr)) 720 and then Comes_From_Source (Expr) 721 then 722 if In_Instance_Body or else In_Inlined_Body then 723 null; 724 725 elsif not OK_For_Limited_Init (Etype (Expr), Expr) then 726 Error_Msg_N 727 ("initialization not allowed for limited types", Expr); 728 Explain_Limited_Type (Etype (Expr), Expr); 729 end if; 730 end if; 731 end Check_Expr_OK_In_Limited_Aggregate; 732 733 ------------------------- 734 -- Is_Others_Aggregate -- 735 ------------------------- 736 737 function Is_Others_Aggregate (Aggr : Node_Id) return Boolean is 738 Assoc : constant List_Id := Component_Associations (Aggr); 739 740 begin 741 return No (Expressions (Aggr)) 742 and then Nkind (First (Choice_List (First (Assoc)))) = N_Others_Choice; 743 end Is_Others_Aggregate; 744 745 ------------------------- 746 -- Is_Single_Aggregate -- 747 ------------------------- 748 749 function Is_Single_Aggregate (Aggr : Node_Id) return Boolean is 750 Assoc : constant List_Id := Component_Associations (Aggr); 751 752 begin 753 return No (Expressions (Aggr)) 754 and then No (Next (First (Assoc))) 755 and then No (Next (First (Choice_List (First (Assoc))))); 756 end Is_Single_Aggregate; 757 758 -------------------------------- 759 -- Make_String_Into_Aggregate -- 760 -------------------------------- 761 762 procedure Make_String_Into_Aggregate (N : Node_Id) is 763 Exprs : constant List_Id := New_List; 764 Loc : constant Source_Ptr := Sloc (N); 765 Str : constant String_Id := Strval (N); 766 Strlen : constant Nat := String_Length (Str); 767 C : Char_Code; 768 C_Node : Node_Id; 769 New_N : Node_Id; 770 P : Source_Ptr; 771 772 begin 773 P := Loc + 1; 774 for J in 1 .. Strlen loop 775 C := Get_String_Char (Str, J); 776 Set_Character_Literal_Name (C); 777 778 C_Node := 779 Make_Character_Literal (P, 780 Chars => Name_Find, 781 Char_Literal_Value => UI_From_CC (C)); 782 Set_Etype (C_Node, Any_Character); 783 Append_To (Exprs, C_Node); 784 785 P := P + 1; 786 -- Something special for wide strings??? 787 end loop; 788 789 New_N := Make_Aggregate (Loc, Expressions => Exprs); 790 Set_Analyzed (New_N); 791 Set_Etype (New_N, Any_Composite); 792 793 Rewrite (N, New_N); 794 end Make_String_Into_Aggregate; 795 796 ----------------------- 797 -- Resolve_Aggregate -- 798 ----------------------- 799 800 procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is 801 Loc : constant Source_Ptr := Sloc (N); 802 803 Aggr_Subtyp : Entity_Id; 804 -- The actual aggregate subtype. This is not necessarily the same as Typ 805 -- which is the subtype of the context in which the aggregate was found. 806 807 Others_Box : Boolean := False; 808 -- Set to True if N represents a simple aggregate with only 809 -- (others => <>), not nested as part of another aggregate. 810 811 function Within_Aggregate (N : Node_Id) return Boolean; 812 -- Return True if N is part of an N_Aggregate 813 814 ---------------------- 815 -- Within_Aggregate -- 816 ---------------------- 817 818 function Within_Aggregate (N : Node_Id) return Boolean is 819 P : Node_Id := Parent (N); 820 begin 821 while Present (P) loop 822 if Nkind (P) = N_Aggregate then 823 return True; 824 end if; 825 826 P := Parent (P); 827 end loop; 828 829 return False; 830 end Within_Aggregate; 831 832 -- Start of processing for Resolve_Aggregate 833 834 begin 835 -- Ignore junk empty aggregate resulting from parser error 836 837 if No (Expressions (N)) 838 and then No (Component_Associations (N)) 839 and then not Null_Record_Present (N) 840 then 841 return; 842 end if; 843 844 -- If the aggregate has box-initialized components, its type must be 845 -- frozen so that initialization procedures can properly be called 846 -- in the resolution that follows. The replacement of boxes with 847 -- initialization calls is properly an expansion activity but it must 848 -- be done during resolution. 849 850 if Expander_Active 851 and then Present (Component_Associations (N)) 852 then 853 declare 854 Comp : Node_Id; 855 First_Comp : Boolean := True; 856 857 begin 858 Comp := First (Component_Associations (N)); 859 while Present (Comp) loop 860 if Box_Present (Comp) then 861 if First_Comp 862 and then No (Expressions (N)) 863 and then Nkind (First (Choices (Comp))) = N_Others_Choice 864 and then not Within_Aggregate (N) 865 then 866 Others_Box := True; 867 end if; 868 869 Insert_Actions (N, Freeze_Entity (Typ, N)); 870 exit; 871 end if; 872 873 First_Comp := False; 874 Next (Comp); 875 end loop; 876 end; 877 end if; 878 879 -- Check for aggregates not allowed in configurable run-time mode. 880 -- We allow all cases of aggregates that do not come from source, since 881 -- these are all assumed to be small (e.g. bounds of a string literal). 882 -- We also allow aggregates of types we know to be small. 883 884 if not Support_Aggregates_On_Target 885 and then Comes_From_Source (N) 886 and then (not Known_Static_Esize (Typ) 887 or else Esize (Typ) > System_Max_Integer_Size) 888 then 889 Error_Msg_CRT ("aggregate", N); 890 end if; 891 892 -- Ada 2005 (AI-287): Limited aggregates allowed 893 894 -- In an instance, ignore aggregate subcomponents that may be limited, 895 -- because they originate in view conflicts. If the original aggregate 896 -- is legal and the actuals are legal, the aggregate itself is legal. 897 898 if Is_Limited_Type (Typ) 899 and then Ada_Version < Ada_2005 900 and then not In_Instance 901 then 902 Error_Msg_N ("aggregate type cannot be limited", N); 903 Explain_Limited_Type (Typ, N); 904 905 elsif Is_Class_Wide_Type (Typ) then 906 Error_Msg_N ("type of aggregate cannot be class-wide", N); 907 908 elsif Typ = Any_String 909 or else Typ = Any_Composite 910 then 911 Error_Msg_N ("no unique type for aggregate", N); 912 Set_Etype (N, Any_Composite); 913 914 elsif Is_Array_Type (Typ) and then Null_Record_Present (N) then 915 Error_Msg_N ("null record forbidden in array aggregate", N); 916 917 elsif Present (Find_Aspect (Typ, Aspect_Aggregate)) 918 and then Ekind (Typ) /= E_Record_Type 919 and then Ada_Version >= Ada_2022 920 then 921 -- Check for Ada 2022 and () aggregate. 922 923 if not Is_Homogeneous_Aggregate (N) then 924 Error_Msg_N ("container aggregate must use '['], not ()", N); 925 end if; 926 927 Resolve_Container_Aggregate (N, Typ); 928 929 elsif Is_Record_Type (Typ) then 930 Resolve_Record_Aggregate (N, Typ); 931 932 elsif Is_Array_Type (Typ) then 933 934 -- First a special test, for the case of a positional aggregate of 935 -- characters which can be replaced by a string literal. 936 937 -- Do not perform this transformation if this was a string literal 938 -- to start with, whose components needed constraint checks, or if 939 -- the component type is non-static, because it will require those 940 -- checks and be transformed back into an aggregate. If the index 941 -- type is not Integer the aggregate may represent a user-defined 942 -- string type but the context might need the original type so we 943 -- do not perform the transformation at this point. 944 945 if Number_Dimensions (Typ) = 1 946 and then Is_Standard_Character_Type (Component_Type (Typ)) 947 and then No (Component_Associations (N)) 948 and then not Is_Limited_Composite (Typ) 949 and then not Is_Private_Composite (Typ) 950 and then not Is_Bit_Packed_Array (Typ) 951 and then Nkind (Original_Node (Parent (N))) /= N_String_Literal 952 and then Is_OK_Static_Subtype (Component_Type (Typ)) 953 and then Base_Type (Etype (First_Index (Typ))) = 954 Base_Type (Standard_Integer) 955 then 956 declare 957 Expr : Node_Id; 958 959 begin 960 Expr := First (Expressions (N)); 961 while Present (Expr) loop 962 exit when Nkind (Expr) /= N_Character_Literal; 963 Next (Expr); 964 end loop; 965 966 if No (Expr) then 967 Start_String; 968 969 Expr := First (Expressions (N)); 970 while Present (Expr) loop 971 Store_String_Char (UI_To_CC (Char_Literal_Value (Expr))); 972 Next (Expr); 973 end loop; 974 975 Rewrite (N, Make_String_Literal (Loc, End_String)); 976 977 Analyze_And_Resolve (N, Typ); 978 return; 979 end if; 980 end; 981 end if; 982 983 -- Here if we have a real aggregate to deal with 984 985 Array_Aggregate : declare 986 Aggr_Resolved : Boolean; 987 988 Aggr_Typ : constant Entity_Id := Etype (Typ); 989 -- This is the unconstrained array type, which is the type against 990 -- which the aggregate is to be resolved. Typ itself is the array 991 -- type of the context which may not be the same subtype as the 992 -- subtype for the final aggregate. 993 994 begin 995 -- In the following we determine whether an OTHERS choice is 996 -- allowed inside the array aggregate. The test checks the context 997 -- in which the array aggregate occurs. If the context does not 998 -- permit it, or the aggregate type is unconstrained, an OTHERS 999 -- choice is not allowed (except that it is always allowed on the 1000 -- right-hand side of an assignment statement; in this case the 1001 -- constrainedness of the type doesn't matter, because an array 1002 -- object is always constrained). 1003 1004 -- If expansion is disabled (generic context, or semantics-only 1005 -- mode) actual subtypes cannot be constructed, and the type of an 1006 -- object may be its unconstrained nominal type. However, if the 1007 -- context is an assignment statement, OTHERS is allowed, because 1008 -- the target of the assignment will have a constrained subtype 1009 -- when fully compiled. Ditto if the context is an initialization 1010 -- procedure where a component may have a predicate function that 1011 -- carries the base type. 1012 1013 -- Note that there is no node for Explicit_Actual_Parameter. 1014 -- To test for this context we therefore have to test for node 1015 -- N_Parameter_Association which itself appears only if there is a 1016 -- formal parameter. Consequently we also need to test for 1017 -- N_Procedure_Call_Statement or N_Function_Call. 1018 1019 -- The context may be an N_Reference node, created by expansion. 1020 -- Legality of the others clause was established in the source, 1021 -- so the context is legal. 1022 1023 Set_Etype (N, Aggr_Typ); -- May be overridden later on 1024 1025 if Nkind (Parent (N)) = N_Assignment_Statement 1026 or else Inside_Init_Proc 1027 or else (Is_Constrained (Typ) 1028 and then Nkind (Parent (N)) in 1029 N_Parameter_Association 1030 | N_Function_Call 1031 | N_Procedure_Call_Statement 1032 | N_Generic_Association 1033 | N_Formal_Object_Declaration 1034 | N_Simple_Return_Statement 1035 | N_Object_Declaration 1036 | N_Component_Declaration 1037 | N_Parameter_Specification 1038 | N_Qualified_Expression 1039 | N_Reference 1040 | N_Aggregate 1041 | N_Extension_Aggregate 1042 | N_Component_Association 1043 | N_Case_Expression_Alternative 1044 | N_If_Expression 1045 | N_Expression_With_Actions) 1046 then 1047 Aggr_Resolved := 1048 Resolve_Array_Aggregate 1049 (N, 1050 Index => First_Index (Aggr_Typ), 1051 Index_Constr => First_Index (Typ), 1052 Component_Typ => Component_Type (Typ), 1053 Others_Allowed => True); 1054 else 1055 Aggr_Resolved := 1056 Resolve_Array_Aggregate 1057 (N, 1058 Index => First_Index (Aggr_Typ), 1059 Index_Constr => First_Index (Aggr_Typ), 1060 Component_Typ => Component_Type (Typ), 1061 Others_Allowed => False); 1062 end if; 1063 1064 if not Aggr_Resolved then 1065 1066 -- A parenthesized expression may have been intended as an 1067 -- aggregate, leading to a type error when analyzing the 1068 -- component. This can also happen for a nested component 1069 -- (see Analyze_Aggr_Expr). 1070 1071 if Paren_Count (N) > 0 then 1072 Error_Msg_N 1073 ("positional aggregate cannot have one component", N); 1074 end if; 1075 1076 Aggr_Subtyp := Any_Composite; 1077 1078 else 1079 Aggr_Subtyp := Array_Aggr_Subtype (N, Typ); 1080 end if; 1081 1082 Set_Etype (N, Aggr_Subtyp); 1083 end Array_Aggregate; 1084 1085 elsif Is_Private_Type (Typ) 1086 and then Present (Full_View (Typ)) 1087 and then (In_Inlined_Body or In_Instance_Body) 1088 and then Is_Composite_Type (Full_View (Typ)) 1089 then 1090 Resolve (N, Full_View (Typ)); 1091 1092 else 1093 Error_Msg_N ("illegal context for aggregate", N); 1094 end if; 1095 1096 -- If we can determine statically that the evaluation of the aggregate 1097 -- raises Constraint_Error, then replace the aggregate with an 1098 -- N_Raise_Constraint_Error node, but set the Etype to the right 1099 -- aggregate subtype. Gigi needs this. 1100 1101 if Raises_Constraint_Error (N) then 1102 Aggr_Subtyp := Etype (N); 1103 Rewrite (N, 1104 Make_Raise_Constraint_Error (Loc, Reason => CE_Range_Check_Failed)); 1105 Set_Raises_Constraint_Error (N); 1106 Set_Etype (N, Aggr_Subtyp); 1107 Set_Analyzed (N); 1108 end if; 1109 1110 if Warn_On_No_Value_Assigned 1111 and then Others_Box 1112 and then not Is_Fully_Initialized_Type (Etype (N)) 1113 then 1114 Error_Msg_N ("?v?aggregate not fully initialized", N); 1115 end if; 1116 1117 Check_Function_Writable_Actuals (N); 1118 end Resolve_Aggregate; 1119 1120 ----------------------------- 1121 -- Resolve_Array_Aggregate -- 1122 ----------------------------- 1123 1124 function Resolve_Array_Aggregate 1125 (N : Node_Id; 1126 Index : Node_Id; 1127 Index_Constr : Node_Id; 1128 Component_Typ : Entity_Id; 1129 Others_Allowed : Boolean) return Boolean 1130 is 1131 Loc : constant Source_Ptr := Sloc (N); 1132 1133 Failure : constant Boolean := False; 1134 Success : constant Boolean := True; 1135 1136 Index_Typ : constant Entity_Id := Etype (Index); 1137 Index_Typ_Low : constant Node_Id := Type_Low_Bound (Index_Typ); 1138 Index_Typ_High : constant Node_Id := Type_High_Bound (Index_Typ); 1139 -- The type of the index corresponding to the array sub-aggregate along 1140 -- with its low and upper bounds. 1141 1142 Index_Base : constant Entity_Id := Base_Type (Index_Typ); 1143 Index_Base_Low : constant Node_Id := Type_Low_Bound (Index_Base); 1144 Index_Base_High : constant Node_Id := Type_High_Bound (Index_Base); 1145 -- Ditto for the base type 1146 1147 Others_Present : Boolean := False; 1148 1149 Nb_Choices : Nat := 0; 1150 -- Contains the overall number of named choices in this sub-aggregate 1151 1152 function Add (Val : Uint; To : Node_Id) return Node_Id; 1153 -- Creates a new expression node where Val is added to expression To. 1154 -- Tries to constant fold whenever possible. To must be an already 1155 -- analyzed expression. 1156 1157 procedure Check_Bound (BH : Node_Id; AH : in out Node_Id); 1158 -- Checks that AH (the upper bound of an array aggregate) is less than 1159 -- or equal to BH (the upper bound of the index base type). If the check 1160 -- fails, a warning is emitted, the Raises_Constraint_Error flag of N is 1161 -- set, and AH is replaced with a duplicate of BH. 1162 1163 procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id); 1164 -- Checks that range AL .. AH is compatible with range L .. H. Emits a 1165 -- warning if not and sets the Raises_Constraint_Error flag in N. 1166 1167 procedure Check_Length (L, H : Node_Id; Len : Uint); 1168 -- Checks that range L .. H contains at least Len elements. Emits a 1169 -- warning if not and sets the Raises_Constraint_Error flag in N. 1170 1171 function Dynamic_Or_Null_Range (L, H : Node_Id) return Boolean; 1172 -- Returns True if range L .. H is dynamic or null 1173 1174 procedure Get (Value : out Uint; From : Node_Id; OK : out Boolean); 1175 -- Given expression node From, this routine sets OK to False if it 1176 -- cannot statically evaluate From. Otherwise it stores this static 1177 -- value into Value. 1178 1179 function Resolve_Aggr_Expr 1180 (Expr : Node_Id; 1181 Single_Elmt : Boolean) return Boolean; 1182 -- Resolves aggregate expression Expr. Returns False if resolution 1183 -- fails. If Single_Elmt is set to False, the expression Expr may be 1184 -- used to initialize several array aggregate elements (this can happen 1185 -- for discrete choices such as "L .. H => Expr" or the OTHERS choice). 1186 -- In this event we do not resolve Expr unless expansion is disabled. 1187 -- To know why, see the DELAYED COMPONENT RESOLUTION note above. 1188 -- 1189 -- NOTE: In the case of "... => <>", we pass the in the 1190 -- N_Component_Association node as Expr, since there is no Expression in 1191 -- that case, and we need a Sloc for the error message. 1192 1193 procedure Resolve_Iterated_Component_Association 1194 (N : Node_Id; 1195 Index_Typ : Entity_Id); 1196 -- For AI12-061 1197 1198 --------- 1199 -- Add -- 1200 --------- 1201 1202 function Add (Val : Uint; To : Node_Id) return Node_Id is 1203 Expr_Pos : Node_Id; 1204 Expr : Node_Id; 1205 To_Pos : Node_Id; 1206 1207 begin 1208 if Raises_Constraint_Error (To) then 1209 return To; 1210 end if; 1211 1212 -- First test if we can do constant folding 1213 1214 if Compile_Time_Known_Value (To) 1215 or else Nkind (To) = N_Integer_Literal 1216 then 1217 Expr_Pos := Make_Integer_Literal (Loc, Expr_Value (To) + Val); 1218 Set_Is_Static_Expression (Expr_Pos); 1219 Set_Etype (Expr_Pos, Etype (To)); 1220 Set_Analyzed (Expr_Pos, Analyzed (To)); 1221 1222 if not Is_Enumeration_Type (Index_Typ) then 1223 Expr := Expr_Pos; 1224 1225 -- If we are dealing with enumeration return 1226 -- Index_Typ'Val (Expr_Pos) 1227 1228 else 1229 Expr := 1230 Make_Attribute_Reference 1231 (Loc, 1232 Prefix => New_Occurrence_Of (Index_Typ, Loc), 1233 Attribute_Name => Name_Val, 1234 Expressions => New_List (Expr_Pos)); 1235 end if; 1236 1237 return Expr; 1238 end if; 1239 1240 -- If we are here no constant folding possible 1241 1242 if not Is_Enumeration_Type (Index_Base) then 1243 Expr := 1244 Make_Op_Add (Loc, 1245 Left_Opnd => Duplicate_Subexpr (To), 1246 Right_Opnd => Make_Integer_Literal (Loc, Val)); 1247 1248 -- If we are dealing with enumeration return 1249 -- Index_Typ'Val (Index_Typ'Pos (To) + Val) 1250 1251 else 1252 To_Pos := 1253 Make_Attribute_Reference 1254 (Loc, 1255 Prefix => New_Occurrence_Of (Index_Typ, Loc), 1256 Attribute_Name => Name_Pos, 1257 Expressions => New_List (Duplicate_Subexpr (To))); 1258 1259 Expr_Pos := 1260 Make_Op_Add (Loc, 1261 Left_Opnd => To_Pos, 1262 Right_Opnd => Make_Integer_Literal (Loc, Val)); 1263 1264 Expr := 1265 Make_Attribute_Reference 1266 (Loc, 1267 Prefix => New_Occurrence_Of (Index_Typ, Loc), 1268 Attribute_Name => Name_Val, 1269 Expressions => New_List (Expr_Pos)); 1270 1271 -- If the index type has a non standard representation, the 1272 -- attributes 'Val and 'Pos expand into function calls and the 1273 -- resulting expression is considered non-safe for reevaluation 1274 -- by the backend. Relocate it into a constant temporary in order 1275 -- to make it safe for reevaluation. 1276 1277 if Has_Non_Standard_Rep (Etype (N)) then 1278 declare 1279 Def_Id : Entity_Id; 1280 1281 begin 1282 Def_Id := Make_Temporary (Loc, 'R', Expr); 1283 Set_Etype (Def_Id, Index_Typ); 1284 Insert_Action (N, 1285 Make_Object_Declaration (Loc, 1286 Defining_Identifier => Def_Id, 1287 Object_Definition => 1288 New_Occurrence_Of (Index_Typ, Loc), 1289 Constant_Present => True, 1290 Expression => Relocate_Node (Expr))); 1291 1292 Expr := New_Occurrence_Of (Def_Id, Loc); 1293 end; 1294 end if; 1295 end if; 1296 1297 return Expr; 1298 end Add; 1299 1300 ----------------- 1301 -- Check_Bound -- 1302 ----------------- 1303 1304 procedure Check_Bound (BH : Node_Id; AH : in out Node_Id) is 1305 Val_BH : Uint; 1306 Val_AH : Uint; 1307 1308 OK_BH : Boolean; 1309 OK_AH : Boolean; 1310 1311 begin 1312 Get (Value => Val_BH, From => BH, OK => OK_BH); 1313 Get (Value => Val_AH, From => AH, OK => OK_AH); 1314 1315 if OK_BH and then OK_AH and then Val_BH < Val_AH then 1316 Set_Raises_Constraint_Error (N); 1317 Error_Msg_Warn := SPARK_Mode /= On; 1318 Error_Msg_N ("upper bound out of range<<", AH); 1319 Error_Msg_N ("\Constraint_Error [<<", AH); 1320 1321 -- You need to set AH to BH or else in the case of enumerations 1322 -- indexes we will not be able to resolve the aggregate bounds. 1323 1324 AH := Duplicate_Subexpr (BH); 1325 end if; 1326 end Check_Bound; 1327 1328 ------------------ 1329 -- Check_Bounds -- 1330 ------------------ 1331 1332 procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id) is 1333 Val_L : Uint; 1334 Val_H : Uint; 1335 Val_AL : Uint; 1336 Val_AH : Uint; 1337 1338 OK_L : Boolean; 1339 OK_H : Boolean; 1340 1341 OK_AL : Boolean; 1342 OK_AH : Boolean; 1343 pragma Warnings (Off, OK_AL); 1344 pragma Warnings (Off, OK_AH); 1345 1346 begin 1347 if Raises_Constraint_Error (N) 1348 or else Dynamic_Or_Null_Range (AL, AH) 1349 then 1350 return; 1351 end if; 1352 1353 Get (Value => Val_L, From => L, OK => OK_L); 1354 Get (Value => Val_H, From => H, OK => OK_H); 1355 1356 Get (Value => Val_AL, From => AL, OK => OK_AL); 1357 Get (Value => Val_AH, From => AH, OK => OK_AH); 1358 1359 if OK_L and then Val_L > Val_AL then 1360 Set_Raises_Constraint_Error (N); 1361 Error_Msg_Warn := SPARK_Mode /= On; 1362 Error_Msg_N ("lower bound of aggregate out of range<<", N); 1363 Error_Msg_N ("\Constraint_Error [<<", N); 1364 end if; 1365 1366 if OK_H and then Val_H < Val_AH then 1367 Set_Raises_Constraint_Error (N); 1368 Error_Msg_Warn := SPARK_Mode /= On; 1369 Error_Msg_N ("upper bound of aggregate out of range<<", N); 1370 Error_Msg_N ("\Constraint_Error [<<", N); 1371 end if; 1372 end Check_Bounds; 1373 1374 ------------------ 1375 -- Check_Length -- 1376 ------------------ 1377 1378 procedure Check_Length (L, H : Node_Id; Len : Uint) is 1379 Val_L : Uint; 1380 Val_H : Uint; 1381 1382 OK_L : Boolean; 1383 OK_H : Boolean; 1384 1385 Range_Len : Uint; 1386 1387 begin 1388 if Raises_Constraint_Error (N) then 1389 return; 1390 end if; 1391 1392 Get (Value => Val_L, From => L, OK => OK_L); 1393 Get (Value => Val_H, From => H, OK => OK_H); 1394 1395 if not OK_L or else not OK_H then 1396 return; 1397 end if; 1398 1399 -- If null range length is zero 1400 1401 if Val_L > Val_H then 1402 Range_Len := Uint_0; 1403 else 1404 Range_Len := Val_H - Val_L + 1; 1405 end if; 1406 1407 if Range_Len < Len then 1408 Set_Raises_Constraint_Error (N); 1409 Error_Msg_Warn := SPARK_Mode /= On; 1410 Error_Msg_N ("too many elements<<", N); 1411 Error_Msg_N ("\Constraint_Error [<<", N); 1412 end if; 1413 end Check_Length; 1414 1415 --------------------------- 1416 -- Dynamic_Or_Null_Range -- 1417 --------------------------- 1418 1419 function Dynamic_Or_Null_Range (L, H : Node_Id) return Boolean is 1420 Val_L : Uint; 1421 Val_H : Uint; 1422 1423 OK_L : Boolean; 1424 OK_H : Boolean; 1425 1426 begin 1427 Get (Value => Val_L, From => L, OK => OK_L); 1428 Get (Value => Val_H, From => H, OK => OK_H); 1429 1430 return not OK_L or else not OK_H 1431 or else not Is_OK_Static_Expression (L) 1432 or else not Is_OK_Static_Expression (H) 1433 or else Val_L > Val_H; 1434 end Dynamic_Or_Null_Range; 1435 1436 --------- 1437 -- Get -- 1438 --------- 1439 1440 procedure Get (Value : out Uint; From : Node_Id; OK : out Boolean) is 1441 begin 1442 OK := True; 1443 1444 if Compile_Time_Known_Value (From) then 1445 Value := Expr_Value (From); 1446 1447 -- If expression From is something like Some_Type'Val (10) then 1448 -- Value = 10. 1449 1450 elsif Nkind (From) = N_Attribute_Reference 1451 and then Attribute_Name (From) = Name_Val 1452 and then Compile_Time_Known_Value (First (Expressions (From))) 1453 then 1454 Value := Expr_Value (First (Expressions (From))); 1455 else 1456 Value := Uint_0; 1457 OK := False; 1458 end if; 1459 end Get; 1460 1461 ----------------------- 1462 -- Resolve_Aggr_Expr -- 1463 ----------------------- 1464 1465 function Resolve_Aggr_Expr 1466 (Expr : Node_Id; 1467 Single_Elmt : Boolean) return Boolean 1468 is 1469 Nxt_Ind : constant Node_Id := Next_Index (Index); 1470 Nxt_Ind_Constr : constant Node_Id := Next_Index (Index_Constr); 1471 -- Index is the current index corresponding to the expression 1472 1473 Resolution_OK : Boolean := True; 1474 -- Set to False if resolution of the expression failed 1475 1476 begin 1477 -- Defend against previous errors 1478 1479 if Nkind (Expr) = N_Error 1480 or else Error_Posted (Expr) 1481 then 1482 return True; 1483 end if; 1484 1485 -- If the array type against which we are resolving the aggregate 1486 -- has several dimensions, the expressions nested inside the 1487 -- aggregate must be further aggregates (or strings). 1488 1489 if Present (Nxt_Ind) then 1490 if Nkind (Expr) /= N_Aggregate then 1491 1492 -- A string literal can appear where a one-dimensional array 1493 -- of characters is expected. If the literal looks like an 1494 -- operator, it is still an operator symbol, which will be 1495 -- transformed into a string when analyzed. 1496 1497 if Is_Character_Type (Component_Typ) 1498 and then No (Next_Index (Nxt_Ind)) 1499 and then Nkind (Expr) in N_String_Literal | N_Operator_Symbol 1500 then 1501 -- A string literal used in a multidimensional array 1502 -- aggregate in place of the final one-dimensional 1503 -- aggregate must not be enclosed in parentheses. 1504 1505 if Paren_Count (Expr) /= 0 then 1506 Error_Msg_N ("no parenthesis allowed here", Expr); 1507 end if; 1508 1509 Make_String_Into_Aggregate (Expr); 1510 1511 else 1512 Error_Msg_N ("nested array aggregate expected", Expr); 1513 1514 -- If the expression is parenthesized, this may be 1515 -- a missing component association for a 1-aggregate. 1516 1517 if Paren_Count (Expr) > 0 then 1518 Error_Msg_N 1519 ("\if single-component aggregate is intended, " 1520 & "write e.g. (1 ='> ...)", Expr); 1521 end if; 1522 1523 return Failure; 1524 end if; 1525 end if; 1526 1527 -- If it's "... => <>", nothing to resolve 1528 1529 if Nkind (Expr) = N_Component_Association then 1530 pragma Assert (Box_Present (Expr)); 1531 return Success; 1532 end if; 1533 1534 -- Ada 2005 (AI-231): Propagate the type to the nested aggregate. 1535 -- Required to check the null-exclusion attribute (if present). 1536 -- This value may be overridden later on. 1537 1538 Set_Etype (Expr, Etype (N)); 1539 1540 Resolution_OK := Resolve_Array_Aggregate 1541 (Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ, Others_Allowed); 1542 1543 else 1544 -- If it's "... => <>", nothing to resolve 1545 1546 if Nkind (Expr) = N_Component_Association then 1547 pragma Assert (Box_Present (Expr)); 1548 return Success; 1549 end if; 1550 1551 -- Do not resolve the expressions of discrete or others choices 1552 -- unless the expression covers a single component, or the 1553 -- expander is inactive. 1554 1555 -- In SPARK mode, expressions that can perform side effects will 1556 -- be recognized by the gnat2why back-end, and the whole 1557 -- subprogram will be ignored. So semantic analysis can be 1558 -- performed safely. 1559 1560 if Single_Elmt 1561 or else not Expander_Active 1562 or else In_Spec_Expression 1563 then 1564 Analyze_And_Resolve (Expr, Component_Typ); 1565 Check_Expr_OK_In_Limited_Aggregate (Expr); 1566 Check_Non_Static_Context (Expr); 1567 Aggregate_Constraint_Checks (Expr, Component_Typ); 1568 Check_Unset_Reference (Expr); 1569 end if; 1570 end if; 1571 1572 -- If an aggregate component has a type with predicates, an explicit 1573 -- predicate check must be applied, as for an assignment statement, 1574 -- because the aggregate might not be expanded into individual 1575 -- component assignments. If the expression covers several components 1576 -- the analysis and the predicate check take place later. 1577 1578 if Has_Predicates (Component_Typ) 1579 and then Analyzed (Expr) 1580 then 1581 Apply_Predicate_Check (Expr, Component_Typ); 1582 end if; 1583 1584 if Raises_Constraint_Error (Expr) 1585 and then Nkind (Parent (Expr)) /= N_Component_Association 1586 then 1587 Set_Raises_Constraint_Error (N); 1588 end if; 1589 1590 -- If the expression has been marked as requiring a range check, 1591 -- then generate it here. It's a bit odd to be generating such 1592 -- checks in the analyzer, but harmless since Generate_Range_Check 1593 -- does nothing (other than making sure Do_Range_Check is set) if 1594 -- the expander is not active. 1595 1596 if Do_Range_Check (Expr) then 1597 Generate_Range_Check (Expr, Component_Typ, CE_Range_Check_Failed); 1598 end if; 1599 1600 return Resolution_OK; 1601 end Resolve_Aggr_Expr; 1602 1603 -------------------------------------------- 1604 -- Resolve_Iterated_Component_Association -- 1605 -------------------------------------------- 1606 1607 procedure Resolve_Iterated_Component_Association 1608 (N : Node_Id; 1609 Index_Typ : Entity_Id) 1610 is 1611 Loc : constant Source_Ptr := Sloc (N); 1612 Id : constant Entity_Id := Defining_Identifier (N); 1613 1614 Id_Typ : Entity_Id := Any_Type; 1615 1616 ----------------------- 1617 -- Remove_References -- 1618 ----------------------- 1619 1620 function Remove_Ref (N : Node_Id) return Traverse_Result; 1621 -- Remove references to the entity Id after analysis, so it can be 1622 -- properly reanalyzed after construct is expanded into a loop. 1623 1624 function Remove_Ref (N : Node_Id) return Traverse_Result is 1625 begin 1626 if Nkind (N) = N_Identifier 1627 and then Present (Entity (N)) 1628 and then Entity (N) = Id 1629 then 1630 Set_Entity (N, Empty); 1631 Set_Etype (N, Empty); 1632 end if; 1633 Set_Analyzed (N, False); 1634 return OK; 1635 end Remove_Ref; 1636 1637 procedure Remove_References is new Traverse_Proc (Remove_Ref); 1638 1639 -- Local variables 1640 1641 Choice : Node_Id; 1642 Dummy : Boolean; 1643 Ent : Entity_Id; 1644 Expr : Node_Id; 1645 1646 -- Start of processing for Resolve_Iterated_Component_Association 1647 1648 begin 1649 Error_Msg_Ada_2022_Feature ("iterated component", Loc); 1650 1651 if Present (Iterator_Specification (N)) then 1652 Analyze (Name (Iterator_Specification (N))); 1653 1654 -- We assume that the domain of iteration cannot be overloaded. 1655 1656 declare 1657 Domain : constant Node_Id := Name (Iterator_Specification (N)); 1658 D_Type : constant Entity_Id := Etype (Domain); 1659 Elt : Entity_Id; 1660 begin 1661 if Is_Array_Type (D_Type) then 1662 Id_Typ := Component_Type (D_Type); 1663 1664 else 1665 if Has_Aspect (D_Type, Aspect_Iterable) then 1666 Elt := 1667 Get_Iterable_Type_Primitive (D_Type, Name_Element); 1668 if No (Elt) then 1669 Error_Msg_N 1670 ("missing Element primitive for iteration", Domain); 1671 else 1672 Id_Typ := Etype (Elt); 1673 end if; 1674 else 1675 Error_Msg_N ("cannot iterate over", Domain); 1676 end if; 1677 end if; 1678 end; 1679 1680 else 1681 Id_Typ := Index_Typ; 1682 Choice := First (Discrete_Choices (N)); 1683 1684 while Present (Choice) loop 1685 if Nkind (Choice) = N_Others_Choice then 1686 Others_Present := True; 1687 1688 else 1689 Analyze (Choice); 1690 1691 -- Choice can be a subtype name, a range, or an expression 1692 1693 if Is_Entity_Name (Choice) 1694 and then Is_Type (Entity (Choice)) 1695 and then 1696 Base_Type (Entity (Choice)) = Base_Type (Index_Typ) 1697 then 1698 null; 1699 1700 else 1701 Analyze_And_Resolve (Choice, Index_Typ); 1702 end if; 1703 end if; 1704 1705 Next (Choice); 1706 end loop; 1707 end if; 1708 1709 -- Create a scope in which to introduce an index, which is usually 1710 -- visible in the expression for the component, and needed for its 1711 -- analysis. 1712 1713 Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); 1714 Set_Etype (Ent, Standard_Void_Type); 1715 Set_Parent (Ent, Parent (N)); 1716 Push_Scope (Ent); 1717 1718 -- Insert and decorate the index variable in the current scope. 1719 -- The expression has to be analyzed once the index variable is 1720 -- directly visible. 1721 1722 Enter_Name (Id); 1723 Set_Etype (Id, Id_Typ); 1724 Mutate_Ekind (Id, E_Variable); 1725 Set_Scope (Id, Ent); 1726 1727 -- Analyze expression without expansion, to verify legality. 1728 -- When generating code, we then remove references to the index 1729 -- variable, because the expression will be analyzed anew after 1730 -- rewritting as a loop with a new index variable; when not 1731 -- generating code we leave the analyzed expression as it is. 1732 1733 Expr := Expression (N); 1734 1735 Expander_Mode_Save_And_Set (False); 1736 Dummy := Resolve_Aggr_Expr (Expr, Single_Elmt => False); 1737 Expander_Mode_Restore; 1738 1739 if Operating_Mode /= Check_Semantics then 1740 Remove_References (Expr); 1741 end if; 1742 1743 -- An iterated_component_association may appear in a nested 1744 -- aggregate for a multidimensional structure: preserve the bounds 1745 -- computed for the expression, as well as the anonymous array 1746 -- type generated for it; both are needed during array expansion. 1747 1748 if Nkind (Expr) = N_Aggregate then 1749 Set_Aggregate_Bounds (Expression (N), Aggregate_Bounds (Expr)); 1750 Set_Etype (Expression (N), Etype (Expr)); 1751 end if; 1752 1753 End_Scope; 1754 end Resolve_Iterated_Component_Association; 1755 1756 -- Local variables 1757 1758 Assoc : Node_Id; 1759 Choice : Node_Id; 1760 Expr : Node_Id; 1761 Discard : Node_Id; 1762 1763 Aggr_Low : Node_Id := Empty; 1764 Aggr_High : Node_Id := Empty; 1765 -- The actual low and high bounds of this sub-aggregate 1766 1767 Case_Table_Size : Nat; 1768 -- Contains the size of the case table needed to sort aggregate choices 1769 1770 Choices_Low : Node_Id := Empty; 1771 Choices_High : Node_Id := Empty; 1772 -- The lowest and highest discrete choices values for a named aggregate 1773 1774 Delete_Choice : Boolean; 1775 -- Used when replacing a subtype choice with predicate by a list 1776 1777 Has_Iterator_Specifications : Boolean := False; 1778 -- Flag to indicate that all named associations are iterated component 1779 -- associations with iterator specifications, in which case the 1780 -- expansion will create two loops: one to evaluate the size and one 1781 -- to generate the elements (4.3.3 (20.2/5)). 1782 1783 Nb_Elements : Uint := Uint_0; 1784 -- The number of elements in a positional aggregate 1785 1786 Nb_Discrete_Choices : Nat := 0; 1787 -- The overall number of discrete choices (not counting others choice) 1788 1789 -- Start of processing for Resolve_Array_Aggregate 1790 1791 begin 1792 -- Ignore junk empty aggregate resulting from parser error 1793 1794 if No (Expressions (N)) 1795 and then No (Component_Associations (N)) 1796 and then not Null_Record_Present (N) 1797 then 1798 return False; 1799 end if; 1800 1801 -- Disable the warning for GNAT Mode to allow for easier transition. 1802 1803 if Ada_Version >= Ada_2022 1804 and then Warn_On_Obsolescent_Feature 1805 and then not GNAT_Mode 1806 and then not Is_Homogeneous_Aggregate (N) 1807 and then not Is_Enum_Array_Aggregate (N) 1808 and then Is_Parenthesis_Aggregate (N) 1809 and then Nkind (Parent (N)) /= N_Qualified_Expression 1810 and then Comes_From_Source (N) 1811 then 1812 Error_Msg_N 1813 ("?j?array aggregate using () is an" & 1814 " obsolescent syntax, use '['] instead", N); 1815 end if; 1816 1817 -- STEP 1: make sure the aggregate is correctly formatted 1818 1819 if Present (Component_Associations (N)) then 1820 1821 -- Verify that all or none of the component associations 1822 -- include an iterator specification. 1823 1824 Assoc := First (Component_Associations (N)); 1825 if Nkind (Assoc) = N_Iterated_Component_Association 1826 and then Present (Iterator_Specification (Assoc)) 1827 then 1828 -- All other component associations must have an iterator spec. 1829 1830 Next (Assoc); 1831 while Present (Assoc) loop 1832 if Nkind (Assoc) /= N_Iterated_Component_Association 1833 or else No (Iterator_Specification (Assoc)) 1834 then 1835 Error_Msg_N ("mixed iterated component association" 1836 & " (RM 4.4.3 (17.1/5))", 1837 Assoc); 1838 return False; 1839 end if; 1840 1841 Next (Assoc); 1842 end loop; 1843 1844 Has_Iterator_Specifications := True; 1845 1846 else 1847 -- or none of them do. 1848 1849 Next (Assoc); 1850 while Present (Assoc) loop 1851 if Nkind (Assoc) = N_Iterated_Component_Association 1852 and then Present (Iterator_Specification (Assoc)) 1853 then 1854 Error_Msg_N ("mixed iterated component association" 1855 & " (RM 4.4.3 (17.1/5))", 1856 Assoc); 1857 return False; 1858 end if; 1859 1860 Next (Assoc); 1861 end loop; 1862 1863 while Present (Assoc) loop 1864 Next (Assoc); 1865 end loop; 1866 end if; 1867 1868 Assoc := First (Component_Associations (N)); 1869 while Present (Assoc) loop 1870 if Nkind (Assoc) = N_Iterated_Component_Association then 1871 Resolve_Iterated_Component_Association (Assoc, Index_Typ); 1872 end if; 1873 1874 Choice := First (Choice_List (Assoc)); 1875 Delete_Choice := False; 1876 while Present (Choice) loop 1877 if Nkind (Choice) = N_Others_Choice then 1878 Others_Present := True; 1879 1880 if Choice /= First (Choice_List (Assoc)) 1881 or else Present (Next (Choice)) 1882 then 1883 Error_Msg_N 1884 ("OTHERS must appear alone in a choice list", Choice); 1885 return Failure; 1886 end if; 1887 1888 if Present (Next (Assoc)) then 1889 Error_Msg_N 1890 ("OTHERS must appear last in an aggregate", Choice); 1891 return Failure; 1892 end if; 1893 1894 if Ada_Version = Ada_83 1895 and then Assoc /= First (Component_Associations (N)) 1896 and then Nkind (Parent (N)) in 1897 N_Assignment_Statement | N_Object_Declaration 1898 then 1899 Error_Msg_N 1900 ("(Ada 83) illegal context for OTHERS choice", N); 1901 end if; 1902 1903 elsif Is_Entity_Name (Choice) then 1904 Analyze (Choice); 1905 1906 declare 1907 E : constant Entity_Id := Entity (Choice); 1908 New_Cs : List_Id; 1909 P : Node_Id; 1910 C : Node_Id; 1911 1912 begin 1913 if Is_Type (E) and then Has_Predicates (E) then 1914 Freeze_Before (N, E); 1915 1916 if Has_Dynamic_Predicate_Aspect (E) then 1917 Error_Msg_NE 1918 ("subtype& has dynamic predicate, not allowed " 1919 & "in aggregate choice", Choice, E); 1920 1921 elsif not Is_OK_Static_Subtype (E) then 1922 Error_Msg_NE 1923 ("non-static subtype& has predicate, not allowed " 1924 & "in aggregate choice", Choice, E); 1925 end if; 1926 1927 -- If the subtype has a static predicate, replace the 1928 -- original choice with the list of individual values 1929 -- covered by the predicate. 1930 -- This should be deferred to expansion time ??? 1931 1932 if Present (Static_Discrete_Predicate (E)) then 1933 Delete_Choice := True; 1934 1935 New_Cs := New_List; 1936 P := First (Static_Discrete_Predicate (E)); 1937 while Present (P) loop 1938 C := New_Copy (P); 1939 Set_Sloc (C, Sloc (Choice)); 1940 Append_To (New_Cs, C); 1941 Next (P); 1942 end loop; 1943 1944 Insert_List_After (Choice, New_Cs); 1945 end if; 1946 end if; 1947 end; 1948 end if; 1949 1950 Nb_Choices := Nb_Choices + 1; 1951 1952 declare 1953 C : constant Node_Id := Choice; 1954 1955 begin 1956 Next (Choice); 1957 1958 if Delete_Choice then 1959 Remove (C); 1960 Nb_Choices := Nb_Choices - 1; 1961 Delete_Choice := False; 1962 end if; 1963 end; 1964 end loop; 1965 1966 Next (Assoc); 1967 end loop; 1968 end if; 1969 1970 -- At this point we know that the others choice, if present, is by 1971 -- itself and appears last in the aggregate. Check if we have mixed 1972 -- positional and discrete associations (other than the others choice). 1973 1974 if Present (Expressions (N)) 1975 and then (Nb_Choices > 1 1976 or else (Nb_Choices = 1 and then not Others_Present)) 1977 then 1978 Error_Msg_N 1979 ("cannot mix named and positional associations in array aggregate", 1980 First (Choice_List (First (Component_Associations (N))))); 1981 return Failure; 1982 end if; 1983 1984 -- Test for the validity of an others choice if present 1985 1986 if Others_Present and then not Others_Allowed then 1987 declare 1988 Others_N : constant Node_Id := 1989 First (Choice_List (First (Component_Associations (N)))); 1990 begin 1991 Error_Msg_N ("OTHERS choice not allowed here", Others_N); 1992 Error_Msg_N ("\qualify the aggregate with a constrained subtype " 1993 & "to provide bounds for it", Others_N); 1994 return Failure; 1995 end; 1996 end if; 1997 1998 -- Protect against cascaded errors 1999 2000 if Etype (Index_Typ) = Any_Type then 2001 return Failure; 2002 end if; 2003 2004 -- STEP 2: Process named components 2005 2006 if No (Expressions (N)) then 2007 if Others_Present then 2008 Case_Table_Size := Nb_Choices - 1; 2009 else 2010 Case_Table_Size := Nb_Choices; 2011 end if; 2012 2013 Step_2 : declare 2014 function Empty_Range (A : Node_Id) return Boolean; 2015 -- If an association covers an empty range, some warnings on the 2016 -- expression of the association can be disabled. 2017 2018 ----------------- 2019 -- Empty_Range -- 2020 ----------------- 2021 2022 function Empty_Range (A : Node_Id) return Boolean is 2023 R : constant Node_Id := First (Choices (A)); 2024 begin 2025 return No (Next (R)) 2026 and then Nkind (R) = N_Range 2027 and then Compile_Time_Compare 2028 (Low_Bound (R), High_Bound (R), False) = GT; 2029 end Empty_Range; 2030 2031 -- Local variables 2032 2033 Low : Node_Id; 2034 High : Node_Id; 2035 -- Denote the lowest and highest values in an aggregate choice 2036 2037 S_Low : Node_Id := Empty; 2038 S_High : Node_Id := Empty; 2039 -- if a choice in an aggregate is a subtype indication these 2040 -- denote the lowest and highest values of the subtype 2041 2042 Table : Case_Table_Type (1 .. Case_Table_Size); 2043 -- Used to sort all the different choice values 2044 2045 Single_Choice : Boolean; 2046 -- Set to true every time there is a single discrete choice in a 2047 -- discrete association 2048 2049 Prev_Nb_Discrete_Choices : Nat; 2050 -- Used to keep track of the number of discrete choices in the 2051 -- current association. 2052 2053 Errors_Posted_On_Choices : Boolean := False; 2054 -- Keeps track of whether any choices have semantic errors 2055 2056 -- Start of processing for Step_2 2057 2058 begin 2059 -- STEP 2 (A): Check discrete choices validity 2060 -- No need if this is an element iteration. 2061 2062 Assoc := First (Component_Associations (N)); 2063 while Present (Assoc) 2064 and then Present (Choice_List (Assoc)) 2065 loop 2066 Prev_Nb_Discrete_Choices := Nb_Discrete_Choices; 2067 Choice := First (Choice_List (Assoc)); 2068 2069 loop 2070 Analyze (Choice); 2071 2072 if Nkind (Choice) = N_Others_Choice then 2073 Single_Choice := False; 2074 exit; 2075 2076 -- Test for subtype mark without constraint 2077 2078 elsif Is_Entity_Name (Choice) and then 2079 Is_Type (Entity (Choice)) 2080 then 2081 if Base_Type (Entity (Choice)) /= Index_Base then 2082 Error_Msg_N 2083 ("invalid subtype mark in aggregate choice", 2084 Choice); 2085 return Failure; 2086 end if; 2087 2088 -- Case of subtype indication 2089 2090 elsif Nkind (Choice) = N_Subtype_Indication then 2091 Resolve_Discrete_Subtype_Indication (Choice, Index_Base); 2092 2093 if Has_Dynamic_Predicate_Aspect 2094 (Entity (Subtype_Mark (Choice))) 2095 then 2096 Error_Msg_NE 2097 ("subtype& has dynamic predicate, " 2098 & "not allowed in aggregate choice", 2099 Choice, Entity (Subtype_Mark (Choice))); 2100 end if; 2101 2102 -- Does the subtype indication evaluation raise CE? 2103 2104 Get_Index_Bounds (Subtype_Mark (Choice), S_Low, S_High); 2105 Get_Index_Bounds (Choice, Low, High); 2106 Check_Bounds (S_Low, S_High, Low, High); 2107 2108 -- Case of range or expression 2109 2110 else 2111 Resolve (Choice, Index_Base); 2112 Check_Unset_Reference (Choice); 2113 Check_Non_Static_Context (Choice); 2114 2115 -- If semantic errors were posted on the choice, then 2116 -- record that for possible early return from later 2117 -- processing (see handling of enumeration choices). 2118 2119 if Error_Posted (Choice) then 2120 Errors_Posted_On_Choices := True; 2121 end if; 2122 2123 -- Do not range check a choice. This check is redundant 2124 -- since this test is already done when we check that the 2125 -- bounds of the array aggregate are within range. 2126 2127 Set_Do_Range_Check (Choice, False); 2128 end if; 2129 2130 -- If we could not resolve the discrete choice stop here 2131 2132 if Etype (Choice) = Any_Type then 2133 return Failure; 2134 2135 -- If the discrete choice raises CE get its original bounds 2136 2137 elsif Nkind (Choice) = N_Raise_Constraint_Error then 2138 Set_Raises_Constraint_Error (N); 2139 Get_Index_Bounds (Original_Node (Choice), Low, High); 2140 2141 -- Otherwise get its bounds as usual 2142 2143 else 2144 Get_Index_Bounds (Choice, Low, High); 2145 end if; 2146 2147 if (Dynamic_Or_Null_Range (Low, High) 2148 or else (Nkind (Choice) = N_Subtype_Indication 2149 and then 2150 Dynamic_Or_Null_Range (S_Low, S_High))) 2151 and then Nb_Choices /= 1 2152 then 2153 Error_Msg_N 2154 ("dynamic or empty choice in aggregate " 2155 & "must be the only choice", Choice); 2156 return Failure; 2157 end if; 2158 2159 if not (All_Composite_Constraints_Static (Low) 2160 and then All_Composite_Constraints_Static (High) 2161 and then All_Composite_Constraints_Static (S_Low) 2162 and then All_Composite_Constraints_Static (S_High)) 2163 then 2164 Check_Restriction (No_Dynamic_Sized_Objects, Choice); 2165 end if; 2166 2167 Nb_Discrete_Choices := Nb_Discrete_Choices + 1; 2168 Table (Nb_Discrete_Choices).Lo := Low; 2169 Table (Nb_Discrete_Choices).Hi := High; 2170 Table (Nb_Discrete_Choices).Choice := Choice; 2171 2172 Next (Choice); 2173 2174 if No (Choice) then 2175 2176 -- Check if we have a single discrete choice and whether 2177 -- this discrete choice specifies a single value. 2178 2179 Single_Choice := 2180 (Nb_Discrete_Choices = Prev_Nb_Discrete_Choices + 1) 2181 and then (Low = High); 2182 2183 exit; 2184 end if; 2185 end loop; 2186 2187 -- Ada 2005 (AI-231) 2188 2189 if Ada_Version >= Ada_2005 2190 and then Known_Null (Expression (Assoc)) 2191 and then not Empty_Range (Assoc) 2192 then 2193 Check_Can_Never_Be_Null (Etype (N), Expression (Assoc)); 2194 end if; 2195 2196 -- Ada 2005 (AI-287): In case of default initialized component 2197 -- we delay the resolution to the expansion phase. 2198 2199 if Box_Present (Assoc) then 2200 2201 -- Ada 2005 (AI-287): In case of default initialization of a 2202 -- component the expander will generate calls to the 2203 -- corresponding initialization subprogram. We need to call 2204 -- Resolve_Aggr_Expr to check the rules about 2205 -- dimensionality. 2206 2207 if not Resolve_Aggr_Expr 2208 (Assoc, Single_Elmt => Single_Choice) 2209 then 2210 return Failure; 2211 end if; 2212 2213 -- ??? Checks for dynamically tagged expressions below will 2214 -- be only applied to iterated_component_association after 2215 -- expansion; in particular, errors might not be reported when 2216 -- -gnatc switch is used. 2217 2218 elsif Nkind (Assoc) = N_Iterated_Component_Association then 2219 null; -- handled above, in a loop context 2220 2221 elsif not Resolve_Aggr_Expr 2222 (Expression (Assoc), Single_Elmt => Single_Choice) 2223 then 2224 return Failure; 2225 2226 -- Check incorrect use of dynamically tagged expression 2227 2228 -- We differentiate here two cases because the expression may 2229 -- not be decorated. For example, the analysis and resolution 2230 -- of the expression associated with the others choice will be 2231 -- done later with the full aggregate. In such case we 2232 -- duplicate the expression tree to analyze the copy and 2233 -- perform the required check. 2234 2235 elsif not Present (Etype (Expression (Assoc))) then 2236 declare 2237 Save_Analysis : constant Boolean := Full_Analysis; 2238 Expr : constant Node_Id := 2239 New_Copy_Tree (Expression (Assoc)); 2240 2241 begin 2242 Expander_Mode_Save_And_Set (False); 2243 Full_Analysis := False; 2244 2245 -- Analyze the expression, making sure it is properly 2246 -- attached to the tree before we do the analysis. 2247 2248 Set_Parent (Expr, Parent (Expression (Assoc))); 2249 Analyze (Expr); 2250 2251 -- Compute its dimensions now, rather than at the end of 2252 -- resolution, because in the case of multidimensional 2253 -- aggregates subsequent expansion may lead to spurious 2254 -- errors. 2255 2256 Check_Expression_Dimensions (Expr, Component_Typ); 2257 2258 -- If the expression is a literal, propagate this info 2259 -- to the expression in the association, to enable some 2260 -- optimizations downstream. 2261 2262 if Is_Entity_Name (Expr) 2263 and then Present (Entity (Expr)) 2264 and then Ekind (Entity (Expr)) = E_Enumeration_Literal 2265 then 2266 Analyze_And_Resolve 2267 (Expression (Assoc), Component_Typ); 2268 end if; 2269 2270 Full_Analysis := Save_Analysis; 2271 Expander_Mode_Restore; 2272 2273 if Is_Tagged_Type (Etype (Expr)) then 2274 Check_Dynamically_Tagged_Expression 2275 (Expr => Expr, 2276 Typ => Component_Type (Etype (N)), 2277 Related_Nod => N); 2278 end if; 2279 end; 2280 2281 elsif Is_Tagged_Type (Etype (Expression (Assoc))) then 2282 Check_Dynamically_Tagged_Expression 2283 (Expr => Expression (Assoc), 2284 Typ => Component_Type (Etype (N)), 2285 Related_Nod => N); 2286 end if; 2287 2288 Next (Assoc); 2289 end loop; 2290 2291 -- If aggregate contains more than one choice then these must be 2292 -- static. Check for duplicate and missing values. 2293 2294 -- Note: there is duplicated code here wrt Check_Choice_Set in 2295 -- the body of Sem_Case, and it is possible we could just reuse 2296 -- that procedure. To be checked ??? 2297 2298 if Nb_Discrete_Choices > 1 then 2299 Check_Choices : declare 2300 Choice : Node_Id; 2301 -- Location of choice for messages 2302 2303 Hi_Val : Uint; 2304 Lo_Val : Uint; 2305 -- High end of one range and Low end of the next. Should be 2306 -- contiguous if there is no hole in the list of values. 2307 2308 Lo_Dup : Uint; 2309 Hi_Dup : Uint; 2310 -- End points of duplicated range 2311 2312 Missing_Or_Duplicates : Boolean := False; 2313 -- Set True if missing or duplicate choices found 2314 2315 procedure Output_Bad_Choices (Lo, Hi : Uint; C : Node_Id); 2316 -- Output continuation message with a representation of the 2317 -- bounds (just Lo if Lo = Hi, else Lo .. Hi). C is the 2318 -- choice node where the message is to be posted. 2319 2320 ------------------------ 2321 -- Output_Bad_Choices -- 2322 ------------------------ 2323 2324 procedure Output_Bad_Choices (Lo, Hi : Uint; C : Node_Id) is 2325 begin 2326 -- Enumeration type case 2327 2328 if Is_Enumeration_Type (Index_Typ) then 2329 Error_Msg_Name_1 := 2330 Chars (Get_Enum_Lit_From_Pos (Index_Typ, Lo, Loc)); 2331 Error_Msg_Name_2 := 2332 Chars (Get_Enum_Lit_From_Pos (Index_Typ, Hi, Loc)); 2333 2334 if Lo = Hi then 2335 Error_Msg_N ("\\ %!", C); 2336 else 2337 Error_Msg_N ("\\ % .. %!", C); 2338 end if; 2339 2340 -- Integer types case 2341 2342 else 2343 Error_Msg_Uint_1 := Lo; 2344 Error_Msg_Uint_2 := Hi; 2345 2346 if Lo = Hi then 2347 Error_Msg_N ("\\ ^!", C); 2348 else 2349 Error_Msg_N ("\\ ^ .. ^!", C); 2350 end if; 2351 end if; 2352 end Output_Bad_Choices; 2353 2354 -- Start of processing for Check_Choices 2355 2356 begin 2357 Sort_Case_Table (Table); 2358 2359 -- First we do a quick linear loop to find out if we have 2360 -- any duplicates or missing entries (usually we have a 2361 -- legal aggregate, so this will get us out quickly). 2362 2363 for J in 1 .. Nb_Discrete_Choices - 1 loop 2364 Hi_Val := Expr_Value (Table (J).Hi); 2365 Lo_Val := Expr_Value (Table (J + 1).Lo); 2366 2367 if Lo_Val <= Hi_Val 2368 or else (Lo_Val > Hi_Val + 1 2369 and then not Others_Present) 2370 then 2371 Missing_Or_Duplicates := True; 2372 exit; 2373 end if; 2374 end loop; 2375 2376 -- If we have missing or duplicate entries, first fill in 2377 -- the Highest entries to make life easier in the following 2378 -- loops to detect bad entries. 2379 2380 if Missing_Or_Duplicates then 2381 Table (1).Highest := Expr_Value (Table (1).Hi); 2382 2383 for J in 2 .. Nb_Discrete_Choices loop 2384 Table (J).Highest := 2385 UI_Max 2386 (Table (J - 1).Highest, Expr_Value (Table (J).Hi)); 2387 end loop; 2388 2389 -- Loop through table entries to find duplicate indexes 2390 2391 for J in 2 .. Nb_Discrete_Choices loop 2392 Lo_Val := Expr_Value (Table (J).Lo); 2393 Hi_Val := Expr_Value (Table (J).Hi); 2394 2395 -- Case where we have duplicates (the lower bound of 2396 -- this choice is less than or equal to the highest 2397 -- high bound found so far). 2398 2399 if Lo_Val <= Table (J - 1).Highest then 2400 2401 -- We move backwards looking for duplicates. We can 2402 -- abandon this loop as soon as we reach a choice 2403 -- highest value that is less than Lo_Val. 2404 2405 for K in reverse 1 .. J - 1 loop 2406 exit when Table (K).Highest < Lo_Val; 2407 2408 -- Here we may have duplicates between entries 2409 -- for K and J. Get range of duplicates. 2410 2411 Lo_Dup := 2412 UI_Max (Lo_Val, Expr_Value (Table (K).Lo)); 2413 Hi_Dup := 2414 UI_Min (Hi_Val, Expr_Value (Table (K).Hi)); 2415 2416 -- Nothing to do if duplicate range is null 2417 2418 if Lo_Dup > Hi_Dup then 2419 null; 2420 2421 -- Otherwise place proper message 2422 2423 else 2424 -- We place message on later choice, with a 2425 -- line reference to the earlier choice. 2426 2427 if Sloc (Table (J).Choice) < 2428 Sloc (Table (K).Choice) 2429 then 2430 Choice := Table (K).Choice; 2431 Error_Msg_Sloc := Sloc (Table (J).Choice); 2432 else 2433 Choice := Table (J).Choice; 2434 Error_Msg_Sloc := Sloc (Table (K).Choice); 2435 end if; 2436 2437 if Lo_Dup = Hi_Dup then 2438 Error_Msg_N 2439 ("index value in array aggregate " 2440 & "duplicates the one given#!", Choice); 2441 else 2442 Error_Msg_N 2443 ("index values in array aggregate " 2444 & "duplicate those given#!", Choice); 2445 end if; 2446 2447 Output_Bad_Choices (Lo_Dup, Hi_Dup, Choice); 2448 end if; 2449 end loop; 2450 end if; 2451 end loop; 2452 2453 -- Loop through entries in table to find missing indexes. 2454 -- Not needed if others, since missing impossible. 2455 2456 if not Others_Present then 2457 for J in 2 .. Nb_Discrete_Choices loop 2458 Lo_Val := Expr_Value (Table (J).Lo); 2459 Hi_Val := Table (J - 1).Highest; 2460 2461 if Lo_Val > Hi_Val + 1 then 2462 2463 declare 2464 Error_Node : Node_Id; 2465 2466 begin 2467 -- If the choice is the bound of a range in 2468 -- a subtype indication, it is not in the 2469 -- source lists for the aggregate itself, so 2470 -- post the error on the aggregate. Otherwise 2471 -- post it on choice itself. 2472 2473 Choice := Table (J).Choice; 2474 2475 if Is_List_Member (Choice) then 2476 Error_Node := Choice; 2477 else 2478 Error_Node := N; 2479 end if; 2480 2481 if Hi_Val + 1 = Lo_Val - 1 then 2482 Error_Msg_N 2483 ("missing index value " 2484 & "in array aggregate!", Error_Node); 2485 else 2486 Error_Msg_N 2487 ("missing index values " 2488 & "in array aggregate!", Error_Node); 2489 end if; 2490 2491 Output_Bad_Choices 2492 (Hi_Val + 1, Lo_Val - 1, Error_Node); 2493 end; 2494 end if; 2495 end loop; 2496 end if; 2497 2498 -- If either missing or duplicate values, return failure 2499 2500 Set_Etype (N, Any_Composite); 2501 return Failure; 2502 end if; 2503 end Check_Choices; 2504 end if; 2505 2506 if Has_Iterator_Specifications then 2507 -- Bounds will be determined dynamically. 2508 2509 return Success; 2510 end if; 2511 2512 -- STEP 2 (B): Compute aggregate bounds and min/max choices values 2513 2514 if Nb_Discrete_Choices > 0 then 2515 Choices_Low := Table (1).Lo; 2516 Choices_High := Table (Nb_Discrete_Choices).Hi; 2517 end if; 2518 2519 -- If Others is present, then bounds of aggregate come from the 2520 -- index constraint (not the choices in the aggregate itself). 2521 2522 if Others_Present then 2523 Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High); 2524 2525 -- Abandon processing if either bound is already signalled as 2526 -- an error (prevents junk cascaded messages and blow ups). 2527 2528 if Nkind (Aggr_Low) = N_Error 2529 or else 2530 Nkind (Aggr_High) = N_Error 2531 then 2532 return False; 2533 end if; 2534 2535 -- No others clause present 2536 2537 else 2538 -- Special processing if others allowed and not present. This 2539 -- means that the bounds of the aggregate come from the index 2540 -- constraint (and the length must match). 2541 2542 if Others_Allowed then 2543 Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High); 2544 2545 -- Abandon processing if either bound is already signalled 2546 -- as an error (stop junk cascaded messages and blow ups). 2547 2548 if Nkind (Aggr_Low) = N_Error 2549 or else 2550 Nkind (Aggr_High) = N_Error 2551 then 2552 return False; 2553 end if; 2554 2555 -- If others allowed, and no others present, then the array 2556 -- should cover all index values. If it does not, we will 2557 -- get a length check warning, but there is two cases where 2558 -- an additional warning is useful: 2559 2560 -- If we have no positional components, and the length is 2561 -- wrong (which we can tell by others being allowed with 2562 -- missing components), and the index type is an enumeration 2563 -- type, then issue appropriate warnings about these missing 2564 -- components. They are only warnings, since the aggregate 2565 -- is fine, it's just the wrong length. We skip this check 2566 -- for standard character types (since there are no literals 2567 -- and it is too much trouble to concoct them), and also if 2568 -- any of the bounds have values that are not known at 2569 -- compile time. 2570 2571 -- Another case warranting a warning is when the length 2572 -- is right, but as above we have an index type that is 2573 -- an enumeration, and the bounds do not match. This is a 2574 -- case where dubious sliding is allowed and we generate a 2575 -- warning that the bounds do not match. 2576 2577 if No (Expressions (N)) 2578 and then Nkind (Index) = N_Range 2579 and then Is_Enumeration_Type (Etype (Index)) 2580 and then not Is_Standard_Character_Type (Etype (Index)) 2581 and then Compile_Time_Known_Value (Aggr_Low) 2582 and then Compile_Time_Known_Value (Aggr_High) 2583 and then Compile_Time_Known_Value (Choices_Low) 2584 and then Compile_Time_Known_Value (Choices_High) 2585 then 2586 -- If any of the expressions or range bounds in choices 2587 -- have semantic errors, then do not attempt further 2588 -- resolution, to prevent cascaded errors. 2589 2590 if Errors_Posted_On_Choices then 2591 return Failure; 2592 end if; 2593 2594 declare 2595 ALo : constant Node_Id := Expr_Value_E (Aggr_Low); 2596 AHi : constant Node_Id := Expr_Value_E (Aggr_High); 2597 CLo : constant Node_Id := Expr_Value_E (Choices_Low); 2598 CHi : constant Node_Id := Expr_Value_E (Choices_High); 2599 2600 Ent : Entity_Id; 2601 2602 begin 2603 -- Warning case 1, missing values at start/end. Only 2604 -- do the check if the number of entries is too small. 2605 2606 if (Enumeration_Pos (CHi) - Enumeration_Pos (CLo)) 2607 < 2608 (Enumeration_Pos (AHi) - Enumeration_Pos (ALo)) 2609 then 2610 Error_Msg_N 2611 ("missing index value(s) in array aggregate??", 2612 N); 2613 2614 -- Output missing value(s) at start 2615 2616 if Chars (ALo) /= Chars (CLo) then 2617 Ent := Prev (CLo); 2618 2619 if Chars (ALo) = Chars (Ent) then 2620 Error_Msg_Name_1 := Chars (ALo); 2621 Error_Msg_N ("\ %??", N); 2622 else 2623 Error_Msg_Name_1 := Chars (ALo); 2624 Error_Msg_Name_2 := Chars (Ent); 2625 Error_Msg_N ("\ % .. %??", N); 2626 end if; 2627 end if; 2628 2629 -- Output missing value(s) at end 2630 2631 if Chars (AHi) /= Chars (CHi) then 2632 Ent := Next (CHi); 2633 2634 if Chars (AHi) = Chars (Ent) then 2635 Error_Msg_Name_1 := Chars (Ent); 2636 Error_Msg_N ("\ %??", N); 2637 else 2638 Error_Msg_Name_1 := Chars (Ent); 2639 Error_Msg_Name_2 := Chars (AHi); 2640 Error_Msg_N ("\ % .. %??", N); 2641 end if; 2642 end if; 2643 2644 -- Warning case 2, dubious sliding. The First_Subtype 2645 -- test distinguishes between a constrained type where 2646 -- sliding is not allowed (so we will get a warning 2647 -- later that Constraint_Error will be raised), and 2648 -- the unconstrained case where sliding is permitted. 2649 2650 elsif (Enumeration_Pos (CHi) - Enumeration_Pos (CLo)) 2651 = 2652 (Enumeration_Pos (AHi) - Enumeration_Pos (ALo)) 2653 and then Chars (ALo) /= Chars (CLo) 2654 and then 2655 not Is_Constrained (First_Subtype (Etype (N))) 2656 then 2657 Error_Msg_N 2658 ("bounds of aggregate do not match target??", N); 2659 end if; 2660 end; 2661 end if; 2662 end if; 2663 2664 -- If no others, aggregate bounds come from aggregate 2665 2666 Aggr_Low := Choices_Low; 2667 Aggr_High := Choices_High; 2668 end if; 2669 end Step_2; 2670 2671 -- STEP 3: Process positional components 2672 2673 else 2674 -- STEP 3 (A): Process positional elements 2675 2676 Expr := First (Expressions (N)); 2677 Nb_Elements := Uint_0; 2678 while Present (Expr) loop 2679 Nb_Elements := Nb_Elements + 1; 2680 2681 -- Ada 2005 (AI-231) 2682 2683 if Ada_Version >= Ada_2005 and then Known_Null (Expr) then 2684 Check_Can_Never_Be_Null (Etype (N), Expr); 2685 end if; 2686 2687 if not Resolve_Aggr_Expr (Expr, Single_Elmt => True) then 2688 return Failure; 2689 end if; 2690 2691 -- Check incorrect use of dynamically tagged expression 2692 2693 if Is_Tagged_Type (Etype (Expr)) then 2694 Check_Dynamically_Tagged_Expression 2695 (Expr => Expr, 2696 Typ => Component_Type (Etype (N)), 2697 Related_Nod => N); 2698 end if; 2699 2700 Next (Expr); 2701 end loop; 2702 2703 if Others_Present then 2704 Assoc := Last (Component_Associations (N)); 2705 2706 -- Ada 2005 (AI-231) 2707 2708 if Ada_Version >= Ada_2005 and then Known_Null (Assoc) then 2709 Check_Can_Never_Be_Null (Etype (N), Expression (Assoc)); 2710 end if; 2711 2712 -- Ada 2005 (AI-287): In case of default initialized component, 2713 -- we delay the resolution to the expansion phase. 2714 2715 if Box_Present (Assoc) then 2716 2717 -- Ada 2005 (AI-287): In case of default initialization of a 2718 -- component the expander will generate calls to the 2719 -- corresponding initialization subprogram. We need to call 2720 -- Resolve_Aggr_Expr to check the rules about 2721 -- dimensionality. 2722 2723 if not Resolve_Aggr_Expr (Assoc, Single_Elmt => False) then 2724 return Failure; 2725 end if; 2726 2727 elsif not Resolve_Aggr_Expr (Expression (Assoc), 2728 Single_Elmt => False) 2729 then 2730 return Failure; 2731 2732 -- Check incorrect use of dynamically tagged expression. The 2733 -- expression of the others choice has not been resolved yet. 2734 -- In order to diagnose the semantic error we create a duplicate 2735 -- tree to analyze it and perform the check. 2736 2737 elsif Nkind (Assoc) /= N_Iterated_Component_Association then 2738 declare 2739 Save_Analysis : constant Boolean := Full_Analysis; 2740 Expr : constant Node_Id := 2741 New_Copy_Tree (Expression (Assoc)); 2742 2743 begin 2744 Expander_Mode_Save_And_Set (False); 2745 Full_Analysis := False; 2746 Analyze (Expr); 2747 Full_Analysis := Save_Analysis; 2748 Expander_Mode_Restore; 2749 2750 if Is_Tagged_Type (Etype (Expr)) then 2751 Check_Dynamically_Tagged_Expression 2752 (Expr => Expr, 2753 Typ => Component_Type (Etype (N)), 2754 Related_Nod => N); 2755 end if; 2756 end; 2757 end if; 2758 end if; 2759 2760 -- STEP 3 (B): Compute the aggregate bounds 2761 2762 if Others_Present then 2763 Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High); 2764 2765 else 2766 if Others_Allowed then 2767 Get_Index_Bounds (Index_Constr, Aggr_Low, Discard); 2768 else 2769 Aggr_Low := Index_Typ_Low; 2770 end if; 2771 2772 Aggr_High := Add (Nb_Elements - 1, To => Aggr_Low); 2773 Check_Bound (Index_Base_High, Aggr_High); 2774 end if; 2775 end if; 2776 2777 -- STEP 4: Perform static aggregate checks and save the bounds 2778 2779 -- Check (A) 2780 2781 Check_Bounds (Index_Typ_Low, Index_Typ_High, Aggr_Low, Aggr_High); 2782 Check_Bounds (Index_Base_Low, Index_Base_High, Aggr_Low, Aggr_High); 2783 2784 -- Check (B) 2785 2786 if Others_Present and then Nb_Discrete_Choices > 0 then 2787 Check_Bounds (Aggr_Low, Aggr_High, Choices_Low, Choices_High); 2788 Check_Bounds (Index_Typ_Low, Index_Typ_High, 2789 Choices_Low, Choices_High); 2790 Check_Bounds (Index_Base_Low, Index_Base_High, 2791 Choices_Low, Choices_High); 2792 2793 -- Check (C) 2794 2795 elsif Others_Present and then Nb_Elements > 0 then 2796 Check_Length (Aggr_Low, Aggr_High, Nb_Elements); 2797 Check_Length (Index_Typ_Low, Index_Typ_High, Nb_Elements); 2798 Check_Length (Index_Base_Low, Index_Base_High, Nb_Elements); 2799 end if; 2800 2801 if Raises_Constraint_Error (Aggr_Low) 2802 or else Raises_Constraint_Error (Aggr_High) 2803 then 2804 Set_Raises_Constraint_Error (N); 2805 end if; 2806 2807 Aggr_Low := Duplicate_Subexpr (Aggr_Low); 2808 2809 -- Do not duplicate Aggr_High if Aggr_High = Aggr_Low + Nb_Elements 2810 -- since the addition node returned by Add is not yet analyzed. Attach 2811 -- to tree and analyze first. Reset analyzed flag to ensure it will get 2812 -- analyzed when it is a literal bound whose type must be properly set. 2813 2814 if Others_Present or else Nb_Discrete_Choices > 0 then 2815 Aggr_High := Duplicate_Subexpr (Aggr_High); 2816 2817 if Etype (Aggr_High) = Universal_Integer then 2818 Set_Analyzed (Aggr_High, False); 2819 end if; 2820 end if; 2821 2822 -- If the aggregate already has bounds attached to it, it means this is 2823 -- a positional aggregate created as an optimization by 2824 -- Exp_Aggr.Convert_To_Positional, so we don't want to change those 2825 -- bounds. 2826 2827 if Present (Aggregate_Bounds (N)) 2828 and then not Others_Allowed 2829 and then not Comes_From_Source (N) 2830 then 2831 Aggr_Low := Low_Bound (Aggregate_Bounds (N)); 2832 Aggr_High := High_Bound (Aggregate_Bounds (N)); 2833 end if; 2834 2835 Set_Aggregate_Bounds 2836 (N, Make_Range (Loc, Low_Bound => Aggr_Low, High_Bound => Aggr_High)); 2837 2838 -- The bounds may contain expressions that must be inserted upwards. 2839 -- Attach them fully to the tree. After analysis, remove side effects 2840 -- from upper bound, if still needed. 2841 2842 Set_Parent (Aggregate_Bounds (N), N); 2843 Analyze_And_Resolve (Aggregate_Bounds (N), Index_Typ); 2844 Check_Unset_Reference (Aggregate_Bounds (N)); 2845 2846 if not Others_Present and then Nb_Discrete_Choices = 0 then 2847 Set_High_Bound 2848 (Aggregate_Bounds (N), 2849 Duplicate_Subexpr (High_Bound (Aggregate_Bounds (N)))); 2850 end if; 2851 2852 -- Check the dimensions of each component in the array aggregate 2853 2854 Analyze_Dimension_Array_Aggregate (N, Component_Typ); 2855 2856 return Success; 2857 end Resolve_Array_Aggregate; 2858 2859 --------------------------------- 2860 -- Resolve_Container_Aggregate -- 2861 --------------------------------- 2862 2863 procedure Resolve_Container_Aggregate (N : Node_Id; Typ : Entity_Id) is 2864 procedure Resolve_Iterated_Association 2865 (Comp : Node_Id; 2866 Key_Type : Entity_Id; 2867 Elmt_Type : Entity_Id); 2868 -- Resolve choices and expression in an iterated component association 2869 -- or an iterated element association, which has a key_expression. 2870 -- This is similar but not identical to the handling of this construct 2871 -- in an array aggregate. 2872 -- For a named container, the type of each choice must be compatible 2873 -- with the key type. For a positional container, the choice must be 2874 -- a subtype indication or an iterator specification that determines 2875 -- an element type. 2876 2877 Asp : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Aggregate); 2878 2879 Empty_Subp : Node_Id := Empty; 2880 Add_Named_Subp : Node_Id := Empty; 2881 Add_Unnamed_Subp : Node_Id := Empty; 2882 New_Indexed_Subp : Node_Id := Empty; 2883 Assign_Indexed_Subp : Node_Id := Empty; 2884 2885 ---------------------------------- 2886 -- Resolve_Iterated_Association -- 2887 ---------------------------------- 2888 2889 procedure Resolve_Iterated_Association 2890 (Comp : Node_Id; 2891 Key_Type : Entity_Id; 2892 Elmt_Type : Entity_Id) 2893 is 2894 Loc : constant Source_Ptr := Sloc (N); 2895 Choice : Node_Id; 2896 Ent : Entity_Id; 2897 Expr : Node_Id; 2898 Key_Expr : Node_Id; 2899 Id : Entity_Id; 2900 Id_Name : Name_Id; 2901 Iter : Node_Id; 2902 Typ : Entity_Id := Empty; 2903 2904 begin 2905 Error_Msg_Ada_2022_Feature ("iterated component", Loc); 2906 2907 -- If this is an Iterated_Element_Association then either a 2908 -- an Iterator_Specification or a Loop_Parameter specification 2909 -- is present. In both cases a Key_Expression is present. 2910 2911 if Nkind (Comp) = N_Iterated_Element_Association then 2912 if Present (Loop_Parameter_Specification (Comp)) then 2913 Analyze_Loop_Parameter_Specification 2914 (Loop_Parameter_Specification (Comp)); 2915 Id_Name := Chars (Defining_Identifier 2916 (Loop_Parameter_Specification (Comp))); 2917 else 2918 Iter := Copy_Separate_Tree (Iterator_Specification (Comp)); 2919 Analyze (Iter); 2920 Typ := Etype (Defining_Identifier (Iter)); 2921 Id_Name := Chars (Defining_Identifier 2922 (Iterator_Specification (Comp))); 2923 end if; 2924 2925 -- Key expression must have the type of the key. We analyze 2926 -- a copy of the original expression, because it will be 2927 -- reanalyzed and copied as needed during expansion of the 2928 -- corresponding loop. 2929 2930 Key_Expr := Key_Expression (Comp); 2931 Analyze_And_Resolve (New_Copy_Tree (Key_Expr), Key_Type); 2932 2933 elsif Present (Iterator_Specification (Comp)) then 2934 Iter := Copy_Separate_Tree (Iterator_Specification (Comp)); 2935 Id_Name := Chars (Defining_Identifier (Comp)); 2936 Analyze (Iter); 2937 Typ := Etype (Defining_Identifier (Iter)); 2938 2939 else 2940 Choice := First (Discrete_Choices (Comp)); 2941 2942 while Present (Choice) loop 2943 Analyze (Choice); 2944 2945 -- Choice can be a subtype name, a range, or an expression 2946 2947 if Is_Entity_Name (Choice) 2948 and then Is_Type (Entity (Choice)) 2949 and then Base_Type (Entity (Choice)) = Base_Type (Key_Type) 2950 then 2951 null; 2952 2953 elsif Present (Key_Type) then 2954 Analyze_And_Resolve (Choice, Key_Type); 2955 2956 else 2957 Typ := Etype (Choice); -- assume unique for now 2958 end if; 2959 2960 Next (Choice); 2961 end loop; 2962 2963 Id_Name := Chars (Defining_Identifier (Comp)); 2964 end if; 2965 2966 -- Create a scope in which to introduce an index, which is usually 2967 -- visible in the expression for the component, and needed for its 2968 -- analysis. 2969 2970 Id := Make_Defining_Identifier (Sloc (Comp), Id_Name); 2971 Ent := New_Internal_Entity (E_Loop, Current_Scope, Sloc (Comp), 'L'); 2972 Set_Etype (Ent, Standard_Void_Type); 2973 Set_Parent (Ent, Parent (Comp)); 2974 Push_Scope (Ent); 2975 2976 -- Insert and decorate the loop variable in the current scope. 2977 -- The expression has to be analyzed once the loop variable is 2978 -- directly visible. Mark the variable as referenced to prevent 2979 -- spurious warnings, given that subsequent uses of its name in the 2980 -- expression will reference the internal (synonym) loop variable. 2981 2982 Enter_Name (Id); 2983 2984 if No (Key_Type) then 2985 pragma Assert (Present (Typ)); 2986 Set_Etype (Id, Typ); 2987 else 2988 Set_Etype (Id, Key_Type); 2989 end if; 2990 2991 Mutate_Ekind (Id, E_Variable); 2992 Set_Scope (Id, Ent); 2993 Set_Referenced (Id); 2994 2995 -- Analyze a copy of the expression, to verify legality. We use 2996 -- a copy because the expression will be analyzed anew when the 2997 -- enclosing aggregate is expanded, and the construct is rewritten 2998 -- as a loop with a new index variable. 2999 3000 Expr := New_Copy_Tree (Expression (Comp)); 3001 Preanalyze_And_Resolve (Expr, Elmt_Type); 3002 End_Scope; 3003 3004 end Resolve_Iterated_Association; 3005 3006 begin 3007 pragma Assert (Nkind (Asp) = N_Aggregate); 3008 3009 Set_Etype (N, Typ); 3010 Parse_Aspect_Aggregate (Asp, 3011 Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp, 3012 New_Indexed_Subp, Assign_Indexed_Subp); 3013 3014 if Present (Add_Unnamed_Subp) 3015 and then No (New_Indexed_Subp) 3016 then 3017 declare 3018 Elmt_Type : constant Entity_Id := 3019 Etype (Next_Formal 3020 (First_Formal (Entity (Add_Unnamed_Subp)))); 3021 Comp : Node_Id; 3022 3023 begin 3024 if Present (Expressions (N)) then 3025 -- positional aggregate 3026 3027 Comp := First (Expressions (N)); 3028 while Present (Comp) loop 3029 Analyze_And_Resolve (Comp, Elmt_Type); 3030 Next (Comp); 3031 end loop; 3032 end if; 3033 3034 -- Empty aggregate, to be replaced by Empty during 3035 -- expansion, or iterated component association. 3036 3037 if Present (Component_Associations (N)) then 3038 declare 3039 Comp : Node_Id := First (Component_Associations (N)); 3040 begin 3041 while Present (Comp) loop 3042 if Nkind (Comp) /= 3043 N_Iterated_Component_Association 3044 then 3045 Error_Msg_N ("illegal component association " 3046 & "for unnamed container aggregate", Comp); 3047 return; 3048 else 3049 Resolve_Iterated_Association 3050 (Comp, Empty, Elmt_Type); 3051 end if; 3052 3053 Next (Comp); 3054 end loop; 3055 end; 3056 end if; 3057 end; 3058 3059 elsif Present (Add_Named_Subp) then 3060 declare 3061 -- Retrieves types of container, key, and element from the 3062 -- specified insertion procedure. 3063 3064 Container : constant Entity_Id := 3065 First_Formal (Entity (Add_Named_Subp)); 3066 Key_Type : constant Entity_Id := Etype (Next_Formal (Container)); 3067 Elmt_Type : constant Entity_Id := 3068 Etype (Next_Formal (Next_Formal (Container))); 3069 Comp : Node_Id; 3070 Choice : Node_Id; 3071 3072 begin 3073 Comp := First (Component_Associations (N)); 3074 while Present (Comp) loop 3075 if Nkind (Comp) = N_Component_Association then 3076 Choice := First (Choices (Comp)); 3077 3078 while Present (Choice) loop 3079 Analyze_And_Resolve (Choice, Key_Type); 3080 if not Is_Static_Expression (Choice) then 3081 Error_Msg_N ("choice must be static", Choice); 3082 end if; 3083 3084 Next (Choice); 3085 end loop; 3086 3087 Analyze_And_Resolve (Expression (Comp), Elmt_Type); 3088 3089 elsif Nkind (Comp) in 3090 N_Iterated_Component_Association | 3091 N_Iterated_Element_Association 3092 then 3093 Resolve_Iterated_Association 3094 (Comp, Key_Type, Elmt_Type); 3095 end if; 3096 3097 Next (Comp); 3098 end loop; 3099 end; 3100 3101 else 3102 -- Indexed Aggregate. Positional or indexed component 3103 -- can be present, but not both. Choices must be static 3104 -- values or ranges with static bounds. 3105 3106 declare 3107 Container : constant Entity_Id := 3108 First_Formal (Entity (Assign_Indexed_Subp)); 3109 Index_Type : constant Entity_Id := Etype (Next_Formal (Container)); 3110 Comp_Type : constant Entity_Id := 3111 Etype (Next_Formal (Next_Formal (Container))); 3112 Comp : Node_Id; 3113 Choice : Node_Id; 3114 Num_Choices : Nat := 0; 3115 3116 Hi_Val : Uint; 3117 Lo_Val : Uint; 3118 begin 3119 if Present (Expressions (N)) then 3120 Comp := First (Expressions (N)); 3121 while Present (Comp) loop 3122 Analyze_And_Resolve (Comp, Comp_Type); 3123 Next (Comp); 3124 end loop; 3125 end if; 3126 3127 if Present (Component_Associations (N)) then 3128 if Present (Expressions (N)) then 3129 Error_Msg_N ("container aggregate cannot be " 3130 & "both positional and named", N); 3131 return; 3132 end if; 3133 3134 Comp := First (Component_Associations (N)); 3135 3136 while Present (Comp) loop 3137 if Nkind (Comp) = N_Component_Association then 3138 Choice := First (Choices (Comp)); 3139 3140 while Present (Choice) loop 3141 Analyze_And_Resolve (Choice, Index_Type); 3142 Num_Choices := Num_Choices + 1; 3143 Next (Choice); 3144 end loop; 3145 3146 Analyze_And_Resolve (Expression (Comp), Comp_Type); 3147 3148 elsif Nkind (Comp) in 3149 N_Iterated_Component_Association | 3150 N_Iterated_Element_Association 3151 then 3152 Resolve_Iterated_Association 3153 (Comp, Index_Type, Comp_Type); 3154 Num_Choices := Num_Choices + 1; 3155 end if; 3156 3157 Next (Comp); 3158 end loop; 3159 3160 -- The component associations in an indexed aggregate 3161 -- must denote a contiguous set of static values. We 3162 -- build a table of values/ranges and sort it, as is done 3163 -- elsewhere for case statements and array aggregates. 3164 -- If the aggregate has a single iterated association it 3165 -- is allowed to be nonstatic and there is nothing to check. 3166 3167 if Num_Choices > 1 then 3168 declare 3169 Table : Case_Table_Type (1 .. Num_Choices); 3170 No_Choice : Pos := 1; 3171 Lo, Hi : Node_Id; 3172 3173 -- Traverse aggregate to determine size of needed table. 3174 -- Verify that bounds are static and that loops have no 3175 -- filters or key expressions. 3176 3177 begin 3178 Comp := First (Component_Associations (N)); 3179 while Present (Comp) loop 3180 if Nkind (Comp) = N_Iterated_Element_Association then 3181 if Present 3182 (Loop_Parameter_Specification (Comp)) 3183 then 3184 if Present (Iterator_Filter 3185 (Loop_Parameter_Specification (Comp))) 3186 then 3187 Error_Msg_N 3188 ("iterator filter not allowed " & 3189 "in indexed aggregate", Comp); 3190 return; 3191 3192 elsif Present (Key_Expression 3193 (Loop_Parameter_Specification (Comp))) 3194 then 3195 Error_Msg_N 3196 ("key expression not allowed " & 3197 "in indexed aggregate", Comp); 3198 return; 3199 end if; 3200 end if; 3201 else 3202 Choice := First (Choices (Comp)); 3203 3204 while Present (Choice) loop 3205 Get_Index_Bounds (Choice, Lo, Hi); 3206 Table (No_Choice).Choice := Choice; 3207 Table (No_Choice).Lo := Lo; 3208 Table (No_Choice).Hi := Hi; 3209 3210 -- Verify staticness of value or range 3211 3212 if not Is_Static_Expression (Lo) 3213 or else not Is_Static_Expression (Hi) 3214 then 3215 Error_Msg_N 3216 ("nonstatic expression for index " & 3217 "for indexed aggregate", Choice); 3218 return; 3219 end if; 3220 3221 No_Choice := No_Choice + 1; 3222 Next (Choice); 3223 end loop; 3224 end if; 3225 3226 Next (Comp); 3227 end loop; 3228 3229 Sort_Case_Table (Table); 3230 3231 for J in 1 .. Num_Choices - 1 loop 3232 Hi_Val := Expr_Value (Table (J).Hi); 3233 Lo_Val := Expr_Value (Table (J + 1).Lo); 3234 3235 if Lo_Val = Hi_Val then 3236 Error_Msg_N 3237 ("duplicate index in indexed aggregate", 3238 Table (J + 1).Choice); 3239 exit; 3240 3241 elsif Lo_Val < Hi_Val then 3242 Error_Msg_N 3243 ("overlapping indices in indexed aggregate", 3244 Table (J + 1).Choice); 3245 exit; 3246 3247 elsif Lo_Val > Hi_Val + 1 then 3248 Error_Msg_N 3249 ("missing index values", Table (J + 1).Choice); 3250 exit; 3251 end if; 3252 end loop; 3253 end; 3254 end if; 3255 end if; 3256 end; 3257 end if; 3258 end Resolve_Container_Aggregate; 3259 3260 ----------------------------- 3261 -- Resolve_Delta_Aggregate -- 3262 ----------------------------- 3263 3264 procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is 3265 Base : constant Node_Id := Expression (N); 3266 3267 begin 3268 Error_Msg_Ada_2022_Feature ("delta aggregate", Sloc (N)); 3269 3270 if not Is_Composite_Type (Typ) then 3271 Error_Msg_N ("not a composite type", N); 3272 end if; 3273 3274 Analyze_And_Resolve (Base, Typ); 3275 3276 if Is_Array_Type (Typ) then 3277 Resolve_Delta_Array_Aggregate (N, Typ); 3278 else 3279 Resolve_Delta_Record_Aggregate (N, Typ); 3280 end if; 3281 3282 Set_Etype (N, Typ); 3283 end Resolve_Delta_Aggregate; 3284 3285 ----------------------------------- 3286 -- Resolve_Delta_Array_Aggregate -- 3287 ----------------------------------- 3288 3289 procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id) is 3290 Deltas : constant List_Id := Component_Associations (N); 3291 Index_Type : constant Entity_Id := Etype (First_Index (Typ)); 3292 3293 Assoc : Node_Id; 3294 Choice : Node_Id; 3295 Expr : Node_Id; 3296 3297 begin 3298 Assoc := First (Deltas); 3299 while Present (Assoc) loop 3300 if Nkind (Assoc) = N_Iterated_Component_Association then 3301 Choice := First (Choice_List (Assoc)); 3302 while Present (Choice) loop 3303 if Nkind (Choice) = N_Others_Choice then 3304 Error_Msg_N 3305 ("OTHERS not allowed in delta aggregate", Choice); 3306 3307 elsif Nkind (Choice) = N_Subtype_Indication then 3308 Resolve_Discrete_Subtype_Indication 3309 (Choice, Base_Type (Index_Type)); 3310 3311 else 3312 Analyze_And_Resolve (Choice, Index_Type); 3313 end if; 3314 3315 Next (Choice); 3316 end loop; 3317 3318 declare 3319 Id : constant Entity_Id := Defining_Identifier (Assoc); 3320 Ent : constant Entity_Id := 3321 New_Internal_Entity 3322 (E_Loop, Current_Scope, Sloc (Assoc), 'L'); 3323 3324 begin 3325 Set_Etype (Ent, Standard_Void_Type); 3326 Set_Parent (Ent, Assoc); 3327 Push_Scope (Ent); 3328 3329 if No (Scope (Id)) then 3330 Set_Etype (Id, Index_Type); 3331 Mutate_Ekind (Id, E_Variable); 3332 Set_Scope (Id, Ent); 3333 end if; 3334 Enter_Name (Id); 3335 3336 -- Resolve a copy of the expression, after setting 3337 -- its parent properly to preserve its context. 3338 3339 Expr := New_Copy_Tree (Expression (Assoc)); 3340 Set_Parent (Expr, Assoc); 3341 Analyze_And_Resolve (Expr, Component_Type (Typ)); 3342 End_Scope; 3343 end; 3344 3345 else 3346 Choice := First (Choice_List (Assoc)); 3347 while Present (Choice) loop 3348 Analyze (Choice); 3349 3350 if Nkind (Choice) = N_Others_Choice then 3351 Error_Msg_N 3352 ("OTHERS not allowed in delta aggregate", Choice); 3353 3354 elsif Is_Entity_Name (Choice) 3355 and then Is_Type (Entity (Choice)) 3356 then 3357 -- Choice covers a range of values 3358 3359 if Base_Type (Entity (Choice)) /= 3360 Base_Type (Index_Type) 3361 then 3362 Error_Msg_NE 3363 ("choice does not match index type of &", 3364 Choice, Typ); 3365 end if; 3366 3367 elsif Nkind (Choice) = N_Subtype_Indication then 3368 Resolve_Discrete_Subtype_Indication 3369 (Choice, Base_Type (Index_Type)); 3370 3371 else 3372 Resolve (Choice, Index_Type); 3373 end if; 3374 3375 Next (Choice); 3376 end loop; 3377 3378 Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ)); 3379 end if; 3380 3381 Next (Assoc); 3382 end loop; 3383 end Resolve_Delta_Array_Aggregate; 3384 3385 ------------------------------------ 3386 -- Resolve_Delta_Record_Aggregate -- 3387 ------------------------------------ 3388 3389 procedure Resolve_Delta_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is 3390 3391 -- Variables used to verify that discriminant-dependent components 3392 -- appear in the same variant. 3393 3394 Comp_Ref : Entity_Id := Empty; -- init to avoid warning 3395 Variant : Node_Id; 3396 3397 procedure Check_Variant (Id : Entity_Id); 3398 -- If a given component of the delta aggregate appears in a variant 3399 -- part, verify that it is within the same variant as that of previous 3400 -- specified variant components of the delta. 3401 3402 function Get_Component (Nam : Node_Id) return Entity_Id; 3403 -- Locate component with a given name and return it. If none found then 3404 -- report error and return Empty. 3405 3406 function Nested_In (V1 : Node_Id; V2 : Node_Id) return Boolean; 3407 -- Determine whether variant V1 is within variant V2 3408 3409 function Variant_Depth (N : Node_Id) return Natural; 3410 -- Determine the distance of a variant to the enclosing type declaration 3411 3412 -------------------- 3413 -- Check_Variant -- 3414 -------------------- 3415 3416 procedure Check_Variant (Id : Entity_Id) is 3417 Comp : Entity_Id; 3418 Comp_Variant : Node_Id; 3419 3420 begin 3421 if not Has_Discriminants (Typ) then 3422 return; 3423 end if; 3424 3425 Comp := First_Entity (Typ); 3426 while Present (Comp) loop 3427 exit when Chars (Comp) = Chars (Id); 3428 Next_Component (Comp); 3429 end loop; 3430 3431 -- Find the variant, if any, whose component list includes the 3432 -- component declaration. 3433 3434 Comp_Variant := Parent (Parent (List_Containing (Parent (Comp)))); 3435 if Nkind (Comp_Variant) = N_Variant then 3436 if No (Variant) then 3437 Variant := Comp_Variant; 3438 Comp_Ref := Comp; 3439 3440 elsif Variant /= Comp_Variant then 3441 declare 3442 D1 : constant Integer := Variant_Depth (Variant); 3443 D2 : constant Integer := Variant_Depth (Comp_Variant); 3444 3445 begin 3446 if D1 = D2 3447 or else 3448 (D1 > D2 and then not Nested_In (Variant, Comp_Variant)) 3449 or else 3450 (D2 > D1 and then not Nested_In (Comp_Variant, Variant)) 3451 then 3452 pragma Assert (Present (Comp_Ref)); 3453 Error_Msg_Node_2 := Comp_Ref; 3454 Error_Msg_NE 3455 ("& and & appear in different variants", Id, Comp); 3456 3457 -- Otherwise retain the deeper variant for subsequent tests 3458 3459 elsif D2 > D1 then 3460 Variant := Comp_Variant; 3461 end if; 3462 end; 3463 end if; 3464 end if; 3465 end Check_Variant; 3466 3467 ------------------- 3468 -- Get_Component -- 3469 ------------------- 3470 3471 function Get_Component (Nam : Node_Id) return Entity_Id is 3472 Comp : Entity_Id; 3473 3474 begin 3475 Comp := First_Entity (Typ); 3476 while Present (Comp) loop 3477 if Chars (Comp) = Chars (Nam) then 3478 if Ekind (Comp) = E_Discriminant then 3479 Error_Msg_N ("delta cannot apply to discriminant", Nam); 3480 end if; 3481 3482 return Comp; 3483 end if; 3484 3485 Next_Entity (Comp); 3486 end loop; 3487 3488 Error_Msg_NE ("type& has no component with this name", Nam, Typ); 3489 return Empty; 3490 end Get_Component; 3491 3492 --------------- 3493 -- Nested_In -- 3494 --------------- 3495 3496 function Nested_In (V1, V2 : Node_Id) return Boolean is 3497 Par : Node_Id; 3498 3499 begin 3500 Par := Parent (V1); 3501 while Nkind (Par) /= N_Full_Type_Declaration loop 3502 if Par = V2 then 3503 return True; 3504 end if; 3505 3506 Par := Parent (Par); 3507 end loop; 3508 3509 return False; 3510 end Nested_In; 3511 3512 ------------------- 3513 -- Variant_Depth -- 3514 ------------------- 3515 3516 function Variant_Depth (N : Node_Id) return Natural is 3517 Depth : Natural; 3518 Par : Node_Id; 3519 3520 begin 3521 Depth := 0; 3522 Par := Parent (N); 3523 while Nkind (Par) /= N_Full_Type_Declaration loop 3524 Depth := Depth + 1; 3525 Par := Parent (Par); 3526 end loop; 3527 3528 return Depth; 3529 end Variant_Depth; 3530 3531 -- Local variables 3532 3533 Deltas : constant List_Id := Component_Associations (N); 3534 3535 Assoc : Node_Id; 3536 Choice : Node_Id; 3537 Comp : Entity_Id; 3538 Comp_Type : Entity_Id := Empty; -- init to avoid warning 3539 3540 -- Start of processing for Resolve_Delta_Record_Aggregate 3541 3542 begin 3543 Variant := Empty; 3544 3545 Assoc := First (Deltas); 3546 while Present (Assoc) loop 3547 Choice := First (Choice_List (Assoc)); 3548 while Present (Choice) loop 3549 Comp := Get_Component (Choice); 3550 3551 if Present (Comp) then 3552 Check_Variant (Choice); 3553 3554 Comp_Type := Etype (Comp); 3555 3556 -- Decorate the component reference by setting its entity and 3557 -- type, as otherwise backends like GNATprove would have to 3558 -- rediscover this information by themselves. 3559 3560 Set_Entity (Choice, Comp); 3561 Set_Etype (Choice, Comp_Type); 3562 else 3563 Comp_Type := Any_Type; 3564 end if; 3565 3566 Next (Choice); 3567 end loop; 3568 3569 pragma Assert (Present (Comp_Type)); 3570 3571 -- A record_component_association in record_delta_aggregate shall not 3572 -- use the box compound delimiter <> rather than an expression; see 3573 -- RM 4.3.1(17.3/5). 3574 3575 pragma Assert (Present (Expression (Assoc)) xor Box_Present (Assoc)); 3576 3577 if Box_Present (Assoc) then 3578 Error_Msg_N 3579 ("'<'> in record delta aggregate is not allowed", Assoc); 3580 else 3581 Analyze_And_Resolve (Expression (Assoc), Comp_Type); 3582 end if; 3583 Next (Assoc); 3584 end loop; 3585 end Resolve_Delta_Record_Aggregate; 3586 3587 --------------------------------- 3588 -- Resolve_Extension_Aggregate -- 3589 --------------------------------- 3590 3591 -- There are two cases to consider: 3592 3593 -- a) If the ancestor part is a type mark, the components needed are the 3594 -- difference between the components of the expected type and the 3595 -- components of the given type mark. 3596 3597 -- b) If the ancestor part is an expression, it must be unambiguous, and 3598 -- once we have its type we can also compute the needed components as in 3599 -- the previous case. In both cases, if the ancestor type is not the 3600 -- immediate ancestor, we have to build this ancestor recursively. 3601 3602 -- In both cases, discriminants of the ancestor type do not play a role in 3603 -- the resolution of the needed components, because inherited discriminants 3604 -- cannot be used in a type extension. As a result we can compute 3605 -- independently the list of components of the ancestor type and of the 3606 -- expected type. 3607 3608 procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id) is 3609 A : constant Node_Id := Ancestor_Part (N); 3610 A_Type : Entity_Id; 3611 I : Interp_Index; 3612 It : Interp; 3613 3614 function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean; 3615 -- If the type is limited, verify that the ancestor part is a legal 3616 -- expression (aggregate or function call, including 'Input)) that does 3617 -- not require a copy, as specified in 7.5(2). 3618 3619 function Valid_Ancestor_Type return Boolean; 3620 -- Verify that the type of the ancestor part is a non-private ancestor 3621 -- of the expected type, which must be a type extension. 3622 3623 procedure Transform_BIP_Assignment (Typ : Entity_Id); 3624 -- For an extension aggregate whose ancestor part is a build-in-place 3625 -- call returning a nonlimited type, this is used to transform the 3626 -- assignment to the ancestor part to use a temp. 3627 3628 ---------------------------- 3629 -- Valid_Limited_Ancestor -- 3630 ---------------------------- 3631 3632 function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean is 3633 begin 3634 if Is_Entity_Name (Anc) and then Is_Type (Entity (Anc)) then 3635 return True; 3636 3637 -- The ancestor must be a call or an aggregate, but a call may 3638 -- have been expanded into a temporary, so check original node. 3639 3640 elsif Nkind (Anc) in N_Aggregate 3641 | N_Extension_Aggregate 3642 | N_Function_Call 3643 then 3644 return True; 3645 3646 elsif Nkind (Original_Node (Anc)) = N_Function_Call then 3647 return True; 3648 3649 elsif Nkind (Anc) = N_Attribute_Reference 3650 and then Attribute_Name (Anc) = Name_Input 3651 then 3652 return True; 3653 3654 elsif Nkind (Anc) = N_Qualified_Expression then 3655 return Valid_Limited_Ancestor (Expression (Anc)); 3656 3657 elsif Nkind (Anc) = N_Raise_Expression then 3658 return True; 3659 3660 else 3661 return False; 3662 end if; 3663 end Valid_Limited_Ancestor; 3664 3665 ------------------------- 3666 -- Valid_Ancestor_Type -- 3667 ------------------------- 3668 3669 function Valid_Ancestor_Type return Boolean is 3670 Imm_Type : Entity_Id; 3671 3672 begin 3673 Imm_Type := Base_Type (Typ); 3674 while Is_Derived_Type (Imm_Type) loop 3675 if Etype (Imm_Type) = Base_Type (A_Type) then 3676 return True; 3677 3678 -- The base type of the parent type may appear as a private 3679 -- extension if it is declared as such in a parent unit of the 3680 -- current one. For consistency of the subsequent analysis use 3681 -- the partial view for the ancestor part. 3682 3683 elsif Is_Private_Type (Etype (Imm_Type)) 3684 and then Present (Full_View (Etype (Imm_Type))) 3685 and then Base_Type (A_Type) = Full_View (Etype (Imm_Type)) 3686 then 3687 A_Type := Etype (Imm_Type); 3688 return True; 3689 3690 -- The parent type may be a private extension. The aggregate is 3691 -- legal if the type of the aggregate is an extension of it that 3692 -- is not a private extension. 3693 3694 elsif Is_Private_Type (A_Type) 3695 and then not Is_Private_Type (Imm_Type) 3696 and then Present (Full_View (A_Type)) 3697 and then Base_Type (Full_View (A_Type)) = Etype (Imm_Type) 3698 then 3699 return True; 3700 3701 -- The parent type may be a raise expression (which is legal in 3702 -- any expression context). 3703 3704 elsif A_Type = Raise_Type then 3705 A_Type := Etype (Imm_Type); 3706 return True; 3707 3708 else 3709 Imm_Type := Etype (Base_Type (Imm_Type)); 3710 end if; 3711 end loop; 3712 3713 -- If previous loop did not find a proper ancestor, report error 3714 3715 Error_Msg_NE ("expect ancestor type of &", A, Typ); 3716 return False; 3717 end Valid_Ancestor_Type; 3718 3719 ------------------------------ 3720 -- Transform_BIP_Assignment -- 3721 ------------------------------ 3722 3723 procedure Transform_BIP_Assignment (Typ : Entity_Id) is 3724 Loc : constant Source_Ptr := Sloc (N); 3725 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', A); 3726 Obj_Decl : constant Node_Id := 3727 Make_Object_Declaration (Loc, 3728 Defining_Identifier => Def_Id, 3729 Constant_Present => True, 3730 Object_Definition => New_Occurrence_Of (Typ, Loc), 3731 Expression => A, 3732 Has_Init_Expression => True); 3733 begin 3734 Set_Etype (Def_Id, Typ); 3735 Set_Ancestor_Part (N, New_Occurrence_Of (Def_Id, Loc)); 3736 Insert_Action (N, Obj_Decl); 3737 end Transform_BIP_Assignment; 3738 3739 -- Start of processing for Resolve_Extension_Aggregate 3740 3741 begin 3742 -- Analyze the ancestor part and account for the case where it is a 3743 -- parameterless function call. 3744 3745 Analyze (A); 3746 Check_Parameterless_Call (A); 3747 3748 if Is_Entity_Name (A) and then Is_Type (Entity (A)) then 3749 3750 -- AI05-0115: If the ancestor part is a subtype mark, the ancestor 3751 -- must not have unknown discriminants. To catch cases where the 3752 -- aggregate occurs at a place where the full view of the ancestor 3753 -- type is visible and doesn't have unknown discriminants, but the 3754 -- aggregate type was derived from a partial view that has unknown 3755 -- discriminants, we check whether the aggregate type has unknown 3756 -- discriminants (unknown discriminants were inherited), along 3757 -- with checking that the partial view of the ancestor has unknown 3758 -- discriminants. (It might be sufficient to replace the entire 3759 -- condition with Has_Unknown_Discriminants (Typ), but that might 3760 -- miss some cases, not clear, and causes error changes in some tests 3761 -- such as class-wide cases, that aren't clearly improvements. ???) 3762 3763 if Has_Unknown_Discriminants (Entity (A)) 3764 or else (Has_Unknown_Discriminants (Typ) 3765 and then Partial_View_Has_Unknown_Discr (Entity (A))) 3766 then 3767 Error_Msg_NE 3768 ("aggregate not available for type& whose ancestor " 3769 & "has unknown discriminants", N, Typ); 3770 end if; 3771 end if; 3772 3773 if not Is_Tagged_Type (Typ) then 3774 Error_Msg_N ("type of extension aggregate must be tagged", N); 3775 return; 3776 3777 elsif Is_Limited_Type (Typ) then 3778 3779 -- Ada 2005 (AI-287): Limited aggregates are allowed 3780 3781 if Ada_Version < Ada_2005 then 3782 Error_Msg_N ("aggregate type cannot be limited", N); 3783 Explain_Limited_Type (Typ, N); 3784 return; 3785 3786 elsif Valid_Limited_Ancestor (A) then 3787 null; 3788 3789 else 3790 Error_Msg_N 3791 ("limited ancestor part must be aggregate or function call", A); 3792 end if; 3793 3794 elsif Is_Class_Wide_Type (Typ) then 3795 Error_Msg_N ("aggregate cannot be of a class-wide type", N); 3796 return; 3797 end if; 3798 3799 if Is_Entity_Name (A) and then Is_Type (Entity (A)) then 3800 A_Type := Get_Full_View (Entity (A)); 3801 3802 if Valid_Ancestor_Type then 3803 Set_Entity (A, A_Type); 3804 Set_Etype (A, A_Type); 3805 3806 Validate_Ancestor_Part (N); 3807 Resolve_Record_Aggregate (N, Typ); 3808 end if; 3809 3810 elsif Nkind (A) /= N_Aggregate then 3811 if Is_Overloaded (A) then 3812 A_Type := Any_Type; 3813 3814 Get_First_Interp (A, I, It); 3815 while Present (It.Typ) loop 3816 3817 -- Consider limited interpretations if Ada 2005 or higher 3818 3819 if Is_Tagged_Type (It.Typ) 3820 and then (Ada_Version >= Ada_2005 3821 or else not Is_Limited_Type (It.Typ)) 3822 then 3823 if A_Type /= Any_Type then 3824 Error_Msg_N ("cannot resolve expression", A); 3825 return; 3826 else 3827 A_Type := It.Typ; 3828 end if; 3829 end if; 3830 3831 Get_Next_Interp (I, It); 3832 end loop; 3833 3834 if A_Type = Any_Type then 3835 if Ada_Version >= Ada_2005 then 3836 Error_Msg_N 3837 ("ancestor part must be of a tagged type", A); 3838 else 3839 Error_Msg_N 3840 ("ancestor part must be of a nonlimited tagged type", A); 3841 end if; 3842 3843 return; 3844 end if; 3845 3846 else 3847 A_Type := Etype (A); 3848 end if; 3849 3850 if Valid_Ancestor_Type then 3851 Resolve (A, A_Type); 3852 Check_Unset_Reference (A); 3853 Check_Non_Static_Context (A); 3854 3855 -- The aggregate is illegal if the ancestor expression is a call 3856 -- to a function with a limited unconstrained result, unless the 3857 -- type of the aggregate is a null extension. This restriction 3858 -- was added in AI05-67 to simplify implementation. 3859 3860 if Nkind (A) = N_Function_Call 3861 and then Is_Limited_Type (A_Type) 3862 and then not Is_Null_Extension (Typ) 3863 and then not Is_Constrained (A_Type) 3864 then 3865 Error_Msg_N 3866 ("type of limited ancestor part must be constrained", A); 3867 3868 -- Reject the use of CPP constructors that leave objects partially 3869 -- initialized. For example: 3870 3871 -- type CPP_Root is tagged limited record ... 3872 -- pragma Import (CPP, CPP_Root); 3873 3874 -- type CPP_DT is new CPP_Root and Iface ... 3875 -- pragma Import (CPP, CPP_DT); 3876 3877 -- type Ada_DT is new CPP_DT with ... 3878 3879 -- Obj : Ada_DT := Ada_DT'(New_CPP_Root with others => <>); 3880 3881 -- Using the constructor of CPP_Root the slots of the dispatch 3882 -- table of CPP_DT cannot be set, and the secondary tag of 3883 -- CPP_DT is unknown. 3884 3885 elsif Nkind (A) = N_Function_Call 3886 and then Is_CPP_Constructor_Call (A) 3887 and then Enclosing_CPP_Parent (Typ) /= A_Type 3888 then 3889 Error_Msg_NE 3890 ("??must use 'C'P'P constructor for type &", A, 3891 Enclosing_CPP_Parent (Typ)); 3892 3893 -- The following call is not needed if the previous warning 3894 -- is promoted to an error. 3895 3896 Resolve_Record_Aggregate (N, Typ); 3897 3898 elsif Is_Class_Wide_Type (Etype (A)) 3899 and then Nkind (Original_Node (A)) = N_Function_Call 3900 then 3901 -- If the ancestor part is a dispatching call, it appears 3902 -- statically to be a legal ancestor, but it yields any member 3903 -- of the class, and it is not possible to determine whether 3904 -- it is an ancestor of the extension aggregate (much less 3905 -- which ancestor). It is not possible to determine the 3906 -- components of the extension part. 3907 3908 -- This check implements AI-306, which in fact was motivated by 3909 -- an AdaCore query to the ARG after this test was added. 3910 3911 Error_Msg_N ("ancestor part must be statically tagged", A); 3912 else 3913 -- We are using the build-in-place protocol, but we can't build 3914 -- in place, because we need to call the function before 3915 -- allocating the aggregate. Could do better for null 3916 -- extensions, and maybe for nondiscriminated types. 3917 -- This is wrong for limited, but those were wrong already. 3918 3919 if not Is_Limited_View (A_Type) 3920 and then Is_Build_In_Place_Function_Call (A) 3921 then 3922 Transform_BIP_Assignment (A_Type); 3923 end if; 3924 3925 Resolve_Record_Aggregate (N, Typ); 3926 end if; 3927 end if; 3928 3929 else 3930 Error_Msg_N ("no unique type for this aggregate", A); 3931 end if; 3932 3933 Check_Function_Writable_Actuals (N); 3934 end Resolve_Extension_Aggregate; 3935 3936 ------------------------------ 3937 -- Resolve_Record_Aggregate -- 3938 ------------------------------ 3939 3940 procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is 3941 New_Assoc_List : constant List_Id := New_List; 3942 -- New_Assoc_List is the newly built list of N_Component_Association 3943 -- nodes. 3944 3945 Others_Etype : Entity_Id := Empty; 3946 -- This variable is used to save the Etype of the last record component 3947 -- that takes its value from the others choice. Its purpose is: 3948 -- 3949 -- (a) make sure the others choice is useful 3950 -- 3951 -- (b) make sure the type of all the components whose value is 3952 -- subsumed by the others choice are the same. 3953 -- 3954 -- This variable is updated as a side effect of function Get_Value. 3955 3956 Box_Node : Node_Id := Empty; 3957 Is_Box_Present : Boolean := False; 3958 Is_Box_Init_By_Default : Boolean := False; 3959 Others_Box : Natural := 0; 3960 -- Ada 2005 (AI-287): Variables used in case of default initialization 3961 -- to provide a functionality similar to Others_Etype. Box_Present 3962 -- indicates that the component takes its default initialization; 3963 -- Others_Box counts the number of components of the current aggregate 3964 -- (which may be a sub-aggregate of a larger one) that are default- 3965 -- initialized. A value of One indicates that an others_box is present. 3966 -- Any larger value indicates that the others_box is not redundant. 3967 -- These variables, similar to Others_Etype, are also updated as a side 3968 -- effect of function Get_Value. Box_Node is used to place a warning on 3969 -- a redundant others_box. 3970 3971 procedure Add_Association 3972 (Component : Entity_Id; 3973 Expr : Node_Id; 3974 Assoc_List : List_Id; 3975 Is_Box_Present : Boolean := False); 3976 -- Builds a new N_Component_Association node which associates Component 3977 -- to expression Expr and adds it to the association list being built, 3978 -- either New_Assoc_List, or the association being built for an inner 3979 -- aggregate. 3980 3981 procedure Add_Discriminant_Values 3982 (New_Aggr : Node_Id; 3983 Assoc_List : List_Id); 3984 -- The constraint to a component may be given by a discriminant of the 3985 -- enclosing type, in which case we have to retrieve its value, which is 3986 -- part of the enclosing aggregate. Assoc_List provides the discriminant 3987 -- associations of the current type or of some enclosing record. 3988 3989 function Discriminant_Present (Input_Discr : Entity_Id) return Boolean; 3990 -- If aggregate N is a regular aggregate this routine will return True. 3991 -- Otherwise, if N is an extension aggregate, then Input_Discr denotes 3992 -- a discriminant whose value may already have been specified by N's 3993 -- ancestor part. This routine checks whether this is indeed the case 3994 -- and if so returns False, signaling that no value for Input_Discr 3995 -- should appear in N's aggregate part. Also, in this case, the routine 3996 -- appends to New_Assoc_List the discriminant value specified in the 3997 -- ancestor part. 3998 -- 3999 -- If the aggregate is in a context with expansion delayed, it will be 4000 -- reanalyzed. The inherited discriminant values must not be reinserted 4001 -- in the component list to prevent spurious errors, but they must be 4002 -- present on first analysis to build the proper subtype indications. 4003 -- The flag Inherited_Discriminant is used to prevent the re-insertion. 4004 4005 function Find_Private_Ancestor (Typ : Entity_Id) return Entity_Id; 4006 -- AI05-0115: Find earlier ancestor in the derivation chain that is 4007 -- derived from private view Typ. Whether the aggregate is legal depends 4008 -- on the current visibility of the type as well as that of the parent 4009 -- of the ancestor. 4010 4011 function Get_Value 4012 (Compon : Entity_Id; 4013 From : List_Id; 4014 Consider_Others_Choice : Boolean := False) return Node_Id; 4015 -- Given a record component stored in parameter Compon, this function 4016 -- returns its value as it appears in the list From, which is a list 4017 -- of N_Component_Association nodes. 4018 -- 4019 -- If no component association has a choice for the searched component, 4020 -- the value provided by the others choice is returned, if there is one, 4021 -- and Consider_Others_Choice is set to true. Otherwise Empty is 4022 -- returned. If there is more than one component association giving a 4023 -- value for the searched record component, an error message is emitted 4024 -- and the first found value is returned. 4025 -- 4026 -- If Consider_Others_Choice is set and the returned expression comes 4027 -- from the others choice, then Others_Etype is set as a side effect. 4028 -- An error message is emitted if the components taking their value from 4029 -- the others choice do not have same type. 4030 4031 procedure Propagate_Discriminants 4032 (Aggr : Node_Id; 4033 Assoc_List : List_Id); 4034 -- Nested components may themselves be discriminated types constrained 4035 -- by outer discriminants, whose values must be captured before the 4036 -- aggregate is expanded into assignments. 4037 4038 procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Entity_Id); 4039 -- Analyzes and resolves expression Expr against the Etype of the 4040 -- Component. This routine also applies all appropriate checks to Expr. 4041 -- It finally saves a Expr in the newly created association list that 4042 -- will be attached to the final record aggregate. Note that if the 4043 -- Parent pointer of Expr is not set then Expr was produced with a 4044 -- New_Copy_Tree or some such. 4045 4046 procedure Rewrite_Range (Root_Type : Entity_Id; Rge : Node_Id); 4047 -- Rewrite a range node Rge when its bounds refer to non-stored 4048 -- discriminants from Root_Type, to replace them with the stored 4049 -- discriminant values. This is required in GNATprove mode, and is 4050 -- adopted in all modes to avoid special-casing GNATprove mode. 4051 4052 --------------------- 4053 -- Add_Association -- 4054 --------------------- 4055 4056 procedure Add_Association 4057 (Component : Entity_Id; 4058 Expr : Node_Id; 4059 Assoc_List : List_Id; 4060 Is_Box_Present : Boolean := False) 4061 is 4062 Choice_List : constant List_Id := New_List; 4063 Loc : Source_Ptr; 4064 4065 begin 4066 -- If this is a box association the expression is missing, so use the 4067 -- Sloc of the aggregate itself for the new association. 4068 4069 pragma Assert (Present (Expr) xor Is_Box_Present); 4070 4071 if Present (Expr) then 4072 Loc := Sloc (Expr); 4073 else 4074 Loc := Sloc (N); 4075 end if; 4076 4077 Append_To (Choice_List, New_Occurrence_Of (Component, Loc)); 4078 4079 Append_To (Assoc_List, 4080 Make_Component_Association (Loc, 4081 Choices => Choice_List, 4082 Expression => Expr, 4083 Box_Present => Is_Box_Present)); 4084 4085 -- If this association has a box for a component that is initialized 4086 -- by default, then set flag on the new association to indicate that 4087 -- the original association was for such a box-initialized component. 4088 4089 if Is_Box_Init_By_Default then 4090 Set_Was_Default_Init_Box_Association (Last (Assoc_List)); 4091 end if; 4092 end Add_Association; 4093 4094 ----------------------------- 4095 -- Add_Discriminant_Values -- 4096 ----------------------------- 4097 4098 procedure Add_Discriminant_Values 4099 (New_Aggr : Node_Id; 4100 Assoc_List : List_Id) 4101 is 4102 Assoc : Node_Id; 4103 Discr : Entity_Id; 4104 Discr_Elmt : Elmt_Id; 4105 Discr_Val : Node_Id; 4106 Val : Entity_Id; 4107 4108 begin 4109 Discr := First_Discriminant (Etype (New_Aggr)); 4110 Discr_Elmt := First_Elmt (Discriminant_Constraint (Etype (New_Aggr))); 4111 while Present (Discr_Elmt) loop 4112 Discr_Val := Node (Discr_Elmt); 4113 4114 -- If the constraint is given by a discriminant then it is a 4115 -- discriminant of an enclosing record, and its value has already 4116 -- been placed in the association list. 4117 4118 if Is_Entity_Name (Discr_Val) 4119 and then Ekind (Entity (Discr_Val)) = E_Discriminant 4120 then 4121 Val := Entity (Discr_Val); 4122 4123 Assoc := First (Assoc_List); 4124 while Present (Assoc) loop 4125 if Present (Entity (First (Choices (Assoc)))) 4126 and then Entity (First (Choices (Assoc))) = Val 4127 then 4128 Discr_Val := Expression (Assoc); 4129 exit; 4130 end if; 4131 4132 Next (Assoc); 4133 end loop; 4134 end if; 4135 4136 Add_Association 4137 (Discr, New_Copy_Tree (Discr_Val), 4138 Component_Associations (New_Aggr)); 4139 4140 -- If the discriminant constraint is a current instance, mark the 4141 -- current aggregate so that the self-reference can be expanded 4142 -- later. The constraint may refer to the subtype of aggregate, so 4143 -- use base type for comparison. 4144 4145 if Nkind (Discr_Val) = N_Attribute_Reference 4146 and then Is_Entity_Name (Prefix (Discr_Val)) 4147 and then Is_Type (Entity (Prefix (Discr_Val))) 4148 and then Base_Type (Etype (N)) = Entity (Prefix (Discr_Val)) 4149 then 4150 Set_Has_Self_Reference (N); 4151 end if; 4152 4153 Next_Elmt (Discr_Elmt); 4154 Next_Discriminant (Discr); 4155 end loop; 4156 end Add_Discriminant_Values; 4157 4158 -------------------------- 4159 -- Discriminant_Present -- 4160 -------------------------- 4161 4162 function Discriminant_Present (Input_Discr : Entity_Id) return Boolean is 4163 Regular_Aggr : constant Boolean := Nkind (N) /= N_Extension_Aggregate; 4164 4165 Ancestor_Is_Subtyp : Boolean; 4166 4167 Loc : Source_Ptr; 4168 4169 Ancestor : Node_Id; 4170 Ancestor_Typ : Entity_Id; 4171 Comp_Assoc : Node_Id; 4172 Discr : Entity_Id; 4173 Discr_Expr : Node_Id; 4174 Discr_Val : Elmt_Id := No_Elmt; 4175 Orig_Discr : Entity_Id; 4176 4177 begin 4178 if Regular_Aggr then 4179 return True; 4180 end if; 4181 4182 -- Check whether inherited discriminant values have already been 4183 -- inserted in the aggregate. This will be the case if we are 4184 -- re-analyzing an aggregate whose expansion was delayed. 4185 4186 if Present (Component_Associations (N)) then 4187 Comp_Assoc := First (Component_Associations (N)); 4188 while Present (Comp_Assoc) loop 4189 if Inherited_Discriminant (Comp_Assoc) then 4190 return True; 4191 end if; 4192 4193 Next (Comp_Assoc); 4194 end loop; 4195 end if; 4196 4197 Ancestor := Ancestor_Part (N); 4198 Ancestor_Typ := Etype (Ancestor); 4199 Loc := Sloc (Ancestor); 4200 4201 -- For a private type with unknown discriminants, use the underlying 4202 -- record view if it is available. 4203 4204 if Has_Unknown_Discriminants (Ancestor_Typ) 4205 and then Present (Full_View (Ancestor_Typ)) 4206 and then Present (Underlying_Record_View (Full_View (Ancestor_Typ))) 4207 then 4208 Ancestor_Typ := Underlying_Record_View (Full_View (Ancestor_Typ)); 4209 end if; 4210 4211 Ancestor_Is_Subtyp := 4212 Is_Entity_Name (Ancestor) and then Is_Type (Entity (Ancestor)); 4213 4214 -- If the ancestor part has no discriminants clearly N's aggregate 4215 -- part must provide a value for Discr. 4216 4217 if not Has_Discriminants (Ancestor_Typ) then 4218 return True; 4219 4220 -- If the ancestor part is an unconstrained subtype mark then the 4221 -- Discr must be present in N's aggregate part. 4222 4223 elsif Ancestor_Is_Subtyp 4224 and then not Is_Constrained (Entity (Ancestor)) 4225 then 4226 return True; 4227 end if; 4228 4229 -- Now look to see if Discr was specified in the ancestor part 4230 4231 if Ancestor_Is_Subtyp then 4232 Discr_Val := 4233 First_Elmt (Discriminant_Constraint (Entity (Ancestor))); 4234 end if; 4235 4236 Orig_Discr := Original_Record_Component (Input_Discr); 4237 4238 Discr := First_Discriminant (Ancestor_Typ); 4239 while Present (Discr) loop 4240 4241 -- If Ancestor has already specified Disc value then insert its 4242 -- value in the final aggregate. 4243 4244 if Original_Record_Component (Discr) = Orig_Discr then 4245 if Ancestor_Is_Subtyp then 4246 Discr_Expr := New_Copy_Tree (Node (Discr_Val)); 4247 else 4248 Discr_Expr := 4249 Make_Selected_Component (Loc, 4250 Prefix => Duplicate_Subexpr (Ancestor), 4251 Selector_Name => New_Occurrence_Of (Input_Discr, Loc)); 4252 end if; 4253 4254 Resolve_Aggr_Expr (Discr_Expr, Input_Discr); 4255 Set_Inherited_Discriminant (Last (New_Assoc_List)); 4256 return False; 4257 end if; 4258 4259 Next_Discriminant (Discr); 4260 4261 if Ancestor_Is_Subtyp then 4262 Next_Elmt (Discr_Val); 4263 end if; 4264 end loop; 4265 4266 return True; 4267 end Discriminant_Present; 4268 4269 --------------------------- 4270 -- Find_Private_Ancestor -- 4271 --------------------------- 4272 4273 function Find_Private_Ancestor (Typ : Entity_Id) return Entity_Id is 4274 Par : Entity_Id; 4275 4276 begin 4277 Par := Typ; 4278 loop 4279 if Has_Private_Ancestor (Par) 4280 and then not Has_Private_Ancestor (Etype (Base_Type (Par))) 4281 then 4282 return Par; 4283 4284 elsif not Is_Derived_Type (Par) then 4285 return Empty; 4286 4287 else 4288 Par := Etype (Base_Type (Par)); 4289 end if; 4290 end loop; 4291 end Find_Private_Ancestor; 4292 4293 --------------- 4294 -- Get_Value -- 4295 --------------- 4296 4297 function Get_Value 4298 (Compon : Entity_Id; 4299 From : List_Id; 4300 Consider_Others_Choice : Boolean := False) return Node_Id 4301 is 4302 Typ : constant Entity_Id := Etype (Compon); 4303 Assoc : Node_Id; 4304 Expr : Node_Id := Empty; 4305 Selector_Name : Node_Id; 4306 4307 begin 4308 Is_Box_Present := False; 4309 Is_Box_Init_By_Default := False; 4310 4311 if No (From) then 4312 return Empty; 4313 end if; 4314 4315 Assoc := First (From); 4316 while Present (Assoc) loop 4317 Selector_Name := First (Choices (Assoc)); 4318 while Present (Selector_Name) loop 4319 if Nkind (Selector_Name) = N_Others_Choice then 4320 if Consider_Others_Choice and then No (Expr) then 4321 4322 -- We need to duplicate the expression for each 4323 -- successive component covered by the others choice. 4324 -- This is redundant if the others_choice covers only 4325 -- one component (small optimization possible???), but 4326 -- indispensable otherwise, because each one must be 4327 -- expanded individually to preserve side effects. 4328 4329 -- Ada 2005 (AI-287): In case of default initialization 4330 -- of components, we duplicate the corresponding default 4331 -- expression (from the record type declaration). The 4332 -- copy must carry the sloc of the association (not the 4333 -- original expression) to prevent spurious elaboration 4334 -- checks when the default includes function calls. 4335 4336 if Box_Present (Assoc) then 4337 Others_Box := Others_Box + 1; 4338 Is_Box_Present := True; 4339 4340 if Expander_Active then 4341 return 4342 New_Copy_Tree_And_Copy_Dimensions 4343 (Expression (Parent (Compon)), 4344 New_Sloc => Sloc (Assoc)); 4345 else 4346 return Expression (Parent (Compon)); 4347 end if; 4348 4349 else 4350 if Present (Others_Etype) 4351 and then Base_Type (Others_Etype) /= Base_Type (Typ) 4352 then 4353 -- If the components are of an anonymous access 4354 -- type they are distinct, but this is legal in 4355 -- Ada 2012 as long as designated types match. 4356 4357 if (Ekind (Typ) = E_Anonymous_Access_Type 4358 or else Ekind (Typ) = 4359 E_Anonymous_Access_Subprogram_Type) 4360 and then Designated_Type (Typ) = 4361 Designated_Type (Others_Etype) 4362 then 4363 null; 4364 else 4365 Error_Msg_N 4366 ("components in OTHERS choice must have same " 4367 & "type", Selector_Name); 4368 end if; 4369 end if; 4370 4371 Others_Etype := Typ; 4372 4373 -- Copy the expression so that it is resolved 4374 -- independently for each component, This is needed 4375 -- for accessibility checks on components of anonymous 4376 -- access types, even in compile_only mode. 4377 4378 if not Inside_A_Generic then 4379 return 4380 New_Copy_Tree_And_Copy_Dimensions 4381 (Expression (Assoc)); 4382 else 4383 return Expression (Assoc); 4384 end if; 4385 end if; 4386 end if; 4387 4388 elsif Chars (Compon) = Chars (Selector_Name) then 4389 if No (Expr) then 4390 4391 -- Ada 2005 (AI-231) 4392 4393 if Ada_Version >= Ada_2005 4394 and then Known_Null (Expression (Assoc)) 4395 then 4396 Check_Can_Never_Be_Null (Compon, Expression (Assoc)); 4397 end if; 4398 4399 -- We need to duplicate the expression when several 4400 -- components are grouped together with a "|" choice. 4401 -- For instance "filed1 | filed2 => Expr" 4402 4403 -- Ada 2005 (AI-287) 4404 4405 if Box_Present (Assoc) then 4406 Is_Box_Present := True; 4407 4408 -- Duplicate the default expression of the component 4409 -- from the record type declaration, so a new copy 4410 -- can be attached to the association. 4411 4412 -- Note that we always copy the default expression, 4413 -- even when the association has a single choice, in 4414 -- order to create a proper association for the 4415 -- expanded aggregate. 4416 4417 -- Component may have no default, in which case the 4418 -- expression is empty and the component is default- 4419 -- initialized, but an association for the component 4420 -- exists, and it is not covered by an others clause. 4421 4422 -- Scalar and private types have no initialization 4423 -- procedure, so they remain uninitialized. If the 4424 -- target of the aggregate is a constant this 4425 -- deserves a warning. 4426 4427 if No (Expression (Parent (Compon))) 4428 and then not Has_Non_Null_Base_Init_Proc (Typ) 4429 and then not Has_Aspect (Typ, Aspect_Default_Value) 4430 and then not Is_Concurrent_Type (Typ) 4431 and then Nkind (Parent (N)) = N_Object_Declaration 4432 and then Constant_Present (Parent (N)) 4433 then 4434 Error_Msg_Node_2 := Typ; 4435 Error_Msg_NE 4436 ("component&? of type& is uninitialized", 4437 Assoc, Selector_Name); 4438 4439 -- An additional reminder if the component type 4440 -- is a generic formal. 4441 4442 if Is_Generic_Type (Base_Type (Typ)) then 4443 Error_Msg_NE 4444 ("\instance should provide actual type with " 4445 & "initialization for&", Assoc, Typ); 4446 end if; 4447 end if; 4448 4449 return 4450 New_Copy_Tree_And_Copy_Dimensions 4451 (Expression (Parent (Compon))); 4452 4453 else 4454 if Present (Next (Selector_Name)) then 4455 Expr := New_Copy_Tree_And_Copy_Dimensions 4456 (Expression (Assoc)); 4457 else 4458 Expr := Expression (Assoc); 4459 end if; 4460 end if; 4461 4462 Generate_Reference (Compon, Selector_Name, 'm'); 4463 4464 else 4465 Error_Msg_NE 4466 ("more than one value supplied for &", 4467 Selector_Name, Compon); 4468 4469 end if; 4470 end if; 4471 4472 Next (Selector_Name); 4473 end loop; 4474 4475 Next (Assoc); 4476 end loop; 4477 4478 return Expr; 4479 end Get_Value; 4480 4481 ----------------------------- 4482 -- Propagate_Discriminants -- 4483 ----------------------------- 4484 4485 procedure Propagate_Discriminants 4486 (Aggr : Node_Id; 4487 Assoc_List : List_Id) 4488 is 4489 Loc : constant Source_Ptr := Sloc (N); 4490 4491 procedure Process_Component (Comp : Entity_Id); 4492 -- Add one component with a box association to the inner aggregate, 4493 -- and recurse if component is itself composite. 4494 4495 ----------------------- 4496 -- Process_Component -- 4497 ----------------------- 4498 4499 procedure Process_Component (Comp : Entity_Id) is 4500 T : constant Entity_Id := Etype (Comp); 4501 New_Aggr : Node_Id; 4502 4503 begin 4504 if Is_Record_Type (T) and then Has_Discriminants (T) then 4505 New_Aggr := Make_Aggregate (Loc, No_List, New_List); 4506 Set_Etype (New_Aggr, T); 4507 4508 Add_Association 4509 (Comp, New_Aggr, Component_Associations (Aggr)); 4510 4511 -- Collect discriminant values and recurse 4512 4513 Add_Discriminant_Values (New_Aggr, Assoc_List); 4514 Propagate_Discriminants (New_Aggr, Assoc_List); 4515 4516 Build_Constrained_Itype 4517 (New_Aggr, T, Component_Associations (New_Aggr)); 4518 else 4519 Add_Association 4520 (Comp, Empty, Component_Associations (Aggr), 4521 Is_Box_Present => True); 4522 end if; 4523 end Process_Component; 4524 4525 -- Local variables 4526 4527 Aggr_Type : constant Entity_Id := Base_Type (Etype (Aggr)); 4528 Components : constant Elist_Id := New_Elmt_List; 4529 Def_Node : constant Node_Id := 4530 Type_Definition (Declaration_Node (Aggr_Type)); 4531 4532 Comp : Node_Id; 4533 Comp_Elmt : Elmt_Id; 4534 Errors : Boolean; 4535 4536 -- Start of processing for Propagate_Discriminants 4537 4538 begin 4539 -- The component type may be a variant type. Collect the components 4540 -- that are ruled by the known values of the discriminants. Their 4541 -- values have already been inserted into the component list of the 4542 -- current aggregate. 4543 4544 if Nkind (Def_Node) = N_Record_Definition 4545 and then Present (Component_List (Def_Node)) 4546 and then Present (Variant_Part (Component_List (Def_Node))) 4547 then 4548 Gather_Components (Aggr_Type, 4549 Component_List (Def_Node), 4550 Governed_By => Component_Associations (Aggr), 4551 Into => Components, 4552 Report_Errors => Errors); 4553 4554 Comp_Elmt := First_Elmt (Components); 4555 while Present (Comp_Elmt) loop 4556 if Ekind (Node (Comp_Elmt)) /= E_Discriminant then 4557 Process_Component (Node (Comp_Elmt)); 4558 end if; 4559 4560 Next_Elmt (Comp_Elmt); 4561 end loop; 4562 4563 -- No variant part, iterate over all components 4564 4565 else 4566 Comp := First_Component (Etype (Aggr)); 4567 while Present (Comp) loop 4568 Process_Component (Comp); 4569 Next_Component (Comp); 4570 end loop; 4571 end if; 4572 end Propagate_Discriminants; 4573 4574 ----------------------- 4575 -- Resolve_Aggr_Expr -- 4576 ----------------------- 4577 4578 procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Entity_Id) is 4579 function Has_Expansion_Delayed (Expr : Node_Id) return Boolean; 4580 -- If the expression is an aggregate (possibly qualified) then its 4581 -- expansion is delayed until the enclosing aggregate is expanded 4582 -- into assignments. In that case, do not generate checks on the 4583 -- expression, because they will be generated later, and will other- 4584 -- wise force a copy (to remove side effects) that would leave a 4585 -- dynamic-sized aggregate in the code, something that gigi cannot 4586 -- handle. 4587 4588 --------------------------- 4589 -- Has_Expansion_Delayed -- 4590 --------------------------- 4591 4592 function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is 4593 begin 4594 return 4595 (Nkind (Expr) in N_Aggregate | N_Extension_Aggregate 4596 and then Present (Etype (Expr)) 4597 and then Is_Record_Type (Etype (Expr)) 4598 and then Expansion_Delayed (Expr)) 4599 or else 4600 (Nkind (Expr) = N_Qualified_Expression 4601 and then Has_Expansion_Delayed (Expression (Expr))); 4602 end Has_Expansion_Delayed; 4603 4604 -- Local variables 4605 4606 Expr_Type : Entity_Id := Empty; 4607 New_C : Entity_Id := Component; 4608 New_Expr : Node_Id; 4609 4610 Relocate : Boolean; 4611 -- Set to True if the resolved Expr node needs to be relocated when 4612 -- attached to the newly created association list. This node need not 4613 -- be relocated if its parent pointer is not set. In fact in this 4614 -- case Expr is the output of a New_Copy_Tree call. If Relocate is 4615 -- True then we have analyzed the expression node in the original 4616 -- aggregate and hence it needs to be relocated when moved over to 4617 -- the new association list. 4618 4619 -- Start of processing for Resolve_Aggr_Expr 4620 4621 begin 4622 -- If the type of the component is elementary or the type of the 4623 -- aggregate does not contain discriminants, use the type of the 4624 -- component to resolve Expr. 4625 4626 if Is_Elementary_Type (Etype (Component)) 4627 or else not Has_Discriminants (Etype (N)) 4628 then 4629 Expr_Type := Etype (Component); 4630 4631 -- Otherwise we have to pick up the new type of the component from 4632 -- the new constrained subtype of the aggregate. In fact components 4633 -- which are of a composite type might be constrained by a 4634 -- discriminant, and we want to resolve Expr against the subtype were 4635 -- all discriminant occurrences are replaced with their actual value. 4636 4637 else 4638 New_C := First_Component (Etype (N)); 4639 while Present (New_C) loop 4640 if Chars (New_C) = Chars (Component) then 4641 Expr_Type := Etype (New_C); 4642 exit; 4643 end if; 4644 4645 Next_Component (New_C); 4646 end loop; 4647 4648 pragma Assert (Present (Expr_Type)); 4649 4650 -- For each range in an array type where a discriminant has been 4651 -- replaced with the constraint, check that this range is within 4652 -- the range of the base type. This checks is done in the init 4653 -- proc for regular objects, but has to be done here for 4654 -- aggregates since no init proc is called for them. 4655 4656 if Is_Array_Type (Expr_Type) then 4657 declare 4658 Index : Node_Id; 4659 -- Range of the current constrained index in the array 4660 4661 Orig_Index : Node_Id := First_Index (Etype (Component)); 4662 -- Range corresponding to the range Index above in the 4663 -- original unconstrained record type. The bounds of this 4664 -- range may be governed by discriminants. 4665 4666 Unconstr_Index : Node_Id := First_Index (Etype (Expr_Type)); 4667 -- Range corresponding to the range Index above for the 4668 -- unconstrained array type. This range is needed to apply 4669 -- range checks. 4670 4671 begin 4672 Index := First_Index (Expr_Type); 4673 while Present (Index) loop 4674 if Depends_On_Discriminant (Orig_Index) then 4675 Apply_Range_Check (Index, Etype (Unconstr_Index)); 4676 end if; 4677 4678 Next_Index (Index); 4679 Next_Index (Orig_Index); 4680 Next_Index (Unconstr_Index); 4681 end loop; 4682 end; 4683 end if; 4684 end if; 4685 4686 -- If the Parent pointer of Expr is not set, Expr is an expression 4687 -- duplicated by New_Tree_Copy (this happens for record aggregates 4688 -- that look like (Field1 | Filed2 => Expr) or (others => Expr)). 4689 -- Such a duplicated expression must be attached to the tree 4690 -- before analysis and resolution to enforce the rule that a tree 4691 -- fragment should never be analyzed or resolved unless it is 4692 -- attached to the current compilation unit. 4693 4694 if No (Parent (Expr)) then 4695 Set_Parent (Expr, N); 4696 Relocate := False; 4697 else 4698 Relocate := True; 4699 end if; 4700 4701 Analyze_And_Resolve (Expr, Expr_Type); 4702 Check_Expr_OK_In_Limited_Aggregate (Expr); 4703 Check_Non_Static_Context (Expr); 4704 Check_Unset_Reference (Expr); 4705 4706 -- Check wrong use of class-wide types 4707 4708 if Is_Class_Wide_Type (Etype (Expr)) then 4709 Error_Msg_N ("dynamically tagged expression not allowed", Expr); 4710 end if; 4711 4712 if not Has_Expansion_Delayed (Expr) then 4713 Aggregate_Constraint_Checks (Expr, Expr_Type); 4714 end if; 4715 4716 -- If an aggregate component has a type with predicates, an explicit 4717 -- predicate check must be applied, as for an assignment statement, 4718 -- because the aggregate might not be expanded into individual 4719 -- component assignments. 4720 4721 if Has_Predicates (Expr_Type) 4722 and then Analyzed (Expr) 4723 then 4724 Apply_Predicate_Check (Expr, Expr_Type); 4725 end if; 4726 4727 if Raises_Constraint_Error (Expr) then 4728 Set_Raises_Constraint_Error (N); 4729 end if; 4730 4731 -- If the expression has been marked as requiring a range check, then 4732 -- generate it here. It's a bit odd to be generating such checks in 4733 -- the analyzer, but harmless since Generate_Range_Check does nothing 4734 -- (other than making sure Do_Range_Check is set) if the expander is 4735 -- not active. 4736 4737 if Do_Range_Check (Expr) then 4738 Generate_Range_Check (Expr, Expr_Type, CE_Range_Check_Failed); 4739 end if; 4740 4741 -- Add association Component => Expr if the caller requests it 4742 4743 if Relocate then 4744 New_Expr := Relocate_Node (Expr); 4745 4746 -- Since New_Expr is not gonna be analyzed later on, we need to 4747 -- propagate here the dimensions form Expr to New_Expr. 4748 4749 Copy_Dimensions (Expr, New_Expr); 4750 4751 else 4752 New_Expr := Expr; 4753 end if; 4754 4755 Add_Association (New_C, New_Expr, New_Assoc_List); 4756 end Resolve_Aggr_Expr; 4757 4758 ------------------- 4759 -- Rewrite_Range -- 4760 ------------------- 4761 4762 procedure Rewrite_Range (Root_Type : Entity_Id; Rge : Node_Id) is 4763 procedure Rewrite_Bound 4764 (Bound : Node_Id; 4765 Disc : Entity_Id; 4766 Expr_Disc : Node_Id); 4767 -- Rewrite a bound of the range Bound, when it is equal to the 4768 -- non-stored discriminant Disc, into the stored discriminant 4769 -- value Expr_Disc. 4770 4771 ------------------- 4772 -- Rewrite_Bound -- 4773 ------------------- 4774 4775 procedure Rewrite_Bound 4776 (Bound : Node_Id; 4777 Disc : Entity_Id; 4778 Expr_Disc : Node_Id) 4779 is 4780 begin 4781 if Nkind (Bound) /= N_Identifier then 4782 return; 4783 end if; 4784 4785 -- We expect either the discriminant or the discriminal 4786 4787 if Entity (Bound) = Disc 4788 or else (Ekind (Entity (Bound)) = E_In_Parameter 4789 and then Discriminal_Link (Entity (Bound)) = Disc) 4790 then 4791 Rewrite (Bound, New_Copy_Tree (Expr_Disc)); 4792 end if; 4793 end Rewrite_Bound; 4794 4795 -- Local variables 4796 4797 Low, High : Node_Id; 4798 Disc : Entity_Id; 4799 Expr_Disc : Elmt_Id; 4800 4801 -- Start of processing for Rewrite_Range 4802 4803 begin 4804 if Has_Discriminants (Root_Type) and then Nkind (Rge) = N_Range then 4805 Low := Low_Bound (Rge); 4806 High := High_Bound (Rge); 4807 4808 Disc := First_Discriminant (Root_Type); 4809 Expr_Disc := First_Elmt (Stored_Constraint (Etype (N))); 4810 while Present (Disc) loop 4811 Rewrite_Bound (Low, Disc, Node (Expr_Disc)); 4812 Rewrite_Bound (High, Disc, Node (Expr_Disc)); 4813 Next_Discriminant (Disc); 4814 Next_Elmt (Expr_Disc); 4815 end loop; 4816 end if; 4817 end Rewrite_Range; 4818 4819 -- Local variables 4820 4821 Components : constant Elist_Id := New_Elmt_List; 4822 -- Components is the list of the record components whose value must be 4823 -- provided in the aggregate. This list does include discriminants. 4824 4825 Component : Entity_Id; 4826 Component_Elmt : Elmt_Id; 4827 Expr : Node_Id; 4828 Positional_Expr : Node_Id; 4829 4830 -- Start of processing for Resolve_Record_Aggregate 4831 4832 begin 4833 -- A record aggregate is restricted in SPARK: 4834 4835 -- Each named association can have only a single choice. 4836 -- OTHERS cannot be used. 4837 -- Positional and named associations cannot be mixed. 4838 4839 if Present (Component_Associations (N)) 4840 and then Present (First (Component_Associations (N))) 4841 then 4842 declare 4843 Assoc : Node_Id; 4844 4845 begin 4846 Assoc := First (Component_Associations (N)); 4847 while Present (Assoc) loop 4848 if Nkind (Assoc) = N_Iterated_Component_Association then 4849 Error_Msg_N 4850 ("iterated component association can only appear in an " 4851 & "array aggregate", N); 4852 raise Unrecoverable_Error; 4853 end if; 4854 4855 Next (Assoc); 4856 end loop; 4857 end; 4858 end if; 4859 4860 -- We may end up calling Duplicate_Subexpr on expressions that are 4861 -- attached to New_Assoc_List. For this reason we need to attach it 4862 -- to the tree by setting its parent pointer to N. This parent point 4863 -- will change in STEP 8 below. 4864 4865 Set_Parent (New_Assoc_List, N); 4866 4867 -- STEP 1: abstract type and null record verification 4868 4869 if Is_Abstract_Type (Typ) then 4870 Error_Msg_N ("type of aggregate cannot be abstract", N); 4871 end if; 4872 4873 if No (First_Entity (Typ)) and then Null_Record_Present (N) then 4874 Set_Etype (N, Typ); 4875 return; 4876 4877 elsif Present (First_Entity (Typ)) 4878 and then Null_Record_Present (N) 4879 and then not Is_Tagged_Type (Typ) 4880 then 4881 Error_Msg_N ("record aggregate cannot be null", N); 4882 return; 4883 4884 -- If the type has no components, then the aggregate should either 4885 -- have "null record", or in Ada 2005 it could instead have a single 4886 -- component association given by "others => <>". For Ada 95 we flag an 4887 -- error at this point, but for Ada 2005 we proceed with checking the 4888 -- associations below, which will catch the case where it's not an 4889 -- aggregate with "others => <>". Note that the legality of a <> 4890 -- aggregate for a null record type was established by AI05-016. 4891 4892 elsif No (First_Entity (Typ)) 4893 and then Ada_Version < Ada_2005 4894 then 4895 Error_Msg_N ("record aggregate must be null", N); 4896 return; 4897 end if; 4898 4899 -- STEP 2: Verify aggregate structure 4900 4901 Step_2 : declare 4902 Assoc : Node_Id; 4903 Bad_Aggregate : Boolean := False; 4904 Selector_Name : Node_Id; 4905 4906 begin 4907 if Present (Component_Associations (N)) then 4908 Assoc := First (Component_Associations (N)); 4909 else 4910 Assoc := Empty; 4911 end if; 4912 4913 while Present (Assoc) loop 4914 Selector_Name := First (Choices (Assoc)); 4915 while Present (Selector_Name) loop 4916 if Nkind (Selector_Name) = N_Identifier then 4917 null; 4918 4919 elsif Nkind (Selector_Name) = N_Others_Choice then 4920 if Selector_Name /= First (Choices (Assoc)) 4921 or else Present (Next (Selector_Name)) 4922 then 4923 Error_Msg_N 4924 ("OTHERS must appear alone in a choice list", 4925 Selector_Name); 4926 return; 4927 4928 elsif Present (Next (Assoc)) then 4929 Error_Msg_N 4930 ("OTHERS must appear last in an aggregate", 4931 Selector_Name); 4932 return; 4933 4934 -- (Ada 2005): If this is an association with a box, 4935 -- indicate that the association need not represent 4936 -- any component. 4937 4938 elsif Box_Present (Assoc) then 4939 Others_Box := 1; 4940 Box_Node := Assoc; 4941 end if; 4942 4943 else 4944 Error_Msg_N 4945 ("selector name should be identifier or OTHERS", 4946 Selector_Name); 4947 Bad_Aggregate := True; 4948 end if; 4949 4950 Next (Selector_Name); 4951 end loop; 4952 4953 Next (Assoc); 4954 end loop; 4955 4956 if Bad_Aggregate then 4957 return; 4958 end if; 4959 end Step_2; 4960 4961 -- STEP 3: Find discriminant Values 4962 4963 Step_3 : declare 4964 Discrim : Entity_Id; 4965 Missing_Discriminants : Boolean := False; 4966 4967 begin 4968 if Present (Expressions (N)) then 4969 Positional_Expr := First (Expressions (N)); 4970 else 4971 Positional_Expr := Empty; 4972 end if; 4973 4974 -- AI05-0115: if the ancestor part is a subtype mark, the ancestor 4975 -- must not have unknown discriminants. 4976 -- ??? We are not checking any subtype mark here and this code is not 4977 -- exercised by any test, so it's likely wrong (in particular 4978 -- we should not use Root_Type here but the subtype mark, if any), 4979 -- and possibly not needed. 4980 4981 if Is_Derived_Type (Typ) 4982 and then Has_Unknown_Discriminants (Root_Type (Typ)) 4983 and then Nkind (N) /= N_Extension_Aggregate 4984 then 4985 Error_Msg_NE 4986 ("aggregate not available for type& whose ancestor " 4987 & "has unknown discriminants", N, Typ); 4988 end if; 4989 4990 if Has_Unknown_Discriminants (Typ) 4991 and then Present (Underlying_Record_View (Typ)) 4992 then 4993 Discrim := First_Discriminant (Underlying_Record_View (Typ)); 4994 elsif Has_Discriminants (Typ) then 4995 Discrim := First_Discriminant (Typ); 4996 else 4997 Discrim := Empty; 4998 end if; 4999 5000 -- First find the discriminant values in the positional components 5001 5002 while Present (Discrim) and then Present (Positional_Expr) loop 5003 if Discriminant_Present (Discrim) then 5004 Resolve_Aggr_Expr (Positional_Expr, Discrim); 5005 5006 -- Ada 2005 (AI-231) 5007 5008 if Ada_Version >= Ada_2005 5009 and then Known_Null (Positional_Expr) 5010 then 5011 Check_Can_Never_Be_Null (Discrim, Positional_Expr); 5012 end if; 5013 5014 Next (Positional_Expr); 5015 end if; 5016 5017 if Present (Get_Value (Discrim, Component_Associations (N))) then 5018 Error_Msg_NE 5019 ("more than one value supplied for discriminant&", 5020 N, Discrim); 5021 end if; 5022 5023 Next_Discriminant (Discrim); 5024 end loop; 5025 5026 -- Find remaining discriminant values if any among named components 5027 5028 while Present (Discrim) loop 5029 Expr := Get_Value (Discrim, Component_Associations (N), True); 5030 5031 if not Discriminant_Present (Discrim) then 5032 if Present (Expr) then 5033 Error_Msg_NE 5034 ("more than one value supplied for discriminant &", 5035 N, Discrim); 5036 end if; 5037 5038 elsif No (Expr) then 5039 Error_Msg_NE 5040 ("no value supplied for discriminant &", N, Discrim); 5041 Missing_Discriminants := True; 5042 5043 else 5044 Resolve_Aggr_Expr (Expr, Discrim); 5045 end if; 5046 5047 Next_Discriminant (Discrim); 5048 end loop; 5049 5050 if Missing_Discriminants then 5051 return; 5052 end if; 5053 5054 -- At this point and until the beginning of STEP 6, New_Assoc_List 5055 -- contains only the discriminants and their values. 5056 5057 end Step_3; 5058 5059 -- STEP 4: Set the Etype of the record aggregate 5060 5061 if Has_Discriminants (Typ) 5062 or else (Has_Unknown_Discriminants (Typ) 5063 and then Present (Underlying_Record_View (Typ))) 5064 then 5065 Build_Constrained_Itype (N, Typ, New_Assoc_List); 5066 else 5067 Set_Etype (N, Typ); 5068 end if; 5069 5070 -- STEP 5: Get remaining components according to discriminant values 5071 5072 Step_5 : declare 5073 Dnode : Node_Id; 5074 Errors_Found : Boolean := False; 5075 Record_Def : Node_Id; 5076 Parent_Typ : Entity_Id; 5077 Parent_Typ_List : Elist_Id; 5078 Parent_Elmt : Elmt_Id; 5079 Root_Typ : Entity_Id; 5080 5081 begin 5082 if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then 5083 Parent_Typ_List := New_Elmt_List; 5084 5085 -- If this is an extension aggregate, the component list must 5086 -- include all components that are not in the given ancestor type. 5087 -- Otherwise, the component list must include components of all 5088 -- ancestors, starting with the root. 5089 5090 if Nkind (N) = N_Extension_Aggregate then 5091 Root_Typ := Base_Type (Etype (Ancestor_Part (N))); 5092 5093 else 5094 -- AI05-0115: check legality of aggregate for type with a 5095 -- private ancestor. 5096 5097 Root_Typ := Root_Type (Typ); 5098 if Has_Private_Ancestor (Typ) then 5099 declare 5100 Ancestor : constant Entity_Id := 5101 Find_Private_Ancestor (Typ); 5102 Ancestor_Unit : constant Entity_Id := 5103 Cunit_Entity 5104 (Get_Source_Unit (Ancestor)); 5105 Parent_Unit : constant Entity_Id := 5106 Cunit_Entity (Get_Source_Unit 5107 (Base_Type (Etype (Ancestor)))); 5108 begin 5109 -- Check whether we are in a scope that has full view 5110 -- over the private ancestor and its parent. This can 5111 -- only happen if the derivation takes place in a child 5112 -- unit of the unit that declares the parent, and we are 5113 -- in the private part or body of that child unit, else 5114 -- the aggregate is illegal. 5115 5116 if Is_Child_Unit (Ancestor_Unit) 5117 and then Scope (Ancestor_Unit) = Parent_Unit 5118 and then In_Open_Scopes (Scope (Ancestor)) 5119 and then 5120 (In_Private_Part (Scope (Ancestor)) 5121 or else In_Package_Body (Scope (Ancestor))) 5122 then 5123 null; 5124 5125 else 5126 Error_Msg_NE 5127 ("type of aggregate has private ancestor&!", 5128 N, Root_Typ); 5129 Error_Msg_N ("must use extension aggregate!", N); 5130 return; 5131 end if; 5132 end; 5133 end if; 5134 5135 Dnode := Declaration_Node (Base_Type (Root_Typ)); 5136 5137 -- If we don't get a full declaration, then we have some error 5138 -- which will get signalled later so skip this part. Otherwise 5139 -- gather components of root that apply to the aggregate type. 5140 -- We use the base type in case there is an applicable stored 5141 -- constraint that renames the discriminants of the root. 5142 5143 if Nkind (Dnode) = N_Full_Type_Declaration then 5144 Record_Def := Type_Definition (Dnode); 5145 Gather_Components 5146 (Base_Type (Typ), 5147 Component_List (Record_Def), 5148 Governed_By => New_Assoc_List, 5149 Into => Components, 5150 Report_Errors => Errors_Found); 5151 5152 if Errors_Found then 5153 Error_Msg_N 5154 ("discriminant controlling variant part is not static", 5155 N); 5156 return; 5157 end if; 5158 end if; 5159 end if; 5160 5161 Parent_Typ := Base_Type (Typ); 5162 while Parent_Typ /= Root_Typ loop 5163 Prepend_Elmt (Parent_Typ, To => Parent_Typ_List); 5164 Parent_Typ := Etype (Parent_Typ); 5165 5166 -- Check whether a private parent requires the use of 5167 -- an extension aggregate. This test does not apply in 5168 -- an instantiation: if the generic unit is legal so is 5169 -- the instance. 5170 5171 if Nkind (Parent (Base_Type (Parent_Typ))) = 5172 N_Private_Type_Declaration 5173 or else Nkind (Parent (Base_Type (Parent_Typ))) = 5174 N_Private_Extension_Declaration 5175 then 5176 if Nkind (N) /= N_Extension_Aggregate 5177 and then not In_Instance 5178 then 5179 Error_Msg_NE 5180 ("type of aggregate has private ancestor&!", 5181 N, Parent_Typ); 5182 Error_Msg_N ("must use extension aggregate!", N); 5183 return; 5184 5185 elsif Parent_Typ /= Root_Typ then 5186 Error_Msg_NE 5187 ("ancestor part of aggregate must be private type&", 5188 Ancestor_Part (N), Parent_Typ); 5189 return; 5190 end if; 5191 5192 -- The current view of ancestor part may be a private type, 5193 -- while the context type is always non-private. 5194 5195 elsif Is_Private_Type (Root_Typ) 5196 and then Present (Full_View (Root_Typ)) 5197 and then Nkind (N) = N_Extension_Aggregate 5198 then 5199 exit when Base_Type (Full_View (Root_Typ)) = Parent_Typ; 5200 end if; 5201 end loop; 5202 5203 -- Now collect components from all other ancestors, beginning 5204 -- with the current type. If the type has unknown discriminants 5205 -- use the component list of the Underlying_Record_View, which 5206 -- needs to be used for the subsequent expansion of the aggregate 5207 -- into assignments. 5208 5209 Parent_Elmt := First_Elmt (Parent_Typ_List); 5210 while Present (Parent_Elmt) loop 5211 Parent_Typ := Node (Parent_Elmt); 5212 5213 if Has_Unknown_Discriminants (Parent_Typ) 5214 and then Present (Underlying_Record_View (Typ)) 5215 then 5216 Parent_Typ := Underlying_Record_View (Parent_Typ); 5217 end if; 5218 5219 Record_Def := Type_Definition (Parent (Base_Type (Parent_Typ))); 5220 Gather_Components (Empty, 5221 Component_List (Record_Extension_Part (Record_Def)), 5222 Governed_By => New_Assoc_List, 5223 Into => Components, 5224 Report_Errors => Errors_Found); 5225 5226 Next_Elmt (Parent_Elmt); 5227 end loop; 5228 5229 -- Typ is not a derived tagged type 5230 5231 else 5232 Record_Def := Type_Definition (Parent (Base_Type (Typ))); 5233 5234 if Null_Present (Record_Def) then 5235 null; 5236 5237 elsif not Has_Unknown_Discriminants (Typ) then 5238 Gather_Components 5239 (Base_Type (Typ), 5240 Component_List (Record_Def), 5241 Governed_By => New_Assoc_List, 5242 Into => Components, 5243 Report_Errors => Errors_Found); 5244 5245 else 5246 Gather_Components 5247 (Base_Type (Underlying_Record_View (Typ)), 5248 Component_List (Record_Def), 5249 Governed_By => New_Assoc_List, 5250 Into => Components, 5251 Report_Errors => Errors_Found); 5252 end if; 5253 end if; 5254 5255 if Errors_Found then 5256 return; 5257 end if; 5258 end Step_5; 5259 5260 -- STEP 6: Find component Values 5261 5262 Component := Empty; 5263 Component_Elmt := First_Elmt (Components); 5264 5265 -- First scan the remaining positional associations in the aggregate. 5266 -- Remember that at this point Positional_Expr contains the current 5267 -- positional association if any is left after looking for discriminant 5268 -- values in step 3. 5269 5270 while Present (Positional_Expr) and then Present (Component_Elmt) loop 5271 Component := Node (Component_Elmt); 5272 Resolve_Aggr_Expr (Positional_Expr, Component); 5273 5274 -- Ada 2005 (AI-231) 5275 5276 if Ada_Version >= Ada_2005 and then Known_Null (Positional_Expr) then 5277 Check_Can_Never_Be_Null (Component, Positional_Expr); 5278 end if; 5279 5280 if Present (Get_Value (Component, Component_Associations (N))) then 5281 Error_Msg_NE 5282 ("more than one value supplied for component &", N, Component); 5283 end if; 5284 5285 Next (Positional_Expr); 5286 Next_Elmt (Component_Elmt); 5287 end loop; 5288 5289 if Present (Positional_Expr) then 5290 Error_Msg_N 5291 ("too many components for record aggregate", Positional_Expr); 5292 end if; 5293 5294 -- Now scan for the named arguments of the aggregate 5295 5296 while Present (Component_Elmt) loop 5297 Component := Node (Component_Elmt); 5298 Expr := Get_Value (Component, Component_Associations (N), True); 5299 5300 -- Note: The previous call to Get_Value sets the value of the 5301 -- variable Is_Box_Present. 5302 5303 -- Ada 2005 (AI-287): Handle components with default initialization. 5304 -- Note: This feature was originally added to Ada 2005 for limited 5305 -- but it was finally allowed with any type. 5306 5307 if Is_Box_Present then 5308 Check_Box_Component : declare 5309 Ctyp : constant Entity_Id := Etype (Component); 5310 5311 begin 5312 -- Initially assume that the box is for a default-initialized 5313 -- component and reset to False in cases where that's not true. 5314 5315 Is_Box_Init_By_Default := True; 5316 5317 -- If there is a default expression for the aggregate, copy 5318 -- it into a new association. This copy must modify the scopes 5319 -- of internal types that may be attached to the expression 5320 -- (e.g. index subtypes of arrays) because in general the type 5321 -- declaration and the aggregate appear in different scopes, 5322 -- and the backend requires the scope of the type to match the 5323 -- point at which it is elaborated. 5324 5325 -- If the component has an initialization procedure (IP) we 5326 -- pass the component to the expander, which will generate 5327 -- the call to such IP. 5328 5329 -- If the component has discriminants, their values must 5330 -- be taken from their subtype. This is indispensable for 5331 -- constraints that are given by the current instance of an 5332 -- enclosing type, to allow the expansion of the aggregate to 5333 -- replace the reference to the current instance by the target 5334 -- object of the aggregate. 5335 5336 if Is_Case_Choice_Pattern (N) then 5337 5338 -- Do not transform box component values in a case-choice 5339 -- aggregate. 5340 5341 Add_Association 5342 (Component => Component, 5343 Expr => Empty, 5344 Assoc_List => New_Assoc_List, 5345 Is_Box_Present => True); 5346 5347 elsif Present (Parent (Component)) 5348 and then Nkind (Parent (Component)) = N_Component_Declaration 5349 and then Present (Expression (Parent (Component))) 5350 then 5351 -- If component declaration has an initialization expression 5352 -- then this is not a case of default initialization. 5353 5354 Is_Box_Init_By_Default := False; 5355 5356 Expr := 5357 New_Copy_Tree_And_Copy_Dimensions 5358 (Expression (Parent (Component)), 5359 New_Scope => Current_Scope, 5360 New_Sloc => Sloc (N)); 5361 5362 -- As the type of the copied default expression may refer 5363 -- to discriminants of the record type declaration, these 5364 -- non-stored discriminants need to be rewritten into stored 5365 -- discriminant values for the aggregate. This is required 5366 -- in GNATprove mode, and is adopted in all modes to avoid 5367 -- special-casing GNATprove mode. 5368 5369 if Is_Array_Type (Etype (Expr)) then 5370 declare 5371 Rec_Typ : constant Entity_Id := Scope (Component); 5372 -- Root record type whose discriminants may be used as 5373 -- bounds in range nodes. 5374 5375 Assoc : Node_Id; 5376 Choice : Node_Id; 5377 Index : Node_Id; 5378 5379 begin 5380 -- Rewrite the range nodes occurring in the indexes 5381 -- and their types. 5382 5383 Index := First_Index (Etype (Expr)); 5384 while Present (Index) loop 5385 Rewrite_Range (Rec_Typ, Index); 5386 Rewrite_Range 5387 (Rec_Typ, Scalar_Range (Etype (Index))); 5388 5389 Next_Index (Index); 5390 end loop; 5391 5392 -- Rewrite the range nodes occurring as aggregate 5393 -- bounds and component associations. 5394 5395 if Nkind (Expr) = N_Aggregate then 5396 if Present (Aggregate_Bounds (Expr)) then 5397 Rewrite_Range (Rec_Typ, Aggregate_Bounds (Expr)); 5398 end if; 5399 5400 if Present (Component_Associations (Expr)) then 5401 Assoc := First (Component_Associations (Expr)); 5402 while Present (Assoc) loop 5403 Choice := First (Choices (Assoc)); 5404 while Present (Choice) loop 5405 Rewrite_Range (Rec_Typ, Choice); 5406 5407 Next (Choice); 5408 end loop; 5409 5410 Next (Assoc); 5411 end loop; 5412 end if; 5413 end if; 5414 end; 5415 end if; 5416 5417 Add_Association 5418 (Component => Component, 5419 Expr => Expr, 5420 Assoc_List => New_Assoc_List); 5421 Set_Has_Self_Reference (N); 5422 5423 elsif Needs_Simple_Initialization (Ctyp) then 5424 Add_Association 5425 (Component => Component, 5426 Expr => Empty, 5427 Assoc_List => New_Assoc_List, 5428 Is_Box_Present => True); 5429 5430 elsif Has_Non_Null_Base_Init_Proc (Ctyp) 5431 or else not Expander_Active 5432 then 5433 if Is_Record_Type (Ctyp) 5434 and then Has_Discriminants (Ctyp) 5435 and then not Is_Private_Type (Ctyp) 5436 then 5437 -- We build a partially initialized aggregate with the 5438 -- values of the discriminants and box initialization 5439 -- for the rest, if other components are present. 5440 5441 -- The type of the aggregate is the known subtype of 5442 -- the component. The capture of discriminants must be 5443 -- recursive because subcomponents may be constrained 5444 -- (transitively) by discriminants of enclosing types. 5445 -- For a private type with discriminants, a call to the 5446 -- initialization procedure will be generated, and no 5447 -- subaggregate is needed. 5448 5449 Capture_Discriminants : declare 5450 Loc : constant Source_Ptr := Sloc (N); 5451 Expr : Node_Id; 5452 5453 begin 5454 Expr := Make_Aggregate (Loc, No_List, New_List); 5455 Set_Etype (Expr, Ctyp); 5456 5457 -- If the enclosing type has discriminants, they have 5458 -- been collected in the aggregate earlier, and they 5459 -- may appear as constraints of subcomponents. 5460 5461 -- Similarly if this component has discriminants, they 5462 -- might in turn be propagated to their components. 5463 5464 if Has_Discriminants (Typ) then 5465 Add_Discriminant_Values (Expr, New_Assoc_List); 5466 Propagate_Discriminants (Expr, New_Assoc_List); 5467 5468 elsif Has_Discriminants (Ctyp) then 5469 Add_Discriminant_Values 5470 (Expr, Component_Associations (Expr)); 5471 Propagate_Discriminants 5472 (Expr, Component_Associations (Expr)); 5473 5474 Build_Constrained_Itype 5475 (Expr, Ctyp, Component_Associations (Expr)); 5476 5477 else 5478 declare 5479 Comp : Entity_Id; 5480 5481 begin 5482 -- If the type has additional components, create 5483 -- an OTHERS box association for them. 5484 5485 Comp := First_Component (Ctyp); 5486 while Present (Comp) loop 5487 if Ekind (Comp) = E_Component then 5488 if not Is_Record_Type (Etype (Comp)) then 5489 Append_To 5490 (Component_Associations (Expr), 5491 Make_Component_Association (Loc, 5492 Choices => 5493 New_List ( 5494 Make_Others_Choice (Loc)), 5495 Expression => Empty, 5496 Box_Present => True)); 5497 end if; 5498 5499 exit; 5500 end if; 5501 5502 Next_Component (Comp); 5503 end loop; 5504 end; 5505 end if; 5506 5507 Add_Association 5508 (Component => Component, 5509 Expr => Expr, 5510 Assoc_List => New_Assoc_List); 5511 end Capture_Discriminants; 5512 5513 -- Otherwise the component type is not a record, or it has 5514 -- not discriminants, or it is private. 5515 5516 else 5517 Add_Association 5518 (Component => Component, 5519 Expr => Empty, 5520 Assoc_List => New_Assoc_List, 5521 Is_Box_Present => True); 5522 end if; 5523 5524 -- Otherwise we only need to resolve the expression if the 5525 -- component has partially initialized values (required to 5526 -- expand the corresponding assignments and run-time checks). 5527 5528 elsif Present (Expr) 5529 and then Is_Partially_Initialized_Type (Ctyp) 5530 then 5531 Resolve_Aggr_Expr (Expr, Component); 5532 end if; 5533 end Check_Box_Component; 5534 5535 elsif No (Expr) then 5536 5537 -- Ignore hidden components associated with the position of the 5538 -- interface tags: these are initialized dynamically. 5539 5540 if not Present (Related_Type (Component)) then 5541 Error_Msg_NE 5542 ("no value supplied for component &!", N, Component); 5543 end if; 5544 5545 else 5546 Resolve_Aggr_Expr (Expr, Component); 5547 end if; 5548 5549 Next_Elmt (Component_Elmt); 5550 end loop; 5551 5552 -- STEP 7: check for invalid components + check type in choice list 5553 5554 Step_7 : declare 5555 Assoc : Node_Id; 5556 New_Assoc : Node_Id; 5557 5558 Selectr : Node_Id; 5559 -- Selector name 5560 5561 Typech : Entity_Id; 5562 -- Type of first component in choice list 5563 5564 begin 5565 if Present (Component_Associations (N)) then 5566 Assoc := First (Component_Associations (N)); 5567 else 5568 Assoc := Empty; 5569 end if; 5570 5571 Verification : while Present (Assoc) loop 5572 Selectr := First (Choices (Assoc)); 5573 Typech := Empty; 5574 5575 if Nkind (Selectr) = N_Others_Choice then 5576 5577 -- Ada 2005 (AI-287): others choice may have expression or box 5578 5579 if No (Others_Etype) and then Others_Box = 0 then 5580 Error_Msg_N 5581 ("OTHERS must represent at least one component", Selectr); 5582 5583 elsif Others_Box = 1 and then Warn_On_Redundant_Constructs then 5584 Error_Msg_N ("OTHERS choice is redundant?", Box_Node); 5585 Error_Msg_N 5586 ("\previous choices cover all components?", Box_Node); 5587 end if; 5588 5589 exit Verification; 5590 end if; 5591 5592 while Present (Selectr) loop 5593 New_Assoc := First (New_Assoc_List); 5594 while Present (New_Assoc) loop 5595 Component := First (Choices (New_Assoc)); 5596 5597 if Chars (Selectr) = Chars (Component) then 5598 if Style_Check then 5599 Check_Identifier (Selectr, Entity (Component)); 5600 end if; 5601 5602 exit; 5603 end if; 5604 5605 Next (New_Assoc); 5606 end loop; 5607 5608 -- If no association, this is not a legal component of the type 5609 -- in question, unless its association is provided with a box. 5610 5611 if No (New_Assoc) then 5612 if Box_Present (Parent (Selectr)) then 5613 5614 -- This may still be a bogus component with a box. Scan 5615 -- list of components to verify that a component with 5616 -- that name exists. 5617 5618 declare 5619 C : Entity_Id; 5620 5621 begin 5622 C := First_Component (Typ); 5623 while Present (C) loop 5624 if Chars (C) = Chars (Selectr) then 5625 5626 -- If the context is an extension aggregate, 5627 -- the component must not be inherited from 5628 -- the ancestor part of the aggregate. 5629 5630 if Nkind (N) /= N_Extension_Aggregate 5631 or else 5632 Scope (Original_Record_Component (C)) /= 5633 Etype (Ancestor_Part (N)) 5634 then 5635 exit; 5636 end if; 5637 end if; 5638 5639 Next_Component (C); 5640 end loop; 5641 5642 if No (C) then 5643 Error_Msg_Node_2 := Typ; 5644 Error_Msg_N ("& is not a component of}", Selectr); 5645 end if; 5646 end; 5647 5648 elsif Chars (Selectr) /= Name_uTag 5649 and then Chars (Selectr) /= Name_uParent 5650 then 5651 if not Has_Discriminants (Typ) then 5652 Error_Msg_Node_2 := Typ; 5653 Error_Msg_N ("& is not a component of}", Selectr); 5654 else 5655 Error_Msg_N 5656 ("& is not a component of the aggregate subtype", 5657 Selectr); 5658 end if; 5659 5660 Check_Misspelled_Component (Components, Selectr); 5661 end if; 5662 5663 elsif No (Typech) then 5664 Typech := Base_Type (Etype (Component)); 5665 5666 -- AI05-0199: In Ada 2012, several components of anonymous 5667 -- access types can appear in a choice list, as long as the 5668 -- designated types match. 5669 5670 elsif Typech /= Base_Type (Etype (Component)) then 5671 if Ada_Version >= Ada_2012 5672 and then Ekind (Typech) = E_Anonymous_Access_Type 5673 and then 5674 Ekind (Etype (Component)) = E_Anonymous_Access_Type 5675 and then Base_Type (Designated_Type (Typech)) = 5676 Base_Type (Designated_Type (Etype (Component))) 5677 and then 5678 Subtypes_Statically_Match (Typech, (Etype (Component))) 5679 then 5680 null; 5681 5682 elsif not Box_Present (Parent (Selectr)) then 5683 Error_Msg_N 5684 ("components in choice list must have same type", 5685 Selectr); 5686 end if; 5687 end if; 5688 5689 Next (Selectr); 5690 end loop; 5691 5692 Next (Assoc); 5693 end loop Verification; 5694 end Step_7; 5695 5696 -- STEP 8: replace the original aggregate 5697 5698 Step_8 : declare 5699 New_Aggregate : constant Node_Id := New_Copy (N); 5700 5701 begin 5702 Set_Expressions (New_Aggregate, No_List); 5703 Set_Etype (New_Aggregate, Etype (N)); 5704 Set_Component_Associations (New_Aggregate, New_Assoc_List); 5705 Set_Check_Actuals (New_Aggregate, Check_Actuals (N)); 5706 5707 Rewrite (N, New_Aggregate); 5708 end Step_8; 5709 5710 -- Check the dimensions of the components in the record aggregate 5711 5712 Analyze_Dimension_Extension_Or_Record_Aggregate (N); 5713 end Resolve_Record_Aggregate; 5714 5715 ----------------------------- 5716 -- Check_Can_Never_Be_Null -- 5717 ----------------------------- 5718 5719 procedure Check_Can_Never_Be_Null (Typ : Entity_Id; Expr : Node_Id) is 5720 Comp_Typ : Entity_Id; 5721 5722 begin 5723 pragma Assert 5724 (Ada_Version >= Ada_2005 5725 and then Present (Expr) 5726 and then Known_Null (Expr)); 5727 5728 case Ekind (Typ) is 5729 when E_Array_Type => 5730 Comp_Typ := Component_Type (Typ); 5731 5732 when E_Component 5733 | E_Discriminant 5734 => 5735 Comp_Typ := Etype (Typ); 5736 5737 when others => 5738 return; 5739 end case; 5740 5741 if Can_Never_Be_Null (Comp_Typ) then 5742 5743 -- Here we know we have a constraint error. Note that we do not use 5744 -- Apply_Compile_Time_Constraint_Error here to the Expr, which might 5745 -- seem the more natural approach. That's because in some cases the 5746 -- components are rewritten, and the replacement would be missed. 5747 -- We do not mark the whole aggregate as raising a constraint error, 5748 -- because the association may be a null array range. 5749 5750 Error_Msg_N 5751 ("(Ada 2005) NULL not allowed in null-excluding component??", Expr); 5752 Error_Msg_N 5753 ("\Constraint_Error will be raised at run time??", Expr); 5754 5755 Rewrite (Expr, 5756 Make_Raise_Constraint_Error 5757 (Sloc (Expr), Reason => CE_Access_Check_Failed)); 5758 Set_Etype (Expr, Comp_Typ); 5759 Set_Analyzed (Expr); 5760 end if; 5761 end Check_Can_Never_Be_Null; 5762 5763 --------------------- 5764 -- Sort_Case_Table -- 5765 --------------------- 5766 5767 procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is 5768 U : constant Int := Case_Table'Last; 5769 K : Int; 5770 J : Int; 5771 T : Case_Bounds; 5772 5773 begin 5774 K := 1; 5775 while K < U loop 5776 T := Case_Table (K + 1); 5777 5778 J := K + 1; 5779 while J > 1 5780 and then Expr_Value (Case_Table (J - 1).Lo) > Expr_Value (T.Lo) 5781 loop 5782 Case_Table (J) := Case_Table (J - 1); 5783 J := J - 1; 5784 end loop; 5785 5786 Case_Table (J) := T; 5787 K := K + 1; 5788 end loop; 5789 end Sort_Case_Table; 5790 5791end Sem_Aggr; 5792