1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2010, 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 ------------------------------------------------------------------------------
27 with Osint; use Osint;
28 with Output; use Output;
30 with Prj.Err; use Prj.Err;
31 with Snames; use Snames;
32 with Uintp; use Uintp;
34 with Ada.Characters.Handling; use Ada.Characters.Handling;
35 with Ada.Unchecked_Deallocation;
37 with GNAT.Case_Util; use GNAT.Case_Util;
38 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
43 Object_Suffix : constant String := Get_Target_Object_Suffix.all;
44 -- File suffix for object files
46 Initial_Buffer_Size : constant := 100;
47 -- Initial size for extensible buffer used in Add_To_Buffer
49 The_Empty_String : Name_Id := No_Name;
51 type Cst_String_Access is access constant String;
53 All_Lower_Case_Image : aliased constant String := "lowercase";
54 All_Upper_Case_Image : aliased constant String := "UPPERCASE";
55 Mixed_Case_Image : aliased constant String := "MixedCase";
57 The_Casing_Images : constant array (Known_Casing) of Cst_String_Access :=
58 (All_Lower_Case => All_Lower_Case_Image'Access,
59 All_Upper_Case => All_Upper_Case_Image'Access,
60 Mixed_Case => Mixed_Case_Image'Access);
62 Project_Empty : constant Project_Data :=
63 (Qualifier => Unspecified,
64 Externally_Built => False,
65 Config => Default_Project_Config,
67 Display_Name => No_Name,
68 Path => No_Path_Information,
70 Location => No_Location,
72 Directory => No_Path_Information,
74 Library_Dir => No_Path_Information,
75 Library_Src_Dir => No_Path_Information,
76 Library_ALI_Dir => No_Path_Information,
77 Library_Name => No_Name,
78 Library_Kind => Static,
79 Lib_Internal_Name => No_Name,
80 Standalone_Library => False,
81 Lib_Interface_ALIs => Nil_String,
82 Lib_Auto_Init => False,
83 Libgnarl_Needed => Unknown,
84 Symbol_Data => No_Symbols,
85 Interfaces_Defined => False,
86 Source_Dirs => Nil_String,
87 Source_Dir_Ranks => No_Number_List,
88 Object_Directory => No_Path_Information,
89 Library_TS => Empty_Time_Stamp,
90 Exec_Directory => No_Path_Information,
91 Extends => No_Project,
92 Extended_By => No_Project,
93 Languages => No_Language_Index,
94 Decl => No_Declarations,
95 Imported_Projects => null,
96 Include_Path_File => No_Path,
97 All_Imported_Projects => null,
98 Ada_Include_Path => null,
99 Ada_Objects_Path => null,
100 Objects_Path => null,
101 Objects_Path_File_With_Libs => No_Path,
102 Objects_Path_File_Without_Libs => No_Path,
103 Config_File_Name => No_Path,
104 Config_File_Temp => False,
105 Config_Checked => False,
106 Need_To_Build_Lib => False,
107 Has_Multi_Unit_Sources => False,
109 Unkept_Comments => False);
111 procedure Free (Project : in out Project_Id);
112 -- Free memory allocated for Project
114 procedure Free_List (Languages : in out Language_Ptr);
115 procedure Free_List (Source : in out Source_Id);
116 procedure Free_List (Languages : in out Language_List);
117 -- Free memory allocated for the list of languages or sources
119 procedure Free_Units (Table : in out Units_Htable.Instance);
120 -- Free memory allocated for unit information in the project
122 procedure Language_Changed (Iter : in out Source_Iterator);
123 procedure Project_Changed (Iter : in out Source_Iterator);
124 -- Called when a new project or language was selected for this iterator
126 function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean;
127 -- Return True if there is at least one ALI file in the directory Dir
133 procedure Add_To_Buffer
135 To : in out String_Access;
136 Last : in out Natural)
140 To := new String (1 .. Initial_Buffer_Size);
144 -- If Buffer is too small, double its size
146 while Last + S'Length > To'Last loop
148 New_Buffer : constant String_Access :=
149 new String (1 .. 2 * Last);
152 New_Buffer (1 .. Last) := To (1 .. Last);
158 To (Last + 1 .. Last + S'Length) := S;
159 Last := Last + S'Length;
162 ---------------------------
163 -- Delete_Temporary_File --
164 ---------------------------
166 procedure Delete_Temporary_File
167 (Tree : Project_Tree_Ref;
168 Path : Path_Name_Type)
171 pragma Warnings (Off, Dont_Care);
174 if not Debug.Debug_Flag_N then
175 if Current_Verbosity = High then
176 Write_Line ("Removing temp file: " & Get_Name_String (Path));
179 Delete_File (Get_Name_String (Path), Dont_Care);
182 1 .. Temp_Files_Table.Last (Tree.Private_Part.Temp_Files)
184 if Tree.Private_Part.Temp_Files.Table (Index) = Path then
185 Tree.Private_Part.Temp_Files.Table (Index) := No_Path;
189 end Delete_Temporary_File;
191 ---------------------------
192 -- Delete_All_Temp_Files --
193 ---------------------------
195 procedure Delete_All_Temp_Files (Tree : Project_Tree_Ref) is
197 pragma Warnings (Off, Dont_Care);
199 Path : Path_Name_Type;
202 if not Debug.Debug_Flag_N then
204 1 .. Temp_Files_Table.Last (Tree.Private_Part.Temp_Files)
206 Path := Tree.Private_Part.Temp_Files.Table (Index);
208 if Path /= No_Path then
209 if Current_Verbosity = High then
210 Write_Line ("Removing temp file: "
211 & Get_Name_String (Path));
214 Delete_File (Get_Name_String (Path), Dont_Care);
218 Temp_Files_Table.Free (Tree.Private_Part.Temp_Files);
219 Temp_Files_Table.Init (Tree.Private_Part.Temp_Files);
222 -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or
223 -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
224 -- the empty string. On VMS, this has the effect of deassigning
225 -- the logical names.
227 if Tree.Private_Part.Current_Source_Path_File /= No_Path then
228 Setenv (Project_Include_Path_File, "");
231 if Tree.Private_Part.Current_Object_Path_File /= No_Path then
232 Setenv (Project_Objects_Path_File, "");
234 end Delete_All_Temp_Files;
236 ---------------------
237 -- Dependency_Name --
238 ---------------------
240 function Dependency_Name
241 (Source_File_Name : File_Name_Type;
242 Dependency : Dependency_File_Kind) return File_Name_Type
250 return Extend_Name (Source_File_Name, Makefile_Dependency_Suffix);
253 return Extend_Name (Source_File_Name, ALI_Dependency_Suffix);
261 function Empty_File return File_Name_Type is
263 return File_Name_Type (The_Empty_String);
270 function Empty_Project return Project_Data is
272 Prj.Initialize (Tree => No_Project_Tree);
273 return Project_Empty;
280 function Empty_String return Name_Id is
282 return The_Empty_String;
289 procedure Expect (The_Token : Token_Type; Token_Image : String) is
291 if Token /= The_Token then
292 -- ??? Should pass user flags here instead
293 Error_Msg (Gnatmake_Flags, Token_Image & " expected", Token_Ptr);
302 (File : File_Name_Type;
303 With_Suffix : String) return File_Name_Type
308 Get_Name_String (File);
309 Last := Name_Len + 1;
311 while Name_Len /= 0 and then Name_Buffer (Name_Len) /= '.' loop
312 Name_Len := Name_Len - 1;
315 if Name_Len <= 1 then
319 for J in With_Suffix'Range loop
320 Name_Buffer (Name_Len) := With_Suffix (J);
321 Name_Len := Name_Len + 1;
324 Name_Len := Name_Len - 1;
329 ---------------------
330 -- Project_Changed --
331 ---------------------
333 procedure Project_Changed (Iter : in out Source_Iterator) is
335 Iter.Language := Iter.Project.Project.Languages;
336 Language_Changed (Iter);
339 ----------------------
340 -- Language_Changed --
341 ----------------------
343 procedure Language_Changed (Iter : in out Source_Iterator) is
345 Iter.Current := No_Source;
347 if Iter.Language_Name /= No_Name then
348 while Iter.Language /= null
349 and then Iter.Language.Name /= Iter.Language_Name
351 Iter.Language := Iter.Language.Next;
355 -- If there is no matching language in this project, move to next
357 if Iter.Language = No_Language_Index then
358 if Iter.All_Projects then
359 Iter.Project := Iter.Project.Next;
361 if Iter.Project /= null then
362 Project_Changed (Iter);
366 Iter.Project := null;
370 Iter.Current := Iter.Language.First_Source;
372 if Iter.Current = No_Source then
373 Iter.Language := Iter.Language.Next;
374 Language_Changed (Iter);
377 end Language_Changed;
379 ---------------------
380 -- For_Each_Source --
381 ---------------------
383 function For_Each_Source
384 (In_Tree : Project_Tree_Ref;
385 Project : Project_Id := No_Project;
386 Language : Name_Id := No_Name) return Source_Iterator
388 Iter : Source_Iterator;
390 Iter := Source_Iterator'
392 Project => In_Tree.Projects,
393 All_Projects => Project = No_Project,
394 Language_Name => Language,
395 Language => No_Language_Index,
396 Current => No_Source);
398 if Project /= null then
399 while Iter.Project /= null
400 and then Iter.Project.Project /= Project
402 Iter.Project := Iter.Project.Next;
406 Project_Changed (Iter);
415 function Element (Iter : Source_Iterator) return Source_Id is
424 procedure Next (Iter : in out Source_Iterator) is
426 Iter.Current := Iter.Current.Next_In_Lang;
427 if Iter.Current = No_Source then
428 Iter.Language := Iter.Language.Next;
429 Language_Changed (Iter);
433 --------------------------------
434 -- For_Every_Project_Imported --
435 --------------------------------
437 procedure For_Every_Project_Imported
439 With_State : in out State;
440 Imported_First : Boolean := False)
442 use Project_Boolean_Htable;
443 Seen : Project_Boolean_Htable.Instance := Project_Boolean_Htable.Nil;
445 procedure Recursive_Check (Project : Project_Id);
446 -- Check if a project has already been seen. If not seen, mark it as
447 -- Seen, Call Action, and check all its imported projects.
449 ---------------------
450 -- Recursive_Check --
451 ---------------------
453 procedure Recursive_Check (Project : Project_Id) is
457 if not Get (Seen, Project) then
458 Set (Seen, Project, True);
460 if not Imported_First then
461 Action (Project, With_State);
464 -- Visited all extended projects
466 if Project.Extends /= No_Project then
467 Recursive_Check (Project.Extends);
470 -- Visited all imported projects
472 List := Project.Imported_Projects;
473 while List /= null loop
474 Recursive_Check (List.Project);
478 if Imported_First then
479 Action (Project, With_State);
484 -- Start of processing for For_Every_Project_Imported
487 Recursive_Check (Project => By);
489 end For_Every_Project_Imported;
496 (In_Tree : Project_Tree_Ref;
497 Project : Project_Id;
498 In_Imported_Only : Boolean := False;
499 In_Extended_Only : Boolean := False;
500 Base_Name : File_Name_Type) return Source_Id
502 Result : Source_Id := No_Source;
504 procedure Look_For_Sources (Proj : Project_Id; Src : in out Source_Id);
505 -- Look for Base_Name in the sources of Proj
507 ----------------------
508 -- Look_For_Sources --
509 ----------------------
511 procedure Look_For_Sources (Proj : Project_Id; Src : in out Source_Id) is
512 Iterator : Source_Iterator;
515 Iterator := For_Each_Source (In_Tree => In_Tree, Project => Proj);
516 while Element (Iterator) /= No_Source loop
517 if Element (Iterator).File = Base_Name then
518 Src := Element (Iterator);
524 end Look_For_Sources;
526 procedure For_Imported_Projects is new For_Every_Project_Imported
527 (State => Source_Id, Action => Look_For_Sources);
531 -- Start of processing for Find_Source
534 if In_Extended_Only then
536 while Proj /= No_Project loop
537 Look_For_Sources (Proj, Result);
538 exit when Result /= No_Source;
540 Proj := Proj.Extends;
543 elsif In_Imported_Only then
544 Look_For_Sources (Project, Result);
546 if Result = No_Source then
547 For_Imported_Projects
549 With_State => Result);
552 Look_For_Sources (No_Project, Result);
562 function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num);
563 -- Used in implementation of other functions Hash below
565 function Hash (Name : File_Name_Type) return Header_Num is
567 return Hash (Get_Name_String (Name));
570 function Hash (Name : Name_Id) return Header_Num is
572 return Hash (Get_Name_String (Name));
575 function Hash (Name : Path_Name_Type) return Header_Num is
577 return Hash (Get_Name_String (Name));
580 function Hash (Project : Project_Id) return Header_Num is
582 if Project = No_Project then
583 return Header_Num'First;
585 return Hash (Get_Name_String (Project.Name));
593 function Image (The_Casing : Casing_Type) return String is
595 return The_Casing_Images (The_Casing).all;
598 -----------------------------
599 -- Is_Standard_GNAT_Naming --
600 -----------------------------
602 function Is_Standard_GNAT_Naming
603 (Naming : Lang_Naming_Data) return Boolean
606 return Get_Name_String (Naming.Spec_Suffix) = ".ads"
607 and then Get_Name_String (Naming.Body_Suffix) = ".adb"
608 and then Get_Name_String (Naming.Dot_Replacement) = "-";
609 end Is_Standard_GNAT_Naming;
615 procedure Initialize (Tree : Project_Tree_Ref) is
617 if The_Empty_String = No_Name then
620 The_Empty_String := Name_Find;
623 Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
624 Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends));
625 Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
628 if Tree /= No_Project_Tree then
637 function Is_Extending
638 (Extending : Project_Id;
639 Extended : Project_Id) return Boolean
645 while Proj /= No_Project loop
646 if Proj = Extended then
650 Proj := Proj.Extends;
661 (Source_File_Name : File_Name_Type;
662 Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
665 if Object_File_Suffix = No_Name then
667 (Source_File_Name, Object_Suffix);
670 (Source_File_Name, Get_Name_String (Object_File_Suffix));
675 (Source_File_Name : File_Name_Type;
677 Index_Separator : Character;
678 Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
680 Index_Img : constant String := Source_Index'Img;
684 Get_Name_String (Source_File_Name);
687 while Last > 1 and then Name_Buffer (Last) /= '.' loop
692 Name_Len := Last - 1;
695 Add_Char_To_Name_Buffer (Index_Separator);
696 Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last));
698 if Object_File_Suffix = No_Name then
699 Add_Str_To_Name_Buffer (Object_Suffix);
701 Add_Str_To_Name_Buffer (Get_Name_String (Object_File_Suffix));
707 ----------------------
708 -- Record_Temp_File --
709 ----------------------
711 procedure Record_Temp_File
712 (Tree : Project_Tree_Ref;
713 Path : Path_Name_Type)
716 Temp_Files_Table.Append (Tree.Private_Part.Temp_Files, Path);
717 end Record_Temp_File;
723 procedure Free (Project : in out Project_Id) is
724 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
725 (Project_Data, Project_Id);
728 if Project /= null then
729 Free (Project.Ada_Include_Path);
730 Free (Project.Objects_Path);
731 Free (Project.Ada_Objects_Path);
732 Free_List (Project.Imported_Projects, Free_Project => False);
733 Free_List (Project.All_Imported_Projects, Free_Project => False);
734 Free_List (Project.Languages);
736 Unchecked_Free (Project);
744 procedure Free_List (Languages : in out Language_List) is
745 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
746 (Language_List_Element, Language_List);
749 while Languages /= null loop
750 Tmp := Languages.Next;
751 Unchecked_Free (Languages);
760 procedure Free_List (Source : in out Source_Id) is
761 procedure Unchecked_Free is new
762 Ada.Unchecked_Deallocation (Source_Data, Source_Id);
767 while Source /= No_Source loop
768 Tmp := Source.Next_In_Lang;
769 Free_List (Source.Alternate_Languages);
771 if Source.Unit /= null
772 and then Source.Kind in Spec_Or_Body
774 Source.Unit.File_Names (Source.Kind) := null;
777 Unchecked_Free (Source);
787 (List : in out Project_List;
788 Free_Project : Boolean)
790 procedure Unchecked_Free is new
791 Ada.Unchecked_Deallocation (Project_List_Element, Project_List);
796 while List /= null loop
803 Unchecked_Free (List);
812 procedure Free_List (Languages : in out Language_Ptr) is
813 procedure Unchecked_Free is new
814 Ada.Unchecked_Deallocation (Language_Data, Language_Ptr);
819 while Languages /= null loop
820 Tmp := Languages.Next;
821 Free_List (Languages.First_Source);
822 Unchecked_Free (Languages);
831 procedure Free_Units (Table : in out Units_Htable.Instance) is
832 procedure Unchecked_Free is new
833 Ada.Unchecked_Deallocation (Unit_Data, Unit_Index);
838 Unit := Units_Htable.Get_First (Table);
839 while Unit /= No_Unit_Index loop
840 if Unit.File_Names (Spec) /= null then
841 Unit.File_Names (Spec).Unit := No_Unit_Index;
844 if Unit.File_Names (Impl) /= null then
845 Unit.File_Names (Impl).Unit := No_Unit_Index;
848 Unchecked_Free (Unit);
849 Unit := Units_Htable.Get_Next (Table);
852 Units_Htable.Reset (Table);
859 procedure Free (Tree : in out Project_Tree_Ref) is
860 procedure Unchecked_Free is new
861 Ada.Unchecked_Deallocation (Project_Tree_Data, Project_Tree_Ref);
865 Name_List_Table.Free (Tree.Name_Lists);
866 Number_List_Table.Free (Tree.Number_Lists);
867 String_Element_Table.Free (Tree.String_Elements);
868 Variable_Element_Table.Free (Tree.Variable_Elements);
869 Array_Element_Table.Free (Tree.Array_Elements);
870 Array_Table.Free (Tree.Arrays);
871 Package_Table.Free (Tree.Packages);
872 Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
874 Free_List (Tree.Projects, Free_Project => True);
875 Free_Units (Tree.Units_HT);
879 Temp_Files_Table.Free (Tree.Private_Part.Temp_Files);
881 Unchecked_Free (Tree);
889 procedure Reset (Tree : Project_Tree_Ref) is
893 Name_List_Table.Init (Tree.Name_Lists);
894 Number_List_Table.Init (Tree.Number_Lists);
895 String_Element_Table.Init (Tree.String_Elements);
896 Variable_Element_Table.Init (Tree.Variable_Elements);
897 Array_Element_Table.Init (Tree.Array_Elements);
898 Array_Table.Init (Tree.Arrays);
899 Package_Table.Init (Tree.Packages);
900 Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
902 Free_List (Tree.Projects, Free_Project => True);
903 Free_Units (Tree.Units_HT);
905 -- Private part table
907 Temp_Files_Table.Init (Tree.Private_Part.Temp_Files);
909 Tree.Private_Part.Current_Source_Path_File := No_Path;
910 Tree.Private_Part.Current_Object_Path_File := No_Path;
917 function Switches_Name
918 (Source_File_Name : File_Name_Type) return File_Name_Type
921 return Extend_Name (Source_File_Name, Switches_Dependency_Suffix);
928 function Value (Image : String) return Casing_Type is
930 for Casing in The_Casing_Images'Range loop
931 if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
936 raise Constraint_Error;
939 ---------------------
940 -- Has_Ada_Sources --
941 ---------------------
943 function Has_Ada_Sources (Data : Project_Id) return Boolean is
947 Lang := Data.Languages;
948 while Lang /= No_Language_Index loop
949 if Lang.Name = Name_Ada then
950 return Lang.First_Source /= No_Source;
958 ------------------------
959 -- Contains_ALI_Files --
960 ------------------------
962 function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is
963 Dir_Name : constant String := Get_Name_String (Dir);
965 Name : String (1 .. 1_000);
967 Result : Boolean := False;
970 Open (Direct, Dir_Name);
972 -- For each file in the directory, check if it is an ALI file
975 Read (Direct, Name, Last);
977 Canonical_Case_File_Name (Name (1 .. Last));
978 Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali";
986 -- If there is any problem, close the directory if open and return True.
987 -- The library directory will be added to the path.
990 if Is_Open (Direct) then
995 end Contains_ALI_Files;
997 --------------------------
998 -- Get_Object_Directory --
999 --------------------------
1001 function Get_Object_Directory
1002 (Project : Project_Id;
1003 Including_Libraries : Boolean;
1004 Only_If_Ada : Boolean := False) return Path_Name_Type
1007 if (Project.Library and then Including_Libraries)
1009 (Project.Object_Directory /= No_Path_Information
1010 and then (not Including_Libraries or else not Project.Library))
1012 -- For a library project, add the library ALI directory if there is
1013 -- no object directory or if the library ALI directory contains ALI
1014 -- files; otherwise add the object directory.
1016 if Project.Library then
1017 if Project.Object_Directory = No_Path_Information
1018 or else Contains_ALI_Files (Project.Library_ALI_Dir.Display_Name)
1020 return Project.Library_ALI_Dir.Display_Name;
1022 return Project.Object_Directory.Display_Name;
1025 -- For a non-library project, add object directory if it is not a
1026 -- virtual project, and if there are Ada sources in the project or
1027 -- one of the projects it extends. If there are no Ada sources,
1028 -- adding the object directory could disrupt the order of the
1029 -- object dirs in the path.
1031 elsif not Project.Virtual then
1033 Add_Object_Dir : Boolean;
1037 Add_Object_Dir := not Only_If_Ada;
1039 while not Add_Object_Dir and then Prj /= No_Project loop
1040 if Has_Ada_Sources (Prj) then
1041 Add_Object_Dir := True;
1047 if Add_Object_Dir then
1048 return Project.Object_Directory.Display_Name;
1055 end Get_Object_Directory;
1057 -----------------------------------
1058 -- Ultimate_Extending_Project_Of --
1059 -----------------------------------
1061 function Ultimate_Extending_Project_Of
1062 (Proj : Project_Id) return Project_Id
1068 while Prj /= null and then Prj.Extended_By /= No_Project loop
1069 Prj := Prj.Extended_By;
1073 end Ultimate_Extending_Project_Of;
1075 -----------------------------------
1076 -- Compute_All_Imported_Projects --
1077 -----------------------------------
1079 procedure Compute_All_Imported_Projects (Tree : Project_Tree_Ref) is
1080 Project : Project_Id;
1082 procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean);
1083 -- Recursively add the projects imported by project Project, but not
1084 -- those that are extended.
1090 procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean) is
1091 pragma Unreferenced (Dummy);
1092 List : Project_List;
1096 -- A project is not importing itself
1098 Prj2 := Ultimate_Extending_Project_Of (Prj);
1100 if Project /= Prj2 then
1102 -- Check that the project is not already in the list. We know the
1103 -- one passed to Recursive_Add have never been visited before, but
1104 -- the one passed it are the extended projects.
1106 List := Project.All_Imported_Projects;
1107 while List /= null loop
1108 if List.Project = Prj2 then
1115 -- Add it to the list
1117 Project.All_Imported_Projects :=
1118 new Project_List_Element'
1120 Next => Project.All_Imported_Projects);
1124 procedure For_All_Projects is
1125 new For_Every_Project_Imported (Boolean, Recursive_Add);
1127 Dummy : Boolean := False;
1128 List : Project_List;
1131 List := Tree.Projects;
1132 while List /= null loop
1133 Project := List.Project;
1134 Free_List (Project.All_Imported_Projects, Free_Project => False);
1135 For_All_Projects (Project, Dummy);
1138 end Compute_All_Imported_Projects;
1144 function Is_Compilable (Source : Source_Id) return Boolean is
1146 return Source.Language.Config.Compiler_Driver /= No_File
1147 and then Length_Of_Name (Source.Language.Config.Compiler_Driver) /= 0
1148 and then not Source.Locally_Removed
1149 and then (Source.Language.Config.Kind /= File_Based
1151 Source.Kind /= Spec);
1154 ------------------------------
1155 -- Object_To_Global_Archive --
1156 ------------------------------
1158 function Object_To_Global_Archive (Source : Source_Id) return Boolean is
1160 return Source.Language.Config.Kind = File_Based
1161 and then Source.Kind = Impl
1162 and then Source.Language.Config.Objects_Linked
1163 and then Is_Compilable (Source)
1164 and then Source.Language.Config.Object_Generated;
1165 end Object_To_Global_Archive;
1167 ----------------------------
1168 -- Get_Language_From_Name --
1169 ----------------------------
1171 function Get_Language_From_Name
1172 (Project : Project_Id;
1173 Name : String) return Language_Ptr
1176 Result : Language_Ptr;
1179 Name_Len := Name'Length;
1180 Name_Buffer (1 .. Name_Len) := Name;
1181 To_Lower (Name_Buffer (1 .. Name_Len));
1184 Result := Project.Languages;
1185 while Result /= No_Language_Index loop
1186 if Result.Name = N then
1190 Result := Result.Next;
1193 return No_Language_Index;
1194 end Get_Language_From_Name;
1200 function Other_Part (Source : Source_Id) return Source_Id is
1202 if Source.Unit /= No_Unit_Index then
1205 return Source.Unit.File_Names (Spec);
1207 return Source.Unit.File_Names (Impl);
1220 function Create_Flags
1221 (Report_Error : Error_Handler;
1222 When_No_Sources : Error_Warning;
1223 Require_Sources_Other_Lang : Boolean := True;
1224 Allow_Duplicate_Basenames : Boolean := True;
1225 Compiler_Driver_Mandatory : Boolean := False;
1226 Error_On_Unknown_Language : Boolean := True;
1227 Require_Obj_Dirs : Error_Warning := Error;
1228 Allow_Invalid_External : Error_Warning := Error;
1229 Missing_Source_Files : Error_Warning := Error)
1230 return Processing_Flags
1233 return Processing_Flags'
1234 (Report_Error => Report_Error,
1235 When_No_Sources => When_No_Sources,
1236 Require_Sources_Other_Lang => Require_Sources_Other_Lang,
1237 Allow_Duplicate_Basenames => Allow_Duplicate_Basenames,
1238 Error_On_Unknown_Language => Error_On_Unknown_Language,
1239 Compiler_Driver_Mandatory => Compiler_Driver_Mandatory,
1240 Require_Obj_Dirs => Require_Obj_Dirs,
1241 Allow_Invalid_External => Allow_Invalid_External,
1242 Missing_Source_Files => Missing_Source_Files);
1250 (Table : Name_List_Table.Instance;
1251 List : Name_List_Index) return Natural
1253 Count : Natural := 0;
1254 Tmp : Name_List_Index;
1258 while Tmp /= No_Name_List loop
1260 Tmp := Table.Table (Tmp).Next;
1267 -- Make sure that the standard config and user project file extensions are
1268 -- compatible with canonical case file naming.
1270 Canonical_Case_File_Name (Config_Project_File_Extension);
1271 Canonical_Case_File_Name (Project_File_Extension);