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). # 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. #This file is part of GCC.
...@@ -100,6 +100,7 @@ GNATRTL_NONTASKING_OBJS= \ ...@@ -100,6 +100,7 @@ GNATRTL_NONTASKING_OBJS= \
a-ciorma$(objext) \ a-ciorma$(objext) \
a-ciormu$(objext) \ a-ciormu$(objext) \
a-ciorse$(objext) \ a-ciorse$(objext) \
a-clrefi$(objext) \
a-cohama$(objext) \ a-cohama$(objext) \
a-cohase$(objext) \ a-cohase$(objext) \
a-cohata$(objext) \ a-cohata$(objext) \
...@@ -366,6 +367,7 @@ GNATRTL_NONTASKING_OBJS= \ ...@@ -366,6 +367,7 @@ GNATRTL_NONTASKING_OBJS= \
g-sptavs$(objext) \ g-sptavs$(objext) \
g-string$(objext) \ g-string$(objext) \
g-strspl$(objext) \ g-strspl$(objext) \
g-sttsne$(objext) \
g-table$(objext) \ g-table$(objext) \
g-tasloc$(objext) \ g-tasloc$(objext) \
g-traceb$(objext) \ g-traceb$(objext) \
...@@ -409,6 +411,7 @@ GNATRTL_NONTASKING_OBJS= \ ...@@ -409,6 +411,7 @@ GNATRTL_NONTASKING_OBJS= \
s-dsaser$(objext) \ s-dsaser$(objext) \
s-errrep$(objext) \ s-errrep$(objext) \
s-exctab$(objext) \ s-exctab$(objext) \
s-except$(objext) \
s-exnint$(objext) \ s-exnint$(objext) \
s-exnllf$(objext) \ s-exnllf$(objext) \
s-exnlli$(objext) \ s-exnlli$(objext) \
...@@ -454,6 +457,7 @@ GNATRTL_NONTASKING_OBJS= \ ...@@ -454,6 +457,7 @@ GNATRTL_NONTASKING_OBJS= \
s-maccod$(objext) \ s-maccod$(objext) \
s-mantis$(objext) \ s-mantis$(objext) \
s-mastop$(objext) \ s-mastop$(objext) \
s-os_lib$(objext) \
s-osprim$(objext) \ s-osprim$(objext) \
s-pack03$(objext) \ s-pack03$(objext) \
s-pack05$(objext) \ s-pack05$(objext) \
...@@ -519,6 +523,8 @@ GNATRTL_NONTASKING_OBJS= \ ...@@ -519,6 +523,8 @@ GNATRTL_NONTASKING_OBJS= \
s-poosiz$(objext) \ s-poosiz$(objext) \
s-powtab$(objext) \ s-powtab$(objext) \
s-purexc$(objext) \ s-purexc$(objext) \
s-regexp$(objext) \
s-regpat$(objext) \
s-restri$(objext) \ s-restri$(objext) \
s-rident$(objext) \ s-rident$(objext) \
s-rpc$(objext) \ s-rpc$(objext) \
...@@ -540,10 +546,13 @@ GNATRTL_NONTASKING_OBJS= \ ...@@ -540,10 +546,13 @@ GNATRTL_NONTASKING_OBJS= \
s-soflin$(objext) \ s-soflin$(objext) \
s-memory$(objext) \ s-memory$(objext) \
s-memcop$(objext) \ s-memcop$(objext) \
s-string$(objext) \
s-tasloc$(objext) \
s-traceb$(objext) \ s-traceb$(objext) \
s-traces$(objext) \ s-traces$(objext) \
s-traent$(objext) \ s-traent$(objext) \
s-unstyp$(objext) \ s-unstyp$(objext) \
s-utf_32$(objext) \
s-vaflop$(objext) \ s-vaflop$(objext) \
s-valboo$(objext) \ s-valboo$(objext) \
s-valcha$(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 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -145,6 +145,7 @@ package body Impunit is ...@@ -145,6 +145,7 @@ package body Impunit is
----------------------------------- -----------------------------------
"a-chlat9", -- Ada.Characters.Latin_9 "a-chlat9", -- Ada.Characters.Latin_9
"a-clrefi", -- Ada.Command_Line.Response_File
"a-colien", -- Ada.Command_Line.Environment "a-colien", -- Ada.Command_Line.Environment
"a-colire", -- Ada.Command_Line.Remove "a-colire", -- Ada.Command_Line.Remove
"a-cwila1", -- Ada.Characters.Wide_Latin_1 "a-cwila1", -- Ada.Characters.Wide_Latin_1
...@@ -288,17 +289,8 @@ package body Impunit is ...@@ -288,17 +289,8 @@ package body Impunit is
"i-cexten", -- Interfaces.C.Extensions "i-cexten", -- Interfaces.C.Extensions
"i-cpp ", -- Interfaces.CPP "i-cpp ", -- Interfaces.CPP
"i-cstrea", -- Interfaces.C.Streams "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-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-pacdec", -- Interfaces.Packed_Decimal
"i-vthrea", -- Interfaces.Vthreads
"i-vxwoio", -- Interfaces.VxWorks.IO "i-vxwoio", -- Interfaces.VxWorks.IO
"i-vxwork", -- Interfaces.VxWorks "i-vxwork", -- Interfaces.VxWorks
...@@ -319,6 +311,7 @@ package body Impunit is ...@@ -319,6 +311,7 @@ package body Impunit is
"s-addima", -- System.Address_Image "s-addima", -- System.Address_Image
"s-assert", -- System.Assertions "s-assert", -- System.Assertions
"s-memory", -- System.Memory "s-memory", -- System.Memory
"s-os_lib", -- System.Os_Lib
"s-parint", -- System.Partition_Interface "s-parint", -- System.Partition_Interface
"s-pooglo", -- System.Pool_Global "s-pooglo", -- System.Pool_Global
"s-pooloc", -- System.Pool_Local "s-pooloc", -- System.Pool_Local
...@@ -364,6 +357,8 @@ package body Impunit is ...@@ -364,6 +357,8 @@ package body Impunit is
"a-diroro", -- Ada.Dispatching.Round_Robin "a-diroro", -- Ada.Dispatching.Round_Robin
"a-dispat", -- Ada.Dispatching "a-dispat", -- Ada.Dispatching
"a-envvar", -- Ada.Environment_Variables "a-envvar", -- Ada.Environment_Variables
"a-exetim", -- Ada.Execution_Time
"a-extiti", -- Ada.Execution_Time.Timers
"a-rttiev", -- Ada.Real_Time.Timing_Events "a-rttiev", -- Ada.Real_Time.Timing_Events
"a-ngcoar", -- Ada.Numerics.Generic_Complex_Arrays "a-ngcoar", -- Ada.Numerics.Generic_Complex_Arrays
"a-ngrear", -- Ada.Numerics.Generic_Real_Arrays "a-ngrear", -- Ada.Numerics.Generic_Real_Arrays
......
gcc/ada/mlib-prj.adb
...@@ -2,11 +2,11 @@ ...@@ -2,11 +2,11 @@
-- -- -- --
-- GNAT COMPILER COMPONENTS -- -- GNAT COMPILER COMPONENTS --
-- -- -- --
-- M L I B . P R J -- -- M L I B . P R J --
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -29,7 +29,6 @@ with Gnatvsn; use Gnatvsn; ...@@ -29,7 +29,6 @@ with Gnatvsn; use Gnatvsn;
with MLib.Fil; use MLib.Fil; with MLib.Fil; use MLib.Fil;
with MLib.Tgt; use MLib.Tgt; with MLib.Tgt; use MLib.Tgt;
with MLib.Utl; use MLib.Utl; with MLib.Utl; use MLib.Utl;
with Namet; use Namet;
with Opt; with Opt;
with Output; use Output; with Output; use Output;
with Prj.Com; use Prj.Com; with Prj.Com; use Prj.Com;
...@@ -40,11 +39,14 @@ with Snames; use Snames; ...@@ -40,11 +39,14 @@ with Snames; use Snames;
with Switch; use Switch; with Switch; use Switch;
with Table; with Table;
with Targparm; use Targparm; with Targparm; use Targparm;
with Tempdir;
with Types; use Types;
with Ada.Characters.Handling; with Ada.Characters.Handling;
with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.HTable; with GNAT.HTable;
with Interfaces.C_Streams; use Interfaces.C_Streams; with Interfaces.C_Streams; use Interfaces.C_Streams;
with System; use System; with System; use System;
with System.Case_Util; use System.Case_Util; with System.Case_Util; use System.Case_Util;
...@@ -63,13 +65,13 @@ package body MLib.Prj is ...@@ -63,13 +65,13 @@ package body MLib.Prj is
B_Start : String_Ptr := new String'("b~"); B_Start : String_Ptr := new String'("b~");
-- Prefix of bind file, changed to b__ for VMS -- 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" -- 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" -- 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" -- Name_Id for "g-trasym.ads"
No_Argument_List : aliased String_List := (1 .. 0 => null); No_Argument_List : aliased String_List := (1 .. 0 => null);
...@@ -158,7 +160,7 @@ package body MLib.Prj is ...@@ -158,7 +160,7 @@ package body MLib.Prj is
(Header_Num => Header_Num, (Header_Num => Header_Num,
Element => Boolean, Element => Boolean,
No_Element => False, No_Element => False,
Key => Name_Id, Key => File_Name_Type,
Hash => Hash, Hash => Hash,
Equal => "="); Equal => "=");
...@@ -168,7 +170,7 @@ package body MLib.Prj is ...@@ -168,7 +170,7 @@ package body MLib.Prj is
(Header_Num => Header_Num, (Header_Num => Header_Num,
Element => Boolean, Element => Boolean,
No_Element => False, No_Element => False,
Key => Name_Id, Key => File_Name_Type,
Hash => Hash, Hash => Hash,
Equal => "="); Equal => "=");
...@@ -179,7 +181,7 @@ package body MLib.Prj is ...@@ -179,7 +181,7 @@ package body MLib.Prj is
(Header_Num => Header_Num, (Header_Num => Header_Num,
Element => Boolean, Element => Boolean,
No_Element => False, No_Element => False,
Key => Name_Id, Key => File_Name_Type,
Hash => Hash, Hash => Hash,
Equal => "="); Equal => "=");
...@@ -222,7 +224,7 @@ package body MLib.Prj is ...@@ -222,7 +224,7 @@ package body MLib.Prj is
(For_Project : Project_Id; (For_Project : Project_Id;
In_Tree : Project_Tree_Ref; In_Tree : Project_Tree_Ref;
Interfaces : Argument_List; Interfaces : Argument_List;
To_Dir : Name_Id); To_Dir : Path_Name_Type);
-- Copy the interface sources of a SAL to directory To_Dir -- Copy the interface sources of a SAL to directory To_Dir
procedure Display (Executable : String); procedure Display (Executable : String);
...@@ -238,7 +240,7 @@ package body MLib.Prj is ...@@ -238,7 +240,7 @@ package body MLib.Prj is
procedure Reset_Tables; procedure Reset_Tables;
-- Make sure that all the above tables are empty -- Make sure that all the above tables are empty
-- (Objects, Foreign_Objects, Ali_Files, Options). -- (Objects, ALIs, Options, ...).
function SALs_Use_Constructors return Boolean; function SALs_Use_Constructors return Boolean;
-- Indicate if Stand-Alone Libraries are automatically initialized using -- Indicate if Stand-Alone Libraries are automatically initialized using
...@@ -312,24 +314,32 @@ package body MLib.Prj is ...@@ -312,24 +314,32 @@ package body MLib.Prj is
Bind : Boolean := True; Bind : Boolean := True;
Link : Boolean := True) Link : Boolean := True)
is 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; Warning_For_Library : Boolean := False;
-- Set to True for the first warning about a unit missing from the -- Set to True for the first warning about a unit missing from the
-- interface set. -- 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; Gtrasymobj_Needed : Boolean := False;
-- On OpenVMS, set to True if library needs to be linked with -- On OpenVMS, set to True if library needs to be linked with
-- g-trasym.obj. -- g-trasym.obj.
Data : Project_Data := In_Tree.Projects.Table (For_Project); 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 := Object_Directory_Path : constant String :=
Get_Name_String (Data.Object_Directory); Get_Name_String (Data.Display_Object_Dir);
Standalone : constant Boolean := Data.Standalone_Library; Standalone : constant Boolean := Data.Standalone_Library;
...@@ -346,7 +356,6 @@ package body MLib.Prj is ...@@ -346,7 +356,6 @@ package body MLib.Prj is
Success : Boolean := False; Success : Boolean := False;
Library_Options : Variable_Value := Nil_Variable_Value; Library_Options : Variable_Value := Nil_Variable_Value;
Library_GCC : Variable_Value := Nil_Variable_Value; Library_GCC : Variable_Value := Nil_Variable_Value;
Driver_Name : Name_Id := No_Name; Driver_Name : Name_Id := No_Name;
...@@ -366,12 +375,11 @@ package body MLib.Prj is ...@@ -366,12 +375,11 @@ package body MLib.Prj is
-- If null, Path Option is not supported. -- If null, Path Option is not supported.
-- Not a constant so that it can be deallocated. -- 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) -- Store the ALI file name of a source of the library (the first found)
procedure Add_ALI_For (Source : Name_Id); procedure Add_ALI_For (Source : File_Name_Type);
-- Add the name of the ALI file corresponding to Source to the -- Add the name of the ALI file corresponding to Source to the arguments
-- Arguments.
procedure Add_Rpath (Path : String); procedure Add_Rpath (Path : String);
-- Add a path name to Rpath -- Add a path name to Rpath
...@@ -379,7 +387,7 @@ package body MLib.Prj is ...@@ -379,7 +387,7 @@ package body MLib.Prj is
function Check_Project (P : Project_Id) return Boolean; function Check_Project (P : Project_Id) return Boolean;
-- Returns True if P is For_Project or a project extended by For_Project -- 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 -- 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 -- 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 -- on s-osinte.ads). On OpenVMS, set Libdecgnat_Needed if the ALI file
...@@ -401,9 +409,9 @@ package body MLib.Prj is ...@@ -401,9 +409,9 @@ package body MLib.Prj is
-- Add_ALI_For -- -- 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 : constant String := ALI_File_Name (Get_Name_String (Source));
ALI_Id : Name_Id; ALI_Id : File_Name_Type;
begin begin
if Bind then if Bind then
...@@ -422,7 +430,7 @@ package body MLib.Prj is ...@@ -422,7 +430,7 @@ package body MLib.Prj is
-- Set First_ALI, if not already done -- Set First_ALI, if not already done
if First_ALI = No_Name then if First_ALI = No_File then
First_ALI := ALI_Id; First_ALI := ALI_Id;
end if; end if;
end Add_ALI_For; end Add_ALI_For;
...@@ -512,16 +520,17 @@ package body MLib.Prj is ...@@ -512,16 +520,17 @@ package body MLib.Prj is
-- Check_Libs -- -- Check_Libs --
---------------- ----------------
procedure Check_Libs (ALI_File : String) is procedure Check_Libs (ALI_File : String; Main_Project : Boolean) is
Lib_File : Name_Id; Lib_File : File_Name_Type;
Text : Text_Buffer_Ptr; Text : Text_Buffer_Ptr;
Id : ALI.ALI_Id; Id : ALI.ALI_Id;
begin begin
if not Libgnarl_Needed or if Libgnarl_Needed /= Yes
(OpenVMS_On_Target and then or else
((not Libdecgnat_Needed) or (Main_Project
(not Gtrasymobj_Needed))) and then OpenVMS_On_Target
and then ((not Libdecgnat_Needed) or (not Gtrasymobj_Needed)))
then then
-- Scan the ALI file -- Scan the ALI file
...@@ -544,7 +553,14 @@ package body MLib.Prj is ...@@ -544,7 +553,14 @@ package body MLib.Prj is
ALI.ALIs.Table (Id).Last_Sdep ALI.ALIs.Table (Id).Last_Sdep
loop loop
if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then 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 elsif OpenVMS_On_Target then
if ALI.Sdep.Table (Index).Sfile = S_Dec_Ads then if ALI.Sdep.Table (Index).Sfile = S_Dec_Ads then
...@@ -611,7 +627,7 @@ package body MLib.Prj is ...@@ -611,7 +627,7 @@ package body MLib.Prj is
for W in Unit_Data.First_With .. Unit_Data.Last_With loop for W in Unit_Data.First_With .. Unit_Data.Last_With loop
Afile := Withs.Table (W).Afile; 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) and then not Processed_ALIs.Get (Afile)
then then
if not Interface_ALIs.Get (Afile) then if not Interface_ALIs.Get (Afile) then
...@@ -676,8 +692,7 @@ package body MLib.Prj is ...@@ -676,8 +692,7 @@ package body MLib.Prj is
--------------------- ---------------------
procedure Process_Project (Project : Project_Id) is procedure Process_Project (Project : Project_Id) is
Data : constant Project_Data := Data : Project_Data := In_Tree.Projects.Table (Project);
In_Tree.Projects.Table (Project);
Imported : Project_List := Data.Imported_Projects; Imported : Project_List := Data.Imported_Projects;
Element : Project_Element; Element : Project_Element;
...@@ -707,6 +722,76 @@ package body MLib.Prj is ...@@ -707,6 +722,76 @@ package body MLib.Prj is
if Project /= For_Project and then Data.Library then if Project /= For_Project and then Data.Library then
Library_Projs.Increment_Last; Library_Projs.Increment_Last;
Library_Projs.Table (Library_Projs.Last) := Project; 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;
end if; end if;
...@@ -722,6 +807,7 @@ package body MLib.Prj is ...@@ -722,6 +807,7 @@ package body MLib.Prj is
-- Add the -L and -l switches and, if the Rpath option is supported, -- Add the -L and -l switches and, if the Rpath option is supported,
-- add the directory to the Rpath. -- add the directory to the Rpath.
-- As the library projects are in the wrong order, process from the -- As the library projects are in the wrong order, process from the
-- last to the first. -- last to the first.
...@@ -729,7 +815,7 @@ package body MLib.Prj is ...@@ -729,7 +815,7 @@ package body MLib.Prj is
Current := Library_Projs.Table (Index); Current := Library_Projs.Table (Index);
Get_Name_String Get_Name_String
(In_Tree.Projects.Table (Current).Library_Dir); (In_Tree.Projects.Table (Current).Display_Library_Dir);
Opts.Increment_Last; Opts.Increment_Last;
Opts.Table (Opts.Last) := Opts.Table (Opts.Last) :=
new String'("-L" & Name_Buffer (1 .. Name_Len)); new String'("-L" & Name_Buffer (1 .. Name_Len));
...@@ -760,21 +846,21 @@ package body MLib.Prj is ...@@ -760,21 +846,21 @@ package body MLib.Prj is
end if; end if;
-- If this is the first time Build_Library is called, get the Name_Id -- 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; Name_Len := 0;
Add_Str_To_Name_Buffer ("s-osinte.ads"); Add_Str_To_Name_Buffer ("s-osinte.ads");
S_Osinte_Ads := Name_Find; S_Osinte_Ads := Name_Find;
end if; end if;
if S_Dec_Ads = No_Name then if S_Dec_Ads = No_File then
Name_Len := 0; Name_Len := 0;
Add_Str_To_Name_Buffer ("dec.ads"); Add_Str_To_Name_Buffer ("dec.ads");
S_Dec_Ads := Name_Find; S_Dec_Ads := Name_Find;
end if; end if;
if G_Trasym_Ads = No_Name then if G_Trasym_Ads = No_File then
Name_Len := 0; Name_Len := 0;
Add_Str_To_Name_Buffer ("g-trasym.ads"); Add_Str_To_Name_Buffer ("g-trasym.ads");
G_Trasym_Ads := Name_Find; G_Trasym_Ads := Name_Find;
...@@ -785,6 +871,7 @@ package body MLib.Prj is ...@@ -785,6 +871,7 @@ package body MLib.Prj is
Change_Dir (Object_Directory_Path); Change_Dir (Object_Directory_Path);
if Standalone then if Standalone then
-- Call gnatbind only if Bind is True -- Call gnatbind only if Bind is True
if Bind then if Bind then
...@@ -888,26 +975,25 @@ package body MLib.Prj is ...@@ -888,26 +975,25 @@ package body MLib.Prj is
loop loop
Unit := In_Tree.Units.Table (Source); 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 and then Unit.File_Names (Body_Part).Path /= Slash
then then
if if
Check_Project (Unit.File_Names (Body_Part).Project) Check_Project (Unit.File_Names (Body_Part).Project)
then then
if Unit.File_Names (Specification).Name = No_Name then if Unit.File_Names (Specification).Name = No_File then
declare declare
Src_Ind : Source_File_Index; Src_Ind : Source_File_Index;
begin begin
Src_Ind := Sinput.P.Load_Project_File Src_Ind := Sinput.P.Load_Project_File
(Get_Name_String (Get_Name_String
(Unit.File_Names (Unit.File_Names (Body_Part).Path));
(Body_Part).Path));
-- Add the ALI file only if it is not a subunit -- Add the ALI file only if it is not a subunit
if if
not Sinput.P.Source_File_Is_Subunit (Src_Ind) not Sinput.P.Source_File_Is_Subunit (Src_Ind)
then then
Add_ALI_For Add_ALI_For
(Unit.File_Names (Body_Part).Name); (Unit.File_Names (Body_Part).Name);
...@@ -921,7 +1007,7 @@ package body MLib.Prj is ...@@ -921,7 +1007,7 @@ package body MLib.Prj is
end if; end if;
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 Unit.File_Names (Specification).Path /= Slash
and then Check_Project and then Check_Project
(Unit.File_Names (Specification).Project) (Unit.File_Names (Specification).Project)
...@@ -938,7 +1024,7 @@ package body MLib.Prj is ...@@ -938,7 +1024,7 @@ package body MLib.Prj is
-- Get an eventual --RTS from the ALI file -- Get an eventual --RTS from the ALI file
if First_ALI /= No_Name then if First_ALI /= No_File then
declare declare
T : Text_Buffer_Ptr; T : Text_Buffer_Ptr;
A : ALI_Id; A : ALI_Id;
...@@ -989,10 +1075,114 @@ package body MLib.Prj is ...@@ -989,10 +1075,114 @@ package body MLib.Prj is
Display (Gnatbind); Display (Gnatbind);
-- Invoke gnatbind -- Check the size of the arguments
GNAT.OS_Lib.Spawn Size := 0;
(Gnatbind_Path.all, Arguments (1 .. Argument_Number), Success); 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 if not Success then
Com.Fail ("could not bind standalone library ", Com.Fail ("could not bind standalone library ",
...@@ -1003,6 +1193,7 @@ package body MLib.Prj is ...@@ -1003,6 +1193,7 @@ package body MLib.Prj is
-- Compile the binder generated file only if Link is true -- Compile the binder generated file only if Link is true
if Link then if Link then
-- Set the paths -- Set the paths
Set_Ada_Paths Set_Ada_Paths
...@@ -1037,7 +1228,7 @@ package body MLib.Prj is ...@@ -1037,7 +1228,7 @@ package body MLib.Prj is
-- Get the back-end switches and --RTS from the ALI file -- Get the back-end switches and --RTS from the ALI file
if First_ALI /= No_Name then if First_ALI /= No_File then
declare declare
T : Text_Buffer_Ptr; T : Text_Buffer_Ptr;
A : ALI_Id; A : ALI_Id;
...@@ -1136,8 +1327,10 @@ package body MLib.Prj is ...@@ -1136,8 +1327,10 @@ package body MLib.Prj is
end; end;
end if; end if;
Lib_Dirpath := new String'(Get_Name_String (Data.Library_Dir)); Lib_Dirpath :=
Lib_Filename := new String'(Get_Name_String (Data.Library_Name)); new String'(Get_Name_String (Data.Display_Library_Dir));
Lib_Filename :=
new String'(Get_Name_String (Data.Library_Name));
case Data.Library_Kind is case Data.Library_Kind is
when Static => when Static =>
...@@ -1157,7 +1350,7 @@ package body MLib.Prj is ...@@ -1157,7 +1350,7 @@ package body MLib.Prj is
-- Get the library version, if any -- Get the library version, if any
if Data.Lib_Internal_Name /= No_Name then if Data.Lib_Internal_Name /= No_File then
Lib_Version := Lib_Version :=
new String'(Get_Name_String (Data.Lib_Internal_Name)); new String'(Get_Name_String (Data.Lib_Internal_Name));
end if; end if;
...@@ -1165,6 +1358,7 @@ package body MLib.Prj is ...@@ -1165,6 +1358,7 @@ package body MLib.Prj is
-- Add the objects found in the object directory and the object -- Add the objects found in the object directory and the object
-- directories of the extended files, if any, except for generated -- directories of the extended files, if any, except for generated
-- object files (b~.. or B__..) from extended projects. -- object files (b~.. or B__..) from extended projects.
-- When there are one or more extended files, only add an object file -- 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. -- if no object file with the same name have already been added.
...@@ -1173,7 +1367,7 @@ package body MLib.Prj is ...@@ -1173,7 +1367,7 @@ package body MLib.Prj is
loop loop
declare declare
Object_Dir_Path : constant String := Object_Dir_Path : constant String :=
Get_Name_String (Data.Object_Directory); Get_Name_String (Data.Display_Object_Dir);
Object_Dir : Dir_Type; Object_Dir : Dir_Type;
Filename : String (1 .. 255); Filename : String (1 .. 255);
Last : Natural; Last : Natural;
...@@ -1193,24 +1387,28 @@ package body MLib.Prj is ...@@ -1193,24 +1387,28 @@ package body MLib.Prj is
if Is_Obj (Filename (1 .. Last)) then if Is_Obj (Filename (1 .. Last)) then
declare declare
Object_Path : String := Object_Path : constant String :=
Normalize_Pathname Normalize_Pathname
(Object_Dir_Path & Directory_Separator & (Object_Dir_Path & Directory_Separator &
Filename (1 .. Last)); Filename (1 .. Last));
C_Object_Path : String := Object_Path;
C_Filename : String := Filename (1 .. Last);
begin begin
Canonical_Case_File_Name (Object_Path); Canonical_Case_File_Name (C_Object_Path);
Canonical_Case_File_Name (Filename (1 .. Last)); Canonical_Case_File_Name (C_Filename);
-- If in the object directory of an extended project, -- If in the object directory of an extended project,
-- do not consider generated object files. -- do not consider generated object files.
if In_Main_Object_Directory if In_Main_Object_Directory
or else Last < 5 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 then
Name_Len := Last; Name_Len := Last;
Name_Buffer (1 .. Name_Len) := Filename (1 .. Last); Name_Buffer (1 .. Name_Len) :=
C_Filename (1 .. Last);
Id := Name_Find; Id := Name_Find;
if not Objects_Htable.Get (Id) then if not Objects_Htable.Get (Id) then
...@@ -1235,11 +1433,11 @@ package body MLib.Prj is ...@@ -1235,11 +1433,11 @@ package body MLib.Prj is
ALIs.Table (ALIs.Last) := ALIs.Table (ALIs.Last) :=
new String'(ALI_File); new String'(ALI_File);
-- Find out if for this ALI file, -- Find out if for this ALI file, libgnarl
-- libgnarl or libdecgnat or g-trasym.obj -- or libdecgnat or g-trasym.obj (on
-- (on OpenVMS) is necessary. -- OpenVMS) is necessary.
Check_Libs (ALI_File); Check_Libs (ALI_File, True);
else else
-- Object file is a foreign object file -- Object file is a foreign object file
...@@ -1312,7 +1510,7 @@ package body MLib.Prj is ...@@ -1312,7 +1510,7 @@ package body MLib.Prj is
end; end;
end if; end if;
if Libgnarl_Needed then if Libgnarl_Needed = Yes then
Opts.Increment_Last; Opts.Increment_Last;
if The_Build_Mode = Static then if The_Build_Mode = Static then
...@@ -1320,6 +1518,9 @@ package body MLib.Prj is ...@@ -1320,6 +1518,9 @@ package body MLib.Prj is
else else
Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnarl")); Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnarl"));
end if; end if;
else
In_Tree.Projects.Table (For_Project).Libgnarl_Needed := No;
end if; end if;
if Gtrasymobj_Needed then if Gtrasymobj_Needed then
...@@ -1377,8 +1578,8 @@ package body MLib.Prj is ...@@ -1377,8 +1578,8 @@ package body MLib.Prj is
Options := Options :=
new Argument_List'(Argument_List (Opts.Table (1 .. Opts.Last))); new Argument_List'(Argument_List (Opts.Table (1 .. Opts.Last)));
-- We fail if there are no object to put in the library -- We fail if there are no object to put in the library (Ada or
-- (Ada or foreign objects). -- foreign objects).
if Object_Files'Length = 0 then if Object_Files'Length = 0 then
Com.Fail ("no object files for library """ & Com.Fail ("no object files for library """ &
...@@ -1393,8 +1594,7 @@ package body MLib.Prj is ...@@ -1393,8 +1594,7 @@ package body MLib.Prj is
Write_Str (" library for project "); Write_Str (" library for project ");
Write_Line (Project_Name); Write_Line (Project_Name);
-- Only output the list of object files and ALI files in verbose -- Only output list of object files and ALI files in verbose mode
-- mode.
if Opt.Verbose_Mode then if Opt.Verbose_Mode then
Write_Eol; Write_Eol;
...@@ -1428,17 +1628,17 @@ package body MLib.Prj is ...@@ -1428,17 +1628,17 @@ package body MLib.Prj is
Check_Context; Check_Context;
-- Delete the existing library file, if it exists. -- Delete the existing library file, if it exists. Fail if the
-- Fail if the library file is not writable, or if it is not possible -- library file is not writable, or if it is not possible to delete
-- to delete the file. -- the file.
declare declare
DLL_Name : aliased String := DLL_Name : aliased String :=
Lib_Dirpath.all & '/' & DLL_Prefix & Lib_Dirpath.all & Directory_Separator & DLL_Prefix &
Lib_Filename.all & "." & DLL_Ext; Lib_Filename.all & "." & DLL_Ext;
Archive_Name : aliased String := Archive_Name : aliased String :=
Lib_Dirpath.all & "/lib" & Lib_Dirpath.all & Directory_Separator & "lib" &
Lib_Filename.all & "." & Archive_Ext; Lib_Filename.all & "." & Archive_Ext;
type Str_Ptr is access all String; type Str_Ptr is access all String;
...@@ -1482,19 +1682,20 @@ package body MLib.Prj is ...@@ -1482,19 +1682,20 @@ package body MLib.Prj is
Data := In_Tree.Projects.Table (For_Project); Data := In_Tree.Projects.Table (For_Project);
declare declare
Iface : String_List_Id := Data.Lib_Interface_ALIs; Iface : String_List_Id;
ALI : File_Name_Type; ALI : File_Name_Type;
begin begin
Iface := Data.Lib_Interface_ALIs;
while Iface /= Nil_String loop while Iface /= Nil_String loop
ALI := ALI :=
In_Tree.String_Elements.Table (Iface).Value; File_Name_Type
(In_Tree.String_Elements.Table (Iface).Value);
Interface_ALIs.Set (ALI, True); Interface_ALIs.Set (ALI, True);
Get_Name_String Get_Name_String
(In_Tree.String_Elements.Table (Iface).Value); (In_Tree.String_Elements.Table (Iface).Value);
Add_Argument (Name_Buffer (1 .. Name_Len)); Add_Argument (Name_Buffer (1 .. Name_Len));
Iface := Iface := In_Tree.String_Elements.Table (Iface).Next;
In_Tree.String_Elements.Table (Iface).Next;
end loop; end loop;
Iface := Data.Lib_Interface_ALIs; Iface := Data.Lib_Interface_ALIs;
...@@ -1506,11 +1707,11 @@ package body MLib.Prj is ...@@ -1506,11 +1707,11 @@ package body MLib.Prj is
-- interface. If it is not the case, output a warning. -- interface. If it is not the case, output a warning.
while Iface /= Nil_String loop while Iface /= Nil_String loop
ALI := In_Tree.String_Elements.Table ALI :=
(Iface).Value; File_Name_Type
(In_Tree.String_Elements.Table (Iface).Value);
Process (ALI); Process (ALI);
Iface := Iface := In_Tree.String_Elements.Table (Iface).Next;
In_Tree.String_Elements.Table (Iface).Next;
end loop; end loop;
end if; end if;
end; end;
...@@ -1518,20 +1719,15 @@ package body MLib.Prj is ...@@ -1518,20 +1719,15 @@ package body MLib.Prj is
declare declare
Current_Dir : constant String := Get_Current_Dir; Current_Dir : constant String := Get_Current_Dir;
Dir : Dir_Type; DLL_Name : aliased constant String :=
Lib_Filename.all & "." & DLL_Ext;
Name : String (1 .. 200);
Last : Natural;
Disregard : Boolean;
DLL_Name : aliased constant String :=
Lib_Filename.all & "." & DLL_Ext;
Archive_Name : aliased constant String := Archive_Name : aliased constant String :=
Lib_Filename.all & "." & Archive_Ext; Lib_Filename.all & "." & Archive_Ext;
Dir : Dir_Type;
Delete : Boolean := False; Name : String (1 .. 200);
Last : Natural;
Disregard : Boolean;
Delete : Boolean := False;
begin begin
-- Clean the library directory: remove any file with the name of -- Clean the library directory: remove any file with the name of
...@@ -1556,74 +1752,85 @@ package body MLib.Prj is ...@@ -1556,74 +1752,85 @@ package body MLib.Prj is
Read (Dir, Name, Last); Read (Dir, Name, Last);
exit when Last = 0; exit when Last = 0;
if Is_Regular_File (Name (1 .. Last)) then declare
Canonical_Case_File_Name (Name (1 .. Last)); Filename : constant String := 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 begin
declare if Is_Regular_File (Filename) then
Unit : Unit_Data; Canonical_Case_File_Name (Name (1 .. Last));
begin Delete := False;
-- Compare with ALI file names of the project
for Index in 1 .. Unit_Table.Last (In_Tree.Units) loop if (The_Build_Mode = Static and then
Unit := In_Tree.Units.Table (Index); 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 /= elsif Last > 4
No_Project and then Name (Last - 3 .. Last) = ".ali"
then then
if Ultimate_Extension_Of declare
(Unit.File_Names (Body_Part).Project, In_Tree) Unit : Unit_Data;
= For_Project
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 then
Get_Name_String Get_Name_String
(Unit.File_Names (Body_Part).Name); (Unit.File_Names (Specification).Name);
Name_Len := Name_Len - Name_Len := Name_Len -
File_Extension File_Extension
(Name (1 .. Name_Len))'Length; (Name (1 .. Name_Len))'Length;
if Name_Buffer (1 .. Name_Len) = if Name_Buffer (1 .. Name_Len) =
Name (1 .. Last - 4) Name (1 .. Last - 4)
then then
Delete := True; Delete := True;
exit; exit;
end if; end if;
end if; end if;
end loop;
end;
end if;
elsif Ultimate_Extension_Of if Delete then
(Unit.File_Names (Specification).Project, In_Tree) Set_Writable (Filename);
= For_Project Delete_File (Filename, Disregard);
then end if;
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);
end if; end if;
end if; end;
end loop; end loop;
Close (Dir); Close (Dir);
...@@ -1671,14 +1878,15 @@ package body MLib.Prj is ...@@ -1671,14 +1878,15 @@ package body MLib.Prj is
Copy_ALI_Files Copy_ALI_Files
(Files => Ali_Files.all, (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)); Interfaces => Arguments (1 .. Argument_Number));
-- Copy interface sources if Library_Src_Dir specified -- Copy interface sources if Library_Src_Dir specified
if Standalone if Standalone
and then In_Tree.Projects.Table and then In_Tree.Projects.Table
(For_Project).Library_Src_Dir /= No_Name (For_Project).Library_Src_Dir /= No_Path
then then
-- Clean the interface copy directory: remove any source that -- Clean the interface copy directory: remove any source that
-- could be a source of the project. -- could be a source of the project.
...@@ -1697,13 +1905,11 @@ package body MLib.Prj is ...@@ -1697,13 +1905,11 @@ package body MLib.Prj is
end; end;
declare declare
Dir : Dir_Type; Dir : Dir_Type;
Delete : Boolean := False; Delete : Boolean := False;
Unit : Unit_Data; Unit : Unit_Data;
Name : String (1 .. 200);
Name : String (1 .. 200); Last : Natural;
Last : Natural;
Disregard : Boolean; Disregard : Boolean;
begin begin
...@@ -1713,45 +1919,50 @@ package body MLib.Prj is ...@@ -1713,45 +1919,50 @@ package body MLib.Prj is
Read (Dir, Name, Last); Read (Dir, Name, Last);
exit when Last = 0; exit when Last = 0;
if Is_Regular_File (Name (1 .. Last)) then declare
Canonical_Case_File_Name (Name (1 .. Last)); Filename : constant String := Name (1 .. Last);
Delete := False;
-- 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 -- Compare with source file names of the project
Unit := In_Tree.Units.Table (Index);
if Ultimate_Extension_Of for Index in 1 .. Unit_Table.Last (In_Tree.Units) loop
(Unit.File_Names (Body_Part).Project, In_Tree) = Unit := In_Tree.Units.Table (Index);
For_Project
and then
Get_Name_String
(Unit.File_Names (Body_Part).Name) =
Name (1 .. Last)
then
Delete := True;
exit;
end if;
if Ultimate_Extension_Of if Ultimate_Extension_Of
(Unit.File_Names (Specification).Project, In_Tree) = (Unit.File_Names (Body_Part).Project, In_Tree) =
For_Project For_Project
and then and then
Get_Name_String Get_Name_String
(Unit.File_Names (Specification).Name) = (Unit.File_Names (Body_Part).Name) =
Name (1 .. Last) Name (1 .. Last)
then then
Delete := True; Delete := True;
exit; exit;
end if; end if;
end loop;
end if;
if Delete then if Ultimate_Extension_Of
Set_Writable (Name (1 .. Last)); (Unit.File_Names
Delete_File (Name (1 .. Last), Disregard); (Specification).Project, In_Tree) = For_Project
end if; 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; end loop;
Close (Dir); Close (Dir);
...@@ -1762,7 +1973,7 @@ package body MLib.Prj is ...@@ -1762,7 +1973,7 @@ package body MLib.Prj is
In_Tree => In_Tree, In_Tree => In_Tree,
Interfaces => Arguments (1 .. Argument_Number), Interfaces => Arguments (1 .. Argument_Number),
To_Dir => In_Tree.Projects.Table To_Dir => In_Tree.Projects.Table
(For_Project).Library_Src_Dir); (For_Project).Display_Library_Src_Dir);
end if; end if;
end if; end if;
...@@ -1800,7 +2011,8 @@ package body MLib.Prj is ...@@ -1800,7 +2011,8 @@ package body MLib.Prj is
------------------- -------------------
procedure Check_Library procedure Check_Library
(For_Project : Project_Id; In_Tree : Project_Tree_Ref) (For_Project : Project_Id;
In_Tree : Project_Tree_Ref)
is is
Data : constant Project_Data := Data : constant Project_Data :=
In_Tree.Projects.Table (For_Project); In_Tree.Projects.Table (For_Project);
...@@ -1813,8 +2025,8 @@ package body MLib.Prj is ...@@ -1813,8 +2025,8 @@ package body MLib.Prj is
if Data.Library then if Data.Library then
declare declare
Lib_Name : constant Name_Id := Lib_Name : constant File_Name_Type :=
Library_File_Name_For (For_Project, In_Tree); Library_File_Name_For (For_Project, In_Tree);
begin begin
Change_Dir (Get_Name_String (Data.Library_Dir)); Change_Dir (Get_Name_String (Data.Library_Dir));
Lib_TS := File_Stamp (Lib_Name); Lib_TS := File_Stamp (Lib_Name);
...@@ -1823,7 +2035,7 @@ package body MLib.Prj is ...@@ -1823,7 +2035,7 @@ package body MLib.Prj is
if not Data.Externally_Built if not Data.Externally_Built
and then not Data.Need_To_Build_Lib and then not Data.Need_To_Build_Lib
and then Data.Object_Directory /= No_Name and then Data.Object_Directory /= No_Path
then then
declare declare
Obj_TS : Time_Stamp_Type; Obj_TS : Time_Stamp_Type;
...@@ -1854,7 +2066,7 @@ package body MLib.Prj is ...@@ -1854,7 +2066,7 @@ package body MLib.Prj is
then then
-- Get the object file time stamp -- 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 -- If library file time stamp is earlier, set
-- Need_To_Build_Lib and return. String comparaison is -- Need_To_Build_Lib and return. String comparaison is
...@@ -1889,7 +2101,7 @@ package body MLib.Prj is ...@@ -1889,7 +2101,7 @@ package body MLib.Prj is
(For_Project : Project_Id; (For_Project : Project_Id;
In_Tree : Project_Tree_Ref; In_Tree : Project_Tree_Ref;
Interfaces : Argument_List; Interfaces : Argument_List;
To_Dir : Name_Id) To_Dir : Path_Name_Type)
is is
Current : constant Dir_Name_Str := Get_Current_Dir; Current : constant Dir_Name_Str := Get_Current_Dir;
-- The current directory, where to return to at the end -- The current directory, where to return to at the end
...@@ -1899,7 +2111,7 @@ package body MLib.Prj is ...@@ -1899,7 +2111,7 @@ package body MLib.Prj is
Text : Text_Buffer_Ptr; Text : Text_Buffer_Ptr;
The_ALI : ALI.ALI_Id; The_ALI : ALI.ALI_Id;
Lib_File : Name_Id; Lib_File : File_Name_Type;
First_Unit : ALI.Unit_Id; First_Unit : ALI.Unit_Id;
Second_Unit : ALI.Unit_Id; Second_Unit : ALI.Unit_Id;
...@@ -1909,7 +2121,7 @@ package body MLib.Prj is ...@@ -1909,7 +2121,7 @@ package body MLib.Prj is
Copy_Subunits : Boolean := False; Copy_Subunits : Boolean := False;
-- When True, indicates that subunits, if any, need to be copied too -- 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 -- Copy one source of the project to the target directory
function Is_Same_Or_Extension function Is_Same_Or_Extension
...@@ -1922,7 +2134,7 @@ package body MLib.Prj is ...@@ -1922,7 +2134,7 @@ package body MLib.Prj is
-- Copy -- -- Copy --
---------- ----------
procedure Copy (File_Name : Name_Id) is procedure Copy (File_Name : File_Name_Type) is
Success : Boolean := False; Success : Boolean := False;
begin begin
......
gcc/ada/mlib-prj.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -47,7 +47,8 @@ package MLib.Prj is ...@@ -47,7 +47,8 @@ package MLib.Prj is
-- If Link is False, the library is not linked/built. -- If Link is False, the library is not linked/built.
procedure Check_Library 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, -- 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 -- because its time-stamp is earlier than the time stamp of one of its
-- object files. -- 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