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;
625 (Name_Project, Token_Type'Pos (Tok_Project));
627 (Name_Extends, Token_Type'Pos (Tok_Extends));
629 (Name_External, Token_Type'Pos (Tok_External));
631 (Name_External_As_List, Token_Type'Pos (Tok_External_As_List));
634 if Tree /= No_Project_Tree then
643 function Is_Extending
644 (Extending : Project_Id;
645 Extended : Project_Id) return Boolean
651 while Proj /= No_Project loop
652 if Proj = Extended then
656 Proj := Proj.Extends;
667 (Source_File_Name : File_Name_Type;
668 Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
671 if Object_File_Suffix = No_Name then
673 (Source_File_Name, Object_Suffix);
676 (Source_File_Name, Get_Name_String (Object_File_Suffix));
681 (Source_File_Name : File_Name_Type;
683 Index_Separator : Character;
684 Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
686 Index_Img : constant String := Source_Index'Img;
690 Get_Name_String (Source_File_Name);
693 while Last > 1 and then Name_Buffer (Last) /= '.' loop
698 Name_Len := Last - 1;
701 Add_Char_To_Name_Buffer (Index_Separator);
702 Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last));
704 if Object_File_Suffix = No_Name then
705 Add_Str_To_Name_Buffer (Object_Suffix);
707 Add_Str_To_Name_Buffer (Get_Name_String (Object_File_Suffix));
713 ----------------------
714 -- Record_Temp_File --
715 ----------------------
717 procedure Record_Temp_File
718 (Tree : Project_Tree_Ref;
719 Path : Path_Name_Type)
722 Temp_Files_Table.Append (Tree.Private_Part.Temp_Files, Path);
723 end Record_Temp_File;
729 procedure Free (Project : in out Project_Id) is
730 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
731 (Project_Data, Project_Id);
734 if Project /= null then
735 Free (Project.Ada_Include_Path);
736 Free (Project.Objects_Path);
737 Free (Project.Ada_Objects_Path);
738 Free_List (Project.Imported_Projects, Free_Project => False);
739 Free_List (Project.All_Imported_Projects, Free_Project => False);
740 Free_List (Project.Languages);
742 Unchecked_Free (Project);
750 procedure Free_List (Languages : in out Language_List) is
751 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
752 (Language_List_Element, Language_List);
755 while Languages /= null loop
756 Tmp := Languages.Next;
757 Unchecked_Free (Languages);
766 procedure Free_List (Source : in out Source_Id) is
767 procedure Unchecked_Free is new
768 Ada.Unchecked_Deallocation (Source_Data, Source_Id);
773 while Source /= No_Source loop
774 Tmp := Source.Next_In_Lang;
775 Free_List (Source.Alternate_Languages);
777 if Source.Unit /= null
778 and then Source.Kind in Spec_Or_Body
780 Source.Unit.File_Names (Source.Kind) := null;
783 Unchecked_Free (Source);
793 (List : in out Project_List;
794 Free_Project : Boolean)
796 procedure Unchecked_Free is new
797 Ada.Unchecked_Deallocation (Project_List_Element, Project_List);
802 while List /= null loop
809 Unchecked_Free (List);
818 procedure Free_List (Languages : in out Language_Ptr) is
819 procedure Unchecked_Free is new
820 Ada.Unchecked_Deallocation (Language_Data, Language_Ptr);
825 while Languages /= null loop
826 Tmp := Languages.Next;
827 Free_List (Languages.First_Source);
828 Unchecked_Free (Languages);
837 procedure Free_Units (Table : in out Units_Htable.Instance) is
838 procedure Unchecked_Free is new
839 Ada.Unchecked_Deallocation (Unit_Data, Unit_Index);
844 Unit := Units_Htable.Get_First (Table);
845 while Unit /= No_Unit_Index loop
846 if Unit.File_Names (Spec) /= null then
847 Unit.File_Names (Spec).Unit := No_Unit_Index;
850 if Unit.File_Names (Impl) /= null then
851 Unit.File_Names (Impl).Unit := No_Unit_Index;
854 Unchecked_Free (Unit);
855 Unit := Units_Htable.Get_Next (Table);
858 Units_Htable.Reset (Table);
865 procedure Free (Tree : in out Project_Tree_Ref) is
866 procedure Unchecked_Free is new
867 Ada.Unchecked_Deallocation (Project_Tree_Data, Project_Tree_Ref);
871 Name_List_Table.Free (Tree.Name_Lists);
872 Number_List_Table.Free (Tree.Number_Lists);
873 String_Element_Table.Free (Tree.String_Elements);
874 Variable_Element_Table.Free (Tree.Variable_Elements);
875 Array_Element_Table.Free (Tree.Array_Elements);
876 Array_Table.Free (Tree.Arrays);
877 Package_Table.Free (Tree.Packages);
878 Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
879 Source_Files_Htable.Reset (Tree.Source_Files_HT);
881 Free_List (Tree.Projects, Free_Project => True);
882 Free_Units (Tree.Units_HT);
886 Temp_Files_Table.Free (Tree.Private_Part.Temp_Files);
888 Unchecked_Free (Tree);
896 procedure Reset (Tree : Project_Tree_Ref) is
900 Name_List_Table.Init (Tree.Name_Lists);
901 Number_List_Table.Init (Tree.Number_Lists);
902 String_Element_Table.Init (Tree.String_Elements);
903 Variable_Element_Table.Init (Tree.Variable_Elements);
904 Array_Element_Table.Init (Tree.Array_Elements);
905 Array_Table.Init (Tree.Arrays);
906 Package_Table.Init (Tree.Packages);
907 Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
908 Source_Files_Htable.Reset (Tree.Source_Files_HT);
909 Replaced_Source_HTable.Reset (Tree.Replaced_Sources);
911 Tree.Replaced_Source_Number := 0;
913 Free_List (Tree.Projects, Free_Project => True);
914 Free_Units (Tree.Units_HT);
916 -- Private part table
918 Temp_Files_Table.Init (Tree.Private_Part.Temp_Files);
920 Tree.Private_Part.Current_Source_Path_File := No_Path;
921 Tree.Private_Part.Current_Object_Path_File := No_Path;
928 function Switches_Name
929 (Source_File_Name : File_Name_Type) return File_Name_Type
932 return Extend_Name (Source_File_Name, Switches_Dependency_Suffix);
939 function Value (Image : String) return Casing_Type is
941 for Casing in The_Casing_Images'Range loop
942 if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
947 raise Constraint_Error;
950 ---------------------
951 -- Has_Ada_Sources --
952 ---------------------
954 function Has_Ada_Sources (Data : Project_Id) return Boolean is
958 Lang := Data.Languages;
959 while Lang /= No_Language_Index loop
960 if Lang.Name = Name_Ada then
961 return Lang.First_Source /= No_Source;
969 ------------------------
970 -- Contains_ALI_Files --
971 ------------------------
973 function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is
974 Dir_Name : constant String := Get_Name_String (Dir);
976 Name : String (1 .. 1_000);
978 Result : Boolean := False;
981 Open (Direct, Dir_Name);
983 -- For each file in the directory, check if it is an ALI file
986 Read (Direct, Name, Last);
988 Canonical_Case_File_Name (Name (1 .. Last));
989 Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali";
997 -- If there is any problem, close the directory if open and return True.
998 -- The library directory will be added to the path.
1001 if Is_Open (Direct) then
1006 end Contains_ALI_Files;
1008 --------------------------
1009 -- Get_Object_Directory --
1010 --------------------------
1012 function Get_Object_Directory
1013 (Project : Project_Id;
1014 Including_Libraries : Boolean;
1015 Only_If_Ada : Boolean := False) return Path_Name_Type
1018 if (Project.Library and then Including_Libraries)
1020 (Project.Object_Directory /= No_Path_Information
1021 and then (not Including_Libraries or else not Project.Library))
1023 -- For a library project, add the library ALI directory if there is
1024 -- no object directory or if the library ALI directory contains ALI
1025 -- files; otherwise add the object directory.
1027 if Project.Library then
1028 if Project.Object_Directory = No_Path_Information
1029 or else Contains_ALI_Files (Project.Library_ALI_Dir.Display_Name)
1031 return Project.Library_ALI_Dir.Display_Name;
1033 return Project.Object_Directory.Display_Name;
1036 -- For a non-library project, add object directory if it is not a
1037 -- virtual project, and if there are Ada sources in the project or
1038 -- one of the projects it extends. If there are no Ada sources,
1039 -- adding the object directory could disrupt the order of the
1040 -- object dirs in the path.
1042 elsif not Project.Virtual then
1044 Add_Object_Dir : Boolean;
1048 Add_Object_Dir := not Only_If_Ada;
1050 while not Add_Object_Dir and then Prj /= No_Project loop
1051 if Has_Ada_Sources (Prj) then
1052 Add_Object_Dir := True;
1058 if Add_Object_Dir then
1059 return Project.Object_Directory.Display_Name;
1066 end Get_Object_Directory;
1068 -----------------------------------
1069 -- Ultimate_Extending_Project_Of --
1070 -----------------------------------
1072 function Ultimate_Extending_Project_Of
1073 (Proj : Project_Id) return Project_Id
1079 while Prj /= null and then Prj.Extended_By /= No_Project loop
1080 Prj := Prj.Extended_By;
1084 end Ultimate_Extending_Project_Of;
1086 -----------------------------------
1087 -- Compute_All_Imported_Projects --
1088 -----------------------------------
1090 procedure Compute_All_Imported_Projects (Tree : Project_Tree_Ref) is
1091 Project : Project_Id;
1093 procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean);
1094 -- Recursively add the projects imported by project Project, but not
1095 -- those that are extended.
1101 procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean) is
1102 pragma Unreferenced (Dummy);
1103 List : Project_List;
1107 -- A project is not importing itself
1109 Prj2 := Ultimate_Extending_Project_Of (Prj);
1111 if Project /= Prj2 then
1113 -- Check that the project is not already in the list. We know the
1114 -- one passed to Recursive_Add have never been visited before, but
1115 -- the one passed it are the extended projects.
1117 List := Project.All_Imported_Projects;
1118 while List /= null loop
1119 if List.Project = Prj2 then
1126 -- Add it to the list
1128 Project.All_Imported_Projects :=
1129 new Project_List_Element'
1131 Next
=> Project
.All_Imported_Projects
);
1135 procedure For_All_Projects
is
1136 new For_Every_Project_Imported
(Boolean, Recursive_Add
);
1138 Dummy
: Boolean := False;
1139 List
: Project_List
;
1142 List
:= Tree
.Projects
;
1143 while List
/= null loop
1144 Project
:= List
.Project
;
1145 Free_List
(Project
.All_Imported_Projects
, Free_Project
=> False);
1146 For_All_Projects
(Project
, Dummy
);
1149 end Compute_All_Imported_Projects
;
1155 function Is_Compilable
(Source
: Source_Id
) return Boolean is
1157 case Source
.Compilable
is
1159 if Source
.Language
.Config
.Compiler_Driver
/= No_File
1161 Length_Of_Name
(Source
.Language
.Config
.Compiler_Driver
) /= 0
1162 and then not Source
.Locally_Removed
1163 and then (Source
.Language
.Config
.Kind
/= File_Based
1164 or else Source
.Kind
/= Spec
)
1166 -- Do not modify Source.Compilable before the source record
1167 -- has been initialized.
1169 if Source
.Source_TS
/= Empty_Time_Stamp
then
1170 Source
.Compilable
:= Yes
;
1176 if Source
.Source_TS
/= Empty_Time_Stamp
then
1177 Source
.Compilable
:= No
;
1191 ------------------------------
1192 -- Object_To_Global_Archive --
1193 ------------------------------
1195 function Object_To_Global_Archive
(Source
: Source_Id
) return Boolean is
1197 return Source
.Language
.Config
.Kind
= File_Based
1198 and then Source
.Kind
= Impl
1199 and then Source
.Language
.Config
.Objects_Linked
1200 and then Is_Compilable
(Source
)
1201 and then Source
.Language
.Config
.Object_Generated
;
1202 end Object_To_Global_Archive
;
1204 ----------------------------
1205 -- Get_Language_From_Name --
1206 ----------------------------
1208 function Get_Language_From_Name
1209 (Project
: Project_Id
;
1210 Name
: String) return Language_Ptr
1213 Result
: Language_Ptr
;
1216 Name_Len
:= Name
'Length;
1217 Name_Buffer
(1 .. Name_Len
) := Name
;
1218 To_Lower
(Name_Buffer
(1 .. Name_Len
));
1221 Result
:= Project
.Languages
;
1222 while Result
/= No_Language_Index
loop
1223 if Result
.Name
= N
then
1227 Result
:= Result
.Next
;
1230 return No_Language_Index
;
1231 end Get_Language_From_Name
;
1237 function Other_Part
(Source
: Source_Id
) return Source_Id
is
1239 if Source
.Unit
/= No_Unit_Index
then
1242 return Source
.Unit
.File_Names
(Spec
);
1244 return Source
.Unit
.File_Names
(Impl
);
1257 function Create_Flags
1258 (Report_Error
: Error_Handler
;
1259 When_No_Sources
: Error_Warning
;
1260 Require_Sources_Other_Lang
: Boolean := True;
1261 Allow_Duplicate_Basenames
: Boolean := True;
1262 Compiler_Driver_Mandatory
: Boolean := False;
1263 Error_On_Unknown_Language
: Boolean := True;
1264 Require_Obj_Dirs
: Error_Warning
:= Error
;
1265 Allow_Invalid_External
: Error_Warning
:= Error
;
1266 Missing_Source_Files
: Error_Warning
:= Error
)
1267 return Processing_Flags
1270 return Processing_Flags
'
1271 (Report_Error => Report_Error,
1272 When_No_Sources => When_No_Sources,
1273 Require_Sources_Other_Lang => Require_Sources_Other_Lang,
1274 Allow_Duplicate_Basenames => Allow_Duplicate_Basenames,
1275 Error_On_Unknown_Language => Error_On_Unknown_Language,
1276 Compiler_Driver_Mandatory => Compiler_Driver_Mandatory,
1277 Require_Obj_Dirs => Require_Obj_Dirs,
1278 Allow_Invalid_External => Allow_Invalid_External,
1279 Missing_Source_Files => Missing_Source_Files);
1287 (Table : Name_List_Table.Instance;
1288 List : Name_List_Index) return Natural
1290 Count : Natural := 0;
1291 Tmp : Name_List_Index;
1295 while Tmp /= No_Name_List loop
1297 Tmp := Table.Table (Tmp).Next;
1304 -- Make sure that the standard config and user project file extensions are
1305 -- compatible with canonical case file naming.
1307 Canonical_Case_File_Name (Config_Project_File_Extension);
1308 Canonical_Case_File_Name (Project_File_Extension);