| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- G N A T N A M E -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2001-2022, 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 Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Ada.Characters.Handling; use Ada.Characters.Handling; |
| with Ada.Command_Line; use Ada.Command_Line; |
| with Ada.Text_IO; use Ada.Text_IO; |
| |
| with GNAT.Command_Line; use GNAT.Command_Line; |
| with GNAT.Directory_Operations; use GNAT.Directory_Operations; |
| with GNAT.Dynamic_Tables; |
| with GNAT.OS_Lib; use GNAT.OS_Lib; |
| |
| with Make_Util; use Make_Util; |
| with Namet; use Namet; |
| with Opt; |
| with Osint; use Osint; |
| with Output; |
| with Switch; use Switch; |
| with Table; |
| with Tempdir; |
| with Types; use Types; |
| |
| with System.CRTL; |
| with System.Regexp; use System.Regexp; |
| |
| procedure Gnatname is |
| |
| pragma Warnings (Off); |
| type Matched_Type is (True, False, Excluded); |
| pragma Warnings (On); |
| |
| Create_Project : Boolean := False; |
| |
| Subdirs_Switch : constant String := "--subdirs="; |
| |
| Usage_Output : Boolean := False; |
| -- Set to True when usage is output, to avoid multiple output |
| |
| Usage_Needed : Boolean := False; |
| -- Set to True by -h switch |
| |
| Version_Output : Boolean := False; |
| -- Set to True when version is output, to avoid multiple output |
| |
| Very_Verbose : Boolean := False; |
| -- Set to True with -v -v |
| |
| File_Path : String_Access := new String'("gnat.adc"); |
| -- Path name of the file specified by -c or -P switch |
| |
| File_Set : Boolean := False; |
| -- Set to True by -c or -P switch. |
| -- Used to detect multiple -c/-P switches. |
| |
| Args : Argument_List_Access; |
| -- The list of arguments for calls to the compiler to get the unit names |
| -- and kinds (spec or body) in the Ada sources. |
| |
| Path_Name : String_Access; |
| |
| Path_Last : Natural; |
| |
| Directory_Last : Natural := 0; |
| |
| function Dup (Fd : File_Descriptor) return File_Descriptor; |
| |
| procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); |
| |
| Gcc : constant String := "gcc"; |
| Gcc_Path : String_Access := null; |
| |
| package Patterns is new GNAT.Dynamic_Tables |
| (Table_Component_Type => String_Access, |
| Table_Index_Type => Natural, |
| Table_Low_Bound => 0, |
| Table_Initial => 10, |
| Table_Increment => 100); |
| -- Table to accumulate the patterns |
| |
| type Argument_Data is record |
| Directories : Patterns.Instance; |
| Name_Patterns : Patterns.Instance; |
| Excluded_Patterns : Patterns.Instance; |
| Foreign_Patterns : Patterns.Instance; |
| end record; |
| |
| package Arguments is new Table.Table |
| (Table_Component_Type => Argument_Data, |
| Table_Index_Type => Natural, |
| Table_Low_Bound => 0, |
| Table_Initial => 10, |
| Table_Increment => 100, |
| Table_Name => "Gnatname.Arguments"); |
| -- Table to accumulate directories and patterns |
| |
| package Preprocessor_Switches is new Table.Table |
| (Table_Component_Type => String_Access, |
| Table_Index_Type => Natural, |
| Table_Low_Bound => 0, |
| Table_Initial => 10, |
| Table_Increment => 100, |
| Table_Name => "Gnatname.Preprocessor_Switches"); |
| -- Table to store the preprocessor switches to be used in the call |
| -- to the compiler. |
| |
| type Source is record |
| File_Name : Name_Id; |
| Unit_Name : Name_Id; |
| Index : Int := 0; |
| Spec : Boolean; |
| end record; |
| |
| package Processed_Directories is new Table.Table |
| (Table_Component_Type => String_Access, |
| Table_Index_Type => Natural, |
| Table_Low_Bound => 0, |
| Table_Initial => 10, |
| Table_Increment => 100, |
| Table_Name => "Prj.Makr.Processed_Directories"); |
| -- The list of already processed directories for each section, to avoid |
| -- processing several times the same directory in the same section. |
| |
| package Sources is new Table.Table |
| (Table_Component_Type => Source, |
| Table_Index_Type => Natural, |
| Table_Low_Bound => 0, |
| Table_Initial => 10, |
| Table_Increment => 100, |
| Table_Name => "Gnatname.Sources"); |
| -- The list of Ada sources found, with their unit name and kind, to be put |
| -- in the pragmas Source_File_Name in the configuration pragmas file. |
| |
| procedure Output_Version; |
| -- Print name and version |
| |
| procedure Usage; |
| -- Print usage |
| |
| procedure Scan_Args; |
| -- Scan the command line arguments |
| |
| procedure Add_Source_Directory (S : String); |
| -- Add S in the Source_Directories table |
| |
| procedure Get_Directories (From_File : String); |
| -- Read a source directory text file |
| |
| procedure Write_Eol; |
| -- Output an empty line |
| |
| procedure Write_A_String (S : String); |
| -- Write a String to Output_FD |
| |
| procedure Initialize |
| (File_Path : String; |
| Preproc_Switches : Argument_List); |
| -- Start the creation of a configuration pragmas file |
| -- |
| -- File_Path is the name of the configuration pragmas file to create |
| -- |
| -- Preproc_Switches is a list of switches to be used when invoking the |
| -- compiler to get the name and kind of unit of a source file. |
| |
| type Regexp_List is array (Positive range <>) of Regexp; |
| |
| procedure Process |
| (Directories : Argument_List; |
| Name_Patterns : Regexp_List; |
| Excluded_Patterns : Regexp_List; |
| Foreign_Patterns : Regexp_List); |
| -- Look for source files in the specified directories, with the specified |
| -- patterns. |
| -- |
| -- Directories is the list of source directories where to look for sources. |
| -- |
| -- Name_Patterns is a potentially empty list of file name patterns to check |
| -- for Ada Sources. |
| -- |
| -- Excluded_Patterns is a potentially empty list of file name patterns that |
| -- should not be checked for Ada or non Ada sources. |
| -- |
| -- Foreign_Patterns is a potentially empty list of file name patterns to |
| -- check for non Ada sources. |
| -- |
| -- At least one of Name_Patterns and Foreign_Patterns is not empty |
| |
| procedure Finalize; |
| -- Write the configuration pragmas file indicated in a call to procedure |
| -- Initialize, after one or several calls to procedure Process. |
| |
| -------------------------- |
| -- Add_Source_Directory -- |
| -------------------------- |
| |
| procedure Add_Source_Directory (S : String) is |
| begin |
| Patterns.Append |
| (Arguments.Table (Arguments.Last).Directories, new String'(S)); |
| end Add_Source_Directory; |
| |
| --------- |
| -- Dup -- |
| --------- |
| |
| function Dup (Fd : File_Descriptor) return File_Descriptor is |
| begin |
| return File_Descriptor (System.CRTL.dup (Integer (Fd))); |
| end Dup; |
| |
| ---------- |
| -- Dup2 -- |
| ---------- |
| |
| procedure Dup2 (Old_Fd, New_Fd : File_Descriptor) is |
| Fd : Integer; |
| pragma Warnings (Off, Fd); |
| begin |
| Fd := System.CRTL.dup2 (Integer (Old_Fd), Integer (New_Fd)); |
| end Dup2; |
| |
| --------------------- |
| -- Get_Directories -- |
| --------------------- |
| |
| procedure Get_Directories (From_File : String) is |
| File : Ada.Text_IO.File_Type; |
| Line : String (1 .. 2_000); |
| Last : Natural; |
| |
| begin |
| Open (File, In_File, From_File); |
| |
| while not End_Of_File (File) loop |
| Get_Line (File, Line, Last); |
| |
| if Last /= 0 then |
| Add_Source_Directory (Line (1 .. Last)); |
| end if; |
| end loop; |
| |
| Close (File); |
| |
| exception |
| when Name_Error => |
| Fail ("cannot open source directory file """ & From_File & '"'); |
| end Get_Directories; |
| |
| -------------- |
| -- Finalize -- |
| -------------- |
| |
| procedure Finalize is |
| Discard : Boolean; |
| pragma Warnings (Off, Discard); |
| |
| begin |
| -- Delete the file if it already exists |
| |
| Delete_File |
| (Path_Name (Directory_Last + 1 .. Path_Last), |
| Success => Discard); |
| |
| -- Create a new one |
| |
| if Opt.Verbose_Mode then |
| Output.Write_Str ("Creating new file """); |
| Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last)); |
| Output.Write_Line (""""); |
| end if; |
| |
| Output_FD := Create_New_File |
| (Path_Name (Directory_Last + 1 .. Path_Last), |
| Fmode => Text); |
| |
| -- Fails if file cannot be created |
| |
| if Output_FD = Invalid_FD then |
| Fail_Program |
| ("cannot create new """ & Path_Name (1 .. Path_Last) & """"); |
| end if; |
| |
| -- For each Ada source, write a pragma Source_File_Name to the |
| -- configuration pragmas file. |
| |
| for Index in 1 .. Sources.Last loop |
| if Sources.Table (Index).Unit_Name /= No_Name then |
| Write_A_String ("pragma Source_File_Name"); |
| Write_Eol; |
| Write_A_String (" ("); |
| Write_A_String |
| (Get_Name_String (Sources.Table (Index).Unit_Name)); |
| Write_A_String (","); |
| Write_Eol; |
| |
| if Sources.Table (Index).Spec then |
| Write_A_String (" Spec_File_Name => """); |
| |
| else |
| Write_A_String (" Body_File_Name => """); |
| end if; |
| |
| Write_A_String |
| (Get_Name_String (Sources.Table (Index).File_Name)); |
| |
| Write_A_String (""""); |
| |
| if Sources.Table (Index).Index /= 0 then |
| Write_A_String (", Index =>"); |
| Write_A_String (Sources.Table (Index).Index'Img); |
| end if; |
| |
| Write_A_String (");"); |
| Write_Eol; |
| end if; |
| end loop; |
| |
| Close (Output_FD); |
| end Finalize; |
| |
| ---------------- |
| -- Initialize -- |
| ---------------- |
| |
| procedure Initialize |
| (File_Path : String; |
| Preproc_Switches : Argument_List) |
| is |
| begin |
| Sources.Set_Last (0); |
| |
| -- Initialize the compiler switches |
| |
| Args := new Argument_List (1 .. Preproc_Switches'Length + 6); |
| Args (1) := new String'("-c"); |
| Args (2) := new String'("-gnats"); |
| Args (3) := new String'("-gnatu"); |
| Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches; |
| Args (4 + Preproc_Switches'Length) := new String'("-x"); |
| Args (5 + Preproc_Switches'Length) := new String'("ada"); |
| |
| -- Get the path and file names |
| |
| Path_Name := new |
| String (1 .. File_Path'Length); |
| Path_Last := File_Path'Length; |
| |
| if File_Names_Case_Sensitive then |
| Path_Name (1 .. Path_Last) := File_Path; |
| else |
| Path_Name (1 .. Path_Last) := To_Lower (File_Path); |
| end if; |
| |
| -- Get the end of directory information, if any |
| |
| for Index in reverse 1 .. Path_Last loop |
| if Path_Name (Index) = Directory_Separator then |
| Directory_Last := Index; |
| exit; |
| end if; |
| end loop; |
| |
| -- Change the current directory to the directory of the project file, |
| -- if any directory information is specified. |
| |
| if Directory_Last /= 0 then |
| begin |
| Change_Dir (Path_Name (1 .. Directory_Last)); |
| exception |
| when Directory_Error => |
| Fail_Program |
| ("unknown directory """ |
| & Path_Name (1 .. Directory_Last) |
| & """"); |
| end; |
| end if; |
| end Initialize; |
| |
| ------------- |
| -- Process -- |
| ------------- |
| |
| procedure Process |
| (Directories : Argument_List; |
| Name_Patterns : Regexp_List; |
| Excluded_Patterns : Regexp_List; |
| Foreign_Patterns : Regexp_List) |
| is |
| procedure Process_Directory (Dir_Name : String); |
| -- Look for Ada and foreign sources in a directory, according to the |
| -- patterns. |
| |
| ----------------------- |
| -- Process_Directory -- |
| ----------------------- |
| |
| procedure Process_Directory (Dir_Name : String) is |
| Matched : Matched_Type := False; |
| Str : String (1 .. 2_000); |
| Canon : String (1 .. 2_000); |
| Last : Natural; |
| Dir : Dir_Type; |
| Do_Process : Boolean := True; |
| |
| Temp_File_Name : String_Access := null; |
| Save_Last_Source_Index : Natural := 0; |
| File_Name_Id : Name_Id := No_Name; |
| |
| Current_Source : Source; |
| |
| begin |
| -- Avoid processing the same directory more than once |
| |
| for Index in 1 .. Processed_Directories.Last loop |
| if Processed_Directories.Table (Index).all = Dir_Name then |
| Do_Process := False; |
| exit; |
| end if; |
| end loop; |
| |
| if Do_Process then |
| if Opt.Verbose_Mode then |
| Output.Write_Str ("Processing directory """); |
| Output.Write_Str (Dir_Name); |
| Output.Write_Line (""""); |
| end if; |
| |
| Processed_Directories. Increment_Last; |
| Processed_Directories.Table (Processed_Directories.Last) := |
| new String'(Dir_Name); |
| |
| -- Get the source file names from the directory. Fails if the |
| -- directory does not exist. |
| |
| begin |
| Open (Dir, Dir_Name); |
| exception |
| when Directory_Error => |
| Fail_Program ("cannot open directory """ & Dir_Name & """"); |
| end; |
| |
| -- Process each regular file in the directory |
| |
| File_Loop : loop |
| Read (Dir, Str, Last); |
| exit File_Loop when Last = 0; |
| |
| -- Copy the file name and put it in canonical case to match |
| -- against the patterns that have themselves already been put |
| -- in canonical case. |
| |
| Canon (1 .. Last) := Str (1 .. Last); |
| Canonical_Case_File_Name (Canon (1 .. Last)); |
| |
| if Is_Regular_File |
| (Dir_Name & Directory_Separator & Str (1 .. Last)) |
| then |
| Matched := True; |
| |
| Name_Len := Last; |
| Name_Buffer (1 .. Name_Len) := Str (1 .. Last); |
| File_Name_Id := Name_Find; |
| |
| -- First, check if the file name matches at least one of |
| -- the excluded expressions; |
| |
| for Index in Excluded_Patterns'Range loop |
| if |
| Match (Canon (1 .. Last), Excluded_Patterns (Index)) |
| then |
| Matched := Excluded; |
| exit; |
| end if; |
| end loop; |
| |
| -- If it does not match any of the excluded expressions, |
| -- check if the file name matches at least one of the |
| -- regular expressions. |
| |
| if Matched = True then |
| Matched := False; |
| |
| for Index in Name_Patterns'Range loop |
| if |
| Match |
| (Canon (1 .. Last), Name_Patterns (Index)) |
| then |
| Matched := True; |
| exit; |
| end if; |
| end loop; |
| end if; |
| |
| if Very_Verbose |
| or else (Matched = True and then Opt.Verbose_Mode) |
| then |
| Output.Write_Str (" Checking """); |
| Output.Write_Str (Str (1 .. Last)); |
| Output.Write_Line (""": "); |
| end if; |
| |
| -- If the file name matches one of the regular expressions, |
| -- parse it to get its unit name. |
| |
| if Matched = True then |
| declare |
| FD : File_Descriptor; |
| Success : Boolean; |
| Saved_Output : File_Descriptor; |
| Saved_Error : File_Descriptor; |
| Tmp_File : Path_Name_Type; |
| |
| begin |
| -- If we don't have the path of the compiler yet, |
| -- get it now. The compiler name may have a prefix, |
| -- so we get the potentially prefixed name. |
| |
| if Gcc_Path = null then |
| declare |
| Prefix_Gcc : String_Access := |
| Program_Name (Gcc, "gnatname"); |
| begin |
| Gcc_Path := |
| Locate_Exec_On_Path (Prefix_Gcc.all); |
| Free (Prefix_Gcc); |
| end; |
| |
| if Gcc_Path = null then |
| Fail_Program ("could not locate " & Gcc); |
| end if; |
| end if; |
| |
| -- Create the temporary file |
| |
| Tempdir.Create_Temp_File (FD, Tmp_File); |
| |
| if FD = Invalid_FD then |
| Fail_Program |
| ("could not create temporary file"); |
| |
| else |
| Temp_File_Name := |
| new String'(Get_Name_String (Tmp_File)); |
| end if; |
| |
| Args (Args'Last) := |
| new String' |
| (Dir_Name & Directory_Separator & Str (1 .. Last)); |
| |
| -- Save the standard output and error |
| |
| Saved_Output := Dup (Standout); |
| Saved_Error := Dup (Standerr); |
| |
| -- Set standard output and error to the temporary file |
| |
| Dup2 (FD, Standout); |
| Dup2 (FD, Standerr); |
| |
| -- And spawn the compiler |
| |
| Spawn (Gcc_Path.all, Args.all, Success); |
| |
| -- Restore the standard output and error |
| |
| Dup2 (Saved_Output, Standout); |
| Dup2 (Saved_Error, Standerr); |
| |
| -- Close the temporary file |
| |
| Close (FD); |
| |
| -- And close the saved standard output and error to |
| -- avoid too many file descriptors. |
| |
| Close (Saved_Output); |
| Close (Saved_Error); |
| |
| -- Now that standard output is restored, check if |
| -- the compiler ran correctly. |
| |
| -- Read the lines of the temporary file: |
| -- they should contain the kind and name of the unit. |
| |
| declare |
| File : Ada.Text_IO.File_Type; |
| Text_Line : String (1 .. 1_000); |
| Text_Last : Natural; |
| |
| begin |
| begin |
| Open (File, In_File, Temp_File_Name.all); |
| |
| exception |
| when others => |
| Fail_Program |
| ("could not read temporary file " & |
| Temp_File_Name.all); |
| end; |
| |
| Save_Last_Source_Index := Sources.Last; |
| |
| if End_Of_File (File) then |
| if Opt.Verbose_Mode then |
| if not Success then |
| Output.Write_Str (" (process died) "); |
| end if; |
| end if; |
| |
| else |
| Line_Loop : while not End_Of_File (File) loop |
| Get_Line (File, Text_Line, Text_Last); |
| |
| -- Find the first closing parenthesis |
| |
| Char_Loop : for J in 1 .. Text_Last loop |
| if Text_Line (J) = ')' then |
| if J >= 13 and then |
| Text_Line (1 .. 4) = "Unit" |
| then |
| -- Add entry to Sources table |
| |
| Name_Len := J - 12; |
| Name_Buffer (1 .. Name_Len) := |
| Text_Line (6 .. J - 7); |
| Current_Source := |
| (Unit_Name => Name_Find, |
| File_Name => File_Name_Id, |
| Index => 0, |
| Spec => Text_Line (J - 5 .. J) = |
| "(spec)"); |
| |
| Sources.Append (Current_Source); |
| end if; |
| |
| exit Char_Loop; |
| end if; |
| end loop Char_Loop; |
| end loop Line_Loop; |
| end if; |
| |
| if Save_Last_Source_Index = Sources.Last then |
| if Opt.Verbose_Mode then |
| Output.Write_Line (" not a unit"); |
| end if; |
| |
| else |
| if Sources.Last > |
| Save_Last_Source_Index + 1 |
| then |
| for Index in Save_Last_Source_Index + 1 .. |
| Sources.Last |
| loop |
| Sources.Table (Index).Index := |
| Int (Index - Save_Last_Source_Index); |
| end loop; |
| end if; |
| |
| for Index in Save_Last_Source_Index + 1 .. |
| Sources.Last |
| loop |
| Current_Source := Sources.Table (Index); |
| pragma Annotate |
| (CodePeer, Modified, Current_Source); |
| |
| if Opt.Verbose_Mode then |
| if Current_Source.Spec then |
| Output.Write_Str (" spec of "); |
| |
| else |
| Output.Write_Str (" body of "); |
| end if; |
| |
| Output.Write_Line |
| (Get_Name_String |
| (Current_Source.Unit_Name)); |
| end if; |
| end loop; |
| end if; |
| |
| Close (File); |
| |
| Delete_File (Temp_File_Name.all, Success); |
| end; |
| end; |
| |
| -- File name matches none of the regular expressions |
| |
| else |
| -- If file is not excluded, see if this is foreign source |
| |
| if Matched /= Excluded then |
| for Index in Foreign_Patterns'Range loop |
| if Match (Canon (1 .. Last), |
| Foreign_Patterns (Index)) |
| then |
| Matched := True; |
| exit; |
| end if; |
| end loop; |
| end if; |
| |
| if Very_Verbose then |
| case Matched is |
| when False => |
| Output.Write_Line ("no match"); |
| |
| when Excluded => |
| Output.Write_Line ("excluded"); |
| |
| when True => |
| Output.Write_Line ("foreign source"); |
| end case; |
| end if; |
| |
| if Matched = True then |
| |
| -- Add source file name without unit name |
| |
| Name_Len := 0; |
| Add_Str_To_Name_Buffer (Canon (1 .. Last)); |
| Sources.Append |
| ((File_Name => Name_Find, |
| Unit_Name => No_Name, |
| Index => 0, |
| Spec => False)); |
| end if; |
| end if; |
| end if; |
| end loop File_Loop; |
| |
| Close (Dir); |
| end if; |
| |
| end Process_Directory; |
| |
| -- Start of processing for Process |
| |
| begin |
| Processed_Directories.Set_Last (0); |
| |
| -- Process each directory |
| |
| for Index in Directories'Range loop |
| Process_Directory (Directories (Index).all); |
| end loop; |
| end Process; |
| |
| -------------------- |
| -- Output_Version -- |
| -------------------- |
| |
| procedure Output_Version is |
| begin |
| if not Version_Output then |
| Version_Output := True; |
| Output.Write_Eol; |
| Display_Version ("GNATNAME", "2001"); |
| end if; |
| end Output_Version; |
| |
| --------------- |
| -- Scan_Args -- |
| --------------- |
| |
| procedure Scan_Args is |
| |
| procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); |
| |
| Project_File_Name_Expected : Boolean; |
| |
| Pragmas_File_Expected : Boolean; |
| |
| Directory_Expected : Boolean; |
| |
| Dir_File_Name_Expected : Boolean; |
| |
| Foreign_Pattern_Expected : Boolean; |
| |
| Excluded_Pattern_Expected : Boolean; |
| |
| procedure Check_Regular_Expression (S : String); |
| -- Compile string S into a Regexp, fail if any error |
| |
| ----------------------------- |
| -- Check_Regular_Expression-- |
| ----------------------------- |
| |
| procedure Check_Regular_Expression (S : String) is |
| Dummy : Regexp; |
| pragma Warnings (Off, Dummy); |
| begin |
| Dummy := Compile (S, Glob => True); |
| exception |
| when Error_In_Regexp => |
| Fail ("invalid regular expression """ & S & """"); |
| end Check_Regular_Expression; |
| |
| -- Start of processing for Scan_Args |
| |
| begin |
| -- First check for --version or --help |
| |
| Check_Version_And_Help ("GNATNAME", "2001"); |
| |
| -- Now scan the other switches |
| |
| Project_File_Name_Expected := False; |
| Pragmas_File_Expected := False; |
| Directory_Expected := False; |
| Dir_File_Name_Expected := False; |
| Foreign_Pattern_Expected := False; |
| Excluded_Pattern_Expected := False; |
| |
| for Next_Arg in 1 .. Argument_Count loop |
| declare |
| Next_Argv : constant String := Argument (Next_Arg); |
| Arg : String (1 .. Next_Argv'Length) := Next_Argv; |
| |
| begin |
| if Arg'Length > 0 then |
| |
| -- -P xxx |
| |
| if Project_File_Name_Expected then |
| if Arg (1) = '-' then |
| Fail ("project file name missing"); |
| |
| else |
| File_Set := True; |
| File_Path := new String'(Arg); |
| Project_File_Name_Expected := False; |
| end if; |
| |
| -- -c file |
| |
| elsif Pragmas_File_Expected then |
| File_Set := True; |
| File_Path := new String'(Arg); |
| Pragmas_File_Expected := False; |
| |
| -- -d xxx |
| |
| elsif Directory_Expected then |
| Add_Source_Directory (Arg); |
| Directory_Expected := False; |
| |
| -- -D xxx |
| |
| elsif Dir_File_Name_Expected then |
| Get_Directories (Arg); |
| Dir_File_Name_Expected := False; |
| |
| -- -f xxx |
| |
| elsif Foreign_Pattern_Expected then |
| Patterns.Append |
| (Arguments.Table (Arguments.Last).Foreign_Patterns, |
| new String'(Arg)); |
| Check_Regular_Expression (Arg); |
| Foreign_Pattern_Expected := False; |
| |
| -- -x xxx |
| |
| elsif Excluded_Pattern_Expected then |
| Patterns.Append |
| (Arguments.Table (Arguments.Last).Excluded_Patterns, |
| new String'(Arg)); |
| Check_Regular_Expression (Arg); |
| Excluded_Pattern_Expected := False; |
| |
| -- There must be at least one Ada pattern or one foreign |
| -- pattern for the previous section. |
| |
| -- --and |
| |
| elsif Arg = "--and" then |
| |
| if Patterns.Last |
| (Arguments.Table (Arguments.Last).Name_Patterns) = 0 |
| and then |
| Patterns.Last |
| (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0 |
| then |
| Try_Help; |
| return; |
| end if; |
| |
| -- If no directory were specified for the previous section, |
| -- then the directory is the project directory. |
| |
| if Patterns.Last |
| (Arguments.Table (Arguments.Last).Directories) = 0 |
| then |
| Patterns.Append |
| (Arguments.Table (Arguments.Last).Directories, |
| new String'(".")); |
| end if; |
| |
| -- Add and initialize another component to Arguments table |
| |
| declare |
| New_Arguments : Argument_Data; |
| pragma Warnings (Off, New_Arguments); |
| -- Declaring this defaulted initialized object ensures |
| -- that the new allocated component of table Arguments |
| -- is correctly initialized. |
| |
| -- This is VERY ugly, Table should never be used with |
| -- data requiring default initialization. We should |
| -- find a way to avoid violating this rule ??? |
| |
| begin |
| Arguments.Append (New_Arguments); |
| end; |
| |
| Patterns.Init |
| (Arguments.Table (Arguments.Last).Directories); |
| Patterns.Set_Last |
| (Arguments.Table (Arguments.Last).Directories, 0); |
| Patterns.Init |
| (Arguments.Table (Arguments.Last).Name_Patterns); |
| Patterns.Set_Last |
| (Arguments.Table (Arguments.Last).Name_Patterns, 0); |
| Patterns.Init |
| (Arguments.Table (Arguments.Last).Excluded_Patterns); |
| Patterns.Set_Last |
| (Arguments.Table (Arguments.Last).Excluded_Patterns, 0); |
| Patterns.Init |
| (Arguments.Table (Arguments.Last).Foreign_Patterns); |
| Patterns.Set_Last |
| (Arguments.Table (Arguments.Last).Foreign_Patterns, 0); |
| |
| -- Subdirectory switch |
| |
| elsif Arg'Length > Subdirs_Switch'Length |
| and then Arg (1 .. Subdirs_Switch'Length) = Subdirs_Switch |
| then |
| null; |
| -- Subdirs are only used in gprname |
| |
| -- --no-backup |
| |
| elsif Arg = "--no-backup" then |
| Opt.No_Backup := True; |
| |
| -- -c |
| |
| elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-c" then |
| if File_Set then |
| Fail ("only one -P or -c switch may be specified"); |
| end if; |
| |
| if Arg'Length = 2 then |
| Pragmas_File_Expected := True; |
| |
| if Next_Arg = Argument_Count then |
| Fail ("configuration pragmas file name missing"); |
| end if; |
| |
| else |
| File_Set := True; |
| File_Path := new String'(Arg (3 .. Arg'Last)); |
| end if; |
| |
| -- -d |
| |
| elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-d" then |
| if Arg'Length = 2 then |
| Directory_Expected := True; |
| |
| if Next_Arg = Argument_Count then |
| Fail ("directory name missing"); |
| end if; |
| |
| else |
| Add_Source_Directory (Arg (3 .. Arg'Last)); |
| end if; |
| |
| -- -D |
| |
| elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-D" then |
| if Arg'Length = 2 then |
| Dir_File_Name_Expected := True; |
| |
| if Next_Arg = Argument_Count then |
| Fail ("directory list file name missing"); |
| end if; |
| |
| else |
| Get_Directories (Arg (3 .. Arg'Last)); |
| end if; |
| |
| -- -eL |
| |
| elsif Arg = "-eL" then |
| Opt.Follow_Links_For_Files := True; |
| Opt.Follow_Links_For_Dirs := True; |
| |
| -- -f |
| |
| elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-f" then |
| if Arg'Length = 2 then |
| Foreign_Pattern_Expected := True; |
| |
| if Next_Arg = Argument_Count then |
| Fail ("foreign pattern missing"); |
| end if; |
| |
| else |
| Patterns.Append |
| (Arguments.Table (Arguments.Last).Foreign_Patterns, |
| new String'(Arg (3 .. Arg'Last))); |
| Check_Regular_Expression (Arg (3 .. Arg'Last)); |
| end if; |
| |
| -- -gnatep or -gnateD |
| |
| elsif Arg'Length > 7 and then |
| (Arg (1 .. 7) = "-gnatep" or else Arg (1 .. 7) = "-gnateD") |
| then |
| Preprocessor_Switches.Append (new String'(Arg)); |
| |
| -- -h |
| |
| elsif Arg = "-h" then |
| Usage_Needed := True; |
| |
| -- -P |
| |
| elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-P" then |
| if File_Set then |
| Fail ("only one -c or -P switch may be specified"); |
| end if; |
| |
| if Arg'Length = 2 then |
| if Next_Arg = Argument_Count then |
| Fail ("project file name missing"); |
| |
| else |
| Project_File_Name_Expected := True; |
| end if; |
| |
| else |
| File_Set := True; |
| File_Path := new String'(Arg (3 .. Arg'Last)); |
| end if; |
| |
| Create_Project := True; |
| |
| -- -v |
| |
| elsif Arg = "-v" then |
| if Opt.Verbose_Mode then |
| Very_Verbose := True; |
| else |
| Opt.Verbose_Mode := True; |
| end if; |
| |
| -- -x |
| |
| elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-x" then |
| if Arg'Length = 2 then |
| Excluded_Pattern_Expected := True; |
| |
| if Next_Arg = Argument_Count then |
| Fail ("excluded pattern missing"); |
| end if; |
| |
| else |
| Patterns.Append |
| (Arguments.Table (Arguments.Last).Excluded_Patterns, |
| new String'(Arg (3 .. Arg'Last))); |
| Check_Regular_Expression (Arg (3 .. Arg'Last)); |
| end if; |
| |
| -- Junk switch starting with minus |
| |
| elsif Arg (1) = '-' then |
| Fail ("wrong switch: " & Arg); |
| |
| -- Not a recognized switch, assume file name |
| |
| else |
| Canonical_Case_File_Name (Arg); |
| Patterns.Append |
| (Arguments.Table (Arguments.Last).Name_Patterns, |
| new String'(Arg)); |
| Check_Regular_Expression (Arg); |
| end if; |
| end if; |
| end; |
| end loop; |
| end Scan_Args; |
| |
| ----------- |
| -- Usage -- |
| ----------- |
| |
| procedure Usage is |
| begin |
| if not Usage_Output then |
| Usage_Needed := False; |
| Usage_Output := True; |
| Output.Write_Str ("Usage: "); |
| Osint.Write_Program_Name; |
| Output.Write_Line (" [switches] naming-pattern [naming-patterns]"); |
| Output.Write_Line |
| (" {--and [switches] naming-pattern [naming-patterns]}"); |
| Output.Write_Eol; |
| Output.Write_Line ("switches:"); |
| |
| Display_Usage_Version_And_Help; |
| |
| Output.Write_Line |
| (" --subdirs=dir real obj/lib/exec dirs are subdirs"); |
| Output.Write_Line |
| (" --no-backup do not create backup of project file"); |
| Output.Write_Eol; |
| |
| Output.Write_Line (" --and use different patterns"); |
| Output.Write_Eol; |
| |
| Output.Write_Line |
| (" -cfile create configuration pragmas file"); |
| Output.Write_Line (" -ddir use dir as one of the source " & |
| "directories"); |
| Output.Write_Line (" -Dfile get source directories from file"); |
| Output.Write_Line |
| (" -eL follow symbolic links when processing " & |
| "project files"); |
| Output.Write_Line (" -fpat foreign pattern"); |
| Output.Write_Line |
| (" -gnateDsym=v preprocess with symbol definition"); |
| Output.Write_Line (" -gnatep=data preprocess files with data file"); |
| Output.Write_Line (" -h output this help message"); |
| Output.Write_Line |
| (" -Pproj update or create project file proj"); |
| Output.Write_Line (" -v verbose output"); |
| Output.Write_Line (" -v -v very verbose output"); |
| Output.Write_Line (" -xpat exclude pattern pat"); |
| end if; |
| end Usage; |
| |
| --------------- |
| -- Write_Eol -- |
| --------------- |
| |
| procedure Write_Eol is |
| begin |
| Write_A_String ((1 => ASCII.LF)); |
| end Write_Eol; |
| |
| -------------------- |
| -- Write_A_String -- |
| -------------------- |
| |
| procedure Write_A_String (S : String) is |
| Str : String (1 .. S'Length); |
| |
| begin |
| if S'Length > 0 then |
| Str := S; |
| |
| if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then |
| Fail_Program ("disk full"); |
| end if; |
| end if; |
| end Write_A_String; |
| |
| -- Start of processing for Gnatname |
| |
| begin |
| -- Add the directory where gnatname is invoked in front of the |
| -- path, if gnatname is invoked with directory information. |
| |
| declare |
| Command : constant String := Command_Name; |
| |
| begin |
| for Index in reverse Command'Range loop |
| if Command (Index) = Directory_Separator then |
| declare |
| Absolute_Dir : constant String := |
| Normalize_Pathname |
| (Command (Command'First .. Index)); |
| |
| PATH : constant String := |
| Absolute_Dir & |
| Path_Separator & |
| Getenv ("PATH").all; |
| |
| begin |
| Setenv ("PATH", PATH); |
| end; |
| |
| exit; |
| end if; |
| end loop; |
| end; |
| |
| -- Initialize tables |
| |
| Arguments.Set_Last (0); |
| declare |
| New_Arguments : Argument_Data; |
| pragma Warnings (Off, New_Arguments); |
| -- Declaring this defaulted initialized object ensures that the new |
| -- allocated component of table Arguments is correctly initialized. |
| begin |
| Arguments.Append (New_Arguments); |
| end; |
| |
| Patterns.Init (Arguments.Table (1).Directories); |
| Patterns.Set_Last (Arguments.Table (1).Directories, 0); |
| Patterns.Init (Arguments.Table (1).Name_Patterns); |
| Patterns.Set_Last (Arguments.Table (1).Name_Patterns, 0); |
| Patterns.Init (Arguments.Table (1).Excluded_Patterns); |
| Patterns.Set_Last (Arguments.Table (1).Excluded_Patterns, 0); |
| Patterns.Init (Arguments.Table (1).Foreign_Patterns); |
| Patterns.Set_Last (Arguments.Table (1).Foreign_Patterns, 0); |
| |
| Preprocessor_Switches.Set_Last (0); |
| |
| -- Get the arguments |
| |
| Scan_Args; |
| |
| if Create_Project then |
| declare |
| Gprname_Path : constant String_Access := |
| Locate_Exec_On_Path ("gprname"); |
| Arg_Len : Natural := Argument_Count; |
| Pos : Natural := 0; |
| Target : String_Access := null; |
| Success : Boolean := False; |
| begin |
| if Gprname_Path = null then |
| Fail_Program |
| ("project files are no longer supported by gnatname;" & |
| " use gprname instead"); |
| end if; |
| |
| Find_Program_Name; |
| |
| if Name_Len > 9 |
| and then Name_Buffer (Name_Len - 7 .. Name_Len) = "gnatname" |
| then |
| Target := new String'(Name_Buffer (1 .. Name_Len - 9)); |
| Arg_Len := Arg_Len + 1; |
| end if; |
| |
| declare |
| Args : Argument_List (1 .. Arg_Len); |
| begin |
| if Target /= null then |
| Args (1) := new String'("--target=" & Target.all); |
| Pos := 1; |
| end if; |
| |
| for J in 1 .. Argument_Count loop |
| Pos := Pos + 1; |
| Args (Pos) := new String'(Argument (J)); |
| end loop; |
| |
| Spawn (Gprname_Path.all, Args, Success); |
| |
| if Success then |
| Exit_Program (E_Success); |
| else |
| Exit_Program (E_Errors); |
| end if; |
| end; |
| end; |
| end if; |
| |
| if Opt.Verbose_Mode then |
| Output_Version; |
| end if; |
| |
| if Usage_Needed then |
| Usage; |
| end if; |
| |
| -- If no Ada or foreign pattern was specified, print the usage and return |
| |
| if Patterns.Last (Arguments.Table (Arguments.Last).Name_Patterns) = 0 |
| and then |
| Patterns.Last (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0 |
| then |
| if Argument_Count = 0 then |
| Usage; |
| elsif not Usage_Output then |
| Try_Help; |
| end if; |
| |
| return; |
| end if; |
| |
| -- If no source directory was specified, use the current directory as the |
| -- unique directory. Note that if a file was specified with directory |
| -- information, the current directory is the directory of the specified |
| -- file. |
| |
| if Patterns.Last (Arguments.Table (Arguments.Last).Directories) = 0 then |
| Patterns.Append |
| (Arguments.Table (Arguments.Last).Directories, new String'(".")); |
| end if; |
| |
| -- Initialize |
| |
| declare |
| Prep_Switches : Argument_List |
| (1 .. Integer (Preprocessor_Switches.Last)); |
| |
| begin |
| for Index in Prep_Switches'Range loop |
| Prep_Switches (Index) := Preprocessor_Switches.Table (Index); |
| end loop; |
| |
| Initialize |
| (File_Path => File_Path.all, |
| Preproc_Switches => Prep_Switches); |
| end; |
| |
| -- Process each section successively |
| |
| for J in 1 .. Arguments.Last loop |
| declare |
| Directories : Argument_List |
| (1 .. Integer |
| (Patterns.Last (Arguments.Table (J).Directories))); |
| Name_Patterns : Regexp_List |
| (1 .. Integer |
| (Patterns.Last (Arguments.Table (J).Name_Patterns))); |
| Excl_Patterns : Regexp_List |
| (1 .. Integer |
| (Patterns.Last (Arguments.Table (J).Excluded_Patterns))); |
| Frgn_Patterns : Regexp_List |
| (1 .. Integer |
| (Patterns.Last (Arguments.Table (J).Foreign_Patterns))); |
| |
| begin |
| -- Build the Directories and Patterns arguments |
| |
| for Index in Directories'Range loop |
| Directories (Index) := |
| Arguments.Table (J).Directories.Table (Index); |
| end loop; |
| |
| for Index in Name_Patterns'Range loop |
| Name_Patterns (Index) := |
| Compile |
| (Arguments.Table (J).Name_Patterns.Table (Index).all, |
| Glob => True); |
| end loop; |
| |
| for Index in Excl_Patterns'Range loop |
| Excl_Patterns (Index) := |
| Compile |
| (Arguments.Table (J).Excluded_Patterns.Table (Index).all, |
| Glob => True); |
| end loop; |
| |
| for Index in Frgn_Patterns'Range loop |
| Frgn_Patterns (Index) := |
| Compile |
| (Arguments.Table (J).Foreign_Patterns.Table (Index).all, |
| Glob => True); |
| end loop; |
| |
| -- Call Prj.Makr.Process where the real work is done |
| |
| Process |
| (Directories => Directories, |
| Name_Patterns => Name_Patterns, |
| Excluded_Patterns => Excl_Patterns, |
| Foreign_Patterns => Frgn_Patterns); |
| end; |
| end loop; |
| |
| -- Finalize |
| |
| Finalize; |
| |
| if Opt.Verbose_Mode then |
| Output.Write_Eol; |
| end if; |
| end Gnatname; |
