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