From: Arnaud Charlet Date: Tue, 25 Apr 2017 10:26:52 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=94295b259310bb5a7a156f799cfc84e0eebbccdc;p=gcc.git [multiple changes] 2017-04-25 Hristian Kirtchev * exp_ch7.adb, checks.adb, sem_prag.adb, eval_fat.adb: Minor reformatting. 2017-04-25 Bob Duff * binde.adb (Validate): Do not pass dynamic strings to pragma Assert, because older compilers do not support that. 2017-04-25 Bob Duff * 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 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a3ceadb3204..d33d7b6ed00 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,27 @@ +2017-04-25 Hristian Kirtchev + + * exp_ch7.adb, checks.adb, sem_prag.adb, eval_fat.adb: Minor + reformatting. + +2017-04-25 Bob Duff + + * binde.adb (Validate): Do not pass dynamic strings + to pragma Assert, because older compilers do not support that. + +2017-04-25 Bob Duff + + * 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 * checks.adb (Insert_Valid_Check): Do not generate diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb index 2becc1b43b1..58bf4fa15e7 100644 --- a/gcc/ada/binde.adb +++ b/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; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 61fb006f1ff..b839863e5c2 100644 --- a/gcc/ada/checks.adb +++ b/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)); diff --git a/gcc/ada/eval_fat.adb b/gcc/ada/eval_fat.adb index 394098ad7a1..7cb3a3c0053 100644 --- a/gcc/ada/eval_fat.adb +++ b/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 diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 4febff09c48..56414e00a62 100644 --- a/gcc/ada/exp_ch7.adb +++ b/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; diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index 9c27a0e9072..796b0b1d87d 100644 --- a/gcc/ada/s-fileio.adb +++ b/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,16 +350,20 @@ 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 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; @@ -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; ------------------------ diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index f549198c126..f727c7a232b 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -4243,35 +4243,34 @@ 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); 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; @@ -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,11 +4423,11 @@ 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 + -- instance it may not override any visible operations, but -- still have a parent operation that carries a precondition. elsif In_Instance @@ -4439,7 +4440,7 @@ package body Sem_Prag is 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;