[multiple changes]
authorArnaud Charlet <charlet@gcc.gnu.org>
Mon, 23 Jan 2017 12:07:34 +0000 (13:07 +0100)
committerArnaud Charlet <charlet@gcc.gnu.org>
Mon, 23 Jan 2017 12:07:34 +0000 (13:07 +0100)
2017-01-23  Ed Schonberg  <schonberg@adacore.com>

* par-ch4.adb (P_Aggregate_Or_Parent_Expr): Recognize delta
aggregate construct.
(P_Record_Or_Array_Component_Association): An array aggregate
can start with an Iterated_Component_Association.
* scng.adb: Modify error message on improper use of @ in earlier
versions of the language.
* sinfo.ads: New node kind N_Delta_Aggregate.
* sinfo.adb: An N_Delta_Aggregate has component associations and
an expression.
* sem_res.adb (Resolve): Call Resolve_Delta_Aggregate.
* sem_aggr.ads, sem_aggr.adb (Resolve_Iterated_Component_Association):
Create a new index for each one of the choices in the association,
to prevent spurious homonyms in the scope.
(Resolve_Delta_Aggregate): New.
* sem.adb: An N_Delta_Aggregate is analyzed like an aggregate.
* exp_util.adb (Insert_Actions): Take into account
N_Delta_Aggregate.
* exp_aggr.ads: New procedure Expand_N_Delta_Aggregate.
* exp_aggr.adb: New procedure Expand_N_Delta_Aggregate,
and local procedures Expand_Delta_Array_Aggregate and
expand_Delta_Record_Aggregate.
* sprint.adb: Handle N_Delta_Aggregate.

2017-01-23  Hristian Kirtchev  <kirtchev@adacore.com>

* exp_ch11.adb (Expand_N_Exception_Declaration): Generate an
empty name when the exception declaration is subject to pragma
Discard_Names.
(Null_String): New routine.

2017-01-23  Hristian Kirtchev  <kirtchev@adacore.com>

* par-ch9.adb (P_Protected_Definition): Parse
any optional and potentially illegal pragmas which appear in
a protected operation declaration list.
(P_Task_Items): Parse
any optional and potentially illegal pragmas which appear in a
task item list.

From-SVN: r244794

15 files changed:
gcc/ada/ChangeLog
gcc/ada/exp_aggr.adb
gcc/ada/exp_aggr.ads
gcc/ada/exp_ch11.adb
gcc/ada/exp_util.adb
gcc/ada/par-ch4.adb
gcc/ada/par-ch9.adb
gcc/ada/scng.adb
gcc/ada/sem.adb
gcc/ada/sem_aggr.adb
gcc/ada/sem_aggr.ads
gcc/ada/sem_res.adb
gcc/ada/sinfo.adb
gcc/ada/sinfo.ads
gcc/ada/sprint.adb

index 10a61b88759ae49d67551861ba2936fe5c4e8ff7..8a8c290cad9c404533ad93140e504a00fd0a2932 100644 (file)
@@ -1,3 +1,44 @@
+2017-01-23  Ed Schonberg  <schonberg@adacore.com>
+
+       * par-ch4.adb (P_Aggregate_Or_Parent_Expr): Recognize delta
+       aggregate construct.
+       (P_Record_Or_Array_Component_Association): An array aggregate
+       can start with an Iterated_Component_Association.
+       * scng.adb: Modify error message on improper use of @ in earlier
+       versions of the language.
+       * sinfo.ads: New node kind N_Delta_Aggregate.
+       * sinfo.adb: An N_Delta_Aggregate has component associations and
+       an expression.
+       * sem_res.adb (Resolve): Call Resolve_Delta_Aggregate.
+       * sem_aggr.ads, sem_aggr.adb (Resolve_Iterated_Component_Association):
+       Create a new index for each one of the choices in the association,
+       to prevent spurious homonyms in the scope.
+       (Resolve_Delta_Aggregate): New.
+       * sem.adb: An N_Delta_Aggregate is analyzed like an aggregate.
+       * exp_util.adb (Insert_Actions): Take into account
+       N_Delta_Aggregate.
+       * exp_aggr.ads: New procedure Expand_N_Delta_Aggregate.
+       * exp_aggr.adb: New procedure Expand_N_Delta_Aggregate,
+       and local procedures Expand_Delta_Array_Aggregate and
+       expand_Delta_Record_Aggregate.
+       * sprint.adb: Handle N_Delta_Aggregate.
+
+2017-01-23  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * exp_ch11.adb (Expand_N_Exception_Declaration): Generate an
+       empty name when the exception declaration is subject to pragma
+       Discard_Names.
+       (Null_String): New routine.
+
+2017-01-23  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * par-ch9.adb (P_Protected_Definition): Parse
+       any optional and potentially illegal pragmas which appear in
+       a protected operation declaration list.
+       (P_Task_Items): Parse
+       any optional and potentially illegal pragmas which appear in a
+       task item list.
+
 2017-01-23  Pascal Obry  <obry@adacore.com>
 
        * s-taprop-mingw.adb (Enter_Task): Initialize the Thread handle which
index 9da35ddb9c2e6a418e2c72cccce3d27f28928793..a41bfa08aeda8fa80dbc2f7ed10b2b66b0fbe14e 100644 (file)
@@ -84,6 +84,9 @@ package body Exp_Aggr is
    --  expression with actions, which becomes the Initialization_Statements for
    --  Obj.
 
+   procedure Expand_Delta_Array_Aggregate  (N : Node_Id; Deltas : List_Id);
+   procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id);
+
    function Has_Default_Init_Comps (N : Node_Id) return Boolean;
    --  N is an aggregate (record or array). Checks the presence of default
    --  initialization (<>) in any component (Ada 2005: AI-287).
@@ -6436,6 +6439,151 @@ package body Exp_Aggr is
          return;
    end Expand_N_Aggregate;
 
+   ------------------------------
+   -- Expand_N_Delta_Aggregate --
+   ------------------------------
+
+   procedure Expand_N_Delta_Aggregate (N : Node_Id) is
+      Loc :  constant Source_Ptr := Sloc (N);
+      Temp : constant Entity_Id := Make_Temporary (Loc, 'T');
+      Typ  : constant Entity_Id := Etype (N);
+      Decl : Node_Id;
+
+   begin
+      Decl := Make_Object_Declaration (Loc,
+         Defining_Identifier => Temp,
+         Object_Definition => New_Occurrence_Of (Typ, Loc),
+         Expression => New_Copy_Tree (Expression (N)));
+
+      if Is_Array_Type (Etype (N)) then
+         Expand_Delta_Array_Aggregate (N, New_List (Decl));
+      else
+         Expand_Delta_Record_Aggregate (N, New_List (Decl));
+      end if;
+   end Expand_N_Delta_Aggregate;
+
+   ----------------------------------
+   -- Expand_Delta_Array_Aggregate --
+   ----------------------------------
+
+   procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id) is
+      Loc    : constant Source_Ptr := Sloc (N);
+      Temp   : constant Entity_Id  := Defining_Identifier (First (Deltas));
+      Assoc  : Node_Id;
+      Choice : Node_Id;
+      function Generate_Loop (C : Node_Id) return Node_Id;
+      --  Generate a loop containing individual component assignments for
+      --  choices that are ranges, subtype indications, subtype names, and
+      --  iterated component associations.
+
+      function Generate_Loop (C : Node_Id) return Node_Id is
+         Sl : constant Source_Ptr := Sloc (C);
+         Ix : Entity_Id;
+
+      begin
+         if Nkind (Parent (C)) = N_Iterated_Component_Association then
+            Ix :=
+              Make_Defining_Identifier (Loc,
+                Chars => (Chars (Defining_Identifier (Parent (C)))));
+         else
+            Ix := Make_Temporary (Sl, 'I');
+         end if;
+
+         return
+           Make_Loop_Statement (Loc,
+              Iteration_Scheme => Make_Iteration_Scheme (Sl,
+                Loop_Parameter_Specification =>
+                Make_Loop_Parameter_Specification (Sl,
+                  Defining_Identifier => Ix,
+                  Discrete_Subtype_Definition => New_Copy_Tree (C))),
+              End_Label => Empty,
+              Statements =>
+                New_List (
+                  Make_Assignment_Statement (Sl,
+                    Name       => Make_Indexed_Component (Sl,
+                      Prefix      => New_Occurrence_Of (Temp, Sl),
+                      Expressions => New_List (New_Occurrence_Of (Ix, Sl))),
+                    Expression => New_Copy_Tree (Expression (Assoc)))));
+      end Generate_Loop;
+
+   begin
+      Assoc := First (Component_Associations (N));
+      while Present (Assoc) loop
+         Choice := First (Choice_List (Assoc));
+         if Nkind (Assoc) = N_Iterated_Component_Association then
+            while Present (Choice) loop
+               Append_To (Deltas, Generate_Loop (Choice));
+               Next (Choice);
+            end loop;
+
+         else
+            while Present (Choice) loop
+
+               --  Choice can be given by a range, a subtype indication, a
+               --  subtype name, a scalar value, or an entity.
+
+               if Nkind (Choice) = N_Range
+                 or else (Is_Entity_Name (Choice)
+                   and then Is_Type (Entity (Choice)))
+               then
+                  Append_To (Deltas, Generate_Loop (Choice));
+
+               elsif Nkind (Choice) = N_Subtype_Indication then
+                  Append_To (Deltas,
+                    Generate_Loop (Range_Expression (Constraint (Choice))));
+
+               else
+                  Append_To (Deltas,
+                     Make_Assignment_Statement (Sloc (Choice),
+                       Name => Make_Indexed_Component (Sloc (Choice),
+                         Prefix => New_Occurrence_Of (Temp, Loc),
+                         Expressions => New_List (New_Copy_Tree (Choice))),
+                       Expression => New_Copy_Tree (Expression (Assoc))));
+               end if;
+
+               Next (Choice);
+            end loop;
+         end if;
+
+         Next (Assoc);
+      end loop;
+
+      Insert_Actions (N, Deltas);
+      Rewrite (N, New_Occurrence_Of (Temp, Loc));
+   end Expand_Delta_Array_Aggregate;
+
+   -----------------------------------
+   -- Expand_Delta_Record_Aggregate --
+   -----------------------------------
+
+   procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id) is
+      Loc    : constant Source_Ptr := Sloc (N);
+      Temp   : constant Entity_Id  := Defining_Identifier (First (Deltas));
+      Assoc  : Node_Id;
+      Choice : Node_Id;
+
+   begin
+      Assoc := First (Component_Associations (N));
+
+      while Present (Assoc) loop
+         Choice := First (Choice_List (Assoc));
+         while Present (Choice) loop
+            Append_To (Deltas,
+               Make_Assignment_Statement (Sloc (Choice),
+                 Name => Make_Selected_Component (Sloc (Choice),
+                   Prefix => New_Occurrence_Of (Temp, Loc),
+                   Selector_Name => Make_Identifier (Loc, Chars (Choice))),
+                 Expression => New_Copy_Tree (Expression (Assoc))));
+            Next (Choice);
+         end loop;
+
+         Next (Assoc);
+      end loop;
+
+      Insert_Actions (N, Deltas);
+      Rewrite (N, New_Occurrence_Of (Temp, Loc));
+   end Expand_Delta_Record_Aggregate;
+
    ----------------------------------
    -- Expand_N_Extension_Aggregate --
    ----------------------------------
index 912f5465870138f34bc1037a6fbd913ffdb94d94..b9441fde4c0ee7ef1a1cca7d1af1a46a00472da2 100644 (file)
@@ -28,6 +28,7 @@ with Types; use Types;
 package Exp_Aggr is
 
    procedure Expand_N_Aggregate           (N : Node_Id);
+   procedure Expand_N_Delta_Aggregate     (N : Node_Id);
    procedure Expand_N_Extension_Aggregate (N : Node_Id);
 
    function Is_Delayed_Aggregate (N : Node_Id) return Boolean;
index 4e37a50becdef7866df44703d5ca1c2a93d6a84b..8711c89d0eb483b2c2aa67052f4a11cf5fff7d01 100644 (file)
@@ -1171,11 +1171,8 @@ package body Exp_Ch11 is
    --     end if;
 
    procedure Expand_N_Exception_Declaration (N : Node_Id) is
-      Id      : constant Entity_Id  := Defining_Identifier (N);
-      Loc     : constant Source_Ptr := Sloc (N);
-      Ex_Id   : Entity_Id;
-      Flag_Id : Entity_Id;
-      L       : List_Id;
+      Id  : constant Entity_Id  := Defining_Identifier (N);
+      Loc : constant Source_Ptr := Sloc (N);
 
       procedure Force_Static_Allocation_Of_Referenced_Objects
         (Aggregate : Node_Id);
@@ -1205,6 +1202,9 @@ package body Exp_Ch11 is
       --  references to other local (non-hoisted) objects (e.g., in the initial
       --  value expression).
 
+      function Null_String return String_Id;
+      --  Build a null-terminated empty string
+
       ---------------------------------------------------
       -- Force_Static_Allocation_Of_Referenced_Objects --
       ---------------------------------------------------
@@ -1248,6 +1248,24 @@ package body Exp_Ch11 is
          Fixup_Tree (Aggregate);
       end Force_Static_Allocation_Of_Referenced_Objects;
 
+      -----------------
+      -- Null_String --
+      -----------------
+
+      function Null_String return String_Id is
+      begin
+         Start_String;
+         Store_String_Char (Get_Char_Code (ASCII.NUL));
+         return End_String;
+      end Null_String;
+
+      --  Local variables
+
+      Ex_Id   : Entity_Id;
+      Ex_Val  : String_Id;
+      Flag_Id : Entity_Id;
+      L       : List_Id;
+
    --  Start of processing for Expand_N_Exception_Declaration
 
    begin
@@ -1262,14 +1280,25 @@ package body Exp_Ch11 is
       Ex_Id :=
         Make_Defining_Identifier (Loc, New_External_Name (Chars (Id), 'E'));
 
+      --  Do not generate an external name if the exception declaration is
+      --  subject to pragma Discard_Names. Use a null-terminated empty name
+      --  to ensure that Ada.Exceptions.Exception_Name functions properly.
+
+      if Global_Discard_Names or else Discard_Names (Ex_Id) then
+         Ex_Val := Null_String;
+
+      --  Otherwise generate the fully qualified name of the exception
+
+      else
+         Ex_Val := Fully_Qualified_Name_String (Id);
+      end if;
+
       Insert_Action (N,
         Make_Object_Declaration (Loc,
           Defining_Identifier => Ex_Id,
           Constant_Present    => True,
           Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
-          Expression          =>
-            Make_String_Literal (Loc,
-              Strval => Fully_Qualified_Name_String (Id))));
+          Expression          => Make_String_Literal (Loc, Ex_Val)));
 
       Set_Is_Statically_Allocated (Ex_Id);
 
index a0b0edad191483e82c134a0f54594c75d0cc7c79..3a1d98587c7e27cfc6d57a7d456c703125f4fccb 100644 (file)
@@ -5831,6 +5831,7 @@ package body Exp_Util is
                | N_Defining_Operator_Symbol
                | N_Defining_Program_Unit_Name
                | N_Delay_Alternative
+               | N_Delta_Aggregate
                | N_Delta_Constraint
                | N_Derived_Type_Definition
                | N_Designator
index 776b2284b5d428026ae52148fd50ba0d74b29ddd..e9a3a23b3fb06093e06ef4972a98343bddfba77a 100644 (file)
@@ -1381,7 +1381,7 @@ package body Ch4 is
             Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
          end if;
 
-         --  Extension aggregate
+         --  Extension or Delta aggregate
 
          if Token = Tok_With then
             if Nkind (Expr_Node) = N_Attribute_Reference
@@ -1395,9 +1395,18 @@ package body Ch4 is
                Error_Msg_SC ("(Ada 83) extension aggregate not allowed");
             end if;
 
-            Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc);
-            Set_Ancestor_Part (Aggregate_Node, Expr_Node);
             Scan; -- past WITH
+            if Token = Tok_Delta then
+               Scan; -- past DELTA
+               Aggregate_Node := New_Node (N_Delta_Aggregate, Lparen_Sloc);
+               Set_Expression (Aggregate_Node, Expr_Node);
+               Expr_Node := Empty;
+               goto Aggregate;
+
+            else
+               Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc);
+               Set_Ancestor_Part (Aggregate_Node, Expr_Node);
+            end if;
 
             --  Deal with WITH NULL RECORD case
 
@@ -1586,7 +1595,11 @@ package body Ch4 is
       --  All component associations (positional and named) have been scanned
 
       T_Right_Paren;
-      Set_Expressions (Aggregate_Node, Expr_List);
+
+      if Nkind (Aggregate_Node) /= N_Delta_Aggregate then
+         Set_Expressions (Aggregate_Node, Expr_List);
+      end if;
+
       Set_Component_Associations (Aggregate_Node, Assoc_List);
       return Aggregate_Node;
    end P_Aggregate_Or_Paren_Expr;
@@ -1622,6 +1635,10 @@ package body Ch4 is
       Assoc_Node : Node_Id;
 
    begin
+      if Token = Tok_For then
+         return P_Iterated_Component_Association;
+      end if;
+
       Assoc_Node := New_Node (N_Component_Association, Token_Ptr);
       Set_Choices (Assoc_Node, P_Discrete_Choice_List);
       Set_Sloc (Assoc_Node, Token_Ptr);
index 1137823133e72241d856a48818e7d3c53ed0820a..11b6542e54d178148f67921be1fcbc2155dc6f41 100644 (file)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2016, 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- --
@@ -338,10 +338,10 @@ package body Ch9 is
          Decl_Sloc := Token_Ptr;
 
          if Token = Tok_Pragma then
-            Append (P_Pragma, Items);
+            P_Pragmas_Opt (Items);
 
-         --  Ada 2005 (AI-397): Reserved words NOT and OVERRIDING
-         --  may begin an entry declaration.
+         --  Ada 2005 (AI-397): Reserved words NOT and OVERRIDING may begin an
+         --  entry declaration.
 
          elsif Token = Tok_Entry
            or else Token = Tok_Not
@@ -350,8 +350,9 @@ package body Ch9 is
             Append (P_Entry_Declaration, Items);
 
          elsif Token = Tok_For then
-            --  Representation clause in task declaration. The only rep
-            --  clause which is legal in a protected is an address clause,
+
+            --  Representation clause in task declaration. The only rep clause
+            --  which is legal in a protected declaration is an address clause,
             --  so that is what we try to scan out.
 
             Item_Node := P_Representation_Clause;
@@ -617,8 +618,10 @@ package body Ch9 is
    --  Error recovery: cannot raise Error_Resync
 
    function P_Protected_Definition return Node_Id is
-      Def_Node  : Node_Id;
-      Item_Node : Node_Id;
+      Def_Node   : Node_Id;
+      Item_Node  : Node_Id;
+      Priv_Decls : List_Id;
+      Vis_Decls  : List_Id;
 
    begin
       Def_Node := New_Node (N_Protected_Definition, Token_Ptr);
@@ -631,33 +634,63 @@ package body Ch9 is
 
       --  Loop to scan visible declarations (protected operation declarations)
 
-      Set_Visible_Declarations (Def_Node, New_List);
+      Vis_Decls := New_List;
+      Set_Visible_Declarations (Def_Node, Vis_Decls);
+
+      --  Flag and discard all pragmas which cannot appear in the protected
+      --  definition. Note that certain pragmas are still allowed as long as
+      --  they apply to entries, entry families, or protected subprograms.
+
+      P_Pragmas_Opt (Vis_Decls);
 
       loop
          Item_Node := P_Protected_Operation_Declaration_Opt;
+
+         if Present (Item_Node) then
+            Append (Item_Node, Vis_Decls);
+         end if;
+
+         P_Pragmas_Opt (Vis_Decls);
+
          exit when No (Item_Node);
-         Append (Item_Node, Visible_Declarations (Def_Node));
       end loop;
 
       --  Deal with PRIVATE part (including graceful handling of multiple
       --  PRIVATE parts).
 
       Private_Loop : while Token = Tok_Private loop
-         if No (Private_Declarations (Def_Node)) then
-            Set_Private_Declarations (Def_Node, New_List);
-         else
+         Priv_Decls := Private_Declarations (Def_Node);
+
+         if Present (Priv_Decls) then
             Error_Msg_SC ("duplicate private part");
+         else
+            Priv_Decls := New_List;
+            Set_Private_Declarations (Def_Node, Priv_Decls);
          end if;
 
          Scan; -- past PRIVATE
 
+         --  Flag and discard all pragmas which cannot appear in the protected
+         --  definition. Note that certain pragmas are still allowed as long as
+         --  they apply to entries, entry families, or protected subprograms.
+
+         P_Pragmas_Opt (Priv_Decls);
+
          Declaration_Loop : loop
             if Token = Tok_Identifier then
-               P_Component_Items (Private_Declarations (Def_Node));
+               P_Component_Items (Priv_Decls);
+               P_Pragmas_Opt (Priv_Decls);
+
             else
                Item_Node := P_Protected_Operation_Declaration_Opt;
+
+               if Present (Item_Node) then
+                  Append (Item_Node, Priv_Decls);
+               end if;
+
+               P_Pragmas_Opt (Priv_Decls);
+
                exit Declaration_Loop when No (Item_Node);
-               Append (Item_Node, Private_Declarations (Def_Node));
             end if;
          end loop Declaration_Loop;
       end loop Private_Loop;
index ba3c9502b9369417fd6714d32f74adf8300f8752..ae09cc8e43bd76b83b3cefd0b3f8c2518cd8379a 100644 (file)
@@ -1613,7 +1613,7 @@ package body Scng is
 
          when '@' =>
             if Ada_Version < Ada_2020 then
-               Error_Illegal_Character;
+               Error_Msg ("target_name is an Ada2020 feature", Scan_Ptr);
                Scan_Ptr := Scan_Ptr + 1;
 
             else
index 36b561e79c9c772758f3a0cbc62d4fa0bf49bd8f..bae89ad5ad11a5d50e7e4f14cb74867ff727aa85 100644 (file)
@@ -196,6 +196,9 @@ package body Sem is
          when N_Delay_Relative_Statement =>
             Analyze_Delay_Relative (N);
 
+         when N_Delta_Aggregate =>
+            Analyze_Aggregate (N);
+
          when N_Delay_Until_Statement =>
             Analyze_Delay_Until (N);
 
index 6ca9d181b3d575b66fe359aa96f6c65ba5391c19..65d586da32afa785ea53ea2b4a3adb5bee49eac5 100644 (file)
@@ -1678,10 +1678,16 @@ package body Sem_Aggr is
          Set_Etype  (Ent, Standard_Void_Type);
          Set_Parent (Ent, Parent (N));
 
-         Enter_Name (Id);
-         Set_Etype (Id, Index_Typ);
-         Set_Ekind (Id, E_Variable);
-         Set_Scope (Id, Ent);
+         --  Decorate the index variable in the current scope. The association
+         --  may have several choices, each one leading to a loop, so we create
+         --  this variable only once to prevent homonyms in this scope.
+
+         if No (Scope (Id)) then
+            Enter_Name (Id);
+            Set_Etype (Id, Index_Typ);
+            Set_Ekind (Id, E_Variable);
+            Set_Scope (Id, Ent);
+         end if;
 
          Push_Scope (Ent);
          Dummy := Resolve_Aggr_Expr (Expression (N), False);
@@ -2082,6 +2088,9 @@ package body Sem_Aggr is
                      return Failure;
                   end if;
 
+               elsif Nkind (Assoc) = N_Iterated_Component_Association then
+                  null;   --  handled above, in a loop context.
+
                elsif not Resolve_Aggr_Expr
                            (Expression (Assoc), Single_Elmt => Single_Choice)
                then
@@ -2726,6 +2735,143 @@ package body Sem_Aggr is
       return Success;
    end Resolve_Array_Aggregate;
 
+   -----------------------------
+   -- Resolve_Delta_Aggregate --
+   -----------------------------
+
+   procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is
+      Base       : constant Node_Id   := Expression (N);
+      Deltas     : constant List_Id   := Component_Associations (N);
+      Assoc      : Node_Id;
+      Choice     : Node_Id;
+      Comp_Type  : Entity_Id;
+      Index_Type : Entity_Id;
+
+      function Get_Component_Type (Nam : Node_Id) return Entity_Id;
+
+      ------------------------
+      -- Get_Component_Type --
+      ------------------------
+
+      function Get_Component_Type (Nam : Node_Id) return Entity_Id is
+         Comp : Entity_Id;
+
+      begin
+         Comp := First_Entity (Typ);
+
+         while Present (Comp) loop
+            if Chars (Comp) = Chars (Nam) then
+               if Ekind (Comp) = E_Discriminant then
+                  Error_Msg_N ("delta cannot apply to discriminant", Nam);
+               end if;
+
+               return Etype (Comp);
+            end if;
+
+            Comp := Next_Entity (Comp);
+         end loop;
+
+         Error_Msg_NE ("type& has no component with this name", Nam, Typ);
+         return Any_Type;
+      end Get_Component_Type;
+
+   begin
+      if not Is_Composite_Type (Typ) then
+         Error_Msg_N ("not a composite type", N);
+      end if;
+
+      Analyze_And_Resolve (Base, Typ);
+      if Is_Array_Type (Typ) then
+         Index_Type := Etype (First_Index (Typ));
+         Assoc := First (Deltas);
+         while Present (Assoc) loop
+            if Nkind (Assoc) = N_Iterated_Component_Association then
+               Choice := First (Choice_List (Assoc));
+               while Present (Choice) loop
+                  if Nkind (Choice) = N_Others_Choice then
+                     Error_Msg_N
+                       ("others not allowed in delta aggregate", Choice);
+
+                  else
+                     Analyze_And_Resolve (Choice, Index_Type);
+                  end if;
+
+                  Next (Choice);
+               end loop;
+
+               declare
+                  Id  : constant Entity_Id  := Defining_Identifier (Assoc);
+                  Ent : constant Entity_Id  :=
+                    New_Internal_Entity
+                      (E_Loop, Current_Scope, Sloc (Assoc), 'L');
+
+               begin
+                  Set_Etype  (Ent, Standard_Void_Type);
+                  Set_Parent (Ent, Assoc);
+
+                  if No (Scope (Id)) then
+                     Enter_Name (Id);
+                     Set_Etype (Id, Index_Type);
+                     Set_Ekind (Id, E_Variable);
+                     Set_Scope (Id, Ent);
+                  end if;
+
+                  Push_Scope (Ent);
+                  Analyze_And_Resolve
+                    (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ));
+                  End_Scope;
+               end;
+
+            else
+               Choice := First (Choice_List (Assoc));
+               while Present (Choice) loop
+                  if Nkind (Choice) = N_Others_Choice then
+                     Error_Msg_N
+                       ("others not allowed in delta aggregate", Choice);
+
+                  else
+                     Analyze (Choice);
+                     if Is_Entity_Name (Choice)
+                       and then Is_Type (Entity (Choice))
+                     then
+                        --  Choice covers a range of values.
+                        if Base_Type (Entity (Choice)) /=
+                           Base_Type (Index_Type)
+                        then
+                           Error_Msg_NE ("choice does mat match index type of",
+                             Choice, Typ);
+                        end if;
+                     else
+                        Resolve (Choice, Index_Type);
+                     end if;
+                  end if;
+
+                  Next (Choice);
+               end loop;
+
+               Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ));
+            end if;
+
+            Next (Assoc);
+         end loop;
+
+      else
+         Assoc := First (Deltas);
+         while Present (Assoc) loop
+            Choice := First (Choice_List (Assoc));
+            while Present (Choice) loop
+               Comp_Type := Get_Component_Type (Choice);
+               Next (Choice);
+            end loop;
+
+            Analyze_And_Resolve (Expression (Assoc), Comp_Type);
+            Next (Assoc);
+         end loop;
+      end if;
+
+      Set_Etype (N, Typ);
+   end Resolve_Delta_Aggregate;
+
    ---------------------------------
    -- Resolve_Extension_Aggregate --
    ---------------------------------
index a0c1620cd38371e557e3718b2c0bfd41580d3025..8e795291c3641602eb2d5bac289f30e5e3752d4b 100644 (file)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2016, 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- --
@@ -30,6 +30,7 @@ with Types; use Types;
 
 package Sem_Aggr is
 
+   procedure Resolve_Delta_Aggregate     (N : Node_Id; Typ : Entity_Id);
    procedure Resolve_Aggregate           (N : Node_Id; Typ : Entity_Id);
    procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id);
 
index 33d3b60c61933876d5756bf2587b8f0559f3dbcf..3d6c39583c84886567680e0cbbb80cca51825116 100644 (file)
@@ -2870,6 +2870,9 @@ package body Sem_Res is
             when N_Character_Literal =>
                Resolve_Character_Literal         (N, Ctx_Type);
 
+            when N_Delta_Aggregate =>
+               Resolve_Delta_Aggregate           (N, Ctx_Type);
+
             when N_Expanded_Name =>
                Resolve_Entity_Name               (N, Ctx_Type);
 
index d52c43c17d80c733efca509a07e07d85226beb02..fc88da8e0120f2612d8adae99e27c4f06f5caf3f 100644 (file)
@@ -466,6 +466,7 @@ package body Sinfo is
    begin
       pragma Assert (False
         or else NT (N).Nkind = N_Aggregate
+        or else NT (N).Nkind = N_Delta_Aggregate
         or else NT (N).Nkind = N_Extension_Aggregate);
       return List2 (N);
    end Component_Associations;
@@ -1265,6 +1266,7 @@ package body Sinfo is
         or else NT (N).Nkind = N_Component_Declaration
         or else NT (N).Nkind = N_Delay_Relative_Statement
         or else NT (N).Nkind = N_Delay_Until_Statement
+        or else NT (N).Nkind = N_Delta_Aggregate
         or else NT (N).Nkind = N_Discriminant_Association
         or else NT (N).Nkind = N_Discriminant_Specification
         or else NT (N).Nkind = N_Exception_Declaration
@@ -3775,6 +3777,7 @@ package body Sinfo is
    begin
       pragma Assert (False
         or else NT (N).Nkind = N_Aggregate
+        or else NT (N).Nkind = N_Delta_Aggregate
         or else NT (N).Nkind = N_Extension_Aggregate);
       Set_List2_With_Parent (N, Val);
    end Set_Component_Associations;
@@ -4565,6 +4568,7 @@ package body Sinfo is
         or else NT (N).Nkind = N_Component_Declaration
         or else NT (N).Nkind = N_Delay_Relative_Statement
         or else NT (N).Nkind = N_Delay_Until_Statement
+        or else NT (N).Nkind = N_Delta_Aggregate
         or else NT (N).Nkind = N_Discriminant_Association
         or else NT (N).Nkind = N_Discriminant_Specification
         or else NT (N).Nkind = N_Exception_Declaration
index 4ff8fb1da9fb7c5a7dc46acb0c215216c931d2dd..69f283759b52bec610ee7a9813790cae8a4a4608 100644 (file)
@@ -4133,6 +4133,15 @@ package Sinfo is
       --  Note that Box_Present is always False, but it is intentionally added
       --  for completeness.
 
+      ----------------------------
+      --  4.3.4 Delta Aggregate --
+      ----------------------------
+
+      --  N_Delta_Aggregate
+      --  Sloc points to left parenthesis
+      --  Expression (Node3)
+      --  Component_Associations (List2)
+
       --------------------------------------------------
       -- 4.4  Expression/Relation/Term/Factor/Primary --
       --------------------------------------------------
@@ -8475,6 +8484,7 @@ package Sinfo is
       N_Aggregate,
       N_Allocator,
       N_Case_Expression,
+      N_Delta_Aggregate,
       N_Extension_Aggregate,
       N_Raise_Expression,
       N_Range,
@@ -11524,6 +11534,13 @@ package Sinfo is
         4 => True,    --  Discrete_Choices (List4)
         5 => False),  --  unused
 
+     N_Delta_Aggregate =>
+       (1 => False,   --  Expressions (List1)
+        2 => True,    --  Component_Associations (List2)
+        3 => True,    --  Expression (Node3)
+        4 => False,   --  Unused
+        5 => False),  --  Etype (Node5-Sem)
+
      N_Extension_Aggregate =>
        (1 => True,    --  Expressions (List1)
         2 => True,    --  Component_Associations (List2)
index bed39b52df4834b923f7abd73f6633323e9f9b61..f10ff039f8daeaba5469982419b34837340f6efc 100644 (file)
@@ -1775,6 +1775,13 @@ package body Sprint is
                Write_Indent_Str (";");
             end if;
 
+         when N_Delta_Aggregate =>
+            Write_Str_With_Col_Check_Sloc ("(");
+            Sprint_Node (Expression (Node));
+            Write_Str_With_Col_Check (" with delta ");
+            Sprint_Comma_List (Component_Associations (Node));
+            Write_Char (')');
+
          when N_Extension_Aggregate =>
             Write_Str_With_Col_Check_Sloc ("(");
             Sprint_Node (Ancestor_Part (Node));