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