1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2000-2006, 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 ------------------------------------------------------------------------------
28 with Makeutl; use Makeutl;
29 with Namet; use Namet;
30 with Output; use Output;
31 with Osint; use Osint;
36 package body Prj.Ext is
38 Gpr_Project_Path : constant String := "GPR_PROJECT_PATH";
39 Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
40 -- Name of the env. variables that contain path name(s) of directories
41 -- where project files may reside. GPR_PROJECT_PATH has precedence over
44 Gpr_Prj_Path : constant String_Access := Getenv (Gpr_Project_Path);
45 Ada_Prj_Path : constant String_Access := Getenv (Ada_Project_Path);
46 -- The path name(s) of directories where project files may reside.
49 No_Project_Default_Dir : constant String := "-";
51 Current_Project_Path : String_Access;
52 -- The project path. Initialized by procedure Initialize_Project_Path
55 procedure Initialize_Project_Path;
56 -- Initialize Current_Project_Path
58 package Htable is new GNAT.HTable.Simple_HTable
59 (Header_Num => Header_Num,
61 No_Element => No_Name,
65 -- External references are stored in this hash table, either by procedure
66 -- Add (directly or through a call to function Check) or by function
67 -- Value_Of when an environment variable is found non empty. Value_Of
68 -- first for external reference in this table, before checking the
69 -- environment. Htable is emptied (reset) by procedure Reset.
76 (External_Name : String;
82 Name_Len := Value'Length;
83 Name_Buffer (1 .. Name_Len) := Value;
84 The_Value := Name_Find;
85 Name_Len := External_Name'Length;
86 Name_Buffer (1 .. Name_Len) := External_Name;
87 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
89 Htable.Set (The_Key, The_Value);
96 function Check (Declaration : String) return Boolean is
98 for Equal_Pos in Declaration'Range loop
99 if Declaration (Equal_Pos) = '=' then
100 exit when Equal_Pos = Declaration'First;
101 exit when Equal_Pos = Declaration'Last;
104 Declaration (Declaration'First .. Equal_Pos - 1),
106 Declaration (Equal_Pos + 1 .. Declaration'Last));
114 -----------------------------
115 -- Initialize_Project_Path --
116 -----------------------------
118 procedure Initialize_Project_Path is
119 Add_Default_Dir : Boolean := True;
124 Prj_Path : String_Access := Gpr_Prj_Path;
127 if Gpr_Prj_Path.all /= "" then
129 -- Warn if both environment variables are defined
131 if Ada_Prj_Path.all /= "" then
132 Write_Line ("Warning: ADA_PROJECT_PATH is not taken into account");
133 Write_Line (" when GPR_PROJECT_PATH is defined");
137 Prj_Path := Ada_Prj_Path;
140 -- The current directory is always first
143 Name_Buffer (Name_Len) := '.';
145 -- If environment variable is defined and not empty, add its content
147 if Prj_Path.all /= "" then
148 Name_Len := Name_Len + 1;
149 Name_Buffer (Name_Len) := Path_Separator;
151 Add_Str_To_Name_Buffer (Prj_Path.all);
153 -- Scan the directory path to see if "-" is one of the directories.
154 -- Remove each occurence of "-" and set Add_Default_Dir to False.
155 -- Also resolve relative paths and symbolic links.
159 while First <= Name_Len
160 and then (Name_Buffer (First) = Path_Separator)
165 exit when First > Name_Len;
169 while Last < Name_Len
170 and then Name_Buffer (Last + 1) /= Path_Separator
175 -- If the directory is "-", set Add_Default_Dir to False and
178 if Name_Buffer (First .. Last) = No_Project_Default_Dir then
179 Add_Default_Dir := False;
181 for J in Last + 1 .. Name_Len loop
182 Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
186 Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
188 elsif not Hostparm.OpenVMS
189 or else not Is_Absolute_Path (Name_Buffer (First .. Last))
191 -- On VMS, only expand relative path names, as absolute paths
192 -- may correspond to multi-valued VMS logical names.
195 New_Dir : constant String :=
196 Normalize_Pathname (Name_Buffer (First .. Last));
199 -- If the absolute path was resolved and is different from
200 -- the original, replace original with the resolved path.
202 if New_Dir /= Name_Buffer (First .. Last)
203 and then New_Dir'Length /= 0
205 New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
206 New_Last := First + New_Dir'Length - 1;
207 Name_Buffer (New_Last + 1 .. New_Len) :=
208 Name_Buffer (Last + 1 .. Name_Len);
209 Name_Buffer (First .. New_Last) := New_Dir;
220 -- Set the initial value of Current_Project_Path
222 if Add_Default_Dir then
224 Prefix : String_Ptr := Sdefault.Search_Dir_Prefix;
226 if Prefix = null then
227 Prefix := new String'(Executable_Prefix_Path);
229 if Prefix.all /= "" then
230 Current_Project_Path :=
231 new String'(Name_Buffer (1 .. Name_Len) & Path_Separator &
232 Prefix.all & Directory_Separator & "gnat");
236 Current_Project_Path :=
237 new String'(Name_Buffer (1 .. Name_Len) & Path_Separator &
239 ".." & Directory_Separator &
240 ".." & Directory_Separator &
241 ".." & Directory_Separator & "gnat");
245 Current_Project_Path := new String'(Name_Buffer (1 .. Name_Len));
247 end Initialize_Project_Path;
253 function Project_Path return String is
255 if Current_Project_Path = null then
256 Initialize_Project_Path;
259 return Current_Project_Path.all;
271 ----------------------
272 -- Set_Project_Path --
273 ----------------------
275 procedure Set_Project_Path (New_Path : String) is
277 Free (Current_Project_Path);
278 Current_Project_Path := new String'(New_Path);
279 end Set_Project_Path;
286 (External_Name : Name_Id;
287 With_Default : Name_Id := No_Name)
291 Name : String := Get_Name_String (External_Name);
294 Canonical_Case_File_Name (Name);
295 Name_Len := Name'Length;
296 Name_Buffer (1 .. Name_Len) := Name;
297 The_Value := Htable.Get (Name_Find);
299 if The_Value /= No_Name then
303 -- Find if it is an environment, if it is, put value in the hash table
306 Env_Value : String_Access := Getenv (Name);
309 if Env_Value /= null and then Env_Value'Length > 0 then
310 Name_Len := Env_Value'Length;
311 Name_Buffer (1 .. Name_Len) := Env_Value.all;
312 The_Value := Name_Find;
313 Htable.Set (External_Name, The_Value);