1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2012, 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 Makeutl; use Makeutl;
30 with Osint; use Osint;
31 with Output; use Output;
32 with Prj.Com; use Prj.Com;
36 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
38 package body Prj.Env is
40 Buffer_Initial : constant := 1_000;
41 -- Initial size of Buffer
43 Uninitialized_Prefix : constant String := '#' & Path_Separator;
44 -- Prefix to indicate that the project path has not been initialized yet.
45 -- Must be two characters long
47 No_Project_Default_Dir : constant String := "-";
48 -- Indicator in the project path to indicate that the default search
49 -- directories should not be added to the path
51 -----------------------
52 -- Local Subprograms --
53 -----------------------
55 package Source_Path_Table is new GNAT.Dynamic_Tables
56 (Table_Component_Type => Name_Id,
57 Table_Index_Type => Natural,
60 Table_Increment => 100);
61 -- A table to store the source dirs before creating the source path file
63 package Object_Path_Table is new GNAT.Dynamic_Tables
64 (Table_Component_Type => Path_Name_Type,
65 Table_Index_Type => Natural,
68 Table_Increment => 100);
69 -- A table to store the object dirs, before creating the object path file
71 procedure Add_To_Buffer
73 Buffer : in out String_Access;
74 Buffer_Last : in out Natural);
75 -- Add a string to Buffer, extending Buffer if needed
78 (Source_Dirs : String_List_Id;
79 Shared : Shared_Project_Tree_Data_Access;
80 Buffer : in out String_Access;
81 Buffer_Last : in out Natural);
82 -- Add to Ada_Path_Buffer all the source directories in string list
83 -- Source_Dirs, if any.
87 Buffer : in out String_Access;
88 Buffer_Last : in out Natural);
89 -- If Dir is not already in the global variable Ada_Path_Buffer, add it.
90 -- If Buffer_Last /= 0, prepend a Path_Separator character to Path.
92 procedure Add_To_Source_Path
93 (Source_Dirs : String_List_Id;
94 Shared : Shared_Project_Tree_Data_Access;
95 Source_Paths : in out Source_Path_Table.Instance);
96 -- Add to Ada_Path_B all the source directories in string list
97 -- Source_Dirs, if any. Increment Ada_Path_Length.
99 procedure Add_To_Object_Path
100 (Object_Dir : Path_Name_Type;
101 Object_Paths : in out Object_Path_Table.Instance);
102 -- Add Object_Dir to object path table. Make sure it is not duplicate
103 -- and it is the last one in the current table.
105 ----------------------
106 -- Ada_Include_Path --
107 ----------------------
109 function Ada_Include_Path
110 (Project : Project_Id;
111 In_Tree : Project_Tree_Ref;
112 Recursive : Boolean := False) return String
114 Buffer : String_Access;
115 Buffer_Last : Natural := 0;
118 (Project : Project_Id;
119 In_Tree : Project_Tree_Ref;
120 Dummy : in out Boolean);
121 -- Add source dirs of Project to the path
128 (Project : Project_Id;
129 In_Tree : Project_Tree_Ref;
130 Dummy : in out Boolean)
132 pragma Unreferenced (Dummy);
135 (Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last);
138 procedure For_All_Projects is
139 new For_Every_Project_Imported (Boolean, Add);
141 Dummy : Boolean := False;
143 -- Start of processing for Ada_Include_Path
148 -- If it is the first time we call this function for
149 -- this project, compute the source path
151 if Project.Ada_Include_Path = null then
152 Buffer := new String (1 .. 4096);
154 (Project, In_Tree, Dummy, Include_Aggregated => True);
155 Project.Ada_Include_Path := new String'(Buffer (1 .. Buffer_Last));
159 return Project.Ada_Include_Path.all;
162 Buffer := new String (1 .. 4096);
164 (Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last);
167 Result : constant String := Buffer (1 .. Buffer_Last);
173 end Ada_Include_Path;
175 ----------------------
176 -- Ada_Objects_Path --
177 ----------------------
179 function Ada_Objects_Path
180 (Project : Project_Id;
181 In_Tree : Project_Tree_Ref;
182 Including_Libraries : Boolean := True) return String_Access
184 Buffer : String_Access;
185 Buffer_Last : Natural := 0;
188 (Project : Project_Id;
189 In_Tree : Project_Tree_Ref;
190 Dummy : in out Boolean);
191 -- Add all the object directories of a project to the path
198 (Project : Project_Id;
199 In_Tree : Project_Tree_Ref;
200 Dummy : in out Boolean)
202 pragma Unreferenced (Dummy, In_Tree);
204 Path : constant Path_Name_Type :=
207 Including_Libraries => Including_Libraries,
208 Only_If_Ada => False);
210 if Path /= No_Path then
211 Add_To_Path (Get_Name_String (Path), Buffer, Buffer_Last);
215 procedure For_All_Projects is
216 new For_Every_Project_Imported (Boolean, Add);
218 Dummy : Boolean := False;
220 -- Start of processing for Ada_Objects_Path
223 -- If it is the first time we call this function for
224 -- this project, compute the objects path
226 if Project.Ada_Objects_Path = null then
227 Buffer := new String (1 .. 4096);
228 For_All_Projects (Project, In_Tree, Dummy);
230 Project.Ada_Objects_Path := new String'(Buffer (1 .. Buffer_Last));
234 return Project.Ada_Objects_Path;
235 end Ada_Objects_Path;
241 procedure Add_To_Buffer
243 Buffer : in out String_Access;
244 Buffer_Last : in out Natural)
246 Last : constant Natural := Buffer_Last + S'Length;
249 while Last > Buffer'Last loop
251 New_Buffer : constant String_Access :=
252 new String (1 .. 2 * Buffer'Last);
254 New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
256 Buffer := New_Buffer;
260 Buffer (Buffer_Last + 1 .. Last) := S;
264 ------------------------
265 -- Add_To_Object_Path --
266 ------------------------
268 procedure Add_To_Object_Path
269 (Object_Dir : Path_Name_Type;
270 Object_Paths : in out Object_Path_Table.Instance)
273 -- Check if the directory is already in the table
276 Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths)
279 -- If it is, remove it, and add it as the last one
281 if Object_Paths.Table (Index) = Object_Dir then
283 Index + 1 .. Object_Path_Table.Last (Object_Paths)
285 Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2);
289 (Object_Path_Table.Last (Object_Paths)) := Object_Dir;
294 -- The directory is not already in the table, add it
296 Object_Path_Table.Append (Object_Paths, Object_Dir);
297 end Add_To_Object_Path;
303 procedure Add_To_Path
304 (Source_Dirs : String_List_Id;
305 Shared : Shared_Project_Tree_Data_Access;
306 Buffer : in out String_Access;
307 Buffer_Last : in out Natural)
309 Current : String_List_Id := Source_Dirs;
310 Source_Dir : String_Element;
312 while Current /= Nil_String loop
313 Source_Dir := Shared.String_Elements.Table (Current);
314 Add_To_Path (Get_Name_String (Source_Dir.Display_Value),
315 Buffer, Buffer_Last);
316 Current := Source_Dir.Next;
320 procedure Add_To_Path
322 Buffer : in out String_Access;
323 Buffer_Last : in out Natural)
326 New_Buffer : String_Access;
329 function Is_Present (Path : String; Dir : String) return Boolean;
330 -- Return True if Dir is part of Path
336 function Is_Present (Path : String; Dir : String) return Boolean is
337 Last : constant Integer := Path'Last - Dir'Length + 1;
340 for J in Path'First .. Last loop
342 -- Note: the order of the conditions below is important, since
343 -- it ensures a minimal number of string comparisons.
346 or else Path (J - 1) = Path_Separator)
348 (J + Dir'Length > Path'Last
349 or else Path (J + Dir'Length) = Path_Separator)
350 and then Dir = Path (J .. J + Dir'Length - 1)
359 -- Start of processing for Add_To_Path
362 if Is_Present (Buffer (1 .. Buffer_Last), Dir) then
364 -- Dir is already in the path, nothing to do
369 Min_Len := Buffer_Last + Dir'Length;
371 if Buffer_Last > 0 then
373 -- Add 1 for the Path_Separator character
375 Min_Len := Min_Len + 1;
378 -- If Ada_Path_Buffer is too small, increase it
382 if Len < Min_Len then
385 exit when Len >= Min_Len;
388 New_Buffer := new String (1 .. Len);
389 New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
391 Buffer := New_Buffer;
394 if Buffer_Last > 0 then
395 Buffer_Last := Buffer_Last + 1;
396 Buffer (Buffer_Last) := Path_Separator;
399 Buffer (Buffer_Last + 1 .. Buffer_Last + Dir'Length) := Dir;
400 Buffer_Last := Buffer_Last + Dir'Length;
403 ------------------------
404 -- Add_To_Source_Path --
405 ------------------------
407 procedure Add_To_Source_Path
408 (Source_Dirs : String_List_Id;
409 Shared : Shared_Project_Tree_Data_Access;
410 Source_Paths : in out Source_Path_Table.Instance)
412 Current : String_List_Id := Source_Dirs;
413 Source_Dir : String_Element;
417 -- Add each source directory
419 while Current /= Nil_String loop
420 Source_Dir := Shared.String_Elements.Table (Current);
423 -- Check if the source directory is already in the table
426 Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths)
428 -- If it is already, no need to add it
430 if Source_Paths.Table (Index) = Source_Dir.Value then
437 Source_Path_Table.Append (Source_Paths, Source_Dir.Display_Value);
440 -- Next source directory
442 Current := Source_Dir.Next;
444 end Add_To_Source_Path;
446 --------------------------------
447 -- Create_Config_Pragmas_File --
448 --------------------------------
450 procedure Create_Config_Pragmas_File
451 (For_Project : Project_Id;
452 In_Tree : Project_Tree_Ref)
454 type Naming_Id is new Nat;
455 package Naming_Table is new GNAT.Dynamic_Tables
456 (Table_Component_Type => Lang_Naming_Data,
457 Table_Index_Type => Naming_Id,
458 Table_Low_Bound => 1,
460 Table_Increment => 100);
462 Default_Naming : constant Naming_Id := Naming_Table.First;
463 Namings : Naming_Table.Instance;
464 -- Table storing the naming data for gnatmake/gprmake
466 Buffer : String_Access := new String (1 .. Buffer_Initial);
467 Buffer_Last : Natural := 0;
469 File_Name : Path_Name_Type := No_Path;
470 File : File_Descriptor := Invalid_FD;
472 Current_Naming : Naming_Id;
475 (Project : Project_Id;
476 In_Tree : Project_Tree_Ref;
477 State : in out Integer);
478 -- Recursive procedure that put in the config pragmas file any non
479 -- standard naming schemes, if it is not already in the file, then call
480 -- itself for any imported project.
482 procedure Put (Source : Source_Id);
483 -- Put an SFN pragma in the temporary file
485 procedure Put (S : String);
486 procedure Put_Line (S : String);
487 -- Output procedures, analogous to normal Text_IO procs of same name.
488 -- The text is put in Buffer, then it will be written into a temporary
489 -- file with procedure Write_Temp_File below.
491 procedure Write_Temp_File;
492 -- Create a temporary file and put the content of the buffer in it
499 (Project : Project_Id;
500 In_Tree : Project_Tree_Ref;
501 State : in out Integer)
503 pragma Unreferenced (State);
505 Lang : constant Language_Ptr :=
506 Get_Language_From_Name (Project, "ada");
507 Naming : Lang_Naming_Data;
508 Iter : Source_Iterator;
512 if Current_Verbosity = High then
513 Debug_Output ("Checking project file:", Project.Name);
517 if Current_Verbosity = High then
518 Debug_Output ("Languages does not contain Ada, nothing to do");
524 -- Visit all the files and process those that need an SFN pragma
526 Iter := For_Each_Source (In_Tree, Project);
527 while Element (Iter) /= No_Source loop
528 Source := Element (Iter);
530 if not Source.Locally_Removed
531 and then Source.Unit /= null
533 (Source.Index >= 1 or else Source.Naming_Exception /= No)
541 Naming := Lang.Config.Naming_Data;
543 -- Is the naming scheme of this project one that we know?
545 Current_Naming := Default_Naming;
546 while Current_Naming <= Naming_Table.Last (Namings)
547 and then Namings.Table (Current_Naming).Dot_Replacement =
548 Naming.Dot_Replacement
549 and then Namings.Table (Current_Naming).Casing =
551 and then Namings.Table (Current_Naming).Separate_Suffix =
552 Naming.Separate_Suffix
554 Current_Naming := Current_Naming + 1;
557 -- If we don't know it, add it
559 if Current_Naming > Naming_Table.Last (Namings) then
560 Naming_Table.Increment_Last (Namings);
561 Namings.Table (Naming_Table.Last (Namings)) := Naming;
563 -- Put the SFN pragmas for the naming scheme
568 ("pragma Source_File_Name_Project");
570 (" (Spec_File_Name => ""*" &
571 Get_Name_String (Naming.Spec_Suffix) & """,");
574 Image (Naming.Casing) & ",");
576 (" Dot_Replacement => """ &
577 Get_Name_String (Naming.Dot_Replacement) & """);");
582 ("pragma Source_File_Name_Project");
584 (" (Body_File_Name => ""*" &
585 Get_Name_String (Naming.Body_Suffix) & """,");
588 Image (Naming.Casing) & ",");
590 (" Dot_Replacement => """ &
591 Get_Name_String (Naming.Dot_Replacement) &
594 -- and maybe separate
596 if Naming.Body_Suffix /= Naming.Separate_Suffix then
597 Put_Line ("pragma Source_File_Name_Project");
599 (" (Subunit_File_Name => ""*" &
600 Get_Name_String (Naming.Separate_Suffix) & """,");
603 Image (Naming.Casing) & ",");
605 (" Dot_Replacement => """ &
606 Get_Name_String (Naming.Dot_Replacement) &
616 procedure Put (Source : Source_Id) is
618 -- Put the pragma SFN for the unit kind (spec or body)
620 Put ("pragma Source_File_Name_Project (");
621 Put (Namet.Get_Name_String (Source.Unit.Name));
623 if Source.Kind = Spec then
624 Put (", Spec_File_Name => """);
626 Put (", Body_File_Name => """);
629 Put (Namet.Get_Name_String (Source.File));
632 if Source.Index /= 0 then
634 Put (Source.Index'Img);
640 procedure Put (S : String) is
642 Add_To_Buffer (S, Buffer, Buffer_Last);
644 if Current_Verbosity = High then
653 procedure Put_Line (S : String) is
655 -- Add an ASCII.LF to the string. As this config file is supposed to
656 -- be used only by the compiler, we don't care about the characters
657 -- for the end of line. In fact we could have put a space, but
658 -- it is more convenient to be able to read gnat.adc during
659 -- development, for which the ASCII.LF is fine.
662 Put (S => (1 => ASCII.LF));
665 ---------------------
666 -- Write_Temp_File --
667 ---------------------
669 procedure Write_Temp_File is
670 Status : Boolean := False;
674 Tempdir.Create_Temp_File (File, File_Name);
676 if File /= Invalid_FD then
677 Last := Write (File, Buffer (1)'Address, Buffer_Last);
679 if Last = Buffer_Last then
680 Close (File, Status);
685 Prj.Com.Fail ("unable to create temporary file");
689 procedure Check_Imported_Projects is
690 new For_Every_Project_Imported (Integer, Check);
692 Dummy : Integer := 0;
694 -- Start of processing for Create_Config_Pragmas_File
697 if not For_Project.Config_Checked then
698 Naming_Table.Init (Namings);
700 -- Check the naming schemes
702 Check_Imported_Projects
703 (For_Project, In_Tree, Dummy, Imported_First => False);
705 -- If there are no non standard naming scheme, issue the GNAT
706 -- standard naming scheme. This will tell the compiler that
707 -- a project file is used and will forbid any pragma SFN.
709 if Buffer_Last = 0 then
711 Put_Line ("pragma Source_File_Name_Project");
712 Put_Line (" (Spec_File_Name => ""*.ads"",");
713 Put_Line (" Dot_Replacement => ""-"",");
714 Put_Line (" Casing => lowercase);");
716 Put_Line ("pragma Source_File_Name_Project");
717 Put_Line (" (Body_File_Name => ""*.adb"",");
718 Put_Line (" Dot_Replacement => ""-"",");
719 Put_Line (" Casing => lowercase);");
722 -- Close the temporary file
726 if Opt.Verbose_Mode then
727 Write_Str ("Created configuration file """);
728 Write_Str (Get_Name_String (File_Name));
732 For_Project.Config_File_Name := File_Name;
733 For_Project.Config_File_Temp := True;
734 For_Project.Config_Checked := True;
738 end Create_Config_Pragmas_File;
744 procedure Create_Mapping (In_Tree : Project_Tree_Ref) is
746 Iter : Source_Iterator;
751 Iter := For_Each_Source (In_Tree);
753 Data := Element (Iter);
754 exit when Data = No_Source;
756 if Data.Unit /= No_Unit_Index then
757 if Data.Locally_Removed then
758 Fmap.Add_Forbidden_File_Name (Data.File);
761 (Unit_Name => Unit_Name_Type (Data.Unit.Name),
762 File_Name => Data.File,
763 Path_Name => File_Name_Type (Data.Path.Display_Name));
771 -------------------------
772 -- Create_Mapping_File --
773 -------------------------
775 procedure Create_Mapping_File
776 (Project : Project_Id;
778 In_Tree : Project_Tree_Ref;
779 Name : out Path_Name_Type)
781 File : File_Descriptor := Invalid_FD;
782 Buffer : String_Access := new String (1 .. Buffer_Initial);
783 Buffer_Last : Natural := 0;
785 procedure Put_Name_Buffer;
786 -- Put the line contained in the Name_Buffer in the global buffer
789 (Project : Project_Id;
790 In_Tree : Project_Tree_Ref;
791 State : in out Integer);
792 -- Generate the mapping file for Project (not recursively)
794 ---------------------
795 -- Put_Name_Buffer --
796 ---------------------
798 procedure Put_Name_Buffer is
800 if Current_Verbosity = High then
801 Debug_Output (Name_Buffer (1 .. Name_Len));
804 Name_Len := Name_Len + 1;
805 Name_Buffer (Name_Len) := ASCII.LF;
806 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
814 (Project : Project_Id;
815 In_Tree : Project_Tree_Ref;
816 State : in out Integer)
818 pragma Unreferenced (State);
821 Suffix : File_Name_Type;
822 Iter : Source_Iterator;
825 Debug_Output ("Add mapping for project", Project.Name);
826 Iter := For_Each_Source (In_Tree, Project, Language => Language);
829 Source := Prj.Element (Iter);
830 exit when Source = No_Source;
832 if Source.Replaced_By = No_Source
833 and then Source.Path.Name /= No_Path
834 and then (Source.Language.Config.Kind = File_Based
835 or else Source.Unit /= No_Unit_Index)
837 if Source.Unit /= No_Unit_Index then
839 -- Put the encoded unit name in the name buffer
842 Uname : constant String :=
843 Get_Name_String (Source.Unit.Name);
847 for J in Uname'Range loop
848 if Uname (J) in Upper_Half_Character then
849 Store_Encoded_Character (Get_Char_Code (Uname (J)));
851 Add_Char_To_Name_Buffer (Uname (J));
856 if Source.Language.Config.Kind = Unit_Based then
858 -- ??? Mapping_Spec_Suffix could be set in the case of
861 Add_Char_To_Name_Buffer ('%');
863 if Source.Kind = Spec then
864 Add_Char_To_Name_Buffer ('s');
866 Add_Char_To_Name_Buffer ('b');
873 Source.Language.Config.Mapping_Spec_Suffix;
876 Source.Language.Config.Mapping_Body_Suffix;
879 if Suffix /= No_File then
880 Add_Str_To_Name_Buffer (Get_Name_String (Suffix));
887 Get_Name_String (Source.Display_File);
890 if Source.Locally_Removed then
892 Name_Buffer (1) := '/';
894 Get_Name_String (Source.Path.Display_Name);
904 procedure For_Every_Imported_Project is new
905 For_Every_Project_Imported (State => Integer, Action => Process);
909 Dummy : Integer := 0;
911 -- Start of processing for Create_Mapping_File
914 if Current_Verbosity = High then
915 Debug_Output ("Create mapping file for", Debug_Name (In_Tree));
918 Create_Temp_File (In_Tree.Shared, File, Name, "mapping");
920 if Current_Verbosity = High then
921 Debug_Increase_Indent ("Create mapping file ", Name_Id (Name));
924 For_Every_Imported_Project
925 (Project, In_Tree, Dummy, Include_Aggregated => False);
929 Status : Boolean := False;
932 if File /= Invalid_FD then
933 Last := Write (File, Buffer (1)'Address, Buffer_Last);
935 if Last = Buffer_Last then
936 GNAT.OS_Lib.Close (File, Status);
941 Prj.Com.Fail ("could not write mapping file");
947 Debug_Decrease_Indent ("Done create mapping file");
948 end Create_Mapping_File;
950 ----------------------
951 -- Create_Temp_File --
952 ----------------------
954 procedure Create_Temp_File
955 (Shared : Shared_Project_Tree_Data_Access;
956 Path_FD : out File_Descriptor;
957 Path_Name : out Path_Name_Type;
961 Tempdir.Create_Temp_File (Path_FD, Path_Name);
963 if Path_Name /= No_Path then
964 if Current_Verbosity = High then
965 Write_Line ("Create temp file (" & File_Use & ") "
966 & Get_Name_String (Path_Name));
969 Record_Temp_File (Shared, Path_Name);
973 ("unable to create temporary " & File_Use & " file");
975 end Create_Temp_File;
977 --------------------------
978 -- Create_New_Path_File --
979 --------------------------
981 procedure Create_New_Path_File
982 (Shared : Shared_Project_Tree_Data_Access;
983 Path_FD : out File_Descriptor;
984 Path_Name : out Path_Name_Type)
987 Create_Temp_File (Shared, Path_FD, Path_Name, "path file");
988 end Create_New_Path_File;
990 ------------------------------------
991 -- File_Name_Of_Library_Unit_Body --
992 ------------------------------------
994 function File_Name_Of_Library_Unit_Body
996 Project : Project_Id;
997 In_Tree : Project_Tree_Ref;
998 Main_Project_Only : Boolean := True;
999 Full_Path : Boolean := False) return String
1002 Lang : constant Language_Ptr :=
1003 Get_Language_From_Name (Project, "ada");
1004 The_Project : Project_Id := Project;
1005 Original_Name : String := Name;
1008 The_Original_Name : Name_Id;
1009 The_Spec_Name : Name_Id;
1010 The_Body_Name : Name_Id;
1013 -- ??? Same block in Project_Of
1014 Canonical_Case_File_Name (Original_Name);
1015 Name_Len := Original_Name'Length;
1016 Name_Buffer (1 .. Name_Len) := Original_Name;
1017 The_Original_Name := Name_Find;
1019 if Lang /= null then
1021 Naming : constant Lang_Naming_Data := Lang.Config.Naming_Data;
1022 Extended_Spec_Name : String :=
1023 Name & Namet.Get_Name_String
1024 (Naming.Spec_Suffix);
1025 Extended_Body_Name : String :=
1026 Name & Namet.Get_Name_String
1027 (Naming.Body_Suffix);
1030 Canonical_Case_File_Name (Extended_Spec_Name);
1031 Name_Len := Extended_Spec_Name'Length;
1032 Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1033 The_Spec_Name := Name_Find;
1035 Canonical_Case_File_Name (Extended_Body_Name);
1036 Name_Len := Extended_Body_Name'Length;
1037 Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1038 The_Body_Name := Name_Find;
1042 Name_Len := Name'Length;
1043 Name_Buffer (1 .. Name_Len) := Name;
1044 Canonical_Case_File_Name (Name_Buffer);
1045 The_Spec_Name := Name_Find;
1046 The_Body_Name := The_Spec_Name;
1049 if Current_Verbosity = High then
1050 Write_Str ("Looking for file name of """);
1054 Write_Str (" Extended Spec Name = """);
1055 Write_Str (Get_Name_String (The_Spec_Name));
1058 Write_Str (" Extended Body Name = """);
1059 Write_Str (Get_Name_String (The_Body_Name));
1064 -- For extending project, search in the extended project if the source
1065 -- is not found. For non extending projects, this loop will be run only
1069 -- Loop through units
1071 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1072 while Unit /= null loop
1075 if not Main_Project_Only
1077 (Unit.File_Names (Impl) /= null
1078 and then Unit.File_Names (Impl).Project = The_Project)
1081 Current_Name : File_Name_Type;
1083 -- Case of a body present
1085 if Unit.File_Names (Impl) /= null then
1086 Current_Name := Unit.File_Names (Impl).File;
1088 if Current_Verbosity = High then
1089 Write_Str (" Comparing with """);
1090 Write_Str (Get_Name_String (Current_Name));
1095 -- If it has the name of the original name, return the
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 (Impl).Path.Name);
1111 return Get_Name_String (Current_Name);
1114 -- If it has the name of the extended body name,
1115 -- return the extended body name
1117 elsif Current_Name = File_Name_Type (The_Body_Name) then
1118 if Current_Verbosity = High then
1123 return Get_Name_String
1124 (Unit.File_Names (Impl).Path.Name);
1127 return Get_Name_String (The_Body_Name);
1131 if Current_Verbosity = High then
1132 Write_Line (" not good");
1141 if not Main_Project_Only
1142 or else (Unit.File_Names (Spec) /= null
1143 and then Unit.File_Names (Spec).Project = The_Project)
1146 Current_Name : File_Name_Type;
1149 -- Case of spec present
1151 if Unit.File_Names (Spec) /= null then
1152 Current_Name := Unit.File_Names (Spec).File;
1153 if Current_Verbosity = High then
1154 Write_Str (" Comparing with """);
1155 Write_Str (Get_Name_String (Current_Name));
1160 -- If name same as original name, return original name
1162 if Unit.Name = The_Original_Name
1164 Current_Name = File_Name_Type (The_Original_Name)
1166 if Current_Verbosity = High then
1171 return Get_Name_String
1172 (Unit.File_Names (Spec).Path.Name);
1174 return Get_Name_String (Current_Name);
1177 -- If it has the same name as the extended spec name,
1178 -- return the extended spec name.
1180 elsif Current_Name = File_Name_Type (The_Spec_Name) then
1181 if Current_Verbosity = High then
1186 return Get_Name_String
1187 (Unit.File_Names (Spec).Path.Name);
1189 return Get_Name_String (The_Spec_Name);
1193 if Current_Verbosity = High then
1194 Write_Line (" not good");
1201 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1204 -- If we are not in an extending project, give up
1206 exit when not Main_Project_Only
1207 or else The_Project.Extends = No_Project;
1209 -- Otherwise, look in the project we are extending
1211 The_Project := The_Project.Extends;
1214 -- We don't know this file name, return an empty string
1217 end File_Name_Of_Library_Unit_Body;
1219 -------------------------
1220 -- For_All_Object_Dirs --
1221 -------------------------
1223 procedure For_All_Object_Dirs
1224 (Project : Project_Id;
1225 Tree : Project_Tree_Ref)
1227 procedure For_Project
1229 Tree : Project_Tree_Ref;
1230 Dummy : in out Integer);
1231 -- Get all object directories of Prj
1237 procedure For_Project
1239 Tree : Project_Tree_Ref;
1240 Dummy : in out Integer)
1242 pragma Unreferenced (Dummy, Tree);
1245 -- ??? Set_Ada_Paths has a different behavior for library project
1246 -- files, should we have the same ?
1248 if Prj.Object_Directory /= No_Path_Information then
1249 Get_Name_String (Prj.Object_Directory.Display_Name);
1250 Action (Name_Buffer (1 .. Name_Len));
1254 procedure Get_Object_Dirs is
1255 new For_Every_Project_Imported (Integer, For_Project);
1256 Dummy : Integer := 1;
1258 -- Start of processing for For_All_Object_Dirs
1261 Get_Object_Dirs (Project, Tree, Dummy);
1262 end For_All_Object_Dirs;
1264 -------------------------
1265 -- For_All_Source_Dirs --
1266 -------------------------
1268 procedure For_All_Source_Dirs
1269 (Project : Project_Id;
1270 In_Tree : Project_Tree_Ref)
1272 procedure For_Project
1274 In_Tree : Project_Tree_Ref;
1275 Dummy : in out Integer);
1276 -- Get all object directories of Prj
1282 procedure For_Project
1284 In_Tree : Project_Tree_Ref;
1285 Dummy : in out Integer)
1287 pragma Unreferenced (Dummy);
1289 Current : String_List_Id := Prj.Source_Dirs;
1290 The_String : String_Element;
1293 -- If there are Ada sources, call action with the name of every
1294 -- source directory.
1296 if Has_Ada_Sources (Prj) then
1297 while Current /= Nil_String loop
1298 The_String := In_Tree.Shared.String_Elements.Table (Current);
1299 Action (Get_Name_String (The_String.Display_Value));
1300 Current := The_String.Next;
1305 procedure Get_Source_Dirs is
1306 new For_Every_Project_Imported (Integer, For_Project);
1307 Dummy : Integer := 1;
1309 -- Start of processing for For_All_Source_Dirs
1312 Get_Source_Dirs (Project, In_Tree, Dummy);
1313 end For_All_Source_Dirs;
1319 procedure Get_Reference
1320 (Source_File_Name : String;
1321 In_Tree : Project_Tree_Ref;
1322 Project : out Project_Id;
1323 Path : out Path_Name_Type)
1326 -- Body below could use some comments ???
1328 if Current_Verbosity > Default then
1329 Write_Str ("Getting Reference_Of (""");
1330 Write_Str (Source_File_Name);
1331 Write_Str (""") ... ");
1335 Original_Name : String := Source_File_Name;
1339 Canonical_Case_File_Name (Original_Name);
1340 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1342 while Unit /= null loop
1343 if Unit.File_Names (Spec) /= null
1344 and then not Unit.File_Names (Spec).Locally_Removed
1345 and then Unit.File_Names (Spec).File /= No_File
1347 (Namet.Get_Name_String
1348 (Unit.File_Names (Spec).File) = Original_Name
1349 or else (Unit.File_Names (Spec).Path /= No_Path_Information
1351 Namet.Get_Name_String
1352 (Unit.File_Names (Spec).Path.Name) =
1356 Ultimate_Extending_Project_Of
1357 (Unit.File_Names (Spec).Project);
1358 Path := Unit.File_Names (Spec).Path.Display_Name;
1360 if Current_Verbosity > Default then
1361 Write_Str ("Done: Spec.");
1367 elsif Unit.File_Names (Impl) /= null
1368 and then Unit.File_Names (Impl).File /= No_File
1369 and then not Unit.File_Names (Impl).Locally_Removed
1371 (Namet.Get_Name_String
1372 (Unit.File_Names (Impl).File) = Original_Name
1373 or else (Unit.File_Names (Impl).Path /= No_Path_Information
1374 and then Namet.Get_Name_String
1375 (Unit.File_Names (Impl).Path.Name) =
1379 Ultimate_Extending_Project_Of
1380 (Unit.File_Names (Impl).Project);
1381 Path := Unit.File_Names (Impl).Path.Display_Name;
1383 if Current_Verbosity > Default then
1384 Write_Str ("Done: Body.");
1391 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1395 Project := No_Project;
1398 if Current_Verbosity > Default then
1399 Write_Str ("Cannot be found.");
1404 ----------------------
1405 -- Get_Runtime_Path --
1406 ----------------------
1408 function Get_Runtime_Path
1409 (Self : Project_Search_Path;
1410 Name : String) return String_Access
1412 function Is_Base_Name (Path : String) return Boolean;
1413 -- Returns True if Path has no directory separator
1419 function Is_Base_Name (Path : String) return Boolean is
1421 for J in Path'Range loop
1422 if Path (J) = Directory_Separator or else Path (J) = '/' then
1430 function Find_Rts_In_Path is new Prj.Env.Find_Name_In_Path
1431 (Check_Filename => Is_Directory);
1433 -- Start of processing for Get_Runtime_Path
1436 if not Is_Base_Name (Name) then
1437 return Find_Rts_In_Path (Self, Name);
1441 end Get_Runtime_Path;
1447 procedure Initialize (In_Tree : Project_Tree_Ref) is
1449 In_Tree.Shared.Private_Part.Current_Source_Path_File := No_Path;
1450 In_Tree.Shared.Private_Part.Current_Object_Path_File := No_Path;
1457 -- Could use some comments in this body ???
1459 procedure Print_Sources (In_Tree : Project_Tree_Ref) is
1463 Write_Line ("List of Sources:");
1465 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1467 while Unit /= No_Unit_Index loop
1469 Write_Line (Namet.Get_Name_String (Unit.Name));
1471 if Unit.File_Names (Spec).File /= No_File then
1472 if Unit.File_Names (Spec).Project = No_Project then
1473 Write_Line (" No project");
1476 Write_Str (" Project: ");
1478 (Unit.File_Names (Spec).Project.Path.Name);
1479 Write_Line (Name_Buffer (1 .. Name_Len));
1482 Write_Str (" spec: ");
1484 (Namet.Get_Name_String
1485 (Unit.File_Names (Spec).File));
1488 if Unit.File_Names (Impl).File /= No_File then
1489 if Unit.File_Names (Impl).Project = No_Project then
1490 Write_Line (" No project");
1493 Write_Str (" Project: ");
1495 (Unit.File_Names (Impl).Project.Path.Name);
1496 Write_Line (Name_Buffer (1 .. Name_Len));
1499 Write_Str (" body: ");
1501 (Namet.Get_Name_String (Unit.File_Names (Impl).File));
1504 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1507 Write_Line ("end of List of Sources.");
1516 Main_Project : Project_Id;
1517 In_Tree : Project_Tree_Ref) return Project_Id
1519 Result : Project_Id := No_Project;
1521 Original_Name : String := Name;
1523 Lang : constant Language_Ptr :=
1524 Get_Language_From_Name (Main_Project, "ada");
1528 Current_Name : File_Name_Type;
1529 The_Original_Name : File_Name_Type;
1530 The_Spec_Name : File_Name_Type;
1531 The_Body_Name : File_Name_Type;
1534 -- ??? Same block in File_Name_Of_Library_Unit_Body
1535 Canonical_Case_File_Name (Original_Name);
1536 Name_Len := Original_Name'Length;
1537 Name_Buffer (1 .. Name_Len) := Original_Name;
1538 The_Original_Name := Name_Find;
1540 if Lang /= null then
1542 Naming : Lang_Naming_Data renames Lang.Config.Naming_Data;
1543 Extended_Spec_Name : String :=
1544 Name & Namet.Get_Name_String
1545 (Naming.Spec_Suffix);
1546 Extended_Body_Name : String :=
1547 Name & Namet.Get_Name_String
1548 (Naming.Body_Suffix);
1551 Canonical_Case_File_Name (Extended_Spec_Name);
1552 Name_Len := Extended_Spec_Name'Length;
1553 Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1554 The_Spec_Name := Name_Find;
1556 Canonical_Case_File_Name (Extended_Body_Name);
1557 Name_Len := Extended_Body_Name'Length;
1558 Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1559 The_Body_Name := Name_Find;
1563 The_Spec_Name := The_Original_Name;
1564 The_Body_Name := The_Original_Name;
1567 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1568 while Unit /= null loop
1570 -- Case of a body present
1572 if Unit.File_Names (Impl) /= null then
1573 Current_Name := Unit.File_Names (Impl).File;
1575 -- If it has the name of the original name or the body name,
1576 -- we have found the project.
1578 if Unit.Name = Name_Id (The_Original_Name)
1579 or else Current_Name = The_Original_Name
1580 or else Current_Name = The_Body_Name
1582 Result := Unit.File_Names (Impl).Project;
1589 if Unit.File_Names (Spec) /= null then
1590 Current_Name := Unit.File_Names (Spec).File;
1592 -- If name same as the original name, or the spec name, we have
1593 -- found the project.
1595 if Unit.Name = Name_Id (The_Original_Name)
1596 or else Current_Name = The_Original_Name
1597 or else Current_Name = The_Spec_Name
1599 Result := Unit.File_Names (Spec).Project;
1604 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1607 return Ultimate_Extending_Project_Of (Result);
1614 procedure Set_Ada_Paths
1615 (Project : Project_Id;
1616 In_Tree : Project_Tree_Ref;
1617 Including_Libraries : Boolean;
1618 Include_Path : Boolean := True;
1619 Objects_Path : Boolean := True)
1622 Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared;
1624 Source_Paths : Source_Path_Table.Instance;
1625 Object_Paths : Object_Path_Table.Instance;
1626 -- List of source or object dirs. Only computed the first time this
1627 -- procedure is called (since Source_FD is then reused)
1629 Source_FD : File_Descriptor := Invalid_FD;
1630 Object_FD : File_Descriptor := Invalid_FD;
1631 -- The temporary files to store the paths. These are only created the
1632 -- first time this procedure is called, and reused from then on.
1634 Process_Source_Dirs : Boolean := False;
1635 Process_Object_Dirs : Boolean := False;
1638 -- For calls to Close
1641 Buffer : String_Access := new String (1 .. Buffer_Initial);
1642 Buffer_Last : Natural := 0;
1644 procedure Recursive_Add
1645 (Project : Project_Id;
1646 In_Tree : Project_Tree_Ref;
1647 Dummy : in out Boolean);
1648 -- Recursive procedure to add the source/object paths of extended/
1649 -- imported projects.
1655 procedure Recursive_Add
1656 (Project : Project_Id;
1657 In_Tree : Project_Tree_Ref;
1658 Dummy : in out Boolean)
1660 pragma Unreferenced (Dummy, In_Tree);
1662 Path : Path_Name_Type;
1665 -- ??? This is almost the equivalent of For_All_Source_Dirs
1667 if Process_Source_Dirs then
1669 -- Add to path all source directories of this project if there are
1672 if Has_Ada_Sources (Project) then
1673 Add_To_Source_Path (Project.Source_Dirs, Shared, Source_Paths);
1677 if Process_Object_Dirs then
1678 Path := Get_Object_Directory
1680 Including_Libraries => Including_Libraries,
1681 Only_If_Ada => True);
1683 if Path /= No_Path then
1684 Add_To_Object_Path (Path, Object_Paths);
1689 procedure For_All_Projects is
1690 new For_Every_Project_Imported (Boolean, Recursive_Add);
1692 Dummy : Boolean := False;
1694 -- Start of processing for Set_Ada_Paths
1697 -- If it is the first time we call this procedure for this project,
1698 -- compute the source path and/or the object path.
1700 if Include_Path and then Project.Include_Path_File = No_Path then
1701 Source_Path_Table.Init (Source_Paths);
1702 Process_Source_Dirs := True;
1703 Create_New_Path_File (Shared, Source_FD, Project.Include_Path_File);
1706 -- For the object path, we make a distinction depending on
1707 -- Including_Libraries.
1709 if Objects_Path and Including_Libraries then
1710 if Project.Objects_Path_File_With_Libs = No_Path then
1711 Object_Path_Table.Init (Object_Paths);
1712 Process_Object_Dirs := True;
1713 Create_New_Path_File
1714 (Shared, Object_FD, Project.Objects_Path_File_With_Libs);
1717 elsif Objects_Path then
1718 if Project.Objects_Path_File_Without_Libs = No_Path then
1719 Object_Path_Table.Init (Object_Paths);
1720 Process_Object_Dirs := True;
1721 Create_New_Path_File
1722 (Shared, Object_FD, Project.Objects_Path_File_Without_Libs);
1726 -- If there is something to do, set Seen to False for all projects,
1727 -- then call the recursive procedure Add for Project.
1729 if Process_Source_Dirs or Process_Object_Dirs then
1730 For_All_Projects (Project, In_Tree, Dummy);
1733 -- Write and close any file that has been created. Source_FD is not set
1734 -- when this subprogram is called a second time or more, since we reuse
1735 -- the previous version of the file.
1737 if Source_FD /= Invalid_FD then
1741 Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths)
1743 Get_Name_String (Source_Paths.Table (Index));
1744 Name_Len := Name_Len + 1;
1745 Name_Buffer (Name_Len) := ASCII.LF;
1746 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1749 Last := Write (Source_FD, Buffer (1)'Address, Buffer_Last);
1751 if Last = Buffer_Last then
1752 Close (Source_FD, Status);
1759 Prj.Com.Fail ("could not write temporary file");
1763 if Object_FD /= Invalid_FD then
1767 Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths)
1769 Get_Name_String (Object_Paths.Table (Index));
1770 Name_Len := Name_Len + 1;
1771 Name_Buffer (Name_Len) := ASCII.LF;
1772 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1775 Last := Write (Object_FD, Buffer (1)'Address, Buffer_Last);
1777 if Last = Buffer_Last then
1778 Close (Object_FD, Status);
1784 Prj.Com.Fail ("could not write temporary file");
1788 -- Set the env vars, if they need to be changed, and set the
1789 -- corresponding flags.
1793 Shared.Private_Part.Current_Source_Path_File /=
1794 Project.Include_Path_File
1796 Shared.Private_Part.Current_Source_Path_File :=
1797 Project.Include_Path_File;
1799 (Project_Include_Path_File,
1800 Get_Name_String (Shared.Private_Part.Current_Source_Path_File));
1803 if Objects_Path then
1804 if Including_Libraries then
1805 if Shared.Private_Part.Current_Object_Path_File /=
1806 Project.Objects_Path_File_With_Libs
1808 Shared.Private_Part.Current_Object_Path_File :=
1809 Project.Objects_Path_File_With_Libs;
1811 (Project_Objects_Path_File,
1813 (Shared.Private_Part.Current_Object_Path_File));
1817 if Shared.Private_Part.Current_Object_Path_File /=
1818 Project.Objects_Path_File_Without_Libs
1820 Shared.Private_Part.Current_Object_Path_File :=
1821 Project.Objects_Path_File_Without_Libs;
1823 (Project_Objects_Path_File,
1825 (Shared.Private_Part.Current_Object_Path_File));
1833 ---------------------
1834 -- Add_Directories --
1835 ---------------------
1837 procedure Add_Directories
1838 (Self : in out Project_Search_Path;
1841 Tmp : String_Access;
1843 if Self.Path = null then
1844 Self.Path := new String'(Uninitialized_Prefix & Path);
1847 Self.Path := new String'(Tmp.all & Path_Separator & Path);
1851 if Current_Verbosity = High then
1852 Debug_Output ("Adding directories to Project_Path: """
1855 end Add_Directories;
1857 --------------------
1858 -- Is_Initialized --
1859 --------------------
1861 function Is_Initialized (Self : Project_Search_Path) return Boolean is
1863 return Self.Path /= null
1864 and then (Self.Path'Length = 0
1865 or else Self.Path (Self.Path'First) /= '#');
1868 ----------------------
1869 -- Initialize_Empty --
1870 ----------------------
1872 procedure Initialize_Empty (Self : in out Project_Search_Path) is
1875 Self.Path := new String'("");
1876 end Initialize_Empty;
1878 -------------------------------------
1879 -- Initialize_Default_Project_Path --
1880 -------------------------------------
1882 procedure Initialize_Default_Project_Path
1883 (Self : in out Project_Search_Path;
1884 Target_Name : String)
1886 Add_Default_Dir : Boolean := True;
1890 New_Last : Positive;
1892 Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
1893 Gpr_Project_Path : constant String := "GPR_PROJECT_PATH";
1894 -- Name of alternate env. variable that contain path name(s) of
1895 -- directories where project files may reside. GPR_PROJECT_PATH has
1896 -- precedence over ADA_PROJECT_PATH.
1898 Gpr_Prj_Path : String_Access;
1899 Ada_Prj_Path : String_Access;
1900 -- The path name(s) of directories where project files may reside.
1904 if Is_Initialized (Self) then
1908 -- The current directory is always first in the search path. Since the
1909 -- Project_Path currently starts with '#:' as a sign that it isn't
1910 -- initialized, we simply replace '#' with '.'
1912 if Self.Path = null then
1913 Self.Path := new String'('.' & Path_Separator);
1915 Self.Path (Self.Path'First) := '.';
1918 -- Then the reset of the project path (if any) currently contains the
1919 -- directories added through Add_Search_Project_Directory
1921 -- If environment variables are defined and not empty, add their content
1923 Gpr_Prj_Path := Getenv (Gpr_Project_Path);
1924 Ada_Prj_Path := Getenv (Ada_Project_Path);
1926 if Gpr_Prj_Path.all /= "" then
1927 Add_Directories (Self, Gpr_Prj_Path.all);
1930 Free (Gpr_Prj_Path);
1932 if Ada_Prj_Path.all /= "" then
1933 Add_Directories (Self, Ada_Prj_Path.all);
1936 Free (Ada_Prj_Path);
1938 -- Copy to Name_Buffer, since we will need to manipulate the path
1940 Name_Len := Self.Path'Length;
1941 Name_Buffer (1 .. Name_Len) := Self.Path.all;
1943 -- Scan the directory path to see if "-" is one of the directories.
1944 -- Remove each occurrence of "-" and set Add_Default_Dir to False.
1945 -- Also resolve relative paths and symbolic links.
1949 while First <= Name_Len
1950 and then (Name_Buffer (First) = Path_Separator)
1955 exit when First > Name_Len;
1959 while Last < Name_Len
1960 and then Name_Buffer (Last + 1) /= Path_Separator
1965 -- If the directory is "-", set Add_Default_Dir to False and
1966 -- remove from path.
1968 if Name_Buffer (First .. Last) = No_Project_Default_Dir then
1969 Add_Default_Dir := False;
1971 for J in Last + 1 .. Name_Len loop
1972 Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
1976 Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
1978 -- After removing the '-', go back one character to get the next
1979 -- directory correctly.
1983 elsif not Hostparm.OpenVMS
1984 or else not Is_Absolute_Path (Name_Buffer (First .. Last))
1986 -- On VMS, only expand relative path names, as absolute paths
1987 -- may correspond to multi-valued VMS logical names.
1990 New_Dir : constant String :=
1992 (Name_Buffer (First .. Last),
1993 Resolve_Links => Opt.Follow_Links_For_Dirs);
1996 -- If the absolute path was resolved and is different from
1997 -- the original, replace original with the resolved path.
1999 if New_Dir /= Name_Buffer (First .. Last)
2000 and then New_Dir'Length /= 0
2002 New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
2003 New_Last := First + New_Dir'Length - 1;
2004 Name_Buffer (New_Last + 1 .. New_Len) :=
2005 Name_Buffer (Last + 1 .. Name_Len);
2006 Name_Buffer (First .. New_Last) := New_Dir;
2007 Name_Len := New_Len;
2018 -- Set the initial value of Current_Project_Path
2020 if Add_Default_Dir then
2022 Prefix : String_Ptr;
2025 if Sdefault.Search_Dir_Prefix = null then
2029 Prefix := new String'(Executable_Prefix_Path);
2032 Prefix := new String'(Sdefault.Search_Dir_Prefix.all
2033 & ".." & Dir_Separator
2034 & ".." & Dir_Separator
2035 & ".." & Dir_Separator
2036 & ".." & Dir_Separator);
2039 if Prefix.all /= "" then
2040 if Target_Name /= "" then
2042 -- $prefix/$target/lib/gnat
2044 Add_Str_To_Name_Buffer
2045 (Path_Separator & Prefix.all &
2048 -- Note: Target_Name has a trailing / when it comes from
2051 if Name_Buffer (Name_Len) /= '/' then
2052 Add_Char_To_Name_Buffer (Directory_Separator);
2055 Add_Str_To_Name_Buffer
2056 ("lib" & Directory_Separator & "gnat");
2059 -- $prefix/share/gpr
2061 Add_Str_To_Name_Buffer
2062 (Path_Separator & Prefix.all &
2063 "share" & Directory_Separator & "gpr");
2067 Add_Str_To_Name_Buffer
2068 (Path_Separator & Prefix.all &
2069 "lib" & Directory_Separator & "gnat");
2076 Self.Path := new String'(Name_Buffer (1 .. Name_Len));
2077 end Initialize_Default_Project_Path;
2083 procedure Get_Path (Self : Project_Search_Path; Path : out String_Access) is
2085 pragma Assert (Is_Initialized (Self));
2093 procedure Set_Path (Self : in out Project_Search_Path; Path : String) is
2096 Self.Path := new String'(Path);
2097 Projects_Paths.Reset (Self.Cache);
2100 -----------------------
2101 -- Find_Name_In_Path --
2102 -----------------------
2104 function Find_Name_In_Path
2105 (Self : Project_Search_Path;
2106 Path : String) return String_Access
2112 if Current_Verbosity = High then
2113 Debug_Output ("Trying " & Path);
2116 if Is_Absolute_Path (Path) then
2117 if Check_Filename (Path) then
2118 return new String'(Path);
2124 -- Because we don't want to resolve symbolic links, we cannot use
2125 -- Locate_Regular_File. So, we try each possible path successively.
2127 First := Self.Path'First;
2128 while First <= Self.Path'Last loop
2129 while First <= Self.Path'Last
2130 and then Self.Path (First) = Path_Separator
2135 exit when First > Self.Path'Last;
2138 while Last < Self.Path'Last
2139 and then Self.Path (Last + 1) /= Path_Separator
2146 if not Is_Absolute_Path (Self.Path (First .. Last)) then
2147 Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call
2148 Add_Char_To_Name_Buffer (Directory_Separator);
2151 Add_Str_To_Name_Buffer (Self.Path (First .. Last));
2152 Add_Char_To_Name_Buffer (Directory_Separator);
2153 Add_Str_To_Name_Buffer (Path);
2155 if Current_Verbosity = High then
2156 Debug_Output ("Testing file " & Name_Buffer (1 .. Name_Len));
2159 if Check_Filename (Name_Buffer (1 .. Name_Len)) then
2160 return new String'(Name_Buffer (1 .. Name_Len));
2168 end Find_Name_In_Path;
2174 procedure Find_Project
2175 (Self : in out Project_Search_Path;
2176 Project_File_Name : String;
2178 Path : out Namet.Path_Name_Type)
2180 File : constant String := Project_File_Name;
2181 -- Have to do a copy, in case the parameter is Name_Buffer, which we
2184 function Try_Path_Name is new Find_Name_In_Path
2185 (Check_Filename => Is_Regular_File);
2186 -- Find a file in the project search path.
2188 -- Local Declarations
2190 Result : String_Access;
2191 Has_Dot : Boolean := False;
2194 -- Start of processing for Find_Project
2197 pragma Assert (Is_Initialized (Self));
2199 if Current_Verbosity = High then
2200 Debug_Increase_Indent
2201 ("Searching for project """ & File & """ in """
2205 -- Check the project cache
2207 Name_Len := File'Length;
2208 Name_Buffer (1 .. Name_Len) := File;
2210 Path := Projects_Paths.Get (Self.Cache, Key);
2212 if Path /= No_Path then
2213 Debug_Decrease_Indent;
2217 -- Check if File contains an extension (a dot before a
2218 -- directory separator). If it is the case we do not try project file
2219 -- with an added extension as it is not possible to have multiple dots
2220 -- on a project file name.
2222 Check_Dot : for K in reverse File'Range loop
2223 if File (K) = '.' then
2228 exit Check_Dot when File (K) = Directory_Separator
2229 or else File (K) = '/';
2232 if not Is_Absolute_Path (File) then
2234 -- First we try <directory>/<file_name>.<extension>
2237 Result := Try_Path_Name
2239 Directory & Directory_Separator &
2240 File & Project_File_Extension);
2243 -- Then we try <directory>/<file_name>
2245 if Result = null then
2246 Result := Try_Path_Name
2247 (Self, Directory & Directory_Separator & File);
2251 -- Then we try <file_name>.<extension>
2253 if Result = null and then not Has_Dot then
2254 Result := Try_Path_Name (Self, File & Project_File_Extension);
2257 -- Then we try <file_name>
2259 if Result = null then
2260 Result := Try_Path_Name (Self, File);
2263 -- If we cannot find the project file, we return an empty string
2265 if Result = null then
2266 Path := Namet.No_Path;
2271 Final_Result : constant String :=
2272 GNAT.OS_Lib.Normalize_Pathname
2274 Directory => Directory,
2275 Resolve_Links => Opt.Follow_Links_For_Files,
2276 Case_Sensitive => True);
2279 Name_Len := Final_Result'Length;
2280 Name_Buffer (1 .. Name_Len) := Final_Result;
2282 Projects_Paths.Set (Self.Cache, Key, Path);
2286 Debug_Decrease_Indent;
2293 procedure Free (Self : in out Project_Search_Path) is
2296 Projects_Paths.Reset (Self.Cache);
2303 procedure Copy (From : Project_Search_Path; To : out Project_Search_Path) is
2307 if From.Path /= null then
2308 To.Path := new String'(From.Path.all);
2311 -- No need to copy the Cache, it will be recomputed as needed