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