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 ------------------------------------------------------------------------------
26 with System
.OS_Lib
; use System
.OS_Lib
;
28 with Makeutl
; use Makeutl
;
30 with Osint
; use Osint
;
31 with Prj
.Tree
; use Prj
.Tree
;
34 package body Prj
.Ext
is
36 No_Project_Default_Dir
: constant String := "-";
37 -- Indicator in the project path to indicate that the default search
38 -- directories should not be added to the path
40 Uninitialized_Prefix
: constant String := '#' & Path_Separator
;
41 -- Prefix to indicate that the project path has not been initilized yet.
42 -- Must be two characters long
44 procedure Initialize_Project_Path
(Tree
: Prj
.Tree
.Project_Node_Tree_Ref
);
45 -- Initialize Current_Project_Path
52 (Tree
: Prj
.Tree
.Project_Node_Tree_Ref
;
53 External_Name
: String;
59 Name_Len
:= Value
'Length;
60 Name_Buffer
(1 .. Name_Len
) := Value
;
61 The_Value
:= Name_Find
;
62 Name_Len
:= External_Name
'Length;
63 Name_Buffer
(1 .. Name_Len
) := External_Name
;
64 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
66 Name_To_Name_HTable
.Set
(Tree
.External_References
, The_Key
, The_Value
);
69 ----------------------------------
70 -- Add_Search_Project_Directory --
71 ----------------------------------
73 procedure Add_Search_Project_Directory
74 (Tree
: Prj
.Tree
.Project_Node_Tree_Ref
;
79 if Tree
.Project_Path
= null then
80 Tree
.Project_Path
:= new String'(Uninitialized_Prefix & Path);
82 Tmp := Tree.Project_Path;
83 Tree.Project_Path := new String'(Tmp
.all & Path_Separator
& Path
);
86 end Add_Search_Project_Directory
;
93 (Tree
: Prj
.Tree
.Project_Node_Tree_Ref
;
94 Declaration
: String) return Boolean
97 for Equal_Pos
in Declaration
'Range loop
98 if Declaration
(Equal_Pos
) = '=' then
99 exit when Equal_Pos
= Declaration
'First;
103 Declaration
(Declaration
'First .. Equal_Pos
- 1),
105 Declaration
(Equal_Pos
+ 1 .. Declaration
'Last));
113 -----------------------------
114 -- Initialize_Project_Path --
115 -----------------------------
117 procedure Initialize_Project_Path
(Tree
: Prj
.Tree
.Project_Node_Tree_Ref
) is
118 Add_Default_Dir
: Boolean := True;
124 Ada_Project_Path
: constant String := "ADA_PROJECT_PATH";
125 Gpr_Project_Path
: constant String := "GPR_PROJECT_PATH";
126 -- Name of alternate env. variable that contain path name(s) of
127 -- directories where project files may reside. GPR_PROJECT_PATH has
128 -- precedence over ADA_PROJECT_PATH.
130 Gpr_Prj_Path
: String_Access
:= Getenv
(Gpr_Project_Path
);
131 Ada_Prj_Path
: String_Access
:= Getenv
(Ada_Project_Path
);
132 -- The path name(s) of directories where project files may reside.
136 -- The current directory is always first in the search path. Since the
137 -- Project_Path currently starts with '#:' as a sign that it isn't
138 -- initialized, we simply replace '#' with '.'
140 if Tree
.Project_Path
= null then
141 Tree
.Project_Path
:= new String'('.' & Path_Separator);
143 Tree.Project_Path (Tree.Project_Path'First) := '.';
146 -- Then the reset of the project path (if any) currently contains the
147 -- directories added through Add_Search_Project_Directory
149 -- If environment variables are defined and not empty, add their content
151 if Gpr_Prj_Path.all /= "" then
152 Add_Search_Project_Directory (Tree, Gpr_Prj_Path.all);
157 if Ada_Prj_Path.all /= "" then
158 Add_Search_Project_Directory (Tree, Ada_Prj_Path.all);
163 -- Copy to Name_Buffer, since we will need to manipulate the path
165 Name_Len := Tree.Project_Path'Length;
166 Name_Buffer (1 .. Name_Len) := Tree.Project_Path.all;
168 -- Scan the directory path to see if "-" is one of the directories.
169 -- Remove each occurrence of "-" and set Add_Default_Dir to False.
170 -- Also resolve relative paths and symbolic links.
174 while First <= Name_Len
175 and then (Name_Buffer (First) = Path_Separator)
180 exit when First > Name_Len;
184 while Last < Name_Len
185 and then Name_Buffer (Last + 1) /= Path_Separator
190 -- If the directory is "-", set Add_Default_Dir to False and
193 if Name_Buffer (First .. Last) = No_Project_Default_Dir then
194 Add_Default_Dir := False;
196 for J in Last + 1 .. Name_Len loop
197 Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
201 Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
203 -- After removing the '-', go back one character to get the next
204 -- directory correctly.
208 elsif not Hostparm.OpenVMS
209 or else not Is_Absolute_Path (Name_Buffer (First .. Last))
211 -- On VMS, only expand relative path names, as absolute paths
212 -- may correspond to multi-valued VMS logical names.
215 New_Dir : constant String :=
217 (Name_Buffer (First .. Last),
218 Resolve_Links => Opt.Follow_Links_For_Dirs);
221 -- If the absolute path was resolved and is different from
222 -- the original, replace original with the resolved path.
224 if New_Dir /= Name_Buffer (First .. Last)
225 and then New_Dir'Length /= 0
227 New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
228 New_Last := First + New_Dir'Length - 1;
229 Name_Buffer (New_Last + 1 .. New_Len) :=
230 Name_Buffer (Last + 1 .. Name_Len);
231 Name_Buffer (First .. New_Last) := New_Dir;
241 Free (Tree.Project_Path);
243 -- Set the initial value of Current_Project_Path
245 if Add_Default_Dir then
247 Prefix : String_Ptr := Sdefault.Search_Dir_Prefix;
250 if Prefix = null then
251 Prefix := new String'(Executable_Prefix_Path
);
253 if Prefix
.all /= "" then
254 Add_Str_To_Name_Buffer
255 (Path_Separator
& Prefix
.all &
256 "share" & Directory_Separator
& "gpr");
257 Add_Str_To_Name_Buffer
258 (Path_Separator
& Prefix
.all &
259 Directory_Separator
& "lib" &
260 Directory_Separator
& "gnat");
265 new String'(Name_Buffer (1 .. Name_Len) & Path_Separator &
267 ".." & Directory_Separator &
268 ".." & Directory_Separator &
269 ".." & Directory_Separator & "gnat");
276 if Tree.Project_Path = null then
277 Tree.Project_Path := new String'(Name_Buffer
(1 .. Name_Len
));
279 end Initialize_Project_Path
;
285 function Project_Path
(Tree
: Project_Node_Tree_Ref
) return String is
287 if Tree
.Project_Path
= null
288 or else Tree
.Project_Path
(Tree
.Project_Path
'First) = '#'
290 Initialize_Project_Path
(Tree
);
293 return Tree
.Project_Path
.all;
300 procedure Reset
(Tree
: Prj
.Tree
.Project_Node_Tree_Ref
) is
302 Name_To_Name_HTable
.Reset
(Tree
.External_References
);
305 ----------------------
306 -- Set_Project_Path --
307 ----------------------
309 procedure Set_Project_Path
310 (Tree
: Project_Node_Tree_Ref
;
311 New_Path
: String) is
313 Free
(Tree
.Project_Path
);
314 Tree
.Project_Path
:= new String'(New_Path);
315 end Set_Project_Path;
322 (Tree : Prj.Tree.Project_Node_Tree_Ref;
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;
335 Name_To_Name_HTable.Get (Tree.External_References, Name_Find);
337 if The_Value /= No_Name then
341 -- Find if it is an environment, if it is, put value in the hash table
344 Env_Value : String_Access := Getenv (Name);
347 if Env_Value /= null and then Env_Value'Length > 0 then
348 Name_Len := Env_Value'Length;
349 Name_Buffer (1 .. Name_Len) := Env_Value.all;
350 The_Value := Name_Find;
351 Name_To_Name_HTable.Set
352 (Tree.External_References, External_Name, The_Value);