mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 20:01:28 +08:00
Code Issues Packages Projects Releases Wiki Activity

einfo.ads, einfo.adb (Has_Out_Or_In_Out_Parameter): This attribute is now present in subprograms...

Browse Source 
2015-05-25  Javier Miranda  <miranda@adacore.com>

	* einfo.ads, einfo.adb (Has_Out_Or_In_Out_Parameter): This attribute
	is now present in subprograms, generic subprograms, entries and
	entry families.
	* sem_ch6.adb (Set_Formal_Mode): Set As_Out_Or_In_Out_Parameter
	on entries, entry families, subprograms and generic subprograms.
	* sem_ch12.adb (Analyze_Generic_Subprogram_Declaration):
	Minor code reorganization to ensure that the Ekind attribute
	of the subprogram entity is set before its formals are
	processed. Required to allow the use of the attribute
	Has_Out_Or_In_Out_Parameter on the subprogram entity.
	* sem_aggr.adb (Resolve_Aggregate, Resolve_Extension_Aggregate):
	Perform the check on writable actuals only if the value of some
	component of the aggregate involves calling a function with
	out-mode parameters.
	(Resolve_Record_Aggregate): Propagate the Check_Actuals flag to the
	internally built aggregate.
	* sem_ch3.adb (Build_Derived_Record_Type, Record_Type_Declaration):
	Perform the check on writable actuals only if the initialization of
	some component involves calling a function with out-mode parameters.
	* sem_ch4.adb (Analyze_Arithmetic_Op, Analyze_Comparison_Op,
	Analyze_Equality_Op, Analyze_Logical_Op, Analyze_Membership_Op,
	Analyze_Range): Check writable actuals only if the
	subtrees have a call to a function with out-mode parameters
	(Analyze_Call.Check_Writable_Actuals): New subprogram. If the call
	has out or in-out parameters then mark its outermost enclosing
	construct as a node on which the writable actuals check must
	be performed.
	(Analyze_Call): Check if the flag must be set and if the outermost
	enclosing construct.
	* sem_util.adb (Check_Function_Writable_Actuals): Code cleanup
	and reorganization. We skip processing aggregate discriminants
	since their precise analysis involves two phases traversal.
	* sem_res.adb (Resolve_Actuals, Resolve_Arithmetic_Op,
	Resolve_Logical_Op, Resolve_Membership_Op): Remove call to
	check_writable_actuals.

From-SVN: r223643
This commit is contained in:
Javier Miranda 2015-05-25 12:37:37 +00:00 committed by Arnaud Charlet
parent 277420210d
commit 288cbbbdac
10 changed files with 329 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
gcc/ada/ChangeLog
View File

@ -1,3 +1,41 @@
2015-05-25 Javier Miranda <miranda@adacore.com>
* einfo.ads, einfo.adb (Has_Out_Or_In_Out_Parameter): This attribute
is now present in subprograms, generic subprograms, entries and
entry families.
* sem_ch6.adb (Set_Formal_Mode): Set As_Out_Or_In_Out_Parameter
on entries, entry families, subprograms and generic subprograms.
* sem_ch12.adb (Analyze_Generic_Subprogram_Declaration):
Minor code reorganization to ensure that the Ekind attribute
of the subprogram entity is set before its formals are
processed. Required to allow the use of the attribute
Has_Out_Or_In_Out_Parameter on the subprogram entity.
* sem_aggr.adb (Resolve_Aggregate, Resolve_Extension_Aggregate):
Perform the check on writable actuals only if the value of some
component of the aggregate involves calling a function with
out-mode parameters.
(Resolve_Record_Aggregate): Propagate the Check_Actuals flag to the
internally built aggregate.
* sem_ch3.adb (Build_Derived_Record_Type, Record_Type_Declaration):
Perform the check on writable actuals only if the initialization of
some component involves calling a function with out-mode parameters.
* sem_ch4.adb (Analyze_Arithmetic_Op, Analyze_Comparison_Op,
Analyze_Equality_Op, Analyze_Logical_Op, Analyze_Membership_Op,
Analyze_Range): Check writable actuals only if the
subtrees have a call to a function with out-mode parameters
(Analyze_Call.Check_Writable_Actuals): New subprogram. If the call
has out or in-out parameters then mark its outermost enclosing
construct as a node on which the writable actuals check must
be performed.
(Analyze_Call): Check if the flag must be set and if the outermost
enclosing construct.
* sem_util.adb (Check_Function_Writable_Actuals): Code cleanup
and reorganization. We skip processing aggregate discriminants
since their precise analysis involves two phases traversal.
* sem_res.adb (Resolve_Actuals, Resolve_Arithmetic_Op,
Resolve_Logical_Op, Resolve_Membership_Op): Remove call to
check_writable_actuals.
2015-05-22 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Constrain_Concurrent): If the context is a

8
gcc/ada/einfo.adb
View File

@ -1611,7 +1611,9 @@ package body Einfo is
function Has_Out_Or_In_Out_Parameter (Id : E) return B is
begin
pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function));
pragma Assert
(Ekind_In (Id, E_Entry, E_Entry_Family)
or else Is_Subprogram_Or_Generic_Subprogram (Id));
return Flag110 (Id);
end Has_Out_Or_In_Out_Parameter;
@ -4505,7 +4507,9 @@ package body Einfo is
procedure Set_Has_Out_Or_In_Out_Parameter (Id : E; V : B := True) is
begin
pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function));
pragma Assert
(Ekind_In (Id, E_Entry, E_Entry_Family)
or else Is_Subprogram_Or_Generic_Subprogram (Id));
Set_Flag110 (Id, V);
end Set_Has_Out_Or_In_Out_Parameter;

5
gcc/ada/einfo.ads
View File

@ -1756,8 +1756,9 @@ package Einfo is
-- Object_Size clauses for a given entity.
-- Has_Out_Or_In_Out_Parameter (Flag110)
-- Present in function and generic function entities. Set if the function
-- has at least one OUT or IN OUT parameter (allowed only in Ada 2012).
-- Present in subprograms, generic subprograms, entries and entry
-- families. Set if they have at least one OUT or IN OUT parameter
-- (allowed for functions only in Ada 2012).
-- Has_Per_Object_Constraint (Flag154)
-- Defined in E_Component entities. Set if the subtype of the component

9
gcc/ada/sem_aggr.adb
View File

@ -1161,7 +1161,9 @@ package body Sem_Aggr is
Set_Analyzed (N);
end if;
Check_Function_Writable_Actuals (N);
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
end Resolve_Aggregate;
-----------------------------
@ -2904,7 +2906,9 @@ package body Sem_Aggr is
Error_Msg_N ("no unique type for this aggregate", A);
end if;
Check_Function_Writable_Actuals (N);
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
end Resolve_Extension_Aggregate;
------------------------------
@ -4677,6 +4681,7 @@ package body Sem_Aggr is
Set_Expressions (New_Aggregate, No_List);
Set_Etype (New_Aggregate, Etype (N));
Set_Component_Associations (New_Aggregate, New_Assoc_List);
Set_Check_Actuals (New_Aggregate, Check_Actuals (N));
Rewrite (N, New_Aggregate);
end Step_8;

9
gcc/ada/sem_ch12.adb
View File

@ -3366,13 +3366,17 @@ package body Sem_Ch12 is
Formals := Parameter_Specifications (Spec);
if Nkind (Spec) = N_Function_Specification then
Set_Ekind (Id, E_Generic_Function);
else
Set_Ekind (Id, E_Generic_Procedure);
end if;
if Present (Formals) then
Process_Formals (Formals, Spec);
end if;
if Nkind (Spec) = N_Function_Specification then
Set_Ekind (Id, E_Generic_Function);
if Nkind (Result_Definition (Spec)) = N_Access_Definition then
Result_Type := Access_Definition (Spec, Result_Definition (Spec));
Set_Etype (Id, Result_Type);
@ -3420,7 +3424,6 @@ package body Sem_Ch12 is
end if;
else
Set_Ekind (Id, E_Generic_Procedure);
Set_Etype (Id, Standard_Void_Type);
end if;

8
gcc/ada/sem_ch3.adb
View File

@ -8953,7 +8953,9 @@ package body Sem_Ch3 is
(Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type));
end if;
Check_Function_Writable_Actuals (N);
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
end Build_Derived_Record_Type;
------------------------
@ -21116,7 +21118,9 @@ package body Sem_Ch3 is
Derive_Progenitor_Subprograms (T, T);
end if;
Check_Function_Writable_Actuals (N);
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
end Record_Type_Declaration;
----------------------------

183
gcc/ada/sem_ch4.adb
View File

@ -830,6 +830,10 @@ package body Sem_Ch4 is
end if;
Operator_Check (N);
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
end Analyze_Arithmetic_Op;
------------------
@ -862,6 +866,11 @@ package body Sem_Ch4 is
-- Check that parameter and named associations are not mixed. This is
-- a restriction in SPARK mode.
procedure Check_Writable_Actuals (N : Node_Id);
-- If the call has out or in-out parameters then mark its outermost
-- enclosing construct as a node on which the writable actuals check
-- must be performed.
function Name_Denotes_Function return Boolean;
-- If the type of the name is an access to subprogram, this may be the
-- type of a name, or the return type of the function being called. If
@ -902,6 +911,140 @@ package body Sem_Ch4 is
end loop;
end Check_Mixed_Parameter_And_Named_Associations;
----------------------------
-- Check_Writable_Actuals --
----------------------------
-- The identification of conflicts in calls to functions with writable
-- actuals is performed in the analysis phase of the frontend to ensure
-- that it reports exactly the same errors compiling with and without
-- expansion enabled. It is performed in two stages:
-- 1) When a call to a function with out-mode parameters is found
-- we climb to the outermost enclosing construct which can be
-- evaluated in arbitrary order and we mark it with the flag
-- Check_Actuals.
-- 2) When the analysis of the marked node is complete then we
-- traverse its decorated subtree searching for conflicts
-- (see function Sem_Util.Check_Function_Writable_Actuals).
-- The unique exception to this general rule are aggregates, since
-- their analysis is performed by the frontend in the resolution
-- phase. For aggregates we do not climb to its enclosing construct:
-- we restrict the analysis to the subexpressions initializing the
-- aggregate components.
-- This implies that the analysis of expressions containing aggregates
-- is not complete since there may be conflicts on writable actuals
-- involving subexpressions of the enclosing logical or arithmetic
-- expressions. However, we cannot wait and perform the analysis when
-- the whole subtree is resolved since the subtrees may be transformed
-- thus adding extra complexity and computation cost to identify and
-- report exactly the same errors compiling with and without expansion
-- enabled.
procedure Check_Writable_Actuals (N : Node_Id) is
function Is_Arbitrary_Evaluation_Order_Construct
(N : Node_Id) return Boolean;
-- Return True if N is an Ada construct which may evaluate in
-- arbitrary order. This function does not cover all the language
-- constructs which can be evaluated in arbitrary order but the
-- subset needed for AI05-0144.
---------------------------------------------
-- Is_Arbitrary_Evaluation_Order_Construct --
---------------------------------------------
function Is_Arbitrary_Evaluation_Order_Construct
(N : Node_Id) return Boolean is
begin
return Nkind (N) = N_Aggregate
or else Nkind (N) = N_Assignment_Statement
or else Nkind (N) = N_Full_Type_Declaration
or else Nkind (N) = N_Entry_Call_Statement
or else Nkind (N) = N_Extension_Aggregate
or else Nkind (N) = N_Indexed_Component
or else Nkind (N) = N_Object_Declaration
or else Nkind (N) = N_Pragma
or else Nkind (N) = N_Range
or else Nkind (N) = N_Slice
or else Nkind (N) in N_Array_Type_Definition
or else Nkind (N) in N_Membership_Test
or else Nkind (N) in N_Op
or else Nkind (N) in N_Subprogram_Call;
end Is_Arbitrary_Evaluation_Order_Construct;
-- Start of processing for Check_Writable_Actuals
begin
if Comes_From_Source (N)
and then Present (Get_Subprogram_Entity (N))
and then Has_Out_Or_In_Out_Parameter (Get_Subprogram_Entity (N))
then
-- For procedures and entries there is no need to climb since
-- we only need to check if the actuals of this call invoke
-- functions whose out-mode parameters overlap.
if Nkind (N) /= N_Function_Call then
Set_Check_Actuals (N);
-- For calls to functions we climb to the outermost enclosing
-- construct where the out-mode actuals of this function may
-- introduce conflicts.
else
declare
Outermost : Node_Id;
P : Node_Id := N;
begin
while Present (P) loop
-- For object declarations we can climb to such node from
-- its object definition branch or from its initializing
-- expression. We prefer to mark the child node as the
-- outermost construct to avoid adding further complexity
-- to the routine which will take care later of
-- performing the writable actuals check.
if Is_Arbitrary_Evaluation_Order_Construct (P)
and then Nkind (P) /= N_Assignment_Statement
and then Nkind (P) /= N_Object_Declaration
then
Outermost := P;
end if;
-- Avoid climbing more than needed!
exit when Nkind (P) = N_Aggregate
or else Nkind (P) = N_Assignment_Statement
or else Nkind (P) = N_Entry_Call_Statement
or else Nkind (P) = N_Extended_Return_Statement
or else Nkind (P) = N_Extension_Aggregate
or else Nkind (P) = N_Full_Type_Declaration
or else Nkind (P) = N_Object_Declaration
or else Nkind (P) = N_Object_Renaming_Declaration
or else Nkind (P) = N_Package_Specification
or else Nkind (P) = N_Pragma
or else Nkind (P) = N_Procedure_Call_Statement
or else Nkind (P) = N_Simple_Return_Statement
or else (Nkind (P) = N_Range
and then not
Nkind_In (Parent (P), N_In, N_Not_In))
or else Nkind (P) in N_Has_Condition;
P := Parent (P);
end loop;
Set_Check_Actuals (Outermost);
end;
end if;
end if;
end Check_Writable_Actuals;
---------------------------
-- Name_Denotes_Function --
---------------------------
@ -1257,6 +1400,21 @@ package body Sem_Ch4 is
End_Interp_List;
end if;
if Ada_Version >= Ada_2012 then
-- Check if the call contains a function with writable actuals
Check_Writable_Actuals (N);
-- If found and the outermost construct which can be evaluated in
-- arbitrary order is precisely this call then check all its
-- actuals.
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
end if;
end Analyze_Call;
-----------------------------
@ -1474,6 +1632,10 @@ package body Sem_Ch4 is
end if;
Operator_Check (N);
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
end Analyze_Comparison_Op;
---------------------------
@ -1721,6 +1883,10 @@ package body Sem_Ch4 is
end if;
Operator_Check (N);
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
end Analyze_Equality_Op;
----------------------------------
@ -2544,6 +2710,10 @@ package body Sem_Ch4 is
end if;
Operator_Check (N);
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
end Analyze_Logical_Op;
---------------------------
@ -2699,6 +2869,11 @@ package body Sem_Ch4 is
if No (R) and then Ada_Version >= Ada_2012 then
Analyze_Set_Membership;
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
return;
end if;
@ -2770,6 +2945,10 @@ package body Sem_Ch4 is
then
Error_Msg_N ("membership test not applicable to cpp-class types", N);
end if;
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
end Analyze_Membership_Op;
-----------------
@ -3849,7 +4028,9 @@ package body Sem_Ch4 is
Check_Universal_Expression (H);
end if;
Check_Function_Writable_Actuals (N);
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
end Analyze_Range;
-----------------------

11
gcc/ada/sem_ch6.adb
View File

@ -10539,6 +10539,7 @@ package body Sem_Ch6 is
procedure Set_Formal_Mode (Formal_Id : Entity_Id) is
Spec : constant Node_Id := Parent (Formal_Id);
Id : constant Entity_Id := Scope (Formal_Id);
begin
-- Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
@ -10546,7 +10547,13 @@ package body Sem_Ch6 is
-- point of the call.
if Out_Present (Spec) then
if Ekind_In (Scope (Formal_Id), E_Function, E_Generic_Function) then
if Ekind_In (Id, E_Entry, E_Entry_Family)
or else Is_Subprogram_Or_Generic_Subprogram (Id)
then
Set_Has_Out_Or_In_Out_Parameter (Id, True);
end if;
if Ekind_In (Id, E_Function, E_Generic_Function) then
-- [IN] OUT parameters allowed for functions in Ada 2012
@ -10564,8 +10571,6 @@ package body Sem_Ch6 is
Set_Ekind (Formal_Id, E_Out_Parameter);
end if;
Set_Has_Out_Or_In_Out_Parameter (Scope (Formal_Id), True);
-- But not in earlier versions of Ada
else

5
gcc/ada/sem_res.adb
View File

@ -3566,7 +3566,6 @@ package body Sem_Res is
begin
Check_Argument_Order;
Check_Function_Writable_Actuals (N);
if Is_Overloadable (Nam)
and then Is_Inherited_Operation (Nam)
@ -5508,7 +5507,6 @@ package body Sem_Res is
Check_Unset_Reference (L);
Check_Unset_Reference (R);
Check_Function_Writable_Actuals (N);
end Resolve_Arithmetic_Op;
------------------
@ -8600,8 +8598,6 @@ package body Sem_Res is
end if;
end;
end if;
Check_Function_Writable_Actuals (N);
end Resolve_Logical_Op;
---------------------------
@ -8793,7 +8789,6 @@ package body Sem_Res is
<<SM_Exit>>
Eval_Membership_Op (N);
Check_Function_Writable_Actuals (N);
end Resolve_Membership_Op;
------------------

93
gcc/ada/sem_util.adb
View File

@ -2119,11 +2119,37 @@ package body Sem_Util is
then
return Skip;
-- For now we skip aggregate discriminants since they require
-- performing the analysis in two phases to identify conflicts:
-- first one analyzing discriminants and second one analyzing
-- the rest of components (since at runtime discriminants are
-- evaluated prior to components): too much computation cost
-- to identify a corner case???
elsif Nkind (Parent (N)) = N_Component_Association
and then Nkind_In (Parent (Parent (N)),
N_Aggregate,
N_Extension_Aggregate)
then
declare
Choice : constant Node_Id := First (Choices (Parent (N)));
begin
if Ekind (Entity (N)) = E_Discriminant then
return Skip;
elsif Expression (Parent (N)) = N
and then Nkind (Choice) = N_Identifier
and then Ekind (Entity (Choice)) = E_Discriminant
then
return Skip;
end if;
end;
-- Analyze if N is a writable actual of a function
elsif Nkind (Parent (N)) = N_Function_Call then
declare
Call : constant Node_Id := Parent (N);
Call : constant Node_Id := Parent (N);
Actual : Node_Id;
Formal : Node_Id;
@ -2136,32 +2162,59 @@ package body Sem_Util is
return Abandon;
end if;
Formal := First_Formal (Id);
Actual := First_Actual (Call);
while Present (Actual) and then Present (Formal) loop
if Actual = N then
if Ekind_In (Formal, E_Out_Parameter,
E_In_Out_Parameter)
then
Is_Writable_Actual := True;
if Ekind_In (Id, E_Function, E_Generic_Function)
and then Has_Out_Or_In_Out_Parameter (Id)
then
Formal := First_Formal (Id);
Actual := First_Actual (Call);
while Present (Actual) and then Present (Formal) loop
if Actual = N then
if Ekind_In (Formal, E_Out_Parameter,
E_In_Out_Parameter)
then
Is_Writable_Actual := True;
end if;
exit;
end if;
exit;
end if;
Next_Formal (Formal);
Next_Actual (Actual);
end loop;
Next_Formal (Formal);
Next_Actual (Actual);
end loop;
end if;
end;
end if;
if Is_Writable_Actual then
if Contains (Writable_Actuals_List, N) then
Error_Msg_NE
("value may be affected by call to& "
& "because order of evaluation is arbitrary", N, Id);
Error_Node := N;
return Abandon;
-- Report the error on the second occurrence of the
-- identifier. We cannot assume that N is the second
-- occurrence since traverse_func walks through Field2
-- last (see comment in the body of traverse_func).
declare
Elmt : Elmt_Id := First_Elmt (Writable_Actuals_List);
begin
while Present (Elmt)
and then Entity (Node (Elmt)) /= Entity (N)
loop
Next_Elmt (Elmt);
end loop;
if Sloc (N) > Sloc (Node (Elmt)) then
Error_Node := N;
else
Error_Node := Node (Elmt);
end if;
Error_Msg_NE
("value may be affected by call to& "
& "because order of evaluation is arbitrary",
Error_Node, Id);
return Abandon;
end;
end if;
Append_New_Elmt (N, To => Writable_Actuals_List);