procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
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
This commit is contained in:
Arnaud Charlet 2017-01-23 13:07:34 +01:00
parent f6b9f2ffc1
commit 9eb8d5b4e9
15 changed files with 484 additions and 33 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

41
gcc/ada/ChangeLog
View 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

148
gcc/ada/exp_aggr.adb
View 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 --
----------------------------------

1
gcc/ada/exp_aggr.ads
View 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;

45
gcc/ada/exp_ch11.adb
View 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);

1
gcc/ada/exp_util.adb
View 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

25
gcc/ada/par-ch4.adb
View 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);

63
gcc/ada/par-ch9.adb
View 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;

2
gcc/ada/scng.adb
View 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

3
gcc/ada/sem.adb
View 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);

154
gcc/ada/sem_aggr.adb
View 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 --
---------------------------------

3
gcc/ada/sem_aggr.ads
View 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);

3
gcc/ada/sem_res.adb
View 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);

4
gcc/ada/sinfo.adb
View 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

17
gcc/ada/sinfo.ads
View 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)

7
gcc/ada/sprint.adb
View 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));