Skip to content

R
riscv-gcc-1
Commit 94295b25 by Arnaud Charlet
Options

[multiple changes] 

2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb, checks.adb, sem_prag.adb, eval_fat.adb: Minor
	reformatting.

2017-04-25  Bob Duff  <duff@adacore.com>

	* binde.adb (Validate): Do not pass dynamic strings
	to pragma Assert, because older compilers do not support that.

2017-04-25  Bob Duff  <duff@adacore.com>

	* s-fileio.adb (Close): When a temp file is
	closed, delete it and clean up its Temp_File_Record immediately,
	rather than waiting until later.
	(Temp_File_Record): Add File
	component, so Close can know which Temp_File_Record corresponds
	to the file being closed.
	(Delete): Don't delete temp files,
	because they are deleted by Close.
	(Open): Set the File component
	of Temp_File_Record. This requires moving the creation of the
	Temp_File_Record to the end, after the AFCB has been created.

From-SVN: r247175
parent b0cd50fd
Showing with 136 additions and 60 deletions
gcc/ada/ChangeLog
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb, checks.adb, sem_prag.adb, eval_fat.adb: Minor
reformatting.
2017-04-25 Bob Duff <duff@adacore.com>
* binde.adb (Validate): Do not pass dynamic strings
to pragma Assert, because older compilers do not support that.
2017-04-25 Bob Duff <duff@adacore.com>
* s-fileio.adb (Close): When a temp file is
closed, delete it and clean up its Temp_File_Record immediately,
rather than waiting until later.
(Temp_File_Record): Add File
component, so Close can know which Temp_File_Record corresponds
to the file being closed.
(Delete): Don't delete temp files,
because they are deleted by Close.
(Open): Set the File component
of Temp_File_Record. This requires moving the creation of the
Temp_File_Record to the end, after the AFCB has been created.
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* checks.adb (Insert_Valid_Check): Do not generate
a validity check when inside a generic.
......
gcc/ada/binde.adb
......@@ -2234,10 +2234,13 @@ package body Binde is
begin
while S /= No_Successor loop
pragma Assert
(UNR.Table (Succ.Table (S).After).Elab_Position >
UNR.Table (U).Elab_Position,
Msg & " elab order failed");
if UNR.Table (Succ.Table (S).After).Elab_Position <=
UNR.Table (U).Elab_Position
then
OK := False;
Write_Line (Msg & " elab order failed");
end if;
S := Succ.Table (S).Next;
end loop;
end;
......
gcc/ada/checks.adb
......@@ -2959,23 +2959,23 @@ package body Checks is
and then No (Source_Typ)
then
declare
Tlo : constant Node_Id := Type_Low_Bound (Target_Typ);
Thi : constant Node_Id := Type_High_Bound (Target_Typ);
Tlo : constant Node_Id := Type_Low_Bound (Target_Typ);
begin
if Compile_Time_Known_Value (Tlo)
and then Compile_Time_Known_Value (Thi)
then
declare
Lov : constant Uint := Expr_Value (Tlo);
Hiv : constant Uint := Expr_Value (Thi);
Lo : Uint;
Lov : constant Uint := Expr_Value (Tlo);
Hi : Uint;
Lo : Uint;
begin
-- If range is null, we for sure have a constraint error
-- (we don't even need to look at the value involved,
-- since all possible values will raise CE).
-- If range is null, we for sure have a constraint error (we
-- don't even need to look at the value involved, since all
-- possible values will raise CE).
if Lov > Hiv then
......@@ -2998,8 +2998,8 @@ package body Checks is
-- Otherwise determine range of value
if Is_Discrete_Type (Etype (Expr)) then
Determine_Range (Expr, OK, Lo, Hi,
Assume_Valid => True);
Determine_Range
(Expr, OK, Lo, Hi, Assume_Valid => True);
-- When converting a float to an integer type, determine the
-- range in real first, and then convert the bounds using
......@@ -3013,11 +3013,12 @@ package body Checks is
and then Is_Floating_Point_Type (Etype (Expr))
then
declare
Lor : Ureal;
Hir : Ureal;
Lor : Ureal;
begin
Determine_Range_R (Expr, OK, Lor, Hir,
Assume_Valid => True);
Determine_Range_R
(Expr, OK, Lor, Hir, Assume_Valid => True);
if OK then
Lo := UR_To_Uint (Lor);
......@@ -5111,6 +5112,7 @@ package body Checks is
M2 : constant Ureal := Round_Machine (Lo_Left * Hi_Right);
M3 : constant Ureal := Round_Machine (Hi_Left * Lo_Right);
M4 : constant Ureal := Round_Machine (Hi_Left * Hi_Right);
begin
Lor := UR_Min (UR_Min (M1, M2), UR_Min (M3, M4));
Hir := UR_Max (UR_Max (M1, M2), UR_Max (M3, M4));
......@@ -5195,10 +5197,12 @@ package body Checks is
elsif Is_Discrete_Type (Etype (Expression (N))) then
declare
Lor_Int, Hir_Int : Uint;
Hir_Int : Uint;
Lor_Int : Uint;
begin
Determine_Range (Expression (N), OK1, Lor_Int, Hir_Int,
Assume_Valid);
Determine_Range
(Expression (N), OK1, Lor_Int, Hir_Int, Assume_Valid);
if OK1 then
Lor := Round_Machine (UR_From_Uint (Lor_Int));
......
gcc/ada/eval_fat.adb
......@@ -503,8 +503,9 @@ package body Eval_Fat is
if X_Exp < Emin then
declare
Emin_Den : constant UI := Machine_Emin_Value (RT)
- Machine_Mantissa_Value (RT) + Uint_1;
Emin_Den : constant UI := Machine_Emin_Value (RT) -
Machine_Mantissa_Value (RT) + Uint_1;
begin
-- Do not issue warnings about underflows in GNATprove mode,
-- as calling Machine as part of interval checking may lead
......@@ -516,6 +517,7 @@ package body Eval_Fat is
Error_Msg_N
("floating-point value underflows to -0.0??", Enode);
end if;
return Ureal_M_0;
else
......@@ -523,6 +525,7 @@ package body Eval_Fat is
Error_Msg_N
("floating-point value underflows to 0.0??", Enode);
end if;
return Ureal_0;
end if;
......@@ -553,8 +556,8 @@ package body Eval_Fat is
begin
-- Do not issue warnings about loss of precision in
-- GNATprove mode, as calling Machine as part of
-- interval checking may lead to spurious warnings.
-- GNATprove mode, as calling Machine as part of interval
-- checking may lead to spurious warnings.
if X_Frac_Denorm /= X_Frac then
if not GNATprove_Mode then
......
gcc/ada/exp_ch7.adb
......@@ -787,7 +787,7 @@ package body Exp_Ch7 is
Typ => Typ,
Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
-- Create TSS primitive Finalize_Address (unless CodePeer_Mode).
-- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
if not CodePeer_Mode then
Set_TSS (Typ,
......@@ -3671,7 +3671,7 @@ package body Exp_Ch7 is
Typ => Typ,
Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
-- Create TSS primitive Finalize_Address (unless CodePeer_Mode).
-- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
if not CodePeer_Mode then
Set_TSS (Typ,
......@@ -7801,7 +7801,8 @@ package body Exp_Ch7 is
return;
end if;
-- Don't generate Finalize_Address routine for CodePeer
-- Do not generate Finalize_Address routine for CodePeer
if CodePeer_Mode then
return;
end if;
......
gcc/ada/s-fileio.adb
......@@ -64,19 +64,23 @@ package body System.File_IO is
type Temp_File_Record_Ptr is access all Temp_File_Record;
type Temp_File_Record is record
File : AFCB_Ptr;
Name : String (1 .. max_path_len + 1);
Next : Temp_File_Record_Ptr;
Next : aliased Temp_File_Record_Ptr;
end record;
-- One of these is allocated for each temporary file created
Temp_Files : Temp_File_Record_Ptr;
Temp_Files : aliased Temp_File_Record_Ptr;
-- Points to list of names of temporary files. Note that this global
-- variable must be properly protected to provide thread safety.
procedure Free is new Ada.Unchecked_Deallocation
(Temp_File_Record, Temp_File_Record_Ptr);
type File_IO_Clean_Up_Type is new Limited_Controlled with null record;
-- The closing of all open files and deletion of temporary files is an
-- action that takes place at the end of execution of the main program.
-- This action is implemented using a library level object which gets
-- This action is implemented using a library level object that gets
-- finalized at the end of program execution. Note that the type is
-- limited, in order to stop the compiler optimizing away the declaration
-- which would be allowed in the non-limited case.
......@@ -221,7 +225,8 @@ package body System.File_IO is
File : AFCB_Ptr renames File_Ptr.all;
begin
-- Take a task lock, to protect the global data value Open_Files
-- Take a task lock, to protect the global variables Open_Files and
-- Temp_Files, and the chains they point to.
SSL.Lock_Task.all;
......@@ -279,6 +284,32 @@ package body System.File_IO is
File.Next.Prev := File.Prev;
end if;
-- If it's a temp file, remove the corresponding record from Temp_Files,
-- and delete the file. There are unlikely to be large numbers of temp
-- files open, so a linear search is sufficiently efficient. Note that
-- we don't need to check for end of list, because the file must be
-- somewhere on the list. Note that as for Finalize, we ignore any
-- errors while attempting the unlink operation.
if File.Is_Temporary_File then
declare
Temp : access Temp_File_Record_Ptr := Temp_Files'Access;
-- Note the double indirection here
New_Temp : Temp_File_Record_Ptr;
Discard : int;
begin
while Temp.all.all.File /= File loop
Temp := Temp.all.all.Next'Access;
end loop;
Discard := unlink (Temp.all.all.Name'Address);
New_Temp := Temp.all.all.Next;
Free (Temp.all);
Temp.all := New_Temp;
end;
end if;
-- Deallocate some parts of the file structure that were kept in heap
-- storage with the exception of system files (standard input, output
-- and error) since they had some information allocated in the stack.
......@@ -319,17 +350,21 @@ package body System.File_IO is
declare
Filename : aliased constant String := File.Name.all;
Is_Temporary_File : constant Boolean := File.Is_Temporary_File;
begin
Close (File_Ptr);
-- Now unlink the external file. Note that we use the full name in
-- this unlink, because the working directory may have changed since
-- we did the open, and we want to unlink the right file.
-- we did the open, and we want to unlink the right file. However, if
-- it's a temporary file, then closing it already unlinked it.
if not Is_Temporary_File then
if unlink (Filename'Address) = -1 then
raise Use_Error with OS_Lib.Errno_Message;
end if;
end if;
end;
end Delete;
......@@ -386,7 +421,7 @@ package body System.File_IO is
SSL.Lock_Task.all;
-- First close all open files (the slightly complex form of this loop is
-- required because Close as a side effect nulls out its argument).
-- required because Close nulls out its argument).
Fptr1 := Open_Files;
while Fptr1 /= null loop
......@@ -766,8 +801,9 @@ package body System.File_IO is
Text_Encoding : Content_Encoding;
Tempfile : constant Boolean := (Name'Length = 0);
-- Indicates temporary file case
Tempfile : constant Boolean := Name = "";
-- Indicates temporary file case, which is indicated by an empty file
-- name.
Namelen : constant Integer := max_path_len;
-- Length required for file name, not including final ASCII.NUL.
......@@ -936,21 +972,7 @@ package body System.File_IO is
raise Use_Error with "invalid temp file name";
end if;
-- Chain to temp file list, ensuring thread safety with a lock
begin
SSL.Lock_Task.all;
Temp_Files :=
new Temp_File_Record'(Name => Namestr, Next => Temp_Files);
SSL.Unlock_Task.all;
exception
when others =>
SSL.Unlock_Task.all;
raise;
end;
-- Normal case of non-null name given
-- Normal case of non-empty name given (i.e. not a temp file)
else
if Name'Length > Namelen then
......@@ -1024,6 +1046,7 @@ package body System.File_IO is
Stream := P.Stream;
Record_AFCB;
pragma Assert (not Tempfile);
exit;
......@@ -1124,6 +1147,23 @@ package body System.File_IO is
-- heap and fill in its fields.
Record_AFCB;
if Tempfile then
-- Chain to temp file list, ensuring thread safety with a lock
begin
SSL.Lock_Task.all;
Temp_Files :=
new Temp_File_Record'
(File => File_Ptr, Name => Namestr, Next => Temp_Files);
SSL.Unlock_Task.all;
exception
when others =>
SSL.Unlock_Task.all;
raise;
end;
end if;
end Open;
------------------------
......
gcc/ada/sem_prag.adb
......@@ -4243,28 +4243,27 @@ package body Sem_Prag is
Prev := Overridden_Operation (Prev);
end loop;
-- If the controlling type of the subprogram has progenitors,
-- an interface operation implemented by the current operation
-- may have a class-wide precondition.
-- If the controlling type of the subprogram has progenitors, an
-- interface operation implemented by the current operation may
-- have a class-wide precondition.
Typ := Find_Dispatching_Type (E);
if Has_Interfaces (Typ) then
declare
Ints : Elist_Id;
Elmt : Elmt_Id;
Prim_List : Elist_Id;
Prim_Elmt : Elmt_Id;
Ints : Elist_Id;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
Prim_List : Elist_Id;
begin
Collect_Interfaces (Typ, Ints);
Elmt := First_Elmt (Ints);
-- Iterate over the primitive operations of each
-- interface.
-- Iterate over the primitive operations of each interface
while Present (Elmt) loop
Prim_List :=
(Direct_Primitive_Operations (Node (Elmt)));
Prim_List := Direct_Primitive_Operations (Node (Elmt));
Prim_Elmt := First_Elmt (Prim_List);
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
......@@ -4287,6 +4286,8 @@ package body Sem_Prag is
return False;
end Inherits_Class_Wide_Pre;
-- Start of processing for Analyze_Pre_Post_Condition
begin
-- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
-- offer uniformity among the various kinds of pre/postconditions by
......@@ -4422,8 +4423,8 @@ package body Sem_Prag is
and then not Inherits_Class_Wide_Pre (E)
then
Error_Msg_N
("illegal class-wide precondition on overriding "
& "operation", Corresponding_Aspect (N));
("illegal class-wide precondition on overriding operation",
Corresponding_Aspect (N));
-- If the operation is declared in the private part of an
-- instance it may not override any visible operations, but
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment