[multiple changes]

2017-04-25  Ed Schonberg  <schonberg@adacore.com>

	* sem_prag.adb (Inherits_Class_Wide_Pre): Cleanup code, handle
	properly type derived from generic formal types, to handle
	properly modified version of ACATS 4.1B B611017.

2017-04-25  Javier Miranda  <miranda@adacore.com>

	* exp_unst.adb (Subp_Index): Adding missing
	support for renamings and functions that return a constrained
	array type (i.e. functions for which the frontend built a
	procedure with an extra out parameter).

2017-04-25  Pascal Obry  <obry@adacore.com>

	* s-string.adb: Minor code clean-up.

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

	* s-os_lib.ads, s-os_lib.adb (Non_Blocking_Wait_Process): New
	procedure.
	* adaint.h, adaint.c (__gnat_portable_no_block_wait): C support
	function for Non_Blocking_Wait_Process.

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

	* prep.adb (Preprocess): Remove incorrect
	Assert. Current character can be ASCII.CR.

From-SVN: r247177

9 files changed, 110 insertions, 29 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 3d5423c..4ed0c74 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,34 @@
 2017-04-25  Ed Schonberg  <schonberg@adacore.com>
 
+	* sem_prag.adb (Inherits_Class_Wide_Pre): Cleanup code, handle
+	properly type derived from generic formal types, to handle
+	properly modified version of ACATS 4.1B B611017.
+
+2017-04-25  Javier Miranda  <miranda@adacore.com>
+
+	* exp_unst.adb (Subp_Index): Adding missing
+	support for renamings and functions that return a constrained
+	array type (i.e. functions for which the frontend built a
+	procedure with an extra out parameter).
+
+2017-04-25  Pascal Obry  <obry@adacore.com>
+
+	* s-string.adb: Minor code clean-up.
+
+2017-04-25  Bob Duff  <duff@adacore.com>
+
+	* s-os_lib.ads, s-os_lib.adb (Non_Blocking_Wait_Process): New
+	procedure.
+	* adaint.h, adaint.c (__gnat_portable_no_block_wait): C support
+	function for Non_Blocking_Wait_Process.
+
+2017-04-25  Bob Duff  <duff@adacore.com>
+
+	* prep.adb (Preprocess): Remove incorrect
+	Assert. Current character can be ASCII.CR.
+
+2017-04-25  Ed Schonberg  <schonberg@adacore.com>
+
 	* sem_prag.adb (Set_Convention_From_Pragma): Cleanup code for
 	convention Stdcall, which has a number of exceptions. Convention
 	is legal on a component declaration whose type is an anonymous
diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c
index bff875a..5cc84ca 100644
--- a/gcc/ada/adaint.c
+++ b/gcc/ada/adaint.c
@@ -2315,7 +2315,7 @@ __gnat_dup2 (int oldfd ATTRIBUTE_UNUSED, int newfd ATTRIBUTE_UNUSED)
      RTPs.  */
   return -1;
 #elif defined (__PikeOS__)
-  /* Not supported.  */
+  /* Not supported. */
   return -1;
 #elif defined (_WIN32)
   /* Special case when oldfd and newfd are identical and are the standard
@@ -2679,6 +2679,26 @@ __gnat_portable_wait (int *process_status)
   return pid;
 }
 
+int
+__gnat_portable_no_block_wait (int *process_status)
+{
+  int status = 0;
+  int pid = 0;
+
+#if defined (__vxworks) || defined (__PikeOS__) || defined (_WIN32)
+  /* Not supported. */
+  status = -1;
+
+#else
+
+  pid = waitpid (-1, &status, WNOHANG);
+  status = status & 0xffff;
+#endif
+
+  *process_status = status;
+  return pid;
+}
+
 void
 __gnat_os_exit (int status)
 {
diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h
index 232b5eb..444e04d 100644
--- a/gcc/ada/adaint.h
+++ b/gcc/ada/adaint.h
@@ -233,6 +233,7 @@ extern int    __gnat_is_symbolic_link		   (char *name);
 extern int    __gnat_portable_spawn                (char *[]);
 extern int    __gnat_portable_no_block_spawn       (char *[]);
 extern int    __gnat_portable_wait                 (int *);
+extern int    __gnat_portable_no_block_wait        (int *);
 extern int    __gnat_current_process_id            (void);
 extern char  *__gnat_locate_exec                   (char *, char *);
 extern char  *__gnat_locate_exec_on_path           (char *);
diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb
index a3e433f..62d9d33 100644
--- a/gcc/ada/exp_unst.adb
+++ b/gcc/ada/exp_unst.adb
@@ -35,6 +35,7 @@ with Opt;      use Opt;
 with Output;   use Output;
 with Rtsfind;  use Rtsfind;
 with Sem;      use Sem;
+with Sem_Aux;  use Sem_Aux;
 with Sem_Ch8;  use Sem_Ch8;
 with Sem_Mech; use Sem_Mech;
 with Sem_Res;  use Sem_Res;
@@ -176,9 +177,24 @@ package body Exp_Unst is
    ----------------
 
    function Subp_Index (Sub : Entity_Id) return SI_Type is
+      E : Entity_Id := Sub;
+
    begin
-      pragma Assert (Is_Subprogram (Sub));
-      return SI_Type (UI_To_Int (Subps_Index (Sub)));
+      pragma Assert (Is_Subprogram (E));
+
+      if Subps_Index (E) = Uint_0 then
+         E := Ultimate_Alias (E);
+
+         if Ekind (E) = E_Function
+           and then Rewritten_For_C (E)
+           and then Present (Corresponding_Procedure (E))
+         then
+            E := Corresponding_Procedure (E);
+         end if;
+      end if;
+
+      pragma Assert (Subps_Index (E) /= Uint_0);
+      return SI_Type (UI_To_Int (Subps_Index (E)));
    end Subp_Index;
 
    -----------------------
diff --git a/gcc/ada/prep.adb b/gcc/ada/prep.adb
index 02256ec..ef0712d 100644
--- a/gcc/ada/prep.adb
+++ b/gcc/ada/prep.adb
@@ -1572,7 +1572,6 @@ package body Prep is
             then
                Start_Of_Processing := Token_Ptr + 2;
             else
-               pragma Assert (Sinput.Source (Token_Ptr) = ASCII.LF);
                Start_Of_Processing := Token_Ptr + 1;
             end if;
          end if;
diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb
index 36064e9..014f6b4 100644
--- a/gcc/ada/s-os_lib.adb
+++ b/gcc/ada/s-os_lib.adb
@@ -1927,6 +1927,28 @@ package body System.OS_Lib is
       return Result;
    end Non_Blocking_Spawn;
 
+   -------------------------------
+   -- Non_Blocking_Wait_Process --
+   -------------------------------
+
+   procedure Non_Blocking_Wait_Process
+     (Pid : out Process_Id; Success : out Boolean)
+   is
+      Status : Integer;
+
+      function Portable_No_Block_Wait (S : Address) return Process_Id;
+      pragma Import
+        (C, Portable_No_Block_Wait, "__gnat_portable_no_block_wait");
+
+   begin
+      Pid := Portable_No_Block_Wait (Status'Address);
+      Success := (Status = 0);
+
+      if Pid = 0 then
+         Pid := Invalid_Pid;
+      end if;
+   end Non_Blocking_Wait_Process;
+
    -------------------------
    -- Normalize_Arguments --
    -------------------------
diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads
index 21f9ec5..31e171b 100644
--- a/gcc/ada/s-os_lib.ads
+++ b/gcc/ada/s-os_lib.ads
@@ -937,6 +937,12 @@ package System.OS_Lib is
    --  This function will always set success to False under VxWorks, since
    --  there is no notion of executables under this OS.
 
+   procedure Non_Blocking_Wait_Process
+     (Pid : out Process_Id; Success : out Boolean);
+   --  Same as Wait_Process, except if there are no completed child processes,
+   --  return immediately without blocking, and return Invalid_Pid in Pid.
+   --  Not supported on all platforms; Success = False if not supported.
+
    -------------------------------------
    -- NOTE: Spawn in Tasking Programs --
    -------------------------------------
diff --git a/gcc/ada/s-string.adb b/gcc/ada/s-string.adb
index d6e32fb..88439cc 100644
--- a/gcc/ada/s-string.adb
+++ b/gcc/ada/s-string.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1995-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 1995-2016, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -38,7 +38,6 @@ package body System.Strings is
    ----------
 
    procedure Free (Arg : in out String_List_Access) is
-      X : String_Access;
 
       procedure Free_Array is new Ada.Unchecked_Deallocation
         (Object => String_List, Name => String_List_Access);
@@ -48,8 +47,7 @@ package body System.Strings is
 
       if Arg /= null then
          for J in Arg'Range loop
-            X := Arg (J);
-            Free (X);
+            Free (Arg (J));
          end loop;
       end if;
 
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 70e20ab..7e13f52 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -4218,10 +4218,10 @@ package body Sem_Prag is
          -----------------------------
 
          function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is
-            Prev : Entity_Id := Overridden_Operation (E);
+            Typ  : constant Entity_Id := Find_Dispatching_Type (E);
+            Prev : Entity_Id          := Overridden_Operation (E);
             Cont : Node_Id;
             Prag : Node_Id;
-            Typ  : Entity_Id;
 
          begin
             --  Check ancestors on the overriding operation to examine the
@@ -4240,14 +4240,21 @@ package body Sem_Prag is
                   end loop;
                end if;
 
-               Prev := Overridden_Operation (Prev);
+               --  For a type derived from a generic formal type, the
+               --  operation inheriting the condition is a renaming, not
+               --  an overriding of the operation of the formal.
+
+               if Is_Generic_Type (Find_Dispatching_Type (Prev)) then
+                  Prev := Alias (Prev);
+               else
+                  Prev := Overridden_Operation (Prev);
+               end if;
             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.
 
-            Typ := Find_Dispatching_Type (E);
             if Has_Interfaces (Typ) then
                declare
                   Elmt      : Elmt_Id;
@@ -4414,7 +4421,6 @@ package body Sem_Prag is
 
             declare
                E : constant Entity_Id := Defining_Entity (Subp_Decl);
-               H : constant Entity_Id := Homonym (E);
 
             begin
                if Class_Present (N)
@@ -4425,22 +4431,6 @@ package body Sem_Prag is
                   Error_Msg_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
-               --  still have a parent operation that carries a precondition.
-
-               elsif In_Instance
-                 and then In_Private_Part (Current_Scope)
-                 and then Present (H)
-                 and then Scope (E) = Scope (H)
-                 and then Is_Inherited_Operation (H)
-                 and then Present (Overridden_Operation (H))
-                 and then not Inherits_Class_Wide_Pre (H)
-               then
-                  Error_Msg_N
-                    ("illegal class-wide precondition on overriding "
-                     & "operation in instance", Corresponding_Aspect (N));
                end if;
             end;