[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

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,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;
 
    ------------------------

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;