1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- M A K E _ U T I L --
9 -- Copyright (C) 2004-2018, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
29 with Osint; use Osint;
30 with Output; use Output;
34 with Ada.Command_Line; use Ada.Command_Line;
36 with GNAT.Case_Util; use GNAT.Case_Util;
37 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
40 package body Make_Util is
47 (Option : String_Access;
48 To : in out String_List_Access;
49 Last : in out Natural)
52 if Last = To'Last then
54 New_Options : constant String_List_Access :=
55 new String_List (1 .. To'Last * 2);
58 New_Options (To'Range) := To.all;
60 -- Set all elements of the original options to null to avoid
61 -- deallocation of copies.
63 To.all := (others => null);
76 To : in out String_List_Access;
77 Last : in out Natural)
80 Add (Option => new String'(Option), To => To, Last => Last);
83 -------------------------
84 -- Base_Name_Index_For --
85 -------------------------
87 function Base_Name_Index_For
90 Index_Separator : Character) return File_Name_Type
92 Result : File_Name_Type;
96 Add_Str_To_Name_Buffer (Base_Name (Main));
98 -- Remove the extension, if any, that is the last part of the base name
99 -- starting with a dot and following some characters.
101 for J in reverse 2 .. Name_Len loop
102 if Name_Buffer (J) = '.' then
108 -- Add the index info, if index is different from 0
110 if Main_Index > 0 then
111 Add_Char_To_Name_Buffer (Index_Separator);
114 Img : constant String := Main_Index'Img;
116 Add_Str_To_Name_Buffer (Img (2 .. Img'Last));
122 end Base_Name_Index_For;
128 function Create_Name (Name : String) return File_Name_Type is
131 Add_Str_To_Name_Buffer (Name);
135 function Create_Name (Name : String) return Name_Id is
138 Add_Str_To_Name_Buffer (Name);
142 function Create_Name (Name : String) return Path_Name_Type is
145 Add_Str_To_Name_Buffer (Name);
149 ---------------------------
150 -- Ensure_Absolute_Path --
151 ---------------------------
153 procedure Ensure_Absolute_Path
154 (Switch : in out String_Access;
157 For_Gnatbind : Boolean := False;
158 Including_Non_Switch : Boolean := True;
159 Including_RTS : Boolean := False)
162 if Switch /= null then
164 Sw : String (1 .. Switch'Length);
172 and then (Sw (2) = 'I'
173 or else (not For_Gnatbind
174 and then (Sw (2) = 'L'
186 (Sw (2 .. 3) = "aL" or else
187 Sw (2 .. 3) = "aO" or else
189 or else (For_Gnatbind and then Sw (2 .. 3) = "A="))
194 and then Sw'Length >= 7
195 and then Sw (2 .. 6) = "-RTS="
203 -- Because relative path arguments to --RTS= may be relative to
204 -- the search directory prefix, those relative path arguments
205 -- are converted only when they include directory information.
207 if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
208 if Parent'Length = 0 then
210 ("relative search path switches ("""
212 & """) are not allowed");
214 elsif Including_RTS then
215 for J in Start .. Sw'Last loop
216 if Sw (J) = Directory_Separator then
221 & Directory_Separator
222 & Sw (Start .. Sw'Last));
232 & Directory_Separator
233 & Sw (Start .. Sw'Last));
237 elsif Including_Non_Switch then
238 if not Is_Absolute_Path (Sw) then
239 if Parent'Length = 0 then
241 ("relative paths (""" & Sw & """) are not allowed");
243 Switch := new String'(Parent & Directory_Separator & Sw);
249 end Ensure_Absolute_Path;
251 ----------------------------
252 -- Executable_Prefix_Path --
253 ----------------------------
255 function Executable_Prefix_Path return String is
256 Exec_Name : constant String := Command_Name;
258 function Get_Install_Dir (S : String) return String;
259 -- S is the executable name preceded by the absolute or relative path,
260 -- e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory where "bin"
261 -- lies (in the example "C:\usr"). If the executable is not in a "bin"
262 -- directory, return "".
264 ---------------------
265 -- Get_Install_Dir --
266 ---------------------
268 function Get_Install_Dir (S : String) return String is
270 Path_Last : Integer := 0;
273 for J in reverse Exec'Range loop
274 if Exec (J) = Directory_Separator then
280 if Path_Last >= Exec'First + 2 then
281 To_Lower (Exec (Path_Last - 2 .. Path_Last));
284 if Path_Last < Exec'First + 2
285 or else Exec (Path_Last - 2 .. Path_Last) /= "bin"
286 or else (Path_Last - 3 >= Exec'First
287 and then Exec (Path_Last - 3) /= Directory_Separator)
292 return Normalize_Pathname
293 (Exec (Exec'First .. Path_Last - 4),
294 Resolve_Links => Opt.Follow_Links_For_Dirs)
295 & Directory_Separator;
298 -- Beginning of Executable_Prefix_Path
301 -- First determine if a path prefix was placed in front of the
304 for J in reverse Exec_Name'Range loop
305 if Exec_Name (J) = Directory_Separator then
306 return Get_Install_Dir (Exec_Name);
310 -- If we get here, the user has typed the executable name with no
314 Path : String_Access := Locate_Exec_On_Path (Exec_Name);
320 Dir : constant String := Get_Install_Dir (Path.all);
327 end Executable_Prefix_Path;
333 procedure Fail_Program
335 Flush_Messages : Boolean := True)
338 if Flush_Messages and not No_Exit_Message then
339 if Total_Errors_Detected /= 0 or else Warnings_Detected /= 0 then
344 Finish_Program (E_Fatal, S => S);
351 procedure Finish_Program
352 (Exit_Code : Osint.Exit_Code_Type := Osint.E_Success;
357 if Exit_Code /= E_Success then
358 if No_Exit_Message then
359 Osint.Exit_Program (E_Fatal);
364 elsif not No_Exit_Message then
369 -- Output Namet statistics
373 Exit_Program (Exit_Code);
380 function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num);
381 -- Used in implementation of other functions Hash below
387 function Hash (Name : File_Name_Type) return Header_Num is
389 return Hash (Get_Name_String (Name));
392 function Hash (Name : Name_Id) return Header_Num is
394 return Hash (Get_Name_String (Name));
397 function Hash (Name : Path_Name_Type) return Header_Num is
399 return Hash (Get_Name_String (Name));
406 procedure Inform (N : File_Name_Type; Msg : String) is
408 Inform (Name_Id (N), Msg);
411 procedure Inform (N : Name_Id := No_Name; Msg : String) is
413 Osint.Write_Program_Name;
421 Name : constant String := Get_Name_String (N);
423 if Debug.Debug_Flag_F and then Is_Absolute_Path (Name) then
424 Write_Str (File_Name (Name));
441 package body Mains is
443 package Names is new Table.Table
444 (Table_Component_Type => Main_Info,
445 Table_Index_Type => Integer,
446 Table_Low_Bound => 1,
448 Table_Increment => 100,
449 Table_Name => "Makeutl.Mains.Names");
450 -- The table that stores the mains
452 Current : Natural := 0;
453 -- The index of the last main retrieved from the table
455 Count_Of_Mains_With_No_Tree : Natural := 0;
456 -- Number of main units for which we do not know the project tree
462 procedure Add_Main (Name : String; Index : Int := 0) is
465 Add_Str_To_Name_Buffer (Name);
466 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
468 Names.Increment_Last;
469 Names.Table (Names.Last) := (Name_Find, Index);
471 Mains.Count_Of_Mains_With_No_Tree :=
472 Mains.Count_Of_Mains_With_No_Tree + 1;
489 function Next_Main return String is
490 Info : constant Main_Info := Next_Main;
492 if Info = No_Main_Info then
495 return Get_Name_String (Info.File);
499 function Next_Main return Main_Info is
501 if Current >= Names.Last then
504 Current := Current + 1;
507 Orig_Main : constant File_Name_Type :=
508 Names.Table (Current).File;
509 Current_Main : File_Name_Type;
512 if Strip_Suffix (Orig_Main) = Orig_Main then
513 Get_Name_String (Orig_Main);
514 Add_Str_To_Name_Buffer (".adb");
515 Current_Main := Name_Find;
517 if Full_Source_Name (Current_Main) = No_File then
518 Get_Name_String (Orig_Main);
519 Add_Str_To_Name_Buffer (".ads");
520 Current_Main := Name_Find;
522 if Full_Source_Name (Current_Main) /= No_File then
523 Names.Table (Current).File := Current_Main;
527 Names.Table (Current).File := Current_Main;
532 return Names.Table (Current);
536 ---------------------
537 -- Number_Of_Mains --
538 ---------------------
540 function Number_Of_Mains return Natural is
554 --------------------------
555 -- Set_Multi_Unit_Index --
556 --------------------------
558 procedure Set_Multi_Unit_Index
563 if Names.Last = 0 then
565 ("cannot specify a multi-unit index but no main "
566 & "on the command line");
568 elsif Names.Last > 1 then
570 ("cannot specify several mains with a multi-unit index");
573 Names.Table (Names.Last).Index := Index;
576 end Set_Multi_Unit_Index;
580 -----------------------
581 -- Path_Or_File_Name --
582 -----------------------
584 function Path_Or_File_Name (Path : Path_Name_Type) return String is
585 Path_Name : constant String := Get_Name_String (Path);
587 if Debug.Debug_Flag_F then
588 return File_Name (Path_Name);
592 end Path_Or_File_Name;
598 function Unit_Index_Of (ALI_File : File_Name_Type) return Int is
604 Get_Name_String (ALI_File);
606 -- First, find the last dot
610 while Finish >= 1 and then Name_Buffer (Finish) /= '.' loop
611 Finish := Finish - 1;
618 -- Now check that the dot is preceded by digits
621 Finish := Finish - 1;
622 while Start >= 1 and then Name_Buffer (Start - 1) in '0' .. '9' loop
626 -- If there are no digits, or if the digits are not preceded by the
627 -- character that precedes a unit index, this is not the ALI file of
628 -- a unit in a multi-unit source.
632 or else Name_Buffer (Start - 1) /= Multi_Unit_Index_Character
637 -- Build the index from the digit(s)
639 while Start <= Finish loop
640 Result := Result * 10 +
641 Character'Pos (Name_Buffer (Start)) - Character'Pos ('0');
652 procedure Verbose_Msg
655 N2 : Name_Id := No_Name;
657 Prefix : String := " -> ";
658 Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
661 if not Opt.Verbose_Mode
662 or else Minimum_Verbosity > Opt.Verbosity_Level
673 if N2 /= No_Name then
683 procedure Verbose_Msg
684 (N1 : File_Name_Type;
686 N2 : File_Name_Type := No_File;
688 Prefix : String := " -> ";
689 Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
693 (Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity);
700 package body Queue is
702 type Q_Record is record
707 package Q is new Table.Table
708 (Table_Component_Type => Q_Record,
709 Table_Index_Type => Natural,
710 Table_Low_Bound => 1,
711 Table_Initial => 1000,
712 Table_Increment => 100,
713 Table_Name => "Makeutl.Queue.Q");
714 -- This is the actual Queue
716 type Mark_Key is record
717 File : File_Name_Type;
720 -- Identify either a mono-unit source (when Index = 0) or a specific
721 -- unit (index = 1's origin index of unit) in a multi-unit source.
723 Max_Mask_Num : constant := 2048;
724 subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1;
726 function Hash (Key : Mark_Key) return Mark_Num;
728 package Marks is new GNAT.HTable.Simple_HTable
729 (Header_Num => Mark_Num,
735 -- A hash table to keep tracks of the marked units.
736 -- These are the units that have already been processed, when using the
737 -- gnatmake format. When using the gprbuild format, we can directly
738 -- store in the source_id whether the file has already been processed.
740 procedure Mark (Source_File : File_Name_Type; Index : Int := 0);
741 -- Mark a unit, identified by its source file and, when Index is not 0,
742 -- the index of the unit in the source file. Marking is used to signal
743 -- that the unit has already been inserted in the Q.
746 (Source_File : File_Name_Type;
747 Index : Int := 0) return Boolean;
748 -- Returns True if the unit was previously marked
750 Q_Processed : Natural := 0;
751 Q_Initialized : Boolean := False;
753 Q_First : Natural := 1;
754 -- Points to the first valid element in the queue
756 procedure Debug_Display (S : Source_Info);
757 -- A debug display for S
759 function Was_Processed (S : Source_Info) return Boolean;
760 -- Whether S has already been processed. This marks the source as
761 -- processed, if it hasn't already been processed.
767 function Was_Processed (S : Source_Info) return Boolean is
769 if Is_Marked (S.File, S.Index) then
773 Mark (S.File, Index => S.Index);
782 procedure Debug_Display (S : Source_Info) is
796 function Hash (Key : Mark_Key) return Mark_Num is
798 return Union_Id (Key.File) mod Max_Mask_Num;
806 (Source_File : File_Name_Type;
807 Index : Int := 0) return Boolean
810 return Marks.Get (K => (File => Source_File, Index => Index));
817 procedure Mark (Source_File : File_Name_Type; Index : Int := 0) is
819 Marks.Set (K => (File => Source_File, Index => Index), E => True);
827 (Found : out Boolean;
828 Source : out Source_Info)
833 if Q_First <= Q.Last then
834 Source := Q.Table (Q_First).Info;
835 Q.Table (Q_First).Processed := True;
836 Q_First := Q_First + 1;
841 Q_Processed := Q_Processed + 1;
844 if Found and then Debug.Debug_Flag_Q then
845 Write_Str (" Q := Q - [ ");
846 Debug_Display (Source);
850 Write_Str (" Q_First =");
851 Write_Int (Int (Q_First));
854 Write_Str (" Q.Last =");
855 Write_Int (Int (Q.Last));
864 function Processed return Natural is
873 procedure Initialize (Force : Boolean := False) is
875 if Force or else not Q_Initialized then
876 Q_Initialized := True;
887 function Insert (Source : Source_Info) return Boolean is
889 -- Only insert in the Q if it is not already done, to avoid
890 -- simultaneous compilations if -jnnn is used.
892 if Was_Processed (Source) then
896 Q.Append (New_Val => (Info => Source, Processed => False));
898 if Debug.Debug_Flag_Q then
899 Write_Str (" Q := Q + [ ");
900 Debug_Display (Source);
904 Write_Str (" Q_First =");
905 Write_Int (Int (Q_First));
908 Write_Str (" Q.Last =");
909 Write_Int (Int (Q.Last));
916 procedure Insert (Source : Source_Info) is
919 Discard := Insert (Source);
926 function Is_Empty return Boolean is
928 return Q_Processed >= Q.Last;
935 function Size return Natural is
944 function Element (Rank : Positive) return File_Name_Type is
946 if Rank <= Q.Last then
947 return Q.Table (Rank).Info.File;
957 procedure Remove_Marks is