Commit 3c08de34 by Ed Schonberg Committed by Pierre-Marie de Rodat

[Ada] Prototype implementastion of Ada2020 Map-reduce construct

2019-12-16  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* scng.adb (Scan): In Ada2020, a left-bracket indicates the
	start of an homogenous aggregate.
	* par-ch4.adb (P_Reduction_Attribute_Reference): New procedure.
	(P_Aggregate): Recognize Ada2020 bracket-delimited aggregates.
	(P_Primary): Ditto.
	* par-util.adb (Comma_Present): Return false on a right bracket
	in Ada2020, indicating the end of an aggregate.
	* snames.ads-tmpl: Introduce Name_Reduce and Attribute Reduce.
	* sinfo.ads, sinfo.adb (Is_Homogeneous_Aggregate): New flag on
	aggregates, to designate an Ada2020 array or container aggregate
	that is bracket-delimited in the source.
	* sem_attr.adb (Analyze_Attribute): For attribute Reduce, verify
	that two arguments are present, and verify that the prefix is a
	stream or an object that is iterable (array or contrainer).
	(Resolve_Attribute): For attribute Reduce, resolve initial value
	with the type of the context. Type-checking of element type of
	prefix is performed after expansion.
	* exp_attr.adb (Expand_N_Attribute_Reference): For attribute
	Reduce, expand into a loop: a) If prefix is an aggregate with a
	single iterated component association, use its iterator
	specification to construct a loop, b) If prefix is a name, build
	a loop using an element iterator loop.
	* scans.ads: Add brackets tokens.

From-SVN: r279431
parent a517d6c1
2019-12-16 Ed Schonberg <schonberg@adacore.com>
* scng.adb (Scan): In Ada2020, a left-bracket indicates the
start of an homogenous aggregate.
* par-ch4.adb (P_Reduction_Attribute_Reference): New procedure.
(P_Aggregate): Recognize Ada2020 bracket-delimited aggregates.
(P_Primary): Ditto.
* par-util.adb (Comma_Present): Return false on a right bracket
in Ada2020, indicating the end of an aggregate.
* snames.ads-tmpl: Introduce Name_Reduce and Attribute Reduce.
* sinfo.ads, sinfo.adb (Is_Homogeneous_Aggregate): New flag on
aggregates, to designate an Ada2020 array or container aggregate
that is bracket-delimited in the source.
* sem_attr.adb (Analyze_Attribute): For attribute Reduce, verify
that two arguments are present, and verify that the prefix is a
stream or an object that is iterable (array or contrainer).
(Resolve_Attribute): For attribute Reduce, resolve initial value
with the type of the context. Type-checking of element type of
prefix is performed after expansion.
* exp_attr.adb (Expand_N_Attribute_Reference): For attribute
Reduce, expand into a loop: a) If prefix is an aggregate with a
single iterated component association, use its iterator
specification to construct a loop, b) If prefix is a name, build
a loop using an element iterator loop.
* scans.ads: Add brackets tokens.
2019-12-16 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/decl.c (gnat_to_gnu_entity): Adjust calls to
......
......@@ -5463,6 +5463,97 @@ package body Exp_Attr is
Apply_Universal_Integer_Attribute_Checks (N);
end if;
------------
-- Reduce --
------------
when Attribute_Reduce =>
declare
Loc : constant Source_Ptr := Sloc (N);
E1 : constant Node_Id := First (Expressions (N));
E2 : constant Node_Id := Next (E1);
Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
Typ : constant Entity_Id := Etype (N);
New_Loop : Node_Id;
-- If the prefix is an aggregwte, its unique component is sn
-- Iterated_Element, and we create a loop out of its itertor.
begin
if Nkind (Prefix (N)) = N_Aggregate then
declare
Stream : constant Node_Id :=
First (Component_Associations (Prefix (N)));
Id : constant Node_Id := Defining_Identifier (Stream);
Expr : constant Node_Id := Expression (Stream);
Ch : constant Node_Id :=
First (Discrete_Choices (Stream));
begin
New_Loop := Make_Loop_Statement (Loc,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Iterator_Specification => Empty,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => New_Copy (Id),
Discrete_Subtype_Definition =>
Relocate_Node (Ch))),
End_Label => Empty,
Statements => New_List (
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Bnn, Loc),
Expression => Make_Function_Call (Loc,
Name => New_Occurrence_Of (Entity (E1), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Bnn, Loc),
Relocate_Node (Expr))))));
end;
else
-- If the prefix is a name we construct an element iterwtor
-- over it. Its expansion will verify that it is an array
-- or a container with the proper aspects.
declare
Iter : Node_Id;
Elem : constant Entity_Id := Make_Temporary (Loc, 'E', N);
begin
Iter :=
Make_Iterator_Specification (Loc,
Defining_Identifier => Elem,
Name => Relocate_Node (Prefix (N)),
Subtype_Indication => Empty);
Set_Of_Present (Iter);
New_Loop := Make_Loop_Statement (Loc,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Iterator_Specification => Iter,
Loop_Parameter_Specification => Empty),
End_Label => Empty,
Statements => New_List (
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Bnn, Loc),
Expression => Make_Function_Call (Loc,
Name => New_Occurrence_Of (Entity (E1), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Bnn, Loc),
New_Occurrence_Of (Elem, Loc))))));
end;
end if;
Rewrite (N,
Make_Expression_With_Actions (Loc,
Actions => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Bnn,
Object_Definition =>
New_Occurrence_Of (Typ, Loc),
Expression => Relocate_Node (E2)), New_Loop),
Expression => New_Occurrence_Of (Bnn, Loc)));
Analyze_And_Resolve (N, Typ);
end;
----------
-- Read --
----------
......
......@@ -81,6 +81,8 @@ package body Ch4 is
function P_Primary return Node_Id;
function P_Relation return Node_Id;
function P_Term return Node_Id;
function P_Reduction_Attribute_Reference (S : Node_Id)
return Node_Id;
function P_Binary_Adding_Operator return Node_Kind;
function P_Logical_Operator return Node_Kind;
......@@ -1202,12 +1204,48 @@ package body Ch4 is
return Attr_Node;
end P_Range_Attribute_Reference;
-------------------------------------
-- P_Reduction_Attribute_Reference --
-------------------------------------
function P_Reduction_Attribute_Reference (S : Node_Id)
return Node_Id
is
Attr_Node : Node_Id;
Attr_Name : Name_Id;
begin
Attr_Name := Token_Name;
Scan; -- past Reduce
Attr_Node := New_Node (N_Attribute_Reference, Token_Ptr);
Set_Attribute_Name (Attr_Node, Attr_Name);
if Attr_Name /= Name_Reduce then
Error_Msg ("reduce attribute expected", Prev_Token_Ptr);
end if;
Set_Prefix (Attr_Node, S);
Set_Expressions (Attr_Node, New_List);
T_Left_Paren;
Append (P_Name, Expressions (Attr_Node));
T_Comma;
Append (P_Expression, Expressions (Attr_Node));
T_Right_Paren;
return Attr_Node;
end P_Reduction_Attribute_Reference;
---------------------------------------
-- 4.1.4 Range Attribute Designator --
---------------------------------------
-- Parsed by P_Range_Attribute_Reference (4.4)
---------------------------------------------
-- 4.1.4 (2) Reduction_Attribute_Reference --
---------------------------------------------
-- parsed by P_Reduction_Attribute_Reference
--------------------
-- 4.3 Aggregate --
--------------------
......@@ -1229,6 +1267,7 @@ package body Ch4 is
if Nkind (Aggr_Node) /= N_Aggregate
and then
Nkind (Aggr_Node) /= N_Extension_Aggregate
and then Ada_Version < Ada_2020
then
Error_Msg
("aggregate may not have single positional component", Aggr_Sloc);
......@@ -1343,7 +1382,21 @@ package body Ch4 is
begin
Lparen_Sloc := Token_Ptr;
T_Left_Paren;
if Token = Tok_Left_Bracket and then Ada_Version >= Ada_2020 then
Scan;
-- Special case for null aggregate in Ada2020.
if Token = Tok_Right_Bracket then
Scan; -- past ]
Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
Set_Expressions (Aggregate_Node, New_List);
Set_Is_Homogeneous_Aggregate (Aggregate_Node);
return Aggregate_Node;
end if;
else
T_Left_Paren;
end if;
-- Note on parentheses count. For cases like an if expression, the
-- parens here really count as real parentheses for the paren count,
......@@ -1577,6 +1630,14 @@ package body Ch4 is
Append (Expr_Node, Expr_List);
elsif Token = Tok_Right_Bracket then
if No (Expr_List) then
Expr_List := New_List;
end if;
Append (Expr_Node, Expr_List);
exit;
-- Anything else is assumed to be a named association
else
......@@ -1625,7 +1686,19 @@ package body Ch4 is
-- All component associations (positional and named) have been scanned
T_Right_Paren;
if Token = Tok_Right_Bracket and then Ada_Version >= Ada_2020 then
Set_Component_Associations (Aggregate_Node, Assoc_List);
Set_Is_Homogeneous_Aggregate (Aggregate_Node);
Scan; -- past right bracket
if Token = Tok_Apostrophe then
Scan;
if Token = Tok_Identifier then
return P_Reduction_Attribute_Reference (Aggregate_Node);
end if;
end if;
else
T_Right_Paren;
end if;
if Nkind (Aggregate_Node) /= N_Delta_Aggregate then
Set_Expressions (Aggregate_Node, Expr_List);
......@@ -2623,6 +2696,7 @@ package body Ch4 is
-- | STRING_LITERAL | AGGREGATE
-- | NAME | QUALIFIED_EXPRESSION
-- | ALLOCATOR | (EXPRESSION) | QUANTIFIED_EXPRESSION
-- | REDUCTION_ATTRIBUTE_REFERENCE
-- Error recovery: can raise Error_Resync
......@@ -2715,6 +2789,9 @@ package body Ch4 is
return Expr;
end;
when Tok_Left_Bracket =>
return P_Aggregate;
-- Allocator
when Tok_New =>
......
......@@ -276,8 +276,11 @@ package body Util is
-- If we have a right paren, then that is taken as ending the list
-- i.e. no comma is present.
-- Ditto for a right bracket in Ada2020.
elsif Token = Tok_Right_Paren then
elsif Token = Tok_Right_Paren
or else (Token = Tok_Right_Bracket and then Ada_Version >= Ada_2020)
then
return False;
-- If pragmas, then get rid of them and make a recursive call
......
......@@ -87,11 +87,15 @@ package Scans is
-- exception-name". This degrades error recovery slightly, and perhaps
-- we could do better, but not worth the effort.
-- Ada2020 introduces square brackets as delimiters for array and
-- container aggregates.
Tok_Raise, -- RAISE
Tok_Dot, -- . Namext
Tok_Apostrophe, -- ' Namext
Tok_Left_Bracket, -- [ Namest
Tok_Left_Paren, -- ( Namext, Consk
Tok_Delta, -- DELTA Atkwd, Sterm, Consk
......@@ -99,6 +103,7 @@ package Scans is
Tok_Range, -- RANGE Atkwd, Sterm, Consk
Tok_Right_Paren, -- ) Sterm
Tok_Right_Bracket, -- ] Sterm
Tok_Comma, -- , Sterm
Tok_And, -- AND Logop, Sterm
......
......@@ -182,6 +182,7 @@ package body Scng is
| Tok_Integer_Literal
| Tok_Interface
| Tok_Is
| Tok_Left_Bracket
| Tok_Left_Paren
| Tok_Less
| Tok_Less_Equal
......@@ -204,6 +205,7 @@ package body Scng is
| Tok_Rem
| Tok_Renames
| Tok_Reverse
| Tok_Right_Bracket
| Tok_Right_Paren
| Tok_Slash
| Tok_String_Literal
......@@ -324,6 +326,7 @@ package body Scng is
| Tok_In
| Tok_Integer_Literal
| Tok_Is
| Tok_Left_Bracket
| Tok_Left_Paren
| Tok_Less
| Tok_Less_Equal
......@@ -340,6 +343,7 @@ package body Scng is
| Tok_Range
| Tok_Real_Literal
| Tok_Rem
| Tok_Right_Bracket
| Tok_Right_Paren
| Tok_Slash
| Tok_String_Literal
......@@ -1697,6 +1701,11 @@ package body Scng is
if Source (Scan_Ptr + 1) = '"' then
goto Scan_Wide_Character;
elsif Ada_Version = Ada_2020 then
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Left_Bracket;
return;
else
Error_Msg_S ("illegal character, replaced by ""(""");
Scan_Ptr := Scan_Ptr + 1;
......@@ -2063,6 +2072,7 @@ package body Scng is
or else Prev_Token = Tok_Identifier
or else Prev_Token = Tok_Project
or else Prev_Token = Tok_Right_Paren
or else Prev_Token = Tok_Right_Bracket
or else Prev_Token in Token_Class_Literal
then
Token := Tok_Apostrophe;
......@@ -2172,11 +2182,18 @@ package body Scng is
return;
-- Right bracket or right brace, treated as right paren
-- but proper aggregate delimiter in Ada_2020
when ']' | '}' =>
Error_Msg_S ("illegal character, replaced by "")""");
if Ada_Version >= Ada_2020 then
Token := Tok_Right_Bracket;
else
Error_Msg_S ("illegal character, replaced by "")""");
Token := Tok_Right_Paren;
end if;
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Right_Paren;
return;
-- Slash (can be division operator or first character of not equal)
......
......@@ -25,6 +25,7 @@
with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
with Aspects; use Aspects;
with Atree; use Atree;
with Casing; use Casing;
with Checks; use Checks;
......@@ -5497,6 +5498,55 @@ package body Sem_Attr is
Check_Discrete_Type;
Set_Etype (N, Universal_Integer);
------------
-- Reduce --
------------
when Attribute_Reduce =>
Check_E2;
declare
Stream : constant Node_Id := Prefix (N);
Typ : Entity_Id;
begin
if Nkind (Stream) /= N_Aggregate then
-- Prefix is a name, as for other attributes.
-- If the object is a function we asume that it is not
-- overloaded. AI12-242 does not suggest an name resulution
-- rule for that case, but can suppose that the expected
-- type of the reduction is the expected type of the
-- component of the prefix.
Analyze_And_Resolve (Stream);
Typ := Etype (Stream);
-- Verify that prefix can be iterated upon.
if Is_Array_Type (Typ)
or else Present (Find_Aspect (Typ, Aspect_Default_Iterator))
or else Present (Find_Aspect (Typ, Aspect_Iterable))
then
null;
else
Error_Msg_NE
("cannot apply reduce to object of type$", N, Typ);
end if;
elsif Present (Expressions (Stream))
or else No (Component_Associations (Stream))
or else Nkind (First (Component_Associations (Stream))) /=
N_Iterated_Component_Association
then
Error_Msg_N
("Prefix of reduce must be an iterated component", N);
end if;
Analyze (E1);
Analyze (E2);
Set_Etype (N, Etype (E2));
end;
----------
-- Read --
----------
......@@ -8241,6 +8291,7 @@ package body Sem_Attr is
| Attribute_Implicit_Dereference
| Attribute_Iterator_Element
| Attribute_Iterable
| Attribute_Reduce
| Attribute_Variable_Indexing
=>
null;
......@@ -11651,6 +11702,70 @@ package body Sem_Attr is
return;
end Range_Attribute;
-------------
-- Reduce --
-------------
when Attribute_Reduce =>
declare
E1 : constant Node_Id := First (Expressions (N));
E2 : constant Node_Id := Next (E1);
Op : Entity_Id := Empty;
Index : Interp_Index;
It : Interp;
function Proper_Op (Op : Entity_Id) return Boolean;
---------------
-- Proper_Op --
---------------
function Proper_Op (Op : Entity_Id) return Boolean is
F1, F2 : Entity_Id;
begin
F1 := First_Formal (Op);
if No (F1) then
return False;
else
F2 := Next_Formal (F1);
if No (F2)
or else Present (Next_Formal (F2))
then
return False;
else
return
(Ekind (Op) = E_Operator
and then Scope (Op) = Standard_Standard)
or else Covers (Typ, Etype (Op));
end if;
end if;
end Proper_Op;
begin
Resolve (E2, Typ);
if Is_Overloaded (E1) then
Get_First_Interp (E1, Index, It);
while Present (It.Nam) loop
if Proper_Op (It.Nam) then
Op := It.Nam;
Set_Entity (E1, Op);
exit;
end if;
Get_Next_Interp (Index, It);
end loop;
elsif Proper_Op (Entity (E1)) then
Op := Entity (E1);
Set_Etype (N, Typ);
end if;
if No (Op) then
Error_Msg_N ("No visible function for reduction", E1);
end if;
end;
------------
-- Result --
------------
......
......@@ -2010,6 +2010,14 @@ package body Sinfo is
return Flag2 (N);
end Is_Generic_Contract_Pragma;
function Is_Homogeneous_Aggregate
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Aggregate);
return Flag14 (N);
end Is_Homogeneous_Aggregate;
function Is_Ignored
(N : Node_Id) return Boolean is
begin
......@@ -5505,6 +5513,14 @@ package body Sinfo is
Set_Flag2 (N, Val);
end Set_Is_Generic_Contract_Pragma;
procedure Set_Is_Homogeneous_Aggregate
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Aggregate);
Set_Flag14 (N, Val);
end Set_Is_Homogeneous_Aggregate;
procedure Set_Is_Ignored
(N : Node_Id; Val : Boolean := True) is
begin
......
......@@ -1837,6 +1837,11 @@ package Sinfo is
-- Refined_State
-- Test_Case
-- Is_Homogeneous_Aggregate (Flag14)
-- A flag set on an Ada2020 aggregate that uses square brackets as
-- delimiters, and thus denotes an array or container aggregate, or
-- the prefix of a reduction attribute.
-- Is_Ignored (Flag9-Sem)
-- A flag set in an N_Aspect_Specification or N_Pragma node if there was
-- a Check_Policy or Assertion_Policy (or in the case of a Debug_Pragma)
......@@ -4163,6 +4168,7 @@ package Sinfo is
-- Compile_Time_Known_Aggregate (Flag18-Sem)
-- Expansion_Delayed (Flag11-Sem)
-- Has_Self_Reference (Flag13-Sem)
-- Is_Homogeneous_Aggregate (Flag14)
-- plus fields for expression
-- Note: this structure is used for both record and array aggregates
......@@ -9855,6 +9861,9 @@ package Sinfo is
function Is_Generic_Contract_Pragma
(N : Node_Id) return Boolean; -- Flag2
function Is_Homogeneous_Aggregate
(N : Node_Id) return Boolean; -- Flag14
function Is_Ignored
(N : Node_Id) return Boolean; -- Flag9
......@@ -10967,6 +10976,9 @@ package Sinfo is
procedure Set_Is_Generic_Contract_Pragma
(N : Node_Id; Val : Boolean := True); -- Flag2
procedure Set_Is_Homogeneous_Aggregate
(N : Node_Id; Val : Boolean := True); -- Flag14
procedure Set_Is_Ignored
(N : Node_Id; Val : Boolean := True); -- Flag9
......@@ -13521,6 +13533,7 @@ package Sinfo is
pragma Inline (Is_Finalization_Wrapper);
pragma Inline (Is_Folded_In_Parser);
pragma Inline (Is_Generic_Contract_Pragma);
pragma Inline (Is_Homogeneous_Aggregate);
pragma Inline (Is_Ignored);
pragma Inline (Is_Ignored_Ghost_Pragma);
pragma Inline (Is_In_Discriminant_Check);
......@@ -13887,6 +13900,7 @@ package Sinfo is
pragma Inline (Set_Is_Finalization_Wrapper);
pragma Inline (Set_Is_Folded_In_Parser);
pragma Inline (Set_Is_Generic_Contract_Pragma);
pragma Inline (Set_Is_Homogeneous_Aggregate);
pragma Inline (Set_Is_Ignored);
pragma Inline (Set_Is_Ignored_Ghost_Pragma);
pragma Inline (Set_Is_In_Discriminant_Check);
......
......@@ -1002,6 +1002,7 @@ package Snames is
Name_Priority : constant Name_Id := N + $; -- Ada 05
Name_Range : constant Name_Id := N + $;
Name_Range_Length : constant Name_Id := N + $; -- GNAT
Name_Reduce : constant Name_Id := N + $;
Name_Ref : constant Name_Id := N + $; -- GNAT
Name_Restriction_Set : constant Name_Id := N + $; -- GNAT
Name_Result : constant Name_Id := N + $; -- GNAT
......@@ -1674,6 +1675,7 @@ package Snames is
Attribute_Priority,
Attribute_Range,
Attribute_Range_Length,
Attribute_Reduce,
Attribute_Ref,
Attribute_Restriction_Set,
Attribute_Result,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment