Skip to content

R
riscv-gcc-1
Commit 10e77af2 by Vincent Celier Committed by Arnaud Charlet
Options

a-clrefi.adb, [...]: New files 

2007-04-20  Vincent Celier  <celier@adacore.com>
	    Arnaud Charlet  <charlet@adacore.com>

	* a-clrefi.adb, a-clrefi.ads: New files

	* impunit.adb: Add s-os_lib in the list of user visible units.
	(Non_Imp_File_Names_95): Add a-clrefi to this list
	Remove obsolete run-time entries.
	(Non_Imp_File_Names_05): Add Ada 2005 entries for:
	 "a-exetim" -- Ada.Execution_Time
	 "a-extiti" -- Ada.Execution_Time.Timers

	* mlib-prj.ads, mlib-prj.adb
	(Build_Library): Use untouched object dir and library dir. At the
	same time makes sure that the checks are done using the canonical
	form. Removes hard-coded directory separator and use the proper host
	one instead.
	(Process_Project): Do not look in object directory to check if libgnarl
	is needed for a library, if there is no object directory.
	(Build_Library): Scan the ALI files to decide if libgnarl is needed for
	linking.
	(Build_Library): When invoking gnatbind, use a response file if the
	total size of the arguments is too large.

	* Makefile.rtl: (g-sttsne): New object file.
	Add entry for a-clrefi, s-utf_32, System.Exceptions

	* Make-lang.in: Remove bogus dependency of s-memory.o on memtrack.o.
	(GNAT_ADA_OBJS, GNATBIND_OBJS): Add s-except.o.
	(GNATBIND_OBJS): Add new objects a-clrefi.o and a-comlin.o
	Change g-string to s-string, g-os_lib to s-os_lib
	Change all g-utf_32 references to s-utf_32

From-SVN: r125427
parent 26fa2a35
Showing with 1052 additions and 214 deletions
gcc/ada/Make-lang.in
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/Makefile.rtl
# Makefile.rtl for GNU Ada Compiler (GNAT).
# Copyright (C) 2003-2005, Free Software Foundation, Inc.
# Copyright (C) 2003-2007, Free Software Foundation, Inc.
#This file is part of GCC.
......@@ -100,6 +100,7 @@ GNATRTL_NONTASKING_OBJS= \
a-ciorma$(objext) \
a-ciormu$(objext) \
a-ciorse$(objext) \
a-clrefi$(objext) \
a-cohama$(objext) \
a-cohase$(objext) \
a-cohata$(objext) \
......@@ -366,6 +367,7 @@ GNATRTL_NONTASKING_OBJS= \
g-sptavs$(objext) \
g-string$(objext) \
g-strspl$(objext) \
g-sttsne$(objext) \
g-table$(objext) \
g-tasloc$(objext) \
g-traceb$(objext) \
......@@ -409,6 +411,7 @@ GNATRTL_NONTASKING_OBJS= \
s-dsaser$(objext) \
s-errrep$(objext) \
s-exctab$(objext) \
s-except$(objext) \
s-exnint$(objext) \
s-exnllf$(objext) \
s-exnlli$(objext) \
......@@ -454,6 +457,7 @@ GNATRTL_NONTASKING_OBJS= \
s-maccod$(objext) \
s-mantis$(objext) \
s-mastop$(objext) \
s-os_lib$(objext) \
s-osprim$(objext) \
s-pack03$(objext) \
s-pack05$(objext) \
......@@ -519,6 +523,8 @@ GNATRTL_NONTASKING_OBJS= \
s-poosiz$(objext) \
s-powtab$(objext) \
s-purexc$(objext) \
s-regexp$(objext) \
s-regpat$(objext) \
s-restri$(objext) \
s-rident$(objext) \
s-rpc$(objext) \
......@@ -540,10 +546,13 @@ GNATRTL_NONTASKING_OBJS= \
s-soflin$(objext) \
s-memory$(objext) \
s-memcop$(objext) \
s-string$(objext) \
s-tasloc$(objext) \
s-traceb$(objext) \
s-traces$(objext) \
s-traent$(objext) \
s-unstyp$(objext) \
s-utf_32$(objext) \
s-vaflop$(objext) \
s-valboo$(objext) \
s-valcha$(objext) \
......
gcc/ada/a-clrefi.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . C O M M A N D _ L I N E . R E S P O N S E _ F I L E --
-- --
-- B o d y --
-- --
-- Copyright (C) 2007, 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with System.OS_Lib; use System.OS_Lib;
package body Ada.Command_Line.Response_File is
type File_Rec;
type File_Ptr is access File_Rec;
type File_Rec is record
Name : String_Access;
Next : File_Ptr;
Prev : File_Ptr;
end record;
-- To build a stack of response file names
procedure Free is new Ada.Unchecked_Deallocation (File_Rec, File_Ptr);
type Argument_List_Access is access Argument_List;
procedure Free is new Ada.Unchecked_Deallocation
(Argument_List, Argument_List_Access);
-- Free only the allocated Argument_List, not the allocated String
-- components.
--------------------
-- Arguments_From --
--------------------
function Arguments_From
(Response_File_Name : String;
Recursive : Boolean := False;
Ignore_Non_Existing_Files : Boolean := False)
return Argument_List
is
First_File : File_Ptr := null;
Last_File : File_Ptr := null;
-- The stack of response files
Arguments : Argument_List_Access := new Argument_List (1 .. 4);
Last_Arg : Natural := 0;
procedure Add_Argument (Arg : String);
-- Add argument Arg to argument list Arguments, increasing Arguments
-- if necessary.
procedure Recurse (File_Name : String);
-- Get the arguments from the file and call itself recursively if
-- one of the argument starts with character '@'.
------------------
-- Add_Argument --
------------------
procedure Add_Argument (Arg : String) is
begin
if Last_Arg = Arguments'Last then
declare
New_Arguments : constant Argument_List_Access :=
new Argument_List (1 .. Arguments'Last * 2);
begin
New_Arguments (Arguments'Range) := Arguments.all;
Arguments.all := (others => null);
Free (Arguments);
Arguments := New_Arguments;
end;
end if;
Last_Arg := Last_Arg + 1;
Arguments (Last_Arg) := new String'(Arg);
end Add_Argument;
-------------
-- Recurse --
-------------
procedure Recurse (File_Name : String) is
FD : File_Descriptor;
Buffer_Size : constant := 1500;
Buffer : String (1 .. Buffer_Size);
Buffer_Length : Natural;
Buffer_Cursor : Natural;
End_Of_File_Reached : Boolean;
Line : String (1 .. Max_Line_Length + 1);
Last : Natural;
First_Char : Positive;
-- Index of the first character of an argument in Line
Last_Char : Natural;
-- Index of the last character of an argument in Line
In_String : Boolean;
-- True when inside a quoted string
Arg : Positive;
function End_Of_File return Boolean;
-- True when the end of the response file has been reached
procedure Get_Buffer;
-- Read one buffer from the response file
procedure Get_Line;
-- Get one line from the response file
-----------------
-- End_Of_File --
-----------------
function End_Of_File return Boolean is
begin
return End_Of_File_Reached and then Buffer_Cursor > Buffer_Length;
end End_Of_File;
----------------
-- Get_Buffer --
----------------
procedure Get_Buffer is
begin
Buffer_Length := Read (FD, Buffer (1)'Address, Buffer'Length);
End_Of_File_Reached := Buffer_Length < Buffer'Length;
Buffer_Cursor := 1;
end Get_Buffer;
--------------
-- Get_Line --
--------------
procedure Get_Line is
Ch : Character;
begin
Last := 0;
if End_Of_File then
return;
end if;
loop
Ch := Buffer (Buffer_Cursor);
exit when Ch = ASCII.CR or else
Ch = ASCII.LF or else
Ch = ASCII.FF;
Last := Last + 1;
Line (Last) := Ch;
if Last = Line'Last then
return;
end if;
Buffer_Cursor := Buffer_Cursor + 1;
if Buffer_Cursor > Buffer_Length then
Get_Buffer;
if End_Of_File then
return;
end if;
end if;
end loop;
loop
Ch := Buffer (Buffer_Cursor);
exit when Ch /= ASCII.HT and then
Ch /= ASCII.LF and then
Ch /= ASCII.FF;
Buffer_Cursor := Buffer_Cursor + 1;
if Buffer_Cursor > Buffer_Length then
Get_Buffer;
if End_Of_File then
return;
end if;
end if;
end loop;
end Get_Line;
-- Start or Recurse
begin
Last_Arg := 0;
-- Open the response file. If not found, fail or report a warning,
-- depending on the value of Ignore_Non_Existing_Files.
FD := Open_Read (File_Name, Text);
if FD = Invalid_FD then
if Ignore_Non_Existing_Files then
return;
else
raise File_Does_Not_Exist;
end if;
end if;
-- Put the response file name on the stack
if First_File = null then
First_File :=
new File_Rec'
(Name => new String'(File_Name),
Next => null,
Prev => null);
Last_File := First_File;
else
declare
Current : File_Ptr := First_File;
begin
loop
if Current.Name.all = File_Name then
raise Circularity_Detected;
end if;
Current := Current.Next;
exit when Current = null;
end loop;
Last_File.Next :=
new File_Rec'
(Name => new String'(File_Name),
Next => null,
Prev => Last_File);
Last_File := Last_File.Next;
end;
end if;
End_Of_File_Reached := False;
Get_Buffer;
-- Read the response file line by line
Line_Loop :
while not End_Of_File loop
Get_Line;
if Last = Line'Last then
raise Line_Too_Long;
end if;
First_Char := 1;
-- Get each argument on the line
Arg_Loop :
loop
-- First, skip any white space
while First_Char <= Last loop
exit when Line (First_Char) /= ' ' and then
Line (First_Char) /= ASCII.HT;
First_Char := First_Char + 1;
end loop;
exit Arg_Loop when First_Char > Last;
Last_Char := First_Char;
In_String := False;
-- Get the character one by one
Character_Loop :
while Last_Char <= Last loop
-- Inside a string, check only for '"'
if In_String then
if Line (Last_Char) = '"' then
-- Remove the '"'
Line (Last_Char .. Last - 1) :=
Line (Last_Char + 1 .. Last);
Last := Last - 1;
-- End of string is end of argument
if Last_Char > Last or else
Line (Last_Char) = ' ' or else
Line (Last_Char) = ASCII.HT
then
In_String := False;
Last_Char := Last_Char - 1;
exit Character_Loop;
else
-- If there are two consecutive '"', the quoted
-- string is not closed
In_String := Line (Last_Char) = '"';
if In_String then
Last_Char := Last_Char + 1;
end if;
end if;
else
Last_Char := Last_Char + 1;
end if;
elsif Last_Char = Last then
-- An opening '"' at the end of the line is an error
if Line (Last) = '"' then
raise No_Closing_Quote;
else
-- The argument ends with the line
exit Character_Loop;
end if;
elsif Line (Last_Char) = '"' then
-- Entering a quoted string: remove the '"'
In_String := True;
Line (Last_Char .. Last - 1) :=
Line (Last_Char + 1 .. Last);
Last := Last - 1;
else
-- Outside of quoted strings, white space ends the
-- argument.
exit Character_Loop
when Line (Last_Char + 1) = ' ' or else
Line (Last_Char + 1) = ASCII.HT;
Last_Char := Last_Char + 1;
end if;
end loop Character_Loop;
-- It is an error to not close a quoted string before the end
-- of the line.
if In_String then
raise No_Closing_Quote;
end if;
-- Add the argument to the list
declare
Arg : String (1 .. Last_Char - First_Char + 1);
begin
Arg := Line (First_Char .. Last_Char);
Add_Argument (Arg);
end;
-- Next argument, if line is not finished
First_Char := Last_Char + 1;
end loop Arg_Loop;
end loop Line_Loop;
Close (FD);
-- If Recursive is True, check for any argument starting with '@'
if Recursive then
Arg := 1;
while Arg <= Last_Arg loop
if Arguments (Arg)'Length > 0 and then
Arguments (Arg) (1) = '@'
then
-- Ignore argument "@" with no file name
if Arguments (Arg)'Length = 1 then
Arguments (Arg .. Last_Arg - 1) :=
Arguments (Arg + 1 .. Last_Arg);
Last_Arg := Last_Arg - 1;
else
-- Save the current arguments and get those in the
-- new response file.
declare
Inc_File_Name : constant String :=
Arguments (Arg)
(2 .. Arguments (Arg)'Last);
Current_Arguments : constant Argument_List :=
Arguments (1 .. Last_Arg);
begin
Recurse (Inc_File_Name);
-- Insert the new arguments where the new response
-- file was imported.
declare
New_Arguments : constant Argument_List :=
Arguments (1 .. Last_Arg);
New_Last_Arg : constant Positive :=
Current_Arguments'Length +
New_Arguments'Length - 1;
begin
-- Grow Arguments if it is not large enough
if Arguments'Last < New_Last_Arg then
Last_Arg := Arguments'Last;
Free (Arguments);
while Last_Arg < New_Last_Arg loop
Last_Arg := Last_Arg * 2;
end loop;
Arguments := new Argument_List (1 .. Last_Arg);
end if;
Last_Arg := New_Last_Arg;
Arguments (1 .. Last_Arg) :=
Current_Arguments (1 .. Arg - 1) &
New_Arguments &
Current_Arguments
(Arg + 1 .. Current_Arguments'Last);
Arg := Arg + New_Arguments'Length;
end;
end;
end if;
else
Arg := Arg + 1;
end if;
end loop;
end if;
-- Remove the response file name from the stack
if First_File = Last_File then
System.Strings.Free (First_File.Name);
Free (First_File);
First_File := null;
Last_File := null;
else
System.Strings.Free (Last_File.Name);
Last_File := Last_File.Prev;
Free (Last_File.Next);
end if;
exception
when others =>
Close (FD);
raise;
end Recurse;
-- Start of Arguments_From
begin
-- The job is done by procedure Recurse
Recurse (Response_File_Name);
-- Free Arguments before returning the result
declare
Result : constant Argument_List := Arguments (1 .. Last_Arg);
begin
Free (Arguments);
return Result;
end;
exception
when others =>
-- When an exception occurs, deallocate everything
Free (Arguments);
while First_File /= null loop
Last_File := First_File.Next;
System.Strings.Free (First_File.Name);
Free (First_File);
First_File := Last_File;
end loop;
raise;
end Arguments_From;
end Ada.Command_Line.Response_File;
gcc/ada/a-clrefi.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . C O M M A N D _ L I N E . R E S P O N S E _ F I L E --
-- --
-- S p e c --
-- --
-- Copyright (C) 2007, 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package is intended to be used in conjunction with its parent unit,
-- Ada.Command_Line. It provides facilities for getting command line arguments
-- from a text file, called a "response file".
--
-- Using a response file allow passing a set of arguments to an executable
-- longer than the maximum allowed by the system on the command line.
with System.Strings;
package Ada.Command_Line.Response_File is
subtype String_Access is System.Strings.String_Access;
-- type String_Access is access all String;
procedure Free (S : in out String_Access) renames System.Strings.Free;
-- To deallocate a String
subtype Argument_List is System.Strings.String_List;
-- type String_List is array (Positive range <>) of String_Access;
Max_Line_Length : constant := 4096;
-- The maximum length of lines in a response file
File_Does_Not_Exist : exception;
-- Raise by Arguments_From when a response file cannot be found
Line_Too_Long : exception;
-- Raise by Arguments_From when a line in the response file is longer than
-- Max_Line_Length.
No_Closing_Quote : exception;
-- Raise by Arguments_From when a quoted string does not end before the
-- end of the line.
Circularity_Detected : exception;
-- Raise by Arguments_From when Recursive is True and the same response
-- file is reading itself, either directly or indirectly.
function Arguments_From
(Response_File_Name : String;
Recursive : Boolean := False;
Ignore_Non_Existing_Files : Boolean := False)
return Argument_List;
-- Read response file with name Response_File_Name and return the argument
-- it contains as an Argument_List. It is the responsibility of the caller
-- to deallocate the strings in the Argument_List if desired. When
-- Recursive is True, any argument of the form @file_name indicates the
-- name of another response file and is replaced by the arguments in this
-- response file.
--
-- Each non empty line of the response file contains one or several
-- arguments sparated by white space. Empty lines or lines containing only
-- white space are ignored. Arguments containing white space or a double
-- quote ('"')must be quoted. A double quote inside a quote string is
-- indicated by two consecutive double quotes. Example: "-Idir with quote
-- "" and spaces" Non white space characters immediately before or after a
-- quoted string are part of the same argument. Example -Idir" with "spaces
--
-- When a response file cannot be found, exception File_Does_Not_Exist is
-- raised if Ignore_Non_Existing_Files is False, otherwise the response
-- file is ignored. Exception Line_Too_Long is raised when a line of a
-- response file is longer than Max_Line_Length. Exception No_Closing_Quote
-- is raised when a quoted argument is not closed before the end of the
-- line. Exception Circularity_Detected is raised when a Recursive is True
-- and a response file is reading itself, either directly or indirectly.
end Ada.Command_Line.Response_File;
gcc/ada/impunit.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2000-2006, Free Software Foundation, Inc. --
-- Copyright (C) 2000-2007, 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- --
......@@ -145,6 +145,7 @@ package body Impunit is
-----------------------------------
"a-chlat9", -- Ada.Characters.Latin_9
"a-clrefi", -- Ada.Command_Line.Response_File
"a-colien", -- Ada.Command_Line.Environment
"a-colire", -- Ada.Command_Line.Remove
"a-cwila1", -- Ada.Characters.Wide_Latin_1
......@@ -288,17 +289,8 @@ package body Impunit is
"i-cexten", -- Interfaces.C.Extensions
"i-cpp ", -- Interfaces.CPP
"i-cstrea", -- Interfaces.C.Streams
"i-jalaob", -- Interfaces.Java.Lang.Object
"i-jalasy", -- Interfaces.Java.Lang.System
"i-jalath", -- Interfaces.Java.Lang.Thread
"i-java ", -- Interfaces.Java
"i-javlan", -- Interfaces.Java.Lang
"i-os2err", -- Interfaces.Os2lib.Errors
"i-os2lib", -- Interfaces.Os2lib
"i-os2syn", -- Interfaces.Os2lib.Synchronization
"i-os2thr", -- Interfaces.Os2lib.Threads
"i-pacdec", -- Interfaces.Packed_Decimal
"i-vthrea", -- Interfaces.Vthreads
"i-vxwoio", -- Interfaces.VxWorks.IO
"i-vxwork", -- Interfaces.VxWorks
......@@ -319,6 +311,7 @@ package body Impunit is
"s-addima", -- System.Address_Image
"s-assert", -- System.Assertions
"s-memory", -- System.Memory
"s-os_lib", -- System.Os_Lib
"s-parint", -- System.Partition_Interface
"s-pooglo", -- System.Pool_Global
"s-pooloc", -- System.Pool_Local
......@@ -364,6 +357,8 @@ package body Impunit is
"a-diroro", -- Ada.Dispatching.Round_Robin
"a-dispat", -- Ada.Dispatching
"a-envvar", -- Ada.Environment_Variables
"a-exetim", -- Ada.Execution_Time
"a-extiti", -- Ada.Execution_Time.Timers
"a-rttiev", -- Ada.Real_Time.Timing_Events
"a-ngcoar", -- Ada.Numerics.Generic_Complex_Arrays
"a-ngrear", -- Ada.Numerics.Generic_Real_Arrays
......
gcc/ada/mlib-prj.adb
......@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- M L I B . P R J --
-- M L I B . P R J --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2006, AdaCore --
-- Copyright (C) 2001-2007, 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- --
......@@ -29,7 +29,6 @@ with Gnatvsn; use Gnatvsn;
with MLib.Fil; use MLib.Fil;
with MLib.Tgt; use MLib.Tgt;
with MLib.Utl; use MLib.Utl;
with Namet; use Namet;
with Opt;
with Output; use Output;
with Prj.Com; use Prj.Com;
......@@ -40,11 +39,14 @@ with Snames; use Snames;
with Switch; use Switch;
with Table;
with Targparm; use Targparm;
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;
......@@ -63,13 +65,13 @@ package body MLib.Prj is
B_Start : String_Ptr := new String'("b~");
-- Prefix of bind file, changed to b__ for VMS
S_Osinte_Ads : Name_Id := No_Name;
S_Osinte_Ads : File_Name_Type := No_File;
-- Name_Id for "s-osinte.ads"
S_Dec_Ads : Name_Id := No_Name;
S_Dec_Ads : File_Name_Type := No_File;
-- Name_Id for "dec.ads"
G_Trasym_Ads : Name_Id := No_Name;
G_Trasym_Ads : File_Name_Type := No_File;
-- Name_Id for "g-trasym.ads"
No_Argument_List : aliased String_List := (1 .. 0 => null);
......@@ -158,7 +160,7 @@ package body MLib.Prj is
(Header_Num => Header_Num,
Element => Boolean,
No_Element => False,
Key => Name_Id,
Key => File_Name_Type,
Hash => Hash,
Equal => "=");
......@@ -168,7 +170,7 @@ package body MLib.Prj is
(Header_Num => Header_Num,
Element => Boolean,
No_Element => False,
Key => Name_Id,
Key => File_Name_Type,
Hash => Hash,
Equal => "=");
......@@ -179,7 +181,7 @@ package body MLib.Prj is
(Header_Num => Header_Num,
Element => Boolean,
No_Element => False,
Key => Name_Id,
Key => File_Name_Type,
Hash => Hash,
Equal => "=");
......@@ -222,7 +224,7 @@ package body MLib.Prj is
(For_Project : Project_Id;
In_Tree : Project_Tree_Ref;
Interfaces : Argument_List;
To_Dir : Name_Id);
To_Dir : Path_Name_Type);
-- Copy the interface sources of a SAL to directory To_Dir
procedure Display (Executable : String);
......@@ -238,7 +240,7 @@ package body MLib.Prj is
procedure Reset_Tables;
-- Make sure that all the above tables are empty
-- (Objects, Foreign_Objects, Ali_Files, Options).
-- (Objects, ALIs, Options, ...).
function SALs_Use_Constructors return Boolean;
-- Indicate if Stand-Alone Libraries are automatically initialized using
......@@ -312,24 +314,32 @@ package body MLib.Prj is
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 the
-- gnatbind.
Size : Integer;
-- The number of bytes for the invocation of the gnatbind
Warning_For_Library : Boolean := False;
-- Set to True for the first warning about a unit missing from the
-- interface set.
Libgnarl_Needed : Boolean := False;
-- Set to True if library needs to be linked with libgnarl
Libdecgnat_Needed : Boolean := False;
-- On OpenVMS, set to True if library needs to be linked with libdecgnat
Gtrasymobj_Needed : Boolean := False;
-- On OpenVMS, set to True if library needs to be linked with
-- g-trasym.obj.
Data : Project_Data := In_Tree.Projects.Table (For_Project);
Libgnarl_Needed : Yes_No_Unknown := Data.Libgnarl_Needed;
-- Set to True if library needs to be linked with libgnarl
Libdecgnat_Needed : Boolean := False;
-- On OpenVMS, set to True if library needs to be linked with libdecgnat
Object_Directory_Path : constant String :=
Get_Name_String (Data.Object_Directory);
Get_Name_String (Data.Display_Object_Dir);
Standalone : constant Boolean := Data.Standalone_Library;
......@@ -346,7 +356,6 @@ package body MLib.Prj is
Success : Boolean := False;
Library_Options : Variable_Value := Nil_Variable_Value;
Library_GCC : Variable_Value := Nil_Variable_Value;
Driver_Name : Name_Id := No_Name;
......@@ -366,12 +375,11 @@ package body MLib.Prj is
-- If null, Path Option is not supported.
-- Not a constant so that it can be deallocated.
First_ALI : Name_Id := No_Name;
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 : Name_Id);
-- Add the name of the ALI file corresponding to Source to the
-- Arguments.
procedure Add_ALI_For (Source : File_Name_Type);
-- Add the name of the ALI file corresponding to Source to the arguments
procedure Add_Rpath (Path : String);
-- Add a path name to Rpath
......@@ -379,7 +387,7 @@ package body MLib.Prj is
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);
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). On OpenVMS, set Libdecgnat_Needed if the ALI file
......@@ -401,9 +409,9 @@ package body MLib.Prj is
-- Add_ALI_For --
-----------------
procedure Add_ALI_For (Source : Name_Id) is
procedure Add_ALI_For (Source : File_Name_Type) is
ALI : constant String := ALI_File_Name (Get_Name_String (Source));
ALI_Id : Name_Id;
ALI_Id : File_Name_Type;
begin
if Bind then
......@@ -422,7 +430,7 @@ package body MLib.Prj is
-- Set First_ALI, if not already done
if First_ALI = No_Name then
if First_ALI = No_File then
First_ALI := ALI_Id;
end if;
end Add_ALI_For;
......@@ -512,16 +520,17 @@ package body MLib.Prj is
-- Check_Libs --
----------------
procedure Check_Libs (ALI_File : String) is
Lib_File : Name_Id;
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 not Libgnarl_Needed or
(OpenVMS_On_Target and then
((not Libdecgnat_Needed) or
(not Gtrasymobj_Needed)))
if Libgnarl_Needed /= Yes
or else
(Main_Project
and then OpenVMS_On_Target
and then ((not Libdecgnat_Needed) or (not Gtrasymobj_Needed)))
then
-- Scan the ALI file
......@@ -544,7 +553,14 @@ package body MLib.Prj is
ALI.ALIs.Table (Id).Last_Sdep
loop
if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then
Libgnarl_Needed := True;
Libgnarl_Needed := Yes;
if Main_Project then
In_Tree.Projects.Table (For_Project).Libgnarl_Needed :=
Yes;
else
exit;
end if;
elsif OpenVMS_On_Target then
if ALI.Sdep.Table (Index).Sfile = S_Dec_Ads then
......@@ -611,7 +627,7 @@ package body MLib.Prj is
for W in Unit_Data.First_With .. Unit_Data.Last_With loop
Afile := Withs.Table (W).Afile;
if Afile /= No_Name and then Library_ALIs.Get (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
......@@ -676,8 +692,7 @@ package body MLib.Prj is
---------------------
procedure Process_Project (Project : Project_Id) is
Data : constant Project_Data :=
In_Tree.Projects.Table (Project);
Data : Project_Data := In_Tree.Projects.Table (Project);
Imported : Project_List := Data.Imported_Projects;
Element : Project_Element;
......@@ -707,6 +722,76 @@ package body MLib.Prj is
if Project /= For_Project and then Data.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 Data.Libgnarl_Needed = Unknown
and then Data.Object_Directory /= No_Path
then
-- Check if libgnarl is needed for this library
declare
Object_Dir_Path : constant String :=
Get_Name_String
(Data.Display_Object_Dir);
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
Data.Libgnarl_Needed := Yes;
In_Tree.Projects.Table
(For_Project).Libgnarl_Needed :=
Yes;
exit;
end if;
end if;
end;
end if;
end loop;
Close (Object_Dir);
end;
end if;
if Data.Libgnarl_Needed = Yes then
Libgnarl_Needed := Yes;
In_Tree.Projects.Table (For_Project).Libgnarl_Needed :=
Yes;
end if;
end if;
end if;
end if;
......@@ -722,6 +807,7 @@ package body MLib.Prj is
-- 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.
......@@ -729,7 +815,7 @@ package body MLib.Prj is
Current := Library_Projs.Table (Index);
Get_Name_String
(In_Tree.Projects.Table (Current).Library_Dir);
(In_Tree.Projects.Table (Current).Display_Library_Dir);
Opts.Increment_Last;
Opts.Table (Opts.Last) :=
new String'("-L" & Name_Buffer (1 .. Name_Len));
......@@ -760,21 +846,21 @@ package body MLib.Prj is
end if;
-- If this is the first time Build_Library is called, get the Name_Id
-- of "s-osinte.ads".
-- values of "s-osinte.ads", "dec.ads", and "g-trasym.ads".
if S_Osinte_Ads = No_Name then
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_Name then
if S_Dec_Ads = No_File then
Name_Len := 0;
Add_Str_To_Name_Buffer ("dec.ads");
S_Dec_Ads := Name_Find;
end if;
if G_Trasym_Ads = No_Name then
if G_Trasym_Ads = No_File then
Name_Len := 0;
Add_Str_To_Name_Buffer ("g-trasym.ads");
G_Trasym_Ads := Name_Find;
......@@ -785,6 +871,7 @@ package body MLib.Prj is
Change_Dir (Object_Directory_Path);
if Standalone then
-- Call gnatbind only if Bind is True
if Bind then
......@@ -888,26 +975,25 @@ package body MLib.Prj is
loop
Unit := In_Tree.Units.Table (Source);
if Unit.File_Names (Body_Part).Name /= No_Name
if Unit.File_Names (Body_Part).Name /= No_File
and then Unit.File_Names (Body_Part).Path /= Slash
then
if
Check_Project (Unit.File_Names (Body_Part).Project)
then
if Unit.File_Names (Specification).Name = No_Name then
if Unit.File_Names (Specification).Name = No_File then
declare
Src_Ind : Source_File_Index;
begin
Src_Ind := Sinput.P.Load_Project_File
(Get_Name_String
(Unit.File_Names
(Body_Part).Path));
(Unit.File_Names (Body_Part).Path));
-- Add the ALI file only if it is not a subunit
if
not Sinput.P.Source_File_Is_Subunit (Src_Ind)
not Sinput.P.Source_File_Is_Subunit (Src_Ind)
then
Add_ALI_For
(Unit.File_Names (Body_Part).Name);
......@@ -921,7 +1007,7 @@ package body MLib.Prj is
end if;
end if;
elsif Unit.File_Names (Specification).Name /= No_Name
elsif Unit.File_Names (Specification).Name /= No_File
and then Unit.File_Names (Specification).Path /= Slash
and then Check_Project
(Unit.File_Names (Specification).Project)
......@@ -938,7 +1024,7 @@ package body MLib.Prj is
-- Get an eventual --RTS from the ALI file
if First_ALI /= No_Name then
if First_ALI /= No_File then
declare
T : Text_Buffer_Ptr;
A : ALI_Id;
......@@ -989,10 +1075,114 @@ package body MLib.Prj is
Display (Gnatbind);
-- Invoke gnatbind
-- Check the size of the arguments
GNAT.OS_Lib.Spawn
(Gnatbind_Path.all, Arguments (1 .. Argument_Number), Success);
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);
else
-- Otherwise create a temporary response file
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 this response file
Spawn (Gnatbind_Path.all, Args, Success);
Delete_File (Get_Name_String (Path), Succ);
if not Succ then
null;
end if;
end;
end if;
if not Success then
Com.Fail ("could not bind standalone library ",
......@@ -1003,6 +1193,7 @@ package body MLib.Prj is
-- Compile the binder generated file only if Link is true
if Link then
-- Set the paths
Set_Ada_Paths
......@@ -1037,7 +1228,7 @@ package body MLib.Prj is
-- Get the back-end switches and --RTS from the ALI file
if First_ALI /= No_Name then
if First_ALI /= No_File then
declare
T : Text_Buffer_Ptr;
A : ALI_Id;
......@@ -1136,8 +1327,10 @@ package body MLib.Prj is
end;
end if;
Lib_Dirpath := new String'(Get_Name_String (Data.Library_Dir));
Lib_Filename := new String'(Get_Name_String (Data.Library_Name));
Lib_Dirpath :=
new String'(Get_Name_String (Data.Display_Library_Dir));
Lib_Filename :=
new String'(Get_Name_String (Data.Library_Name));
case Data.Library_Kind is
when Static =>
......@@ -1157,7 +1350,7 @@ package body MLib.Prj is
-- Get the library version, if any
if Data.Lib_Internal_Name /= No_Name then
if Data.Lib_Internal_Name /= No_File then
Lib_Version :=
new String'(Get_Name_String (Data.Lib_Internal_Name));
end if;
......@@ -1165,6 +1358,7 @@ package body MLib.Prj is
-- 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.
......@@ -1173,7 +1367,7 @@ package body MLib.Prj is
loop
declare
Object_Dir_Path : constant String :=
Get_Name_String (Data.Object_Directory);
Get_Name_String (Data.Display_Object_Dir);
Object_Dir : Dir_Type;
Filename : String (1 .. 255);
Last : Natural;
......@@ -1193,24 +1387,28 @@ package body MLib.Prj is
if Is_Obj (Filename (1 .. Last)) then
declare
Object_Path : String :=
Object_Path : constant String :=
Normalize_Pathname
(Object_Dir_Path & Directory_Separator &
Filename (1 .. Last));
C_Object_Path : String := Object_Path;
C_Filename : String := Filename (1 .. Last);
begin
Canonical_Case_File_Name (Object_Path);
Canonical_Case_File_Name (Filename (1 .. Last));
Canonical_Case_File_Name (C_Object_Path);
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 Filename (1 .. B_Start'Length) /= B_Start.all
or else C_Filename (1 .. B_Start'Length) /=
B_Start.all
then
Name_Len := Last;
Name_Buffer (1 .. Name_Len) := Filename (1 .. Last);
Name_Buffer (1 .. Name_Len) :=
C_Filename (1 .. Last);
Id := Name_Find;
if not Objects_Htable.Get (Id) then
......@@ -1235,11 +1433,11 @@ package body MLib.Prj is
ALIs.Table (ALIs.Last) :=
new String'(ALI_File);
-- Find out if for this ALI file,
-- libgnarl or libdecgnat or g-trasym.obj
-- (on OpenVMS) is necessary.
-- Find out if for this ALI file, libgnarl
-- or libdecgnat or g-trasym.obj (on
-- OpenVMS) is necessary.
Check_Libs (ALI_File);
Check_Libs (ALI_File, True);
else
-- Object file is a foreign object file
......@@ -1312,7 +1510,7 @@ package body MLib.Prj is
end;
end if;
if Libgnarl_Needed then
if Libgnarl_Needed = Yes then
Opts.Increment_Last;
if The_Build_Mode = Static then
......@@ -1320,6 +1518,9 @@ package body MLib.Prj is
else
Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnarl"));
end if;
else
In_Tree.Projects.Table (For_Project).Libgnarl_Needed := No;
end if;
if Gtrasymobj_Needed then
......@@ -1377,8 +1578,8 @@ package body MLib.Prj is
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).
-- 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 """ &
......@@ -1393,8 +1594,7 @@ package body MLib.Prj is
Write_Str (" library for project ");
Write_Line (Project_Name);
-- Only output the list of object files and ALI files in verbose
-- mode.
-- Only output list of object files and ALI files in verbose mode
if Opt.Verbose_Mode then
Write_Eol;
......@@ -1428,17 +1628,17 @@ package body MLib.Prj is
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.
-- 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 & '/' & DLL_Prefix &
Lib_Dirpath.all & Directory_Separator & DLL_Prefix &
Lib_Filename.all & "." & DLL_Ext;
Archive_Name : aliased String :=
Lib_Dirpath.all & "/lib" &
Lib_Dirpath.all & Directory_Separator & "lib" &
Lib_Filename.all & "." & Archive_Ext;
type Str_Ptr is access all String;
......@@ -1482,19 +1682,20 @@ package body MLib.Prj is
Data := In_Tree.Projects.Table (For_Project);
declare
Iface : String_List_Id := Data.Lib_Interface_ALIs;
Iface : String_List_Id;
ALI : File_Name_Type;
begin
Iface := Data.Lib_Interface_ALIs;
while Iface /= Nil_String loop
ALI :=
In_Tree.String_Elements.Table (Iface).Value;
File_Name_Type
(In_Tree.String_Elements.Table (Iface).Value);
Interface_ALIs.Set (ALI, True);
Get_Name_String
(In_Tree.String_Elements.Table (Iface).Value);
Add_Argument (Name_Buffer (1 .. Name_Len));
Iface :=
In_Tree.String_Elements.Table (Iface).Next;
Iface := In_Tree.String_Elements.Table (Iface).Next;
end loop;
Iface := Data.Lib_Interface_ALIs;
......@@ -1506,11 +1707,11 @@ package body MLib.Prj is
-- interface. If it is not the case, output a warning.
while Iface /= Nil_String loop
ALI := In_Tree.String_Elements.Table
(Iface).Value;
ALI :=
File_Name_Type
(In_Tree.String_Elements.Table (Iface).Value);
Process (ALI);
Iface :=
In_Tree.String_Elements.Table (Iface).Next;
Iface := In_Tree.String_Elements.Table (Iface).Next;
end loop;
end if;
end;
......@@ -1518,20 +1719,15 @@ package body MLib.Prj is
declare
Current_Dir : constant String := Get_Current_Dir;
Dir : Dir_Type;
Name : String (1 .. 200);
Last : Natural;
Disregard : Boolean;
DLL_Name : aliased constant String :=
Lib_Filename.all & "." & DLL_Ext;
DLL_Name : aliased constant String :=
Lib_Filename.all & "." & DLL_Ext;
Archive_Name : aliased constant String :=
Lib_Filename.all & "." & Archive_Ext;
Delete : Boolean := False;
Dir : Dir_Type;
Name : String (1 .. 200);
Last : Natural;
Disregard : Boolean;
Delete : Boolean := False;
begin
-- Clean the library directory: remove any file with the name of
......@@ -1556,74 +1752,85 @@ package body MLib.Prj is
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;
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;
declare
Filename : constant String := Name (1 .. Last);
elsif Last > 4 and then Name (Last - 3 .. Last) = ".ali" then
declare
Unit : Unit_Data;
begin
-- Compare with ALI file names of the project
begin
if Is_Regular_File (Filename) then
Canonical_Case_File_Name (Name (1 .. Last));
Delete := False;
for Index in 1 .. Unit_Table.Last (In_Tree.Units) loop
Unit := In_Tree.Units.Table (Index);
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;
if Unit.File_Names (Body_Part).Project /=
No_Project
then
if Ultimate_Extension_Of
(Unit.File_Names (Body_Part).Project, In_Tree)
= For_Project
elsif Last > 4
and then Name (Last - 3 .. Last) = ".ali"
then
declare
Unit : Unit_Data;
begin
-- Compare with ALI file names of the project
for Index in
1 .. Unit_Table.Last (In_Tree.Units)
loop
Unit := In_Tree.Units.Table (Index);
if Unit.File_Names (Body_Part).Project /=
No_Project
then
if Ultimate_Extension_Of
(Unit.File_Names (Body_Part).Project,
In_Tree) = For_Project
then
Get_Name_String
(Unit.File_Names (Body_Part).Name);
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 Ultimate_Extension_Of
(Unit.File_Names (Specification).Project,
In_Tree) = For_Project
then
Get_Name_String
(Unit.File_Names (Body_Part).Name);
(Unit.File_Names (Specification).Name);
Name_Len := Name_Len -
File_Extension
(Name (1 .. Name_Len))'Length;
if Name_Buffer (1 .. Name_Len) =
Name (1 .. Last - 4)
Name (1 .. Last - 4)
then
Delete := True;
exit;
end if;
end if;
end loop;
end;
end if;
elsif Ultimate_Extension_Of
(Unit.File_Names (Specification).Project, In_Tree)
= For_Project
then
Get_Name_String
(Unit.File_Names (Specification).Name);
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;
end loop;
end;
end if;
if Delete then
Set_Writable (Name (1 .. Last));
Delete_File (Name (1 .. Last), Disregard);
if Delete then
Set_Writable (Filename);
Delete_File (Filename, Disregard);
end if;
end if;
end if;
end;
end loop;
Close (Dir);
......@@ -1671,14 +1878,15 @@ package body MLib.Prj is
Copy_ALI_Files
(Files => Ali_Files.all,
To => In_Tree.Projects.Table (For_Project).Library_ALI_Dir,
To => In_Tree.Projects.Table
(For_Project).Display_Library_ALI_Dir,
Interfaces => Arguments (1 .. Argument_Number));
-- Copy interface sources if Library_Src_Dir specified
if Standalone
and then In_Tree.Projects.Table
(For_Project).Library_Src_Dir /= No_Name
(For_Project).Library_Src_Dir /= No_Path
then
-- Clean the interface copy directory: remove any source that
-- could be a source of the project.
......@@ -1697,13 +1905,11 @@ package body MLib.Prj is
end;
declare
Dir : Dir_Type;
Delete : Boolean := False;
Unit : Unit_Data;
Name : String (1 .. 200);
Last : Natural;
Dir : Dir_Type;
Delete : Boolean := False;
Unit : Unit_Data;
Name : String (1 .. 200);
Last : Natural;
Disregard : Boolean;
begin
......@@ -1713,45 +1919,50 @@ package body MLib.Prj is
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;
declare
Filename : constant String := Name (1 .. Last);
-- Compare with source file names of the project
begin
if Is_Regular_File (Filename) then
Canonical_Case_File_Name (Name (1 .. Last));
Delete := False;
for Index in 1 .. Unit_Table.Last (In_Tree.Units) loop
Unit := In_Tree.Units.Table (Index);
-- Compare with source file names of the project
if Ultimate_Extension_Of
(Unit.File_Names (Body_Part).Project, In_Tree) =
For_Project
and then
Get_Name_String
(Unit.File_Names (Body_Part).Name) =
Name (1 .. Last)
then
Delete := True;
exit;
end if;
for Index in 1 .. Unit_Table.Last (In_Tree.Units) loop
Unit := In_Tree.Units.Table (Index);
if Ultimate_Extension_Of
(Unit.File_Names (Specification).Project, In_Tree) =
For_Project
and then
Get_Name_String
(Unit.File_Names (Specification).Name) =
Name (1 .. Last)
then
Delete := True;
exit;
end if;
end loop;
end if;
if Ultimate_Extension_Of
(Unit.File_Names (Body_Part).Project, In_Tree) =
For_Project
and then
Get_Name_String
(Unit.File_Names (Body_Part).Name) =
Name (1 .. Last)
then
Delete := True;
exit;
end if;
if Delete then
Set_Writable (Name (1 .. Last));
Delete_File (Name (1 .. Last), Disregard);
end if;
if Ultimate_Extension_Of
(Unit.File_Names
(Specification).Project, In_Tree) = For_Project
and then
Get_Name_String
(Unit.File_Names (Specification).Name) =
Name (1 .. Last)
then
Delete := True;
exit;
end if;
end loop;
end if;
if Delete then
Set_Writable (Filename);
Delete_File (Filename, Disregard);
end if;
end;
end loop;
Close (Dir);
......@@ -1762,7 +1973,7 @@ package body MLib.Prj is
In_Tree => In_Tree,
Interfaces => Arguments (1 .. Argument_Number),
To_Dir => In_Tree.Projects.Table
(For_Project).Library_Src_Dir);
(For_Project).Display_Library_Src_Dir);
end if;
end if;
......@@ -1800,7 +2011,8 @@ package body MLib.Prj is
-------------------
procedure Check_Library
(For_Project : Project_Id; In_Tree : Project_Tree_Ref)
(For_Project : Project_Id;
In_Tree : Project_Tree_Ref)
is
Data : constant Project_Data :=
In_Tree.Projects.Table (For_Project);
......@@ -1813,8 +2025,8 @@ package body MLib.Prj is
if Data.Library then
declare
Lib_Name : constant Name_Id :=
Library_File_Name_For (For_Project, In_Tree);
Lib_Name : constant File_Name_Type :=
Library_File_Name_For (For_Project, In_Tree);
begin
Change_Dir (Get_Name_String (Data.Library_Dir));
Lib_TS := File_Stamp (Lib_Name);
......@@ -1823,7 +2035,7 @@ package body MLib.Prj is
if not Data.Externally_Built
and then not Data.Need_To_Build_Lib
and then Data.Object_Directory /= No_Name
and then Data.Object_Directory /= No_Path
then
declare
Obj_TS : Time_Stamp_Type;
......@@ -1854,7 +2066,7 @@ package body MLib.Prj is
then
-- Get the object file time stamp
Obj_TS := File_Stamp (Name_Find);
Obj_TS := File_Stamp (File_Name_Type'(Name_Find));
-- If library file time stamp is earlier, set
-- Need_To_Build_Lib and return. String comparaison is
......@@ -1889,7 +2101,7 @@ package body MLib.Prj is
(For_Project : Project_Id;
In_Tree : Project_Tree_Ref;
Interfaces : Argument_List;
To_Dir : Name_Id)
To_Dir : Path_Name_Type)
is
Current : constant Dir_Name_Str := Get_Current_Dir;
-- The current directory, where to return to at the end
......@@ -1899,7 +2111,7 @@ package body MLib.Prj is
Text : Text_Buffer_Ptr;
The_ALI : ALI.ALI_Id;
Lib_File : Name_Id;
Lib_File : File_Name_Type;
First_Unit : ALI.Unit_Id;
Second_Unit : ALI.Unit_Id;
......@@ -1909,7 +2121,7 @@ package body MLib.Prj is
Copy_Subunits : Boolean := False;
-- When True, indicates that subunits, if any, need to be copied too
procedure Copy (File_Name : Name_Id);
procedure Copy (File_Name : File_Name_Type);
-- Copy one source of the project to the target directory
function Is_Same_Or_Extension
......@@ -1922,7 +2134,7 @@ package body MLib.Prj is
-- Copy --
----------
procedure Copy (File_Name : Name_Id) is
procedure Copy (File_Name : File_Name_Type) is
Success : Boolean := False;
begin
......
gcc/ada/mlib-prj.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2005, AdaCore --
-- Copyright (C) 2001-2007, 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- --
......@@ -47,7 +47,8 @@ package MLib.Prj is
-- If Link is False, the library is not linked/built.
procedure Check_Library
(For_Project : Project_Id; In_Tree : Project_Tree_Ref);
(For_Project : Project_Id;
In_Tree : Project_Tree_Ref);
-- Check if the library of a library project needs to be rebuilt,
-- because its time-stamp is earlier than the time stamp of one of its
-- object files.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment