+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
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 --
----------
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;
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 --
--------------------
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);
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,
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
-- 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);
-- | STRING_LITERAL | AGGREGATE
-- | NAME | QUALIFIED_EXPRESSION
-- | ALLOCATOR | (EXPRESSION) | QUANTIFIED_EXPRESSION
+ -- | REDUCTION_ATTRIBUTE_REFERENCE
-- Error recovery: can raise Error_Resync
return Expr;
end;
+ when Tok_Left_Bracket =>
+ return P_Aggregate;
+
-- Allocator
when Tok_New =>
-- 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
-- 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
Tok_Range, -- RANGE Atkwd, Sterm, Consk
Tok_Right_Paren, -- ) Sterm
+ Tok_Right_Bracket, -- ] Sterm
Tok_Comma, -- , Sterm
Tok_And, -- AND Logop, Sterm
| Tok_Integer_Literal
| Tok_Interface
| Tok_Is
+ | Tok_Left_Bracket
| Tok_Left_Paren
| Tok_Less
| Tok_Less_Equal
| Tok_Rem
| Tok_Renames
| Tok_Reverse
+ | Tok_Right_Bracket
| Tok_Right_Paren
| Tok_Slash
| Tok_String_Literal
| Tok_In
| Tok_Integer_Literal
| Tok_Is
+ | Tok_Left_Bracket
| Tok_Left_Paren
| Tok_Less
| Tok_Less_Equal
| Tok_Range
| Tok_Real_Literal
| Tok_Rem
+ | Tok_Right_Bracket
| Tok_Right_Paren
| Tok_Slash
| Tok_String_Literal
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;
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;
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)
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;
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 --
----------
| Attribute_Implicit_Dereference
| Attribute_Iterator_Element
| Attribute_Iterable
+ | Attribute_Reduce
| Attribute_Variable_Indexing
=>
null;
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 --
------------
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
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
-- 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)
-- 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
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
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
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);
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);
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
Attribute_Priority,
Attribute_Range,
Attribute_Range_Length,
+ Attribute_Reduce,
Attribute_Ref,
Attribute_Restriction_Set,
Attribute_Result,
projects / gcc.git / commitdiff