1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2000-2008, 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 Output; use Output;
29 with Osint; use Osint;
35 package body Prj.Ext is
37 Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
38 -- Name of alternate env. variable that contain path name(s) of directories
39 -- where project files may reside. GPR_PROJECT_PATH has precedence over
42 Gpr_Prj_Path : constant String_Access := Getenv (Gpr_Project_Path);
43 Ada_Prj_Path : constant String_Access := Getenv (Ada_Project_Path);
44 -- The path name(s) of directories where project files may reside.
47 No_Project_Default_Dir : constant String := "-";
49 Current_Project_Path : String_Access;
50 -- The project path. Initialized by procedure Initialize_Project_Path
53 procedure Initialize_Project_Path;
54 -- Initialize Current_Project_Path
56 package Htable is new GNAT.HTable.Simple_HTable
57 (Header_Num => Header_Num,
59 No_Element => No_Name,
63 -- External references are stored in this hash table, either by procedure
64 -- Add (directly or through a call to function Check) or by function
65 -- Value_Of when an environment variable is found non empty. Value_Of
66 -- first for external reference in this table, before checking the
67 -- environment. Htable is emptied (reset) by procedure Reset.
69 package Search_Directories is new Table.Table
70 (Table_Component_Type => Name_Id,
71 Table_Index_Type => Natural,
74 Table_Increment => 100,
75 Table_Name => "Prj.Ext.Search_Directories");
76 -- The table for the directories specified with -aP switches
83 (External_Name : String;
89 Name_Len := Value'Length;
90 Name_Buffer (1 .. Name_Len) := Value;
91 The_Value := Name_Find;
92 Name_Len := External_Name'Length;
93 Name_Buffer (1 .. Name_Len) := External_Name;
94 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
96 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;
114 function Check (Declaration : String) return Boolean is
116 for Equal_Pos in Declaration'Range loop
117 if Declaration (Equal_Pos) = '=' then
118 exit when Equal_Pos = Declaration'First;
119 exit when Equal_Pos = Declaration'Last;
122 Declaration (Declaration'First .. Equal_Pos - 1),
124 Declaration (Equal_Pos + 1 .. Declaration'Last));
132 -----------------------------
133 -- Initialize_Project_Path --
134 -----------------------------
136 procedure Initialize_Project_Path is
137 Add_Default_Dir : Boolean := True;
142 Prj_Path : String_Access := Gpr_Prj_Path;
145 if Gpr_Prj_Path.all /= "" then
147 -- In Ada only mode, warn if both environment variables are defined
149 if Get_Mode = Ada_Only and then Ada_Prj_Path.all /= "" then
151 ("Warning: ADA_PROJECT_PATH is not taken into account");
152 Write_Line (" when GPR_PROJECT_PATH is defined");
156 Prj_Path := Ada_Prj_Path;
159 -- The current directory is always first
162 Name_Buffer (Name_Len) := '.';
164 -- If there are directories in the Search_Directories table, add them
166 for J in 1 .. Search_Directories.Last loop
167 Name_Len := Name_Len + 1;
168 Name_Buffer (Name_Len) := Path_Separator;
169 Add_Str_To_Name_Buffer
170 (Get_Name_String (Search_Directories.Table (J)));
173 -- If environment variable is defined and not empty, add its content
175 if Prj_Path.all /= "" then
176 Name_Len := Name_Len + 1;
177 Name_Buffer (Name_Len) := Path_Separator;
179 Add_Str_To_Name_Buffer (Prj_Path.all);
182 -- Scan the directory path to see if "-" is one of the directories.
183 -- Remove each occurrence of "-" and set Add_Default_Dir to False.
184 -- Also resolve relative paths and symbolic links.
188 while First <= Name_Len
189 and then (Name_Buffer (First) = Path_Separator)
194 exit when First > Name_Len;
198 while Last < Name_Len
199 and then Name_Buffer (Last + 1) /= Path_Separator
204 -- If the directory is "-", set Add_Default_Dir to False and
207 if Name_Buffer (First .. Last) = No_Project_Default_Dir then
208 Add_Default_Dir := False;
210 for J in Last + 1 .. Name_Len loop
211 Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
215 Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
217 -- After removing the '-', go back one character to get the next
218 -- directory correctly.
222 elsif not Hostparm.OpenVMS
223 or else not Is_Absolute_Path (Name_Buffer (First .. Last))
225 -- On VMS, only expand relative path names, as absolute paths
226 -- may correspond to multi-valued VMS logical names.
229 New_Dir : constant String :=
230 Normalize_Pathname (Name_Buffer (First .. Last));
233 -- If the absolute path was resolved and is different from
234 -- the original, replace original with the resolved path.
236 if New_Dir /= Name_Buffer (First .. Last)
237 and then New_Dir'Length /= 0
239 New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
240 New_Last := First + New_Dir'Length - 1;
241 Name_Buffer (New_Last + 1 .. New_Len) :=
242 Name_Buffer (Last + 1 .. Name_Len);
243 Name_Buffer (First .. New_Last) := New_Dir;
253 -- Set the initial value of Current_Project_Path
255 if Add_Default_Dir then
257 Prefix : String_Ptr := Sdefault.Search_Dir_Prefix;
259 if Prefix = null then
260 Prefix := new String'(Executable_Prefix_Path);
262 if Prefix.all /= "" then
263 if Get_Mode = Multi_Language then
264 Add_Str_To_Name_Buffer
265 (Path_Separator & Prefix.all &
266 Directory_Separator & "share" &
267 Directory_Separator & "gpr");
270 Add_Str_To_Name_Buffer
271 (Path_Separator & Prefix.all &
272 Directory_Separator & "lib" &
273 Directory_Separator & "gnat");
277 Current_Project_Path :=
278 new String'(Name_Buffer (1 .. Name_Len) & Path_Separator &
280 ".." & Directory_Separator &
281 ".." & Directory_Separator &
282 ".." & Directory_Separator & "gnat");
287 if Current_Project_Path = null then
288 Current_Project_Path := new String'(Name_Buffer (1 .. Name_Len));
290 end Initialize_Project_Path;
296 function Project_Path return String is
298 if Current_Project_Path = null then
299 Initialize_Project_Path;
302 return Current_Project_Path.all;
314 ----------------------
315 -- Set_Project_Path --
316 ----------------------
318 procedure Set_Project_Path (New_Path : String) is
320 Free (Current_Project_Path);
321 Current_Project_Path := new String'(New_Path);
322 end Set_Project_Path;
329 (External_Name : Name_Id;
330 With_Default : Name_Id := No_Name)
334 Name : String := Get_Name_String (External_Name);
337 Canonical_Case_File_Name (Name);
338 Name_Len := Name'Length;
339 Name_Buffer (1 .. Name_Len) := Name;
340 The_Value := Htable.Get (Name_Find);
342 if The_Value /= No_Name then
346 -- Find if it is an environment, if it is, put value in the hash table
349 Env_Value : String_Access := Getenv (Name);
352 if Env_Value /= null and then Env_Value'Length > 0 then
353 Name_Len := Env_Value'Length;
354 Name_Buffer (1 .. Name_Len) := Env_Value.all;
355 The_Value := Name_Find;
356 Htable.Set (External_Name, The_Value);