1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2012, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
28 with Osint; use Osint;
29 with Output; use Output;
32 with Prj.Err; use Prj.Err;
33 with Snames; use Snames;
34 with Uintp; use Uintp;
36 with Ada.Characters.Handling; use Ada.Characters.Handling;
37 with Ada.Containers.Ordered_Sets;
38 with Ada.Unchecked_Deallocation;
40 with GNAT.Case_Util; use GNAT.Case_Util;
41 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
47 type Restricted_Lang_Access is access Restricted_Lang;
48 type Restricted_Lang is record
50 Next : Restricted_Lang_Access;
53 Restricted_Languages : Restricted_Lang_Access := null;
54 -- When null, all languages are allowed, otherwise only the languages in
55 -- the list are allowed.
57 Object_Suffix : constant String := Get_Target_Object_Suffix.all;
58 -- File suffix for object files
60 Initial_Buffer_Size : constant := 100;
61 -- Initial size for extensible buffer used in Add_To_Buffer
63 The_Empty_String : Name_Id := No_Name;
65 Debug_Level : Integer := 0;
66 -- Current indentation level for debug traces
68 type Cst_String_Access is access constant String;
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";
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);
79 procedure Free (Project : in out Project_Id);
80 -- Free memory allocated for Project
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
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.
91 procedure Free_Units (Table : in out Units_Htable.Instance);
92 -- Free memory allocated for unit information in the project
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
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
101 -----------------------------
102 -- Add_Restricted_Language --
103 -----------------------------
105 procedure Add_Restricted_Language (Name : String) is
106 N : String (1 .. Name'Length) := Name;
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;
119 procedure Add_To_Buffer
121 To : in out String_Access;
122 Last : in out Natural)
126 To := new String (1 .. Initial_Buffer_Size);
130 -- If Buffer is too small, double its size
132 while Last + S'Length > To'Last loop
134 New_Buffer : constant String_Access :=
135 new String (1 .. 2 * Last);
138 New_Buffer (1 .. Last) := To (1 .. Last);
144 To (Last + 1 .. Last + S'Length) := S;
145 Last := Last + S'Length;
148 ---------------------------------
149 -- Current_Object_Path_File_Of --
150 ---------------------------------
152 function Current_Object_Path_File_Of
153 (Shared : Shared_Project_Tree_Data_Access) return Path_Name_Type
156 return Shared.Private_Part.Current_Object_Path_File;
157 end Current_Object_Path_File_Of;
159 ---------------------------------
160 -- Current_Source_Path_File_Of --
161 ---------------------------------
163 function Current_Source_Path_File_Of
164 (Shared : Shared_Project_Tree_Data_Access)
165 return Path_Name_Type is
167 return Shared.Private_Part.Current_Source_Path_File;
168 end Current_Source_Path_File_Of;
170 ---------------------------
171 -- Delete_Temporary_File --
172 ---------------------------
174 procedure Delete_Temporary_File
175 (Shared : Shared_Project_Tree_Data_Access := null;
176 Path : Path_Name_Type)
179 pragma Warnings (Off, Dont_Care);
182 if not Debug.Debug_Flag_N then
183 if Current_Verbosity = High then
184 Write_Line ("Removing temp file: " & Get_Name_String (Path));
187 Delete_File (Get_Name_String (Path), Dont_Care);
189 if Shared /= null then
191 1 .. Temp_Files_Table.Last (Shared.Private_Part.Temp_Files)
193 if Shared.Private_Part.Temp_Files.Table (Index) = Path then
194 Shared.Private_Part.Temp_Files.Table (Index) := No_Path;
199 end Delete_Temporary_File;
201 ------------------------------
202 -- Delete_Temp_Config_Files --
203 ------------------------------
205 procedure Delete_Temp_Config_Files (Project_Tree : Project_Tree_Ref) is
207 pragma Warnings (Off, Success);
212 if not Debug.Debug_Flag_N then
213 if Project_Tree /= null then
214 Proj := Project_Tree.Projects;
215 while Proj /= null loop
216 if Proj.Project.Config_File_Temp then
217 Delete_Temporary_File
218 (Project_Tree.Shared, Proj.Project.Config_File_Name);
220 -- Make sure that we don't have a config file for this
221 -- project, in case there are several mains. In this case,
222 -- we will recreate another config file: we cannot reuse the
223 -- one that we just deleted!
225 Proj.Project.Config_Checked := False;
226 Proj.Project.Config_File_Name := No_Path;
227 Proj.Project.Config_File_Temp := False;
234 end Delete_Temp_Config_Files;
236 ---------------------------
237 -- Delete_All_Temp_Files --
238 ---------------------------
240 procedure Delete_All_Temp_Files
241 (Shared : Shared_Project_Tree_Data_Access)
244 pragma Warnings (Off, Dont_Care);
246 Path : Path_Name_Type;
249 if not Debug.Debug_Flag_N then
251 1 .. Temp_Files_Table.Last (Shared.Private_Part.Temp_Files)
253 Path := Shared.Private_Part.Temp_Files.Table (Index);
255 if Path /= No_Path then
256 if Current_Verbosity = High then
257 Write_Line ("Removing temp file: "
258 & Get_Name_String (Path));
261 Delete_File (Get_Name_String (Path), Dont_Care);
265 Temp_Files_Table.Free (Shared.Private_Part.Temp_Files);
266 Temp_Files_Table.Init (Shared.Private_Part.Temp_Files);
269 -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or
270 -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
271 -- the empty string. On VMS, this has the effect of deassigning
272 -- the logical names.
274 if Shared.Private_Part.Current_Source_Path_File /= No_Path then
275 Setenv (Project_Include_Path_File, "");
278 if Shared.Private_Part.Current_Object_Path_File /= No_Path then
279 Setenv (Project_Objects_Path_File, "");
281 end Delete_All_Temp_Files;
283 ---------------------
284 -- Dependency_Name --
285 ---------------------
287 function Dependency_Name
288 (Source_File_Name : File_Name_Type;
289 Dependency : Dependency_File_Kind) return File_Name_Type
297 return Extend_Name (Source_File_Name, Makefile_Dependency_Suffix);
300 return Extend_Name (Source_File_Name, ALI_Dependency_Suffix);
308 function Empty_File return File_Name_Type is
310 return File_Name_Type (The_Empty_String);
317 function Empty_Project
318 (Qualifier : Project_Qualifier) return Project_Data
321 Prj.Initialize (Tree => No_Project_Tree);
324 Data : Project_Data (Qualifier => Qualifier);
327 -- Only the fields for which no default value could be provided in
328 -- prj.ads are initialized below.
330 Data.Config := Default_Project_Config;
339 function Empty_String return Name_Id is
341 return The_Empty_String;
348 procedure Expect (The_Token : Token_Type; Token_Image : String) is
350 if Token /= The_Token then
352 -- ??? Should pass user flags here instead
354 Error_Msg (Gnatmake_Flags, Token_Image & " expected", Token_Ptr);
363 (File : File_Name_Type;
364 With_Suffix : String) return File_Name_Type
369 Get_Name_String (File);
370 Last := Name_Len + 1;
372 while Name_Len /= 0 and then Name_Buffer (Name_Len) /= '.' loop
373 Name_Len := Name_Len - 1;
376 if Name_Len <= 1 then
380 for J in With_Suffix'Range loop
381 Name_Buffer (Name_Len) := With_Suffix (J);
382 Name_Len := Name_Len + 1;
385 Name_Len := Name_Len - 1;
389 -------------------------
390 -- Is_Allowed_Language --
391 -------------------------
393 function Is_Allowed_Language (Name : Name_Id) return Boolean is
394 R : Restricted_Lang_Access := Restricted_Languages;
395 Lang : constant String := Get_Name_String (Name);
403 if Get_Name_String (R.Name) = Lang then
412 end Is_Allowed_Language;
414 ---------------------
415 -- Project_Changed --
416 ---------------------
418 procedure Project_Changed (Iter : in out Source_Iterator) is
420 if Iter.Project /= null then
421 Iter.Language := Iter.Project.Project.Languages;
422 Language_Changed (Iter);
426 ----------------------
427 -- Language_Changed --
428 ----------------------
430 procedure Language_Changed (Iter : in out Source_Iterator) is
432 Iter.Current := No_Source;
434 if Iter.Language_Name /= No_Name then
435 while Iter.Language /= null
436 and then Iter.Language.Name /= Iter.Language_Name
438 Iter.Language := Iter.Language.Next;
442 -- If there is no matching language in this project, move to next
444 if Iter.Language = No_Language_Index then
445 if Iter.All_Projects then
447 Iter.Project := Iter.Project.Next;
448 exit when Iter.Project = null
449 or else Iter.Encapsulated_Libs
450 or else not Iter.Project.From_Encapsulated_Lib;
453 Project_Changed (Iter);
455 Iter.Project := null;
459 Iter.Current := Iter.Language.First_Source;
461 if Iter.Current = No_Source then
462 Iter.Language := Iter.Language.Next;
463 Language_Changed (Iter);
466 end Language_Changed;
468 ---------------------
469 -- For_Each_Source --
470 ---------------------
472 function For_Each_Source
473 (In_Tree : Project_Tree_Ref;
474 Project : Project_Id := No_Project;
475 Language : Name_Id := No_Name;
476 Encapsulated_Libs : Boolean := True) return Source_Iterator
478 Iter : Source_Iterator;
480 Iter := Source_Iterator'
482 Project => In_Tree.Projects,
483 All_Projects => Project = No_Project,
484 Language_Name => Language,
485 Language => No_Language_Index,
486 Current => No_Source,
487 Encapsulated_Libs => Encapsulated_Libs);
489 if Project /= null then
490 while Iter.Project /= null
491 and then Iter.Project.Project /= Project
493 Iter.Project := Iter.Project.Next;
497 while not Iter.Encapsulated_Libs
498 and then Iter.Project.From_Encapsulated_Lib
500 Iter.Project := Iter.Project.Next;
504 Project_Changed (Iter);
513 function Element (Iter : Source_Iterator) return Source_Id is
522 procedure Next (Iter : in out Source_Iterator) is
524 Iter.Current := Iter.Current.Next_In_Lang;
525 if Iter.Current = No_Source then
526 Iter.Language := Iter.Language.Next;
527 Language_Changed (Iter);
531 --------------------------------
532 -- For_Every_Project_Imported --
533 --------------------------------
535 procedure For_Every_Project_Imported_Context
537 Tree : Project_Tree_Ref;
538 With_State : in out State;
539 Include_Aggregated : Boolean := True;
540 Imported_First : Boolean := False)
542 use Project_Boolean_Htable;
544 procedure Recursive_Check_Context
545 (Project : Project_Id;
546 Tree : Project_Tree_Ref;
547 In_Aggregate_Lib : Boolean;
548 From_Encapsulated_Lib : Boolean);
549 -- Recursively handle the project tree creating a new context for
550 -- keeping track about already handled projects.
552 -----------------------------
553 -- Recursive_Check_Context --
554 -----------------------------
556 procedure Recursive_Check_Context
557 (Project : Project_Id;
558 Tree : Project_Tree_Ref;
559 In_Aggregate_Lib : Boolean;
560 From_Encapsulated_Lib : Boolean)
562 package Name_Id_Set is
563 new Ada.Containers.Ordered_Sets (Element_Type => Name_Id);
565 Seen_Name : Name_Id_Set.Set;
566 -- This set is needed to ensure that we do not haandle the same
567 -- project twice in the context of aggregate libraries.
569 procedure Recursive_Check
570 (Project : Project_Id;
571 Tree : Project_Tree_Ref;
572 In_Aggregate_Lib : Boolean;
573 From_Encapsulated_Lib : Boolean);
574 -- Check if project has already been seen. If not, mark it as Seen,
575 -- Call Action, and check all its imported and aggregated projects.
577 ---------------------
578 -- Recursive_Check --
579 ---------------------
581 procedure Recursive_Check
582 (Project : Project_Id;
583 Tree : Project_Tree_Ref;
584 In_Aggregate_Lib : Boolean;
585 From_Encapsulated_Lib : Boolean)
588 T : Project_Tree_Ref;
591 if not Seen_Name.Contains (Project.Name) then
593 -- Even if a project is aggregated multiple times in an
594 -- aggregated library, we will only return it once.
596 Seen_Name.Include (Project.Name);
598 if not Imported_First then
602 Project_Context'(In_Aggregate_Lib, From_Encapsulated_Lib),
606 -- Visit all extended projects
608 if Project.Extends /= No_Project then
610 (Project.Extends, Tree,
611 In_Aggregate_Lib, From_Encapsulated_Lib);
614 -- Visit all imported projects
616 List := Project.Imported_Projects;
617 while List /= null loop
621 From_Encapsulated_Lib
622 or (Project.Standalone_Library = Encapsulated));
626 -- Visit all aggregated projects
628 if Include_Aggregated
629 and then Project.Qualifier in Aggregate_Project
632 Agg : Aggregated_Project_List;
635 Agg := Project.Aggregated_Projects;
636 while Agg /= null loop
637 pragma Assert (Agg.Project /= No_Project);
639 -- For aggregated libraries, the tree must be the one
640 -- of the aggregate library.
642 if Project.Qualifier = Aggregate_Library then
647 From_Encapsulated_Lib or
648 Project.Standalone_Library = Encapsulated);
653 -- Use a new context as we want to returns the same
654 -- project in different project tree for aggregated
657 Recursive_Check_Context
658 (Agg.Project, T, False, False);
666 if Imported_First then
670 Project_Context'(In_Aggregate_Lib, From_Encapsulated_Lib),
676 -- Start of processing for Recursive_Check_Context
680 (Project, Tree, In_Aggregate_Lib, From_Encapsulated_Lib);
681 end Recursive_Check_Context;
683 -- Start of processing for For_Every_Project_Imported
686 Recursive_Check_Context
689 In_Aggregate_Lib => False,
690 From_Encapsulated_Lib => False);
691 end For_Every_Project_Imported_Context;
693 procedure For_Every_Project_Imported
695 Tree : Project_Tree_Ref;
696 With_State : in out State;
697 Include_Aggregated : Boolean := True;
698 Imported_First : Boolean := False)
701 (Project : Project_Id;
702 Tree : Project_Tree_Ref;
703 Context : Project_Context;
704 With_State : in out State);
705 -- Action wrapper for handling the context
712 (Project : Project_Id;
713 Tree : Project_Tree_Ref;
714 Context : Project_Context;
715 With_State : in out State)
717 pragma Unreferenced (Context);
719 Action (Project, Tree, With_State);
722 procedure For_Projects is
723 new For_Every_Project_Imported_Context (State, Internal);
726 For_Projects (By, Tree, With_State, Include_Aggregated, Imported_First);
727 end For_Every_Project_Imported;
734 (In_Tree : Project_Tree_Ref;
735 Project : Project_Id;
736 In_Imported_Only : Boolean := False;
737 In_Extended_Only : Boolean := False;
738 Base_Name : File_Name_Type;
739 Index : Int := 0) return Source_Id
741 Result : Source_Id := No_Source;
743 procedure Look_For_Sources
745 Tree : Project_Tree_Ref;
746 Src : in out Source_Id);
747 -- Look for Base_Name in the sources of Proj
749 ----------------------
750 -- Look_For_Sources --
751 ----------------------
753 procedure Look_For_Sources
755 Tree : Project_Tree_Ref;
756 Src : in out Source_Id)
758 Iterator : Source_Iterator;
761 Iterator := For_Each_Source (In_Tree => Tree, Project => Proj);
762 while Element (Iterator) /= No_Source loop
763 if Element (Iterator).File = Base_Name
764 and then (Index = 0 or else Element (Iterator).Index = Index)
766 Src := Element (Iterator);
768 -- If the source has been excluded, continue looking. We will
769 -- get the excluded source only if there is no other source
770 -- with the same base name that is not locally removed.
772 if not Element (Iterator).Locally_Removed then
779 end Look_For_Sources;
781 procedure For_Imported_Projects is new For_Every_Project_Imported
782 (State => Source_Id, Action => Look_For_Sources);
786 -- Start of processing for Find_Source
789 if In_Extended_Only then
791 while Proj /= No_Project loop
792 Look_For_Sources (Proj, In_Tree, Result);
793 exit when Result /= No_Source;
795 Proj := Proj.Extends;
798 elsif In_Imported_Only then
799 Look_For_Sources (Project, In_Tree, Result);
801 if Result = No_Source then
802 For_Imported_Projects
805 Include_Aggregated => False,
806 With_State => Result);
810 Look_For_Sources (No_Project, In_Tree, Result);
820 function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num);
821 -- Used in implementation of other functions Hash below
823 function Hash (Name : File_Name_Type) return Header_Num is
825 return Hash (Get_Name_String (Name));
828 function Hash (Name : Name_Id) return Header_Num is
830 return Hash (Get_Name_String (Name));
833 function Hash (Name : Path_Name_Type) return Header_Num is
835 return Hash (Get_Name_String (Name));
838 function Hash (Project : Project_Id) return Header_Num is
840 if Project = No_Project then
841 return Header_Num'First;
843 return Hash (Get_Name_String (Project.Name));
851 function Image (The_Casing : Casing_Type) return String is
853 return The_Casing_Images (The_Casing).all;
856 -----------------------------
857 -- Is_Standard_GNAT_Naming --
858 -----------------------------
860 function Is_Standard_GNAT_Naming
861 (Naming : Lang_Naming_Data) return Boolean
864 return Get_Name_String (Naming.Spec_Suffix) = ".ads"
865 and then Get_Name_String (Naming.Body_Suffix) = ".adb"
866 and then Get_Name_String (Naming.Dot_Replacement) = "-";
867 end Is_Standard_GNAT_Naming;
873 procedure Initialize (Tree : Project_Tree_Ref) is
875 if The_Empty_String = No_Name then
878 The_Empty_String := Name_Find;
882 -- Make sure that new reserved words after Ada 95 may be used as
885 Opt.Ada_Version := Opt.Ada_95;
887 Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
888 Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends));
889 Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
891 (Name_External_As_List, Token_Type'Pos (Tok_External_As_List));
894 if Tree /= No_Project_Tree then
903 function Is_Extending
904 (Extending : Project_Id;
905 Extended : Project_Id) return Boolean
911 while Proj /= No_Project loop
912 if Proj = Extended then
916 Proj := Proj.Extends;
927 (Source_File_Name : File_Name_Type;
928 Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
931 if Object_File_Suffix = No_Name then
933 (Source_File_Name, Object_Suffix);
936 (Source_File_Name, Get_Name_String (Object_File_Suffix));
941 (Source_File_Name : File_Name_Type;
943 Index_Separator : Character;
944 Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
946 Index_Img : constant String := Source_Index'Img;
950 Get_Name_String (Source_File_Name);
953 while Last > 1 and then Name_Buffer (Last) /= '.' loop
958 Name_Len := Last - 1;
961 Add_Char_To_Name_Buffer (Index_Separator);
962 Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last));
964 if Object_File_Suffix = No_Name then
965 Add_Str_To_Name_Buffer (Object_Suffix);
967 Add_Str_To_Name_Buffer (Get_Name_String (Object_File_Suffix));
973 ----------------------
974 -- Record_Temp_File --
975 ----------------------
977 procedure Record_Temp_File
978 (Shared : Shared_Project_Tree_Data_Access;
979 Path : Path_Name_Type)
982 Temp_Files_Table.Append (Shared.Private_Part.Temp_Files, Path);
983 end Record_Temp_File;
989 procedure Free (List : in out Aggregated_Project_List) is
990 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
991 (Aggregated_Project, Aggregated_Project_List);
992 Tmp : Aggregated_Project_List;
994 while List /= null loop
999 Unchecked_Free (List);
1004 ----------------------------
1005 -- Add_Aggregated_Project --
1006 ----------------------------
1008 procedure Add_Aggregated_Project
1009 (Project : Project_Id; Path : Path_Name_Type) is
1011 Project.Aggregated_Projects := new Aggregated_Project'
1013 Project => No_Project,
1015 Next => Project.Aggregated_Projects);
1016 end Add_Aggregated_Project;
1022 procedure Free (Project : in out Project_Id) is
1023 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
1024 (Project_Data, Project_Id);
1027 if Project /= null then
1028 Free (Project.Ada_Include_Path);
1029 Free (Project.Objects_Path);
1030 Free (Project.Ada_Objects_Path);
1031 Free_List (Project.Imported_Projects, Free_Project => False);
1032 Free_List (Project.All_Imported_Projects, Free_Project => False);
1033 Free_List (Project.Languages);
1035 case Project.Qualifier is
1036 when Aggregate | Aggregate_Library =>
1037 Free (Project.Aggregated_Projects);
1043 Unchecked_Free (Project);
1051 procedure Free_List (Languages : in out Language_List) is
1052 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
1053 (Language_List_Element, Language_List);
1054 Tmp : Language_List;
1056 while Languages /= null loop
1057 Tmp := Languages.Next;
1058 Unchecked_Free (Languages);
1067 procedure Free_List (Source : in out Source_Id) is
1068 procedure Unchecked_Free is new
1069 Ada.Unchecked_Deallocation (Source_Data, Source_Id);
1074 while Source /= No_Source loop
1075 Tmp := Source.Next_In_Lang;
1076 Free_List (Source.Alternate_Languages);
1078 if Source.Unit /= null
1079 and then Source.Kind in Spec_Or_Body
1081 Source.Unit.File_Names (Source.Kind) := null;
1084 Unchecked_Free (Source);
1094 (List : in out Project_List;
1095 Free_Project : Boolean)
1097 procedure Unchecked_Free is new
1098 Ada.Unchecked_Deallocation (Project_List_Element, Project_List);
1103 while List /= null loop
1106 if Free_Project then
1107 Free (List.Project);
1110 Unchecked_Free (List);
1119 procedure Free_List (Languages : in out Language_Ptr) is
1120 procedure Unchecked_Free is new
1121 Ada.Unchecked_Deallocation (Language_Data, Language_Ptr);
1126 while Languages /= null loop
1127 Tmp := Languages.Next;
1128 Free_List (Languages.First_Source);
1129 Unchecked_Free (Languages);
1134 --------------------------
1135 -- Reset_Units_In_Table --
1136 --------------------------
1138 procedure Reset_Units_In_Table (Table : in out Units_Htable.Instance) is
1142 Unit := Units_Htable.Get_First (Table);
1143 while Unit /= No_Unit_Index loop
1144 if Unit.File_Names (Spec) /= null then
1145 Unit.File_Names (Spec).Unit := No_Unit_Index;
1148 if Unit.File_Names (Impl) /= null then
1149 Unit.File_Names (Impl).Unit := No_Unit_Index;
1152 Unit := Units_Htable.Get_Next (Table);
1154 end Reset_Units_In_Table;
1160 procedure Free_Units (Table : in out Units_Htable.Instance) is
1161 procedure Unchecked_Free is new
1162 Ada.Unchecked_Deallocation (Unit_Data, Unit_Index);
1167 Unit := Units_Htable.Get_First (Table);
1168 while Unit /= No_Unit_Index loop
1170 -- We cannot reset Unit.File_Names (Impl or Spec).Unit here as
1171 -- Source_Data buffer is freed by the following instruction
1172 -- Free_List (Tree.Projects, Free_Project => True);
1174 Unchecked_Free (Unit);
1175 Unit := Units_Htable.Get_Next (Table);
1178 Units_Htable.Reset (Table);
1185 procedure Free (Tree : in out Project_Tree_Ref) is
1186 procedure Unchecked_Free is new
1187 Ada.Unchecked_Deallocation
1188 (Project_Tree_Data, Project_Tree_Ref);
1190 procedure Unchecked_Free is new
1191 Ada.Unchecked_Deallocation
1192 (Project_Tree_Appdata'Class, Project_Tree_Appdata_Access);
1195 if Tree /= null then
1196 if Tree.Is_Root_Tree then
1197 Name_List_Table.Free (Tree.Shared.Name_Lists);
1198 Number_List_Table.Free (Tree.Shared.Number_Lists);
1199 String_Element_Table.Free (Tree.Shared.String_Elements);
1200 Variable_Element_Table.Free (Tree.Shared.Variable_Elements);
1201 Array_Element_Table.Free (Tree.Shared.Array_Elements);
1202 Array_Table.Free (Tree.Shared.Arrays);
1203 Package_Table.Free (Tree.Shared.Packages);
1204 Temp_Files_Table.Free (Tree.Shared.Private_Part.Temp_Files);
1207 if Tree.Appdata /= null then
1208 Free (Tree.Appdata.all);
1209 Unchecked_Free (Tree.Appdata);
1212 Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
1213 Source_Files_Htable.Reset (Tree.Source_Files_HT);
1215 Reset_Units_In_Table (Tree.Units_HT);
1216 Free_List (Tree.Projects, Free_Project => True);
1217 Free_Units (Tree.Units_HT);
1219 Unchecked_Free (Tree);
1227 procedure Reset (Tree : Project_Tree_Ref) is
1231 if Tree.Is_Root_Tree then
1233 -- We cannot use 'Access here:
1234 -- "illegal attribute for discriminant-dependent component"
1235 -- However, we know this is valid since Shared and Shared_Data have
1236 -- the same lifetime and will always exist concurrently.
1238 Tree.Shared := Tree.Shared_Data'Unrestricted_Access;
1239 Name_List_Table.Init (Tree.Shared.Name_Lists);
1240 Number_List_Table.Init (Tree.Shared.Number_Lists);
1241 String_Element_Table.Init (Tree.Shared.String_Elements);
1242 Variable_Element_Table.Init (Tree.Shared.Variable_Elements);
1243 Array_Element_Table.Init (Tree.Shared.Array_Elements);
1244 Array_Table.Init (Tree.Shared.Arrays);
1245 Package_Table.Init (Tree.Shared.Packages);
1247 -- Private part table
1249 Temp_Files_Table.Init (Tree.Shared.Private_Part.Temp_Files);
1251 Tree.Shared.Private_Part.Current_Source_Path_File := No_Path;
1252 Tree.Shared.Private_Part.Current_Object_Path_File := No_Path;
1255 Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
1256 Source_Files_Htable.Reset (Tree.Source_Files_HT);
1257 Replaced_Source_HTable.Reset (Tree.Replaced_Sources);
1259 Tree.Replaced_Source_Number := 0;
1261 Reset_Units_In_Table (Tree.Units_HT);
1262 Free_List (Tree.Projects, Free_Project => True);
1263 Free_Units (Tree.Units_HT);
1266 -------------------------------------
1267 -- Set_Current_Object_Path_File_Of --
1268 -------------------------------------
1270 procedure Set_Current_Object_Path_File_Of
1271 (Shared : Shared_Project_Tree_Data_Access;
1272 To : Path_Name_Type)
1275 Shared.Private_Part.Current_Object_Path_File := To;
1276 end Set_Current_Object_Path_File_Of;
1278 -------------------------------------
1279 -- Set_Current_Source_Path_File_Of --
1280 -------------------------------------
1282 procedure Set_Current_Source_Path_File_Of
1283 (Shared : Shared_Project_Tree_Data_Access;
1284 To : Path_Name_Type)
1287 Shared.Private_Part.Current_Source_Path_File := To;
1288 end Set_Current_Source_Path_File_Of;
1290 -----------------------
1291 -- Set_Path_File_Var --
1292 -----------------------
1294 procedure Set_Path_File_Var (Name : String; Value : String) is
1295 Host_Spec : String_Access := To_Host_File_Spec (Value);
1297 if Host_Spec = null then
1299 ("could not convert file name """ & Value & """ to host spec");
1301 Setenv (Name, Host_Spec.all);
1304 end Set_Path_File_Var;
1310 function Switches_Name
1311 (Source_File_Name : File_Name_Type) return File_Name_Type
1314 return Extend_Name (Source_File_Name, Switches_Dependency_Suffix);
1321 function Value (Image : String) return Casing_Type is
1323 for Casing in The_Casing_Images'Range loop
1324 if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
1329 raise Constraint_Error;
1332 ---------------------
1333 -- Has_Ada_Sources --
1334 ---------------------
1336 function Has_Ada_Sources (Data : Project_Id) return Boolean is
1337 Lang : Language_Ptr;
1340 Lang := Data.Languages;
1341 while Lang /= No_Language_Index loop
1342 if Lang.Name = Name_Ada then
1343 return Lang.First_Source /= No_Source;
1349 end Has_Ada_Sources;
1351 ------------------------
1352 -- Contains_ALI_Files --
1353 ------------------------
1355 function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is
1356 Dir_Name : constant String := Get_Name_String (Dir);
1358 Name : String (1 .. 1_000);
1360 Result : Boolean := False;
1363 Open (Direct, Dir_Name);
1365 -- For each file in the directory, check if it is an ALI file
1368 Read (Direct, Name, Last);
1370 Canonical_Case_File_Name (Name (1 .. Last));
1371 Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali";
1379 -- If there is any problem, close the directory if open and return True.
1380 -- The library directory will be added to the path.
1383 if Is_Open (Direct) then
1388 end Contains_ALI_Files;
1390 --------------------------
1391 -- Get_Object_Directory --
1392 --------------------------
1394 function Get_Object_Directory
1395 (Project : Project_Id;
1396 Including_Libraries : Boolean;
1397 Only_If_Ada : Boolean := False) return Path_Name_Type
1400 if (Project.Library and then Including_Libraries)
1402 (Project.Object_Directory /= No_Path_Information
1403 and then (not Including_Libraries or else not Project.Library))
1405 -- For a library project, add the library ALI directory if there is
1406 -- no object directory or if the library ALI directory contains ALI
1407 -- files; otherwise add the object directory.
1409 if Project.Library then
1410 if Project.Object_Directory = No_Path_Information
1411 or else Contains_ALI_Files (Project.Library_ALI_Dir.Display_Name)
1413 return Project.Library_ALI_Dir.Display_Name;
1415 return Project.Object_Directory.Display_Name;
1418 -- For a non-library project, add object directory if it is not a
1419 -- virtual project, and if there are Ada sources in the project or
1420 -- one of the projects it extends. If there are no Ada sources,
1421 -- adding the object directory could disrupt the order of the
1422 -- object dirs in the path.
1424 elsif not Project.Virtual then
1426 Add_Object_Dir : Boolean;
1430 Add_Object_Dir := not Only_If_Ada;
1432 while not Add_Object_Dir and then Prj /= No_Project loop
1433 if Has_Ada_Sources (Prj) then
1434 Add_Object_Dir := True;
1440 if Add_Object_Dir then
1441 return Project.Object_Directory.Display_Name;
1448 end Get_Object_Directory;
1450 -----------------------------------
1451 -- Ultimate_Extending_Project_Of --
1452 -----------------------------------
1454 function Ultimate_Extending_Project_Of
1455 (Proj : Project_Id) return Project_Id
1461 while Prj /= null and then Prj.Extended_By /= No_Project loop
1462 Prj := Prj.Extended_By;
1466 end Ultimate_Extending_Project_Of;
1468 -----------------------------------
1469 -- Compute_All_Imported_Projects --
1470 -----------------------------------
1472 procedure Compute_All_Imported_Projects
1473 (Root_Project : Project_Id;
1474 Tree : Project_Tree_Ref)
1476 procedure Analyze_Tree
1477 (Local_Root : Project_Id;
1478 Local_Tree : Project_Tree_Ref);
1479 -- Process Project and all its aggregated project to analyze their own
1480 -- imported projects.
1486 procedure Analyze_Tree
1487 (Local_Root : Project_Id;
1488 Local_Tree : Project_Tree_Ref)
1490 pragma Unreferenced (Local_Root);
1492 Project : Project_Id;
1494 procedure Recursive_Add
1496 Tree : Project_Tree_Ref;
1497 Context : Project_Context;
1498 Dummy : in out Boolean);
1499 -- Recursively add the projects imported by project Project, but not
1500 -- those that are extended.
1506 procedure Recursive_Add
1508 Tree : Project_Tree_Ref;
1509 Context : Project_Context;
1510 Dummy : in out Boolean)
1512 pragma Unreferenced (Dummy, Tree);
1514 List : Project_List;
1518 -- A project is not importing itself
1520 Prj2 := Ultimate_Extending_Project_Of (Prj);
1522 if Project /= Prj2 then
1524 -- Check that the project is not already in the list. We know
1525 -- the one passed to Recursive_Add have never been visited
1526 -- before, but the one passed it are the extended projects.
1528 List := Project.All_Imported_Projects;
1529 while List /= null loop
1530 if List.Project = Prj2 then
1537 -- Add it to the list
1539 Project.All_Imported_Projects :=
1540 new Project_List_Element'
1542 From_Encapsulated_Lib => Context.From_Encapsulated_Lib,
1543 Next => Project.All_Imported_Projects);
1547 procedure For_All_Projects is
1548 new For_Every_Project_Imported_Context (Boolean, Recursive_Add);
1550 Dummy : Boolean := False;
1551 List : Project_List;
1554 List := Local_Tree.Projects;
1555 while List /= null loop
1556 Project := List.Project;
1558 (Project.All_Imported_Projects, Free_Project => False);
1560 (Project, Local_Tree, Dummy, Include_Aggregated => False);
1565 procedure For_Aggregates is
1566 new For_Project_And_Aggregated (Analyze_Tree);
1568 -- Start of processing for Compute_All_Imported_Projects
1571 For_Aggregates (Root_Project, Tree);
1572 end Compute_All_Imported_Projects;
1578 function Is_Compilable (Source : Source_Id) return Boolean is
1580 case Source.Compilable is
1582 if Source.Language.Config.Compiler_Driver /= No_File
1584 Length_Of_Name (Source.Language.Config.Compiler_Driver) /= 0
1585 and then not Source.Locally_Removed
1586 and then (Source.Language.Config.Kind /= File_Based
1587 or else Source.Kind /= Spec)
1589 -- Do not modify Source.Compilable before the source record
1590 -- has been initialized.
1592 if Source.Source_TS /= Empty_Time_Stamp then
1593 Source.Compilable := Yes;
1599 if Source.Source_TS /= Empty_Time_Stamp then
1600 Source.Compilable := No;
1614 ------------------------------
1615 -- Object_To_Global_Archive --
1616 ------------------------------
1618 function Object_To_Global_Archive (Source : Source_Id) return Boolean is
1620 return Source.Language.Config.Kind = File_Based
1621 and then Source.Kind = Impl
1622 and then Source.Language.Config.Objects_Linked
1623 and then Is_Compilable (Source)
1624 and then Source.Language.Config.Object_Generated;
1625 end Object_To_Global_Archive;
1627 ----------------------------
1628 -- Get_Language_From_Name --
1629 ----------------------------
1631 function Get_Language_From_Name
1632 (Project : Project_Id;
1633 Name : String) return Language_Ptr
1636 Result : Language_Ptr;
1639 Name_Len := Name'Length;
1640 Name_Buffer (1 .. Name_Len) := Name;
1641 To_Lower (Name_Buffer (1 .. Name_Len));
1644 Result := Project.Languages;
1645 while Result /= No_Language_Index loop
1646 if Result.Name = N then
1650 Result := Result.Next;
1653 return No_Language_Index;
1654 end Get_Language_From_Name;
1660 function Other_Part (Source : Source_Id) return Source_Id is
1662 if Source.Unit /= No_Unit_Index then
1665 return Source.Unit.File_Names (Spec);
1667 return Source.Unit.File_Names (Impl);
1680 function Create_Flags
1681 (Report_Error : Error_Handler;
1682 When_No_Sources : Error_Warning;
1683 Require_Sources_Other_Lang : Boolean := True;
1684 Allow_Duplicate_Basenames : Boolean := True;
1685 Compiler_Driver_Mandatory : Boolean := False;
1686 Error_On_Unknown_Language : Boolean := True;
1687 Require_Obj_Dirs : Error_Warning := Error;
1688 Allow_Invalid_External : Error_Warning := Error;
1689 Missing_Source_Files : Error_Warning := Error;
1690 Ignore_Missing_With : Boolean := False)
1691 return Processing_Flags
1694 return Processing_Flags'
1695 (Report_Error => Report_Error,
1696 When_No_Sources => When_No_Sources,
1697 Require_Sources_Other_Lang => Require_Sources_Other_Lang,
1698 Allow_Duplicate_Basenames => Allow_Duplicate_Basenames,
1699 Error_On_Unknown_Language => Error_On_Unknown_Language,
1700 Compiler_Driver_Mandatory => Compiler_Driver_Mandatory,
1701 Require_Obj_Dirs => Require_Obj_Dirs,
1702 Allow_Invalid_External => Allow_Invalid_External,
1703 Missing_Source_Files => Missing_Source_Files,
1704 Ignore_Missing_With => Ignore_Missing_With);
1712 (Table : Name_List_Table.Instance;
1713 List : Name_List_Index) return Natural
1715 Count : Natural := 0;
1716 Tmp : Name_List_Index;
1720 while Tmp /= No_Name_List loop
1722 Tmp := Table.Table (Tmp).Next;
1732 procedure Debug_Output (Str : String) is
1734 if Current_Verbosity > Default then
1736 Write_Line ((1 .. Debug_Level * 2 => ' ') & Str);
1737 Set_Standard_Output;
1745 procedure Debug_Indent is
1747 if Current_Verbosity = High then
1749 Write_Str ((1 .. Debug_Level * 2 => ' '));
1750 Set_Standard_Output;
1758 procedure Debug_Output (Str : String; Str2 : Name_Id) is
1760 if Current_Verbosity = High then
1765 if Str2 = No_Name then
1766 Write_Line (" <no_name>");
1768 Write_Line (" """ & Get_Name_String (Str2) & '"');
1771 Set_Standard_Output;
1775 ---------------------------
1776 -- Debug_Increase_Indent --
1777 ---------------------------
1779 procedure Debug_Increase_Indent
1780 (Str : String := ""; Str2 : Name_Id := No_Name)
1783 if Str2 /= No_Name then
1784 Debug_Output (Str, Str2);
1788 Debug_Level := Debug_Level + 1;
1789 end Debug_Increase_Indent;
1791 ---------------------------
1792 -- Debug_Decrease_Indent --
1793 ---------------------------
1795 procedure Debug_Decrease_Indent (Str : String := "") is
1797 if Debug_Level > 0 then
1798 Debug_Level := Debug_Level - 1;
1804 end Debug_Decrease_Indent;
1810 function Debug_Name (Tree : Project_Tree_Ref) return Name_Id is
1815 Add_Str_To_Name_Buffer ("Tree [");
1818 while P /= null loop
1819 if P /= Tree.Projects then
1820 Add_Char_To_Name_Buffer (',');
1823 Add_Str_To_Name_Buffer (Get_Name_String (P.Project.Name));
1828 Add_Char_To_Name_Buffer (']');
1837 procedure Free (Tree : in out Project_Tree_Appdata) is
1838 pragma Unreferenced (Tree);
1843 --------------------------------
1844 -- For_Project_And_Aggregated --
1845 --------------------------------
1847 procedure For_Project_And_Aggregated
1848 (Root_Project : Project_Id;
1849 Root_Tree : Project_Tree_Ref)
1851 Agg : Aggregated_Project_List;
1854 Action (Root_Project, Root_Tree);
1856 if Root_Project.Qualifier in Aggregate_Project then
1857 Agg := Root_Project.Aggregated_Projects;
1858 while Agg /= null loop
1859 For_Project_And_Aggregated (Agg.Project, Agg.Tree);
1863 end For_Project_And_Aggregated;
1865 -- Package initialization for Prj
1868 -- Make sure that the standard config and user project file extensions are
1869 -- compatible with canonical case file naming.
1871 Canonical_Case_File_Name (Config_Project_File_Extension);
1872 Canonical_Case_File_Name (Project_File_Extension);