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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
28 with Makeutl; use Makeutl;
29 with Output; use Output;
30 with Osint; use Osint;
36 package body Prj.Ext is
38 Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
39 -- Name of alternate env. variable that contain path name(s) of directories
40 -- where project files may reside. GPR_PROJECT_PATH has precedence over
43 Gpr_Prj_Path : constant String_Access := Getenv (Gpr_Project_Path);
44 Ada_Prj_Path : constant String_Access := Getenv (Ada_Project_Path);
45 -- The path name(s) of directories where project files may reside.
48 No_Project_Default_Dir : constant String := "-";
50 Current_Project_Path : String_Access;
51 -- The project path. Initialized by procedure Initialize_Project_Path
54 procedure Initialize_Project_Path;
55 -- Initialize Current_Project_Path
57 package Htable is new GNAT.HTable.Simple_HTable
58 (Header_Num => Header_Num,
60 No_Element => No_Name,
64 -- External references are stored in this hash table, either by procedure
65 -- Add (directly or through a call to function Check) or by function
66 -- Value_Of when an environment variable is found non empty. Value_Of
67 -- first for external reference in this table, before checking the
68 -- environment. Htable is emptied (reset) by procedure Reset.
71 package Search_Directories is new Table.Table
72 (Table_Component_Type => Name_Id,
73 Table_Index_Type => Natural,
76 Table_Increment => 100,
77 Table_Name => "Prj.Ext.Search_Directories");
78 -- The table for the directories specified with -aP switches
84 (External_Name : String;
90 Name_Len := Value'Length;
91 Name_Buffer (1 .. Name_Len) := Value;
92 The_Value := Name_Find;
93 Name_Len := External_Name'Length;
94 Name_Buffer (1 .. Name_Len) := External_Name;
95 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
97 Htable.Set (The_Key, The_Value);
101 ----------------------------------
102 -- Add_Search_Project_Directory --
103 ----------------------------------
105 procedure Add_Search_Project_Directory (Path : String) is
108 Add_Str_To_Name_Buffer (Path);
109 Search_Directories.Append (Name_Find);
110 end Add_Search_Project_Directory;
115 function Check (Declaration : String) return Boolean is
117 for Equal_Pos in Declaration'Range loop
118 if Declaration (Equal_Pos) = '=' then
119 exit when Equal_Pos = Declaration'First;
120 exit when Equal_Pos = Declaration'Last;
123 Declaration (Declaration'First .. Equal_Pos - 1),
125 Declaration (Equal_Pos + 1 .. Declaration'Last));
133 -----------------------------
134 -- Initialize_Project_Path --
135 -----------------------------
137 procedure Initialize_Project_Path is
138 Add_Default_Dir : Boolean := True;
143 Prj_Path : String_Access := Gpr_Prj_Path;
146 if Get_Mode = Ada_Only then
147 if Gpr_Prj_Path.all /= "" then
149 -- Warn if both environment variables are defined
151 if Ada_Prj_Path.all /= "" then
153 ("Warning: ADA_PROJECT_PATH is not taken into account");
154 Write_Line (" when GPR_PROJECT_PATH is defined");
158 Prj_Path := Ada_Prj_Path;
162 -- The current directory is always first
165 Name_Buffer (Name_Len) := '.';
167 -- If there are directories in the Search_Directories table, add them
169 for J in 1 .. Search_Directories.Last loop
170 Name_Len := Name_Len + 1;
171 Name_Buffer (Name_Len) := Path_Separator;
172 Add_Str_To_Name_Buffer
173 (Get_Name_String (Search_Directories.Table (J)));
176 -- If environment variable is defined and not empty, add its content
178 if Prj_Path.all /= "" then
179 Name_Len := Name_Len + 1;
180 Name_Buffer (Name_Len) := Path_Separator;
182 Add_Str_To_Name_Buffer (Prj_Path.all);
185 -- Scan the directory path to see if "-" is one of the directories.
186 -- Remove each occurence of "-" and set Add_Default_Dir to False.
187 -- Also resolve relative paths and symbolic links.
191 while First <= Name_Len
192 and then (Name_Buffer (First) = Path_Separator)
197 exit when First > Name_Len;
201 while Last < Name_Len
202 and then Name_Buffer (Last + 1) /= Path_Separator
207 -- If the directory is "-", set Add_Default_Dir to False and
210 if Name_Buffer (First .. Last) = No_Project_Default_Dir then
211 Add_Default_Dir := False;
213 for J in Last + 1 .. Name_Len loop
214 Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
218 Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
220 -- After removing the '-', go back one character to get the next
221 -- directory corectly.
225 elsif not Hostparm.OpenVMS
226 or else not Is_Absolute_Path (Name_Buffer (First .. Last))
228 -- On VMS, only expand relative path names, as absolute paths
229 -- may correspond to multi-valued VMS logical names.
232 New_Dir : constant String :=
233 Normalize_Pathname (Name_Buffer (First .. Last));
236 -- If the absolute path was resolved and is different from
237 -- the original, replace original with the resolved path.
239 if New_Dir /= Name_Buffer (First .. Last)
240 and then New_Dir'Length /= 0
242 New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
243 New_Last := First + New_Dir'Length - 1;
244 Name_Buffer (New_Last + 1 .. New_Len) :=
245 Name_Buffer (Last + 1 .. Name_Len);
246 Name_Buffer (First .. New_Last) := New_Dir;
256 -- Set the initial value of Current_Project_Path
258 if Add_Default_Dir then
260 Prefix : String_Ptr := Sdefault.Search_Dir_Prefix;
262 if Prefix = null then
263 Prefix := new String'(Executable_Prefix_Path);
265 if Prefix.all /= "" then
266 if Get_Mode = Ada_Only then
267 Current_Project_Path :=
268 new String'(Name_Buffer (1 .. Name_Len) &
270 Prefix.all & Directory_Separator & "gnat");
273 Current_Project_Path :=
274 new String'(Name_Buffer (1 .. Name_Len) &
276 Prefix.all & Directory_Separator &
277 "share" & Directory_Separator & "gpr");
282 Current_Project_Path :=
283 new String'(Name_Buffer (1 .. Name_Len) & Path_Separator &
285 ".." & Directory_Separator &
286 ".." & Directory_Separator &
287 ".." & Directory_Separator & "gnat");
292 if Current_Project_Path = null then
293 Current_Project_Path := new String'(Name_Buffer (1 .. Name_Len));
295 end Initialize_Project_Path;
301 function Project_Path return String is
303 if Current_Project_Path = null then
304 Initialize_Project_Path;
307 return Current_Project_Path.all;
319 ----------------------
320 -- Set_Project_Path --
321 ----------------------
323 procedure Set_Project_Path (New_Path : String) is
325 Free (Current_Project_Path);
326 Current_Project_Path := new String'(New_Path);
327 end Set_Project_Path;
334 (External_Name : Name_Id;
335 With_Default : Name_Id := No_Name)
339 Name : String := Get_Name_String (External_Name);
342 Canonical_Case_File_Name (Name);
343 Name_Len := Name'Length;
344 Name_Buffer (1 .. Name_Len) := Name;
345 The_Value := Htable.Get (Name_Find);
347 if The_Value /= No_Name then
351 -- Find if it is an environment, if it is, put value in the hash table
354 Env_Value : String_Access := Getenv (Name);
357 if Env_Value /= null and then Env_Value'Length > 0 then
358 Name_Len := Env_Value'Length;
359 Name_Buffer (1 .. Name_Len) := Env_Value.all;
360 The_Value := Name_Find;
361 Htable.Set (External_Name, The_Value);