@@ -76,6 +76,7 @@ package Aspects is
(No_Aspect, -- Dummy entry for no aspect
Aspect_Abstract_State, -- GNAT
Aspect_Address,
+ Aspect_Aggregate,
Aspect_Alignment,
Aspect_Annotate, -- GNAT
Aspect_Async_Readers, -- GNAT
@@ -300,6 +301,7 @@ package Aspects is
Aspect_Iterator_Element => True,
Aspect_Iterable => True,
Aspect_Variable_Indexing => True,
+ Aspect_Aggregate => True,
others => False);
-- The following array indicates aspects for which multiple occurrences of
@@ -345,6 +347,7 @@ package Aspects is
(No_Aspect => Optional_Expression,
Aspect_Abstract_State => Expression,
Aspect_Address => Expression,
+ Aspect_Aggregate => Expression,
Aspect_Alignment => Expression,
Aspect_Annotate => Expression,
Aspect_Async_Readers => Optional_Expression,
@@ -442,6 +445,7 @@ package Aspects is
(No_Aspect => False,
Aspect_Abstract_State => False,
Aspect_Address => True,
+ Aspect_Aggregate => False,
Aspect_Alignment => True,
Aspect_Annotate => False,
Aspect_Async_Readers => False,
@@ -580,6 +584,7 @@ package Aspects is
(No_Aspect => No_Name,
Aspect_Abstract_State => Name_Abstract_State,
Aspect_Address => Name_Address,
+ Aspect_Aggregate => Name_Aggregate,
Aspect_Alignment => Name_Alignment,
Aspect_All_Calls_Remote => Name_All_Calls_Remote,
Aspect_Annotate => Name_Annotate,
@@ -828,6 +833,7 @@ package Aspects is
Aspect_Delay : constant array (Aspect_Id) of Delay_Type :=
(No_Aspect => Always_Delay,
Aspect_Address => Always_Delay,
+ Aspect_Aggregate => Always_Delay,
Aspect_All_Calls_Remote => Always_Delay,
Aspect_Asynchronous => Always_Delay,
Aspect_Attach_Handler => Always_Delay,
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@@ -52,6 +53,7 @@ with Sem; use Sem;
with Sem_Aggr; use Sem_Aggr;
with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
@@ -86,6 +88,7 @@ package body Exp_Aggr is
procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id);
procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id);
+ procedure Expand_Container_Aggregate (N : Node_Id);
function Get_Base_Object (N : Node_Id) return Entity_Id;
-- Return the base object, i.e. the outermost prefix object, that N refers
@@ -6740,6 +6743,9 @@ package body Exp_Aggr is
if Is_Record_Type (Etype (N)) then
Expand_Record_Aggregate (N);
+ elsif Has_Aspect (Etype (N), Aspect_Aggregate) then
+ Expand_Container_Aggregate (N);
+
-- Array aggregate case
else
@@ -6839,6 +6845,73 @@ package body Exp_Aggr is
return;
end Expand_N_Aggregate;
+ --------------------------------
+ -- Expand_Container_Aggregate --
+ --------------------------------
+
+ procedure Expand_Container_Aggregate (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+ Asp : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Aggregate);
+
+ Empty_Subp : Node_Id := Empty;
+ Add_Named_Subp : Node_Id := Empty;
+ Add_Unnamed_Subp : Node_Id := Empty;
+ New_Indexed_Subp : Node_Id := Empty;
+ Assign_Indexed_Subp : Node_Id := Empty;
+
+ Aggr_Code : constant List_Id := New_List;
+ Temp : constant Entity_Id := Make_Temporary (Loc, 'C', N);
+
+ Decl : Node_Id;
+ Init_Stat : Node_Id;
+ begin
+ Parse_Aspect_Aggregate (Asp,
+ Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp,
+ New_Indexed_Subp, Assign_Indexed_Subp);
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition => New_Occurrence_Of (Typ, Loc));
+
+ Insert_Action (N, Decl);
+ if Ekind (Entity (Empty_Subp)) = E_Constant then
+ Init_Stat := Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Temp, Loc),
+ Expression => Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Entity (Empty_Subp), Loc)));
+ else
+ Init_Stat := Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Temp, Loc),
+ Expression => New_Occurrence_Of (Entity (Empty_Subp), Loc));
+ end if;
+ Append (Init_Stat, Aggr_Code);
+
+ -- First case : positional aggregate.
+
+ if Present (Expressions (N)) then
+ declare
+ Insert : constant Entity_Id := Entity (Add_Unnamed_Subp);
+ Comp : Node_Id;
+ Stat : Node_Id;
+ begin
+ Comp := First (Expressions (N));
+ while Present (Comp) loop
+ Stat := Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Insert, Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Copy_Tree (Comp)));
+ Append (Stat, Aggr_Code);
+ Next (Comp);
+ end loop;
+ end;
+ end if;
+ Insert_Actions (N, Aggr_Code);
+ Rewrite (N, New_Occurrence_Of (Temp, Loc));
+ Analyze_And_Resolve (N, Typ);
+ end Expand_Container_Aggregate;
+
------------------------------
-- Expand_N_Delta_Aggregate --
------------------------------
@@ -2639,6 +2639,57 @@ package body Sem_Aggr is
return Success;
end Resolve_Array_Aggregate;
+ ---------------------------------
+ -- Resolve_Container_Aggregate --
+ ---------------------------------
+
+ procedure Resolve_Container_Aggregate (N : Node_Id; Typ : Entity_Id) is
+ Asp : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Aggregate);
+
+ Empty_Subp : Node_Id := Empty;
+ Add_Named_Subp : Node_Id := Empty;
+ Add_Unnamed_Subp : Node_Id := Empty;
+ New_Indexed_Subp : Node_Id := Empty;
+ Assign_Indexed_Subp : Node_Id := Empty;
+
+ begin
+ if Nkind (Asp) /= N_Aggregate then
+ pragma Assert (False);
+ return;
+ else
+ Set_Etype (N, Typ);
+ Parse_Aspect_Aggregate (Asp,
+ Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp,
+ New_Indexed_Subp, Assign_Indexed_Subp);
+
+ if Present (Add_Unnamed_Subp) then
+ declare
+ Elmt_Type : constant Entity_Id :=
+ Etype (Next_Formal
+ (First_Formal (Entity (Add_Unnamed_Subp))));
+ Comp : Node_Id;
+ begin
+ if Present (Expressions (N)) then
+ -- positional aggregate
+
+ Comp := First (Expressions (N));
+ while Present (Comp) loop
+ Analyze_And_Resolve (Comp, Elmt_Type);
+ Next (Comp);
+ end loop;
+ else
+
+ -- Empty aggregate, to be replaced by Empty during
+ -- expansion.
+ null;
+ end if;
+ end;
+ else
+ Error_Msg_N ("indexed aggregates are forthcoming", N);
+ end if;
+ end if;
+ end Resolve_Container_Aggregate;
+
-----------------------------
-- Resolve_Delta_Aggregate --
-----------------------------
@@ -33,6 +33,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);
+ procedure Resolve_Container_Aggregate (N : Node_Id; Typ : Entity_Id);
function Is_Others_Aggregate (Aggr : Node_Id) return Boolean;
-- Returns True is aggregate Aggr consists of a single OTHERS choice
@@ -242,6 +242,16 @@ package body Sem_Ch13 is
-- Register a check for the address clause N. The rest of the parameters
-- are in keeping with the components of Address_Clause_Check_Record below.
+ procedure Validate_Aspect_Aggregate (N : Node_Id);
+ -- Check legality of operations given in the Ada_2020 Aggregate aspect
+ -- for containers.
+
+ procedure Resolve_Aspect_Aggregate
+ (Typ : Entity_Id;
+ Expr : Node_Id);
+ -- Resolve each one of the operations specified in the specification of
+ -- Aspect_Aggregate.
+
procedure Resolve_Iterable_Operation
(N : Node_Id;
Cursor : Entity_Id;
@@ -1471,6 +1481,9 @@ package body Sem_Ch13 is
when Aspect_Iterable =>
Validate_Iterable_Aspect (E, ASN);
+ when Aspect_Aggregate =>
+ null;
+
when others =>
null;
end case;
@@ -4043,6 +4056,11 @@ package body Sem_Ch13 is
Aitem := Empty;
+ when Aspect_Aggregate =>
+ Validate_Aspect_Aggregate (Expr);
+ Record_Rep_Item (E, Aspect);
+ return;
+
when Aspect_Integer_Literal
| Aspect_Real_Literal
| Aspect_String_Literal
@@ -5193,8 +5211,9 @@ package body Sem_Ch13 is
Indexing_Found : Boolean := False;
procedure Check_Inherited_Indexing;
- -- For a derived type, check that no indexing aspect is specified
- -- for the type if it is also inherited
+ -- For a derived type, check tha for a derived type a specification
+ -- of an indexing aspect can only be confirming, i.e. uses the
+ -- the same name as in the parent type.
-- AI12-0160: verify that an indexing cannot be specified for
-- a derived type unless it is specified for the parent.
@@ -6613,6 +6632,7 @@ package body Sem_Ch13 is
or else not Is_Type (Entity (Expr))
then
Error_Msg_N ("aspect Iterator_Element must be a type", Expr);
+ return;
end if;
-------------------
@@ -10542,6 +10562,10 @@ package body Sem_Ch13 is
return;
+ when Aspect_Aggregate =>
+ Resolve_Aspect_Aggregate (Entity (ASN), Expr);
+ return;
+
-- Invariant/Predicate take boolean expressions
when Aspect_Dynamic_Predicate
@@ -14329,6 +14353,9 @@ package body Sem_Ch13 is
begin
case A_Id is
+ when Aspect_Aggregate =>
+ Resolve_Aspect_Aggregate (Entity (ASN), Expr);
+
-- For now we only deal with aspects that do not generate
-- subprograms, or that may mention current instances of
-- types. These will require special handling (???TBD).
@@ -14642,6 +14669,92 @@ package body Sem_Ch13 is
end if;
end Same_Representation;
+ ----------------------------
+ -- Parse_Aspect_Aggregate --
+ ----------------------------
+
+ procedure Parse_Aspect_Aggregate
+ (N : Node_Id;
+ Empty_Subp : in out Node_Id;
+ Add_Named_Subp : in out Node_Id;
+ Add_Unnamed_Subp : in out Node_Id;
+ New_Indexed_Subp : in out Node_Id;
+ Assign_Indexed_Subp : in out Node_Id)
+ is
+ Assoc : Node_Id := First (Component_Associations (N));
+ Op_Name : Name_Id;
+ Subp : Node_Id;
+
+ begin
+ while Present (Assoc) loop
+ Subp := Expression (Assoc);
+ Op_Name := Chars (First (Choices (Assoc)));
+ if Op_Name = Name_Empty then
+ Empty_Subp := Subp;
+
+ elsif Op_Name = Name_Add_Named then
+ Add_Named_Subp := Subp;
+
+ elsif Op_Name = Name_Add_Unnamed then
+ Add_Unnamed_Subp := Subp;
+
+ elsif Op_Name = Name_New_Indexed then
+ New_Indexed_Subp := Subp;
+
+ elsif Op_Name = Name_Assign_Indexed then
+ Assign_Indexed_Subp := Subp;
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end Parse_Aspect_Aggregate;
+
+ -------------------------------
+ -- Validate_Aspect_Aggregate --
+ -------------------------------
+
+ procedure Validate_Aspect_Aggregate (N : Node_Id) is
+ Empty_Subp : Node_Id := Empty;
+ Add_Named_Subp : Node_Id := Empty;
+ Add_Unnamed_Subp : Node_Id := Empty;
+ New_Indexed_Subp : Node_Id := Empty;
+ Assign_Indexed_Subp : Node_Id := Empty;
+
+ begin
+ if Ada_Version < Ada_2020 then
+ Error_Msg_N ("Aspect Aggregate is an Ada_2020 feature", N);
+
+ elsif Nkind (N) /= N_Aggregate
+ or else Present (Expressions (N))
+ or else No (Component_Associations (N))
+ then
+ Error_Msg_N ("Aspect Aggregate requires an aggregate "
+ & "with component associations", N);
+ return;
+ end if;
+
+ Parse_Aspect_Aggregate (N,
+ Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp,
+ New_Indexed_Subp, Assign_Indexed_Subp);
+
+ if No (Empty_Subp) then
+ Error_Msg_N ("missing specification for Empty in aggregate", N);
+ end if;
+
+ if Present (Add_Named_Subp) then
+ if Present (Add_Unnamed_Subp)
+ or else Present (Assign_Indexed_Subp)
+ then
+ Error_Msg_N
+ ("conflicting operations for aggregate (RM 4.3.5)", N);
+ return;
+ end if;
+
+ elsif Present (New_Indexed_Subp) /= Present (Assign_Indexed_Subp) then
+ Error_Msg_N ("incomplete specification for indexed aggregate", N);
+ end if;
+ end Validate_Aspect_Aggregate;
+
--------------------------------
-- Resolve_Iterable_Operation --
--------------------------------
@@ -14803,6 +14916,189 @@ package body Sem_Ch13 is
end if;
end Resolve_Iterable_Operation;
+ ------------------------------
+ -- Resolve_Aspect_Aggregate --
+ ------------------------------
+
+ procedure Resolve_Aspect_Aggregate
+ (Typ : Entity_Id;
+ Expr : Node_Id)
+ is
+ -- Predicates that establish the legality of each possible
+ -- operation in an Aggregate aspect.
+
+ function Valid_Empty (E : Entity_Id) return Boolean;
+ function Valid_Add_Named (E : Entity_Id) return Boolean;
+ function Valid_Add_Unnamed (E : Entity_Id) return Boolean;
+ function Valid_New_Indexed (E : Entity_Id) return Boolean;
+
+ -- Note : the leglity rules for Assign_Indexed are the same
+ -- as for Add_Named.
+
+ generic
+ with function Pred (Id : Node_Id) return Boolean;
+ procedure Resolve_Operation (Subp_Id : Node_Id);
+ -- Common processing to resolve each aggregate operation.
+
+ -----------------
+ -- Valid_Emoty --
+ -----------------
+
+ function Valid_Empty (E : Entity_Id) return Boolean is
+ begin
+ if Etype (E) /= Typ or else Scope (E) /= Scope (Typ) then
+ return False;
+
+ elsif Ekind (E) = E_Constant then
+ return True;
+
+ elsif Ekind (E) = E_Function then
+ return No (First_Formal (E))
+ or else
+ (Is_Integer_Type (Etype (First_Formal (E)))
+ and then No (Next_Formal (First_Formal (E))));
+ else
+ return False;
+ end if;
+ end Valid_Empty;
+
+ ---------------------
+ -- Valid_Add_Named --
+ ---------------------
+
+ function Valid_Add_Named (E : Entity_Id) return Boolean is
+ F2, F3 : Entity_Id;
+ begin
+ if Ekind (E) = E_Procedure
+ and then Scope (E) = Scope (Typ)
+ and then Number_Formals (E) = 3
+ and then Etype (First_Formal (E)) = Typ
+ and then Ekind (First_Formal (E)) = E_In_Out_Parameter
+ then
+ F2 := Next_Formal (First_Formal (E));
+ F3 := Next_Formal (F2);
+ return Ekind (F2) = E_In_Parameter
+ and then Ekind (F3) = E_In_Parameter
+ and then not Is_Limited_Type (Etype (F2))
+ and then not Is_Limited_Type (Etype (F3));
+ else
+ return False;
+ end if;
+ end Valid_Add_Named;
+
+ -----------------------
+ -- Valid_Add_Unnamed --
+ -----------------------
+
+ function Valid_Add_Unnamed (E : Entity_Id) return Boolean is
+ begin
+ return Ekind (E) = E_Procedure
+ and then Scope (E) = Scope (Typ)
+ and then Number_Formals (E) = 2
+ and then Etype (First_Formal (E)) = Typ
+ and then Ekind (First_Formal (E)) = E_In_Out_Parameter
+ and then
+ not Is_Limited_Type (Etype (Next_Formal (First_Formal (E))));
+ end Valid_Add_Unnamed;
+
+ -----------------------
+ -- Valid_Nmw_Indexed --
+ -----------------------
+
+ function Valid_New_Indexed (E : Entity_Id) return Boolean is
+ begin
+ return Ekind (E) = E_Function
+ and then Scope (E) = Scope (Typ)
+ and then Etype (E) = Typ
+ and then Number_Formals (E) = 2
+ and then Is_Discrete_Type (Etype (First_Formal (E)))
+ and then Etype (First_Formal (E)) =
+ Etype (Next_Formal (First_Formal (E)));
+ end Valid_New_Indexed;
+
+ -----------------------
+ -- Resolve_Operation --
+ -----------------------
+
+ procedure Resolve_Operation (Subp_Id : Node_Id) is
+ Subp : Entity_Id;
+
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ if not Is_Overloaded (Subp_Id) then
+ Subp := Entity (Subp_Id);
+ if not Pred (Subp) then
+ Error_Msg_NE
+ ("improper aggregate operation for&", Subp_Id, Typ);
+ end if;
+
+ else
+ Set_Entity (Subp_Id, Empty);
+ Get_First_Interp (Subp_Id, I, It);
+ while Present (It.Nam) loop
+ if Pred (It.Nam) then
+ Set_Is_Overloaded (Subp_Id, False);
+ Set_Entity (Subp_Id, It.Nam);
+ exit;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if No (Entity (Subp_Id)) then
+ Error_Msg_NE
+ ("improper aggregate operation for&", Subp_Id, Typ);
+ end if;
+ end if;
+ end Resolve_Operation;
+
+ Assoc : Node_Id;
+ Op_Name : Name_Id;
+ Subp_Id : Node_Id;
+
+ procedure Resolve_Empty is new Resolve_Operation (Valid_Empty);
+ procedure Resolve_Unnamed is new Resolve_Operation (Valid_Add_Unnamed);
+ procedure Resolve_Named is new Resolve_Operation (Valid_Add_Named);
+ procedure Resolve_Indexed is new Resolve_Operation (Valid_New_Indexed);
+ procedure Resolve_Assign_Indexed
+ is new Resolve_Operation (Valid_Add_Named);
+ begin
+ Assoc := First (Component_Associations (Expr));
+
+ while Present (Assoc) loop
+ Op_Name := Chars (First (Choices (Assoc)));
+
+ -- When verifying the consistency of aspects between
+ -- the freeze point and the end of declarqtions, we
+ -- use a copy which is not analyzed yet, so do it now.
+
+ Subp_Id := Expression (Assoc);
+ if No (Etype (Subp_Id)) then
+ Analyze (Subp_Id);
+ end if;
+
+ if Op_Name = Name_Empty then
+ Resolve_Empty (Subp_Id);
+
+ elsif Op_Name = Name_Add_Named then
+ Resolve_Named (Subp_Id);
+
+ elsif Op_Name = Name_Add_Unnamed then
+ Resolve_Unnamed (Subp_Id);
+
+ elsif Op_Name = Name_New_Indexed then
+ Resolve_Indexed (Subp_Id);
+
+ elsif Op_Name = Name_Assign_Indexed then
+ Resolve_Assign_Indexed (Subp_Id);
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end Resolve_Aspect_Aggregate;
+
----------------
-- Set_Biased --
----------------
@@ -128,6 +128,17 @@ package Sem_Ch13 is
-- If the size is too small, and an error message is given, then both
-- Esize and RM_Size are reset to the allowed minimum value in T.
+ procedure Parse_Aspect_Aggregate
+ (N : Node_Id;
+ Empty_Subp : in out Node_Id;
+ Add_Named_Subp : in out Node_Id;
+ Add_Unnamed_Subp : in out Node_Id;
+ New_Indexed_Subp : in out Node_Id;
+ Assign_Indexed_Subp : in out Node_Id);
+ -- Utility to unpack the subprogramz in an occurrence of asoect Aggregate,
+ -- used to verify the structure of the asoect, and resolve and expand an
+ -- aggregate for a container type that carries the asoect.
+
function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean;
-- Called at start of processing a representation clause/pragma. Used to
-- check that the representation item is not being applied to an incomplete
@@ -2776,6 +2776,17 @@ package body Sem_Res is
elsif Nkind (N) = N_Aggregate
and then Etype (N) = Any_Composite
then
+ if Ada_Version >= Ada_2020
+ and then Has_Aspect (Typ, Aspect_Aggregate)
+ then
+ Resolve_Container_Aggregate (N, Typ);
+
+ if Expander_Active then
+ Expand (N);
+ end if;
+ return;
+ end if;
+
-- Disable expansion in any case. If there is a type mismatch
-- it may be fatal to try to expand the aggregate. The flag
-- would otherwise be set to false when the error is posted.
@@ -1550,6 +1550,15 @@ package Snames is
Name_Reference_Control_Type : constant Name_Id := N + $;
Name_Get_Element_Access : constant Name_Id := N + $;
+ -- Names for Ada2020 Aggregate aspect. Nmme_Aggregate is already
+ -- present for gprbuild.
+
+ Name_Empty : constant Name_Id := N + $;
+ Name_Add_Named : constant Name_Id := N + $;
+ Name_Add_Unnamed : constant Name_Id := N + $;
+ Name_New_Indexed : constant Name_Id := N + $;
+ Name_Assign_Indexed : constant Name_Id := N + $;
+
-- Ada 2005 reserved words
First_2005_Reserved_Word : constant Name_Id := N + $;