OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
f6d17c4d02
gcc/gcc/ada/make_util.adb
Arnaud Charlet 4dfba737a4 [Ada] Bump copyright notices to 2018 
2018-01-11  Arnaud Charlet  <charlet@adacore.com>

gcc/ada/

	Bump copyright notices to 2018.

From-SVN: r256519
2018-01-11 08:55:25 +00:00

965 lines
26 KiB
Ada
Raw Blame History

------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- M A K E _ U T I L --
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2018, 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;
Reference in New Issue View Git Blame Copy Permalink