]>
Commit | Line | Data |
---|---|---|
19235870 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- P R J -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
0df5ae93 | 9 | -- Copyright (C) 2001-2014, 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- -- | |
b5c84c3c | 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 -- | |
b5c84c3c RD |
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 | ||
ede007da | 26 | with Debug; |
833eaa8a | 27 | with Opt; |
fbf5a39b | 28 | with Osint; use Osint; |
7bccff24 | 29 | with Output; use Output; |
19235870 | 30 | with Prj.Attr; |
94fb7608 | 31 | with Prj.Com; |
fbf5a39b | 32 | with Prj.Err; use Prj.Err; |
fbf5a39b | 33 | with Snames; use Snames; |
aa720a54 | 34 | with Uintp; use Uintp; |
fbf5a39b | 35 | |
43ccd04b | 36 | with Ada.Characters.Handling; use Ada.Characters.Handling; |
72348e26 | 37 | with Ada.Containers.Ordered_Sets; |
43ccd04b AC |
38 | with Ada.Unchecked_Deallocation; |
39 | ||
f6da8aff | 40 | with GNAT.Case_Util; use GNAT.Case_Util; |
8b9890fa | 41 | with GNAT.Directory_Operations; use GNAT.Directory_Operations; |
55c1c66d | 42 | with GNAT.HTable; |
19235870 RK |
43 | |
44 | package body Prj is | |
45 | ||
dea1d3dc AC |
46 | type Restricted_Lang; |
47 | type Restricted_Lang_Access is access Restricted_Lang; | |
48 | type Restricted_Lang is record | |
49 | Name : Name_Id; | |
50 | Next : Restricted_Lang_Access; | |
51 | end record; | |
52 | ||
53 | Restricted_Languages : Restricted_Lang_Access := null; | |
54 | -- When null, all languages are allowed, otherwise only the languages in | |
55 | -- the list are allowed. | |
56 | ||
ede007da VC |
57 | Object_Suffix : constant String := Get_Target_Object_Suffix.all; |
58 | -- File suffix for object files | |
59 | ||
7e98a4c6 VC |
60 | Initial_Buffer_Size : constant := 100; |
61 | -- Initial size for extensible buffer used in Add_To_Buffer | |
62 | ||
7bccff24 | 63 | The_Empty_String : Name_Id := No_Name; |
7e98a4c6 | 64 | |
3e582869 | 65 | Debug_Level : Integer := 0; |
e917aec2 | 66 | -- Current indentation level for debug traces |
3e582869 | 67 | |
7bccff24 | 68 | type Cst_String_Access is access constant String; |
442c0581 | 69 | |
7bccff24 EB |
70 | All_Lower_Case_Image : aliased constant String := "lowercase"; |
71 | All_Upper_Case_Image : aliased constant String := "UPPERCASE"; | |
72 | Mixed_Case_Image : aliased constant String := "MixedCase"; | |
442c0581 | 73 | |
7bccff24 | 74 | The_Casing_Images : constant array (Known_Casing) of Cst_String_Access := |
442c0581 RD |
75 | (All_Lower_Case => All_Lower_Case_Image'Access, |
76 | All_Upper_Case => All_Upper_Case_Image'Access, | |
77 | Mixed_Case => Mixed_Case_Image'Access); | |
19235870 | 78 | |
d45871da | 79 | procedure Free (Project : in out Project_Id); |
93bcda23 AC |
80 | -- Free memory allocated for Project |
81 | ||
e0697153 | 82 | procedure Free_List (Languages : in out Language_Ptr); |
5d07d0cf | 83 | procedure Free_List (Source : in out Source_Id); |
e1c9f239 | 84 | procedure Free_List (Languages : in out Language_List); |
5d07d0cf | 85 | -- Free memory allocated for the list of languages or sources |
e0697153 | 86 | |
3e37be71 | 87 | procedure Reset_Units_In_Table (Table : in out Units_Htable.Instance); |
f0f88eb6 RD |
88 | -- Resets all Units to No_Unit_Index Unit.File_Names (Spec).Unit & |
89 | -- Unit.File_Names (Impl).Unit in the given table. | |
3e37be71 | 90 | |
5a66a766 EB |
91 | procedure Free_Units (Table : in out Units_Htable.Instance); |
92 | -- Free memory allocated for unit information in the project | |
93 | ||
5eed512d EB |
94 | procedure Language_Changed (Iter : in out Source_Iterator); |
95 | procedure Project_Changed (Iter : in out Source_Iterator); | |
e1f3cb58 | 96 | -- Called when a new project or language was selected for this iterator |
5eed512d | 97 | |
8b9890fa EB |
98 | function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean; |
99 | -- Return True if there is at least one ALI file in the directory Dir | |
100 | ||
dea1d3dc AC |
101 | ----------------------------- |
102 | -- Add_Restricted_Language -- | |
103 | ----------------------------- | |
104 | ||
105 | procedure Add_Restricted_Language (Name : String) is | |
106 | N : String (1 .. Name'Length) := Name; | |
107 | begin | |
108 | To_Lower (N); | |
109 | Name_Len := 0; | |
110 | Add_Str_To_Name_Buffer (N); | |
111 | Restricted_Languages := | |
112 | new Restricted_Lang'(Name => Name_Find, Next => Restricted_Languages); | |
113 | end Add_Restricted_Language; | |
114 | ||
ce532f42 AC |
115 | ------------------------------------- |
116 | -- Remove_All_Restricted_Languages -- | |
117 | ------------------------------------- | |
118 | ||
119 | procedure Remove_All_Restricted_Languages is | |
120 | begin | |
121 | Restricted_Languages := null; | |
122 | end Remove_All_Restricted_Languages; | |
123 | ||
fbf5a39b AC |
124 | ------------------- |
125 | -- Add_To_Buffer -- | |
126 | ------------------- | |
127 | ||
7e98a4c6 VC |
128 | procedure Add_To_Buffer |
129 | (S : String; | |
130 | To : in out String_Access; | |
131 | Last : in out Natural) | |
132 | is | |
fbf5a39b | 133 | begin |
7e98a4c6 VC |
134 | if To = null then |
135 | To := new String (1 .. Initial_Buffer_Size); | |
136 | Last := 0; | |
137 | end if; | |
138 | ||
fbf5a39b AC |
139 | -- If Buffer is too small, double its size |
140 | ||
7e98a4c6 | 141 | while Last + S'Length > To'Last loop |
fbf5a39b | 142 | declare |
ede007da | 143 | New_Buffer : constant String_Access := |
5f6fb720 | 144 | new String (1 .. 2 * To'Length); |
fbf5a39b AC |
145 | |
146 | begin | |
7e98a4c6 VC |
147 | New_Buffer (1 .. Last) := To (1 .. Last); |
148 | Free (To); | |
149 | To := New_Buffer; | |
fbf5a39b | 150 | end; |
7e98a4c6 | 151 | end loop; |
fbf5a39b | 152 | |
7e98a4c6 VC |
153 | To (Last + 1 .. Last + S'Length) := S; |
154 | Last := Last + S'Length; | |
fbf5a39b | 155 | end Add_To_Buffer; |
b30668b7 | 156 | |
94fb7608 AC |
157 | --------------------------------- |
158 | -- Current_Object_Path_File_Of -- | |
159 | --------------------------------- | |
160 | ||
161 | function Current_Object_Path_File_Of | |
f0f88eb6 RD |
162 | (Shared : Shared_Project_Tree_Data_Access) return Path_Name_Type |
163 | is | |
94fb7608 AC |
164 | begin |
165 | return Shared.Private_Part.Current_Object_Path_File; | |
166 | end Current_Object_Path_File_Of; | |
167 | ||
168 | --------------------------------- | |
169 | -- Current_Source_Path_File_Of -- | |
170 | --------------------------------- | |
171 | ||
172 | function Current_Source_Path_File_Of | |
173 | (Shared : Shared_Project_Tree_Data_Access) | |
174 | return Path_Name_Type is | |
175 | begin | |
176 | return Shared.Private_Part.Current_Source_Path_File; | |
177 | end Current_Source_Path_File_Of; | |
178 | ||
7bccff24 EB |
179 | --------------------------- |
180 | -- Delete_Temporary_File -- | |
181 | --------------------------- | |
7e98a4c6 | 182 | |
7bccff24 | 183 | procedure Delete_Temporary_File |
98c99a5a AC |
184 | (Shared : Shared_Project_Tree_Data_Access := null; |
185 | Path : Path_Name_Type) | |
7bccff24 EB |
186 | is |
187 | Dont_Care : Boolean; | |
188 | pragma Warnings (Off, Dont_Care); | |
442c0581 | 189 | |
7e98a4c6 | 190 | begin |
7bccff24 EB |
191 | if not Debug.Debug_Flag_N then |
192 | if Current_Verbosity = High then | |
193 | Write_Line ("Removing temp file: " & Get_Name_String (Path)); | |
194 | end if; | |
7e98a4c6 | 195 | |
7bccff24 | 196 | Delete_File (Get_Name_String (Path), Dont_Care); |
7e98a4c6 | 197 | |
98c99a5a AC |
198 | if Shared /= null then |
199 | for Index in | |
200 | 1 .. Temp_Files_Table.Last (Shared.Private_Part.Temp_Files) | |
201 | loop | |
202 | if Shared.Private_Part.Temp_Files.Table (Index) = Path then | |
203 | Shared.Private_Part.Temp_Files.Table (Index) := No_Path; | |
204 | end if; | |
205 | end loop; | |
206 | end if; | |
7bccff24 EB |
207 | end if; |
208 | end Delete_Temporary_File; | |
7e98a4c6 | 209 | |
fccd42a9 AC |
210 | ------------------------------ |
211 | -- Delete_Temp_Config_Files -- | |
212 | ------------------------------ | |
213 | ||
214 | procedure Delete_Temp_Config_Files (Project_Tree : Project_Tree_Ref) is | |
215 | Success : Boolean; | |
fccd42a9 AC |
216 | pragma Warnings (Off, Success); |
217 | ||
2c1b72d7 AC |
218 | Proj : Project_List; |
219 | ||
fccd42a9 AC |
220 | begin |
221 | if not Debug.Debug_Flag_N then | |
222 | if Project_Tree /= null then | |
223 | Proj := Project_Tree.Projects; | |
224 | while Proj /= null loop | |
225 | if Proj.Project.Config_File_Temp then | |
226 | Delete_Temporary_File | |
227 | (Project_Tree.Shared, Proj.Project.Config_File_Name); | |
228 | ||
229 | -- Make sure that we don't have a config file for this | |
230 | -- project, in case there are several mains. In this case, | |
231 | -- we will recreate another config file: we cannot reuse the | |
a90bd866 | 232 | -- one that we just deleted. |
fccd42a9 AC |
233 | |
234 | Proj.Project.Config_Checked := False; | |
235 | Proj.Project.Config_File_Name := No_Path; | |
236 | Proj.Project.Config_File_Temp := False; | |
237 | end if; | |
2c1b72d7 | 238 | |
fccd42a9 AC |
239 | Proj := Proj.Next; |
240 | end loop; | |
241 | end if; | |
242 | end if; | |
243 | end Delete_Temp_Config_Files; | |
244 | ||
ede007da VC |
245 | --------------------------- |
246 | -- Delete_All_Temp_Files -- | |
247 | --------------------------- | |
248 | ||
98c99a5a AC |
249 | procedure Delete_All_Temp_Files |
250 | (Shared : Shared_Project_Tree_Data_Access) | |
251 | is | |
ede007da | 252 | Dont_Care : Boolean; |
67ce0d7e | 253 | pragma Warnings (Off, Dont_Care); |
442c0581 | 254 | |
7bccff24 | 255 | Path : Path_Name_Type; |
442c0581 | 256 | |
ede007da VC |
257 | begin |
258 | if not Debug.Debug_Flag_N then | |
7bccff24 | 259 | for Index in |
98c99a5a | 260 | 1 .. Temp_Files_Table.Last (Shared.Private_Part.Temp_Files) |
7bccff24 | 261 | loop |
98c99a5a | 262 | Path := Shared.Private_Part.Temp_Files.Table (Index); |
7bccff24 EB |
263 | |
264 | if Path /= No_Path then | |
265 | if Current_Verbosity = High then | |
266 | Write_Line ("Removing temp file: " | |
267 | & Get_Name_String (Path)); | |
268 | end if; | |
269 | ||
270 | Delete_File (Get_Name_String (Path), Dont_Care); | |
271 | end if; | |
ede007da | 272 | end loop; |
7bccff24 | 273 | |
98c99a5a AC |
274 | Temp_Files_Table.Free (Shared.Private_Part.Temp_Files); |
275 | Temp_Files_Table.Init (Shared.Private_Part.Temp_Files); | |
7bccff24 EB |
276 | end if; |
277 | ||
278 | -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or | |
279 | -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to | |
280 | -- the empty string. On VMS, this has the effect of deassigning | |
281 | -- the logical names. | |
282 | ||
98c99a5a | 283 | if Shared.Private_Part.Current_Source_Path_File /= No_Path then |
7bccff24 | 284 | Setenv (Project_Include_Path_File, ""); |
7bccff24 EB |
285 | end if; |
286 | ||
98c99a5a | 287 | if Shared.Private_Part.Current_Object_Path_File /= No_Path then |
7bccff24 | 288 | Setenv (Project_Objects_Path_File, ""); |
ede007da VC |
289 | end if; |
290 | end Delete_All_Temp_Files; | |
291 | ||
292 | --------------------- | |
293 | -- Dependency_Name -- | |
294 | --------------------- | |
295 | ||
296 | function Dependency_Name | |
297 | (Source_File_Name : File_Name_Type; | |
298 | Dependency : Dependency_File_Kind) return File_Name_Type | |
299 | is | |
300 | begin | |
301 | case Dependency is | |
302 | when None => | |
303 | return No_File; | |
304 | ||
305 | when Makefile => | |
a8930b80 | 306 | return Extend_Name (Source_File_Name, Makefile_Dependency_Suffix); |
ede007da | 307 | |
50421527 | 308 | when ALI_File | ALI_Closure => |
a8930b80 | 309 | return Extend_Name (Source_File_Name, ALI_Dependency_Suffix); |
ede007da VC |
310 | end case; |
311 | end Dependency_Name; | |
312 | ||
ede007da VC |
313 | ---------------- |
314 | -- Empty_File -- | |
315 | ---------------- | |
316 | ||
317 | function Empty_File return File_Name_Type is | |
318 | begin | |
319 | return File_Name_Type (The_Empty_String); | |
320 | end Empty_File; | |
321 | ||
19235870 RK |
322 | ------------------- |
323 | -- Empty_Project -- | |
324 | ------------------- | |
325 | ||
c4d67e2d | 326 | function Empty_Project |
e917aec2 RD |
327 | (Qualifier : Project_Qualifier) return Project_Data |
328 | is | |
19235870 | 329 | begin |
7e98a4c6 | 330 | Prj.Initialize (Tree => No_Project_Tree); |
c4d67e2d AC |
331 | |
332 | declare | |
333 | Data : Project_Data (Qualifier => Qualifier); | |
e917aec2 | 334 | |
c4d67e2d AC |
335 | begin |
336 | -- Only the fields for which no default value could be provided in | |
767ab2fd | 337 | -- prj.ads are initialized below. |
c4d67e2d AC |
338 | |
339 | Data.Config := Default_Project_Config; | |
340 | return Data; | |
341 | end; | |
19235870 RK |
342 | end Empty_Project; |
343 | ||
344 | ------------------ | |
345 | -- Empty_String -- | |
346 | ------------------ | |
347 | ||
fbf5a39b | 348 | function Empty_String return Name_Id is |
19235870 RK |
349 | begin |
350 | return The_Empty_String; | |
351 | end Empty_String; | |
352 | ||
353 | ------------ | |
354 | -- Expect -- | |
355 | ------------ | |
356 | ||
357 | procedure Expect (The_Token : Token_Type; Token_Image : String) is | |
358 | begin | |
359 | if Token /= The_Token then | |
e917aec2 | 360 | |
e2d9085b | 361 | -- ??? Should pass user flags here instead |
e917aec2 | 362 | |
e2d9085b | 363 | Error_Msg (Gnatmake_Flags, Token_Image & " expected", Token_Ptr); |
19235870 RK |
364 | end if; |
365 | end Expect; | |
366 | ||
ede007da VC |
367 | ----------------- |
368 | -- Extend_Name -- | |
369 | ----------------- | |
370 | ||
371 | function Extend_Name | |
372 | (File : File_Name_Type; | |
373 | With_Suffix : String) return File_Name_Type | |
374 | is | |
375 | Last : Positive; | |
376 | ||
377 | begin | |
378 | Get_Name_String (File); | |
379 | Last := Name_Len + 1; | |
380 | ||
381 | while Name_Len /= 0 and then Name_Buffer (Name_Len) /= '.' loop | |
382 | Name_Len := Name_Len - 1; | |
383 | end loop; | |
384 | ||
385 | if Name_Len <= 1 then | |
386 | Name_Len := Last; | |
387 | end if; | |
388 | ||
389 | for J in With_Suffix'Range loop | |
390 | Name_Buffer (Name_Len) := With_Suffix (J); | |
391 | Name_Len := Name_Len + 1; | |
392 | end loop; | |
393 | ||
394 | Name_Len := Name_Len - 1; | |
395 | return Name_Find; | |
ede007da VC |
396 | end Extend_Name; |
397 | ||
dea1d3dc AC |
398 | ------------------------- |
399 | -- Is_Allowed_Language -- | |
400 | ------------------------- | |
401 | ||
402 | function Is_Allowed_Language (Name : Name_Id) return Boolean is | |
d781a615 | 403 | R : Restricted_Lang_Access := Restricted_Languages; |
dea1d3dc | 404 | Lang : constant String := Get_Name_String (Name); |
d781a615 | 405 | |
dea1d3dc AC |
406 | begin |
407 | if R = null then | |
408 | return True; | |
409 | ||
410 | else | |
411 | while R /= null loop | |
412 | if Get_Name_String (R.Name) = Lang then | |
413 | return True; | |
414 | end if; | |
415 | ||
416 | R := R.Next; | |
417 | end loop; | |
418 | ||
419 | return False; | |
420 | end if; | |
421 | end Is_Allowed_Language; | |
422 | ||
5eed512d EB |
423 | --------------------- |
424 | -- Project_Changed -- | |
425 | --------------------- | |
426 | ||
427 | procedure Project_Changed (Iter : in out Source_Iterator) is | |
428 | begin | |
735ca1b9 PO |
429 | if Iter.Project /= null then |
430 | Iter.Language := Iter.Project.Project.Languages; | |
431 | Language_Changed (Iter); | |
432 | end if; | |
5eed512d EB |
433 | end Project_Changed; |
434 | ||
435 | ---------------------- | |
436 | -- Language_Changed -- | |
437 | ---------------------- | |
438 | ||
439 | procedure Language_Changed (Iter : in out Source_Iterator) is | |
440 | begin | |
86828d40 | 441 | Iter.Current := No_Source; |
481f29eb | 442 | |
5eed512d EB |
443 | if Iter.Language_Name /= No_Name then |
444 | while Iter.Language /= null | |
445 | and then Iter.Language.Name /= Iter.Language_Name | |
446 | loop | |
447 | Iter.Language := Iter.Language.Next; | |
448 | end loop; | |
449 | end if; | |
450 | ||
451 | -- If there is no matching language in this project, move to next | |
452 | ||
453 | if Iter.Language = No_Language_Index then | |
454 | if Iter.All_Projects then | |
de6e4fc4 AC |
455 | loop |
456 | Iter.Project := Iter.Project.Next; | |
457 | exit when Iter.Project = null | |
458 | or else Iter.Encapsulated_Libs | |
459 | or else not Iter.Project.From_Encapsulated_Lib; | |
460 | end loop; | |
461 | ||
735ca1b9 | 462 | Project_Changed (Iter); |
5eed512d | 463 | else |
66713d62 | 464 | Iter.Project := null; |
5eed512d | 465 | end if; |
481f29eb | 466 | |
5eed512d EB |
467 | else |
468 | Iter.Current := Iter.Language.First_Source; | |
481f29eb | 469 | |
5eed512d EB |
470 | if Iter.Current = No_Source then |
471 | Iter.Language := Iter.Language.Next; | |
472 | Language_Changed (Iter); | |
0e564ab4 AC |
473 | |
474 | elsif not Iter.Locally_Removed | |
475 | and then Iter.Current.Locally_Removed | |
476 | then | |
477 | Next (Iter); | |
5eed512d EB |
478 | end if; |
479 | end if; | |
480 | end Language_Changed; | |
481 | ||
482 | --------------------- | |
483 | -- For_Each_Source -- | |
484 | --------------------- | |
485 | ||
486 | function For_Each_Source | |
de6e4fc4 AC |
487 | (In_Tree : Project_Tree_Ref; |
488 | Project : Project_Id := No_Project; | |
489 | Language : Name_Id := No_Name; | |
0e564ab4 AC |
490 | Encapsulated_Libs : Boolean := True; |
491 | Locally_Removed : Boolean := True) return Source_Iterator | |
5eed512d EB |
492 | is |
493 | Iter : Source_Iterator; | |
494 | begin | |
495 | Iter := Source_Iterator' | |
de6e4fc4 AC |
496 | (In_Tree => In_Tree, |
497 | Project => In_Tree.Projects, | |
498 | All_Projects => Project = No_Project, | |
499 | Language_Name => Language, | |
500 | Language => No_Language_Index, | |
501 | Current => No_Source, | |
0e564ab4 AC |
502 | Encapsulated_Libs => Encapsulated_Libs, |
503 | Locally_Removed => Locally_Removed); | |
5eed512d | 504 | |
66713d62 AC |
505 | if Project /= null then |
506 | while Iter.Project /= null | |
507 | and then Iter.Project.Project /= Project | |
508 | loop | |
509 | Iter.Project := Iter.Project.Next; | |
510 | end loop; | |
de6e4fc4 AC |
511 | |
512 | else | |
513 | while not Iter.Encapsulated_Libs | |
514 | and then Iter.Project.From_Encapsulated_Lib | |
515 | loop | |
516 | Iter.Project := Iter.Project.Next; | |
517 | end loop; | |
5eed512d EB |
518 | end if; |
519 | ||
520 | Project_Changed (Iter); | |
521 | ||
522 | return Iter; | |
523 | end For_Each_Source; | |
524 | ||
525 | ------------- | |
526 | -- Element -- | |
527 | ------------- | |
528 | ||
529 | function Element (Iter : Source_Iterator) return Source_Id is | |
530 | begin | |
531 | return Iter.Current; | |
532 | end Element; | |
533 | ||
534 | ---------- | |
535 | -- Next -- | |
536 | ---------- | |
537 | ||
538 | procedure Next (Iter : in out Source_Iterator) is | |
539 | begin | |
0e564ab4 AC |
540 | loop |
541 | Iter.Current := Iter.Current.Next_In_Lang; | |
542 | ||
543 | exit when Iter.Locally_Removed | |
544 | or else Iter.Current = No_Source | |
545 | or else not Iter.Current.Locally_Removed; | |
546 | end loop; | |
547 | ||
5eed512d EB |
548 | if Iter.Current = No_Source then |
549 | Iter.Language := Iter.Language.Next; | |
550 | Language_Changed (Iter); | |
551 | end if; | |
552 | end Next; | |
553 | ||
19235870 RK |
554 | -------------------------------- |
555 | -- For_Every_Project_Imported -- | |
556 | -------------------------------- | |
557 | ||
457c5df4 | 558 | procedure For_Every_Project_Imported_Context |
e917aec2 | 559 | (By : Project_Id; |
40ecf2f5 | 560 | Tree : Project_Tree_Ref; |
e917aec2 | 561 | With_State : in out State; |
c4d67e2d | 562 | Include_Aggregated : Boolean := True; |
e917aec2 | 563 | Imported_First : Boolean := False) |
19235870 | 564 | is |
8b9890fa | 565 | use Project_Boolean_Htable; |
19235870 | 566 | |
72348e26 | 567 | procedure Recursive_Check_Context |
457c5df4 AC |
568 | (Project : Project_Id; |
569 | Tree : Project_Tree_Ref; | |
570 | In_Aggregate_Lib : Boolean; | |
571 | From_Encapsulated_Lib : Boolean); | |
72348e26 AC |
572 | -- Recursively handle the project tree creating a new context for |
573 | -- keeping track about already handled projects. | |
44e1918a | 574 | |
72348e26 AC |
575 | ----------------------------- |
576 | -- Recursive_Check_Context -- | |
577 | ----------------------------- | |
19235870 | 578 | |
72348e26 | 579 | procedure Recursive_Check_Context |
457c5df4 AC |
580 | (Project : Project_Id; |
581 | Tree : Project_Tree_Ref; | |
582 | In_Aggregate_Lib : Boolean; | |
583 | From_Encapsulated_Lib : Boolean) | |
40ecf2f5 | 584 | is |
72348e26 AC |
585 | package Name_Id_Set is |
586 | new Ada.Containers.Ordered_Sets (Element_Type => Name_Id); | |
587 | ||
588 | Seen_Name : Name_Id_Set.Set; | |
8190087e | 589 | -- This set is needed to ensure that we do not handle the same |
72348e26 AC |
590 | -- project twice in the context of aggregate libraries. |
591 | ||
592 | procedure Recursive_Check | |
457c5df4 AC |
593 | (Project : Project_Id; |
594 | Tree : Project_Tree_Ref; | |
595 | In_Aggregate_Lib : Boolean; | |
596 | From_Encapsulated_Lib : Boolean); | |
72348e26 AC |
597 | -- Check if project has already been seen. If not, mark it as Seen, |
598 | -- Call Action, and check all its imported and aggregated projects. | |
599 | ||
600 | --------------------- | |
601 | -- Recursive_Check -- | |
602 | --------------------- | |
603 | ||
604 | procedure Recursive_Check | |
457c5df4 AC |
605 | (Project : Project_Id; |
606 | Tree : Project_Tree_Ref; | |
607 | In_Aggregate_Lib : Boolean; | |
608 | From_Encapsulated_Lib : Boolean) | |
72348e26 | 609 | is |
065dd775 AC |
610 | |
611 | function Has_Sources (P : Project_Id) return Boolean; | |
612 | -- Returns True if P has sources | |
613 | ||
614 | function Get_From_Tree (P : Project_Id) return Project_Id; | |
615 | -- Get project P from Tree. If P has no sources get another | |
616 | -- instance of this project with sources. If P has sources, | |
617 | -- returns it. | |
618 | ||
619 | ----------------- | |
620 | -- Has_Sources -- | |
621 | ----------------- | |
622 | ||
623 | function Has_Sources (P : Project_Id) return Boolean is | |
624 | Lang : Language_Ptr; | |
cd20e505 | 625 | |
065dd775 AC |
626 | begin |
627 | Lang := P.Languages; | |
628 | while Lang /= No_Language_Index loop | |
629 | if Lang.First_Source /= No_Source then | |
630 | return True; | |
631 | end if; | |
cd20e505 | 632 | |
065dd775 AC |
633 | Lang := Lang.Next; |
634 | end loop; | |
635 | ||
636 | return False; | |
637 | end Has_Sources; | |
638 | ||
639 | ------------------- | |
640 | -- Get_From_Tree -- | |
641 | ------------------- | |
642 | ||
643 | function Get_From_Tree (P : Project_Id) return Project_Id is | |
644 | List : Project_List := Tree.Projects; | |
cd20e505 | 645 | |
065dd775 AC |
646 | begin |
647 | if not Has_Sources (P) then | |
648 | while List /= null loop | |
649 | if List.Project.Name = P.Name | |
650 | and then Has_Sources (List.Project) | |
651 | then | |
652 | return List.Project; | |
653 | end if; | |
cd20e505 | 654 | |
065dd775 AC |
655 | List := List.Next; |
656 | end loop; | |
657 | end if; | |
658 | ||
659 | return P; | |
660 | end Get_From_Tree; | |
661 | ||
cd20e505 AC |
662 | -- Local variables |
663 | ||
72348e26 | 664 | List : Project_List; |
8eaf1723 | 665 | |
cd20e505 AC |
666 | -- Start of processing for Recursive_Check |
667 | ||
72348e26 AC |
668 | begin |
669 | if not Seen_Name.Contains (Project.Name) then | |
7471389a | 670 | |
72348e26 AC |
671 | -- Even if a project is aggregated multiple times in an |
672 | -- aggregated library, we will only return it once. | |
40ecf2f5 | 673 | |
72348e26 | 674 | Seen_Name.Include (Project.Name); |
8b9890fa | 675 | |
72348e26 | 676 | if not Imported_First then |
457c5df4 | 677 | Action |
065dd775 | 678 | (Get_From_Tree (Project), |
457c5df4 AC |
679 | Tree, |
680 | Project_Context'(In_Aggregate_Lib, From_Encapsulated_Lib), | |
681 | With_State); | |
72348e26 | 682 | end if; |
8b9890fa | 683 | |
72348e26 | 684 | -- Visit all extended projects |
19235870 | 685 | |
72348e26 | 686 | if Project.Extends /= No_Project then |
457c5df4 AC |
687 | Recursive_Check |
688 | (Project.Extends, Tree, | |
689 | In_Aggregate_Lib, From_Encapsulated_Lib); | |
72348e26 | 690 | end if; |
8b9890fa | 691 | |
72348e26 | 692 | -- Visit all imported projects |
8b9890fa | 693 | |
a17e8c05 AC |
694 | List := Project.Imported_Projects; |
695 | while List /= null loop | |
457c5df4 AC |
696 | Recursive_Check |
697 | (List.Project, Tree, | |
698 | In_Aggregate_Lib, | |
699 | From_Encapsulated_Lib | |
37da997b | 700 | or else Project.Standalone_Library = Encapsulated); |
a17e8c05 AC |
701 | List := List.Next; |
702 | end loop; | |
8b9890fa | 703 | |
72348e26 AC |
704 | -- Visit all aggregated projects |
705 | ||
706 | if Include_Aggregated | |
707 | and then Project.Qualifier in Aggregate_Project | |
708 | then | |
709 | declare | |
710 | Agg : Aggregated_Project_List; | |
711 | ||
712 | begin | |
713 | Agg := Project.Aggregated_Projects; | |
714 | while Agg /= null loop | |
715 | pragma Assert (Agg.Project /= No_Project); | |
716 | ||
717 | -- For aggregated libraries, the tree must be the one | |
718 | -- of the aggregate library. | |
c4d67e2d | 719 | |
72348e26 | 720 | if Project.Qualifier = Aggregate_Library then |
457c5df4 | 721 | Recursive_Check |
065dd775 | 722 | (Agg.Project, Tree, |
457c5df4 | 723 | True, |
37da997b RD |
724 | From_Encapsulated_Lib |
725 | or else | |
726 | Project.Standalone_Library = Encapsulated); | |
72348e26 AC |
727 | |
728 | else | |
72348e26 AC |
729 | -- Use a new context as we want to returns the same |
730 | -- project in different project tree for aggregated | |
731 | -- projects. | |
732 | ||
457c5df4 | 733 | Recursive_Check_Context |
065dd775 | 734 | (Agg.Project, Agg.Tree, False, False); |
72348e26 AC |
735 | end if; |
736 | ||
737 | Agg := Agg.Next; | |
738 | end loop; | |
739 | end; | |
740 | end if; | |
741 | ||
742 | if Imported_First then | |
457c5df4 | 743 | Action |
065dd775 | 744 | (Get_From_Tree (Project), |
457c5df4 AC |
745 | Tree, |
746 | Project_Context'(In_Aggregate_Lib, From_Encapsulated_Lib), | |
747 | With_State); | |
72348e26 | 748 | end if; |
8b9890fa | 749 | end if; |
72348e26 AC |
750 | end Recursive_Check; |
751 | ||
752 | -- Start of processing for Recursive_Check_Context | |
753 | ||
754 | begin | |
457c5df4 AC |
755 | Recursive_Check |
756 | (Project, Tree, In_Aggregate_Lib, From_Encapsulated_Lib); | |
72348e26 | 757 | end Recursive_Check_Context; |
19235870 | 758 | |
7e98a4c6 | 759 | -- Start of processing for For_Every_Project_Imported |
44e1918a | 760 | |
19235870 | 761 | begin |
72348e26 | 762 | Recursive_Check_Context |
457c5df4 AC |
763 | (Project => By, |
764 | Tree => Tree, | |
765 | In_Aggregate_Lib => False, | |
766 | From_Encapsulated_Lib => False); | |
767 | end For_Every_Project_Imported_Context; | |
768 | ||
769 | procedure For_Every_Project_Imported | |
770 | (By : Project_Id; | |
771 | Tree : Project_Tree_Ref; | |
772 | With_State : in out State; | |
773 | Include_Aggregated : Boolean := True; | |
774 | Imported_First : Boolean := False) | |
775 | is | |
776 | procedure Internal | |
777 | (Project : Project_Id; | |
778 | Tree : Project_Tree_Ref; | |
779 | Context : Project_Context; | |
780 | With_State : in out State); | |
781 | -- Action wrapper for handling the context | |
782 | ||
783 | -------------- | |
784 | -- Internal -- | |
785 | -------------- | |
786 | ||
787 | procedure Internal | |
788 | (Project : Project_Id; | |
789 | Tree : Project_Tree_Ref; | |
790 | Context : Project_Context; | |
791 | With_State : in out State) | |
792 | is | |
793 | pragma Unreferenced (Context); | |
794 | begin | |
795 | Action (Project, Tree, With_State); | |
796 | end Internal; | |
797 | ||
798 | procedure For_Projects is | |
799 | new For_Every_Project_Imported_Context (State, Internal); | |
800 | ||
801 | begin | |
802 | For_Projects (By, Tree, With_State, Include_Aggregated, Imported_First); | |
19235870 RK |
803 | end For_Every_Project_Imported; |
804 | ||
b0159fbe AC |
805 | ----------------- |
806 | -- Find_Source -- | |
807 | ----------------- | |
808 | ||
809 | function Find_Source | |
810 | (In_Tree : Project_Tree_Ref; | |
811 | Project : Project_Id; | |
fc2c32e2 EB |
812 | In_Imported_Only : Boolean := False; |
813 | In_Extended_Only : Boolean := False; | |
fccd42a9 AC |
814 | Base_Name : File_Name_Type; |
815 | Index : Int := 0) return Source_Id | |
b0159fbe | 816 | is |
01e17342 | 817 | Result : Source_Id := No_Source; |
b0159fbe | 818 | |
40ecf2f5 | 819 | procedure Look_For_Sources |
457c5df4 AC |
820 | (Proj : Project_Id; |
821 | Tree : Project_Tree_Ref; | |
822 | Src : in out Source_Id); | |
b0159fbe AC |
823 | -- Look for Base_Name in the sources of Proj |
824 | ||
01e17342 RD |
825 | ---------------------- |
826 | -- Look_For_Sources -- | |
827 | ---------------------- | |
828 | ||
40ecf2f5 | 829 | procedure Look_For_Sources |
457c5df4 AC |
830 | (Proj : Project_Id; |
831 | Tree : Project_Tree_Ref; | |
832 | Src : in out Source_Id) | |
40ecf2f5 | 833 | is |
b0159fbe | 834 | Iterator : Source_Iterator; |
01e17342 | 835 | |
b0159fbe | 836 | begin |
40ecf2f5 | 837 | Iterator := For_Each_Source (In_Tree => Tree, Project => Proj); |
b0159fbe | 838 | while Element (Iterator) /= No_Source loop |
fccd42a9 AC |
839 | if Element (Iterator).File = Base_Name |
840 | and then (Index = 0 or else Element (Iterator).Index = Index) | |
841 | then | |
b0159fbe | 842 | Src := Element (Iterator); |
78efd712 AC |
843 | |
844 | -- If the source has been excluded, continue looking. We will | |
845 | -- get the excluded source only if there is no other source | |
846 | -- with the same base name that is not locally removed. | |
847 | ||
848 | if not Element (Iterator).Locally_Removed then | |
849 | return; | |
850 | end if; | |
b0159fbe | 851 | end if; |
01e17342 | 852 | |
b0159fbe AC |
853 | Next (Iterator); |
854 | end loop; | |
855 | end Look_For_Sources; | |
856 | ||
857 | procedure For_Imported_Projects is new For_Every_Project_Imported | |
858 | (State => Source_Id, Action => Look_For_Sources); | |
859 | ||
fc2c32e2 EB |
860 | Proj : Project_Id; |
861 | ||
01e17342 RD |
862 | -- Start of processing for Find_Source |
863 | ||
b0159fbe | 864 | begin |
fc2c32e2 EB |
865 | if In_Extended_Only then |
866 | Proj := Project; | |
867 | while Proj /= No_Project loop | |
457c5df4 | 868 | Look_For_Sources (Proj, In_Tree, Result); |
fc2c32e2 EB |
869 | exit when Result /= No_Source; |
870 | ||
871 | Proj := Proj.Extends; | |
872 | end loop; | |
873 | ||
874 | elsif In_Imported_Only then | |
457c5df4 | 875 | Look_For_Sources (Project, In_Tree, Result); |
01e17342 | 876 | |
b0159fbe AC |
877 | if Result = No_Source then |
878 | For_Imported_Projects | |
767ab2fd EB |
879 | (By => Project, |
880 | Tree => In_Tree, | |
881 | Include_Aggregated => False, | |
882 | With_State => Result); | |
b0159fbe | 883 | end if; |
86828d40 | 884 | |
b0159fbe | 885 | else |
457c5df4 | 886 | Look_For_Sources (No_Project, In_Tree, Result); |
b0159fbe AC |
887 | end if; |
888 | ||
889 | return Result; | |
890 | end Find_Source; | |
891 | ||
0df5ae93 AC |
892 | ---------------------- |
893 | -- Find_All_Sources -- | |
894 | ---------------------- | |
895 | ||
896 | function Find_All_Sources | |
897 | (In_Tree : Project_Tree_Ref; | |
898 | Project : Project_Id; | |
899 | In_Imported_Only : Boolean := False; | |
900 | In_Extended_Only : Boolean := False; | |
901 | Base_Name : File_Name_Type; | |
902 | Index : Int := 0) return Source_Ids | |
903 | is | |
904 | Result : Source_Ids (1 .. 1_000); | |
905 | Last : Natural := 0; | |
906 | ||
907 | type Empty_State is null record; | |
908 | No_State : Empty_State; | |
b7b92f15 AC |
909 | -- This is needed for the State parameter of procedure Look_For_Sources |
910 | -- below, because of the instantiation For_Imported_Projects of generic | |
911 | -- procedure For_Every_Project_Imported. As procedure Look_For_Sources | |
912 | -- does not modify parameter State, there is no need to give its type | |
913 | -- more than one value. | |
0df5ae93 AC |
914 | |
915 | procedure Look_For_Sources | |
916 | (Proj : Project_Id; | |
917 | Tree : Project_Tree_Ref; | |
918 | State : in out Empty_State); | |
919 | -- Look for Base_Name in the sources of Proj | |
920 | ||
921 | ---------------------- | |
922 | -- Look_For_Sources -- | |
923 | ---------------------- | |
924 | ||
925 | procedure Look_For_Sources | |
926 | (Proj : Project_Id; | |
927 | Tree : Project_Tree_Ref; | |
928 | State : in out Empty_State) | |
929 | is | |
930 | Iterator : Source_Iterator; | |
931 | Src : Source_Id; | |
932 | ||
933 | begin | |
934 | State := No_State; | |
935 | ||
936 | Iterator := For_Each_Source (In_Tree => Tree, Project => Proj); | |
937 | while Element (Iterator) /= No_Source loop | |
938 | if Element (Iterator).File = Base_Name | |
939 | and then (Index = 0 | |
940 | or else | |
941 | (Element (Iterator).Unit /= No_Unit_Index | |
942 | and then | |
943 | Element (Iterator).Index = Index)) | |
944 | then | |
945 | Src := Element (Iterator); | |
946 | ||
947 | -- If the source has been excluded, continue looking. We will | |
948 | -- get the excluded source only if there is no other source | |
949 | -- with the same base name that is not locally removed. | |
950 | ||
951 | if not Element (Iterator).Locally_Removed then | |
952 | Last := Last + 1; | |
953 | Result (Last) := Src; | |
954 | end if; | |
955 | end if; | |
956 | ||
957 | Next (Iterator); | |
958 | end loop; | |
959 | end Look_For_Sources; | |
960 | ||
961 | procedure For_Imported_Projects is new For_Every_Project_Imported | |
962 | (State => Empty_State, Action => Look_For_Sources); | |
963 | ||
964 | Proj : Project_Id; | |
965 | ||
966 | -- Start of processing for Find_All_Sources | |
967 | ||
968 | begin | |
969 | if In_Extended_Only then | |
970 | Proj := Project; | |
971 | while Proj /= No_Project loop | |
972 | Look_For_Sources (Proj, In_Tree, No_State); | |
973 | exit when Last > 0; | |
974 | Proj := Proj.Extends; | |
975 | end loop; | |
976 | ||
977 | elsif In_Imported_Only then | |
978 | Look_For_Sources (Project, In_Tree, No_State); | |
979 | ||
980 | if Last = 0 then | |
981 | For_Imported_Projects | |
982 | (By => Project, | |
983 | Tree => In_Tree, | |
984 | Include_Aggregated => False, | |
985 | With_State => No_State); | |
986 | end if; | |
987 | ||
988 | else | |
989 | Look_For_Sources (No_Project, In_Tree, No_State); | |
990 | end if; | |
991 | ||
992 | return Result (1 .. Last); | |
993 | end Find_All_Sources; | |
994 | ||
44e1918a AC |
995 | ---------- |
996 | -- Hash -- | |
997 | ---------- | |
998 | ||
55c1c66d | 999 | function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num); |
6c1f47ee EB |
1000 | -- Used in implementation of other functions Hash below |
1001 | ||
0df5ae93 AC |
1002 | ---------- |
1003 | -- Hash -- | |
1004 | ---------- | |
1005 | ||
ede007da VC |
1006 | function Hash (Name : File_Name_Type) return Header_Num is |
1007 | begin | |
1008 | return Hash (Get_Name_String (Name)); | |
1009 | end Hash; | |
1010 | ||
44e1918a AC |
1011 | function Hash (Name : Name_Id) return Header_Num is |
1012 | begin | |
1013 | return Hash (Get_Name_String (Name)); | |
1014 | end Hash; | |
1015 | ||
ede007da | 1016 | function Hash (Name : Path_Name_Type) return Header_Num is |
38c2fd0c VC |
1017 | begin |
1018 | return Hash (Get_Name_String (Name)); | |
1019 | end Hash; | |
1020 | ||
4f469be3 VC |
1021 | function Hash (Project : Project_Id) return Header_Num is |
1022 | begin | |
66713d62 AC |
1023 | if Project = No_Project then |
1024 | return Header_Num'First; | |
1025 | else | |
1026 | return Hash (Get_Name_String (Project.Name)); | |
1027 | end if; | |
4f469be3 VC |
1028 | end Hash; |
1029 | ||
19235870 RK |
1030 | ----------- |
1031 | -- Image -- | |
1032 | ----------- | |
1033 | ||
55603e5e | 1034 | function Image (The_Casing : Casing_Type) return String is |
19235870 | 1035 | begin |
55603e5e | 1036 | return The_Casing_Images (The_Casing).all; |
19235870 RK |
1037 | end Image; |
1038 | ||
7bccff24 EB |
1039 | ----------------------------- |
1040 | -- Is_Standard_GNAT_Naming -- | |
1041 | ----------------------------- | |
1042 | ||
1043 | function Is_Standard_GNAT_Naming | |
1044 | (Naming : Lang_Naming_Data) return Boolean | |
1045 | is | |
1046 | begin | |
1047 | return Get_Name_String (Naming.Spec_Suffix) = ".ads" | |
1048 | and then Get_Name_String (Naming.Body_Suffix) = ".adb" | |
1049 | and then Get_Name_String (Naming.Dot_Replacement) = "-"; | |
1050 | end Is_Standard_GNAT_Naming; | |
1051 | ||
19235870 RK |
1052 | ---------------- |
1053 | -- Initialize -- | |
1054 | ---------------- | |
1055 | ||
7e98a4c6 | 1056 | procedure Initialize (Tree : Project_Tree_Ref) is |
19235870 | 1057 | begin |
7bccff24 | 1058 | if The_Empty_String = No_Name then |
aa720a54 | 1059 | Uintp.Initialize; |
fbf5a39b AC |
1060 | Name_Len := 0; |
1061 | The_Empty_String := Name_Find; | |
7324bf49 | 1062 | |
19235870 | 1063 | Prj.Attr.Initialize; |
ef237104 | 1064 | |
833eaa8a AC |
1065 | -- Make sure that new reserved words after Ada 95 may be used as |
1066 | -- identifiers. | |
1067 | ||
1068 | Opt.Ada_Version := Opt.Ada_95; | |
fb620b37 | 1069 | Opt.Ada_Version_Pragma := Empty; |
833eaa8a | 1070 | |
40ecf2f5 EB |
1071 | Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project)); |
1072 | Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends)); | |
1073 | Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External)); | |
ef237104 AC |
1074 | Set_Name_Table_Byte |
1075 | (Name_External_As_List, Token_Type'Pos (Tok_External_As_List)); | |
19235870 | 1076 | end if; |
7e98a4c6 VC |
1077 | |
1078 | if Tree /= No_Project_Tree then | |
1079 | Reset (Tree); | |
1080 | end if; | |
19235870 RK |
1081 | end Initialize; |
1082 | ||
ede007da VC |
1083 | ------------------ |
1084 | -- Is_Extending -- | |
1085 | ------------------ | |
1086 | ||
1087 | function Is_Extending | |
1088 | (Extending : Project_Id; | |
66713d62 | 1089 | Extended : Project_Id) return Boolean |
ede007da | 1090 | is |
d9c0e057 | 1091 | Proj : Project_Id; |
ede007da VC |
1092 | |
1093 | begin | |
d9c0e057 | 1094 | Proj := Extending; |
ede007da VC |
1095 | while Proj /= No_Project loop |
1096 | if Proj = Extended then | |
1097 | return True; | |
1098 | end if; | |
1099 | ||
66713d62 | 1100 | Proj := Proj.Extends; |
ede007da VC |
1101 | end loop; |
1102 | ||
1103 | return False; | |
1104 | end Is_Extending; | |
1105 | ||
ede007da VC |
1106 | ----------------- |
1107 | -- Object_Name -- | |
1108 | ----------------- | |
1109 | ||
1110 | function Object_Name | |
618fb570 | 1111 | (Source_File_Name : File_Name_Type; |
481f29eb | 1112 | Object_File_Suffix : Name_Id := No_Name) return File_Name_Type |
ede007da VC |
1113 | is |
1114 | begin | |
618fb570 | 1115 | if Object_File_Suffix = No_Name then |
f3b01cd9 AC |
1116 | return Extend_Name |
1117 | (Source_File_Name, Object_Suffix); | |
618fb570 AC |
1118 | else |
1119 | return Extend_Name | |
1120 | (Source_File_Name, Get_Name_String (Object_File_Suffix)); | |
1121 | end if; | |
ede007da VC |
1122 | end Object_Name; |
1123 | ||
c9df623a AC |
1124 | function Object_Name |
1125 | (Source_File_Name : File_Name_Type; | |
1126 | Source_Index : Int; | |
1127 | Index_Separator : Character; | |
1128 | Object_File_Suffix : Name_Id := No_Name) return File_Name_Type | |
1129 | is | |
1130 | Index_Img : constant String := Source_Index'Img; | |
1131 | Last : Natural; | |
c8c41617 | 1132 | |
c9df623a AC |
1133 | begin |
1134 | Get_Name_String (Source_File_Name); | |
c9df623a | 1135 | |
c8c41617 | 1136 | Last := Name_Len; |
c9df623a AC |
1137 | while Last > 1 and then Name_Buffer (Last) /= '.' loop |
1138 | Last := Last - 1; | |
1139 | end loop; | |
1140 | ||
1141 | if Last > 1 then | |
1142 | Name_Len := Last - 1; | |
1143 | end if; | |
1144 | ||
1145 | Add_Char_To_Name_Buffer (Index_Separator); | |
1146 | Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last)); | |
1147 | ||
1148 | if Object_File_Suffix = No_Name then | |
1149 | Add_Str_To_Name_Buffer (Object_Suffix); | |
c9df623a AC |
1150 | else |
1151 | Add_Str_To_Name_Buffer (Get_Name_String (Object_File_Suffix)); | |
1152 | end if; | |
1153 | ||
1154 | return Name_Find; | |
1155 | end Object_Name; | |
1156 | ||
ede007da VC |
1157 | ---------------------- |
1158 | -- Record_Temp_File -- | |
1159 | ---------------------- | |
1160 | ||
7bccff24 | 1161 | procedure Record_Temp_File |
98c99a5a AC |
1162 | (Shared : Shared_Project_Tree_Data_Access; |
1163 | Path : Path_Name_Type) | |
442c0581 | 1164 | is |
ede007da | 1165 | begin |
98c99a5a | 1166 | Temp_Files_Table.Append (Shared.Private_Part.Temp_Files, Path); |
ede007da VC |
1167 | end Record_Temp_File; |
1168 | ||
1f6821b4 AC |
1169 | ---------- |
1170 | -- Free -- | |
1171 | ---------- | |
1172 | ||
c4d67e2d AC |
1173 | procedure Free (List : in out Aggregated_Project_List) is |
1174 | procedure Unchecked_Free is new Ada.Unchecked_Deallocation | |
1175 | (Aggregated_Project, Aggregated_Project_List); | |
1176 | Tmp : Aggregated_Project_List; | |
1177 | begin | |
1178 | while List /= null loop | |
1179 | Tmp := List.Next; | |
40ecf2f5 EB |
1180 | |
1181 | Free (List.Tree); | |
1182 | ||
c4d67e2d AC |
1183 | Unchecked_Free (List); |
1184 | List := Tmp; | |
1185 | end loop; | |
1186 | end Free; | |
1187 | ||
1188 | ---------------------------- | |
1189 | -- Add_Aggregated_Project -- | |
1190 | ---------------------------- | |
1191 | ||
1192 | procedure Add_Aggregated_Project | |
ab986406 AC |
1193 | (Project : Project_Id; |
1194 | Path : Path_Name_Type) | |
1195 | is | |
1196 | Aggregated : Aggregated_Project_List; | |
1197 | ||
c4d67e2d | 1198 | begin |
ab986406 AC |
1199 | -- Check if the project is already in the aggregated project list. If it |
1200 | -- is, do not add it again. | |
1201 | ||
1202 | Aggregated := Project.Aggregated_Projects; | |
1203 | while Aggregated /= null loop | |
1204 | if Path = Aggregated.Path then | |
1205 | return; | |
1206 | else | |
1207 | Aggregated := Aggregated.Next; | |
1208 | end if; | |
1209 | end loop; | |
1210 | ||
c4d67e2d AC |
1211 | Project.Aggregated_Projects := new Aggregated_Project' |
1212 | (Path => Path, | |
1213 | Project => No_Project, | |
40ecf2f5 | 1214 | Tree => null, |
c4d67e2d AC |
1215 | Next => Project.Aggregated_Projects); |
1216 | end Add_Aggregated_Project; | |
1217 | ||
1218 | ---------- | |
1219 | -- Free -- | |
1220 | ---------- | |
1221 | ||
d45871da | 1222 | procedure Free (Project : in out Project_Id) is |
66713d62 AC |
1223 | procedure Unchecked_Free is new Ada.Unchecked_Deallocation |
1224 | (Project_Data, Project_Id); | |
0b8074ed | 1225 | |
93bcda23 | 1226 | begin |
66713d62 | 1227 | if Project /= null then |
66713d62 AC |
1228 | Free (Project.Ada_Include_Path); |
1229 | Free (Project.Objects_Path); | |
1230 | Free (Project.Ada_Objects_Path); | |
d0ef7921 | 1231 | Free (Project.Ada_Objects_Path_No_Libs); |
66713d62 AC |
1232 | Free_List (Project.Imported_Projects, Free_Project => False); |
1233 | Free_List (Project.All_Imported_Projects, Free_Project => False); | |
d45871da | 1234 | Free_List (Project.Languages); |
66713d62 | 1235 | |
c4d67e2d | 1236 | case Project.Qualifier is |
5415acbd | 1237 | when Aggregate | Aggregate_Library => |
c4d67e2d AC |
1238 | Free (Project.Aggregated_Projects); |
1239 | ||
1240 | when others => | |
1241 | null; | |
1242 | end case; | |
1243 | ||
66713d62 | 1244 | Unchecked_Free (Project); |
3563739b | 1245 | end if; |
93bcda23 AC |
1246 | end Free; |
1247 | ||
e0697153 EB |
1248 | --------------- |
1249 | -- Free_List -- | |
1250 | --------------- | |
1251 | ||
e1c9f239 EB |
1252 | procedure Free_List (Languages : in out Language_List) is |
1253 | procedure Unchecked_Free is new Ada.Unchecked_Deallocation | |
1254 | (Language_List_Element, Language_List); | |
1255 | Tmp : Language_List; | |
1256 | begin | |
1257 | while Languages /= null loop | |
1258 | Tmp := Languages.Next; | |
1259 | Unchecked_Free (Languages); | |
1260 | Languages := Tmp; | |
1261 | end loop; | |
1262 | end Free_List; | |
1263 | ||
1264 | --------------- | |
1265 | -- Free_List -- | |
1266 | --------------- | |
1267 | ||
5d07d0cf | 1268 | procedure Free_List (Source : in out Source_Id) is |
e1f3cb58 AC |
1269 | procedure Unchecked_Free is new |
1270 | Ada.Unchecked_Deallocation (Source_Data, Source_Id); | |
1271 | ||
5d07d0cf | 1272 | Tmp : Source_Id; |
e1f3cb58 | 1273 | |
5d07d0cf EB |
1274 | begin |
1275 | while Source /= No_Source loop | |
1276 | Tmp := Source.Next_In_Lang; | |
e1c9f239 | 1277 | Free_List (Source.Alternate_Languages); |
5a66a766 | 1278 | |
e1f3cb58 AC |
1279 | if Source.Unit /= null |
1280 | and then Source.Kind in Spec_Or_Body | |
1281 | then | |
5a66a766 EB |
1282 | Source.Unit.File_Names (Source.Kind) := null; |
1283 | end if; | |
1284 | ||
5d07d0cf EB |
1285 | Unchecked_Free (Source); |
1286 | Source := Tmp; | |
1287 | end loop; | |
1288 | end Free_List; | |
1289 | ||
1290 | --------------- | |
1291 | -- Free_List -- | |
1292 | --------------- | |
1293 | ||
66713d62 AC |
1294 | procedure Free_List |
1295 | (List : in out Project_List; | |
d45871da | 1296 | Free_Project : Boolean) |
66713d62 | 1297 | is |
e1f3cb58 AC |
1298 | procedure Unchecked_Free is new |
1299 | Ada.Unchecked_Deallocation (Project_List_Element, Project_List); | |
1300 | ||
3563739b | 1301 | Tmp : Project_List; |
0b8074ed | 1302 | |
3563739b AC |
1303 | begin |
1304 | while List /= null loop | |
1305 | Tmp := List.Next; | |
0b8074ed | 1306 | |
66713d62 | 1307 | if Free_Project then |
d45871da | 1308 | Free (List.Project); |
66713d62 AC |
1309 | end if; |
1310 | ||
3563739b AC |
1311 | Unchecked_Free (List); |
1312 | List := Tmp; | |
1313 | end loop; | |
1314 | end Free_List; | |
1315 | ||
1316 | --------------- | |
1317 | -- Free_List -- | |
1318 | --------------- | |
1319 | ||
e0697153 | 1320 | procedure Free_List (Languages : in out Language_Ptr) is |
e1f3cb58 AC |
1321 | procedure Unchecked_Free is new |
1322 | Ada.Unchecked_Deallocation (Language_Data, Language_Ptr); | |
1323 | ||
e0697153 | 1324 | Tmp : Language_Ptr; |
e1f3cb58 | 1325 | |
e0697153 EB |
1326 | begin |
1327 | while Languages /= null loop | |
1328 | Tmp := Languages.Next; | |
5d07d0cf | 1329 | Free_List (Languages.First_Source); |
e0697153 EB |
1330 | Unchecked_Free (Languages); |
1331 | Languages := Tmp; | |
1332 | end loop; | |
1333 | end Free_List; | |
1334 | ||
3e37be71 PG |
1335 | -------------------------- |
1336 | -- Reset_Units_In_Table -- | |
1337 | -------------------------- | |
1338 | ||
1339 | procedure Reset_Units_In_Table (Table : in out Units_Htable.Instance) is | |
1340 | Unit : Unit_Index; | |
1341 | ||
1342 | begin | |
1343 | Unit := Units_Htable.Get_First (Table); | |
1344 | while Unit /= No_Unit_Index loop | |
1345 | if Unit.File_Names (Spec) /= null then | |
1346 | Unit.File_Names (Spec).Unit := No_Unit_Index; | |
1347 | end if; | |
1348 | ||
1349 | if Unit.File_Names (Impl) /= null then | |
1350 | Unit.File_Names (Impl).Unit := No_Unit_Index; | |
1351 | end if; | |
1352 | ||
1353 | Unit := Units_Htable.Get_Next (Table); | |
1354 | end loop; | |
3e37be71 PG |
1355 | end Reset_Units_In_Table; |
1356 | ||
5a66a766 EB |
1357 | ---------------- |
1358 | -- Free_Units -- | |
1359 | ---------------- | |
1360 | ||
1361 | procedure Free_Units (Table : in out Units_Htable.Instance) is | |
e1f3cb58 AC |
1362 | procedure Unchecked_Free is new |
1363 | Ada.Unchecked_Deallocation (Unit_Data, Unit_Index); | |
1364 | ||
5a66a766 | 1365 | Unit : Unit_Index; |
e1f3cb58 | 1366 | |
5a66a766 EB |
1367 | begin |
1368 | Unit := Units_Htable.Get_First (Table); | |
5a66a766 | 1369 | while Unit /= No_Unit_Index loop |
e1f3cb58 | 1370 | |
f0f88eb6 | 1371 | -- We cannot reset Unit.File_Names (Impl or Spec).Unit here as |
3e37be71 PG |
1372 | -- Source_Data buffer is freed by the following instruction |
1373 | -- Free_List (Tree.Projects, Free_Project => True); | |
5a66a766 EB |
1374 | |
1375 | Unchecked_Free (Unit); | |
1376 | Unit := Units_Htable.Get_Next (Table); | |
1377 | end loop; | |
1378 | ||
1379 | Units_Htable.Reset (Table); | |
1380 | end Free_Units; | |
1381 | ||
93bcda23 AC |
1382 | ---------- |
1383 | -- Free -- | |
1384 | ---------- | |
1385 | ||
1f6821b4 | 1386 | procedure Free (Tree : in out Project_Tree_Ref) is |
e1f3cb58 | 1387 | procedure Unchecked_Free is new |
2c1b72d7 AC |
1388 | Ada.Unchecked_Deallocation |
1389 | (Project_Tree_Data, Project_Tree_Ref); | |
1390 | ||
1391 | procedure Unchecked_Free is new | |
1392 | Ada.Unchecked_Deallocation | |
9434c32e | 1393 | (Project_Tree_Appdata'Class, Project_Tree_Appdata_Access); |
481f29eb | 1394 | |
1f6821b4 AC |
1395 | begin |
1396 | if Tree /= null then | |
40ecf2f5 | 1397 | if Tree.Is_Root_Tree then |
f9ad6b62 AC |
1398 | Name_List_Table.Free (Tree.Shared.Name_Lists); |
1399 | Number_List_Table.Free (Tree.Shared.Number_Lists); | |
1400 | String_Element_Table.Free (Tree.Shared.String_Elements); | |
40ecf2f5 | 1401 | Variable_Element_Table.Free (Tree.Shared.Variable_Elements); |
f9ad6b62 AC |
1402 | Array_Element_Table.Free (Tree.Shared.Array_Elements); |
1403 | Array_Table.Free (Tree.Shared.Arrays); | |
1404 | Package_Table.Free (Tree.Shared.Packages); | |
1405 | Temp_Files_Table.Free (Tree.Shared.Private_Part.Temp_Files); | |
40ecf2f5 EB |
1406 | end if; |
1407 | ||
9434c32e EB |
1408 | if Tree.Appdata /= null then |
1409 | Free (Tree.Appdata.all); | |
1410 | Unchecked_Free (Tree.Appdata); | |
1411 | end if; | |
1412 | ||
1f6821b4 | 1413 | Source_Paths_Htable.Reset (Tree.Source_Paths_HT); |
f166413a | 1414 | Source_Files_Htable.Reset (Tree.Source_Files_HT); |
1f6821b4 | 1415 | |
3e37be71 | 1416 | Reset_Units_In_Table (Tree.Units_HT); |
d45871da | 1417 | Free_List (Tree.Projects, Free_Project => True); |
5a66a766 | 1418 | Free_Units (Tree.Units_HT); |
93bcda23 | 1419 | |
1f6821b4 AC |
1420 | Unchecked_Free (Tree); |
1421 | end if; | |
1422 | end Free; | |
1423 | ||
15ce9ca2 AC |
1424 | ----------- |
1425 | -- Reset -- | |
1426 | ----------- | |
19235870 | 1427 | |
7e98a4c6 | 1428 | procedure Reset (Tree : Project_Tree_Ref) is |
19235870 | 1429 | begin |
ede007da VC |
1430 | -- Visible tables |
1431 | ||
40ecf2f5 | 1432 | if Tree.Is_Root_Tree then |
686d0984 | 1433 | |
40ecf2f5 EB |
1434 | -- We cannot use 'Access here: |
1435 | -- "illegal attribute for discriminant-dependent component" | |
1436 | -- However, we know this is valid since Shared and Shared_Data have | |
1437 | -- the same lifetime and will always exist concurrently. | |
686d0984 | 1438 | |
40ecf2f5 | 1439 | Tree.Shared := Tree.Shared_Data'Unrestricted_Access; |
686d0984 AC |
1440 | Name_List_Table.Init (Tree.Shared.Name_Lists); |
1441 | Number_List_Table.Init (Tree.Shared.Number_Lists); | |
1442 | String_Element_Table.Init (Tree.Shared.String_Elements); | |
1443 | Variable_Element_Table.Init (Tree.Shared.Variable_Elements); | |
1444 | Array_Element_Table.Init (Tree.Shared.Array_Elements); | |
1445 | Array_Table.Init (Tree.Shared.Arrays); | |
1446 | Package_Table.Init (Tree.Shared.Packages); | |
98c99a5a AC |
1447 | |
1448 | -- Private part table | |
1449 | ||
1450 | Temp_Files_Table.Init (Tree.Shared.Private_Part.Temp_Files); | |
1451 | ||
1452 | Tree.Shared.Private_Part.Current_Source_Path_File := No_Path; | |
1453 | Tree.Shared.Private_Part.Current_Object_Path_File := No_Path; | |
40ecf2f5 EB |
1454 | end if; |
1455 | ||
686d0984 AC |
1456 | Source_Paths_Htable.Reset (Tree.Source_Paths_HT); |
1457 | Source_Files_Htable.Reset (Tree.Source_Files_HT); | |
1458 | Replaced_Source_HTable.Reset (Tree.Replaced_Sources); | |
72e9f2b9 AC |
1459 | |
1460 | Tree.Replaced_Source_Number := 0; | |
ede007da | 1461 | |
3e37be71 | 1462 | Reset_Units_In_Table (Tree.Units_HT); |
d45871da | 1463 | Free_List (Tree.Projects, Free_Project => True); |
5a66a766 | 1464 | Free_Units (Tree.Units_HT); |
19235870 RK |
1465 | end Reset; |
1466 | ||
94fb7608 AC |
1467 | ------------------------------------- |
1468 | -- Set_Current_Object_Path_File_Of -- | |
1469 | ------------------------------------- | |
1470 | ||
1471 | procedure Set_Current_Object_Path_File_Of | |
1472 | (Shared : Shared_Project_Tree_Data_Access; | |
1473 | To : Path_Name_Type) | |
1474 | is | |
1475 | begin | |
1476 | Shared.Private_Part.Current_Object_Path_File := To; | |
1477 | end Set_Current_Object_Path_File_Of; | |
1478 | ||
1479 | ------------------------------------- | |
1480 | -- Set_Current_Source_Path_File_Of -- | |
1481 | ------------------------------------- | |
1482 | ||
1483 | procedure Set_Current_Source_Path_File_Of | |
1484 | (Shared : Shared_Project_Tree_Data_Access; | |
1485 | To : Path_Name_Type) | |
1486 | is | |
1487 | begin | |
1488 | Shared.Private_Part.Current_Source_Path_File := To; | |
1489 | end Set_Current_Source_Path_File_Of; | |
1490 | ||
1491 | ----------------------- | |
1492 | -- Set_Path_File_Var -- | |
1493 | ----------------------- | |
1494 | ||
1495 | procedure Set_Path_File_Var (Name : String; Value : String) is | |
1496 | Host_Spec : String_Access := To_Host_File_Spec (Value); | |
1497 | begin | |
1498 | if Host_Spec = null then | |
1499 | Prj.Com.Fail | |
1500 | ("could not convert file name """ & Value & """ to host spec"); | |
1501 | else | |
1502 | Setenv (Name, Host_Spec.all); | |
1503 | Free (Host_Spec); | |
1504 | end if; | |
1505 | end Set_Path_File_Var; | |
1506 | ||
ede007da VC |
1507 | ------------------- |
1508 | -- Switches_Name -- | |
1509 | ------------------- | |
1510 | ||
1511 | function Switches_Name | |
1512 | (Source_File_Name : File_Name_Type) return File_Name_Type | |
1513 | is | |
1514 | begin | |
1515 | return Extend_Name (Source_File_Name, Switches_Dependency_Suffix); | |
1516 | end Switches_Name; | |
1517 | ||
19235870 RK |
1518 | ----------- |
1519 | -- Value -- | |
1520 | ----------- | |
1521 | ||
1522 | function Value (Image : String) return Casing_Type is | |
1523 | begin | |
1524 | for Casing in The_Casing_Images'Range loop | |
1525 | if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then | |
1526 | return Casing; | |
1527 | end if; | |
1528 | end loop; | |
1529 | ||
1530 | raise Constraint_Error; | |
1531 | end Value; | |
1532 | ||
76e776e5 AC |
1533 | --------------------- |
1534 | -- Has_Ada_Sources -- | |
1535 | --------------------- | |
1536 | ||
66713d62 | 1537 | function Has_Ada_Sources (Data : Project_Id) return Boolean is |
8eaf1723 RD |
1538 | Lang : Language_Ptr; |
1539 | ||
76e776e5 | 1540 | begin |
8eaf1723 | 1541 | Lang := Data.Languages; |
76e776e5 AC |
1542 | while Lang /= No_Language_Index loop |
1543 | if Lang.Name = Name_Ada then | |
1544 | return Lang.First_Source /= No_Source; | |
1545 | end if; | |
1546 | Lang := Lang.Next; | |
1547 | end loop; | |
1548 | ||
1549 | return False; | |
1550 | end Has_Ada_Sources; | |
1551 | ||
8b9890fa EB |
1552 | ------------------------ |
1553 | -- Contains_ALI_Files -- | |
1554 | ------------------------ | |
1555 | ||
1556 | function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is | |
1557 | Dir_Name : constant String := Get_Name_String (Dir); | |
8eaf1723 RD |
1558 | Direct : Dir_Type; |
1559 | Name : String (1 .. 1_000); | |
1560 | Last : Natural; | |
1561 | Result : Boolean := False; | |
8b9890fa EB |
1562 | |
1563 | begin | |
1564 | Open (Direct, Dir_Name); | |
1565 | ||
1566 | -- For each file in the directory, check if it is an ALI file | |
1567 | ||
1568 | loop | |
1569 | Read (Direct, Name, Last); | |
1570 | exit when Last = 0; | |
1571 | Canonical_Case_File_Name (Name (1 .. Last)); | |
1572 | Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali"; | |
1573 | exit when Result; | |
1574 | end loop; | |
1575 | ||
1576 | Close (Direct); | |
1577 | return Result; | |
1578 | ||
1579 | exception | |
8eaf1723 RD |
1580 | -- If there is any problem, close the directory if open and return True. |
1581 | -- The library directory will be added to the path. | |
8b9890fa EB |
1582 | |
1583 | when others => | |
1584 | if Is_Open (Direct) then | |
1585 | Close (Direct); | |
1586 | end if; | |
1587 | ||
1588 | return True; | |
1589 | end Contains_ALI_Files; | |
1590 | ||
1591 | -------------------------- | |
1592 | -- Get_Object_Directory -- | |
1593 | -------------------------- | |
1594 | ||
1595 | function Get_Object_Directory | |
66713d62 | 1596 | (Project : Project_Id; |
8b9890fa EB |
1597 | Including_Libraries : Boolean; |
1598 | Only_If_Ada : Boolean := False) return Path_Name_Type | |
1599 | is | |
8b9890fa | 1600 | begin |
d1ced162 | 1601 | if (Project.Library and then Including_Libraries) |
8b9890fa | 1602 | or else |
66713d62 AC |
1603 | (Project.Object_Directory /= No_Path_Information |
1604 | and then (not Including_Libraries or else not Project.Library)) | |
8b9890fa EB |
1605 | then |
1606 | -- For a library project, add the library ALI directory if there is | |
1607 | -- no object directory or if the library ALI directory contains ALI | |
1608 | -- files; otherwise add the object directory. | |
1609 | ||
66713d62 AC |
1610 | if Project.Library then |
1611 | if Project.Object_Directory = No_Path_Information | |
d0ef7921 AC |
1612 | or else |
1613 | (Including_Libraries | |
8edc33fa RD |
1614 | and then |
1615 | Contains_ALI_Files (Project.Library_ALI_Dir.Display_Name)) | |
8b9890fa | 1616 | then |
8cce3d75 | 1617 | return Project.Library_ALI_Dir.Display_Name; |
8b9890fa | 1618 | else |
8cce3d75 | 1619 | return Project.Object_Directory.Display_Name; |
8b9890fa EB |
1620 | end if; |
1621 | ||
1622 | -- For a non-library project, add object directory if it is not a | |
1623 | -- virtual project, and if there are Ada sources in the project or | |
1624 | -- one of the projects it extends. If there are no Ada sources, | |
1625 | -- adding the object directory could disrupt the order of the | |
1626 | -- object dirs in the path. | |
1627 | ||
66713d62 | 1628 | elsif not Project.Virtual then |
8b9890fa | 1629 | declare |
8eaf1723 RD |
1630 | Add_Object_Dir : Boolean; |
1631 | Prj : Project_Id; | |
8b9890fa EB |
1632 | |
1633 | begin | |
8eaf1723 RD |
1634 | Add_Object_Dir := not Only_If_Ada; |
1635 | Prj := Project; | |
8b9890fa | 1636 | while not Add_Object_Dir and then Prj /= No_Project loop |
66713d62 | 1637 | if Has_Ada_Sources (Prj) then |
8b9890fa EB |
1638 | Add_Object_Dir := True; |
1639 | else | |
66713d62 | 1640 | Prj := Prj.Extends; |
8b9890fa EB |
1641 | end if; |
1642 | end loop; | |
1643 | ||
1644 | if Add_Object_Dir then | |
61619168 | 1645 | return Project.Object_Directory.Display_Name; |
8b9890fa EB |
1646 | end if; |
1647 | end; | |
1648 | end if; | |
1649 | end if; | |
8eaf1723 | 1650 | |
8b9890fa EB |
1651 | return No_Path; |
1652 | end Get_Object_Directory; | |
1653 | ||
1654 | ----------------------------------- | |
1655 | -- Ultimate_Extending_Project_Of -- | |
1656 | ----------------------------------- | |
1657 | ||
1658 | function Ultimate_Extending_Project_Of | |
66713d62 | 1659 | (Proj : Project_Id) return Project_Id |
8b9890fa | 1660 | is |
8eaf1723 RD |
1661 | Prj : Project_Id; |
1662 | ||
8b9890fa | 1663 | begin |
8eaf1723 | 1664 | Prj := Proj; |
0b8074ed | 1665 | while Prj /= null and then Prj.Extended_By /= No_Project loop |
66713d62 | 1666 | Prj := Prj.Extended_By; |
8b9890fa EB |
1667 | end loop; |
1668 | ||
1669 | return Prj; | |
1670 | end Ultimate_Extending_Project_Of; | |
1671 | ||
1672 | ----------------------------------- | |
1673 | -- Compute_All_Imported_Projects -- | |
1674 | ----------------------------------- | |
1675 | ||
444acbdd AC |
1676 | procedure Compute_All_Imported_Projects |
1677 | (Root_Project : Project_Id; | |
1678 | Tree : Project_Tree_Ref) | |
1679 | is | |
1680 | procedure Analyze_Tree | |
3ddd922e | 1681 | (Local_Root : Project_Id; |
75685ef7 PO |
1682 | Local_Tree : Project_Tree_Ref; |
1683 | Context : Project_Context); | |
444acbdd AC |
1684 | -- Process Project and all its aggregated project to analyze their own |
1685 | -- imported projects. | |
1686 | ||
1687 | ------------------ | |
1688 | -- Analyze_Tree -- | |
1689 | ------------------ | |
1690 | ||
1691 | procedure Analyze_Tree | |
3ddd922e | 1692 | (Local_Root : Project_Id; |
75685ef7 PO |
1693 | Local_Tree : Project_Tree_Ref; |
1694 | Context : Project_Context) | |
40ecf2f5 | 1695 | is |
444acbdd AC |
1696 | pragma Unreferenced (Local_Root); |
1697 | ||
1698 | Project : Project_Id; | |
1699 | ||
1700 | procedure Recursive_Add | |
a76b09dc PO |
1701 | (Prj : Project_Id; |
1702 | Tree : Project_Tree_Ref; | |
1703 | Context : Project_Context; | |
1704 | Dummy : in out Boolean); | |
444acbdd AC |
1705 | -- Recursively add the projects imported by project Project, but not |
1706 | -- those that are extended. | |
1707 | ||
1708 | ------------------- | |
1709 | -- Recursive_Add -- | |
1710 | ------------------- | |
1711 | ||
1712 | procedure Recursive_Add | |
a76b09dc PO |
1713 | (Prj : Project_Id; |
1714 | Tree : Project_Tree_Ref; | |
1715 | Context : Project_Context; | |
1716 | Dummy : in out Boolean) | |
444acbdd | 1717 | is |
457c5df4 | 1718 | pragma Unreferenced (Dummy, Tree); |
a17e8c05 | 1719 | |
3ddd922e AC |
1720 | List : Project_List; |
1721 | Prj2 : Project_Id; | |
8eaf1723 | 1722 | |
444acbdd AC |
1723 | begin |
1724 | -- A project is not importing itself | |
8eaf1723 | 1725 | |
444acbdd | 1726 | Prj2 := Ultimate_Extending_Project_Of (Prj); |
8d12c865 | 1727 | |
444acbdd | 1728 | if Project /= Prj2 then |
3563739b | 1729 | |
444acbdd AC |
1730 | -- Check that the project is not already in the list. We know |
1731 | -- the one passed to Recursive_Add have never been visited | |
1732 | -- before, but the one passed it are the extended projects. | |
3563739b | 1733 | |
444acbdd AC |
1734 | List := Project.All_Imported_Projects; |
1735 | while List /= null loop | |
1736 | if List.Project = Prj2 then | |
1737 | return; | |
1738 | end if; | |
8d12c865 | 1739 | |
444acbdd AC |
1740 | List := List.Next; |
1741 | end loop; | |
3563739b | 1742 | |
444acbdd | 1743 | -- Add it to the list |
3563739b | 1744 | |
444acbdd AC |
1745 | Project.All_Imported_Projects := |
1746 | new Project_List_Element' | |
a76b09dc | 1747 | (Project => Prj2, |
75685ef7 PO |
1748 | From_Encapsulated_Lib => |
1749 | Context.From_Encapsulated_Lib | |
1750 | or else Analyze_Tree.Context.From_Encapsulated_Lib, | |
a76b09dc | 1751 | Next => Project.All_Imported_Projects); |
444acbdd AC |
1752 | end if; |
1753 | end Recursive_Add; | |
8b9890fa | 1754 | |
444acbdd | 1755 | procedure For_All_Projects is |
a76b09dc | 1756 | new For_Every_Project_Imported_Context (Boolean, Recursive_Add); |
8d12c865 | 1757 | |
86828d40 AC |
1758 | Dummy : Boolean := False; |
1759 | List : Project_List; | |
3ddd922e | 1760 | |
444acbdd AC |
1761 | begin |
1762 | List := Local_Tree.Projects; | |
1763 | while List /= null loop | |
1764 | Project := List.Project; | |
1765 | Free_List | |
1766 | (Project.All_Imported_Projects, Free_Project => False); | |
1767 | For_All_Projects | |
1768 | (Project, Local_Tree, Dummy, Include_Aggregated => False); | |
1769 | List := List.Next; | |
1770 | end loop; | |
1771 | end Analyze_Tree; | |
1772 | ||
1773 | procedure For_Aggregates is | |
75685ef7 | 1774 | new For_Project_And_Aggregated_Context (Analyze_Tree); |
8b9890fa | 1775 | |
3ddd922e AC |
1776 | -- Start of processing for Compute_All_Imported_Projects |
1777 | ||
8b9890fa | 1778 | begin |
444acbdd | 1779 | For_Aggregates (Root_Project, Tree); |
8b9890fa EB |
1780 | end Compute_All_Imported_Projects; |
1781 | ||
5a66a766 EB |
1782 | ------------------- |
1783 | -- Is_Compilable -- | |
1784 | ------------------- | |
1785 | ||
1786 | function Is_Compilable (Source : Source_Id) return Boolean is | |
1787 | begin | |
e7efbe2f AC |
1788 | case Source.Compilable is |
1789 | when Unknown => | |
1790 | if Source.Language.Config.Compiler_Driver /= No_File | |
1791 | and then | |
1792 | Length_Of_Name (Source.Language.Config.Compiler_Driver) /= 0 | |
1793 | and then not Source.Locally_Removed | |
1794 | and then (Source.Language.Config.Kind /= File_Based | |
468ee96a | 1795 | or else Source.Kind /= Spec) |
e7efbe2f | 1796 | then |
12009a12 | 1797 | -- Do not modify Source.Compilable before the source record |
308e6f3a | 1798 | -- has been initialized. |
12009a12 AC |
1799 | |
1800 | if Source.Source_TS /= Empty_Time_Stamp then | |
1801 | Source.Compilable := Yes; | |
1802 | end if; | |
1803 | ||
e7efbe2f | 1804 | return True; |
468ee96a | 1805 | |
e7efbe2f | 1806 | else |
12009a12 AC |
1807 | if Source.Source_TS /= Empty_Time_Stamp then |
1808 | Source.Compilable := No; | |
1809 | end if; | |
1810 | ||
e7efbe2f AC |
1811 | return False; |
1812 | end if; | |
1813 | ||
1814 | when Yes => | |
1815 | return True; | |
1816 | ||
1817 | when No => | |
1818 | return False; | |
1819 | end case; | |
5a66a766 EB |
1820 | end Is_Compilable; |
1821 | ||
1d24fc5e EB |
1822 | ------------------------------ |
1823 | -- Object_To_Global_Archive -- | |
1824 | ------------------------------ | |
1825 | ||
1826 | function Object_To_Global_Archive (Source : Source_Id) return Boolean is | |
1827 | begin | |
1828 | return Source.Language.Config.Kind = File_Based | |
1829 | and then Source.Kind = Impl | |
1830 | and then Source.Language.Config.Objects_Linked | |
1831 | and then Is_Compilable (Source) | |
1832 | and then Source.Language.Config.Object_Generated; | |
1833 | end Object_To_Global_Archive; | |
1834 | ||
5a66a766 EB |
1835 | ---------------------------- |
1836 | -- Get_Language_From_Name -- | |
1837 | ---------------------------- | |
1838 | ||
1839 | function Get_Language_From_Name | |
e1f3cb58 AC |
1840 | (Project : Project_Id; |
1841 | Name : String) return Language_Ptr | |
5a66a766 | 1842 | is |
e1f3cb58 | 1843 | N : Name_Id; |
5a66a766 | 1844 | Result : Language_Ptr; |
e1f3cb58 | 1845 | |
5a66a766 EB |
1846 | begin |
1847 | Name_Len := Name'Length; | |
1848 | Name_Buffer (1 .. Name_Len) := Name; | |
1849 | To_Lower (Name_Buffer (1 .. Name_Len)); | |
1850 | N := Name_Find; | |
1851 | ||
1852 | Result := Project.Languages; | |
1853 | while Result /= No_Language_Index loop | |
1854 | if Result.Name = N then | |
1855 | return Result; | |
1856 | end if; | |
1857 | ||
1858 | Result := Result.Next; | |
1859 | end loop; | |
1860 | ||
1861 | return No_Language_Index; | |
1862 | end Get_Language_From_Name; | |
1863 | ||
e1f3cb58 AC |
1864 | ---------------- |
1865 | -- Other_Part -- | |
1866 | ---------------- | |
1867 | ||
1868 | function Other_Part (Source : Source_Id) return Source_Id is | |
1869 | begin | |
1870 | if Source.Unit /= No_Unit_Index then | |
1871 | case Source.Kind is | |
1872 | when Impl => | |
1873 | return Source.Unit.File_Names (Spec); | |
1874 | when Spec => | |
1875 | return Source.Unit.File_Names (Impl); | |
1876 | when Sep => | |
1877 | return No_Source; | |
1878 | end case; | |
1879 | else | |
1880 | return No_Source; | |
1881 | end if; | |
1882 | end Other_Part; | |
1883 | ||
32404665 EB |
1884 | ------------------ |
1885 | -- Create_Flags -- | |
1886 | ------------------ | |
1887 | ||
1888 | function Create_Flags | |
e2d9085b | 1889 | (Report_Error : Error_Handler; |
32404665 | 1890 | When_No_Sources : Error_Warning; |
7c1ab287 RD |
1891 | Require_Sources_Other_Lang : Boolean := True; |
1892 | Allow_Duplicate_Basenames : Boolean := True; | |
1893 | Compiler_Driver_Mandatory : Boolean := False; | |
1894 | Error_On_Unknown_Language : Boolean := True; | |
82923c66 | 1895 | Require_Obj_Dirs : Error_Warning := Error; |
3aee21ef | 1896 | Allow_Invalid_External : Error_Warning := Error; |
0180fd26 AC |
1897 | Missing_Source_Files : Error_Warning := Error; |
1898 | Ignore_Missing_With : Boolean := False) | |
48eff283 | 1899 | return Processing_Flags |
2c011ce1 | 1900 | is |
32404665 EB |
1901 | begin |
1902 | return Processing_Flags' | |
1903 | (Report_Error => Report_Error, | |
1904 | When_No_Sources => When_No_Sources, | |
1905 | Require_Sources_Other_Lang => Require_Sources_Other_Lang, | |
1906 | Allow_Duplicate_Basenames => Allow_Duplicate_Basenames, | |
1907 | Error_On_Unknown_Language => Error_On_Unknown_Language, | |
48eff283 | 1908 | Compiler_Driver_Mandatory => Compiler_Driver_Mandatory, |
82923c66 | 1909 | Require_Obj_Dirs => Require_Obj_Dirs, |
3aee21ef | 1910 | Allow_Invalid_External => Allow_Invalid_External, |
0180fd26 AC |
1911 | Missing_Source_Files => Missing_Source_Files, |
1912 | Ignore_Missing_With => Ignore_Missing_With); | |
32404665 EB |
1913 | end Create_Flags; |
1914 | ||
636e3cb6 AC |
1915 | ------------ |
1916 | -- Length -- | |
1917 | ------------ | |
1918 | ||
1919 | function Length | |
196b1993 AC |
1920 | (Table : Name_List_Table.Instance; |
1921 | List : Name_List_Index) return Natural | |
636e3cb6 AC |
1922 | is |
1923 | Count : Natural := 0; | |
196b1993 AC |
1924 | Tmp : Name_List_Index; |
1925 | ||
636e3cb6 | 1926 | begin |
196b1993 | 1927 | Tmp := List; |
636e3cb6 AC |
1928 | while Tmp /= No_Name_List loop |
1929 | Count := Count + 1; | |
1930 | Tmp := Table.Table (Tmp).Next; | |
1931 | end loop; | |
196b1993 | 1932 | |
636e3cb6 AC |
1933 | return Count; |
1934 | end Length; | |
1935 | ||
3e582869 AC |
1936 | ------------------ |
1937 | -- Debug_Output -- | |
1938 | ------------------ | |
1939 | ||
1940 | procedure Debug_Output (Str : String) is | |
1941 | begin | |
1942 | if Current_Verbosity > Default then | |
dea1d3dc | 1943 | Set_Standard_Error; |
3e582869 | 1944 | Write_Line ((1 .. Debug_Level * 2 => ' ') & Str); |
dea1d3dc | 1945 | Set_Standard_Output; |
3e582869 AC |
1946 | end if; |
1947 | end Debug_Output; | |
1948 | ||
1949 | ------------------ | |
1950 | -- Debug_Indent -- | |
1951 | ------------------ | |
1952 | ||
1953 | procedure Debug_Indent is | |
1954 | begin | |
1955 | if Current_Verbosity = High then | |
dea1d3dc | 1956 | Set_Standard_Error; |
3e582869 | 1957 | Write_Str ((1 .. Debug_Level * 2 => ' ')); |
dea1d3dc | 1958 | Set_Standard_Output; |
3e582869 AC |
1959 | end if; |
1960 | end Debug_Indent; | |
1961 | ||
1962 | ------------------ | |
1963 | -- Debug_Output -- | |
1964 | ------------------ | |
1965 | ||
1966 | procedure Debug_Output (Str : String; Str2 : Name_Id) is | |
1967 | begin | |
08cd7c2f | 1968 | if Current_Verbosity > Default then |
3e582869 | 1969 | Debug_Indent; |
dea1d3dc | 1970 | Set_Standard_Error; |
3e582869 AC |
1971 | Write_Str (Str); |
1972 | ||
1973 | if Str2 = No_Name then | |
1974 | Write_Line (" <no_name>"); | |
1975 | else | |
1976 | Write_Line (" """ & Get_Name_String (Str2) & '"'); | |
1977 | end if; | |
d781a615 | 1978 | |
dea1d3dc | 1979 | Set_Standard_Output; |
3e582869 AC |
1980 | end if; |
1981 | end Debug_Output; | |
1982 | ||
1983 | --------------------------- | |
1984 | -- Debug_Increase_Indent -- | |
1985 | --------------------------- | |
1986 | ||
1987 | procedure Debug_Increase_Indent | |
1988 | (Str : String := ""; Str2 : Name_Id := No_Name) | |
1989 | is | |
1990 | begin | |
1991 | if Str2 /= No_Name then | |
1992 | Debug_Output (Str, Str2); | |
1993 | else | |
1994 | Debug_Output (Str); | |
1995 | end if; | |
1996 | Debug_Level := Debug_Level + 1; | |
1997 | end Debug_Increase_Indent; | |
1998 | ||
1999 | --------------------------- | |
2000 | -- Debug_Decrease_Indent -- | |
2001 | --------------------------- | |
2002 | ||
2003 | procedure Debug_Decrease_Indent (Str : String := "") is | |
2004 | begin | |
2005 | if Debug_Level > 0 then | |
2006 | Debug_Level := Debug_Level - 1; | |
2007 | end if; | |
2008 | ||
2009 | if Str /= "" then | |
2010 | Debug_Output (Str); | |
2011 | end if; | |
2012 | end Debug_Decrease_Indent; | |
2013 | ||
9434c32e EB |
2014 | ---------------- |
2015 | -- Debug_Name -- | |
2016 | ---------------- | |
2017 | ||
2018 | function Debug_Name (Tree : Project_Tree_Ref) return Name_Id is | |
2c1b72d7 AC |
2019 | P : Project_List; |
2020 | ||
9434c32e EB |
2021 | begin |
2022 | Name_Len := 0; | |
2023 | Add_Str_To_Name_Buffer ("Tree ["); | |
2024 | ||
2c1b72d7 | 2025 | P := Tree.Projects; |
9434c32e EB |
2026 | while P /= null loop |
2027 | if P /= Tree.Projects then | |
2028 | Add_Char_To_Name_Buffer (','); | |
2029 | end if; | |
2030 | ||
2031 | Add_Str_To_Name_Buffer (Get_Name_String (P.Project.Name)); | |
2032 | ||
2033 | P := P.Next; | |
2034 | end loop; | |
2035 | ||
2036 | Add_Char_To_Name_Buffer (']'); | |
2037 | ||
2038 | return Name_Find; | |
2039 | end Debug_Name; | |
2040 | ||
2041 | ---------- | |
2042 | -- Free -- | |
2043 | ---------- | |
2044 | ||
2045 | procedure Free (Tree : in out Project_Tree_Appdata) is | |
2046 | pragma Unreferenced (Tree); | |
2047 | begin | |
2048 | null; | |
2049 | end Free; | |
2050 | ||
316d9d4f EB |
2051 | -------------------------------- |
2052 | -- For_Project_And_Aggregated -- | |
2053 | -------------------------------- | |
2054 | ||
2055 | procedure For_Project_And_Aggregated | |
2056 | (Root_Project : Project_Id; | |
2057 | Root_Tree : Project_Tree_Ref) | |
2058 | is | |
2059 | Agg : Aggregated_Project_List; | |
67c86178 | 2060 | |
316d9d4f EB |
2061 | begin |
2062 | Action (Root_Project, Root_Tree); | |
2063 | ||
5415acbd | 2064 | if Root_Project.Qualifier in Aggregate_Project then |
316d9d4f EB |
2065 | Agg := Root_Project.Aggregated_Projects; |
2066 | while Agg /= null loop | |
2067 | For_Project_And_Aggregated (Agg.Project, Agg.Tree); | |
2068 | Agg := Agg.Next; | |
2069 | end loop; | |
2070 | end if; | |
2071 | end For_Project_And_Aggregated; | |
2072 | ||
83649257 PO |
2073 | ---------------------------------------- |
2074 | -- For_Project_And_Aggregated_Context -- | |
2075 | ---------------------------------------- | |
2076 | ||
2077 | procedure For_Project_And_Aggregated_Context | |
2078 | (Root_Project : Project_Id; | |
2079 | Root_Tree : Project_Tree_Ref) | |
2080 | is | |
2081 | ||
2082 | procedure Recursive_Process | |
2083 | (Project : Project_Id; | |
2084 | Tree : Project_Tree_Ref; | |
2085 | Context : Project_Context); | |
2086 | -- Process Project and all aggregated projects recursively | |
2087 | ||
2088 | ----------------------- | |
2089 | -- Recursive_Process -- | |
2090 | ----------------------- | |
2091 | ||
2092 | procedure Recursive_Process | |
2093 | (Project : Project_Id; | |
2094 | Tree : Project_Tree_Ref; | |
2095 | Context : Project_Context) | |
2096 | is | |
2097 | Agg : Aggregated_Project_List; | |
2098 | Ctx : Project_Context; | |
260359e3 | 2099 | |
83649257 PO |
2100 | begin |
2101 | Action (Project, Tree, Context); | |
2102 | ||
2103 | if Project.Qualifier in Aggregate_Project then | |
2104 | Ctx := | |
2105 | (In_Aggregate_Lib => True, | |
2106 | From_Encapsulated_Lib => | |
2107 | Context.From_Encapsulated_Lib | |
260359e3 | 2108 | or else Project.Standalone_Library = Encapsulated); |
83649257 PO |
2109 | |
2110 | Agg := Project.Aggregated_Projects; | |
2111 | while Agg /= null loop | |
2112 | Recursive_Process (Agg.Project, Agg.Tree, Ctx); | |
2113 | Agg := Agg.Next; | |
2114 | end loop; | |
2115 | end if; | |
2116 | end Recursive_Process; | |
2117 | ||
260359e3 AC |
2118 | -- Start of processing for For_Project_And_Aggregated_Context |
2119 | ||
83649257 PO |
2120 | begin |
2121 | Recursive_Process | |
2122 | (Root_Project, Root_Tree, Project_Context'(False, False)); | |
2123 | end For_Project_And_Aggregated_Context; | |
2124 | ||
67c86178 AC |
2125 | -- Package initialization for Prj |
2126 | ||
07fc65c4 | 2127 | begin |
ede007da VC |
2128 | -- Make sure that the standard config and user project file extensions are |
2129 | -- compatible with canonical case file naming. | |
07fc65c4 | 2130 | |
ede007da | 2131 | Canonical_Case_File_Name (Config_Project_File_Extension); |
07fc65c4 | 2132 | Canonical_Case_File_Name (Project_File_Extension); |
19235870 | 2133 | end Prj; |