1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2000-2007, 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 Output; use Output;
30 with Osint; use Osint;
35 package body Prj.Ext is
37 Gpr_Project_Path : constant String := "GPR_PROJECT_PATH";
38 Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
39 -- Name of the env. variables that contain path name(s) of directories
40 -- where project files may reside. GPR_PROJECT_PATH has precedence over
43 Gpr_Prj_Path : constant String_Access := Getenv (Gpr_Project_Path);
44 Ada_Prj_Path : constant String_Access := Getenv (Ada_Project_Path);
45 -- The path name(s) of directories where project files may reside.
48 No_Project_Default_Dir : constant String := "-";
50 Current_Project_Path : String_Access;
51 -- The project path. Initialized by procedure Initialize_Project_Path
54 procedure Initialize_Project_Path;
55 -- Initialize Current_Project_Path
57 package Htable is new GNAT.HTable.Simple_HTable
58 (Header_Num => Header_Num,
60 No_Element => No_Name,
64 -- External references are stored in this hash table, either by procedure
65 -- Add (directly or through a call to function Check) or by function
66 -- Value_Of when an environment variable is found non empty. Value_Of
67 -- first for external reference in this table, before checking the
68 -- environment. Htable is emptied (reset) by procedure Reset.
70 package Search_Directories is new Table.Table
71 (Table_Component_Type => Name_Id,
72 Table_Index_Type => Natural,
75 Table_Increment => 100,
76 Table_Name => "Prj.Ext.Search_Directories");
77 -- The table for the directories specified with -aP switches
84 (External_Name : String;
90 Name_Len := Value'Length;
91 Name_Buffer (1 .. Name_Len) := Value;
92 The_Value := Name_Find;
93 Name_Len := External_Name'Length;
94 Name_Buffer (1 .. Name_Len) := External_Name;
95 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
97 Htable.Set (The_Key, The_Value);
100 ----------------------------------
101 -- Add_Search_Project_Directory --
102 ----------------------------------
104 procedure Add_Search_Project_Directory (Path : String) is
107 Add_Str_To_Name_Buffer (Path);
108 Search_Directories.Append (Name_Find);
109 end Add_Search_Project_Directory;
115 function Check (Declaration : String) return Boolean is
117 for Equal_Pos in Declaration'Range loop
118 if Declaration (Equal_Pos) = '=' then
119 exit when Equal_Pos = Declaration'First;
120 exit when Equal_Pos = Declaration'Last;
123 Declaration (Declaration'First .. Equal_Pos - 1),
125 Declaration (Equal_Pos + 1 .. Declaration'Last));
133 -----------------------------
134 -- Initialize_Project_Path --
135 -----------------------------
137 procedure Initialize_Project_Path is
138 Add_Default_Dir : Boolean := True;
143 Prj_Path : String_Access := null;
146 if Gpr_Prj_Path.all /= "" then
147 if Hostparm.OpenVMS then
148 Prj_Path := To_Canonical_Path_Spec ("GPR_PROJECT_PATH:");
150 Prj_Path := To_Canonical_Path_Spec (Gpr_Prj_Path.all);
153 -- Warn if both environment variables are defined
155 if Ada_Prj_Path.all /= "" then
156 Write_Line ("Warning: ADA_PROJECT_PATH is not taken into account");
157 Write_Line (" when GPR_PROJECT_PATH is defined");
160 elsif Ada_Prj_Path.all /= "" then
161 if Hostparm.OpenVMS then
162 Prj_Path := To_Canonical_Path_Spec ("ADA_PROJECT_PATH:");
164 Prj_Path := To_Canonical_Path_Spec (Ada_Prj_Path.all);
168 -- The current directory is always first
171 Name_Buffer (Name_Len) := '.';
173 -- If there are directories in the Search_Directories table, add them
175 for J in 1 .. Search_Directories.Last loop
176 Name_Len := Name_Len + 1;
177 Name_Buffer (Name_Len) := Path_Separator;
178 Add_Str_To_Name_Buffer
179 (Get_Name_String (Search_Directories.Table (J)));
182 -- If environment variable is defined, add its content
184 if Prj_Path /= null then
185 Name_Len := Name_Len + 1;
186 Name_Buffer (Name_Len) := Path_Separator;
188 Add_Str_To_Name_Buffer (Prj_Path.all);
191 -- Scan the directory path to see if "-" is one of the directories.
192 -- Remove each occurence of "-" and set Add_Default_Dir to False.
193 -- Also resolve relative paths and symbolic links.
197 while First <= Name_Len
198 and then (Name_Buffer (First) = Path_Separator)
203 exit when First > Name_Len;
207 while Last < Name_Len
208 and then Name_Buffer (Last + 1) /= Path_Separator
213 -- If the directory is "-", set Add_Default_Dir to False and
216 if Name_Buffer (First .. Last) = No_Project_Default_Dir then
217 Add_Default_Dir := False;
219 for J in Last + 1 .. Name_Len loop
220 Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
224 Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
226 elsif not Hostparm.OpenVMS
227 or else not Is_Absolute_Path (Name_Buffer (First .. Last))
229 -- On VMS, only expand relative path names, as absolute paths
230 -- may correspond to multi-valued VMS logical names.
233 New_Dir : constant String :=
234 Normalize_Pathname (Name_Buffer (First .. Last));
237 -- If the absolute path was resolved and is different from
238 -- the original, replace original with the resolved path.
240 if New_Dir /= Name_Buffer (First .. Last)
241 and then New_Dir'Length /= 0
243 New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
244 New_Last := First + New_Dir'Length - 1;
245 Name_Buffer (New_Last + 1 .. New_Len) :=
246 Name_Buffer (Last + 1 .. Name_Len);
247 Name_Buffer (First .. New_Last) := New_Dir;
257 -- Set the initial value of Current_Project_Path
259 if Add_Default_Dir then
261 Prefix : String_Ptr := Sdefault.Search_Dir_Prefix;
263 if Prefix = null then
264 Prefix := new String'(Executable_Prefix_Path);
266 if Prefix.all /= "" then
267 Current_Project_Path :=
268 new String'(Name_Buffer (1 .. Name_Len) & Path_Separator &
269 Prefix.all & Directory_Separator & "gnat");
273 Current_Project_Path :=
274 new String'(Name_Buffer (1 .. Name_Len) & Path_Separator &
276 ".." & Directory_Separator &
277 ".." & Directory_Separator &
278 ".." & Directory_Separator & "gnat");
282 Current_Project_Path := new String'(Name_Buffer (1 .. Name_Len));
284 end Initialize_Project_Path;
290 function Project_Path return String is
292 if Current_Project_Path = null then
293 Initialize_Project_Path;
296 return Current_Project_Path.all;
308 ----------------------
309 -- Set_Project_Path --
310 ----------------------
312 procedure Set_Project_Path (New_Path : String) is
314 Free (Current_Project_Path);
315 Current_Project_Path := new String'(New_Path);
316 end Set_Project_Path;
323 (External_Name : Name_Id;
324 With_Default : Name_Id := No_Name)
328 Name : String := Get_Name_String (External_Name);
331 Canonical_Case_File_Name (Name);
332 Name_Len := Name'Length;
333 Name_Buffer (1 .. Name_Len) := Name;
334 The_Value := Htable.Get (Name_Find);
336 if The_Value /= No_Name then
340 -- Find if it is an environment, if it is, put value in the hash table
343 Env_Value : String_Access := Getenv (Name);
346 if Env_Value /= null and then Env_Value'Length > 0 then
347 Name_Len := Env_Value'Length;
348 Name_Buffer (1 .. Name_Len) := Env_Value.all;
349 The_Value := Name_Find;
350 Htable.Set (External_Name, The_Value);