1275 lines
38 KiB
Ada
1275 lines
38 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- P R J --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 2001-2009, 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 Debug;
|
|
with Osint; use Osint;
|
|
with Output; use Output;
|
|
with Prj.Attr;
|
|
with Prj.Err; use Prj.Err;
|
|
with Snames; use Snames;
|
|
with Uintp; use Uintp;
|
|
|
|
with Ada.Characters.Handling; use Ada.Characters.Handling;
|
|
with Ada.Unchecked_Deallocation;
|
|
|
|
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
|
|
|
|
with System.Case_Util; use System.Case_Util;
|
|
with System.HTable;
|
|
|
|
package body Prj is
|
|
|
|
Object_Suffix : constant String := Get_Target_Object_Suffix.all;
|
|
-- File suffix for object files
|
|
|
|
Initial_Buffer_Size : constant := 100;
|
|
-- Initial size for extensible buffer used in Add_To_Buffer
|
|
|
|
The_Empty_String : Name_Id := No_Name;
|
|
|
|
subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
|
|
|
|
type Cst_String_Access is access constant String;
|
|
|
|
All_Lower_Case_Image : aliased constant String := "lowercase";
|
|
All_Upper_Case_Image : aliased constant String := "UPPERCASE";
|
|
Mixed_Case_Image : aliased constant String := "MixedCase";
|
|
|
|
The_Casing_Images : constant array (Known_Casing) of Cst_String_Access :=
|
|
(All_Lower_Case => All_Lower_Case_Image'Access,
|
|
All_Upper_Case => All_Upper_Case_Image'Access,
|
|
Mixed_Case => Mixed_Case_Image'Access);
|
|
|
|
Project_Empty : constant Project_Data :=
|
|
(Qualifier => Unspecified,
|
|
Externally_Built => False,
|
|
Config => Default_Project_Config,
|
|
Name => No_Name,
|
|
Display_Name => No_Name,
|
|
Path => No_Path_Information,
|
|
Virtual => False,
|
|
Location => No_Location,
|
|
Mains => Nil_String,
|
|
Directory => No_Path_Information,
|
|
Library => False,
|
|
Library_Dir => No_Path_Information,
|
|
Library_Src_Dir => No_Path_Information,
|
|
Library_ALI_Dir => No_Path_Information,
|
|
Library_Name => No_Name,
|
|
Library_Kind => Static,
|
|
Lib_Internal_Name => No_Name,
|
|
Standalone_Library => False,
|
|
Lib_Interface_ALIs => Nil_String,
|
|
Lib_Auto_Init => False,
|
|
Libgnarl_Needed => Unknown,
|
|
Symbol_Data => No_Symbols,
|
|
Interfaces_Defined => False,
|
|
Source_Dirs => Nil_String,
|
|
Source_Dir_Ranks => No_Number_List,
|
|
Object_Directory => No_Path_Information,
|
|
Library_TS => Empty_Time_Stamp,
|
|
Exec_Directory => No_Path_Information,
|
|
Extends => No_Project,
|
|
Extended_By => No_Project,
|
|
Languages => No_Language_Index,
|
|
Decl => No_Declarations,
|
|
Imported_Projects => null,
|
|
Include_Path_File => No_Path,
|
|
All_Imported_Projects => null,
|
|
Ada_Include_Path => null,
|
|
Ada_Objects_Path => null,
|
|
Objects_Path => null,
|
|
Objects_Path_File_With_Libs => No_Path,
|
|
Objects_Path_File_Without_Libs => No_Path,
|
|
Config_File_Name => No_Path,
|
|
Config_File_Temp => False,
|
|
Config_Checked => False,
|
|
Need_To_Build_Lib => False,
|
|
Has_Multi_Unit_Sources => False,
|
|
Depth => 0,
|
|
Unkept_Comments => False);
|
|
|
|
procedure Free (Project : in out Project_Id);
|
|
-- Free memory allocated for Project
|
|
|
|
procedure Free_List (Languages : in out Language_Ptr);
|
|
procedure Free_List (Source : in out Source_Id);
|
|
procedure Free_List (Languages : in out Language_List);
|
|
-- Free memory allocated for the list of languages or sources
|
|
|
|
procedure Free_Units (Table : in out Units_Htable.Instance);
|
|
-- Free memory allocated for unit information in the project
|
|
|
|
procedure Language_Changed (Iter : in out Source_Iterator);
|
|
procedure Project_Changed (Iter : in out Source_Iterator);
|
|
-- Called when a new project or language was selected for this iterator
|
|
|
|
function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean;
|
|
-- Return True if there is at least one ALI file in the directory Dir
|
|
|
|
-------------------
|
|
-- Add_To_Buffer --
|
|
-------------------
|
|
|
|
procedure Add_To_Buffer
|
|
(S : String;
|
|
To : in out String_Access;
|
|
Last : in out Natural)
|
|
is
|
|
begin
|
|
if To = null then
|
|
To := new String (1 .. Initial_Buffer_Size);
|
|
Last := 0;
|
|
end if;
|
|
|
|
-- If Buffer is too small, double its size
|
|
|
|
while Last + S'Length > To'Last loop
|
|
declare
|
|
New_Buffer : constant String_Access :=
|
|
new String (1 .. 2 * Last);
|
|
|
|
begin
|
|
New_Buffer (1 .. Last) := To (1 .. Last);
|
|
Free (To);
|
|
To := New_Buffer;
|
|
end;
|
|
end loop;
|
|
|
|
To (Last + 1 .. Last + S'Length) := S;
|
|
Last := Last + S'Length;
|
|
end Add_To_Buffer;
|
|
|
|
---------------------------
|
|
-- Delete_Temporary_File --
|
|
---------------------------
|
|
|
|
procedure Delete_Temporary_File
|
|
(Tree : Project_Tree_Ref;
|
|
Path : Path_Name_Type)
|
|
is
|
|
Dont_Care : Boolean;
|
|
pragma Warnings (Off, Dont_Care);
|
|
|
|
begin
|
|
if not Debug.Debug_Flag_N then
|
|
if Current_Verbosity = High then
|
|
Write_Line ("Removing temp file: " & Get_Name_String (Path));
|
|
end if;
|
|
|
|
Delete_File (Get_Name_String (Path), Dont_Care);
|
|
|
|
for Index in
|
|
1 .. Temp_Files_Table.Last (Tree.Private_Part.Temp_Files)
|
|
loop
|
|
if Tree.Private_Part.Temp_Files.Table (Index) = Path then
|
|
Tree.Private_Part.Temp_Files.Table (Index) := No_Path;
|
|
end if;
|
|
end loop;
|
|
end if;
|
|
end Delete_Temporary_File;
|
|
|
|
---------------------------
|
|
-- Delete_All_Temp_Files --
|
|
---------------------------
|
|
|
|
procedure Delete_All_Temp_Files (Tree : Project_Tree_Ref) is
|
|
Dont_Care : Boolean;
|
|
pragma Warnings (Off, Dont_Care);
|
|
|
|
Path : Path_Name_Type;
|
|
|
|
begin
|
|
if not Debug.Debug_Flag_N then
|
|
for Index in
|
|
1 .. Temp_Files_Table.Last (Tree.Private_Part.Temp_Files)
|
|
loop
|
|
Path := Tree.Private_Part.Temp_Files.Table (Index);
|
|
|
|
if Path /= No_Path then
|
|
if Current_Verbosity = High then
|
|
Write_Line ("Removing temp file: "
|
|
& Get_Name_String (Path));
|
|
end if;
|
|
|
|
Delete_File (Get_Name_String (Path), Dont_Care);
|
|
end if;
|
|
end loop;
|
|
|
|
Temp_Files_Table.Free (Tree.Private_Part.Temp_Files);
|
|
Temp_Files_Table.Init (Tree.Private_Part.Temp_Files);
|
|
end if;
|
|
|
|
-- If any of the environment variables ADA_PRJ_INCLUDE_FILE or
|
|
-- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
|
|
-- the empty string. On VMS, this has the effect of deassigning
|
|
-- the logical names.
|
|
|
|
if Tree.Private_Part.Current_Source_Path_File /= No_Path then
|
|
Setenv (Project_Include_Path_File, "");
|
|
end if;
|
|
|
|
if Tree.Private_Part.Current_Object_Path_File /= No_Path then
|
|
Setenv (Project_Objects_Path_File, "");
|
|
end if;
|
|
end Delete_All_Temp_Files;
|
|
|
|
---------------------
|
|
-- Dependency_Name --
|
|
---------------------
|
|
|
|
function Dependency_Name
|
|
(Source_File_Name : File_Name_Type;
|
|
Dependency : Dependency_File_Kind) return File_Name_Type
|
|
is
|
|
begin
|
|
case Dependency is
|
|
when None =>
|
|
return No_File;
|
|
|
|
when Makefile =>
|
|
return
|
|
File_Name_Type
|
|
(Extend_Name
|
|
(Source_File_Name, Makefile_Dependency_Suffix));
|
|
|
|
when ALI_File =>
|
|
return
|
|
File_Name_Type
|
|
(Extend_Name
|
|
(Source_File_Name, ALI_Dependency_Suffix));
|
|
end case;
|
|
end Dependency_Name;
|
|
|
|
----------------
|
|
-- Empty_File --
|
|
----------------
|
|
|
|
function Empty_File return File_Name_Type is
|
|
begin
|
|
return File_Name_Type (The_Empty_String);
|
|
end Empty_File;
|
|
|
|
-------------------
|
|
-- Empty_Project --
|
|
-------------------
|
|
|
|
function Empty_Project return Project_Data is
|
|
begin
|
|
Prj.Initialize (Tree => No_Project_Tree);
|
|
return Project_Empty;
|
|
end Empty_Project;
|
|
|
|
------------------
|
|
-- Empty_String --
|
|
------------------
|
|
|
|
function Empty_String return Name_Id is
|
|
begin
|
|
return The_Empty_String;
|
|
end Empty_String;
|
|
|
|
------------
|
|
-- Expect --
|
|
------------
|
|
|
|
procedure Expect (The_Token : Token_Type; Token_Image : String) is
|
|
begin
|
|
if Token /= The_Token then
|
|
-- ??? Should pass user flags here instead
|
|
Error_Msg (Gnatmake_Flags, Token_Image & " expected", Token_Ptr);
|
|
end if;
|
|
end Expect;
|
|
|
|
-----------------
|
|
-- Extend_Name --
|
|
-----------------
|
|
|
|
function Extend_Name
|
|
(File : File_Name_Type;
|
|
With_Suffix : String) return File_Name_Type
|
|
is
|
|
Last : Positive;
|
|
|
|
begin
|
|
Get_Name_String (File);
|
|
Last := Name_Len + 1;
|
|
|
|
while Name_Len /= 0 and then Name_Buffer (Name_Len) /= '.' loop
|
|
Name_Len := Name_Len - 1;
|
|
end loop;
|
|
|
|
if Name_Len <= 1 then
|
|
Name_Len := Last;
|
|
end if;
|
|
|
|
for J in With_Suffix'Range loop
|
|
Name_Buffer (Name_Len) := With_Suffix (J);
|
|
Name_Len := Name_Len + 1;
|
|
end loop;
|
|
|
|
Name_Len := Name_Len - 1;
|
|
return Name_Find;
|
|
|
|
end Extend_Name;
|
|
|
|
---------------------
|
|
-- Project_Changed --
|
|
---------------------
|
|
|
|
procedure Project_Changed (Iter : in out Source_Iterator) is
|
|
begin
|
|
Iter.Language := Iter.Project.Project.Languages;
|
|
Language_Changed (Iter);
|
|
end Project_Changed;
|
|
|
|
----------------------
|
|
-- Language_Changed --
|
|
----------------------
|
|
|
|
procedure Language_Changed (Iter : in out Source_Iterator) is
|
|
begin
|
|
Iter.Current := No_Source;
|
|
|
|
if Iter.Language_Name /= No_Name then
|
|
while Iter.Language /= null
|
|
and then Iter.Language.Name /= Iter.Language_Name
|
|
loop
|
|
Iter.Language := Iter.Language.Next;
|
|
end loop;
|
|
end if;
|
|
|
|
-- If there is no matching language in this project, move to next
|
|
|
|
if Iter.Language = No_Language_Index then
|
|
if Iter.All_Projects then
|
|
Iter.Project := Iter.Project.Next;
|
|
|
|
if Iter.Project /= null then
|
|
Project_Changed (Iter);
|
|
end if;
|
|
|
|
else
|
|
Iter.Project := null;
|
|
end if;
|
|
|
|
else
|
|
Iter.Current := Iter.Language.First_Source;
|
|
|
|
if Iter.Current = No_Source then
|
|
Iter.Language := Iter.Language.Next;
|
|
Language_Changed (Iter);
|
|
end if;
|
|
end if;
|
|
end Language_Changed;
|
|
|
|
---------------------
|
|
-- For_Each_Source --
|
|
---------------------
|
|
|
|
function For_Each_Source
|
|
(In_Tree : Project_Tree_Ref;
|
|
Project : Project_Id := No_Project;
|
|
Language : Name_Id := No_Name) return Source_Iterator
|
|
is
|
|
Iter : Source_Iterator;
|
|
begin
|
|
Iter := Source_Iterator'
|
|
(In_Tree => In_Tree,
|
|
Project => In_Tree.Projects,
|
|
All_Projects => Project = No_Project,
|
|
Language_Name => Language,
|
|
Language => No_Language_Index,
|
|
Current => No_Source);
|
|
|
|
if Project /= null then
|
|
while Iter.Project /= null
|
|
and then Iter.Project.Project /= Project
|
|
loop
|
|
Iter.Project := Iter.Project.Next;
|
|
end loop;
|
|
end if;
|
|
|
|
Project_Changed (Iter);
|
|
|
|
return Iter;
|
|
end For_Each_Source;
|
|
|
|
-------------
|
|
-- Element --
|
|
-------------
|
|
|
|
function Element (Iter : Source_Iterator) return Source_Id is
|
|
begin
|
|
return Iter.Current;
|
|
end Element;
|
|
|
|
----------
|
|
-- Next --
|
|
----------
|
|
|
|
procedure Next (Iter : in out Source_Iterator) is
|
|
begin
|
|
Iter.Current := Iter.Current.Next_In_Lang;
|
|
if Iter.Current = No_Source then
|
|
Iter.Language := Iter.Language.Next;
|
|
Language_Changed (Iter);
|
|
end if;
|
|
end Next;
|
|
|
|
--------------------------------
|
|
-- For_Every_Project_Imported --
|
|
--------------------------------
|
|
|
|
procedure For_Every_Project_Imported
|
|
(By : Project_Id;
|
|
With_State : in out State;
|
|
Imported_First : Boolean := False)
|
|
is
|
|
use Project_Boolean_Htable;
|
|
Seen : Project_Boolean_Htable.Instance := Project_Boolean_Htable.Nil;
|
|
|
|
procedure Recursive_Check (Project : Project_Id);
|
|
-- Check if a project has already been seen. If not seen, mark it as
|
|
-- Seen, Call Action, and check all its imported projects.
|
|
|
|
---------------------
|
|
-- Recursive_Check --
|
|
---------------------
|
|
|
|
procedure Recursive_Check (Project : Project_Id) is
|
|
List : Project_List;
|
|
|
|
begin
|
|
if not Get (Seen, Project) then
|
|
Set (Seen, Project, True);
|
|
|
|
if not Imported_First then
|
|
Action (Project, With_State);
|
|
end if;
|
|
|
|
-- Visited all extended projects
|
|
|
|
if Project.Extends /= No_Project then
|
|
Recursive_Check (Project.Extends);
|
|
end if;
|
|
|
|
-- Visited all imported projects
|
|
|
|
List := Project.Imported_Projects;
|
|
while List /= null loop
|
|
Recursive_Check (List.Project);
|
|
List := List.Next;
|
|
end loop;
|
|
|
|
if Imported_First then
|
|
Action (Project, With_State);
|
|
end if;
|
|
end if;
|
|
end Recursive_Check;
|
|
|
|
-- Start of processing for For_Every_Project_Imported
|
|
|
|
begin
|
|
Recursive_Check (Project => By);
|
|
Reset (Seen);
|
|
end For_Every_Project_Imported;
|
|
|
|
-----------------
|
|
-- Find_Source --
|
|
-----------------
|
|
|
|
function Find_Source
|
|
(In_Tree : Project_Tree_Ref;
|
|
Project : Project_Id;
|
|
In_Imported_Only : Boolean := False;
|
|
In_Extended_Only : Boolean := False;
|
|
Base_Name : File_Name_Type) return Source_Id
|
|
is
|
|
Result : Source_Id := No_Source;
|
|
|
|
procedure Look_For_Sources (Proj : Project_Id; Src : in out Source_Id);
|
|
-- Look for Base_Name in the sources of Proj
|
|
|
|
----------------------
|
|
-- Look_For_Sources --
|
|
----------------------
|
|
|
|
procedure Look_For_Sources (Proj : Project_Id; Src : in out Source_Id) is
|
|
Iterator : Source_Iterator;
|
|
|
|
begin
|
|
Iterator := For_Each_Source (In_Tree => In_Tree, Project => Proj);
|
|
while Element (Iterator) /= No_Source loop
|
|
if Element (Iterator).File = Base_Name then
|
|
Src := Element (Iterator);
|
|
return;
|
|
end if;
|
|
|
|
Next (Iterator);
|
|
end loop;
|
|
end Look_For_Sources;
|
|
|
|
procedure For_Imported_Projects is new For_Every_Project_Imported
|
|
(State => Source_Id, Action => Look_For_Sources);
|
|
|
|
Proj : Project_Id;
|
|
|
|
-- Start of processing for Find_Source
|
|
|
|
begin
|
|
if In_Extended_Only then
|
|
Proj := Project;
|
|
while Proj /= No_Project loop
|
|
Look_For_Sources (Proj, Result);
|
|
exit when Result /= No_Source;
|
|
|
|
Proj := Proj.Extends;
|
|
end loop;
|
|
|
|
elsif In_Imported_Only then
|
|
Look_For_Sources (Project, Result);
|
|
|
|
if Result = No_Source then
|
|
For_Imported_Projects
|
|
(By => Project,
|
|
With_State => Result);
|
|
end if;
|
|
else
|
|
Look_For_Sources (No_Project, Result);
|
|
end if;
|
|
|
|
return Result;
|
|
end Find_Source;
|
|
|
|
----------
|
|
-- Hash --
|
|
----------
|
|
|
|
function Hash is new System.HTable.Hash (Header_Num => Header_Num);
|
|
-- Used in implementation of other functions Hash below
|
|
|
|
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;
|
|
|
|
function Hash (Project : Project_Id) return Header_Num is
|
|
begin
|
|
if Project = No_Project then
|
|
return Header_Num'First;
|
|
else
|
|
return Hash (Get_Name_String (Project.Name));
|
|
end if;
|
|
end Hash;
|
|
|
|
-----------
|
|
-- Image --
|
|
-----------
|
|
|
|
function Image (The_Casing : Casing_Type) return String is
|
|
begin
|
|
return The_Casing_Images (The_Casing).all;
|
|
end Image;
|
|
|
|
-----------------------------
|
|
-- Is_Standard_GNAT_Naming --
|
|
-----------------------------
|
|
|
|
function Is_Standard_GNAT_Naming
|
|
(Naming : Lang_Naming_Data) return Boolean
|
|
is
|
|
begin
|
|
return Get_Name_String (Naming.Spec_Suffix) = ".ads"
|
|
and then Get_Name_String (Naming.Body_Suffix) = ".adb"
|
|
and then Get_Name_String (Naming.Dot_Replacement) = "-";
|
|
end Is_Standard_GNAT_Naming;
|
|
|
|
----------------
|
|
-- Initialize --
|
|
----------------
|
|
|
|
procedure Initialize (Tree : Project_Tree_Ref) is
|
|
begin
|
|
if The_Empty_String = No_Name then
|
|
Uintp.Initialize;
|
|
Name_Len := 0;
|
|
The_Empty_String := Name_Find;
|
|
|
|
Prj.Attr.Initialize;
|
|
Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
|
|
Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends));
|
|
Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
|
|
end if;
|
|
|
|
if Tree /= No_Project_Tree then
|
|
Reset (Tree);
|
|
end if;
|
|
end Initialize;
|
|
|
|
------------------
|
|
-- Is_Extending --
|
|
------------------
|
|
|
|
function Is_Extending
|
|
(Extending : Project_Id;
|
|
Extended : Project_Id) return Boolean
|
|
is
|
|
Proj : Project_Id;
|
|
|
|
begin
|
|
Proj := Extending;
|
|
while Proj /= No_Project loop
|
|
if Proj = Extended then
|
|
return True;
|
|
end if;
|
|
|
|
Proj := Proj.Extends;
|
|
end loop;
|
|
|
|
return False;
|
|
end Is_Extending;
|
|
|
|
-----------------
|
|
-- Object_Name --
|
|
-----------------
|
|
|
|
function Object_Name
|
|
(Source_File_Name : File_Name_Type;
|
|
Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
|
|
is
|
|
begin
|
|
if Object_File_Suffix = No_Name then
|
|
return Extend_Name
|
|
(Source_File_Name, Object_Suffix);
|
|
else
|
|
return Extend_Name
|
|
(Source_File_Name, Get_Name_String (Object_File_Suffix));
|
|
end if;
|
|
end Object_Name;
|
|
|
|
function Object_Name
|
|
(Source_File_Name : File_Name_Type;
|
|
Source_Index : Int;
|
|
Index_Separator : Character;
|
|
Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
|
|
is
|
|
Index_Img : constant String := Source_Index'Img;
|
|
Last : Natural;
|
|
|
|
begin
|
|
Get_Name_String (Source_File_Name);
|
|
|
|
Last := Name_Len;
|
|
while Last > 1 and then Name_Buffer (Last) /= '.' loop
|
|
Last := Last - 1;
|
|
end loop;
|
|
|
|
if Last > 1 then
|
|
Name_Len := Last - 1;
|
|
end if;
|
|
|
|
Add_Char_To_Name_Buffer (Index_Separator);
|
|
Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last));
|
|
|
|
if Object_File_Suffix = No_Name then
|
|
Add_Str_To_Name_Buffer (Object_Suffix);
|
|
else
|
|
Add_Str_To_Name_Buffer (Get_Name_String (Object_File_Suffix));
|
|
end if;
|
|
|
|
return Name_Find;
|
|
end Object_Name;
|
|
|
|
----------------------
|
|
-- Record_Temp_File --
|
|
----------------------
|
|
|
|
procedure Record_Temp_File
|
|
(Tree : Project_Tree_Ref;
|
|
Path : Path_Name_Type)
|
|
is
|
|
begin
|
|
Temp_Files_Table.Append (Tree.Private_Part.Temp_Files, Path);
|
|
end Record_Temp_File;
|
|
|
|
----------
|
|
-- Free --
|
|
----------
|
|
|
|
procedure Free (Project : in out Project_Id) is
|
|
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
|
|
(Project_Data, Project_Id);
|
|
|
|
begin
|
|
if Project /= null then
|
|
Free (Project.Ada_Include_Path);
|
|
Free (Project.Objects_Path);
|
|
Free (Project.Ada_Objects_Path);
|
|
Free_List (Project.Imported_Projects, Free_Project => False);
|
|
Free_List (Project.All_Imported_Projects, Free_Project => False);
|
|
Free_List (Project.Languages);
|
|
|
|
Unchecked_Free (Project);
|
|
end if;
|
|
end Free;
|
|
|
|
---------------
|
|
-- Free_List --
|
|
---------------
|
|
|
|
procedure Free_List (Languages : in out Language_List) is
|
|
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
|
|
(Language_List_Element, Language_List);
|
|
Tmp : Language_List;
|
|
begin
|
|
while Languages /= null loop
|
|
Tmp := Languages.Next;
|
|
Unchecked_Free (Languages);
|
|
Languages := Tmp;
|
|
end loop;
|
|
end Free_List;
|
|
|
|
---------------
|
|
-- Free_List --
|
|
---------------
|
|
|
|
procedure Free_List (Source : in out Source_Id) is
|
|
procedure Unchecked_Free is new
|
|
Ada.Unchecked_Deallocation (Source_Data, Source_Id);
|
|
|
|
Tmp : Source_Id;
|
|
|
|
begin
|
|
while Source /= No_Source loop
|
|
Tmp := Source.Next_In_Lang;
|
|
Free_List (Source.Alternate_Languages);
|
|
|
|
if Source.Unit /= null
|
|
and then Source.Kind in Spec_Or_Body
|
|
then
|
|
Source.Unit.File_Names (Source.Kind) := null;
|
|
end if;
|
|
|
|
Unchecked_Free (Source);
|
|
Source := Tmp;
|
|
end loop;
|
|
end Free_List;
|
|
|
|
---------------
|
|
-- Free_List --
|
|
---------------
|
|
|
|
procedure Free_List
|
|
(List : in out Project_List;
|
|
Free_Project : Boolean)
|
|
is
|
|
procedure Unchecked_Free is new
|
|
Ada.Unchecked_Deallocation (Project_List_Element, Project_List);
|
|
|
|
Tmp : Project_List;
|
|
|
|
begin
|
|
while List /= null loop
|
|
Tmp := List.Next;
|
|
|
|
if Free_Project then
|
|
Free (List.Project);
|
|
end if;
|
|
|
|
Unchecked_Free (List);
|
|
List := Tmp;
|
|
end loop;
|
|
end Free_List;
|
|
|
|
---------------
|
|
-- Free_List --
|
|
---------------
|
|
|
|
procedure Free_List (Languages : in out Language_Ptr) is
|
|
procedure Unchecked_Free is new
|
|
Ada.Unchecked_Deallocation (Language_Data, Language_Ptr);
|
|
|
|
Tmp : Language_Ptr;
|
|
|
|
begin
|
|
while Languages /= null loop
|
|
Tmp := Languages.Next;
|
|
Free_List (Languages.First_Source);
|
|
Unchecked_Free (Languages);
|
|
Languages := Tmp;
|
|
end loop;
|
|
end Free_List;
|
|
|
|
----------------
|
|
-- Free_Units --
|
|
----------------
|
|
|
|
procedure Free_Units (Table : in out Units_Htable.Instance) is
|
|
procedure Unchecked_Free is new
|
|
Ada.Unchecked_Deallocation (Unit_Data, Unit_Index);
|
|
|
|
Unit : Unit_Index;
|
|
|
|
begin
|
|
Unit := Units_Htable.Get_First (Table);
|
|
while Unit /= No_Unit_Index loop
|
|
if Unit.File_Names (Spec) /= null then
|
|
Unit.File_Names (Spec).Unit := No_Unit_Index;
|
|
end if;
|
|
|
|
if Unit.File_Names (Impl) /= null then
|
|
Unit.File_Names (Impl).Unit := No_Unit_Index;
|
|
end if;
|
|
|
|
Unchecked_Free (Unit);
|
|
Unit := Units_Htable.Get_Next (Table);
|
|
end loop;
|
|
|
|
Units_Htable.Reset (Table);
|
|
end Free_Units;
|
|
|
|
----------
|
|
-- Free --
|
|
----------
|
|
|
|
procedure Free (Tree : in out Project_Tree_Ref) is
|
|
procedure Unchecked_Free is new
|
|
Ada.Unchecked_Deallocation (Project_Tree_Data, Project_Tree_Ref);
|
|
|
|
begin
|
|
if Tree /= null then
|
|
Name_List_Table.Free (Tree.Name_Lists);
|
|
Number_List_Table.Free (Tree.Number_Lists);
|
|
String_Element_Table.Free (Tree.String_Elements);
|
|
Variable_Element_Table.Free (Tree.Variable_Elements);
|
|
Array_Element_Table.Free (Tree.Array_Elements);
|
|
Array_Table.Free (Tree.Arrays);
|
|
Package_Table.Free (Tree.Packages);
|
|
Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
|
|
|
|
Free_List (Tree.Projects, Free_Project => True);
|
|
Free_Units (Tree.Units_HT);
|
|
|
|
-- Private part
|
|
|
|
Temp_Files_Table.Free (Tree.Private_Part.Temp_Files);
|
|
|
|
Unchecked_Free (Tree);
|
|
end if;
|
|
end Free;
|
|
|
|
-----------
|
|
-- Reset --
|
|
-----------
|
|
|
|
procedure Reset (Tree : Project_Tree_Ref) is
|
|
begin
|
|
-- Visible tables
|
|
|
|
Name_List_Table.Init (Tree.Name_Lists);
|
|
Number_List_Table.Init (Tree.Number_Lists);
|
|
String_Element_Table.Init (Tree.String_Elements);
|
|
Variable_Element_Table.Init (Tree.Variable_Elements);
|
|
Array_Element_Table.Init (Tree.Array_Elements);
|
|
Array_Table.Init (Tree.Arrays);
|
|
Package_Table.Init (Tree.Packages);
|
|
Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
|
|
|
|
Free_List (Tree.Projects, Free_Project => True);
|
|
Free_Units (Tree.Units_HT);
|
|
|
|
-- Private part table
|
|
|
|
Temp_Files_Table.Init (Tree.Private_Part.Temp_Files);
|
|
|
|
Tree.Private_Part.Current_Source_Path_File := No_Path;
|
|
Tree.Private_Part.Current_Object_Path_File := No_Path;
|
|
end Reset;
|
|
|
|
-------------------
|
|
-- Switches_Name --
|
|
-------------------
|
|
|
|
function Switches_Name
|
|
(Source_File_Name : File_Name_Type) return File_Name_Type
|
|
is
|
|
begin
|
|
return Extend_Name (Source_File_Name, Switches_Dependency_Suffix);
|
|
end Switches_Name;
|
|
|
|
-----------
|
|
-- Value --
|
|
-----------
|
|
|
|
function Value (Image : String) return Casing_Type is
|
|
begin
|
|
for Casing in The_Casing_Images'Range loop
|
|
if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
|
|
return Casing;
|
|
end if;
|
|
end loop;
|
|
|
|
raise Constraint_Error;
|
|
end Value;
|
|
|
|
---------------------
|
|
-- Has_Ada_Sources --
|
|
---------------------
|
|
|
|
function Has_Ada_Sources (Data : Project_Id) return Boolean is
|
|
Lang : Language_Ptr;
|
|
|
|
begin
|
|
Lang := Data.Languages;
|
|
while Lang /= No_Language_Index loop
|
|
if Lang.Name = Name_Ada then
|
|
return Lang.First_Source /= No_Source;
|
|
end if;
|
|
Lang := Lang.Next;
|
|
end loop;
|
|
|
|
return False;
|
|
end Has_Ada_Sources;
|
|
|
|
------------------------
|
|
-- Contains_ALI_Files --
|
|
------------------------
|
|
|
|
function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is
|
|
Dir_Name : constant String := Get_Name_String (Dir);
|
|
Direct : Dir_Type;
|
|
Name : String (1 .. 1_000);
|
|
Last : Natural;
|
|
Result : Boolean := False;
|
|
|
|
begin
|
|
Open (Direct, Dir_Name);
|
|
|
|
-- For each file in the directory, check if it is an ALI file
|
|
|
|
loop
|
|
Read (Direct, Name, Last);
|
|
exit when Last = 0;
|
|
Canonical_Case_File_Name (Name (1 .. Last));
|
|
Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali";
|
|
exit when Result;
|
|
end loop;
|
|
|
|
Close (Direct);
|
|
return Result;
|
|
|
|
exception
|
|
-- If there is any problem, close the directory if open and return True.
|
|
-- The library directory will be added to the path.
|
|
|
|
when others =>
|
|
if Is_Open (Direct) then
|
|
Close (Direct);
|
|
end if;
|
|
|
|
return True;
|
|
end Contains_ALI_Files;
|
|
|
|
--------------------------
|
|
-- Get_Object_Directory --
|
|
--------------------------
|
|
|
|
function Get_Object_Directory
|
|
(Project : Project_Id;
|
|
Including_Libraries : Boolean;
|
|
Only_If_Ada : Boolean := False) return Path_Name_Type
|
|
is
|
|
begin
|
|
if (Project.Library and then Including_Libraries)
|
|
or else
|
|
(Project.Object_Directory /= No_Path_Information
|
|
and then (not Including_Libraries or else not Project.Library))
|
|
then
|
|
-- For a library project, add the library ALI directory if there is
|
|
-- no object directory or if the library ALI directory contains ALI
|
|
-- files; otherwise add the object directory.
|
|
|
|
if Project.Library then
|
|
if Project.Object_Directory = No_Path_Information
|
|
or else Contains_ALI_Files (Project.Library_ALI_Dir.Name)
|
|
then
|
|
return Project.Library_ALI_Dir.Name;
|
|
else
|
|
return Project.Object_Directory.Name;
|
|
end if;
|
|
|
|
-- For a non-library project, add object directory if it is not a
|
|
-- virtual project, and if there are Ada sources in the project or
|
|
-- one of the projects it extends. If there are no Ada sources,
|
|
-- adding the object directory could disrupt the order of the
|
|
-- object dirs in the path.
|
|
|
|
elsif not Project.Virtual then
|
|
declare
|
|
Add_Object_Dir : Boolean;
|
|
Prj : Project_Id;
|
|
|
|
begin
|
|
Add_Object_Dir := not Only_If_Ada;
|
|
Prj := Project;
|
|
while not Add_Object_Dir and then Prj /= No_Project loop
|
|
if Has_Ada_Sources (Prj) then
|
|
Add_Object_Dir := True;
|
|
else
|
|
Prj := Prj.Extends;
|
|
end if;
|
|
end loop;
|
|
|
|
if Add_Object_Dir then
|
|
return Project.Object_Directory.Name;
|
|
end if;
|
|
end;
|
|
end if;
|
|
end if;
|
|
|
|
return No_Path;
|
|
end Get_Object_Directory;
|
|
|
|
-----------------------------------
|
|
-- Ultimate_Extending_Project_Of --
|
|
-----------------------------------
|
|
|
|
function Ultimate_Extending_Project_Of
|
|
(Proj : Project_Id) return Project_Id
|
|
is
|
|
Prj : Project_Id;
|
|
|
|
begin
|
|
Prj := Proj;
|
|
while Prj /= null and then Prj.Extended_By /= No_Project loop
|
|
Prj := Prj.Extended_By;
|
|
end loop;
|
|
|
|
return Prj;
|
|
end Ultimate_Extending_Project_Of;
|
|
|
|
-----------------------------------
|
|
-- Compute_All_Imported_Projects --
|
|
-----------------------------------
|
|
|
|
procedure Compute_All_Imported_Projects (Tree : Project_Tree_Ref) is
|
|
Project : Project_Id;
|
|
|
|
procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean);
|
|
-- Recursively add the projects imported by project Project, but not
|
|
-- those that are extended.
|
|
|
|
-------------------
|
|
-- Recursive_Add --
|
|
-------------------
|
|
|
|
procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean) is
|
|
pragma Unreferenced (Dummy);
|
|
List : Project_List;
|
|
Prj2 : Project_Id;
|
|
|
|
begin
|
|
-- A project is not importing itself
|
|
|
|
Prj2 := Ultimate_Extending_Project_Of (Prj);
|
|
|
|
if Project /= Prj2 then
|
|
|
|
-- Check that the project is not already in the list. We know the
|
|
-- one passed to Recursive_Add have never been visited before, but
|
|
-- the one passed it are the extended projects.
|
|
|
|
List := Project.All_Imported_Projects;
|
|
while List /= null loop
|
|
if List.Project = Prj2 then
|
|
return;
|
|
end if;
|
|
|
|
List := List.Next;
|
|
end loop;
|
|
|
|
-- Add it to the list
|
|
|
|
Project.All_Imported_Projects :=
|
|
new Project_List_Element'
|
|
(Project => Prj2,
|
|
Next => Project.All_Imported_Projects);
|
|
end if;
|
|
end Recursive_Add;
|
|
|
|
procedure For_All_Projects is
|
|
new For_Every_Project_Imported (Boolean, Recursive_Add);
|
|
|
|
Dummy : Boolean := False;
|
|
List : Project_List;
|
|
|
|
begin
|
|
List := Tree.Projects;
|
|
while List /= null loop
|
|
Project := List.Project;
|
|
Free_List (Project.All_Imported_Projects, Free_Project => False);
|
|
For_All_Projects (Project, Dummy);
|
|
List := List.Next;
|
|
end loop;
|
|
end Compute_All_Imported_Projects;
|
|
|
|
-------------------
|
|
-- Is_Compilable --
|
|
-------------------
|
|
|
|
function Is_Compilable (Source : Source_Id) return Boolean is
|
|
begin
|
|
return Source.Language.Config.Compiler_Driver /= No_File
|
|
and then Length_Of_Name (Source.Language.Config.Compiler_Driver) /= 0
|
|
and then not Source.Locally_Removed;
|
|
end Is_Compilable;
|
|
|
|
------------------------------
|
|
-- Object_To_Global_Archive --
|
|
------------------------------
|
|
|
|
function Object_To_Global_Archive (Source : Source_Id) return Boolean is
|
|
begin
|
|
return Source.Language.Config.Kind = File_Based
|
|
and then Source.Kind = Impl
|
|
and then Source.Language.Config.Objects_Linked
|
|
and then Is_Compilable (Source)
|
|
and then Source.Language.Config.Object_Generated;
|
|
end Object_To_Global_Archive;
|
|
|
|
----------------------------
|
|
-- Get_Language_From_Name --
|
|
----------------------------
|
|
|
|
function Get_Language_From_Name
|
|
(Project : Project_Id;
|
|
Name : String) return Language_Ptr
|
|
is
|
|
N : Name_Id;
|
|
Result : Language_Ptr;
|
|
|
|
begin
|
|
Name_Len := Name'Length;
|
|
Name_Buffer (1 .. Name_Len) := Name;
|
|
To_Lower (Name_Buffer (1 .. Name_Len));
|
|
N := Name_Find;
|
|
|
|
Result := Project.Languages;
|
|
while Result /= No_Language_Index loop
|
|
if Result.Name = N then
|
|
return Result;
|
|
end if;
|
|
|
|
Result := Result.Next;
|
|
end loop;
|
|
|
|
return No_Language_Index;
|
|
end Get_Language_From_Name;
|
|
|
|
----------------
|
|
-- Other_Part --
|
|
----------------
|
|
|
|
function Other_Part (Source : Source_Id) return Source_Id is
|
|
begin
|
|
if Source.Unit /= No_Unit_Index then
|
|
case Source.Kind is
|
|
when Impl =>
|
|
return Source.Unit.File_Names (Spec);
|
|
when Spec =>
|
|
return Source.Unit.File_Names (Impl);
|
|
when Sep =>
|
|
return No_Source;
|
|
end case;
|
|
else
|
|
return No_Source;
|
|
end if;
|
|
end Other_Part;
|
|
|
|
------------------
|
|
-- Create_Flags --
|
|
------------------
|
|
|
|
function Create_Flags
|
|
(Report_Error : Error_Handler;
|
|
When_No_Sources : Error_Warning;
|
|
Require_Sources_Other_Lang : Boolean := True;
|
|
Allow_Duplicate_Basenames : Boolean := True;
|
|
Compiler_Driver_Mandatory : Boolean := False;
|
|
Error_On_Unknown_Language : Boolean := True;
|
|
Require_Obj_Dirs : Error_Warning := Error)
|
|
return Processing_Flags
|
|
is
|
|
begin
|
|
return Processing_Flags'
|
|
(Report_Error => Report_Error,
|
|
When_No_Sources => When_No_Sources,
|
|
Require_Sources_Other_Lang => Require_Sources_Other_Lang,
|
|
Allow_Duplicate_Basenames => Allow_Duplicate_Basenames,
|
|
Error_On_Unknown_Language => Error_On_Unknown_Language,
|
|
Compiler_Driver_Mandatory => Compiler_Driver_Mandatory,
|
|
Require_Obj_Dirs => Require_Obj_Dirs);
|
|
end Create_Flags;
|
|
|
|
------------
|
|
-- Length --
|
|
------------
|
|
|
|
function Length
|
|
(Table : Name_List_Table.Instance;
|
|
List : Name_List_Index) return Natural
|
|
is
|
|
Count : Natural := 0;
|
|
Tmp : Name_List_Index;
|
|
|
|
begin
|
|
Tmp := List;
|
|
while Tmp /= No_Name_List loop
|
|
Count := Count + 1;
|
|
Tmp := Table.Table (Tmp).Next;
|
|
end loop;
|
|
|
|
return Count;
|
|
end Length;
|
|
|
|
begin
|
|
-- Make sure that the standard config and user project file extensions are
|
|
-- compatible with canonical case file naming.
|
|
|
|
Canonical_Case_File_Name (Config_Project_File_Extension);
|
|
Canonical_Case_File_Name (Project_File_Extension);
|
|
end Prj;
|