OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2009-10-27  Robert Dewar  <dewar@adacore.com>

	* s-os_lib.ads, s-os_lib.adb, prj-err.adb, makeutl.adb: Minor
	reformatting.

2009-10-27  Ed Schonberg  <schonberg@adacore.com>

	* sem.util.ads, sem_util.adb (Denotes_Same_Object,
	Denotes_Same_Prefix): New functions to detect overlap between actuals
	that are not by-copy in a call, when one of them is in-out.
	* sem_warn.ads, sem_warn.adb (Warn_On_Overlapping_Actuals): New
	procedure,  called on a subprogram call to warn when an in-out actual
	that is not by-copy overlaps with another actual, thus leadind to
	potentially dangerous aliasing in the body of the called subprogram.
	Currently the warning is under control of the -gnatX switch.
	* sem_res.adb (resolve_call): call Warn_On_Overlapping_Actuals.

From-SVN: r153594
This commit is contained in:
Arnaud Charlet 2009-10-27 14:51:46 +01:00
parent 0c0c6f49d5
commit 76b84bf03f
10 changed files with 345 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
gcc/ada/ChangeLog
View File

@ -1,3 +1,20 @@
2009-10-27 Robert Dewar <dewar@adacore.com>
* s-os_lib.ads, s-os_lib.adb, prj-err.adb, makeutl.adb: Minor
reformatting.
2009-10-27 Ed Schonberg <schonberg@adacore.com>
* sem.util.ads, sem_util.adb (Denotes_Same_Object,
Denotes_Same_Prefix): New functions to detect overlap between actuals
that are not by-copy in a call, when one of them is in-out.
* sem_warn.ads, sem_warn.adb (Warn_On_Overlapping_Actuals): New
procedure, called on a subprogram call to warn when an in-out actual
that is not by-copy overlaps with another actual, thus leadind to
potentially dangerous aliasing in the body of the called subprogram.
Currently the warning is under control of the -gnatX switch.
* sem_res.adb (resolve_call): call Warn_On_Overlapping_Actuals.
2009-10-27 Thomas Quinot <quinot@adacore.com>
* sem_ch12.adb (Install_Formal_Packages): Do not omit installation of

11
gcc/ada/makeutl.adb
View File

@ -220,9 +220,9 @@ package body Makeutl is
-- (and then will be for the same unit).
if Find_Source
(In_Tree => Project_Tree,
Project => No_Project,
Base_Name => SD.Sfile) = No_Source
(In_Tree => Project_Tree,
Project => No_Project,
Base_Name => SD.Sfile) = No_Source
then
-- If this is not a runtime file or if, when gnatmake switch
-- -a is used, we are not able to find this subunit in the
@ -230,8 +230,8 @@ package body Makeutl is
if not Fname.Is_Internal_File_Name (SD.Sfile)
or else
(Check_Readonly_Files and then
Find_File (SD.Sfile, Osint.Source) = No_File)
(Check_Readonly_Files
and then Find_File (SD.Sfile, Osint.Source) = No_File)
then
if Verbose_Mode then
Write_Line
@ -242,6 +242,7 @@ package body Makeutl is
& " but this does not match what was found while"
& " parsing the project. Will recompile");
end if;
return False;
end if;
end if;

17
gcc/ada/prj-err.adb
View File

@ -24,8 +24,8 @@
------------------------------------------------------------------------------
with Err_Vars;
with Output; use Output;
with Stringt; use Stringt;
with Output; use Output;
with Stringt; use Stringt;
package body Prj.Err is
@ -118,12 +118,13 @@ package body Prj.Err is
if Flags.Report_Error /= null then
Flags.Report_Error
(Project,
Is_Warning => Msg (Msg'First) = '?'
or else (Msg (Msg'First) = '<'
and then Err_Vars.Error_Msg_Warn)
or else (Msg (Msg'First) = '\'
and then Msg (Msg'First + 1) = '<'
and then Err_Vars.Error_Msg_Warn));
Is_Warning =>
Msg (Msg'First) = '?'
or else (Msg (Msg'First) = '<'
and then Err_Vars.Error_Msg_Warn)
or else (Msg (Msg'First) = '\'
and then Msg (Msg'First + 1) = '<'
and then Err_Vars.Error_Msg_Warn));
end if;
end Error_Msg;

10
gcc/ada/s-os_lib.adb
View File

@ -77,13 +77,13 @@ package body System.OS_Lib is
-----------------------
function Args_Length (Args : Argument_List) return Natural;
-- Returns total number of characters needed to create a string
-- of all Args terminated by ASCII.NUL characters
-- Returns total number of characters needed to create a string of all Args
-- terminated by ASCII.NUL characters.
procedure Create_Temp_File_Internal
(FD : out File_Descriptor;
Name : out String_Access;
Stdout : Boolean);
(FD : out File_Descriptor;
Name : out String_Access;
Stdout : Boolean);
-- Internal routine to implement two Create_Temp_File routines. If Stdout
-- is set to True the created descriptor is stdout-compatible, otherwise
-- it might not be depending on the OS (VMS is one example). The first two

13
gcc/ada/s-os_lib.ads
View File

@ -257,15 +257,14 @@ package System.OS_Lib is
-- temp files at the same time in the same directory.
procedure Create_Temp_Output_File
(FD : out File_Descriptor;
Name : out String_Access);
(FD : out File_Descriptor;
Name : out String_Access);
-- Create and open for writing a temporary file in the current working
-- directory suitable to redirect standard output. The name of the file
-- and the File Descriptor are returned.
-- It is the responsibility of the caller to deallocate the access value
-- returned in Name.
-- directory suitable to redirect standard output. The name of the file and
-- the File Descriptor are returned. It is the responsibility of the caller
-- to deallocate the access value returned in Name.
--
-- The file is opened in text mode.
-- The file is opened in text mode
--
-- This procedure will always succeed if the current working directory is
-- writable. If the current working directory is not writable, then

7
gcc/ada/sem_res.adb
View File

@ -2935,10 +2935,8 @@ package body Sem_Res is
-- anomalies: the subtype was first built in the subprogram
-- declaration, and the current call may be nested.
if Nkind (Actval) = N_Aggregate
and then Has_Discriminants (Etype (Actval))
then
Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
if Nkind (Actval) = N_Aggregate then
Analyze_And_Resolve (Actval, Etype (F));
else
Analyze_And_Resolve (Actval, Etype (Actval));
end if;
@ -5390,6 +5388,7 @@ package body Sem_Res is
Eval_Call (N);
Check_Elab_Call (N);
Warn_On_Overlapping_Actuals (Nam, N);
end Resolve_Call;
-------------------------------

158
gcc/ada/sem_util.adb
View File

@ -2137,6 +2137,164 @@ package body Sem_Util is
end Denotes_Discriminant;
-------------------------
-- Denotes_Same_Object --
-------------------------
function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
begin
if Is_Entity_Name (A1) then
if Is_Entity_Name (A2)then
return Entity (A1) = Entity (A2);
else
return False;
end if;
elsif Nkind (A1) /= Nkind (A2) then
return False;
elsif Nkind (A1) = N_Selected_Component then
return Denotes_Same_Object (Prefix (A1), Prefix (A2))
and then
Entity (Selector_Name (A1)) = Entity (Selector_Name (A2));
elsif Nkind (A1) = N_Explicit_Dereference then
return Denotes_Same_Object (Prefix (A1), Prefix (A2));
elsif Nkind (A1) = N_Indexed_Component then
if Denotes_Same_Object (Prefix (A1), Prefix (A2)) then
declare
Indx1 : Node_Id;
Indx2 : Node_Id;
begin
Indx1 := First (Expressions (A1));
Indx2 := First (Expressions (A2));
while Present (Indx1) loop
if not Denotes_Same_Object (Indx1, Indx2) then
return False;
end if;
Next (Indx1);
Next (Indx2);
end loop;
return True;
end;
else
return False;
end if;
elsif Nkind (A1) = N_Slice
and then Denotes_Same_Object (Prefix (A1), Prefix (A2))
then
declare
Lo1, Lo2, Hi1, Hi2 : Node_Id;
begin
Get_Index_Bounds (Etype (A1), Lo1, Hi1);
Get_Index_Bounds (Etype (A2), Lo2, Hi2);
-- Check whether bounds are statically identical
-- No attempt to detect partial overlap of slices.
return Denotes_Same_Object (Lo1, Lo2)
and then Denotes_Same_Object (Hi1, Hi2);
end;
-- Literals will appear as indices.
elsif Nkind (A1) = N_Integer_Literal then
return Intval (A1) = Intval (A2);
else
return False;
end if;
end Denotes_Same_Object;
-------------------------
-- Denotes_Same_Prefix --
-------------------------
function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
begin
if Is_Entity_Name (A1) then
if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) then
return Denotes_Same_Object (A1, Prefix (A2))
or else Denotes_Same_Prefix (A1, Prefix (A2));
else
return False;
end if;
elsif Is_Entity_Name (A2) then
return Denotes_Same_Prefix (A2, A1);
elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
and then
Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
then
declare
Root1, Root2 : Node_Id;
Depth1, Depth2 : Int := 0;
begin
Root1 := Prefix (A1);
while not Is_Entity_Name (Root1) loop
if not Nkind_In
(Root1, N_Selected_Component, N_Indexed_Component)
then
return False;
else
Root1 := Prefix (Root1);
end if;
Depth1 := Depth1 + 1;
end loop;
Root2 := Prefix (A2);
while not Is_Entity_Name (Root2) loop
if not Nkind_In
(Root2, N_Selected_Component, N_Indexed_Component)
then
return False;
else
Root2 := Prefix (Root2);
end if;
Depth2 := Depth2 + 1;
end loop;
-- If both have the same depth and they do not denote the same
-- object, they are disjoint and not warning is needed.
if Depth1 = Depth2 then
return False;
elsif Depth1 > Depth2 then
Root1 := Prefix (A1);
for I in 1 .. Depth1 - Depth2 - 1 loop
Root1 := Prefix (Root1);
end loop;
return Denotes_Same_Object (Root1, A2);
else
Root2 := Prefix (A2);
for I in 1 .. Depth2 - Depth1 - 1 loop
Root2 := Prefix (Root2);
end loop;
return Denotes_Same_Object (A1, Root2);
end if;
end;
else
return False;
end if;
end Denotes_Same_Prefix;
----------------------
-- Denotes_Variable --
----------------------

6
gcc/ada/sem_util.ads
View File

@ -251,6 +251,12 @@ package Sem_Util is
-- components of protected types, and constraint checks on entry
-- families constrained by discriminants.
function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean;
function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean;
-- Functions to detect suspicious overlapping between actuals in a call,
-- when one of them is writable. The predicates are those proposed in
-- AI05-0144, to detect dangerous order dependence in complex calls.
function Denotes_Variable (N : Node_Id) return Boolean;
-- Returns True if node N denotes a single variable without parentheses

130
gcc/ada/sem_warn.adb
View File

@ -3535,6 +3535,136 @@ package body Sem_Warn is
or else Warn_On_All_Unread_Out_Parameters;
end Warn_On_Modified_As_Out_Parameter;
---------------------------------
-- Warn_On_Overlapping_Actuals --
---------------------------------
procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id) is
Act1, Act2 : Node_Id;
Form1, Form2 : Entity_Id;
begin
-- For now, treat this warning as an extension.
if not Extensions_Allowed then
return;
end if;
-- Exclude calls rewritten as enumeration literals
if not Nkind_In
(N, N_Function_Call, N_Procedure_Call_Statement)
then
return;
end if;
-- Exclude calls to library subprograms. Container operations
-- specify safe behavior when source and target coincide.
if Is_Predefined_File_Name (
Unit_File_Name (Get_Source_Unit (Sloc (Subp))))
then
return;
end if;
Form1 := First_Formal (Subp);
Act1 := First_Actual (N);
while Present (Form1) and then Present (Act1) loop
if Ekind (Form1) = E_In_Out_Parameter then
Form2 := First_Formal (Subp);
Act2 := First_Actual (N);
while Present (Form2) and then Present (Act2) loop
if Form1 /= Form2
and then Ekind (Form2) /= E_Out_Parameter
and then
(Denotes_Same_Object (Act1, Act2)
or else Denotes_Same_Prefix (Act1, Act2))
then
-- Exclude generic types and guard against previous errors.
-- If either type is elementary the aliasing is harmless
if Error_Posted (N)
or else No (Etype (Act1))
or else No (Etype (Act2))
then
null;
elsif Is_Generic_Type (Etype (Act1))
or else Is_Generic_Type (Etype (Act2))
then
null;
-- If the actual is a function call in prefix notation,
-- there is no real overlap.
elsif Nkind (Act2) = N_Function_Call then
null;
elsif Is_Elementary_Type (Underlying_Type (Etype (Form1)))
or else
Is_Elementary_Type (Underlying_Type (Etype (Form2)))
then
null;
else
declare
Act : Node_Id;
Form : Entity_Id;
begin
Act := First_Actual (N);
Form := First_Formal (Subp);
while Act /= Act2 loop
Next_Formal (Form);
Next_Actual (Act);
end loop;
-- If the call was written in prefix notation, count
-- only the visible actuals in the call.
if Is_Entity_Name (First_Actual (N))
and then Nkind (Original_Node (N)) = Nkind (N)
and then
Nkind (Name (Original_Node (N))) =
N_Selected_Component
and then
Is_Entity_Name (Prefix (Name (Original_Node (N))))
and then
Entity (Prefix (Name (Original_Node (N)))) =
Entity (First_Actual (N))
then
if Act1 = First_Actual (N) then
Error_Msg_FE
("in-out prefix overlaps with actual for&?",
Act1, Form);
else
Error_Msg_FE
("writable actual overlaps with actual for&?",
Act1, Form);
end if;
else
Error_Msg_FE
("writable actual overlaps with actual for&?",
Act1, Form);
end if;
end;
end if;
return;
end if;
Next_Formal (Form2);
Next_Actual (Act2);
end loop;
end if;
Next_Formal (Form1);
Next_Actual (Act1);
end loop;
end Warn_On_Overlapping_Actuals;
------------------------------
-- Warn_On_Suspicious_Index --
------------------------------

5
gcc/ada/sem_warn.ads
View File

@ -210,6 +210,11 @@ package Sem_Warn is
-- as an out parameter. True if either Warn_On_Modified_Unread is set for
-- an only OUT parameter, or if Warn_On_All_Unread_Out_Parameters is set.
procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id);
-- Called on a subprogram call. Checks whether an in-out actual that is
-- not by-copy may overlap with another actual, thus leadind to aliasing
-- in the body of the called subprogram.
procedure Warn_On_Suspicious_Index (Name : Entity_Id; X : Node_Id);
-- This is called after resolving an indexed component or a slice. Name
-- is the entity for the name of the indexed array, and X is the subscript