[Ada] Add -gnatX support for casing on array values

gcc/ada/

	* exp_ch5.adb (Expand_General_Case_Statement.Pattern_Match): Add
	new function Indexed_Element to handle array element
	comparisons. Handle case choices that are array aggregates,
	string literals, or names denoting constants.
	* sem_case.adb (Composite_Case_Ops.Array_Case_Ops): New package
	providing utilities needed for casing on arrays.
	(Composite_Case_Ops.Choice_Analysis): If necessary, include
	array length as a "component" (like a discriminant) when
	traversing components. We do not (yet) partition choice analysis
	to deal with unequal length choices separately. Instead, we
	embed everything in the minimum-dimensionality Cartesian product
	space needed to handle all choices properly; this is determined
	by the length of the longest choice pattern.
	(Composite_Case_Ops.Choice_Analysis.Traverse_Discrete_Parts):
	Include length as a "component" in the traversal if necessary.
	(Composite_Case_Ops.Choice_Analysis.Parse_Choice.Traverse_Choice):
	Add support for case choices that are string literals or names
	denoting constants.
	(Composite_Case_Ops.Choice_Analysis): Include length as a
	"component" in the analysis if necessary.
	(Check_Choices.Check_Case_Pattern_Choices.Ops.Value_Sets.Value_Index_Count):
	Improve error message when capacity exceeded.
	* doc/gnat_rm/implementation_defined_pragmas.rst: Update
	documentation to reflect current implementation status.
	* gnat_rm.texi: Regenerate.

4 files changed, 459 insertions, 54 deletions

diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
index 6c81ca7..9d2f113 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
@@ -2270,8 +2270,15 @@ of GNAT specific extensions are recognized as follows:
   values of the composite type shall be covered. The composite type of the
   selector shall be a nonlimited untagged (but possibly discriminated)
   record type, all of whose subcomponent subtypes are either static discrete
-  subtypes or record types that meet the same restrictions. Support for arrays
-  is planned, but not yet implemented.
+  subtypes or record types that meet the same restrictions.
+
+  Support for casing on arrays (and on records that contain arrays) is
+  currently subject to some restrictions. Non-positional
+  array aggregates are not supported as (or within) case choices. Likewise
+  for array type and subtype names. The current implementation exceeds
+  compile-time capacity limits in some annoyingly common scenarios; the
+  message generated in such cases is usually "Capacity exceeded in compiling
+  case statement with composite selector type".
 
   In addition, pattern bindings are supported. This is a mechanism
   for binding a name to a component of a matching value for use within
@@ -2280,7 +2287,8 @@ of GNAT specific extensions are recognized as follows:
   "is <identifier>". In the special case of a "box" component association,
   the identifier may instead be provided within the box. Either of these
   indicates that the given identifer denotes (a constant view of) the matching
-  subcomponent of the case selector.
+  subcomponent of the case selector. Binding is not yet supported for arrays
+  or subcomponents thereof.
 
   Consider this example (which uses type Rec from the previous example):
 
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 9827326..21ac2a2 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -31,7 +31,6 @@ 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 Exp_Aggr;       use Exp_Aggr;
 with Exp_Ch6;        use Exp_Ch6;
 with Exp_Ch7;        use Exp_Ch7;
@@ -3365,6 +3364,30 @@ package body Exp_Ch5 is
               renames Pattern_Match;
             --  convenient rename for recursive calls
 
+            function Indexed_Element (Idx : Pos) return Node_Id;
+            --  Returns the Nth (well, ok, the Idxth) element of Object
+
+            ---------------------
+            -- Indexed_Element --
+            ---------------------
+
+            function Indexed_Element (Idx : Pos) return Node_Id is
+               Obj_Index : constant Node_Id :=
+                 Make_Op_Add (Loc,
+                   Left_Opnd =>
+                     Make_Attribute_Reference (Loc,
+                       Attribute_Name => Name_First,
+                       Prefix => New_Copy_Tree (Object)),
+                   Right_Opnd =>
+                     Make_Integer_Literal (Loc, Idx - 1));
+            begin
+               return Make_Indexed_Component (Loc,
+                        Prefix => New_Copy_Tree (Object),
+                        Expressions => New_List (Obj_Index));
+            end Indexed_Element;
+
+         --  Start of processing for Pattern_Match
+
          begin
             if Choice_Index /= 0 and not Suppress_Choice_Index_Update then
                pragma Assert (Present (Choice_Index_Decl));
@@ -3399,16 +3422,51 @@ package body Exp_Ch5 is
 
             case Nkind (Pattern) is
                when N_Aggregate =>
-                  return Result : Node_Id :=
-                    New_Occurrence_Of (Standard_True, Loc)
-                  do
+                  declare
+                     Result : Node_Id;
+                  begin
                      if Is_Array_Type (Etype (Pattern)) then
-                        --  Calling Error_Msg_N during expansion is usually a
-                        --  mistake but is ok for an "unimplemented" message.
-                        Error_Msg_N
-                          ("array-valued case choices unimplemented",
-                          Pattern);
-                        return;
+
+                        --  Nonpositional aggregates currently unimplemented.
+                        --  We flag that case during analysis, so an assertion
+                        --  is ok here.
+                        --
+                        pragma Assert
+                          (not Is_Non_Empty_List
+                                 (Component_Associations (Pattern)));
+
+                        declare
+                           Agg_Length : constant Node_Id :=
+                             Make_Integer_Literal (Loc,
+                               List_Length (Expressions (Pattern)));
+
+                           Obj_Length : constant Node_Id :=
+                             Make_Attribute_Reference (Loc,
+                               Attribute_Name => Name_Length,
+                               Prefix => New_Copy_Tree (Object));
+                        begin
+                           Result := Make_Op_Eq (Loc,
+                                       Left_Opnd  => Obj_Length,
+                                       Right_Opnd => Agg_Length);
+                        end;
+
+                        declare
+                           Expr : Node_Id := First (Expressions (Pattern));
+                           Idx  : Pos := 1;
+                        begin
+                           while Present (Expr) loop
+                              Result :=
+                                Make_And_Then (Loc,
+                                  Left_Opnd  => Result,
+                                  Right_Opnd =>
+                                    PM (Pattern => Expr,
+                                        Object => Indexed_Element (Idx)));
+                              Next (Expr);
+                              Idx := Idx + 1;
+                           end loop;
+                        end;
+
+                        return Result;
                      end if;
 
                      --  positional notation should have been normalized
@@ -3425,6 +3483,8 @@ package body Exp_Ch5 is
                              Selector_Name => New_Occurrence_Of
                                                 (Entity (Choice), Loc)));
                      begin
+                        Result := New_Occurrence_Of (Standard_True, Loc);
+
                         while Present (Component_Assoc) loop
                            Choice := First (Choices (Component_Assoc));
                            while Present (Choice) loop
@@ -3530,27 +3590,82 @@ package body Exp_Ch5 is
                            Next (Component_Assoc);
                         end loop;
                      end;
+                     return Result;
+                  end;
+
+               when N_String_Literal =>
+                  return Result : Node_Id do
+                     declare
+                        Char_Type : constant Entity_Id :=
+                          Root_Type (Component_Type (Etype (Pattern)));
+
+                        --  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 (Pattern);
+                        Strlen : constant Nat        := String_Length (Str);
+
+                        Lit_Length : constant Node_Id :=
+                          Make_Integer_Literal (Loc, Strlen);
+
+                        Obj_Length : constant Node_Id :=
+                          Make_Attribute_Reference (Loc,
+                            Attribute_Name => Name_Length,
+                            Prefix => New_Copy_Tree (Object));
+                     begin
+                        Result := Make_Op_Eq (Loc,
+                                    Left_Opnd  => Obj_Length,
+                                    Right_Opnd => Lit_Length);
+
+                        for Idx in 1 .. Strlen loop
+                           declare
+                              C           : constant Char_Code :=
+                                Get_String_Char (Str, Idx);
+                              Obj_Element : constant Node_Id :=
+                                Indexed_Element (Idx);
+                              Char_Lit    : Node_Id;
+                           begin
+                              Set_Character_Literal_Name (C);
+                              Char_Lit :=
+                                Make_Character_Literal (Loc,
+                                  Chars              => Name_Find,
+                                  Char_Literal_Value => UI_From_CC (C));
+
+                              Result :=
+                                Make_And_Then (Loc,
+                                  Left_Opnd  => Result,
+                                  Right_Opnd =>
+                                    Make_Op_Eq (Loc,
+                                      Left_Opnd  => Obj_Element,
+                                      Right_Opnd => Char_Lit));
+                           end;
+                        end loop;
+                     end;
                   end return;
 
                when N_Qualified_Expression =>
-                  --  Make a copy for one of the two uses of Object; the choice
-                  --  of where to use the original and where to use the copy
-                  --  is arbitrary.
-
                   return Make_And_Then (Loc,
                     Left_Opnd  => Make_In (Loc,
                       Left_Opnd  => New_Copy_Tree (Object),
                       Right_Opnd => New_Copy_Tree (Subtype_Mark (Pattern))),
                     Right_Opnd =>
                       PM (Pattern => Expression (Pattern),
-                          Object  => Object));
+                          Object  => New_Copy_Tree (Object)));
 
                when N_Identifier | N_Expanded_Name =>
                   if Is_Type (Entity (Pattern)) then
                      return Make_In (Loc,
-                       Left_Opnd  => Object,
+                       Left_Opnd  => New_Copy_Tree (Object),
                        Right_Opnd => New_Occurrence_Of
                                        (Entity (Pattern), Loc));
+                  elsif Ekind (Entity (Pattern)) = E_Constant then
+                     return PM (Pattern =>
+                                  Expression (Parent (Entity (Pattern))),
+                                Object => Object);
                   end if;
 
                when N_Others_Choice =>
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 349586e..08cef9f 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -21,7 +21,7 @@
 
 @copying
 @quotation
-GNAT Reference Manual , Jun 23, 2021
+GNAT Reference Manual , Aug 03, 2021
 
 AdaCore
 
@@ -3698,8 +3698,15 @@ will not be executed if the earlier alternative “matches”). All possible
 values of the composite type shall be covered. The composite type of the
 selector shall be a nonlimited untagged (but possibly discriminated)
 record type, all of whose subcomponent subtypes are either static discrete
-subtypes or record types that meet the same restrictions. Support for arrays
-is planned, but not yet implemented.
+subtypes or record types that meet the same restrictions.
+
+Support for casing on arrays (and on records that contain arrays) is
+currently subject to some restrictions. Non-positional
+array aggregates are not supported as (or within) case choices. Likewise
+for array type and subtype names. The current implementation exceeds
+compile-time capacity limits in some annoyingly common scenarios; the
+message generated in such cases is usually “Capacity exceeded in compiling
+case statement with composite selector type”.
 
 In addition, pattern bindings are supported. This is a mechanism
 for binding a name to a component of a matching value for use within
@@ -3708,7 +3715,8 @@ that occurs within a case choice, the expression may be followed by
 “is <identifier>”. In the special case of a “box” component association,
 the identifier may instead be provided within the box. Either of these
 indicates that the given identifer denotes (a constant view of) the matching
-subcomponent of the case selector.
+subcomponent of the case selector. Binding is not yet supported for arrays
+or subcomponents thereof.
 
 Consider this example (which uses type Rec from the previous example):
 
diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb
index 7d08da5..cc7e988 100644
--- a/gcc/ada/sem_case.adb
+++ b/gcc/ada/sem_case.adb
@@ -44,6 +44,7 @@ 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;
@@ -105,25 +106,70 @@ package body Sem_Case is
 
    package Composite_Case_Ops is
 
+      function Choice_Count (Alternatives : List_Id) return Nat;
+      --  The sum of the number of choices for each alternative in the given
+      --  list.
+
       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.
 
-      function Choice_Count (Alternatives : List_Id) return Nat;
-      --  The sum of the number of choices for each alternative in the given
-      --  list.
+      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 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 array
+         --  subtype with a nonstatic constraint, returns the unconstrained
+         --  array base type.
+
+         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 .. Scalar_Part_Count (Etype (Expression (Case_Statement)));
+           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
@@ -1118,6 +1164,21 @@ package body Sem_Case is
          return UI_To_Int (Len);
       end Static_Array_Length;
 
+      ------------------
+      -- 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;
+
       -----------------------
       -- Scalar_Part_Count --
       -----------------------
@@ -1147,20 +1208,118 @@ package body Sem_Case is
          end if;
       end Scalar_Part_Count;
 
-      ------------------
-      -- Choice_Count --
-      ------------------
+      package body Array_Case_Ops is
 
-      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;
+         -------------------------
+         -- 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;
+
+         -------------------------------
+         -- 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));
+         begin
+            if Is_Array_Type (Unnormalized)
+              and then Is_Constrained (Unnormalized)
+              and then not Has_Static_Array_Bounds (Unnormalized)
+            then
+               return Base_Type (Unnormalized);
+            else
+               return Unnormalized;
+            end if;
+         end Normalized_Case_Expr_Type;
+
+      ------------------------------------------
+         -- 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
 
@@ -1220,9 +1379,32 @@ package body Sem_Case is
                     ((Low  => Expr_Value (Type_Low_Bound (Subtyp)),
                       High => Expr_Value (Type_High_Bound (Subtyp))));
                elsif Is_Array_Type (Subtyp) then
-                  for I in 1 .. Static_Array_Length (Subtyp) loop
-                     Traverse_Discrete_Parts (Component_Type (Subtyp));
-                  end loop;
+                  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
 
@@ -1274,7 +1456,7 @@ package body Sem_Case is
             end Traverse_Discrete_Parts;
 
          begin
-            Traverse_Discrete_Parts (Etype (Expression (Case_Statement)));
+            Traverse_Discrete_Parts (Case_Expr_Type);
             pragma Assert (Done or else Serious_Errors_Detected > 0);
             return Result;
          end Component_Bounds_Info;
@@ -1531,6 +1713,19 @@ package body Sem_Case is
                            & "choice not implemented", Expr);
                      end if;
 
+                     if not Unconstrained_Array_Case
+                        and then List_Length (Expressions (Expr))
+                           /= Nat (Part_Id'Last)
+                     then
+                        Error_Msg_N
+                          ("Array aggregate length"
+                            & List_Length (Expressions (Expr))'Image
+                            & " does not match length of"
+                            & " statically constrained case selector"
+                            & Part_Id'Last'Image, Expr);
+                        return;
+                     end if;
+
                      declare
                         Subexpr : Node_Id := First (Expressions (Expr));
                      begin
@@ -1542,9 +1737,50 @@ package body Sem_Case is
                   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_N
+                             ("String literal length"
+                              & Strlen'Image
+                              & " does not match length of"
+                              & " statically constrained case selector"
+                              & Part_Id'Last'Image, 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
-                    Is_Type (Entity (Expr))
+                  if Nkind (Expr) in N_Has_Entity
+                    and then Present (Entity (Expr))
+                    and then Is_Type (Entity (Expr))
                   then
                      declare
                         Low  : constant Node_Id :=
@@ -1559,10 +1795,20 @@ package body Sem_Case is
                      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 subexpression which is not"
-                     & " of a discrete type not implemented", Expr);
+                    ("non-aggregate case choice (or subexpression thereof)"
+                     & " that is not of a discrete type not implemented",
+                     Expr);
                end if;
             end Traverse_Choice;
 
@@ -1572,8 +1818,26 @@ package body Sem_Case is
             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);
@@ -2098,6 +2362,12 @@ package body Sem_Case is
                   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;
@@ -3014,12 +3284,20 @@ package body Sem_Case is
                         "an enumeration representation clause", N);
                   end if;
                elsif Is_Array_Type (Subtyp) then
-                  pragma Assert (Is_Constrained (Subtyp));
-
                   if Number_Dimensions (Subtyp) /= 1 then
                      Error_Msg_N
                        ("dimensionality of array type of case selector (or " &
                         "subcomponent thereof) is greater than 1", N);
+
+                  elsif not Is_Constrained (Subtyp) then
+                     if not Is_Static_Subtype
+                              (Etype (First_Index (Subtyp)))
+                     then
+                        Error_Msg_N
+                          ("Unconstrained array subtype of case selector" &
+                           " has nonstatic index subtype", N);
+                     end if;
+
                   elsif not Is_OK_Static_Range (First_Index (Subtyp)) then
                      Error_Msg_N
                        ("array subtype of case selector (or " &
@@ -3077,10 +3355,6 @@ package body Sem_Case is
             elsif Needs_Finalization (Subtyp) then
                Error_Msg_N ("case selector type requires finalization", N);
 
-            elsif Is_Array_Type (Subtyp) and not Is_Constrained (Subtyp) then
-               Error_Msg_N
-                 ("case selector subtype is unconstrained array subtype", N);
-
             else
                Check_Component_Subtype (Subtyp);
             end if;