+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
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;
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
-- 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
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);
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));
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));
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
Error_Msg_N
("floating-point value underflows to -0.0??", Enode);
end if;
+
return Ureal_M_0;
else
Error_Msg_N
("floating-point value underflows to 0.0??", Enode);
end if;
+
return Ureal_0;
end if;
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
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,
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,
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;
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.
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;
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.
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 unlink (Filename'Address) = -1 then
- raise Use_Error with OS_Lib.Errno_Message;
+ 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;
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
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.
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
Stream := P.Stream;
Record_AFCB;
+ pragma Assert (not Tempfile);
exit;
-- 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;
------------------------
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);
if Chars (Prim) = Chars (E)
and then Present (Contract (Prim))
and then Class_Present
- (Pre_Post_Conditions (Contract (Prim)))
+ (Pre_Post_Conditions (Contract (Prim)))
then
return True;
end if;
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
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
+ -- instance it may not override any visible operations, but
-- still have a parent operation that carries a precondition.
elsif In_Instance
then
Error_Msg_N
("illegal class-wide precondition on overriding "
- & "operation in instance", Corresponding_Aspect (N));
+ & "operation in instance", Corresponding_Aspect (N));
end if;
end;
projects / gcc.git / commitdiff