1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
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 In_Tree : Project_Tree_Ref;
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 In_Tree : Project_Tree_Ref;
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 procedure Set_Path_File_Var (Name : String; Value : String);
106 -- Call Setenv, after calling To_Host_File_Spec
108 function Ultimate_Extension_Of
109 (Project : Project_Id) return Project_Id;
110 -- Return a project that is either Project or an extended ancestor of
111 -- Project that itself is not extended.
113 procedure Initialize_Project_Path
114 (Self : in out Project_Search_Path;
115 Target_Name : String);
116 -- Initialize Current_Project_Path. Does nothing if the path has already
117 -- been initialized properly.
119 ----------------------
120 -- Ada_Include_Path --
121 ----------------------
123 function Ada_Include_Path
124 (Project : Project_Id;
125 In_Tree : Project_Tree_Ref;
126 Recursive : Boolean := False) return String
128 Buffer : String_Access;
129 Buffer_Last : Natural := 0;
131 procedure Add (Project : Project_Id; Dummy : in out Boolean);
132 -- Add source dirs of Project to the path
138 procedure Add (Project : Project_Id; Dummy : in out Boolean) is
139 pragma Unreferenced (Dummy);
141 Add_To_Path (Project.Source_Dirs, In_Tree, Buffer, Buffer_Last);
144 procedure For_All_Projects is
145 new For_Every_Project_Imported (Boolean, Add);
147 Dummy : Boolean := False;
149 -- Start of processing for Ada_Include_Path
154 -- If it is the first time we call this function for
155 -- this project, compute the source path
157 if Project.Ada_Include_Path = null then
158 Buffer := new String (1 .. 4096);
159 For_All_Projects (Project, Dummy);
160 Project.Ada_Include_Path := new String'(Buffer (1 .. Buffer_Last));
164 return Project.Ada_Include_Path.all;
167 Buffer := new String (1 .. 4096);
168 Add_To_Path (Project.Source_Dirs, In_Tree, Buffer, Buffer_Last);
171 Result : constant String := Buffer (1 .. Buffer_Last);
177 end Ada_Include_Path;
179 ----------------------
180 -- Ada_Objects_Path --
181 ----------------------
183 function Ada_Objects_Path
184 (Project : Project_Id;
185 Including_Libraries : Boolean := True) return String_Access
187 Buffer : String_Access;
188 Buffer_Last : Natural := 0;
190 procedure Add (Project : Project_Id; Dummy : in out Boolean);
191 -- Add all the object directories of a project to the path
197 procedure Add (Project : Project_Id; Dummy : in out Boolean) is
198 pragma Unreferenced (Dummy);
199 Path : constant Path_Name_Type :=
202 Including_Libraries => Including_Libraries,
203 Only_If_Ada => False);
205 if Path /= No_Path then
206 Add_To_Path (Get_Name_String (Path), Buffer, Buffer_Last);
210 procedure For_All_Projects is
211 new For_Every_Project_Imported (Boolean, Add);
213 Dummy : Boolean := False;
215 -- Start of processing for Ada_Objects_Path
218 -- If it is the first time we call this function for
219 -- this project, compute the objects path
221 if Project.Ada_Objects_Path = null then
222 Buffer := new String (1 .. 4096);
223 For_All_Projects (Project, Dummy);
225 Project.Ada_Objects_Path := new String'(Buffer (1 .. Buffer_Last));
229 return Project.Ada_Objects_Path;
230 end Ada_Objects_Path;
236 procedure Add_To_Buffer
238 Buffer : in out String_Access;
239 Buffer_Last : in out Natural)
241 Last : constant Natural := Buffer_Last + S'Length;
244 while Last > Buffer'Last loop
246 New_Buffer : constant String_Access :=
247 new String (1 .. 2 * Buffer'Last);
249 New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
251 Buffer := New_Buffer;
255 Buffer (Buffer_Last + 1 .. Last) := S;
259 ------------------------
260 -- Add_To_Object_Path --
261 ------------------------
263 procedure Add_To_Object_Path
264 (Object_Dir : Path_Name_Type;
265 Object_Paths : in out Object_Path_Table.Instance)
268 -- Check if the directory is already in the table
270 for Index in Object_Path_Table.First ..
271 Object_Path_Table.Last (Object_Paths)
274 -- If it is, remove it, and add it as the last one
276 if Object_Paths.Table (Index) = Object_Dir then
277 for Index2 in Index + 1 ..
278 Object_Path_Table.Last (Object_Paths)
280 Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2);
284 (Object_Path_Table.Last (Object_Paths)) := Object_Dir;
289 -- The directory is not already in the table, add it
291 Object_Path_Table.Append (Object_Paths, Object_Dir);
292 end Add_To_Object_Path;
298 procedure Add_To_Path
299 (Source_Dirs : String_List_Id;
300 In_Tree : Project_Tree_Ref;
301 Buffer : in out String_Access;
302 Buffer_Last : in out Natural)
304 Current : String_List_Id := Source_Dirs;
305 Source_Dir : String_Element;
307 while Current /= Nil_String loop
308 Source_Dir := In_Tree.String_Elements.Table (Current);
309 Add_To_Path (Get_Name_String (Source_Dir.Display_Value),
310 Buffer, Buffer_Last);
311 Current := Source_Dir.Next;
315 procedure Add_To_Path
317 Buffer : in out String_Access;
318 Buffer_Last : in out Natural)
321 New_Buffer : String_Access;
324 function Is_Present (Path : String; Dir : String) return Boolean;
325 -- Return True if Dir is part of Path
331 function Is_Present (Path : String; Dir : String) return Boolean is
332 Last : constant Integer := Path'Last - Dir'Length + 1;
335 for J in Path'First .. Last loop
337 -- Note: the order of the conditions below is important, since
338 -- it ensures a minimal number of string comparisons.
341 or else Path (J - 1) = Path_Separator)
343 (J + Dir'Length > Path'Last
344 or else Path (J + Dir'Length) = Path_Separator)
345 and then Dir = Path (J .. J + Dir'Length - 1)
354 -- Start of processing for Add_To_Path
357 if Is_Present (Buffer (1 .. Buffer_Last), Dir) then
359 -- Dir is already in the path, nothing to do
364 Min_Len := Buffer_Last + Dir'Length;
366 if Buffer_Last > 0 then
368 -- Add 1 for the Path_Separator character
370 Min_Len := Min_Len + 1;
373 -- If Ada_Path_Buffer is too small, increase it
377 if Len < Min_Len then
380 exit when Len >= Min_Len;
383 New_Buffer := new String (1 .. Len);
384 New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
386 Buffer := New_Buffer;
389 if Buffer_Last > 0 then
390 Buffer_Last := Buffer_Last + 1;
391 Buffer (Buffer_Last) := Path_Separator;
394 Buffer (Buffer_Last + 1 .. Buffer_Last + Dir'Length) := Dir;
395 Buffer_Last := Buffer_Last + Dir'Length;
398 ------------------------
399 -- Add_To_Source_Path --
400 ------------------------
402 procedure Add_To_Source_Path
403 (Source_Dirs : String_List_Id;
404 In_Tree : Project_Tree_Ref;
405 Source_Paths : in out Source_Path_Table.Instance)
407 Current : String_List_Id := Source_Dirs;
408 Source_Dir : String_Element;
412 -- Add each source directory
414 while Current /= Nil_String loop
415 Source_Dir := In_Tree.String_Elements.Table (Current);
418 -- Check if the source directory is already in the table
420 for Index in Source_Path_Table.First ..
421 Source_Path_Table.Last (Source_Paths)
423 -- If it is already, no need to add it
425 if Source_Paths.Table (Index) = Source_Dir.Value then
432 Source_Path_Table.Append (Source_Paths, Source_Dir.Display_Value);
435 -- Next source directory
437 Current := Source_Dir.Next;
439 end Add_To_Source_Path;
441 --------------------------------
442 -- Create_Config_Pragmas_File --
443 --------------------------------
445 procedure Create_Config_Pragmas_File
446 (For_Project : Project_Id;
447 In_Tree : Project_Tree_Ref)
449 type Naming_Id is new Nat;
450 package Naming_Table is new GNAT.Dynamic_Tables
451 (Table_Component_Type => Lang_Naming_Data,
452 Table_Index_Type => Naming_Id,
453 Table_Low_Bound => 1,
455 Table_Increment => 100);
456 Default_Naming : constant Naming_Id := Naming_Table.First;
457 Namings : Naming_Table.Instance;
458 -- Table storing the naming data for gnatmake/gprmake
460 Buffer : String_Access := new String (1 .. Buffer_Initial);
461 Buffer_Last : Natural := 0;
463 File_Name : Path_Name_Type := No_Path;
464 File : File_Descriptor := Invalid_FD;
466 Current_Naming : Naming_Id;
467 Iter : Source_Iterator;
470 procedure Check (Project : Project_Id; State : in out Integer);
471 -- Recursive procedure that put in the config pragmas file any non
472 -- standard naming schemes, if it is not already in the file, then call
473 -- itself for any imported project.
475 procedure Put (Source : Source_Id);
476 -- Put an SFN pragma in the temporary file
478 procedure Put (S : String);
479 procedure Put_Line (S : String);
480 -- Output procedures, analogous to normal Text_IO procs of same name.
481 -- The text is put in Buffer, then it will be written into a temporary
482 -- file with procedure Write_Temp_File below.
484 procedure Write_Temp_File;
485 -- Create a temporary file and put the content of the buffer in it
491 procedure Check (Project : Project_Id; State : in out Integer) is
492 pragma Unreferenced (State);
493 Lang : constant Language_Ptr :=
494 Get_Language_From_Name (Project, "ada");
495 Naming : Lang_Naming_Data;
498 if Current_Verbosity = High then
499 Write_Str ("Checking project file """);
500 Write_Str (Namet.Get_Name_String (Project.Name));
506 if Current_Verbosity = High then
507 Write_Line (" Languages does not contain Ada, nothing to do");
513 Naming := Lang.Config.Naming_Data;
515 -- Is the naming scheme of this project one that we know?
517 Current_Naming := Default_Naming;
518 while Current_Naming <= Naming_Table.Last (Namings)
519 and then Namings.Table (Current_Naming).Dot_Replacement =
520 Naming.Dot_Replacement
521 and then Namings.Table (Current_Naming).Casing =
523 and then Namings.Table (Current_Naming).Separate_Suffix =
524 Naming.Separate_Suffix
526 Current_Naming := Current_Naming + 1;
529 -- If we don't know it, add it
531 if Current_Naming > Naming_Table.Last (Namings) then
532 Naming_Table.Increment_Last (Namings);
533 Namings.Table (Naming_Table.Last (Namings)) := Naming;
535 -- Put the SFN pragmas for the naming scheme
540 ("pragma Source_File_Name_Project");
542 (" (Spec_File_Name => ""*" &
543 Get_Name_String (Naming.Spec_Suffix) & """,");
546 Image (Naming.Casing) & ",");
548 (" Dot_Replacement => """ &
549 Get_Name_String (Naming.Dot_Replacement) & """);");
554 ("pragma Source_File_Name_Project");
556 (" (Body_File_Name => ""*" &
557 Get_Name_String (Naming.Body_Suffix) & """,");
560 Image (Naming.Casing) & ",");
562 (" Dot_Replacement => """ &
563 Get_Name_String (Naming.Dot_Replacement) &
566 -- and maybe separate
568 if Naming.Body_Suffix /= Naming.Separate_Suffix then
569 Put_Line ("pragma Source_File_Name_Project");
571 (" (Subunit_File_Name => ""*" &
572 Get_Name_String (Naming.Separate_Suffix) & """,");
575 Image (Naming.Casing) & ",");
577 (" Dot_Replacement => """ &
578 Get_Name_String (Naming.Dot_Replacement) &
588 procedure Put (Source : Source_Id) is
590 -- Put the pragma SFN for the unit kind (spec or body)
592 Put ("pragma Source_File_Name_Project (");
593 Put (Namet.Get_Name_String (Source.Unit.Name));
595 if Source.Kind = Spec then
596 Put (", Spec_File_Name => """);
598 Put (", Body_File_Name => """);
601 Put (Namet.Get_Name_String (Source.File));
604 if Source.Index /= 0 then
606 Put (Source.Index'Img);
612 procedure Put (S : String) is
614 Add_To_Buffer (S, Buffer, Buffer_Last);
616 if Current_Verbosity = High then
625 procedure Put_Line (S : String) is
627 -- Add an ASCII.LF to the string. As this config file is supposed to
628 -- be used only by the compiler, we don't care about the characters
629 -- for the end of line. In fact we could have put a space, but
630 -- it is more convenient to be able to read gnat.adc during
631 -- development, for which the ASCII.LF is fine.
634 Put (S => (1 => ASCII.LF));
637 ---------------------
638 -- Write_Temp_File --
639 ---------------------
641 procedure Write_Temp_File is
642 Status : Boolean := False;
646 Tempdir.Create_Temp_File (File, File_Name);
648 if File /= Invalid_FD then
649 Last := Write (File, Buffer (1)'Address, Buffer_Last);
651 if Last = Buffer_Last then
652 Close (File, Status);
657 Prj.Com.Fail ("unable to create temporary file");
661 procedure Check_Imported_Projects is
662 new For_Every_Project_Imported (Integer, Check);
664 Dummy : Integer := 0;
666 -- Start of processing for Create_Config_Pragmas_File
669 if not For_Project.Config_Checked then
670 Naming_Table.Init (Namings);
672 -- Check the naming schemes
674 Check_Imported_Projects (For_Project, Dummy, Imported_First => False);
676 -- Visit all the files and process those that need an SFN pragma
678 Iter := For_Each_Source (In_Tree, For_Project);
679 while Element (Iter) /= No_Source loop
680 Source := Element (Iter);
683 and then not Source.Locally_Removed
684 and then Source.Unit /= null
692 -- If there are no non standard naming scheme, issue the GNAT
693 -- standard naming scheme. This will tell the compiler that
694 -- a project file is used and will forbid any pragma SFN.
696 if Buffer_Last = 0 then
698 Put_Line ("pragma Source_File_Name_Project");
699 Put_Line (" (Spec_File_Name => ""*.ads"",");
700 Put_Line (" Dot_Replacement => ""-"",");
701 Put_Line (" Casing => lowercase);");
703 Put_Line ("pragma Source_File_Name_Project");
704 Put_Line (" (Body_File_Name => ""*.adb"",");
705 Put_Line (" Dot_Replacement => ""-"",");
706 Put_Line (" Casing => lowercase);");
709 -- Close the temporary file
713 if Opt.Verbose_Mode then
714 Write_Str ("Created configuration file """);
715 Write_Str (Get_Name_String (File_Name));
719 For_Project.Config_File_Name := File_Name;
720 For_Project.Config_File_Temp := True;
721 For_Project.Config_Checked := True;
725 end Create_Config_Pragmas_File;
731 procedure Create_Mapping (In_Tree : Project_Tree_Ref) is
733 Iter : Source_Iterator;
738 Iter := For_Each_Source (In_Tree);
740 Data := Element (Iter);
741 exit when Data = No_Source;
743 if Data.Unit /= No_Unit_Index then
744 if Data.Locally_Removed then
745 Fmap.Add_Forbidden_File_Name (Data.File);
748 (Unit_Name => Unit_Name_Type (Data.Unit.Name),
749 File_Name => Data.File,
750 Path_Name => File_Name_Type (Data.Path.Display_Name));
758 -------------------------
759 -- Create_Mapping_File --
760 -------------------------
762 procedure Create_Mapping_File
763 (Project : Project_Id;
765 In_Tree : Project_Tree_Ref;
766 Name : out Path_Name_Type)
768 File : File_Descriptor := Invalid_FD;
770 Buffer : String_Access := new String (1 .. Buffer_Initial);
771 Buffer_Last : Natural := 0;
773 procedure Put_Name_Buffer;
774 -- Put the line contained in the Name_Buffer in the global buffer
776 procedure Process (Project : Project_Id; State : in out Integer);
777 -- Generate the mapping file for Project (not recursively)
779 ---------------------
780 -- Put_Name_Buffer --
781 ---------------------
783 procedure Put_Name_Buffer is
785 Name_Len := Name_Len + 1;
786 Name_Buffer (Name_Len) := ASCII.LF;
788 if Current_Verbosity = High then
789 Write_Str ("Mapping file: " & Name_Buffer (1 .. Name_Len));
792 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
799 procedure Process (Project : Project_Id; State : in out Integer) is
800 pragma Unreferenced (State);
802 Suffix : File_Name_Type;
803 Iter : Source_Iterator;
806 Iter := For_Each_Source (In_Tree, Project, Language => Language);
809 Source := Prj.Element (Iter);
810 exit when Source = No_Source;
812 if Source.Replaced_By = No_Source
813 and then Source.Path.Name /= No_Path
815 (Source.Language.Config.Kind = File_Based
816 or else Source.Unit /= No_Unit_Index)
818 if Source.Unit /= No_Unit_Index then
819 Get_Name_String (Source.Unit.Name);
821 if Source.Language.Config.Kind = Unit_Based then
823 -- ??? Mapping_Spec_Suffix could be set in the case of
826 Add_Char_To_Name_Buffer ('%');
828 if Source.Kind = Spec then
829 Add_Char_To_Name_Buffer ('s');
831 Add_Char_To_Name_Buffer ('b');
838 Source.Language.Config.Mapping_Spec_Suffix;
841 Source.Language.Config.Mapping_Body_Suffix;
844 if Suffix /= No_File then
845 Add_Str_To_Name_Buffer
846 (Get_Name_String (Suffix));
853 Get_Name_String (Source.Display_File);
856 if Source.Locally_Removed then
858 Name_Buffer (1) := '/';
860 Get_Name_String (Source.Path.Display_Name);
870 procedure For_Every_Imported_Project is new
871 For_Every_Project_Imported (State => Integer, Action => Process);
873 Dummy : Integer := 0;
875 -- Start of processing for Create_Mapping_File
878 For_Every_Imported_Project (Project, Dummy);
882 Status : Boolean := False;
885 Create_Temp_File (In_Tree, File, Name, "mapping");
887 if File /= Invalid_FD then
888 Last := Write (File, Buffer (1)'Address, Buffer_Last);
890 if Last = Buffer_Last then
891 GNAT.OS_Lib.Close (File, Status);
896 Prj.Com.Fail ("could not write mapping file");
901 end Create_Mapping_File;
903 ----------------------
904 -- Create_Temp_File --
905 ----------------------
907 procedure Create_Temp_File
908 (In_Tree : Project_Tree_Ref;
909 Path_FD : out File_Descriptor;
910 Path_Name : out Path_Name_Type;
914 Tempdir.Create_Temp_File (Path_FD, Path_Name);
916 if Path_Name /= No_Path then
917 if Current_Verbosity = High then
918 Write_Line ("Create temp file (" & File_Use & ") "
919 & Get_Name_String (Path_Name));
922 Record_Temp_File (In_Tree, Path_Name);
926 ("unable to create temporary " & File_Use & " file");
928 end Create_Temp_File;
930 --------------------------
931 -- Create_New_Path_File --
932 --------------------------
934 procedure Create_New_Path_File
935 (In_Tree : Project_Tree_Ref;
936 Path_FD : out File_Descriptor;
937 Path_Name : out Path_Name_Type)
940 Create_Temp_File (In_Tree, Path_FD, Path_Name, "path file");
941 end Create_New_Path_File;
943 ------------------------------------
944 -- File_Name_Of_Library_Unit_Body --
945 ------------------------------------
947 function File_Name_Of_Library_Unit_Body
949 Project : Project_Id;
950 In_Tree : Project_Tree_Ref;
951 Main_Project_Only : Boolean := True;
952 Full_Path : Boolean := False) return String
954 The_Project : Project_Id := Project;
955 Original_Name : String := Name;
957 Lang : constant Language_Ptr :=
958 Get_Language_From_Name (Project, "ada");
961 The_Original_Name : Name_Id;
962 The_Spec_Name : Name_Id;
963 The_Body_Name : Name_Id;
966 -- ??? Same block in Project_Of
967 Canonical_Case_File_Name (Original_Name);
968 Name_Len := Original_Name'Length;
969 Name_Buffer (1 .. Name_Len) := Original_Name;
970 The_Original_Name := Name_Find;
974 Naming : constant Lang_Naming_Data := Lang.Config.Naming_Data;
975 Extended_Spec_Name : String :=
976 Name & Namet.Get_Name_String
977 (Naming.Spec_Suffix);
978 Extended_Body_Name : String :=
979 Name & Namet.Get_Name_String
980 (Naming.Body_Suffix);
983 Canonical_Case_File_Name (Extended_Spec_Name);
984 Name_Len := Extended_Spec_Name'Length;
985 Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
986 The_Spec_Name := Name_Find;
988 Canonical_Case_File_Name (Extended_Body_Name);
989 Name_Len := Extended_Body_Name'Length;
990 Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
991 The_Body_Name := Name_Find;
995 Name_Len := Name'Length;
996 Name_Buffer (1 .. Name_Len) := Name;
997 Canonical_Case_File_Name (Name_Buffer);
998 The_Spec_Name := Name_Find;
999 The_Body_Name := The_Spec_Name;
1002 if Current_Verbosity = High then
1003 Write_Str ("Looking for file name of """);
1007 Write_Str (" Extended Spec Name = """);
1008 Write_Str (Get_Name_String (The_Spec_Name));
1011 Write_Str (" Extended Body Name = """);
1012 Write_Str (Get_Name_String (The_Body_Name));
1017 -- For extending project, search in the extended project if the source
1018 -- is not found. For non extending projects, this loop will be run only
1022 -- Loop through units
1024 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1025 while Unit /= null loop
1028 if not Main_Project_Only
1030 (Unit.File_Names (Impl) /= null
1031 and then Unit.File_Names (Impl).Project = The_Project)
1034 Current_Name : File_Name_Type;
1036 -- Case of a body present
1038 if Unit.File_Names (Impl) /= null then
1039 Current_Name := Unit.File_Names (Impl).File;
1041 if Current_Verbosity = High then
1042 Write_Str (" Comparing with """);
1043 Write_Str (Get_Name_String (Current_Name));
1048 -- If it has the name of the original name, return the
1051 if Unit.Name = The_Original_Name
1053 Current_Name = File_Name_Type (The_Original_Name)
1055 if Current_Verbosity = High then
1060 return Get_Name_String
1061 (Unit.File_Names (Impl).Path.Name);
1064 return Get_Name_String (Current_Name);
1067 -- If it has the name of the extended body name,
1068 -- return the extended body name
1070 elsif Current_Name = File_Name_Type (The_Body_Name) then
1071 if Current_Verbosity = High then
1076 return Get_Name_String
1077 (Unit.File_Names (Impl).Path.Name);
1080 return Get_Name_String (The_Body_Name);
1084 if Current_Verbosity = High then
1085 Write_Line (" not good");
1094 if not Main_Project_Only
1096 (Unit.File_Names (Spec) /= null
1097 and then Unit.File_Names (Spec).Project =
1101 Current_Name : File_Name_Type;
1104 -- Case of spec present
1106 if Unit.File_Names (Spec) /= null then
1107 Current_Name := Unit.File_Names (Spec).File;
1108 if Current_Verbosity = High then
1109 Write_Str (" Comparing with """);
1110 Write_Str (Get_Name_String (Current_Name));
1115 -- If name same as original name, return original name
1117 if Unit.Name = The_Original_Name
1119 Current_Name = File_Name_Type (The_Original_Name)
1121 if Current_Verbosity = High then
1126 return Get_Name_String
1127 (Unit.File_Names (Spec).Path.Name);
1129 return Get_Name_String (Current_Name);
1132 -- If it has the same name as the extended spec name,
1133 -- return the extended spec name.
1135 elsif Current_Name = File_Name_Type (The_Spec_Name) then
1136 if Current_Verbosity = High then
1141 return Get_Name_String
1142 (Unit.File_Names (Spec).Path.Name);
1144 return Get_Name_String (The_Spec_Name);
1148 if Current_Verbosity = High then
1149 Write_Line (" not good");
1156 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1159 -- If we are not in an extending project, give up
1161 exit when not Main_Project_Only
1162 or else The_Project.Extends = No_Project;
1164 -- Otherwise, look in the project we are extending
1166 The_Project := The_Project.Extends;
1169 -- We don't know this file name, return an empty string
1172 end File_Name_Of_Library_Unit_Body;
1174 -------------------------
1175 -- For_All_Object_Dirs --
1176 -------------------------
1178 procedure For_All_Object_Dirs (Project : Project_Id) is
1179 procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
1180 -- Get all object directories of Prj
1186 procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
1187 pragma Unreferenced (Dummy);
1189 -- ??? Set_Ada_Paths has a different behavior for library project
1190 -- files, should we have the same ?
1192 if Prj.Object_Directory /= No_Path_Information then
1193 Get_Name_String (Prj.Object_Directory.Display_Name);
1194 Action (Name_Buffer (1 .. Name_Len));
1198 procedure Get_Object_Dirs is
1199 new For_Every_Project_Imported (Integer, For_Project);
1200 Dummy : Integer := 1;
1202 -- Start of processing for For_All_Object_Dirs
1205 Get_Object_Dirs (Project, Dummy);
1206 end For_All_Object_Dirs;
1208 -------------------------
1209 -- For_All_Source_Dirs --
1210 -------------------------
1212 procedure For_All_Source_Dirs
1213 (Project : Project_Id;
1214 In_Tree : Project_Tree_Ref)
1216 procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
1217 -- Get all object directories of Prj
1223 procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
1224 pragma Unreferenced (Dummy);
1225 Current : String_List_Id := Prj.Source_Dirs;
1226 The_String : String_Element;
1229 -- If there are Ada sources, call action with the name of every
1230 -- source directory.
1232 if Has_Ada_Sources (Project) then
1233 while Current /= Nil_String loop
1234 The_String := In_Tree.String_Elements.Table (Current);
1235 Action (Get_Name_String (The_String.Display_Value));
1236 Current := The_String.Next;
1241 procedure Get_Source_Dirs is
1242 new For_Every_Project_Imported (Integer, For_Project);
1243 Dummy : Integer := 1;
1245 -- Start of processing for For_All_Source_Dirs
1248 Get_Source_Dirs (Project, Dummy);
1249 end For_All_Source_Dirs;
1255 procedure Get_Reference
1256 (Source_File_Name : String;
1257 In_Tree : Project_Tree_Ref;
1258 Project : out Project_Id;
1259 Path : out Path_Name_Type)
1262 -- Body below could use some comments ???
1264 if Current_Verbosity > Default then
1265 Write_Str ("Getting Reference_Of (""");
1266 Write_Str (Source_File_Name);
1267 Write_Str (""") ... ");
1271 Original_Name : String := Source_File_Name;
1275 Canonical_Case_File_Name (Original_Name);
1276 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1278 while Unit /= null loop
1279 if Unit.File_Names (Spec) /= null
1280 and then Unit.File_Names (Spec).File /= No_File
1282 (Namet.Get_Name_String
1283 (Unit.File_Names (Spec).File) = Original_Name
1284 or else (Unit.File_Names (Spec).Path /=
1287 Namet.Get_Name_String
1288 (Unit.File_Names (Spec).Path.Name) =
1291 Project := Ultimate_Extension_Of
1292 (Project => Unit.File_Names (Spec).Project);
1293 Path := Unit.File_Names (Spec).Path.Display_Name;
1295 if Current_Verbosity > Default then
1296 Write_Str ("Done: Spec.");
1302 elsif Unit.File_Names (Impl) /= null
1303 and then Unit.File_Names (Impl).File /= No_File
1305 (Namet.Get_Name_String
1306 (Unit.File_Names (Impl).File) = Original_Name
1307 or else (Unit.File_Names (Impl).Path /=
1309 and then Namet.Get_Name_String
1310 (Unit.File_Names (Impl).Path.Name) =
1313 Project := Ultimate_Extension_Of
1314 (Project => Unit.File_Names (Impl).Project);
1315 Path := Unit.File_Names (Impl).Path.Display_Name;
1317 if Current_Verbosity > Default then
1318 Write_Str ("Done: Body.");
1325 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1329 Project := No_Project;
1332 if Current_Verbosity > Default then
1333 Write_Str ("Cannot be found.");
1342 procedure Initialize (In_Tree : Project_Tree_Ref) is
1344 In_Tree.Private_Part.Current_Source_Path_File := No_Path;
1345 In_Tree.Private_Part.Current_Object_Path_File := No_Path;
1352 -- Could use some comments in this body ???
1354 procedure Print_Sources (In_Tree : Project_Tree_Ref) is
1358 Write_Line ("List of Sources:");
1360 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1362 while Unit /= No_Unit_Index loop
1364 Write_Line (Namet.Get_Name_String (Unit.Name));
1366 if Unit.File_Names (Spec).File /= No_File then
1367 if Unit.File_Names (Spec).Project = No_Project then
1368 Write_Line (" No project");
1371 Write_Str (" Project: ");
1373 (Unit.File_Names (Spec).Project.Path.Name);
1374 Write_Line (Name_Buffer (1 .. Name_Len));
1377 Write_Str (" spec: ");
1379 (Namet.Get_Name_String
1380 (Unit.File_Names (Spec).File));
1383 if Unit.File_Names (Impl).File /= No_File then
1384 if Unit.File_Names (Impl).Project = No_Project then
1385 Write_Line (" No project");
1388 Write_Str (" Project: ");
1390 (Unit.File_Names (Impl).Project.Path.Name);
1391 Write_Line (Name_Buffer (1 .. Name_Len));
1394 Write_Str (" body: ");
1396 (Namet.Get_Name_String (Unit.File_Names (Impl).File));
1399 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1402 Write_Line ("end of List of Sources.");
1411 Main_Project : Project_Id;
1412 In_Tree : Project_Tree_Ref) return Project_Id
1414 Result : Project_Id := No_Project;
1416 Original_Name : String := Name;
1418 Lang : constant Language_Ptr :=
1419 Get_Language_From_Name (Main_Project, "ada");
1423 Current_Name : File_Name_Type;
1424 The_Original_Name : File_Name_Type;
1425 The_Spec_Name : File_Name_Type;
1426 The_Body_Name : File_Name_Type;
1429 -- ??? Same block in File_Name_Of_Library_Unit_Body
1430 Canonical_Case_File_Name (Original_Name);
1431 Name_Len := Original_Name'Length;
1432 Name_Buffer (1 .. Name_Len) := Original_Name;
1433 The_Original_Name := Name_Find;
1435 if Lang /= null then
1437 Naming : Lang_Naming_Data renames Lang.Config.Naming_Data;
1438 Extended_Spec_Name : String :=
1439 Name & Namet.Get_Name_String
1440 (Naming.Spec_Suffix);
1441 Extended_Body_Name : String :=
1442 Name & Namet.Get_Name_String
1443 (Naming.Body_Suffix);
1446 Canonical_Case_File_Name (Extended_Spec_Name);
1447 Name_Len := Extended_Spec_Name'Length;
1448 Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1449 The_Spec_Name := Name_Find;
1451 Canonical_Case_File_Name (Extended_Body_Name);
1452 Name_Len := Extended_Body_Name'Length;
1453 Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1454 The_Body_Name := Name_Find;
1458 The_Spec_Name := The_Original_Name;
1459 The_Body_Name := The_Original_Name;
1462 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1463 while Unit /= null loop
1465 -- Case of a body present
1467 if Unit.File_Names (Impl) /= null then
1468 Current_Name := Unit.File_Names (Impl).File;
1470 -- If it has the name of the original name or the body name,
1471 -- we have found the project.
1473 if Unit.Name = Name_Id (The_Original_Name)
1474 or else Current_Name = The_Original_Name
1475 or else Current_Name = The_Body_Name
1477 Result := Unit.File_Names (Impl).Project;
1484 if Unit.File_Names (Spec) /= null then
1485 Current_Name := Unit.File_Names (Spec).File;
1487 -- If name same as the original name, or the spec name, we have
1488 -- found the project.
1490 if Unit.Name = Name_Id (The_Original_Name)
1491 or else Current_Name = The_Original_Name
1492 or else Current_Name = The_Spec_Name
1494 Result := Unit.File_Names (Spec).Project;
1499 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1502 -- Get the ultimate extending project
1504 if Result /= No_Project then
1505 while Result.Extended_By /= No_Project loop
1506 Result := Result.Extended_By;
1517 procedure Set_Ada_Paths
1518 (Project : Project_Id;
1519 In_Tree : Project_Tree_Ref;
1520 Including_Libraries : Boolean;
1521 Include_Path : Boolean := True;
1522 Objects_Path : Boolean := True)
1525 Source_Paths : Source_Path_Table.Instance;
1526 Object_Paths : Object_Path_Table.Instance;
1527 -- List of source or object dirs. Only computed the first time this
1528 -- procedure is called (since Source_FD is then reused)
1530 Source_FD : File_Descriptor := Invalid_FD;
1531 Object_FD : File_Descriptor := Invalid_FD;
1532 -- The temporary files to store the paths. These are only created the
1533 -- first time this procedure is called, and reused from then on.
1535 Process_Source_Dirs : Boolean := False;
1536 Process_Object_Dirs : Boolean := False;
1539 -- For calls to Close
1542 Buffer : String_Access := new String (1 .. Buffer_Initial);
1543 Buffer_Last : Natural := 0;
1545 procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean);
1546 -- Recursive procedure to add the source/object paths of extended/
1547 -- imported projects.
1553 procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean) is
1554 pragma Unreferenced (Dummy);
1556 Path : Path_Name_Type;
1559 -- ??? This is almost the equivalent of For_All_Source_Dirs
1561 if Process_Source_Dirs then
1563 -- Add to path all source directories of this project if there are
1566 if Has_Ada_Sources (Project) then
1567 Add_To_Source_Path (Project.Source_Dirs, In_Tree, Source_Paths);
1571 if Process_Object_Dirs then
1572 Path := Get_Object_Directory
1574 Including_Libraries => Including_Libraries,
1575 Only_If_Ada => True);
1577 if Path /= No_Path then
1578 Add_To_Object_Path (Path, Object_Paths);
1583 procedure For_All_Projects is
1584 new For_Every_Project_Imported (Boolean, Recursive_Add);
1586 Dummy : Boolean := False;
1588 -- Start of processing for Set_Ada_Paths
1591 -- If it is the first time we call this procedure for this project,
1592 -- compute the source path and/or the object path.
1594 if Include_Path and then Project.Include_Path_File = No_Path then
1595 Source_Path_Table.Init (Source_Paths);
1596 Process_Source_Dirs := True;
1597 Create_New_Path_File
1598 (In_Tree, Source_FD, Project.Include_Path_File);
1601 -- For the object path, we make a distinction depending on
1602 -- Including_Libraries.
1604 if Objects_Path and Including_Libraries then
1605 if Project.Objects_Path_File_With_Libs = No_Path then
1606 Object_Path_Table.Init (Object_Paths);
1607 Process_Object_Dirs := True;
1608 Create_New_Path_File
1609 (In_Tree, Object_FD, Project.Objects_Path_File_With_Libs);
1612 elsif Objects_Path then
1613 if Project.Objects_Path_File_Without_Libs = No_Path then
1614 Object_Path_Table.Init (Object_Paths);
1615 Process_Object_Dirs := True;
1616 Create_New_Path_File
1617 (In_Tree, Object_FD, Project.Objects_Path_File_Without_Libs);
1621 -- If there is something to do, set Seen to False for all projects,
1622 -- then call the recursive procedure Add for Project.
1624 if Process_Source_Dirs or Process_Object_Dirs then
1625 For_All_Projects (Project, Dummy);
1628 -- Write and close any file that has been created. Source_FD is not set
1629 -- when this subprogram is called a second time or more, since we reuse
1630 -- the previous version of the file.
1632 if Source_FD /= Invalid_FD then
1635 for Index in Source_Path_Table.First ..
1636 Source_Path_Table.Last (Source_Paths)
1638 Get_Name_String (Source_Paths.Table (Index));
1639 Name_Len := Name_Len + 1;
1640 Name_Buffer (Name_Len) := ASCII.LF;
1641 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1644 Last := Write (Source_FD, Buffer (1)'Address, Buffer_Last);
1646 if Last = Buffer_Last then
1647 Close (Source_FD, Status);
1654 Prj.Com.Fail ("could not write temporary file");
1658 if Object_FD /= Invalid_FD then
1661 for Index in Object_Path_Table.First ..
1662 Object_Path_Table.Last (Object_Paths)
1664 Get_Name_String (Object_Paths.Table (Index));
1665 Name_Len := Name_Len + 1;
1666 Name_Buffer (Name_Len) := ASCII.LF;
1667 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1670 Last := Write (Object_FD, Buffer (1)'Address, Buffer_Last);
1672 if Last = Buffer_Last then
1673 Close (Object_FD, Status);
1679 Prj.Com.Fail ("could not write temporary file");
1683 -- Set the env vars, if they need to be changed, and set the
1684 -- corresponding flags.
1686 if Include_Path and then
1687 In_Tree.Private_Part.Current_Source_Path_File /=
1688 Project.Include_Path_File
1690 In_Tree.Private_Part.Current_Source_Path_File :=
1691 Project.Include_Path_File;
1693 (Project_Include_Path_File,
1694 Get_Name_String (In_Tree.Private_Part.Current_Source_Path_File));
1697 if Objects_Path then
1698 if Including_Libraries then
1699 if In_Tree.Private_Part.Current_Object_Path_File /=
1700 Project.Objects_Path_File_With_Libs
1702 In_Tree.Private_Part.Current_Object_Path_File :=
1703 Project.Objects_Path_File_With_Libs;
1705 (Project_Objects_Path_File,
1707 (In_Tree.Private_Part.Current_Object_Path_File));
1711 if In_Tree.Private_Part.Current_Object_Path_File /=
1712 Project.Objects_Path_File_Without_Libs
1714 In_Tree.Private_Part.Current_Object_Path_File :=
1715 Project.Objects_Path_File_Without_Libs;
1717 (Project_Objects_Path_File,
1719 (In_Tree.Private_Part.Current_Object_Path_File));
1727 -----------------------
1728 -- Set_Path_File_Var --
1729 -----------------------
1731 procedure Set_Path_File_Var (Name : String; Value : String) is
1732 Host_Spec : String_Access := To_Host_File_Spec (Value);
1734 if Host_Spec = null then
1736 ("could not convert file name """ & Value & """ to host spec");
1738 Setenv (Name, Host_Spec.all);
1741 end Set_Path_File_Var;
1743 ---------------------------
1744 -- Ultimate_Extension_Of --
1745 ---------------------------
1747 function Ultimate_Extension_Of
1748 (Project : Project_Id) return Project_Id
1750 Result : Project_Id;
1754 while Result.Extended_By /= No_Project loop
1755 Result := Result.Extended_By;
1759 end Ultimate_Extension_Of;
1761 ---------------------
1762 -- Add_Directories --
1763 ---------------------
1765 procedure Add_Directories
1766 (Self : in out Project_Search_Path;
1769 Tmp : String_Access;
1771 if Self.Path = null then
1772 Self.Path := new String'(Uninitialized_Prefix & Path);
1775 Self.Path := new String'(Tmp.all & Path_Separator & Path);
1778 end Add_Directories;
1780 -----------------------------
1781 -- Initialize_Project_Path --
1782 -----------------------------
1784 procedure Initialize_Project_Path
1785 (Self : in out Project_Search_Path;
1786 Target_Name : String)
1788 Add_Default_Dir : Boolean := True;
1792 New_Last : Positive;
1794 Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
1795 Gpr_Project_Path : constant String := "GPR_PROJECT_PATH";
1796 -- Name of alternate env. variable that contain path name(s) of
1797 -- directories where project files may reside. GPR_PROJECT_PATH has
1798 -- precedence over ADA_PROJECT_PATH.
1800 Gpr_Prj_Path : String_Access;
1801 Ada_Prj_Path : String_Access;
1802 -- The path name(s) of directories where project files may reside.
1806 -- If already initialized, nothing else to do
1808 if Self.Path /= null
1809 and then Self.Path (Self.Path'First) /= '#'
1814 -- The current directory is always first in the search path. Since the
1815 -- Project_Path currently starts with '#:' as a sign that it isn't
1816 -- initialized, we simply replace '#' with '.'
1818 if Self.Path = null then
1819 Self.Path := new String'('.' & Path_Separator);
1821 Self.Path (Self.Path'First) := '.';
1824 -- Then the reset of the project path (if any) currently contains the
1825 -- directories added through Add_Search_Project_Directory
1827 -- If environment variables are defined and not empty, add their content
1829 Gpr_Prj_Path := Getenv (Gpr_Project_Path);
1830 Ada_Prj_Path := Getenv (Ada_Project_Path);
1832 if Gpr_Prj_Path.all /= "" then
1833 Add_Directories (Self, Gpr_Prj_Path.all);
1836 Free (Gpr_Prj_Path);
1838 if Ada_Prj_Path.all /= "" then
1839 Add_Directories (Self, Ada_Prj_Path.all);
1842 Free (Ada_Prj_Path);
1844 -- Copy to Name_Buffer, since we will need to manipulate the path
1846 Name_Len := Self.Path'Length;
1847 Name_Buffer (1 .. Name_Len) := Self.Path.all;
1849 -- Scan the directory path to see if "-" is one of the directories.
1850 -- Remove each occurrence of "-" and set Add_Default_Dir to False.
1851 -- Also resolve relative paths and symbolic links.
1855 while First <= Name_Len
1856 and then (Name_Buffer (First) = Path_Separator)
1861 exit when First > Name_Len;
1865 while Last < Name_Len
1866 and then Name_Buffer (Last + 1) /= Path_Separator
1871 -- If the directory is "-", set Add_Default_Dir to False and
1872 -- remove from path.
1874 if Name_Buffer (First .. Last) = No_Project_Default_Dir then
1875 Add_Default_Dir := False;
1877 for J in Last + 1 .. Name_Len loop
1878 Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
1882 Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
1884 -- After removing the '-', go back one character to get the next
1885 -- directory correctly.
1889 elsif not Hostparm.OpenVMS
1890 or else not Is_Absolute_Path (Name_Buffer (First .. Last))
1892 -- On VMS, only expand relative path names, as absolute paths
1893 -- may correspond to multi-valued VMS logical names.
1896 New_Dir : constant String :=
1898 (Name_Buffer (First .. Last),
1899 Resolve_Links => Opt.Follow_Links_For_Dirs);
1902 -- If the absolute path was resolved and is different from
1903 -- the original, replace original with the resolved path.
1905 if New_Dir /= Name_Buffer (First .. Last)
1906 and then New_Dir'Length /= 0
1908 New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
1909 New_Last := First + New_Dir'Length - 1;
1910 Name_Buffer (New_Last + 1 .. New_Len) :=
1911 Name_Buffer (Last + 1 .. Name_Len);
1912 Name_Buffer (First .. New_Last) := New_Dir;
1913 Name_Len := New_Len;
1924 -- Set the initial value of Current_Project_Path
1926 if Add_Default_Dir then
1928 Prefix : String_Ptr := Sdefault.Search_Dir_Prefix;
1931 if Prefix = null then
1932 Prefix := new String'(Executable_Prefix_Path);
1934 if Prefix.all /= "" then
1935 if Target_Name /= "" then
1936 Add_Str_To_Name_Buffer
1937 (Path_Separator & Prefix.all &
1938 "lib" & Directory_Separator & "gpr" &
1939 Directory_Separator & Target_Name);
1942 Add_Str_To_Name_Buffer
1943 (Path_Separator & Prefix.all &
1944 "share" & Directory_Separator & "gpr");
1945 Add_Str_To_Name_Buffer
1946 (Path_Separator & Prefix.all &
1947 "lib" & Directory_Separator & "gnat");
1952 new String'(Name_Buffer (1 .. Name_Len) & Path_Separator &
1954 ".." & Directory_Separator &
1955 ".." & Directory_Separator &
1956 ".." & Directory_Separator & "gnat");
1963 if Self.Path = null then
1964 Self.Path := new String'(Name_Buffer (1 .. Name_Len));
1966 end Initialize_Project_Path;
1973 (Self : in out Project_Search_Path;
1974 Path : out String_Access)
1977 Initialize_Project_Path (Self, ""); -- ??? Target_Name unspecified
1986 (Self : in out Project_Search_Path; Path : String) is
1989 Self.Path := new String'(Path);
1990 Projects_Paths.Reset (Self.Cache);
1997 procedure Find_Project
1998 (Self : in out Project_Search_Path;
1999 Project_File_Name : String;
2001 Path : out Namet.Path_Name_Type)
2003 File : constant String := Project_File_Name;
2004 -- Have to do a copy, in case the parameter is Name_Buffer, which we
2007 function Try_Path_Name (Path : String) return String_Access;
2008 pragma Inline (Try_Path_Name);
2009 -- Try the specified Path
2015 function Try_Path_Name (Path : String) return String_Access is
2018 Result : String_Access := null;
2021 if Current_Verbosity = High then
2022 Write_Str (" Trying ");
2026 if Is_Absolute_Path (Path) then
2027 if Is_Regular_File (Path) then
2028 Result := new String'(Path);
2032 -- Because we don't want to resolve symbolic links, we cannot use
2033 -- Locate_Regular_File. So, we try each possible path
2036 First := Self.Path'First;
2037 while First <= Self.Path'Last loop
2038 while First <= Self.Path'Last
2039 and then Self.Path (First) = Path_Separator
2044 exit when First > Self.Path'Last;
2047 while Last < Self.Path'Last
2048 and then Self.Path (Last + 1) /= Path_Separator
2055 if not Is_Absolute_Path (Self.Path (First .. Last)) then
2056 Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call
2057 Add_Char_To_Name_Buffer (Directory_Separator);
2060 Add_Str_To_Name_Buffer (Self.Path (First .. Last));
2061 Add_Char_To_Name_Buffer (Directory_Separator);
2062 Add_Str_To_Name_Buffer (Path);
2064 if Current_Verbosity = High then
2065 Write_Str (" Testing file ");
2066 Write_Line (Name_Buffer (1 .. Name_Len));
2069 if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
2070 Result := new String'(Name_Buffer (1 .. Name_Len));
2081 -- Local Declarations
2083 Result : String_Access;
2084 Has_Dot : Boolean := False;
2087 -- Start of processing for Find_Project
2090 Initialize_Project_Path (Self, "");
2092 if Current_Verbosity = High then
2093 Write_Str ("Searching for project (""");
2095 Write_Str (""", """);
2096 Write_Str (Directory);
2097 Write_Line (""");");
2100 -- Check the project cache
2102 Name_Len := File'Length;
2103 Name_Buffer (1 .. Name_Len) := File;
2105 Path := Projects_Paths.Get (Self.Cache, Key);
2107 if Path /= No_Path then
2111 -- Check if File contains an extension (a dot before a
2112 -- directory separator). If it is the case we do not try project file
2113 -- with an added extension as it is not possible to have multiple dots
2114 -- on a project file name.
2116 Check_Dot : for K in reverse File'Range loop
2117 if File (K) = '.' then
2122 exit Check_Dot when File (K) = Directory_Separator
2123 or else File (K) = '/';
2126 if not Is_Absolute_Path (File) then
2128 -- First we try <directory>/<file_name>.<extension>
2131 Result := Try_Path_Name
2132 (Directory & Directory_Separator &
2133 File & Project_File_Extension);
2136 -- Then we try <directory>/<file_name>
2138 if Result = null then
2139 Result := Try_Path_Name (Directory & Directory_Separator & File);
2143 -- Then we try <file_name>.<extension>
2145 if Result = null and then not Has_Dot then
2146 Result := Try_Path_Name (File & Project_File_Extension);
2149 -- Then we try <file_name>
2151 if Result = null then
2152 Result := Try_Path_Name (File);
2155 -- If we cannot find the project file, we return an empty string
2157 if Result = null then
2158 Path := Namet.No_Path;
2163 Final_Result : constant String :=
2164 GNAT.OS_Lib.Normalize_Pathname
2166 Directory => Directory,
2167 Resolve_Links => Opt.Follow_Links_For_Files,
2168 Case_Sensitive => True);
2171 Name_Len := Final_Result'Length;
2172 Name_Buffer (1 .. Name_Len) := Final_Result;
2174 Projects_Paths.Set (Self.Cache, Key, Path);
2183 procedure Free (Self : in out Project_Search_Path) is
2186 Projects_Paths.Reset (Self.Cache);