OSDN Git Service

2010-10-08 Robert Dewar <dewar@adacore.com>
[pf3gnuchains/gcc-fork.git] / gcc / ada / sem_aggr.adb
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-2010, 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
26 with Atree;    use Atree;
27 with Checks;   use Checks;
28 with Einfo;    use Einfo;
29 with Elists;   use Elists;
30 with Errout;   use Errout;
31 with Expander; use Expander;
32 with Exp_Tss;  use Exp_Tss;
33 with Exp_Util; use Exp_Util;
34 with Freeze;   use Freeze;
35 with Itypes;   use Itypes;
36 with Lib;      use Lib;
37 with Lib.Xref; use Lib.Xref;
38 with Namet;    use Namet;
39 with Namet.Sp; use Namet.Sp;
40 with Nmake;    use Nmake;
41 with Nlists;   use Nlists;
42 with Opt;      use Opt;
43 with Sem;      use Sem;
44 with Sem_Aux;  use Sem_Aux;
45 with Sem_Cat;  use Sem_Cat;
46 with Sem_Ch3;  use Sem_Ch3;
47 with Sem_Ch13; use Sem_Ch13;
48 with Sem_Eval; use Sem_Eval;
49 with Sem_Res;  use Sem_Res;
50 with Sem_Util; use Sem_Util;
51 with Sem_Type; use Sem_Type;
52 with Sem_Warn; use Sem_Warn;
53 with Sinfo;    use Sinfo;
54 with Snames;   use Snames;
55 with Stringt;  use Stringt;
56 with Stand;    use Stand;
57 with Style;    use Style;
58 with Targparm; use Targparm;
59 with Tbuild;   use Tbuild;
60 with Uintp;    use Uintp;
61
62 package body Sem_Aggr is
63
64    type Case_Bounds is record
65      Choice_Lo   : Node_Id;
66      Choice_Hi   : Node_Id;
67      Choice_Node : Node_Id;
68    end record;
69
70    type Case_Table_Type is array (Nat range <>) of Case_Bounds;
71    --  Table type used by Check_Case_Choices procedure
72
73    -----------------------
74    -- Local Subprograms --
75    -----------------------
76
77    procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
78    --  Sort the Case Table using the Lower Bound of each Choice as the key.
79    --  A simple insertion sort is used since the number of choices in a case
80    --  statement of variant part will usually be small and probably in near
81    --  sorted order.
82
83    procedure Check_Can_Never_Be_Null (Typ : Entity_Id; Expr : Node_Id);
84    --  Ada 2005 (AI-231): Check bad usage of null for a component for which
85    --  null exclusion (NOT NULL) is specified. Typ can be an E_Array_Type for
86    --  the array case (the component type of the array will be used) or an
87    --  E_Component/E_Discriminant entity in the record case, in which case the
88    --  type of the component will be used for the test. If Typ is any other
89    --  kind of entity, the call is ignored. Expr is the component node in the
90    --  aggregate which is known to have a null value. A warning message will be
91    --  issued if the component is null excluding.
92    --
93    --  It would be better to pass the proper type for Typ ???
94
95    procedure Check_Expr_OK_In_Limited_Aggregate (Expr : Node_Id);
96    --  Check that Expr is either not limited or else is one of the cases of
97    --  expressions allowed for a limited component association (namely, an
98    --  aggregate, function call, or <> notation). Report error for violations.
99
100    ------------------------------------------------------
101    -- Subprograms used for RECORD AGGREGATE Processing --
102    ------------------------------------------------------
103
104    procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id);
105    --  This procedure performs all the semantic checks required for record
106    --  aggregates. Note that for aggregates analysis and resolution go
107    --  hand in hand. Aggregate analysis has been delayed up to here and
108    --  it is done while resolving the aggregate.
109    --
110    --    N is the N_Aggregate node.
111    --    Typ is the record type for the aggregate resolution
112    --
113    --  While performing the semantic checks, this procedure builds a new
114    --  Component_Association_List where each record field appears alone in a
115    --  Component_Choice_List along with its corresponding expression. The
116    --  record fields in the Component_Association_List appear in the same order
117    --  in which they appear in the record type Typ.
118    --
119    --  Once this new Component_Association_List is built and all the semantic
120    --  checks performed, the original aggregate subtree is replaced with the
121    --  new named record aggregate just built. Note that subtree substitution is
122    --  performed with Rewrite so as to be able to retrieve the original
123    --  aggregate.
124    --
125    --  The aggregate subtree manipulation performed by Resolve_Record_Aggregate
126    --  yields the aggregate format expected by Gigi. Typically, this kind of
127    --  tree manipulations are done in the expander. However, because the
128    --  semantic checks that need to be performed on record aggregates really go
129    --  hand in hand with the record aggregate normalization, the aggregate
130    --  subtree transformation is performed during resolution rather than
131    --  expansion. Had we decided otherwise we would have had to duplicate most
132    --  of the code in the expansion procedure Expand_Record_Aggregate. Note,
133    --  however, that all the expansion concerning aggregates for tagged records
134    --  is done in Expand_Record_Aggregate.
135    --
136    --  The algorithm of Resolve_Record_Aggregate proceeds as follows:
137    --
138    --  1. Make sure that the record type against which the record aggregate
139    --     has to be resolved is not abstract. Furthermore if the type is a
140    --     null aggregate make sure the input aggregate N is also null.
141    --
142    --  2. Verify that the structure of the aggregate is that of a record
143    --     aggregate. Specifically, look for component associations and ensure
144    --     that each choice list only has identifiers or the N_Others_Choice
145    --     node. Also make sure that if present, the N_Others_Choice occurs
146    --     last and by itself.
147    --
148    --  3. If Typ contains discriminants, the values for each discriminant is
149    --     looked for. If the record type Typ has variants, we check that the
150    --     expressions corresponding to each discriminant ruling the (possibly
151    --     nested) variant parts of Typ, are static. This allows us to determine
152    --     the variant parts to which the rest of the aggregate must conform.
153    --     The names of discriminants with their values are saved in a new
154    --     association list, New_Assoc_List which is later augmented with the
155    --     names and values of the remaining components in the record type.
156    --
157    --     During this phase we also make sure that every discriminant is
158    --     assigned exactly one value. Note that when several values for a given
159    --     discriminant are found, semantic processing continues looking for
160    --     further errors. In this case it's the first discriminant value found
161    --     which we will be recorded.
162    --
163    --     IMPORTANT NOTE: For derived tagged types this procedure expects
164    --     First_Discriminant and Next_Discriminant to give the correct list
165    --     of discriminants, in the correct order.
166    --
167    --  4. After all the discriminant values have been gathered, we can set the
168    --     Etype of the record aggregate. If Typ contains no discriminants this
169    --     is straightforward: the Etype of N is just Typ, otherwise a new
170    --     implicit constrained subtype of Typ is built to be the Etype of N.
171    --
172    --  5. Gather the remaining record components according to the discriminant
173    --     values. This involves recursively traversing the record type
174    --     structure to see what variants are selected by the given discriminant
175    --     values. This processing is a little more convoluted if Typ is a
176    --     derived tagged types since we need to retrieve the record structure
177    --     of all the ancestors of Typ.
178    --
179    --  6. After gathering the record components we look for their values in the
180    --     record aggregate and emit appropriate error messages should we not
181    --     find such values or should they be duplicated.
182    --
183    --  7. We then make sure no illegal component names appear in the record
184    --     aggregate and make sure that the type of the record components
185    --     appearing in a same choice list is the same. Finally we ensure that
186    --     the others choice, if present, is used to provide the value of at
187    --     least a record component.
188    --
189    --  8. The original aggregate node is replaced with the new named aggregate
190    --     built in steps 3 through 6, as explained earlier.
191    --
192    --  Given the complexity of record aggregate resolution, the primary goal of
193    --  this routine is clarity and simplicity rather than execution and storage
194    --  efficiency. If there are only positional components in the aggregate the
195    --  running time is linear. If there are associations the running time is
196    --  still linear as long as the order of the associations is not too far off
197    --  the order of the components in the record type. If this is not the case
198    --  the running time is at worst quadratic in the size of the association
199    --  list.
200
201    procedure Check_Misspelled_Component
202      (Elements  : Elist_Id;
203       Component : Node_Id);
204    --  Give possible misspelling diagnostic if Component is likely to be a
205    --  misspelling of one of the components of the Assoc_List. This is called
206    --  by Resolve_Aggr_Expr after producing an invalid component error message.
207
208    procedure Check_Static_Discriminated_Subtype (T : Entity_Id; V : Node_Id);
209    --  An optimization: determine whether a discriminated subtype has a static
210    --  constraint, and contains array components whose length is also static,
211    --  either because they are constrained by the discriminant, or because the
212    --  original component bounds are static.
213
214    -----------------------------------------------------
215    -- Subprograms used for ARRAY AGGREGATE Processing --
216    -----------------------------------------------------
217
218    function Resolve_Array_Aggregate
219      (N              : Node_Id;
220       Index          : Node_Id;
221       Index_Constr   : Node_Id;
222       Component_Typ  : Entity_Id;
223       Others_Allowed : Boolean) return Boolean;
224    --  This procedure performs the semantic checks for an array aggregate.
225    --  True is returned if the aggregate resolution succeeds.
226    --
227    --  The procedure works by recursively checking each nested aggregate.
228    --  Specifically, after checking a sub-aggregate nested at the i-th level
229    --  we recursively check all the subaggregates at the i+1-st level (if any).
230    --  Note that for aggregates analysis and resolution go hand in hand.
231    --  Aggregate analysis has been delayed up to here and it is done while
232    --  resolving the aggregate.
233    --
234    --    N is the current N_Aggregate node to be checked.
235    --
236    --    Index is the index node corresponding to the array sub-aggregate that
237    --    we are currently checking (RM 4.3.3 (8)). Its Etype is the
238    --    corresponding index type (or subtype).
239    --
240    --    Index_Constr is the node giving the applicable index constraint if
241    --    any (RM 4.3.3 (10)). It "is a constraint provided by certain
242    --    contexts [...] that can be used to determine the bounds of the array
243    --    value specified by the aggregate". If Others_Allowed below is False
244    --    there is no applicable index constraint and this node is set to Index.
245    --
246    --    Component_Typ is the array component type.
247    --
248    --    Others_Allowed indicates whether an others choice is allowed
249    --    in the context where the top-level aggregate appeared.
250    --
251    --  The algorithm of Resolve_Array_Aggregate proceeds as follows:
252    --
253    --  1. Make sure that the others choice, if present, is by itself and
254    --     appears last in the sub-aggregate. Check that we do not have
255    --     positional and named components in the array sub-aggregate (unless
256    --     the named association is an others choice). Finally if an others
257    --     choice is present, make sure it is allowed in the aggregate context.
258    --
259    --  2. If the array sub-aggregate contains discrete_choices:
260    --
261    --     (A) Verify their validity. Specifically verify that:
262    --
263    --        (a) If a null range is present it must be the only possible
264    --            choice in the array aggregate.
265    --
266    --        (b) Ditto for a non static range.
267    --
268    --        (c) Ditto for a non static expression.
269    --
270    --        In addition this step analyzes and resolves each discrete_choice,
271    --        making sure that its type is the type of the corresponding Index.
272    --        If we are not at the lowest array aggregate level (in the case of
273    --        multi-dimensional aggregates) then invoke Resolve_Array_Aggregate
274    --        recursively on each component expression. Otherwise, resolve the
275    --        bottom level component expressions against the expected component
276    --        type ONLY IF the component corresponds to a single discrete choice
277    --        which is not an others choice (to see why read the DELAYED
278    --        COMPONENT RESOLUTION below).
279    --
280    --     (B) Determine the bounds of the sub-aggregate and lowest and
281    --         highest choice values.
282    --
283    --  3. For positional aggregates:
284    --
285    --     (A) Loop over the component expressions either recursively invoking
286    --         Resolve_Array_Aggregate on each of these for multi-dimensional
287    --         array aggregates or resolving the bottom level component
288    --         expressions against the expected component type.
289    --
290    --     (B) Determine the bounds of the positional sub-aggregates.
291    --
292    --  4. Try to determine statically whether the evaluation of the array
293    --     sub-aggregate raises Constraint_Error. If yes emit proper
294    --     warnings. The precise checks are the following:
295    --
296    --     (A) Check that the index range defined by aggregate bounds is
297    --         compatible with corresponding index subtype.
298    --         We also check against the base type. In fact it could be that
299    --         Low/High bounds of the base type are static whereas those of
300    --         the index subtype are not. Thus if we can statically catch
301    --         a problem with respect to the base type we are guaranteed
302    --         that the same problem will arise with the index subtype
303    --
304    --     (B) If we are dealing with a named aggregate containing an others
305    --         choice and at least one discrete choice then make sure the range
306    --         specified by the discrete choices does not overflow the
307    --         aggregate bounds. We also check against the index type and base
308    --         type bounds for the same reasons given in (A).
309    --
310    --     (C) If we are dealing with a positional aggregate with an others
311    --         choice make sure the number of positional elements specified
312    --         does not overflow the aggregate bounds. We also check against
313    --         the index type and base type bounds as mentioned in (A).
314    --
315    --     Finally construct an N_Range node giving the sub-aggregate bounds.
316    --     Set the Aggregate_Bounds field of the sub-aggregate to be this
317    --     N_Range. The routine Array_Aggr_Subtype below uses such N_Ranges
318    --     to build the appropriate aggregate subtype. Aggregate_Bounds
319    --     information is needed during expansion.
320    --
321    --  DELAYED COMPONENT RESOLUTION: The resolution of bottom level component
322    --  expressions in an array aggregate may call Duplicate_Subexpr or some
323    --  other routine that inserts code just outside the outermost aggregate.
324    --  If the array aggregate contains discrete choices or an others choice,
325    --  this may be wrong. Consider for instance the following example.
326    --
327    --    type Rec is record
328    --       V : Integer := 0;
329    --    end record;
330    --
331    --    type Acc_Rec is access Rec;
332    --    Arr : array (1..3) of Acc_Rec := (1 .. 3 => new Rec);
333    --
334    --  Then the transformation of "new Rec" that occurs during resolution
335    --  entails the following code modifications
336    --
337    --    P7b : constant Acc_Rec := new Rec;
338    --    RecIP (P7b.all);
339    --    Arr : array (1..3) of Acc_Rec := (1 .. 3 => P7b);
340    --
341    --  This code transformation is clearly wrong, since we need to call
342    --  "new Rec" for each of the 3 array elements. To avoid this problem we
343    --  delay resolution of the components of non positional array aggregates
344    --  to the expansion phase. As an optimization, if the discrete choice
345    --  specifies a single value we do not delay resolution.
346
347    function Array_Aggr_Subtype (N : Node_Id; Typ : Node_Id) return Entity_Id;
348    --  This routine returns the type or subtype of an array aggregate.
349    --
350    --    N is the array aggregate node whose type we return.
351    --
352    --    Typ is the context type in which N occurs.
353    --
354    --  This routine creates an implicit array subtype whose bounds are
355    --  those defined by the aggregate. When this routine is invoked
356    --  Resolve_Array_Aggregate has already processed aggregate N. Thus the
357    --  Aggregate_Bounds of each sub-aggregate, is an N_Range node giving the
358    --  sub-aggregate bounds. When building the aggregate itype, this function
359    --  traverses the array aggregate N collecting such Aggregate_Bounds and
360    --  constructs the proper array aggregate itype.
361    --
362    --  Note that in the case of multidimensional aggregates each inner
363    --  sub-aggregate corresponding to a given array dimension, may provide a
364    --  different bounds. If it is possible to determine statically that
365    --  some sub-aggregates corresponding to the same index do not have the
366    --  same bounds, then a warning is emitted. If such check is not possible
367    --  statically (because some sub-aggregate bounds are dynamic expressions)
368    --  then this job is left to the expander. In all cases the particular
369    --  bounds that this function will chose for a given dimension is the first
370    --  N_Range node for a sub-aggregate corresponding to that dimension.
371    --
372    --  Note that the Raises_Constraint_Error flag of an array aggregate
373    --  whose evaluation is determined to raise CE by Resolve_Array_Aggregate,
374    --  is set in Resolve_Array_Aggregate but the aggregate is not
375    --  immediately replaced with a raise CE. In fact, Array_Aggr_Subtype must
376    --  first construct the proper itype for the aggregate (Gigi needs
377    --  this). After constructing the proper itype we will eventually  replace
378    --  the top-level aggregate with a raise CE (done in Resolve_Aggregate).
379    --  Of course in cases such as:
380    --
381    --     type Arr is array (integer range <>) of Integer;
382    --     A : Arr := (positive range -1 .. 2 => 0);
383    --
384    --  The bounds of the aggregate itype are cooked up to look reasonable
385    --  (in this particular case the bounds will be 1 .. 2).
386
387    procedure Aggregate_Constraint_Checks
388      (Exp       : Node_Id;
389       Check_Typ : Entity_Id);
390    --  Checks expression Exp against subtype Check_Typ. If Exp is an
391    --  aggregate and Check_Typ a constrained record type with discriminants,
392    --  we generate the appropriate discriminant checks. If Exp is an array
393    --  aggregate then emit the appropriate length checks. If Exp is a scalar
394    --  type, or a string literal, Exp is changed into Check_Typ'(Exp) to
395    --  ensure that range checks are performed at run time.
396
397    procedure Make_String_Into_Aggregate (N : Node_Id);
398    --  A string literal can appear in  a context in  which a one dimensional
399    --  array of characters is expected. This procedure simply rewrites the
400    --  string as an aggregate, prior to resolution.
401
402    ---------------------------------
403    -- Aggregate_Constraint_Checks --
404    ---------------------------------
405
406    procedure Aggregate_Constraint_Checks
407      (Exp       : Node_Id;
408       Check_Typ : Entity_Id)
409    is
410       Exp_Typ : constant Entity_Id  := Etype (Exp);
411
412    begin
413       if Raises_Constraint_Error (Exp) then
414          return;
415       end if;
416
417       --  Ada 2005 (AI-230): Generate a conversion to an anonymous access
418       --  component's type to force the appropriate accessibility checks.
419
420       --  Ada 2005 (AI-231): Generate conversion to the null-excluding
421       --  type to force the corresponding run-time check
422
423       if Is_Access_Type (Check_Typ)
424         and then ((Is_Local_Anonymous_Access (Check_Typ))
425                     or else (Can_Never_Be_Null (Check_Typ)
426                                and then not Can_Never_Be_Null (Exp_Typ)))
427       then
428          Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
429          Analyze_And_Resolve (Exp, Check_Typ);
430          Check_Unset_Reference (Exp);
431       end if;
432
433       --  This is really expansion activity, so make sure that expansion
434       --  is on and is allowed.
435
436       if not Expander_Active or else In_Spec_Expression then
437          return;
438       end if;
439
440       --  First check if we have to insert discriminant checks
441
442       if Has_Discriminants (Exp_Typ) then
443          Apply_Discriminant_Check (Exp, Check_Typ);
444
445       --  Next emit length checks for array aggregates
446
447       elsif Is_Array_Type (Exp_Typ) then
448          Apply_Length_Check (Exp, Check_Typ);
449
450       --  Finally emit scalar and string checks. If we are dealing with a
451       --  scalar literal we need to check by hand because the Etype of
452       --  literals is not necessarily correct.
453
454       elsif Is_Scalar_Type (Exp_Typ)
455         and then Compile_Time_Known_Value (Exp)
456       then
457          if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then
458             Apply_Compile_Time_Constraint_Error
459               (Exp, "value not in range of}?", CE_Range_Check_Failed,
460                Ent => Base_Type (Check_Typ),
461                Typ => Base_Type (Check_Typ));
462
463          elsif Is_Out_Of_Range (Exp, Check_Typ) then
464             Apply_Compile_Time_Constraint_Error
465               (Exp, "value not in range of}?", CE_Range_Check_Failed,
466                Ent => Check_Typ,
467                Typ => Check_Typ);
468
469          elsif not Range_Checks_Suppressed (Check_Typ) then
470             Apply_Scalar_Range_Check (Exp, Check_Typ);
471          end if;
472
473       --  Verify that target type is also scalar, to prevent view anomalies
474       --  in instantiations.
475
476       elsif (Is_Scalar_Type (Exp_Typ)
477               or else Nkind (Exp) = N_String_Literal)
478         and then Is_Scalar_Type (Check_Typ)
479         and then Exp_Typ /= Check_Typ
480       then
481          if Is_Entity_Name (Exp)
482            and then Ekind (Entity (Exp)) = E_Constant
483          then
484             --  If expression is a constant, it is worthwhile checking whether
485             --  it is a bound of the type.
486
487             if (Is_Entity_Name (Type_Low_Bound (Check_Typ))
488                  and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ)))
489               or else (Is_Entity_Name (Type_High_Bound (Check_Typ))
490                 and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ)))
491             then
492                return;
493
494             else
495                Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
496                Analyze_And_Resolve (Exp, Check_Typ);
497                Check_Unset_Reference (Exp);
498             end if;
499          else
500             Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
501             Analyze_And_Resolve (Exp, Check_Typ);
502             Check_Unset_Reference (Exp);
503          end if;
504
505       end if;
506    end Aggregate_Constraint_Checks;
507
508    ------------------------
509    -- Array_Aggr_Subtype --
510    ------------------------
511
512    function Array_Aggr_Subtype
513      (N   : Node_Id;
514       Typ : Entity_Id) return Entity_Id
515    is
516       Aggr_Dimension : constant Pos := Number_Dimensions (Typ);
517       --  Number of aggregate index dimensions
518
519       Aggr_Range : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
520       --  Constrained N_Range of each index dimension in our aggregate itype
521
522       Aggr_Low   : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
523       Aggr_High  : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
524       --  Low and High bounds for each index dimension in our aggregate itype
525
526       Is_Fully_Positional : Boolean := True;
527
528       procedure Collect_Aggr_Bounds (N : Node_Id; Dim : Pos);
529       --  N is an array (sub-)aggregate. Dim is the dimension corresponding to
530       --  (sub-)aggregate N. This procedure collects the constrained N_Range
531       --  nodes corresponding to each index dimension of our aggregate itype.
532       --  These N_Range nodes are collected in Aggr_Range above.
533       --
534       --  Likewise collect in Aggr_Low & Aggr_High above the low and high
535       --  bounds of each index dimension. If, when collecting, two bounds
536       --  corresponding to the same dimension are static and found to differ,
537       --  then emit a warning, and mark N as raising Constraint_Error.
538
539       -------------------------
540       -- Collect_Aggr_Bounds --
541       -------------------------
542
543       procedure Collect_Aggr_Bounds (N : Node_Id; Dim : Pos) is
544          This_Range : constant Node_Id := Aggregate_Bounds (N);
545          --  The aggregate range node of this specific sub-aggregate
546
547          This_Low  : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
548          This_High : constant Node_Id := High_Bound (Aggregate_Bounds (N));
549          --  The aggregate bounds of this specific sub-aggregate
550
551          Assoc : Node_Id;
552          Expr  : Node_Id;
553
554       begin
555          --  Collect the first N_Range for a given dimension that you find.
556          --  For a given dimension they must be all equal anyway.
557
558          if No (Aggr_Range (Dim)) then
559             Aggr_Low (Dim)   := This_Low;
560             Aggr_High (Dim)  := This_High;
561             Aggr_Range (Dim) := This_Range;
562
563          else
564             if Compile_Time_Known_Value (This_Low) then
565                if not Compile_Time_Known_Value (Aggr_Low (Dim)) then
566                   Aggr_Low (Dim)  := This_Low;
567
568                elsif Expr_Value (This_Low) /= Expr_Value (Aggr_Low (Dim)) then
569                   Set_Raises_Constraint_Error (N);
570                   Error_Msg_N ("sub-aggregate low bound mismatch?", N);
571                   Error_Msg_N
572                      ("\Constraint_Error will be raised at run time?", N);
573                end if;
574             end if;
575
576             if Compile_Time_Known_Value (This_High) then
577                if not Compile_Time_Known_Value (Aggr_High (Dim)) then
578                   Aggr_High (Dim)  := This_High;
579
580                elsif
581                  Expr_Value (This_High) /= Expr_Value (Aggr_High (Dim))
582                then
583                   Set_Raises_Constraint_Error (N);
584                   Error_Msg_N ("sub-aggregate high bound mismatch?", N);
585                   Error_Msg_N
586                      ("\Constraint_Error will be raised at run time?", N);
587                end if;
588             end if;
589          end if;
590
591          if Dim < Aggr_Dimension then
592
593             --  Process positional components
594
595             if Present (Expressions (N)) then
596                Expr := First (Expressions (N));
597                while Present (Expr) loop
598                   Collect_Aggr_Bounds (Expr, Dim + 1);
599                   Next (Expr);
600                end loop;
601             end if;
602
603             --  Process component associations
604
605             if Present (Component_Associations (N)) then
606                Is_Fully_Positional := False;
607
608                Assoc := First (Component_Associations (N));
609                while Present (Assoc) loop
610                   Expr := Expression (Assoc);
611                   Collect_Aggr_Bounds (Expr, Dim + 1);
612                   Next (Assoc);
613                end loop;
614             end if;
615          end if;
616       end Collect_Aggr_Bounds;
617
618       --  Array_Aggr_Subtype variables
619
620       Itype : Entity_Id;
621       --  The final itype of the overall aggregate
622
623       Index_Constraints : constant List_Id := New_List;
624       --  The list of index constraints of the aggregate itype
625
626    --  Start of processing for Array_Aggr_Subtype
627
628    begin
629       --  Make sure that the list of index constraints is properly attached to
630       --  the tree, and then collect the aggregate bounds.
631
632       Set_Parent (Index_Constraints, N);
633       Collect_Aggr_Bounds (N, 1);
634
635       --  Build the list of constrained indices of our aggregate itype
636
637       for J in 1 .. Aggr_Dimension loop
638          Create_Index : declare
639             Index_Base : constant Entity_Id :=
640                            Base_Type (Etype (Aggr_Range (J)));
641             Index_Typ  : Entity_Id;
642
643          begin
644             --  Construct the Index subtype, and associate it with the range
645             --  construct that generates it.
646
647             Index_Typ :=
648               Create_Itype (Subtype_Kind (Ekind (Index_Base)), Aggr_Range (J));
649
650             Set_Etype (Index_Typ, Index_Base);
651
652             if Is_Character_Type (Index_Base) then
653                Set_Is_Character_Type (Index_Typ);
654             end if;
655
656             Set_Size_Info      (Index_Typ,                (Index_Base));
657             Set_RM_Size        (Index_Typ, RM_Size        (Index_Base));
658             Set_First_Rep_Item (Index_Typ, First_Rep_Item (Index_Base));
659             Set_Scalar_Range   (Index_Typ, Aggr_Range (J));
660
661             if Is_Discrete_Or_Fixed_Point_Type (Index_Typ) then
662                Set_RM_Size (Index_Typ, UI_From_Int (Minimum_Size (Index_Typ)));
663             end if;
664
665             Set_Etype (Aggr_Range (J), Index_Typ);
666
667             Append (Aggr_Range (J), To => Index_Constraints);
668          end Create_Index;
669       end loop;
670
671       --  Now build the Itype
672
673       Itype := Create_Itype (E_Array_Subtype, N);
674
675       Set_First_Rep_Item         (Itype, First_Rep_Item        (Typ));
676       Set_Convention             (Itype, Convention            (Typ));
677       Set_Depends_On_Private     (Itype, Has_Private_Component (Typ));
678       Set_Etype                  (Itype, Base_Type             (Typ));
679       Set_Has_Alignment_Clause   (Itype, Has_Alignment_Clause  (Typ));
680       Set_Is_Aliased             (Itype, Is_Aliased            (Typ));
681       Set_Depends_On_Private     (Itype, Depends_On_Private    (Typ));
682
683       Copy_Suppress_Status (Index_Check,  Typ, Itype);
684       Copy_Suppress_Status (Length_Check, Typ, Itype);
685
686       Set_First_Index    (Itype, First (Index_Constraints));
687       Set_Is_Constrained (Itype, True);
688       Set_Is_Internal    (Itype, True);
689
690       --  A simple optimization: purely positional aggregates of static
691       --  components should be passed to gigi unexpanded whenever possible, and
692       --  regardless of the staticness of the bounds themselves. Subsequent
693       --  checks in exp_aggr verify that type is not packed, etc.
694
695       Set_Size_Known_At_Compile_Time (Itype,
696          Is_Fully_Positional
697            and then Comes_From_Source (N)
698            and then Size_Known_At_Compile_Time (Component_Type (Typ)));
699
700       --  We always need a freeze node for a packed array subtype, so that we
701       --  can build the Packed_Array_Type corresponding to the subtype. If
702       --  expansion is disabled, the packed array subtype is not built, and we
703       --  must not generate a freeze node for the type, or else it will appear
704       --  incomplete to gigi.
705
706       if Is_Packed (Itype)
707         and then not In_Spec_Expression
708         and then Expander_Active
709       then
710          Freeze_Itype (Itype, N);
711       end if;
712
713       return Itype;
714    end Array_Aggr_Subtype;
715
716    --------------------------------
717    -- Check_Misspelled_Component --
718    --------------------------------
719
720    procedure Check_Misspelled_Component
721      (Elements  : Elist_Id;
722       Component : Node_Id)
723    is
724       Max_Suggestions   : constant := 2;
725
726       Nr_Of_Suggestions : Natural := 0;
727       Suggestion_1      : Entity_Id := Empty;
728       Suggestion_2      : Entity_Id := Empty;
729       Component_Elmt    : Elmt_Id;
730
731    begin
732       --  All the components of List are matched against Component and a count
733       --  is maintained of possible misspellings. When at the end of the
734       --  the analysis there are one or two (not more!) possible misspellings,
735       --  these misspellings will be suggested as possible correction.
736
737       Component_Elmt := First_Elmt (Elements);
738       while Nr_Of_Suggestions <= Max_Suggestions
739         and then Present (Component_Elmt)
740       loop
741          if Is_Bad_Spelling_Of
742               (Chars (Node (Component_Elmt)),
743                Chars (Component))
744          then
745             Nr_Of_Suggestions := Nr_Of_Suggestions + 1;
746
747             case Nr_Of_Suggestions is
748                when 1      => Suggestion_1 := Node (Component_Elmt);
749                when 2      => Suggestion_2 := Node (Component_Elmt);
750                when others => exit;
751             end case;
752          end if;
753
754          Next_Elmt (Component_Elmt);
755       end loop;
756
757       --  Report at most two suggestions
758
759       if Nr_Of_Suggestions = 1 then
760          Error_Msg_NE -- CODEFIX
761            ("\possible misspelling of&", Component, Suggestion_1);
762
763       elsif Nr_Of_Suggestions = 2 then
764          Error_Msg_Node_2 := Suggestion_2;
765          Error_Msg_NE -- CODEFIX
766            ("\possible misspelling of& or&", Component, Suggestion_1);
767       end if;
768    end Check_Misspelled_Component;
769
770    ----------------------------------------
771    -- Check_Expr_OK_In_Limited_Aggregate --
772    ----------------------------------------
773
774    procedure Check_Expr_OK_In_Limited_Aggregate (Expr : Node_Id) is
775    begin
776       if Is_Limited_Type (Etype (Expr))
777          and then Comes_From_Source (Expr)
778          and then not In_Instance_Body
779       then
780          if not OK_For_Limited_Init (Etype (Expr), Expr) then
781             Error_Msg_N ("initialization not allowed for limited types", Expr);
782             Explain_Limited_Type (Etype (Expr), Expr);
783          end if;
784       end if;
785    end Check_Expr_OK_In_Limited_Aggregate;
786
787    ----------------------------------------
788    -- Check_Static_Discriminated_Subtype --
789    ----------------------------------------
790
791    procedure Check_Static_Discriminated_Subtype (T : Entity_Id; V : Node_Id) is
792       Disc : constant Entity_Id := First_Discriminant (T);
793       Comp : Entity_Id;
794       Ind  : Entity_Id;
795
796    begin
797       if Has_Record_Rep_Clause (T) then
798          return;
799
800       elsif Present (Next_Discriminant (Disc)) then
801          return;
802
803       elsif Nkind (V) /= N_Integer_Literal then
804          return;
805       end if;
806
807       Comp := First_Component (T);
808       while Present (Comp) loop
809          if Is_Scalar_Type (Etype (Comp)) then
810             null;
811
812          elsif Is_Private_Type (Etype (Comp))
813            and then Present (Full_View (Etype (Comp)))
814            and then Is_Scalar_Type (Full_View (Etype (Comp)))
815          then
816             null;
817
818          elsif Is_Array_Type (Etype (Comp)) then
819             if Is_Bit_Packed_Array (Etype (Comp)) then
820                return;
821             end if;
822
823             Ind := First_Index (Etype (Comp));
824             while Present (Ind) loop
825                if Nkind (Ind) /= N_Range
826                  or else Nkind (Low_Bound (Ind)) /= N_Integer_Literal
827                  or else Nkind (High_Bound (Ind)) /= N_Integer_Literal
828                then
829                   return;
830                end if;
831
832                Next_Index (Ind);
833             end loop;
834
835          else
836             return;
837          end if;
838
839          Next_Component (Comp);
840       end loop;
841
842       --  On exit, all components have statically known sizes
843
844       Set_Size_Known_At_Compile_Time (T);
845    end Check_Static_Discriminated_Subtype;
846
847    --------------------------------
848    -- Make_String_Into_Aggregate --
849    --------------------------------
850
851    procedure Make_String_Into_Aggregate (N : Node_Id) is
852       Exprs  : constant List_Id    := New_List;
853       Loc    : constant Source_Ptr := Sloc (N);
854       Str    : constant String_Id  := Strval (N);
855       Strlen : constant Nat        := String_Length (Str);
856       C      : Char_Code;
857       C_Node : Node_Id;
858       New_N  : Node_Id;
859       P      : Source_Ptr;
860
861    begin
862       P := Loc + 1;
863       for J in  1 .. Strlen loop
864          C := Get_String_Char (Str, J);
865          Set_Character_Literal_Name (C);
866
867          C_Node :=
868            Make_Character_Literal (P,
869              Chars              => Name_Find,
870              Char_Literal_Value => UI_From_CC (C));
871          Set_Etype (C_Node, Any_Character);
872          Append_To (Exprs, C_Node);
873
874          P := P + 1;
875          --  Something special for wide strings???
876       end loop;
877
878       New_N := Make_Aggregate (Loc, Expressions => Exprs);
879       Set_Analyzed (New_N);
880       Set_Etype (New_N, Any_Composite);
881
882       Rewrite (N, New_N);
883    end Make_String_Into_Aggregate;
884
885    -----------------------
886    -- Resolve_Aggregate --
887    -----------------------
888
889    procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is
890       Pkind : constant Node_Kind := Nkind (Parent (N));
891
892       Aggr_Subtyp : Entity_Id;
893       --  The actual aggregate subtype. This is not necessarily the same as Typ
894       --  which is the subtype of the context in which the aggregate was found.
895
896    begin
897       --  Ignore junk empty aggregate resulting from parser error
898
899       if No (Expressions (N))
900         and then No (Component_Associations (N))
901         and then not Null_Record_Present (N)
902       then
903          return;
904       end if;
905
906       --  Check for aggregates not allowed in configurable run-time mode.
907       --  We allow all cases of aggregates that do not come from source, since
908       --  these are all assumed to be small (e.g. bounds of a string literal).
909       --  We also allow aggregates of types we know to be small.
910
911       if not Support_Aggregates_On_Target
912         and then Comes_From_Source (N)
913         and then (not Known_Static_Esize (Typ) or else Esize (Typ) > 64)
914       then
915          Error_Msg_CRT ("aggregate", N);
916       end if;
917
918       --  Ada 2005 (AI-287): Limited aggregates allowed
919
920       if Is_Limited_Type (Typ) and then Ada_Version < Ada_05 then
921          Error_Msg_N ("aggregate type cannot be limited", N);
922          Explain_Limited_Type (Typ, N);
923
924       elsif Is_Class_Wide_Type (Typ) then
925          Error_Msg_N ("type of aggregate cannot be class-wide", N);
926
927       elsif Typ = Any_String
928         or else Typ = Any_Composite
929       then
930          Error_Msg_N ("no unique type for aggregate", N);
931          Set_Etype (N, Any_Composite);
932
933       elsif Is_Array_Type (Typ) and then Null_Record_Present (N) then
934          Error_Msg_N ("null record forbidden in array aggregate", N);
935
936       elsif Is_Record_Type (Typ) then
937          Resolve_Record_Aggregate (N, Typ);
938
939       elsif Is_Array_Type (Typ) then
940
941          --  First a special test, for the case of a positional aggregate
942          --  of characters which can be replaced by a string literal.
943
944          --  Do not perform this transformation if this was a string literal to
945          --  start with, whose components needed constraint checks, or if the
946          --  component type is non-static, because it will require those checks
947          --  and be transformed back into an aggregate.
948
949          if Number_Dimensions (Typ) = 1
950            and then Is_Standard_Character_Type (Component_Type (Typ))
951            and then No (Component_Associations (N))
952            and then not Is_Limited_Composite (Typ)
953            and then not Is_Private_Composite (Typ)
954            and then not Is_Bit_Packed_Array (Typ)
955            and then Nkind (Original_Node (Parent (N))) /= N_String_Literal
956            and then Is_Static_Subtype (Component_Type (Typ))
957          then
958             declare
959                Expr : Node_Id;
960
961             begin
962                Expr := First (Expressions (N));
963                while Present (Expr) loop
964                   exit when Nkind (Expr) /= N_Character_Literal;
965                   Next (Expr);
966                end loop;
967
968                if No (Expr) then
969                   Start_String;
970
971                   Expr := First (Expressions (N));
972                   while Present (Expr) loop
973                      Store_String_Char (UI_To_CC (Char_Literal_Value (Expr)));
974                      Next (Expr);
975                   end loop;
976
977                   Rewrite (N,
978                     Make_String_Literal (Sloc (N), End_String));
979
980                   Analyze_And_Resolve (N, Typ);
981                   return;
982                end if;
983             end;
984          end if;
985
986          --  Here if we have a real aggregate to deal with
987
988          Array_Aggregate : declare
989             Aggr_Resolved : Boolean;
990
991             Aggr_Typ : constant Entity_Id := Etype (Typ);
992             --  This is the unconstrained array type, which is the type against
993             --  which the aggregate is to be resolved. Typ itself is the array
994             --  type of the context which may not be the same subtype as the
995             --  subtype for the final aggregate.
996
997          begin
998             --  In the following we determine whether an others choice is
999             --  allowed inside the array aggregate. The test checks the context
1000             --  in which the array aggregate occurs. If the context does not
1001             --  permit it, or the aggregate type is unconstrained, an others
1002             --  choice is not allowed.
1003
1004             --  If expansion is disabled (generic context, or semantics-only
1005             --  mode) actual subtypes cannot be constructed, and the type of an
1006             --  object may be its unconstrained nominal type. However, if the
1007             --  context is an assignment, we assume that "others" is allowed,
1008             --  because the target of the assignment will have a constrained
1009             --  subtype when fully compiled.
1010
1011             --  Note that there is no node for Explicit_Actual_Parameter.
1012             --  To test for this context we therefore have to test for node
1013             --  N_Parameter_Association which itself appears only if there is a
1014             --  formal parameter. Consequently we also need to test for
1015             --  N_Procedure_Call_Statement or N_Function_Call.
1016
1017             Set_Etype (N, Aggr_Typ);  --  May be overridden later on
1018
1019             if Is_Constrained (Typ) and then
1020               (Pkind = N_Assignment_Statement      or else
1021                Pkind = N_Parameter_Association     or else
1022                Pkind = N_Function_Call             or else
1023                Pkind = N_Procedure_Call_Statement  or else
1024                Pkind = N_Generic_Association       or else
1025                Pkind = N_Formal_Object_Declaration or else
1026                Pkind = N_Simple_Return_Statement   or else
1027                Pkind = N_Object_Declaration        or else
1028                Pkind = N_Component_Declaration     or else
1029                Pkind = N_Parameter_Specification   or else
1030                Pkind = N_Qualified_Expression      or else
1031                Pkind = N_Aggregate                 or else
1032                Pkind = N_Extension_Aggregate       or else
1033                Pkind = N_Component_Association)
1034             then
1035                Aggr_Resolved :=
1036                  Resolve_Array_Aggregate
1037                    (N,
1038                     Index          => First_Index (Aggr_Typ),
1039                     Index_Constr   => First_Index (Typ),
1040                     Component_Typ  => Component_Type (Typ),
1041                     Others_Allowed => True);
1042
1043             elsif not Expander_Active
1044               and then Pkind = N_Assignment_Statement
1045             then
1046                Aggr_Resolved :=
1047                  Resolve_Array_Aggregate
1048                    (N,
1049                     Index          => First_Index (Aggr_Typ),
1050                     Index_Constr   => First_Index (Typ),
1051                     Component_Typ  => Component_Type (Typ),
1052                     Others_Allowed => True);
1053             else
1054                Aggr_Resolved :=
1055                  Resolve_Array_Aggregate
1056                    (N,
1057                     Index          => First_Index (Aggr_Typ),
1058                     Index_Constr   => First_Index (Aggr_Typ),
1059                     Component_Typ  => Component_Type (Typ),
1060                     Others_Allowed => False);
1061             end if;
1062
1063             if not Aggr_Resolved then
1064                Aggr_Subtyp := Any_Composite;
1065             else
1066                Aggr_Subtyp := Array_Aggr_Subtype (N, Typ);
1067             end if;
1068
1069             Set_Etype (N, Aggr_Subtyp);
1070          end Array_Aggregate;
1071
1072       elsif Is_Private_Type (Typ)
1073         and then Present (Full_View (Typ))
1074         and then In_Inlined_Body
1075         and then Is_Composite_Type (Full_View (Typ))
1076       then
1077          Resolve (N, Full_View (Typ));
1078
1079       else
1080          Error_Msg_N ("illegal context for aggregate", N);
1081       end if;
1082
1083       --  If we can determine statically that the evaluation of the aggregate
1084       --  raises Constraint_Error, then replace the aggregate with an
1085       --  N_Raise_Constraint_Error node, but set the Etype to the right
1086       --  aggregate subtype. Gigi needs this.
1087
1088       if Raises_Constraint_Error (N) then
1089          Aggr_Subtyp := Etype (N);
1090          Rewrite (N,
1091            Make_Raise_Constraint_Error (Sloc (N),
1092              Reason => CE_Range_Check_Failed));
1093          Set_Raises_Constraint_Error (N);
1094          Set_Etype (N, Aggr_Subtyp);
1095          Set_Analyzed (N);
1096       end if;
1097    end Resolve_Aggregate;
1098
1099    -----------------------------
1100    -- Resolve_Array_Aggregate --
1101    -----------------------------
1102
1103    function Resolve_Array_Aggregate
1104      (N              : Node_Id;
1105       Index          : Node_Id;
1106       Index_Constr   : Node_Id;
1107       Component_Typ  : Entity_Id;
1108       Others_Allowed : Boolean) return Boolean
1109    is
1110       Loc : constant Source_Ptr := Sloc (N);
1111
1112       Failure : constant Boolean := False;
1113       Success : constant Boolean := True;
1114
1115       Index_Typ      : constant Entity_Id := Etype (Index);
1116       Index_Typ_Low  : constant Node_Id   := Type_Low_Bound  (Index_Typ);
1117       Index_Typ_High : constant Node_Id   := Type_High_Bound (Index_Typ);
1118       --  The type of the index corresponding to the array sub-aggregate along
1119       --  with its low and upper bounds.
1120
1121       Index_Base      : constant Entity_Id := Base_Type (Index_Typ);
1122       Index_Base_Low  : constant Node_Id   := Type_Low_Bound (Index_Base);
1123       Index_Base_High : constant Node_Id   := Type_High_Bound (Index_Base);
1124       --  Ditto for the base type
1125
1126       function Add (Val : Uint; To : Node_Id) return Node_Id;
1127       --  Creates a new expression node where Val is added to expression To.
1128       --  Tries to constant fold whenever possible. To must be an already
1129       --  analyzed expression.
1130
1131       procedure Check_Bound (BH : Node_Id; AH : in out Node_Id);
1132       --  Checks that AH (the upper bound of an array aggregate) is <= BH
1133       --  (the upper bound of the index base type). If the check fails a
1134       --  warning is emitted, the Raises_Constraint_Error flag of N is set,
1135       --  and AH is replaced with a duplicate of BH.
1136
1137       procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id);
1138       --  Checks that range AL .. AH is compatible with range L .. H. Emits a
1139       --  warning if not and sets the Raises_Constraint_Error flag in N.
1140
1141       procedure Check_Length (L, H : Node_Id; Len : Uint);
1142       --  Checks that range L .. H contains at least Len elements. Emits a
1143       --  warning if not and sets the Raises_Constraint_Error flag in N.
1144
1145       function Dynamic_Or_Null_Range (L, H : Node_Id) return Boolean;
1146       --  Returns True if range L .. H is dynamic or null
1147
1148       procedure Get (Value : out Uint; From : Node_Id; OK : out Boolean);
1149       --  Given expression node From, this routine sets OK to False if it
1150       --  cannot statically evaluate From. Otherwise it stores this static
1151       --  value into Value.
1152
1153       function Resolve_Aggr_Expr
1154         (Expr        : Node_Id;
1155          Single_Elmt : Boolean) return Boolean;
1156       --  Resolves aggregate expression Expr. Returns False if resolution
1157       --  fails. If Single_Elmt is set to False, the expression Expr may be
1158       --  used to initialize several array aggregate elements (this can happen
1159       --  for discrete choices such as "L .. H => Expr" or the others choice).
1160       --  In this event we do not resolve Expr unless expansion is disabled.
1161       --  To know why, see the DELAYED COMPONENT RESOLUTION note above.
1162
1163       ---------
1164       -- Add --
1165       ---------
1166
1167       function Add (Val : Uint; To : Node_Id) return Node_Id is
1168          Expr_Pos : Node_Id;
1169          Expr     : Node_Id;
1170          To_Pos   : Node_Id;
1171
1172       begin
1173          if Raises_Constraint_Error (To) then
1174             return To;
1175          end if;
1176
1177          --  First test if we can do constant folding
1178
1179          if Compile_Time_Known_Value (To)
1180            or else Nkind (To) = N_Integer_Literal
1181          then
1182             Expr_Pos := Make_Integer_Literal (Loc, Expr_Value (To) + Val);
1183             Set_Is_Static_Expression (Expr_Pos);
1184             Set_Etype (Expr_Pos, Etype (To));
1185             Set_Analyzed (Expr_Pos, Analyzed (To));
1186
1187             if not Is_Enumeration_Type (Index_Typ) then
1188                Expr := Expr_Pos;
1189
1190             --  If we are dealing with enumeration return
1191             --     Index_Typ'Val (Expr_Pos)
1192
1193             else
1194                Expr :=
1195                  Make_Attribute_Reference
1196                    (Loc,
1197                     Prefix         => New_Reference_To (Index_Typ, Loc),
1198                     Attribute_Name => Name_Val,
1199                     Expressions    => New_List (Expr_Pos));
1200             end if;
1201
1202             return Expr;
1203          end if;
1204
1205          --  If we are here no constant folding possible
1206
1207          if not Is_Enumeration_Type (Index_Base) then
1208             Expr :=
1209               Make_Op_Add (Loc,
1210                            Left_Opnd  => Duplicate_Subexpr (To),
1211                            Right_Opnd => Make_Integer_Literal (Loc, Val));
1212
1213          --  If we are dealing with enumeration return
1214          --    Index_Typ'Val (Index_Typ'Pos (To) + Val)
1215
1216          else
1217             To_Pos :=
1218               Make_Attribute_Reference
1219                 (Loc,
1220                  Prefix         => New_Reference_To (Index_Typ, Loc),
1221                  Attribute_Name => Name_Pos,
1222                  Expressions    => New_List (Duplicate_Subexpr (To)));
1223
1224             Expr_Pos :=
1225               Make_Op_Add (Loc,
1226                            Left_Opnd  => To_Pos,
1227                            Right_Opnd => Make_Integer_Literal (Loc, Val));
1228
1229             Expr :=
1230               Make_Attribute_Reference
1231                 (Loc,
1232                  Prefix         => New_Reference_To (Index_Typ, Loc),
1233                  Attribute_Name => Name_Val,
1234                  Expressions    => New_List (Expr_Pos));
1235          end if;
1236
1237          return Expr;
1238       end Add;
1239
1240       -----------------
1241       -- Check_Bound --
1242       -----------------
1243
1244       procedure Check_Bound (BH : Node_Id; AH : in out Node_Id) is
1245          Val_BH : Uint;
1246          Val_AH : Uint;
1247
1248          OK_BH : Boolean;
1249          OK_AH : Boolean;
1250
1251       begin
1252          Get (Value => Val_BH, From => BH, OK => OK_BH);
1253          Get (Value => Val_AH, From => AH, OK => OK_AH);
1254
1255          if OK_BH and then OK_AH and then Val_BH < Val_AH then
1256             Set_Raises_Constraint_Error (N);
1257             Error_Msg_N ("upper bound out of range?", AH);
1258             Error_Msg_N ("\Constraint_Error will be raised at run time?", AH);
1259
1260             --  You need to set AH to BH or else in the case of enumerations
1261             --  indices we will not be able to resolve the aggregate bounds.
1262
1263             AH := Duplicate_Subexpr (BH);
1264          end if;
1265       end Check_Bound;
1266
1267       ------------------
1268       -- Check_Bounds --
1269       ------------------
1270
1271       procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id) is
1272          Val_L  : Uint;
1273          Val_H  : Uint;
1274          Val_AL : Uint;
1275          Val_AH : Uint;
1276
1277          OK_L : Boolean;
1278          OK_H : Boolean;
1279
1280          OK_AL : Boolean;
1281          OK_AH  : Boolean;
1282          pragma Warnings (Off, OK_AL);
1283          pragma Warnings (Off, OK_AH);
1284
1285       begin
1286          if Raises_Constraint_Error (N)
1287            or else Dynamic_Or_Null_Range (AL, AH)
1288          then
1289             return;
1290          end if;
1291
1292          Get (Value => Val_L, From => L, OK => OK_L);
1293          Get (Value => Val_H, From => H, OK => OK_H);
1294
1295          Get (Value => Val_AL, From => AL, OK => OK_AL);
1296          Get (Value => Val_AH, From => AH, OK => OK_AH);
1297
1298          if OK_L and then Val_L > Val_AL then
1299             Set_Raises_Constraint_Error (N);
1300             Error_Msg_N ("lower bound of aggregate out of range?", N);
1301             Error_Msg_N ("\Constraint_Error will be raised at run time?", N);
1302          end if;
1303
1304          if OK_H and then Val_H < Val_AH then
1305             Set_Raises_Constraint_Error (N);
1306             Error_Msg_N ("upper bound of aggregate out of range?", N);
1307             Error_Msg_N ("\Constraint_Error will be raised at run time?", N);
1308          end if;
1309       end Check_Bounds;
1310
1311       ------------------
1312       -- Check_Length --
1313       ------------------
1314
1315       procedure Check_Length (L, H : Node_Id; Len : Uint) is
1316          Val_L  : Uint;
1317          Val_H  : Uint;
1318
1319          OK_L  : Boolean;
1320          OK_H  : Boolean;
1321
1322          Range_Len : Uint;
1323
1324       begin
1325          if Raises_Constraint_Error (N) then
1326             return;
1327          end if;
1328
1329          Get (Value => Val_L, From => L, OK => OK_L);
1330          Get (Value => Val_H, From => H, OK => OK_H);
1331
1332          if not OK_L or else not OK_H then
1333             return;
1334          end if;
1335
1336          --  If null range length is zero
1337
1338          if Val_L > Val_H then
1339             Range_Len := Uint_0;
1340          else
1341             Range_Len := Val_H - Val_L + 1;
1342          end if;
1343
1344          if Range_Len < Len then
1345             Set_Raises_Constraint_Error (N);
1346             Error_Msg_N ("too many elements?", N);
1347             Error_Msg_N ("\Constraint_Error will be raised at run time?", N);
1348          end if;
1349       end Check_Length;
1350
1351       ---------------------------
1352       -- Dynamic_Or_Null_Range --
1353       ---------------------------
1354
1355       function Dynamic_Or_Null_Range (L, H : Node_Id) return Boolean is
1356          Val_L : Uint;
1357          Val_H : Uint;
1358
1359          OK_L  : Boolean;
1360          OK_H  : Boolean;
1361
1362       begin
1363          Get (Value => Val_L, From => L, OK => OK_L);
1364          Get (Value => Val_H, From => H, OK => OK_H);
1365
1366          return not OK_L or else not OK_H
1367            or else not Is_OK_Static_Expression (L)
1368            or else not Is_OK_Static_Expression (H)
1369            or else Val_L > Val_H;
1370       end Dynamic_Or_Null_Range;
1371
1372       ---------
1373       -- Get --
1374       ---------
1375
1376       procedure Get (Value : out Uint; From : Node_Id; OK : out Boolean) is
1377       begin
1378          OK := True;
1379
1380          if Compile_Time_Known_Value (From) then
1381             Value := Expr_Value (From);
1382
1383          --  If expression From is something like Some_Type'Val (10) then
1384          --  Value = 10
1385
1386          elsif Nkind (From) = N_Attribute_Reference
1387            and then Attribute_Name (From) = Name_Val
1388            and then Compile_Time_Known_Value (First (Expressions (From)))
1389          then
1390             Value := Expr_Value (First (Expressions (From)));
1391
1392          else
1393             Value := Uint_0;
1394             OK := False;
1395          end if;
1396       end Get;
1397
1398       -----------------------
1399       -- Resolve_Aggr_Expr --
1400       -----------------------
1401
1402       function Resolve_Aggr_Expr
1403         (Expr        : Node_Id;
1404          Single_Elmt : Boolean) return Boolean
1405       is
1406          Nxt_Ind        : constant Node_Id := Next_Index (Index);
1407          Nxt_Ind_Constr : constant Node_Id := Next_Index (Index_Constr);
1408          --  Index is the current index corresponding to the expression
1409
1410          Resolution_OK : Boolean := True;
1411          --  Set to False if resolution of the expression failed
1412
1413       begin
1414          --  Defend against previous errors
1415
1416          if Nkind (Expr) = N_Error
1417            or else Error_Posted (Expr)
1418          then
1419             return True;
1420          end if;
1421
1422          --  If the array type against which we are resolving the aggregate
1423          --  has several dimensions, the expressions nested inside the
1424          --  aggregate must be further aggregates (or strings).
1425
1426          if Present (Nxt_Ind) then
1427             if Nkind (Expr) /= N_Aggregate then
1428
1429                --  A string literal can appear where a one-dimensional array
1430                --  of characters is expected. If the literal looks like an
1431                --  operator, it is still an operator symbol, which will be
1432                --  transformed into a string when analyzed.
1433
1434                if Is_Character_Type (Component_Typ)
1435                  and then No (Next_Index (Nxt_Ind))
1436                  and then Nkind_In (Expr, N_String_Literal, N_Operator_Symbol)
1437                then
1438                   --  A string literal used in a multidimensional array
1439                   --  aggregate in place of the final one-dimensional
1440                   --  aggregate must not be enclosed in parentheses.
1441
1442                   if Paren_Count (Expr) /= 0 then
1443                      Error_Msg_N ("no parenthesis allowed here", Expr);
1444                   end if;
1445
1446                   Make_String_Into_Aggregate (Expr);
1447
1448                else
1449                   Error_Msg_N ("nested array aggregate expected", Expr);
1450
1451                   --  If the expression is parenthesized, this may be
1452                   --  a missing component association for a 1-aggregate.
1453
1454                   if Paren_Count (Expr) > 0 then
1455                      Error_Msg_N
1456                        ("\if single-component aggregate is intended,"
1457                         & " write e.g. (1 ='> ...)", Expr);
1458                   end if;
1459                   return Failure;
1460                end if;
1461             end if;
1462
1463             --  Ada 2005 (AI-231): Propagate the type to the nested aggregate.
1464             --  Required to check the null-exclusion attribute (if present).
1465             --  This value may be overridden later on.
1466
1467             Set_Etype (Expr, Etype (N));
1468
1469             Resolution_OK := Resolve_Array_Aggregate
1470               (Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ, Others_Allowed);
1471
1472          --  Do not resolve the expressions of discrete or others choices
1473          --  unless the expression covers a single component, or the expander
1474          --  is inactive.
1475
1476          elsif Single_Elmt
1477            or else not Expander_Active
1478            or else In_Spec_Expression
1479          then
1480             Analyze_And_Resolve (Expr, Component_Typ);
1481             Check_Expr_OK_In_Limited_Aggregate (Expr);
1482             Check_Non_Static_Context (Expr);
1483             Aggregate_Constraint_Checks (Expr, Component_Typ);
1484             Check_Unset_Reference (Expr);
1485          end if;
1486
1487          if Raises_Constraint_Error (Expr)
1488            and then Nkind (Parent (Expr)) /= N_Component_Association
1489          then
1490             Set_Raises_Constraint_Error (N);
1491          end if;
1492
1493          --  If the expression has been marked as requiring a range check,
1494          --  then generate it here.
1495
1496          if Do_Range_Check (Expr) then
1497             Set_Do_Range_Check (Expr, False);
1498             Generate_Range_Check (Expr, Component_Typ, CE_Range_Check_Failed);
1499          end if;
1500
1501          return Resolution_OK;
1502       end Resolve_Aggr_Expr;
1503
1504       --  Variables local to Resolve_Array_Aggregate
1505
1506       Assoc   : Node_Id;
1507       Choice  : Node_Id;
1508       Expr    : Node_Id;
1509
1510       Discard : Node_Id;
1511       pragma Warnings (Off, Discard);
1512
1513       Aggr_Low  : Node_Id := Empty;
1514       Aggr_High : Node_Id := Empty;
1515       --  The actual low and high bounds of this sub-aggregate
1516
1517       Choices_Low  : Node_Id := Empty;
1518       Choices_High : Node_Id := Empty;
1519       --  The lowest and highest discrete choices values for a named aggregate
1520
1521       Nb_Elements : Uint := Uint_0;
1522       --  The number of elements in a positional aggregate
1523
1524       Others_Present : Boolean := False;
1525
1526       Nb_Choices : Nat := 0;
1527       --  Contains the overall number of named choices in this sub-aggregate
1528
1529       Nb_Discrete_Choices : Nat := 0;
1530       --  The overall number of discrete choices (not counting others choice)
1531
1532       Case_Table_Size : Nat;
1533       --  Contains the size of the case table needed to sort aggregate choices
1534
1535    --  Start of processing for Resolve_Array_Aggregate
1536
1537    begin
1538       --  Ignore junk empty aggregate resulting from parser error
1539
1540       if No (Expressions (N))
1541         and then No (Component_Associations (N))
1542         and then not Null_Record_Present (N)
1543       then
1544          return False;
1545       end if;
1546
1547       --  STEP 1: make sure the aggregate is correctly formatted
1548
1549       if Present (Component_Associations (N)) then
1550          Assoc := First (Component_Associations (N));
1551          while Present (Assoc) loop
1552             Choice := First (Choices (Assoc));
1553             while Present (Choice) loop
1554                if Nkind (Choice) = N_Others_Choice then
1555                   Others_Present := True;
1556
1557                   if Choice /= First (Choices (Assoc))
1558                     or else Present (Next (Choice))
1559                   then
1560                      Error_Msg_N
1561                        ("OTHERS must appear alone in a choice list", Choice);
1562                      return Failure;
1563                   end if;
1564
1565                   if Present (Next (Assoc)) then
1566                      Error_Msg_N
1567                        ("OTHERS must appear last in an aggregate", Choice);
1568                      return Failure;
1569                   end if;
1570
1571                   if Ada_Version = Ada_83
1572                     and then Assoc /= First (Component_Associations (N))
1573                     and then Nkind_In (Parent (N), N_Assignment_Statement,
1574                                                    N_Object_Declaration)
1575                   then
1576                      Error_Msg_N
1577                        ("(Ada 83) illegal context for OTHERS choice", N);
1578                   end if;
1579                end if;
1580
1581                Nb_Choices := Nb_Choices + 1;
1582                Next (Choice);
1583             end loop;
1584
1585             Next (Assoc);
1586          end loop;
1587       end if;
1588
1589       --  At this point we know that the others choice, if present, is by
1590       --  itself and appears last in the aggregate. Check if we have mixed
1591       --  positional and discrete associations (other than the others choice).
1592
1593       if Present (Expressions (N))
1594         and then (Nb_Choices > 1
1595                    or else (Nb_Choices = 1 and then not Others_Present))
1596       then
1597          Error_Msg_N
1598            ("named association cannot follow positional association",
1599             First (Choices (First (Component_Associations (N)))));
1600          return Failure;
1601       end if;
1602
1603       --  Test for the validity of an others choice if present
1604
1605       if Others_Present and then not Others_Allowed then
1606          Error_Msg_N
1607            ("OTHERS choice not allowed here",
1608             First (Choices (First (Component_Associations (N)))));
1609          return Failure;
1610       end if;
1611
1612       --  Protect against cascaded errors
1613
1614       if Etype (Index_Typ) = Any_Type then
1615          return Failure;
1616       end if;
1617
1618       --  STEP 2: Process named components
1619
1620       if No (Expressions (N)) then
1621          if Others_Present then
1622             Case_Table_Size := Nb_Choices - 1;
1623          else
1624             Case_Table_Size := Nb_Choices;
1625          end if;
1626
1627          Step_2 : declare
1628             Low  : Node_Id;
1629             High : Node_Id;
1630             --  Denote the lowest and highest values in an aggregate choice
1631
1632             Hi_Val : Uint;
1633             Lo_Val : Uint;
1634             --  High end of one range and Low end of the next. Should be
1635             --  contiguous if there is no hole in the list of values.
1636
1637             Missing_Values : Boolean;
1638             --  Set True if missing index values
1639
1640             S_Low  : Node_Id := Empty;
1641             S_High : Node_Id := Empty;
1642             --  if a choice in an aggregate is a subtype indication these
1643             --  denote the lowest and highest values of the subtype
1644
1645             Table : Case_Table_Type (1 .. Case_Table_Size);
1646             --  Used to sort all the different choice values
1647
1648             Single_Choice : Boolean;
1649             --  Set to true every time there is a single discrete choice in a
1650             --  discrete association
1651
1652             Prev_Nb_Discrete_Choices : Nat;
1653             --  Used to keep track of the number of discrete choices in the
1654             --  current association.
1655
1656          begin
1657             --  STEP 2 (A): Check discrete choices validity
1658
1659             Assoc := First (Component_Associations (N));
1660             while Present (Assoc) loop
1661                Prev_Nb_Discrete_Choices := Nb_Discrete_Choices;
1662                Choice := First (Choices (Assoc));
1663                loop
1664                   Analyze (Choice);
1665
1666                   if Nkind (Choice) = N_Others_Choice then
1667                      Single_Choice := False;
1668                      exit;
1669
1670                   --  Test for subtype mark without constraint
1671
1672                   elsif Is_Entity_Name (Choice) and then
1673                     Is_Type (Entity (Choice))
1674                   then
1675                      if Base_Type (Entity (Choice)) /= Index_Base then
1676                         Error_Msg_N
1677                           ("invalid subtype mark in aggregate choice",
1678                            Choice);
1679                         return Failure;
1680                      end if;
1681
1682                   --  Case of subtype indication
1683
1684                   elsif Nkind (Choice) = N_Subtype_Indication then
1685                      Resolve_Discrete_Subtype_Indication (Choice, Index_Base);
1686
1687                      --  Does the subtype indication evaluation raise CE ?
1688
1689                      Get_Index_Bounds (Subtype_Mark (Choice), S_Low, S_High);
1690                      Get_Index_Bounds (Choice, Low, High);
1691                      Check_Bounds (S_Low, S_High, Low, High);
1692
1693                   --  Case of range or expression
1694
1695                   else
1696                      Resolve (Choice, Index_Base);
1697                      Check_Unset_Reference (Choice);
1698                      Check_Non_Static_Context (Choice);
1699
1700                      --  Do not range check a choice. This check is redundant
1701                      --  since this test is already done when we check that the
1702                      --  bounds of the array aggregate are within range.
1703
1704                      Set_Do_Range_Check (Choice, False);
1705                   end if;
1706
1707                   --  If we could not resolve the discrete choice stop here
1708
1709                   if Etype (Choice) = Any_Type then
1710                      return Failure;
1711
1712                   --  If the discrete choice raises CE get its original bounds
1713
1714                   elsif Nkind (Choice) = N_Raise_Constraint_Error then
1715                      Set_Raises_Constraint_Error (N);
1716                      Get_Index_Bounds (Original_Node (Choice), Low, High);
1717
1718                   --  Otherwise get its bounds as usual
1719
1720                   else
1721                      Get_Index_Bounds (Choice, Low, High);
1722                   end if;
1723
1724                   if (Dynamic_Or_Null_Range (Low, High)
1725                        or else (Nkind (Choice) = N_Subtype_Indication
1726                                  and then
1727                                    Dynamic_Or_Null_Range (S_Low, S_High)))
1728                     and then Nb_Choices /= 1
1729                   then
1730                      Error_Msg_N
1731                        ("dynamic or empty choice in aggregate " &
1732                         "must be the only choice", Choice);
1733                      return Failure;
1734                   end if;
1735
1736                   Nb_Discrete_Choices := Nb_Discrete_Choices + 1;
1737                   Table (Nb_Discrete_Choices).Choice_Lo := Low;
1738                   Table (Nb_Discrete_Choices).Choice_Hi := High;
1739
1740                   Next (Choice);
1741
1742                   if No (Choice) then
1743
1744                      --  Check if we have a single discrete choice and whether
1745                      --  this discrete choice specifies a single value.
1746
1747                      Single_Choice :=
1748                        (Nb_Discrete_Choices = Prev_Nb_Discrete_Choices + 1)
1749                          and then (Low = High);
1750
1751                      exit;
1752                   end if;
1753                end loop;
1754
1755                --  Ada 2005 (AI-231)
1756
1757                if Ada_Version >= Ada_05
1758                  and then Known_Null (Expression (Assoc))
1759                then
1760                   Check_Can_Never_Be_Null (Etype (N), Expression (Assoc));
1761                end if;
1762
1763                --  Ada 2005 (AI-287): In case of default initialized component
1764                --  we delay the resolution to the expansion phase.
1765
1766                if Box_Present (Assoc) then
1767
1768                   --  Ada 2005 (AI-287): In case of default initialization of a
1769                   --  component the expander will generate calls to the
1770                   --  corresponding initialization subprogram.
1771
1772                   null;
1773
1774                elsif not Resolve_Aggr_Expr (Expression (Assoc),
1775                                             Single_Elmt => Single_Choice)
1776                then
1777                   return Failure;
1778
1779                --  Check incorrect use of dynamically tagged expression
1780
1781                --  We differentiate here two cases because the expression may
1782                --  not be decorated. For example, the analysis and resolution
1783                --  of the expression associated with the others choice will be
1784                --  done later with the full aggregate. In such case we
1785                --  duplicate the expression tree to analyze the copy and
1786                --  perform the required check.
1787
1788                elsif not Present (Etype (Expression (Assoc))) then
1789                   declare
1790                      Save_Analysis : constant Boolean := Full_Analysis;
1791                      Expr          : constant Node_Id :=
1792                                        New_Copy_Tree (Expression (Assoc));
1793
1794                   begin
1795                      Expander_Mode_Save_And_Set (False);
1796                      Full_Analysis := False;
1797                      Analyze (Expr);
1798
1799                      --  If the expression is a literal, propagate this info
1800                      --  to the expression in the association, to enable some
1801                      --  optimizations downstream.
1802
1803                      if Is_Entity_Name (Expr)
1804                        and then Present (Entity (Expr))
1805                        and then Ekind (Entity (Expr)) = E_Enumeration_Literal
1806                      then
1807                         Analyze_And_Resolve
1808                           (Expression (Assoc), Component_Typ);
1809                      end if;
1810
1811                      Full_Analysis := Save_Analysis;
1812                      Expander_Mode_Restore;
1813
1814                      if Is_Tagged_Type (Etype (Expr)) then
1815                         Check_Dynamically_Tagged_Expression
1816                           (Expr => Expr,
1817                            Typ  => Component_Type (Etype (N)),
1818                            Related_Nod => N);
1819                      end if;
1820                   end;
1821
1822                elsif Is_Tagged_Type (Etype (Expression (Assoc))) then
1823                   Check_Dynamically_Tagged_Expression
1824                     (Expr        => Expression (Assoc),
1825                      Typ         => Component_Type (Etype (N)),
1826                      Related_Nod => N);
1827                end if;
1828
1829                Next (Assoc);
1830             end loop;
1831
1832             --  If aggregate contains more than one choice then these must be
1833             --  static. Sort them and check that they are contiguous.
1834
1835             if Nb_Discrete_Choices > 1 then
1836                Sort_Case_Table (Table);
1837                Missing_Values := False;
1838
1839                Outer : for J in 1 .. Nb_Discrete_Choices - 1 loop
1840                   if Expr_Value (Table (J).Choice_Hi) >=
1841                        Expr_Value (Table (J + 1).Choice_Lo)
1842                   then
1843                      Error_Msg_N
1844                        ("duplicate choice values in array aggregate",
1845                         Table (J).Choice_Hi);
1846                      return Failure;
1847
1848                   elsif not Others_Present then
1849                      Hi_Val := Expr_Value (Table (J).Choice_Hi);
1850                      Lo_Val := Expr_Value (Table (J + 1).Choice_Lo);
1851
1852                      --  If missing values, output error messages
1853
1854                      if Lo_Val - Hi_Val > 1 then
1855
1856                         --  Header message if not first missing value
1857
1858                         if not Missing_Values then
1859                            Error_Msg_N
1860                              ("missing index value(s) in array aggregate", N);
1861                            Missing_Values := True;
1862                         end if;
1863
1864                         --  Output values of missing indexes
1865
1866                         Lo_Val := Lo_Val - 1;
1867                         Hi_Val := Hi_Val + 1;
1868
1869                         --  Enumeration type case
1870
1871                         if Is_Enumeration_Type (Index_Typ) then
1872                            Error_Msg_Name_1 :=
1873                              Chars
1874                                (Get_Enum_Lit_From_Pos
1875                                  (Index_Typ, Hi_Val, Loc));
1876
1877                            if Lo_Val = Hi_Val then
1878                               Error_Msg_N ("\  %", N);
1879                            else
1880                               Error_Msg_Name_2 :=
1881                                 Chars
1882                                   (Get_Enum_Lit_From_Pos
1883                                     (Index_Typ, Lo_Val, Loc));
1884                               Error_Msg_N ("\  % .. %", N);
1885                            end if;
1886
1887                         --  Integer types case
1888
1889                         else
1890                            Error_Msg_Uint_1 := Hi_Val;
1891
1892                            if Lo_Val = Hi_Val then
1893                               Error_Msg_N ("\  ^", N);
1894                            else
1895                               Error_Msg_Uint_2 := Lo_Val;
1896                               Error_Msg_N ("\  ^ .. ^", N);
1897                            end if;
1898                         end if;
1899                      end if;
1900                   end if;
1901                end loop Outer;
1902
1903                if Missing_Values then
1904                   Set_Etype (N, Any_Composite);
1905                   return Failure;
1906                end if;
1907             end if;
1908
1909             --  STEP 2 (B): Compute aggregate bounds and min/max choices values
1910
1911             if Nb_Discrete_Choices > 0 then
1912                Choices_Low  := Table (1).Choice_Lo;
1913                Choices_High := Table (Nb_Discrete_Choices).Choice_Hi;
1914             end if;
1915
1916             --  If Others is present, then bounds of aggregate come from the
1917             --  index constraint (not the choices in the aggregate itself).
1918
1919             if Others_Present then
1920                Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
1921
1922             --  No others clause present
1923
1924             else
1925                --  Special processing if others allowed and not present. This
1926                --  means that the bounds of the aggregate come from the index
1927                --  constraint (and the length must match).
1928
1929                if Others_Allowed then
1930                   Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
1931
1932                   --  If others allowed, and no others present, then the array
1933                   --  should cover all index values. If it does not, we will
1934                   --  get a length check warning, but there is two cases where
1935                   --  an additional warning is useful:
1936
1937                   --  If we have no positional components, and the length is
1938                   --  wrong (which we can tell by others being allowed with
1939                   --  missing components), and the index type is an enumeration
1940                   --  type, then issue appropriate warnings about these missing
1941                   --  components. They are only warnings, since the aggregate
1942                   --  is fine, it's just the wrong length. We skip this check
1943                   --  for standard character types (since there are no literals
1944                   --  and it is too much trouble to concoct them), and also if
1945                   --  any of the bounds have not-known-at-compile-time values.
1946
1947                   --  Another case warranting a warning is when the length is
1948                   --  right, but as above we have an index type that is an
1949                   --  enumeration, and the bounds do not match. This is a
1950                   --  case where dubious sliding is allowed and we generate
1951                   --  a warning that the bounds do not match.
1952
1953                   if No (Expressions (N))
1954                     and then Nkind (Index) = N_Range
1955                     and then Is_Enumeration_Type (Etype (Index))
1956                     and then not Is_Standard_Character_Type (Etype (Index))
1957                     and then Compile_Time_Known_Value (Aggr_Low)
1958                     and then Compile_Time_Known_Value (Aggr_High)
1959                     and then Compile_Time_Known_Value (Choices_Low)
1960                     and then Compile_Time_Known_Value (Choices_High)
1961                   then
1962                      --  If the bounds have semantic errors, do not attempt
1963                      --  further resolution to prevent cascaded errors.
1964
1965                      if Error_Posted (Choices_Low)
1966                        or else Error_Posted (Choices_High)
1967                      then
1968                         return False;
1969                      end if;
1970
1971                      declare
1972                         ALo : constant Node_Id := Expr_Value_E (Aggr_Low);
1973                         AHi : constant Node_Id := Expr_Value_E (Aggr_High);
1974                         CLo : constant Node_Id := Expr_Value_E (Choices_Low);
1975                         CHi : constant Node_Id := Expr_Value_E (Choices_High);
1976
1977                         Ent : Entity_Id;
1978
1979                      begin
1980                         --  Warning case 1, missing values at start/end. Only
1981                         --  do the check if the number of entries is too small.
1982
1983                         if (Enumeration_Pos (CHi) - Enumeration_Pos (CLo))
1984                               <
1985                            (Enumeration_Pos (AHi) - Enumeration_Pos (ALo))
1986                         then
1987                            Error_Msg_N
1988                              ("missing index value(s) in array aggregate?", N);
1989
1990                            --  Output missing value(s) at start
1991
1992                            if Chars (ALo) /= Chars (CLo) then
1993                               Ent := Prev (CLo);
1994
1995                               if Chars (ALo) = Chars (Ent) then
1996                                  Error_Msg_Name_1 := Chars (ALo);
1997                                  Error_Msg_N ("\  %?", N);
1998                               else
1999                                  Error_Msg_Name_1 := Chars (ALo);
2000                                  Error_Msg_Name_2 := Chars (Ent);
2001                                  Error_Msg_N ("\  % .. %?", N);
2002                               end if;
2003                            end if;
2004
2005                            --  Output missing value(s) at end
2006
2007                            if Chars (AHi) /= Chars (CHi) then
2008                               Ent := Next (CHi);
2009
2010                               if Chars (AHi) = Chars (Ent) then
2011                                  Error_Msg_Name_1 := Chars (Ent);
2012                                  Error_Msg_N ("\  %?", N);
2013                               else
2014                                  Error_Msg_Name_1 := Chars (Ent);
2015                                  Error_Msg_Name_2 := Chars (AHi);
2016                                  Error_Msg_N ("\  % .. %?", N);
2017                               end if;
2018                            end if;
2019
2020                         --  Warning case 2, dubious sliding. The First_Subtype
2021                         --  test distinguishes between a constrained type where
2022                         --  sliding is not allowed (so we will get a warning
2023                         --  later that Constraint_Error will be raised), and
2024                         --  the unconstrained case where sliding is permitted.
2025
2026                         elsif (Enumeration_Pos (CHi) - Enumeration_Pos (CLo))
2027                                  =
2028                               (Enumeration_Pos (AHi) - Enumeration_Pos (ALo))
2029                           and then Chars (ALo) /= Chars (CLo)
2030                           and then
2031                             not Is_Constrained (First_Subtype (Etype (N)))
2032                         then
2033                            Error_Msg_N
2034                              ("bounds of aggregate do not match target?", N);
2035                         end if;
2036                      end;
2037                   end if;
2038                end if;
2039
2040                --  If no others, aggregate bounds come from aggregate
2041
2042                Aggr_Low  := Choices_Low;
2043                Aggr_High := Choices_High;
2044             end if;
2045          end Step_2;
2046
2047       --  STEP 3: Process positional components
2048
2049       else
2050          --  STEP 3 (A): Process positional elements
2051
2052          Expr := First (Expressions (N));
2053          Nb_Elements := Uint_0;
2054          while Present (Expr) loop
2055             Nb_Elements := Nb_Elements + 1;
2056
2057             --  Ada 2005 (AI-231)
2058
2059             if Ada_Version >= Ada_05
2060               and then Known_Null (Expr)
2061             then
2062                Check_Can_Never_Be_Null (Etype (N), Expr);
2063             end if;
2064
2065             if not Resolve_Aggr_Expr (Expr, Single_Elmt => True) then
2066                return Failure;
2067             end if;
2068
2069             --  Check incorrect use of dynamically tagged expression
2070
2071             if Is_Tagged_Type (Etype (Expr)) then
2072                Check_Dynamically_Tagged_Expression
2073                  (Expr => Expr,
2074                   Typ  => Component_Type (Etype (N)),
2075                   Related_Nod => N);
2076             end if;
2077
2078             Next (Expr);
2079          end loop;
2080
2081          if Others_Present then
2082             Assoc := Last (Component_Associations (N));
2083
2084             --  Ada 2005 (AI-231)
2085
2086             if Ada_Version >= Ada_05
2087               and then Known_Null (Assoc)
2088             then
2089                Check_Can_Never_Be_Null (Etype (N), Expression (Assoc));
2090             end if;
2091
2092             --  Ada 2005 (AI-287): In case of default initialized component,
2093             --  we delay the resolution to the expansion phase.
2094
2095             if Box_Present (Assoc) then
2096
2097                --  Ada 2005 (AI-287): In case of default initialization of a
2098                --  component the expander will generate calls to the
2099                --  corresponding initialization subprogram.
2100
2101                null;
2102
2103             elsif not Resolve_Aggr_Expr (Expression (Assoc),
2104                                          Single_Elmt => False)
2105             then
2106                return Failure;
2107
2108             --  Check incorrect use of dynamically tagged expression. The
2109             --  expression of the others choice has not been resolved yet.
2110             --  In order to diagnose the semantic error we create a duplicate
2111             --  tree to analyze it and perform the check.
2112
2113             else
2114                declare
2115                   Save_Analysis : constant Boolean := Full_Analysis;
2116                   Expr          : constant Node_Id :=
2117                                     New_Copy_Tree (Expression (Assoc));
2118
2119                begin
2120                   Expander_Mode_Save_And_Set (False);
2121                   Full_Analysis := False;
2122                   Analyze (Expr);
2123                   Full_Analysis := Save_Analysis;
2124                   Expander_Mode_Restore;
2125
2126                   if Is_Tagged_Type (Etype (Expr)) then
2127                      Check_Dynamically_Tagged_Expression
2128                        (Expr => Expr,
2129                         Typ  => Component_Type (Etype (N)),
2130                         Related_Nod => N);
2131                   end if;
2132                end;
2133             end if;
2134          end if;
2135
2136          --  STEP 3 (B): Compute the aggregate bounds
2137
2138          if Others_Present then
2139             Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
2140
2141          else
2142             if Others_Allowed then
2143                Get_Index_Bounds (Index_Constr, Aggr_Low, Discard);
2144             else
2145                Aggr_Low := Index_Typ_Low;
2146             end if;
2147
2148             Aggr_High := Add (Nb_Elements - 1, To => Aggr_Low);
2149             Check_Bound (Index_Base_High, Aggr_High);
2150          end if;
2151       end if;
2152
2153       --  STEP 4: Perform static aggregate checks and save the bounds
2154
2155       --  Check (A)
2156
2157       Check_Bounds (Index_Typ_Low, Index_Typ_High, Aggr_Low, Aggr_High);
2158       Check_Bounds (Index_Base_Low, Index_Base_High, Aggr_Low, Aggr_High);
2159
2160       --  Check (B)
2161
2162       if Others_Present and then Nb_Discrete_Choices > 0 then
2163          Check_Bounds (Aggr_Low, Aggr_High, Choices_Low, Choices_High);
2164          Check_Bounds (Index_Typ_Low, Index_Typ_High,
2165                        Choices_Low, Choices_High);
2166          Check_Bounds (Index_Base_Low, Index_Base_High,
2167                        Choices_Low, Choices_High);
2168
2169       --  Check (C)
2170
2171       elsif Others_Present and then Nb_Elements > 0 then
2172          Check_Length (Aggr_Low, Aggr_High, Nb_Elements);
2173          Check_Length (Index_Typ_Low, Index_Typ_High, Nb_Elements);
2174          Check_Length (Index_Base_Low, Index_Base_High, Nb_Elements);
2175       end if;
2176
2177       if Raises_Constraint_Error (Aggr_Low)
2178         or else Raises_Constraint_Error (Aggr_High)
2179       then
2180          Set_Raises_Constraint_Error (N);
2181       end if;
2182
2183       Aggr_Low := Duplicate_Subexpr (Aggr_Low);
2184
2185       --  Do not duplicate Aggr_High if Aggr_High = Aggr_Low + Nb_Elements
2186       --  since the addition node returned by Add is not yet analyzed. Attach
2187       --  to tree and analyze first. Reset analyzed flag to ensure it will get
2188       --  analyzed when it is a literal bound whose type must be properly set.
2189
2190       if Others_Present or else Nb_Discrete_Choices > 0 then
2191          Aggr_High := Duplicate_Subexpr (Aggr_High);
2192
2193          if Etype (Aggr_High) = Universal_Integer then
2194             Set_Analyzed (Aggr_High, False);
2195          end if;
2196       end if;
2197
2198       --  If the aggregate already has bounds attached to it, it means this is
2199       --  a positional aggregate created as an optimization by
2200       --  Exp_Aggr.Convert_To_Positional, so we don't want to change those
2201       --  bounds.
2202
2203       if Present (Aggregate_Bounds (N)) and then not Others_Allowed then
2204          Aggr_Low  := Low_Bound  (Aggregate_Bounds (N));
2205          Aggr_High := High_Bound (Aggregate_Bounds (N));
2206       end if;
2207
2208       Set_Aggregate_Bounds
2209         (N, Make_Range (Loc, Low_Bound => Aggr_Low, High_Bound => Aggr_High));
2210
2211       --  The bounds may contain expressions that must be inserted upwards.
2212       --  Attach them fully to the tree. After analysis, remove side effects
2213       --  from upper bound, if still needed.
2214
2215       Set_Parent (Aggregate_Bounds (N), N);
2216       Analyze_And_Resolve (Aggregate_Bounds (N), Index_Typ);
2217       Check_Unset_Reference (Aggregate_Bounds (N));
2218
2219       if not Others_Present and then Nb_Discrete_Choices = 0 then
2220          Set_High_Bound (Aggregate_Bounds (N),
2221              Duplicate_Subexpr (High_Bound (Aggregate_Bounds (N))));
2222       end if;
2223
2224       return Success;
2225    end Resolve_Array_Aggregate;
2226
2227    ---------------------------------
2228    -- Resolve_Extension_Aggregate --
2229    ---------------------------------
2230
2231    --  There are two cases to consider:
2232
2233    --  a) If the ancestor part is a type mark, the components needed are the
2234    --  difference between the components of the expected type and the
2235    --  components of the given type mark.
2236
2237    --  b) If the ancestor part is an expression, it must be unambiguous, and
2238    --  once we have its type we can also compute the needed  components as in
2239    --  the previous case. In both cases, if the ancestor type is not the
2240    --  immediate ancestor, we have to build this ancestor recursively.
2241
2242    --  In both cases discriminants of the ancestor type do not play a role in
2243    --  the resolution of the needed components, because inherited discriminants
2244    --  cannot be used in a type extension. As a result we can compute
2245    --  independently the list of components of the ancestor type and of the
2246    --  expected type.
2247
2248    procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id) is
2249       A      : constant Node_Id := Ancestor_Part (N);
2250       A_Type : Entity_Id;
2251       I      : Interp_Index;
2252       It     : Interp;
2253
2254       function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean;
2255       --  If the type is limited, verify that the ancestor part is a legal
2256       --  expression (aggregate or function call, including 'Input)) that does
2257       --  not require a copy, as specified in 7.5(2).
2258
2259       function Valid_Ancestor_Type return Boolean;
2260       --  Verify that the type of the ancestor part is a non-private ancestor
2261       --  of the expected type, which must be a type extension.
2262
2263       ----------------------------
2264       -- Valid_Limited_Ancestor --
2265       ----------------------------
2266
2267       function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean is
2268       begin
2269          if Is_Entity_Name (Anc)
2270            and then Is_Type (Entity (Anc))
2271          then
2272             return True;
2273
2274          elsif Nkind_In (Anc, N_Aggregate, N_Function_Call) then
2275             return True;
2276
2277          elsif Nkind (Anc) = N_Attribute_Reference
2278            and then Attribute_Name (Anc) = Name_Input
2279          then
2280             return True;
2281
2282          elsif Nkind (Anc) = N_Qualified_Expression then
2283             return Valid_Limited_Ancestor (Expression (Anc));
2284
2285          else
2286             return False;
2287          end if;
2288       end Valid_Limited_Ancestor;
2289
2290       -------------------------
2291       -- Valid_Ancestor_Type --
2292       -------------------------
2293
2294       function Valid_Ancestor_Type return Boolean is
2295          Imm_Type : Entity_Id;
2296
2297       begin
2298          Imm_Type := Base_Type (Typ);
2299          while Is_Derived_Type (Imm_Type) loop
2300             if Etype (Imm_Type) = Base_Type (A_Type) then
2301                return True;
2302
2303             --  The base type of the parent type may appear as  a private
2304             --  extension if it is declared as such in a parent unit of the
2305             --  current one. For consistency of the subsequent analysis use
2306             --  the partial view for the ancestor part.
2307
2308             elsif Is_Private_Type (Etype (Imm_Type))
2309               and then Present (Full_View (Etype (Imm_Type)))
2310               and then Base_Type (A_Type) = Full_View (Etype (Imm_Type))
2311             then
2312                A_Type := Etype (Imm_Type);
2313                return True;
2314
2315             --  The parent type may be a private extension. The aggregate is
2316             --  legal if the type of the aggregate is an extension of it that
2317             --  is not a private extension.
2318
2319             elsif Is_Private_Type (A_Type)
2320               and then not Is_Private_Type (Imm_Type)
2321               and then Present (Full_View (A_Type))
2322               and then Base_Type (Full_View (A_Type)) = Etype (Imm_Type)
2323             then
2324                return True;
2325
2326             else
2327                Imm_Type := Etype (Base_Type (Imm_Type));
2328             end if;
2329          end loop;
2330
2331          --  If previous loop did not find a proper ancestor, report error
2332
2333          Error_Msg_NE ("expect ancestor type of &", A, Typ);
2334          return False;
2335       end Valid_Ancestor_Type;
2336
2337    --  Start of processing for Resolve_Extension_Aggregate
2338
2339    begin
2340       --  Analyze the ancestor part and account for the case where it is a
2341       --  parameterless function call.
2342
2343       Analyze (A);
2344       Check_Parameterless_Call (A);
2345
2346       if not Is_Tagged_Type (Typ) then
2347          Error_Msg_N ("type of extension aggregate must be tagged", N);
2348          return;
2349
2350       elsif Is_Limited_Type (Typ) then
2351
2352          --  Ada 2005 (AI-287): Limited aggregates are allowed
2353
2354          if Ada_Version < Ada_05 then
2355             Error_Msg_N ("aggregate type cannot be limited", N);
2356             Explain_Limited_Type (Typ, N);
2357             return;
2358
2359          elsif Valid_Limited_Ancestor (A) then
2360             null;
2361
2362          else
2363             Error_Msg_N
2364               ("limited ancestor part must be aggregate or function call", A);
2365          end if;
2366
2367       elsif Is_Class_Wide_Type (Typ) then
2368          Error_Msg_N ("aggregate cannot be of a class-wide type", N);
2369          return;
2370       end if;
2371
2372       if Is_Entity_Name (A)
2373         and then Is_Type (Entity (A))
2374       then
2375          A_Type := Get_Full_View (Entity (A));
2376
2377          if Valid_Ancestor_Type then
2378             Set_Entity (A, A_Type);
2379             Set_Etype  (A, A_Type);
2380
2381             Validate_Ancestor_Part (N);
2382             Resolve_Record_Aggregate (N, Typ);
2383          end if;
2384
2385       elsif Nkind (A) /= N_Aggregate then
2386          if Is_Overloaded (A) then
2387             A_Type := Any_Type;
2388
2389             Get_First_Interp (A, I, It);
2390             while Present (It.Typ) loop
2391                --  Only consider limited interpretations in the Ada 2005 case
2392
2393                if Is_Tagged_Type (It.Typ)
2394                  and then (Ada_Version >= Ada_05
2395                             or else not Is_Limited_Type (It.Typ))
2396                then
2397                   if A_Type /= Any_Type then
2398                      Error_Msg_N ("cannot resolve expression", A);
2399                      return;
2400                   else
2401                      A_Type := It.Typ;
2402                   end if;
2403                end if;
2404
2405                Get_Next_Interp (I, It);
2406             end loop;
2407
2408             if A_Type = Any_Type then
2409                if Ada_Version >= Ada_05 then
2410                   Error_Msg_N ("ancestor part must be of a tagged type", A);
2411                else
2412                   Error_Msg_N
2413                     ("ancestor part must be of a nonlimited tagged type", A);
2414                end if;
2415
2416                return;
2417             end if;
2418
2419          else
2420             A_Type := Etype (A);
2421          end if;
2422
2423          if Valid_Ancestor_Type then
2424             Resolve (A, A_Type);
2425             Check_Unset_Reference (A);
2426             Check_Non_Static_Context (A);
2427
2428             --  The aggregate is illegal if the ancestor expression is a call
2429             --  to a function with a limited unconstrained result, unless the
2430             --  type of the aggregate is a null extension. This restriction
2431             --  was added in AI05-67 to simplify implementation.
2432
2433             if Nkind (A) = N_Function_Call
2434               and then Is_Limited_Type (A_Type)
2435               and then not Is_Null_Extension (Typ)
2436               and then not Is_Constrained (A_Type)
2437             then
2438                Error_Msg_N
2439                  ("type of limited ancestor part must be constrained", A);
2440
2441             --  Reject the use of CPP constructors that leave objects partially
2442             --  initialized. For example:
2443
2444             --    type CPP_Root is tagged limited record ...
2445             --    pragma Import (CPP, CPP_Root);
2446
2447             --    type CPP_DT is new CPP_Root and Iface ...
2448             --    pragma Import (CPP, CPP_DT);
2449
2450             --    type Ada_DT is new CPP_DT with ...
2451
2452             --    Obj : Ada_DT := Ada_DT'(New_CPP_Root with others => <>);
2453
2454             --  Using the constructor of CPP_Root the slots of the dispatch
2455             --  table of CPP_DT cannot be set, and the secondary tag of
2456             --  CPP_DT is unknown.
2457
2458             elsif Nkind (A) = N_Function_Call
2459               and then Is_CPP_Constructor_Call (A)
2460               and then Enclosing_CPP_Parent (Typ) /= A_Type
2461             then
2462                Error_Msg_NE
2463                  ("?must use 'C'P'P constructor for type &", A,
2464                   Enclosing_CPP_Parent (Typ));
2465
2466                --  The following call is not needed if the previous warning
2467                --  is promoted to an error.
2468
2469                Resolve_Record_Aggregate (N, Typ);
2470
2471             elsif Is_Class_Wide_Type (Etype (A))
2472               and then Nkind (Original_Node (A)) = N_Function_Call
2473             then
2474                --  If the ancestor part is a dispatching call, it appears
2475                --  statically to be a legal ancestor, but it yields any member
2476                --  of the class, and it is not possible to determine whether
2477                --  it is an ancestor of the extension aggregate (much less
2478                --  which ancestor). It is not possible to determine the
2479                --  components of the extension part.
2480
2481                --  This check implements AI-306, which in fact was motivated by
2482                --  an AdaCore query to the ARG after this test was added.
2483
2484                Error_Msg_N ("ancestor part must be statically tagged", A);
2485             else
2486                Resolve_Record_Aggregate (N, Typ);
2487             end if;
2488          end if;
2489
2490       else
2491          Error_Msg_N ("no unique type for this aggregate",  A);
2492       end if;
2493    end Resolve_Extension_Aggregate;
2494
2495    ------------------------------
2496    -- Resolve_Record_Aggregate --
2497    ------------------------------
2498
2499    procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is
2500       Assoc : Node_Id;
2501       --  N_Component_Association node belonging to the input aggregate N
2502
2503       Expr            : Node_Id;
2504       Positional_Expr : Node_Id;
2505       Component       : Entity_Id;
2506       Component_Elmt  : Elmt_Id;
2507
2508       Components : constant Elist_Id := New_Elmt_List;
2509       --  Components is the list of the record components whose value must be
2510       --  provided in the aggregate. This list does include discriminants.
2511
2512       New_Assoc_List : constant List_Id := New_List;
2513       New_Assoc      : Node_Id;
2514       --  New_Assoc_List is the newly built list of N_Component_Association
2515       --  nodes. New_Assoc is one such N_Component_Association node in it.
2516       --  Note that while Assoc and New_Assoc contain the same kind of nodes,
2517       --  they are used to iterate over two different N_Component_Association
2518       --  lists.
2519
2520       Others_Etype : Entity_Id := Empty;
2521       --  This variable is used to save the Etype of the last record component
2522       --  that takes its value from the others choice. Its purpose is:
2523       --
2524       --    (a) make sure the others choice is useful
2525       --
2526       --    (b) make sure the type of all the components whose value is
2527       --        subsumed by the others choice are the same.
2528       --
2529       --  This variable is updated as a side effect of function Get_Value.
2530
2531       Is_Box_Present : Boolean := False;
2532       Others_Box     : Boolean := False;
2533       --  Ada 2005 (AI-287): Variables used in case of default initialization
2534       --  to provide a functionality similar to Others_Etype. Box_Present
2535       --  indicates that the component takes its default initialization;
2536       --  Others_Box indicates that at least one component takes its default
2537       --  initialization. Similar to Others_Etype, they are also updated as a
2538       --  side effect of function Get_Value.
2539
2540       procedure Add_Association
2541         (Component      : Entity_Id;
2542          Expr           : Node_Id;
2543          Assoc_List     : List_Id;
2544          Is_Box_Present : Boolean := False);
2545       --  Builds a new N_Component_Association node which associates Component
2546       --  to expression Expr and adds it to the association list being built,
2547       --  either New_Assoc_List, or the association being built for an inner
2548       --  aggregate.
2549
2550       function Discr_Present (Discr : Entity_Id) return Boolean;
2551       --  If aggregate N is a regular aggregate this routine will return True.
2552       --  Otherwise, if N is an extension aggregate, Discr is a discriminant
2553       --  whose value may already have been specified by N's ancestor part.
2554       --  This routine checks whether this is indeed the case and if so returns
2555       --  False, signaling that no value for Discr should appear in N's
2556       --  aggregate part. Also, in this case, the routine appends to
2557       --  New_Assoc_List the discriminant value specified in the ancestor part.
2558       --
2559       --  If the aggregate is in a context with expansion delayed, it will be
2560       --  reanalyzed. The inherited discriminant values must not be reinserted
2561       --  in the component list to prevent spurious errors, but they must be
2562       --  present on first analysis to build the proper subtype indications.
2563       --  The flag Inherited_Discriminant is used to prevent the re-insertion.
2564
2565       function Get_Value
2566         (Compon                 : Node_Id;
2567          From                   : List_Id;
2568          Consider_Others_Choice : Boolean := False)
2569          return                   Node_Id;
2570       --  Given a record component stored in parameter Compon, this function
2571       --  returns its value as it appears in the list From, which is a list
2572       --  of N_Component_Association nodes.
2573       --
2574       --  If no component association has a choice for the searched component,
2575       --  the value provided by the others choice is returned, if there is one,
2576       --  and Consider_Others_Choice is set to true. Otherwise Empty is
2577       --  returned. If there is more than one component association giving a
2578       --  value for the searched record component, an error message is emitted
2579       --  and the first found value is returned.
2580       --
2581       --  If Consider_Others_Choice is set and the returned expression comes
2582       --  from the others choice, then Others_Etype is set as a side effect.
2583       --  An error message is emitted if the components taking their value from
2584       --  the others choice do not have same type.
2585
2586       procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id);
2587       --  Analyzes and resolves expression Expr against the Etype of the
2588       --  Component. This routine also applies all appropriate checks to Expr.
2589       --  It finally saves a Expr in the newly created association list that
2590       --  will be attached to the final record aggregate. Note that if the
2591       --  Parent pointer of Expr is not set then Expr was produced with a
2592       --  New_Copy_Tree or some such.
2593
2594       ---------------------
2595       -- Add_Association --
2596       ---------------------
2597
2598       procedure Add_Association
2599         (Component      : Entity_Id;
2600          Expr           : Node_Id;
2601          Assoc_List     : List_Id;
2602          Is_Box_Present : Boolean := False)
2603       is
2604          Choice_List : constant List_Id := New_List;
2605          New_Assoc   : Node_Id;
2606
2607       begin
2608          Append (New_Occurrence_Of (Component, Sloc (Expr)), Choice_List);
2609          New_Assoc :=
2610            Make_Component_Association (Sloc (Expr),
2611              Choices     => Choice_List,
2612              Expression  => Expr,
2613              Box_Present => Is_Box_Present);
2614          Append (New_Assoc, Assoc_List);
2615       end Add_Association;
2616
2617       -------------------
2618       -- Discr_Present --
2619       -------------------
2620
2621       function Discr_Present (Discr : Entity_Id) return Boolean is
2622          Regular_Aggr : constant Boolean := Nkind (N) /= N_Extension_Aggregate;
2623
2624          Loc : Source_Ptr;
2625
2626          Ancestor     : Node_Id;
2627          Comp_Assoc   : Node_Id;
2628          Discr_Expr   : Node_Id;
2629
2630          Ancestor_Typ : Entity_Id;
2631          Orig_Discr   : Entity_Id;
2632          D            : Entity_Id;
2633          D_Val        : Elmt_Id := No_Elmt; -- stop junk warning
2634
2635          Ancestor_Is_Subtyp : Boolean;
2636
2637       begin
2638          if Regular_Aggr then
2639             return True;
2640          end if;
2641
2642          --  Check whether inherited discriminant values have already been
2643          --  inserted in the aggregate. This will be the case if we are
2644          --  re-analyzing an aggregate whose expansion was delayed.
2645
2646          if Present (Component_Associations (N)) then
2647             Comp_Assoc := First (Component_Associations (N));
2648             while Present (Comp_Assoc) loop
2649                if Inherited_Discriminant (Comp_Assoc) then
2650                   return True;
2651                end if;
2652
2653                Next (Comp_Assoc);
2654             end loop;
2655          end if;
2656
2657          Ancestor     := Ancestor_Part (N);
2658          Ancestor_Typ := Etype (Ancestor);
2659          Loc          := Sloc (Ancestor);
2660
2661          --  For a private type with unknown discriminants, use the underlying
2662          --  record view if it is available.
2663
2664          if Has_Unknown_Discriminants (Ancestor_Typ)
2665            and then Present (Full_View (Ancestor_Typ))
2666            and then Present (Underlying_Record_View (Full_View (Ancestor_Typ)))
2667          then
2668             Ancestor_Typ := Underlying_Record_View (Full_View (Ancestor_Typ));
2669          end if;
2670
2671          Ancestor_Is_Subtyp :=
2672            Is_Entity_Name (Ancestor) and then Is_Type (Entity (Ancestor));
2673
2674          --  If the ancestor part has no discriminants clearly N's aggregate
2675          --  part must provide a value for Discr.
2676
2677          if not Has_Discriminants (Ancestor_Typ) then
2678             return True;
2679
2680          --  If the ancestor part is an unconstrained subtype mark then the
2681          --  Discr must be present in N's aggregate part.
2682
2683          elsif Ancestor_Is_Subtyp
2684            and then not Is_Constrained (Entity (Ancestor))
2685          then
2686             return True;
2687          end if;
2688
2689          --  Now look to see if Discr was specified in the ancestor part
2690
2691          if Ancestor_Is_Subtyp then
2692             D_Val := First_Elmt (Discriminant_Constraint (Entity (Ancestor)));
2693          end if;
2694
2695          Orig_Discr := Original_Record_Component (Discr);
2696
2697          D := First_Discriminant (Ancestor_Typ);
2698          while Present (D) loop
2699
2700             --  If Ancestor has already specified Disc value then insert its
2701             --  value in the final aggregate.
2702
2703             if Original_Record_Component (D) = Orig_Discr then
2704                if Ancestor_Is_Subtyp then
2705                   Discr_Expr := New_Copy_Tree (Node (D_Val));
2706                else
2707                   Discr_Expr :=
2708                     Make_Selected_Component (Loc,
2709                       Prefix        => Duplicate_Subexpr (Ancestor),
2710                       Selector_Name => New_Occurrence_Of (Discr, Loc));
2711                end if;
2712
2713                Resolve_Aggr_Expr (Discr_Expr, Discr);
2714                Set_Inherited_Discriminant (Last (New_Assoc_List));
2715                return False;
2716             end if;
2717
2718             Next_Discriminant (D);
2719
2720             if Ancestor_Is_Subtyp then
2721                Next_Elmt (D_Val);
2722             end if;
2723          end loop;
2724
2725          return True;
2726       end Discr_Present;
2727
2728       ---------------
2729       -- Get_Value --
2730       ---------------
2731
2732       function Get_Value
2733         (Compon                 : Node_Id;
2734          From                   : List_Id;
2735          Consider_Others_Choice : Boolean := False)
2736          return                   Node_Id
2737       is
2738          Assoc         : Node_Id;
2739          Expr          : Node_Id := Empty;
2740          Selector_Name : Node_Id;
2741
2742       begin
2743          Is_Box_Present := False;
2744
2745          if Present (From) then
2746             Assoc := First (From);
2747          else
2748             return Empty;
2749          end if;
2750
2751          while Present (Assoc) loop
2752             Selector_Name := First (Choices (Assoc));
2753             while Present (Selector_Name) loop
2754                if Nkind (Selector_Name) = N_Others_Choice then
2755                   if Consider_Others_Choice and then No (Expr) then
2756
2757                      --  We need to duplicate the expression for each
2758                      --  successive component covered by the others choice.
2759                      --  This is redundant if the others_choice covers only
2760                      --  one component (small optimization possible???), but
2761                      --  indispensable otherwise, because each one must be
2762                      --  expanded individually to preserve side-effects.
2763
2764                      --  Ada 2005 (AI-287): In case of default initialization
2765                      --  of components, we duplicate the corresponding default
2766                      --  expression (from the record type declaration). The
2767                      --  copy must carry the sloc of the association (not the
2768                      --  original expression) to prevent spurious elaboration
2769                      --  checks when the default includes function calls.
2770
2771                      if Box_Present (Assoc) then
2772                         Others_Box     := True;
2773                         Is_Box_Present := True;
2774
2775                         if Expander_Active then
2776                            return
2777                              New_Copy_Tree
2778                                (Expression (Parent (Compon)),
2779                                 New_Sloc => Sloc (Assoc));
2780                         else
2781                            return Expression (Parent (Compon));
2782                         end if;
2783
2784                      else
2785                         if Present (Others_Etype) and then
2786                            Base_Type (Others_Etype) /= Base_Type (Etype
2787                                                                    (Compon))
2788                         then
2789                            Error_Msg_N ("components in OTHERS choice must " &
2790                                         "have same type", Selector_Name);
2791                         end if;
2792
2793                         Others_Etype := Etype (Compon);
2794
2795                         if Expander_Active then
2796                            return New_Copy_Tree (Expression (Assoc));
2797                         else
2798                            return Expression (Assoc);
2799                         end if;
2800                      end if;
2801                   end if;
2802
2803                elsif Chars (Compon) = Chars (Selector_Name) then
2804                   if No (Expr) then
2805
2806                      --  Ada 2005 (AI-231)
2807
2808                      if Ada_Version >= Ada_05
2809                        and then Known_Null (Expression (Assoc))
2810                      then
2811                         Check_Can_Never_Be_Null (Compon, Expression (Assoc));
2812                      end if;
2813
2814                      --  We need to duplicate the expression when several
2815                      --  components are grouped together with a "|" choice.
2816                      --  For instance "filed1 | filed2 => Expr"
2817
2818                      --  Ada 2005 (AI-287)
2819
2820                      if Box_Present (Assoc) then
2821                         Is_Box_Present := True;
2822
2823                         --  Duplicate the default expression of the component
2824                         --  from the record type declaration, so a new copy
2825                         --  can be attached to the association.
2826
2827                         --  Note that we always copy the default expression,
2828                         --  even when the association has a single choice, in
2829                         --  order to create a proper association for the
2830                         --  expanded aggregate.
2831
2832                         Expr := New_Copy_Tree (Expression (Parent (Compon)));
2833
2834                      else
2835                         if Present (Next (Selector_Name)) then
2836                            Expr := New_Copy_Tree (Expression (Assoc));
2837                         else
2838                            Expr := Expression (Assoc);
2839                         end if;
2840                      end if;
2841
2842                      Generate_Reference (Compon, Selector_Name, 'm');
2843
2844                   else
2845                      Error_Msg_NE
2846                        ("more than one value supplied for &",
2847                         Selector_Name, Compon);
2848
2849                   end if;
2850                end if;
2851
2852                Next (Selector_Name);
2853             end loop;
2854
2855             Next (Assoc);
2856          end loop;
2857
2858          return Expr;
2859       end Get_Value;
2860
2861       -----------------------
2862       -- Resolve_Aggr_Expr --
2863       -----------------------
2864
2865       procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id) is
2866          New_C     : Entity_Id := Component;
2867          Expr_Type : Entity_Id := Empty;
2868
2869          function Has_Expansion_Delayed (Expr : Node_Id) return Boolean;
2870          --  If the expression is an aggregate (possibly qualified) then its
2871          --  expansion is delayed until the enclosing aggregate is expanded
2872          --  into assignments. In that case, do not generate checks on the
2873          --  expression, because they will be generated later, and will other-
2874          --  wise force a copy (to remove side-effects) that would leave a
2875          --  dynamic-sized aggregate in the code, something that gigi cannot
2876          --  handle.
2877
2878          Relocate  : Boolean;
2879          --  Set to True if the resolved Expr node needs to be relocated
2880          --  when attached to the newly created association list. This node
2881          --  need not be relocated if its parent pointer is not set.
2882          --  In fact in this case Expr is the output of a New_Copy_Tree call.
2883          --  if Relocate is True then we have analyzed the expression node
2884          --  in the original aggregate and hence it needs to be relocated
2885          --  when moved over the new association list.
2886
2887          function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is
2888             Kind : constant Node_Kind := Nkind (Expr);
2889          begin
2890             return (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)
2891                      and then Present (Etype (Expr))
2892                      and then Is_Record_Type (Etype (Expr))
2893                      and then Expansion_Delayed (Expr))
2894               or else (Kind = N_Qualified_Expression
2895                         and then Has_Expansion_Delayed (Expression (Expr)));
2896          end Has_Expansion_Delayed;
2897
2898       --  Start of processing for  Resolve_Aggr_Expr
2899
2900       begin
2901          --  If the type of the component is elementary or the type of the
2902          --  aggregate does not contain discriminants, use the type of the
2903          --  component to resolve Expr.
2904
2905          if Is_Elementary_Type (Etype (Component))
2906            or else not Has_Discriminants (Etype (N))
2907          then
2908             Expr_Type := Etype (Component);
2909
2910          --  Otherwise we have to pick up the new type of the component from
2911          --  the new constrained subtype of the aggregate. In fact components
2912          --  which are of a composite type might be constrained by a
2913          --  discriminant, and we want to resolve Expr against the subtype were
2914          --  all discriminant occurrences are replaced with their actual value.
2915
2916          else
2917             New_C := First_Component (Etype (N));
2918             while Present (New_C) loop
2919                if Chars (New_C) = Chars (Component) then
2920                   Expr_Type := Etype (New_C);
2921                   exit;
2922                end if;
2923
2924                Next_Component (New_C);
2925             end loop;
2926
2927             pragma Assert (Present (Expr_Type));
2928
2929             --  For each range in an array type where a discriminant has been
2930             --  replaced with the constraint, check that this range is within
2931             --  the range of the base type. This checks is done in the init
2932             --  proc for regular objects, but has to be done here for
2933             --  aggregates since no init proc is called for them.
2934
2935             if Is_Array_Type (Expr_Type) then
2936                declare
2937                   Index : Node_Id;
2938                   --  Range of the current constrained index in the array
2939
2940                   Orig_Index : Node_Id := First_Index (Etype (Component));
2941                   --  Range corresponding to the range Index above in the
2942                   --  original unconstrained record type. The bounds of this
2943                   --  range may be governed by discriminants.
2944
2945                   Unconstr_Index : Node_Id := First_Index (Etype (Expr_Type));
2946                   --  Range corresponding to the range Index above for the
2947                   --  unconstrained array type. This range is needed to apply
2948                   --  range checks.
2949
2950                begin
2951                   Index := First_Index (Expr_Type);
2952                   while Present (Index) loop
2953                      if Depends_On_Discriminant (Orig_Index) then
2954                         Apply_Range_Check (Index, Etype (Unconstr_Index));
2955                      end if;
2956
2957                      Next_Index (Index);
2958                      Next_Index (Orig_Index);
2959                      Next_Index (Unconstr_Index);
2960                   end loop;
2961                end;
2962             end if;
2963          end if;
2964
2965          --  If the Parent pointer of Expr is not set, Expr is an expression
2966          --  duplicated by New_Tree_Copy (this happens for record aggregates
2967          --  that look like (Field1 | Filed2 => Expr) or (others => Expr)).
2968          --  Such a duplicated expression must be attached to the tree
2969          --  before analysis and resolution to enforce the rule that a tree
2970          --  fragment should never be analyzed or resolved unless it is
2971          --  attached to the current compilation unit.
2972
2973          if No (Parent (Expr)) then
2974             Set_Parent (Expr, N);
2975             Relocate := False;
2976          else
2977             Relocate := True;
2978          end if;
2979
2980          Analyze_And_Resolve (Expr, Expr_Type);
2981          Check_Expr_OK_In_Limited_Aggregate (Expr);
2982          Check_Non_Static_Context (Expr);
2983          Check_Unset_Reference (Expr);
2984
2985          --  Check wrong use of class-wide types
2986
2987          if Is_Class_Wide_Type (Etype (Expr)) then
2988             Error_Msg_N ("dynamically tagged expression not allowed", Expr);
2989          end if;
2990
2991          if not Has_Expansion_Delayed (Expr) then
2992             Aggregate_Constraint_Checks (Expr, Expr_Type);
2993          end if;
2994
2995          if Raises_Constraint_Error (Expr) then
2996             Set_Raises_Constraint_Error (N);
2997          end if;
2998
2999          --  If the expression has been marked as requiring a range check,
3000          --  then generate it here.
3001
3002          if Do_Range_Check (Expr) then
3003             Set_Do_Range_Check (Expr, False);
3004             Generate_Range_Check (Expr, Expr_Type, CE_Range_Check_Failed);
3005          end if;
3006
3007          if Relocate then
3008             Add_Association (New_C, Relocate_Node (Expr), New_Assoc_List);
3009          else
3010             Add_Association (New_C, Expr, New_Assoc_List);
3011          end if;
3012       end Resolve_Aggr_Expr;
3013
3014    --  Start of processing for Resolve_Record_Aggregate
3015
3016    begin
3017       --  We may end up calling Duplicate_Subexpr on expressions that are
3018       --  attached to New_Assoc_List. For this reason we need to attach it
3019       --  to the tree by setting its parent pointer to N. This parent point
3020       --  will change in STEP 8 below.
3021
3022       Set_Parent (New_Assoc_List, N);
3023
3024       --  STEP 1: abstract type and null record verification
3025
3026       if Is_Abstract_Type (Typ) then
3027          Error_Msg_N ("type of aggregate cannot be abstract",  N);
3028       end if;
3029
3030       if No (First_Entity (Typ)) and then Null_Record_Present (N) then
3031          Set_Etype (N, Typ);
3032          return;
3033
3034       elsif Present (First_Entity (Typ))
3035         and then Null_Record_Present (N)
3036         and then not Is_Tagged_Type (Typ)
3037       then
3038          Error_Msg_N ("record aggregate cannot be null", N);
3039          return;
3040
3041       --  If the type has no components, then the aggregate should either
3042       --  have "null record", or in Ada 2005 it could instead have a single
3043       --  component association given by "others => <>". For Ada 95 we flag
3044       --  an error at this point, but for Ada 2005 we proceed with checking
3045       --  the associations below, which will catch the case where it's not
3046       --  an aggregate with "others => <>". Note that the legality of a <>
3047       --  aggregate for a null record type was established by AI05-016.
3048
3049       elsif No (First_Entity (Typ))
3050          and then Ada_Version < Ada_05
3051       then
3052          Error_Msg_N ("record aggregate must be null", N);
3053          return;
3054       end if;
3055
3056       --  STEP 2: Verify aggregate structure
3057
3058       Step_2 : declare
3059          Selector_Name : Node_Id;
3060          Bad_Aggregate : Boolean := False;
3061
3062       begin
3063          if Present (Component_Associations (N)) then
3064             Assoc := First (Component_Associations (N));
3065          else
3066             Assoc := Empty;
3067          end if;
3068
3069          while Present (Assoc) loop
3070             Selector_Name := First (Choices (Assoc));
3071             while Present (Selector_Name) loop
3072                if Nkind (Selector_Name) = N_Identifier then
3073                   null;
3074
3075                elsif Nkind (Selector_Name) = N_Others_Choice then
3076                   if Selector_Name /= First (Choices (Assoc))
3077                     or else Present (Next (Selector_Name))
3078                   then
3079                      Error_Msg_N
3080                        ("OTHERS must appear alone in a choice list",
3081                         Selector_Name);
3082                      return;
3083
3084                   elsif Present (Next (Assoc)) then
3085                      Error_Msg_N
3086                        ("OTHERS must appear last in an aggregate",
3087                         Selector_Name);
3088                      return;
3089
3090                   --  (Ada2005): If this is an association with a box,
3091                   --  indicate that the association need not represent
3092                   --  any component.
3093
3094                   elsif Box_Present (Assoc) then
3095                      Others_Box := True;
3096                   end if;
3097
3098                else
3099                   Error_Msg_N
3100                     ("selector name should be identifier or OTHERS",
3101                      Selector_Name);
3102                   Bad_Aggregate := True;
3103                end if;
3104
3105                Next (Selector_Name);
3106             end loop;
3107
3108             Next (Assoc);
3109          end loop;
3110
3111          if Bad_Aggregate then
3112             return;
3113          end if;
3114       end Step_2;
3115
3116       --  STEP 3: Find discriminant Values
3117
3118       Step_3 : declare
3119          Discrim               : Entity_Id;
3120          Missing_Discriminants : Boolean := False;
3121
3122       begin
3123          if Present (Expressions (N)) then
3124             Positional_Expr := First (Expressions (N));
3125          else
3126             Positional_Expr := Empty;
3127          end if;
3128
3129          if Has_Unknown_Discriminants (Typ)
3130            and then Present (Underlying_Record_View (Typ))
3131          then
3132             Discrim := First_Discriminant (Underlying_Record_View (Typ));
3133          elsif Has_Discriminants (Typ) then
3134             Discrim := First_Discriminant (Typ);
3135          else
3136             Discrim := Empty;
3137          end if;
3138
3139          --  First find the discriminant values in the positional components
3140
3141          while Present (Discrim) and then Present (Positional_Expr) loop
3142             if Discr_Present (Discrim) then
3143                Resolve_Aggr_Expr (Positional_Expr, Discrim);
3144
3145                --  Ada 2005 (AI-231)
3146
3147                if Ada_Version >= Ada_05
3148                  and then Known_Null (Positional_Expr)
3149                then
3150                   Check_Can_Never_Be_Null (Discrim, Positional_Expr);
3151                end if;
3152
3153                Next (Positional_Expr);
3154             end if;
3155
3156             if Present (Get_Value (Discrim, Component_Associations (N))) then
3157                Error_Msg_NE
3158                  ("more than one value supplied for discriminant&",
3159                   N, Discrim);
3160             end if;
3161
3162             Next_Discriminant (Discrim);
3163          end loop;
3164
3165