ada: Deep delta aggregates

Add support for "deep" delta aggregates, a GNAT-defined language extension
conditionally enabled via the -gnatX0 switch. In a deep delta aggregate, a
delta choice may specify a subcomponent (as opposed to just a component).

gcc/ada/

	* par.adb: Add new Boolean variable Inside_Delta_Aggregate.
	* par-ch4.adb (P_Simple_Expression): Add support for a deep delta
	aggregate choice. We turn a sequence of selectors into a peculiar
	tree. We build a component (Indexed or Selected) whose prefix is
	another such component, etc. The leftmost prefix at the bottom of
	the tree has a "name" which is the first selector, without any
	further prefix. For something like "with delta (1)(2) => 3" where
	the type of the aggregate is an array of arrays of integers, we'll
	build an N_Indexed_Component whose prefix is an integer literal 1.
	This is consistent with the trees built for "regular"
	(Ada-defined) delta aggregates.
	* sem_aggr.adb (Is_Deep_Choice, Is_Root_Prefix_Of_Deep_Choice):
	New queries.
	(Resolve_Deep_Delta_Assoc): new procedure.
	(Resolve_Delta_Array_Aggregate): call Resolve_Deep_Delta_Assoc in
	deep case.
	(Resolve_Delta_Record_Aggregate): call Resolve_Deep_Delta_Assoc in
	deep case.
	(Get_Component_Type): new function replaces old Get_Component
	function.
	* sem_aggr.ads (Is_Deep_Choice, Is_Root_Prefix_Of_Deep_Choice):
	New queries.
	* exp_aggr.adb (Expand_Delta_Array_Aggregate): add nested function
	Make_Array_Delta_Assignment_LHS; call it instead of
	Make_Indexed_Component.
	(Expand_Delta_Record_Aggregate): add nested function
	Make_Record_Delta_Assignment_LHS; call it instead of
	Make_Selected_Component.
	* exp_spark.adb (Expand_SPARK_Delta_Or_Update): Insert range
	checks for indexes in deep delta aggregates.

1 files changed, 118 insertions, 2 deletions

diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb
index 52f2b02..2ff6e00 100644
--- a/gcc/ada/par-ch4.adb
+++ b/gcc/ada/par-ch4.adb
@@ -1393,6 +1393,8 @@ package body Ch4 is
       Start_Token : constant Token_Type := Token;
       --  Used to prevent mismatches (...] and [...)
 
+      Saved_Delta_Aggregate_Flag : constant Boolean := Inside_Delta_Aggregate;
+
    --  Start of processing for P_Aggregate_Or_Paren_Expr
 
    begin
@@ -1497,6 +1499,7 @@ package body Ch4 is
             Scan; -- past WITH
             if Token = Tok_Delta then
                Scan; -- past DELTA
+               Inside_Delta_Aggregate := True;
                Aggregate_Node := New_Node (N_Delta_Aggregate, Lparen_Sloc);
                Set_Expression (Aggregate_Node, Expr_Node);
                Expr_Node := Empty;
@@ -1707,6 +1710,16 @@ package body Ch4 is
       end if;
 
       Set_Component_Associations (Aggregate_Node, Assoc_List);
+
+      --  Inside_Delta_Aggregate is only tested if Serious_Errors = 0, so
+      --  it is ok if we fail to restore the saved I_D_A value in an error
+      --  path. In particular, it is ok that we do not restore it if
+      --  Error_Resync is propagated. Earlier return statements (which return
+      --  without restoring the saved I_D_A value) should either be in error
+      --  paths or in paths where I_D_A could not have been modified.
+
+      Inside_Delta_Aggregate := Saved_Delta_Aggregate_Flag;
+
       return Aggregate_Node;
    end P_Aggregate_Or_Paren_Expr;
 
@@ -2519,6 +2532,109 @@ package body Ch4 is
          Expr_Form := EF_Simple;
       end if;
 
+      --  If all extensions are enabled and we have a deep delta aggregate
+      --  whose type is an array type with an element type that is a
+      --  record type, then we can encounter legal things like
+      --    with delta (Some_Index_Expression).Some_Component
+      --  where a parenthesized expression precedes a dot.
+      --  Similarly, if the element type is an array type then we can see
+      --    with delta (Some_Index_Expression)(Another_Index_Expression)
+      --  where a parenthesized expression precedes a left parenthesis.
+
+      if Token in Tok_Dot | Tok_Left_Paren
+        and then Prev_Token = Tok_Right_Paren
+        and then Serious_Errors_Detected = 0
+        and then Inside_Delta_Aggregate
+        and then All_Extensions_Allowed
+      then
+         if Token = Tok_Dot then
+            Node2 := New_Node (N_Selected_Component, Token_Ptr);
+            Scan; -- past dot
+            declare
+               Tail  : constant Node_Id := P_Simple_Expression;
+               --  remaining selectors occurring after the dot
+
+               Rover : Node_Id := Tail;
+               Prev  : Node_Id := Empty;
+            begin
+               --  If Tail already has a prefix, then we want to prepend
+               --  Node1 onto that prefix and then return Tail.
+               --  Otherwise, Tail should simply be an identifier so
+               --  we want to build a Selected_Component with Tail as the
+               --  selector name and return that.
+
+               Set_Prefix (Node2, Node1);
+
+               while Nkind (Rover)
+                       in N_Indexed_Component | N_Selected_Component loop
+                  Prev := Rover;
+                  Rover := Prefix (Rover);
+               end loop;
+
+               case Nkind (Prev) is
+                  when N_Selected_Component | N_Indexed_Component =>
+                     --  We've scanned a dot, so an identifier should follow
+                     if Nkind (Prefix (Prev)) = N_Identifier then
+                        Set_Selector_Name (Node2, Prefix (Prev));
+                        Set_Prefix (Prev, Node2);
+                        return Tail;
+                     end if;
+
+                  when N_Empty =>
+                     --  We've scanned a dot, so an identifier should follow
+                     if Nkind (Tail) = N_Identifier then
+                        Set_Selector_Name (Node2, Tail);
+                        return Node2;
+                     end if;
+
+                  when others =>
+                     null;
+               end case;
+
+               --  fall through to error case
+            end;
+         else
+            Node2 := New_Node (N_Indexed_Component, Token_Ptr);
+            declare
+               Tail  : constant Node_Id := P_Simple_Expression;
+               --  remaining selectors
+
+               Rover : Node_Id := Tail;
+               Prev  : Node_Id := Empty;
+            begin
+               --  If Tail already has a prefix, then we want to prepend
+               --  Node1 onto that prefix and then return Tail.
+               --  Otherwise, Tail should be an index expression and
+               --  we want to build an Indexed_Component with Tail as the
+               --  index value and return that.
+
+               Set_Prefix (Node2, Node1);
+
+               while Nkind (Rover)
+                       in N_Indexed_Component | N_Selected_Component loop
+                  Prev := Rover;
+                  Rover := Prefix (Rover);
+               end loop;
+
+               case Nkind (Prev) is
+                  when N_Selected_Component | N_Indexed_Component =>
+                     Set_Expressions (Node2, New_List (Prefix (Prev)));
+                     Set_Prefix (Prev, Node2);
+                     return Tail;
+
+                  when N_Empty =>
+                     Set_Expressions (Node2, New_List (Tail));
+                     return Node2;
+
+                  when others =>
+                     null;
+               end case;
+
+               --  fall through to error case
+            end;
+         end if;
+      end if;
+
       --  Come here at end of simple expression, where we do a couple of
       --  special checks to improve error recovery.
 
@@ -2529,8 +2645,8 @@ package body Ch4 is
       if Token = Tok_Dot then
          Error_Msg_SC ("prefix for selection is not a name");
 
-         --  If qualified expression, comment and continue, otherwise something
-         --  is pretty nasty so do an Error_Resync call.
+         --  If qualified expression, comment and continue, otherwise
+         --  something is pretty nasty so do an Error_Resync call.
 
          if Ada_Version < Ada_2012
            and then Nkind (Node1) = N_Qualified_Expression