-- 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 --
-----------------------
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 --
-------------------
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
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;
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 --
----------
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
projects / thirdparty / gcc.git / commitdiff
