[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, 73 insertions, 4 deletions

diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb
index ba128ec..20f8dd1 100644
--- a/gcc/ada/par-ch4.adb
+++ b/gcc/ada/par-ch4.adb
@@ -1734,8 +1734,9 @@ package body Ch4 is
    --        aggregates (AI-287)
 
    function P_Record_Or_Array_Component_Association return Node_Id is
-      Assoc_Node : Node_Id;
-
+      Assoc_Node                  : Node_Id;
+      Box_Present                 : Boolean := False;
+      Box_With_Identifier_Present : Boolean := False;
    begin
       --  A loop indicates an iterated_component_association
 
@@ -1744,6 +1745,8 @@ package body Ch4 is
       end if;
 
       Assoc_Node := New_Node (N_Component_Association, Token_Ptr);
+      Set_Binding_Chars (Assoc_Node, No_Name);
+
       Set_Choices (Assoc_Node, P_Discrete_Choice_List);
       Set_Sloc (Assoc_Node, Token_Ptr);
       TF_Arrow;
@@ -1755,12 +1758,78 @@ package body Ch4 is
 
          Error_Msg_Ada_2005_Extension ("component association with '<'>");
 
+         Box_Present := True;
          Set_Box_Present (Assoc_Node);
-         Scan; -- Past box
-      else
+         Scan; -- past box
+      elsif Token = Tok_Less then
+         declare
+            Scan_State : Saved_Scan_State;
+            Id         : Node_Id;
+         begin
+            Save_Scan_State (Scan_State);
+            Scan; -- past "<"
+            if Token = Tok_Identifier then
+               Id := P_Defining_Identifier;
+               if Token = Tok_Greater then
+                  if Extensions_Allowed then
+                     Set_Box_Present (Assoc_Node);
+                     Set_Binding_Chars (Assoc_Node, Chars (Id));
+                     Box_Present := True;
+                     Box_With_Identifier_Present := True;
+                     Scan; -- past ">"
+                  else
+                     Error_Msg
+                       ("Identifier within box only supported under -gnatX",
+                        Token_Ptr);
+                     Box_Present := True;
+                     --  Avoid cascading errors by ignoring the identifier
+                  end if;
+               end if;
+            end if;
+            if not Box_Present then
+               --  it wasn't an "is <identifier>", so restore.
+               Restore_Scan_State (Scan_State);
+            end if;
+         end;
+      end if;
+
+      if not Box_Present then
          Set_Expression (Assoc_Node, P_Expression);
       end if;
 
+      --  Check for "is <identifier>" for aggregate that is part of
+      --  a pattern for a general case statement.
+
+      if Token = Tok_Is then
+         declare
+            Scan_State : Saved_Scan_State;
+            Id         : Node_Id;
+         begin
+            Save_Scan_State (Scan_State);
+            Scan; -- past "is"
+            if Token = Tok_Identifier then
+               Id := P_Defining_Identifier;
+
+               if not Extensions_Allowed then
+                  Error_Msg
+                    ("IS following component association"
+                       & " only supported under -gnatX",
+                     Token_Ptr);
+               elsif Box_With_Identifier_Present then
+                  Error_Msg
+                    ("Both identifier-in-box and trailing identifier"
+                       & " specified for one component association",
+                     Token_Ptr);
+               else
+                  Set_Binding_Chars (Assoc_Node, Chars (Id));
+               end if;
+            else
+               --  It wasn't an "is <identifier>", so restore.
+               Restore_Scan_State (Scan_State);
+            end if;
+         end;
+      end if;
+
       return Assoc_Node;
    end P_Record_Or_Array_Component_Association;