blob: ff84abace85bd4cbdbd3ad89c6b45228b6dc03f6 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- M L I B . P R J --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2014, AdaCore --
-- --
-- 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 ALI; use ALI;
with Gnatvsn; use Gnatvsn;
with Makeutl; use Makeutl;
with MLib.Fil; use MLib.Fil;
with MLib.Tgt; use MLib.Tgt;
with MLib.Utl; use MLib.Utl;
with Opt;
with Output; use Output;
with Prj.Com; use Prj.Com;
with Prj.Env; use Prj.Env;
with Prj.Util; use Prj.Util;
with Sinput.P;
with Snames; use Snames;
with Switch; use Switch;
with Table;
with Tempdir;
with Types; use Types;
with Ada.Characters.Handling;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.HTable;
with Interfaces.C_Streams; use Interfaces.C_Streams;
with System; use System;
with System.Case_Util; use System.Case_Util;
package body MLib.Prj is
Prj_Add_Obj_Files : Types.Int;
pragma Import (C, Prj_Add_Obj_Files, "__gnat_prj_add_obj_files");
Add_Object_Files : constant Boolean := Prj_Add_Obj_Files /= 0;
-- Indicates if object files in pragmas Linker_Options (found in the
-- binder generated file) should be taken when linking a stand-alone
-- library. False for Windows, True for other platforms.
ALI_Suffix : constant String := ".ali";
B_Start : constant String := "b~";
-- Prefix of bind file
S_Osinte_Ads : File_Name_Type := No_File;
-- Name_Id for "s-osinte.ads"
S_Dec_Ads : File_Name_Type := No_File;
-- Name_Id for "dec.ads"
Arguments : String_List_Access := No_Argument;
-- Used to accumulate arguments for the invocation of gnatbind and of the
-- compiler. Also used to collect the interface ALI when copying the ALI
-- files to the library directory.
Argument_Number : Natural := 0;
-- Index of the last argument in Arguments
Initial_Argument_Max : constant := 10;
-- Where does the magic constant 10 come from???
No_Main_String : aliased String := "-n";
No_Main : constant String_Access := No_Main_String'Access;
Output_Switch_String : aliased String := "-o";
Output_Switch : constant String_Access :=
Output_Switch_String'Access;
Compile_Switch_String : aliased String := "-c";
Compile_Switch : constant String_Access :=
Compile_Switch_String'Access;
No_Warning_String : aliased String := "-gnatws";
No_Warning : constant String_Access := No_Warning_String'Access;
Auto_Initialize : constant String := "-a";
-- List of objects to put inside the library
Object_Files : Argument_List_Access;
package Objects is new Table.Table
(Table_Name => "Mlib.Prj.Objects",
Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 50,
Table_Increment => 100);
package Objects_Htable is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num,
Element => Boolean,
No_Element => False,
Key => Name_Id,
Hash => Hash,
Equal => "=");
-- List of ALI files
Ali_Files : Argument_List_Access;
package ALIs is new Table.Table
(Table_Name => "Mlib.Prj.Alis",
Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 50,
Table_Increment => 100);
-- List of options set in the command line
Options : Argument_List_Access;
package Opts is new Table.Table
(Table_Name => "Mlib.Prj.Opts",
Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 5,
Table_Increment => 100);
-- All the ALI file in the library
package Library_ALIs is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num,
Element => Boolean,
No_Element => False,
Key => File_Name_Type,
Hash => Hash,
Equal => "=");
-- The ALI files in the interface sets
package Interface_ALIs is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num,
Element => Boolean,
No_Element => False,
Key => File_Name_Type,
Hash => Hash,
Equal => "=");
-- The ALI files that have been processed to check if the corresponding
-- library unit is in the interface set.
package Processed_ALIs is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num,
Element => Boolean,
No_Element => False,
Key => File_Name_Type,
Hash => Hash,
Equal => "=");
-- The projects imported directly or indirectly
package Processed_Projects is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num,
Element => Boolean,
No_Element => False,
Key => Name_Id,
Hash => Hash,
Equal => "=");
-- The library projects imported directly or indirectly
package Library_Projs is new Table.Table (
Table_Component_Type => Project_Id,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 10,
Table_Name => "Make.Library_Projs");
type Build_Mode_State is (None, Static, Dynamic, Relocatable);
procedure Add_Argument (S : String);
-- Add one argument to Arguments array, if array is full, double its size
function ALI_File_Name (Source : String) return String;
-- Return the ALI file name corresponding to a source
procedure Check (Filename : String);
-- Check if filename is a regular file. Fail if it is not
procedure Check_Context;
-- Check each object files in table Object_Files
-- Fail if any of them is not a regular file
procedure Copy_Interface_Sources
(For_Project : Project_Id;
In_Tree : Project_Tree_Ref;
Interfaces : Argument_List;
To_Dir : Path_Name_Type);
-- Copy the interface sources of a SAL to directory To_Dir
procedure Display (Executable : String);
-- Display invocation of gnatbind and of the compiler with the arguments
-- in Arguments, except when Quiet_Output is True.
function Index (S, Pattern : String) return Natural;
-- Return the last occurrence of Pattern in S, or 0 if none
procedure Process_Binder_File (Name : String);
-- For Stand-Alone libraries, get the Linker Options in the binder
-- generated file.
procedure Reset_Tables;
-- Make sure that all the above tables are empty
-- (Objects, Ali_Files, Options).
function SALs_Use_Constructors return Boolean;
-- Indicate if Stand-Alone Libraries are automatically initialized using
-- the constructor mechanism.
------------------
-- Add_Argument --
------------------
procedure Add_Argument (S : String) is
begin
if Argument_Number = Arguments'Last then
declare
New_Args : constant String_List_Access :=
new String_List (1 .. 2 * Arguments'Last);
begin
-- Copy the String_Accesses and set them to null in Arguments
-- so that they will not be deallocated by the call to
-- Free (Arguments).
New_Args (Arguments'Range) := Arguments.all;
Arguments.all := (others => null);
Free (Arguments);
Arguments := New_Args;
end;
end if;
Argument_Number := Argument_Number + 1;
Arguments (Argument_Number) := new String'(S);
end Add_Argument;
-------------------
-- ALI_File_Name --
-------------------
function ALI_File_Name (Source : String) return String is
begin
-- If the source name has an extension, then replace it with
-- the ALI suffix.
for Index in reverse Source'First + 1 .. Source'Last loop
if Source (Index) = '.' then
return Source (Source'First .. Index - 1) & ALI_Suffix;
end if;
end loop;
-- If there is no dot, or if it is the first character, just add the
-- ALI suffix.
return Source & ALI_Suffix;
end ALI_File_Name;
-------------------
-- Build_Library --
-------------------
procedure Build_Library
(For_Project : Project_Id;
In_Tree : Project_Tree_Ref;
Gnatbind : String;
Gnatbind_Path : String_Access;
Gcc : String;
Gcc_Path : String_Access;
Bind : Boolean := True;
Link : Boolean := True)
is
Maximum_Size : Integer;
pragma Import (C, Maximum_Size, "__gnat_link_max");
-- Maximum number of bytes to put in an invocation of gnatbind
Size : Integer;
-- The number of bytes for the invocation of gnatbind
Warning_For_Library : Boolean := False;
-- Set True for first warning for a unit missing from the interface set
Current_Proj : Project_Id;
Libgnarl_Needed : Yes_No_Unknown := For_Project.Libgnarl_Needed;
-- Set True if library needs to be linked with libgnarl
Object_Directory_Path : constant String :=
Get_Name_String
(For_Project.Object_Directory.Display_Name);
Standalone : constant Boolean := For_Project.Standalone_Library /= No;
Project_Name : constant String := Get_Name_String (For_Project.Name);
Current_Dir : constant String := Get_Current_Dir;
Lib_Filename : String_Access;
Lib_Dirpath : String_Access;
Lib_Version : String_Access := new String'("");
The_Build_Mode : Build_Mode_State := None;
Success : Boolean := False;
Library_Options : Variable_Value := Nil_Variable_Value;
Driver_Name : Name_Id := No_Name;
In_Main_Object_Directory : Boolean := True;
Foreign_Sources : Boolean;
Rpath : String_Access := null;
-- Allocated only if Path Option is supported
Rpath_Last : Natural := 0;
-- Index of last valid character of Rpath
Initial_Rpath_Length : constant := 200;
-- Initial size of Rpath, when first allocated
Path_Option : String_Access := Linker_Library_Path_Option;
-- If null, Path Option is not supported. Not a constant so that it can
-- be deallocated.
First_ALI : File_Name_Type := No_File;
-- Store the ALI file name of a source of the library (the first found)
procedure Add_ALI_For (Source : File_Name_Type);
-- Add name of the ALI file corresponding to Source to the Arguments
procedure Add_Rpath (Path : String);
-- Add a path name to Rpath
function Check_Project (P : Project_Id) return Boolean;
-- Returns True if P is For_Project or a project extended by For_Project
procedure Check_Libs (ALI_File : String; Main_Project : Boolean);
-- Set Libgnarl_Needed if the ALI_File indicates that there is a need
-- to link with -lgnarl (this is the case when there is a dependency
-- on s-osinte.ads).
procedure Process (The_ALI : File_Name_Type);
-- Check if the closure of a library unit which is or should be in the
-- interface set is also in the interface set. Issue a warning for each
-- missing library unit.
procedure Process_Imported_Libraries;
-- Add the -L and -l switches for the imported Library Project Files,
-- and, if Path Option is supported, the library directory path names
-- to Rpath.
-----------------
-- Add_ALI_For --
-----------------
procedure Add_ALI_For (Source : File_Name_Type) is
ALI : constant String := ALI_File_Name (Get_Name_String (Source));
ALI_Id : File_Name_Type;
begin
if Bind then
Add_Argument (ALI);
end if;
Name_Len := 0;
Add_Str_To_Name_Buffer (S => ALI);
ALI_Id := Name_Find;
-- Add the ALI file name to the library ALIs
if Bind then
Library_ALIs.Set (ALI_Id, True);
end if;
-- Set First_ALI, if not already done
if First_ALI = No_File then
First_ALI := ALI_Id;
end if;
end Add_ALI_For;
---------------
-- Add_Rpath --
---------------
procedure Add_Rpath (Path : String) is
procedure Double;
-- Double Rpath size
------------
-- Double --
------------
procedure Double is
New_Rpath : constant String_Access :=
new String (1 .. 2 * Rpath'Length);
begin
New_Rpath (1 .. Rpath_Last) := Rpath (1 .. Rpath_Last);
Free (Rpath);
Rpath := New_Rpath;
end Double;
-- Start of processing for Add_Rpath
begin
-- If first path, allocate initial Rpath
if Rpath = null then
Rpath := new String (1 .. Initial_Rpath_Length);
Rpath_Last := 0;
else
-- Otherwise, add a path separator between two path names
if Rpath_Last = Rpath'Last then
Double;
end if;
Rpath_Last := Rpath_Last + 1;
Rpath (Rpath_Last) := Path_Separator;
end if;
-- Increase Rpath size until it is large enough
while Rpath_Last + Path'Length > Rpath'Last loop
Double;
end loop;
-- Add the path name
Rpath (Rpath_Last + 1 .. Rpath_Last + Path'Length) := Path;
Rpath_Last := Rpath_Last + Path'Length;
end Add_Rpath;
-------------------
-- Check_Project --
-------------------
function Check_Project (P : Project_Id) return Boolean is
begin
if P = For_Project then
return True;
elsif P /= No_Project then
declare
Proj : Project_Id;
begin
Proj := For_Project;
while Proj.Extends /= No_Project loop
if P = Proj.Extends then
return True;
end if;
Proj := Proj.Extends;
end loop;
end;
end if;
return False;
end Check_Project;
----------------
-- Check_Libs --
----------------
procedure Check_Libs (ALI_File : String; Main_Project : Boolean) is
Lib_File : File_Name_Type;
Text : Text_Buffer_Ptr;
Id : ALI.ALI_Id;
begin
if Libgnarl_Needed /= Yes then
-- Scan the ALI file
Name_Len := ALI_File'Length;
Name_Buffer (1 .. Name_Len) := ALI_File;
Lib_File := Name_Find;
Text := Read_Library_Info (Lib_File, True);
Id := ALI.Scan_ALI
(F => Lib_File,
T => Text,
Ignore_ED => False,
Err => True,
Read_Lines => "D");
Free (Text);
-- Look for s-osinte.ads in the dependencies
for Index in ALI.ALIs.Table (Id).First_Sdep ..
ALI.ALIs.Table (Id).Last_Sdep
loop
if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then
Libgnarl_Needed := Yes;
if Main_Project then
For_Project.Libgnarl_Needed := Yes;
else
exit;
end if;
end if;
end loop;
end if;
end Check_Libs;
-------------
-- Process --
-------------
procedure Process (The_ALI : File_Name_Type) is
Text : Text_Buffer_Ptr;
Idread : ALI_Id;
First_Unit : ALI.Unit_Id;
Last_Unit : ALI.Unit_Id;
Unit_Data : Unit_Record;
Afile : File_Name_Type;
begin
-- Nothing to do if the ALI file has already been processed.
-- This happens if an interface imports another interface.
if not Processed_ALIs.Get (The_ALI) then
Processed_ALIs.Set (The_ALI, True);
Text := Read_Library_Info (The_ALI);
if Text /= null then
Idread :=
Scan_ALI
(F => The_ALI,
T => Text,
Ignore_ED => False,
Err => True);
Free (Text);
if Idread /= No_ALI_Id then
First_Unit := ALI.ALIs.Table (Idread).First_Unit;
Last_Unit := ALI.ALIs.Table (Idread).Last_Unit;
-- Process both unit (spec and body) if the body is needed
-- by the spec (inline or generic). Otherwise, just process
-- the spec.
if First_Unit /= Last_Unit and then
not ALI.Units.Table (Last_Unit).Body_Needed_For_SAL
then
First_Unit := Last_Unit;
end if;
for Unit in First_Unit .. Last_Unit loop
Unit_Data := ALI.Units.Table (Unit);
-- Check if each withed unit which is in the library is
-- also in the interface set, if it has not yet been
-- processed.
for W in Unit_Data.First_With .. Unit_Data.Last_With loop
Afile := Withs.Table (W).Afile;
if Afile /= No_File and then Library_ALIs.Get (Afile)
and then not Processed_ALIs.Get (Afile)
then
if not Interface_ALIs.Get (Afile) then
if not Warning_For_Library then
Write_Str ("Warning: In library project """);
Get_Name_String (Current_Proj.Name);
To_Mixed (Name_Buffer (1 .. Name_Len));
Write_Str (Name_Buffer (1 .. Name_Len));
Write_Line ("""");
Warning_For_Library := True;
end if;
Write_Str (" Unit """);
Get_Name_String (Withs.Table (W).Uname);
To_Mixed (Name_Buffer (1 .. Name_Len - 2));
Write_Str (Name_Buffer (1 .. Name_Len - 2));
Write_Line (""" is not in the interface set");
Write_Str (" but it is needed by ");
case Unit_Data.Utype is
when Is_Spec =>
Write_Str ("the spec of ");
when Is_Body =>
Write_Str ("the body of ");
when others =>
null;
end case;
Write_Str ("""");
Get_Name_String (Unit_Data.Uname);
To_Mixed (Name_Buffer (1 .. Name_Len - 2));
Write_Str (Name_Buffer (1 .. Name_Len - 2));
Write_Line ("""");
end if;
-- Now, process this unit
Process (Afile);
end if;
end loop;
end loop;
end if;
end if;
end if;
end Process;
--------------------------------
-- Process_Imported_Libraries --
--------------------------------
procedure Process_Imported_Libraries is
Current : Project_Id;
procedure Process_Project (Project : Project_Id);
-- Process Project and its imported projects recursively.
-- Add any library projects to table Library_Projs.
---------------------
-- Process_Project --
---------------------
procedure Process_Project (Project : Project_Id) is
Imported : Project_List;
begin
-- Nothing to do if process has already been processed
if not Processed_Projects.Get (Project.Name) then
Processed_Projects.Set (Project.Name, True);
-- Call Process_Project recursively for any imported project.
-- We first process the imported projects to guarantee that
-- we have a proper reverse order for the libraries.
Imported := Project.Imported_Projects;
while Imported /= null loop
if Imported.Project /= No_Project then
Process_Project (Imported.Project);
end if;
Imported := Imported.Next;
end loop;
-- If it is a library project, add it to Library_Projs
if Project /= For_Project and then Project.Library then
Library_Projs.Increment_Last;
Library_Projs.Table (Library_Projs.Last) := Project;
-- Check if because of this library we need to use libgnarl
if Libgnarl_Needed = Unknown then
if Project.Libgnarl_Needed = Unknown
and then Project.Object_Directory /= No_Path_Information
then
-- Check if libgnarl is needed for this library
declare
Object_Dir_Path : constant String :=
Get_Name_String
(Project.Object_Directory.
Display_Name);
Object_Dir : Dir_Type;
Filename : String (1 .. 255);
Last : Natural;
begin
Open (Object_Dir, Object_Dir_Path);
-- For all entries in the object directory
loop
Read (Object_Dir, Filename, Last);
exit when Last = 0;
-- Check if it is an object file
if Is_Obj (Filename (1 .. Last)) then
declare
Object_Path : constant String :=
Normalize_Pathname
(Object_Dir_Path &
Directory_Separator &
Filename (1 .. Last));
ALI_File : constant String :=
Ext_To
(Object_Path, "ali");
begin
if Is_Regular_File (ALI_File) then
-- Find out if for this ALI file,
-- libgnarl is necessary.
Check_Libs
(ALI_File, Main_Project => False);
if Libgnarl_Needed = Yes then
Project.Libgnarl_Needed := Yes;
For_Project.Libgnarl_Needed := Yes;
exit;
end if;
end if;
end;
end if;
end loop;
Close (Object_Dir);
end;
end if;
if Project.Libgnarl_Needed = Yes then
Libgnarl_Needed := Yes;
For_Project.Libgnarl_Needed := Yes;
end if;
end if;
end if;
end if;
end Process_Project;
-- Start of processing for Process_Imported_Libraries
begin
-- Build list of library projects imported directly or indirectly,
-- in the reverse order.
Process_Project (For_Project);
-- Add the -L and -l switches and, if the Rpath option is supported,
-- add the directory to the Rpath. As the library projects are in the
-- wrong order, process from the last to the first.
for Index in reverse 1 .. Library_Projs.Last loop
Current := Library_Projs.Table (Index);
Get_Name_String (Current.Library_Dir.Display_Name);
Opts.Increment_Last;
Opts.Table (Opts.Last) :=
new String'("-L" & Name_Buffer (1 .. Name_Len));
if Path_Option /= null then
Add_Rpath (Name_Buffer (1 .. Name_Len));
end if;
Opts.Increment_Last;
Opts.Table (Opts.Last) :=
new String'("-l" & Get_Name_String (Current.Library_Name));
end loop;
end Process_Imported_Libraries;
Path_FD : File_Descriptor := Invalid_FD;
-- Used for setting the source and object paths
-- Start of processing for Build_Library
begin
Reset_Tables;
-- Fail if project is not a library project
if not For_Project.Library then
Com.Fail ("project """ & Project_Name & """ has no library");
end if;
-- Do not attempt to build the library if it is externally built
if For_Project.Externally_Built then
return;
end if;
-- If this is the first time Build_Library is called, get the Name_Id
-- of "s-osinte.ads".
if S_Osinte_Ads = No_File then
Name_Len := 0;
Add_Str_To_Name_Buffer ("s-osinte.ads");
S_Osinte_Ads := Name_Find;
end if;
if S_Dec_Ads = No_File then
Name_Len := 0;
Add_Str_To_Name_Buffer ("dec.ads");
S_Dec_Ads := Name_Find;
end if;
-- We work in the object directory
Change_Dir (Object_Directory_Path);
if Standalone then
-- Call gnatbind only if Bind is True
if Bind then
if Gnatbind_Path = null then
Com.Fail ("unable to locate " & Gnatbind);
end if;
if Gcc_Path = null then
Com.Fail ("unable to locate " & Gcc);
end if;
-- Allocate Arguments, if it is the first time we see a standalone
-- library.
if Arguments = No_Argument then
Arguments := new String_List (1 .. Initial_Argument_Max);
end if;
-- Add "-n -o b~<lib>.adb -L<lib>_"
Argument_Number := 2;
Arguments (1) := No_Main;
Arguments (2) := Output_Switch;
Add_Argument
(B_Start & Get_Name_String (For_Project.Library_Name) & ".adb");
-- Make sure that the init procedure is never "adainit"
Get_Name_String (For_Project.Library_Name);
if Name_Buffer (1 .. Name_Len) = "ada" then
Add_Argument ("-Lada_");
else
Add_Argument
("-L" & Get_Name_String (For_Project.Library_Name));
end if;
if For_Project.Lib_Auto_Init and then SALs_Use_Constructors then
Add_Argument (Auto_Initialize);
end if;
-- Check if Binder'Default_Switches ("Ada") is defined. If it is,
-- add these switches to call gnatbind.
declare
Binder_Package : constant Package_Id :=
Value_Of
(Name => Name_Binder,
In_Packages => For_Project.Decl.Packages,
Shared => In_Tree.Shared);
begin
if Binder_Package /= No_Package then
declare
Defaults : constant Array_Element_Id :=
Value_Of
(Name => Name_Default_Switches,
In_Arrays =>
In_Tree.Shared.Packages.Table
(Binder_Package).Decl.Arrays,
Shared => In_Tree.Shared);
Switches : Variable_Value := Nil_Variable_Value;
Switch : String_List_Id := Nil_String;
begin
if Defaults /= No_Array_Element then
Switches :=
Value_Of
(Index => Name_Ada,
Src_Index => 0,
In_Array => Defaults,
Shared => In_Tree.Shared);
if not Switches.Default then
Switch := Switches.Values;
while Switch /= Nil_String loop
Add_Argument
(Get_Name_String
(In_Tree.Shared.String_Elements.Table
(Switch).Value));
Switch := In_Tree.Shared.String_Elements.
Table (Switch).Next;
end loop;
end if;
end if;
end;
end if;
end;
end if;
-- Get all the ALI files of the project file. We do that even if
-- Bind is False, so that First_ALI is set.
declare
Unit : Unit_Index;
begin
Library_ALIs.Reset;
Interface_ALIs.Reset;
Processed_ALIs.Reset;
Unit := Units_Htable.Get_First (In_Tree.Units_HT);
while Unit /= No_Unit_Index loop
if Unit.File_Names (Impl) /= null
and then not Unit.File_Names (Impl).Locally_Removed
then
if Check_Project (Unit.File_Names (Impl).Project) then
if Unit.File_Names (Spec) = null then
-- Add the ALI file only if it is not a subunit
declare
Src_Ind : constant Source_File_Index :=
Sinput.P.Load_Project_File
(Get_Name_String
(Unit.File_Names (Impl).Path.Name));
begin
if not
Sinput.P.Source_File_Is_Subunit (Src_Ind)
then
Add_ALI_For (Unit.File_Names (Impl).File);
exit when not Bind;
end if;
end;
else
Add_ALI_For (Unit.File_Names (Impl).File);
exit when not Bind;
end if;
end if;
elsif Unit.File_Names (Spec) /= null
and then not Unit.File_Names (Spec).Locally_Removed
and then Check_Project (Unit.File_Names (Spec).Project)
then
Add_ALI_For (Unit.File_Names (Spec).File);
exit when not Bind;
end if;
Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
end loop;
end;
-- Continue setup and call gnatbind if Bind is True
if Bind then
-- Get an eventual --RTS from the ALI file
if First_ALI /= No_File then
declare
T : Text_Buffer_Ptr;
A : ALI_Id;
begin
-- Load the ALI file
T := Read_Library_Info (First_ALI, True);
-- Read it
A := Scan_ALI
(First_ALI, T, Ignore_ED => False, Err => False);
if A /= No_ALI_Id then
for Index in
ALI.Units.Table
(ALI.ALIs.Table (A).First_Unit).First_Arg ..
ALI.Units.Table
(ALI.ALIs.Table (A).First_Unit).Last_Arg
loop
-- If --RTS found, add switch to call gnatbind
declare
Arg : String_Ptr renames Args.Table (Index);
begin
if Arg'Length >= 6 and then
Arg (Arg'First + 2 .. Arg'First + 5) = "RTS="
then
Add_Argument (Arg.all);
exit;
end if;
end;
end loop;
end if;
end;
end if;
-- Set the paths
-- First the source path
if For_Project.Include_Path_File = No_Path then
Get_Directories
(Project_Tree => In_Tree,
For_Project => For_Project,
Activity => Compilation,
Languages => Ada_Only);
Create_New_Path_File
(In_Tree.Shared, Path_FD, For_Project.Include_Path_File);
Write_Path_File (Path_FD);
Path_FD := Invalid_FD;
end if;
if Current_Source_Path_File_Of (In_Tree.Shared) /=
For_Project.Include_Path_File
then
Set_Current_Source_Path_File_Of
(In_Tree.Shared, For_Project.Include_Path_File);
Set_Path_File_Var
(Project_Include_Path_File,
Get_Name_String (For_Project.Include_Path_File));
end if;
-- Then, the object path
Get_Directories
(Project_Tree => In_Tree,
For_Project => For_Project,
Activity => SAL_Binding,
Languages => Ada_Only);
declare
Path_File_Name : Path_Name_Type;
begin
Create_New_Path_File (In_Tree.Shared, Path_FD, Path_File_Name);
Write_Path_File (Path_FD);
Path_FD := Invalid_FD;
Set_Path_File_Var
(Project_Objects_Path_File, Get_Name_String (Path_File_Name));
Set_Current_Source_Path_File_Of
(In_Tree.Shared, Path_File_Name);
end;
-- Display the gnatbind command, if not in quiet output
Display (Gnatbind);
Size := 0;
for J in 1 .. Argument_Number loop
Size := Size + Arguments (J)'Length + 1;
end loop;
-- Invoke gnatbind with the arguments if the size is not too large
if Size <= Maximum_Size then
Spawn
(Gnatbind_Path.all,
Arguments (1 .. Argument_Number),
Success);
-- Otherwise create a temporary response file
else
declare
FD : File_Descriptor;
Path : Path_Name_Type;
Args : Argument_List (1 .. 1);
EOL : constant String (1 .. 1) := (1 => ASCII.LF);
Status : Integer;
Succ : Boolean;
Quotes_Needed : Boolean;
Last_Char : Natural;
Ch : Character;
begin
Tempdir.Create_Temp_File (FD, Path);
Args (1) := new String'("@" & Get_Name_String (Path));
for J in 1 .. Argument_Number loop
-- Check if the argument should be quoted
Quotes_Needed := False;
Last_Char := Arguments (J)'Length;
for K in Arguments (J)'Range loop
Ch := Arguments (J) (K);
if Ch = ' ' or else Ch = ASCII.HT or else Ch = '"' then
Quotes_Needed := True;
exit;
end if;
end loop;
if Quotes_Needed then
-- Quote the argument, doubling '"'
declare
Arg : String (1 .. Arguments (J)'Length * 2 + 2);
begin
Arg (1) := '"';
Last_Char := 1;
for K in Arguments (J)'Range loop
Ch := Arguments (J) (K);
Last_Char := Last_Char + 1;
Arg (Last_Char) := Ch;
if Ch = '"' then
Last_Char := Last_Char + 1;
Arg (Last_Char) := '"';
end if;
end loop;
Last_Char := Last_Char + 1;
Arg (Last_Char) := '"';
Status := Write (FD, Arg'Address, Last_Char);
end;
else
Status := Write
(FD,
Arguments (J) (Arguments (J)'First)'Address,
Last_Char);
end if;
if Status /= Last_Char then
Fail ("disk full");
end if;
Status := Write (FD, EOL (1)'Address, 1);
if Status /= 1 then
Fail ("disk full");
end if;
end loop;
Close (FD);
-- And invoke gnatbind with this response file
Spawn (Gnatbind_Path.all, Args, Success);
Delete_File (Get_Name_String (Path), Succ);
-- We ignore a failure in this Delete_File operation.
-- Is that OK??? If so, worth a comment as to why we
-- are OK with the operation failing
end;
end if;
if not Success then
Com.Fail ("could not bind standalone library "
& Get_Name_String (For_Project.Library_Name));
end if;
end if;
-- Compile the binder generated file only if Link is true
if Link then
-- Set the paths
Set_Ada_Paths
(Project => For_Project,
In_Tree => In_Tree,
Including_Libraries => True);
-- Invoke <gcc> -c b__<lib>.adb
-- Allocate Arguments, if first time we see a standalone library
if Arguments = No_Argument then
Arguments := new String_List (1 .. Initial_Argument_Max);
end if;
Argument_Number := 2;
Arguments (1) := Compile_Switch;
Arguments (2) := No_Warning;
Add_Argument
(B_Start & Get_Name_String (For_Project.Library_Name) & ".adb");
-- If necessary, add the PIC option
if PIC_Option /= "" then
Add_Argument (PIC_Option);
end if;
-- Get the back-end switches and --RTS from the ALI file
if First_ALI /= No_File then
declare
T : Text_Buffer_Ptr;
A : ALI_Id;
begin
-- Load the ALI file
T := Read_Library_Info (First_ALI, True);
-- Read it
A :=
Scan_ALI (First_ALI, T, Ignore_ED => False, Err => False);
if A /= No_ALI_Id then
for Index in
ALI.Units.Table
(ALI.ALIs.Table (A).First_Unit).First_Arg ..
ALI.Units.Table
(ALI.ALIs.Table (A).First_Unit).Last_Arg
loop
-- Do not compile with the front end switches except
-- for --RTS.
declare
Arg : String_Ptr renames Args.Table (Index);
begin
if not Is_Front_End_Switch (Arg.all)
or else
Arg (Arg'First + 2 .. Arg'First + 5) = "RTS="
then
Add_Argument (Arg.all);
end if;
end;
end loop;
end if;
end;
end if;
-- Now all the arguments are set, compile binder generated file
Display (Gcc);
Spawn
(Gcc_Path.all, Arguments (1 .. Argument_Number), Success);
if not Success then
Com.Fail
("could not compile binder generated file for library "
& Get_Name_String (For_Project.Library_Name));
end if;
-- Process binder generated file for pragmas Linker_Options
Process_Binder_File (Arguments (3).all & ASCII.NUL);
end if;
end if;
-- Build the library only if Link is True
if Link then
-- If attributes Library_GCC or Linker'Driver were specified, get the
-- driver name.
if For_Project.Config.Shared_Lib_Driver /= No_File then
Driver_Name := Name_Id (For_Project.Config.Shared_Lib_Driver);
end if;
-- If attribute Library_Options was specified, add these options
Library_Options := Value_Of
(Name_Library_Options, For_Project.Decl.Attributes,
In_Tree.Shared);
if not Library_Options.Default then
declare
Current : String_List_Id;
Element : String_Element;
begin
Current := Library_Options.Values;
while Current /= Nil_String loop
Element := In_Tree.Shared.String_Elements.Table (Current);
Get_Name_String (Element.Value);
if Name_Len /= 0 then
Opts.Increment_Last;
Opts.Table (Opts.Last) :=
new String'(Name_Buffer (1 .. Name_Len));
end if;
Current := Element.Next;
end loop;
end;
end if;
Lib_Dirpath :=
new String'(Get_Name_String (For_Project.Library_Dir.Display_Name));
Lib_Filename :=
new String'(Get_Name_String (For_Project.Library_Name));
case For_Project.Library_Kind is
when Static =>
The_Build_Mode := Static;
when Dynamic =>
The_Build_Mode := Dynamic;
when Relocatable =>
The_Build_Mode := Relocatable;
if PIC_Option /= "" then
Opts.Increment_Last;
Opts.Table (Opts.Last) := new String'(PIC_Option);
end if;
end case;
-- Get the library version, if any
if For_Project.Lib_Internal_Name /= No_Name then
Lib_Version :=
new String'(Get_Name_String (For_Project.Lib_Internal_Name));
end if;
-- Add the objects found in the object directory and the object
-- directories of the extended files, if any, except for generated
-- object files (b~.. or B__..) from extended projects.
-- When there are one or more extended files, only add an object file
-- if no object file with the same name have already been added.
In_Main_Object_Directory := True;
-- For gnatmake, when the project specifies more than just Ada as a
-- language (even if course we could not find any source file for
-- the other languages), we will take all object files found in the
-- object directories. Since we know the project supports at least
-- Ada, we just have to test whether it has at least two languages,
-- and not care about the sources.
Foreign_Sources := For_Project.Languages.Next /= null;
Current_Proj := For_Project;
loop
if Current_Proj.Object_Directory /= No_Path_Information then
-- The following code gets far too indented ... suggest some
-- procedural abstraction here. How about making this declare
-- block a named procedure???
declare
Object_Dir_Path : constant String :=
Get_Name_String
(Current_Proj.Object_Directory
.Display_Name);
Object_Dir : Dir_Type;
Filename : String (1 .. 255);
Last : Natural;
Id : Name_Id;
begin
Open (Dir => Object_Dir, Dir_Name => Object_Dir_Path);
-- For all entries in the object directory
loop
Read (Object_Dir, Filename, Last);
exit when Last = 0;
-- Check if it is an object file
if Is_Obj (Filename (1 .. Last)) then
declare
Object_Path : constant String :=
Normalize_Pathname
(Object_Dir_Path
& Directory_Separator
& Filename (1 .. Last));
Object_File : constant String :=
Filename (1 .. Last);
C_Filename : String := Object_File;
begin
Canonical_Case_File_Name (C_Filename);
-- If in the object directory of an extended
-- project, do not consider generated object files.
if In_Main_Object_Directory
or else Last < 5
or else
C_Filename (1 .. B_Start'Length) /= B_Start
then
Name_Len := 0;
Add_Str_To_Name_Buffer (C_Filename);
Id := Name_Find;
if not Objects_Htable.Get (Id) then
declare
ALI_File : constant String :=
Ext_To (C_Filename, "ali");
ALI_Path : constant String :=
Ext_To (Object_Path, "ali");
Add_It : Boolean;
Fname : File_Name_Type;
Proj : Project_Id;
Index : Unit_Index;
begin
-- The following assignment could use
-- a comment ???
Add_It :=
Foreign_Sources
or else
(Last >= 5
and then
C_Filename (1 .. B_Start'Length)
= B_Start);
if Is_Regular_File (ALI_Path) then
-- If there is an ALI file, check if
-- the object file should be added to
-- the library. If there are foreign
-- sources we put all object files in
-- the library.
if not Add_It then
Index :=
Units_Htable.Get_First
(In_Tree.Units_HT);
while Index /= null loop
if Index.File_Names (Impl) /=
null
then
Proj :=
Index.File_Names (Impl)
.Project;
Fname :=
Index.File_Names (Impl).File;
elsif Index.File_Names (Spec) /=
null
then
Proj :=
Index.File_Names (Spec)
.Project;
Fname :=
Index.File_Names (Spec).File;
else
Proj := No_Project;
end if;
Add_It := Proj /= No_Project;
-- If the source is in the
-- project or a project it
-- extends, we may put it in
-- the library.
if Add_It then
Add_It := Check_Project (Proj);
end if;
-- But we don't, if the ALI file
-- does not correspond to the
-- unit.
if Add_It then
declare
F : constant String :=
Ext_To
(Get_Name_String
(Fname), "ali");
begin
Add_It := F = ALI_File;
end;
end if;
exit when Add_It;
Index :=
Units_Htable.Get_Next
(In_Tree.Units_HT);
end loop;
end if;
if Add_It then
Objects_Htable.Set (Id, True);
Objects.Append
(new String'(Object_Path));
-- Record the ALI file
ALIs.Append (new String'(ALI_Path));
-- Find out if for this ALI file,
-- libgnarl is necessary.
Check_Libs (ALI_Path, True);
end if;
elsif Foreign_Sources then
Objects.Append
(new String'(Object_Path));
end if;
end;
end if;
end if;
end;
end if;
end loop;
Close (Dir => Object_Dir);
exception
when Directory_Error =>
Com.Fail ("cannot find object directory """
& Get_Name_String
(Current_Proj.Object_Directory.Display_Name)
& """");
end;
end if;
exit when Current_Proj.Extends = No_Project;
In_Main_Object_Directory := False;
Current_Proj := Current_Proj.Extends;
end loop;
-- Add the -L and -l switches for the imported Library Project Files,
-- and, if Path Option is supported, the library directory path names
-- to Rpath.
Process_Imported_Libraries;
-- Link with libgnat and possibly libgnarl
Opts.Increment_Last;
Opts.Table (Opts.Last) := new String'("-L" & Lib_Directory);
-- If Path Option supported, add libgnat directory path name to Rpath
if Path_Option /= null then
declare
Libdir : constant String := Lib_Directory;
GCC_Index : Natural := 0;
begin
Add_Rpath (Libdir);
-- For shared libraries, add to the Path Option the directory
-- of the shared version of libgcc.
if The_Build_Mode /= Static then
GCC_Index := Index (Libdir, "/lib/");
if GCC_Index = 0 then
GCC_Index :=
Index
(Libdir,
Directory_Separator & "lib" & Directory_Separator);
end if;
if GCC_Index /= 0 then
Add_Rpath (Libdir (Libdir'First .. GCC_Index + 3));
end if;
end if;
end;
end if;
if Libgnarl_Needed = Yes then
Opts.Increment_Last;
if The_Build_Mode = Static then
Opts.Table (Opts.Last) := new String'("-lgnarl");
else
Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnarl"));
end if;
end if;
Opts.Increment_Last;
if The_Build_Mode = Static then
Opts.Table (Opts.Last) := new String'("-lgnat");
else
Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnat"));
end if;
-- If Path Option is supported, add the necessary switch with the
-- content of Rpath. As Rpath contains at least libgnat directory
-- path name, it is guaranteed that it is not null.
if Opt.Run_Path_Option and then Path_Option /= null then
Opts.Increment_Last;
Opts.Table (Opts.Last) :=
new String'(Path_Option.all & Rpath (1 .. Rpath_Last));
Free (Path_Option);
Free (Rpath);
end if;
Object_Files :=
new Argument_List'
(Argument_List (Objects.Table (1 .. Objects.Last)));
Ali_Files :=
new Argument_List'(Argument_List (ALIs.Table (1 .. ALIs.Last)));
Options :=
new Argument_List'(Argument_List (Opts.Table (1 .. Opts.Last)));
-- We fail if there are no object to put in the library
-- (Ada or foreign objects).
if Object_Files'Length = 0 then
Com.Fail ("no object files for library """ &
Lib_Filename.all & '"');
end if;
if not Opt.Quiet_Output then
Write_Eol;
Write_Str ("building ");
Write_Str (Ada.Characters.Handling.To_Lower
(Build_Mode_State'Image (The_Build_Mode)));
Write_Str (" library for project ");
Write_Line (Project_Name);
-- Only output list of object files and ALI files in verbose mode
if Opt.Verbose_Mode then
Write_Eol;
Write_Line ("object files:");
for Index in Object_Files'Range loop
Write_Str (" ");
Write_Line (Object_Files (Index).all);
end loop;
Write_Eol;
if Ali_Files'Length = 0 then
Write_Line ("NO ALI files");
else
Write_Line ("ALI files:");
for Index in Ali_Files'Range loop
Write_Str (" ");
Write_Line (Ali_Files (Index).all);
end loop;
end if;
Write_Eol;
end if;
end if;
-- We check that all object files are regular files
Check_Context;
-- Delete the existing library file, if it exists. Fail if the
-- library file is not writable, or if it is not possible to delete
-- the file.
declare
DLL_Name : aliased String :=
Lib_Dirpath.all & Directory_Separator & DLL_Prefix &
Lib_Filename.all & "." & DLL_Ext;
Archive_Name : aliased String :=
Lib_Dirpath.all & Directory_Separator & "lib" &
Lib_Filename.all & "." & Archive_Ext;
type Str_Ptr is access all String;
-- This type is necessary to meet the accessibility rules of Ada.
-- It is not possible to use String_Access here.
Full_Lib_Name : Str_Ptr;
-- Designates the full library path name. Either DLL_Name or
-- Archive_Name, depending on the library kind.
Success : Boolean;
pragma Warnings (Off, Success);
-- Used to call Delete_File
begin
if The_Build_Mode = Static then
Full_Lib_Name := Archive_Name'Access;
else
Full_Lib_Name := DLL_Name'Access;
end if;
if Is_Regular_File (Full_Lib_Name.all) then
if Is_Writable_File (Full_Lib_Name.all) then
Delete_File (Full_Lib_Name.all, Success);
end if;
if Is_Regular_File (Full_Lib_Name.all) then
Com.Fail ("could not delete """ & Full_Lib_Name.all & """");
end if;
end if;
end;
Argument_Number := 0;
-- If we have a standalone library, gather all the interface ALI.
-- They are flagged as Interface when we copy them to the library
-- directory (by Copy_ALI_Files, below).
if Standalone then
Current_Proj := For_Project;
declare
Iface : String_List_Id := For_Project.Lib_Interface_ALIs;
ALI : File_Name_Type;
begin
while Iface /= Nil_String loop
ALI :=
File_Name_Type
(In_Tree.Shared.String_Elements.Table (Iface).Value);
Interface_ALIs.Set (ALI, True);
Get_Name_String
(In_Tree.Shared.String_Elements.Table (Iface).Value);
Add_Argument (Name_Buffer (1 .. Name_Len));
Iface := In_Tree.Shared.String_Elements.Table (Iface).Next;
end loop;
Iface := For_Project.Lib_Interface_ALIs;
if not Opt.Quiet_Output then
-- Check that the interface set is complete: any unit in the
-- library that is needed by an interface should also be an
-- interface. If it is not the case, output a warning.
while Iface /= Nil_String loop
ALI :=
File_Name_Type
(In_Tree.Shared.String_Elements.Table (Iface).Value);
Process (ALI);
Iface :=
In_Tree.Shared.String_Elements.Table (Iface).Next;
end loop;
end if;
end;
end if;
declare
Current_Dir : constant String := Get_Current_Dir;
Dir : Dir_Type;
Name : String (1 .. 200);
Last : Natural;
Disregard : Boolean;
pragma Warnings (Off, Disregard);
DLL_Name : aliased constant String :=
Lib_Filename.all & "." & DLL_Ext;
Archive_Name : aliased constant String :=
Lib_Filename.all & "." & Archive_Ext;
Delete : Boolean := False;
begin
-- Clean the library directory: remove any file with the name of
-- the library file and any ALI file of a source of the project.
begin
Get_Name_String (For_Project.Library_Dir.Display_Name);
Change_Dir (Name_Buffer (1 .. Name_Len));
exception
when others =>
Com.Fail
("unable to access library directory """
& Name_Buffer (1 .. Name_Len)
& """");
end;
Open (Dir, ".");
loop
Read (Dir, Name, Last);
exit when Last = 0;
declare
Filename : constant String := Name (1 .. Last);
begin
if Is_Regular_File (Filename) then
Canonical_Case_File_Name (Name (1 .. Last));
Delete := False;
if (The_Build_Mode = Static
and then Name (1 .. Last) = Archive_Name)
or else
((The_Build_Mode = Dynamic
or else
The_Build_Mode = Relocatable)
and then Name (1 .. Last) = DLL_Name)
then
Delete := True;
elsif Last > 4
and then Name (Last - 3 .. Last) = ".ali"
then
declare
Unit : Unit_Index;
begin
-- Compare with ALI file names of the project
Unit := Units_Htable.Get_First (In_Tree.Units_HT);
while Unit /= No_Unit_Index loop
if Unit.File_Names (Impl) /= null
and then Unit.File_Names (Impl).Project /=
No_Project
then
if Ultimate_Extending_Project_Of
(Unit.File_Names (Impl).Project) =
For_Project
then
Get_Name_String
(Unit.File_Names (Impl).File);
Name_Len :=
Name_Len -
File_Extension
(Name (1 .. Name_Len))'Length;
if Name_Buffer (1 .. Name_Len) =
Name (1 .. Last - 4)
then
Delete := True;
exit;
end if;
end if;
elsif Unit.File_Names (Spec) /= null
and then Ultimate_Extending_Project_Of
(Unit.File_Names (Spec).Project) =
For_Project
then
Get_Name_String (Unit.File_Names (Spec).File);
Name_Len :=
Name_Len -
File_Extension (Name (1 .. Last))'Length;
if Name_Buffer (1 .. Name_Len) =
Name (1 .. Last - 4)
then
Delete := True;
exit;
end if;
end if;
Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
end loop;
end;
end if;
if Delete then
Set_Writable (Filename);
Delete_File (Filename, Disregard);
end if;
end if;
end;
end loop;
Close (Dir);
Change_Dir (Current_Dir);
end;
-- Call procedure to build the library, depending on the build mode
case The_Build_Mode is
when Dynamic | Relocatable =>
Build_Dynamic_Library
(Ofiles => Object_Files.all,
Options => Options.all,
Interfaces => Arguments (1 .. Argument_Number),
Lib_Filename => Lib_Filename.all,
Lib_Dir => Lib_Dirpath.all,
Symbol_Data => Current_Proj.Symbol_Data,
Driver_Name => Driver_Name,
Lib_Version => Lib_Version.all,
Auto_Init => Current_Proj.Lib_Auto_Init);
when Static =>
MLib.Build_Library
(Object_Files.all,
Lib_Filename.all,
Lib_Dirpath.all);
when None =>
null;
end case;
-- We need to copy the ALI files from the object directory to the
-- library ALI directory, so that the linker find them there, and
-- does not need to look in the object directory where it would also
-- find the object files; and we don't want that: we want the linker
-- to use the library.
-- Copy the ALI files and make the copies read-only. For interfaces,
-- mark the copies as interfaces.
Copy_ALI_Files
(Files => Ali_Files.all,
To => For_Project.Library_ALI_Dir.Display_Name,
Interfaces => Arguments (1 .. Argument_Number));
-- Copy interface sources if Library_Src_Dir specified
if Standalone
and then For_Project.Library_Src_Dir /= No_Path_Information
then
-- Clean the interface copy directory: remove any source that
-- could be a source of the project.
begin
Get_Name_String (For_Project.Library_Src_Dir.Display_Name);
Change_Dir (Name_Buffer (1 .. Name_Len));
exception
when others =>
Com.Fail
("unable to access library source copy directory """
& Name_Buffer (1 .. Name_Len)
& """");
end;
declare
Dir : Dir_Type;
Delete : Boolean := False;
Unit : Unit_Index;
Name : String (1 .. 200);
Last : Natural;
Disregard : Boolean;
pragma Warnings (Off, Disregard);
begin
Open (Dir, ".");
loop
Read (Dir, Name, Last);
exit when Last = 0;
if Is_Regular_File (Name (1 .. Last)) then
Canonical_Case_File_Name (Name (1 .. Last));
Delete := False;
-- Compare with source file names of the project
Unit := Units_Htable.Get_First (In_Tree.Units_HT);
while Unit /= No_Unit_Index loop
if Unit.File_Names (Impl) /= null
and then Ultimate_Extending_Project_Of
(Unit.File_Names (Impl).Project) = For_Project
and then
Get_Name_String
(Unit.File_Names (Impl).File) =
Name (1 .. Last)
then
Delete := True;
exit;
end if;
if Unit.File_Names (Spec) /= null
and then Ultimate_Extending_Project_Of
(Unit.File_Names (Spec).Project) =
For_Project
and then
Get_Name_String
(Unit.File_Names (Spec).File) =
Name (1 .. Last)
then
Delete := True;
exit;
end if;
Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
end loop;
end if;
if Delete then
Set_Writable (Name (1 .. Last));
Delete_File (Name (1 .. Last), Disregard);
end if;
end loop;
Close (Dir);
end;
Copy_Interface_Sources
(For_Project => For_Project,
In_Tree => In_Tree,
Interfaces => Arguments (1 .. Argument_Number),
To_Dir => For_Project.Library_Src_Dir.Display_Name);
end if;
end if;
-- Reset the current working directory to its previous value
Change_Dir (Current_Dir);
end Build_Library;
-----------
-- Check --
-----------
procedure Check (Filename : String) is
begin
if not Is_Regular_File (Filename) then
Com.Fail (Filename & " not found.");
end if;
end Check;
-------------------
-- Check_Context --
-------------------
procedure Check_Context is
begin
-- Check that each object file exists
for F in Object_Files'Range loop
Check (Object_Files (F).all);
end loop;
end Check_Context;
-------------------
-- Check_Library --
-------------------
procedure Check_Library
(For_Project : Project_Id; In_Tree : Project_Tree_Ref)
is
Lib_TS : Time_Stamp_Type;
Current : constant Dir_Name_Str := Get_Current_Dir;
begin
-- No need to build the library if there is no object directory,
-- hence no object files to build the library.
if For_Project.Library then
declare
Lib_Name : constant File_Name_Type :=
Library_File_Name_For (For_Project, In_Tree);
begin
Change_Dir
(Get_Name_String (For_Project.Library_Dir.Display_Name));
Lib_TS := File_Stamp (Lib_Name);
For_Project.Library_TS := Lib_TS;
end;
if not For_Project.Externally_Built
and then not For_Project.Need_To_Build_Lib
and then For_Project.Object_Directory /= No_Path_Information
then
declare
Obj_TS : Time_Stamp_Type;
Object_Dir : Dir_Type;
begin
-- If the library file does not exist, then the time stamp will
-- be Empty_Time_Stamp, earlier than any other time stamp.
Change_Dir
(Get_Name_String (For_Project.Object_Directory.Display_Name));
Open (Dir => Object_Dir, Dir_Name => ".");
-- For all entries in the object directory
loop
Read (Object_Dir, Name_Buffer, Name_Len);
exit when Name_Len = 0;
-- Check if it is an object file, but ignore any binder
-- generated file.
if Is_Obj (Name_Buffer (1 .. Name_Len))
and then Name_Buffer (1 .. B_Start'Length) /= B_Start
then
-- Get the object file time stamp
Obj_TS := File_Stamp (File_Name_Type'(Name_Find));
-- If library file time stamp is earlier, set
-- Need_To_Build_Lib and return. String comparison is
-- used, otherwise time stamps may be too close and the
-- comparison would return True, which would trigger
-- an unnecessary rebuild of the library.
if String (Lib_TS) < String (Obj_TS) then
-- Library must be rebuilt
For_Project.Need_To_Build_Lib := True;
exit;
end if;
end if;
end loop;
Close (Object_Dir);
end;
end if;
Change_Dir (Current);
end if;
end Check_Library;
----------------------------
-- Copy_Interface_Sources --
----------------------------
procedure Copy_Interface_Sources
(For_Project : Project_Id;
In_Tree : Project_Tree_Ref;
Interfaces : Argument_List;
To_Dir : Path_Name_Type)
is
Current : constant Dir_Name_Str := Get_Current_Dir;
-- The current directory, where to return to at the end
Target : constant Dir_Name_Str := Get_Name_String (To_Dir);
-- The directory where to copy sources
Text : Text_Buffer_Ptr;
The_ALI : ALI.ALI_Id;
Lib_File : File_Name_Type;
First_Unit : ALI.Unit_Id;
Second_Unit : ALI.Unit_Id;
Copy_Subunits : Boolean := False;
-- When True, indicates that subunits, if any, need to be copied too
procedure Copy (File_Name : File_Name_Type);
-- Copy one source of the project to the target directory
----------
-- Copy --
----------
procedure Copy (File_Name : File_Name_Type) is
Success : Boolean;
pragma Warnings (Off, Success);
Source : Standard.Prj.Source_Id;
begin
Source := Find_Source
(In_Tree, For_Project,
In_Extended_Only => True,
Base_Name => File_Name);
if Source /= No_Source
and then not Source.Locally_Removed
and then Source.Replaced_By = No_Source
then
Copy_File
(Get_Name_String (Source.Path.Name),
Target,
Success,
Mode => Overwrite,
Preserve => Preserve);
end if;
end Copy;
-- Start of processing for Copy_Interface_Sources
begin
-- Change the working directory to the object directory
Change_Dir (Get_Name_String (For_Project.Object_Directory.Display_Name));
for Index in Interfaces'Range loop
-- First, load the ALI file
Name_Len := 0;
Add_Str_To_Name_Buffer (Interfaces (Index).all);
Lib_File := Name_Find;
Text := Read_Library_Info (Lib_File);
The_ALI := Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True);
Free (Text);
Second_Unit := No_Unit_Id;
First_Unit := ALI.ALIs.Table (The_ALI).First_Unit;
Copy_Subunits := True;
-- If there is both a spec and a body, check if they are both needed
if ALI.Units.Table (First_Unit).Utype = Is_Body then
Second_Unit := ALI.ALIs.Table (The_ALI).Last_Unit;
-- If the body is not needed, then reset First_Unit
if not ALI.Units.Table (Second_Unit).Body_Needed_For_SAL then
First_Unit := No_Unit_Id;
Copy_Subunits := False;
end if;
elsif ALI.Units.Table (First_Unit).Utype = Is_Spec_Only then
Copy_Subunits := False;
end if;
-- Copy the file(s) that need to be copied
if First_Unit /= No_Unit_Id then
Copy (File_Name => ALI.Units.Table (First_Unit).Sfile);
end if;
if Second_Unit /= No_Unit_Id then
Copy (File_Name => ALI.Units.Table (Second_Unit).Sfile);
end if;
-- Copy all the separates, if any
if Copy_Subunits then
for Dep in ALI.ALIs.Table (The_ALI).First_Sdep ..
ALI.ALIs.Table (The_ALI).Last_Sdep
loop
if Sdep.Table (Dep).Subunit_Name /= No_Name then
Copy (File_Name => Sdep.Table (Dep).Sfile);
end if;
end loop;
end if;
end loop;
-- Restore the initial working directory
Change_Dir (Current);
end Copy_Interface_Sources;
-------------
-- Display --
-------------
procedure Display (Executable : String) is
begin
if not Opt.Quiet_Output then
Write_Str (Executable);
for Index in 1 .. Argument_Number loop
Write_Char (' ');
Write_Str (Arguments (Index).all);
if not Opt.Verbose_Mode and then Index > 4 then
Write_Str (" ...");
exit;
end if;
end loop;
Write_Eol;
end if;
end Display;
-----------
-- Index --
-----------
function Index (S, Pattern : String) return Natural is
Len : constant Natural := Pattern'Length;
begin
for J in reverse S'First .. S'Last - Len + 1 loop
if Pattern = S (J .. J + Len - 1) then
return J;
end if;
end loop;
return 0;
end Index;
-------------------------
-- Process_Binder_File --
-------------------------
procedure Process_Binder_File (Name : String) is
Fd : FILEs;
-- Binder file's descriptor
Read_Mode : constant String := "r" & ASCII.NUL;
-- For fopen
Status : Interfaces.C_Streams.int;
pragma Unreferenced (Status);
-- For fclose
Begin_Info : constant String := "-- BEGIN Object file/option list";
End_Info : constant String := "-- END Object file/option list ";
Next_Line : String (1 .. 1000);
-- Current line value
-- Where does this odd constant 1000 come from, looks suspicious ???
Nlast : Integer;
-- End of line slice (the slice does not contain the line terminator)
procedure Get_Next_Line;
-- Read the next line from the binder file without the line terminator
-------------------
-- Get_Next_Line --
-------------------
procedure Get_Next_Line is
Fchars : chars;
begin
Fchars := fgets (Next_Line'Address, Next_Line'Length, Fd);
if Fchars = System.Null_Address then
Fail ("Error reading binder output");
end if;
Nlast := 1;
while Nlast <= Next_Line'Last
and then Next_Line (Nlast) /= ASCII.LF
and then Next_Line (Nlast) /= ASCII.CR
loop
Nlast := Nlast + 1;
end loop;
Nlast := Nlast - 1;
end Get_Next_Line;
-- Start of processing for Process_Binder_File
begin
Fd := fopen (Name'Address, Read_Mode'Address);
if Fd = NULL_Stream then
Fail ("Failed to open binder output");
end if;
-- Skip up to the Begin Info line
loop
Get_Next_Line;
exit when Next_Line (1 .. Nlast) = Begin_Info;
end loop;
-- Find the first switch
loop
Get_Next_Line;
exit when Next_Line (1 .. Nlast) = End_Info;
-- As the binder generated file is in Ada, remove the first eight
-- characters " -- ".
Next_Line (1 .. Nlast - 8) := Next_Line (9 .. Nlast);
Nlast := Nlast - 8;
-- Stop when the first switch is found
exit when Next_Line (1) = '-';
end loop;
if Next_Line (1 .. Nlast) /= End_Info then
loop
-- Ignore -static and -shared, since -shared will be used
-- in any case.
-- Ignore -lgnat and -lgnarl as they will be added later,
-- because they are also needed for non Stand-Alone shared
-- libraries.
-- Also ignore the shared libraries which are:
-- -lgnat-<version> (7 + version'length chars)
-- -lgnarl-<version> (8 + version'length chars)
if Next_Line (1 .. Nlast) /= "-static" and then
Next_Line (1 .. Nlast) /= "-shared" and then
Next_Line (1 .. Nlast) /= "-lgnarl" and then
Next_Line (1 .. Nlast) /= "-lgnat"
and then
Next_Line
(1 .. Natural'Min (Nlast, 8 + Library_Version'Length)) /=
Shared_Lib ("gnarl")
and then
Next_Line
(1 .. Natural'Min (Nlast, 7 + Library_Version'Length)) /=
Shared_Lib ("gnat")
then
if Next_Line (1) /= '-' then
-- This is not an option, should we add it?
if Add_Object_Files then
Opts.Increment_Last;
Opts.Table (Opts.Last) :=
new String'(Next_Line (1 .. Nlast));
end if;
else
-- Add all other options
Opts.Increment_Last;
Opts.Table (Opts.Last) :=
new String'(Next_Line (1 .. Nlast));
end if;
end if;
-- Next option, if any
Get_Next_Line;
exit when Next_Line (1 .. Nlast) = End_Info;
-- Remove first eight characters " -- "
Next_Line (1 .. Nlast - 8) := Next_Line (9 .. Nlast);
Nlast := Nlast - 8;
end loop;
end if;
Status := fclose (Fd);
-- Is it really right to ignore any close error ???
end Process_Binder_File;
------------------
-- Reset_Tables --
------------------
procedure Reset_Tables is
begin
Objects.Init;
Objects_Htable.Reset;
ALIs.Init;
Opts.Init;
Processed_Projects.Reset;
Library_Projs.Init;
end Reset_Tables;
---------------------------
-- SALs_Use_Constructors --
---------------------------
function SALs_Use_Constructors return Boolean is
function C_SALs_Init_Using_Constructors return Integer;
pragma Import (C, C_SALs_Init_Using_Constructors,
"__gnat_sals_init_using_constructors");
begin
return C_SALs_Init_Using_Constructors /= 0;
end SALs_Use_Constructors;
end MLib.Prj;