[Ada] Casing on composite values

gcc/ada/

	* exp_ch5.adb
	(Expand_N_Case_Statement.Expand_General_Case_Statement): New
	subprogram.
	(Expand_N_Case_Statement): If extensions are allowed and the
	case selector is not of a discrete type, then call
	Expand_General_Case_Statement to generate expansion instead of
	flagging the non-discrete selector as an error.
	* sem_case.ads (Is_Case_Choice_Pattern): New Boolean-valued
	function for testing whether a given expression occurs as part
	of a case choice pattern.
	* sem_case.adb (Composite_Case_Ops): New package providing
	support routines for the new form of case statements. This
	includes a nested package, Composite_Case_Ops.Value_Sets, which
	encapsulates the "representative values" implementation of
	composite value sets.
	(Check_Choices.Check_Case_Pattern_Choices): New procedure for
	semantic checking of non-discrete case choices. This includes
	the checks pertaining to coverage and overlapping.
	(Check_Choices.Check_Composite_Case_Selector): New procedure for
	semantic checking of non-discrete case selectors.
	(Check_Choices): If extensions are allowed then a non-discrete
	selector type no longer implies that an error must have been
	flagged earlier.  Instead of simply returning, call
	Check_Composite_Case_Selector and Check_Case_Pattern_Choices.
	(Is_Case_Choice_Pattern): Body of new function declared in
	sem_case.ads .
	* sem_ch5.adb (Analyze_Case_Statement): If extensions are
	allowed, then we can't use RM 5.4's "The selecting_expression is
	expected to be of any discrete type" name resolution rule.
	Handle the case where the type of the selecting expression is
	not discrete, as well as the new ambiguous-name-resolution error
	cases made possible by this change.
	* sem_res.adb (Resolve_Entity_Name): It is ok to treat the name
	of a type or subtype as an expression if it is part of a case
	choice pattern, as in "(Field1 => Positive, Field2 => <>)".
	* exp_aggr.adb (Expand_Record_Aggregate): Do not expand case
	choice aggregates.
	* gen_il-fields.ads: Define two new node attributes,
	Binding_Chars and Multidefined_Bindings.
	* gen_il-gen-gen_nodes.adb: The new Multidefined_Bindings
	attribute is Boolean-valued and may be set on
	N_Case_Statement_Alternative nodes. The new Binding_Chars
	attribute is Name_Id-valued and may be set on
	N_Component_Association nodes.
	* par-ch4.adb (P_Record_Or_Array_Component_Association): When
	parsing a component association, check for both new syntax forms
	used to specify a bound value in a case-choice aggregate.  In
	the case of a box value, an identifier may occur within the box,
	as in "Foo => <Abc>" instead of "Foo => <>". In the more general
	case, an expression (or a box) may be followed by "is
	<identifier>", as in
	"Foo => Bar is Abc" instead of just "Foo => Bar".
	* sem_aggr.adb (Resolve_Record_Aggregate): Do not transform box
	component values in a case-choice aggregate.
	* sinfo.ads: Provide comments for the new attributes added in
	gen_il-fields.ads.
	* doc/gnat_rm/implementation_defined_pragmas.rst: Describe this
	new feature in documentation for pragma Extensions_Allowed.
	* gnat_rm.texi: Regenerate.

1 files changed, 53 insertions, 0 deletions

diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 2c0bb5f..4574ef9 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -1412,6 +1412,9 @@ package body Sem_Ch5 is
       --  the case statement, and as a result it is not a good idea to output
       --  warning messages about unreachable code.
 
+      Is_General_Case_Statement : Boolean := False;
+      --  Set True (later) if type of case expression is not discrete
+
       procedure Non_Static_Choice_Error (Choice : Node_Id);
       --  Error routine invoked by the generic instantiation below when the
       --  case statement has a non static choice.
@@ -1453,6 +1456,12 @@ package body Sem_Ch5 is
          Ent     : Entity_Id;
 
       begin
+         if Is_General_Case_Statement then
+            return;
+            --  Processing deferred in this case; decls associated with
+            --  pattern match bindings don't exist yet.
+         end if;
+
          Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
          Statements_Analyzed := True;
 
@@ -1527,6 +1536,35 @@ package body Sem_Ch5 is
          Resolve (Exp);
          Exp_Type := Full_View (Etype (Exp));
 
+      --  For Ada, overloading might be ok because subsequently filtering
+      --  out non-discretes may resolve the ambiguity.
+      --  But GNAT extensions allow casing on non-discretes.
+
+      elsif Extensions_Allowed and then Is_Overloaded (Exp) then
+
+         --  TBD: Generate better ambiguity diagnostics here.
+         --  It would be nice if we could generate all the right error
+         --  messages by calling "Resolve (Exp, Any_Type);" in the
+         --  same way that they are generated a few lines below by the
+         --  call "Analyze_And_Resolve (Exp, Any_Discrete);".
+         --  Unfortunately, Any_Type and Any_Discrete are not treated
+         --  consistently (specifically, by Sem_Type.Covers), so that
+         --  doesn't work.
+
+         Error_Msg_N
+           ("selecting expression of general case statement is ambiguous",
+            Exp);
+         return;
+
+      --  Check for a GNAT-extension "general" case statement (i.e., one where
+      --  the type of the selecting expression is not discrete).
+
+      elsif Extensions_Allowed
+         and then not Is_Discrete_Type (Etype (Exp))
+      then
+         Resolve (Exp, Etype (Exp));
+         Exp_Type := Etype (Exp);
+         Is_General_Case_Statement := True;
       else
          Analyze_And_Resolve (Exp, Any_Discrete);
          Exp_Type := Etype (Exp);
@@ -1579,6 +1617,21 @@ package body Sem_Ch5 is
       Analyze_Choices (Alternatives (N), Exp_Type);
       Check_Choices (N, Alternatives (N), Exp_Type, Others_Present);
 
+      if Is_General_Case_Statement then
+         --  Work normally done in Process_Statements was deferred; do that
+         --  deferred work now that Check_Choices has had a chance to create
+         --  any needed pattern-match-binding declarations.
+         declare
+            Alt : Node_Id := First (Alternatives (N));
+         begin
+            while Present (Alt) loop
+               Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
+               Analyze_Statements (Statements (Alt));
+               Next (Alt);
+            end loop;
+         end;
+      end if;
+
       if Exp_Type = Universal_Integer and then not Others_Present then
          Error_Msg_N ("case on universal integer requires OTHERS choice", Exp);
       end if;