path: root/gcc/ada/sem_case.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             S E M _ C A S E                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1996-2022, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Atree;          use Atree;
with Einfo;          use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils;    use Einfo.Utils;
with Elists;         use Elists;
with Errout;         use Errout;
with Namet;          use Namet;
with Nlists;         use Nlists;
with Nmake;          use Nmake;
with Opt;            use Opt;
with Sem;            use Sem;
with Sem_Aux;        use Sem_Aux;
with Sem_Eval;       use Sem_Eval;
with Sem_Res;        use Sem_Res;
with Sem_Util;       use Sem_Util;
with Sem_Type;       use Sem_Type;
with Snames;         use Snames;
with Stand;          use Stand;
with Sinfo;          use Sinfo;
with Sinfo.Nodes;    use Sinfo.Nodes;
with Sinfo.Utils;    use Sinfo.Utils;
with Stringt;        use Stringt;
with Table;
with Tbuild;         use Tbuild;
with Uintp;          use Uintp;

with Ada.Unchecked_Deallocation;

with GNAT.Heap_Sort_G;
with GNAT.Sets;

package body Sem_Case is

   type Choice_Bounds is record
     Lo   : Node_Id;
     Hi   : Node_Id;
     Node : Node_Id;
   end record;
   --  Represent one choice bounds entry with Lo and Hi values, Node points
   --  to the choice node itself.

   type Choice_Table_Type is array (Nat range <>) of Choice_Bounds;
   --  Table type used to sort the choices present in a case statement or
   --  record variant. The actual entries are stored in 1 .. Last, but we
   --  have a 0 entry for use in sorting.

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure Check_Choice_Set
     (Choice_Table   : in out Choice_Table_Type;
      Bounds_Type    : Entity_Id;
      Subtyp         : Entity_Id;
      Others_Present : Boolean;
      Case_Node      : Node_Id);
   --  This is the procedure which verifies that a set of case alternatives
   --  or record variant choices has no duplicates, and covers the range
   --  specified by Bounds_Type. Choice_Table contains the discrete choices
   --  to check. These must start at position 1.
   --
   --  Furthermore Choice_Table (0) must exist. This element is used by
   --  the sorting algorithm as a temporary. Others_Present is a flag
   --  indicating whether or not an Others choice is present. Finally
   --  Msg_Sloc gives the source location of the construct containing the
   --  choices in the Choice_Table.
   --
   --  Bounds_Type is the type whose range must be covered by the alternatives
   --
   --  Subtyp is the subtype of the expression. If its bounds are nonstatic
   --  the alternatives must cover its base type.

   function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id;
   --  Given a Pos value of enumeration type Ctype, returns the name
   --  ID of an appropriate string to be used in error message output.

   function Has_Static_Discriminant_Constraint
     (Subtyp : Entity_Id) return Boolean;
   --  Returns True if the given subtype is subject to a discriminant
   --  constraint and at least one of the constraint values is nonstatic.

   package Composite_Case_Ops is

      Simplified_Composite_Coverage_Rules : constant Boolean := True;
      --  Indicates that, as a temporary stopgap, we implement
      --  simpler coverage-checking rules when casing on a
      --  composite selector:
      --     1) Require that an Others choice must be given, regardless
      --        of whether all possible values are covered explicitly.
      --     2) No legality checks regarding overlapping choices.

      function Box_Value_Required (Subtyp : Entity_Id) return Boolean;
      --  If result is True, then the only allowed value (in a choice
      --  aggregate) for a component of this (sub)type is a box. This rule
      --  means that such a component can be ignored in case alternative
      --  selection. This in turn implies that it is ok if the component
      --  type doesn't meet the usual restrictions, such as not being an
      --  access/task/protected type, since nobody is going to look
      --  at it.

      function Choice_Count (Alternatives : List_Id) return Nat;
      --  The sum of the number of choices for each alternative in the given
      --  list.

      function Normalized_Case_Expr_Type
        (Case_Statement : Node_Id) return Entity_Id;
      --  Usually returns the Etype of the selector expression of the
      --  case statement. However, in the case of a constrained composite
      --  subtype with a nonstatic constraint, returns the unconstrained
      --  base type.

      function Scalar_Part_Count (Subtyp : Entity_Id) return Nat;
      --  Given the composite type Subtyp of a case selector, returns the
      --  number of scalar parts in an object of this type. This is the
      --  dimensionality of the associated Cartesian product space.

      package Array_Case_Ops is
         function Array_Choice_Length (Choice : Node_Id) return Nat;
         --  Given a choice expression of an array type, returns its length.

         function Unconstrained_Array_Effective_Length
           (Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat;
         --  If the nominal subtype of the case selector is unconstrained,
         --  then use the length of the longest choice of the case statement.
         --  Components beyond that index value will not influence the case
         --  selection decision.

         function Unconstrained_Array_Scalar_Part_Count
           (Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat;
         --  Same as Scalar_Part_Count except that the value used for the
         --  "length" of the array subtype being cased on is determined by
         --  calling Unconstrained_Array_Effective_Length.
      end Array_Case_Ops;

      generic
         Case_Statement : Node_Id;
      package Choice_Analysis is

         use Array_Case_Ops;

         type Alternative_Id is
           new Int range 1 .. List_Length (Alternatives (Case_Statement));
         type Choice_Id is
           new Int range 1 .. Choice_Count (Alternatives (Case_Statement));

         Case_Expr_Type : constant Entity_Id :=
           Normalized_Case_Expr_Type (Case_Statement);

         Unconstrained_Array_Case : constant Boolean :=
           Is_Array_Type (Case_Expr_Type)
             and then not Is_Constrained (Case_Expr_Type);

         --  If Unconstrained_Array_Case is True, choice lengths may differ:
         --    when "Aaa" | "Bb" | "C" | "" =>
         --
         --  Strictly speaking, the name "Unconstrained_Array_Case" is
         --  slightly imprecise; a subtype with a nonstatic constraint is
         --  also treated as unconstrained (see Normalize_Case_Expr_Type).

         type Part_Id is new Int range
           1 .. (if Unconstrained_Array_Case
                 then Unconstrained_Array_Scalar_Part_Count
                        (Case_Expr_Type, Case_Statement)
                 else Scalar_Part_Count (Case_Expr_Type));

         type Discrete_Range_Info is
           record
              Low, High : Uint;
           end record;
         function "=" (X, Y : Discrete_Range_Info) return Boolean is abstract;
         --  Here (and below), we don't use "=", which is a good thing,
         --  because it wouldn't work, because the user-defined "=" on
         --  Uint does not compose according to Ada rules.

         type Composite_Range_Info is array (Part_Id) of Discrete_Range_Info;
         function "=" (X, Y : Composite_Range_Info) return Boolean is abstract;

         type Choice_Range_Info (Is_Others : Boolean := False) is
           record
              case Is_Others is
                 when False =>
                    Ranges : Composite_Range_Info;
                 when True =>
                    null;
              end case;
           end record;
         function "=" (X, Y : Choice_Range_Info) return Boolean is abstract;

         type Choices_Range_Info is array (Choice_Id) of Choice_Range_Info;

         package Value_Sets is

            type Value_Set is private;
            --  A set of points in the Cartesian product space defined
            --  by the composite type of the case selector.
            --  Implemented as an access type.

            type Set_Comparison is
              (Disjoint, Equal, Contains, Contained_By, Overlaps);

            function Compare (S1, S2 : Value_Set) return Set_Comparison;
            --  If either argument (or both) is empty, result is Disjoint.
            --  Otherwise, result is Equal if the two sets are equal.

            Empty : constant Value_Set;

            function Matching_Values
              (Info : Composite_Range_Info) return Value_Set;
            --  The Cartesian product of the given array of ranges
            --  (excluding any values outside the Cartesian product of the
            --  component ranges).

            procedure Union (Target : in out Value_Set; Source : Value_Set);
            --  Add elements of Source into Target

            procedure Remove (Target : in out Value_Set; Source : Value_Set);
            --  Remove elements of Source from Target

            function Complement_Is_Empty (Set : Value_Set) return Boolean;
            --  Return True iff the set is "maximal", in the sense that it
            --  includes every value in the Cartesian product of the
            --  component ranges.

            procedure Free_Value_Sets;
            --  Reclaim storage associated with implementation of this package.

         private
            type Value_Set is new Natural;
            --  An index for a table that will be declared in the package body.

            Empty : constant Value_Set := 0;

         end Value_Sets;

         type Single_Choice_Info (Is_Others : Boolean := False) is
           record
              Alternative : Alternative_Id;
              case Is_Others is
                 when False =>
                    Matches : Value_Sets.Value_Set;
                 when True =>
                    null;
              end case;
           end record;

         type Choices_Info is array (Choice_Id) of Single_Choice_Info;

         function Analysis return Choices_Info;
         --  Parse the case choices in order to determine the set of
         --  matching values associated with each choice.

         type Bound_Values is array (Positive range <>) of Node_Id;

      end Choice_Analysis;
   end Composite_Case_Ops;

   procedure Expand_Others_Choice
     (Case_Table    : Choice_Table_Type;
      Others_Choice : Node_Id;
      Choice_Type   : Entity_Id);
   --  The case table is the table generated by a call to Check_Choices
   --  (with just 1 .. Last_Choice entries present). Others_Choice is a
   --  pointer to the N_Others_Choice node (this routine is only called if
   --  an others choice is present), and Choice_Type is the discrete type
   --  of the bounds. The effect of this call is to analyze the cases and
   --  determine the set of values covered by others. This choice list is
   --  set in the Others_Discrete_Choices field of the N_Others_Choice node.

   ----------------------
   -- Check_Choice_Set --
   ----------------------

   procedure Check_Choice_Set
     (Choice_Table   : in out Choice_Table_Type;
      Bounds_Type    : Entity_Id;
      Subtyp         : Entity_Id;
      Others_Present : Boolean;
      Case_Node      : Node_Id)
   is
      Predicate_Error : Boolean := False;
      --  Flag to prevent cascaded errors when a static predicate is known to
      --  be violated by one choice.

      Num_Choices : constant Nat := Choice_Table'Last;

      procedure Check_Against_Predicate
        (Pred    : in out Node_Id;
         Choice  : Choice_Bounds;
         Prev_Lo : in out Uint;
         Prev_Hi : in out Uint;
         Error   : in out Boolean);
      --  Determine whether a choice covers legal values as defined by a static
      --  predicate set. Pred is a static predicate range. Choice is the choice
      --  to be examined. Prev_Lo and Prev_Hi are the bounds of the previous
      --  choice that covered a predicate set. Error denotes whether the check
      --  found an illegal intersection.

      procedure Check_Duplicates;
      --  Check for duplicate choices, and call Dup_Choice if there are any
      --  such errors. Note that predicates are irrelevant here.

      procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id);
      --  Post message "duplication of choice value(s) bla bla at xx". Message
      --  is posted at location C. Caller sets Error_Msg_Sloc for xx.

      procedure Explain_Non_Static_Bound;
      --  Called when we find a nonstatic bound, requiring the base type to
      --  be covered. Provides where possible a helpful explanation of why the
      --  bounds are nonstatic, since this is not always obvious.

      function Lt_Choice (C1, C2 : Natural) return Boolean;
      --  Comparison routine for comparing Choice_Table entries. Use the lower
      --  bound of each Choice as the key.

      procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id);
      procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint);
      procedure Missing_Choice (Value1 : Uint;    Value2 : Node_Id);
      procedure Missing_Choice (Value1 : Uint;    Value2 : Uint);
      --  Issue an error message indicating that there are missing choices,
      --  followed by the image of the missing choices themselves which lie
      --  between Value1 and Value2 inclusive.

      procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint);
      --  Emit an error message for each non-covered static predicate set.
      --  Prev_Hi denotes the upper bound of the last choice covering a set.

      procedure Move_Choice (From : Natural; To : Natural);
      --  Move routine for sorting the Choice_Table

      package Sorting is new GNAT.Heap_Sort_G (Move_Choice, Lt_Choice);

      -----------------------------
      -- Check_Against_Predicate --
      -----------------------------

      procedure Check_Against_Predicate
        (Pred    : in out Node_Id;
         Choice  : Choice_Bounds;
         Prev_Lo : in out Uint;
         Prev_Hi : in out Uint;
         Error   : in out Boolean)
      is
         procedure Illegal_Range
           (Loc : Source_Ptr;
            Lo  : Uint;
            Hi  : Uint);
         --  Emit an error message regarding a choice that clashes with the
         --  legal static predicate sets. Loc is the location of the choice
         --  that introduced the illegal range. Lo .. Hi is the range.

         function Inside_Range
           (Lo  : Uint;
            Hi  : Uint;
            Val : Uint) return Boolean;
         --  Determine whether position Val within a discrete type is within
         --  the range Lo .. Hi inclusive.

         -------------------
         -- Illegal_Range --
         -------------------

         procedure Illegal_Range
           (Loc : Source_Ptr;
            Lo  : Uint;
            Hi  : Uint)
         is
         begin
            Error_Msg_Name_1 := Chars (Bounds_Type);

            --  Single value

            if Lo = Hi then
               if Is_Integer_Type (Bounds_Type) then
                  Error_Msg_Uint_1 := Lo;
                  Error_Msg ("static predicate on % excludes value ^!", Loc);
               else
                  Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type);
                  Error_Msg ("static predicate on % excludes value %!", Loc);
               end if;

            --  Range

            else
               if Is_Integer_Type (Bounds_Type) then
                  Error_Msg_Uint_1 := Lo;
                  Error_Msg_Uint_2 := Hi;
                  Error_Msg
                    ("static predicate on % excludes range ^ .. ^!", Loc);
               else
                  Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type);
                  Error_Msg_Name_3 := Choice_Image (Hi, Bounds_Type);
                  Error_Msg
                    ("static predicate on % excludes range % .. %!", Loc);
               end if;
            end if;
         end Illegal_Range;

         ------------------
         -- Inside_Range --
         ------------------

         function Inside_Range
           (Lo  : Uint;
            Hi  : Uint;
            Val : Uint) return Boolean
         is
         begin
            return Lo <= Val and then Val <= Hi;
         end Inside_Range;

         --  Local variables

         Choice_Hi : constant Uint := Expr_Value (Choice.Hi);
         Choice_Lo : constant Uint := Expr_Value (Choice.Lo);
         Loc       : Source_Ptr;
         LocN      : Node_Id;
         Next_Hi   : Uint;
         Next_Lo   : Uint;
         Pred_Hi   : Uint;
         Pred_Lo   : Uint;

      --  Start of processing for Check_Against_Predicate

      begin
         --  Find the proper error message location

         if Present (Choice.Node) then
            LocN := Choice.Node;
         else
            LocN := Case_Node;
         end if;

         Loc := Sloc (LocN);

         if Present (Pred) then
            Pred_Lo := Expr_Value (Low_Bound  (Pred));
            Pred_Hi := Expr_Value (High_Bound (Pred));

         --  Previous choices managed to satisfy all static predicate sets

         else
            Illegal_Range (Loc, Choice_Lo, Choice_Hi);
            Error := True;
            return;
         end if;

         --  Step 1: Ignore duplicate choices, other than to set the flag,
         --  because these were already detected by Check_Duplicates.

         if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo)
           or else  Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi)
         then
            Error := True;

         --  Step 2: Detect full coverage

         --  Choice_Lo    Choice_Hi
         --  +============+
         --  Pred_Lo      Pred_Hi

         elsif Choice_Lo = Pred_Lo and then Choice_Hi = Pred_Hi then
            Prev_Lo := Choice_Lo;
            Prev_Hi := Choice_Hi;
            Next (Pred);

         --  Step 3: Detect all cases where a choice mentions values that are
         --  not part of the static predicate sets.

         --  Choice_Lo   Choice_Hi   Pred_Lo   Pred_Hi
         --  +-----------+ . . . . . +=========+
         --   ^ illegal ^

         elsif Choice_Lo < Pred_Lo and then Choice_Hi < Pred_Lo then
            Illegal_Range (Loc, Choice_Lo, Choice_Hi);
            Error := True;

         --  Choice_Lo   Pred_Lo   Choice_Hi   Pred_Hi
         --  +-----------+=========+===========+
         --   ^ illegal ^

         elsif Choice_Lo < Pred_Lo
           and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Hi)
         then
            Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1);
            Error := True;

         --  Pred_Lo   Pred_Hi   Choice_Lo   Choice_Hi
         --  +=========+ . . . . +-----------+
         --                       ^ illegal ^

         elsif Pred_Lo < Choice_Lo and then Pred_Hi < Choice_Lo then
            if Others_Present then

               --  Current predicate set is covered by others clause.

               null;

            else
               Missing_Choice (Pred_Lo, Pred_Hi);
               Error := True;
            end if;

            --  There may be several static predicate sets between the current
            --  one and the choice. Inspect the next static predicate set.

            Next (Pred);
            Check_Against_Predicate
              (Pred    => Pred,
               Choice  => Choice,
               Prev_Lo => Prev_Lo,
               Prev_Hi => Prev_Hi,
               Error   => Error);

         --  Pred_Lo   Choice_Lo   Pred_Hi     Choice_Hi
         --  +=========+===========+-----------+
         --                         ^ illegal ^

         elsif Pred_Hi < Choice_Hi
           and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Lo)
         then
            Next (Pred);

            --  The choice may fall in a static predicate set. If this is the
            --  case, avoid mentioning legal values in the error message.

            if Present (Pred) then
               Next_Lo := Expr_Value (Low_Bound  (Pred));
               Next_Hi := Expr_Value (High_Bound (Pred));

               --  The next static predicate set is to the right of the choice

               if Choice_Hi < Next_Lo and then Choice_Hi < Next_Hi then
                  Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi);
               else
                  Illegal_Range (Loc, Pred_Hi + 1, Next_Lo - 1);
               end if;
            else
               Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi);
            end if;

            Error := True;

         --  Choice_Lo   Pred_Lo   Pred_Hi     Choice_Hi
         --  +-----------+=========+-----------+
         --   ^ illegal ^           ^ illegal ^

         --  Emit an error on the low gap, disregard the upper gap

         elsif Choice_Lo < Pred_Lo and then Pred_Hi < Choice_Hi then
            Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1);
            Error := True;

         --  Step 4: Detect all cases of partial or missing coverage

         --  Pred_Lo   Choice_Lo  Choice_Hi   Pred_Hi
         --  +=========+==========+===========+
         --   ^  gap  ^            ^   gap   ^

         else
            --  An "others" choice covers all gaps

            if Others_Present then
               Prev_Lo := Choice_Lo;
               Prev_Hi := Choice_Hi;

               --  Check whether predicate set is fully covered by choice

               if Pred_Hi = Choice_Hi then
                  Next (Pred);
               end if;

            --  Choice_Lo   Choice_Hi   Pred_Hi
            --  +===========+===========+
            --  Pred_Lo      ^   gap   ^

            --  The upper gap may be covered by a subsequent choice

            elsif Pred_Lo = Choice_Lo then
               Prev_Lo := Choice_Lo;
               Prev_Hi := Choice_Hi;

            --  Pred_Lo     Prev_Hi   Choice_Lo   Choice_Hi   Pred_Hi
            --  +===========+=========+===========+===========+
            --   ^ covered ^ ^  gap  ^

            else pragma Assert (Pred_Lo < Choice_Lo);

               --  A previous choice covered the gap up to the current choice

               if Prev_Hi = Choice_Lo - 1 then
                  Prev_Lo := Choice_Lo;
                  Prev_Hi := Choice_Hi;

                  if Choice_Hi = Pred_Hi then
                     Next (Pred);
                  end if;

               --  The previous choice did not intersect with the current
               --  static predicate set.

               elsif Prev_Hi < Pred_Lo then
                  Missing_Choice (Pred_Lo, Choice_Lo - 1);
                  Error := True;

               --  The previous choice covered part of the static predicate set
               --  but there is a gap after Prev_Hi.

               else
                  Missing_Choice (Prev_Hi + 1, Choice_Lo - 1);
                  Error := True;
               end if;
            end if;
         end if;
      end Check_Against_Predicate;

      ----------------------
      -- Check_Duplicates --
      ----------------------

      procedure Check_Duplicates is
         Choice      : Node_Id;
         Choice_Hi   : Uint;
         Choice_Lo   : Uint;
         Prev_Choice : Node_Id := Empty;
         Prev_Hi     : Uint;

      begin
         Prev_Hi := Expr_Value (Choice_Table (1).Hi);

         for Outer_Index in 2 .. Num_Choices loop
            Choice_Lo := Expr_Value (Choice_Table (Outer_Index).Lo);
            Choice_Hi := Expr_Value (Choice_Table (Outer_Index).Hi);

            --  Choices overlap; this is an error

            if Choice_Lo <= Prev_Hi then
               Choice := Choice_Table (Outer_Index).Node;

               --  Find first previous choice that overlaps

               for Inner_Index in 1 .. Outer_Index - 1 loop
                  if Choice_Lo <=
                       Expr_Value (Choice_Table (Inner_Index).Hi)
                  then
                     Prev_Choice := Choice_Table (Inner_Index).Node;
                     exit;
                  end if;
               end loop;

               pragma Assert (Present (Prev_Choice));

               if Sloc (Prev_Choice) <= Sloc (Choice) then
                  Error_Msg_Sloc := Sloc (Prev_Choice);
                  Dup_Choice (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice);
               else
                  Error_Msg_Sloc := Sloc (Choice);
                  Dup_Choice
                    (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Prev_Choice);
               end if;
            end if;

            if Choice_Hi > Prev_Hi then
               Prev_Hi := Choice_Hi;
            end if;
         end loop;
      end Check_Duplicates;

      ----------------
      -- Dup_Choice --
      ----------------

      procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id) is
      begin
         --  In some situations, we call this with a null range, and obviously
         --  we don't want to complain in this case.

         if Lo > Hi then
            return;
         end if;

         --  Case of only one value that is duplicated

         if Lo = Hi then

            --  Integer type

            if Is_Integer_Type (Bounds_Type) then

               --  We have an integer value, Lo, but if the given choice
               --  placement is a constant with that value, then use the
               --  name of that constant instead in the message:

               if Nkind (C) = N_Identifier
                 and then Compile_Time_Known_Value (C)
                 and then Expr_Value (C) = Lo
               then
                  Error_Msg_N
                    ("duplication of choice value: &#!", Original_Node (C));

               --  Not that special case, so just output the integer value

               else
                  Error_Msg_Uint_1 := Lo;
                  Error_Msg_N
                    ("duplication of choice value: ^#!", Original_Node (C));
               end if;

            --  Enumeration type

            else
               Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type);
               Error_Msg_N
                 ("duplication of choice value: %#!", Original_Node (C));
            end if;

         --  More than one choice value, so print range of values

         else
            --  Integer type

            if Is_Integer_Type (Bounds_Type) then

               --  Similar to the above, if C is a range of known values which
               --  match Lo and Hi, then use the names. We have to go to the
               --  original nodes, since the values will have been rewritten
               --  to their integer values.

               if Nkind (C) = N_Range
                 and then Nkind (Original_Node (Low_Bound  (C))) = N_Identifier
                 and then Nkind (Original_Node (High_Bound (C))) = N_Identifier
                 and then Compile_Time_Known_Value (Low_Bound (C))
                 and then Compile_Time_Known_Value (High_Bound (C))
                 and then Expr_Value (Low_Bound (C))  = Lo
                 and then Expr_Value (High_Bound (C)) = Hi
               then
                  Error_Msg_Node_2 := Original_Node (High_Bound (C));
                  Error_Msg_N
                    ("duplication of choice values: & .. &#!",
                     Original_Node (Low_Bound (C)));

               --  Not that special case, output integer values

               else
                  Error_Msg_Uint_1 := Lo;
                  Error_Msg_Uint_2 := Hi;
                  Error_Msg_N
                    ("duplication of choice values: ^ .. ^#!",
                     Original_Node (C));
               end if;

            --  Enumeration type

            else
               Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type);
               Error_Msg_Name_2 := Choice_Image (Hi, Bounds_Type);
               Error_Msg_N
                 ("duplication of choice values: % .. %#!", Original_Node (C));
            end if;
         end if;
      end Dup_Choice;

      ------------------------------
      -- Explain_Non_Static_Bound --
      ------------------------------

      procedure Explain_Non_Static_Bound is
         Expr : Node_Id;

      begin
         if Nkind (Case_Node) = N_Variant_Part then
            Expr := Name (Case_Node);
         else
            Expr := Expression (Case_Node);
         end if;

         if Bounds_Type /= Subtyp then

            --  If the case is a variant part, the expression is given by the
            --  discriminant itself, and the bounds are the culprits.

            if Nkind (Case_Node) = N_Variant_Part then
               Error_Msg_NE
                 ("bounds of & are not static, "
                  & "alternatives must cover base type!", Expr, Expr);

            --  If this is a case statement, the expression may be nonstatic
            --  or else the subtype may be at fault.

            elsif Is_Entity_Name (Expr) then
               Error_Msg_NE
                 ("bounds of & are not static, "
                  & "alternatives must cover base type!", Expr, Expr);

            else
               Error_Msg_N
                 ("subtype of expression is not static, "
                  & "alternatives must cover base type!", Expr);
            end if;

         --  Otherwise the expression is not static, even if the bounds of the
         --  type are, or else there are missing alternatives. If both, the
         --  additional information may be redundant but harmless. Examine
         --  whether original node is an entity, because it may have been
         --  constant-folded to a literal if value is known.

         elsif not Is_Entity_Name (Original_Node (Expr)) then
            Error_Msg_N
              ("subtype of expression is not static, "
               & "alternatives must cover base type!", Expr);
         end if;
      end Explain_Non_Static_Bound;

      ---------------
      -- Lt_Choice --
      ---------------

      function Lt_Choice (C1, C2 : Natural) return Boolean is
      begin
         return
           Expr_Value (Choice_Table (Nat (C1)).Lo)
             <
           Expr_Value (Choice_Table (Nat (C2)).Lo);
      end Lt_Choice;

      --------------------
      -- Missing_Choice --
      --------------------

      procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id) is
      begin
         Missing_Choice (Expr_Value (Value1), Expr_Value (Value2));
      end Missing_Choice;

      procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint) is
      begin
         Missing_Choice (Expr_Value (Value1), Value2);
      end Missing_Choice;

      procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id) is
      begin
         Missing_Choice (Value1, Expr_Value (Value2));
      end Missing_Choice;

      --------------------
      -- Missing_Choice --
      --------------------

      procedure Missing_Choice (Value1 : Uint; Value2 : Uint) is
      begin
         --  AI05-0188 : within an instance the non-others choices do not have
         --  to belong to the actual subtype.

         if Ada_Version >= Ada_2012 and then In_Instance then
            return;

         --  In some situations, we call this with a null range, and obviously
         --  we don't want to complain in this case.

         elsif Value1 > Value2 then
            return;

         --  If predicate is already known to be violated, do not check for
         --  coverage error, to prevent cascaded messages.

         elsif Predicate_Error then
            return;
         end if;

         --  Case of only one value that is missing

         if Value1 = Value2 then
            if Is_Integer_Type (Bounds_Type) then
               Error_Msg_Uint_1 := Value1;
               Error_Msg_N ("missing case value: ^!", Case_Node);
            else
               Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
               Error_Msg_N ("missing case value: %!", Case_Node);
            end if;

         --  More than one choice value, so print range of values

         else
            if Is_Integer_Type (Bounds_Type) then
               Error_Msg_Uint_1 := Value1;
               Error_Msg_Uint_2 := Value2;
               Error_Msg_N ("missing case values: ^ .. ^!", Case_Node);
            else
               Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
               Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type);
               Error_Msg_N ("missing case values: % .. %!", Case_Node);
            end if;
         end if;
      end Missing_Choice;

      ---------------------
      -- Missing_Choices --
      ---------------------

      procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint) is
         Hi  : Uint;
         Lo  : Uint;
         Set : Node_Id;

      begin
         Set := Pred;
         while Present (Set) loop
            Lo := Expr_Value (Low_Bound (Set));
            Hi := Expr_Value (High_Bound (Set));

            --  A choice covered part of a static predicate set

            if Lo <= Prev_Hi and then Prev_Hi < Hi then
               Missing_Choice (Prev_Hi + 1, Hi);

            else
               Missing_Choice (Lo, Hi);
            end if;

            Next (Set);
         end loop;
      end Missing_Choices;

      -----------------
      -- Move_Choice --
      -----------------

      procedure Move_Choice (From : Natural; To : Natural) is
      begin
         Choice_Table (Nat (To)) := Choice_Table (Nat (From));
      end Move_Choice;

      --  Local variables

      Bounds_Hi     : constant Node_Id := Type_High_Bound (Bounds_Type);
      Bounds_Lo     : constant Node_Id := Type_Low_Bound  (Bounds_Type);
      Has_Predicate : constant Boolean :=
                        Is_OK_Static_Subtype (Bounds_Type)
                          and then Has_Static_Predicate (Bounds_Type);

      Choice_Hi   : Uint;
      Choice_Lo   : Uint;
      Pred        : Node_Id;
      Prev_Lo     : Uint;
      Prev_Hi     : Uint;

   --  Start of processing for Check_Choice_Set

   begin
      --  If the case is part of a predicate aspect specification, do not
      --  recheck it against itself.

      if Present (Parent (Case_Node))
        and then Nkind (Parent (Case_Node)) = N_Aspect_Specification
      then
         return;
      end if;

      --  Choice_Table must start at 0 which is an unused location used by the
      --  sorting algorithm. However the first valid position for a discrete
      --  choice is 1.

      pragma Assert (Choice_Table'First = 0);

      --  The choices do not cover the base range. Emit an error if "others" is
      --  not available and return as there is no need for further processing.

      if Num_Choices = 0 then
         if not Others_Present then
            Missing_Choice (Bounds_Lo, Bounds_Hi);
         end if;

         return;
      end if;

      Sorting.Sort (Positive (Choice_Table'Last));

      --  First check for duplicates. This involved the choices; predicates, if
      --  any, are irrelevant.

      Check_Duplicates;

      --  Then check for overlaps

      --  If the subtype has a static predicate, the predicate defines subsets
      --  of legal values and requires finer-grained analysis.

      --  Note that in GNAT the predicate is considered static if the predicate
      --  expression is static, independently of whether the aspect mentions
      --  Static explicitly.

      if Has_Predicate then
         Pred := First (Static_Discrete_Predicate (Bounds_Type));

         --  Make initial value smaller than 'First of type, so that first
         --  range comparison succeeds. This applies both to integer types
         --  and to enumeration types.

         Prev_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)) - 1;
         Prev_Hi := Prev_Lo;

         declare
            Error : Boolean := False;
         begin
            for Index in 1 .. Num_Choices loop
               Check_Against_Predicate
                 (Pred    => Pred,
                  Choice  => Choice_Table (Index),
                  Prev_Lo => Prev_Lo,
                  Prev_Hi => Prev_Hi,
                  Error   => Error);

               --  The analysis detected an illegal intersection between a
               --  choice and a static predicate set. Do not examine other
               --  choices unless all errors are requested.

               if Error then
                  Predicate_Error := True;

                  if not All_Errors_Mode then
                     return;
                  end if;
               end if;
            end loop;
         end;

         if Predicate_Error then
            return;
         end if;

         --  The choices may legally cover some of the static predicate sets,
         --  but not all. Emit an error for each non-covered set.

         if not Others_Present then
            Missing_Choices (Pred, Prev_Hi);
         end if;

      --  Default analysis

      else
         Choice_Lo := Expr_Value (Choice_Table (1).Lo);
         Choice_Hi := Expr_Value (Choice_Table (1).Hi);
         Prev_Hi   := Choice_Hi;

         if not Others_Present and then Expr_Value (Bounds_Lo) < Choice_Lo then
            Missing_Choice (Bounds_Lo, Choice_Lo - 1);

            --  If values are missing outside of the subtype, add explanation.
            --  No additional message if only one value is missing.

            if Expr_Value (Bounds_Lo) < Choice_Lo - 1 then
               Explain_Non_Static_Bound;
            end if;
         end if;

         for Index in 2 .. Num_Choices loop
            Choice_Lo := Expr_Value (Choice_Table (Index).Lo);
            Choice_Hi := Expr_Value (Choice_Table (Index).Hi);

            if Choice_Lo > Prev_Hi + 1 and then not Others_Present then
               Missing_Choice (Prev_Hi + 1, Choice_Lo - 1);
            end if;

            if Choice_Hi > Prev_Hi then
               Prev_Hi := Choice_Hi;
            end if;
         end loop;

         if not Others_Present and then Expr_Value (Bounds_Hi) > Prev_Hi then
            Missing_Choice (Prev_Hi + 1, Bounds_Hi);

            if Expr_Value (Bounds_Hi) > Prev_Hi + 1 then
               Explain_Non_Static_Bound;
            end if;
         end if;
      end if;
   end Check_Choice_Set;

   ------------------
   -- Choice_Image --
   ------------------

   function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id is
      Rtp : constant Entity_Id := Root_Type (Ctype);
      Lit : Entity_Id;
      C   : Int;

   begin
      --  For character, or wide [wide] character. If 7-bit ASCII graphic
      --  range, then build and return appropriate character literal name

      if Is_Standard_Character_Type (Ctype) then
         C := UI_To_Int (Value);

         if C in 16#20# .. 16#7E# then
            Set_Character_Literal_Name (UI_To_CC (Value));
            return Name_Find;
         end if;

      --  For user defined enumeration type, find enum/char literal

      else
         Lit := First_Literal (Rtp);

         for J in 1 .. UI_To_Int (Value) loop
            Next_Literal (Lit);
         end loop;

         --  If enumeration literal, just return its value

         if Nkind (Lit) = N_Defining_Identifier then
            return Chars (Lit);

         --  For character literal, get the name and use it if it is
         --  for a 7-bit ASCII graphic character in 16#20#..16#7E#.

         else
            Get_Decoded_Name_String (Chars (Lit));

            if Name_Len = 3
              and then Name_Buffer (2) in
                Character'Val (16#20#) .. Character'Val (16#7E#)
            then
               return Chars (Lit);
            end if;
         end if;
      end if;

      --  If we fall through, we have a character literal which is not in
      --  the 7-bit ASCII graphic set. For such cases, we construct the
      --  name "type'val(nnn)" where type is the choice type, and nnn is
      --  the pos value passed as an argument to Choice_Image.

      Get_Name_String (Chars (First_Subtype (Ctype)));

      Add_Str_To_Name_Buffer ("'val(");
      UI_Image (Value);
      Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
      Add_Char_To_Name_Buffer (')');
      return Name_Find;
   end Choice_Image;

   package body Composite_Case_Ops is

      function Static_Array_Length (Subtyp : Entity_Id) return Nat;
      --  Given a one-dimensional constrained array subtype with
      --  statically known bounds, return its length.

      -------------------------
      -- Static_Array_Length --
      -------------------------

      function Static_Array_Length (Subtyp : Entity_Id) return Nat is
         pragma Assert (Is_Constrained (Subtyp));
         pragma Assert (Number_Dimensions (Subtyp) = 1);
         Index : constant Node_Id := First_Index (Subtyp);
         pragma Assert (Is_OK_Static_Range (Index));
         Lo  : constant Uint := Expr_Value (Low_Bound (Index));
         Hi  : constant Uint := Expr_Value (High_Bound (Index));
         Len : constant Uint := UI_Max (0, (Hi - Lo) + 1);
      begin
         return UI_To_Int (Len);
      end Static_Array_Length;

      ------------------------
      -- Box_Value_Required --
      ------------------------

      function Box_Value_Required (Subtyp : Entity_Id) return Boolean is
         --  Some of these restrictions will be relaxed eventually, but best
         --  to initially err in the direction of being too restrictive.
      begin
         if Has_Predicates (Subtyp) then
            return True;
         elsif Is_Discrete_Type (Subtyp) then
            if not Is_Static_Subtype (Subtyp) then
               return True;
            elsif Is_Enumeration_Type (Subtyp)
               and then Has_Enumeration_Rep_Clause (Subtyp)
               --  Maybe enumeration rep clauses can be ignored here?
            then
               return True;
            end if;
         elsif Is_Array_Type (Subtyp) then
            if Number_Dimensions (Subtyp) /= 1 then
               return True;
            elsif not Is_Constrained (Subtyp) then
               if not Is_Static_Subtype (Etype (First_Index (Subtyp))) then
                  return True;
               end if;
            elsif not Is_OK_Static_Range (First_Index (Subtyp)) then
               return True;
            end if;
         elsif Is_Record_Type (Subtyp) then
            if Has_Discriminants (Subtyp)
              and then Is_Constrained (Subtyp)
              and then not Has_Static_Discriminant_Constraint (Subtyp)
            then
               --  Perhaps treat differently the case where Subtyp is the
               --  subtype of the top-level selector expression, as opposed
               --  to the subtype of some subcomponent thereof.
               return True;
            end if;
         else
            --  Return True for any type that is not a discrete type,
            --  a record type, or an array type.
            return True;
         end if;

         return False;
      end Box_Value_Required;

      ------------------
      -- Choice_Count --
      ------------------

      function Choice_Count (Alternatives : List_Id) return Nat is
         Result : Nat := 0;
         Alt : Node_Id := First (Alternatives);
      begin
         while Present (Alt) loop
            Result := Result + List_Length (Discrete_Choices (Alt));
            Next (Alt);
         end loop;
         return Result;
      end Choice_Count;

      -------------------------------
      -- Normalized_Case_Expr_Type --
      -------------------------------

      function Normalized_Case_Expr_Type
        (Case_Statement : Node_Id) return Entity_Id
      is
         Unnormalized : constant Entity_Id :=
           Etype (Expression (Case_Statement));

         Is_Dynamically_Constrained_Array : constant Boolean :=
           Is_Array_Type (Unnormalized)
             and then Is_Constrained (Unnormalized)
             and then not Has_Static_Array_Bounds (Unnormalized);

         Is_Dynamically_Constrained_Record : constant Boolean :=
           Is_Record_Type (Unnormalized)
             and then Has_Discriminants (Unnormalized)
             and then Is_Constrained (Unnormalized)
             and then not Has_Static_Discriminant_Constraint (Unnormalized);
      begin
         if Is_Dynamically_Constrained_Array
           or Is_Dynamically_Constrained_Record
         then
            return Base_Type (Unnormalized);
         else
            return Unnormalized;
         end if;
      end Normalized_Case_Expr_Type;

      -----------------------
      -- Scalar_Part_Count --
      -----------------------

      function Scalar_Part_Count (Subtyp : Entity_Id) return Nat is
      begin
         if Box_Value_Required (Subtyp) then
            return 0; -- component does not participate in case selection
         elsif Is_Scalar_Type (Subtyp) then
            return 1;
         elsif Is_Array_Type (Subtyp) then
            return Static_Array_Length (Subtyp)
              * Scalar_Part_Count (Component_Type (Subtyp));
         elsif Is_Record_Type (Subtyp) then
            declare
               Result : Nat := 0;
               Comp : Entity_Id := First_Component_Or_Discriminant
                                     (Base_Type (Subtyp));
            begin
               while Present (Comp) loop
                  Result := Result + Scalar_Part_Count (Etype (Comp));
                  Next_Component_Or_Discriminant (Comp);
               end loop;
               return Result;
            end;
         else
            pragma Assert (Serious_Errors_Detected > 0);
            return 0;
         end if;
      end Scalar_Part_Count;

      package body Array_Case_Ops is

         -------------------------
         -- Array_Choice_Length --
         -------------------------

         function Array_Choice_Length (Choice : Node_Id) return Nat is
         begin
            case Nkind (Choice) is
               when N_String_Literal =>
                  return String_Length (Strval (Choice));
               when N_Aggregate =>
                  declare
                     Bounds : constant Node_Id :=
                       Aggregate_Bounds (Choice);
                     pragma Assert (Is_OK_Static_Range (Bounds));
                     Lo     : constant Uint :=
                       Expr_Value (Low_Bound (Bounds));
                     Hi     : constant Uint :=
                       Expr_Value (High_Bound (Bounds));
                     Len : constant Uint := (Hi - Lo) + 1;
                  begin
                     return UI_To_Int (Len);
                  end;
               when N_Has_Entity =>
                  if Present (Entity (Choice))
                    and then Ekind (Entity (Choice)) = E_Constant
                  then
                     return Array_Choice_Length
                              (Expression (Parent (Entity (Choice))));
                  end if;
               when N_Others_Choice =>
                  return 0;
               when others =>
                  null;
            end case;

            if Nkind (Original_Node (Choice))
                 in N_String_Literal | N_Aggregate
            then
               return Array_Choice_Length (Original_Node (Choice));
            end if;

            Error_Msg_N ("Unsupported case choice", Choice);
            return 0;
         end Array_Choice_Length;

         ------------------------------------------
         -- Unconstrained_Array_Effective_Length --
         ------------------------------------------

         function Unconstrained_Array_Effective_Length
           (Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat
         is
            pragma Assert (Is_Array_Type (Array_Type));
            --  Array_Type is otherwise unreferenced for now.

            Result : Nat := 0;
            Alt : Node_Id := First (Alternatives (Case_Statement));
         begin
            while Present (Alt) loop
               declare
                  Choice : Node_Id := First (Discrete_Choices (Alt));
               begin
                  while Present (Choice) loop
                     Result := Nat'Max (Result, Array_Choice_Length (Choice));
                     Next (Choice);
                  end loop;
               end;
               Next (Alt);
            end loop;

            return Result;
         end Unconstrained_Array_Effective_Length;

         -------------------------------------------
         -- Unconstrained_Array_Scalar_Part_Count --
         -------------------------------------------

         function Unconstrained_Array_Scalar_Part_Count
           (Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat
         is
         begin
            --  Add one for the length, which is treated like a discriminant

            return 1 + (Unconstrained_Array_Effective_Length
                          (Array_Type     => Array_Type,
                           Case_Statement => Case_Statement)
                        * Scalar_Part_Count (Component_Type (Array_Type)));
         end Unconstrained_Array_Scalar_Part_Count;

      end Array_Case_Ops;

      package body Choice_Analysis is

         function Component_Bounds_Info return Composite_Range_Info;
         --  Returns the (statically known) bounds for each component.
         --  The selector expression value (or any other value of the type
         --  of the selector expression) can be thought of as a point in the
         --  Cartesian product of these sets.

         function Parse_Choice (Choice : Node_Id;
                                Alt    : Node_Id) return Choice_Range_Info;
         --  Extract Choice_Range_Info from a Choice node

         ---------------------------
         -- Component_Bounds_Info --
         ---------------------------

         function Component_Bounds_Info return Composite_Range_Info is
            Result : Composite_Range_Info;
            Next   : Part_Id := 1;
            Done   : Boolean := False;

            procedure Update_Result (Info : Discrete_Range_Info);
            --  Initialize first remaining uninitialized element of Result.
            --  Also set Next and Done.

            -------------------
            -- Update_Result --
            -------------------

            procedure Update_Result (Info : Discrete_Range_Info) is
            begin
               Result (Next) := Info;
               if Next /= Part_Id'Last then
                  Next := Next + 1;
               else
                  pragma Assert (not Done);
                  Done := True;
               end if;
            end Update_Result;

            procedure Traverse_Discrete_Parts (Subtyp : Entity_Id);
            --  Traverse the given subtype, looking for discrete parts.
            --  For an array subtype of length N, the element subtype
            --  is traversed N times. For a record subtype, traverse
            --  each component's subtype (once). When a discrete part is
            --  found, call Update_Result.

            -----------------------------
            -- Traverse_Discrete_Parts --
            -----------------------------

            procedure Traverse_Discrete_Parts (Subtyp : Entity_Id) is
            begin
               if Box_Value_Required (Subtyp) then
                  return;
               end if;

               if Is_Discrete_Type (Subtyp) then
                  Update_Result
                    ((Low  => Expr_Value (Type_Low_Bound (Subtyp)),
                      High => Expr_Value (Type_High_Bound (Subtyp))));
               elsif Is_Array_Type (Subtyp) then
                  declare
                     Len : Nat;
                  begin
                     if Is_Constrained (Subtyp) then
                        Len := Static_Array_Length (Subtyp);
                     else
                        --  Length will be treated like a discriminant;
                        --  We could compute High more precisely as
                        --    1 + Index_Subtype'Last - Index_Subtype'First
                        --  (we currently require that those bounds be
                        --  static, so this is an option), but only downside of
                        --  overshooting is if somebody wants to omit a
                        --  "when others" choice and exhaustively cover all
                        --  possibilities explicitly.
                        Update_Result
                          ((Low  => Uint_0,
                            High => Uint_2 ** Uint_32));

                        Len := Unconstrained_Array_Effective_Length
                                 (Array_Type     => Subtyp,
                                  Case_Statement => Case_Statement);
                     end if;
                     for I in 1 .. Len loop
                        Traverse_Discrete_Parts (Component_Type (Subtyp));
                     end loop;
                  end;
               elsif Is_Record_Type (Subtyp) then
                  if Has_Static_Discriminant_Constraint (Subtyp) then

                     --  The component range for a constrained discriminant
                     --  is a single value.
                     declare
                        Dc_Elmt : Elmt_Id :=
                          First_Elmt (Discriminant_Constraint (Subtyp));
                        Dc_Value : Uint;
                     begin
                        while Present (Dc_Elmt) loop
                           Dc_Value := Expr_Value (Node (Dc_Elmt));
                           Update_Result ((Low  => Dc_Value,
                                           High => Dc_Value));

                           Next_Elmt (Dc_Elmt);
                        end loop;
                     end;

                     --  Generate ranges for nondiscriminant components.
                     declare
                        Comp : Entity_Id := First_Component
                                              (Base_Type (Subtyp));
                     begin
                        while Present (Comp) loop
                           Traverse_Discrete_Parts (Etype (Comp));
                           Next_Component (Comp);
                        end loop;
                     end;
                  else
                     --  Generate ranges for all components
                     declare
                        Comp : Entity_Id :=
                          First_Component_Or_Discriminant
                            (Base_Type (Subtyp));
                     begin
                        while Present (Comp) loop
                           Traverse_Discrete_Parts (Etype (Comp));
                           Next_Component_Or_Discriminant (Comp);
                        end loop;
                     end;
                  end if;
               else
                  Error_Msg_N
                    ("case selector type having a non-discrete non-record"
                     & "  non-array subcomponent type not implemented",
                     Expression (Case_Statement));
               end if;
            end Traverse_Discrete_Parts;

         begin
            Traverse_Discrete_Parts (Case_Expr_Type);
            pragma Assert (Done or else Serious_Errors_Detected > 0);
            return Result;
         end Component_Bounds_Info;

         Component_Bounds : constant Composite_Range_Info
           := Component_Bounds_Info;

         package Case_Bindings is

            procedure Note_Binding
              (Comp_Assoc : Node_Id;
               Choice     : Node_Id;
               Alt        : Node_Id);
            --  Note_Binding is called once for each component association
            --  that defines a binding (using either "A => B is X" or
            --  "A => <X>" syntax);

            procedure Check_Bindings;
            --  After all calls to Note_Binding, check that bindings are
            --  ok (e.g., check consistency among different choices of
            --  one alternative).

         end Case_Bindings;

         procedure Refresh_Binding_Info (Aggr : Node_Id);
         --  The parser records binding-related info in the tree.
         --  The choice nodes that we see here might not be (will never be?)
         --  the original nodes that were produced by the parser. The info
         --  recorded by the parser is missing in that case, so this
         --  procedure recovers it.
         --
         --  There are bugs here. In some cases involving nested aggregates,
         --  the path back to the parser-created nodes is lost. In particular,
         --  we may fail to detect an illegal case like
         --   when (F1 | F2 => (Aa => Natural, Bb => Natural is X)) =>
         --  This should be rejected because it is binding X to both the
         --  F1.Bb and to the F2.Bb subcomponents of the case selector.
         --  It would be nice if the not-specific-to-pattern-matching
         --  aggregate-processing code could remain unaware of the existence
         --  of this binding-related info but perhaps that isn't possible.

         --------------------------
         -- Refresh_Binding_Info --
         --------------------------

         procedure Refresh_Binding_Info (Aggr : Node_Id) is
            Orig_Aggr : constant Node_Id := Original_Node (Aggr);
            Orig_Comp : Node_Id := First (Component_Associations (Orig_Aggr));
         begin
            if Aggr = Orig_Aggr then
               return;
            end if;

            while Present (Orig_Comp) loop
               if Nkind (Orig_Comp) = N_Component_Association
                 and then Binding_Chars (Orig_Comp) /= No_Name
               then
                  if List_Length (Choices (Orig_Comp)) /= 1 then
                     --  Conceivably this could be checked during parsing,
                     --  but checking is easier here.

                     Error_Msg_N
                       ("binding shared by multiple components", Orig_Comp);
                     return;
                  end if;

                  declare
                     Orig_Name : constant Name_Id :=
                       Chars (First (Choices (Orig_Comp)));
                     Comp : Node_Id := First (Component_Associations (Aggr));
                     Matching_Comp : Node_Id := Empty;
                  begin
                     while Present (Comp) loop
                        if Chars (First (Choices (Comp))) = Orig_Name then
                           pragma Assert (No (Matching_Comp));
                           Matching_Comp := Comp;
                        end if;

                        Next (Comp);
                     end loop;

                     pragma Assert (Present (Matching_Comp));

                     Set_Binding_Chars
                       (Matching_Comp,
                        Binding_Chars (Orig_Comp));
                  end;
               end if;

               Next (Orig_Comp);
            end loop;
         end Refresh_Binding_Info;

         ------------------
         -- Parse_Choice --
         ------------------

         function Parse_Choice (Choice : Node_Id;
                                Alt    : Node_Id) return Choice_Range_Info
         is
            Result    : Choice_Range_Info (Is_Others => False);
            Ranges    : Composite_Range_Info renames Result.Ranges;
            Next_Part : Part_Id'Base range 1 .. Part_Id'Last + 1 := 1;

            procedure Traverse_Choice (Expr : Node_Id);
            --  Traverse a legal choice expression, looking for
            --  values/ranges of discrete parts. Call Update_Result
            --  for each.

            procedure Update_Result (Discrete_Range : Discrete_Range_Info);
            --  Initialize first remaining uninitialized element of Ranges.
            --  Also set Next_Part.

            procedure Update_Result_For_Full_Coverage (Comp_Type  : Entity_Id);
            --  For each scalar part of the given component type, call
            --  Update_Result with the full range for that scalar part.
            --  This is used for both box components in aggregates and
            --  for any inactive-variant components that do not appear in
            --  a given aggregate.

            -------------------
            -- Update_Result --
            -------------------

            procedure Update_Result (Discrete_Range : Discrete_Range_Info) is
            begin
               Ranges (Next_Part) := Discrete_Range;
               Next_Part := Next_Part + 1;
            end Update_Result;

            -------------------------------------
            -- Update_Result_For_Full_Coverage --
            -------------------------------------

            procedure Update_Result_For_Full_Coverage (Comp_Type : Entity_Id)
            is
            begin
               for Counter in 1 .. Scalar_Part_Count (Comp_Type) loop
                  Update_Result (Component_Bounds (Next_Part));
               end loop;
            end Update_Result_For_Full_Coverage;

            ---------------------
            -- Traverse_Choice --
            ---------------------

            procedure Traverse_Choice (Expr : Node_Id) is
            begin
               if Nkind (Expr) = N_Qualified_Expression then
                  Traverse_Choice (Expression (Expr));

               elsif Nkind (Expr) = N_Type_Conversion
                  and then not Comes_From_Source (Expr)
               then
                  if Expr /= Original_Node (Expr) then
                     Traverse_Choice (Original_Node (Expr));
                  else
                     Traverse_Choice (Expression (Expr));
                  end if;

               elsif Nkind (Expr) = N_Aggregate then
                  if Is_Record_Type (Etype (Expr)) then
                     Refresh_Binding_Info (Aggr => Expr);

                     declare
                        Comp_Assoc : Node_Id :=
                          First (Component_Associations (Expr));
                        --  Aggregate has been normalized (components in
                        --  order, only one component per choice, etc.).

                        Comp_From_Type : Node_Id :=
                          First_Component_Or_Discriminant
                            (Base_Type (Etype (Expr)));

                        Saved_Next_Part : constant Part_Id := Next_Part;
                     begin
                        while Present (Comp_Assoc) loop
                           pragma Assert
                             (List_Length (Choices (Comp_Assoc)) = 1);

                           declare
                              Comp : constant Node_Id :=
                                Entity (First (Choices (Comp_Assoc)));
                              Comp_Seen : Boolean := False;
                           begin
                              loop
                                 if Original_Record_Component (Comp) =
                                   Original_Record_Component (Comp_From_Type)
                                 then
                                    Comp_Seen := True;
                                 else
                                    --  We have an aggregate of a type that
                                    --  has a variant part (or has a
                                    --  subcomponent type that has a variant
                                    --  part) and we have to deal with a
                                    --  component that is present in the type
                                    --  but not in the aggregate (because the
                                    --  component is in an inactive variant).
                                    --
                                    Update_Result_For_Full_Coverage
                                      (Comp_Type => Etype (Comp_From_Type));
                                 end if;

                                 Comp_From_Type :=
                                   Next_Component_Or_Discriminant
                                     (Comp_From_Type);

                                 exit when Comp_Seen;
                              end loop;
                           end;

                           declare
                              Comp_Type : constant Entity_Id :=
                                Etype (First (Choices (Comp_Assoc)));
                           begin
                              if Box_Value_Required (Comp_Type) then
                                 --  This component is not allowed to
                                 --  influence which alternative is
                                 --  chosen; case choice must be box.
                                 --
                                 --  For example, component might be
                                 --  of a real type or of an access type
                                 --  or of a non-static discrete subtype.
                                 if not Box_Present (Comp_Assoc) then
                                    Error_Msg_N
                                      ("Non-box case choice component value" &
                                         " of unsupported type/subtype",
                                       Expression (Comp_Assoc));
                                 end if;
                              elsif Box_Present (Comp_Assoc) then
                                 --  Box matches all values
                                 Update_Result_For_Full_Coverage
                                   (Etype (First (Choices (Comp_Assoc))));
                              else
                                 Traverse_Choice (Expression (Comp_Assoc));
                              end if;
                           end;

                           if Binding_Chars (Comp_Assoc) /= No_Name
                           then
                              Case_Bindings.Note_Binding
                                (Comp_Assoc => Comp_Assoc,
                                 Choice     => Choice,
                                 Alt        => Alt);
                           end if;

                           Next (Comp_Assoc);
                        end loop;

                        while Present (Comp_From_Type) loop
                           --  Deal with any trailing inactive-variant
                           --  components.
                           --
                           --  See earlier commment about calling
                           --  Update_Result_For_Full_Coverage for such
                           --  components.

                           Update_Result_For_Full_Coverage
                             (Comp_Type => Etype (Comp_From_Type));

                           Comp_From_Type :=
                             Next_Component_Or_Discriminant (Comp_From_Type);
                        end loop;

                        declare
                           Expr_Type : Entity_Id := Etype (Expr);
                        begin
                           if Has_Discriminants (Expr_Type) then
                              --  Avoid nonstatic choice expr types,
                              --  for which Scalar_Part_Count returns 0.
                              Expr_Type := Base_Type (Expr_Type);
                           end if;

                           pragma Assert
                             (Nat (Next_Part - Saved_Next_Part)
                               = Scalar_Part_Count (Expr_Type));
                        end;
                     end;
                  elsif Is_Array_Type (Etype (Expr)) then
                     if Is_Non_Empty_List (Component_Associations (Expr)) then
                        Error_Msg_N
                          ("non-positional array aggregate as/within case "
                           & "choice not implemented", Expr);
                     end if;

                     if not Unconstrained_Array_Case
                        and then List_Length (Expressions (Expr))
                           /= Nat (Part_Id'Last)
                     then
                        Error_Msg_Uint_1 := UI_From_Int
                          (List_Length (Expressions (Expr)));
                        Error_Msg_Uint_2 := UI_From_Int (Int (Part_Id'Last));
                        Error_Msg_N
                          ("array aggregate length ^ does not match length " &
                           "of statically constrained case selector ^", Expr);
                        return;
                     end if;

                     declare
                        Subexpr : Node_Id := First (Expressions (Expr));
                     begin
                        while Present (Subexpr) loop
                           Traverse_Choice (Subexpr);
                           Next (Subexpr);
                        end loop;
                     end;
                  else
                     raise Program_Error;
                  end if;
               elsif Nkind (Expr) = N_String_Literal then
                  if not Is_Array_Type (Etype (Expr)) then
                     Error_Msg_N
                       ("User-defined string literal not allowed as/within"
                        & "case choice", Expr);
                  else
                     declare
                        Char_Type : constant Entity_Id :=
                          Root_Type (Component_Type (Etype (Expr)));

                        --  If the component type is not a standard character
                        --  type then this string lit should have already been
                        --  transformed into an aggregate in
                        --  Resolve_String_Literal.
                        --
                        pragma Assert (Is_Standard_Character_Type (Char_Type));

                        Str      : constant String_Id := Strval (Expr);
                        Strlen   : constant Nat       := String_Length (Str);
                        Char_Val : Uint;
                     begin
                        if not Unconstrained_Array_Case
                           and then Strlen /= Nat (Part_Id'Last)
                        then
                           Error_Msg_Uint_1 := UI_From_Int (Strlen);
                           Error_Msg_Uint_2 := UI_From_Int
                             (Int (Part_Id'Last));
                           Error_Msg_N
                             ("String literal length ^ does not match length" &
                              " of statically constrained case selector ^",
                              Expr);
                           return;
                        end if;

                        for Idx in 1 .. Strlen loop
                           Char_Val :=
                             UI_From_CC (Get_String_Char (Str, Idx));
                           Update_Result ((Low | High => Char_Val));
                        end loop;
                     end;
                  end if;
               elsif Is_Discrete_Type (Etype (Expr)) then
                  if Nkind (Expr) in N_Has_Entity
                    and then Present (Entity (Expr))
                    and then Is_Type (Entity (Expr))
                  then
                     declare
                        Low  : constant Node_Id :=
                          Type_Low_Bound (Entity (Expr));
                        High : constant Node_Id :=
                          Type_High_Bound (Entity (Expr));
                     begin
                        Update_Result ((Low  => Expr_Value (Low),
                                        High => Expr_Value (High)));
                     end;
                  else
                     pragma Assert (Compile_Time_Known_Value (Expr));
                     Update_Result ((Low | High => Expr_Value (Expr)));
                  end if;
               elsif Nkind (Expr) in N_Has_Entity
                 and then Present (Entity (Expr))
                 and then Ekind (Entity (Expr)) = E_Constant
               then
                  Traverse_Choice (Expression (Parent (Entity (Expr))));
               elsif Nkind (Original_Node (Expr))
                       in N_Aggregate | N_String_Literal
               then
                  Traverse_Choice (Original_Node (Expr));
               else
                  Error_Msg_N
                    ("non-aggregate case choice (or subexpression thereof)"
                     & " that is not of a discrete type not implemented",
                     Expr);
               end if;
            end Traverse_Choice;

         --  Start of processing for Parse_Choice

         begin
            if Nkind (Choice) = N_Others_Choice then
               return (Is_Others => True);
            end if;

            if Unconstrained_Array_Case then
               --  Treat length like a discriminant
               Update_Result ((Low | High =>
                                 UI_From_Int (Array_Choice_Length (Choice))));
            end if;

            Traverse_Choice (Choice);

            if Unconstrained_Array_Case then
               --  This is somewhat tricky. Suppose we are casing on String,
               --  the longest choice in the case statement is length 10, and
               --  the choice we are looking at now is of length 6. We fill
               --  in the trailing 4 slots here.
               while Next_Part <= Part_Id'Last loop
                  Update_Result_For_Full_Coverage
                    (Comp_Type => Component_Type (Case_Expr_Type));
               end loop;
            end if;

            --  Avoid returning uninitialized garbage in error case
            if Next_Part /= Part_Id'Last + 1 then
               pragma Assert (Serious_Errors_Detected > 0);
               Result.Ranges := (others => (Low => Uint_1, High => Uint_0));
            end if;

            return Result;
         end Parse_Choice;

         package body Case_Bindings is

            type Binding is record
               Comp_Assoc : Node_Id;
               Choice     : Node_Id;
               Alt        : Node_Id;
            end record;

            type Binding_Index is new Natural;

            package Case_Bindings_Table is new Table.Table
              (Table_Component_Type => Binding,
               Table_Index_Type     => Binding_Index,
               Table_Low_Bound      => 1,
               Table_Initial        => 16,
               Table_Increment      => 64,
               Table_Name           => "Composite_Case_Ops.Case_Bindings");

            ------------------
            -- Note_Binding --
            ------------------

            procedure Note_Binding
              (Comp_Assoc : Node_Id;
               Choice     : Node_Id;
               Alt        : Node_Id)
            is
            begin
               Case_Bindings_Table.Append
                 ((Comp_Assoc => Comp_Assoc,
                   Choice     => Choice,
                   Alt        => Alt));
            end Note_Binding;

            --------------------
            -- Check_Bindings --
            --------------------

            procedure Check_Bindings
            is
               use Case_Bindings_Table;

               function Binding_Subtype (Idx : Binding_Index;
                                         Tab : Table_Type)
                 return Entity_Id is
                 (Etype (Nlists.First (Choices (Tab (Idx).Comp_Assoc))));

               procedure Declare_Binding_Objects
                  (Alt_Start             : Binding_Index;
                   Alt                   : Node_Id;
                   First_Choice_Bindings : Natural;
                   Tab                   : Table_Type);
               --  Declare the binding objects for a given alternative

               ------------------------------
               --  Declare_Binding_Objects --
               ------------------------------

               procedure Declare_Binding_Objects
                  (Alt_Start             : Binding_Index;
                   Alt                   : Node_Id;
                   First_Choice_Bindings : Natural;
                   Tab                   : Table_Type)
               is
                  Loc : constant Source_Ptr := Sloc (Alt);
                  Declarations : constant List_Id := New_List;
                  Decl         : Node_Id;
                  Obj_Type     : Entity_Id;
                  Def_Id       : Entity_Id;
               begin
                  for FC_Idx in Alt_Start ..
                    Alt_Start + Binding_Index (First_Choice_Bindings - 1)
                  loop
                     Obj_Type := Binding_Subtype (FC_Idx, Tab);
                     Def_Id := Make_Defining_Identifier
                                 (Loc,
                                  Binding_Chars (Tab (FC_Idx).Comp_Assoc));

                     --  Either make a copy or rename the original. At a
                     --  minimum, we do not want a copy if it would need
                     --  finalization. Copies may also introduce problems
                     --  if default init can have side effects (although we
                     --  could suppress such default initialization).
                     --  We have to make a copy in any cases where
                     --  Unrestricted_Access doesn't work.
                     --
                     --  This is where the copy-or-rename decision is made.
                     --  In many cases either way would work and so we have
                     --  some flexibility here.

                     if not Is_By_Copy_Type (Obj_Type) then
                        --  Generate
                        --     type Ref
                        --       is access constant Obj_Type;
                        --     Ptr : Ref := <some bogus value>;
                        --     Obj : Obj_Type renames Ptr.all;
                                       --
                        --  Initialization of Ptr will be generated later
                        --  during expansion.

                        declare
                           Ptr_Type : constant Entity_Id :=
                             Make_Temporary (Loc, 'P');

                           Ptr_Type_Def : constant Node_Id :=
                             Make_Access_To_Object_Definition (Loc,
                               All_Present => True,
                               Subtype_Indication =>
                                 New_Occurrence_Of (Obj_Type, Loc));

                           Ptr_Type_Decl : constant Node_Id :=
                             Make_Full_Type_Declaration (Loc,
                               Ptr_Type,
                               Type_Definition => Ptr_Type_Def);

                           Ptr_Obj : constant Entity_Id :=
                             Make_Temporary (Loc, 'T');

                           --  We will generate initialization code for this
                           --  object later (during expansion) but in the
                           --  meantime we don't want the dereference that
                           --  is generated a few lines below here to be
                           --  transformed into a Raise_C_E. To prevent this,
                           --  we provide a bogus initial value here; this
                           --  initial value will be removed later during
                           --  expansion.

                           Ptr_Obj_Decl : constant Node_Id :=
                             Make_Object_Declaration
                               (Loc, Ptr_Obj,
                                Object_Definition =>
                                  New_Occurrence_Of (Ptr_Type, Loc),
                                Expression =>
                                  Unchecked_Convert_To
                                    (Ptr_Type,
                                     Make_Integer_Literal (Loc, 5432)));
                        begin
                           Mutate_Ekind (Ptr_Type, E_Access_Type);

                           --  in effect, Storage_Size => 0
                           Set_No_Pool_Assigned (Ptr_Type);

                           Set_Is_Access_Constant (Ptr_Type);

                           --  We could set Ptr_Type'Alignment here if that
                           --  ever turns out to be needed for renaming a
                           --  misaligned subcomponent.

                           Mutate_Ekind (Ptr_Obj, E_Variable);
                           Set_Etype (Ptr_Obj, Ptr_Type);

                           Decl :=
                             Make_Object_Renaming_Declaration
                               (Loc, Def_Id,
                                Subtype_Mark =>
                                  New_Occurrence_Of (Obj_Type, Loc),
                                Name =>
                                  Make_Explicit_Dereference
                                    (Loc, New_Occurrence_Of (Ptr_Obj, Loc)));

                           Append_To (Declarations, Ptr_Type_Decl);
                           Append_To (Declarations, Ptr_Obj_Decl);
                        end;
                     else
                        Decl := Make_Object_Declaration
                          (Sloc => Loc,
                           Defining_Identifier => Def_Id,
                           Object_Definition =>
                              New_Occurrence_Of (Obj_Type, Loc));
                     end if;
                     Append_To (Declarations, Decl);
                  end loop;

                  declare
                     Old_Statements : constant List_Id := Statements (Alt);
                     New_Statements : constant List_Id := New_List;

                     Block_Statement : constant Node_Id :=
                       Make_Block_Statement (Sloc => Loc,
                         Declarations => Declarations,
                         Handled_Statement_Sequence =>
                           Make_Handled_Sequence_Of_Statements
                             (Loc, Old_Statements),
                         Has_Created_Identifier => True);
                  begin
                     Append_To (New_Statements, Block_Statement);
                     Set_Statements (Alt, New_Statements);
                  end;
               end Declare_Binding_Objects;
            begin
               if Last = 0 then
                  --  no bindings to check
                  return;
               end if;

               declare
                  Tab : Table_Type
                          renames Case_Bindings_Table.Table (1 .. Last);

                  function Same_Id (Idx1, Idx2 : Binding_Index)
                    return Boolean is (
                    Binding_Chars (Tab (Idx1).Comp_Assoc) =
                    Binding_Chars (Tab (Idx2).Comp_Assoc));
               begin
                  --  Verify that elements with given choice or alt value
                  --  are contiguous, and that elements with equal
                  --  choice values have same alt value.

                  for Idx1 in 2 .. Tab'Last loop
                     if Tab (Idx1 - 1).Choice /= Tab (Idx1).Choice then
                        pragma Assert
                          (for all Idx2 in Idx1 + 1 .. Tab'Last =>
                             Tab (Idx2).Choice /= Tab (Idx1 - 1).Choice);
                     else
                        pragma Assert (Tab (Idx1 - 1).Alt = Tab (Idx1).Alt);
                     end if;
                     if Tab (Idx1 - 1).Alt /= Tab (Idx1).Alt then
                        pragma Assert
                          (for all Idx2 in Idx1 + 1 .. Tab'Last =>
                             Tab (Idx2).Alt /= Tab (Idx1 - 1).Alt);
                     end if;
                  end loop;

                  --  Check for user errors:
                  --  1) Two choices for a given alternative shall define the
                  --     same set of names. Can't have
                  --        when (<X>, 0) | (0, <Y>) =>
                  --  2) A choice shall not define a name twice. Can't have
                  --        when (A => <X>, B => <X>, C => 0) =>
                  --  3) Two definitions of a name within one alternative
                  --     shall have statically matching component subtypes.
                  --     Can't have
                  --        type R is record Int : Integer;
                  --                         Nat : Natural; end record;
                  --        case R'(...) is
                  --          when (<X>, 1) | (1, <X>) =>
                  --  4) A given binding shall match only one value.
                  --     Can't have
                  --         (Fld1 | Fld2 => (Fld => <X>))
                  --     For now, this is enforced *very* conservatively
                  --     with respect to arrays - a binding cannot match
                  --     any part of an array. This is temporary.

                  for Idx1 in Tab'Range loop
                     if Idx1 = 1
                       or else Tab (Idx1 - 1).Alt /= Tab (Idx1).Alt
                     then
                        --  Process one alternative
                        declare
                           Alt_Start : constant Binding_Index := Idx1;
                           Alt : constant Node_Id := Tab (Alt_Start).Alt;

                           First_Choice : constant Node_Id :=
                             Nlists.First (Discrete_Choices (Alt));
                           First_Choice_Bindings : Natural := 0;
                        begin
                           --  Check for duplicates within one choice,
                           --  and for choices with no bindings.

                           if First_Choice /= Tab (Alt_Start).Choice then
                              Error_Msg_N ("binding(s) missing for choice",
                                           First_Choice);
                              return;
                           end if;

                           declare
                              Current_Choice : Node_Id := First_Choice;
                              Choice_Start : Binding_Index := Alt_Start;
                           begin
                              for Idx2 in Alt_Start .. Tab'Last loop
                                 exit when Tab (Idx2).Alt /= Alt;
                                 if Tab (Idx2).Choice = Current_Choice then
                                    for Idx3 in Choice_Start .. Idx2 - 1 loop
                                       if Same_Id (Idx2, Idx3)
                                       then
                                          Error_Msg_N
                                            ("duplicate binding in choice",
                                             Current_Choice);
                                          return;
                                       end if;
                                    end loop;
                                 else
                                    Next (Current_Choice);
                                    pragma Assert (Present (Current_Choice));
                                    Choice_Start := Idx2;

                                    if Tab (Idx2).Choice /= Current_Choice
                                    then
                                       Error_Msg_N
                                         ("binding(s) missing for choice",
                                          Current_Choice);
                                       return;
                                    end if;
                                 end if;
                              end loop;

                              --  If we made it through all the bindings
                              --  for this alternative but didn't make it
                              --  to the last choice, then bindings are
                              --  missing for all remaining choices.
                              --  We only complain about the first one.

                              if Present (Next (Current_Choice)) then
                                 Error_Msg_N
                                   ("binding(s) missing for choice",
                                     Next (Current_Choice));
                                 return;
                              end if;
                           end;

                           --  Count bindings for first choice of alternative

                           for FC_Idx in Alt_Start .. Tab'Last loop
                              exit when Tab (FC_Idx).Choice /= First_Choice;
                              First_Choice_Bindings :=
                                First_Choice_Bindings + 1;
                           end loop;

                           declare
                              Current_Choice : Node_Id := First_Choice;
                              Current_Choice_Bindings : Natural := 0;
                           begin
                              for Idx2 in Alt_Start .. Tab'Last loop
                                 exit when Tab (Idx2).Alt /= Alt;

                                 --  If starting a new choice

                                 if Tab (Idx2).Choice /= Current_Choice then

                                    --  Check count for choice just finished

                                    if Current_Choice_Bindings
                                      /= First_Choice_Bindings
                                    then
                                       Error_Msg_N
                                         ("subsequent choice has different"
                                          & " number of bindings than first"
                                          & " choice", Current_Choice);
                                    end if;

                                    Current_Choice := Tab (Idx2).Choice;
                                    Current_Choice_Bindings := 1;

                                    --  Remember that Alt has both one or more
                                    --  bindings and two or more choices; we'll
                                    --  need to know this during expansion.

                                    Set_Multidefined_Bindings (Alt, True);
                                 else
                                    Current_Choice_Bindings :=
                                      Current_Choice_Bindings + 1;
                                 end if;

                                 --  Check that first choice has binding with
                                 --  matching name; check subtype consistency.

                                 declare
                                    Found : Boolean := False;
                                 begin
                                    for FC_Idx in
                                      Alt_Start ..
                                      Alt_Start + Binding_Index
                                                    (First_Choice_Bindings - 1)
                                    loop
                                       if Same_Id (Idx2, FC_Idx) then
                                          if not Subtypes_Statically_Match
                                            (Binding_Subtype (Idx2, Tab),
                                             Binding_Subtype (FC_Idx, Tab))
                                          then
                                             Error_Msg_N
                                               ("subtype of binding in "
                                                & "subsequent choice does not "
                                                & "match that in first choice",
                                                Tab (Idx2).Comp_Assoc);
                                          end if;
                                          Found := True;
                                          exit;
                                       end if;
                                    end loop;

                                    if not Found then
                                       Error_Msg_N
                                         ("binding defined in subsequent "
                                          & "choice not defined in first "
                                          & "choice", Current_Choice);
                                    end if;
                                 end;

                                 --  Check for illegal repeated binding
                                 --  via an enclosing aggregate, as in
                                 --  (F1 | F2 => (F3 => Natural is X,
                                 --               F4 => Natural))
                                 --  where the inner aggregate would be ok.

                                 declare
                                    Rover : Node_Id := Tab (Idx2).Comp_Assoc;
                                 begin
                                    while Rover /= Tab (Idx2).Choice loop
                                       Rover :=
                                         (if Is_List_Member (Rover) then
                                            Parent (List_Containing (Rover))
                                          else Parent (Rover));
                                       pragma Assert (Present (Rover));
                                       if Nkind (Rover)
                                         = N_Component_Association
                                         and then List_Length (Choices (Rover))
                                         > 1
                                       then
                                          Error_Msg_N
                                            ("binding shared by multiple "
                                                & "enclosing components",
                                             Tab (Idx2).Comp_Assoc);
                                       end if;
                                    end loop;
                                 end;
                              end loop;
                           end;

                           --  Construct the (unanalyzed) declarations for
                           --  the current alternative. Then analyze them.

                           if First_Choice_Bindings > 0 then
                              Declare_Binding_Objects
                                (Alt_Start             => Alt_Start,
                                 Alt                   => Alt,
                                 First_Choice_Bindings =>
                                   First_Choice_Bindings,
                                 Tab                   => Tab);
                           end if;
                        end;
                     end if;
                  end loop;
               end;
            end Check_Bindings;
         end Case_Bindings;

         function Choice_Bounds_Info return Choices_Range_Info;
         --  Returns mapping from any given Choice_Id value to that choice's
         --  component-to-range map.

         ------------------------
         -- Choice_Bounds_Info --
         ------------------------

         function Choice_Bounds_Info return Choices_Range_Info is
            Result : Choices_Range_Info;
            Alt    : Node_Id := First (Alternatives (Case_Statement));
            C_Id   : Choice_Id := 1;
         begin
            while Present (Alt) loop
               declare
                  Choice : Node_Id := First (Discrete_Choices (Alt));
               begin
                  while Present (Choice) loop
                     Result (C_Id) := Parse_Choice (Choice, Alt => Alt);

                     Next (Choice);
                     if C_Id /= Choice_Id'Last then
                        C_Id := C_Id + 1;
                     end if;
                  end loop;
               end;
               Next (Alt);
            end loop;

            pragma Assert (C_Id = Choice_Id'Last);

            --  No more calls to Note_Binding, so time for checks.
            Case_Bindings.Check_Bindings;

            return Result;
         end Choice_Bounds_Info;

         Choices_Bounds : constant Choices_Range_Info := Choice_Bounds_Info;

         package body Value_Sets is
            use GNAT;

            function Hash (Key : Uint) return Bucket_Range_Type is
              (Bucket_Range_Type
                 (UI_To_Int (Key mod (Uint_2 ** Uint_31))));

            package Uint_Sets is new GNAT.Sets.Membership_Sets
              (Uint, "=", Hash);

            type Representative_Values_Array is
              array (Part_Id) of Uint_Sets.Membership_Set;

            function Representative_Values_Init
              return Representative_Values_Array;
            --  Select the representative values for each Part_Id value.
            --  This function is called exactly once, immediately after it
            --  is declared.

            --------------------------------
            -- Representative_Values_Init --
            --------------------------------

            function Representative_Values_Init
              return Representative_Values_Array
            is
               --  For each range of each choice (as well as the range for the
               --  component subtype, which is handled in the first loop),
               --  insert the low bound of the range and the successor of
               --  the high bound into the corresponding R_V element.
               --
               --  The idea we are trying to capture here is somewhat tricky.
               --  Given an arbitrary point P1 in the Cartesian product
               --  of the Component_Bounds sets, we want to be able
               --  to map that to a point P2 in the (smaller) Cartesian product
               --  of the Representative_Values sets that has the property
               --  that for every choice of the case statement, P1 matches
               --  the choice if and only if P2 also matches. Given that,
               --  we can implement the overlapping/containment/etc. rules
               --  safely by just looking at (using brute force enumeration)
               --  the (smaller) Cartesian product of the R_V sets.
               --  We are never going to actually perform this point-to-point
               --  mapping - just the fact that it exists is enough to ensure
               --  we can safely look at just the R_V sets.
               --
               --  The desired mapping can be implemented by mapping a point
               --  P1 to a point P2 by reducing each of P1's coordinates down
               --  to the largest element of the corresponding R_V set that is
               --  less than or equal to the original coordinate value (such
               --  an element Y will always exist because the R_V set for a
               --  given component always includes the low bound of the
               --  component subtype). It then suffices to show that every
               --  choice in the case statement yields the same Boolean result
               --  for P1 as for P2.
               --
               --  Suppose the contrary. Then there is some particular
               --  coordinate position X (i.e., a Part_Id value) and some
               --  choice C where exactly one of P1(X) and P2(X) belongs to
               --  the (contiguous) range associated with C(X); call that
               --  range L .. H. We know that P2(X) <= P1(X) because the
               --  mapping never increases coordinate values. Consider three
               --  cases: P1(X) lies within the L .. H range, or it is greater
               --  than H, or it is lower than L.
               --  The third case is impossible because reducing a value that
               --  is less than L can only produce another such value,
               --  violating the "exactly one" assumption. The second
               --  case is impossible because L belongs to the corresponding
               --  R_V set, so P2(X) >= L and both values belong to the
               --  range, again violating the "exactly one" assumption.
               --  Finally, the third case is impossible because H+1 belongs
               --  to the corresponding R_V set, so P2(X) > H, so neither
               --  value belongs to the range, again violating the "exactly
               --  one" assumption. So our initial supposition was wrong. QED.

               use Uint_Sets;

               Result : constant Representative_Values_Array
                 := (others => Uint_Sets.Create (Initial_Size => 32));

               procedure Insert_Representative (Value : Uint; P : Part_Id);
               --  Insert the given Value into the representative values set
               --  for the given component if it belongs to the component's
               --  subtype. Otherwise, do nothing.

               ---------------------------
               -- Insert_Representative --
               ---------------------------

               procedure Insert_Representative (Value : Uint; P : Part_Id) is
               begin
                  if Value >= Component_Bounds (P).Low and
                    Value <= Component_Bounds (P).High
                  then
                     Insert (Result (P), Value);
                  end if;
               end Insert_Representative;

            begin
               for P in Part_Id loop
                  Insert_Representative (Component_Bounds (P).Low, P);
               end loop;

               if Simplified_Composite_Coverage_Rules then
                  --  Omit other representative values to avoid capacity
                  --  problems building data structures only used in
                  --  compile-time checks that will not be performed.
                  return Result;
               end if;

               for C of Choices_Bounds loop
                  if not C.Is_Others then
                     for P in Part_Id loop
                        if C.Ranges (P).Low <= C.Ranges (P).High then
                           Insert_Representative (C.Ranges (P).Low, P);
                           Insert_Representative (C.Ranges (P).High + 1, P);
                        end if;
                     end loop;
                  end if;
               end loop;
               return Result;
            end Representative_Values_Init;

            Representative_Values : constant Representative_Values_Array
              := Representative_Values_Init;
            --  We want to avoid looking at every point in the Cartesian
            --  product of all component values. Instead we select, for each
            --  component, a set of representative values and then look only
            --  at the Cartesian product of those sets. A single value can
            --  safely represent a larger enclosing interval if every choice
            --  for that component either completely includes or completely
            --  excludes the interval. The elements of this array will be
            --  populated by a call to Initialize_Representative_Values and
            --  will remain constant after that.

            type Value_Index_Base is new Natural;

            function Value_Index_Count return Value_Index_Base;
            --  Returns the product of the sizes of the Representative_Values
            --  sets (i.e., the size of the Cartesian product of the sets).
            --  May return zero if one of the sets is empty.
            --  This function is called exactly once, immediately after it
            --  is declared.

            -----------------------
            -- Value_Index_Count --
            -----------------------

            function Value_Index_Count return Value_Index_Base is
               Result : Value_Index_Base := 1;
            begin
               for Set of Representative_Values loop
                  Result := Result * Value_Index_Base (Uint_Sets.Size (Set));
               end loop;
               return Result;
            exception
               when Constraint_Error =>
                  Error_Msg_N
                    ("Capacity exceeded in compiling case statement with"
                      & " composite selector type", Case_Statement);
                  raise;
            end Value_Index_Count;

            Max_Value_Index : constant Value_Index_Base := Value_Index_Count;

            subtype Value_Index is Value_Index_Base range 1 .. Max_Value_Index;
            type Value_Index_Set is array (Value_Index) of Boolean;

            package Value_Index_Set_Table is new Table.Table
              (Table_Component_Type => Value_Index_Set,
               Table_Index_Type     => Value_Set,
               Table_Low_Bound      => 1,
               Table_Initial        => 16,
               Table_Increment      => 100,
               Table_Name           => "Composite_Case_Ops.Value_Sets");
            --  A nonzero Value_Set value is an index into this table.

            function Indexed (Index : Value_Set) return Value_Index_Set
              is (Value_Index_Set_Table.Table.all (Index));

            function Allocate_Table_Element (Initial_Value : Value_Index_Set)
              return Value_Set;
            --  Allocate and initialize a new table element; return its index.

            ----------------------------
            -- Allocate_Table_Element --
            ----------------------------

            function Allocate_Table_Element (Initial_Value : Value_Index_Set)
              return Value_Set
            is
               use Value_Index_Set_Table;
            begin
               Append (Initial_Value);
               return Last;
            end Allocate_Table_Element;

            procedure Assign_Table_Element (Index : Value_Set;
                                            Value : Value_Index_Set);
            --  Assign specified value to specified table element.

            --------------------------
            -- Assign_Table_Element --
            --------------------------

            procedure Assign_Table_Element (Index : Value_Set;
                                            Value : Value_Index_Set)
            is
            begin
               Value_Index_Set_Table.Table.all (Index) := Value;
            end Assign_Table_Element;

            -------------
            -- Compare --
            -------------

            function Compare (S1, S2 : Value_Set) return Set_Comparison is
            begin
               if S1 = Empty or S2 = Empty then
                  return Disjoint;
               elsif Indexed (S1) = Indexed (S2) then
                  return Equal;
               else
                  declare
                     Intersection : constant Value_Index_Set
                       := Indexed (S1) and Indexed (S2);
                  begin
                     if (for all Flag of Intersection => not Flag) then
                        return Disjoint;
                     elsif Intersection = Indexed (S1) then
                        return Contained_By;
                     elsif Intersection = Indexed (S2) then
                        return Contains;
                     else
                        return Overlaps;
                     end if;
                  end;
               end if;
            end Compare;

            -------------------------
            -- Complement_Is_Empty --
            -------------------------

            function Complement_Is_Empty (Set : Value_Set) return Boolean
              is (Set /= Empty
                  and then (for all Flag of Indexed (Set) => Flag));

            ---------------------
            -- Free_Value_Sets --
            ---------------------

            procedure Free_Value_Sets is
            begin
               Value_Index_Set_Table.Free;
            end Free_Value_Sets;

            -----------
            -- Union --
            -----------

            procedure Union (Target : in out Value_Set; Source : Value_Set) is
            begin
               if Source /= Empty then
                  if Target = Empty then
                     Target := Allocate_Table_Element (Indexed (Source));
                  else
                     Assign_Table_Element
                       (Target, Indexed (Target) or Indexed (Source));
                  end if;
               end if;
            end Union;

            ------------
            -- Remove --
            ------------

            procedure Remove (Target : in out Value_Set; Source : Value_Set) is
            begin
               if Source /= Empty and Target /= Empty then
                  Assign_Table_Element
                    (Target, Indexed (Target) and not Indexed (Source));
                  if (for all V of Indexed (Target) => not V) then
                     Target := Empty;
                  end if;
               end if;
            end Remove;

            ---------------------
            -- Matching_Values --
            ---------------------

            function Matching_Values
              (Info : Composite_Range_Info) return Value_Set
            is
               Matches    : Value_Index_Set;
               Next_Index : Value_Index := 1;
               Done       : Boolean := False;
               Point      : array (Part_Id) of Uint;

               procedure Test_Point_For_Match;
               --  Point identifies a point in the Cartesian product of the
               --  representative value sets. Record whether that Point
               --  belongs to the product-of-ranges specified by Info.

               --------------------------
               -- Test_Point_For_Match --
               --------------------------

               procedure Test_Point_For_Match is
                  function In_Range (Val : Uint; Rang : Discrete_Range_Info)
                    return Boolean is
                    ((Rang.Low <= Val) and then (Val <= Rang.High));
               begin
                  pragma Assert (not Done);
                  Matches (Next_Index) :=
                    (for all P in Part_Id => In_Range (Point (P), Info (P)));
                  if Next_Index = Matches'Last then
                     Done := True;
                  else
                     Next_Index := Next_Index + 1;
                  end if;
               end Test_Point_For_Match;

               procedure Test_Points (P : Part_Id);
               --  Iterate over the Cartesian product of the representative
               --  value sets, calling Test_Point_For_Match for each point.

               -----------------
               -- Test_Points --
               -----------------

               procedure Test_Points (P : Part_Id) is
                  use Uint_Sets;
                  Iter : Iterator := Iterate (Representative_Values (P));
               begin
                  --  We could traverse here in sorted order, as opposed to
                  --  whatever order the set iterator gives us.
                  --  No need for that as long as every iteration over
                  --  a given representative values set yields the same order.
                  --  Not sorting is more efficient, but it makes it harder to
                  --  interpret a Value_Index_Set bit vector when debugging.

                  while Has_Next (Iter) loop
                     Next (Iter, Point (P));

                     --  If we have finished building up a Point value, then
                     --  test it for matching. Otherwise, recurse to continue
                     --  building up a point value.

                     if P = Part_Id'Last then
                        Test_Point_For_Match;
                     else
                        Test_Points (P + 1);
                     end if;
                  end loop;
               end Test_Points;

            begin
               Test_Points (1);
               if (for all Flag of Matches => not Flag) then
                  return Empty;
               end if;
               return Allocate_Table_Element (Matches);
            end Matching_Values;

         end Value_Sets;

         --------------
         -- Analysis --
         --------------

         function Analysis return Choices_Info is
            Result : Choices_Info;
            Alt    : Node_Id := First (Alternatives (Case_Statement));
            A_Id   : Alternative_Id := 1;
            C_Id   : Choice_Id := 1;
         begin
            while Present (Alt) loop
               declare
                  Choice : Node_Id := First (Discrete_Choices (Alt));
               begin
                  while Present (Choice) loop
                     if Nkind (Choice) = N_Others_Choice then
                        pragma Assert (Choices_Bounds (C_Id).Is_Others);
                        Result (C_Id) :=
                          (Alternative => A_Id,
                           Is_Others   => True);
                     else
                        Result (C_Id) :=
                          (Alternative => A_Id,
                           Is_Others   => False,
                           Matches     => Value_Sets.Matching_Values
                                            (Choices_Bounds (C_Id).Ranges));
                     end if;
                     Next (Choice);
                     if C_Id /= Choice_Id'Last then
                        C_Id := C_Id + 1;
                     end if;
                  end loop;
               end;

               Next (Alt);
               if A_Id /= Alternative_Id'Last then
                  A_Id := A_Id + 1;
               end if;
            end loop;

            pragma Assert (A_Id = Alternative_Id'Last);
            pragma Assert (C_Id = Choice_Id'Last);

            return Result;
         end Analysis;

      end Choice_Analysis;

   end Composite_Case_Ops;

   --------------------------
   -- Expand_Others_Choice --
   --------------------------

   procedure Expand_Others_Choice
     (Case_Table    : Choice_Table_Type;
      Others_Choice : Node_Id;
      Choice_Type   : Entity_Id)
   is
      Loc         : constant Source_Ptr := Sloc (Others_Choice);
      Choice_List : constant List_Id    := New_List;
      Choice      : Node_Id;
      Exp_Lo      : Node_Id;
      Exp_Hi      : Node_Id;
      Hi          : Uint;
      Lo          : Uint;
      Previous_Hi : Uint;

      function Build_Choice (Value1, Value2 : Uint) return Node_Id;
      --  Builds a node representing the missing choices given by Value1 and
      --  Value2. A N_Range node is built if there is more than one literal
      --  value missing. Otherwise a single N_Integer_Literal, N_Identifier
      --  or N_Character_Literal is built depending on what Choice_Type is.

      function Lit_Of (Value : Uint) return Node_Id;
      --  Returns the Node_Id for the enumeration literal corresponding to the
      --  position given by Value within the enumeration type Choice_Type. The
      --  returned value has its Is_Static_Expression flag set to true.

      ------------------
      -- Build_Choice --
      ------------------

      function Build_Choice (Value1, Value2 : Uint) return Node_Id is
         Lit_Node : Node_Id;
         Lo, Hi   : Node_Id;

      begin
         --  If there is only one choice value missing between Value1 and
         --  Value2, build an integer or enumeration literal to represent it.

         if Value1 = Value2 then
            if Is_Integer_Type (Choice_Type) then
               Lit_Node := Make_Integer_Literal (Loc, Value1);
               Set_Etype (Lit_Node, Choice_Type);
               Set_Is_Static_Expression (Lit_Node);
            else
               Lit_Node := Lit_Of (Value1);
            end if;

         --  Otherwise is more that one choice value that is missing between
         --  Value1 and Value2, therefore build a N_Range node of either
         --  integer or enumeration literals.

         else
            if Is_Integer_Type (Choice_Type) then
               Lo := Make_Integer_Literal (Loc, Value1);
               Set_Etype (Lo, Choice_Type);
               Set_Is_Static_Expression (Lo);
               Hi := Make_Integer_Literal (Loc, Value2);
               Set_Etype (Hi, Choice_Type);
               Set_Is_Static_Expression (Hi);
               Lit_Node :=
                 Make_Range (Loc,
                   Low_Bound  => Lo,
                   High_Bound => Hi);

            else
               Lit_Node :=
                 Make_Range (Loc,
                   Low_Bound  => Lit_Of (Value1),
                   High_Bound => Lit_Of (Value2));
            end if;
         end if;

         return Lit_Node;
      end Build_Choice;

      ------------
      -- Lit_Of --
      ------------

      function Lit_Of (Value : Uint) return Node_Id is
         Lit : Entity_Id;

      begin
         --  In the case where the literal is of type Character, there needs
         --  to be some special handling since there is no explicit chain
         --  of literals to search. Instead, a N_Character_Literal node
         --  is created with the appropriate Char_Code and Chars fields.

         if Is_Standard_Character_Type (Choice_Type) then
            Set_Character_Literal_Name (UI_To_CC (Value));
            Lit :=
              Make_Character_Literal (Loc,
                Chars              => Name_Find,
                Char_Literal_Value => Value);
            Set_Etype (Lit, Choice_Type);
            Set_Is_Static_Expression (Lit, True);
            return Lit;

         --  Otherwise, iterate through the literals list of Choice_Type
         --  "Value" number of times until the desired literal is reached
         --  and then return an occurrence of it.

         else
            Lit := First_Literal (Choice_Type);
            for J in 1 .. UI_To_Int (Value) loop
               Next_Literal (Lit);
            end loop;

            return New_Occurrence_Of (Lit, Loc);
         end if;
      end Lit_Of;

   --  Start of processing for Expand_Others_Choice

   begin
      if Case_Table'Last = 0 then

         --  Special case: only an others case is present. The others case
         --  covers the full range of the type.

         if Is_OK_Static_Subtype (Choice_Type) then
            Choice := New_Occurrence_Of (Choice_Type, Loc);
         else
            Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc);
         end if;

         Set_Others_Discrete_Choices (Others_Choice, New_List (Choice));
         return;
      end if;

      --  Establish the bound values for the choice depending upon whether the
      --  type of the case statement is static or not.

      if Is_OK_Static_Subtype (Choice_Type) then
         Exp_Lo := Type_Low_Bound (Choice_Type);
         Exp_Hi := Type_High_Bound (Choice_Type);
      else
         Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type));
         Exp_Hi := Type_High_Bound (Base_Type (Choice_Type));
      end if;

      Lo := Expr_Value (Case_Table (1).Lo);
      Hi := Expr_Value (Case_Table (1).Hi);
      Previous_Hi := Expr_Value (Case_Table (1).Hi);

      --  Build the node for any missing choices that are smaller than any
      --  explicit choices given in the case.

      if Expr_Value (Exp_Lo) < Lo then
         Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List);
      end if;

      --  Build the nodes representing any missing choices that lie between
      --  the explicit ones given in the case.

      for J in 2 .. Case_Table'Last loop
         Lo := Expr_Value (Case_Table (J).Lo);
         Hi := Expr_Value (Case_Table (J).Hi);

         if Lo /= (Previous_Hi + 1) then
            Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1));
         end if;

         Previous_Hi := Hi;
      end loop;

      --  Build the node for any missing choices that are greater than any
      --  explicit choices given in the case.

      if Expr_Value (Exp_Hi) > Hi then
         Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List);
      end if;

      Set_Others_Discrete_Choices (Others_Choice, Choice_List);

      --  Warn on null others list if warning option set

      if Warn_On_Redundant_Constructs
        and then Comes_From_Source (Others_Choice)
        and then Is_Empty_List (Choice_List)
      then
         Error_Msg_N ("?r?OTHERS choice is redundant", Others_Choice);
         Error_Msg_N ("\?r?previous choices cover all values", Others_Choice);
      end if;
   end Expand_Others_Choice;

   -----------
   -- No_OP --
   -----------

   procedure No_OP (C : Node_Id) is
   begin
      if Nkind (C) = N_Range and then Warn_On_Redundant_Constructs then
         Error_Msg_N ("choice is an empty range?r?", C);
      end if;
   end No_OP;

   -----------------------------
   -- Generic_Analyze_Choices --
   -----------------------------

   package body Generic_Analyze_Choices is

      --  The following type is used to gather the entries for the choice
      --  table, so that we can then allocate the right length.

      type Link;
      type Link_Ptr is access all Link;

      type Link is record
         Val : Choice_Bounds;
         Nxt : Link_Ptr;
      end record;

      ---------------------
      -- Analyze_Choices --
      ---------------------

      procedure Analyze_Choices
        (Alternatives : List_Id;
         Subtyp       : Entity_Id)
      is
         Choice_Type : constant Entity_Id := Base_Type (Subtyp);
         --  The actual type against which the discrete choices are resolved.
         --  Note that this type is always the base type not the subtype of the
         --  ruling expression, index or discriminant.

         Expected_Type : Entity_Id;
         --  The expected type of each choice. Equal to Choice_Type, except if
         --  the expression is universal, in which case the choices can be of
         --  any integer type.

         Alt : Node_Id;
         --  A case statement alternative or a variant in a record type
         --  declaration.

         Choice : Node_Id;
         Kind   : Node_Kind;
         --  The node kind of the current Choice

      begin
         --  Set Expected type (= choice type except for universal integer,
         --  where we accept any integer type as a choice).

         if Choice_Type = Universal_Integer then
            Expected_Type := Any_Integer;
         else
            Expected_Type := Choice_Type;
         end if;

         --  Now loop through the case alternatives or record variants

         Alt := First (Alternatives);
         while Present (Alt) loop

            --  If pragma, just analyze it

            if Nkind (Alt) = N_Pragma then
               Analyze (Alt);

            --  Otherwise we have an alternative. In most cases the semantic
            --  processing leaves the list of choices unchanged

            --  Check each choice against its base type

            else
               Choice := First (Discrete_Choices (Alt));
               while Present (Choice) loop
                  Analyze (Choice);
                  Kind := Nkind (Choice);

                  --  Choice is a Range

                  if Kind = N_Range
                    or else (Kind = N_Attribute_Reference
                              and then Attribute_Name (Choice) = Name_Range)
                  then
                     Resolve (Choice, Expected_Type);

                  --  Choice is a subtype name, nothing further to do now

                  elsif Is_Entity_Name (Choice)
                    and then Is_Type (Entity (Choice))
                  then
                     null;

                  --  Choice is a subtype indication

                  elsif Kind = N_Subtype_Indication then
                     Resolve_Discrete_Subtype_Indication
                       (Choice, Expected_Type);

                  --  Others choice, no analysis needed

                  elsif Kind = N_Others_Choice then
                     null;

                  --  Only other possibility is an expression

                  else
                     Resolve (Choice, Expected_Type);
                  end if;

                  --  Move to next choice

                  Next (Choice);
               end loop;

               Process_Associated_Node (Alt);
            end if;

            Next (Alt);
         end loop;
      end Analyze_Choices;

   end Generic_Analyze_Choices;

   ---------------------------
   -- Generic_Check_Choices --
   ---------------------------

   package body Generic_Check_Choices is

      --  The following type is used to gather the entries for the choice
      --  table, so that we can then allocate the right length.

      type Link;
      type Link_Ptr is access all Link;

      type Link is record
         Val : Choice_Bounds;
         Nxt : Link_Ptr;
      end record;

      procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr);

      -------------------
      -- Check_Choices --
      -------------------

      procedure Check_Choices
        (N              : Node_Id;
         Alternatives   : List_Id;
         Subtyp         : Entity_Id;
         Others_Present : out Boolean)
      is
         E : Entity_Id;

         Raises_CE : Boolean;
         --  Set True if one of the bounds of a choice raises CE

         Enode : Node_Id;
         --  This is where we post error messages for bounds out of range

         Choice_List : Link_Ptr := null;
         --  Gather list of choices

         Num_Choices : Nat := 0;
         --  Number of entries in Choice_List

         Choice_Type : constant Entity_Id := Base_Type (Subtyp);
         --  The actual type against which the discrete choices are resolved.
         --  Note that this type is always the base type not the subtype of the
         --  ruling expression, index or discriminant.

         Bounds_Type : Entity_Id;
         --  The type from which are derived the bounds of the values covered
         --  by the discrete choices (see 3.8.1 (4)). If a discrete choice
         --  specifies a value outside of these bounds we have an error.

         Bounds_Lo : Uint;
         Bounds_Hi : Uint;
         --  The actual bounds of the above type

         Expected_Type : Entity_Id;
         --  The expected type of each choice. Equal to Choice_Type, except if
         --  the expression is universal, in which case the choices can be of
         --  any integer type.

         Alt : Node_Id;
         --  A case statement alternative or a variant in a record type
         --  declaration.

         Choice : Node_Id;
         Kind   : Node_Kind;
         --  The node kind of the current Choice

         Others_Choice : Node_Id := Empty;
         --  Remember others choice if it is present (empty otherwise)

         procedure Check (Choice : Node_Id; Lo, Hi : Node_Id);
         --  Checks the validity of the bounds of a choice. When the bounds
         --  are static and no error occurred the bounds are collected for
         --  later entry into the choices table so that they can be sorted
         --  later on.

         procedure Check_Case_Pattern_Choices;
         --  Check choices validity for the Ada extension case where the
         --  selecting expression is not of a discrete type and so the
         --  choices are patterns.

         procedure Check_Composite_Case_Selector;
         --  Check that the (non-discrete) type of the expression being
         --  cased on is suitable.

         procedure Handle_Static_Predicate
           (Typ : Entity_Id;
            Lo  : Node_Id;
            Hi  : Node_Id);
         --  If the type of the alternative has predicates, we must examine
         --  each subset of the predicate rather than the bounds of the type
         --  itself. This is relevant when the choice is a subtype mark or a
         --  subtype indication.

         -----------
         -- Check --
         -----------

         procedure Check (Choice : Node_Id; Lo, Hi : Node_Id) is
            Lo_Val : Uint;
            Hi_Val : Uint;

         begin
            --  First check if an error was already detected on either bounds

            if Etype (Lo) = Any_Type or else Etype (Hi) = Any_Type then
               return;

            --  Do not insert non static choices in the table to be sorted

            elsif not Is_OK_Static_Expression (Lo)
                    or else
                  not Is_OK_Static_Expression (Hi)
            then
               Process_Non_Static_Choice (Choice);
               return;

            --  Ignore range which raise constraint error

            elsif Raises_Constraint_Error (Lo)
              or else Raises_Constraint_Error (Hi)
            then
               Raises_CE := True;
               return;

            --  AI05-0188 : Within an instance the non-others choices do not
            --  have to belong to the actual subtype.

            elsif Ada_Version >= Ada_2012 and then In_Instance then
               return;

            --  Otherwise we have an OK static choice

            else
               Lo_Val := Expr_Value (Lo);
               Hi_Val := Expr_Value (Hi);

               --  Do not insert null ranges in the choices table

               if Lo_Val > Hi_Val then
                  Process_Empty_Choice (Choice);
                  return;
               end if;
            end if;

            --  Check for low bound out of range

            if Lo_Val < Bounds_Lo then

               --  If the choice is an entity name, then it is a type, and we
               --  want to post the message on the reference to this entity.
               --  Otherwise post it on the lower bound of the range.

               if Is_Entity_Name (Choice) then
                  Enode := Choice;
               else
                  Enode := Lo;
               end if;

               --  Specialize message for integer/enum type

               if Is_Integer_Type (Bounds_Type) then
                  Error_Msg_Uint_1 := Bounds_Lo;
                  Error_Msg_N ("minimum allowed choice value is^", Enode);
               else
                  Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type);
                  Error_Msg_N ("minimum allowed choice value is%", Enode);
               end if;
            end if;

            --  Check for high bound out of range

            if Hi_Val > Bounds_Hi then

               --  If the choice is an entity name, then it is a type, and we
               --  want to post the message on the reference to this entity.
               --  Otherwise post it on the upper bound of the range.

               if Is_Entity_Name (Choice) then
                  Enode := Choice;
               else
                  Enode := Hi;
               end if;

               --  Specialize message for integer/enum type

               if Is_Integer_Type (Bounds_Type) then
                  Error_Msg_Uint_1 := Bounds_Hi;
                  Error_Msg_N ("maximum allowed choice value is^", Enode);
               else
                  Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type);
                  Error_Msg_N ("maximum allowed choice value is%", Enode);
               end if;
            end if;

            --  Collect bounds in the list

            --  Note: we still store the bounds, even if they are out of range,
            --  since this may prevent unnecessary cascaded errors for values
            --  that are covered by such an excessive range.

            Choice_List :=
              new Link'(Val => (Lo, Hi, Choice), Nxt => Choice_List);
            Num_Choices := Num_Choices + 1;
         end Check;

         --------------------------------
         -- Check_Case_Pattern_Choices --
         --------------------------------

         procedure Check_Case_Pattern_Choices is
            package Ops is new Composite_Case_Ops.Choice_Analysis
              (Case_Statement => N);
            use Ops;
            use Ops.Value_Sets;

            Empty : Value_Set renames Value_Sets.Empty;
            --  Cope with hiding due to multiple use clauses

            Info        : constant Choices_Info := Analysis;
            Others_Seen : Boolean := False;

         begin
            declare
               Matches : array (Alternative_Id) of Value_Sets.Value_Set :=
                 (others => Empty);

               Flag_Overlapping_Within_One_Alternative : constant Boolean :=
                 False;
               --  We may want to flag overlapping (perhaps with only a
               --  warning) if the pattern binds an identifier, as in
               --    when (Positive, <X>) | (Integer, <X>) =>

               Covered : Value_Set := Empty;
               --  The union of all alternatives seen so far
            begin
               if Composite_Case_Ops.Simplified_Composite_Coverage_Rules then
                  if not (for some Choice of Info => Choice.Is_Others) then
                     Error_Msg_N ("others choice required", N);
                  end if;
                  return;
               end if;

               for Choice of Info loop
                  if Choice.Is_Others then
                     Others_Seen := True;
                  else
                     if Flag_Overlapping_Within_One_Alternative
                        and then (Compare (Matches (Choice.Alternative),
                                  Choice.Matches) /= Disjoint)
                     then
                        Error_Msg_N
                          ("bad overlapping within one alternative", N);
                     end if;

                     Union (Target => Matches (Choice.Alternative),
                            Source => Choice.Matches);
                  end if;
               end loop;

               for A1 in Alternative_Id loop
                  for A2 in Alternative_Id
                              range A1 + 1 .. Alternative_Id'Last
                  loop
                     case Compare (Matches (A1), Matches (A2)) is
                        when Disjoint | Contained_By =>
                           null; -- OK
                        when Overlaps =>
                           declare
                              Uncovered_1, Uncovered_2 : Value_Set := Empty;
                           begin
                              Union (Uncovered_1, Matches (A1));
                              Remove (Uncovered_1, Covered);
                              Union (Uncovered_2, Matches (A2));
                              Remove (Uncovered_2, Covered);

                              --  Recheck for overlap after removing choices
                              --  covered by earlier alternatives.

                              case Compare (Uncovered_1, Uncovered_2) is
                                 when Disjoint | Contained_By =>
                                    null;
                                 when Contains | Overlaps | Equal =>
                                    Error_Msg_N
                                      ("bad alternative overlapping", N);
                              end case;
                           end;

                        when Equal =>
                           Error_Msg_N ("alternatives match same values", N);
                        when Contains =>
                           Error_Msg_N ("alternatives in wrong order", N);
                     end case;
                  end loop;

                  Union (Target => Covered, Source => Matches (A1));
               end loop;

               if (not Others_Seen) and then not Complement_Is_Empty (Covered)
               then
                  Error_Msg_N ("not all values are covered", N);
               end if;
            end;

            Ops.Value_Sets.Free_Value_Sets;
         end Check_Case_Pattern_Choices;

         -----------------------------------
         -- Check_Composite_Case_Selector --
         -----------------------------------

         procedure Check_Composite_Case_Selector is
         begin
            if not Is_Composite_Type (Subtyp) then
               Error_Msg_N
                 ("case selector type must be discrete or composite", N);
            elsif Is_Limited_Type (Subtyp) then
               Error_Msg_N ("case selector type must not be limited", N);
            elsif Is_Class_Wide_Type (Subtyp) then
               Error_Msg_N ("case selector type must not be class-wide", N);
            elsif Needs_Finalization (Subtyp)
              and then Is_Newly_Constructed
                         (Expression (N), Context_Requires_NC => False)
            then
               --  We could allow this case as long as there are no bindings.
               --
               --  If there are bindings, then allowing this case will get
               --  messy because the selector expression will be finalized
               --  before the statements of the selected alternative are
               --  executed (unless we add an INOX-specific change to the
               --  accessibility rules to prevent this earlier-than-wanted
               --  finalization, but adding new INOX-specific accessibility
               --  complexity is probably not the direction we want to go).
               --  This early selector finalization would be ok if we made
               --  copies in this case (so that the bindings would not yield
               --  a view of a finalized object), but then we'd have to deal
               --  with finalizing those copies (which would necessarily
               --  include defining their accessibility level). So it gets
               --  messy either way.

               Error_Msg_N ("case selector must not require finalization", N);
            end if;
         end Check_Composite_Case_Selector;

         -----------------------------
         -- Handle_Static_Predicate --
         -----------------------------

         procedure Handle_Static_Predicate
           (Typ : Entity_Id;
            Lo  : Node_Id;
            Hi  : Node_Id)
         is
            P : Node_Id;
            C : Node_Id;

         begin
            --  Loop through entries in predicate list, checking each entry.
            --  Note that if the list is empty, corresponding to a False
            --  predicate, then no choices are checked. If the choice comes
            --  from a subtype indication, the given range may have bounds
            --  that narrow the predicate choices themselves, so we must
            --  consider only those entries within the range of the given
            --  subtype indication..

            P := First (Static_Discrete_Predicate (Typ));
            while Present (P) loop

               --  Check that part of the predicate choice is included in the
               --  given bounds.

               if Expr_Value (High_Bound (P)) >= Expr_Value (Lo)
                 and then Expr_Value (Low_Bound (P)) <= Expr_Value (Hi)
               then
                  C := New_Copy (P);
                  Set_Sloc (C, Sloc (Choice));
                  Set_Original_Node (C, Choice);

                  if Expr_Value (Low_Bound (C)) < Expr_Value (Lo) then
                     Set_Low_Bound (C, Lo);
                  end if;

                  if Expr_Value (High_Bound (C)) > Expr_Value (Hi) then
                     Set_High_Bound (C, Hi);
                  end if;

                  Check (C, Low_Bound (C), High_Bound (C));
               end if;

               Next (P);
            end loop;

            Set_Has_SP_Choice (Alt);
         end Handle_Static_Predicate;

      --  Start of processing for Check_Choices

      begin
         Raises_CE      := False;
         Others_Present := False;

         --  If Subtyp is not a discrete type or there was some other error,
         --  then don't try any semantic checking on the choices since we have
         --  a complete mess.

         if not Is_Discrete_Type (Subtyp) or else Subtyp = Any_Type then

            --  Hold on, maybe it isn't a complete mess after all.

            if Core_Extensions_Allowed and then Subtyp /= Any_Type then
               Check_Composite_Case_Selector;
               Check_Case_Pattern_Choices;
            end if;

            return;
         end if;

         --  If Subtyp is not a static subtype Ada 95 requires then we use the
         --  bounds of its base type to determine the values covered by the
         --  discrete choices.

         --  In Ada 2012, if the subtype has a nonstatic predicate the full
         --  range of the base type must be covered as well.

         if Is_OK_Static_Subtype (Subtyp) then
            if not Has_Predicates (Subtyp)
              or else Has_Static_Predicate (Subtyp)
            then
               Bounds_Type := Subtyp;
            else
               Bounds_Type := Choice_Type;
            end if;

         else
            Bounds_Type := Choice_Type;
         end if;

         --  Obtain static bounds of type, unless this is a generic formal
         --  discrete type for which all choices will be nonstatic.

         if not Is_Generic_Type (Root_Type (Bounds_Type))
           or else Ekind (Bounds_Type) /= E_Enumeration_Type
         then
            Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
            Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
         end if;

         if Choice_Type = Universal_Integer then
            Expected_Type := Any_Integer;
         else
            Expected_Type := Choice_Type;
         end if;

         --  Now loop through the case alternatives or record variants

         Alt := First (Alternatives);
         while Present (Alt) loop

            --  If pragma, just analyze it

            if Nkind (Alt) = N_Pragma then
               Analyze (Alt);

            --  Otherwise we have an alternative. In most cases the semantic
            --  processing leaves the list of choices unchanged

            --  Check each choice against its base type

            else
               Choice := First (Discrete_Choices (Alt));
               while Present (Choice) loop
                  Kind := Nkind (Choice);

                  --  Choice is a Range

                  if Kind = N_Range
                    or else (Kind = N_Attribute_Reference
                              and then Attribute_Name (Choice) = Name_Range)
                  then
                     Check (Choice, Low_Bound (Choice), High_Bound (Choice));

                  --  Choice is a subtype name

                  elsif Is_Entity_Name (Choice)
                    and then Is_Type (Entity (Choice))
                  then
                     --  Check for inappropriate type

                     if not Covers (Expected_Type, Etype (Choice)) then
                        Wrong_Type (Choice, Choice_Type);

                     --  Type is OK, so check further

                     else
                        E := Entity (Choice);

                        --  Case of predicated subtype

                        if Has_Predicates (E) then

                           --  Use of nonstatic predicate is an error

                           if not Is_Discrete_Type (E)
                             or else not Has_Static_Predicate (E)
                             or else Has_Dynamic_Predicate_Aspect (E)
                           then
                              Bad_Predicated_Subtype_Use
                                ("cannot use subtype& with non-static "
                                 & "predicate as case alternative",
                                 Choice, E, Suggest_Static => True);

                           --  Static predicate case. The bounds are those of
                           --  the given subtype.

                           else
                              Handle_Static_Predicate (E,
                                Type_Low_Bound (E), Type_High_Bound (E));
                           end if;

                        --  Not predicated subtype case

                        elsif not Is_OK_Static_Subtype (E) then
                           Process_Non_Static_Choice (Choice);
                        else
                           Check
                             (Choice, Type_Low_Bound (E), Type_High_Bound (E));
                        end if;
                     end if;

                  --  Choice is a subtype indication

                  elsif Kind = N_Subtype_Indication then
                     Resolve_Discrete_Subtype_Indication
                       (Choice, Expected_Type);

                     if Etype (Choice) /= Any_Type then
                        declare
                           C : constant Node_Id := Constraint (Choice);
                           R : constant Node_Id := Range_Expression (C);
                           L : constant Node_Id := Low_Bound (R);
                           H : constant Node_Id := High_Bound (R);

                        begin
                           E := Entity (Subtype_Mark (Choice));

                           if not Is_OK_Static_Subtype (E) then
                              Process_Non_Static_Choice (Choice);

                           else
                              if Is_OK_Static_Expression (L)
                                   and then
                                 Is_OK_Static_Expression (H)
                              then
                                 if Expr_Value (L) > Expr_Value (H) then
                                    Process_Empty_Choice (Choice);
                                 else
                                    if Is_Out_Of_Range (L, E) then
                                       Apply_Compile_Time_Constraint_Error
                                         (L, "static value out of range",
                                          CE_Range_Check_Failed);
                                    end if;

                                    if Is_Out_Of_Range (H, E) then
                                       Apply_Compile_Time_Constraint_Error
                                         (H, "static value out of range",
                                          CE_Range_Check_Failed);
                                    end if;
                                 end if;
                              end if;

                              --  Check applicable predicate values within the
                              --  bounds of the given range.

                              if Has_Static_Predicate (E) then
                                 Handle_Static_Predicate (E, L, H);

                              else
                                 Check (Choice, L, H);
                              end if;
                           end if;
                        end;
                     end if;

                  --  The others choice is only allowed for the last
                  --  alternative and as its only choice.

                  elsif Kind = N_Others_Choice then
                     if not (Choice = First (Discrete_Choices (Alt))
                              and then Choice = Last (Discrete_Choices (Alt))
                              and then Alt = Last (Alternatives))
                     then
                        Error_Msg_N
                          ("the choice OTHERS must appear alone and last",
                           Choice);
                        return;
                     end if;

                     Others_Present := True;
                     Others_Choice  := Choice;

                  --  Only other possibility is an expression

                  else
                     Check (Choice, Choice, Choice);
                  end if;

                  --  Move to next choice

                  Next (Choice);
               end loop;

               Process_Associated_Node (Alt);
            end if;

            Next (Alt);
         end loop;

         --  Now we can create the Choice_Table, since we know how long
         --  it needs to be so we can allocate exactly the right length.

         declare
            Choice_Table : Choice_Table_Type (0 .. Num_Choices);

         begin
            --  Now copy the items we collected in the linked list into this
            --  newly allocated table (leave entry 0 unused for sorting).

            declare
               T : Link_Ptr;
            begin
               for J in 1 .. Num_Choices loop
                  T := Choice_List;
                  Choice_List := T.Nxt;
                  Choice_Table (J) := T.Val;
                  Free (T);
               end loop;
            end;

            Check_Choice_Set
              (Choice_Table,
               Bounds_Type,
               Subtyp,
               Others_Present or else (Choice_Type = Universal_Integer),
               N);

            --  If no others choice we are all done, otherwise we have one more
            --  step, which is to set the Others_Discrete_Choices field of the
            --  others choice (to contain all otherwise unspecified choices).
            --  Skip this if CE is known to be raised.

            if Others_Present and not Raises_CE then
               Expand_Others_Choice
                 (Case_Table    => Choice_Table,
                  Others_Choice => Others_Choice,
                  Choice_Type   => Bounds_Type);
            end if;
         end;
      end Check_Choices;

   end Generic_Check_Choices;

   -----------------------------------------
   --  Has_Static_Discriminant_Constraint --
   -----------------------------------------

   function Has_Static_Discriminant_Constraint
     (Subtyp : Entity_Id) return Boolean
   is
   begin
      if Has_Discriminants (Subtyp) and then Is_Constrained (Subtyp) then
         declare
            DC_Elmt : Elmt_Id := First_Elmt (Discriminant_Constraint (Subtyp));
         begin
            while Present (DC_Elmt) loop
               if not All_Composite_Constraints_Static (Node (DC_Elmt)) then
                  return False;
               end if;
               Next_Elmt (DC_Elmt);
            end loop;
            return True;
         end;
      end if;
      return False;
   end Has_Static_Discriminant_Constraint;

   ----------------------------
   -- Is_Case_Choice_Pattern --
   ----------------------------

   function Is_Case_Choice_Pattern (Expr : Node_Id) return Boolean is
      E : Node_Id := Expr;
   begin
      if not Core_Extensions_Allowed then
         return False;
      end if;

      loop
         case Nkind (E) is
            when N_Case_Statement_Alternative
               | N_Case_Expression_Alternative
            =>
               --  We could return False if selecting expression is discrete,
               --  but this doesn't seem to be worth the bother.
               return True;

            when N_Empty
               | N_Statement_Other_Than_Procedure_Call
               | N_Procedure_Call_Statement
               | N_Declaration
            =>
               return False;

            when others =>
               E := Parent (E);
         end case;
      end loop;
   end Is_Case_Choice_Pattern;

end Sem_Case;