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