1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2000-2010, 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;
29 with Osint; use Osint;
30 with Prj.Tree; use Prj.Tree;
33 package body Prj.Ext is
35 No_Project_Default_Dir : constant String := "-";
36 -- Indicator in the project path to indicate that the default search
37 -- directories should not be added to the path
39 Uninitialized_Prefix : constant String := '#' & Path_Separator;
40 -- Prefix to indicate that the project path has not been initilized yet.
41 -- Must be two characters long
43 procedure Initialize_Project_Path (Tree : Prj.Tree.Project_Node_Tree_Ref);
44 -- Initialize Current_Project_Path
51 (Tree : Prj.Tree.Project_Node_Tree_Ref;
52 External_Name : String;
58 Name_Len := Value'Length;
59 Name_Buffer (1 .. Name_Len) := Value;
60 The_Value := Name_Find;
61 Name_Len := External_Name'Length;
62 Name_Buffer (1 .. Name_Len) := External_Name;
63 Canonical_Case_Env_Var_Name (Name_Buffer (1 .. Name_Len));
65 Name_To_Name_HTable.Set (Tree.External_References, The_Key, The_Value);
68 ----------------------------------
69 -- Add_Search_Project_Directory --
70 ----------------------------------
72 procedure Add_Search_Project_Directory
73 (Tree : Prj.Tree.Project_Node_Tree_Ref;
78 if Tree.Project_Path = null then
79 Tree.Project_Path := new String'(Uninitialized_Prefix & Path);
81 Tmp := Tree.Project_Path;
82 Tree.Project_Path := new String'(Tmp.all & Path_Separator & Path);
85 end Add_Search_Project_Directory;
92 (Tree : Prj.Tree.Project_Node_Tree_Ref;
93 Declaration : String) return Boolean
96 for Equal_Pos in Declaration'Range loop
97 if Declaration (Equal_Pos) = '=' then
98 exit when Equal_Pos = Declaration'First;
102 Declaration (Declaration'First .. Equal_Pos - 1),
104 Declaration (Equal_Pos + 1 .. Declaration'Last));
112 -----------------------------
113 -- Initialize_Project_Path --
114 -----------------------------
116 procedure Initialize_Project_Path (Tree : Prj.Tree.Project_Node_Tree_Ref) is
117 Add_Default_Dir : Boolean := True;
123 Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
124 Gpr_Project_Path : constant String := "GPR_PROJECT_PATH";
125 -- Name of alternate env. variable that contain path name(s) of
126 -- directories where project files may reside. GPR_PROJECT_PATH has
127 -- precedence over ADA_PROJECT_PATH.
129 Gpr_Prj_Path : String_Access := Getenv (Gpr_Project_Path);
130 Ada_Prj_Path : String_Access := Getenv (Ada_Project_Path);
131 -- The path name(s) of directories where project files may reside.
135 -- The current directory is always first in the search path. Since the
136 -- Project_Path currently starts with '#:' as a sign that it isn't
137 -- initialized, we simply replace '#' with '.'
139 if Tree.Project_Path = null then
140 Tree.Project_Path := new String'('.' & Path_Separator);
142 Tree.Project_Path (Tree.Project_Path'First) := '.';
145 -- Then the reset of the project path (if any) currently contains the
146 -- directories added through Add_Search_Project_Directory
148 -- If environment variables are defined and not empty, add their content
150 if Gpr_Prj_Path.all /= "" then
151 Add_Search_Project_Directory (Tree, Gpr_Prj_Path.all);
156 if Ada_Prj_Path.all /= "" then
157 Add_Search_Project_Directory (Tree, Ada_Prj_Path.all);
162 -- Copy to Name_Buffer, since we will need to manipulate the path
164 Name_Len := Tree.Project_Path'Length;
165 Name_Buffer (1 .. Name_Len) := Tree.Project_Path.all;
167 -- Scan the directory path to see if "-" is one of the directories.
168 -- Remove each occurrence of "-" and set Add_Default_Dir to False.
169 -- Also resolve relative paths and symbolic links.
173 while First <= Name_Len
174 and then (Name_Buffer (First) = Path_Separator)
179 exit when First > Name_Len;
183 while Last < Name_Len
184 and then Name_Buffer (Last + 1) /= Path_Separator
189 -- If the directory is "-", set Add_Default_Dir to False and
192 if Name_Buffer (First .. Last) = No_Project_Default_Dir then
193 Add_Default_Dir := False;
195 for J in Last + 1 .. Name_Len loop
196 Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
200 Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
202 -- After removing the '-', go back one character to get the next
203 -- directory correctly.
207 elsif not Hostparm.OpenVMS
208 or else not Is_Absolute_Path (Name_Buffer (First .. Last))
210 -- On VMS, only expand relative path names, as absolute paths
211 -- may correspond to multi-valued VMS logical names.
214 New_Dir : constant String :=
216 (Name_Buffer (First .. Last),
217 Resolve_Links => Opt.Follow_Links_For_Dirs);
220 -- If the absolute path was resolved and is different from
221 -- the original, replace original with the resolved path.
223 if New_Dir /= Name_Buffer (First .. Last)
224 and then New_Dir'Length /= 0
226 New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
227 New_Last := First + New_Dir'Length - 1;
228 Name_Buffer (New_Last + 1 .. New_Len) :=
229 Name_Buffer (Last + 1 .. Name_Len);
230 Name_Buffer (First .. New_Last) := New_Dir;
240 Free (Tree.Project_Path);
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 if Tree.Target_Name /= null and then
254 Tree.Target_Name.all /= ""
256 Add_Str_To_Name_Buffer
257 (Path_Separator & Prefix.all &
258 "lib" & Directory_Separator & "gpr" &
259 Directory_Separator & Tree.Target_Name.all);
262 Add_Str_To_Name_Buffer
263 (Path_Separator & Prefix.all &
264 "share" & Directory_Separator & "gpr");
265 Add_Str_To_Name_Buffer
266 (Path_Separator & Prefix.all &
267 "lib" & Directory_Separator & "gnat");
272 new String'(Name_Buffer (1 .. Name_Len) & Path_Separator &
274 ".." & Directory_Separator &
275 ".." & Directory_Separator &
276 ".." & Directory_Separator & "gnat");
283 if Tree.Project_Path = null then
284 Tree.Project_Path := new String'(Name_Buffer (1 .. Name_Len));
286 end Initialize_Project_Path;
292 function Project_Path (Tree : Project_Node_Tree_Ref) return String is
294 if Tree.Project_Path = null
295 or else Tree.Project_Path (Tree.Project_Path'First) = '#'
297 Initialize_Project_Path (Tree);
300 return Tree.Project_Path.all;
307 procedure Reset (Tree : Prj.Tree.Project_Node_Tree_Ref) is
309 Name_To_Name_HTable.Reset (Tree.External_References);
312 ----------------------
313 -- Set_Project_Path --
314 ----------------------
316 procedure Set_Project_Path
317 (Tree : Project_Node_Tree_Ref;
318 New_Path : String) is
320 Free (Tree.Project_Path);
321 Tree.Project_Path := new String'(New_Path);
322 end Set_Project_Path;
329 (Tree : Prj.Tree.Project_Node_Tree_Ref;
330 External_Name : Name_Id;
331 With_Default : Name_Id := No_Name)
335 Name : String := Get_Name_String (External_Name);
338 Canonical_Case_Env_Var_Name (Name);
339 Name_Len := Name'Length;
340 Name_Buffer (1 .. Name_Len) := Name;
342 Name_To_Name_HTable.Get (Tree.External_References, Name_Find);
344 if The_Value /= No_Name then
348 -- Find if it is an environment, if it is, put value in the hash table
351 Env_Value : String_Access := Getenv (Name);
354 if Env_Value /= null and then Env_Value'Length > 0 then
355 Name_Len := Env_Value'Length;
356 Name_Buffer (1 .. Name_Len) := Env_Value.all;
357 The_Value := Name_Find;
358 Name_To_Name_HTable.Set
359 (Tree.External_References, External_Name, The_Value);