Mercurial > hg > CbC > CbC_gcc
diff gcc/ada/make_util.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/ada/make_util.adb Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,964 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M A K E _ U T I L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, 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 Atree; use Atree; +with Debug; +with Errutil; +with Osint; use Osint; +with Output; use Output; +with Opt; use Opt; +with Table; + +with Ada.Command_Line; use Ada.Command_Line; + +with GNAT.Case_Util; use GNAT.Case_Util; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.HTable; + +package body Make_Util is + + --------- + -- Add -- + --------- + + procedure Add + (Option : String_Access; + To : in out String_List_Access; + Last : in out Natural) + is + begin + if Last = To'Last then + declare + New_Options : constant String_List_Access := + new String_List (1 .. To'Last * 2); + + begin + New_Options (To'Range) := To.all; + + -- Set all elements of the original options to null to avoid + -- deallocation of copies. + + To.all := (others => null); + + Free (To); + To := New_Options; + end; + end if; + + Last := Last + 1; + To (Last) := Option; + end Add; + + procedure Add + (Option : String; + To : in out String_List_Access; + Last : in out Natural) + is + begin + Add (Option => new String'(Option), To => To, Last => Last); + end Add; + + ------------------------- + -- Base_Name_Index_For -- + ------------------------- + + function Base_Name_Index_For + (Main : String; + Main_Index : Int; + Index_Separator : Character) return File_Name_Type + is + Result : File_Name_Type; + + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (Base_Name (Main)); + + -- Remove the extension, if any, that is the last part of the base name + -- starting with a dot and following some characters. + + for J in reverse 2 .. Name_Len loop + if Name_Buffer (J) = '.' then + Name_Len := J - 1; + exit; + end if; + end loop; + + -- Add the index info, if index is different from 0 + + if Main_Index > 0 then + Add_Char_To_Name_Buffer (Index_Separator); + + declare + Img : constant String := Main_Index'Img; + begin + Add_Str_To_Name_Buffer (Img (2 .. Img'Last)); + end; + end if; + + Result := Name_Find; + return Result; + end Base_Name_Index_For; + + ----------------- + -- Create_Name -- + ----------------- + + function Create_Name (Name : String) return File_Name_Type is + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (Name); + return Name_Find; + end Create_Name; + + function Create_Name (Name : String) return Name_Id is + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (Name); + return Name_Find; + end Create_Name; + + function Create_Name (Name : String) return Path_Name_Type is + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (Name); + return Name_Find; + end Create_Name; + + --------------------------- + -- Ensure_Absolute_Path -- + --------------------------- + + procedure Ensure_Absolute_Path + (Switch : in out String_Access; + Parent : String; + Do_Fail : Fail_Proc; + For_Gnatbind : Boolean := False; + Including_Non_Switch : Boolean := True; + Including_RTS : Boolean := False) + is + begin + if Switch /= null then + declare + Sw : String (1 .. Switch'Length); + Start : Positive; + + begin + Sw := Switch.all; + + if Sw (1) = '-' then + if Sw'Length >= 3 + and then (Sw (2) = 'I' + or else (not For_Gnatbind + and then (Sw (2) = 'L' + or else + Sw (2) = 'A'))) + then + Start := 3; + + if Sw = "-I-" then + return; + end if; + + elsif Sw'Length >= 4 + and then + (Sw (2 .. 3) = "aL" or else + Sw (2 .. 3) = "aO" or else + Sw (2 .. 3) = "aI" + or else (For_Gnatbind and then Sw (2 .. 3) = "A=")) + then + Start := 4; + + elsif Including_RTS + and then Sw'Length >= 7 + and then Sw (2 .. 6) = "-RTS=" + then + Start := 7; + + else + return; + end if; + + -- Because relative path arguments to --RTS= may be relative to + -- the search directory prefix, those relative path arguments + -- are converted only when they include directory information. + + if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then + if Parent'Length = 0 then + Do_Fail + ("relative search path switches (""" + & Sw + & """) are not allowed"); + + elsif Including_RTS then + for J in Start .. Sw'Last loop + if Sw (J) = Directory_Separator then + Switch := + new String' + (Sw (1 .. Start - 1) + & Parent + & Directory_Separator + & Sw (Start .. Sw'Last)); + return; + end if; + end loop; + + else + Switch := + new String' + (Sw (1 .. Start - 1) + & Parent + & Directory_Separator + & Sw (Start .. Sw'Last)); + end if; + end if; + + elsif Including_Non_Switch then + if not Is_Absolute_Path (Sw) then + if Parent'Length = 0 then + Do_Fail + ("relative paths (""" & Sw & """) are not allowed"); + else + Switch := new String'(Parent & Directory_Separator & Sw); + end if; + end if; + end if; + end; + end if; + end Ensure_Absolute_Path; + + ---------------------------- + -- Executable_Prefix_Path -- + ---------------------------- + + function Executable_Prefix_Path return String is + Exec_Name : constant String := Command_Name; + + function Get_Install_Dir (S : String) return String; + -- S is the executable name preceded by the absolute or relative path, + -- e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory where "bin" + -- lies (in the example "C:\usr"). If the executable is not in a "bin" + -- directory, return "". + + --------------------- + -- Get_Install_Dir -- + --------------------- + + function Get_Install_Dir (S : String) return String is + Exec : String := S; + Path_Last : Integer := 0; + + begin + for J in reverse Exec'Range loop + if Exec (J) = Directory_Separator then + Path_Last := J - 1; + exit; + end if; + end loop; + + if Path_Last >= Exec'First + 2 then + To_Lower (Exec (Path_Last - 2 .. Path_Last)); + end if; + + if Path_Last < Exec'First + 2 + or else Exec (Path_Last - 2 .. Path_Last) /= "bin" + or else (Path_Last - 3 >= Exec'First + and then Exec (Path_Last - 3) /= Directory_Separator) + then + return ""; + end if; + + return Normalize_Pathname + (Exec (Exec'First .. Path_Last - 4), + Resolve_Links => Opt.Follow_Links_For_Dirs) + & Directory_Separator; + end Get_Install_Dir; + + -- Beginning of Executable_Prefix_Path + + begin + -- First determine if a path prefix was placed in front of the + -- executable name. + + for J in reverse Exec_Name'Range loop + if Exec_Name (J) = Directory_Separator then + return Get_Install_Dir (Exec_Name); + end if; + end loop; + + -- If we get here, the user has typed the executable name with no + -- directory prefix. + + declare + Path : String_Access := Locate_Exec_On_Path (Exec_Name); + begin + if Path = null then + return ""; + else + declare + Dir : constant String := Get_Install_Dir (Path.all); + begin + Free (Path); + return Dir; + end; + end if; + end; + end Executable_Prefix_Path; + + ------------------ + -- Fail_Program -- + ------------------ + + procedure Fail_Program + (S : String; + Flush_Messages : Boolean := True) + is + begin + if Flush_Messages and not No_Exit_Message then + if Total_Errors_Detected /= 0 or else Warnings_Detected /= 0 then + Errutil.Finalize; + end if; + end if; + + Finish_Program (E_Fatal, S => S); + end Fail_Program; + + -------------------- + -- Finish_Program -- + -------------------- + + procedure Finish_Program + (Exit_Code : Osint.Exit_Code_Type := Osint.E_Success; + S : String := "") + is + begin + if S'Length > 0 then + if Exit_Code /= E_Success then + if No_Exit_Message then + Osint.Exit_Program (E_Fatal); + else + Osint.Fail (S); + end if; + + elsif not No_Exit_Message then + Write_Str (S); + end if; + end if; + + -- Output Namet statistics + + Namet.Finalize; + + Exit_Program (Exit_Code); + end Finish_Program; + + ---------- + -- Hash -- + ---------- + + function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num); + -- Used in implementation of other functions Hash below + + ---------- + -- Hash -- + ---------- + + function Hash (Name : File_Name_Type) return Header_Num is + begin + return Hash (Get_Name_String (Name)); + end Hash; + + function Hash (Name : Name_Id) return Header_Num is + begin + return Hash (Get_Name_String (Name)); + end Hash; + + function Hash (Name : Path_Name_Type) return Header_Num is + begin + return Hash (Get_Name_String (Name)); + end Hash; + + ------------ + -- Inform -- + ------------ + + procedure Inform (N : File_Name_Type; Msg : String) is + begin + Inform (Name_Id (N), Msg); + end Inform; + + procedure Inform (N : Name_Id := No_Name; Msg : String) is + begin + Osint.Write_Program_Name; + + Write_Str (": "); + + if N /= No_Name then + Write_Str (""""); + + declare + Name : constant String := Get_Name_String (N); + begin + if Debug.Debug_Flag_F and then Is_Absolute_Path (Name) then + Write_Str (File_Name (Name)); + else + Write_Str (Name); + end if; + end; + + Write_Str (""" "); + end if; + + Write_Str (Msg); + Write_Eol; + end Inform; + + ----------- + -- Mains -- + ----------- + + package body Mains is + + package Names is new Table.Table + (Table_Component_Type => Main_Info, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Makeutl.Mains.Names"); + -- The table that stores the mains + + Current : Natural := 0; + -- The index of the last main retrieved from the table + + Count_Of_Mains_With_No_Tree : Natural := 0; + -- Number of main units for which we do not know the project tree + + -------------- + -- Add_Main -- + -------------- + + procedure Add_Main (Name : String; Index : Int := 0) is + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (Name); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + + Names.Increment_Last; + Names.Table (Names.Last) := (Name_Find, Index); + + Mains.Count_Of_Mains_With_No_Tree := + Mains.Count_Of_Mains_With_No_Tree + 1; + end Add_Main; + + ------------ + -- Delete -- + ------------ + + procedure Delete is + begin + Names.Set_Last (0); + Mains.Reset; + end Delete; + + --------------- + -- Next_Main -- + --------------- + + function Next_Main return String is + Info : constant Main_Info := Next_Main; + begin + if Info = No_Main_Info then + return ""; + else + return Get_Name_String (Info.File); + end if; + end Next_Main; + + function Next_Main return Main_Info is + begin + if Current >= Names.Last then + return No_Main_Info; + else + Current := Current + 1; + + declare + Orig_Main : constant File_Name_Type := + Names.Table (Current).File; + Current_Main : File_Name_Type; + + begin + if Strip_Suffix (Orig_Main) = Orig_Main then + Get_Name_String (Orig_Main); + Add_Str_To_Name_Buffer (".adb"); + Current_Main := Name_Find; + + if Full_Source_Name (Current_Main) = No_File then + Get_Name_String (Orig_Main); + Add_Str_To_Name_Buffer (".ads"); + Current_Main := Name_Find; + + if Full_Source_Name (Current_Main) /= No_File then + Names.Table (Current).File := Current_Main; + end if; + + else + Names.Table (Current).File := Current_Main; + end if; + end if; + end; + + return Names.Table (Current); + end if; + end Next_Main; + + --------------------- + -- Number_Of_Mains -- + --------------------- + + function Number_Of_Mains return Natural is + begin + return Names.Last; + end Number_Of_Mains; + + ----------- + -- Reset -- + ----------- + + procedure Reset is + begin + Current := 0; + end Reset; + + -------------------------- + -- Set_Multi_Unit_Index -- + -------------------------- + + procedure Set_Multi_Unit_Index + (Index : Int := 0) + is + begin + if Index /= 0 then + if Names.Last = 0 then + Fail_Program + ("cannot specify a multi-unit index but no main " + & "on the command line"); + + elsif Names.Last > 1 then + Fail_Program + ("cannot specify several mains with a multi-unit index"); + + else + Names.Table (Names.Last).Index := Index; + end if; + end if; + end Set_Multi_Unit_Index; + + end Mains; + + ----------------------- + -- Path_Or_File_Name -- + ----------------------- + + function Path_Or_File_Name (Path : Path_Name_Type) return String is + Path_Name : constant String := Get_Name_String (Path); + begin + if Debug.Debug_Flag_F then + return File_Name (Path_Name); + else + return Path_Name; + end if; + end Path_Or_File_Name; + + ------------------- + -- Unit_Index_Of -- + ------------------- + + function Unit_Index_Of (ALI_File : File_Name_Type) return Int is + Start : Natural; + Finish : Natural; + Result : Int := 0; + + begin + Get_Name_String (ALI_File); + + -- First, find the last dot + + Finish := Name_Len; + + while Finish >= 1 and then Name_Buffer (Finish) /= '.' loop + Finish := Finish - 1; + end loop; + + if Finish = 1 then + return 0; + end if; + + -- Now check that the dot is preceded by digits + + Start := Finish; + Finish := Finish - 1; + while Start >= 1 and then Name_Buffer (Start - 1) in '0' .. '9' loop + Start := Start - 1; + end loop; + + -- If there are no digits, or if the digits are not preceded by the + -- character that precedes a unit index, this is not the ALI file of + -- a unit in a multi-unit source. + + if Start > Finish + or else Start = 1 + or else Name_Buffer (Start - 1) /= Multi_Unit_Index_Character + then + return 0; + end if; + + -- Build the index from the digit(s) + + while Start <= Finish loop + Result := Result * 10 + + Character'Pos (Name_Buffer (Start)) - Character'Pos ('0'); + Start := Start + 1; + end loop; + + return Result; + end Unit_Index_Of; + + ----------------- + -- Verbose_Msg -- + ----------------- + + procedure Verbose_Msg + (N1 : Name_Id; + S1 : String; + N2 : Name_Id := No_Name; + S2 : String := ""; + Prefix : String := " -> "; + Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low) + is + begin + if not Opt.Verbose_Mode + or else Minimum_Verbosity > Opt.Verbosity_Level + then + return; + end if; + + Write_Str (Prefix); + Write_Str (""""); + Write_Name (N1); + Write_Str (""" "); + Write_Str (S1); + + if N2 /= No_Name then + Write_Str (" """); + Write_Name (N2); + Write_Str (""" "); + end if; + + Write_Str (S2); + Write_Eol; + end Verbose_Msg; + + procedure Verbose_Msg + (N1 : File_Name_Type; + S1 : String; + N2 : File_Name_Type := No_File; + S2 : String := ""; + Prefix : String := " -> "; + Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low) + is + begin + Verbose_Msg + (Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity); + end Verbose_Msg; + + ----------- + -- Queue -- + ----------- + + package body Queue is + + type Q_Record is record + Info : Source_Info; + Processed : Boolean; + end record; + + package Q is new Table.Table + (Table_Component_Type => Q_Record, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 1000, + Table_Increment => 100, + Table_Name => "Makeutl.Queue.Q"); + -- This is the actual Queue + + type Mark_Key is record + File : File_Name_Type; + Index : Int; + end record; + -- Identify either a mono-unit source (when Index = 0) or a specific + -- unit (index = 1's origin index of unit) in a multi-unit source. + + Max_Mask_Num : constant := 2048; + subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1; + + function Hash (Key : Mark_Key) return Mark_Num; + + package Marks is new GNAT.HTable.Simple_HTable + (Header_Num => Mark_Num, + Element => Boolean, + No_Element => False, + Key => Mark_Key, + Hash => Hash, + Equal => "="); + -- A hash table to keep tracks of the marked units. + -- These are the units that have already been processed, when using the + -- gnatmake format. When using the gprbuild format, we can directly + -- store in the source_id whether the file has already been processed. + + procedure Mark (Source_File : File_Name_Type; Index : Int := 0); + -- Mark a unit, identified by its source file and, when Index is not 0, + -- the index of the unit in the source file. Marking is used to signal + -- that the unit has already been inserted in the Q. + + function Is_Marked + (Source_File : File_Name_Type; + Index : Int := 0) return Boolean; + -- Returns True if the unit was previously marked + + Q_Processed : Natural := 0; + Q_Initialized : Boolean := False; + + Q_First : Natural := 1; + -- Points to the first valid element in the queue + + procedure Debug_Display (S : Source_Info); + -- A debug display for S + + function Was_Processed (S : Source_Info) return Boolean; + -- Whether S has already been processed. This marks the source as + -- processed, if it hasn't already been processed. + + ------------------- + -- Was_Processed -- + ------------------- + + function Was_Processed (S : Source_Info) return Boolean is + begin + if Is_Marked (S.File, S.Index) then + return True; + end if; + + Mark (S.File, Index => S.Index); + + return False; + end Was_Processed; + + ------------------- + -- Debug_Display -- + ------------------- + + procedure Debug_Display (S : Source_Info) is + begin + Write_Name (S.File); + + if S.Index /= 0 then + Write_Str (", "); + Write_Int (S.Index); + end if; + end Debug_Display; + + ---------- + -- Hash -- + ---------- + + function Hash (Key : Mark_Key) return Mark_Num is + begin + return Union_Id (Key.File) mod Max_Mask_Num; + end Hash; + + --------------- + -- Is_Marked -- + --------------- + + function Is_Marked + (Source_File : File_Name_Type; + Index : Int := 0) return Boolean + is + begin + return Marks.Get (K => (File => Source_File, Index => Index)); + end Is_Marked; + + ---------- + -- Mark -- + ---------- + + procedure Mark (Source_File : File_Name_Type; Index : Int := 0) is + begin + Marks.Set (K => (File => Source_File, Index => Index), E => True); + end Mark; + + ------------- + -- Extract -- + ------------- + + procedure Extract + (Found : out Boolean; + Source : out Source_Info) + is + begin + Found := False; + + if Q_First <= Q.Last then + Source := Q.Table (Q_First).Info; + Q.Table (Q_First).Processed := True; + Q_First := Q_First + 1; + Found := True; + end if; + + if Found then + Q_Processed := Q_Processed + 1; + end if; + + if Found and then Debug.Debug_Flag_Q then + Write_Str (" Q := Q - [ "); + Debug_Display (Source); + Write_Str (" ]"); + Write_Eol; + + Write_Str (" Q_First ="); + Write_Int (Int (Q_First)); + Write_Eol; + + Write_Str (" Q.Last ="); + Write_Int (Int (Q.Last)); + Write_Eol; + end if; + end Extract; + + --------------- + -- Processed -- + --------------- + + function Processed return Natural is + begin + return Q_Processed; + end Processed; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Force : Boolean := False) is + begin + if Force or else not Q_Initialized then + Q_Initialized := True; + Q.Init; + Q_Processed := 0; + Q_First := 1; + end if; + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert (Source : Source_Info) return Boolean is + begin + -- Only insert in the Q if it is not already done, to avoid + -- simultaneous compilations if -jnnn is used. + + if Was_Processed (Source) then + return False; + end if; + + Q.Append (New_Val => (Info => Source, Processed => False)); + + if Debug.Debug_Flag_Q then + Write_Str (" Q := Q + [ "); + Debug_Display (Source); + Write_Str (" ] "); + Write_Eol; + + Write_Str (" Q_First ="); + Write_Int (Int (Q_First)); + Write_Eol; + + Write_Str (" Q.Last ="); + Write_Int (Int (Q.Last)); + Write_Eol; + end if; + + return True; + end Insert; + + procedure Insert (Source : Source_Info) is + Discard : Boolean; + begin + Discard := Insert (Source); + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty return Boolean is + begin + return Q_Processed >= Q.Last; + end Is_Empty; + + ---------- + -- Size -- + ---------- + + function Size return Natural is + begin + return Q.Last; + end Size; + + ------------- + -- Element -- + ------------- + + function Element (Rank : Positive) return File_Name_Type is + begin + if Rank <= Q.Last then + return Q.Table (Rank).Info.File; + else + return No_File; + end if; + end Element; + + ------------------ + -- Remove_Marks -- + ------------------ + + procedure Remove_Marks is + begin + Marks.Reset; + end Remove_Marks; + + end Queue; + +end Make_Util;