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