]>
Commit | Line | Data |
---|---|---|
19235870 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- P R J . E N V -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
3e582869 | 9 | -- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- |
19235870 RK |
10 | -- -- |
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- -- | |
10583694 | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
19235870 RK |
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 -- | |
10583694 VC |
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. -- | |
19235870 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
19235870 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
15cf0748 | 26 | with Fmap; |
a0a786e3 | 27 | with Hostparm; |
3ce5ca75 | 28 | with Makeutl; use Makeutl; |
19235870 | 29 | with Opt; |
3ce5ca75 RD |
30 | with Osint; use Osint; |
31 | with Output; use Output; | |
32 | with Prj.Com; use Prj.Com; | |
a0a786e3 | 33 | with Sdefault; |
fbf5a39b AC |
34 | with Tempdir; |
35 | ||
3ce5ca75 RD |
36 | with GNAT.Directory_Operations; use GNAT.Directory_Operations; |
37 | ||
19235870 RK |
38 | package body Prj.Env is |
39 | ||
68716ad5 AC |
40 | Buffer_Initial : constant := 1_000; |
41 | -- Initial size of Buffer | |
42 | ||
a0a786e3 | 43 | Uninitialized_Prefix : constant String := '#' & Path_Separator; |
308e6f3a | 44 | -- Prefix to indicate that the project path has not been initialized yet. |
a0a786e3 EB |
45 | -- Must be two characters long |
46 | ||
47 | No_Project_Default_Dir : constant String := "-"; | |
48 | -- Indicator in the project path to indicate that the default search | |
49 | -- directories should not be added to the path | |
50 | ||
19235870 RK |
51 | ----------------------- |
52 | -- Local Subprograms -- | |
53 | ----------------------- | |
54 | ||
7bccff24 EB |
55 | package Source_Path_Table is new GNAT.Dynamic_Tables |
56 | (Table_Component_Type => Name_Id, | |
57 | Table_Index_Type => Natural, | |
58 | Table_Low_Bound => 1, | |
59 | Table_Initial => 50, | |
60 | Table_Increment => 100); | |
61 | -- A table to store the source dirs before creating the source path file | |
62 | ||
63 | package Object_Path_Table is new GNAT.Dynamic_Tables | |
64 | (Table_Component_Type => Path_Name_Type, | |
65 | Table_Index_Type => Natural, | |
66 | Table_Low_Bound => 1, | |
67 | Table_Initial => 50, | |
68 | Table_Increment => 100); | |
69 | -- A table to store the object dirs, before creating the object path file | |
70 | ||
68716ad5 AC |
71 | procedure Add_To_Buffer |
72 | (S : String; | |
73 | Buffer : in out String_Access; | |
74 | Buffer_Last : in out Natural); | |
75 | -- Add a string to Buffer, extending Buffer if needed | |
76 | ||
7e98a4c6 VC |
77 | procedure Add_To_Path |
78 | (Source_Dirs : String_List_Id; | |
40ecf2f5 | 79 | Shared : Shared_Project_Tree_Data_Access; |
7bccff24 EB |
80 | Buffer : in out String_Access; |
81 | Buffer_Last : in out Natural); | |
07fc65c4 | 82 | -- Add to Ada_Path_Buffer all the source directories in string list |
7bccff24 | 83 | -- Source_Dirs, if any. |
07fc65c4 | 84 | |
7bccff24 EB |
85 | procedure Add_To_Path |
86 | (Dir : String; | |
87 | Buffer : in out String_Access; | |
88 | Buffer_Last : in out Natural); | |
fbf5a39b | 89 | -- If Dir is not already in the global variable Ada_Path_Buffer, add it. |
7bccff24 | 90 | -- If Buffer_Last /= 0, prepend a Path_Separator character to Path. |
fbf5a39b | 91 | |
7e98a4c6 | 92 | procedure Add_To_Source_Path |
7bccff24 | 93 | (Source_Dirs : String_List_Id; |
40ecf2f5 | 94 | Shared : Shared_Project_Tree_Data_Access; |
7bccff24 | 95 | Source_Paths : in out Source_Path_Table.Instance); |
ede007da VC |
96 | -- Add to Ada_Path_B all the source directories in string list |
97 | -- Source_Dirs, if any. Increment Ada_Path_Length. | |
fbf5a39b | 98 | |
7e98a4c6 | 99 | procedure Add_To_Object_Path |
7bccff24 EB |
100 | (Object_Dir : Path_Name_Type; |
101 | Object_Paths : in out Object_Path_Table.Instance); | |
a336eaca AC |
102 | -- Add Object_Dir to object path table. Make sure it is not duplicate |
103 | -- and it is the last one in the current table. | |
fbf5a39b | 104 | |
fbf5a39b AC |
105 | procedure Set_Path_File_Var (Name : String; Value : String); |
106 | -- Call Setenv, after calling To_Host_File_Spec | |
107 | ||
7e98a4c6 | 108 | function Ultimate_Extension_Of |
66713d62 | 109 | (Project : Project_Id) return Project_Id; |
fbf5a39b AC |
110 | -- Return a project that is either Project or an extended ancestor of |
111 | -- Project that itself is not extended. | |
19235870 RK |
112 | |
113 | ---------------------- | |
114 | -- Ada_Include_Path -- | |
115 | ---------------------- | |
116 | ||
7e98a4c6 | 117 | function Ada_Include_Path |
7bccff24 EB |
118 | (Project : Project_Id; |
119 | In_Tree : Project_Tree_Ref; | |
120 | Recursive : Boolean := False) return String | |
8b9890fa | 121 | is |
7bccff24 EB |
122 | Buffer : String_Access; |
123 | Buffer_Last : Natural := 0; | |
124 | ||
40ecf2f5 EB |
125 | procedure Add |
126 | (Project : Project_Id; | |
127 | In_Tree : Project_Tree_Ref; | |
128 | Dummy : in out Boolean); | |
8b9890fa | 129 | -- Add source dirs of Project to the path |
19235870 RK |
130 | |
131 | --------- | |
132 | -- Add -- | |
133 | --------- | |
134 | ||
40ecf2f5 EB |
135 | procedure Add |
136 | (Project : Project_Id; | |
137 | In_Tree : Project_Tree_Ref; | |
138 | Dummy : in out Boolean) | |
139 | is | |
8b9890fa | 140 | pragma Unreferenced (Dummy); |
19235870 | 141 | begin |
40ecf2f5 EB |
142 | Add_To_Path |
143 | (Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last); | |
19235870 RK |
144 | end Add; |
145 | ||
8b9890fa EB |
146 | procedure For_All_Projects is |
147 | new For_Every_Project_Imported (Boolean, Add); | |
8b9890fa | 148 | |
7bccff24 | 149 | Dummy : Boolean := False; |
19235870 | 150 | |
3c2815d8 RD |
151 | -- Start of processing for Ada_Include_Path |
152 | ||
19235870 | 153 | begin |
7bccff24 | 154 | if Recursive then |
3c2815d8 | 155 | |
7bccff24 EB |
156 | -- If it is the first time we call this function for |
157 | -- this project, compute the source path | |
158 | ||
159 | if Project.Ada_Include_Path = null then | |
160 | Buffer := new String (1 .. 4096); | |
40ecf2f5 EB |
161 | For_All_Projects |
162 | (Project, In_Tree, Dummy, Include_Aggregated => True); | |
7bccff24 EB |
163 | Project.Ada_Include_Path := new String'(Buffer (1 .. Buffer_Last)); |
164 | Free (Buffer); | |
165 | end if; | |
19235870 | 166 | |
7bccff24 | 167 | return Project.Ada_Include_Path.all; |
19235870 | 168 | |
07fc65c4 | 169 | else |
7bccff24 | 170 | Buffer := new String (1 .. 4096); |
40ecf2f5 EB |
171 | Add_To_Path |
172 | (Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last); | |
7bccff24 EB |
173 | |
174 | declare | |
175 | Result : constant String := Buffer (1 .. Buffer_Last); | |
176 | begin | |
177 | Free (Buffer); | |
178 | return Result; | |
179 | end; | |
07fc65c4 GB |
180 | end if; |
181 | end Ada_Include_Path; | |
182 | ||
19235870 RK |
183 | ---------------------- |
184 | -- Ada_Objects_Path -- | |
185 | ---------------------- | |
186 | ||
187 | function Ada_Objects_Path | |
188 | (Project : Project_Id; | |
40ecf2f5 | 189 | In_Tree : Project_Tree_Ref; |
ecad994d | 190 | Including_Libraries : Boolean := True) return String_Access |
07fc65c4 | 191 | is |
3c2815d8 | 192 | Buffer : String_Access; |
7bccff24 EB |
193 | Buffer_Last : Natural := 0; |
194 | ||
40ecf2f5 EB |
195 | procedure Add |
196 | (Project : Project_Id; | |
197 | In_Tree : Project_Tree_Ref; | |
198 | Dummy : in out Boolean); | |
8b9890fa | 199 | -- Add all the object directories of a project to the path |
19235870 RK |
200 | |
201 | --------- | |
202 | -- Add -- | |
203 | --------- | |
204 | ||
40ecf2f5 EB |
205 | procedure Add |
206 | (Project : Project_Id; | |
207 | In_Tree : Project_Tree_Ref; | |
208 | Dummy : in out Boolean) | |
209 | is | |
210 | pragma Unreferenced (Dummy, In_Tree); | |
686d0984 | 211 | |
8b9890fa | 212 | Path : constant Path_Name_Type := |
8eaf1723 | 213 | Get_Object_Directory |
66713d62 | 214 | (Project, |
8eaf1723 RD |
215 | Including_Libraries => Including_Libraries, |
216 | Only_If_Ada => False); | |
19235870 | 217 | begin |
8b9890fa | 218 | if Path /= No_Path then |
7bccff24 | 219 | Add_To_Path (Get_Name_String (Path), Buffer, Buffer_Last); |
19235870 RK |
220 | end if; |
221 | end Add; | |
222 | ||
8b9890fa EB |
223 | procedure For_All_Projects is |
224 | new For_Every_Project_Imported (Boolean, Add); | |
3c2815d8 | 225 | |
8b9890fa EB |
226 | Dummy : Boolean := False; |
227 | ||
19235870 RK |
228 | -- Start of processing for Ada_Objects_Path |
229 | ||
230 | begin | |
231 | -- If it is the first time we call this function for | |
232 | -- this project, compute the objects path | |
233 | ||
66713d62 | 234 | if Project.Ada_Objects_Path = null then |
7bccff24 | 235 | Buffer := new String (1 .. 4096); |
40ecf2f5 | 236 | For_All_Projects (Project, In_Tree, Dummy); |
19235870 | 237 | |
7bccff24 EB |
238 | Project.Ada_Objects_Path := new String'(Buffer (1 .. Buffer_Last)); |
239 | Free (Buffer); | |
19235870 RK |
240 | end if; |
241 | ||
66713d62 | 242 | return Project.Ada_Objects_Path; |
19235870 RK |
243 | end Ada_Objects_Path; |
244 | ||
68716ad5 AC |
245 | ------------------- |
246 | -- Add_To_Buffer -- | |
247 | ------------------- | |
248 | ||
249 | procedure Add_To_Buffer | |
250 | (S : String; | |
251 | Buffer : in out String_Access; | |
252 | Buffer_Last : in out Natural) | |
253 | is | |
254 | Last : constant Natural := Buffer_Last + S'Length; | |
88eb6e62 | 255 | |
68716ad5 AC |
256 | begin |
257 | while Last > Buffer'Last loop | |
258 | declare | |
259 | New_Buffer : constant String_Access := | |
88eb6e62 | 260 | new String (1 .. 2 * Buffer'Last); |
68716ad5 AC |
261 | begin |
262 | New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last); | |
263 | Free (Buffer); | |
264 | Buffer := New_Buffer; | |
265 | end; | |
266 | end loop; | |
267 | ||
268 | Buffer (Buffer_Last + 1 .. Last) := S; | |
269 | Buffer_Last := Last; | |
270 | end Add_To_Buffer; | |
271 | ||
a336eaca AC |
272 | ------------------------ |
273 | -- Add_To_Object_Path -- | |
274 | ------------------------ | |
275 | ||
7e98a4c6 | 276 | procedure Add_To_Object_Path |
7bccff24 EB |
277 | (Object_Dir : Path_Name_Type; |
278 | Object_Paths : in out Object_Path_Table.Instance) | |
7e98a4c6 | 279 | is |
a336eaca AC |
280 | begin |
281 | -- Check if the directory is already in the table | |
282 | ||
7e98a4c6 | 283 | for Index in Object_Path_Table.First .. |
7bccff24 | 284 | Object_Path_Table.Last (Object_Paths) |
7e98a4c6 | 285 | loop |
24105bab | 286 | |
a336eaca AC |
287 | -- If it is, remove it, and add it as the last one |
288 | ||
7bccff24 | 289 | if Object_Paths.Table (Index) = Object_Dir then |
7e98a4c6 | 290 | for Index2 in Index + 1 .. |
7bccff24 | 291 | Object_Path_Table.Last (Object_Paths) |
7e98a4c6 | 292 | loop |
7bccff24 | 293 | Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2); |
a336eaca AC |
294 | end loop; |
295 | ||
7bccff24 EB |
296 | Object_Paths.Table |
297 | (Object_Path_Table.Last (Object_Paths)) := Object_Dir; | |
a336eaca AC |
298 | return; |
299 | end if; | |
300 | end loop; | |
301 | ||
302 | -- The directory is not already in the table, add it | |
303 | ||
7bccff24 | 304 | Object_Path_Table.Append (Object_Paths, Object_Dir); |
a336eaca AC |
305 | end Add_To_Object_Path; |
306 | ||
19235870 RK |
307 | ----------------- |
308 | -- Add_To_Path -- | |
309 | ----------------- | |
310 | ||
7e98a4c6 VC |
311 | procedure Add_To_Path |
312 | (Source_Dirs : String_List_Id; | |
40ecf2f5 | 313 | Shared : Shared_Project_Tree_Data_Access; |
7bccff24 EB |
314 | Buffer : in out String_Access; |
315 | Buffer_Last : in out Natural) | |
7e98a4c6 | 316 | is |
07fc65c4 GB |
317 | Current : String_List_Id := Source_Dirs; |
318 | Source_Dir : String_Element; | |
07fc65c4 GB |
319 | begin |
320 | while Current /= Nil_String loop | |
40ecf2f5 | 321 | Source_Dir := Shared.String_Elements.Table (Current); |
7bccff24 EB |
322 | Add_To_Path (Get_Name_String (Source_Dir.Display_Value), |
323 | Buffer, Buffer_Last); | |
07fc65c4 GB |
324 | Current := Source_Dir.Next; |
325 | end loop; | |
326 | end Add_To_Path; | |
327 | ||
7bccff24 EB |
328 | procedure Add_To_Path |
329 | (Dir : String; | |
330 | Buffer : in out String_Access; | |
331 | Buffer_Last : in out Natural) | |
332 | is | |
fbf5a39b AC |
333 | Len : Natural; |
334 | New_Buffer : String_Access; | |
335 | Min_Len : Natural; | |
336 | ||
337 | function Is_Present (Path : String; Dir : String) return Boolean; | |
338 | -- Return True if Dir is part of Path | |
339 | ||
340 | ---------------- | |
341 | -- Is_Present -- | |
342 | ---------------- | |
343 | ||
344 | function Is_Present (Path : String; Dir : String) return Boolean is | |
345 | Last : constant Integer := Path'Last - Dir'Length + 1; | |
24105bab | 346 | |
fbf5a39b AC |
347 | begin |
348 | for J in Path'First .. Last loop | |
24105bab | 349 | |
fbf5a39b AC |
350 | -- Note: the order of the conditions below is important, since |
351 | -- it ensures a minimal number of string comparisons. | |
352 | ||
353 | if (J = Path'First | |
354 | or else Path (J - 1) = Path_Separator) | |
355 | and then | |
356 | (J + Dir'Length > Path'Last | |
357 | or else Path (J + Dir'Length) = Path_Separator) | |
358 | and then Dir = Path (J .. J + Dir'Length - 1) | |
359 | then | |
360 | return True; | |
361 | end if; | |
362 | end loop; | |
363 | ||
364 | return False; | |
365 | end Is_Present; | |
366 | ||
24105bab AC |
367 | -- Start of processing for Add_To_Path |
368 | ||
19235870 | 369 | begin |
7bccff24 | 370 | if Is_Present (Buffer (1 .. Buffer_Last), Dir) then |
24105bab | 371 | |
fbf5a39b | 372 | -- Dir is already in the path, nothing to do |
19235870 | 373 | |
fbf5a39b AC |
374 | return; |
375 | end if; | |
19235870 | 376 | |
7bccff24 | 377 | Min_Len := Buffer_Last + Dir'Length; |
fbf5a39b | 378 | |
7bccff24 | 379 | if Buffer_Last > 0 then |
24105bab | 380 | |
fbf5a39b AC |
381 | -- Add 1 for the Path_Separator character |
382 | ||
383 | Min_Len := Min_Len + 1; | |
384 | end if; | |
385 | ||
386 | -- If Ada_Path_Buffer is too small, increase it | |
387 | ||
7bccff24 | 388 | Len := Buffer'Last; |
fbf5a39b AC |
389 | |
390 | if Len < Min_Len then | |
391 | loop | |
392 | Len := Len * 2; | |
393 | exit when Len >= Min_Len; | |
394 | end loop; | |
395 | ||
396 | New_Buffer := new String (1 .. Len); | |
7bccff24 EB |
397 | New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last); |
398 | Free (Buffer); | |
399 | Buffer := New_Buffer; | |
fbf5a39b AC |
400 | end if; |
401 | ||
7bccff24 EB |
402 | if Buffer_Last > 0 then |
403 | Buffer_Last := Buffer_Last + 1; | |
404 | Buffer (Buffer_Last) := Path_Separator; | |
19235870 RK |
405 | end if; |
406 | ||
7bccff24 EB |
407 | Buffer (Buffer_Last + 1 .. Buffer_Last + Dir'Length) := Dir; |
408 | Buffer_Last := Buffer_Last + Dir'Length; | |
19235870 RK |
409 | end Add_To_Path; |
410 | ||
a336eaca AC |
411 | ------------------------ |
412 | -- Add_To_Source_Path -- | |
413 | ------------------------ | |
fbf5a39b | 414 | |
7e98a4c6 | 415 | procedure Add_To_Source_Path |
7bccff24 | 416 | (Source_Dirs : String_List_Id; |
40ecf2f5 | 417 | Shared : Shared_Project_Tree_Data_Access; |
7bccff24 | 418 | Source_Paths : in out Source_Path_Table.Instance) |
7e98a4c6 | 419 | is |
fbf5a39b AC |
420 | Current : String_List_Id := Source_Dirs; |
421 | Source_Dir : String_Element; | |
a336eaca | 422 | Add_It : Boolean; |
fbf5a39b AC |
423 | |
424 | begin | |
a336eaca AC |
425 | -- Add each source directory |
426 | ||
fbf5a39b | 427 | while Current /= Nil_String loop |
40ecf2f5 | 428 | Source_Dir := Shared.String_Elements.Table (Current); |
a336eaca | 429 | Add_It := True; |
fbf5a39b | 430 | |
a336eaca | 431 | -- Check if the source directory is already in the table |
fbf5a39b | 432 | |
7e98a4c6 | 433 | for Index in Source_Path_Table.First .. |
7bccff24 | 434 | Source_Path_Table.Last (Source_Paths) |
7e98a4c6 | 435 | loop |
a336eaca | 436 | -- If it is already, no need to add it |
fbf5a39b | 437 | |
7bccff24 | 438 | if Source_Paths.Table (Index) = Source_Dir.Value then |
a336eaca AC |
439 | Add_It := False; |
440 | exit; | |
441 | end if; | |
442 | end loop; | |
443 | ||
444 | if Add_It then | |
90e9a6be | 445 | Source_Path_Table.Append (Source_Paths, Source_Dir.Display_Value); |
a336eaca AC |
446 | end if; |
447 | ||
448 | -- Next source directory | |
449 | ||
450 | Current := Source_Dir.Next; | |
451 | end loop; | |
452 | end Add_To_Source_Path; | |
fbf5a39b | 453 | |
19235870 RK |
454 | -------------------------------- |
455 | -- Create_Config_Pragmas_File -- | |
456 | -------------------------------- | |
457 | ||
458 | procedure Create_Config_Pragmas_File | |
84157c9a RD |
459 | (For_Project : Project_Id; |
460 | In_Tree : Project_Tree_Ref) | |
19235870 | 461 | is |
fadcf313 AC |
462 | type Naming_Id is new Nat; |
463 | package Naming_Table is new GNAT.Dynamic_Tables | |
464 | (Table_Component_Type => Lang_Naming_Data, | |
465 | Table_Index_Type => Naming_Id, | |
466 | Table_Low_Bound => 1, | |
467 | Table_Initial => 5, | |
468 | Table_Increment => 100); | |
469 | Default_Naming : constant Naming_Id := Naming_Table.First; | |
470 | Namings : Naming_Table.Instance; | |
471 | -- Table storing the naming data for gnatmake/gprmake | |
19235870 | 472 | |
88eb6e62 | 473 | Buffer : String_Access := new String (1 .. Buffer_Initial); |
68716ad5 AC |
474 | Buffer_Last : Natural := 0; |
475 | ||
38c2fd0c | 476 | File_Name : Path_Name_Type := No_Path; |
fbf5a39b | 477 | File : File_Descriptor := Invalid_FD; |
19235870 | 478 | |
19235870 RK |
479 | Current_Naming : Naming_Id; |
480 | ||
40ecf2f5 EB |
481 | procedure Check |
482 | (Project : Project_Id; | |
483 | In_Tree : Project_Tree_Ref; | |
484 | State : in out Integer); | |
7324bf49 AC |
485 | -- Recursive procedure that put in the config pragmas file any non |
486 | -- standard naming schemes, if it is not already in the file, then call | |
487 | -- itself for any imported project. | |
19235870 | 488 | |
23c4ff9b | 489 | procedure Put (Source : Source_Id); |
24105bab | 490 | -- Put an SFN pragma in the temporary file |
19235870 | 491 | |
68716ad5 AC |
492 | procedure Put (S : String); |
493 | procedure Put_Line (S : String); | |
494 | -- Output procedures, analogous to normal Text_IO procs of same name. | |
308e6f3a | 495 | -- The text is put in Buffer, then it will be written into a temporary |
68716ad5 AC |
496 | -- file with procedure Write_Temp_File below. |
497 | ||
498 | procedure Write_Temp_File; | |
88eb6e62 | 499 | -- Create a temporary file and put the content of the buffer in it |
19235870 RK |
500 | |
501 | ----------- | |
502 | -- Check -- | |
503 | ----------- | |
504 | ||
40ecf2f5 EB |
505 | procedure Check |
506 | (Project : Project_Id; | |
507 | In_Tree : Project_Tree_Ref; | |
508 | State : in out Integer) | |
509 | is | |
ad05f2e9 | 510 | pragma Unreferenced (State); |
686d0984 | 511 | |
fadcf313 | 512 | Lang : constant Language_Ptr := |
84157c9a | 513 | Get_Language_From_Name (Project, "ada"); |
fadcf313 | 514 | Naming : Lang_Naming_Data; |
ad05f2e9 AC |
515 | Iter : Source_Iterator; |
516 | Source : Source_Id; | |
84157c9a | 517 | |
19235870 RK |
518 | begin |
519 | if Current_Verbosity = High then | |
40ecf2f5 | 520 | Debug_Output ("Checking project file:", Project.Name); |
19235870 RK |
521 | end if; |
522 | ||
fadcf313 AC |
523 | if Lang = null then |
524 | if Current_Verbosity = High then | |
40ecf2f5 | 525 | Debug_Output ("Languages does not contain Ada, nothing to do"); |
fadcf313 | 526 | end if; |
84157c9a | 527 | |
fadcf313 AC |
528 | return; |
529 | end if; | |
19235870 | 530 | |
ad05f2e9 AC |
531 | -- Visit all the files and process those that need an SFN pragma |
532 | ||
533 | Iter := For_Each_Source (In_Tree, Project); | |
534 | while Element (Iter) /= No_Source loop | |
535 | Source := Element (Iter); | |
536 | ||
ad05f2e9 AC |
537 | if Source.Index >= 1 |
538 | and then not Source.Locally_Removed | |
539 | and then Source.Unit /= null | |
540 | then | |
541 | Put (Source); | |
542 | end if; | |
543 | ||
544 | Next (Iter); | |
545 | end loop; | |
546 | ||
fadcf313 | 547 | Naming := Lang.Config.Naming_Data; |
19235870 | 548 | |
fadcf313 | 549 | -- Is the naming scheme of this project one that we know? |
19235870 | 550 | |
fadcf313 AC |
551 | Current_Naming := Default_Naming; |
552 | while Current_Naming <= Naming_Table.Last (Namings) | |
553 | and then Namings.Table (Current_Naming).Dot_Replacement = | |
84157c9a | 554 | Naming.Dot_Replacement |
fadcf313 | 555 | and then Namings.Table (Current_Naming).Casing = |
84157c9a | 556 | Naming.Casing |
fadcf313 | 557 | and then Namings.Table (Current_Naming).Separate_Suffix = |
84157c9a | 558 | Naming.Separate_Suffix |
fadcf313 AC |
559 | loop |
560 | Current_Naming := Current_Naming + 1; | |
561 | end loop; | |
19235870 | 562 | |
fadcf313 | 563 | -- If we don't know it, add it |
19235870 | 564 | |
fadcf313 AC |
565 | if Current_Naming > Naming_Table.Last (Namings) then |
566 | Naming_Table.Increment_Last (Namings); | |
567 | Namings.Table (Naming_Table.Last (Namings)) := Naming; | |
19235870 | 568 | |
fadcf313 AC |
569 | -- Put the SFN pragmas for the naming scheme |
570 | ||
571 | -- Spec | |
572 | ||
573 | Put_Line | |
68716ad5 | 574 | ("pragma Source_File_Name_Project"); |
fadcf313 | 575 | Put_Line |
68716ad5 | 576 | (" (Spec_File_Name => ""*" & |
fadcf313 AC |
577 | Get_Name_String (Naming.Spec_Suffix) & ""","); |
578 | Put_Line | |
68716ad5 | 579 | (" Casing => " & |
fadcf313 AC |
580 | Image (Naming.Casing) & ","); |
581 | Put_Line | |
68716ad5 | 582 | (" Dot_Replacement => """ & |
fadcf313 AC |
583 | Get_Name_String (Naming.Dot_Replacement) & """);"); |
584 | ||
585 | -- and body | |
586 | ||
587 | Put_Line | |
68716ad5 | 588 | ("pragma Source_File_Name_Project"); |
fadcf313 | 589 | Put_Line |
68716ad5 | 590 | (" (Body_File_Name => ""*" & |
fadcf313 AC |
591 | Get_Name_String (Naming.Body_Suffix) & ""","); |
592 | Put_Line | |
68716ad5 | 593 | (" Casing => " & |
fadcf313 AC |
594 | Image (Naming.Casing) & ","); |
595 | Put_Line | |
68716ad5 | 596 | (" Dot_Replacement => """ & |
fadcf313 AC |
597 | Get_Name_String (Naming.Dot_Replacement) & |
598 | """);"); | |
599 | ||
600 | -- and maybe separate | |
601 | ||
602 | if Naming.Body_Suffix /= Naming.Separate_Suffix then | |
68716ad5 | 603 | Put_Line ("pragma Source_File_Name_Project"); |
19235870 | 604 | Put_Line |
68716ad5 | 605 | (" (Subunit_File_Name => ""*" & |
fadcf313 | 606 | Get_Name_String (Naming.Separate_Suffix) & ""","); |
19235870 | 607 | Put_Line |
68716ad5 | 608 | (" Casing => " & |
fadcf313 | 609 | Image (Naming.Casing) & ","); |
19235870 | 610 | Put_Line |
68716ad5 | 611 | (" Dot_Replacement => """ & |
fadcf313 | 612 | Get_Name_String (Naming.Dot_Replacement) & |
19235870 | 613 | """);"); |
19235870 | 614 | end if; |
19235870 RK |
615 | end if; |
616 | end Check; | |
617 | ||
19235870 RK |
618 | --------- |
619 | -- Put -- | |
620 | --------- | |
621 | ||
23c4ff9b | 622 | procedure Put (Source : Source_Id) is |
19235870 | 623 | begin |
19235870 RK |
624 | -- Put the pragma SFN for the unit kind (spec or body) |
625 | ||
68716ad5 AC |
626 | Put ("pragma Source_File_Name_Project ("); |
627 | Put (Namet.Get_Name_String (Source.Unit.Name)); | |
19235870 | 628 | |
23c4ff9b | 629 | if Source.Kind = Spec then |
68716ad5 | 630 | Put (", Spec_File_Name => """); |
19235870 | 631 | else |
68716ad5 | 632 | Put (", Body_File_Name => """); |
19235870 RK |
633 | end if; |
634 | ||
68716ad5 AC |
635 | Put (Namet.Get_Name_String (Source.File)); |
636 | Put (""""); | |
aa720a54 | 637 | |
23c4ff9b | 638 | if Source.Index /= 0 then |
68716ad5 AC |
639 | Put (", Index =>"); |
640 | Put (Source.Index'Img); | |
aa720a54 AC |
641 | end if; |
642 | ||
68716ad5 | 643 | Put_Line (");"); |
19235870 RK |
644 | end Put; |
645 | ||
68716ad5 | 646 | procedure Put (S : String) is |
19235870 | 647 | begin |
68716ad5 | 648 | Add_To_Buffer (S, Buffer, Buffer_Last); |
19235870 RK |
649 | |
650 | if Current_Verbosity = High then | |
651 | Write_Str (S); | |
652 | end if; | |
653 | end Put; | |
654 | ||
655 | -------------- | |
656 | -- Put_Line -- | |
657 | -------------- | |
658 | ||
68716ad5 | 659 | procedure Put_Line (S : String) is |
19235870 | 660 | begin |
aa720a54 | 661 | -- Add an ASCII.LF to the string. As this config file is supposed to |
07fc65c4 GB |
662 | -- be used only by the compiler, we don't care about the characters |
663 | -- for the end of line. In fact we could have put a space, but | |
664 | -- it is more convenient to be able to read gnat.adc during | |
665 | -- development, for which the ASCII.LF is fine. | |
19235870 | 666 | |
68716ad5 AC |
667 | Put (S); |
668 | Put (S => (1 => ASCII.LF)); | |
669 | end Put_Line; | |
19235870 | 670 | |
68716ad5 AC |
671 | --------------------- |
672 | -- Write_Temp_File -- | |
673 | --------------------- | |
674 | ||
675 | procedure Write_Temp_File is | |
676 | Status : Boolean := False; | |
677 | Last : Natural; | |
88eb6e62 | 678 | |
68716ad5 AC |
679 | begin |
680 | Tempdir.Create_Temp_File (File, File_Name); | |
681 | ||
682 | if File /= Invalid_FD then | |
683 | Last := Write (File, Buffer (1)'Address, Buffer_Last); | |
684 | ||
685 | if Last = Buffer_Last then | |
686 | Close (File, Status); | |
687 | end if; | |
19235870 RK |
688 | end if; |
689 | ||
68716ad5 | 690 | if not Status then |
477eca00 | 691 | Prj.Com.Fail ("unable to create temporary file"); |
19235870 | 692 | end if; |
68716ad5 | 693 | end Write_Temp_File; |
19235870 | 694 | |
88eb6e62 AC |
695 | procedure Check_Imported_Projects is |
696 | new For_Every_Project_Imported (Integer, Check); | |
697 | ||
fadcf313 AC |
698 | Dummy : Integer := 0; |
699 | ||
19235870 RK |
700 | -- Start of processing for Create_Config_Pragmas_File |
701 | ||
702 | begin | |
66713d62 | 703 | if not For_Project.Config_Checked then |
fadcf313 | 704 | Naming_Table.Init (Namings); |
19235870 RK |
705 | |
706 | -- Check the naming schemes | |
707 | ||
40ecf2f5 EB |
708 | Check_Imported_Projects |
709 | (For_Project, In_Tree, Dummy, Imported_First => False); | |
19235870 | 710 | |
fbf5a39b AC |
711 | -- If there are no non standard naming scheme, issue the GNAT |
712 | -- standard naming scheme. This will tell the compiler that | |
713 | -- a project file is used and will forbid any pragma SFN. | |
19235870 | 714 | |
68716ad5 | 715 | if Buffer_Last = 0 then |
19235870 | 716 | |
68716ad5 AC |
717 | Put_Line ("pragma Source_File_Name_Project"); |
718 | Put_Line (" (Spec_File_Name => ""*.ads"","); | |
719 | Put_Line (" Dot_Replacement => ""-"","); | |
720 | Put_Line (" Casing => lowercase);"); | |
07fc65c4 | 721 | |
68716ad5 AC |
722 | Put_Line ("pragma Source_File_Name_Project"); |
723 | Put_Line (" (Body_File_Name => ""*.adb"","); | |
724 | Put_Line (" Dot_Replacement => ""-"","); | |
725 | Put_Line (" Casing => lowercase);"); | |
19235870 RK |
726 | end if; |
727 | ||
fbf5a39b | 728 | -- Close the temporary file |
19235870 | 729 | |
68716ad5 | 730 | Write_Temp_File; |
19235870 | 731 | |
fbf5a39b | 732 | if Opt.Verbose_Mode then |
68716ad5 | 733 | Write_Str ("Created configuration file """); |
fbf5a39b AC |
734 | Write_Str (Get_Name_String (File_Name)); |
735 | Write_Line (""""); | |
19235870 RK |
736 | end if; |
737 | ||
66713d62 AC |
738 | For_Project.Config_File_Name := File_Name; |
739 | For_Project.Config_File_Temp := True; | |
740 | For_Project.Config_Checked := True; | |
19235870 | 741 | end if; |
68716ad5 AC |
742 | |
743 | Free (Buffer); | |
19235870 RK |
744 | end Create_Config_Pragmas_File; |
745 | ||
15cf0748 VC |
746 | -------------------- |
747 | -- Create_Mapping -- | |
748 | -------------------- | |
749 | ||
750 | procedure Create_Mapping (In_Tree : Project_Tree_Ref) is | |
95cd3246 | 751 | Data : Source_Id; |
bea993f9 | 752 | Iter : Source_Iterator; |
15cf0748 VC |
753 | |
754 | begin | |
755 | Fmap.Reset_Tables; | |
756 | ||
bea993f9 AC |
757 | Iter := For_Each_Source (In_Tree); |
758 | loop | |
759 | Data := Element (Iter); | |
760 | exit when Data = No_Source; | |
15cf0748 | 761 | |
bea993f9 AC |
762 | if Data.Unit /= No_Unit_Index then |
763 | if Data.Locally_Removed then | |
764 | Fmap.Add_Forbidden_File_Name (Data.File); | |
765 | else | |
bea993f9 AC |
766 | Fmap.Add_To_File_Map |
767 | (Unit_Name => Unit_Name_Type (Data.Unit.Name), | |
768 | File_Name => Data.File, | |
8cce3d75 | 769 | Path_Name => File_Name_Type (Data.Path.Display_Name)); |
15cf0748 | 770 | end if; |
bea993f9 | 771 | end if; |
5a66a766 | 772 | |
bea993f9 | 773 | Next (Iter); |
15cf0748 VC |
774 | end loop; |
775 | end Create_Mapping; | |
776 | ||
6510f4c9 GB |
777 | ------------------------- |
778 | -- Create_Mapping_File -- | |
779 | ------------------------- | |
780 | ||
fbf5a39b | 781 | procedure Create_Mapping_File |
2f1e0b61 | 782 | (Project : Project_Id; |
1d24fc5e | 783 | Language : Name_Id; |
2f1e0b61 EB |
784 | In_Tree : Project_Tree_Ref; |
785 | Name : out Path_Name_Type) | |
fbf5a39b | 786 | is |
2f1e0b61 | 787 | File : File_Descriptor := Invalid_FD; |
68716ad5 AC |
788 | |
789 | Buffer : String_Access := new String (1 .. Buffer_Initial); | |
790 | Buffer_Last : Natural := 0; | |
fbf5a39b | 791 | |
07fc65c4 | 792 | procedure Put_Name_Buffer; |
68716ad5 | 793 | -- Put the line contained in the Name_Buffer in the global buffer |
6510f4c9 | 794 | |
40ecf2f5 EB |
795 | procedure Process |
796 | (Project : Project_Id; | |
797 | In_Tree : Project_Tree_Ref; | |
798 | State : in out Integer); | |
1d24fc5e | 799 | -- Generate the mapping file for Project (not recursively) |
fbf5a39b | 800 | |
68716ad5 AC |
801 | --------------------- |
802 | -- Put_Name_Buffer -- | |
803 | --------------------- | |
17c5c8a5 | 804 | |
07fc65c4 | 805 | procedure Put_Name_Buffer is |
6510f4c9 | 806 | begin |
1d24fc5e | 807 | if Current_Verbosity = High then |
3e582869 | 808 | Debug_Output (Name_Buffer (1 .. Name_Len)); |
1d24fc5e EB |
809 | end if; |
810 | ||
3e582869 AC |
811 | Name_Len := Name_Len + 1; |
812 | Name_Buffer (Name_Len) := ASCII.LF; | |
68716ad5 | 813 | Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); |
07fc65c4 | 814 | end Put_Name_Buffer; |
6510f4c9 | 815 | |
1d24fc5e EB |
816 | ------------- |
817 | -- Process -- | |
818 | ------------- | |
6510f4c9 | 819 | |
40ecf2f5 EB |
820 | procedure Process |
821 | (Project : Project_Id; | |
822 | In_Tree : Project_Tree_Ref; | |
823 | State : in out Integer) | |
824 | is | |
1d24fc5e | 825 | pragma Unreferenced (State); |
686d0984 | 826 | |
1d24fc5e EB |
827 | Source : Source_Id; |
828 | Suffix : File_Name_Type; | |
829 | Iter : Source_Iterator; | |
6510f4c9 | 830 | |
1d24fc5e | 831 | begin |
9434c32e | 832 | Debug_Output ("Add mapping for project", Project.Name); |
1d24fc5e | 833 | Iter := For_Each_Source (In_Tree, Project, Language => Language); |
07fc65c4 | 834 | |
1d24fc5e EB |
835 | loop |
836 | Source := Prj.Element (Iter); | |
837 | exit when Source = No_Source; | |
07fc65c4 | 838 | |
1d24fc5e EB |
839 | if Source.Replaced_By = No_Source |
840 | and then Source.Path.Name /= No_Path | |
841 | and then | |
842 | (Source.Language.Config.Kind = File_Based | |
fadcf313 | 843 | or else Source.Unit /= No_Unit_Index) |
1d24fc5e EB |
844 | then |
845 | if Source.Unit /= No_Unit_Index then | |
846 | Get_Name_String (Source.Unit.Name); | |
847 | ||
7bccff24 | 848 | if Source.Language.Config.Kind = Unit_Based then |
fadcf313 | 849 | |
1d24fc5e EB |
850 | -- ??? Mapping_Spec_Suffix could be set in the case of |
851 | -- gnatmake as well | |
fadcf313 AC |
852 | |
853 | Add_Char_To_Name_Buffer ('%'); | |
1d24fc5e EB |
854 | |
855 | if Source.Kind = Spec then | |
fadcf313 | 856 | Add_Char_To_Name_Buffer ('s'); |
1d24fc5e | 857 | else |
fadcf313 | 858 | Add_Char_To_Name_Buffer ('b'); |
1d24fc5e | 859 | end if; |
fadcf313 | 860 | |
1d24fc5e EB |
861 | else |
862 | case Source.Kind is | |
863 | when Spec => | |
864 | Suffix := | |
865 | Source.Language.Config.Mapping_Spec_Suffix; | |
866 | when Impl | Sep => | |
867 | Suffix := | |
868 | Source.Language.Config.Mapping_Body_Suffix; | |
869 | end case; | |
870 | ||
871 | if Suffix /= No_File then | |
872 | Add_Str_To_Name_Buffer | |
873 | (Get_Name_String (Suffix)); | |
874 | end if; | |
875 | end if; | |
07fc65c4 | 876 | |
1d24fc5e EB |
877 | Put_Name_Buffer; |
878 | end if; | |
07fc65c4 | 879 | |
8cce3d75 | 880 | Get_Name_String (Source.Display_File); |
1d24fc5e | 881 | Put_Name_Buffer; |
bea993f9 | 882 | |
1d24fc5e EB |
883 | if Source.Locally_Removed then |
884 | Name_Len := 1; | |
885 | Name_Buffer (1) := '/'; | |
886 | else | |
8cce3d75 | 887 | Get_Name_String (Source.Path.Display_Name); |
1d24fc5e | 888 | end if; |
6510f4c9 | 889 | |
1d24fc5e EB |
890 | Put_Name_Buffer; |
891 | end if; | |
fbf5a39b | 892 | |
1d24fc5e EB |
893 | Next (Iter); |
894 | end loop; | |
895 | end Process; | |
fbf5a39b | 896 | |
1d24fc5e EB |
897 | procedure For_Every_Imported_Project is new |
898 | For_Every_Project_Imported (State => Integer, Action => Process); | |
fbf5a39b | 899 | |
1d24fc5e | 900 | Dummy : Integer := 0; |
fbf5a39b | 901 | |
17c5c8a5 GB |
902 | -- Start of processing for Create_Mapping_File |
903 | ||
6510f4c9 | 904 | begin |
9434c32e EB |
905 | if Current_Verbosity = High then |
906 | Debug_Output ("Create mapping file for", Debug_Name (In_Tree)); | |
907 | end if; | |
908 | ||
98c99a5a | 909 | Create_Temp_File (In_Tree.Shared, File, Name, "mapping"); |
3e582869 AC |
910 | |
911 | if Current_Verbosity = High then | |
912 | Debug_Increase_Indent ("Create mapping file ", Name_Id (Name)); | |
913 | end if; | |
914 | ||
9434c32e EB |
915 | For_Every_Imported_Project |
916 | (Project, In_Tree, Dummy, Include_Aggregated => False); | |
fbf5a39b | 917 | |
68716ad5 | 918 | declare |
88eb6e62 | 919 | Last : Natural; |
68716ad5 | 920 | Status : Boolean := False; |
fbf5a39b | 921 | |
68716ad5 | 922 | begin |
68716ad5 AC |
923 | if File /= Invalid_FD then |
924 | Last := Write (File, Buffer (1)'Address, Buffer_Last); | |
ede007da | 925 | |
68716ad5 AC |
926 | if Last = Buffer_Last then |
927 | GNAT.OS_Lib.Close (File, Status); | |
928 | end if; | |
929 | end if; | |
481f29eb | 930 | |
68716ad5 AC |
931 | if not Status then |
932 | Prj.Com.Fail ("could not write mapping file"); | |
933 | end if; | |
934 | end; | |
481f29eb | 935 | |
68716ad5 | 936 | Free (Buffer); |
3e582869 AC |
937 | |
938 | Debug_Decrease_Indent ("Done create mapping file"); | |
ede007da VC |
939 | end Create_Mapping_File; |
940 | ||
7bccff24 EB |
941 | ---------------------- |
942 | -- Create_Temp_File -- | |
943 | ---------------------- | |
fbf5a39b | 944 | |
7bccff24 | 945 | procedure Create_Temp_File |
98c99a5a | 946 | (Shared : Shared_Project_Tree_Data_Access; |
7e98a4c6 | 947 | Path_FD : out File_Descriptor; |
7bccff24 EB |
948 | Path_Name : out Path_Name_Type; |
949 | File_Use : String) | |
fbf5a39b AC |
950 | is |
951 | begin | |
952 | Tempdir.Create_Temp_File (Path_FD, Path_Name); | |
953 | ||
38c2fd0c | 954 | if Path_Name /= No_Path then |
7bccff24 EB |
955 | if Current_Verbosity = High then |
956 | Write_Line ("Create temp file (" & File_Use & ") " | |
957 | & Get_Name_String (Path_Name)); | |
958 | end if; | |
fbf5a39b | 959 | |
98c99a5a | 960 | Record_Temp_File (Shared, Path_Name); |
fbf5a39b | 961 | |
7bccff24 EB |
962 | else |
963 | Prj.Com.Fail | |
964 | ("unable to create temporary " & File_Use & " file"); | |
fbf5a39b | 965 | end if; |
7bccff24 | 966 | end Create_Temp_File; |
fbf5a39b | 967 | |
7bccff24 EB |
968 | -------------------------- |
969 | -- Create_New_Path_File -- | |
970 | -------------------------- | |
fbf5a39b | 971 | |
7bccff24 | 972 | procedure Create_New_Path_File |
98c99a5a | 973 | (Shared : Shared_Project_Tree_Data_Access; |
7bccff24 | 974 | Path_FD : out File_Descriptor; |
3c2815d8 RD |
975 | Path_Name : out Path_Name_Type) |
976 | is | |
fbf5a39b | 977 | begin |
98c99a5a | 978 | Create_Temp_File (Shared, Path_FD, Path_Name, "path file"); |
7bccff24 | 979 | end Create_New_Path_File; |
fbf5a39b | 980 | |
19235870 RK |
981 | ------------------------------------ |
982 | -- File_Name_Of_Library_Unit_Body -- | |
983 | ------------------------------------ | |
984 | ||
985 | function File_Name_Of_Library_Unit_Body | |
fbf5a39b AC |
986 | (Name : String; |
987 | Project : Project_Id; | |
7e98a4c6 | 988 | In_Tree : Project_Tree_Ref; |
b0f26df5 | 989 | Main_Project_Only : Boolean := True; |
ecad994d | 990 | Full_Path : Boolean := False) return String |
19235870 | 991 | is |
fbf5a39b | 992 | The_Project : Project_Id := Project; |
19235870 RK |
993 | Original_Name : String := Name; |
994 | ||
fadcf313 AC |
995 | Lang : constant Language_Ptr := |
996 | Get_Language_From_Name (Project, "ada"); | |
19235870 | 997 | |
5a66a766 | 998 | Unit : Unit_Index; |
ede007da VC |
999 | The_Original_Name : Name_Id; |
1000 | The_Spec_Name : Name_Id; | |
1001 | The_Body_Name : Name_Id; | |
19235870 RK |
1002 | |
1003 | begin | |
84157c9a | 1004 | -- ??? Same block in Project_Of |
19235870 RK |
1005 | Canonical_Case_File_Name (Original_Name); |
1006 | Name_Len := Original_Name'Length; | |
1007 | Name_Buffer (1 .. Name_Len) := Original_Name; | |
1008 | The_Original_Name := Name_Find; | |
1009 | ||
fadcf313 AC |
1010 | if Lang /= null then |
1011 | declare | |
1012 | Naming : constant Lang_Naming_Data := Lang.Config.Naming_Data; | |
1013 | Extended_Spec_Name : String := | |
84157c9a RD |
1014 | Name & Namet.Get_Name_String |
1015 | (Naming.Spec_Suffix); | |
fadcf313 | 1016 | Extended_Body_Name : String := |
84157c9a RD |
1017 | Name & Namet.Get_Name_String |
1018 | (Naming.Body_Suffix); | |
1019 | ||
fadcf313 AC |
1020 | begin |
1021 | Canonical_Case_File_Name (Extended_Spec_Name); | |
1022 | Name_Len := Extended_Spec_Name'Length; | |
1023 | Name_Buffer (1 .. Name_Len) := Extended_Spec_Name; | |
1024 | The_Spec_Name := Name_Find; | |
1025 | ||
1026 | Canonical_Case_File_Name (Extended_Body_Name); | |
1027 | Name_Len := Extended_Body_Name'Length; | |
1028 | Name_Buffer (1 .. Name_Len) := Extended_Body_Name; | |
1029 | The_Body_Name := Name_Find; | |
1030 | end; | |
19235870 | 1031 | |
fadcf313 AC |
1032 | else |
1033 | Name_Len := Name'Length; | |
1034 | Name_Buffer (1 .. Name_Len) := Name; | |
1035 | Canonical_Case_File_Name (Name_Buffer); | |
1036 | The_Spec_Name := Name_Find; | |
1037 | The_Body_Name := The_Spec_Name; | |
1038 | end if; | |
19235870 RK |
1039 | |
1040 | if Current_Verbosity = High then | |
1041 | Write_Str ("Looking for file name of """); | |
1042 | Write_Str (Name); | |
1043 | Write_Char ('"'); | |
1044 | Write_Eol; | |
1045 | Write_Str (" Extended Spec Name = """); | |
fadcf313 | 1046 | Write_Str (Get_Name_String (The_Spec_Name)); |
19235870 RK |
1047 | Write_Char ('"'); |
1048 | Write_Eol; | |
1049 | Write_Str (" Extended Body Name = """); | |
fadcf313 | 1050 | Write_Str (Get_Name_String (The_Body_Name)); |
19235870 RK |
1051 | Write_Char ('"'); |
1052 | Write_Eol; | |
1053 | end if; | |
1054 | ||
ede007da VC |
1055 | -- For extending project, search in the extended project if the source |
1056 | -- is not found. For non extending projects, this loop will be run only | |
1057 | -- once. | |
19235870 | 1058 | |
fbf5a39b | 1059 | loop |
24105bab | 1060 | -- Loop through units |
19235870 | 1061 | |
5a66a766 EB |
1062 | Unit := Units_Htable.Get_First (In_Tree.Units_HT); |
1063 | while Unit /= null loop | |
fbf5a39b | 1064 | -- Check for body |
19235870 | 1065 | |
fbf5a39b | 1066 | if not Main_Project_Only |
852dba80 AC |
1067 | or else |
1068 | (Unit.File_Names (Impl) /= null | |
1069 | and then Unit.File_Names (Impl).Project = The_Project) | |
fbf5a39b AC |
1070 | then |
1071 | declare | |
852dba80 | 1072 | Current_Name : File_Name_Type; |
fbf5a39b AC |
1073 | begin |
1074 | -- Case of a body present | |
19235870 | 1075 | |
852dba80 AC |
1076 | if Unit.File_Names (Impl) /= null then |
1077 | Current_Name := Unit.File_Names (Impl).File; | |
1078 | ||
19235870 | 1079 | if Current_Verbosity = High then |
fbf5a39b AC |
1080 | Write_Str (" Comparing with """); |
1081 | Write_Str (Get_Name_String (Current_Name)); | |
1082 | Write_Char ('"'); | |
1083 | Write_Eol; | |
19235870 RK |
1084 | end if; |
1085 | ||
38c2fd0c VC |
1086 | -- If it has the name of the original name, return the |
1087 | -- original name. | |
19235870 | 1088 | |
ede007da VC |
1089 | if Unit.Name = The_Original_Name |
1090 | or else | |
1091 | Current_Name = File_Name_Type (The_Original_Name) | |
fbf5a39b AC |
1092 | then |
1093 | if Current_Verbosity = High then | |
1094 | Write_Line (" OK"); | |
1095 | end if; | |
19235870 | 1096 | |
b0f26df5 AC |
1097 | if Full_Path then |
1098 | return Get_Name_String | |
852dba80 | 1099 | (Unit.File_Names (Impl).Path.Name); |
b0f26df5 AC |
1100 | |
1101 | else | |
1102 | return Get_Name_String (Current_Name); | |
1103 | end if; | |
19235870 | 1104 | |
fbf5a39b AC |
1105 | -- If it has the name of the extended body name, |
1106 | -- return the extended body name | |
19235870 | 1107 | |
ede007da | 1108 | elsif Current_Name = File_Name_Type (The_Body_Name) then |
fbf5a39b AC |
1109 | if Current_Verbosity = High then |
1110 | Write_Line (" OK"); | |
1111 | end if; | |
19235870 | 1112 | |
b0f26df5 AC |
1113 | if Full_Path then |
1114 | return Get_Name_String | |
852dba80 | 1115 | (Unit.File_Names (Impl).Path.Name); |
b0f26df5 AC |
1116 | |
1117 | else | |
fadcf313 | 1118 | return Get_Name_String (The_Body_Name); |
b0f26df5 | 1119 | end if; |
19235870 | 1120 | |
fbf5a39b AC |
1121 | else |
1122 | if Current_Verbosity = High then | |
1123 | Write_Line (" not good"); | |
1124 | end if; | |
1125 | end if; | |
1126 | end if; | |
1127 | end; | |
1128 | end if; | |
19235870 | 1129 | |
fbf5a39b | 1130 | -- Check for spec |
19235870 | 1131 | |
fbf5a39b | 1132 | if not Main_Project_Only |
852dba80 AC |
1133 | or else |
1134 | (Unit.File_Names (Spec) /= null | |
1135 | and then Unit.File_Names (Spec).Project = | |
1136 | The_Project) | |
fbf5a39b AC |
1137 | then |
1138 | declare | |
852dba80 | 1139 | Current_Name : File_Name_Type; |
19235870 | 1140 | |
fbf5a39b AC |
1141 | begin |
1142 | -- Case of spec present | |
19235870 | 1143 | |
852dba80 AC |
1144 | if Unit.File_Names (Spec) /= null then |
1145 | Current_Name := Unit.File_Names (Spec).File; | |
19235870 | 1146 | if Current_Verbosity = High then |
fbf5a39b AC |
1147 | Write_Str (" Comparing with """); |
1148 | Write_Str (Get_Name_String (Current_Name)); | |
1149 | Write_Char ('"'); | |
1150 | Write_Eol; | |
19235870 RK |
1151 | end if; |
1152 | ||
24105bab | 1153 | -- If name same as original name, return original name |
19235870 | 1154 | |
ede007da VC |
1155 | if Unit.Name = The_Original_Name |
1156 | or else | |
1157 | Current_Name = File_Name_Type (The_Original_Name) | |
fbf5a39b AC |
1158 | then |
1159 | if Current_Verbosity = High then | |
1160 | Write_Line (" OK"); | |
1161 | end if; | |
19235870 | 1162 | |
b0f26df5 AC |
1163 | if Full_Path then |
1164 | return Get_Name_String | |
852dba80 | 1165 | (Unit.File_Names (Spec).Path.Name); |
b0f26df5 AC |
1166 | else |
1167 | return Get_Name_String (Current_Name); | |
1168 | end if; | |
19235870 | 1169 | |
fbf5a39b AC |
1170 | -- If it has the same name as the extended spec name, |
1171 | -- return the extended spec name. | |
19235870 | 1172 | |
ede007da | 1173 | elsif Current_Name = File_Name_Type (The_Spec_Name) then |
fbf5a39b AC |
1174 | if Current_Verbosity = High then |
1175 | Write_Line (" OK"); | |
1176 | end if; | |
1177 | ||
b0f26df5 AC |
1178 | if Full_Path then |
1179 | return Get_Name_String | |
852dba80 | 1180 | (Unit.File_Names (Spec).Path.Name); |
b0f26df5 | 1181 | else |
fadcf313 | 1182 | return Get_Name_String (The_Spec_Name); |
b0f26df5 | 1183 | end if; |
fbf5a39b AC |
1184 | |
1185 | else | |
1186 | if Current_Verbosity = High then | |
1187 | Write_Line (" not good"); | |
1188 | end if; | |
19235870 RK |
1189 | end if; |
1190 | end if; | |
fbf5a39b AC |
1191 | end; |
1192 | end if; | |
5a66a766 EB |
1193 | |
1194 | Unit := Units_Htable.Get_Next (In_Tree.Units_HT); | |
fbf5a39b AC |
1195 | end loop; |
1196 | ||
1197 | -- If we are not in an extending project, give up | |
1198 | ||
66713d62 AC |
1199 | exit when not Main_Project_Only |
1200 | or else The_Project.Extends = No_Project; | |
fbf5a39b AC |
1201 | |
1202 | -- Otherwise, look in the project we are extending | |
1203 | ||
66713d62 | 1204 | The_Project := The_Project.Extends; |
19235870 RK |
1205 | end loop; |
1206 | ||
1207 | -- We don't know this file name, return an empty string | |
1208 | ||
1209 | return ""; | |
1210 | end File_Name_Of_Library_Unit_Body; | |
1211 | ||
b3520ca0 AC |
1212 | ------------------------- |
1213 | -- For_All_Object_Dirs -- | |
1214 | ------------------------- | |
19235870 | 1215 | |
40ecf2f5 EB |
1216 | procedure For_All_Object_Dirs |
1217 | (Project : Project_Id; | |
1218 | Tree : Project_Tree_Ref) | |
1219 | is | |
1220 | procedure For_Project | |
1221 | (Prj : Project_Id; | |
1222 | Tree : Project_Tree_Ref; | |
1223 | Dummy : in out Integer); | |
b3520ca0 | 1224 | -- Get all object directories of Prj |
19235870 | 1225 | |
b3520ca0 AC |
1226 | ----------------- |
1227 | -- For_Project -- | |
1228 | ----------------- | |
19235870 | 1229 | |
40ecf2f5 EB |
1230 | procedure For_Project |
1231 | (Prj : Project_Id; | |
1232 | Tree : Project_Tree_Ref; | |
1233 | Dummy : in out Integer) | |
1234 | is | |
1235 | pragma Unreferenced (Dummy, Tree); | |
686d0984 | 1236 | |
b3520ca0 | 1237 | begin |
8b9890fa EB |
1238 | -- ??? Set_Ada_Paths has a different behavior for library project |
1239 | -- files, should we have the same ? | |
1240 | ||
66713d62 AC |
1241 | if Prj.Object_Directory /= No_Path_Information then |
1242 | Get_Name_String (Prj.Object_Directory.Display_Name); | |
19235870 RK |
1243 | Action (Name_Buffer (1 .. Name_Len)); |
1244 | end if; | |
b3520ca0 | 1245 | end For_Project; |
19235870 | 1246 | |
8b9890fa EB |
1247 | procedure Get_Object_Dirs is |
1248 | new For_Every_Project_Imported (Integer, For_Project); | |
1249 | Dummy : Integer := 1; | |
481f29eb VC |
1250 | |
1251 | -- Start of processing for For_All_Object_Dirs | |
1252 | ||
19235870 | 1253 | begin |
40ecf2f5 | 1254 | Get_Object_Dirs (Project, Tree, Dummy); |
19235870 RK |
1255 | end For_All_Object_Dirs; |
1256 | ||
1257 | ------------------------- | |
1258 | -- For_All_Source_Dirs -- | |
1259 | ------------------------- | |
1260 | ||
7e98a4c6 VC |
1261 | procedure For_All_Source_Dirs |
1262 | (Project : Project_Id; | |
1263 | In_Tree : Project_Tree_Ref) | |
1264 | is | |
40ecf2f5 EB |
1265 | procedure For_Project |
1266 | (Prj : Project_Id; | |
1267 | In_Tree : Project_Tree_Ref; | |
1268 | Dummy : in out Integer); | |
b3520ca0 | 1269 | -- Get all object directories of Prj |
19235870 | 1270 | |
b3520ca0 AC |
1271 | ----------------- |
1272 | -- For_Project -- | |
1273 | ----------------- | |
19235870 | 1274 | |
40ecf2f5 EB |
1275 | procedure For_Project |
1276 | (Prj : Project_Id; | |
1277 | In_Tree : Project_Tree_Ref; | |
1278 | Dummy : in out Integer) | |
1279 | is | |
8b9890fa | 1280 | pragma Unreferenced (Dummy); |
686d0984 | 1281 | |
66713d62 | 1282 | Current : String_List_Id := Prj.Source_Dirs; |
b3520ca0 | 1283 | The_String : String_Element; |
481f29eb | 1284 | |
19235870 | 1285 | begin |
b3520ca0 AC |
1286 | -- If there are Ada sources, call action with the name of every |
1287 | -- source directory. | |
1288 | ||
66713d62 | 1289 | if Has_Ada_Sources (Project) then |
b3520ca0 | 1290 | while Current /= Nil_String loop |
40ecf2f5 | 1291 | The_String := In_Tree.Shared.String_Elements.Table (Current); |
b3520ca0 AC |
1292 | Action (Get_Name_String (The_String.Display_Value)); |
1293 | Current := The_String.Next; | |
1294 | end loop; | |
19235870 | 1295 | end if; |
b3520ca0 | 1296 | end For_Project; |
19235870 | 1297 | |
8b9890fa EB |
1298 | procedure Get_Source_Dirs is |
1299 | new For_Every_Project_Imported (Integer, For_Project); | |
1300 | Dummy : Integer := 1; | |
481f29eb VC |
1301 | |
1302 | -- Start of processing for For_All_Source_Dirs | |
1303 | ||
19235870 | 1304 | begin |
40ecf2f5 | 1305 | Get_Source_Dirs (Project, In_Tree, Dummy); |
19235870 RK |
1306 | end For_All_Source_Dirs; |
1307 | ||
1308 | ------------------- | |
1309 | -- Get_Reference -- | |
1310 | ------------------- | |
1311 | ||
1312 | procedure Get_Reference | |
1313 | (Source_File_Name : String; | |
7e98a4c6 | 1314 | In_Tree : Project_Tree_Ref; |
19235870 | 1315 | Project : out Project_Id; |
ede007da | 1316 | Path : out Path_Name_Type) |
19235870 RK |
1317 | is |
1318 | begin | |
24105bab AC |
1319 | -- Body below could use some comments ??? |
1320 | ||
19235870 RK |
1321 | if Current_Verbosity > Default then |
1322 | Write_Str ("Getting Reference_Of ("""); | |
1323 | Write_Str (Source_File_Name); | |
1324 | Write_Str (""") ... "); | |
1325 | end if; | |
1326 | ||
1327 | declare | |
1328 | Original_Name : String := Source_File_Name; | |
5a66a766 | 1329 | Unit : Unit_Index; |
19235870 RK |
1330 | |
1331 | begin | |
1332 | Canonical_Case_File_Name (Original_Name); | |
5a66a766 | 1333 | Unit := Units_Htable.Get_First (In_Tree.Units_HT); |
19235870 | 1334 | |
5a66a766 | 1335 | while Unit /= null loop |
852dba80 AC |
1336 | if Unit.File_Names (Spec) /= null |
1337 | and then Unit.File_Names (Spec).File /= No_File | |
1338 | and then | |
1339 | (Namet.Get_Name_String | |
1340 | (Unit.File_Names (Spec).File) = Original_Name | |
1341 | or else (Unit.File_Names (Spec).Path /= | |
1342 | No_Path_Information | |
1343 | and then | |
1344 | Namet.Get_Name_String | |
1345 | (Unit.File_Names (Spec).Path.Name) = | |
1346 | Original_Name)) | |
19235870 | 1347 | then |
fbf5a39b | 1348 | Project := Ultimate_Extension_Of |
852dba80 AC |
1349 | (Project => Unit.File_Names (Spec).Project); |
1350 | Path := Unit.File_Names (Spec).Path.Display_Name; | |
19235870 RK |
1351 | |
1352 | if Current_Verbosity > Default then | |
852dba80 | 1353 | Write_Str ("Done: Spec."); |
19235870 RK |
1354 | Write_Eol; |
1355 | end if; | |
1356 | ||
1357 | return; | |
1358 | ||
852dba80 AC |
1359 | elsif Unit.File_Names (Impl) /= null |
1360 | and then Unit.File_Names (Impl).File /= No_File | |
1361 | and then | |
1362 | (Namet.Get_Name_String | |
1363 | (Unit.File_Names (Impl).File) = Original_Name | |
1364 | or else (Unit.File_Names (Impl).Path /= | |
1365 | No_Path_Information | |
1366 | and then Namet.Get_Name_String | |
1367 | (Unit.File_Names (Impl).Path.Name) = | |
1368 | Original_Name)) | |
19235870 | 1369 | then |
fbf5a39b | 1370 | Project := Ultimate_Extension_Of |
852dba80 AC |
1371 | (Project => Unit.File_Names (Impl).Project); |
1372 | Path := Unit.File_Names (Impl).Path.Display_Name; | |
19235870 RK |
1373 | |
1374 | if Current_Verbosity > Default then | |
1375 | Write_Str ("Done: Body."); | |
1376 | Write_Eol; | |
1377 | end if; | |
1378 | ||
1379 | return; | |
1380 | end if; | |
5a66a766 EB |
1381 | |
1382 | Unit := Units_Htable.Get_Next (In_Tree.Units_HT); | |
19235870 RK |
1383 | end loop; |
1384 | end; | |
1385 | ||
1386 | Project := No_Project; | |
ede007da | 1387 | Path := No_Path; |
19235870 RK |
1388 | |
1389 | if Current_Verbosity > Default then | |
1390 | Write_Str ("Cannot be found."); | |
1391 | Write_Eol; | |
1392 | end if; | |
1393 | end Get_Reference; | |
1394 | ||
1395 | ---------------- | |
1396 | -- Initialize -- | |
1397 | ---------------- | |
1398 | ||
481f29eb | 1399 | procedure Initialize (In_Tree : Project_Tree_Ref) is |
19235870 | 1400 | begin |
98c99a5a AC |
1401 | In_Tree.Shared.Private_Part.Current_Source_Path_File := No_Path; |
1402 | In_Tree.Shared.Private_Part.Current_Object_Path_File := No_Path; | |
19235870 RK |
1403 | end Initialize; |
1404 | ||
19235870 RK |
1405 | ------------------- |
1406 | -- Print_Sources -- | |
1407 | ------------------- | |
1408 | ||
24105bab AC |
1409 | -- Could use some comments in this body ??? |
1410 | ||
7e98a4c6 | 1411 | procedure Print_Sources (In_Tree : Project_Tree_Ref) is |
5a66a766 | 1412 | Unit : Unit_Index; |
19235870 RK |
1413 | |
1414 | begin | |
1415 | Write_Line ("List of Sources:"); | |
1416 | ||
5a66a766 EB |
1417 | Unit := Units_Htable.Get_First (In_Tree.Units_HT); |
1418 | ||
1419 | while Unit /= No_Unit_Index loop | |
19235870 RK |
1420 | Write_Str (" "); |
1421 | Write_Line (Namet.Get_Name_String (Unit.Name)); | |
1422 | ||
852dba80 AC |
1423 | if Unit.File_Names (Spec).File /= No_File then |
1424 | if Unit.File_Names (Spec).Project = No_Project then | |
19235870 RK |
1425 | Write_Line (" No project"); |
1426 | ||
1427 | else | |
1428 | Write_Str (" Project: "); | |
1429 | Get_Name_String | |
852dba80 | 1430 | (Unit.File_Names (Spec).Project.Path.Name); |
19235870 RK |
1431 | Write_Line (Name_Buffer (1 .. Name_Len)); |
1432 | end if; | |
1433 | ||
1434 | Write_Str (" spec: "); | |
1435 | Write_Line | |
1436 | (Namet.Get_Name_String | |
852dba80 | 1437 | (Unit.File_Names (Spec).File)); |
19235870 RK |
1438 | end if; |
1439 | ||
852dba80 AC |
1440 | if Unit.File_Names (Impl).File /= No_File then |
1441 | if Unit.File_Names (Impl).Project = No_Project then | |
19235870 RK |
1442 | Write_Line (" No project"); |
1443 | ||
1444 | else | |
1445 | Write_Str (" Project: "); | |
1446 | Get_Name_String | |
852dba80 | 1447 | (Unit.File_Names (Impl).Project.Path.Name); |
19235870 RK |
1448 | Write_Line (Name_Buffer (1 .. Name_Len)); |
1449 | end if; | |
1450 | ||
1451 | Write_Str (" body: "); | |
1452 | Write_Line | |
852dba80 | 1453 | (Namet.Get_Name_String (Unit.File_Names (Impl).File)); |
19235870 | 1454 | end if; |
5a66a766 EB |
1455 | |
1456 | Unit := Units_Htable.Get_Next (In_Tree.Units_HT); | |
19235870 RK |
1457 | end loop; |
1458 | ||
1459 | Write_Line ("end of List of Sources."); | |
1460 | end Print_Sources; | |
1461 | ||
b0f26df5 AC |
1462 | ---------------- |
1463 | -- Project_Of -- | |
1464 | ---------------- | |
1465 | ||
1466 | function Project_Of | |
1467 | (Name : String; | |
7e98a4c6 VC |
1468 | Main_Project : Project_Id; |
1469 | In_Tree : Project_Tree_Ref) return Project_Id | |
b0f26df5 AC |
1470 | is |
1471 | Result : Project_Id := No_Project; | |
1472 | ||
1473 | Original_Name : String := Name; | |
1474 | ||
fadcf313 | 1475 | Lang : constant Language_Ptr := |
84157c9a | 1476 | Get_Language_From_Name (Main_Project, "ada"); |
b0f26df5 | 1477 | |
5a66a766 | 1478 | Unit : Unit_Index; |
b0f26df5 | 1479 | |
38c2fd0c VC |
1480 | Current_Name : File_Name_Type; |
1481 | The_Original_Name : File_Name_Type; | |
1482 | The_Spec_Name : File_Name_Type; | |
1483 | The_Body_Name : File_Name_Type; | |
b0f26df5 | 1484 | |
b0f26df5 | 1485 | begin |
fadcf313 | 1486 | -- ??? Same block in File_Name_Of_Library_Unit_Body |
b0f26df5 AC |
1487 | Canonical_Case_File_Name (Original_Name); |
1488 | Name_Len := Original_Name'Length; | |
1489 | Name_Buffer (1 .. Name_Len) := Original_Name; | |
1490 | The_Original_Name := Name_Find; | |
1491 | ||
fadcf313 AC |
1492 | if Lang /= null then |
1493 | declare | |
1494 | Naming : Lang_Naming_Data renames Lang.Config.Naming_Data; | |
1495 | Extended_Spec_Name : String := | |
84157c9a RD |
1496 | Name & Namet.Get_Name_String |
1497 | (Naming.Spec_Suffix); | |
fadcf313 | 1498 | Extended_Body_Name : String := |
84157c9a RD |
1499 | Name & Namet.Get_Name_String |
1500 | (Naming.Body_Suffix); | |
1501 | ||
fadcf313 AC |
1502 | begin |
1503 | Canonical_Case_File_Name (Extended_Spec_Name); | |
1504 | Name_Len := Extended_Spec_Name'Length; | |
1505 | Name_Buffer (1 .. Name_Len) := Extended_Spec_Name; | |
1506 | The_Spec_Name := Name_Find; | |
1507 | ||
1508 | Canonical_Case_File_Name (Extended_Body_Name); | |
1509 | Name_Len := Extended_Body_Name'Length; | |
1510 | Name_Buffer (1 .. Name_Len) := Extended_Body_Name; | |
1511 | The_Body_Name := Name_Find; | |
1512 | end; | |
84157c9a | 1513 | |
fadcf313 AC |
1514 | else |
1515 | The_Spec_Name := The_Original_Name; | |
1516 | The_Body_Name := The_Original_Name; | |
1517 | end if; | |
b0f26df5 | 1518 | |
5a66a766 | 1519 | Unit := Units_Htable.Get_First (In_Tree.Units_HT); |
5a66a766 | 1520 | while Unit /= null loop |
84157c9a | 1521 | |
b0f26df5 AC |
1522 | -- Case of a body present |
1523 | ||
852dba80 AC |
1524 | if Unit.File_Names (Impl) /= null then |
1525 | Current_Name := Unit.File_Names (Impl).File; | |
ecad994d | 1526 | |
b0f26df5 AC |
1527 | -- If it has the name of the original name or the body name, |
1528 | -- we have found the project. | |
1529 | ||
ede007da | 1530 | if Unit.Name = Name_Id (The_Original_Name) |
b0f26df5 AC |
1531 | or else Current_Name = The_Original_Name |
1532 | or else Current_Name = The_Body_Name | |
1533 | then | |
852dba80 | 1534 | Result := Unit.File_Names (Impl).Project; |
b0f26df5 AC |
1535 | exit; |
1536 | end if; | |
1537 | end if; | |
1538 | ||
1539 | -- Check for spec | |
1540 | ||
852dba80 AC |
1541 | if Unit.File_Names (Spec) /= null then |
1542 | Current_Name := Unit.File_Names (Spec).File; | |
ecad994d | 1543 | |
b0f26df5 AC |
1544 | -- If name same as the original name, or the spec name, we have |
1545 | -- found the project. | |
1546 | ||
ede007da | 1547 | if Unit.Name = Name_Id (The_Original_Name) |
b0f26df5 AC |
1548 | or else Current_Name = The_Original_Name |
1549 | or else Current_Name = The_Spec_Name | |
1550 | then | |
852dba80 | 1551 | Result := Unit.File_Names (Spec).Project; |
b0f26df5 AC |
1552 | exit; |
1553 | end if; | |
1554 | end if; | |
5a66a766 EB |
1555 | |
1556 | Unit := Units_Htable.Get_Next (In_Tree.Units_HT); | |
b0f26df5 AC |
1557 | end loop; |
1558 | ||
1559 | -- Get the ultimate extending project | |
1560 | ||
1561 | if Result /= No_Project then | |
66713d62 AC |
1562 | while Result.Extended_By /= No_Project loop |
1563 | Result := Result.Extended_By; | |
b0f26df5 AC |
1564 | end loop; |
1565 | end if; | |
1566 | ||
1567 | return Result; | |
1568 | end Project_Of; | |
1569 | ||
fbf5a39b AC |
1570 | ------------------- |
1571 | -- Set_Ada_Paths -- | |
1572 | ------------------- | |
1573 | ||
1574 | procedure Set_Ada_Paths | |
1575 | (Project : Project_Id; | |
7e98a4c6 | 1576 | In_Tree : Project_Tree_Ref; |
b29def53 AC |
1577 | Including_Libraries : Boolean; |
1578 | Include_Path : Boolean := True; | |
1579 | Objects_Path : Boolean := True) | |
8eaf1723 | 1580 | |
fbf5a39b | 1581 | is |
98c99a5a AC |
1582 | Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared; |
1583 | ||
7bccff24 EB |
1584 | Source_Paths : Source_Path_Table.Instance; |
1585 | Object_Paths : Object_Path_Table.Instance; | |
1586 | -- List of source or object dirs. Only computed the first time this | |
1587 | -- procedure is called (since Source_FD is then reused) | |
1588 | ||
fbf5a39b AC |
1589 | Source_FD : File_Descriptor := Invalid_FD; |
1590 | Object_FD : File_Descriptor := Invalid_FD; | |
7bccff24 EB |
1591 | -- The temporary files to store the paths. These are only created the |
1592 | -- first time this procedure is called, and reused from then on. | |
fbf5a39b AC |
1593 | |
1594 | Process_Source_Dirs : Boolean := False; | |
1595 | Process_Object_Dirs : Boolean := False; | |
1596 | ||
1597 | Status : Boolean; | |
1598 | -- For calls to Close | |
1599 | ||
88eb6e62 AC |
1600 | Last : Natural; |
1601 | Buffer : String_Access := new String (1 .. Buffer_Initial); | |
68716ad5 | 1602 | Buffer_Last : Natural := 0; |
a336eaca | 1603 | |
40ecf2f5 EB |
1604 | procedure Recursive_Add |
1605 | (Project : Project_Id; | |
1606 | In_Tree : Project_Tree_Ref; | |
1607 | Dummy : in out Boolean); | |
8b9890fa EB |
1608 | -- Recursive procedure to add the source/object paths of extended/ |
1609 | -- imported projects. | |
fbf5a39b | 1610 | |
8b9890fa EB |
1611 | ------------------- |
1612 | -- Recursive_Add -- | |
1613 | ------------------- | |
fbf5a39b | 1614 | |
40ecf2f5 EB |
1615 | procedure Recursive_Add |
1616 | (Project : Project_Id; | |
1617 | In_Tree : Project_Tree_Ref; | |
1618 | Dummy : in out Boolean) | |
1619 | is | |
98c99a5a | 1620 | pragma Unreferenced (Dummy, In_Tree); |
8eaf1723 | 1621 | |
8b9890fa | 1622 | Path : Path_Name_Type; |
8eaf1723 | 1623 | |
8b9890fa EB |
1624 | begin |
1625 | -- ??? This is almost the equivalent of For_All_Source_Dirs | |
8eaf1723 | 1626 | |
8b9890fa | 1627 | if Process_Source_Dirs then |
fbf5a39b | 1628 | |
8eaf1723 RD |
1629 | -- Add to path all source directories of this project if there are |
1630 | -- Ada sources. | |
fbf5a39b | 1631 | |
66713d62 | 1632 | if Has_Ada_Sources (Project) then |
98c99a5a | 1633 | Add_To_Source_Path (Project.Source_Dirs, Shared, Source_Paths); |
a336eaca | 1634 | end if; |
8b9890fa | 1635 | end if; |
a336eaca | 1636 | |
8b9890fa EB |
1637 | if Process_Object_Dirs then |
1638 | Path := Get_Object_Directory | |
66713d62 | 1639 | (Project, |
8b9890fa EB |
1640 | Including_Libraries => Including_Libraries, |
1641 | Only_If_Ada => True); | |
a336eaca | 1642 | |
8b9890fa | 1643 | if Path /= No_Path then |
7bccff24 | 1644 | Add_To_Object_Path (Path, Object_Paths); |
8b9890fa EB |
1645 | end if; |
1646 | end if; | |
1647 | end Recursive_Add; | |
a336eaca | 1648 | |
8b9890fa EB |
1649 | procedure For_All_Projects is |
1650 | new For_Every_Project_Imported (Boolean, Recursive_Add); | |
88eb6e62 | 1651 | |
8b9890fa | 1652 | Dummy : Boolean := False; |
fbf5a39b AC |
1653 | |
1654 | -- Start of processing for Set_Ada_Paths | |
1655 | ||
1656 | begin | |
8eaf1723 RD |
1657 | -- If it is the first time we call this procedure for this project, |
1658 | -- compute the source path and/or the object path. | |
fbf5a39b | 1659 | |
b29def53 | 1660 | if Include_Path and then Project.Include_Path_File = No_Path then |
7bccff24 | 1661 | Source_Path_Table.Init (Source_Paths); |
fbf5a39b | 1662 | Process_Source_Dirs := True; |
98c99a5a | 1663 | Create_New_Path_File (Shared, Source_FD, Project.Include_Path_File); |
fbf5a39b AC |
1664 | end if; |
1665 | ||
1666 | -- For the object path, we make a distinction depending on | |
1667 | -- Including_Libraries. | |
1668 | ||
d151d6a3 | 1669 | if Objects_Path and Including_Libraries then |
66713d62 | 1670 | if Project.Objects_Path_File_With_Libs = No_Path then |
7bccff24 | 1671 | Object_Path_Table.Init (Object_Paths); |
fbf5a39b AC |
1672 | Process_Object_Dirs := True; |
1673 | Create_New_Path_File | |
98c99a5a | 1674 | (Shared, Object_FD, Project.Objects_Path_File_With_Libs); |
fbf5a39b AC |
1675 | end if; |
1676 | ||
b29def53 | 1677 | elsif Objects_Path then |
66713d62 | 1678 | if Project.Objects_Path_File_Without_Libs = No_Path then |
7bccff24 | 1679 | Object_Path_Table.Init (Object_Paths); |
fbf5a39b AC |
1680 | Process_Object_Dirs := True; |
1681 | Create_New_Path_File | |
98c99a5a | 1682 | (Shared, Object_FD, Project.Objects_Path_File_Without_Libs); |
fbf5a39b AC |
1683 | end if; |
1684 | end if; | |
1685 | ||
1686 | -- If there is something to do, set Seen to False for all projects, | |
1687 | -- then call the recursive procedure Add for Project. | |
1688 | ||
d151d6a3 | 1689 | if Process_Source_Dirs or Process_Object_Dirs then |
40ecf2f5 | 1690 | For_All_Projects (Project, In_Tree, Dummy); |
fbf5a39b AC |
1691 | end if; |
1692 | ||
7bccff24 EB |
1693 | -- Write and close any file that has been created. Source_FD is not set |
1694 | -- when this subprogram is called a second time or more, since we reuse | |
1695 | -- the previous version of the file. | |
fbf5a39b AC |
1696 | |
1697 | if Source_FD /= Invalid_FD then | |
68716ad5 AC |
1698 | Buffer_Last := 0; |
1699 | ||
7e98a4c6 | 1700 | for Index in Source_Path_Table.First .. |
7bccff24 | 1701 | Source_Path_Table.Last (Source_Paths) |
7e98a4c6 | 1702 | loop |
7bccff24 | 1703 | Get_Name_String (Source_Paths.Table (Index)); |
a336eaca AC |
1704 | Name_Len := Name_Len + 1; |
1705 | Name_Buffer (Name_Len) := ASCII.LF; | |
68716ad5 | 1706 | Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); |
a336eaca AC |
1707 | end loop; |
1708 | ||
68716ad5 AC |
1709 | Last := Write (Source_FD, Buffer (1)'Address, Buffer_Last); |
1710 | ||
1711 | if Last = Buffer_Last then | |
1712 | Close (Source_FD, Status); | |
1713 | ||
1714 | else | |
1715 | Status := False; | |
1716 | end if; | |
fbf5a39b AC |
1717 | |
1718 | if not Status then | |
68716ad5 | 1719 | Prj.Com.Fail ("could not write temporary file"); |
fbf5a39b AC |
1720 | end if; |
1721 | end if; | |
1722 | ||
1723 | if Object_FD /= Invalid_FD then | |
68716ad5 AC |
1724 | Buffer_Last := 0; |
1725 | ||
7e98a4c6 | 1726 | for Index in Object_Path_Table.First .. |
7bccff24 | 1727 | Object_Path_Table.Last (Object_Paths) |
7e98a4c6 | 1728 | loop |
7bccff24 | 1729 | Get_Name_String (Object_Paths.Table (Index)); |
a336eaca AC |
1730 | Name_Len := Name_Len + 1; |
1731 | Name_Buffer (Name_Len) := ASCII.LF; | |
68716ad5 | 1732 | Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); |
a336eaca AC |
1733 | end loop; |
1734 | ||
68716ad5 AC |
1735 | Last := Write (Object_FD, Buffer (1)'Address, Buffer_Last); |
1736 | ||
1737 | if Last = Buffer_Last then | |
1738 | Close (Object_FD, Status); | |
68716ad5 AC |
1739 | else |
1740 | Status := False; | |
1741 | end if; | |
fbf5a39b AC |
1742 | |
1743 | if not Status then | |
68716ad5 | 1744 | Prj.Com.Fail ("could not write temporary file"); |
fbf5a39b AC |
1745 | end if; |
1746 | end if; | |
1747 | ||
1748 | -- Set the env vars, if they need to be changed, and set the | |
1749 | -- corresponding flags. | |
1750 | ||
b29def53 | 1751 | if Include_Path and then |
98c99a5a AC |
1752 | Shared.Private_Part.Current_Source_Path_File /= |
1753 | Project.Include_Path_File | |
fbf5a39b | 1754 | then |
98c99a5a | 1755 | Shared.Private_Part.Current_Source_Path_File := |
66713d62 | 1756 | Project.Include_Path_File; |
fbf5a39b AC |
1757 | Set_Path_File_Var |
1758 | (Project_Include_Path_File, | |
98c99a5a | 1759 | Get_Name_String (Shared.Private_Part.Current_Source_Path_File)); |
fbf5a39b AC |
1760 | end if; |
1761 | ||
b29def53 AC |
1762 | if Objects_Path then |
1763 | if Including_Libraries then | |
98c99a5a | 1764 | if Shared.Private_Part.Current_Object_Path_File /= |
b29def53 AC |
1765 | Project.Objects_Path_File_With_Libs |
1766 | then | |
98c99a5a | 1767 | Shared.Private_Part.Current_Object_Path_File := |
b29def53 AC |
1768 | Project.Objects_Path_File_With_Libs; |
1769 | Set_Path_File_Var | |
1770 | (Project_Objects_Path_File, | |
1771 | Get_Name_String | |
98c99a5a | 1772 | (Shared.Private_Part.Current_Object_Path_File)); |
b29def53 | 1773 | end if; |
fbf5a39b | 1774 | |
b29def53 | 1775 | else |
98c99a5a | 1776 | if Shared.Private_Part.Current_Object_Path_File /= |
b29def53 AC |
1777 | Project.Objects_Path_File_Without_Libs |
1778 | then | |
98c99a5a | 1779 | Shared.Private_Part.Current_Object_Path_File := |
b29def53 AC |
1780 | Project.Objects_Path_File_Without_Libs; |
1781 | Set_Path_File_Var | |
1782 | (Project_Objects_Path_File, | |
1783 | Get_Name_String | |
98c99a5a | 1784 | (Shared.Private_Part.Current_Object_Path_File)); |
b29def53 | 1785 | end if; |
fbf5a39b AC |
1786 | end if; |
1787 | end if; | |
68716ad5 AC |
1788 | |
1789 | Free (Buffer); | |
fbf5a39b AC |
1790 | end Set_Ada_Paths; |
1791 | ||
fbf5a39b AC |
1792 | ----------------------- |
1793 | -- Set_Path_File_Var -- | |
1794 | ----------------------- | |
1795 | ||
1796 | procedure Set_Path_File_Var (Name : String; Value : String) is | |
1797 | Host_Spec : String_Access := To_Host_File_Spec (Value); | |
fbf5a39b AC |
1798 | begin |
1799 | if Host_Spec = null then | |
1800 | Prj.Com.Fail | |
3dd9959c | 1801 | ("could not convert file name """ & Value & """ to host spec"); |
fbf5a39b AC |
1802 | else |
1803 | Setenv (Name, Host_Spec.all); | |
1804 | Free (Host_Spec); | |
1805 | end if; | |
1806 | end Set_Path_File_Var; | |
1807 | ||
fbf5a39b AC |
1808 | --------------------------- |
1809 | -- Ultimate_Extension_Of -- | |
1810 | --------------------------- | |
1811 | ||
7e98a4c6 | 1812 | function Ultimate_Extension_Of |
66713d62 | 1813 | (Project : Project_Id) return Project_Id |
fbf5a39b | 1814 | is |
0b8074ed | 1815 | Result : Project_Id; |
fbf5a39b AC |
1816 | |
1817 | begin | |
0b8074ed | 1818 | Result := Project; |
66713d62 AC |
1819 | while Result.Extended_By /= No_Project loop |
1820 | Result := Result.Extended_By; | |
fbf5a39b AC |
1821 | end loop; |
1822 | ||
1823 | return Result; | |
1824 | end Ultimate_Extension_Of; | |
1825 | ||
a0a786e3 EB |
1826 | --------------------- |
1827 | -- Add_Directories -- | |
1828 | --------------------- | |
1829 | ||
1830 | procedure Add_Directories | |
1831 | (Self : in out Project_Search_Path; | |
1832 | Path : String) | |
1833 | is | |
1834 | Tmp : String_Access; | |
1835 | begin | |
1836 | if Self.Path = null then | |
1837 | Self.Path := new String'(Uninitialized_Prefix & Path); | |
1838 | else | |
1839 | Tmp := Self.Path; | |
1840 | Self.Path := new String'(Tmp.all & Path_Separator & Path); | |
1841 | Free (Tmp); | |
1842 | end if; | |
824e9320 AC |
1843 | |
1844 | if Current_Verbosity = High then | |
1845 | Debug_Output ("Adding directories to Project_Path: """ | |
1846 | & Path & '"'); | |
1847 | end if; | |
a0a786e3 EB |
1848 | end Add_Directories; |
1849 | ||
a96ca600 EB |
1850 | -------------------- |
1851 | -- Is_Initialized -- | |
1852 | -------------------- | |
1853 | ||
1854 | function Is_Initialized (Self : Project_Search_Path) return Boolean is | |
1855 | begin | |
1856 | return Self.Path /= null | |
1857 | and then (Self.Path'Length = 0 | |
e917aec2 | 1858 | or else Self.Path (Self.Path'First) /= '#'); |
a96ca600 EB |
1859 | end Is_Initialized; |
1860 | ||
1861 | ---------------------- | |
1862 | -- Initialize_Empty -- | |
1863 | ---------------------- | |
a0a786e3 | 1864 | |
a96ca600 EB |
1865 | procedure Initialize_Empty (Self : in out Project_Search_Path) is |
1866 | begin | |
1867 | Free (Self.Path); | |
1868 | Self.Path := new String'(""); | |
1869 | end Initialize_Empty; | |
1870 | ||
1871 | ------------------------------------- | |
1872 | -- Initialize_Default_Project_Path -- | |
1873 | ------------------------------------- | |
1874 | ||
1875 | procedure Initialize_Default_Project_Path | |
e917aec2 RD |
1876 | (Self : in out Project_Search_Path; |
1877 | Target_Name : String) | |
a0a786e3 EB |
1878 | is |
1879 | Add_Default_Dir : Boolean := True; | |
1880 | First : Positive; | |
1881 | Last : Positive; | |
1882 | New_Len : Positive; | |
1883 | New_Last : Positive; | |
1884 | ||
1885 | Ada_Project_Path : constant String := "ADA_PROJECT_PATH"; | |
1886 | Gpr_Project_Path : constant String := "GPR_PROJECT_PATH"; | |
1887 | -- Name of alternate env. variable that contain path name(s) of | |
1888 | -- directories where project files may reside. GPR_PROJECT_PATH has | |
1889 | -- precedence over ADA_PROJECT_PATH. | |
1890 | ||
1891 | Gpr_Prj_Path : String_Access; | |
1892 | Ada_Prj_Path : String_Access; | |
1893 | -- The path name(s) of directories where project files may reside. | |
1894 | -- May be empty. | |
1895 | ||
1896 | begin | |
a96ca600 | 1897 | if Is_Initialized (Self) then |
a0a786e3 EB |
1898 | return; |
1899 | end if; | |
1900 | ||
1901 | -- The current directory is always first in the search path. Since the | |
1902 | -- Project_Path currently starts with '#:' as a sign that it isn't | |
1903 | -- initialized, we simply replace '#' with '.' | |
1904 | ||
1905 | if Self.Path = null then | |
1906 | Self.Path := new String'('.' & Path_Separator); | |
1907 | else | |
1908 | Self.Path (Self.Path'First) := '.'; | |
1909 | end if; | |
1910 | ||
1911 | -- Then the reset of the project path (if any) currently contains the | |
1912 | -- directories added through Add_Search_Project_Directory | |
1913 | ||
1914 | -- If environment variables are defined and not empty, add their content | |
1915 | ||
1916 | Gpr_Prj_Path := Getenv (Gpr_Project_Path); | |
1917 | Ada_Prj_Path := Getenv (Ada_Project_Path); | |
1918 | ||
1919 | if Gpr_Prj_Path.all /= "" then | |
1920 | Add_Directories (Self, Gpr_Prj_Path.all); | |
1921 | end if; | |
1922 | ||
1923 | Free (Gpr_Prj_Path); | |
1924 | ||
1925 | if Ada_Prj_Path.all /= "" then | |
1926 | Add_Directories (Self, Ada_Prj_Path.all); | |
1927 | end if; | |
1928 | ||
1929 | Free (Ada_Prj_Path); | |
1930 | ||
1931 | -- Copy to Name_Buffer, since we will need to manipulate the path | |
1932 | ||
1933 | Name_Len := Self.Path'Length; | |
1934 | Name_Buffer (1 .. Name_Len) := Self.Path.all; | |
1935 | ||
1936 | -- Scan the directory path to see if "-" is one of the directories. | |
1937 | -- Remove each occurrence of "-" and set Add_Default_Dir to False. | |
1938 | -- Also resolve relative paths and symbolic links. | |
1939 | ||
1940 | First := 3; | |
1941 | loop | |
1942 | while First <= Name_Len | |
1943 | and then (Name_Buffer (First) = Path_Separator) | |
1944 | loop | |
1945 | First := First + 1; | |
1946 | end loop; | |
1947 | ||
1948 | exit when First > Name_Len; | |
1949 | ||
1950 | Last := First; | |
1951 | ||
1952 | while Last < Name_Len | |
1953 | and then Name_Buffer (Last + 1) /= Path_Separator | |
1954 | loop | |
1955 | Last := Last + 1; | |
1956 | end loop; | |
1957 | ||
1958 | -- If the directory is "-", set Add_Default_Dir to False and | |
1959 | -- remove from path. | |
1960 | ||
1961 | if Name_Buffer (First .. Last) = No_Project_Default_Dir then | |
1962 | Add_Default_Dir := False; | |
1963 | ||
1964 | for J in Last + 1 .. Name_Len loop | |
1965 | Name_Buffer (J - No_Project_Default_Dir'Length - 1) := | |
1966 | Name_Buffer (J); | |
1967 | end loop; | |
1968 | ||
1969 | Name_Len := Name_Len - No_Project_Default_Dir'Length - 1; | |
1970 | ||
1971 | -- After removing the '-', go back one character to get the next | |
1972 | -- directory correctly. | |
1973 | ||
1974 | Last := Last - 1; | |
1975 | ||
1976 | elsif not Hostparm.OpenVMS | |
1977 | or else not Is_Absolute_Path (Name_Buffer (First .. Last)) | |
1978 | then | |
1979 | -- On VMS, only expand relative path names, as absolute paths | |
1980 | -- may correspond to multi-valued VMS logical names. | |
1981 | ||
1982 | declare | |
1983 | New_Dir : constant String := | |
1984 | Normalize_Pathname | |
1985 | (Name_Buffer (First .. Last), | |
1986 | Resolve_Links => Opt.Follow_Links_For_Dirs); | |
1987 | ||
1988 | begin | |
1989 | -- If the absolute path was resolved and is different from | |
1990 | -- the original, replace original with the resolved path. | |
1991 | ||
1992 | if New_Dir /= Name_Buffer (First .. Last) | |
1993 | and then New_Dir'Length /= 0 | |
1994 | then | |
1995 | New_Len := Name_Len + New_Dir'Length - (Last - First + 1); | |
1996 | New_Last := First + New_Dir'Length - 1; | |
1997 | Name_Buffer (New_Last + 1 .. New_Len) := | |
1998 | Name_Buffer (Last + 1 .. Name_Len); | |
1999 | Name_Buffer (First .. New_Last) := New_Dir; | |
2000 | Name_Len := New_Len; | |
2001 | Last := New_Last; | |
2002 | end if; | |
2003 | end; | |
2004 | end if; | |
2005 | ||
2006 | First := Last + 1; | |
2007 | end loop; | |
2008 | ||
2009 | Free (Self.Path); | |
2010 | ||
2011 | -- Set the initial value of Current_Project_Path | |
2012 | ||
2013 | if Add_Default_Dir then | |
2014 | declare | |
2015 | Prefix : String_Ptr := Sdefault.Search_Dir_Prefix; | |
2016 | ||
2017 | begin | |
2018 | if Prefix = null then | |
2019 | Prefix := new String'(Executable_Prefix_Path); | |
2020 | ||
2021 | if Prefix.all /= "" then | |
2022 | if Target_Name /= "" then | |
1982d5a8 PO |
2023 | Add_Str_To_Name_Buffer |
2024 | (Path_Separator & Prefix.all & | |
2025 | Target_Name & Directory_Separator & | |
2026 | "lib" & Directory_Separator & "gnat"); | |
a0a786e3 EB |
2027 | end if; |
2028 | ||
2029 | Add_Str_To_Name_Buffer | |
2030 | (Path_Separator & Prefix.all & | |
2031 | "share" & Directory_Separator & "gpr"); | |
2032 | Add_Str_To_Name_Buffer | |
2033 | (Path_Separator & Prefix.all & | |
2034 | "lib" & Directory_Separator & "gnat"); | |
2035 | end if; | |
2036 | ||
2037 | else | |
2038 | Self.Path := | |
2039 | new String'(Name_Buffer (1 .. Name_Len) & Path_Separator & | |
2040 | Prefix.all & | |
2041 | ".." & Directory_Separator & | |
2042 | ".." & Directory_Separator & | |
2043 | ".." & Directory_Separator & "gnat"); | |
2044 | end if; | |
2045 | ||
2046 | Free (Prefix); | |
2047 | end; | |
2048 | end if; | |
2049 | ||
2050 | if Self.Path = null then | |
2051 | Self.Path := new String'(Name_Buffer (1 .. Name_Len)); | |
2052 | end if; | |
a96ca600 | 2053 | end Initialize_Default_Project_Path; |
a0a786e3 EB |
2054 | |
2055 | -------------- | |
2056 | -- Get_Path -- | |
2057 | -------------- | |
2058 | ||
e917aec2 | 2059 | procedure Get_Path (Self : Project_Search_Path; Path : out String_Access) is |
a0a786e3 | 2060 | begin |
a96ca600 | 2061 | pragma Assert (Is_Initialized (Self)); |
a0a786e3 EB |
2062 | Path := Self.Path; |
2063 | end Get_Path; | |
2064 | ||
92817e89 AC |
2065 | -------------- |
2066 | -- Set_Path -- | |
2067 | -------------- | |
a0a786e3 | 2068 | |
e917aec2 | 2069 | procedure Set_Path (Self : in out Project_Search_Path; Path : String) is |
a0a786e3 | 2070 | begin |
92817e89 AC |
2071 | Free (Self.Path); |
2072 | Self.Path := new String'(Path); | |
2073 | Projects_Paths.Reset (Self.Cache); | |
2074 | end Set_Path; | |
a0a786e3 EB |
2075 | |
2076 | ------------------ | |
2077 | -- Find_Project -- | |
2078 | ------------------ | |
2079 | ||
2080 | procedure Find_Project | |
2081 | (Self : in out Project_Search_Path; | |
2082 | Project_File_Name : String; | |
2083 | Directory : String; | |
a96ca600 | 2084 | Path : out Namet.Path_Name_Type) |
a0a786e3 EB |
2085 | is |
2086 | File : constant String := Project_File_Name; | |
2087 | -- Have to do a copy, in case the parameter is Name_Buffer, which we | |
2088 | -- modify below | |
2089 | ||
2090 | function Try_Path_Name (Path : String) return String_Access; | |
2091 | pragma Inline (Try_Path_Name); | |
2092 | -- Try the specified Path | |
2093 | ||
2094 | ------------------- | |
2095 | -- Try_Path_Name -- | |
2096 | ------------------- | |
2097 | ||
2098 | function Try_Path_Name (Path : String) return String_Access is | |
0d53d36b AC |
2099 | First : Natural; |
2100 | Last : Natural; | |
2101 | Result : String_Access := null; | |
a0a786e3 EB |
2102 | |
2103 | begin | |
2104 | if Current_Verbosity = High then | |
3e582869 | 2105 | Debug_Output ("Trying " & Path); |
a0a786e3 EB |
2106 | end if; |
2107 | ||
2108 | if Is_Absolute_Path (Path) then | |
2109 | if Is_Regular_File (Path) then | |
2110 | Result := new String'(Path); | |
2111 | end if; | |
2112 | ||
2113 | else | |
2114 | -- Because we don't want to resolve symbolic links, we cannot use | |
2115 | -- Locate_Regular_File. So, we try each possible path | |
2116 | -- successively. | |
2117 | ||
2118 | First := Self.Path'First; | |
2119 | while First <= Self.Path'Last loop | |
2120 | while First <= Self.Path'Last | |
2121 | and then Self.Path (First) = Path_Separator | |
2122 | loop | |
2123 | First := First + 1; | |
2124 | end loop; | |
2125 | ||
2126 | exit when First > Self.Path'Last; | |
2127 | ||
2128 | Last := First; | |
2129 | while Last < Self.Path'Last | |
2130 | and then Self.Path (Last + 1) /= Path_Separator | |
2131 | loop | |
2132 | Last := Last + 1; | |
2133 | end loop; | |
2134 | ||
2135 | Name_Len := 0; | |
2136 | ||
2137 | if not Is_Absolute_Path (Self.Path (First .. Last)) then | |
2138 | Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call | |
2139 | Add_Char_To_Name_Buffer (Directory_Separator); | |
2140 | end if; | |
2141 | ||
2142 | Add_Str_To_Name_Buffer (Self.Path (First .. Last)); | |
2143 | Add_Char_To_Name_Buffer (Directory_Separator); | |
2144 | Add_Str_To_Name_Buffer (Path); | |
2145 | ||
2146 | if Current_Verbosity = High then | |
3e582869 | 2147 | Debug_Output ("Testing file " & Name_Buffer (1 .. Name_Len)); |
a0a786e3 EB |
2148 | end if; |
2149 | ||
2150 | if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then | |
2151 | Result := new String'(Name_Buffer (1 .. Name_Len)); | |
2152 | exit; | |
2153 | end if; | |
2154 | ||
2155 | First := Last + 1; | |
2156 | end loop; | |
2157 | end if; | |
2158 | ||
2159 | return Result; | |
2160 | end Try_Path_Name; | |
2161 | ||
2162 | -- Local Declarations | |
2163 | ||
0d53d36b AC |
2164 | Result : String_Access; |
2165 | Has_Dot : Boolean := False; | |
2166 | Key : Name_Id; | |
a0a786e3 | 2167 | |
3e5daac4 | 2168 | -- Start of processing for Find_Project |
a0a786e3 EB |
2169 | |
2170 | begin | |
a96ca600 | 2171 | pragma Assert (Is_Initialized (Self)); |
a0a786e3 EB |
2172 | |
2173 | if Current_Verbosity = High then | |
3e582869 AC |
2174 | Debug_Increase_Indent |
2175 | ("Searching for project """ & File & """ in """ | |
2176 | & Directory & '"'); | |
a0a786e3 EB |
2177 | end if; |
2178 | ||
2179 | -- Check the project cache | |
2180 | ||
2181 | Name_Len := File'Length; | |
2182 | Name_Buffer (1 .. Name_Len) := File; | |
2183 | Key := Name_Find; | |
2184 | Path := Projects_Paths.Get (Self.Cache, Key); | |
2185 | ||
2186 | if Path /= No_Path then | |
3e582869 | 2187 | Debug_Decrease_Indent; |
a0a786e3 EB |
2188 | return; |
2189 | end if; | |
2190 | ||
2191 | -- Check if File contains an extension (a dot before a | |
2192 | -- directory separator). If it is the case we do not try project file | |
2193 | -- with an added extension as it is not possible to have multiple dots | |
2194 | -- on a project file name. | |
2195 | ||
2196 | Check_Dot : for K in reverse File'Range loop | |
2197 | if File (K) = '.' then | |
2198 | Has_Dot := True; | |
2199 | exit Check_Dot; | |
2200 | end if; | |
2201 | ||
2202 | exit Check_Dot when File (K) = Directory_Separator | |
2203 | or else File (K) = '/'; | |
2204 | end loop Check_Dot; | |
2205 | ||
2206 | if not Is_Absolute_Path (File) then | |
2207 | ||
2208 | -- First we try <directory>/<file_name>.<extension> | |
2209 | ||
2210 | if not Has_Dot then | |
2211 | Result := Try_Path_Name | |
2212 | (Directory & Directory_Separator & | |
2213 | File & Project_File_Extension); | |
2214 | end if; | |
2215 | ||
2216 | -- Then we try <directory>/<file_name> | |
2217 | ||
2218 | if Result = null then | |
2219 | Result := Try_Path_Name (Directory & Directory_Separator & File); | |
2220 | end if; | |
2221 | end if; | |
2222 | ||
2223 | -- Then we try <file_name>.<extension> | |
2224 | ||
2225 | if Result = null and then not Has_Dot then | |
2226 | Result := Try_Path_Name (File & Project_File_Extension); | |
2227 | end if; | |
2228 | ||
2229 | -- Then we try <file_name> | |
2230 | ||
2231 | if Result = null then | |
2232 | Result := Try_Path_Name (File); | |
2233 | end if; | |
2234 | ||
2235 | -- If we cannot find the project file, we return an empty string | |
2236 | ||
2237 | if Result = null then | |
2238 | Path := Namet.No_Path; | |
2239 | return; | |
2240 | ||
2241 | else | |
2242 | declare | |
2243 | Final_Result : constant String := | |
2244 | GNAT.OS_Lib.Normalize_Pathname | |
2245 | (Result.all, | |
2246 | Directory => Directory, | |
2247 | Resolve_Links => Opt.Follow_Links_For_Files, | |
2248 | Case_Sensitive => True); | |
2249 | begin | |
2250 | Free (Result); | |
2251 | Name_Len := Final_Result'Length; | |
2252 | Name_Buffer (1 .. Name_Len) := Final_Result; | |
2253 | Path := Name_Find; | |
2254 | Projects_Paths.Set (Self.Cache, Key, Path); | |
2255 | end; | |
2256 | end if; | |
3e582869 AC |
2257 | |
2258 | Debug_Decrease_Indent; | |
a0a786e3 EB |
2259 | end Find_Project; |
2260 | ||
2261 | ---------- | |
2262 | -- Free -- | |
2263 | ---------- | |
2264 | ||
2265 | procedure Free (Self : in out Project_Search_Path) is | |
2266 | begin | |
2267 | Free (Self.Path); | |
2268 | Projects_Paths.Reset (Self.Cache); | |
2269 | end Free; | |
2270 | ||
ab29a348 EB |
2271 | ---------- |
2272 | -- Copy -- | |
2273 | ---------- | |
2274 | ||
2275 | procedure Copy (From : Project_Search_Path; To : out Project_Search_Path) is | |
2276 | begin | |
2277 | Free (To); | |
9fde638d | 2278 | |
ab29a348 EB |
2279 | if From.Path /= null then |
2280 | To.Path := new String'(From.Path.all); | |
2281 | end if; | |
2282 | ||
9fde638d RD |
2283 | -- No need to copy the Cache, it will be recomputed as needed |
2284 | ||
ab29a348 EB |
2285 | end Copy; |
2286 | ||
19235870 | 2287 | end Prj.Env; |