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 subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
53 type Cst_String_Access is access constant String;
55 All_Lower_Case_Image : aliased constant String := "lowercase";
56 All_Upper_Case_Image : aliased constant String := "UPPERCASE";
57 Mixed_Case_Image : aliased constant String := "MixedCase";
59 The_Casing_Images : constant array (Known_Casing) of Cst_String_Access :=
60 (All_Lower_Case => All_Lower_Case_Image'Access,
61 All_Upper_Case => All_Upper_Case_Image'Access,
62 Mixed_Case => Mixed_Case_Image'Access);
64 Project_Empty : constant Project_Data :=
65 (Qualifier => Unspecified,
66 Externally_Built => False,
67 Config => Default_Project_Config,
69 Display_Name => No_Name,
70 Path => No_Path_Information,
72 Location => No_Location,
74 Directory => No_Path_Information,
76 Library_Dir => No_Path_Information,
77 Library_Src_Dir => No_Path_Information,
78 Library_ALI_Dir => No_Path_Information,
79 Library_Name => No_Name,
80 Library_Kind => Static,
81 Lib_Internal_Name => No_Name,
82 Standalone_Library => False,
83 Lib_Interface_ALIs => Nil_String,
84 Lib_Auto_Init => False,
85 Libgnarl_Needed => Unknown,
86 Symbol_Data => No_Symbols,
87 Interfaces_Defined => False,
88 Source_Dirs => Nil_String,
89 Source_Dir_Ranks => No_Number_List,
90 Object_Directory => No_Path_Information,
91 Library_TS => Empty_Time_Stamp,
92 Exec_Directory => No_Path_Information,
93 Extends => No_Project,
94 Extended_By => No_Project,
95 Languages => No_Language_Index,
96 Decl => No_Declarations,
97 Imported_Projects => null,
98 Include_Path_File => No_Path,
99 All_Imported_Projects => null,
100 Ada_Include_Path => null,
101 Ada_Objects_Path => null,
102 Objects_Path => null,
103 Objects_Path_File_With_Libs => No_Path,
104 Objects_Path_File_Without_Libs => No_Path,
105 Config_File_Name => No_Path,
106 Config_File_Temp => False,
107 Config_Checked => False,
108 Need_To_Build_Lib => False,
109 Has_Multi_Unit_Sources => False,
111 Unkept_Comments => False);
113 procedure Free (Project : in out Project_Id);
114 -- Free memory allocated for Project
116 procedure Free_List (Languages : in out Language_Ptr);
117 procedure Free_List (Source : in out Source_Id);
118 procedure Free_List (Languages : in out Language_List);
119 -- Free memory allocated for the list of languages or sources
121 procedure Free_Units (Table : in out Units_Htable.Instance);
122 -- Free memory allocated for unit information in the project
124 procedure Language_Changed (Iter : in out Source_Iterator);
125 procedure Project_Changed (Iter : in out Source_Iterator);
126 -- Called when a new project or language was selected for this iterator
128 function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean;
129 -- Return True if there is at least one ALI file in the directory Dir
135 procedure Add_To_Buffer
137 To : in out String_Access;
138 Last : in out Natural)
142 To := new String (1 .. Initial_Buffer_Size);
146 -- If Buffer is too small, double its size
148 while Last + S'Length > To'Last loop
150 New_Buffer : constant String_Access :=
151 new String (1 .. 2 * Last);
154 New_Buffer (1 .. Last) := To (1 .. Last);
160 To (Last + 1 .. Last + S'Length) := S;
161 Last := Last + S'Length;
164 ---------------------------
165 -- Delete_Temporary_File --
166 ---------------------------
168 procedure Delete_Temporary_File
169 (Tree : Project_Tree_Ref;
170 Path : Path_Name_Type)
173 pragma Warnings (Off, Dont_Care);
176 if not Debug.Debug_Flag_N then
177 if Current_Verbosity = High then
178 Write_Line ("Removing temp file: " & Get_Name_String (Path));
181 Delete_File (Get_Name_String (Path), Dont_Care);
184 1 .. Temp_Files_Table.Last (Tree.Private_Part.Temp_Files)
186 if Tree.Private_Part.Temp_Files.Table (Index) = Path then
187 Tree.Private_Part.Temp_Files.Table (Index) := No_Path;
191 end Delete_Temporary_File;
193 ---------------------------
194 -- Delete_All_Temp_Files --
195 ---------------------------
197 procedure Delete_All_Temp_Files (Tree : Project_Tree_Ref) is
199 pragma Warnings (Off, Dont_Care);
201 Path : Path_Name_Type;
204 if not Debug.Debug_Flag_N then
206 1 .. Temp_Files_Table.Last (Tree.Private_Part.Temp_Files)
208 Path := Tree.Private_Part.Temp_Files.Table (Index);
210 if Path /= No_Path then
211 if Current_Verbosity = High then
212 Write_Line ("Removing temp file: "
213 & Get_Name_String (Path));
216 Delete_File (Get_Name_String (Path), Dont_Care);
220 Temp_Files_Table.Free (Tree.Private_Part.Temp_Files);
221 Temp_Files_Table.Init (Tree.Private_Part.Temp_Files);
224 -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or
225 -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
226 -- the empty string. On VMS, this has the effect of deassigning
227 -- the logical names.
229 if Tree.Private_Part.Current_Source_Path_File /= No_Path then
230 Setenv (Project_Include_Path_File, "");
233 if Tree.Private_Part.Current_Object_Path_File /= No_Path then
234 Setenv (Project_Objects_Path_File, "");
236 end Delete_All_Temp_Files;
238 ---------------------
239 -- Dependency_Name --
240 ---------------------
242 function Dependency_Name
243 (Source_File_Name : File_Name_Type;
244 Dependency : Dependency_File_Kind) return File_Name_Type
255 (Source_File_Name, Makefile_Dependency_Suffix));
261 (Source_File_Name, ALI_Dependency_Suffix));
269 function Empty_File return File_Name_Type is
271 return File_Name_Type (The_Empty_String);
278 function Empty_Project return Project_Data is
280 Prj.Initialize (Tree => No_Project_Tree);
281 return Project_Empty;
288 function Empty_String return Name_Id is
290 return The_Empty_String;
297 procedure Expect (The_Token : Token_Type; Token_Image : String) is
299 if Token /= The_Token then
300 -- ??? Should pass user flags here instead
301 Error_Msg (Gnatmake_Flags, Token_Image & " expected", Token_Ptr);
310 (File : File_Name_Type;
311 With_Suffix : String) return File_Name_Type
316 Get_Name_String (File);
317 Last := Name_Len + 1;
319 while Name_Len /= 0 and then Name_Buffer (Name_Len) /= '.' loop
320 Name_Len := Name_Len - 1;
323 if Name_Len <= 1 then
327 for J in With_Suffix'Range loop
328 Name_Buffer (Name_Len) := With_Suffix (J);
329 Name_Len := Name_Len + 1;
332 Name_Len := Name_Len - 1;
337 ---------------------
338 -- Project_Changed --
339 ---------------------
341 procedure Project_Changed (Iter : in out Source_Iterator) is
343 Iter.Language := Iter.Project.Project.Languages;
344 Language_Changed (Iter);
347 ----------------------
348 -- Language_Changed --
349 ----------------------
351 procedure Language_Changed (Iter : in out Source_Iterator) is
353 Iter.Current := No_Source;
355 if Iter.Language_Name /= No_Name then
356 while Iter.Language /= null
357 and then Iter.Language.Name /= Iter.Language_Name
359 Iter.Language := Iter.Language.Next;
363 -- If there is no matching language in this project, move to next
365 if Iter.Language = No_Language_Index then
366 if Iter.All_Projects then
367 Iter.Project := Iter.Project.Next;
369 if Iter.Project /= null then
370 Project_Changed (Iter);
374 Iter.Project := null;
378 Iter.Current := Iter.Language.First_Source;
380 if Iter.Current = No_Source then
381 Iter.Language := Iter.Language.Next;
382 Language_Changed (Iter);
385 end Language_Changed;
387 ---------------------
388 -- For_Each_Source --
389 ---------------------
391 function For_Each_Source
392 (In_Tree : Project_Tree_Ref;
393 Project : Project_Id := No_Project;
394 Language : Name_Id := No_Name) return Source_Iterator
396 Iter : Source_Iterator;
398 Iter := Source_Iterator'
400 Project => In_Tree.Projects,
401 All_Projects => Project = No_Project,
402 Language_Name => Language,
403 Language => No_Language_Index,
404 Current => No_Source);
406 if Project /= null then
407 while Iter.Project /= null
408 and then Iter.Project.Project /= Project
410 Iter.Project := Iter.Project.Next;
414 Project_Changed (Iter);
423 function Element (Iter : Source_Iterator) return Source_Id is
432 procedure Next (Iter : in out Source_Iterator) is
434 Iter.Current := Iter.Current.Next_In_Lang;
435 if Iter.Current = No_Source then
436 Iter.Language := Iter.Language.Next;
437 Language_Changed (Iter);
441 --------------------------------
442 -- For_Every_Project_Imported --
443 --------------------------------
445 procedure For_Every_Project_Imported
447 With_State : in out State;
448 Imported_First : Boolean := False)
450 use Project_Boolean_Htable;
451 Seen : Project_Boolean_Htable.Instance := Project_Boolean_Htable.Nil;
453 procedure Recursive_Check (Project : Project_Id);
454 -- Check if a project has already been seen. If not seen, mark it as
455 -- Seen, Call Action, and check all its imported projects.
457 ---------------------
458 -- Recursive_Check --
459 ---------------------
461 procedure Recursive_Check (Project : Project_Id) is
465 if not Get (Seen, Project) then
466 Set (Seen, Project, True);
468 if not Imported_First then
469 Action (Project, With_State);
472 -- Visited all extended projects
474 if Project.Extends /= No_Project then
475 Recursive_Check (Project.Extends);
478 -- Visited all imported projects
480 List := Project.Imported_Projects;
481 while List /= null loop
482 Recursive_Check (List.Project);
486 if Imported_First then
487 Action (Project, With_State);
492 -- Start of processing for For_Every_Project_Imported
495 Recursive_Check (Project => By);
497 end For_Every_Project_Imported;
504 (In_Tree : Project_Tree_Ref;
505 Project : Project_Id;
506 In_Imported_Only : Boolean := False;
507 In_Extended_Only : Boolean := False;
508 Base_Name : File_Name_Type) return Source_Id
510 Result : Source_Id := No_Source;
512 procedure Look_For_Sources (Proj : Project_Id; Src : in out Source_Id);
513 -- Look for Base_Name in the sources of Proj
515 ----------------------
516 -- Look_For_Sources --
517 ----------------------
519 procedure Look_For_Sources (Proj : Project_Id; Src : in out Source_Id) is
520 Iterator : Source_Iterator;
523 Iterator := For_Each_Source (In_Tree => In_Tree, Project => Proj);
524 while Element (Iterator) /= No_Source loop
525 if Element (Iterator).File = Base_Name then
526 Src := Element (Iterator);
532 end Look_For_Sources;
534 procedure For_Imported_Projects is new For_Every_Project_Imported
535 (State => Source_Id, Action => Look_For_Sources);
539 -- Start of processing for Find_Source
542 if In_Extended_Only then
544 while Proj /= No_Project loop
545 Look_For_Sources (Proj, Result);
546 exit when Result /= No_Source;
548 Proj := Proj.Extends;
551 elsif In_Imported_Only then
552 Look_For_Sources (Project, Result);
554 if Result = No_Source then
555 For_Imported_Projects
557 With_State => Result);
560 Look_For_Sources (No_Project, Result);
570 function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num);
571 -- Used in implementation of other functions Hash below
573 function Hash (Name : File_Name_Type) return Header_Num is
575 return Hash (Get_Name_String (Name));
578 function Hash (Name : Name_Id) return Header_Num is
580 return Hash (Get_Name_String (Name));
583 function Hash (Name : Path_Name_Type) return Header_Num is
585 return Hash (Get_Name_String (Name));
588 function Hash (Project : Project_Id) return Header_Num is
590 if Project = No_Project then
591 return Header_Num'First;
593 return Hash (Get_Name_String (Project.Name));
601 function Image (The_Casing : Casing_Type) return String is
603 return The_Casing_Images (The_Casing).all;
606 -----------------------------
607 -- Is_Standard_GNAT_Naming --
608 -----------------------------
610 function Is_Standard_GNAT_Naming
611 (Naming : Lang_Naming_Data) return Boolean
614 return Get_Name_String (Naming.Spec_Suffix) = ".ads"
615 and then Get_Name_String (Naming.Body_Suffix) = ".adb"
616 and then Get_Name_String (Naming.Dot_Replacement) = "-";
617 end Is_Standard_GNAT_Naming;
623 procedure Initialize (Tree : Project_Tree_Ref) is
625 if The_Empty_String = No_Name then
628 The_Empty_String := Name_Find;
631 Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
632 Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends));
633 Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
636 if Tree /= No_Project_Tree then
645 function Is_Extending
646 (Extending : Project_Id;
647 Extended : Project_Id) return Boolean
653 while Proj /= No_Project loop
654 if Proj = Extended then
658 Proj := Proj.Extends;
669 (Source_File_Name : File_Name_Type;
670 Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
673 if Object_File_Suffix = No_Name then
675 (Source_File_Name, Object_Suffix);
678 (Source_File_Name, Get_Name_String (Object_File_Suffix));
683 (Source_File_Name : File_Name_Type;
685 Index_Separator : Character;
686 Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
688 Index_Img : constant String := Source_Index'Img;
692 Get_Name_String (Source_File_Name);
695 while Last > 1 and then Name_Buffer (Last) /= '.' loop
700 Name_Len := Last - 1;
703 Add_Char_To_Name_Buffer (Index_Separator);
704 Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last));
706 if Object_File_Suffix = No_Name then
707 Add_Str_To_Name_Buffer (Object_Suffix);
709 Add_Str_To_Name_Buffer (Get_Name_String (Object_File_Suffix));
715 ----------------------
716 -- Record_Temp_File --
717 ----------------------
719 procedure Record_Temp_File
720 (Tree : Project_Tree_Ref;
721 Path : Path_Name_Type)
724 Temp_Files_Table.Append (Tree.Private_Part.Temp_Files, Path);
725 end Record_Temp_File;
731 procedure Free (Project : in out Project_Id) is
732 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
733 (Project_Data, Project_Id);
736 if Project /= null then
737 Free (Project.Ada_Include_Path);
738 Free (Project.Objects_Path);
739 Free (Project.Ada_Objects_Path);
740 Free_List (Project.Imported_Projects, Free_Project => False);
741 Free_List (Project.All_Imported_Projects, Free_Project => False);
742 Free_List (Project.Languages);
744 Unchecked_Free (Project);
752 procedure Free_List (Languages : in out Language_List) is
753 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
754 (Language_List_Element, Language_List);
757 while Languages /= null loop
758 Tmp := Languages.Next;
759 Unchecked_Free (Languages);
768 procedure Free_List (Source : in out Source_Id) is
769 procedure Unchecked_Free is new
770 Ada.Unchecked_Deallocation (Source_Data, Source_Id);
775 while Source /= No_Source loop
776 Tmp := Source.Next_In_Lang;
777 Free_List (Source.Alternate_Languages);
779 if Source.Unit /= null
780 and then Source.Kind in Spec_Or_Body
782 Source.Unit.File_Names (Source.Kind) := null;
785 Unchecked_Free (Source);
795 (List : in out Project_List;
796 Free_Project : Boolean)
798 procedure Unchecked_Free is new
799 Ada.Unchecked_Deallocation (Project_List_Element, Project_List);
804 while List /= null loop
811 Unchecked_Free (List);
820 procedure Free_List (Languages : in out Language_Ptr) is
821 procedure Unchecked_Free is new
822 Ada.Unchecked_Deallocation (Language_Data, Language_Ptr);
827 while Languages /= null loop
828 Tmp := Languages.Next;
829 Free_List (Languages.First_Source);
830 Unchecked_Free (Languages);
839 procedure Free_Units (Table : in out Units_Htable.Instance) is
840 procedure Unchecked_Free is new
841 Ada.Unchecked_Deallocation (Unit_Data, Unit_Index);
846 Unit := Units_Htable.Get_First (Table);
847 while Unit /= No_Unit_Index loop
848 if Unit.File_Names (Spec) /= null then
849 Unit.File_Names (Spec).Unit := No_Unit_Index;
852 if Unit.File_Names (Impl) /= null then
853 Unit.File_Names (Impl).Unit := No_Unit_Index;
856 Unchecked_Free (Unit);
857 Unit := Units_Htable.Get_Next (Table);
860 Units_Htable.Reset (Table);
867 procedure Free (Tree : in out Project_Tree_Ref) is
868 procedure Unchecked_Free is new
869 Ada.Unchecked_Deallocation (Project_Tree_Data, Project_Tree_Ref);
873 Name_List_Table.Free (Tree.Name_Lists);
874 Number_List_Table.Free (Tree.Number_Lists);
875 String_Element_Table.Free (Tree.String_Elements);
876 Variable_Element_Table.Free (Tree.Variable_Elements);
877 Array_Element_Table.Free (Tree.Array_Elements);
878 Array_Table.Free (Tree.Arrays);
879 Package_Table.Free (Tree.Packages);
880 Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
882 Free_List (Tree.Projects, Free_Project => True);
883 Free_Units (Tree.Units_HT);
887 Temp_Files_Table.Free (Tree.Private_Part.Temp_Files);
889 Unchecked_Free (Tree);
897 procedure Reset (Tree : Project_Tree_Ref) is
901 Name_List_Table.Init (Tree.Name_Lists);
902 Number_List_Table.Init (Tree.Number_Lists);
903 String_Element_Table.Init (Tree.String_Elements);
904 Variable_Element_Table.Init (Tree.Variable_Elements);
905 Array_Element_Table.Init (Tree.Array_Elements);
906 Array_Table.Init (Tree.Arrays);
907 Package_Table.Init (Tree.Packages);
908 Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
910 Free_List (Tree.Projects, Free_Project => True);
911 Free_Units (Tree.Units_HT);
913 -- Private part table
915 Temp_Files_Table.Init (Tree.Private_Part.Temp_Files);
917 Tree.Private_Part.Current_Source_Path_File := No_Path;
918 Tree.Private_Part.Current_Object_Path_File := No_Path;
925 function Switches_Name
926 (Source_File_Name : File_Name_Type) return File_Name_Type
929 return Extend_Name (Source_File_Name, Switches_Dependency_Suffix);
936 function Value (Image : String) return Casing_Type is
938 for Casing in The_Casing_Images'Range loop
939 if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
944 raise Constraint_Error;
947 ---------------------
948 -- Has_Ada_Sources --
949 ---------------------
951 function Has_Ada_Sources (Data : Project_Id) return Boolean is
955 Lang := Data.Languages;
956 while Lang /= No_Language_Index loop
957 if Lang.Name = Name_Ada then
958 return Lang.First_Source /= No_Source;
966 ------------------------
967 -- Contains_ALI_Files --
968 ------------------------
970 function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is
971 Dir_Name : constant String := Get_Name_String (Dir);
973 Name : String (1 .. 1_000);
975 Result : Boolean := False;
978 Open (Direct, Dir_Name);
980 -- For each file in the directory, check if it is an ALI file
983 Read (Direct, Name, Last);
985 Canonical_Case_File_Name (Name (1 .. Last));
986 Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali";
994 -- If there is any problem, close the directory if open and return True.
995 -- The library directory will be added to the path.
998 if Is_Open (Direct) then
1003 end Contains_ALI_Files;
1005 --------------------------
1006 -- Get_Object_Directory --
1007 --------------------------
1009 function Get_Object_Directory
1010 (Project : Project_Id;
1011 Including_Libraries : Boolean;
1012 Only_If_Ada : Boolean := False) return Path_Name_Type
1015 if (Project.Library and then Including_Libraries)
1017 (Project.Object_Directory /= No_Path_Information
1018 and then (not Including_Libraries or else not Project.Library))
1020 -- For a library project, add the library ALI directory if there is
1021 -- no object directory or if the library ALI directory contains ALI
1022 -- files; otherwise add the object directory.
1024 if Project.Library then
1025 if Project.Object_Directory = No_Path_Information
1026 or else Contains_ALI_Files (Project.Library_ALI_Dir.Name)
1028 return Project.Library_ALI_Dir.Name;
1030 return Project.Object_Directory.Name;
1033 -- For a non-library project, add object directory if it is not a
1034 -- virtual project, and if there are Ada sources in the project or
1035 -- one of the projects it extends. If there are no Ada sources,
1036 -- adding the object directory could disrupt the order of the
1037 -- object dirs in the path.
1039 elsif not Project.Virtual then
1041 Add_Object_Dir : Boolean;
1045 Add_Object_Dir := not Only_If_Ada;
1047 while not Add_Object_Dir and then Prj /= No_Project loop
1048 if Has_Ada_Sources (Prj) then
1049 Add_Object_Dir := True;
1055 if Add_Object_Dir then
1056 return Project.Object_Directory.Name;
1063 end Get_Object_Directory;
1065 -----------------------------------
1066 -- Ultimate_Extending_Project_Of --
1067 -----------------------------------
1069 function Ultimate_Extending_Project_Of
1070 (Proj : Project_Id) return Project_Id
1076 while Prj /= null and then Prj.Extended_By /= No_Project loop
1077 Prj := Prj.Extended_By;
1081 end Ultimate_Extending_Project_Of;
1083 -----------------------------------
1084 -- Compute_All_Imported_Projects --
1085 -----------------------------------
1087 procedure Compute_All_Imported_Projects (Tree : Project_Tree_Ref) is
1088 Project : Project_Id;
1090 procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean);
1091 -- Recursively add the projects imported by project Project, but not
1092 -- those that are extended.
1098 procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean) is
1099 pragma Unreferenced (Dummy);
1100 List : Project_List;
1104 -- A project is not importing itself
1106 Prj2 := Ultimate_Extending_Project_Of (Prj);
1108 if Project /= Prj2 then
1110 -- Check that the project is not already in the list. We know the
1111 -- one passed to Recursive_Add have never been visited before, but
1112 -- the one passed it are the extended projects.
1114 List := Project.All_Imported_Projects;
1115 while List /= null loop
1116 if List.Project = Prj2 then
1123 -- Add it to the list
1125 Project.All_Imported_Projects :=
1126 new Project_List_Element'
1128 Next => Project.All_Imported_Projects);
1132 procedure For_All_Projects is
1133 new For_Every_Project_Imported (Boolean, Recursive_Add);
1135 Dummy : Boolean := False;
1136 List : Project_List;
1139 List := Tree.Projects;
1140 while List /= null loop
1141 Project := List.Project;
1142 Free_List (Project.All_Imported_Projects, Free_Project => False);
1143 For_All_Projects (Project, Dummy);
1146 end Compute_All_Imported_Projects;
1152 function Is_Compilable (Source : Source_Id) return Boolean is
1154 return Source.Language.Config.Compiler_Driver /= No_File
1155 and then Length_Of_Name (Source.Language.Config.Compiler_Driver) /= 0
1156 and then not Source.Locally_Removed;
1159 ------------------------------
1160 -- Object_To_Global_Archive --
1161 ------------------------------
1163 function Object_To_Global_Archive (Source : Source_Id) return Boolean is
1165 return Source.Language.Config.Kind = File_Based
1166 and then Source.Kind = Impl
1167 and then Source.Language.Config.Objects_Linked
1168 and then Is_Compilable (Source)
1169 and then Source.Language.Config.Object_Generated;
1170 end Object_To_Global_Archive;
1172 ----------------------------
1173 -- Get_Language_From_Name --
1174 ----------------------------
1176 function Get_Language_From_Name
1177 (Project : Project_Id;
1178 Name : String) return Language_Ptr
1181 Result : Language_Ptr;
1184 Name_Len := Name'Length;
1185 Name_Buffer (1 .. Name_Len) := Name;
1186 To_Lower (Name_Buffer (1 .. Name_Len));
1189 Result := Project.Languages;
1190 while Result /= No_Language_Index loop
1191 if Result.Name = N then
1195 Result := Result.Next;
1198 return No_Language_Index;
1199 end Get_Language_From_Name;
1205 function Other_Part (Source : Source_Id) return Source_Id is
1207 if Source.Unit /= No_Unit_Index then
1210 return Source.Unit.File_Names (Spec);
1212 return Source.Unit.File_Names (Impl);
1225 function Create_Flags
1226 (Report_Error : Error_Handler;
1227 When_No_Sources : Error_Warning;
1228 Require_Sources_Other_Lang : Boolean := True;
1229 Allow_Duplicate_Basenames : Boolean := True;
1230 Compiler_Driver_Mandatory : Boolean := False;
1231 Error_On_Unknown_Language : Boolean := True;
1232 Require_Obj_Dirs : Error_Warning := Error;
1233 Allow_Invalid_External : Error_Warning := Error;
1234 Missing_Source_Files : Error_Warning := Error)
1235 return Processing_Flags
1238 return Processing_Flags'
1239 (Report_Error => Report_Error,
1240 When_No_Sources => When_No_Sources,
1241 Require_Sources_Other_Lang => Require_Sources_Other_Lang,
1242 Allow_Duplicate_Basenames => Allow_Duplicate_Basenames,
1243 Error_On_Unknown_Language => Error_On_Unknown_Language,
1244 Compiler_Driver_Mandatory => Compiler_Driver_Mandatory,
1245 Require_Obj_Dirs => Require_Obj_Dirs,
1246 Allow_Invalid_External => Allow_Invalid_External,
1247 Missing_Source_Files => Missing_Source_Files);
1255 (Table : Name_List_Table.Instance;
1256 List : Name_List_Index) return Natural
1258 Count : Natural := 0;
1259 Tmp : Name_List_Index;
1263 while Tmp /= No_Name_List loop
1265 Tmp := Table.Table (Tmp).Next;
1272 -- Make sure that the standard config and user project file extensions are
1273 -- compatible with canonical case file naming.
1275 Canonical_Case_File_Name (Config_Project_File_Extension);
1276 Canonical_Case_File_Name (Project_File_Extension);