This patch implements AI12-0127, which describes a new constructor for
aggregate in terms of an existing record or array aggregate and a series
of component-wise modifications of its value.
Executing:
gnatmake -gnat2020 -q a2020
a2020
must yield:
1
2
9
16
25
---
with Text_IO; use Text_IO;
procedure A2020 is
type Powers is array (1..5) of integer;
type Table is array (1..4) of Powers;
Thing : Table;
begin
Thing := (others => (for I in Powers'range => I));
Thing (2) := (@ with delta for J in 3..5 => @(j) ** 2);
for I in Powers'range loop
Put_Line (Integer'Image (Thing (2)(I)));
end loop;
end;
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-01-23 Ed Schonberg <schonb...@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.
Index: sem_aggr.adb
===================================================================
--- sem_aggr.adb (revision 244784)
+++ sem_aggr.adb (working copy)
@@ -1678,11 +1678,17 @@
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);
End_Scope;
@@ -2082,6 +2088,9 @@
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 @@
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: sem_aggr.ads
===================================================================
--- sem_aggr.ads (revision 244773)
+++ sem_aggr.ads (working copy)
@@ -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 @@
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: exp_util.adb
===================================================================
--- exp_util.adb (revision 244792)
+++ exp_util.adb (working copy)
@@ -5831,6 +5831,7 @@
| 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: sinfo.adb
===================================================================
--- sinfo.adb (revision 244783)
+++ sinfo.adb (working copy)
@@ -466,6 +466,7 @@
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 @@
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 @@
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 @@
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: sinfo.ads
===================================================================
--- sinfo.ads (revision 244788)
+++ sinfo.ads (working copy)
@@ -4133,6 +4133,15 @@
-- 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 @@
N_Aggregate,
N_Allocator,
N_Case_Expression,
+ N_Delta_Aggregate,
N_Extension_Aggregate,
N_Raise_Expression,
N_Range,
@@ -11524,6 +11534,13 @@
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: scng.adb
===================================================================
--- scng.adb (revision 244788)
+++ scng.adb (working copy)
@@ -1613,7 +1613,7 @@
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: sem.adb
===================================================================
--- sem.adb (revision 244783)
+++ sem.adb (working copy)
@@ -196,6 +196,9 @@
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: par-ch4.adb
===================================================================
--- par-ch4.adb (revision 244788)
+++ par-ch4.adb (working copy)
@@ -1381,7 +1381,7 @@
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,10 +1395,19 @@
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
if Token = Tok_Null then
@@ -1586,7 +1595,11 @@
-- 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 @@
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: sem_res.adb
===================================================================
--- sem_res.adb (revision 244783)
+++ sem_res.adb (working copy)
@@ -2870,6 +2870,9 @@
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: exp_aggr.adb
===================================================================
--- exp_aggr.adb (revision 244773)
+++ exp_aggr.adb (working copy)
@@ -84,6 +84,9 @@
-- 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,7 +6439,152 @@
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: exp_aggr.ads
===================================================================
--- exp_aggr.ads (revision 244773)
+++ exp_aggr.ads (working copy)
@@ -28,6 +28,7 @@
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: sprint.adb
===================================================================
--- sprint.adb (revision 244783)
+++ sprint.adb (working copy)
@@ -1775,6 +1775,13 @@
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));
