ada: Add adareducer integration to ICE handling

This patch adds a way to have the adareducer tool run on a appropriate
set of files when GNAT crashes. This feature is behind the -gnatd_m
debugging switch.

gcc/ada/ChangeLog:
	* comperr.adb (Compiler_Abort): Add call to
	Generate_Minimal_Reproducer and replace call to Namet.Unlock with
	call to Unlock_If_Locked.
	* debug.adb: Document new purpose of -gnatd_m and -gnatd_M.
	* fname-uf.adb (Instantiate_SFN_Pattern): New procedure.
	(Get_Default_File_Name): New function.
	(Get_File_Name): Replace inline code with call to
	Instantiate_SFN_Pattern.
	* fname-uf.ads (Get_Default_File_Name): New function.
	* generate_minimal_reproducer.adb (Generate_Minimal_Reproducer):
	New procedure.
	* namet.adb (Unlock_If_Locked): New function.
	* namet.ads (Unlock_If_Locked): Likewise.
	* par-prag.adb (Prag): Add special behavior with -gnatd_M.
	* set_targ.adb: Minor fixes to comments.
	* gcc-interface/Make-lang.in: Update list of object files.

10 files changed, 667 insertions, 134 deletions

diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb
index 2623eed..e411ddb 100644
--- a/gcc/ada/comperr.adb
+++ b/gcc/ada/comperr.adb
@@ -30,6 +30,7 @@
 with Atree;          use Atree;
 with Debug;          use Debug;
 with Errout;         use Errout;
+with Generate_Minimal_Reproducer;
 with Gnatvsn;        use Gnatvsn;
 with Lib;            use Lib;
 with Namet;          use Namet;
@@ -263,7 +264,7 @@ package body Comperr is
             Src : Source_Buffer_Ptr;
 
          begin
-            Namet.Unlock;
+            Namet.Unlock_If_Locked;
             Name_Buffer (1 .. 12) := "gnat_bug.box";
             Name_Len := 12;
             Read_Source_File (Name_Enter, 0, Hi, Src, FD);
@@ -403,6 +404,14 @@ package body Comperr is
                Write_Str ("list may be incomplete");
          end;
 
+         begin
+            if Debug_Flag_Underscore_M then
+               Generate_Minimal_Reproducer;
+            end if;
+         exception
+            when others => null;
+         end;
+
          Write_Eol;
          Set_Standard_Output;
 
@@ -539,5 +548,4 @@ package body Comperr is
 
       Write_Char (After);
    end Repeat_Char;
-
 end Comperr;
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index 2c0bff0..3dbf3a7b 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -150,7 +150,7 @@ package body Debug is
    --  d_j  Read JSON files and populate Repinfo tables (opposite of -gnatRjs)
    --  d_k  In CodePeer mode disable expansion of assertion checks
    --  d_l  Disable strict alignment of array types with aliased component
-   --  d_m
+   --  d_m  Run adareducer on crash
    --  d_n
    --  d_o
    --  d_p  Ignore assertion pragmas for elaboration
@@ -177,7 +177,7 @@ package body Debug is
    --  d_J
    --  d_K  (Reserved) Enable reporting a warning on known-problem issues
    --  d_L  Output trace information on elaboration checking
-   --  d_M
+   --  d_M  Ignore Source_File_Name and Source_File_Name_Project pragmas
    --  d_N
    --  d_O
    --  d_P
diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb
index 983cda4..cb93634 100644
--- a/gcc/ada/fname-uf.adb
+++ b/gcc/ada/fname-uf.adb
@@ -93,6 +93,15 @@ package body Fname.UF is
    --  Table recording calls to Set_File_Name_Pattern. Note that the first two
    --  entries are set to represent the standard GNAT rules for file naming.
 
+   procedure Instantiate_SFN_Pattern
+     (Pattern   : SFN_Pattern_Entry;
+      Buf       : in out Bounded_String;
+      Is_Predef : Boolean := False);
+   --  On entry, Buf must contain a unit name. After returning, Buf contains
+   --  the file name corresponding to the unit following the naming pattern
+   --  described by Pattern. Is_Predef must be whether the unit name in Buf
+   --  is a predefined unit name as defined by Is_Predefined_Unit_Name.
+
    -----------------------
    -- File_Name_Of_Body --
    -----------------------
@@ -164,6 +173,29 @@ package body Fname.UF is
       return Unknown;
    end Get_Expected_Unit_Type;
 
+   ---------------------------
+   -- Get_Default_File_Name --
+   ---------------------------
+
+   function Get_Default_File_Name (Uname : Unit_Name_Type) return String is
+      Buf : Bounded_String;
+
+      Pattern : SFN_Pattern_Entry;
+   begin
+      Get_Unit_Name_String (Buf, Uname, False);
+
+      if Is_Spec_Name (Uname) then
+         Pattern := SFN_Patterns.Table (1);
+      else
+         pragma Assert (Is_Body_Name (Uname));
+         Pattern := SFN_Patterns.Table (2);
+      end if;
+
+      Instantiate_SFN_Pattern (Pattern, Buf);
+
+      return To_String (Buf);
+   end Get_Default_File_Name;
+
    -------------------
    -- Get_File_Name --
    -------------------
@@ -261,23 +293,11 @@ package body Fname.UF is
                    Name_Buffer (1 .. Name_Len);
 
          Pent : Nat;
-         Plen : Natural;
          Fnam : File_Name_Type := No_File;
-         J    : Natural;
-         Dot  : String_Ptr;
-         Dotl : Natural;
 
          Is_Predef : Boolean;
          --  Set True for predefined file
 
-         function C (N : Natural) return Character;
-         --  Return N'th character of pattern
-
-         function C (N : Natural) return Character is
-         begin
-            return SFN_Patterns.Table (Pent).Pat (N);
-         end C;
-
       --  Start of search through pattern table
 
       begin
@@ -309,122 +329,8 @@ package body Fname.UF is
                   Name_Len := Uname'Length;
                   Name_Buffer (1 .. Name_Len) := Uname;
 
-                  --  Apply casing, except that we do not do this for the case
-                  --  of a predefined library file. For the latter, we always
-                  --  use the all lower case name, regardless of the setting.
-
-                  if not Is_Predef then
-                     Set_Casing (SFN_Patterns.Table (Pent).Cas);
-                  end if;
-
-                  --  If dot translation required do it
-
-                  Dot  := SFN_Patterns.Table (Pent).Dot;
-                  Dotl := Dot.all'Length;
-
-                  if Dot.all /= "." then
-                     J := 1;
-
-                     while J <= Name_Len loop
-                        if Name_Buffer (J) = '.' then
-
-                           if Dotl = 1 then
-                              Name_Buffer (J) := Dot (Dot'First);
-
-                           else
-                              Name_Buffer (J + Dotl .. Name_Len + Dotl - 1) :=
-                                Name_Buffer (J + 1 .. Name_Len);
-                              Name_Buffer (J .. J + Dotl - 1) := Dot.all;
-                              Name_Len := Name_Len + Dotl - 1;
-                           end if;
-
-                           J := J + Dotl;
-
-                        --  Skip past wide char sequences to avoid messing with
-                        --  dot characters that are part of a sequence.
-
-                        elsif Name_Buffer (J) = ASCII.ESC
-                          or else (Upper_Half_Encoding
-                                    and then
-                                      Name_Buffer (J) in Upper_Half_Character)
-                        then
-                           Skip_Wide (Name_Buffer, J);
-                        else
-                           J := J + 1;
-                        end if;
-                     end loop;
-                  end if;
-
-                  --  Here move result to right if preinsertion before *
-
-                  Plen := SFN_Patterns.Table (Pent).Pat'Length;
-                  for K in 1 .. Plen loop
-                     if C (K) = '*' then
-                        if K /= 1 then
-                           Name_Buffer (1 + K - 1 .. Name_Len + K - 1) :=
-                             Name_Buffer (1 .. Name_Len);
-
-                           for L in 1 .. K - 1 loop
-                              Name_Buffer (L) := C (L);
-                           end loop;
-
-                           Name_Len := Name_Len + K - 1;
-                        end if;
-
-                        for L in K + 1 .. Plen loop
-                           Name_Len := Name_Len + 1;
-                           Name_Buffer (Name_Len) := C (L);
-                        end loop;
-
-                        exit;
-                     end if;
-                  end loop;
-
-                  --  Execute possible crunch on constructed name. The krunch
-                  --  operation excludes any extension that may be present.
-
-                  J := Name_Len;
-                  while J > 1 loop
-                     exit when Name_Buffer (J) = '.';
-                     J := J - 1;
-                  end loop;
-
-                  --  Case of extension present
-
-                  if J > 1 then
-                     declare
-                        Ext : constant String := Name_Buffer (J .. Name_Len);
-
-                     begin
-                        --  Remove extension
-
-                        Name_Len := J - 1;
-
-                        --  Krunch what's left
-
-                        Krunch
-                          (Name_Buffer,
-                           Name_Len,
-                           Integer (Maximum_File_Name_Length),
-                           Debug_Flag_4);
-
-                        --  Replace extension
-
-                        Name_Buffer
-                          (Name_Len + 1 .. Name_Len + Ext'Length) := Ext;
-                        Name_Len := Name_Len + Ext'Length;
-                     end;
-
-                  --  Case of no extension present, straight krunch on the
-                  --  entire file name.
-
-                  else
-                     Krunch
-                       (Name_Buffer,
-                        Name_Len,
-                        Integer (Maximum_File_Name_Length),
-                        Debug_Flag_4);
-                  end if;
+                  Instantiate_SFN_Pattern
+                    (SFN_Patterns.Table (Pent), Global_Name_Buffer, Is_Predef);
 
                   Fnam := Name_Find;
 
@@ -543,6 +449,145 @@ package body Fname.UF is
          Cas => All_Lower_Case));
    end Initialize;
 
+   -----------------------------
+   -- Instantiate_SFN_Pattern --
+   -----------------------------
+
+   procedure Instantiate_SFN_Pattern
+     (Pattern   : SFN_Pattern_Entry;
+      Buf       : in out Bounded_String;
+      Is_Predef : Boolean := False)
+   is
+      function C (N : Natural) return Character;
+      --  Return N'th character of pattern
+
+      function C (N : Natural) return Character is
+      begin
+         return Pattern.Pat (N);
+      end C;
+
+      Dot : constant String_Ptr := Pattern.Dot;
+
+      Dotl : constant Natural := Dot.all'Length;
+
+      Plen : constant Natural := Pattern.Pat'Length;
+
+      J : Natural;
+   begin
+      --  Apply casing, except that we do not do this for the case
+      --  of a predefined library file. For the latter, we always
+      --  use the all lower case name, regardless of the setting.
+
+      if not Is_Predef then
+         Set_Casing (Buf, Pattern.Cas);
+      end if;
+
+      --  If dot translation required do it
+
+      if Dot.all /= "." then
+         J := 1;
+
+         while J <= Buf.Length loop
+            if Buf.Chars (J) = '.' then
+
+               if Dotl = 1 then
+                  Buf.Chars (J) := Dot (Dot'First);
+
+               else
+                  Buf.Chars (J + Dotl .. Buf.Length + Dotl - 1) :=
+                    Buf.Chars (J + 1 .. Buf.Length);
+                  Buf.Chars (J .. J + Dotl - 1) := Dot.all;
+                  Buf.Length := Buf.Length + Dotl - 1;
+               end if;
+
+               J := J + Dotl;
+
+            --  Skip past wide char sequences to avoid messing with
+            --  dot characters that are part of a sequence.
+
+            elsif Buf.Chars (J) = ASCII.ESC
+              or else (Upper_Half_Encoding
+                        and then
+                          Buf.Chars (J) in Upper_Half_Character)
+            then
+               Skip_Wide (Buf.Chars, J);
+            else
+               J := J + 1;
+            end if;
+         end loop;
+      end if;
+
+      --  Here move result to right if preinsertion before *
+
+      for K in 1 .. Plen loop
+         if C (K) = '*' then
+            if K /= 1 then
+               Buf.Chars (1 + K - 1 .. Buf.Length + K - 1) :=
+                 Buf.Chars (1 .. Buf.Length);
+
+               for L in 1 .. K - 1 loop
+                  Buf.Chars (L) := C (L);
+               end loop;
+
+               Buf.Length := Buf.Length + K - 1;
+            end if;
+
+            for L in K + 1 .. Plen loop
+               Buf.Length := Buf.Length + 1;
+               Buf.Chars (Buf.Length) := C (L);
+            end loop;
+
+            exit;
+         end if;
+      end loop;
+
+      --  Execute possible crunch on constructed name. The krunch
+      --  operation excludes any extension that may be present.
+
+      J := Buf.Length;
+      while J > 1 loop
+         exit when Buf.Chars (J) = '.';
+         J := J - 1;
+      end loop;
+
+      --  Case of extension present
+
+      if J > 1 then
+         declare
+            Ext : constant String := Buf.Chars (J .. Buf.Length);
+
+         begin
+            --  Remove extension
+
+            Buf.Length := J - 1;
+
+            --  Krunch what's left
+
+            Krunch
+              (Buf.Chars,
+               Buf.Length,
+               Integer (Maximum_File_Name_Length),
+               Debug_Flag_4);
+
+            --  Replace extension
+
+            Buf.Chars
+              (Buf.Length + 1 .. Buf.Length + Ext'Length) := Ext;
+            Buf.Length := Buf.Length + Ext'Length;
+         end;
+
+      --  Case of no extension present, straight krunch on the
+      --  entire file name.
+
+      else
+         Krunch
+           (Buf.Chars,
+            Buf.Length,
+            Integer (Maximum_File_Name_Length),
+            Debug_Flag_4);
+      end if;
+   end Instantiate_SFN_Pattern;
+
    ----------
    -- Lock --
    ----------
diff --git a/gcc/ada/fname-uf.ads b/gcc/ada/fname-uf.ads
index a57e396..4c35212 100644
--- a/gcc/ada/fname-uf.ads
+++ b/gcc/ada/fname-uf.ads
@@ -53,6 +53,9 @@ package Fname.UF is
    --  be determined with the file naming conventions in use, then the returned
    --  value is set to Unknown.
 
+   function Get_Default_File_Name (Uname : Unit_Name_Type) return String;
+   --  Returns the file name of Uname under the default GNAT naming scheme.
+
    function Get_File_Name
      (Uname    : Unit_Name_Type;
       Subunit  : Boolean;
diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in
index 32c5ed3..0b8f2dd 100644
--- a/gcc/ada/gcc-interface/Make-lang.in
+++ b/gcc/ada/gcc-interface/Make-lang.in
@@ -365,6 +365,7 @@ GNAT_ADA_OBJS =	\
  ada/fname.o	\
  ada/freeze.o	\
  ada/frontend.o	\
+ ada/generate_minimal_reproducer.o	\
  ada/get_targ.o	\
  ada/ghost.o	\
  ada/gnat_cuda.o \
@@ -492,6 +493,7 @@ GNAT1_C_OBJS+=    \
  ada/errno.o      \
  ada/init.o       \
  ada/initialize.o \
+ ada/mkdir.o      \
  ada/raise.o      \
  ada/raise-gcc.o  \
  ada/rtfinal.o    \
diff --git a/gcc/ada/generate_minimal_reproducer.adb b/gcc/ada/generate_minimal_reproducer.adb
new file mode 100644
index 0000000..d9944f1
--- /dev/null
+++ b/gcc/ada/generate_minimal_reproducer.adb
@@ -0,0 +1,455 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--           G E N E R A T E _ M I N I M A L _ R E P R O D U C E R          --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--            Copyright (C) 2024, 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- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license.          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by AdaCore.                        --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Fmap;
+with Fname.UF;
+with Lib;
+with Namet; use Namet;
+with Osint; use Osint;
+with Output; use Output;
+with System.CRTL;
+with System.OS_Lib; use System.OS_Lib;
+with Types; use Types;
+
+procedure Generate_Minimal_Reproducer is
+   Reproducer_Generation_Failed : exception;
+
+   function Create_Reproducer_Directory return String;
+   --  Create a directory that will be used to run adareducer, and will
+   --  eventually contain the reduced set of sources to be collected by the
+   --  user. The name of the directory makes its purpose clear, and it has a
+   --  numeric suffix to avoid clashes with other compiler invocations that
+   --  might have generated reproducers already.
+
+   ---------------------------------
+   -- Create_Reproducer_Directory --
+   ---------------------------------
+
+   function Create_Reproducer_Directory return String is
+      Max_Id : constant Positive := 1000;
+
+      Prefix : constant String := "reduce-crash-reproducer";
+
+      Result : System.CRTL.int;
+   begin
+      for Id in 1 .. Max_Id loop
+         declare
+            Candidate_Path : String := Prefix & Positive'Image (Id);
+         begin
+            Candidate_Path (Prefix'Length + 1) := '-';
+
+            Result := System.CRTL.mkdir (Candidate_Path & ASCII.NUL);
+
+            --  If mkdir fails, we assume that it's because the directory
+            --  already exists. We should check for EEXIST instead???
+            if Result = 0 then
+               return Candidate_Path;
+            end if;
+         end;
+      end loop;
+
+      Write_Line ("failed to create reproducer directory");
+      raise Reproducer_Generation_Failed;
+   end Create_Reproducer_Directory;
+
+   Dirname : constant String := Create_Reproducer_Directory;
+
+   Gpr_File_Path : constant String :=
+     Dirname & Directory_Separator & "reduce_crash_reproducer.gpr";
+
+   Src_Dir_Path : constant String := Dirname & Directory_Separator & "src";
+
+   Oracle_Path : constant String :=
+     Dirname & Directory_Separator & Executable_Name ("oracle");
+
+   Result : Integer;
+begin
+   Create_Semantic_Closure_Project :
+   declare
+      Gpr_File : File_Descriptor;
+
+      B : constant Saved_Output_Buffer := Save_Output_Buffer;
+   begin
+      Gpr_File := Create_File (Gpr_File_Path, Text);
+      if Gpr_File = Invalid_FD then
+         Write_Line ("failed to create GPR file");
+         raise Reproducer_Generation_Failed;
+      end if;
+
+      Push_Output;
+      Set_Output (Gpr_File);
+
+      Write_Line ("project Reduce_Crash_Reproducer is");
+      Write_Line ("   for Source_Dirs use (""src"");");
+      Write_Line ("end Reduce_Crash_Reproducer;");
+
+      Close (Gpr_File);
+      Pop_Output;
+      Restore_Output_Buffer (B);
+
+      Result := System.CRTL.mkdir (Src_Dir_Path & ASCII.NUL);
+
+      if Result /= 0 then
+         Write_Line ("failed to create reproducer directory");
+         raise Reproducer_Generation_Failed;
+      end if;
+
+      for J in Main_Unit .. Lib.Last_Unit loop
+         declare
+            Path : File_Name_Type :=
+              Fmap.Mapped_Path_Name (Lib.Unit_File_Name (J));
+
+            Default_File_Name : constant String :=
+              Fname.UF.Get_Default_File_Name (Lib.Unit_Name (J));
+
+            File_Copy_Path : constant String :=
+              Src_Dir_Path & Directory_Separator & Default_File_Name;
+         begin
+            if not Lib.Is_Internal_Unit (J) then
+               --  Mapped_Path_Name might have returned No_File. This has been
+               --  observed for files with a Source_File_Name pragma.
+               if Path = No_File then
+                  Path := Find_File (Lib.Unit_File_Name (J), Osint.Source);
+                  pragma Assert (Path /= No_File);
+               end if;
+
+               declare
+                  File_Path : constant String := Get_Name_String (Path);
+                  Success   : Boolean;
+               begin
+                  System.OS_Lib.Copy_File
+                    (File_Path, File_Copy_Path, Success, Overwrite);
+
+                  pragma Assert (Success);
+               end;
+            end if;
+         end;
+      end loop;
+   end Create_Semantic_Closure_Project;
+
+   Create_Oracle :
+   declare
+      Gnatmake_Path : String_Access := Locate_Exec_On_Path ("gnatmake");
+
+      Oracle_Dir_Path : constant String :=
+        Dirname & Directory_Separator & "oracle-src";
+
+      Source_File_Path : constant String :=
+        Oracle_Dir_Path & Directory_Separator & "oracle.adb";
+
+      Source_File : File_Descriptor;
+
+      Result : System.CRTL.int;
+   begin
+      if Gnatmake_Path = null then
+         Write_Line ("-gnatd_m was specified but gnatmake is not available");
+         raise Reproducer_Generation_Failed;
+      end if;
+
+      Result := System.CRTL.mkdir (Oracle_Dir_Path & ASCII.NUL);
+
+      if Result /= 0 then
+         Write_Line ("failed to create directory");
+         raise Reproducer_Generation_Failed;
+      end if;
+
+      Source_File := Create_File (Source_File_Path, Text);
+      if Source_File = Invalid_FD then
+         Write_Line ("failed to create oracle source file");
+         raise Reproducer_Generation_Failed;
+      end if;
+
+      Write_Oracle_Code :
+      declare
+         Old_Main_Path : constant String :=
+           Get_Name_String
+             (Fmap.Mapped_Path_Name (Lib.Unit_File_Name (Main_Unit)));
+
+         Default_Main_Name : constant String :=
+           Fname.UF.Get_Default_File_Name (Lib.Unit_Name (Main_Unit));
+
+         New_Main_Path : constant String :=
+           Src_Dir_Path & Directory_Separator & Default_Main_Name;
+
+         Gnat1_Path : String (1 .. Len_Arg (0));
+
+         B : constant Saved_Output_Buffer := Save_Output_Buffer;
+      begin
+         Fill_Arg (Gnat1_Path'Address, 0);
+
+         Push_Output;
+         Set_Output (Source_File);
+
+         Write_Line ("with Ada.Command_Line;");
+         Write_Line ("use Ada.Command_Line;");
+         Write_Line ("with GNAT.Expect;");
+         Write_Line ("with GNAT.OS_Lib;");
+         Write_Eol;
+         Write_Line ("procedure Oracle is");
+         Write_Line ("   Child_Code : aliased Integer;");
+         Write_Eol;
+         Write_Line ("   Gnat1_Path : constant String := ");
+
+         Write_Str ("     """);
+         Write_Str (Gnat1_Path);
+         Write_Line (""";");
+
+         Write_Eol;
+         Write_Line ("   Args : constant GNAT.OS_Lib.Argument_List :=");
+
+         Write_Str ("     (new String'(""-gnatd_M"")");
+
+         --  The following way of iterating through the command line arguments
+         --  was copied from Set_Targ. TODO factorize???
+         declare
+            type Arg_Array is array (Nat) of Big_String_Ptr;
+            type Arg_Array_Ptr is access Arg_Array;
+            --  Types to access compiler arguments
+
+            save_argc : Nat;
+            pragma Import (C, save_argc);
+            --  Saved value of argc (number of arguments), imported from
+            --  misc.cc
+
+            save_argv : Arg_Array_Ptr;
+            pragma Import (C, save_argv);
+            --  Saved value of argv (argument pointers), imported from misc.cc
+
+            gnat_argc : Nat;
+            gnat_argv : Arg_Array_Ptr;
+            pragma Import (C, gnat_argc);
+            pragma Import (C, gnat_argv);
+            --  If save_argv is not set, default to gnat_argc/argv
+
+            argc : Nat;
+            argv : Arg_Array_Ptr;
+
+            function Len_Arg (Arg : Big_String_Ptr) return Nat;
+            --  Determine length of argument Arg (a nul terminated C string).
+
+            -------------
+            -- Len_Arg --
+            -------------
+
+            function Len_Arg (Arg : Big_String_Ptr) return Nat is
+            begin
+               for J in 1 .. Nat'Last loop
+                  if Arg (Natural (J)) = ASCII.NUL then
+                     return J - 1;
+                  end if;
+               end loop;
+
+               raise Program_Error;
+            end Len_Arg;
+
+         begin
+            if save_argv /= null then
+               argv := save_argv;
+               argc := save_argc;
+            else
+               --  Case of a non-GCC compiler, e.g. gnat2why or gnat2scil
+               argv := gnat_argv;
+               argc := gnat_argc;
+            end if;
+
+            for Arg in 1 .. argc - 1 loop
+               declare
+                  Argv_Ptr : constant Big_String_Ptr := argv (Arg);
+                  Argv_Len : constant Nat := Len_Arg (Argv_Ptr);
+
+                  Arg : constant String := Argv_Ptr (1 .. Natural (Argv_Len));
+               begin
+                  --  We filter out mapping file arguments because we want to
+                  --  use the copies of source files we made.
+                  if Argv_Len > 8 and then Arg (1 .. 8) = "-gnatem=" then
+                     null;
+
+                  --  We must not have the oracle run the compiler in
+                  --  reduce-on-crash mode, that would result in recursive
+                  --  invocations.
+                  elsif Arg = "-gnatd_m" then
+                     null;
+                  else
+                     Write_Line (",");
+                     Write_Str ("      new String'(""");
+
+                     --  We replace references to the main source file with
+                     --  references to the copy we made.
+                     if Old_Main_Path = Arg then
+                        Write_Str (New_Main_Path);
+
+                     --  We copy the other command line arguments unmodified
+                     else
+                        Write_Str (Arg);
+                     end if;
+
+                     Write_Str (""")");
+                  end if;
+               end;
+            end loop;
+         end;
+
+         Write_Line (");");
+
+         Write_Eol;
+
+         Write_Line ("   Output : constant String :=");
+         Write_Line ("     GNAT.Expect.Get_Command_Output");
+         Write_Str ("       (Gnat1_Path, Args, """", Child_Code'Access, ");
+         Write_Line ("Err_To_Out => True);");
+
+         Write_Eol;
+
+         Write_Line ("   Crash_Marker : constant String :=");
+         Write_Line ("     ""+===========================GNAT BUG DETECTE"";");
+
+         Write_Eol;
+
+         Write_Line ("   Crashed : constant Boolean :=");
+         Write_Line ("     Crash_Marker'Length <= Output'Length");
+         Write_Str ("     and then Output (Output'First .. Output'First ");
+         Write_Line ("+ Crash_Marker'Length - 1)");
+         Write_Line ("              = Crash_Marker;");
+
+         Write_Eol;
+
+         Write_Str ("   Status_Code : Exit_Status := ");
+         Write_Line ("(if Crashed then 0 else 1);");
+         Write_Line ("begin");
+         Write_Line ("   Set_Exit_Status (Status_Code);");
+         Write_Line ("end Oracle;");
+
+         Pop_Output;
+         Restore_Output_Buffer (B);
+      end Write_Oracle_Code;
+
+      Close (Source_File);
+
+      declare
+         Args : constant Argument_List :=
+           (new String'(Source_File_Path),
+            new String'("-o"),
+            new String'(Oracle_Path),
+            new String'("-D"),
+            new String'(Oracle_Dir_Path));
+
+         Success : Boolean;
+      begin
+         Spawn (Gnatmake_Path.all, Args, Success);
+
+         pragma Assert (Success);
+      end;
+
+      Free (Gnatmake_Path);
+   end Create_Oracle;
+
+   Run_Adareducer :
+   declare
+      --  See section 12.8.3 of the GNAT Studio user's guide for documentation
+      --  about how to invoke adareducer.
+      Gnatstudio_Cli_Path : String_Access :=
+        Locate_Exec_On_Path ("gnatstudio_cli");
+
+   begin
+      if Gnatstudio_Cli_Path = null then
+         Write_Line ("-gnatd_m was specified but adareducer is not available");
+         return;
+      end if;
+
+      declare
+         Args : constant Argument_List :=
+           (new String'("adareducer"),
+            new String'("-P"),
+            new String'(Gpr_File_Path),
+            new String'("-s"),
+            new String'(Oracle_Path));
+
+         Success : Boolean;
+      begin
+         Spawn (Gnatstudio_Cli_Path.all, Args, Success);
+         pragma Assert (Success);
+      end;
+
+      Free (Gnatstudio_Cli_Path);
+   end Run_Adareducer;
+
+   Clean_Up_Reproducer_Source :
+   declare
+
+      use type System.Address;
+
+      Directory_Stream : System.CRTL.DIRs;
+
+      function opendir (file_name : String) return System.CRTL.DIRs with
+        Import, Convention => C, External_Name => "__gnat_opendir";
+
+      Conservative_Name_Max : constant Positive := 4096;
+
+      Buffer : String (1 .. Conservative_Name_Max);
+      Length : aliased Integer;
+
+      Addr : System.Address;
+
+      Dummy : Integer;
+
+      Dummy_Success : Boolean;
+
+      function readdir
+        (Directory : System.CRTL.DIRs;
+         Buffer    : System.Address;
+         Length    : access Integer) return System.Address
+      with Import, Convention => C, External_Name => "__gnat_readdir";
+
+      function closedir (directory : System.CRTL.DIRs) return Integer with
+        Import, Convention => C, External_Name => "__gnat_closedir";
+
+   begin
+      Directory_Stream := opendir (Src_Dir_Path & ASCII.NUL);
+
+      if Directory_Stream = System.Null_Address then
+         return;
+      end if;
+
+      loop
+         Addr := readdir (Directory_Stream, Buffer'Address, Length'Access);
+         if Addr = System.Null_Address then
+            exit;
+         end if;
+
+         declare
+            S : constant String := Buffer (1 .. Length);
+         begin
+            if (5 <= S'Length and then S (S'Last - 4 .. S'Last) = ".orig")
+              or else (2 <= S'Length and then S (S'Last - 1 .. S'Last) = ".s")
+            then
+               System.OS_Lib.Delete_File
+                 (Src_Dir_Path & Directory_Separator & S, Dummy_Success);
+            end if;
+         end;
+      end loop;
+
+      Dummy := closedir (Directory_Stream);
+   end Clean_Up_Reproducer_Source;
+end Generate_Minimal_Reproducer;
diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb
index 34e3bf6..72f6c20 100644
--- a/gcc/ada/namet.adb
+++ b/gcc/ada/namet.adb
@@ -1520,6 +1520,17 @@ package body Namet is
       return Buf.Chars (1 .. Buf.Length);
    end To_String;
 
+   ----------------------
+   -- Unlock_If_Locked --
+   ----------------------
+
+   procedure Unlock_If_Locked is
+   begin
+      if Name_Chars.Locked then
+         Unlock;
+      end if;
+   end Unlock_If_Locked;
+
    ------------
    -- Unlock --
    ------------
diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads
index d3990cb..ab304ad 100644
--- a/gcc/ada/namet.ads
+++ b/gcc/ada/namet.ads
@@ -423,6 +423,9 @@ package Namet is
    --  Unlocks the name table to allow use of the extra space reserved by the
    --  call to Lock. See gnat1drv for details of the need for this.
 
+   procedure Unlock_If_Locked;
+   --  If the name table is locked, calls Unlock. Otherwise, does nothing.
+
    procedure Write_Name (Id : Valid_Name_Id);
    --  Write_Name writes the characters of the specified name using the
    --  standard output procedures in package Output. The name is written
diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
index f464da9..ca47afc 100644
--- a/gcc/ada/par-prag.adb
+++ b/gcc/ada/par-prag.adb
@@ -590,6 +590,12 @@ begin
       when Pragma_Source_File_Name
          | Pragma_Source_File_Name_Project
       =>
+         if Debug_Flag_Underscore_MM then
+            --  -gnatd_M is causes the compiler to ignore source file name
+            --  pragmas. It's used for reduced reproducer generation.
+            return Pragma_Node;
+         end if;
+
          Source_File_Name : declare
             Unam  : Unit_Name_Type;
             Expr1 : Node_Id;
diff --git a/gcc/ada/set_targ.adb b/gcc/ada/set_targ.adb
index 0d4714b..2113312 100644
--- a/gcc/ada/set_targ.adb
+++ b/gcc/ada/set_targ.adb
@@ -837,11 +837,11 @@ begin
 
       save_argc : Nat;
       pragma Import (C, save_argc);
-      --  Saved value of argc (number of arguments), imported from misc.c
+      --  Saved value of argc (number of arguments), imported from misc.cc
 
       save_argv : Arg_Array_Ptr;
       pragma Import (C, save_argv);
-      --  Saved value of argv (argument pointers), imported from misc.c
+      --  Saved value of argv (argument pointers), imported from misc.cc
 
       gnat_argc : Nat;
       gnat_argv : Arg_Array_Ptr;