1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2000-2005 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Namet
; use Namet
;
28 with Osint
; use Osint
;
32 package body Prj
.Ext
is
34 Ada_Project_Path
: constant String := "ADA_PROJECT_PATH";
35 -- Name of the env. variable that contains path name(s) of directories
36 -- where project files may reside.
38 Prj_Path
: constant String_Access
:= Getenv
(Ada_Project_Path
);
39 -- The path name(s) of directories where project files may reside.
42 No_Project_Default_Dir
: constant String := "-";
44 Current_Project_Path
: String_Access
;
45 -- The project path; initialized during elaboration of package
46 -- Contains at least the current working directory.
48 package Htable
is new GNAT
.HTable
.Simple_HTable
49 (Header_Num
=> Header_Num
,
51 No_Element
=> No_Name
,
55 -- External references are stored in this hash table, either by procedure
56 -- Add (directly or through a call to function Check) or by function
57 -- Value_Of when an environment variable is found non empty. Value_Of
58 -- first for external reference in this table, before checking the
59 -- environment. Htable is emptied (reset) by procedure Reset.
66 (External_Name
: String;
73 Name_Len
:= Value
'Length;
74 Name_Buffer
(1 .. Name_Len
) := Value
;
75 The_Value
:= Name_Find
;
76 Name_Len
:= External_Name
'Length;
77 Name_Buffer
(1 .. Name_Len
) := External_Name
;
78 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
80 Htable
.Set
(The_Key
, The_Value
);
87 function Check
(Declaration
: String) return Boolean is
89 for Equal_Pos
in Declaration
'Range loop
90 if Declaration
(Equal_Pos
) = '=' then
91 exit when Equal_Pos
= Declaration
'First;
92 exit when Equal_Pos
= Declaration
'Last;
95 Declaration
(Declaration
'First .. Equal_Pos
- 1),
97 Declaration
(Equal_Pos
+ 1 .. Declaration
'Last));
109 function Project_Path
return String is
111 return Current_Project_Path
.all;
123 ----------------------
124 -- Set_Project_Path --
125 ----------------------
127 procedure Set_Project_Path
(New_Path
: String) is
129 Free
(Current_Project_Path
);
130 Current_Project_Path
:= new String'(New_Path);
131 end Set_Project_Path;
138 (External_Name : Name_Id;
139 With_Default : Name_Id := No_Name)
143 Name : String := Get_Name_String (External_Name);
146 Canonical_Case_File_Name (Name);
147 Name_Len := Name'Length;
148 Name_Buffer (1 .. Name_Len) := Name;
149 The_Value := Htable.Get (Name_Find);
151 if The_Value /= No_Name then
155 -- Find if it is an environment.
156 -- If it is, put the value in the hash table.
159 Env_Value : String_Access := Getenv (Name);
162 if Env_Value /= null and then Env_Value'Length > 0 then
163 Name_Len := Env_Value'Length;
164 Name_Buffer (1 .. Name_Len) := Env_Value.all;
165 The_Value := Name_Find;
166 Htable.Set (External_Name, The_Value);
178 -- Initialize Current_Project_Path during package elaboration
181 Add_Default_Dir : Boolean := True;
186 -- The current directory is always first
189 Name_Buffer (Name_Len) := '.';
191 -- If env. var. is defined and not empty, add its content
193 if Prj_Path.all /= "" then
194 Name_Len := Name_Len + 1;
195 Name_Buffer (Name_Len) := Path_Separator;
197 Add_Str_To_Name_Buffer (Prj_Path.all);
199 -- Scan the directory path to see if "-" is one of the directories.
200 -- Remove each occurence of "-" and set Add_Default_Dir to False.
204 while First <= Name_Len
205 and then (Name_Buffer (First) = Path_Separator)
210 exit when First > Name_Len;
214 while Last < Name_Len
215 and then Name_Buffer (Last + 1) /= Path_Separator
220 -- If the directory is "-", set Add_Default_Dir to False and
223 if Name_Buffer (First .. Last) = No_Project_Default_Dir then
224 Add_Default_Dir := False;
226 for J in Last + 1 .. Name_Len loop
227 Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
231 Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
238 -- Set the initial value of Current_Project_Path
240 if Add_Default_Dir then
241 Current_Project_Path :=
242 new String'(Name_Buffer
(1 .. Name_Len
) & Path_Separator
&
243 Sdefault
.Search_Dir_Prefix
.all & ".." &
244 Directory_Separator
& ".." & Directory_Separator
&
245 ".." & Directory_Separator
& "gnat");
247 Current_Project_Path
:= new String'(Name_Buffer (1 .. Name_Len));