1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
27 with Makeutl; use Makeutl;
29 with Osint; use Osint;
30 with Output; use Output;
31 with Prj.Com; use Prj.Com;
35 with Ada.Text_IO; use Ada.Text_IO;
37 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
39 package body Prj.Env is
41 Buffer_Initial : constant := 1_000;
42 -- Initial arbitrary size of buffers
44 Uninitialized_Prefix : constant String := '#' & Path_Separator;
45 -- Prefix to indicate that the project path has not been initialized yet.
46 -- Must be two characters long
48 No_Project_Default_Dir : constant String := "-";
49 -- Indicator in the project path to indicate that the default search
50 -- directories should not be added to the path
52 -----------------------
53 -- Local Subprograms --
54 -----------------------
56 package Source_Path_Table is new GNAT.Dynamic_Tables
57 (Table_Component_Type => Name_Id,
58 Table_Index_Type => Natural,
61 Table_Increment => 100);
62 -- A table to store the source dirs before creating the source path file
64 package Object_Path_Table is new GNAT.Dynamic_Tables
65 (Table_Component_Type => Path_Name_Type,
66 Table_Index_Type => Natural,
69 Table_Increment => 100);
70 -- A table to store the object dirs, before creating the object path file
72 procedure Add_To_Buffer
74 Buffer : in out String_Access;
75 Buffer_Last : in out Natural);
76 -- Add a string to Buffer, extending Buffer if needed
79 (Source_Dirs : String_List_Id;
80 Shared : Shared_Project_Tree_Data_Access;
81 Buffer : in out String_Access;
82 Buffer_Last : in out Natural);
83 -- Add to Ada_Path_Buffer all the source directories in string list
84 -- Source_Dirs, if any.
88 Buffer : in out String_Access;
89 Buffer_Last : in out Natural);
90 -- If Dir is not already in the global variable Ada_Path_Buffer, add it.
91 -- If Buffer_Last /= 0, prepend a Path_Separator character to Path.
93 procedure Add_To_Source_Path
94 (Source_Dirs : String_List_Id;
95 Shared : Shared_Project_Tree_Data_Access;
96 Source_Paths : in out Source_Path_Table.Instance);
97 -- Add to Ada_Path_B all the source directories in string list
98 -- Source_Dirs, if any. Increment Ada_Path_Length.
100 procedure Add_To_Object_Path
101 (Object_Dir : Path_Name_Type;
102 Object_Paths : in out Object_Path_Table.Instance);
103 -- Add Object_Dir to object path table. Make sure it is not duplicate
104 -- and it is the last one in the current table.
106 ----------------------
107 -- Ada_Include_Path --
108 ----------------------
110 function Ada_Include_Path
111 (Project : Project_Id;
112 In_Tree : Project_Tree_Ref;
113 Recursive : Boolean := False) return String
115 Buffer : String_Access;
116 Buffer_Last : Natural := 0;
119 (Project : Project_Id;
120 In_Tree : Project_Tree_Ref;
121 Dummy : in out Boolean);
122 -- Add source dirs of Project to the path
129 (Project : Project_Id;
130 In_Tree : Project_Tree_Ref;
131 Dummy : in out Boolean)
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 this project,
149 -- compute the source path.
151 if Project.Ada_Include_Path = null then
152 Buffer := new String (1 .. Buffer_Initial);
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 .. Buffer_Initial);
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 (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 Result : String_Access;
222 -- Start of processing for Ada_Objects_Path
225 -- If it is the first time we call this function for
226 -- this project, compute the objects path
228 if Including_Libraries and then Project.Ada_Objects_Path /= null then
229 return Project.Ada_Objects_Path;
231 elsif not Including_Libraries
232 and then Project.Ada_Objects_Path_No_Libs /= null
234 return Project.Ada_Objects_Path_No_Libs;
237 Buffer := new String (1 .. Buffer_Initial);
238 For_All_Projects (Project, In_Tree, Dummy);
239 Result := new String'(Buffer (1 .. Buffer_Last));
242 if Including_Libraries then
243 Project.Ada_Objects_Path := Result;
245 Project.Ada_Objects_Path_No_Libs := Result;
250 end Ada_Objects_Path;
256 procedure Add_To_Buffer
258 Buffer : in out String_Access;
259 Buffer_Last : in out Natural)
261 Last : constant Natural := Buffer_Last + S'Length;
264 while Last > Buffer'Last loop
266 New_Buffer : constant String_Access :=
267 new String (1 .. 2 * Buffer'Last);
269 New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
271 Buffer := New_Buffer;
275 Buffer (Buffer_Last + 1 .. Last) := S;
279 ------------------------
280 -- Add_To_Object_Path --
281 ------------------------
283 procedure Add_To_Object_Path
284 (Object_Dir : Path_Name_Type;
285 Object_Paths : in out Object_Path_Table.Instance)
288 -- Check if the directory is already in the table
291 Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths)
293 -- If it is, remove it, and add it as the last one
295 if Object_Paths.Table (Index) = Object_Dir then
297 Index + 1 .. Object_Path_Table.Last (Object_Paths)
299 Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2);
303 (Object_Path_Table.Last (Object_Paths)) := Object_Dir;
308 -- The directory is not already in the table, add it
310 Object_Path_Table.Append (Object_Paths, Object_Dir);
311 end Add_To_Object_Path;
317 procedure Add_To_Path
318 (Source_Dirs : String_List_Id;
319 Shared : Shared_Project_Tree_Data_Access;
320 Buffer : in out String_Access;
321 Buffer_Last : in out Natural)
323 Current : String_List_Id;
324 Source_Dir : String_Element;
326 Current := Source_Dirs;
327 while Current /= Nil_String loop
328 Source_Dir := Shared.String_Elements.Table (Current);
329 Add_To_Path (Get_Name_String (Source_Dir.Display_Value),
330 Buffer, Buffer_Last);
331 Current := Source_Dir.Next;
335 procedure Add_To_Path
337 Buffer : in out String_Access;
338 Buffer_Last : in out Natural)
341 New_Buffer : String_Access;
344 function Is_Present (Path : String; Dir : String) return Boolean;
345 -- Return True if Dir is part of Path
351 function Is_Present (Path : String; Dir : String) return Boolean is
352 Last : constant Integer := Path'Last - Dir'Length + 1;
355 for J in Path'First .. Last loop
357 -- Note: the order of the conditions below is important, since
358 -- it ensures a minimal number of string comparisons.
360 if (J = Path'First or else Path (J - 1) = Path_Separator)
362 (J + Dir'Length > Path'Last
363 or else Path (J + Dir'Length) = Path_Separator)
364 and then Dir = Path (J .. J + Dir'Length - 1)
373 -- Start of processing for Add_To_Path
376 if Is_Present (Buffer (1 .. Buffer_Last), Dir) then
378 -- Dir is already in the path, nothing to do
383 Min_Len := Buffer_Last + Dir'Length;
385 if Buffer_Last > 0 then
387 -- Add 1 for the Path_Separator character
389 Min_Len := Min_Len + 1;
392 -- If Ada_Path_Buffer is too small, increase it
396 if Len < Min_Len then
399 exit when Len >= Min_Len;
402 New_Buffer := new String (1 .. Len);
403 New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
405 Buffer := New_Buffer;
408 if Buffer_Last > 0 then
409 Buffer_Last := Buffer_Last + 1;
410 Buffer (Buffer_Last) := Path_Separator;
413 Buffer (Buffer_Last + 1 .. Buffer_Last + Dir'Length) := Dir;
414 Buffer_Last := Buffer_Last + Dir'Length;
417 ------------------------
418 -- Add_To_Source_Path --
419 ------------------------
421 procedure Add_To_Source_Path
422 (Source_Dirs : String_List_Id;
423 Shared : Shared_Project_Tree_Data_Access;
424 Source_Paths : in out Source_Path_Table.Instance)
426 Current : String_List_Id;
427 Source_Dir : String_Element;
431 -- Add each source directory
433 Current := Source_Dirs;
434 while Current /= Nil_String loop
435 Source_Dir := Shared.String_Elements.Table (Current);
438 -- Check if the source directory is already in the table
441 Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths)
443 -- If it is already, no need to add it
445 if Source_Paths.Table (Index) = Source_Dir.Value then
452 Source_Path_Table.Append (Source_Paths, Source_Dir.Display_Value);
455 -- Next source directory
457 Current := Source_Dir.Next;
459 end Add_To_Source_Path;
461 --------------------------------
462 -- Create_Config_Pragmas_File --
463 --------------------------------
465 procedure Create_Config_Pragmas_File
466 (For_Project : Project_Id;
467 In_Tree : Project_Tree_Ref)
469 type Naming_Id is new Nat;
470 package Naming_Table is new GNAT.Dynamic_Tables
471 (Table_Component_Type => Lang_Naming_Data,
472 Table_Index_Type => Naming_Id,
473 Table_Low_Bound => 1,
475 Table_Increment => 100);
477 Default_Naming : constant Naming_Id := Naming_Table.First;
478 Namings : Naming_Table.Instance;
479 -- Table storing the naming data for gnatmake/gprmake
481 Buffer : String_Access := new String (1 .. Buffer_Initial);
482 Buffer_Last : Natural := 0;
484 File_Name : Path_Name_Type := No_Path;
485 File : File_Descriptor := Invalid_FD;
487 Current_Naming : Naming_Id;
490 (Project : Project_Id;
491 In_Tree : Project_Tree_Ref;
492 State : in out Integer);
493 -- Recursive procedure that put in the config pragmas file any non
494 -- standard naming schemes, if it is not already in the file, then call
495 -- itself for any imported project.
497 procedure Put (Source : Source_Id);
498 -- Put an SFN pragma in the temporary file
500 procedure Put (S : String);
501 procedure Put_Line (S : String);
502 -- Output procedures, analogous to normal Text_IO procs of same name.
503 -- The text is put in Buffer, then it will be written into a temporary
504 -- file with procedure Write_Temp_File below.
506 procedure Write_Temp_File;
507 -- Create a temporary file and put the content of the buffer in it
514 (Project : Project_Id;
515 In_Tree : Project_Tree_Ref;
516 State : in out Integer)
518 pragma Unreferenced (State);
520 Lang : constant Language_Ptr :=
521 Get_Language_From_Name (Project, "ada");
522 Naming : Lang_Naming_Data;
523 Iter : Source_Iterator;
527 if Current_Verbosity = High then
528 Debug_Output ("Checking project file:", Project.Name);
532 if Current_Verbosity = High then
533 Debug_Output ("Languages does not contain Ada, nothing to do");
539 -- Visit all the files and process those that need an SFN pragma
541 Iter := For_Each_Source (In_Tree, Project);
542 while Element (Iter) /= No_Source loop
543 Source := Element (Iter);
545 if not Source.Locally_Removed
546 and then Source.Unit /= null
548 (Source.Index >= 1 or else Source.Naming_Exception /= No)
556 Naming := Lang.Config.Naming_Data;
558 -- Is the naming scheme of this project one that we know?
560 Current_Naming := Default_Naming;
561 while Current_Naming <= Naming_Table.Last (Namings)
562 and then Namings.Table (Current_Naming).Dot_Replacement =
563 Naming.Dot_Replacement
564 and then Namings.Table (Current_Naming).Casing =
566 and then Namings.Table (Current_Naming).Separate_Suffix =
567 Naming.Separate_Suffix
569 Current_Naming := Current_Naming + 1;
572 -- If we don't know it, add it
574 if Current_Naming > Naming_Table.Last (Namings) then
575 Naming_Table.Increment_Last (Namings);
576 Namings.Table (Naming_Table.Last (Namings)) := Naming;
578 -- Put the SFN pragmas for the naming scheme
583 ("pragma Source_File_Name_Project");
585 (" (Spec_File_Name => ""*" &
586 Get_Name_String (Naming.Spec_Suffix) & """,");
589 Image (Naming.Casing) & ",");
591 (" Dot_Replacement => """ &
592 Get_Name_String (Naming.Dot_Replacement) & """);");
597 ("pragma Source_File_Name_Project");
599 (" (Body_File_Name => ""*" &
600 Get_Name_String (Naming.Body_Suffix) & """,");
603 Image (Naming.Casing) & ",");
605 (" Dot_Replacement => """ &
606 Get_Name_String (Naming.Dot_Replacement) &
609 -- and maybe separate
611 if Naming.Body_Suffix /= Naming.Separate_Suffix then
612 Put_Line ("pragma Source_File_Name_Project");
614 (" (Subunit_File_Name => ""*" &
615 Get_Name_String (Naming.Separate_Suffix) & """,");
618 Image (Naming.Casing) & ",");
620 (" Dot_Replacement => """ &
621 Get_Name_String (Naming.Dot_Replacement) &
631 procedure Put (Source : Source_Id) is
633 -- Put the pragma SFN for the unit kind (spec or body)
635 Put ("pragma Source_File_Name_Project (");
636 Put (Namet.Get_Name_String (Source.Unit.Name));
638 if Source.Kind = Spec then
639 Put (", Spec_File_Name => """);
641 Put (", Body_File_Name => """);
644 Put (Namet.Get_Name_String (Source.File));
647 if Source.Index /= 0 then
649 Put (Source.Index'Img);
655 procedure Put (S : String) is
657 Add_To_Buffer (S, Buffer, Buffer_Last);
659 if Current_Verbosity = High then
668 procedure Put_Line (S : String) is
670 -- Add an ASCII.LF to the string. As this config file is supposed to
671 -- be used only by the compiler, we don't care about the characters
672 -- for the end of line. In fact we could have put a space, but
673 -- it is more convenient to be able to read gnat.adc during
674 -- development, for which the ASCII.LF is fine.
677 Put (S => (1 => ASCII.LF));
680 ---------------------
681 -- Write_Temp_File --
682 ---------------------
684 procedure Write_Temp_File is
685 Status : Boolean := False;
689 Tempdir.Create_Temp_File (File, File_Name);
691 if File /= Invalid_FD then
692 Last := Write (File, Buffer (1)'Address, Buffer_Last);
694 if Last = Buffer_Last then
695 Close (File, Status);
700 Prj.Com.Fail ("unable to create temporary file");
704 procedure Check_Imported_Projects is
705 new For_Every_Project_Imported (Integer, Check);
707 Dummy : Integer := 0;
709 -- Start of processing for Create_Config_Pragmas_File
712 if not For_Project.Config_Checked then
713 Naming_Table.Init (Namings);
715 -- Check the naming schemes
717 Check_Imported_Projects
718 (For_Project, In_Tree, Dummy, Imported_First => False);
720 -- If there are no non standard naming scheme, issue the GNAT
721 -- standard naming scheme. This will tell the compiler that
722 -- a project file is used and will forbid any pragma SFN.
724 if Buffer_Last = 0 then
726 Put_Line ("pragma Source_File_Name_Project");
727 Put_Line (" (Spec_File_Name => ""*.ads"",");
728 Put_Line (" Dot_Replacement => ""-"",");
729 Put_Line (" Casing => lowercase);");
731 Put_Line ("pragma Source_File_Name_Project");
732 Put_Line (" (Body_File_Name => ""*.adb"",");
733 Put_Line (" Dot_Replacement => ""-"",");
734 Put_Line (" Casing => lowercase);");
737 -- Close the temporary file
741 if Opt.Verbose_Mode then
742 Write_Str ("Created configuration file """);
743 Write_Str (Get_Name_String (File_Name));
747 For_Project.Config_File_Name := File_Name;
748 For_Project.Config_File_Temp := True;
749 For_Project.Config_Checked := True;
753 end Create_Config_Pragmas_File;
759 procedure Create_Mapping (In_Tree : Project_Tree_Ref) is
761 Iter : Source_Iterator;
766 Iter := For_Each_Source (In_Tree);
768 Data := Element (Iter);
769 exit when Data = No_Source;
771 if Data.Unit /= No_Unit_Index then
772 if Data.Locally_Removed and then not Data.Suppressed then
773 Fmap.Add_Forbidden_File_Name (Data.File);
776 (Unit_Name => Unit_Name_Type (Data.Unit.Name),
777 File_Name => Data.File,
778 Path_Name => File_Name_Type (Data.Path.Display_Name));
786 -------------------------
787 -- Create_Mapping_File --
788 -------------------------
790 procedure Create_Mapping_File
791 (Project : Project_Id;
793 In_Tree : Project_Tree_Ref;
794 Name : out Path_Name_Type)
796 File : File_Descriptor := Invalid_FD;
797 Buffer : String_Access := new String (1 .. Buffer_Initial);
798 Buffer_Last : Natural := 0;
800 procedure Put_Name_Buffer;
801 -- Put the line contained in the Name_Buffer in the global buffer
804 (Project : Project_Id;
805 In_Tree : Project_Tree_Ref;
806 State : in out Integer);
807 -- Generate the mapping file for Project (not recursively)
809 ---------------------
810 -- Put_Name_Buffer --
811 ---------------------
813 procedure Put_Name_Buffer is
815 if Current_Verbosity = High then
816 Debug_Output (Name_Buffer (1 .. Name_Len));
819 Name_Len := Name_Len + 1;
820 Name_Buffer (Name_Len) := ASCII.LF;
821 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
829 (Project : Project_Id;
830 In_Tree : Project_Tree_Ref;
831 State : in out Integer)
833 pragma Unreferenced (State);
836 Suffix : File_Name_Type;
837 Iter : Source_Iterator;
840 Debug_Output ("Add mapping for project", Project.Name);
841 Iter := For_Each_Source (In_Tree, Project, Language => Language);
844 Source := Prj.Element (Iter);
845 exit when Source = No_Source;
847 if not Source.Suppressed
848 and then Source.Replaced_By = No_Source
849 and then Source.Path.Name /= No_Path
850 and then (Source.Language.Config.Kind = File_Based
851 or else Source.Unit /= No_Unit_Index)
853 if Source.Unit /= No_Unit_Index then
855 -- Put the encoded unit name in the name buffer
858 Uname : constant String :=
859 Get_Name_String (Source.Unit.Name);
863 for J in Uname'Range loop
864 if Uname (J) in Upper_Half_Character then
865 Store_Encoded_Character (Get_Char_Code (Uname (J)));
867 Add_Char_To_Name_Buffer (Uname (J));
872 if Source.Language.Config.Kind = Unit_Based then
874 -- ??? Mapping_Spec_Suffix could be set in the case of
877 Add_Char_To_Name_Buffer ('%');
879 if Source.Kind = Spec then
880 Add_Char_To_Name_Buffer ('s');
882 Add_Char_To_Name_Buffer ('b');
889 Source.Language.Config.Mapping_Spec_Suffix;
895 Source.Language.Config.Mapping_Body_Suffix;
898 if Suffix /= No_File then
899 Add_Str_To_Name_Buffer (Get_Name_String (Suffix));
906 Get_Name_String (Source.Display_File);
909 if Source.Locally_Removed then
911 Name_Buffer (1) := '/';
913 Get_Name_String (Source.Path.Display_Name);
923 procedure For_Every_Imported_Project is new
924 For_Every_Project_Imported (State => Integer, Action => Process);
928 Dummy : Integer := 0;
930 -- Start of processing for Create_Mapping_File
933 if Current_Verbosity = High then
934 Debug_Output ("Create mapping file for", Debug_Name (In_Tree));
937 Create_Temp_File (In_Tree.Shared, File, Name, "mapping");
939 if Current_Verbosity = High then
940 Debug_Increase_Indent ("Create mapping file ", Name_Id (Name));
943 For_Every_Imported_Project
944 (Project, In_Tree, Dummy, Include_Aggregated => False);
948 Status : Boolean := False;
951 if File /= Invalid_FD then
952 Last := Write (File, Buffer (1)'Address, Buffer_Last);
954 if Last = Buffer_Last then
955 GNAT.OS_Lib.Close (File, Status);
960 Prj.Com.Fail ("could not write mapping file");
966 Debug_Decrease_Indent ("Done create mapping file");
967 end Create_Mapping_File;
969 ----------------------
970 -- Create_Temp_File --
971 ----------------------
973 procedure Create_Temp_File
974 (Shared : Shared_Project_Tree_Data_Access;
975 Path_FD : out File_Descriptor;
976 Path_Name : out Path_Name_Type;
980 Tempdir.Create_Temp_File (Path_FD, Path_Name);
982 if Path_Name /= No_Path then
983 if Current_Verbosity = High then
984 Write_Line ("Create temp file (" & File_Use & ") "
985 & Get_Name_String (Path_Name));
988 Record_Temp_File (Shared, Path_Name);
992 ("unable to create temporary " & File_Use & " file");
994 end Create_Temp_File;
996 --------------------------
997 -- Create_New_Path_File --
998 --------------------------
1000 procedure Create_New_Path_File
1001 (Shared : Shared_Project_Tree_Data_Access;
1002 Path_FD : out File_Descriptor;
1003 Path_Name : out Path_Name_Type)
1006 Create_Temp_File (Shared, Path_FD, Path_Name, "path file");
1007 end Create_New_Path_File;
1009 ------------------------------------
1010 -- File_Name_Of_Library_Unit_Body --
1011 ------------------------------------
1013 function File_Name_Of_Library_Unit_Body
1015 Project : Project_Id;
1016 In_Tree : Project_Tree_Ref;
1017 Main_Project_Only : Boolean := True;
1018 Full_Path : Boolean := False) return String
1021 Lang : constant Language_Ptr :=
1022 Get_Language_From_Name (Project, "ada");
1023 The_Project : Project_Id := Project;
1024 Original_Name : String := Name;
1027 The_Original_Name : Name_Id;
1028 The_Spec_Name : Name_Id;
1029 The_Body_Name : Name_Id;
1032 -- ??? Same block in Project_Of
1033 Canonical_Case_File_Name (Original_Name);
1034 Name_Len := Original_Name'Length;
1035 Name_Buffer (1 .. Name_Len) := Original_Name;
1036 The_Original_Name := Name_Find;
1038 if Lang /= null then
1040 Naming : constant Lang_Naming_Data := Lang.Config.Naming_Data;
1041 Extended_Spec_Name : String :=
1042 Name & Namet.Get_Name_String
1043 (Naming.Spec_Suffix);
1044 Extended_Body_Name : String :=
1045 Name & Namet.Get_Name_String
1046 (Naming.Body_Suffix);
1049 Canonical_Case_File_Name (Extended_Spec_Name);
1050 Name_Len := Extended_Spec_Name'Length;
1051 Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1052 The_Spec_Name := Name_Find;
1054 Canonical_Case_File_Name (Extended_Body_Name);
1055 Name_Len := Extended_Body_Name'Length;
1056 Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1057 The_Body_Name := Name_Find;
1061 Name_Len := Name'Length;
1062 Name_Buffer (1 .. Name_Len) := Name;
1063 Canonical_Case_File_Name (Name_Buffer);
1064 The_Spec_Name := Name_Find;
1065 The_Body_Name := The_Spec_Name;
1068 if Current_Verbosity = High then
1069 Write_Str ("Looking for file name of """);
1073 Write_Str (" Extended Spec Name = """);
1074 Write_Str (Get_Name_String (The_Spec_Name));
1077 Write_Str (" Extended Body Name = """);
1078 Write_Str (Get_Name_String (The_Body_Name));
1083 -- For extending project, search in the extended project if the source
1084 -- is not found. For non extending projects, this loop will be run only
1088 -- Loop through units
1090 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1091 while Unit /= null loop
1095 if not Main_Project_Only
1097 (Unit.File_Names (Impl) /= null
1098 and then Unit.File_Names (Impl).Project = The_Project)
1101 Current_Name : File_Name_Type;
1104 -- Case of a body present
1106 if Unit.File_Names (Impl) /= null then
1107 Current_Name := Unit.File_Names (Impl).File;
1109 if Current_Verbosity = High then
1110 Write_Str (" Comparing with """);
1111 Write_Str (Get_Name_String (Current_Name));
1116 -- If it has the name of the original name, return the
1119 if Unit.Name = The_Original_Name
1121 Current_Name = File_Name_Type (The_Original_Name)
1123 if Current_Verbosity = High then
1128 return Get_Name_String
1129 (Unit.File_Names (Impl).Path.Name);
1132 return Get_Name_String (Current_Name);
1135 -- If it has the name of the extended body name,
1136 -- return the extended body name
1138 elsif Current_Name = File_Name_Type (The_Body_Name) then
1139 if Current_Verbosity = High then
1144 return Get_Name_String
1145 (Unit.File_Names (Impl).Path.Name);
1148 return Get_Name_String (The_Body_Name);
1152 if Current_Verbosity = High then
1153 Write_Line (" not good");
1162 if not Main_Project_Only
1163 or else (Unit.File_Names (Spec) /= null
1164 and then Unit.File_Names (Spec).Project = The_Project)
1167 Current_Name : File_Name_Type;
1170 -- Case of spec present
1172 if Unit.File_Names (Spec) /= null then
1173 Current_Name := Unit.File_Names (Spec).File;
1174 if Current_Verbosity = High then
1175 Write_Str (" Comparing with """);
1176 Write_Str (Get_Name_String (Current_Name));
1181 -- If name same as original name, return original name
1183 if Unit.Name = The_Original_Name
1185 Current_Name = File_Name_Type (The_Original_Name)
1187 if Current_Verbosity = High then
1192 return Get_Name_String
1193 (Unit.File_Names (Spec).Path.Name);
1195 return Get_Name_String (Current_Name);
1198 -- If it has the same name as the extended spec name,
1199 -- return the extended spec name.
1201 elsif Current_Name = File_Name_Type (The_Spec_Name) then
1202 if Current_Verbosity = High then
1207 return Get_Name_String
1208 (Unit.File_Names (Spec).Path.Name);
1210 return Get_Name_String (The_Spec_Name);
1214 if Current_Verbosity = High then
1215 Write_Line (" not good");
1222 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1225 -- If we are not in an extending project, give up
1227 exit when not Main_Project_Only
1228 or else The_Project.Extends = No_Project;
1230 -- Otherwise, look in the project we are extending
1232 The_Project := The_Project.Extends;
1235 -- We don't know this file name, return an empty string
1238 end File_Name_Of_Library_Unit_Body;
1240 -------------------------
1241 -- For_All_Object_Dirs --
1242 -------------------------
1244 procedure For_All_Object_Dirs
1245 (Project : Project_Id;
1246 Tree : Project_Tree_Ref)
1248 procedure For_Project
1250 Tree : Project_Tree_Ref;
1251 Dummy : in out Integer);
1252 -- Get all object directories of Prj
1258 procedure For_Project
1260 Tree : Project_Tree_Ref;
1261 Dummy : in out Integer)
1263 pragma Unreferenced (Tree);
1266 -- ??? Set_Ada_Paths has a different behavior for library project
1267 -- files, should we have the same ?
1269 if Prj.Object_Directory /= No_Path_Information then
1270 Get_Name_String (Prj.Object_Directory.Display_Name);
1271 Action (Name_Buffer (1 .. Name_Len));
1275 procedure Get_Object_Dirs is
1276 new For_Every_Project_Imported (Integer, For_Project);
1277 Dummy : Integer := 1;
1279 -- Start of processing for For_All_Object_Dirs
1282 Get_Object_Dirs (Project, Tree, Dummy);
1283 end For_All_Object_Dirs;
1285 -------------------------
1286 -- For_All_Source_Dirs --
1287 -------------------------
1289 procedure For_All_Source_Dirs
1290 (Project : Project_Id;
1291 In_Tree : Project_Tree_Ref)
1293 procedure For_Project
1295 In_Tree : Project_Tree_Ref;
1296 Dummy : in out Integer);
1297 -- Get all object directories of Prj
1303 procedure For_Project
1305 In_Tree : Project_Tree_Ref;
1306 Dummy : in out Integer)
1308 Current : String_List_Id := Prj.Source_Dirs;
1309 The_String : String_Element;
1312 -- If there are Ada sources, call action with the name of every
1313 -- source directory.
1315 if Has_Ada_Sources (Prj) then
1316 while Current /= Nil_String loop
1317 The_String := In_Tree.Shared.String_Elements.Table (Current);
1318 Action (Get_Name_String (The_String.Display_Value));
1319 Current := The_String.Next;
1324 procedure Get_Source_Dirs is
1325 new For_Every_Project_Imported (Integer, For_Project);
1326 Dummy : Integer := 1;
1328 -- Start of processing for For_All_Source_Dirs
1331 Get_Source_Dirs (Project, In_Tree, Dummy);
1332 end For_All_Source_Dirs;
1338 procedure Get_Reference
1339 (Source_File_Name : String;
1340 In_Tree : Project_Tree_Ref;
1341 Project : out Project_Id;
1342 Path : out Path_Name_Type)
1345 -- Body below could use some comments ???
1347 if Current_Verbosity > Default then
1348 Write_Str ("Getting Reference_Of (""");
1349 Write_Str (Source_File_Name);
1350 Write_Str (""") ... ");
1354 Original_Name : String := Source_File_Name;
1358 Canonical_Case_File_Name (Original_Name);
1359 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1361 while Unit /= null loop
1362 if Unit.File_Names (Spec) /= null
1363 and then not Unit.File_Names (Spec).Locally_Removed
1364 and then Unit.File_Names (Spec).File /= No_File
1366 (Namet.Get_Name_String
1367 (Unit.File_Names (Spec).File) = Original_Name
1368 or else (Unit.File_Names (Spec).Path /= No_Path_Information
1370 Namet.Get_Name_String
1371 (Unit.File_Names (Spec).Path.Name) =
1375 Ultimate_Extending_Project_Of
1376 (Unit.File_Names (Spec).Project);
1377 Path := Unit.File_Names (Spec).Path.Display_Name;
1379 if Current_Verbosity > Default then
1380 Write_Str ("Done: Spec.");
1386 elsif Unit.File_Names (Impl) /= null
1387 and then Unit.File_Names (Impl).File /= No_File
1388 and then not Unit.File_Names (Impl).Locally_Removed
1390 (Namet.Get_Name_String
1391 (Unit.File_Names (Impl).File) = Original_Name
1392 or else (Unit.File_Names (Impl).Path /= No_Path_Information
1393 and then Namet.Get_Name_String
1394 (Unit.File_Names (Impl).Path.Name) =
1398 Ultimate_Extending_Project_Of
1399 (Unit.File_Names (Impl).Project);
1400 Path := Unit.File_Names (Impl).Path.Display_Name;
1402 if Current_Verbosity > Default then
1403 Write_Str ("Done: Body.");
1410 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1414 Project := No_Project;
1417 if Current_Verbosity > Default then
1418 Write_Str ("Cannot be found.");
1423 ----------------------
1424 -- Get_Runtime_Path --
1425 ----------------------
1427 function Get_Runtime_Path
1428 (Self : Project_Search_Path;
1429 Name : String) return String_Access
1431 function Find_Rts_In_Path is
1432 new Prj.Env.Find_Name_In_Path (Check_Filename => Is_Directory);
1434 return Find_Rts_In_Path (Self, Name);
1435 end Get_Runtime_Path;
1441 procedure Initialize (In_Tree : Project_Tree_Ref) is
1443 In_Tree.Shared.Private_Part.Current_Source_Path_File := No_Path;
1444 In_Tree.Shared.Private_Part.Current_Object_Path_File := No_Path;
1451 -- Could use some comments in this body ???
1453 procedure Print_Sources (In_Tree : Project_Tree_Ref) is
1457 Write_Line ("List of Sources:");
1459 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1460 while Unit /= No_Unit_Index loop
1462 Write_Line (Namet.Get_Name_String (Unit.Name));
1464 if Unit.File_Names (Spec).File /= No_File then
1465 if Unit.File_Names (Spec).Project = No_Project then
1466 Write_Line (" No project");
1469 Write_Str (" Project: ");
1471 (Unit.File_Names (Spec).Project.Path.Name);
1472 Write_Line (Name_Buffer (1 .. Name_Len));
1475 Write_Str (" spec: ");
1477 (Namet.Get_Name_String
1478 (Unit.File_Names (Spec).File));
1481 if Unit.File_Names (Impl).File /= No_File then
1482 if Unit.File_Names (Impl).Project = No_Project then
1483 Write_Line (" No project");
1486 Write_Str (" Project: ");
1488 (Unit.File_Names (Impl).Project.Path.Name);
1489 Write_Line (Name_Buffer (1 .. Name_Len));
1492 Write_Str (" body: ");
1494 (Namet.Get_Name_String (Unit.File_Names (Impl).File));
1497 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1500 Write_Line ("end of List of Sources.");
1509 Main_Project : Project_Id;
1510 In_Tree : Project_Tree_Ref) return Project_Id
1512 Result : Project_Id := No_Project;
1514 Original_Name : String := Name;
1516 Lang : constant Language_Ptr :=
1517 Get_Language_From_Name (Main_Project, "ada");
1521 Current_Name : File_Name_Type;
1522 The_Original_Name : File_Name_Type;
1523 The_Spec_Name : File_Name_Type;
1524 The_Body_Name : File_Name_Type;
1527 -- ??? Same block in File_Name_Of_Library_Unit_Body
1528 Canonical_Case_File_Name (Original_Name);
1529 Name_Len := Original_Name'Length;
1530 Name_Buffer (1 .. Name_Len) := Original_Name;
1531 The_Original_Name := Name_Find;
1533 if Lang /= null then
1535 Naming : Lang_Naming_Data renames Lang.Config.Naming_Data;
1536 Extended_Spec_Name : String :=
1537 Name & Namet.Get_Name_String
1538 (Naming.Spec_Suffix);
1539 Extended_Body_Name : String :=
1540 Name & Namet.Get_Name_String
1541 (Naming.Body_Suffix);
1544 Canonical_Case_File_Name (Extended_Spec_Name);
1545 Name_Len := Extended_Spec_Name'Length;
1546 Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1547 The_Spec_Name := Name_Find;
1549 Canonical_Case_File_Name (Extended_Body_Name);
1550 Name_Len := Extended_Body_Name'Length;
1551 Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1552 The_Body_Name := Name_Find;
1556 The_Spec_Name := The_Original_Name;
1557 The_Body_Name := The_Original_Name;
1560 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1561 while Unit /= null loop
1563 -- Case of a body present
1565 if Unit.File_Names (Impl) /= null then
1566 Current_Name := Unit.File_Names (Impl).File;
1568 -- If it has the name of the original name or the body name,
1569 -- we have found the project.
1571 if Unit.Name = Name_Id (The_Original_Name)
1572 or else Current_Name = The_Original_Name
1573 or else Current_Name = The_Body_Name
1575 Result := Unit.File_Names (Impl).Project;
1582 if Unit.File_Names (Spec) /= null then
1583 Current_Name := Unit.File_Names (Spec).File;
1585 -- If name same as the original name, or the spec name, we have
1586 -- found the project.
1588 if Unit.Name = Name_Id (The_Original_Name)
1589 or else Current_Name = The_Original_Name
1590 or else Current_Name = The_Spec_Name
1592 Result := Unit.File_Names (Spec).Project;
1597 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1600 return Ultimate_Extending_Project_Of (Result);
1607 procedure Set_Ada_Paths
1608 (Project : Project_Id;
1609 In_Tree : Project_Tree_Ref;
1610 Including_Libraries : Boolean;
1611 Include_Path : Boolean := True;
1612 Objects_Path : Boolean := True)
1615 Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared;
1617 Source_Paths : Source_Path_Table.Instance;
1618 Object_Paths : Object_Path_Table.Instance;
1619 -- List of source or object dirs. Only computed the first time this
1620 -- procedure is called (since Source_FD is then reused)
1622 Source_FD : File_Descriptor := Invalid_FD;
1623 Object_FD : File_Descriptor := Invalid_FD;
1624 -- The temporary files to store the paths. These are only created the
1625 -- first time this procedure is called, and reused from then on.
1627 Process_Source_Dirs : Boolean := False;
1628 Process_Object_Dirs : Boolean := False;
1631 -- For calls to Close
1634 Buffer : String_Access := new String (1 .. Buffer_Initial);
1635 Buffer_Last : Natural := 0;
1637 procedure Recursive_Add
1638 (Project : Project_Id;
1639 In_Tree : Project_Tree_Ref;
1640 Dummy : in out Boolean);
1641 -- Recursive procedure to add the source/object paths of extended/
1642 -- imported projects.
1648 procedure Recursive_Add
1649 (Project : Project_Id;
1650 In_Tree : Project_Tree_Ref;
1651 Dummy : in out Boolean)
1653 pragma Unreferenced (In_Tree);
1655 Path : Path_Name_Type;
1658 if Process_Source_Dirs then
1660 -- Add to path all source directories of this project if there are
1663 if Has_Ada_Sources (Project) then
1664 Add_To_Source_Path (Project.Source_Dirs, Shared, Source_Paths);
1668 if Process_Object_Dirs then
1669 Path := Get_Object_Directory
1671 Including_Libraries => Including_Libraries,
1672 Only_If_Ada => True);
1674 if Path /= No_Path then
1675 Add_To_Object_Path (Path, Object_Paths);
1680 procedure For_All_Projects is
1681 new For_Every_Project_Imported (Boolean, Recursive_Add);
1683 Dummy : Boolean := False;
1685 -- Start of processing for Set_Ada_Paths
1688 -- If it is the first time we call this procedure for this project,
1689 -- compute the source path and/or the object path.
1691 if Include_Path and then Project.Include_Path_File = No_Path then
1692 Source_Path_Table.Init (Source_Paths);
1693 Process_Source_Dirs := True;
1694 Create_New_Path_File (Shared, Source_FD, Project.Include_Path_File);
1697 -- For the object path, we make a distinction depending on
1698 -- Including_Libraries.
1700 if Objects_Path and Including_Libraries then
1701 if Project.Objects_Path_File_With_Libs = No_Path then
1702 Object_Path_Table.Init (Object_Paths);
1703 Process_Object_Dirs := True;
1704 Create_New_Path_File
1705 (Shared, Object_FD, Project.Objects_Path_File_With_Libs);
1708 elsif Objects_Path then
1709 if Project.Objects_Path_File_Without_Libs = No_Path then
1710 Object_Path_Table.Init (Object_Paths);
1711 Process_Object_Dirs := True;
1712 Create_New_Path_File
1713 (Shared, Object_FD, Project.Objects_Path_File_Without_Libs);
1717 -- If there is something to do, set Seen to False for all projects,
1718 -- then call the recursive procedure Add for Project.
1720 if Process_Source_Dirs or Process_Object_Dirs then
1721 For_All_Projects (Project, In_Tree, Dummy);
1724 -- Write and close any file that has been created. Source_FD is not set
1725 -- when this subprogram is called a second time or more, since we reuse
1726 -- the previous version of the file.
1728 if Source_FD /= Invalid_FD then
1732 Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths)
1734 Get_Name_String (Source_Paths.Table (Index));
1735 Name_Len := Name_Len + 1;
1736 Name_Buffer (Name_Len) := ASCII.LF;
1737 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1740 Last := Write (Source_FD, Buffer (1)'Address, Buffer_Last);
1742 if Last = Buffer_Last then
1743 Close (Source_FD, Status);
1750 Prj.Com.Fail ("could not write temporary file");
1754 if Object_FD /= Invalid_FD then
1758 Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths)
1760 Get_Name_String (Object_Paths.Table (Index));
1761 Name_Len := Name_Len + 1;
1762 Name_Buffer (Name_Len) := ASCII.LF;
1763 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1766 Last := Write (Object_FD, Buffer (1)'Address, Buffer_Last);
1768 if Last = Buffer_Last then
1769 Close (Object_FD, Status);
1775 Prj.Com.Fail ("could not write temporary file");
1779 -- Set the env vars, if they need to be changed, and set the
1780 -- corresponding flags.
1784 Shared.Private_Part.Current_Source_Path_File /=
1785 Project.Include_Path_File
1787 Shared.Private_Part.Current_Source_Path_File :=
1788 Project.Include_Path_File;
1790 (Project_Include_Path_File,
1791 Get_Name_String (Shared.Private_Part.Current_Source_Path_File));
1794 if Objects_Path then
1795 if Including_Libraries then
1796 if Shared.Private_Part.Current_Object_Path_File /=
1797 Project.Objects_Path_File_With_Libs
1799 Shared.Private_Part.Current_Object_Path_File :=
1800 Project.Objects_Path_File_With_Libs;
1802 (Project_Objects_Path_File,
1804 (Shared.Private_Part.Current_Object_Path_File));
1808 if Shared.Private_Part.Current_Object_Path_File /=
1809 Project.Objects_Path_File_Without_Libs
1811 Shared.Private_Part.Current_Object_Path_File :=
1812 Project.Objects_Path_File_Without_Libs;
1814 (Project_Objects_Path_File,
1816 (Shared.Private_Part.Current_Object_Path_File));
1824 ---------------------
1825 -- Add_Directories --
1826 ---------------------
1828 procedure Add_Directories
1829 (Self : in out Project_Search_Path;
1831 Prepend : Boolean := False)
1833 Tmp : String_Access;
1835 if Self.Path = null then
1836 Self.Path := new String'(Uninitialized_Prefix & Path);
1840 Self.Path := new String'(Path & Path_Separator & Tmp.all);
1842 Self.Path := new String'(Tmp.all & Path_Separator & Path);
1847 if Current_Verbosity = High then
1848 Debug_Output ("Adding directories to Project_Path: """
1851 end Add_Directories;
1853 --------------------
1854 -- Is_Initialized --
1855 --------------------
1857 function Is_Initialized (Self : Project_Search_Path) return Boolean is
1859 return Self.Path /= null
1860 and then (Self.Path'Length = 0
1861 or else Self.Path (Self.Path'First) /= '#');
1864 ----------------------
1865 -- Initialize_Empty --
1866 ----------------------
1868 procedure Initialize_Empty (Self : in out Project_Search_Path) is
1871 Self.Path := new String'("");
1872 end Initialize_Empty;
1874 -------------------------------------
1875 -- Initialize_Default_Project_Path --
1876 -------------------------------------
1878 procedure Initialize_Default_Project_Path
1879 (Self : in out Project_Search_Path;
1880 Target_Name : String;
1881 Runtime_Name : String := "")
1883 Add_Default_Dir : Boolean := Target_Name /= "-";
1887 Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
1888 Gpr_Project_Path : constant String := "GPR_PROJECT_PATH";
1889 Gpr_Project_Path_File : constant String := "GPR_PROJECT_PATH_FILE";
1890 -- Names of alternate env. variable that contain path name(s) of
1891 -- directories where project files may reside. They are taken into
1892 -- account in this order: GPR_PROJECT_PATH_FILE, GPR_PROJECT_PATH,
1893 -- ADA_PROJECT_PATH.
1895 Gpr_Prj_Path_File : String_Access;
1896 Gpr_Prj_Path : String_Access;
1897 Ada_Prj_Path : String_Access;
1898 -- The path name(s) of directories where project files may reside.
1901 Prefix : String_Ptr;
1902 Runtime : String_Ptr;
1904 procedure Add_Target;
1905 -- Add :<prefix>/<target> to the project path
1911 procedure Add_Target is
1913 Add_Str_To_Name_Buffer
1914 (Path_Separator & Prefix.all & Target_Name);
1916 -- Note: Target_Name has a trailing / when it comes from Sdefault
1918 if Name_Buffer (Name_Len) /= '/' then
1919 Add_Char_To_Name_Buffer (Directory_Separator);
1923 -- Start of processing for Initialize_Default_Project_Path
1926 if Is_Initialized (Self) then
1930 -- The current directory is always first in the search path. Since the
1931 -- Project_Path currently starts with '#:' as a sign that it isn't
1932 -- initialized, we simply replace '#' with '.'
1934 if Self.Path = null then
1935 Self.Path := new String'('.' & Path_Separator);
1937 Self.Path (Self.Path'First) := '.';
1940 -- Then the reset of the project path (if any) currently contains the
1941 -- directories added through Add_Search_Project_Directory
1943 -- If environment variables are defined and not empty, add their content
1945 Gpr_Prj_Path_File := Getenv (Gpr_Project_Path_File);
1946 Gpr_Prj_Path := Getenv (Gpr_Project_Path);
1947 Ada_Prj_Path := Getenv (Ada_Project_Path);
1949 if Gpr_Prj_Path_File.all /= "" then
1951 File : Ada.Text_IO.File_Type;
1952 Line : String (1 .. 10_000);
1955 Tmp : String_Access;
1958 Open (File, In_File, Gpr_Prj_Path_File.all);
1960 while not End_Of_File (File) loop
1961 Get_Line (File, Line, Last);
1964 and then (Last = 1 or else Line (1 .. 2) /= "--")
1969 (Tmp.all & Path_Separator & Line (1 .. Last));
1973 if Current_Verbosity = High then
1974 Debug_Output ("Adding directory to Project_Path: """
1975 & Line (1 .. Last) & '"');
1983 Write_Str ("warning: could not read project path file """);
1984 Write_Str (Gpr_Prj_Path_File.all);
1990 if Gpr_Prj_Path.all /= "" then
1991 Add_Directories (Self, Gpr_Prj_Path.all);
1994 Free (Gpr_Prj_Path);
1996 if Ada_Prj_Path.all /= "" then
1997 Add_Directories (Self, Ada_Prj_Path.all);
2000 Free (Ada_Prj_Path);
2002 -- Copy to Name_Buffer, since we will need to manipulate the path
2004 Name_Len := Self.Path'Length;
2005 Name_Buffer (1 .. Name_Len) := Self.Path.all;
2007 -- Scan the directory path to see if "-" is one of the directories.
2008 -- Remove each occurrence of "-" and set Add_Default_Dir to False.
2009 -- Also resolve relative paths and symbolic links.
2013 while First <= Name_Len
2014 and then (Name_Buffer (First) = Path_Separator)
2019 exit when First > Name_Len;
2023 while Last < Name_Len
2024 and then Name_Buffer (Last + 1) /= Path_Separator
2029 -- If the directory is "-", set Add_Default_Dir to False and
2030 -- remove from path.
2032 if Name_Buffer (First .. Last) = No_Project_Default_Dir then
2033 Add_Default_Dir := False;
2035 for J in Last + 1 .. Name_Len loop
2036 Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
2040 Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
2042 -- After removing the '-', go back one character to get the next
2043 -- directory correctly.
2049 New_Dir : constant String :=
2051 (Name_Buffer (First .. Last),
2052 Resolve_Links => Opt.Follow_Links_For_Dirs);
2054 New_Last : Positive;
2057 -- If the absolute path was resolved and is different from
2058 -- the original, replace original with the resolved path.
2060 if New_Dir /= Name_Buffer (First .. Last)
2061 and then New_Dir'Length /= 0
2063 New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
2064 New_Last := First + New_Dir'Length - 1;
2065 Name_Buffer (New_Last + 1 .. New_Len) :=
2066 Name_Buffer (Last + 1 .. Name_Len);
2067 Name_Buffer (First .. New_Last) := New_Dir;
2068 Name_Len := New_Len;
2079 -- Set the initial value of Current_Project_Path
2081 if Add_Default_Dir then
2082 if Sdefault.Search_Dir_Prefix = null then
2086 Prefix := new String'(Executable_Prefix_Path);
2089 Prefix := new String'(Sdefault.Search_Dir_Prefix.all
2090 & ".." & Dir_Separator
2091 & ".." & Dir_Separator
2092 & ".." & Dir_Separator
2093 & ".." & Dir_Separator);
2096 if Prefix.all /= "" then
2097 if Target_Name /= "" then
2099 if Runtime_Name /= "" then
2100 if Base_Name (Runtime_Name) = Runtime_Name then
2102 -- $prefix/$target/$runtime/lib/gnat
2104 Add_Str_To_Name_Buffer
2105 (Runtime_Name & Directory_Separator &
2106 "lib" & Directory_Separator & "gnat");
2108 -- $prefix/$target/$runtime/share/gpr
2110 Add_Str_To_Name_Buffer
2111 (Runtime_Name & Directory_Separator &
2112 "share" & Directory_Separator & "gpr");
2116 new String'(Normalize_Pathname (Runtime_Name));
2118 -- $runtime_dir/lib/gnat
2119 Add_Str_To_Name_Buffer
2120 (Path_Separator & Runtime.all & Directory_Separator &
2121 "lib" & Directory_Separator & "gnat");
2123 -- $runtime_dir/share/gpr
2124 Add_Str_To_Name_Buffer
2125 (Path_Separator & Runtime.all & Directory_Separator &
2126 "share" & Directory_Separator & "gpr");
2130 -- $prefix/$target/lib/gnat
2133 Add_Str_To_Name_Buffer
2134 ("lib" & Directory_Separator & "gnat");
2136 -- $prefix/$target/share/gpr
2139 Add_Str_To_Name_Buffer
2140 ("share" & Directory_Separator & "gpr");
2143 -- $prefix/share/gpr
2145 Add_Str_To_Name_Buffer
2146 (Path_Separator & Prefix.all & "share"
2147 & Directory_Separator & "gpr");
2151 Add_Str_To_Name_Buffer
2152 (Path_Separator & Prefix.all & "lib"
2153 & Directory_Separator & "gnat");
2159 Self.Path := new String'(Name_Buffer (1 .. Name_Len));
2160 end Initialize_Default_Project_Path;
2166 procedure Get_Path (Self : Project_Search_Path; Path : out String_Access) is
2168 pragma Assert (Is_Initialized (Self));
2176 procedure Set_Path (Self : in out Project_Search_Path; Path : String) is
2179 Self.Path := new String'(Path);
2180 Projects_Paths.Reset (Self.Cache);
2183 -----------------------
2184 -- Find_Name_In_Path --
2185 -----------------------
2187 function Find_Name_In_Path
2188 (Self : Project_Search_Path;
2189 Path : String) return String_Access
2195 if Current_Verbosity = High then
2196 Debug_Output ("Trying " & Path);
2199 if Is_Absolute_Path (Path) then
2200 if Check_Filename (Path) then
2201 return new String'(Path);
2207 -- Because we don't want to resolve symbolic links, we cannot use
2208 -- Locate_Regular_File. So, we try each possible path successively.
2210 First := Self.Path'First;
2211 while First <= Self.Path'Last loop
2212 while First <= Self.Path'Last
2213 and then Self.Path (First) = Path_Separator
2218 exit when First > Self.Path'Last;
2221 while Last < Self.Path'Last
2222 and then Self.Path (Last + 1) /= Path_Separator
2229 if not Is_Absolute_Path (Self.Path (First .. Last)) then
2230 Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call
2231 Add_Char_To_Name_Buffer (Directory_Separator);
2234 Add_Str_To_Name_Buffer (Self.Path (First .. Last));
2235 Add_Char_To_Name_Buffer (Directory_Separator);
2236 Add_Str_To_Name_Buffer (Path);
2238 if Current_Verbosity = High then
2239 Debug_Output ("Testing file " & Name_Buffer (1 .. Name_Len));
2242 if Check_Filename (Name_Buffer (1 .. Name_Len)) then
2243 return new String'(Name_Buffer (1 .. Name_Len));
2251 end Find_Name_In_Path;
2257 procedure Find_Project
2258 (Self : in out Project_Search_Path;
2259 Project_File_Name : String;
2261 Path : out Namet.Path_Name_Type)
2263 Result : String_Access;
2264 Has_Dot : Boolean := False;
2267 File : constant String := Project_File_Name;
2268 -- Have to do a copy, in case the parameter is Name_Buffer, which we
2271 Cached_Path : Namet.Path_Name_Type;
2272 -- This should be commented rather than making us guess from the name???
2274 function Try_Path_Name is new
2275 Find_Name_In_Path (Check_Filename => Is_Regular_File);
2276 -- Find a file in the project search path
2278 -- Start of processing for Find_Project
2281 pragma Assert (Is_Initialized (Self));
2283 if Current_Verbosity = High then
2284 Debug_Increase_Indent
2285 ("Searching for project """ & File & """ in """
2289 -- Check the project cache
2291 Name_Len := File'Length;
2292 Name_Buffer (1 .. Name_Len) := File;
2294 Cached_Path := Projects_Paths.Get (Self.Cache, Key);
2296 -- Check if File contains an extension (a dot before a
2297 -- directory separator). If it is the case we do not try project file
2298 -- with an added extension as it is not possible to have multiple dots
2299 -- on a project file name.
2301 Check_Dot : for K in reverse File'Range loop
2302 if File (K) = '.' then
2307 exit Check_Dot when Is_Directory_Separator (File (K));
2310 if not Is_Absolute_Path (File) then
2312 -- If we have found project in the cache, check if in the directory
2314 if Cached_Path /= No_Path then
2316 Cached : constant String := Get_Name_String (Cached_Path);
2320 GNAT.OS_Lib.Normalize_Pathname
2321 (File & Project_File_Extension,
2322 Directory => Directory,
2323 Resolve_Links => Opt.Follow_Links_For_Files,
2324 Case_Sensitive => True))
2327 GNAT.OS_Lib.Normalize_Pathname
2329 Directory => Directory,
2330 Resolve_Links => Opt.Follow_Links_For_Files,
2331 Case_Sensitive => True)
2333 Path := Cached_Path;
2334 Debug_Decrease_Indent;
2340 -- First we try <directory>/<file_name>.<extension>
2346 Directory & Directory_Separator
2347 & File & Project_File_Extension);
2350 -- Then we try <directory>/<file_name>
2352 if Result = null then
2354 Try_Path_Name (Self, Directory & Directory_Separator & File);
2358 -- If we found the path in the cache, this is the one
2360 if Result = null and then Cached_Path /= No_Path then
2361 Path := Cached_Path;
2362 Debug_Decrease_Indent;
2366 -- Then we try <file_name>.<extension>
2368 if Result = null and then not Has_Dot then
2369 Result := Try_Path_Name (Self, File & Project_File_Extension);
2372 -- Then we try <file_name>
2374 if Result = null then
2375 Result := Try_Path_Name (Self, File);
2378 -- If we cannot find the project file, we return an empty string
2380 if Result = null then
2381 Path := Namet.No_Path;
2386 Final_Result : constant String :=
2387 GNAT.OS_Lib.Normalize_Pathname
2389 Directory => Directory,
2390 Resolve_Links => Opt.Follow_Links_For_Files,
2391 Case_Sensitive => True);
2394 Name_Len := Final_Result'Length;
2395 Name_Buffer (1 .. Name_Len) := Final_Result;
2397 Projects_Paths.Set (Self.Cache, Key, Path);
2401 Debug_Decrease_Indent;
2408 procedure Free (Self : in out Project_Search_Path) is
2411 Projects_Paths.Reset (Self.Cache);
2418 procedure Copy (From : Project_Search_Path; To : out Project_Search_Path) is
2422 if From.Path /= null then
2423 To.Path := new String'(From.Path.all);
2426 -- No need to copy the Cache, it will be recomputed as needed