1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2009, 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;
30 with Prj.Com; use Prj.Com;
33 package body Prj.Env is
35 Buffer_Initial : constant := 1_000;
36 -- Initial size of Buffer
38 -----------------------
39 -- Local Subprograms --
40 -----------------------
42 package Source_Path_Table is new GNAT.Dynamic_Tables
43 (Table_Component_Type => Name_Id,
44 Table_Index_Type => Natural,
47 Table_Increment => 100);
48 -- A table to store the source dirs before creating the source path file
50 package Object_Path_Table is new GNAT.Dynamic_Tables
51 (Table_Component_Type => Path_Name_Type,
52 Table_Index_Type => Natural,
55 Table_Increment => 100);
56 -- A table to store the object dirs, before creating the object path file
58 procedure Add_To_Buffer
60 Buffer : in out String_Access;
61 Buffer_Last : in out Natural);
62 -- Add a string to Buffer, extending Buffer if needed
65 (Source_Dirs : String_List_Id;
66 In_Tree : Project_Tree_Ref;
67 Buffer : in out String_Access;
68 Buffer_Last : in out Natural);
69 -- Add to Ada_Path_Buffer all the source directories in string list
70 -- Source_Dirs, if any.
74 Buffer : in out String_Access;
75 Buffer_Last : in out Natural);
76 -- If Dir is not already in the global variable Ada_Path_Buffer, add it.
77 -- If Buffer_Last /= 0, prepend a Path_Separator character to Path.
79 procedure Add_To_Source_Path
80 (Source_Dirs : String_List_Id;
81 In_Tree : Project_Tree_Ref;
82 Source_Paths : in out Source_Path_Table.Instance);
83 -- Add to Ada_Path_B all the source directories in string list
84 -- Source_Dirs, if any. Increment Ada_Path_Length.
86 procedure Add_To_Object_Path
87 (Object_Dir : Path_Name_Type;
88 Object_Paths : in out Object_Path_Table.Instance);
89 -- Add Object_Dir to object path table. Make sure it is not duplicate
90 -- and it is the last one in the current table.
92 procedure Set_Path_File_Var (Name : String; Value : String);
93 -- Call Setenv, after calling To_Host_File_Spec
95 function Ultimate_Extension_Of
96 (Project : Project_Id) return Project_Id;
97 -- Return a project that is either Project or an extended ancestor of
98 -- Project that itself is not extended.
100 ----------------------
101 -- Ada_Include_Path --
102 ----------------------
104 function Ada_Include_Path
105 (Project : Project_Id;
106 In_Tree : Project_Tree_Ref;
107 Recursive : Boolean := False) return String
109 Buffer : String_Access;
110 Buffer_Last : Natural := 0;
112 procedure Add (Project : Project_Id; Dummy : in out Boolean);
113 -- Add source dirs of Project to the path
119 procedure Add (Project : Project_Id; Dummy : in out Boolean) is
120 pragma Unreferenced (Dummy);
122 Add_To_Path (Project.Source_Dirs, In_Tree, Buffer, Buffer_Last);
125 procedure For_All_Projects is
126 new For_Every_Project_Imported (Boolean, Add);
128 Dummy : Boolean := False;
130 -- Start of processing for Ada_Include_Path
135 -- If it is the first time we call this function for
136 -- this project, compute the source path
138 if Project.Ada_Include_Path = null then
139 Buffer := new String (1 .. 4096);
140 For_All_Projects (Project, Dummy);
141 Project.Ada_Include_Path := new String'(Buffer (1 .. Buffer_Last));
145 return Project.Ada_Include_Path.all;
148 Buffer := new String (1 .. 4096);
149 Add_To_Path (Project.Source_Dirs, In_Tree, Buffer, Buffer_Last);
152 Result : constant String := Buffer (1 .. Buffer_Last);
158 end Ada_Include_Path;
160 ----------------------
161 -- Ada_Objects_Path --
162 ----------------------
164 function Ada_Objects_Path
165 (Project : Project_Id;
166 Including_Libraries : Boolean := True) return String_Access
168 Buffer : String_Access;
169 Buffer_Last : Natural := 0;
171 procedure Add (Project : Project_Id; Dummy : in out Boolean);
172 -- Add all the object directories of a project to the path
178 procedure Add (Project : Project_Id; Dummy : in out Boolean) is
179 pragma Unreferenced (Dummy);
180 Path : constant Path_Name_Type :=
183 Including_Libraries => Including_Libraries,
184 Only_If_Ada => False);
186 if Path /= No_Path then
187 Add_To_Path (Get_Name_String (Path), Buffer, Buffer_Last);
191 procedure For_All_Projects is
192 new For_Every_Project_Imported (Boolean, Add);
194 Dummy : Boolean := False;
196 -- Start of processing for Ada_Objects_Path
199 -- If it is the first time we call this function for
200 -- this project, compute the objects path
202 if Project.Ada_Objects_Path = null then
203 Buffer := new String (1 .. 4096);
204 For_All_Projects (Project, Dummy);
206 Project.Ada_Objects_Path := new String'(Buffer (1 .. Buffer_Last));
210 return Project.Ada_Objects_Path;
211 end Ada_Objects_Path;
217 procedure Add_To_Buffer
219 Buffer : in out String_Access;
220 Buffer_Last : in out Natural)
222 Last : constant Natural := Buffer_Last + S'Length;
225 while Last > Buffer'Last loop
227 New_Buffer : constant String_Access :=
228 new String (1 .. 2 * Buffer'Last);
230 New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
232 Buffer := New_Buffer;
236 Buffer (Buffer_Last + 1 .. Last) := S;
240 ------------------------
241 -- Add_To_Object_Path --
242 ------------------------
244 procedure Add_To_Object_Path
245 (Object_Dir : Path_Name_Type;
246 Object_Paths : in out Object_Path_Table.Instance)
249 -- Check if the directory is already in the table
251 for Index in Object_Path_Table.First ..
252 Object_Path_Table.Last (Object_Paths)
255 -- If it is, remove it, and add it as the last one
257 if Object_Paths.Table (Index) = Object_Dir then
258 for Index2 in Index + 1 ..
259 Object_Path_Table.Last (Object_Paths)
261 Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2);
265 (Object_Path_Table.Last (Object_Paths)) := Object_Dir;
270 -- The directory is not already in the table, add it
272 Object_Path_Table.Append (Object_Paths, Object_Dir);
273 end Add_To_Object_Path;
279 procedure Add_To_Path
280 (Source_Dirs : String_List_Id;
281 In_Tree : Project_Tree_Ref;
282 Buffer : in out String_Access;
283 Buffer_Last : in out Natural)
285 Current : String_List_Id := Source_Dirs;
286 Source_Dir : String_Element;
288 while Current /= Nil_String loop
289 Source_Dir := In_Tree.String_Elements.Table (Current);
290 Add_To_Path (Get_Name_String (Source_Dir.Display_Value),
291 Buffer, Buffer_Last);
292 Current := Source_Dir.Next;
296 procedure Add_To_Path
298 Buffer : in out String_Access;
299 Buffer_Last : in out Natural)
302 New_Buffer : String_Access;
305 function Is_Present (Path : String; Dir : String) return Boolean;
306 -- Return True if Dir is part of Path
312 function Is_Present (Path : String; Dir : String) return Boolean is
313 Last : constant Integer := Path'Last - Dir'Length + 1;
316 for J in Path'First .. Last loop
318 -- Note: the order of the conditions below is important, since
319 -- it ensures a minimal number of string comparisons.
322 or else Path (J - 1) = Path_Separator)
324 (J + Dir'Length > Path'Last
325 or else Path (J + Dir'Length) = Path_Separator)
326 and then Dir = Path (J .. J + Dir'Length - 1)
335 -- Start of processing for Add_To_Path
338 if Is_Present (Buffer (1 .. Buffer_Last), Dir) then
340 -- Dir is already in the path, nothing to do
345 Min_Len := Buffer_Last + Dir'Length;
347 if Buffer_Last > 0 then
349 -- Add 1 for the Path_Separator character
351 Min_Len := Min_Len + 1;
354 -- If Ada_Path_Buffer is too small, increase it
358 if Len < Min_Len then
361 exit when Len >= Min_Len;
364 New_Buffer := new String (1 .. Len);
365 New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
367 Buffer := New_Buffer;
370 if Buffer_Last > 0 then
371 Buffer_Last := Buffer_Last + 1;
372 Buffer (Buffer_Last) := Path_Separator;
375 Buffer (Buffer_Last + 1 .. Buffer_Last + Dir'Length) := Dir;
376 Buffer_Last := Buffer_Last + Dir'Length;
379 ------------------------
380 -- Add_To_Source_Path --
381 ------------------------
383 procedure Add_To_Source_Path
384 (Source_Dirs : String_List_Id;
385 In_Tree : Project_Tree_Ref;
386 Source_Paths : in out Source_Path_Table.Instance)
388 Current : String_List_Id := Source_Dirs;
389 Source_Dir : String_Element;
393 -- Add each source directory
395 while Current /= Nil_String loop
396 Source_Dir := In_Tree.String_Elements.Table (Current);
399 -- Check if the source directory is already in the table
401 for Index in Source_Path_Table.First ..
402 Source_Path_Table.Last (Source_Paths)
404 -- If it is already, no need to add it
406 if Source_Paths.Table (Index) = Source_Dir.Value then
413 Source_Path_Table.Append (Source_Paths, Source_Dir.Display_Value);
416 -- Next source directory
418 Current := Source_Dir.Next;
420 end Add_To_Source_Path;
422 --------------------------------
423 -- Create_Config_Pragmas_File --
424 --------------------------------
426 procedure Create_Config_Pragmas_File
427 (For_Project : Project_Id;
428 In_Tree : Project_Tree_Ref)
430 type Naming_Id is new Nat;
431 package Naming_Table is new GNAT.Dynamic_Tables
432 (Table_Component_Type => Lang_Naming_Data,
433 Table_Index_Type => Naming_Id,
434 Table_Low_Bound => 1,
436 Table_Increment => 100);
437 Default_Naming : constant Naming_Id := Naming_Table.First;
438 Namings : Naming_Table.Instance;
439 -- Table storing the naming data for gnatmake/gprmake
441 Buffer : String_Access := new String (1 .. Buffer_Initial);
442 Buffer_Last : Natural := 0;
444 File_Name : Path_Name_Type := No_Path;
445 File : File_Descriptor := Invalid_FD;
447 Current_Naming : Naming_Id;
448 Iter : Source_Iterator;
451 procedure Check (Project : Project_Id; State : in out Integer);
452 -- Recursive procedure that put in the config pragmas file any non
453 -- standard naming schemes, if it is not already in the file, then call
454 -- itself for any imported project.
456 procedure Put (Source : Source_Id);
457 -- Put an SFN pragma in the temporary file
459 procedure Put (S : String);
460 procedure Put_Line (S : String);
461 -- Output procedures, analogous to normal Text_IO procs of same name.
462 -- The text is put in Buffer, then it will be writen into a temporary
463 -- file with procedure Write_Temp_File below.
465 procedure Write_Temp_File;
466 -- Create a temporary file and put the content of the buffer in it
472 procedure Check (Project : Project_Id; State : in out Integer) is
473 pragma Unreferenced (State);
474 Lang : constant Language_Ptr :=
475 Get_Language_From_Name (Project, "ada");
476 Naming : Lang_Naming_Data;
479 if Current_Verbosity = High then
480 Write_Str ("Checking project file """);
481 Write_Str (Namet.Get_Name_String (Project.Name));
487 if Current_Verbosity = High then
488 Write_Line (" Languages does not contain Ada, nothing to do");
494 Naming := Lang.Config.Naming_Data;
496 -- Is the naming scheme of this project one that we know?
498 Current_Naming := Default_Naming;
499 while Current_Naming <= Naming_Table.Last (Namings)
500 and then Namings.Table (Current_Naming).Dot_Replacement =
501 Naming.Dot_Replacement
502 and then Namings.Table (Current_Naming).Casing =
504 and then Namings.Table (Current_Naming).Separate_Suffix =
505 Naming.Separate_Suffix
507 Current_Naming := Current_Naming + 1;
510 -- If we don't know it, add it
512 if Current_Naming > Naming_Table.Last (Namings) then
513 Naming_Table.Increment_Last (Namings);
514 Namings.Table (Naming_Table.Last (Namings)) := Naming;
516 -- Put the SFN pragmas for the naming scheme
521 ("pragma Source_File_Name_Project");
523 (" (Spec_File_Name => ""*" &
524 Get_Name_String (Naming.Spec_Suffix) & """,");
527 Image (Naming.Casing) & ",");
529 (" Dot_Replacement => """ &
530 Get_Name_String (Naming.Dot_Replacement) & """);");
535 ("pragma Source_File_Name_Project");
537 (" (Body_File_Name => ""*" &
538 Get_Name_String (Naming.Body_Suffix) & """,");
541 Image (Naming.Casing) & ",");
543 (" Dot_Replacement => """ &
544 Get_Name_String (Naming.Dot_Replacement) &
547 -- and maybe separate
549 if Naming.Body_Suffix /= Naming.Separate_Suffix then
550 Put_Line ("pragma Source_File_Name_Project");
552 (" (Subunit_File_Name => ""*" &
553 Get_Name_String (Naming.Separate_Suffix) & """,");
556 Image (Naming.Casing) & ",");
558 (" Dot_Replacement => """ &
559 Get_Name_String (Naming.Dot_Replacement) &
569 procedure Put (Source : Source_Id) is
571 -- Put the pragma SFN for the unit kind (spec or body)
573 Put ("pragma Source_File_Name_Project (");
574 Put (Namet.Get_Name_String (Source.Unit.Name));
576 if Source.Kind = Spec then
577 Put (", Spec_File_Name => """);
579 Put (", Body_File_Name => """);
582 Put (Namet.Get_Name_String (Source.File));
585 if Source.Index /= 0 then
587 Put (Source.Index'Img);
593 procedure Put (S : String) is
595 Add_To_Buffer (S, Buffer, Buffer_Last);
597 if Current_Verbosity = High then
606 procedure Put_Line (S : String) is
608 -- Add an ASCII.LF to the string. As this config file is supposed to
609 -- be used only by the compiler, we don't care about the characters
610 -- for the end of line. In fact we could have put a space, but
611 -- it is more convenient to be able to read gnat.adc during
612 -- development, for which the ASCII.LF is fine.
615 Put (S => (1 => ASCII.LF));
618 ---------------------
619 -- Write_Temp_File --
620 ---------------------
622 procedure Write_Temp_File is
623 Status : Boolean := False;
627 Tempdir.Create_Temp_File (File, File_Name);
629 if File /= Invalid_FD then
630 Last := Write (File, Buffer (1)'Address, Buffer_Last);
632 if Last = Buffer_Last then
633 Close (File, Status);
638 Prj.Com.Fail ("unable to create temporary file");
642 procedure Check_Imported_Projects is
643 new For_Every_Project_Imported (Integer, Check);
645 Dummy : Integer := 0;
647 -- Start of processing for Create_Config_Pragmas_File
650 if not For_Project.Config_Checked then
651 Naming_Table.Init (Namings);
653 -- Check the naming schemes
655 Check_Imported_Projects (For_Project, Dummy, Imported_First => False);
657 -- Visit all the files and process those that need an SFN pragma
659 Iter := For_Each_Source (In_Tree, For_Project);
660 while Element (Iter) /= No_Source loop
661 Source := Element (Iter);
664 and then not Source.Locally_Removed
665 and then Source.Unit /= null
673 -- If there are no non standard naming scheme, issue the GNAT
674 -- standard naming scheme. This will tell the compiler that
675 -- a project file is used and will forbid any pragma SFN.
677 if Buffer_Last = 0 then
679 Put_Line ("pragma Source_File_Name_Project");
680 Put_Line (" (Spec_File_Name => ""*.ads"",");
681 Put_Line (" Dot_Replacement => ""-"",");
682 Put_Line (" Casing => lowercase);");
684 Put_Line ("pragma Source_File_Name_Project");
685 Put_Line (" (Body_File_Name => ""*.adb"",");
686 Put_Line (" Dot_Replacement => ""-"",");
687 Put_Line (" Casing => lowercase);");
690 -- Close the temporary file
694 if Opt.Verbose_Mode then
695 Write_Str ("Created configuration file """);
696 Write_Str (Get_Name_String (File_Name));
700 For_Project.Config_File_Name := File_Name;
701 For_Project.Config_File_Temp := True;
702 For_Project.Config_Checked := True;
706 end Create_Config_Pragmas_File;
712 procedure Create_Mapping (In_Tree : Project_Tree_Ref) is
714 Iter : Source_Iterator;
719 Iter := For_Each_Source (In_Tree);
721 Data := Element (Iter);
722 exit when Data = No_Source;
724 if Data.Unit /= No_Unit_Index then
725 if Data.Locally_Removed then
726 Fmap.Add_Forbidden_File_Name (Data.File);
729 (Unit_Name => Unit_Name_Type (Data.Unit.Name),
730 File_Name => Data.File,
731 Path_Name => File_Name_Type (Data.Path.Name));
739 -------------------------
740 -- Create_Mapping_File --
741 -------------------------
743 procedure Create_Mapping_File
744 (Project : Project_Id;
746 In_Tree : Project_Tree_Ref;
747 Name : out Path_Name_Type)
749 File : File_Descriptor := Invalid_FD;
751 Buffer : String_Access := new String (1 .. Buffer_Initial);
752 Buffer_Last : Natural := 0;
754 procedure Put_Name_Buffer;
755 -- Put the line contained in the Name_Buffer in the global buffer
757 procedure Process (Project : Project_Id; State : in out Integer);
758 -- Generate the mapping file for Project (not recursively)
760 ---------------------
761 -- Put_Name_Buffer --
762 ---------------------
764 procedure Put_Name_Buffer is
766 Name_Len := Name_Len + 1;
767 Name_Buffer (Name_Len) := ASCII.LF;
769 if Current_Verbosity = High then
770 Write_Str ("Mapping file: " & Name_Buffer (1 .. Name_Len));
773 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
780 procedure Process (Project : Project_Id; State : in out Integer) is
781 pragma Unreferenced (State);
783 Suffix : File_Name_Type;
784 Iter : Source_Iterator;
787 Iter := For_Each_Source (In_Tree, Project, Language => Language);
790 Source := Prj.Element (Iter);
791 exit when Source = No_Source;
793 if Source.Replaced_By = No_Source
794 and then Source.Path.Name /= No_Path
796 (Source.Language.Config.Kind = File_Based
797 or else Source.Unit /= No_Unit_Index)
799 if Source.Unit /= No_Unit_Index then
800 Get_Name_String (Source.Unit.Name);
802 if Source.Language.Config.Kind = Unit_Based then
804 -- ??? Mapping_Spec_Suffix could be set in the case of
807 Add_Char_To_Name_Buffer ('%');
809 if Source.Kind = Spec then
810 Add_Char_To_Name_Buffer ('s');
812 Add_Char_To_Name_Buffer ('b');
819 Source.Language.Config.Mapping_Spec_Suffix;
822 Source.Language.Config.Mapping_Body_Suffix;
825 if Suffix /= No_File then
826 Add_Str_To_Name_Buffer
827 (Get_Name_String (Suffix));
834 Get_Name_String (Source.File);
837 if Source.Locally_Removed then
839 Name_Buffer (1) := '/';
841 Get_Name_String (Source.Path.Name);
851 procedure For_Every_Imported_Project is new
852 For_Every_Project_Imported (State => Integer, Action => Process);
854 Dummy : Integer := 0;
856 -- Start of processing for Create_Mapping_File
859 For_Every_Imported_Project (Project, Dummy);
863 Status : Boolean := False;
866 Create_Temp_File (In_Tree, File, Name, "mapping");
868 if File /= Invalid_FD then
869 Last := Write (File, Buffer (1)'Address, Buffer_Last);
871 if Last = Buffer_Last then
872 GNAT.OS_Lib.Close (File, Status);
877 Prj.Com.Fail ("could not write mapping file");
882 end Create_Mapping_File;
884 ----------------------
885 -- Create_Temp_File --
886 ----------------------
888 procedure Create_Temp_File
889 (In_Tree : Project_Tree_Ref;
890 Path_FD : out File_Descriptor;
891 Path_Name : out Path_Name_Type;
895 Tempdir.Create_Temp_File (Path_FD, Path_Name);
897 if Path_Name /= No_Path then
898 if Current_Verbosity = High then
899 Write_Line ("Create temp file (" & File_Use & ") "
900 & Get_Name_String (Path_Name));
903 Record_Temp_File (In_Tree, Path_Name);
907 ("unable to create temporary " & File_Use & " file");
909 end Create_Temp_File;
911 --------------------------
912 -- Create_New_Path_File --
913 --------------------------
915 procedure Create_New_Path_File
916 (In_Tree : Project_Tree_Ref;
917 Path_FD : out File_Descriptor;
918 Path_Name : out Path_Name_Type)
921 Create_Temp_File (In_Tree, Path_FD, Path_Name, "path file");
922 end Create_New_Path_File;
924 ------------------------------------
925 -- File_Name_Of_Library_Unit_Body --
926 ------------------------------------
928 function File_Name_Of_Library_Unit_Body
930 Project : Project_Id;
931 In_Tree : Project_Tree_Ref;
932 Main_Project_Only : Boolean := True;
933 Full_Path : Boolean := False) return String
935 The_Project : Project_Id := Project;
936 Original_Name : String := Name;
938 Lang : constant Language_Ptr :=
939 Get_Language_From_Name (Project, "ada");
942 The_Original_Name : Name_Id;
943 The_Spec_Name : Name_Id;
944 The_Body_Name : Name_Id;
947 -- ??? Same block in Project_Of
948 Canonical_Case_File_Name (Original_Name);
949 Name_Len := Original_Name'Length;
950 Name_Buffer (1 .. Name_Len) := Original_Name;
951 The_Original_Name := Name_Find;
955 Naming : constant Lang_Naming_Data := Lang.Config.Naming_Data;
956 Extended_Spec_Name : String :=
957 Name & Namet.Get_Name_String
958 (Naming.Spec_Suffix);
959 Extended_Body_Name : String :=
960 Name & Namet.Get_Name_String
961 (Naming.Body_Suffix);
964 Canonical_Case_File_Name (Extended_Spec_Name);
965 Name_Len := Extended_Spec_Name'Length;
966 Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
967 The_Spec_Name := Name_Find;
969 Canonical_Case_File_Name (Extended_Body_Name);
970 Name_Len := Extended_Body_Name'Length;
971 Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
972 The_Body_Name := Name_Find;
976 Name_Len := Name'Length;
977 Name_Buffer (1 .. Name_Len) := Name;
978 Canonical_Case_File_Name (Name_Buffer);
979 The_Spec_Name := Name_Find;
980 The_Body_Name := The_Spec_Name;
983 if Current_Verbosity = High then
984 Write_Str ("Looking for file name of """);
988 Write_Str (" Extended Spec Name = """);
989 Write_Str (Get_Name_String (The_Spec_Name));
992 Write_Str (" Extended Body Name = """);
993 Write_Str (Get_Name_String (The_Body_Name));
998 -- For extending project, search in the extended project if the source
999 -- is not found. For non extending projects, this loop will be run only
1003 -- Loop through units
1005 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1006 while Unit /= null loop
1009 if not Main_Project_Only
1011 (Unit.File_Names (Impl) /= null
1012 and then Unit.File_Names (Impl).Project = The_Project)
1015 Current_Name : File_Name_Type;
1017 -- Case of a body present
1019 if Unit.File_Names (Impl) /= null then
1020 Current_Name := Unit.File_Names (Impl).File;
1022 if Current_Verbosity = High then
1023 Write_Str (" Comparing with """);
1024 Write_Str (Get_Name_String (Current_Name));
1029 -- If it has the name of the original name, return the
1032 if Unit.Name = The_Original_Name
1034 Current_Name = File_Name_Type (The_Original_Name)
1036 if Current_Verbosity = High then
1041 return Get_Name_String
1042 (Unit.File_Names (Impl).Path.Name);
1045 return Get_Name_String (Current_Name);
1048 -- If it has the name of the extended body name,
1049 -- return the extended body name
1051 elsif Current_Name = File_Name_Type (The_Body_Name) then
1052 if Current_Verbosity = High then
1057 return Get_Name_String
1058 (Unit.File_Names (Impl).Path.Name);
1061 return Get_Name_String (The_Body_Name);
1065 if Current_Verbosity = High then
1066 Write_Line (" not good");
1075 if not Main_Project_Only
1077 (Unit.File_Names (Spec) /= null
1078 and then Unit.File_Names (Spec).Project =
1082 Current_Name : File_Name_Type;
1085 -- Case of spec present
1087 if Unit.File_Names (Spec) /= null then
1088 Current_Name := Unit.File_Names (Spec).File;
1089 if Current_Verbosity = High then
1090 Write_Str (" Comparing with """);
1091 Write_Str (Get_Name_String (Current_Name));
1096 -- If name same as original name, return original name
1098 if Unit.Name = The_Original_Name
1100 Current_Name = File_Name_Type (The_Original_Name)
1102 if Current_Verbosity = High then
1107 return Get_Name_String
1108 (Unit.File_Names (Spec).Path.Name);
1110 return Get_Name_String (Current_Name);
1113 -- If it has the same name as the extended spec name,
1114 -- return the extended spec name.
1116 elsif Current_Name = File_Name_Type (The_Spec_Name) then
1117 if Current_Verbosity = High then
1122 return Get_Name_String
1123 (Unit.File_Names (Spec).Path.Name);
1125 return Get_Name_String (The_Spec_Name);
1129 if Current_Verbosity = High then
1130 Write_Line (" not good");
1137 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1140 -- If we are not in an extending project, give up
1142 exit when not Main_Project_Only
1143 or else The_Project.Extends = No_Project;
1145 -- Otherwise, look in the project we are extending
1147 The_Project := The_Project.Extends;
1150 -- We don't know this file name, return an empty string
1153 end File_Name_Of_Library_Unit_Body;
1155 -------------------------
1156 -- For_All_Object_Dirs --
1157 -------------------------
1159 procedure For_All_Object_Dirs (Project : Project_Id) is
1160 procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
1161 -- Get all object directories of Prj
1167 procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
1168 pragma Unreferenced (Dummy);
1170 -- ??? Set_Ada_Paths has a different behavior for library project
1171 -- files, should we have the same ?
1173 if Prj.Object_Directory /= No_Path_Information then
1174 Get_Name_String (Prj.Object_Directory.Display_Name);
1175 Action (Name_Buffer (1 .. Name_Len));
1179 procedure Get_Object_Dirs is
1180 new For_Every_Project_Imported (Integer, For_Project);
1181 Dummy : Integer := 1;
1183 -- Start of processing for For_All_Object_Dirs
1186 Get_Object_Dirs (Project, Dummy);
1187 end For_All_Object_Dirs;
1189 -------------------------
1190 -- For_All_Source_Dirs --
1191 -------------------------
1193 procedure For_All_Source_Dirs
1194 (Project : Project_Id;
1195 In_Tree : Project_Tree_Ref)
1197 procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
1198 -- Get all object directories of Prj
1204 procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
1205 pragma Unreferenced (Dummy);
1206 Current : String_List_Id := Prj.Source_Dirs;
1207 The_String : String_Element;
1210 -- If there are Ada sources, call action with the name of every
1211 -- source directory.
1213 if Has_Ada_Sources (Project) then
1214 while Current /= Nil_String loop
1215 The_String := In_Tree.String_Elements.Table (Current);
1216 Action (Get_Name_String (The_String.Display_Value));
1217 Current := The_String.Next;
1222 procedure Get_Source_Dirs is
1223 new For_Every_Project_Imported (Integer, For_Project);
1224 Dummy : Integer := 1;
1226 -- Start of processing for For_All_Source_Dirs
1229 Get_Source_Dirs (Project, Dummy);
1230 end For_All_Source_Dirs;
1236 procedure Get_Reference
1237 (Source_File_Name : String;
1238 In_Tree : Project_Tree_Ref;
1239 Project : out Project_Id;
1240 Path : out Path_Name_Type)
1243 -- Body below could use some comments ???
1245 if Current_Verbosity > Default then
1246 Write_Str ("Getting Reference_Of (""");
1247 Write_Str (Source_File_Name);
1248 Write_Str (""") ... ");
1252 Original_Name : String := Source_File_Name;
1256 Canonical_Case_File_Name (Original_Name);
1257 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1259 while Unit /= null loop
1260 if Unit.File_Names (Spec) /= null
1261 and then Unit.File_Names (Spec).File /= No_File
1263 (Namet.Get_Name_String
1264 (Unit.File_Names (Spec).File) = Original_Name
1265 or else (Unit.File_Names (Spec).Path /=
1268 Namet.Get_Name_String
1269 (Unit.File_Names (Spec).Path.Name) =
1272 Project := Ultimate_Extension_Of
1273 (Project => Unit.File_Names (Spec).Project);
1274 Path := Unit.File_Names (Spec).Path.Display_Name;
1276 if Current_Verbosity > Default then
1277 Write_Str ("Done: Spec.");
1283 elsif Unit.File_Names (Impl) /= null
1284 and then Unit.File_Names (Impl).File /= No_File
1286 (Namet.Get_Name_String
1287 (Unit.File_Names (Impl).File) = Original_Name
1288 or else (Unit.File_Names (Impl).Path /=
1290 and then Namet.Get_Name_String
1291 (Unit.File_Names (Impl).Path.Name) =
1294 Project := Ultimate_Extension_Of
1295 (Project => Unit.File_Names (Impl).Project);
1296 Path := Unit.File_Names (Impl).Path.Display_Name;
1298 if Current_Verbosity > Default then
1299 Write_Str ("Done: Body.");
1306 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1310 Project := No_Project;
1313 if Current_Verbosity > Default then
1314 Write_Str ("Cannot be found.");
1323 procedure Initialize (In_Tree : Project_Tree_Ref) is
1325 In_Tree.Private_Part.Current_Source_Path_File := No_Path;
1326 In_Tree.Private_Part.Current_Object_Path_File := No_Path;
1333 -- Could use some comments in this body ???
1335 procedure Print_Sources (In_Tree : Project_Tree_Ref) is
1339 Write_Line ("List of Sources:");
1341 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1343 while Unit /= No_Unit_Index loop
1345 Write_Line (Namet.Get_Name_String (Unit.Name));
1347 if Unit.File_Names (Spec).File /= No_File then
1348 if Unit.File_Names (Spec).Project = No_Project then
1349 Write_Line (" No project");
1352 Write_Str (" Project: ");
1354 (Unit.File_Names (Spec).Project.Path.Name);
1355 Write_Line (Name_Buffer (1 .. Name_Len));
1358 Write_Str (" spec: ");
1360 (Namet.Get_Name_String
1361 (Unit.File_Names (Spec).File));
1364 if Unit.File_Names (Impl).File /= No_File then
1365 if Unit.File_Names (Impl).Project = No_Project then
1366 Write_Line (" No project");
1369 Write_Str (" Project: ");
1371 (Unit.File_Names (Impl).Project.Path.Name);
1372 Write_Line (Name_Buffer (1 .. Name_Len));
1375 Write_Str (" body: ");
1377 (Namet.Get_Name_String (Unit.File_Names (Impl).File));
1380 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1383 Write_Line ("end of List of Sources.");
1392 Main_Project : Project_Id;
1393 In_Tree : Project_Tree_Ref) return Project_Id
1395 Result : Project_Id := No_Project;
1397 Original_Name : String := Name;
1399 Lang : constant Language_Ptr :=
1400 Get_Language_From_Name (Main_Project, "ada");
1404 Current_Name : File_Name_Type;
1405 The_Original_Name : File_Name_Type;
1406 The_Spec_Name : File_Name_Type;
1407 The_Body_Name : File_Name_Type;
1410 -- ??? Same block in File_Name_Of_Library_Unit_Body
1411 Canonical_Case_File_Name (Original_Name);
1412 Name_Len := Original_Name'Length;
1413 Name_Buffer (1 .. Name_Len) := Original_Name;
1414 The_Original_Name := Name_Find;
1416 if Lang /= null then
1418 Naming : Lang_Naming_Data renames Lang.Config.Naming_Data;
1419 Extended_Spec_Name : String :=
1420 Name & Namet.Get_Name_String
1421 (Naming.Spec_Suffix);
1422 Extended_Body_Name : String :=
1423 Name & Namet.Get_Name_String
1424 (Naming.Body_Suffix);
1427 Canonical_Case_File_Name (Extended_Spec_Name);
1428 Name_Len := Extended_Spec_Name'Length;
1429 Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1430 The_Spec_Name := Name_Find;
1432 Canonical_Case_File_Name (Extended_Body_Name);
1433 Name_Len := Extended_Body_Name'Length;
1434 Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1435 The_Body_Name := Name_Find;
1439 The_Spec_Name := The_Original_Name;
1440 The_Body_Name := The_Original_Name;
1443 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1444 while Unit /= null loop
1446 -- Case of a body present
1448 if Unit.File_Names (Impl) /= null then
1449 Current_Name := Unit.File_Names (Impl).File;
1451 -- If it has the name of the original name or the body name,
1452 -- we have found the project.
1454 if Unit.Name = Name_Id (The_Original_Name)
1455 or else Current_Name = The_Original_Name
1456 or else Current_Name = The_Body_Name
1458 Result := Unit.File_Names (Impl).Project;
1465 if Unit.File_Names (Spec) /= null then
1466 Current_Name := Unit.File_Names (Spec).File;
1468 -- If name same as the original name, or the spec name, we have
1469 -- found the project.
1471 if Unit.Name = Name_Id (The_Original_Name)
1472 or else Current_Name = The_Original_Name
1473 or else Current_Name = The_Spec_Name
1475 Result := Unit.File_Names (Spec).Project;
1480 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1483 -- Get the ultimate extending project
1485 if Result /= No_Project then
1486 while Result.Extended_By /= No_Project loop
1487 Result := Result.Extended_By;
1498 procedure Set_Ada_Paths
1499 (Project : Project_Id;
1500 In_Tree : Project_Tree_Ref;
1501 Including_Libraries : Boolean)
1504 Source_Paths : Source_Path_Table.Instance;
1505 Object_Paths : Object_Path_Table.Instance;
1506 -- List of source or object dirs. Only computed the first time this
1507 -- procedure is called (since Source_FD is then reused)
1509 Source_FD : File_Descriptor := Invalid_FD;
1510 Object_FD : File_Descriptor := Invalid_FD;
1511 -- The temporary files to store the paths. These are only created the
1512 -- first time this procedure is called, and reused from then on.
1514 Process_Source_Dirs : Boolean := False;
1515 Process_Object_Dirs : Boolean := False;
1518 -- For calls to Close
1521 Buffer : String_Access := new String (1 .. Buffer_Initial);
1522 Buffer_Last : Natural := 0;
1524 procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean);
1525 -- Recursive procedure to add the source/object paths of extended/
1526 -- imported projects.
1532 procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean) is
1533 pragma Unreferenced (Dummy);
1535 Path : Path_Name_Type;
1538 -- ??? This is almost the equivalent of For_All_Source_Dirs
1540 if Process_Source_Dirs then
1542 -- Add to path all source directories of this project if there are
1545 if Has_Ada_Sources (Project) then
1546 Add_To_Source_Path (Project.Source_Dirs, In_Tree, Source_Paths);
1550 if Process_Object_Dirs then
1551 Path := Get_Object_Directory
1553 Including_Libraries => Including_Libraries,
1554 Only_If_Ada => True);
1556 if Path /= No_Path then
1557 Add_To_Object_Path (Path, Object_Paths);
1562 procedure For_All_Projects is
1563 new For_Every_Project_Imported (Boolean, Recursive_Add);
1565 Dummy : Boolean := False;
1567 -- Start of processing for Set_Ada_Paths
1570 -- If it is the first time we call this procedure for this project,
1571 -- compute the source path and/or the object path.
1573 if Project.Include_Path_File = No_Path then
1574 Source_Path_Table.Init (Source_Paths);
1575 Process_Source_Dirs := True;
1576 Create_New_Path_File
1577 (In_Tree, Source_FD, Project.Include_Path_File);
1580 -- For the object path, we make a distinction depending on
1581 -- Including_Libraries.
1583 if Including_Libraries then
1584 if Project.Objects_Path_File_With_Libs = No_Path then
1585 Object_Path_Table.Init (Object_Paths);
1586 Process_Object_Dirs := True;
1587 Create_New_Path_File
1588 (In_Tree, Object_FD, Project.Objects_Path_File_With_Libs);
1592 if Project.Objects_Path_File_Without_Libs = No_Path then
1593 Object_Path_Table.Init (Object_Paths);
1594 Process_Object_Dirs := True;
1595 Create_New_Path_File
1596 (In_Tree, Object_FD, Project.Objects_Path_File_Without_Libs);
1600 -- If there is something to do, set Seen to False for all projects,
1601 -- then call the recursive procedure Add for Project.
1603 if Process_Source_Dirs or Process_Object_Dirs then
1604 For_All_Projects (Project, Dummy);
1607 -- Write and close any file that has been created. Source_FD is not set
1608 -- when this subprogram is called a second time or more, since we reuse
1609 -- the previous version of the file.
1611 if Source_FD /= Invalid_FD then
1614 for Index in Source_Path_Table.First ..
1615 Source_Path_Table.Last (Source_Paths)
1617 Get_Name_String (Source_Paths.Table (Index));
1618 Name_Len := Name_Len + 1;
1619 Name_Buffer (Name_Len) := ASCII.LF;
1620 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1623 Last := Write (Source_FD, Buffer (1)'Address, Buffer_Last);
1625 if Last = Buffer_Last then
1626 Close (Source_FD, Status);
1633 Prj.Com.Fail ("could not write temporary file");
1637 if Object_FD /= Invalid_FD then
1640 for Index in Object_Path_Table.First ..
1641 Object_Path_Table.Last (Object_Paths)
1643 Get_Name_String (Object_Paths.Table (Index));
1644 Name_Len := Name_Len + 1;
1645 Name_Buffer (Name_Len) := ASCII.LF;
1646 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1649 Last := Write (Object_FD, Buffer (1)'Address, Buffer_Last);
1651 if Last = Buffer_Last then
1652 Close (Object_FD, Status);
1658 Prj.Com.Fail ("could not write temporary file");
1662 -- Set the env vars, if they need to be changed, and set the
1663 -- corresponding flags.
1665 if In_Tree.Private_Part.Current_Source_Path_File /=
1666 Project.Include_Path_File
1668 In_Tree.Private_Part.Current_Source_Path_File :=
1669 Project.Include_Path_File;
1671 (Project_Include_Path_File,
1672 Get_Name_String (In_Tree.Private_Part.Current_Source_Path_File));
1675 if Including_Libraries then
1676 if In_Tree.Private_Part.Current_Object_Path_File /=
1677 Project.Objects_Path_File_With_Libs
1679 In_Tree.Private_Part.Current_Object_Path_File :=
1680 Project.Objects_Path_File_With_Libs;
1682 (Project_Objects_Path_File,
1684 (In_Tree.Private_Part.Current_Object_Path_File));
1688 if In_Tree.Private_Part.Current_Object_Path_File /=
1689 Project.Objects_Path_File_Without_Libs
1691 In_Tree.Private_Part.Current_Object_Path_File :=
1692 Project.Objects_Path_File_Without_Libs;
1694 (Project_Objects_Path_File,
1696 (In_Tree.Private_Part.Current_Object_Path_File));
1703 -----------------------
1704 -- Set_Path_File_Var --
1705 -----------------------
1707 procedure Set_Path_File_Var (Name : String; Value : String) is
1708 Host_Spec : String_Access := To_Host_File_Spec (Value);
1710 if Host_Spec = null then
1712 ("could not convert file name """ & Value & """ to host spec");
1714 Setenv (Name, Host_Spec.all);
1717 end Set_Path_File_Var;
1719 ---------------------------
1720 -- Ultimate_Extension_Of --
1721 ---------------------------
1723 function Ultimate_Extension_Of
1724 (Project : Project_Id) return Project_Id
1726 Result : Project_Id;
1730 while Result.Extended_By /= No_Project loop
1731 Result := Result.Extended_By;
1735 end Ultimate_Extension_Of;