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