errout.ads, errout.adb (Get_Ignore_Errors): New subprogram.
2013-01-29 Javier Miranda <miranda@adacore.com> * errout.ads, errout.adb (Get_Ignore_Errors): New subprogram. * opt.ads (Warn_On_Overlap): Update documentation. * sem_aggr.adb (Resolve_Aggregate, Resolve_Extension_Aggregate): Check function writable actuals. * sem_ch3.adb (Build_Derived_Record_Type, Record_Type_Declaration): Check function writable actuals. * sem_ch4.adb (Analyze_Range): Check function writable actuals. * sem_ch5.adb (Analyze_Assignment): Remove code of the initial implementation of AI05-0144. * sem_ch6.adb (Analyze_Function_Return, (Analyze_Procedure_Call.Analyze_Call_And_Resolve): Remove code of the initial implementation of AI05-0144. * sem_res.adb (Resolve): Remove code of the initial implementation. (Resolve_Actuals): Call Check_Function_Writable_Actuals and remove call of the initial implementation. (Resolve_Arithmetic_Op, Resolve_Logical_Op, Resolve_Membership_Op): Check function writable actuals. * sem_util.ad[sb] (Actuals_In_Call): Removed (Check_Order_Dependence): Removed (Save_Actual): Removed (Check_Function_Writable_Actuals): New subprogram. * usage.adb (Usage): Update documentation. * warnsw.adb (Set_Warning_Switch): Enable warn_on_overlap when setting all warnings. From-SVN: r195540
This commit is contained in:
Javier Miranda
Arnaud Charlet
parent
54bb89caea
commit
d38207955c
@ -1,3 +1,29 @@
|
||||
2013-01-29 Javier Miranda <miranda@adacore.com>
|
||||
|
||||
* errout.ads, errout.adb (Get_Ignore_Errors): New subprogram.
|
||||
* opt.ads (Warn_On_Overlap): Update documentation.
|
||||
* sem_aggr.adb (Resolve_Aggregate, Resolve_Extension_Aggregate):
|
||||
Check function writable actuals.
|
||||
* sem_ch3.adb (Build_Derived_Record_Type,
|
||||
Record_Type_Declaration): Check function writable actuals.
|
||||
* sem_ch4.adb (Analyze_Range): Check function writable actuals.
|
||||
* sem_ch5.adb (Analyze_Assignment): Remove code of the initial
|
||||
implementation of AI05-0144.
|
||||
* sem_ch6.adb (Analyze_Function_Return,
|
||||
(Analyze_Procedure_Call.Analyze_Call_And_Resolve): Remove code
|
||||
of the initial implementation of AI05-0144.
|
||||
* sem_res.adb (Resolve): Remove code of the initial implementation.
|
||||
(Resolve_Actuals): Call Check_Function_Writable_Actuals and remove call
|
||||
of the initial implementation.
|
||||
(Resolve_Arithmetic_Op, Resolve_Logical_Op,
|
||||
Resolve_Membership_Op): Check function writable actuals.
|
||||
* sem_util.ad[sb] (Actuals_In_Call): Removed
|
||||
(Check_Order_Dependence): Removed (Save_Actual): Removed
|
||||
(Check_Function_Writable_Actuals): New subprogram.
|
||||
* usage.adb (Usage): Update documentation.
|
||||
* warnsw.adb (Set_Warning_Switch): Enable warn_on_overlap when
|
||||
setting all warnings.
|
||||
|
||||
2013-01-29 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* a-calend-vms.adb: Minor comment fix.
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2013, 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- --
|
||||
@ -1458,6 +1458,15 @@ package body Errout is
|
||||
return S;
|
||||
end First_Sloc;
|
||||
|
||||
-----------------------
|
||||
-- Get_Ignore_Errors --
|
||||
-----------------------
|
||||
|
||||
function Get_Ignore_Errors return Boolean is
|
||||
begin
|
||||
return Errors_Must_Be_Ignored;
|
||||
end Get_Ignore_Errors;
|
||||
|
||||
----------------
|
||||
-- Initialize --
|
||||
----------------
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2013, 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- --
|
||||
@ -746,6 +746,9 @@ package Errout is
|
||||
-- where the expression is parenthesized, an attempt is made to include
|
||||
-- the parentheses (i.e. to return the location of the initial paren).
|
||||
|
||||
function Get_Ignore_Errors return Boolean;
|
||||
-- Return True if all error calls are ignored.
|
||||
|
||||
procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr)
|
||||
renames Erroutc.Purge_Messages;
|
||||
-- All error messages whose location is in the range From .. To (not
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2013, 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- --
|
||||
@ -1595,8 +1595,9 @@ package Opt is
|
||||
|
||||
Warn_On_Overlap : Boolean := False;
|
||||
-- GNAT
|
||||
-- Set to True to generate warnings when a writable actual which is not
|
||||
-- a by-copy type overlaps with another actual in a subprogram call.
|
||||
-- Set to True to generate warnings when a writable actual overlaps with
|
||||
-- another actual in a subprogram call. This applies only in modes before
|
||||
-- Ada 2012. Starting with Ada 2012, such overlaps are illegal.
|
||||
-- Modified by use of -gnatw.i/.I.
|
||||
|
||||
Warn_On_Questionable_Missing_Parens : Boolean := True;
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2013, 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- --
|
||||
@ -1252,6 +1252,8 @@ package body Sem_Aggr is
|
||||
Set_Etype (N, Aggr_Subtyp);
|
||||
Set_Analyzed (N);
|
||||
end if;
|
||||
|
||||
Check_Function_Writable_Actuals (N);
|
||||
end Resolve_Aggregate;
|
||||
|
||||
-----------------------------
|
||||
@ -2816,6 +2818,8 @@ package body Sem_Aggr is
|
||||
else
|
||||
Error_Msg_N ("no unique type for this aggregate", A);
|
||||
end if;
|
||||
|
||||
Check_Function_Writable_Actuals (N);
|
||||
end Resolve_Extension_Aggregate;
|
||||
|
||||
------------------------------
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2013, 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- --
|
||||
@ -8061,6 +8061,8 @@ package body Sem_Ch3 is
|
||||
Set_Last_Entity
|
||||
(Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type));
|
||||
end if;
|
||||
|
||||
Check_Function_Writable_Actuals (N);
|
||||
end Build_Derived_Record_Type;
|
||||
|
||||
------------------------
|
||||
@ -19678,6 +19680,8 @@ package body Sem_Ch3 is
|
||||
then
|
||||
Derive_Progenitor_Subprograms (T, T);
|
||||
end if;
|
||||
|
||||
Check_Function_Writable_Actuals (N);
|
||||
end Record_Type_Declaration;
|
||||
|
||||
----------------------------
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2013, 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- --
|
||||
@ -3611,6 +3611,8 @@ package body Sem_Ch4 is
|
||||
Check_Universal_Expression (L);
|
||||
Check_Universal_Expression (H);
|
||||
end if;
|
||||
|
||||
Check_Function_Writable_Actuals (N);
|
||||
end Analyze_Range;
|
||||
|
||||
-----------------------
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2013, 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- --
|
||||
@ -692,7 +692,6 @@ package body Sem_Ch5 is
|
||||
-- checks have been applied.
|
||||
|
||||
Note_Possible_Modification (Lhs, Sure => True);
|
||||
Check_Order_Dependence;
|
||||
|
||||
-- ??? a real accessibility check is needed when ???
|
||||
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2013, 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- --
|
||||
@ -978,10 +978,6 @@ package body Sem_Ch6 is
|
||||
& "null-excluding return??",
|
||||
Reason => CE_Null_Not_Allowed);
|
||||
end if;
|
||||
|
||||
-- Apply checks suggested by AI05-0144 (dangerous order dependence)
|
||||
|
||||
Check_Order_Dependence;
|
||||
end if;
|
||||
end Analyze_Function_Return;
|
||||
|
||||
@ -1266,11 +1262,6 @@ package body Sem_Ch6 is
|
||||
if Nkind (N) = N_Procedure_Call_Statement then
|
||||
Analyze_Call (N);
|
||||
Resolve (N, Standard_Void_Type);
|
||||
|
||||
-- Apply checks suggested by AI05-0144
|
||||
|
||||
Check_Order_Dependence;
|
||||
|
||||
else
|
||||
Analyze (N);
|
||||
end if;
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2013, 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- --
|
||||
@ -2864,18 +2864,6 @@ package body Sem_Res is
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- AI05-144-2: Check dangerous order dependence within an expression
|
||||
-- that is not a subexpression. Exclude RHS of an assignment, because
|
||||
-- both sides may have side-effects and the check must be performed
|
||||
-- over the statement.
|
||||
|
||||
if Nkind (Parent (N)) not in N_Subexpr
|
||||
and then Nkind (Parent (N)) /= N_Assignment_Statement
|
||||
and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
|
||||
then
|
||||
Check_Order_Dependence;
|
||||
end if;
|
||||
|
||||
-- The expression is definitely NOT overloaded at this point, so
|
||||
-- we reset the Is_Overloaded flag to avoid any confusion when
|
||||
-- reanalyzing the node.
|
||||
@ -3378,6 +3366,7 @@ package body Sem_Res is
|
||||
|
||||
begin
|
||||
Check_Argument_Order;
|
||||
Check_Function_Writable_Actuals (N);
|
||||
|
||||
if Present (First_Actual (N)) then
|
||||
Check_Prefixed_Call;
|
||||
@ -3776,21 +3765,6 @@ package body Sem_Res is
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Save actual for subsequent check on order dependence, and
|
||||
-- indicate whether actual is modifiable. For AI05-0144-2.
|
||||
|
||||
-- If this is a call to a reference function that is the result
|
||||
-- of expansion, as in element iterator loops, this does not lead
|
||||
-- to a dangerous order dependence: only subsequent use of the
|
||||
-- denoted element might, in some enclosing call.
|
||||
|
||||
if not Has_Implicit_Dereference (Etype (Nam))
|
||||
or else Comes_From_Source (N)
|
||||
then
|
||||
Save_Actual (A, Ekind (F) /= E_In_Parameter);
|
||||
end if;
|
||||
|
||||
-- For mode IN, if actual is an entity, and the type of the formal
|
||||
-- has warnings suppressed, then we reset Never_Set_In_Source for
|
||||
-- the calling entity. The reason for this is to catch cases like
|
||||
-- GNAT.Spitbol.Patterns.Vstring_Var where the called subprogram
|
||||
@ -5108,6 +5082,7 @@ package body Sem_Res is
|
||||
|
||||
Check_Unset_Reference (L);
|
||||
Check_Unset_Reference (R);
|
||||
Check_Function_Writable_Actuals (N);
|
||||
end Resolve_Arithmetic_Op;
|
||||
|
||||
------------------
|
||||
@ -7632,6 +7607,8 @@ package body Sem_Res is
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
|
||||
Check_Function_Writable_Actuals (N);
|
||||
end Resolve_Logical_Op;
|
||||
|
||||
---------------------------
|
||||
@ -7729,6 +7706,7 @@ package body Sem_Res is
|
||||
|
||||
if Present (Alternatives (N)) then
|
||||
Resolve_Set_Membership;
|
||||
Check_Function_Writable_Actuals (N);
|
||||
return;
|
||||
|
||||
elsif not Is_Overloaded (R)
|
||||
@ -7793,6 +7771,7 @@ package body Sem_Res is
|
||||
end if;
|
||||
|
||||
Eval_Membership_Op (N);
|
||||
Check_Function_Writable_Actuals (N);
|
||||
end Resolve_Membership_Op;
|
||||
|
||||
------------------
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2013, 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- --
|
||||
@ -57,7 +57,6 @@ with Sinput; use Sinput;
|
||||
with Stand; use Stand;
|
||||
with Style;
|
||||
with Stringt; use Stringt;
|
||||
with Table;
|
||||
with Targparm; use Targparm;
|
||||
with Tbuild; use Tbuild;
|
||||
with Ttypes; use Ttypes;
|
||||
@ -96,30 +95,6 @@ package body Sem_Util is
|
||||
subtype NCT_Header_Num is Int range 0 .. 511;
|
||||
-- Defines range of headers in hash tables (512 headers)
|
||||
|
||||
----------------------------------
|
||||
-- Order Dependence (AI05-0144) --
|
||||
----------------------------------
|
||||
|
||||
-- Each actual in a call is entered into the table below. A flag indicates
|
||||
-- whether the corresponding formal is OUT or IN OUT. Each top-level call
|
||||
-- (procedure call, condition, assignment) examines all the actuals for a
|
||||
-- possible order dependence. The table is reset after each such check.
|
||||
-- The actuals to be checked in a call to Check_Order_Dependence are at
|
||||
-- positions 1 .. Last.
|
||||
|
||||
type Actual_Name is record
|
||||
Act : Node_Id;
|
||||
Is_Writable : Boolean;
|
||||
end record;
|
||||
|
||||
package Actuals_In_Call is new Table.Table (
|
||||
Table_Component_Type => Actual_Name,
|
||||
Table_Index_Type => Int,
|
||||
Table_Low_Bound => 0,
|
||||
Table_Initial => 10,
|
||||
Table_Increment => 100,
|
||||
Table_Name => "Actuals");
|
||||
|
||||
-----------------------
|
||||
-- Local Subprograms --
|
||||
-----------------------
|
||||
@ -1245,6 +1220,590 @@ package body Sem_Util is
|
||||
end if;
|
||||
end Cannot_Raise_Constraint_Error;
|
||||
|
||||
-------------------------------------
|
||||
-- Check_Function_Writable_Actuals --
|
||||
-------------------------------------
|
||||
|
||||
procedure Check_Function_Writable_Actuals (N : Node_Id) is
|
||||
Writable_Actuals_List : Elist_Id := No_Elist;
|
||||
Identifiers_List : Elist_Id := No_Elist;
|
||||
Error_Node : Node_Id := Empty;
|
||||
|
||||
procedure Collect_Identifiers (N : Node_Id);
|
||||
-- In a single traversal of subtree N collect in Writable_Actuals_List
|
||||
-- all the actuals of functions with writable actuals, and in the list
|
||||
-- Identifiers_List collect all the identifiers that are not actuals of
|
||||
-- functions with writable actuals. If a writable actual is referenced
|
||||
-- twice as writable actual then Error_Node is set to reference its
|
||||
-- second occurrence, the error is reported, and the tree traversal
|
||||
-- is abandoned.
|
||||
|
||||
function Get_Function_Id (Call : Node_Id) return Entity_Id;
|
||||
-- Return the entity associated with the function call
|
||||
|
||||
procedure Preanalyze_Without_Errors (N : Node_Id);
|
||||
-- Preanalyze N without reporting errors
|
||||
|
||||
-------------------------
|
||||
-- Collect_Identifiers --
|
||||
-------------------------
|
||||
|
||||
procedure Collect_Identifiers (N : Node_Id) is
|
||||
|
||||
function Check_Node (N : Node_Id) return Traverse_Result;
|
||||
-- Process a single node during the tree traversal to collect the
|
||||
-- writable actuals of functions and all the identifiers which are
|
||||
-- not writable actuals of functions.
|
||||
|
||||
function Contains (List : Elist_Id; N : Node_Id) return Boolean;
|
||||
-- Returns True if List has a node whose Entity is Entity (N)
|
||||
|
||||
-------------------------
|
||||
-- Check_Function_Call --
|
||||
-------------------------
|
||||
|
||||
function Check_Node (N : Node_Id) return Traverse_Result is
|
||||
Is_Writable_Actual : Boolean := False;
|
||||
|
||||
begin
|
||||
if Nkind (N) = N_Identifier then
|
||||
|
||||
-- No analysis possible if the entity is not decorated
|
||||
|
||||
if No (Entity (N)) then
|
||||
return Skip;
|
||||
|
||||
-- We don't collect identifiers of packages, called functions,
|
||||
-- etc.
|
||||
|
||||
elsif Ekind_In (Entity (N),
|
||||
E_Package,
|
||||
E_Function,
|
||||
E_Procedure,
|
||||
E_Entry)
|
||||
then
|
||||
return Skip;
|
||||
|
||||
-- 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);
|
||||
Id : constant Entity_Id := Get_Function_Id (Call);
|
||||
Actual : Node_Id;
|
||||
Formal : Node_Id;
|
||||
|
||||
begin
|
||||
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;
|
||||
|
||||
Next_Formal (Formal);
|
||||
Next_Actual (Actual);
|
||||
end loop;
|
||||
end;
|
||||
end if;
|
||||
|
||||
if Is_Writable_Actual then
|
||||
if Contains (Writable_Actuals_List, N) then
|
||||
Error_Msg_N
|
||||
("conflict of writable function parameter in "
|
||||
& "construct with arbitrary order of evaluation", N);
|
||||
Error_Node := N;
|
||||
return Abandon;
|
||||
end if;
|
||||
|
||||
if Writable_Actuals_List = No_Elist then
|
||||
Writable_Actuals_List := New_Elmt_List;
|
||||
end if;
|
||||
|
||||
Append_Elmt (N, Writable_Actuals_List);
|
||||
else
|
||||
if Identifiers_List = No_Elist then
|
||||
Identifiers_List := New_Elmt_List;
|
||||
end if;
|
||||
|
||||
Append_Unique_Elmt (N, Identifiers_List);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
return OK;
|
||||
end Check_Node;
|
||||
|
||||
--------------
|
||||
-- Contains --
|
||||
--------------
|
||||
|
||||
function Contains
|
||||
(List : Elist_Id;
|
||||
N : Node_Id) return Boolean
|
||||
is
|
||||
pragma Assert (Nkind (N) in N_Has_Entity);
|
||||
|
||||
Elmt : Elmt_Id;
|
||||
begin
|
||||
if List = No_Elist then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
Elmt := First_Elmt (List);
|
||||
loop
|
||||
if No (Elmt) then
|
||||
return False;
|
||||
elsif Entity (Node (Elmt)) = Entity (N) then
|
||||
return True;
|
||||
else
|
||||
Next_Elmt (Elmt);
|
||||
end if;
|
||||
end loop;
|
||||
end Contains;
|
||||
|
||||
------------------
|
||||
-- Do_Traversal --
|
||||
------------------
|
||||
|
||||
procedure Do_Traversal is new Traverse_Proc (Check_Node);
|
||||
-- The traversal procedure
|
||||
|
||||
-- Start of processing for Collect_Identifiers
|
||||
|
||||
begin
|
||||
if Present (Error_Node) then
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Nkind (N) in N_Subexpr
|
||||
and then Is_Static_Expression (N)
|
||||
then
|
||||
return;
|
||||
end if;
|
||||
|
||||
Do_Traversal (N);
|
||||
end Collect_Identifiers;
|
||||
|
||||
---------------------
|
||||
-- Get_Function_Id --
|
||||
---------------------
|
||||
|
||||
function Get_Function_Id (Call : Node_Id) return Entity_Id is
|
||||
Nam : constant Node_Id := Name (Call);
|
||||
Id : Entity_Id;
|
||||
begin
|
||||
if Nkind (Nam) = N_Explicit_Dereference then
|
||||
Id := Etype (Nam);
|
||||
pragma Assert (Ekind (Id) = E_Subprogram_Type);
|
||||
|
||||
elsif Nkind (Nam) = N_Selected_Component then
|
||||
Id := Entity (Selector_Name (Nam));
|
||||
|
||||
elsif Nkind (Nam) = N_Indexed_Component then
|
||||
Id := Entity (Selector_Name (Prefix (Nam)));
|
||||
|
||||
else
|
||||
Id := Entity (Nam);
|
||||
end if;
|
||||
|
||||
return Id;
|
||||
end Get_Function_Id;
|
||||
|
||||
---------------------------
|
||||
-- Preanalyze_Expression --
|
||||
---------------------------
|
||||
|
||||
procedure Preanalyze_Without_Errors (N : Node_Id) is
|
||||
Status : constant Boolean := Get_Ignore_Errors;
|
||||
begin
|
||||
Set_Ignore_Errors (True);
|
||||
Preanalyze (N);
|
||||
Set_Ignore_Errors (Status);
|
||||
end Preanalyze_Without_Errors;
|
||||
|
||||
-- Start of processing for Check_Function_Writable_Actuals
|
||||
|
||||
begin
|
||||
if Ada_Version < Ada_2012
|
||||
or else (not (Nkind (N) in N_Op)
|
||||
and then not (Nkind (N) in N_Membership_Test)
|
||||
and then not Nkind_In (N,
|
||||
N_Range,
|
||||
N_Aggregate,
|
||||
N_Extension_Aggregate,
|
||||
N_Full_Type_Declaration,
|
||||
N_Function_Call,
|
||||
N_Procedure_Call_Statement,
|
||||
N_Entry_Call_Statement))
|
||||
or else (Nkind (N) = N_Full_Type_Declaration
|
||||
and then not Is_Record_Type (Defining_Identifier (N)))
|
||||
then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- If a construct C has two or more direct constituents that are names
|
||||
-- or expressions whose evaluation may occur in an arbitrary order, at
|
||||
-- least one of which contains a function call with an in out or out
|
||||
-- parameter, then the construct is legal only if: for each name N that
|
||||
-- is passed as a parameter of mode in out or out to some inner function
|
||||
-- call C2 (not including the construct C itself), there is no other
|
||||
-- name anywhere within a direct constituent of the construct C other
|
||||
-- than the one containing C2, that is known to refer to the same
|
||||
-- object (RM 6.4.1(6.17/3)).
|
||||
|
||||
case Nkind (N) is
|
||||
when N_Range =>
|
||||
Collect_Identifiers (Low_Bound (N));
|
||||
Collect_Identifiers (High_Bound (N));
|
||||
|
||||
when N_Op | N_Membership_Test =>
|
||||
declare
|
||||
Expr : Node_Id;
|
||||
begin
|
||||
Collect_Identifiers (Left_Opnd (N));
|
||||
|
||||
if Present (Right_Opnd (N)) then
|
||||
Collect_Identifiers (Right_Opnd (N));
|
||||
end if;
|
||||
|
||||
if Nkind_In (N, N_In, N_Not_In)
|
||||
and then Present (Alternatives (N))
|
||||
then
|
||||
Expr := First (Alternatives (N));
|
||||
while Present (Expr) loop
|
||||
Collect_Identifiers (Expr);
|
||||
|
||||
Next (Expr);
|
||||
end loop;
|
||||
end if;
|
||||
end;
|
||||
|
||||
when N_Full_Type_Declaration =>
|
||||
declare
|
||||
function Get_Record_Part (N : Node_Id) return Node_Id;
|
||||
-- Return the record part of this record type definition
|
||||
|
||||
function Get_Record_Part (N : Node_Id) return Node_Id is
|
||||
Type_Def : constant Node_Id := Type_Definition (N);
|
||||
begin
|
||||
if Nkind (Type_Def) = N_Derived_Type_Definition then
|
||||
return Record_Extension_Part (Type_Def);
|
||||
else
|
||||
return Type_Def;
|
||||
end if;
|
||||
end Get_Record_Part;
|
||||
|
||||
Comp : Node_Id;
|
||||
Def_Id : Entity_Id := Defining_Identifier (N);
|
||||
Rec : Node_Id := Get_Record_Part (N);
|
||||
begin
|
||||
-- No need to perform any analysis if the record has no
|
||||
-- components
|
||||
|
||||
if No (Rec) or else No (Component_List (Rec)) then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Collect the identifiers starting from the deepest
|
||||
-- derivation. Done to report the error in the deepest
|
||||
-- derivation.
|
||||
|
||||
loop
|
||||
if Present (Component_List (Rec)) then
|
||||
Comp := First (Component_Items (Component_List (Rec)));
|
||||
while Present (Comp) loop
|
||||
if Nkind (Comp) = N_Component_Declaration
|
||||
and then Present (Expression (Comp))
|
||||
then
|
||||
Collect_Identifiers (Expression (Comp));
|
||||
end if;
|
||||
|
||||
Next (Comp);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
exit when No (Underlying_Type (Etype (Def_Id)))
|
||||
or else Base_Type (Underlying_Type (Etype (Def_Id)))
|
||||
= Def_Id;
|
||||
|
||||
Def_Id := Base_Type (Underlying_Type (Etype (Def_Id)));
|
||||
Rec := Get_Record_Part (Parent (Def_Id));
|
||||
end loop;
|
||||
end;
|
||||
|
||||
when N_Subprogram_Call |
|
||||
N_Entry_Call_Statement =>
|
||||
declare
|
||||
Id : constant Entity_Id := Get_Function_Id (N);
|
||||
Formal : Node_Id;
|
||||
Actual : Node_Id;
|
||||
|
||||
begin
|
||||
Formal := First_Formal (Id);
|
||||
Actual := First_Actual (N);
|
||||
while Present (Actual) and then Present (Formal) loop
|
||||
if Ekind_In (Formal, E_Out_Parameter,
|
||||
E_In_Out_Parameter)
|
||||
then
|
||||
Collect_Identifiers (Actual);
|
||||
end if;
|
||||
|
||||
Next_Formal (Formal);
|
||||
Next_Actual (Actual);
|
||||
end loop;
|
||||
end;
|
||||
|
||||
when N_Aggregate |
|
||||
N_Extension_Aggregate =>
|
||||
declare
|
||||
Assoc : Node_Id;
|
||||
Choice : Node_Id;
|
||||
Comp_Expr : Node_Id;
|
||||
|
||||
begin
|
||||
-- Handle the N_Others_Choice of array aggregates with static
|
||||
-- bounds. There is no need to perform this analysis in
|
||||
-- aggregates without static bounds since we cannot evaluate
|
||||
-- if the N_Others_Choice covers several elements. There is
|
||||
-- no need to handle the N_Others choice of record aggregates
|
||||
-- since at this stage it has been already expanded by
|
||||
-- Resolve_Record_Aggregate.
|
||||
|
||||
if Is_Array_Type (Etype (N))
|
||||
and then Nkind (N) = N_Aggregate
|
||||
and then Present (Aggregate_Bounds (N))
|
||||
and then Compile_Time_Known_Bounds (Etype (N))
|
||||
and then Expr_Value (High_Bound (Aggregate_Bounds (N)))
|
||||
> Expr_Value (Low_Bound (Aggregate_Bounds (N)))
|
||||
then
|
||||
declare
|
||||
Count_Components : Uint := Uint_0;
|
||||
Num_Components : Uint;
|
||||
Others_Assoc : Node_Id;
|
||||
Others_Choice : Node_Id := Empty;
|
||||
Others_Box_Present : Boolean := False;
|
||||
|
||||
begin
|
||||
-- Count positional associations
|
||||
|
||||
if Present (Expressions (N)) then
|
||||
Comp_Expr := First (Expressions (N));
|
||||
while Present (Comp_Expr) loop
|
||||
Count_Components := Count_Components + 1;
|
||||
Next (Comp_Expr);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
-- Count the rest of elements and locate the N_Others
|
||||
-- choice (if any)
|
||||
|
||||
Assoc := First (Component_Associations (N));
|
||||
while Present (Assoc) loop
|
||||
Choice := First (Choices (Assoc));
|
||||
while Present (Choice) loop
|
||||
if Nkind (Choice) = N_Others_Choice then
|
||||
Others_Assoc := Assoc;
|
||||
Others_Choice := Choice;
|
||||
Others_Box_Present := Box_Present (Assoc);
|
||||
|
||||
-- Count several components
|
||||
|
||||
elsif Nkind_In (Choice, N_Range,
|
||||
N_Subtype_Indication)
|
||||
or else (Is_Entity_Name (Choice)
|
||||
and then Is_Type (Entity (Choice)))
|
||||
then
|
||||
declare
|
||||
L, H : Node_Id;
|
||||
begin
|
||||
Get_Index_Bounds (Choice, L, H);
|
||||
pragma Assert
|
||||
(Compile_Time_Known_Value (L)
|
||||
and then Compile_Time_Known_Value (H));
|
||||
Count_Components :=
|
||||
Count_Components
|
||||
+ Expr_Value (H) - Expr_Value (L) + 1;
|
||||
end;
|
||||
|
||||
-- Count single component. No other case available
|
||||
-- since we are handling an aggregate with static
|
||||
-- bounds.
|
||||
|
||||
else
|
||||
pragma Assert (Is_Static_Expression (Choice)
|
||||
or else Nkind (Choice) = N_Identifier
|
||||
or else Nkind (Choice) = N_Integer_Literal);
|
||||
|
||||
Count_Components := Count_Components + 1;
|
||||
end if;
|
||||
|
||||
Next (Choice);
|
||||
end loop;
|
||||
|
||||
Next (Assoc);
|
||||
end loop;
|
||||
|
||||
Num_Components :=
|
||||
Expr_Value (High_Bound (Aggregate_Bounds (N)))
|
||||
- Expr_Value (Low_Bound (Aggregate_Bounds (N)))
|
||||
+ 1;
|
||||
|
||||
pragma Assert (Count_Components <= Num_Components);
|
||||
|
||||
-- Handle the N_Others choice if it covers several
|
||||
-- components
|
||||
|
||||
if Present (Others_Choice)
|
||||
and then (Num_Components - Count_Components) > 1
|
||||
then
|
||||
if not Others_Box_Present then
|
||||
|
||||
-- At this stage, if expansion is active, the
|
||||
-- expression of the others choice has not been
|
||||
-- analyzed. Hence we generate a duplicate and
|
||||
-- we analyze it silently to have available the
|
||||
-- minimum decoration required to collect the
|
||||
-- identifiers.
|
||||
|
||||
if not Expander_Active then
|
||||
Comp_Expr := Expression (Others_Assoc);
|
||||
else
|
||||
Comp_Expr :=
|
||||
New_Copy_Tree (Expression (Others_Assoc));
|
||||
Preanalyze_Without_Errors (Comp_Expr);
|
||||
end if;
|
||||
|
||||
Collect_Identifiers (Comp_Expr);
|
||||
|
||||
if Writable_Actuals_List /= No_Elist then
|
||||
|
||||
-- As suggested by Robert, at current stage we
|
||||
-- report occurrences of this case as warnings.
|
||||
|
||||
Error_Msg_N
|
||||
("conflict of writable function parameter in "
|
||||
& "construct with arbitrary order of "
|
||||
& "evaluation?",
|
||||
Node (First_Elmt (Writable_Actuals_List)));
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
|
||||
-- Handle ancestor part of extension aggregates
|
||||
|
||||
if Nkind (N) = N_Extension_Aggregate then
|
||||
Collect_Identifiers (Ancestor_Part (N));
|
||||
end if;
|
||||
|
||||
-- Handle positional associations
|
||||
|
||||
if Present (Expressions (N)) then
|
||||
Comp_Expr := First (Expressions (N));
|
||||
while Present (Comp_Expr) loop
|
||||
if not Is_Static_Expression (Comp_Expr) then
|
||||
Collect_Identifiers (Comp_Expr);
|
||||
end if;
|
||||
|
||||
Next (Comp_Expr);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
-- Handle discrete associations
|
||||
|
||||
if Present (Component_Associations (N)) then
|
||||
Assoc := First (Component_Associations (N));
|
||||
while Present (Assoc) loop
|
||||
|
||||
if not Box_Present (Assoc) then
|
||||
Choice := First (Choices (Assoc));
|
||||
while Present (Choice) loop
|
||||
|
||||
-- For now we skip discriminants since it requires
|
||||
-- performing the analysis in two phases: first one
|
||||
-- analyzing discriminants and second one analyzing
|
||||
-- the rest of components since discriminants are
|
||||
-- evaluated prior to components: too much extra
|
||||
-- work to detect a corner case???
|
||||
|
||||
if Nkind (Choice) in N_Has_Entity
|
||||
and then Present (Entity (Choice))
|
||||
and then Ekind (Entity (Choice))
|
||||
= E_Discriminant
|
||||
then
|
||||
null;
|
||||
|
||||
elsif Box_Present (Assoc) then
|
||||
null;
|
||||
|
||||
else
|
||||
if not Analyzed (Expression (Assoc)) then
|
||||
Comp_Expr :=
|
||||
New_Copy_Tree (Expression (Assoc));
|
||||
Preanalyze_Without_Errors (Comp_Expr);
|
||||
else
|
||||
Comp_Expr := Expression (Assoc);
|
||||
end if;
|
||||
|
||||
Collect_Identifiers (Comp_Expr);
|
||||
end if;
|
||||
|
||||
Next (Choice);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
Next (Assoc);
|
||||
end loop;
|
||||
end if;
|
||||
end;
|
||||
|
||||
when others =>
|
||||
return;
|
||||
end case;
|
||||
|
||||
-- No further action needed if we already reported an error
|
||||
|
||||
if Present (Error_Node) then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Check if some writable argument of a function is referenced
|
||||
|
||||
if Writable_Actuals_List /= No_Elist
|
||||
and then Identifiers_List /= No_Elist
|
||||
then
|
||||
declare
|
||||
Elmt_1 : Elmt_Id;
|
||||
Elmt_2 : Elmt_Id;
|
||||
|
||||
begin
|
||||
Elmt_1 := First_Elmt (Writable_Actuals_List);
|
||||
while Present (Elmt_1) loop
|
||||
Elmt_2 := First_Elmt (Identifiers_List);
|
||||
while Present (Elmt_2) loop
|
||||
if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then
|
||||
Error_Msg_N
|
||||
("conflict of writable function parameter in construct "
|
||||
& "with arbitrary order of evaluation",
|
||||
Node (Elmt_1));
|
||||
end if;
|
||||
|
||||
Next_Elmt (Elmt_2);
|
||||
end loop;
|
||||
|
||||
Next_Elmt (Elmt_1);
|
||||
end loop;
|
||||
end;
|
||||
end if;
|
||||
end Check_Function_Writable_Actuals;
|
||||
|
||||
--------------------------------
|
||||
-- Check_Implicit_Dereference --
|
||||
--------------------------------
|
||||
@ -1529,65 +2088,6 @@ package body Sem_Util is
|
||||
end if;
|
||||
end Check_Nested_Access;
|
||||
|
||||
----------------------------
|
||||
-- Check_Order_Dependence --
|
||||
----------------------------
|
||||
|
||||
procedure Check_Order_Dependence is
|
||||
Act1 : Node_Id;
|
||||
Act2 : Node_Id;
|
||||
|
||||
begin
|
||||
if Ada_Version < Ada_2012 then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Ada 2012 AI05-0144-2: Dangerous order dependence. Actuals in nested
|
||||
-- calls within a construct have been collected. If one of them is
|
||||
-- writable and overlaps with another one, evaluation of the enclosing
|
||||
-- construct is nondeterministic. This is illegal in Ada 2012, but is
|
||||
-- treated as a warning for now.
|
||||
|
||||
for J in 1 .. Actuals_In_Call.Last loop
|
||||
if Actuals_In_Call.Table (J).Is_Writable then
|
||||
Act1 := Actuals_In_Call.Table (J).Act;
|
||||
|
||||
if Nkind (Act1) = N_Attribute_Reference then
|
||||
Act1 := Prefix (Act1);
|
||||
end if;
|
||||
|
||||
for K in 1 .. Actuals_In_Call.Last loop
|
||||
if K /= J then
|
||||
Act2 := Actuals_In_Call.Table (K).Act;
|
||||
|
||||
if Nkind (Act2) = N_Attribute_Reference then
|
||||
Act2 := Prefix (Act2);
|
||||
end if;
|
||||
|
||||
if Actuals_In_Call.Table (K).Is_Writable
|
||||
and then K < J
|
||||
then
|
||||
-- Already checked
|
||||
|
||||
null;
|
||||
|
||||
elsif Denotes_Same_Object (Act1, Act2)
|
||||
and then Parent (Act1) /= Parent (Act2)
|
||||
then
|
||||
Error_Msg_N
|
||||
("result may differ if evaluated "
|
||||
& "after other actual in expression??", Act1);
|
||||
end if;
|
||||
end if;
|
||||
end loop;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
-- Remove checked actuals from table
|
||||
|
||||
Actuals_In_Call.Set_Last (0);
|
||||
end Check_Order_Dependence;
|
||||
|
||||
------------------------------------------
|
||||
-- Check_Potentially_Blocking_Operation --
|
||||
------------------------------------------
|
||||
@ -12595,35 +13095,6 @@ package body Sem_Util is
|
||||
end if;
|
||||
end Same_Value;
|
||||
|
||||
-----------------
|
||||
-- Save_Actual --
|
||||
-----------------
|
||||
|
||||
procedure Save_Actual (N : Node_Id; Writable : Boolean := False) is
|
||||
begin
|
||||
if Ada_Version < Ada_2012 then
|
||||
return;
|
||||
|
||||
elsif Is_Entity_Name (N)
|
||||
or else
|
||||
Nkind_In (N, N_Indexed_Component, N_Selected_Component, N_Slice)
|
||||
or else
|
||||
(Nkind (N) = N_Attribute_Reference
|
||||
and then Attribute_Name (N) = Name_Access)
|
||||
|
||||
then
|
||||
-- We are only interested in IN OUT parameters of inner calls
|
||||
|
||||
if not Writable
|
||||
or else Nkind (Parent (N)) = N_Function_Call
|
||||
or else Nkind (Parent (N)) in N_Op
|
||||
then
|
||||
Actuals_In_Call.Increment_Last;
|
||||
Actuals_In_Call.Table (Actuals_In_Call.Last) := (N, Writable);
|
||||
end if;
|
||||
end if;
|
||||
end Save_Actual;
|
||||
|
||||
------------------------
|
||||
-- Scope_Is_Transient --
|
||||
------------------------
|
||||
|
||||
@ -178,6 +178,17 @@ package Sem_Util is
|
||||
-- not necessarily mean that CE could be raised, but a response of True
|
||||
-- means that for sure CE cannot be raised.
|
||||
|
||||
procedure Check_Function_Writable_Actuals (N : Node_Id);
|
||||
-- (Ada 2012): If the construct N has two or more direct constituents that
|
||||
-- are names or expressions whose evaluation may occur in an arbitrary
|
||||
-- order, at least one of which contains a function call with an in out or
|
||||
-- out parameter, then the construct is legal only if: for each name that
|
||||
-- is passed as a parameter of mode in out or out to some inner function
|
||||
-- call C2 (not including the construct N itself), there is no other name
|
||||
-- anywhere within a direct constituent of the construct C other than
|
||||
-- the one containing C2, that is known to refer to the same object (RM
|
||||
-- 6.4.1(6.17/3)).
|
||||
|
||||
procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id);
|
||||
-- AI05-139-2: Accessors and iterators for containers. This procedure
|
||||
-- checks whether T is a reference type, and if so it adds an interprettion
|
||||
@ -215,11 +226,6 @@ package Sem_Util is
|
||||
-- is accessed inside a nested procedure, and set Has_Up_Level_Access flag
|
||||
-- accordingly. This is currently only enabled for VM_Target /= No_VM.
|
||||
|
||||
procedure Check_Order_Dependence;
|
||||
-- Examine the actuals in a top-level call to determine whether aliasing
|
||||
-- between two actuals, one of which is writable, can make the call
|
||||
-- order-dependent.
|
||||
|
||||
procedure Check_Potentially_Blocking_Operation (N : Node_Id);
|
||||
-- N is one of the statement forms that is a potentially blocking
|
||||
-- operation. If it appears within a protected action, emit warning.
|
||||
@ -1404,11 +1410,6 @@ package Sem_Util is
|
||||
-- are only partially ordered, so Scope_Within_Or_Same (A,B) and
|
||||
-- Scope_Within_Or_Same (B,A) can both be False for a given pair A,B.
|
||||
|
||||
procedure Save_Actual (N : Node_Id; Writable : Boolean := False);
|
||||
-- Enter an actual in a call in a table global, for subsequent check of
|
||||
-- possible order dependence in the presence of IN OUT parameters for
|
||||
-- functions in Ada 2012 (or access parameters in older language versions).
|
||||
|
||||
function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean;
|
||||
-- Like Scope_Within_Or_Same, except that this function returns
|
||||
-- False in the case where Scope1 and Scope2 are the same scope.
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2013, 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- --
|
||||
@ -502,8 +502,8 @@ begin
|
||||
Write_Line (" .H* turn off warnings for holes in records");
|
||||
Write_Line (" i*+ turn on warnings for implementation unit");
|
||||
Write_Line (" I turn off warnings for implementation unit");
|
||||
Write_Line (" .i turn on warnings for overlapping actuals");
|
||||
Write_Line (" .I* turn off warnings for overlapping actuals");
|
||||
Write_Line (" .i*+ turn on warnings for overlapping actuals");
|
||||
Write_Line (" .I turn off warnings for overlapping actuals");
|
||||
Write_Line (" j+ turn on warnings for obsolescent " &
|
||||
"(annex J) feature");
|
||||
Write_Line (" J* turn off warnings for obsolescent " &
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1999-2012, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1999-2013, 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- --
|
||||
@ -292,6 +292,7 @@ package body Warnsw is
|
||||
Warn_On_Non_Local_Exception := True;
|
||||
Warn_On_Object_Renames_Function := True;
|
||||
Warn_On_Obsolescent_Feature := True;
|
||||
Warn_On_Overlap := True;
|
||||
Warn_On_Parameter_Order := True;
|
||||
Warn_On_Questionable_Missing_Parens := True;
|
||||
Warn_On_Redundant_Constructs := True;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user