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 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.
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
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 Get_Mode = Ada_Only then
146 if Gpr_Prj_Path.all /= "" then
148 -- Warn if both environment variables are defined
150 if Ada_Prj_Path.all /= "" then
152 ("Warning: ADA_PROJECT_PATH is not taken into account");
153 Write_Line (" when GPR_PROJECT_PATH is defined");
157 Prj_Path := Ada_Prj_Path;
161 -- The current directory is always first
164 Name_Buffer (Name_Len) := '.';
166 -- If there are directories in the Search_Directories table, add them
168 for J in 1 .. Search_Directories.Last loop
169 Name_Len := Name_Len + 1;
170 Name_Buffer (Name_Len) := Path_Separator;
171 Add_Str_To_Name_Buffer
172 (Get_Name_String (Search_Directories.Table (J)));
175 -- If environment variable is defined and not empty, add its content
177 if Prj_Path.all /= "" then
178 Name_Len := Name_Len + 1;
179 Name_Buffer (Name_Len) := Path_Separator;
181 Add_Str_To_Name_Buffer (Prj_Path.all);
184 -- Scan the directory path to see if "-" is one of the directories.
185 -- Remove each occurence of "-" and set Add_Default_Dir to False.
186 -- Also resolve relative paths and symbolic links.
190 while First <= Name_Len
191 and then (Name_Buffer (First) = Path_Separator)
196 exit when First > Name_Len;
200 while Last < Name_Len
201 and then Name_Buffer (Last + 1) /= Path_Separator
206 -- If the directory is "-", set Add_Default_Dir to False and
209 if Name_Buffer (First .. Last) = No_Project_Default_Dir then
210 Add_Default_Dir := False;
212 for J in Last + 1 .. Name_Len loop
213 Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
217 Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
219 -- After removing the '-', go back one character to get the next
220 -- directory correctly.
224 elsif not Hostparm.OpenVMS
225 or else not Is_Absolute_Path (Name_Buffer (First .. Last))
227 -- On VMS, only expand relative path names, as absolute paths
228 -- may correspond to multi-valued VMS logical names.
231 New_Dir : constant String :=
232 Normalize_Pathname (Name_Buffer (First .. Last));
235 -- If the absolute path was resolved and is different from
236 -- the original, replace original with the resolved path.
238 if New_Dir /= Name_Buffer (First .. Last)
239 and then New_Dir'Length /= 0
241 New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
242 New_Last := First + New_Dir'Length - 1;
243 Name_Buffer (New_Last + 1 .. New_Len) :=
244 Name_Buffer (Last + 1 .. Name_Len);
245 Name_Buffer (First .. New_Last) := New_Dir;
255 -- Set the initial value of Current_Project_Path
257 if Add_Default_Dir then
259 Prefix : String_Ptr := Sdefault.Search_Dir_Prefix;
261 if Prefix = null then
262 Prefix := new String'(Executable_Prefix_Path);
264 if Prefix.all /= "" then
265 if Get_Mode = Ada_Only then
266 Current_Project_Path :=
267 new String'(Name_Buffer (1 .. Name_Len) &
269 Prefix.all & Directory_Separator & "gnat");
272 Current_Project_Path :=
273 new String'(Name_Buffer (1 .. Name_Len) &
275 Prefix.all & Directory_Separator &
276 "share" & Directory_Separator & "gpr");
281 Current_Project_Path :=
282 new String'(Name_Buffer (1 .. Name_Len) & Path_Separator &
284 ".." & Directory_Separator &
285 ".." & Directory_Separator &
286 ".." & Directory_Separator & "gnat");
291 if Current_Project_Path = null then
292 Current_Project_Path := new String'(Name_Buffer (1 .. Name_Len));
294 end Initialize_Project_Path;
300 function Project_Path return String is
302 if Current_Project_Path = null then
303 Initialize_Project_Path;
306 return Current_Project_Path.all;
318 ----------------------
319 -- Set_Project_Path --
320 ----------------------
322 procedure Set_Project_Path (New_Path : String) is
324 Free (Current_Project_Path);
325 Current_Project_Path := new String'(New_Path);
326 end Set_Project_Path;
333 (External_Name : Name_Id;
334 With_Default : Name_Id := No_Name)
338 Name : String := Get_Name_String (External_Name);
341 Canonical_Case_File_Name (Name);
342 Name_Len := Name'Length;
343 Name_Buffer (1 .. Name_Len) := Name;
344 The_Value := Htable.Get (Name_Find);
346 if The_Value /= No_Name then
350 -- Find if it is an environment, if it is, put value in the hash table
353 Env_Value : String_Access := Getenv (Name);
356 if Env_Value /= null and then Env_Value'Length > 0 then
357 Name_Len := Env_Value'Length;
358 Name_Buffer (1 .. Name_Len) := Env_Value.all;
359 The_Value := Name_Find;
360 Htable.Set (External_Name, The_Value);