[Ada] Fix gmem.out corruption by GNAT.Expect

diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c
--- a/gcc/ada/adaint.c
+++ b/gcc/ada/adaint.c
@@ -244,6 +244,8 @@  UINT __gnat_current_ccs_encoding;
 
 #include "adaint.h"
 
+int __gnat_in_child_after_fork = 0;
+
 #if defined (__APPLE__) && defined (st_mtime)
 #define st_atim st_atimespec
 #define st_mtim st_mtimespec
@@ -2421,6 +2423,7 @@  __gnat_portable_spawn (char *args[] ATTRIBUTE_UNUSED)
   if (pid == 0)
     {
       /* The child. */
+      __gnat_in_child_after_fork = 1;
       if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
 	_exit (1);
     }


diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h
--- a/gcc/ada/adaint.h
+++ b/gcc/ada/adaint.h
@@ -139,7 +139,15 @@  struct file_attributes {
  * fit the above struct on any system)
  */
 
-extern int    __gnat_max_path_len;
+extern int  __gnat_max_path_len;
+extern int  __gnat_in_child_after_fork;
+/* This flag expresses the state when the fork call just returned zero result,
+ * i.e. when the new born child process is created and the new executable is
+ * not loaded yet. It is used to e.g. disable tracing memory
+ * allocation/deallocation in memtrack.adb just after fork returns in the child
+ * process to avoid both parent and child writing to the same gmem.out file
+ * simultaneously */
+
 extern OS_Time __gnat_current_time		   (void);
 extern void   __gnat_current_time_string           (char *);
 extern void   __gnat_to_gm_time			   (OS_Time *, int *, int *,


diff --git a/gcc/ada/expect.c b/gcc/ada/expect.c
--- a/gcc/ada/expect.c
+++ b/gcc/ada/expect.c
@@ -39,6 +39,7 @@ 
 #include "system.h"
 #endif
 
+#include "adaint.h"
 #include <sys/types.h>
 
 #ifdef __MINGW32__
@@ -78,7 +79,6 @@ 
 #include <process.h>
 #include <signal.h>
 #include <io.h>
-#include "adaint.h"
 #include "mingw32.h"
 
 int
@@ -360,7 +360,11 @@  __gnat_pipe (int *fd)
 int
 __gnat_expect_fork (void)
 {
-  return fork ();
+  int pid = fork();
+  if (pid == 0) {
+    __gnat_in_child_after_fork = 1;
+  }
+  return pid;
 }
 
 void


diff --git a/gcc/ada/libgnat/memtrack.adb b/gcc/ada/libgnat/memtrack.adb
--- a/gcc/ada/libgnat/memtrack.adb
+++ b/gcc/ada/libgnat/memtrack.adb
@@ -102,6 +102,9 @@  package body System.Memory is
    pragma Import (C, OS_Exit, "__gnat_os_exit");
    pragma No_Return (OS_Exit);
 
+   In_Child_After_Fork : Integer;
+   pragma Import (C, In_Child_After_Fork, "__gnat_in_child_after_fork");
+
    procedure fwrite
      (Ptr    : System.Address;
       Size   : size_t;
@@ -149,6 +152,24 @@  package body System.Memory is
    --  themselves do dynamic allocation. We use First_Call flag to avoid
    --  infinite recursion
 
+   function Allow_Trace return Boolean;
+   pragma Inline (Allow_Trace);
+   --  Check if the memory trace is allowed
+
+   -----------------
+   -- Allow_Trace --
+   -----------------
+
+   function Allow_Trace return Boolean is
+   begin
+      if First_Call then
+         First_Call := False;
+         return In_Child_After_Fork = 0;
+      else
+         return False;
+      end if;
+   end Allow_Trace;
+
    -----------
    -- Alloc --
    -----------
@@ -176,14 +197,12 @@  package body System.Memory is
 
       Result := c_malloc (Actual_Size);
 
-      if First_Call then
+      if Allow_Trace then
 
          --  Logs allocation call
          --  format is:
          --   'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
 
-         First_Call := False;
-
          if Needs_Init then
             Gmem_Initialize;
          end if;
@@ -243,14 +262,12 @@  package body System.Memory is
    begin
       Lock_Task.all;
 
-      if First_Call then
+      if Allow_Trace then
 
          --  Logs deallocation call
          --  format is:
          --   'D' <mem addr> <len backtrace> <addr1> ... <addrn>
 
-         First_Call := False;
-
          if Needs_Init then
             Gmem_Initialize;
          end if;
@@ -334,9 +351,7 @@  package body System.Memory is
       Abort_Defer.all;
       Lock_Task.all;
 
-      if First_Call then
-         First_Call := False;
-
+      if Allow_Trace then
          --  We first log deallocation call
 
          if Needs_Init then