+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
-- (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
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
& " but this does not match what was found while"
& " parsing the project. Will recompile");
end if;
+
return False;
end if;
end if;
------------------------------------------------------------------------------
with Err_Vars;
-with Output; use Output;
-with Stringt; use Stringt;
+with Output; use Output;
+with Stringt; use Stringt;
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;
-----------------------
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
-- 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
-- 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;
Eval_Call (N);
Check_Elab_Call (N);
+ Warn_On_Overlapping_Actuals (Nam, N);
end Resolve_Call;
-------------------------------
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 --
----------------------
-- 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
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 --
------------------------------
-- 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
projects / thirdparty / gcc.git / commitdiff
