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 procedure Create_Temp_File
101 (In_Tree : Project_Tree_Ref;
102 Path_FD : out File_Descriptor;
103 Path_Name : out Path_Name_Type;
105 -- Create a temporary file, and fail with an error if it could not be
108 ----------------------
109 -- Ada_Include_Path --
110 ----------------------
112 function Ada_Include_Path
113 (Project : Project_Id;
114 In_Tree : Project_Tree_Ref;
115 Recursive : Boolean := False) return String
117 Buffer : String_Access;
118 Buffer_Last : Natural := 0;
120 procedure Add (Project : Project_Id; Dummy : in out Boolean);
121 -- Add source dirs of Project to the path
127 procedure Add (Project : Project_Id; Dummy : in out Boolean) is
128 pragma Unreferenced (Dummy);
130 Add_To_Path (Project.Source_Dirs, In_Tree, Buffer, Buffer_Last);
133 procedure For_All_Projects is
134 new For_Every_Project_Imported (Boolean, Add);
136 Dummy : Boolean := False;
138 -- Start of processing for Ada_Include_Path
143 -- If it is the first time we call this function for
144 -- this project, compute the source path
146 if Project.Ada_Include_Path = null then
147 Buffer := new String (1 .. 4096);
148 For_All_Projects (Project, Dummy);
149 Project.Ada_Include_Path := new String'(Buffer (1 .. Buffer_Last));
153 return Project.Ada_Include_Path.all;
156 Buffer := new String (1 .. 4096);
157 Add_To_Path (Project.Source_Dirs, In_Tree, Buffer, Buffer_Last);
160 Result : constant String := Buffer (1 .. Buffer_Last);
166 end Ada_Include_Path;
168 ----------------------
169 -- Ada_Objects_Path --
170 ----------------------
172 function Ada_Objects_Path
173 (Project : Project_Id;
174 Including_Libraries : Boolean := True) return String_Access
176 Buffer : String_Access;
177 Buffer_Last : Natural := 0;
179 procedure Add (Project : Project_Id; Dummy : in out Boolean);
180 -- Add all the object directories of a project to the path
186 procedure Add (Project : Project_Id; Dummy : in out Boolean) is
187 pragma Unreferenced (Dummy);
188 Path : constant Path_Name_Type :=
191 Including_Libraries => Including_Libraries,
192 Only_If_Ada => False);
194 if Path /= No_Path then
195 Add_To_Path (Get_Name_String (Path), Buffer, Buffer_Last);
199 procedure For_All_Projects is
200 new For_Every_Project_Imported (Boolean, Add);
202 Dummy : Boolean := False;
204 -- Start of processing for Ada_Objects_Path
207 -- If it is the first time we call this function for
208 -- this project, compute the objects path
210 if Project.Ada_Objects_Path = null then
211 Buffer := new String (1 .. 4096);
212 For_All_Projects (Project, Dummy);
214 Project.Ada_Objects_Path := new String'(Buffer (1 .. Buffer_Last));
218 return Project.Ada_Objects_Path;
219 end Ada_Objects_Path;
225 procedure Add_To_Buffer
227 Buffer : in out String_Access;
228 Buffer_Last : in out Natural)
230 Last : constant Natural := Buffer_Last + S'Length;
232 while Last > Buffer'Last loop
234 New_Buffer : constant String_Access :=
235 new String (1 .. 2 * Buffer'Last);
238 New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
240 Buffer := New_Buffer;
244 Buffer (Buffer_Last + 1 .. Last) := S;
248 ------------------------
249 -- Add_To_Object_Path --
250 ------------------------
252 procedure Add_To_Object_Path
253 (Object_Dir : Path_Name_Type;
254 Object_Paths : in out Object_Path_Table.Instance)
257 -- Check if the directory is already in the table
259 for Index in Object_Path_Table.First ..
260 Object_Path_Table.Last (Object_Paths)
263 -- If it is, remove it, and add it as the last one
265 if Object_Paths.Table (Index) = Object_Dir then
266 for Index2 in Index + 1 ..
267 Object_Path_Table.Last (Object_Paths)
269 Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2);
273 (Object_Path_Table.Last (Object_Paths)) := Object_Dir;
278 -- The directory is not already in the table, add it
280 Object_Path_Table.Append (Object_Paths, Object_Dir);
281 end Add_To_Object_Path;
287 procedure Add_To_Path
288 (Source_Dirs : String_List_Id;
289 In_Tree : Project_Tree_Ref;
290 Buffer : in out String_Access;
291 Buffer_Last : in out Natural)
293 Current : String_List_Id := Source_Dirs;
294 Source_Dir : String_Element;
296 while Current /= Nil_String loop
297 Source_Dir := In_Tree.String_Elements.Table (Current);
298 Add_To_Path (Get_Name_String (Source_Dir.Display_Value),
299 Buffer, Buffer_Last);
300 Current := Source_Dir.Next;
304 procedure Add_To_Path
306 Buffer : in out String_Access;
307 Buffer_Last : in out Natural)
310 New_Buffer : String_Access;
313 function Is_Present (Path : String; Dir : String) return Boolean;
314 -- Return True if Dir is part of Path
320 function Is_Present (Path : String; Dir : String) return Boolean is
321 Last : constant Integer := Path'Last - Dir'Length + 1;
324 for J in Path'First .. Last loop
326 -- Note: the order of the conditions below is important, since
327 -- it ensures a minimal number of string comparisons.
330 or else Path (J - 1) = Path_Separator)
332 (J + Dir'Length > Path'Last
333 or else Path (J + Dir'Length) = Path_Separator)
334 and then Dir = Path (J .. J + Dir'Length - 1)
343 -- Start of processing for Add_To_Path
346 if Is_Present (Buffer (1 .. Buffer_Last), Dir) then
348 -- Dir is already in the path, nothing to do
353 Min_Len := Buffer_Last + Dir'Length;
355 if Buffer_Last > 0 then
357 -- Add 1 for the Path_Separator character
359 Min_Len := Min_Len + 1;
362 -- If Ada_Path_Buffer is too small, increase it
366 if Len < Min_Len then
369 exit when Len >= Min_Len;
372 New_Buffer := new String (1 .. Len);
373 New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
375 Buffer := New_Buffer;
378 if Buffer_Last > 0 then
379 Buffer_Last := Buffer_Last + 1;
380 Buffer (Buffer_Last) := Path_Separator;
383 Buffer (Buffer_Last + 1 .. Buffer_Last + Dir'Length) := Dir;
384 Buffer_Last := Buffer_Last + Dir'Length;
387 ------------------------
388 -- Add_To_Source_Path --
389 ------------------------
391 procedure Add_To_Source_Path
392 (Source_Dirs : String_List_Id;
393 In_Tree : Project_Tree_Ref;
394 Source_Paths : in out Source_Path_Table.Instance)
396 Current : String_List_Id := Source_Dirs;
397 Source_Dir : String_Element;
401 -- Add each source directory
403 while Current /= Nil_String loop
404 Source_Dir := In_Tree.String_Elements.Table (Current);
407 -- Check if the source directory is already in the table
409 for Index in Source_Path_Table.First ..
410 Source_Path_Table.Last (Source_Paths)
412 -- If it is already, no need to add it
414 if Source_Paths.Table (Index) = Source_Dir.Value then
421 Source_Path_Table.Append (Source_Paths, Source_Dir.Value);
424 -- Next source directory
426 Current := Source_Dir.Next;
428 end Add_To_Source_Path;
430 --------------------------------
431 -- Create_Config_Pragmas_File --
432 --------------------------------
434 procedure Create_Config_Pragmas_File
435 (For_Project : Project_Id;
436 In_Tree : Project_Tree_Ref)
438 type Naming_Id is new Nat;
439 package Naming_Table is new GNAT.Dynamic_Tables
440 (Table_Component_Type => Lang_Naming_Data,
441 Table_Index_Type => Naming_Id,
442 Table_Low_Bound => 1,
444 Table_Increment => 100);
445 Default_Naming : constant Naming_Id := Naming_Table.First;
446 Namings : Naming_Table.Instance;
447 -- Table storing the naming data for gnatmake/gprmake
449 Buffer : String_Access := new String (1 .. Buffer_Initial);
450 Buffer_Last : Natural := 0;
452 File_Name : Path_Name_Type := No_Path;
453 File : File_Descriptor := Invalid_FD;
455 Current_Naming : Naming_Id;
456 Iter : Source_Iterator;
459 procedure Check (Project : Project_Id; State : in out Integer);
460 -- Recursive procedure that put in the config pragmas file any non
461 -- standard naming schemes, if it is not already in the file, then call
462 -- itself for any imported project.
464 procedure Put (Source : Source_Id);
465 -- Put an SFN pragma in the temporary file
467 procedure Put (S : String);
468 procedure Put_Line (S : String);
469 -- Output procedures, analogous to normal Text_IO procs of same name.
470 -- The text is put in Buffer, then it will be writen into a temporary
471 -- file with procedure Write_Temp_File below.
473 procedure Write_Temp_File;
474 -- Create a temporary file and put the content of the buffer in it.
480 procedure Check (Project : Project_Id; State : in out Integer) is
481 pragma Unreferenced (State);
482 Lang : constant Language_Ptr :=
483 Get_Language_From_Name (Project, "ada");
484 Naming : Lang_Naming_Data;
487 if Current_Verbosity = High then
488 Write_Str ("Checking project file """);
489 Write_Str (Namet.Get_Name_String (Project.Name));
495 if Current_Verbosity = High then
496 Write_Line (" Languages does not contain Ada, nothing to do");
502 Naming := Lang.Config.Naming_Data;
504 -- Is the naming scheme of this project one that we know?
506 Current_Naming := Default_Naming;
507 while Current_Naming <= Naming_Table.Last (Namings)
508 and then Namings.Table (Current_Naming).Dot_Replacement =
509 Naming.Dot_Replacement
510 and then Namings.Table (Current_Naming).Casing =
512 and then Namings.Table (Current_Naming).Separate_Suffix =
513 Naming.Separate_Suffix
515 Current_Naming := Current_Naming + 1;
518 -- If we don't know it, add it
520 if Current_Naming > Naming_Table.Last (Namings) then
521 Naming_Table.Increment_Last (Namings);
522 Namings.Table (Naming_Table.Last (Namings)) := Naming;
524 -- Put the SFN pragmas for the naming scheme
529 ("pragma Source_File_Name_Project");
531 (" (Spec_File_Name => ""*" &
532 Get_Name_String (Naming.Spec_Suffix) & """,");
535 Image (Naming.Casing) & ",");
537 (" Dot_Replacement => """ &
538 Get_Name_String (Naming.Dot_Replacement) & """);");
543 ("pragma Source_File_Name_Project");
545 (" (Body_File_Name => ""*" &
546 Get_Name_String (Naming.Body_Suffix) & """,");
549 Image (Naming.Casing) & ",");
551 (" Dot_Replacement => """ &
552 Get_Name_String (Naming.Dot_Replacement) &
555 -- and maybe separate
557 if Naming.Body_Suffix /= Naming.Separate_Suffix then
558 Put_Line ("pragma Source_File_Name_Project");
560 (" (Subunit_File_Name => ""*" &
561 Get_Name_String (Naming.Separate_Suffix) & """,");
564 Image (Naming.Casing) & ",");
566 (" Dot_Replacement => """ &
567 Get_Name_String (Naming.Dot_Replacement) &
577 procedure Put (Source : Source_Id) is
579 -- Put the pragma SFN for the unit kind (spec or body)
581 Put ("pragma Source_File_Name_Project (");
582 Put (Namet.Get_Name_String (Source.Unit.Name));
584 if Source.Kind = Spec then
585 Put (", Spec_File_Name => """);
587 Put (", Body_File_Name => """);
590 Put (Namet.Get_Name_String (Source.File));
593 if Source.Index /= 0 then
595 Put (Source.Index'Img);
601 procedure Put (S : String) is
603 Add_To_Buffer (S, Buffer, Buffer_Last);
605 if Current_Verbosity = High then
614 procedure Put_Line (S : String) is
616 -- Add an ASCII.LF to the string. As this config file is supposed to
617 -- be used only by the compiler, we don't care about the characters
618 -- for the end of line. In fact we could have put a space, but
619 -- it is more convenient to be able to read gnat.adc during
620 -- development, for which the ASCII.LF is fine.
623 Put (S => (1 => ASCII.LF));
626 ---------------------
627 -- Write_Temp_File --
628 ---------------------
630 procedure Write_Temp_File is
631 Status : Boolean := False;
634 Tempdir.Create_Temp_File (File, File_Name);
636 if File /= Invalid_FD then
637 Last := Write (File, Buffer (1)'Address, Buffer_Last);
639 if Last = Buffer_Last then
640 Close (File, Status);
645 Prj.Com.Fail ("unable to create temporary file");
649 procedure Check_Imported_Projects is new For_Every_Project_Imported
651 Dummy : Integer := 0;
653 -- Start of processing for Create_Config_Pragmas_File
656 if not For_Project.Config_Checked then
658 Naming_Table.Init (Namings);
660 -- Check the naming schemes
662 Check_Imported_Projects (For_Project, Dummy, Imported_First => False);
664 -- Visit all the files and process those that need an SFN pragma
666 Iter := For_Each_Source (In_Tree, For_Project);
667 while Element (Iter) /= No_Source loop
668 Source := Element (Iter);
671 and then not Source.Locally_Removed
672 and then Source.Unit /= null
680 -- If there are no non standard naming scheme, issue the GNAT
681 -- standard naming scheme. This will tell the compiler that
682 -- a project file is used and will forbid any pragma SFN.
684 if Buffer_Last = 0 then
686 Put_Line ("pragma Source_File_Name_Project");
687 Put_Line (" (Spec_File_Name => ""*.ads"",");
688 Put_Line (" Dot_Replacement => ""-"",");
689 Put_Line (" Casing => lowercase);");
691 Put_Line ("pragma Source_File_Name_Project");
692 Put_Line (" (Body_File_Name => ""*.adb"",");
693 Put_Line (" Dot_Replacement => ""-"",");
694 Put_Line (" Casing => lowercase);");
697 -- Close the temporary file
701 if Opt.Verbose_Mode then
702 Write_Str ("Created configuration file """);
703 Write_Str (Get_Name_String (File_Name));
707 For_Project.Config_File_Name := File_Name;
708 For_Project.Config_File_Temp := True;
709 For_Project.Config_Checked := True;
713 end Create_Config_Pragmas_File;
719 procedure Create_Mapping (In_Tree : Project_Tree_Ref) is
721 Iter : Source_Iterator;
726 Iter := For_Each_Source (In_Tree);
728 Data := Element (Iter);
729 exit when Data = No_Source;
731 if Data.Unit /= No_Unit_Index then
732 if Data.Locally_Removed then
733 Fmap.Add_Forbidden_File_Name (Data.File);
736 (Unit_Name => Unit_Name_Type (Data.Unit.Name),
737 File_Name => Data.File,
738 Path_Name => File_Name_Type (Data.Path.Name));
746 -------------------------
747 -- Create_Mapping_File --
748 -------------------------
750 procedure Create_Mapping_File
751 (Project : Project_Id;
753 In_Tree : Project_Tree_Ref;
754 Name : out Path_Name_Type)
756 File : File_Descriptor := Invalid_FD;
758 Buffer : String_Access := new String (1 .. Buffer_Initial);
759 Buffer_Last : Natural := 0;
761 procedure Put_Name_Buffer;
762 -- Put the line contained in the Name_Buffer in the global buffer
764 procedure Process (Project : Project_Id; State : in out Integer);
765 -- Generate the mapping file for Project (not recursively)
767 ---------------------
768 -- Put_Name_Buffer --
769 ---------------------
771 procedure Put_Name_Buffer is
773 Name_Len := Name_Len + 1;
774 Name_Buffer (Name_Len) := ASCII.LF;
776 if Current_Verbosity = High then
777 Write_Str ("Mapping file: " & Name_Buffer (1 .. Name_Len));
780 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
787 procedure Process (Project : Project_Id; State : in out Integer) is
788 pragma Unreferenced (State);
790 Suffix : File_Name_Type;
791 Iter : Source_Iterator;
794 Iter := For_Each_Source (In_Tree, Project, Language => Language);
797 Source := Prj.Element (Iter);
798 exit when Source = No_Source;
800 if Source.Replaced_By = No_Source
801 and then Source.Path.Name /= No_Path
803 (Source.Language.Config.Kind = File_Based
804 or else Source.Unit /= No_Unit_Index)
806 if Source.Unit /= No_Unit_Index then
807 Get_Name_String (Source.Unit.Name);
809 if Source.Language.Config.Kind = Unit_Based then
811 -- ??? Mapping_Spec_Suffix could be set in the case of
814 Add_Char_To_Name_Buffer ('%');
816 if Source.Kind = Spec then
817 Add_Char_To_Name_Buffer ('s');
819 Add_Char_To_Name_Buffer ('b');
826 Source.Language.Config.Mapping_Spec_Suffix;
829 Source.Language.Config.Mapping_Body_Suffix;
832 if Suffix /= No_File then
833 Add_Str_To_Name_Buffer
834 (Get_Name_String (Suffix));
841 Get_Name_String (Source.File);
844 if Source.Locally_Removed then
846 Name_Buffer (1) := '/';
848 Get_Name_String (Source.Path.Name);
858 procedure For_Every_Imported_Project is new
859 For_Every_Project_Imported (State => Integer, Action => Process);
861 Dummy : Integer := 0;
863 -- Start of processing for Create_Mapping_File
866 For_Every_Imported_Project (Project, Dummy);
870 Status : Boolean := False;
873 Create_Temp_File (In_Tree, File, Name, "mapping");
875 if File /= Invalid_FD then
876 Last := Write (File, Buffer (1)'Address, Buffer_Last);
878 if Last = Buffer_Last then
879 GNAT.OS_Lib.Close (File, Status);
884 Prj.Com.Fail ("could not write mapping file");
889 end Create_Mapping_File;
891 ----------------------
892 -- Create_Temp_File --
893 ----------------------
895 procedure Create_Temp_File
896 (In_Tree : Project_Tree_Ref;
897 Path_FD : out File_Descriptor;
898 Path_Name : out Path_Name_Type;
902 Tempdir.Create_Temp_File (Path_FD, Path_Name);
904 if Path_Name /= No_Path then
905 if Current_Verbosity = High then
906 Write_Line ("Create temp file (" & File_Use & ") "
907 & Get_Name_String (Path_Name));
910 Record_Temp_File (In_Tree, Path_Name);
914 ("unable to create temporary " & File_Use & " file");
916 end Create_Temp_File;
918 --------------------------
919 -- Create_New_Path_File --
920 --------------------------
922 procedure Create_New_Path_File
923 (In_Tree : Project_Tree_Ref;
924 Path_FD : out File_Descriptor;
925 Path_Name : out Path_Name_Type)
928 Create_Temp_File (In_Tree, Path_FD, Path_Name, "path file");
929 end Create_New_Path_File;
931 ------------------------------------
932 -- File_Name_Of_Library_Unit_Body --
933 ------------------------------------
935 function File_Name_Of_Library_Unit_Body
937 Project : Project_Id;
938 In_Tree : Project_Tree_Ref;
939 Main_Project_Only : Boolean := True;
940 Full_Path : Boolean := False) return String
942 The_Project : Project_Id := Project;
943 Original_Name : String := Name;
945 Lang : constant Language_Ptr :=
946 Get_Language_From_Name (Project, "ada");
949 The_Original_Name : Name_Id;
950 The_Spec_Name : Name_Id;
951 The_Body_Name : Name_Id;
954 -- ??? Same block in Project_Of
955 Canonical_Case_File_Name (Original_Name);
956 Name_Len := Original_Name'Length;
957 Name_Buffer (1 .. Name_Len) := Original_Name;
958 The_Original_Name := Name_Find;
962 Naming : constant Lang_Naming_Data := Lang.Config.Naming_Data;
963 Extended_Spec_Name : String :=
964 Name & Namet.Get_Name_String
965 (Naming.Spec_Suffix);
966 Extended_Body_Name : String :=
967 Name & Namet.Get_Name_String
968 (Naming.Body_Suffix);
971 Canonical_Case_File_Name (Extended_Spec_Name);
972 Name_Len := Extended_Spec_Name'Length;
973 Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
974 The_Spec_Name := Name_Find;
976 Canonical_Case_File_Name (Extended_Body_Name);
977 Name_Len := Extended_Body_Name'Length;
978 Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
979 The_Body_Name := Name_Find;
983 Name_Len := Name'Length;
984 Name_Buffer (1 .. Name_Len) := Name;
985 Canonical_Case_File_Name (Name_Buffer);
986 The_Spec_Name := Name_Find;
987 The_Body_Name := The_Spec_Name;
990 if Current_Verbosity = High then
991 Write_Str ("Looking for file name of """);
995 Write_Str (" Extended Spec Name = """);
996 Write_Str (Get_Name_String (The_Spec_Name));
999 Write_Str (" Extended Body Name = """);
1000 Write_Str (Get_Name_String (The_Body_Name));
1005 -- For extending project, search in the extended project if the source
1006 -- is not found. For non extending projects, this loop will be run only
1010 -- Loop through units
1012 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1013 while Unit /= null loop
1016 if not Main_Project_Only
1018 (Unit.File_Names (Impl) /= null
1019 and then Unit.File_Names (Impl).Project = The_Project)
1022 Current_Name : File_Name_Type;
1024 -- Case of a body present
1026 if Unit.File_Names (Impl) /= null then
1027 Current_Name := Unit.File_Names (Impl).File;
1029 if Current_Verbosity = High then
1030 Write_Str (" Comparing with """);
1031 Write_Str (Get_Name_String (Current_Name));
1036 -- If it has the name of the original name, return the
1039 if Unit.Name = The_Original_Name
1041 Current_Name = File_Name_Type (The_Original_Name)
1043 if Current_Verbosity = High then
1048 return Get_Name_String
1049 (Unit.File_Names (Impl).Path.Name);
1052 return Get_Name_String (Current_Name);
1055 -- If it has the name of the extended body name,
1056 -- return the extended body name
1058 elsif Current_Name = File_Name_Type (The_Body_Name) then
1059 if Current_Verbosity = High then
1064 return Get_Name_String
1065 (Unit.File_Names (Impl).Path.Name);
1068 return Get_Name_String (The_Body_Name);
1072 if Current_Verbosity = High then
1073 Write_Line (" not good");
1082 if not Main_Project_Only
1084 (Unit.File_Names (Spec) /= null
1085 and then Unit.File_Names (Spec).Project =
1089 Current_Name : File_Name_Type;
1092 -- Case of spec present
1094 if Unit.File_Names (Spec) /= null then
1095 Current_Name := Unit.File_Names (Spec).File;
1096 if Current_Verbosity = High then
1097 Write_Str (" Comparing with """);
1098 Write_Str (Get_Name_String (Current_Name));
1103 -- If name same as original name, return original name
1105 if Unit.Name = The_Original_Name
1107 Current_Name = File_Name_Type (The_Original_Name)
1109 if Current_Verbosity = High then
1114 return Get_Name_String
1115 (Unit.File_Names (Spec).Path.Name);
1117 return Get_Name_String (Current_Name);
1120 -- If it has the same name as the extended spec name,
1121 -- return the extended spec name.
1123 elsif Current_Name = File_Name_Type (The_Spec_Name) then
1124 if Current_Verbosity = High then
1129 return Get_Name_String
1130 (Unit.File_Names (Spec).Path.Name);
1132 return Get_Name_String (The_Spec_Name);
1136 if Current_Verbosity = High then
1137 Write_Line (" not good");
1144 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1147 -- If we are not in an extending project, give up
1149 exit when not Main_Project_Only
1150 or else The_Project.Extends = No_Project;
1152 -- Otherwise, look in the project we are extending
1154 The_Project := The_Project.Extends;
1157 -- We don't know this file name, return an empty string
1160 end File_Name_Of_Library_Unit_Body;
1162 -------------------------
1163 -- For_All_Object_Dirs --
1164 -------------------------
1166 procedure For_All_Object_Dirs (Project : Project_Id) is
1167 procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
1168 -- Get all object directories of Prj
1174 procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
1175 pragma Unreferenced (Dummy);
1177 -- ??? Set_Ada_Paths has a different behavior for library project
1178 -- files, should we have the same ?
1180 if Prj.Object_Directory /= No_Path_Information then
1181 Get_Name_String (Prj.Object_Directory.Display_Name);
1182 Action (Name_Buffer (1 .. Name_Len));
1186 procedure Get_Object_Dirs is
1187 new For_Every_Project_Imported (Integer, For_Project);
1188 Dummy : Integer := 1;
1190 -- Start of processing for For_All_Object_Dirs
1193 Get_Object_Dirs (Project, Dummy);
1194 end For_All_Object_Dirs;
1196 -------------------------
1197 -- For_All_Source_Dirs --
1198 -------------------------
1200 procedure For_All_Source_Dirs
1201 (Project : Project_Id;
1202 In_Tree : Project_Tree_Ref)
1204 procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
1205 -- Get all object directories of Prj
1211 procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
1212 pragma Unreferenced (Dummy);
1213 Current : String_List_Id := Prj.Source_Dirs;
1214 The_String : String_Element;
1217 -- If there are Ada sources, call action with the name of every
1218 -- source directory.
1220 if Has_Ada_Sources (Project) then
1221 while Current /= Nil_String loop
1222 The_String := In_Tree.String_Elements.Table (Current);
1223 Action (Get_Name_String (The_String.Display_Value));
1224 Current := The_String.Next;
1229 procedure Get_Source_Dirs is
1230 new For_Every_Project_Imported (Integer, For_Project);
1231 Dummy : Integer := 1;
1233 -- Start of processing for For_All_Source_Dirs
1236 Get_Source_Dirs (Project, Dummy);
1237 end For_All_Source_Dirs;
1243 procedure Get_Reference
1244 (Source_File_Name : String;
1245 In_Tree : Project_Tree_Ref;
1246 Project : out Project_Id;
1247 Path : out Path_Name_Type)
1250 -- Body below could use some comments ???
1252 if Current_Verbosity > Default then
1253 Write_Str ("Getting Reference_Of (""");
1254 Write_Str (Source_File_Name);
1255 Write_Str (""") ... ");
1259 Original_Name : String := Source_File_Name;
1263 Canonical_Case_File_Name (Original_Name);
1264 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1266 while Unit /= null loop
1267 if Unit.File_Names (Spec) /= null
1268 and then Unit.File_Names (Spec).File /= No_File
1270 (Namet.Get_Name_String
1271 (Unit.File_Names (Spec).File) = Original_Name
1272 or else (Unit.File_Names (Spec).Path /=
1275 Namet.Get_Name_String
1276 (Unit.File_Names (Spec).Path.Name) =
1279 Project := Ultimate_Extension_Of
1280 (Project => Unit.File_Names (Spec).Project);
1281 Path := Unit.File_Names (Spec).Path.Display_Name;
1283 if Current_Verbosity > Default then
1284 Write_Str ("Done: Spec.");
1290 elsif Unit.File_Names (Impl) /= null
1291 and then Unit.File_Names (Impl).File /= No_File
1293 (Namet.Get_Name_String
1294 (Unit.File_Names (Impl).File) = Original_Name
1295 or else (Unit.File_Names (Impl).Path /=
1297 and then Namet.Get_Name_String
1298 (Unit.File_Names (Impl).Path.Name) =
1301 Project := Ultimate_Extension_Of
1302 (Project => Unit.File_Names (Impl).Project);
1303 Path := Unit.File_Names (Impl).Path.Display_Name;
1305 if Current_Verbosity > Default then
1306 Write_Str ("Done: Body.");
1313 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1317 Project := No_Project;
1320 if Current_Verbosity > Default then
1321 Write_Str ("Cannot be found.");
1330 procedure Initialize (In_Tree : Project_Tree_Ref) is
1332 In_Tree.Private_Part.Current_Source_Path_File := No_Path;
1333 In_Tree.Private_Part.Current_Object_Path_File := No_Path;
1340 -- Could use some comments in this body ???
1342 procedure Print_Sources (In_Tree : Project_Tree_Ref) is
1346 Write_Line ("List of Sources:");
1348 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1350 while Unit /= No_Unit_Index loop
1352 Write_Line (Namet.Get_Name_String (Unit.Name));
1354 if Unit.File_Names (Spec).File /= No_File then
1355 if Unit.File_Names (Spec).Project = No_Project then
1356 Write_Line (" No project");
1359 Write_Str (" Project: ");
1361 (Unit.File_Names (Spec).Project.Path.Name);
1362 Write_Line (Name_Buffer (1 .. Name_Len));
1365 Write_Str (" spec: ");
1367 (Namet.Get_Name_String
1368 (Unit.File_Names (Spec).File));
1371 if Unit.File_Names (Impl).File /= No_File then
1372 if Unit.File_Names (Impl).Project = No_Project then
1373 Write_Line (" No project");
1376 Write_Str (" Project: ");
1378 (Unit.File_Names (Impl).Project.Path.Name);
1379 Write_Line (Name_Buffer (1 .. Name_Len));
1382 Write_Str (" body: ");
1384 (Namet.Get_Name_String (Unit.File_Names (Impl).File));
1387 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1390 Write_Line ("end of List of Sources.");
1399 Main_Project : Project_Id;
1400 In_Tree : Project_Tree_Ref) return Project_Id
1402 Result : Project_Id := No_Project;
1404 Original_Name : String := Name;
1406 Lang : constant Language_Ptr :=
1407 Get_Language_From_Name (Main_Project, "ada");
1411 Current_Name : File_Name_Type;
1412 The_Original_Name : File_Name_Type;
1413 The_Spec_Name : File_Name_Type;
1414 The_Body_Name : File_Name_Type;
1417 -- ??? Same block in File_Name_Of_Library_Unit_Body
1418 Canonical_Case_File_Name (Original_Name);
1419 Name_Len := Original_Name'Length;
1420 Name_Buffer (1 .. Name_Len) := Original_Name;
1421 The_Original_Name := Name_Find;
1423 if Lang /= null then
1425 Naming : Lang_Naming_Data renames Lang.Config.Naming_Data;
1426 Extended_Spec_Name : String :=
1427 Name & Namet.Get_Name_String
1428 (Naming.Spec_Suffix);
1429 Extended_Body_Name : String :=
1430 Name & Namet.Get_Name_String
1431 (Naming.Body_Suffix);
1434 Canonical_Case_File_Name (Extended_Spec_Name);
1435 Name_Len := Extended_Spec_Name'Length;
1436 Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1437 The_Spec_Name := Name_Find;
1439 Canonical_Case_File_Name (Extended_Body_Name);
1440 Name_Len := Extended_Body_Name'Length;
1441 Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1442 The_Body_Name := Name_Find;
1446 The_Spec_Name := The_Original_Name;
1447 The_Body_Name := The_Original_Name;
1450 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1451 while Unit /= null loop
1453 -- Case of a body present
1455 if Unit.File_Names (Impl) /= null then
1456 Current_Name := Unit.File_Names (Impl).File;
1458 -- If it has the name of the original name or the body name,
1459 -- we have found the project.
1461 if Unit.Name = Name_Id (The_Original_Name)
1462 or else Current_Name = The_Original_Name
1463 or else Current_Name = The_Body_Name
1465 Result := Unit.File_Names (Impl).Project;
1472 if Unit.File_Names (Spec) /= null then
1473 Current_Name := Unit.File_Names (Spec).File;
1475 -- If name same as the original name, or the spec name, we have
1476 -- found the project.
1478 if Unit.Name = Name_Id (The_Original_Name)
1479 or else Current_Name = The_Original_Name
1480 or else Current_Name = The_Spec_Name
1482 Result := Unit.File_Names (Spec).Project;
1487 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1490 -- Get the ultimate extending project
1492 if Result /= No_Project then
1493 while Result.Extended_By /= No_Project loop
1494 Result := Result.Extended_By;
1505 procedure Set_Ada_Paths
1506 (Project : Project_Id;
1507 In_Tree : Project_Tree_Ref;
1508 Including_Libraries : Boolean)
1511 Source_Paths : Source_Path_Table.Instance;
1512 Object_Paths : Object_Path_Table.Instance;
1513 -- List of source or object dirs. Only computed the first time this
1514 -- procedure is called (since Source_FD is then reused)
1516 Source_FD : File_Descriptor := Invalid_FD;
1517 Object_FD : File_Descriptor := Invalid_FD;
1518 -- The temporary files to store the paths. These are only created the
1519 -- first time this procedure is called, and reused from then on.
1521 Process_Source_Dirs : Boolean := False;
1522 Process_Object_Dirs : Boolean := False;
1525 -- For calls to Close
1529 Buffer : String_Access := new String (1 .. Buffer_Initial);
1530 Buffer_Last : Natural := 0;
1532 procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean);
1533 -- Recursive procedure to add the source/object paths of extended/
1534 -- imported projects.
1540 procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean) is
1541 pragma Unreferenced (Dummy);
1543 Path : Path_Name_Type;
1546 -- ??? This is almost the equivalent of For_All_Source_Dirs
1548 if Process_Source_Dirs then
1550 -- Add to path all source directories of this project if there are
1553 if Has_Ada_Sources (Project) then
1554 Add_To_Source_Path (Project.Source_Dirs, In_Tree, Source_Paths);
1558 if Process_Object_Dirs then
1559 Path := Get_Object_Directory
1561 Including_Libraries => Including_Libraries,
1562 Only_If_Ada => True);
1564 if Path /= No_Path then
1565 Add_To_Object_Path (Path, Object_Paths);
1570 procedure For_All_Projects is
1571 new For_Every_Project_Imported (Boolean, Recursive_Add);
1572 Dummy : Boolean := False;
1574 -- Start of processing for Set_Ada_Paths
1577 -- If it is the first time we call this procedure for this project,
1578 -- compute the source path and/or the object path.
1580 if Project.Include_Path_File = No_Path then
1581 Source_Path_Table.Init (Source_Paths);
1582 Process_Source_Dirs := True;
1583 Create_New_Path_File
1584 (In_Tree, Source_FD, Project.Include_Path_File);
1587 -- For the object path, we make a distinction depending on
1588 -- Including_Libraries.
1590 if Including_Libraries then
1591 if Project.Objects_Path_File_With_Libs = No_Path then
1592 Object_Path_Table.Init (Object_Paths);
1593 Process_Object_Dirs := True;
1594 Create_New_Path_File
1595 (In_Tree, Object_FD, Project.Objects_Path_File_With_Libs);
1599 if Project.Objects_Path_File_Without_Libs = No_Path then
1600 Object_Path_Table.Init (Object_Paths);
1601 Process_Object_Dirs := True;
1602 Create_New_Path_File
1603 (In_Tree, Object_FD, Project.Objects_Path_File_Without_Libs);
1607 -- If there is something to do, set Seen to False for all projects,
1608 -- then call the recursive procedure Add for Project.
1610 if Process_Source_Dirs or Process_Object_Dirs then
1611 For_All_Projects (Project, Dummy);
1614 -- Write and close any file that has been created. Source_FD is not set
1615 -- when this subprogram is called a second time or more, since we reuse
1616 -- the previous version of the file.
1618 if Source_FD /= Invalid_FD then
1621 for Index in Source_Path_Table.First ..
1622 Source_Path_Table.Last (Source_Paths)
1624 Get_Name_String (Source_Paths.Table (Index));
1625 Name_Len := Name_Len + 1;
1626 Name_Buffer (Name_Len) := ASCII.LF;
1627 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1630 Last := Write (Source_FD, Buffer (1)'Address, Buffer_Last);
1632 if Last = Buffer_Last then
1633 Close (Source_FD, Status);
1640 Prj.Com.Fail ("could not write temporary file");
1644 if Object_FD /= Invalid_FD then
1647 for Index in Object_Path_Table.First ..
1648 Object_Path_Table.Last (Object_Paths)
1650 Get_Name_String (Object_Paths.Table (Index));
1651 Name_Len := Name_Len + 1;
1652 Name_Buffer (Name_Len) := ASCII.LF;
1653 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1656 Last := Write (Object_FD, Buffer (1)'Address, Buffer_Last);
1658 if Last = Buffer_Last then
1659 Close (Object_FD, Status);
1666 Prj.Com.Fail ("could not write temporary file");
1670 -- Set the env vars, if they need to be changed, and set the
1671 -- corresponding flags.
1673 if In_Tree.Private_Part.Current_Source_Path_File /=
1674 Project.Include_Path_File
1676 In_Tree.Private_Part.Current_Source_Path_File :=
1677 Project.Include_Path_File;
1679 (Project_Include_Path_File,
1680 Get_Name_String (In_Tree.Private_Part.Current_Source_Path_File));
1683 if Including_Libraries then
1684 if In_Tree.Private_Part.Current_Object_Path_File /=
1685 Project.Objects_Path_File_With_Libs
1687 In_Tree.Private_Part.Current_Object_Path_File :=
1688 Project.Objects_Path_File_With_Libs;
1690 (Project_Objects_Path_File,
1692 (In_Tree.Private_Part.Current_Object_Path_File));
1696 if In_Tree.Private_Part.Current_Object_Path_File /=
1697 Project.Objects_Path_File_Without_Libs
1699 In_Tree.Private_Part.Current_Object_Path_File :=
1700 Project.Objects_Path_File_Without_Libs;
1702 (Project_Objects_Path_File,
1704 (In_Tree.Private_Part.Current_Object_Path_File));
1711 -----------------------
1712 -- Set_Path_File_Var --
1713 -----------------------
1715 procedure Set_Path_File_Var (Name : String; Value : String) is
1716 Host_Spec : String_Access := To_Host_File_Spec (Value);
1718 if Host_Spec = null then
1720 ("could not convert file name """ & Value & """ to host spec");
1722 Setenv (Name, Host_Spec.all);
1725 end Set_Path_File_Var;
1727 ---------------------------
1728 -- Ultimate_Extension_Of --
1729 ---------------------------
1731 function Ultimate_Extension_Of
1732 (Project : Project_Id) return Project_Id
1734 Result : Project_Id;
1738 while Result.Extended_By /= No_Project loop
1739 Result := Result.Extended_By;
1743 end Ultimate_Extension_Of;