+2017-12-15 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_prag.adb (Analyze_Initialization_Item): Remove the specialized
+ processing for a null initialization item. Such an item is always
+ illegal.
+
+2017-12-15 Bob Duff <duff@adacore.com>
+
+ * types.ads, types.h, libgnat/a-except.adb, exp_ch11.adb
+ (PE_Build_In_Place_Mismatch): New reason code for raising when the
+ BIPalloc formal parameter is incorrect. This can happen if a compiler
+ bug causes a mismatch of build-in-place between caller and callee.
+ * exp_ch6.adb (Expand_N_Extended_Return_Statement): Use
+ PE_Build_In_Place_Mismatch.
+
+2017-12-15 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch4.ads, exp_ch4.adb (Expand_N_Reduction_Expression): New
+ procedure.
+ * exp_util.adb (Insert_Actions): Handle N_Reduction_Expression.
+ * expander.adb (Expand): Call Expand_N_Reduction_Expression
+ * par-ch4.adb (P_Reduction_Expression): New procedure.
+ (P_Iterated_Component_Assoc_Or_Reduction): New precedure, extension of
+ P_Iterated_Component_Association.
+ (OK_Reduction_Expression_Parameter): New procedure.
+ (P_Aggregate_Or_Paren_Expr): Improve error message for malformed delta
+ aggregate.
+ * sem.adb (Analyze): Call Analyze_Reduction_Expression and
+ Analyze_Reduction_Expression_Parameter
+ * sinfo.ads, sinfo.adb: New node kinds N_Reduction_Expression and
+ N_Reduction_Expression_Parameter.
+ * sem_ch4.ads, sem_ch4.adb (Analyze_Reduction_Expression,
+ Analyze_Reduction_Expression_Parameter): New procedures.
+ * sem_res.adb (Resolve): Handle Reduction_Expression and
+ Reduction_Expression_Parameter
+ * sem_spark.adb: Dummy entries for Reduction_Expression and
+ Reduction_Expression_Parameter
+ * sprint.adb (Sprint_Node_Actual): Print Reduction_Expression,
+ Reduction_Expression_Parameter
+
2017-12-15 Bob Duff <duff@adacore.com>
* einfo.ads: Comment fix.
then
return False;
- -- For an assignment statement we require static matching
- -- of bounds. Ditto for an allocator whose qualified
- -- expression is a constrained type. If the expression in
- -- the allocator is an unconstrained array, we accept an
- -- upper bound that is not static, to allow for non-static
- -- expressions of the base type. Clearly there are further
- -- possibilities (with diminishing returns) for safely
- -- building arrays in place here.
+ -- For an assignment statement we require static matching of
+ -- bounds. Ditto for an allocator whose qualified expression
+ -- is a constrained type. If the expression in the allocator
+ -- is an unconstrained array, we accept an upper bound that
+ -- is not static, to allow for non-static expressions of the
+ -- base type. Clearly there are further possibilities (with
+ -- diminishing returns) for safely building arrays in place
+ -- here.
elsif Nkind (Parent (N)) = N_Assignment_Statement
or else Is_Constrained (Etype (Parent (N)))
then
if not Compile_Time_Known_Value (Aggr_Hi)
- or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
+ or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
then
return False;
end if;
Add_Str_To_Name_Buffer ("PE_All_Guards_Closed");
when PE_Bad_Predicated_Generic_Type =>
Add_Str_To_Name_Buffer ("PE_Bad_Predicated_Generic_Type");
+ when PE_Build_In_Place_Mismatch =>
+ Add_Str_To_Name_Buffer ("PE_Build_In_Place_Mismatch");
when PE_Current_Task_In_Entry_Body =>
Add_Str_To_Name_Buffer ("PE_Current_Task_In_Entry_Body");
when PE_Duplicated_Entry_Address =>
Analyze_And_Resolve (N, Standard_Boolean);
end Expand_N_Quantified_Expression;
+ -----------------------------------
+ -- Expand_N_Reduction_Expression --
+ -----------------------------------
+
+ procedure Expand_N_Reduction_Expression (N : Node_Id) is
+ Actions : constant List_Id := New_List;
+ Expr : constant Node_Id := Expression (N);
+ Iter_Spec : constant Node_Id := Iterator_Specification (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N);
+ Typ : constant Entity_Id := Etype (N);
+
+ Actual : Node_Id;
+ New_Call : Node_Id;
+ Reduction_Par : Node_Id;
+ Result : Entity_Id;
+ Scheme : Node_Id;
+
+ begin
+ Result := Make_Temporary (Loc, 'R', N);
+ New_Call := New_Copy_Tree (Expr);
+
+ if Nkind (New_Call) = N_Function_Call then
+ Actual := First (Parameter_Associations (New_Call));
+
+ if Nkind (Actual) /= N_Reduction_Expression_Parameter then
+ Actual := Next_Actual (Actual);
+ end if;
+
+ elsif Nkind (New_Call) in N_Binary_Op then
+ Actual := Left_Opnd (New_Call);
+
+ if Nkind (Actual) /= N_Reduction_Expression_Parameter then
+ Actual := Right_Opnd (New_Call);
+ end if;
+ end if;
+
+ Reduction_Par := Expression (Actual);
+
+ Append_To (Actions,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Result,
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => New_Copy_Tree (Reduction_Par)));
+
+ if Present (Iter_Spec) then
+ Scheme :=
+ Make_Iteration_Scheme (Loc,
+ Iterator_Specification => Iter_Spec);
+ else
+ Scheme :=
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification => Loop_Spec);
+ end if;
+
+ Replace (Actual, New_Occurrence_Of (Result, Loc));
+
+ Append_To (Actions,
+ Make_Loop_Statement (Loc,
+ Iteration_Scheme => Scheme,
+ Statements => New_List (Make_Assignment_Statement (Loc,
+ New_Occurrence_Of (Result, Loc), New_Call)),
+ End_Label => Empty));
+
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Expression => New_Occurrence_Of (Result, Loc),
+ Actions => Actions));
+ Analyze_And_Resolve (N, Typ);
+ end Expand_N_Reduction_Expression;
+
---------------------------------
-- Expand_N_Selected_Component --
---------------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
procedure Expand_N_Or_Else (N : Node_Id);
procedure Expand_N_Qualified_Expression (N : Node_Id);
procedure Expand_N_Quantified_Expression (N : Node_Id);
+ procedure Expand_N_Reduction_Expression (N : Node_Id);
procedure Expand_N_Selected_Component (N : Node_Id);
procedure Expand_N_Slice (N : Node_Id);
procedure Expand_N_Type_Conversion (N : Node_Id);
Alloc_Expr => Pool_Allocator)))),
-- Raise Program_Error if it's none of the above;
- -- this is a compiler bug. ???PE_All_Guards_Closed
- -- is bogus; we should have a new code.
+ -- this is a compiler bug.
Else_Statements => New_List (
Make_Raise_Program_Error (Loc,
- Reason => PE_All_Guards_Closed)));
+ Reason => PE_Build_In_Place_Mismatch)));
-- If a separate initialization assignment was created
-- earlier, append that following the assignment of the
| N_Real_Literal
| N_Real_Range_Specification
| N_Record_Definition
+ | N_Reduction_Expression
+ | N_Reduction_Expression_Parameter
| N_Reference
| N_SCIL_Dispatch_Table_Tag_Init
| N_SCIL_Dispatching_Call
when N_Record_Representation_Clause =>
Expand_N_Record_Representation_Clause (N);
+ when N_Reduction_Expression =>
+ Expand_N_Reduction_Expression (N);
+
when N_Requeue_Statement =>
Expand_N_Requeue_Statement (N);
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Bad_Predicated_Generic_Type
(File : System.Address; Line : Integer);
+ procedure Rcheck_PE_Build_In_Place_Mismatch
+ (File : System.Address; Line : Integer);
procedure Rcheck_PE_Current_Task_In_Entry_Body
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Duplicated_Entry_Address
"__gnat_rcheck_PE_All_Guards_Closed");
pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type,
"__gnat_rcheck_PE_Bad_Predicated_Generic_Type");
+ pragma Export (C, Rcheck_PE_Build_In_Place_Mismatch,
+ "__gnat_rcheck_PE_Build_In_Place_Mismatch");
pragma Export (C, Rcheck_PE_Current_Task_In_Entry_Body,
"__gnat_rcheck_PE_Current_Task_In_Entry_Body");
pragma Export (C, Rcheck_PE_Duplicated_Entry_Address,
pragma No_Return (Rcheck_PE_Aliased_Parameters);
pragma No_Return (Rcheck_PE_All_Guards_Closed);
pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type);
+ pragma No_Return (Rcheck_PE_Build_In_Place_Mismatch);
pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body);
pragma No_Return (Rcheck_PE_Duplicated_Entry_Address);
pragma No_Return (Rcheck_PE_Explicit_Raise);
Rmsg_34 : constant String := "infinite recursion" & NUL;
Rmsg_35 : constant String := "object too large" & NUL;
Rmsg_36 : constant String := "stream operation not allowed" & NUL;
+ Rmsg_37 : constant String := "build-in-place mismatch" & NUL;
-----------------------
-- Polling Interface --
Raise_Program_Error_Msg (File, Line, Rmsg_19'Address);
end Rcheck_PE_Bad_Predicated_Generic_Type;
+ procedure Rcheck_PE_Build_In_Place_Mismatch
+ (File : System.Address; Line : Integer)
+ is
+ begin
+ Raise_Program_Error_Msg (File, Line, Rmsg_37'Address);
+ end Rcheck_PE_Build_In_Place_Mismatch;
+
procedure Rcheck_PE_Current_Task_In_Entry_Body
(File : System.Address; Line : Integer)
is
function P_Aggregate_Or_Paren_Expr return Node_Id;
function P_Allocator return Node_Id;
function P_Case_Expression_Alternative return Node_Id;
- function P_Iterated_Component_Association return Node_Id;
+ function P_Iterated_Component_Assoc_Or_Reduction return Node_Id;
+ function P_Reduction_Expression (Lparen : Boolean) return Node_Id;
function P_Record_Or_Array_Component_Association return Node_Id;
function P_Factor return Node_Id;
function P_Primary return Node_Id;
-- case of a name which can be extended in the normal manner.
-- This case is handled by LP_State_Name or LP_State_Expr.
+ -- (Ada2020) : the expression can be a reduction_expression_
+ -- psarameter, i.e. a box or < Simple_Expression >
+
-- Note: if and case expressions (without an extra level of
-- parentheses) are permitted in this context).
-- If there is at least one occurrence of identifier => (but
-- none of the other cases apply), then we have a call.
+ -- < simple_expression >
+ -- In Ada 2020 this is a reduction expression parameter that
+ -- specifies the initial value of the reduction.
+
-- Test for Id => case
if Token = Tok_Identifier then
end if;
end if;
- -- Here we have an expression after all
+ -- Here we have an expression after all, which may be a reduction
+ -- expression with a binary operator
- Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
+ if Token = Tok_Less then
+ Scan; -- past <
+
+ Expr_Node :=
+ New_Node (N_Reduction_Expression_Parameter, Token_Ptr);
+ Set_Expression (Expr_Node, P_Simple_Expression);
+
+ if Token = Tok_Greater then
+ Scan;
+ else
+ Error_Msg_N
+ ("malformed reduction expression parameter", Expr_Node);
+ raise Error_Resync;
+ end if;
+
+ else
+ Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
+ end if;
-- Check cases of discrete range for a slice
elsif Token = Tok_For then
Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
- Expr_Node := P_Iterated_Component_Association;
- goto Aggregate;
+ Expr_Node := P_Iterated_Component_Assoc_Or_Reduction;
+
+ if Nkind (Expr_Node) = N_Reduction_Expression then
+ return Expr_Node;
+ else
+ goto Aggregate;
+ end if;
end if;
-- Scan expression, handling box appearing as positional argument
Aggregate_Node := New_Node (N_Delta_Aggregate, Lparen_Sloc);
Set_Expression (Aggregate_Node, Expr_Node);
Expr_Node := Empty;
+
+ if Nkind (Aggregate_Node) = N_Delta_Aggregate
+ and then (Token = Tok_Arrow or else Token = Tok_Others)
+ then
+ Error_Msg_SC
+ ("expect record component association in delta aggregate");
+ raise Error_Resync;
+ end if;
+
goto Aggregate;
else
Expr_Node := Empty;
elsif Token = Tok_For then
- Expr_Node := P_Iterated_Component_Association;
+ Expr_Node := P_Iterated_Component_Assoc_Or_Reduction;
else
Save_Scan_State (Scan_State); -- at start of expression
begin
if Token = Tok_For then
- return P_Iterated_Component_Association;
+ return P_Iterated_Component_Assoc_Or_Reduction;
end if;
Assoc_Node := New_Node (N_Component_Association, Token_Ptr);
end if;
else
Restore_Scan_State (Scan_State); -- To FOR
- Node1 := P_Iterated_Component_Association;
+ Node1 := P_Iterated_Component_Assoc_Or_Reduction;
end if;
return Node1;
Node1 := P_Name;
return Node1;
+ -- Ada2020: reduction expression parameter
+
+ when Tok_Less =>
+ Scan; -- past <
+
+ Node1 :=
+ New_Node (N_Reduction_Expression_Parameter, Token_Ptr);
+ Set_Expression (Node1, P_Simple_Expression);
+
+ Scan; -- past >
+ return Node1;
+
-- Anything else is illegal as the first token of a primary, but
-- we test for some common errors, to improve error messages.
return Case_Alt_Node;
end P_Case_Expression_Alternative;
- --------------------------------------
- -- P_Iterated_Component_Association --
- --------------------------------------
+ ---------------------------------------------
+ -- P_Iterated_Component_Assoc_Or_Reduction --
+ ---------------------------------------------
-- ITERATED_COMPONENT_ASSOCIATION ::=
-- for DEFINING_IDENTIFIER in DISCRETE_CHOICE_LIST => EXPRESSION
- function P_Iterated_Component_Association return Node_Id is
+ function P_Iterated_Component_Assoc_Or_Reduction return Node_Id is
+ Expr : Node_Id;
+
+ function OK_Reduction_Expression_Parameter (L : List_Id) return Boolean;
+ -- Check that if a reduction_expression_Parameter appears, it is a
+ -- single one.
+
+ ---------------------------------------
+ -- OK_Reduction_Expression_Parameter --
+ ---------------------------------------
+
+ function OK_Reduction_Expression_Parameter
+ (L : List_Id) return Boolean
+ is
+ Actual : Node_Id;
+ Num : Int := 0;
+ Seen : Boolean;
+
+ begin
+ Seen := False;
+ Actual := First (L);
+ while Present (Actual) loop
+ if Nkind (Actual) = N_Reduction_Expression_Parameter then
+ if Seen then
+ Error_Msg_N ("only one reduction parameter allowed", Expr);
+ else
+ Seen := True;
+ end if;
+ end if;
+
+ Num := Num + 1;
+ Next (Actual);
+ end loop;
+
+ if Seen and then Num > 2 then
+ Error_Msg_N ("too many parameters in reduction function", Expr);
+ end if;
+
+ return Seen;
+ end OK_Reduction_Expression_Parameter;
+
+ -- Local variables
+
+ Lparen : constant Boolean := Prev_Token = Tok_Left_Paren;
Assoc_Node : Node_Id;
+ State : Saved_Scan_State;
+
+ -- Start of processing for P_Iterated_Component_Assoc_Or_Reduction
begin
Scan; -- past FOR
Assoc_Node :=
New_Node (N_Iterated_Component_Association, Prev_Token_Ptr);
+
+ Save_Scan_State (State);
Set_Defining_Identifier (Assoc_Node, P_Defining_Identifier);
- T_In;
- Set_Discrete_Choices (Assoc_Node, P_Discrete_Choice_List);
- TF_Arrow;
- Set_Expression (Assoc_Node, P_Expression);
+
+ if Token = Tok_In then
+ Scan; -- past in
+
+ Set_Discrete_Choices (Assoc_Node, P_Discrete_Choice_List);
+ TF_Arrow;
+
+ if Token = Tok_Less then
+ Restore_Scan_State (State);
+ return P_Reduction_Expression (Lparen);
+ else
+ Expr := P_Expression;
+ end if;
+
+ if Nkind (Expr) = N_Function_Call
+ and then OK_Reduction_Expression_Parameter
+ (Parameter_Associations (Expr))
+ then
+ Restore_Scan_State (State);
+ return P_Reduction_Expression (Lparen);
+
+ elsif Nkind (Expr) in N_Op
+ and then
+ Nkind (Right_Opnd (Expr)) = N_Reduction_Expression_Parameter
+ then
+ return P_Reduction_Expression (Lparen);
+
+ elsif Nkind (Expr) in N_Binary_Op
+ and then
+ Nkind (Left_Opnd (Expr)) = N_Reduction_Expression_Parameter
+ then
+ return P_Reduction_Expression (Lparen);
+
+ elsif Nkind (Expr) = N_Indexed_Component
+ and then OK_Reduction_Expression_Parameter (Expressions (Expr))
+ then
+ Restore_Scan_State (State);
+ return P_Reduction_Expression (Lparen);
+ end if;
+
+ Set_Expression (Assoc_Node, Expr);
+ if Ada_Version < Ada_2020 then
+ Error_Msg_SC ("iterated component is an Ada 2020 extension");
+ Error_Msg_SC ("\compile with -gnatX");
+ end if;
+
+ return Assoc_Node;
+
+ elsif Token = Tok_Of then
+ Restore_Scan_State (State);
+ return P_Reduction_Expression (Lparen);
+
+ else
+ raise Error_Resync;
+ end if;
+ end P_Iterated_Component_Assoc_Or_Reduction;
+
+ ----------------------------
+ -- P_Reduction_Expression --
+ ----------------------------
+
+ function P_Reduction_Expression (Lparen : Boolean) return Node_Id is
+ Expr : Node_Id;
+ I_Spec : Node_Id;
+ Left_Opnd : Node_Id;
+ Reduction_Node : Node_Id;
+
+ begin
+ Reduction_Node := New_Node (N_Reduction_Expression, Prev_Token_Ptr);
+
+ I_Spec := P_Loop_Parameter_Specification;
+
+ if Nkind (I_Spec) = N_Loop_Parameter_Specification then
+ Set_Loop_Parameter_Specification (Reduction_Node, I_Spec);
+ else
+ Set_Iterator_Specification (Reduction_Node, I_Spec);
+ end if;
+
+ T_Arrow;
+ if Token = Tok_Less and then False then
+ Scan; -- past <
+
+ Left_Opnd := New_Node (N_Reduction_Expression_Parameter, Token_Ptr);
+ Set_Expression (Left_Opnd, P_Simple_Expression);
+
+ Scan; -- past >
+
+ if Token = Tok_Plus then
+ Set_Expression
+ (Reduction_Node, New_Op_Node (N_Op_Add, Token_Ptr));
+ else
+ Set_Expression
+ (Reduction_Node, New_Op_Node (N_Op_Concat, Token_Ptr));
+ end if;
+
+ Scan; -- past operstor
+ Set_Left_Opnd (Expression (Reduction_Node), Left_Opnd);
+ Set_Right_Opnd (Expression (Reduction_Node), P_Primary);
+
+ else
+ Expr := P_Expression;
+ Set_Expression (Reduction_Node, Expr);
+
+ -- if Nkind (Expr) = N_Indexed_Component
+ -- and then List_Length (Expressions (Expr)) /= 2
+ -- then
+ -- Error_Msg_N
+ -- ("combiner function call must have two arguments", Expr);
+ -- end if;
+ end if;
if Ada_Version < Ada_2020 then
- Error_Msg_SC ("iterated component is an Ada 2020 extension");
+ Error_Msg_SC ("Reduction_Expression is an Ada 2020 extension");
Error_Msg_SC ("\compile with -gnatX");
end if;
- return Assoc_Node;
- end P_Iterated_Component_Association;
+ if not (Lparen and then Token = Tok_Right_Paren) then
+ Error_Msg
+ ("reduction expression must be parenthesized",
+ Sloc (Reduction_Node));
+ else
+ Scan; -- past ???
+ end if;
+
+ return Reduction_Node;
+ end P_Reduction_Expression;
---------------------
-- P_If_Expression --
-- an aggregate.
Restore_Scan_State (Scan_State);
- Result := P_Iterated_Component_Association;
+ Result := P_Iterated_Component_Assoc_Or_Reduction;
end if;
-- No other possibility should exist (caller was supposed to check)
when N_Record_Representation_Clause =>
Analyze_Record_Representation_Clause (N);
+ when N_Reduction_Expression =>
+ Analyze_Reduction_Expression (N);
+
+ when N_Reduction_Expression_Parameter =>
+ Analyze_Reduction_Expression_Parameter (N);
+
when N_Reference =>
Analyze_Reference (N);
Check_Function_Writable_Actuals (N);
end Analyze_Range;
+ -----------------------------------
+ -- Analyze_Reduction_Expression --
+ -----------------------------------
+
+ procedure Analyze_Reduction_Expression (N : Node_Id) is
+ Expr : constant Node_Id := Expression (N);
+ QE_Scop : Entity_Id;
+
+ begin
+ QE_Scop := New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L');
+ Set_Etype (QE_Scop, Standard_Void_Type);
+ Set_Scope (QE_Scop, Current_Scope);
+ Set_Parent (QE_Scop, N);
+
+ Push_Scope (QE_Scop);
+
+ -- All constituents are preanalyzed and resolved to avoid untimely
+ -- generation of various temporaries and types. Full analysis and
+ -- expansion is carried out when the reduction expression is
+ -- transformed into an expression with actions.
+
+ if Present (Iterator_Specification (N)) then
+ Preanalyze (Iterator_Specification (N));
+
+ else pragma Assert (Present (Loop_Parameter_Specification (N)));
+ declare
+ Loop_Par : constant Node_Id := Loop_Parameter_Specification (N);
+
+ begin
+ Preanalyze (Loop_Par);
+
+ if Nkind (Discrete_Subtype_Definition (Loop_Par)) = N_Function_Call
+ and then Parent (Loop_Par) /= N
+ then
+ -- The parser cannot distinguish between a loop specification
+ -- and an iterator specification. If after pre-analysis the
+ -- proper form has been recognized, rewrite the expression to
+ -- reflect the right kind. This is needed for proper ASIS
+ -- navigation. If expansion is enabled, the transformation is
+ -- performed when the expression is rewritten as a loop.
+
+ Set_Iterator_Specification (N,
+ New_Copy_Tree (Iterator_Specification (Parent (Loop_Par))));
+
+ Set_Defining_Identifier (Iterator_Specification (N),
+ Relocate_Node (Defining_Identifier (Loop_Par)));
+ Set_Name (Iterator_Specification (N),
+ Relocate_Node (Discrete_Subtype_Definition (Loop_Par)));
+ Set_Comes_From_Source (Iterator_Specification (N),
+ Comes_From_Source (Loop_Parameter_Specification (N)));
+ Set_Loop_Parameter_Specification (N, Empty);
+ end if;
+ end;
+ end if;
+
+ Preanalyze (Expr);
+ End_Scope;
+
+ Set_Etype (N, Etype (Expr));
+ end Analyze_Reduction_Expression;
+
+ --------------------------------------------
+ -- Analyze_Reduction_Expression_Parameter --
+ --------------------------------------------
+
+ procedure Analyze_Reduction_Expression_Parameter (N : Node_Id) is
+ Expr : constant Node_Id := Expression (N);
+
+ begin
+ Analyze (Expr);
+ Set_Etype (N, Etype (Expr));
+ end Analyze_Reduction_Expression_Parameter;
+
-----------------------
-- Analyze_Reference --
-----------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
procedure Analyze_Qualified_Expression (N : Node_Id);
procedure Analyze_Quantified_Expression (N : Node_Id);
procedure Analyze_Range (N : Node_Id);
+ procedure Analyze_Reduction_Expression (N : Node_Id);
+ procedure Analyze_Reduction_Expression_Parameter (N : Node_Id);
procedure Analyze_Reference (N : Node_Id);
procedure Analyze_Selected_Component (N : Node_Id);
procedure Analyze_Short_Circuit (N : Node_Id);
procedure Check_And_Freeze_Type (Typ : Entity_Id) is
begin
- -- Skip Itypes created by the preanalysis, and itypes
- -- whose scope is another type (i.e. component subtypes
- -- that depend on a discriminant),
+ -- Skip Itypes created by the preanalysis, and itypes whose
+ -- scope is another type (i.e. component subtypes that depend
+ -- on a discriminant),
if Is_Itype (Typ)
and then (Scope_Within_Or_Same (Scope (Typ), Def_Id)
- or else Is_Type (Scope (Typ)))
+ or else Is_Type (Scope (Typ)))
then
return;
end if;
------------------------------
procedure Check_Delayed_Subprogram (Designator : Entity_Id) is
- F : Entity_Id;
-
procedure Possible_Freeze (T : Entity_Id);
- -- T is the type of either a formal parameter or of the return type.
- -- If T is not yet frozen and needs a delayed freeze, then the
- -- subprogram itself must be delayed.
+ -- T is the type of either a formal parameter or of the return type. If
+ -- T is not yet frozen and needs a delayed freeze, then the subprogram
+ -- itself must be delayed.
---------------------
-- Possible_Freeze --
procedure Possible_Freeze (T : Entity_Id) is
Scop : constant Entity_Id := Scope (Designator);
+
begin
- -- If the subprogram appears within a package instance (which
- -- may be the wrapper package of a subprogram instance) the
- -- freeze node for that package will freeze the subprogram at
- -- the proper place, so do not emit a freeze node for the
- -- subprogram, given that it may appear in the wrong scope.
+ -- If the subprogram appears within a package instance (which may be
+ -- the wrapper package of a subprogram instance) the freeze node for
+ -- that package will freeze the subprogram at the proper place, so
+ -- do not emit a freeze node for the subprogram, given that it may
+ -- appear in the wrong scope.
if Ekind (Scop) = E_Package
and then not Comes_From_Source (Scop)
then
Set_Has_Delayed_Freeze (Designator);
end if;
-
end Possible_Freeze;
+ -- Local variables
+
+ F : Entity_Id;
+
-- Start of processing for Check_Delayed_Subprogram
begin
Possible_Freeze (Etype (Designator));
Possible_Freeze (Base_Type (Etype (Designator))); -- needed ???
- -- Need delayed freeze if any of the formal types themselves need
- -- a delayed freeze and are not yet frozen.
+ -- Need delayed freeze if any of the formal types themselves need a
+ -- delayed freeze and are not yet frozen.
F := First_Formal (Designator);
while Present (F) loop
Next_Formal (F);
end loop;
- -- Mark functions that return by reference. Note that it cannot be
- -- done for delayed_freeze subprograms because the underlying
- -- returned type may not be known yet (for private types)
+ -- Mark functions that return by reference. Note that it cannot be done
+ -- for delayed_freeze subprograms because the underlying returned type
+ -- may not be known yet (for private types).
if not Has_Delayed_Freeze (Designator) and then Expander_Active then
declare
Typ : constant Entity_Id := Etype (Designator);
Utyp : constant Entity_Id := Underlying_Type (Typ);
+
begin
if Is_Limited_View (Typ) then
Set_Returns_By_Ref (Designator);
+
elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
Set_Returns_By_Ref (Designator);
end if;
-- A list of all initialization items processed so far. This list is
-- used to detect duplicate items.
- Non_Null_Seen : Boolean := False;
- Null_Seen : Boolean := False;
- -- Flags used to check the legality of a null initialization list
-
States_And_Objs : Elist_Id := No_Elist;
-- A list of all abstract states and objects declared in the visible
-- declarations of the related package. This list is used to detect the
Item_Id : Entity_Id;
begin
- -- Null initialization list
-
- if Nkind (Item) = N_Null then
- if Null_Seen then
- SPARK_Msg_N ("multiple null initializations not allowed", Item);
-
- elsif Non_Null_Seen then
- SPARK_Msg_N
- ("cannot mix null and non-null initialization items", Item);
- else
- Null_Seen := True;
- end if;
-
- -- Initialization item
-
- else
- Non_Null_Seen := True;
-
- if Null_Seen then
- SPARK_Msg_N
- ("cannot mix null and non-null initialization items", Item);
- end if;
-
- Analyze (Item);
- Resolve_State (Item);
+ Analyze (Item);
+ Resolve_State (Item);
- if Is_Entity_Name (Item) then
- Item_Id := Entity_Of (Item);
-
- if Present (Item_Id)
- and then Ekind_In (Item_Id, E_Abstract_State,
- E_Constant,
- E_Variable)
- then
- -- When the initialization item is undefined, it appears as
- -- Any_Id. Do not continue with the analysis of the item.
+ if Is_Entity_Name (Item) then
+ Item_Id := Entity_Of (Item);
- if Item_Id = Any_Id then
- null;
+ if Present (Item_Id)
+ and then Ekind_In (Item_Id, E_Abstract_State,
+ E_Constant,
+ E_Variable)
+ then
+ -- When the initialization item is undefined, it appears as
+ -- Any_Id. Do not continue with the analysis of the item.
- -- The state or variable must be declared in the visible
- -- declarations of the package (SPARK RM 7.1.5(7)).
+ if Item_Id = Any_Id then
+ null;
- elsif not Contains (States_And_Objs, Item_Id) then
- Error_Msg_Name_1 := Chars (Pack_Id);
- SPARK_Msg_NE
- ("initialization item & must appear in the visible "
- & "declarations of package %", Item, Item_Id);
+ -- The state or variable must be declared in the visible
+ -- declarations of the package (SPARK RM 7.1.5(7)).
- -- Detect a duplicate use of the same initialization item
- -- (SPARK RM 7.1.5(5)).
+ elsif not Contains (States_And_Objs, Item_Id) then
+ Error_Msg_Name_1 := Chars (Pack_Id);
+ SPARK_Msg_NE
+ ("initialization item & must appear in the visible "
+ & "declarations of package %", Item, Item_Id);
- elsif Contains (Items_Seen, Item_Id) then
- SPARK_Msg_N ("duplicate initialization item", Item);
+ -- Detect a duplicate use of the same initialization item
+ -- (SPARK RM 7.1.5(5)).
- -- The item is legal, add it to the list of processed states
- -- and variables.
+ elsif Contains (Items_Seen, Item_Id) then
+ SPARK_Msg_N ("duplicate initialization item", Item);
- else
- Append_New_Elmt (Item_Id, Items_Seen);
+ -- The item is legal, add it to the list of processed states
+ -- and variables.
- if Ekind (Item_Id) = E_Abstract_State then
- Append_New_Elmt (Item_Id, States_Seen);
- end if;
+ else
+ Append_New_Elmt (Item_Id, Items_Seen);
- if Present (Encapsulating_State (Item_Id)) then
- Append_New_Elmt (Item_Id, Constits_Seen);
- end if;
+ if Ekind (Item_Id) = E_Abstract_State then
+ Append_New_Elmt (Item_Id, States_Seen);
end if;
- -- The item references something that is not a state or object
- -- (SPARK RM 7.1.5(3)).
-
- else
- SPARK_Msg_N
- ("initialization item must denote object or state", Item);
+ if Present (Encapsulating_State (Item_Id)) then
+ Append_New_Elmt (Item_Id, Constits_Seen);
+ end if;
end if;
- -- Some form of illegal construct masquerading as a name
- -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
+ -- The item references something that is not a state or object
+ -- (SPARK RM 7.1.5(3)).
else
- Error_Msg_N
+ SPARK_Msg_N
("initialization item must denote object or state", Item);
end if;
+
+ -- Some form of illegal construct masquerading as a name
+ -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
+
+ else
+ Error_Msg_N
+ ("initialization item must denote object or state", Item);
end if;
end Analyze_Initialization_Item;
when N_Real_Literal =>
Resolve_Real_Literal (N, Ctx_Type);
+ when N_Reduction_Expression =>
+ null;
+ -- Resolve (Expression (N), Ctx_Type);
+
+ when N_Reduction_Expression_Parameter =>
+ null;
+
when N_Reference =>
Resolve_Reference (N, Ctx_Type);
Free_Env (Saved_Env);
end;
+ when N_Reduction_Expression =>
+ null;
+
+ when N_Reduction_Expression_Parameter =>
+ null;
+
-- Analyze the list of associations in the aggregate
when N_Aggregate =>
or else NT (N).Nkind = N_Qualified_Expression
or else NT (N).Nkind = N_Raise_Expression
or else NT (N).Nkind = N_Raise_Statement
+ or else NT (N).Nkind = N_Reduction_Expression
+ or else NT (N).Nkind = N_Reduction_Expression_Parameter
or else NT (N).Nkind = N_Simple_Return_Statement
or else NT (N).Nkind = N_Type_Conversion
or else NT (N).Nkind = N_Unchecked_Expression
begin
pragma Assert (False
or else NT (N).Nkind = N_Iteration_Scheme
- or else NT (N).Nkind = N_Quantified_Expression);
+ or else NT (N).Nkind = N_Quantified_Expression
+ or else NT (N).Nkind = N_Reduction_Expression);
return Node2 (N);
end Iterator_Specification;
begin
pragma Assert (False
or else NT (N).Nkind = N_Iteration_Scheme
- or else NT (N).Nkind = N_Quantified_Expression);
+ or else NT (N).Nkind = N_Quantified_Expression
+ or else NT (N).Nkind = N_Reduction_Expression);
return Node4 (N);
end Loop_Parameter_Specification;
or else NT (N).Nkind = N_Qualified_Expression
or else NT (N).Nkind = N_Raise_Expression
or else NT (N).Nkind = N_Raise_Statement
+ or else NT (N).Nkind = N_Reduction_Expression
+ or else NT (N).Nkind = N_Reduction_Expression_Parameter
or else NT (N).Nkind = N_Simple_Return_Statement
or else NT (N).Nkind = N_Type_Conversion
or else NT (N).Nkind = N_Unchecked_Expression
begin
pragma Assert (False
or else NT (N).Nkind = N_Iteration_Scheme
- or else NT (N).Nkind = N_Quantified_Expression);
+ or else NT (N).Nkind = N_Quantified_Expression
+ or else NT (N).Nkind = N_Reduction_Expression);
Set_Node2_With_Parent (N, Val);
end Set_Iterator_Specification;
begin
pragma Assert (False
or else NT (N).Nkind = N_Iteration_Scheme
- or else NT (N).Nkind = N_Quantified_Expression);
+ or else NT (N).Nkind = N_Quantified_Expression
+ or else NT (N).Nkind = N_Reduction_Expression);
Set_Node4_With_Parent (N, Val);
end Set_Loop_Parameter_Specification;
-- since the expander converts case expressions into case statements.
---------------------------------
- -- 4.5.9 Quantified Expression --
+ -- 4.5.8 Quantified Expression --
---------------------------------
-- QUANTIFIED_EXPRESSION ::=
-- Condition (Node1)
-- All_Present (Flag15)
+ --------------------------------
+ -- 4.5.9 Reduction Expression --
+ --------------------------------
+
+ -- REDUCTION_EXPRESSION ::=
+ -- for LOOP_PARAMETER_SPECIFICATION => COMBINER_FUNCTION_CALL
+ -- for ITERATOR_SPECIFIATION => COMBINER_FUNCTION_CALL
+
+ -- At most one of (Iterator_Specification, Loop_Parameter_Specification)
+ -- is present at a time, in which case the other one is empty.
+
+ -- N_Reduction_Expression
+ -- Sloc points to FOR
+ -- Iterator_Specification (Node2)
+ -- Expression (Node3)
+ -- Loop_Parameter_Specification (Node4)
+ -- plus fields for expression
+
+ -- COMBINER_FUNCTION_CALL => FUNCTION_CALL
+
+ -- A Combiner_Function_Call is either a function call (including an
+ -- operator) with one reduction expression parameter, appearing either
+ -- as a left operand or as the first actual in the parameter list. In
+ -- a reduction expression this is represented as an expression.
+
--------------------------
-- 4.6 Type Conversion --
--------------------------
-- 6.4 Actual Parameter --
---------------------------
- -- EXPLICIT_ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME
+ -- EXPLICIT_ACTUAL_PARAMETER ::=
+ -- EXPRESSION | variable_NAME | REDUCTION_EXPRESSION_PARAMETER
+
+ ------------------------------------------
+ -- 6.4.6 Reduction_Expression_Parameter --
+ ------------------------------------------
+
+ -- REDUCTION_EXPRESSION_PARAMETER ::= <> | < EXPRESSION >
+
+ -- N_Reduction_Expression_Parameter
+ -- Expression (Node3) (Set to Empty if no expression present)
+ -- plus fields for expression
---------------------------
-- 6.5 Return Statement --
N_Null,
N_Qualified_Expression,
N_Quantified_Expression,
+ N_Reduction_Expression,
+ N_Reduction_Expression_Parameter,
N_Aggregate,
N_Allocator,
N_Case_Expression,
4 => True, -- Loop_Parameter_Specification (Node4)
5 => False), -- Etype (Node5-Sem)
+ N_Reduction_Expression =>
+ (1 => False, -- unused
+ 2 => True, -- Iterator_Specification (Node2)
+ 3 => True, -- Expression (Node3)
+ 4 => True, -- Loop_Parameter_Specification (Node4)
+ 5 => False), -- Etype (Node5-Sem)
+
+ N_Reduction_Expression_Parameter =>
+ (1 => False, -- unused
+ 2 => False, -- unused
+ 3 => True, -- Expression (Node3)
+ 4 => False, -- unused
+ 5 => False), -- Etype (Node5-Sem)
+
N_Allocator =>
(1 => False, -- Storage_Pool (Node1-Sem)
2 => False, -- Procedure_To_Call (Node2-Sem)
Sprint_Indented_List (Component_Clauses (Node));
Write_Indent_Str ("end record;");
+ when N_Reduction_Expression =>
+ Write_Str (" for");
+
+ if Present (Iterator_Specification (Node)) then
+ Sprint_Node (Iterator_Specification (Node));
+ else
+ Sprint_Node (Loop_Parameter_Specification (Node));
+ end if;
+
+ Write_Str (" => ");
+ Sprint_Node (Expression (Node));
+ null;
+
+ when N_Reduction_Expression_Parameter =>
+ Write_Char ('<');
+
+ if Present (Expression (Node)) then
+ Sprint_Node (Expression (Node));
+ end if;
+
+ Write_Char ('>');
+
when N_Reference =>
Sprint_Node (Prefix (Node));
Write_Str_With_Col_Check_Sloc ("'reference");
-- Note on ordering of references. For the tables in Ada.Exceptions units,
-- usually the ordering does not matter, and we use the same ordering as
- -- is used here (note the requirement in the ordering here that CE/PE/SE
- -- codes be kept together, so the subtype declarations work OK).
+ -- is used here.
type RT_Exception_Code is
(CE_Access_Check_Failed, -- 00
SE_Explicit_Raise, -- 33
SE_Infinite_Recursion, -- 34
SE_Object_Too_Large, -- 35
- PE_Stream_Operation_Not_Allowed); -- 36
+ PE_Stream_Operation_Not_Allowed, -- 36
+ PE_Build_In_Place_Mismatch); -- 37
- Last_Reason_Code : constant := 36;
+ Last_Reason_Code : constant :=
+ RT_Exception_Code'Pos (RT_Exception_Code'Last);
-- Last reason code
type Reason_Kind is (CE_Reason, PE_Reason, SE_Reason);
PE_Unchecked_Union_Restriction => PE_Reason,
PE_Non_Transportable_Actual => PE_Reason,
PE_Stream_Operation_Not_Allowed => PE_Reason,
+ PE_Build_In_Place_Mismatch => PE_Reason,
SE_Empty_Storage_Pool => SE_Reason,
SE_Explicit_Raise => SE_Reason,
#define PE_Aliased_Parameters 17
#define PE_All_Guards_Closed 18
#define PE_Bad_Predicated_Generic_Type 19
+#define PE_Build_In_Place_Mismatch 37
#define PE_Current_Task_In_Entry_Body 20
#define PE_Duplicated_Entry_Address 21
#define PE_Explicit_Raise 22
#define SE_Infinite_Recursion 34
#define SE_Object_Too_Large 35
-#define LAST_REASON_CODE 36
+#define LAST_REASON_CODE 37
projects / gcc.git / commitdiff