1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2000-2009, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
27 with Makeutl; use Makeutl;
28 with Osint; use Osint;
34 package body Prj.Ext is
36 Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
37 -- Name of alternate env. variable that contain path name(s) of directories
38 -- where project files may reside. GPR_PROJECT_PATH has precedence over
41 Gpr_Prj_Path : constant String_Access := Getenv (Gpr_Project_Path);
42 Ada_Prj_Path : constant String_Access := Getenv (Ada_Project_Path);
43 -- The path name(s) of directories where project files may reside.
46 No_Project_Default_Dir : constant String := "-";
48 Current_Project_Path : String_Access;
49 -- The project path. Initialized by procedure Initialize_Project_Path
52 procedure Initialize_Project_Path;
53 -- Initialize Current_Project_Path
55 package Htable is new GNAT.HTable.Simple_HTable
56 (Header_Num => Header_Num,
58 No_Element => No_Name,
62 -- External references are stored in this hash table, either by procedure
63 -- Add (directly or through a call to function Check) or by function
64 -- Value_Of when an environment variable is found non empty. Value_Of
65 -- first for external reference in this table, before checking the
66 -- environment. Htable is emptied (reset) by procedure Reset.
68 package Search_Directories is new Table.Table
69 (Table_Component_Type => Name_Id,
70 Table_Index_Type => Natural,
73 Table_Increment => 100,
74 Table_Name => "Prj.Ext.Search_Directories");
75 -- The table for the directories specified with -aP switches
82 (External_Name : String;
88 Name_Len := Value'Length;
89 Name_Buffer (1 .. Name_Len) := Value;
90 The_Value := Name_Find;
91 Name_Len := External_Name'Length;
92 Name_Buffer (1 .. Name_Len) := External_Name;
93 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
95 Htable.Set (The_Key, The_Value);
99 ----------------------------------
100 -- Add_Search_Project_Directory --
101 ----------------------------------
103 procedure Add_Search_Project_Directory (Path : String) is
106 Add_Str_To_Name_Buffer (Path);
107 Search_Directories.Append (Name_Find);
108 end Add_Search_Project_Directory;
113 function Check (Declaration : String) return Boolean is
115 for Equal_Pos in Declaration'Range loop
116 if Declaration (Equal_Pos) = '=' then
117 exit when Equal_Pos = Declaration'First;
118 exit when Equal_Pos = Declaration'Last;
121 Declaration (Declaration'First .. Equal_Pos - 1),
123 Declaration (Equal_Pos + 1 .. Declaration'Last));
131 -----------------------------
132 -- Initialize_Project_Path --
133 -----------------------------
135 procedure Initialize_Project_Path is
136 Add_Default_Dir : Boolean := True;
143 -- The current directory is always first
146 Name_Buffer (Name_Len) := '.';
148 -- If there are directories in the Search_Directories table, add them
150 for J in 1 .. Search_Directories.Last loop
151 Name_Len := Name_Len + 1;
152 Name_Buffer (Name_Len) := Path_Separator;
153 Add_Str_To_Name_Buffer
154 (Get_Name_String (Search_Directories.Table (J)));
157 -- If environment variable is defined and not empty, add its content
159 if Gpr_Prj_Path.all /= "" then
160 Name_Len := Name_Len + 1;
161 Name_Buffer (Name_Len) := Path_Separator;
162 Add_Str_To_Name_Buffer (Gpr_Prj_Path.all);
165 if Ada_Prj_Path.all /= "" then
166 Name_Len := Name_Len + 1;
167 Name_Buffer (Name_Len) := Path_Separator;
168 Add_Str_To_Name_Buffer (Ada_Prj_Path.all);
171 -- Scan the directory path to see if "-" is one of the directories.
172 -- Remove each occurrence of "-" and set Add_Default_Dir to False.
173 -- Also resolve relative paths and symbolic links.
177 while First <= Name_Len
178 and then (Name_Buffer (First) = Path_Separator)
183 exit when First > Name_Len;
187 while Last < Name_Len
188 and then Name_Buffer (Last + 1) /= Path_Separator
193 -- If the directory is "-", set Add_Default_Dir to False and
196 if Name_Buffer (First .. Last) = No_Project_Default_Dir then
197 Add_Default_Dir := False;
199 for J in Last + 1 .. Name_Len loop
200 Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
204 Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
206 -- After removing the '-', go back one character to get the next
207 -- directory correctly.
211 elsif not Hostparm.OpenVMS
212 or else not Is_Absolute_Path (Name_Buffer (First .. Last))
214 -- On VMS, only expand relative path names, as absolute paths
215 -- may correspond to multi-valued VMS logical names.
218 New_Dir : constant String :=
219 Normalize_Pathname (Name_Buffer (First .. Last));
222 -- If the absolute path was resolved and is different from
223 -- the original, replace original with the resolved path.
225 if New_Dir /= Name_Buffer (First .. Last)
226 and then New_Dir'Length /= 0
228 New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
229 New_Last := First + New_Dir'Length - 1;
230 Name_Buffer (New_Last + 1 .. New_Len) :=
231 Name_Buffer (Last + 1 .. Name_Len);
232 Name_Buffer (First .. New_Last) := New_Dir;
242 -- Set the initial value of Current_Project_Path
244 if Add_Default_Dir then
246 Prefix : String_Ptr := Sdefault.Search_Dir_Prefix;
249 if Prefix = null then
250 Prefix := new String'(Executable_Prefix_Path);
252 if Prefix.all /= "" then
253 Add_Str_To_Name_Buffer
254 (Path_Separator & Prefix.all &
255 "share" & Directory_Separator & "gpr");
256 Add_Str_To_Name_Buffer
257 (Path_Separator & Prefix.all &
258 Directory_Separator & "lib" &
259 Directory_Separator & "gnat");
263 Current_Project_Path :=
264 new String'(Name_Buffer (1 .. Name_Len) & Path_Separator &
266 ".." & Directory_Separator &
267 ".." & Directory_Separator &
268 ".." & Directory_Separator & "gnat");
275 if Current_Project_Path = null then
276 Current_Project_Path := new String'(Name_Buffer (1 .. Name_Len));
278 end Initialize_Project_Path;
284 function Project_Path return String is
286 if Current_Project_Path = null then
287 Initialize_Project_Path;
290 return Current_Project_Path.all;
302 ----------------------
303 -- Set_Project_Path --
304 ----------------------
306 procedure Set_Project_Path (New_Path : String) is
308 Free (Current_Project_Path);
309 Current_Project_Path := new String'(New_Path);
310 end Set_Project_Path;
317 (External_Name : Name_Id;
318 With_Default : Name_Id := No_Name)
322 Name : String := Get_Name_String (External_Name);
325 Canonical_Case_File_Name (Name);
326 Name_Len := Name'Length;
327 Name_Buffer (1 .. Name_Len) := Name;
328 The_Value := Htable.Get (Name_Find);
330 if The_Value /= No_Name then
334 -- Find if it is an environment, if it is, put value in the hash table
337 Env_Value : String_Access := Getenv (Name);
340 if Env_Value /= null and then Env_Value'Length > 0 then
341 Name_Len := Env_Value'Length;
342 Name_Buffer (1 .. Name_Len) := Env_Value.all;
343 The_Value := Name_Find;
344 Htable.Set (External_Name, The_Value);