-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
-- --
------------------------------------------------------------------------------
+with Alloc;
+with Debug;
+with Fmap; use Fmap;
+with Gnatvsn; use Gnatvsn;
+with Hostparm;
+with Opt; use Opt;
+with Output; use Output;
+with Sdefault; use Sdefault;
+with Table;
+with Targparm; use Targparm;
+
with Unchecked_Conversion;
+pragma Warnings (Off);
+-- This package is used also by gnatcoll
with System.Case_Util; use System.Case_Util;
+pragma Warnings (On);
with GNAT.HTable;
-with Alloc;
-with Debug;
-with Fmap; use Fmap;
-with Gnatvsn; use Gnatvsn;
-with Hostparm;
-with Opt; use Opt;
-with Output; use Output;
-with Sdefault; use Sdefault;
-with Table;
-with Targparm; use Targparm;
-
package body Osint is
Running_Program : Program_Type := Unspecified;
end loop;
end if;
- if not Opt.No_Stdlib and not Opt.RTS_Switch then
+ -- Even when -nostdlib is used, we still want to have visibility on
+ -- the run-time object directory, as it is used by gnatbind to find
+ -- the run-time ALI files in "real" ZFP set up.
+
+ if not Opt.RTS_Switch then
Search_Path :=
Read_Default_Search_Dirs
(String_Access (Update_Path (Search_Dir_Prefix)),
-- Canonical_Case_File_Name --
------------------------------
- -- For now, we only deal with the case of a-z. Eventually we should
- -- worry about other Latin-1 letters on systems that support this ???
-
procedure Canonical_Case_File_Name (S : in out String) is
begin
if not File_Names_Case_Sensitive then
- for J in S'Range loop
- if S (J) in 'A' .. 'Z' then
- S (J) := Character'Val (
- Character'Pos (S (J)) +
- Character'Pos ('a') -
- Character'Pos ('A'));
- end if;
- end loop;
+ To_Lower (S);
end if;
end Canonical_Case_File_Name;
+ ---------------------------------
+ -- Canonical_Case_Env_Var_Name --
+ ---------------------------------
+
+ procedure Canonical_Case_Env_Var_Name (S : in out String) is
+ begin
+ if not Env_Vars_Case_Sensitive then
+ To_Lower (S);
+ end if;
+ end Canonical_Case_Env_Var_Name;
+
---------------------------
-- Create_File_And_Check --
---------------------------
-- Executable_Name --
---------------------
- function Executable_Name (Name : File_Name_Type) return File_Name_Type is
+ function Executable_Name
+ (Name : File_Name_Type;
+ Only_If_No_Suffix : Boolean := False) return File_Name_Type
+ is
Exec_Suffix : String_Access;
+ Add_Suffix : Boolean;
begin
if Name = No_File then
Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
end if;
- Get_Name_String (Name);
-
if Exec_Suffix'Length /= 0 then
- declare
- Buffer : String := Name_Buffer (1 .. Name_Len);
-
- begin
- -- Get the file name in canonical case to accept as is names
- -- ending with ".EXE" on VMS and Windows.
-
- Canonical_Case_File_Name (Buffer);
+ Get_Name_String (Name);
+
+ Add_Suffix := True;
+ if Only_If_No_Suffix then
+ for J in reverse 1 .. Name_Len loop
+ if Name_Buffer (J) = '.' then
+ Add_Suffix := False;
+ exit;
+
+ elsif Name_Buffer (J) = '/' or else
+ Name_Buffer (J) = Directory_Separator
+ then
+ exit;
+ end if;
+ end loop;
+ end if;
- -- If Executable does not end with the executable suffix, add it
+ if Add_Suffix then
+ declare
+ Buffer : String := Name_Buffer (1 .. Name_Len);
- if Buffer'Length <= Exec_Suffix'Length
- or else
- Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last)
- /= Exec_Suffix.all
- then
- Name_Buffer (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
- Exec_Suffix.all;
- Name_Len := Name_Len + Exec_Suffix'Length;
- Free (Exec_Suffix);
- return Name_Find;
- end if;
- end;
+ begin
+ -- Get the file name in canonical case to accept as is names
+ -- ending with ".EXE" on VMS and Windows.
+
+ Canonical_Case_File_Name (Buffer);
+
+ -- If Executable does not end with the executable suffix, add
+ -- it.
+
+ if Buffer'Length <= Exec_Suffix'Length
+ or else
+ Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last)
+ /= Exec_Suffix.all
+ then
+ Name_Buffer
+ (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
+ Exec_Suffix.all;
+ Name_Len := Name_Len + Exec_Suffix'Length;
+ Free (Exec_Suffix);
+ return Name_Find;
+ end if;
+ end;
+ end if;
end if;
Free (Exec_Suffix);
return Name;
end Executable_Name;
- function Executable_Name (Name : String) return String is
+ function Executable_Name
+ (Name : String;
+ Only_If_No_Suffix : Boolean := False) return String
+ is
Exec_Suffix : String_Access;
+ Add_Suffix : Boolean;
Canonical_Name : String := Name;
begin
Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
end if;
- declare
- Suffix : constant String := Exec_Suffix.all;
-
- begin
+ if Exec_Suffix'Length = 0 then
Free (Exec_Suffix);
- Canonical_Case_File_Name (Canonical_Name);
+ return Name;
+
+ else
+ declare
+ Suffix : constant String := Exec_Suffix.all;
- if Suffix'Length /= 0
- and then
- (Canonical_Name'Length <= Suffix'Length
+ begin
+ Free (Exec_Suffix);
+ Canonical_Case_File_Name (Canonical_Name);
+
+ Add_Suffix := True;
+ if Only_If_No_Suffix then
+ for J in reverse Canonical_Name'Range loop
+ if Canonical_Name (J) = '.' then
+ Add_Suffix := False;
+ exit;
+
+ elsif Canonical_Name (J) = '/' or else
+ Canonical_Name (J) = Directory_Separator
+ then
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ if Add_Suffix and then
+ (Canonical_Name'Length <= Suffix'Length
or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
- .. Canonical_Name'Last) /= Suffix)
- then
- declare
- Result : String (1 .. Name'Length + Suffix'Length);
- begin
- Result (1 .. Name'Length) := Name;
- Result (Name'Length + 1 .. Result'Last) := Suffix;
- return Result;
- end;
- else
- return Name;
- end if;
- end;
+ .. Canonical_Name'Last) /= Suffix)
+ then
+ declare
+ Result : String (1 .. Name'Length + Suffix'Length);
+ begin
+ Result (1 .. Name'Length) := Name;
+ Result (Name'Length + 1 .. Result'Last) := Suffix;
+ return Result;
+ end;
+ else
+ return Name;
+ end if;
+ end;
+ end if;
end Executable_Name;
-----------------------
return Internal (Name, Attr.all'Address);
end File_Time_Stamp;
+ function File_Time_Stamp
+ (Name : Path_Name_Type;
+ Attr : access File_Attributes) return Time_Stamp_Type
+ is
+ begin
+ if Name = No_Path then
+ return Empty_Time_Stamp;
+ end if;
+
+ Get_Name_String (Name);
+ Name_Buffer (Name_Len + 1) := ASCII.NUL;
+ return OS_Time_To_GNAT_Time
+ (File_Time_Stamp (Name_Buffer'Address, Attr));
+ end File_Time_Stamp;
+
----------------
-- File_Stamp --
----------------
begin
-- If we are looking for a config file, look only in the current
-- directory, i.e. return input argument unchanged. Also look only in
- -- the curren directory if we are looking for a .dg file (happens in
+ -- the current directory if we are looking for a .dg file (happens in
-- -gnatD mode).
if T = Config
return null;
end if;
+
+ elsif Current_Full_Obj_Stamp < Current_Full_Lib_Stamp then
+ Close (Lib_FD, Status);
+
+ -- No need to check the status, we return null anyway
+
+ return null;
end if;
end if;
OSDN Git Service
