1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2013, 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 Ada
.Text_IO
; use Ada
.Text_IO
;
38 with GNAT
.Directory_Operations
; use GNAT
.Directory_Operations
;
40 package body Prj
.Env
is
42 Buffer_Initial
: constant := 1_000
;
43 -- Initial size of Buffer
45 Uninitialized_Prefix
: constant String := '#' & Path_Separator
;
46 -- Prefix to indicate that the project path has not been initialized yet.
47 -- Must be two characters long
49 No_Project_Default_Dir
: constant String := "-";
50 -- Indicator in the project path to indicate that the default search
51 -- directories should not be added to the path
53 -----------------------
54 -- Local Subprograms --
55 -----------------------
57 package Source_Path_Table
is new GNAT
.Dynamic_Tables
58 (Table_Component_Type
=> Name_Id
,
59 Table_Index_Type
=> Natural,
62 Table_Increment
=> 100);
63 -- A table to store the source dirs before creating the source path file
65 package Object_Path_Table
is new GNAT
.Dynamic_Tables
66 (Table_Component_Type
=> Path_Name_Type
,
67 Table_Index_Type
=> Natural,
70 Table_Increment
=> 100);
71 -- A table to store the object dirs, before creating the object path file
73 procedure Add_To_Buffer
75 Buffer
: in out String_Access
;
76 Buffer_Last
: in out Natural);
77 -- Add a string to Buffer, extending Buffer if needed
80 (Source_Dirs
: String_List_Id
;
81 Shared
: Shared_Project_Tree_Data_Access
;
82 Buffer
: in out String_Access
;
83 Buffer_Last
: in out Natural);
84 -- Add to Ada_Path_Buffer all the source directories in string list
85 -- Source_Dirs, if any.
89 Buffer
: in out String_Access
;
90 Buffer_Last
: in out Natural);
91 -- If Dir is not already in the global variable Ada_Path_Buffer, add it.
92 -- If Buffer_Last /= 0, prepend a Path_Separator character to Path.
94 procedure Add_To_Source_Path
95 (Source_Dirs
: String_List_Id
;
96 Shared
: Shared_Project_Tree_Data_Access
;
97 Source_Paths
: in out Source_Path_Table
.Instance
);
98 -- Add to Ada_Path_B all the source directories in string list
99 -- Source_Dirs, if any. Increment Ada_Path_Length.
101 procedure Add_To_Object_Path
102 (Object_Dir
: Path_Name_Type
;
103 Object_Paths
: in out Object_Path_Table
.Instance
);
104 -- Add Object_Dir to object path table. Make sure it is not duplicate
105 -- and it is the last one in the current table.
107 ----------------------
108 -- Ada_Include_Path --
109 ----------------------
111 function Ada_Include_Path
112 (Project
: Project_Id
;
113 In_Tree
: Project_Tree_Ref
;
114 Recursive
: Boolean := False) return String
116 Buffer
: String_Access
;
117 Buffer_Last
: Natural := 0;
120 (Project
: Project_Id
;
121 In_Tree
: Project_Tree_Ref
;
122 Dummy
: in out Boolean);
123 -- Add source dirs of Project to the path
130 (Project
: Project_Id
;
131 In_Tree
: Project_Tree_Ref
;
132 Dummy
: in out Boolean)
134 pragma Unreferenced
(Dummy
);
137 (Project
.Source_Dirs
, In_Tree
.Shared
, Buffer
, Buffer_Last
);
140 procedure For_All_Projects
is
141 new For_Every_Project_Imported
(Boolean, Add
);
143 Dummy
: Boolean := False;
145 -- Start of processing for Ada_Include_Path
150 -- If it is the first time we call this function for
151 -- this project, compute the source path
153 if Project
.Ada_Include_Path
= null then
154 Buffer
:= new String (1 .. 4096);
156 (Project
, In_Tree
, Dummy
, Include_Aggregated
=> True);
157 Project
.Ada_Include_Path
:= new String'(Buffer (1 .. Buffer_Last));
161 return Project.Ada_Include_Path.all;
164 Buffer := new String (1 .. 4096);
166 (Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last);
169 Result : constant String := Buffer (1 .. Buffer_Last);
175 end Ada_Include_Path;
177 ----------------------
178 -- Ada_Objects_Path --
179 ----------------------
181 function Ada_Objects_Path
182 (Project : Project_Id;
183 In_Tree : Project_Tree_Ref;
184 Including_Libraries : Boolean := True) return String_Access
186 Buffer : String_Access;
187 Buffer_Last : Natural := 0;
190 (Project : Project_Id;
191 In_Tree : Project_Tree_Ref;
192 Dummy : in out Boolean);
193 -- Add all the object directories of a project to the path
200 (Project : Project_Id;
201 In_Tree : Project_Tree_Ref;
202 Dummy : in out Boolean)
204 pragma Unreferenced (Dummy, In_Tree);
206 Path : constant Path_Name_Type :=
209 Including_Libraries => Including_Libraries,
210 Only_If_Ada => False);
212 if Path /= No_Path then
213 Add_To_Path (Get_Name_String (Path), Buffer, Buffer_Last);
217 procedure For_All_Projects is
218 new For_Every_Project_Imported (Boolean, Add);
220 Dummy : Boolean := False;
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 Project.Ada_Objects_Path = null then
229 Buffer := new String (1 .. 4096);
230 For_All_Projects (Project, In_Tree, Dummy);
232 Project.Ada_Objects_Path := new String'(Buffer
(1 .. Buffer_Last
));
236 return Project
.Ada_Objects_Path
;
237 end Ada_Objects_Path
;
243 procedure Add_To_Buffer
245 Buffer
: in out String_Access
;
246 Buffer_Last
: in out Natural)
248 Last
: constant Natural := Buffer_Last
+ S
'Length;
251 while Last
> Buffer
'Last loop
253 New_Buffer
: constant String_Access
:=
254 new String (1 .. 2 * Buffer
'Last);
256 New_Buffer
(1 .. Buffer_Last
) := Buffer
(1 .. Buffer_Last
);
258 Buffer
:= New_Buffer
;
262 Buffer
(Buffer_Last
+ 1 .. Last
) := S
;
266 ------------------------
267 -- Add_To_Object_Path --
268 ------------------------
270 procedure Add_To_Object_Path
271 (Object_Dir
: Path_Name_Type
;
272 Object_Paths
: in out Object_Path_Table
.Instance
)
275 -- Check if the directory is already in the table
278 Object_Path_Table
.First
.. Object_Path_Table
.Last
(Object_Paths
)
281 -- If it is, remove it, and add it as the last one
283 if Object_Paths
.Table
(Index
) = Object_Dir
then
285 Index
+ 1 .. Object_Path_Table
.Last
(Object_Paths
)
287 Object_Paths
.Table
(Index2
- 1) := Object_Paths
.Table
(Index2
);
291 (Object_Path_Table
.Last
(Object_Paths
)) := Object_Dir
;
296 -- The directory is not already in the table, add it
298 Object_Path_Table
.Append
(Object_Paths
, Object_Dir
);
299 end Add_To_Object_Path
;
305 procedure Add_To_Path
306 (Source_Dirs
: String_List_Id
;
307 Shared
: Shared_Project_Tree_Data_Access
;
308 Buffer
: in out String_Access
;
309 Buffer_Last
: in out Natural)
311 Current
: String_List_Id
:= Source_Dirs
;
312 Source_Dir
: String_Element
;
314 while Current
/= Nil_String
loop
315 Source_Dir
:= Shared
.String_Elements
.Table
(Current
);
316 Add_To_Path
(Get_Name_String
(Source_Dir
.Display_Value
),
317 Buffer
, Buffer_Last
);
318 Current
:= Source_Dir
.Next
;
322 procedure Add_To_Path
324 Buffer
: in out String_Access
;
325 Buffer_Last
: in out Natural)
328 New_Buffer
: String_Access
;
331 function Is_Present
(Path
: String; Dir
: String) return Boolean;
332 -- Return True if Dir is part of Path
338 function Is_Present
(Path
: String; Dir
: String) return Boolean is
339 Last
: constant Integer := Path
'Last - Dir
'Length + 1;
342 for J
in Path
'First .. Last
loop
344 -- Note: the order of the conditions below is important, since
345 -- it ensures a minimal number of string comparisons.
348 or else Path
(J
- 1) = Path_Separator
)
350 (J
+ Dir
'Length > Path
'Last
351 or else Path
(J
+ Dir
'Length) = Path_Separator
)
352 and then Dir
= Path
(J
.. J
+ Dir
'Length - 1)
361 -- Start of processing for Add_To_Path
364 if Is_Present
(Buffer
(1 .. Buffer_Last
), Dir
) then
366 -- Dir is already in the path, nothing to do
371 Min_Len
:= Buffer_Last
+ Dir
'Length;
373 if Buffer_Last
> 0 then
375 -- Add 1 for the Path_Separator character
377 Min_Len
:= Min_Len
+ 1;
380 -- If Ada_Path_Buffer is too small, increase it
384 if Len
< Min_Len
then
387 exit when Len
>= Min_Len
;
390 New_Buffer
:= new String (1 .. Len
);
391 New_Buffer
(1 .. Buffer_Last
) := Buffer
(1 .. Buffer_Last
);
393 Buffer
:= New_Buffer
;
396 if Buffer_Last
> 0 then
397 Buffer_Last
:= Buffer_Last
+ 1;
398 Buffer
(Buffer_Last
) := Path_Separator
;
401 Buffer
(Buffer_Last
+ 1 .. Buffer_Last
+ Dir
'Length) := Dir
;
402 Buffer_Last
:= Buffer_Last
+ Dir
'Length;
405 ------------------------
406 -- Add_To_Source_Path --
407 ------------------------
409 procedure Add_To_Source_Path
410 (Source_Dirs
: String_List_Id
;
411 Shared
: Shared_Project_Tree_Data_Access
;
412 Source_Paths
: in out Source_Path_Table
.Instance
)
414 Current
: String_List_Id
:= Source_Dirs
;
415 Source_Dir
: String_Element
;
419 -- Add each source directory
421 while Current
/= Nil_String
loop
422 Source_Dir
:= Shared
.String_Elements
.Table
(Current
);
425 -- Check if the source directory is already in the table
428 Source_Path_Table
.First
.. Source_Path_Table
.Last
(Source_Paths
)
430 -- If it is already, no need to add it
432 if Source_Paths
.Table
(Index
) = Source_Dir
.Value
then
439 Source_Path_Table
.Append
(Source_Paths
, Source_Dir
.Display_Value
);
442 -- Next source directory
444 Current
:= Source_Dir
.Next
;
446 end Add_To_Source_Path
;
448 --------------------------------
449 -- Create_Config_Pragmas_File --
450 --------------------------------
452 procedure Create_Config_Pragmas_File
453 (For_Project
: Project_Id
;
454 In_Tree
: Project_Tree_Ref
)
456 type Naming_Id
is new Nat
;
457 package Naming_Table
is new GNAT
.Dynamic_Tables
458 (Table_Component_Type
=> Lang_Naming_Data
,
459 Table_Index_Type
=> Naming_Id
,
460 Table_Low_Bound
=> 1,
462 Table_Increment
=> 100);
464 Default_Naming
: constant Naming_Id
:= Naming_Table
.First
;
465 Namings
: Naming_Table
.Instance
;
466 -- Table storing the naming data for gnatmake/gprmake
468 Buffer
: String_Access
:= new String (1 .. Buffer_Initial
);
469 Buffer_Last
: Natural := 0;
471 File_Name
: Path_Name_Type
:= No_Path
;
472 File
: File_Descriptor
:= Invalid_FD
;
474 Current_Naming
: Naming_Id
;
477 (Project
: Project_Id
;
478 In_Tree
: Project_Tree_Ref
;
479 State
: in out Integer);
480 -- Recursive procedure that put in the config pragmas file any non
481 -- standard naming schemes, if it is not already in the file, then call
482 -- itself for any imported project.
484 procedure Put
(Source
: Source_Id
);
485 -- Put an SFN pragma in the temporary file
487 procedure Put
(S
: String);
488 procedure Put_Line
(S
: String);
489 -- Output procedures, analogous to normal Text_IO procs of same name.
490 -- The text is put in Buffer, then it will be written into a temporary
491 -- file with procedure Write_Temp_File below.
493 procedure Write_Temp_File
;
494 -- Create a temporary file and put the content of the buffer in it
501 (Project
: Project_Id
;
502 In_Tree
: Project_Tree_Ref
;
503 State
: in out Integer)
505 pragma Unreferenced
(State
);
507 Lang
: constant Language_Ptr
:=
508 Get_Language_From_Name
(Project
, "ada");
509 Naming
: Lang_Naming_Data
;
510 Iter
: Source_Iterator
;
514 if Current_Verbosity
= High
then
515 Debug_Output
("Checking project file:", Project
.Name
);
519 if Current_Verbosity
= High
then
520 Debug_Output
("Languages does not contain Ada, nothing to do");
526 -- Visit all the files and process those that need an SFN pragma
528 Iter
:= For_Each_Source
(In_Tree
, Project
);
529 while Element
(Iter
) /= No_Source
loop
530 Source
:= Element
(Iter
);
532 if not Source
.Locally_Removed
533 and then Source
.Unit
/= null
535 (Source
.Index
>= 1 or else Source
.Naming_Exception
/= No
)
543 Naming
:= Lang
.Config
.Naming_Data
;
545 -- Is the naming scheme of this project one that we know?
547 Current_Naming
:= Default_Naming
;
548 while Current_Naming
<= Naming_Table
.Last
(Namings
)
549 and then Namings
.Table
(Current_Naming
).Dot_Replacement
=
550 Naming
.Dot_Replacement
551 and then Namings
.Table
(Current_Naming
).Casing
=
553 and then Namings
.Table
(Current_Naming
).Separate_Suffix
=
554 Naming
.Separate_Suffix
556 Current_Naming
:= Current_Naming
+ 1;
559 -- If we don't know it, add it
561 if Current_Naming
> Naming_Table
.Last
(Namings
) then
562 Naming_Table
.Increment_Last
(Namings
);
563 Namings
.Table
(Naming_Table
.Last
(Namings
)) := Naming
;
565 -- Put the SFN pragmas for the naming scheme
570 ("pragma Source_File_Name_Project");
572 (" (Spec_File_Name => ""*" &
573 Get_Name_String
(Naming
.Spec_Suffix
) & """,");
576 Image
(Naming
.Casing
) & ",");
578 (" Dot_Replacement => """ &
579 Get_Name_String
(Naming
.Dot_Replacement
) & """);");
584 ("pragma Source_File_Name_Project");
586 (" (Body_File_Name => ""*" &
587 Get_Name_String
(Naming
.Body_Suffix
) & """,");
590 Image
(Naming
.Casing
) & ",");
592 (" Dot_Replacement => """ &
593 Get_Name_String
(Naming
.Dot_Replacement
) &
596 -- and maybe separate
598 if Naming
.Body_Suffix
/= Naming
.Separate_Suffix
then
599 Put_Line
("pragma Source_File_Name_Project");
601 (" (Subunit_File_Name => ""*" &
602 Get_Name_String
(Naming
.Separate_Suffix
) & """,");
605 Image
(Naming
.Casing
) & ",");
607 (" Dot_Replacement => """ &
608 Get_Name_String
(Naming
.Dot_Replacement
) &
618 procedure Put
(Source
: Source_Id
) is
620 -- Put the pragma SFN for the unit kind (spec or body)
622 Put
("pragma Source_File_Name_Project (");
623 Put
(Namet
.Get_Name_String
(Source
.Unit
.Name
));
625 if Source
.Kind
= Spec
then
626 Put
(", Spec_File_Name => """);
628 Put
(", Body_File_Name => """);
631 Put
(Namet
.Get_Name_String
(Source
.File
));
634 if Source
.Index
/= 0 then
636 Put
(Source
.Index
'Img);
642 procedure Put
(S
: String) is
644 Add_To_Buffer
(S
, Buffer
, Buffer_Last
);
646 if Current_Verbosity
= High
then
655 procedure Put_Line
(S
: String) is
657 -- Add an ASCII.LF to the string. As this config file is supposed to
658 -- be used only by the compiler, we don't care about the characters
659 -- for the end of line. In fact we could have put a space, but
660 -- it is more convenient to be able to read gnat.adc during
661 -- development, for which the ASCII.LF is fine.
664 Put
(S
=> (1 => ASCII
.LF
));
667 ---------------------
668 -- Write_Temp_File --
669 ---------------------
671 procedure Write_Temp_File
is
672 Status
: Boolean := False;
676 Tempdir
.Create_Temp_File
(File
, File_Name
);
678 if File
/= Invalid_FD
then
679 Last
:= Write
(File
, Buffer
(1)'Address, Buffer_Last
);
681 if Last
= Buffer_Last
then
682 Close
(File
, Status
);
687 Prj
.Com
.Fail
("unable to create temporary file");
691 procedure Check_Imported_Projects
is
692 new For_Every_Project_Imported
(Integer, Check
);
694 Dummy
: Integer := 0;
696 -- Start of processing for Create_Config_Pragmas_File
699 if not For_Project
.Config_Checked
then
700 Naming_Table
.Init
(Namings
);
702 -- Check the naming schemes
704 Check_Imported_Projects
705 (For_Project
, In_Tree
, Dummy
, Imported_First
=> False);
707 -- If there are no non standard naming scheme, issue the GNAT
708 -- standard naming scheme. This will tell the compiler that
709 -- a project file is used and will forbid any pragma SFN.
711 if Buffer_Last
= 0 then
713 Put_Line
("pragma Source_File_Name_Project");
714 Put_Line
(" (Spec_File_Name => ""*.ads"",");
715 Put_Line
(" Dot_Replacement => ""-"",");
716 Put_Line
(" Casing => lowercase);");
718 Put_Line
("pragma Source_File_Name_Project");
719 Put_Line
(" (Body_File_Name => ""*.adb"",");
720 Put_Line
(" Dot_Replacement => ""-"",");
721 Put_Line
(" Casing => lowercase);");
724 -- Close the temporary file
728 if Opt
.Verbose_Mode
then
729 Write_Str
("Created configuration file """);
730 Write_Str
(Get_Name_String
(File_Name
));
734 For_Project
.Config_File_Name
:= File_Name
;
735 For_Project
.Config_File_Temp
:= True;
736 For_Project
.Config_Checked
:= True;
740 end Create_Config_Pragmas_File
;
746 procedure Create_Mapping
(In_Tree
: Project_Tree_Ref
) is
748 Iter
: Source_Iterator
;
753 Iter
:= For_Each_Source
(In_Tree
);
755 Data
:= Element
(Iter
);
756 exit when Data
= No_Source
;
758 if Data
.Unit
/= No_Unit_Index
then
759 if Data
.Locally_Removed
and then not Data
.Suppressed
then
760 Fmap
.Add_Forbidden_File_Name
(Data
.File
);
763 (Unit_Name
=> Unit_Name_Type
(Data
.Unit
.Name
),
764 File_Name
=> Data
.File
,
765 Path_Name
=> File_Name_Type
(Data
.Path
.Display_Name
));
773 -------------------------
774 -- Create_Mapping_File --
775 -------------------------
777 procedure Create_Mapping_File
778 (Project
: Project_Id
;
780 In_Tree
: Project_Tree_Ref
;
781 Name
: out Path_Name_Type
)
783 File
: File_Descriptor
:= Invalid_FD
;
784 Buffer
: String_Access
:= new String (1 .. Buffer_Initial
);
785 Buffer_Last
: Natural := 0;
787 procedure Put_Name_Buffer
;
788 -- Put the line contained in the Name_Buffer in the global buffer
791 (Project
: Project_Id
;
792 In_Tree
: Project_Tree_Ref
;
793 State
: in out Integer);
794 -- Generate the mapping file for Project (not recursively)
796 ---------------------
797 -- Put_Name_Buffer --
798 ---------------------
800 procedure Put_Name_Buffer
is
802 if Current_Verbosity
= High
then
803 Debug_Output
(Name_Buffer
(1 .. Name_Len
));
806 Name_Len
:= Name_Len
+ 1;
807 Name_Buffer
(Name_Len
) := ASCII
.LF
;
808 Add_To_Buffer
(Name_Buffer
(1 .. Name_Len
), Buffer
, Buffer_Last
);
816 (Project
: Project_Id
;
817 In_Tree
: Project_Tree_Ref
;
818 State
: in out Integer)
820 pragma Unreferenced
(State
);
823 Suffix
: File_Name_Type
;
824 Iter
: Source_Iterator
;
827 Debug_Output
("Add mapping for project", Project
.Name
);
828 Iter
:= For_Each_Source
(In_Tree
, Project
, Language
=> Language
);
831 Source
:= Prj
.Element
(Iter
);
832 exit when Source
= No_Source
;
834 if not Source
.Suppressed
835 and then Source
.Replaced_By
= No_Source
836 and then Source
.Path
.Name
/= No_Path
837 and then (Source
.Language
.Config
.Kind
= File_Based
838 or else Source
.Unit
/= No_Unit_Index
)
840 if Source
.Unit
/= No_Unit_Index
then
842 -- Put the encoded unit name in the name buffer
845 Uname
: constant String :=
846 Get_Name_String
(Source
.Unit
.Name
);
850 for J
in Uname
'Range loop
851 if Uname
(J
) in Upper_Half_Character
then
852 Store_Encoded_Character
(Get_Char_Code
(Uname
(J
)));
854 Add_Char_To_Name_Buffer
(Uname
(J
));
859 if Source
.Language
.Config
.Kind
= Unit_Based
then
861 -- ??? Mapping_Spec_Suffix could be set in the case of
864 Add_Char_To_Name_Buffer
('%');
866 if Source
.Kind
= Spec
then
867 Add_Char_To_Name_Buffer
('s');
869 Add_Char_To_Name_Buffer
('b');
876 Source
.Language
.Config
.Mapping_Spec_Suffix
;
879 Source
.Language
.Config
.Mapping_Body_Suffix
;
882 if Suffix
/= No_File
then
883 Add_Str_To_Name_Buffer
(Get_Name_String
(Suffix
));
890 Get_Name_String
(Source
.Display_File
);
893 if Source
.Locally_Removed
then
895 Name_Buffer
(1) := '/';
897 Get_Name_String
(Source
.Path
.Display_Name
);
907 procedure For_Every_Imported_Project
is new
908 For_Every_Project_Imported
(State
=> Integer, Action
=> Process
);
912 Dummy
: Integer := 0;
914 -- Start of processing for Create_Mapping_File
917 if Current_Verbosity
= High
then
918 Debug_Output
("Create mapping file for", Debug_Name
(In_Tree
));
921 Create_Temp_File
(In_Tree
.Shared
, File
, Name
, "mapping");
923 if Current_Verbosity
= High
then
924 Debug_Increase_Indent
("Create mapping file ", Name_Id
(Name
));
927 For_Every_Imported_Project
928 (Project
, In_Tree
, Dummy
, Include_Aggregated
=> False);
932 Status
: Boolean := False;
935 if File
/= Invalid_FD
then
936 Last
:= Write
(File
, Buffer
(1)'Address, Buffer_Last
);
938 if Last
= Buffer_Last
then
939 GNAT
.OS_Lib
.Close
(File
, Status
);
944 Prj
.Com
.Fail
("could not write mapping file");
950 Debug_Decrease_Indent
("Done create mapping file");
951 end Create_Mapping_File
;
953 ----------------------
954 -- Create_Temp_File --
955 ----------------------
957 procedure Create_Temp_File
958 (Shared
: Shared_Project_Tree_Data_Access
;
959 Path_FD
: out File_Descriptor
;
960 Path_Name
: out Path_Name_Type
;
964 Tempdir
.Create_Temp_File
(Path_FD
, Path_Name
);
966 if Path_Name
/= No_Path
then
967 if Current_Verbosity
= High
then
968 Write_Line
("Create temp file (" & File_Use
& ") "
969 & Get_Name_String
(Path_Name
));
972 Record_Temp_File
(Shared
, Path_Name
);
976 ("unable to create temporary " & File_Use
& " file");
978 end Create_Temp_File
;
980 --------------------------
981 -- Create_New_Path_File --
982 --------------------------
984 procedure Create_New_Path_File
985 (Shared
: Shared_Project_Tree_Data_Access
;
986 Path_FD
: out File_Descriptor
;
987 Path_Name
: out Path_Name_Type
)
990 Create_Temp_File
(Shared
, Path_FD
, Path_Name
, "path file");
991 end Create_New_Path_File
;
993 ------------------------------------
994 -- File_Name_Of_Library_Unit_Body --
995 ------------------------------------
997 function File_Name_Of_Library_Unit_Body
999 Project
: Project_Id
;
1000 In_Tree
: Project_Tree_Ref
;
1001 Main_Project_Only
: Boolean := True;
1002 Full_Path
: Boolean := False) return String
1005 Lang
: constant Language_Ptr
:=
1006 Get_Language_From_Name
(Project
, "ada");
1007 The_Project
: Project_Id
:= Project
;
1008 Original_Name
: String := Name
;
1011 The_Original_Name
: Name_Id
;
1012 The_Spec_Name
: Name_Id
;
1013 The_Body_Name
: Name_Id
;
1016 -- ??? Same block in Project_Of
1017 Canonical_Case_File_Name
(Original_Name
);
1018 Name_Len
:= Original_Name
'Length;
1019 Name_Buffer
(1 .. Name_Len
) := Original_Name
;
1020 The_Original_Name
:= Name_Find
;
1022 if Lang
/= null then
1024 Naming
: constant Lang_Naming_Data
:= Lang
.Config
.Naming_Data
;
1025 Extended_Spec_Name
: String :=
1026 Name
& Namet
.Get_Name_String
1027 (Naming
.Spec_Suffix
);
1028 Extended_Body_Name
: String :=
1029 Name
& Namet
.Get_Name_String
1030 (Naming
.Body_Suffix
);
1033 Canonical_Case_File_Name
(Extended_Spec_Name
);
1034 Name_Len
:= Extended_Spec_Name
'Length;
1035 Name_Buffer
(1 .. Name_Len
) := Extended_Spec_Name
;
1036 The_Spec_Name
:= Name_Find
;
1038 Canonical_Case_File_Name
(Extended_Body_Name
);
1039 Name_Len
:= Extended_Body_Name
'Length;
1040 Name_Buffer
(1 .. Name_Len
) := Extended_Body_Name
;
1041 The_Body_Name
:= Name_Find
;
1045 Name_Len
:= Name
'Length;
1046 Name_Buffer
(1 .. Name_Len
) := Name
;
1047 Canonical_Case_File_Name
(Name_Buffer
);
1048 The_Spec_Name
:= Name_Find
;
1049 The_Body_Name
:= The_Spec_Name
;
1052 if Current_Verbosity
= High
then
1053 Write_Str
("Looking for file name of """);
1057 Write_Str
(" Extended Spec Name = """);
1058 Write_Str
(Get_Name_String
(The_Spec_Name
));
1061 Write_Str
(" Extended Body Name = """);
1062 Write_Str
(Get_Name_String
(The_Body_Name
));
1067 -- For extending project, search in the extended project if the source
1068 -- is not found. For non extending projects, this loop will be run only
1072 -- Loop through units
1074 Unit
:= Units_Htable
.Get_First
(In_Tree
.Units_HT
);
1075 while Unit
/= null loop
1078 if not Main_Project_Only
1080 (Unit
.File_Names
(Impl
) /= null
1081 and then Unit
.File_Names
(Impl
).Project
= The_Project
)
1084 Current_Name
: File_Name_Type
;
1086 -- Case of a body present
1088 if Unit
.File_Names
(Impl
) /= null then
1089 Current_Name
:= Unit
.File_Names
(Impl
).File
;
1091 if Current_Verbosity
= High
then
1092 Write_Str
(" Comparing with """);
1093 Write_Str
(Get_Name_String
(Current_Name
));
1098 -- If it has the name of the original name, return the
1101 if Unit
.Name
= The_Original_Name
1103 Current_Name
= File_Name_Type
(The_Original_Name
)
1105 if Current_Verbosity
= High
then
1110 return Get_Name_String
1111 (Unit
.File_Names
(Impl
).Path
.Name
);
1114 return Get_Name_String
(Current_Name
);
1117 -- If it has the name of the extended body name,
1118 -- return the extended body name
1120 elsif Current_Name
= File_Name_Type
(The_Body_Name
) then
1121 if Current_Verbosity
= High
then
1126 return Get_Name_String
1127 (Unit
.File_Names
(Impl
).Path
.Name
);
1130 return Get_Name_String
(The_Body_Name
);
1134 if Current_Verbosity
= High
then
1135 Write_Line
(" not good");
1144 if not Main_Project_Only
1145 or else (Unit
.File_Names
(Spec
) /= null
1146 and then Unit
.File_Names
(Spec
).Project
= The_Project
)
1149 Current_Name
: File_Name_Type
;
1152 -- Case of spec present
1154 if Unit
.File_Names
(Spec
) /= null then
1155 Current_Name
:= Unit
.File_Names
(Spec
).File
;
1156 if Current_Verbosity
= High
then
1157 Write_Str
(" Comparing with """);
1158 Write_Str
(Get_Name_String
(Current_Name
));
1163 -- If name same as original name, return original name
1165 if Unit
.Name
= The_Original_Name
1167 Current_Name
= File_Name_Type
(The_Original_Name
)
1169 if Current_Verbosity
= High
then
1174 return Get_Name_String
1175 (Unit
.File_Names
(Spec
).Path
.Name
);
1177 return Get_Name_String
(Current_Name
);
1180 -- If it has the same name as the extended spec name,
1181 -- return the extended spec name.
1183 elsif Current_Name
= File_Name_Type
(The_Spec_Name
) then
1184 if Current_Verbosity
= High
then
1189 return Get_Name_String
1190 (Unit
.File_Names
(Spec
).Path
.Name
);
1192 return Get_Name_String
(The_Spec_Name
);
1196 if Current_Verbosity
= High
then
1197 Write_Line
(" not good");
1204 Unit
:= Units_Htable
.Get_Next
(In_Tree
.Units_HT
);
1207 -- If we are not in an extending project, give up
1209 exit when not Main_Project_Only
1210 or else The_Project
.Extends
= No_Project
;
1212 -- Otherwise, look in the project we are extending
1214 The_Project
:= The_Project
.Extends
;
1217 -- We don't know this file name, return an empty string
1220 end File_Name_Of_Library_Unit_Body
;
1222 -------------------------
1223 -- For_All_Object_Dirs --
1224 -------------------------
1226 procedure For_All_Object_Dirs
1227 (Project
: Project_Id
;
1228 Tree
: Project_Tree_Ref
)
1230 procedure For_Project
1232 Tree
: Project_Tree_Ref
;
1233 Dummy
: in out Integer);
1234 -- Get all object directories of Prj
1240 procedure For_Project
1242 Tree
: Project_Tree_Ref
;
1243 Dummy
: in out Integer)
1245 pragma Unreferenced
(Dummy
, Tree
);
1248 -- ??? Set_Ada_Paths has a different behavior for library project
1249 -- files, should we have the same ?
1251 if Prj
.Object_Directory
/= No_Path_Information
then
1252 Get_Name_String
(Prj
.Object_Directory
.Display_Name
);
1253 Action
(Name_Buffer
(1 .. Name_Len
));
1257 procedure Get_Object_Dirs
is
1258 new For_Every_Project_Imported
(Integer, For_Project
);
1259 Dummy
: Integer := 1;
1261 -- Start of processing for For_All_Object_Dirs
1264 Get_Object_Dirs
(Project
, Tree
, Dummy
);
1265 end For_All_Object_Dirs
;
1267 -------------------------
1268 -- For_All_Source_Dirs --
1269 -------------------------
1271 procedure For_All_Source_Dirs
1272 (Project
: Project_Id
;
1273 In_Tree
: Project_Tree_Ref
)
1275 procedure For_Project
1277 In_Tree
: Project_Tree_Ref
;
1278 Dummy
: in out Integer);
1279 -- Get all object directories of Prj
1285 procedure For_Project
1287 In_Tree
: Project_Tree_Ref
;
1288 Dummy
: in out Integer)
1290 pragma Unreferenced
(Dummy
);
1292 Current
: String_List_Id
:= Prj
.Source_Dirs
;
1293 The_String
: String_Element
;
1296 -- If there are Ada sources, call action with the name of every
1297 -- source directory.
1299 if Has_Ada_Sources
(Prj
) then
1300 while Current
/= Nil_String
loop
1301 The_String
:= In_Tree
.Shared
.String_Elements
.Table
(Current
);
1302 Action
(Get_Name_String
(The_String
.Display_Value
));
1303 Current
:= The_String
.Next
;
1308 procedure Get_Source_Dirs
is
1309 new For_Every_Project_Imported
(Integer, For_Project
);
1310 Dummy
: Integer := 1;
1312 -- Start of processing for For_All_Source_Dirs
1315 Get_Source_Dirs
(Project
, In_Tree
, Dummy
);
1316 end For_All_Source_Dirs
;
1322 procedure Get_Reference
1323 (Source_File_Name
: String;
1324 In_Tree
: Project_Tree_Ref
;
1325 Project
: out Project_Id
;
1326 Path
: out Path_Name_Type
)
1329 -- Body below could use some comments ???
1331 if Current_Verbosity
> Default
then
1332 Write_Str
("Getting Reference_Of (""");
1333 Write_Str
(Source_File_Name
);
1334 Write_Str
(""") ... ");
1338 Original_Name
: String := Source_File_Name
;
1342 Canonical_Case_File_Name
(Original_Name
);
1343 Unit
:= Units_Htable
.Get_First
(In_Tree
.Units_HT
);
1345 while Unit
/= null loop
1346 if Unit
.File_Names
(Spec
) /= null
1347 and then not Unit
.File_Names
(Spec
).Locally_Removed
1348 and then Unit
.File_Names
(Spec
).File
/= No_File
1350 (Namet
.Get_Name_String
1351 (Unit
.File_Names
(Spec
).File
) = Original_Name
1352 or else (Unit
.File_Names
(Spec
).Path
/= No_Path_Information
1354 Namet
.Get_Name_String
1355 (Unit
.File_Names
(Spec
).Path
.Name
) =
1359 Ultimate_Extending_Project_Of
1360 (Unit
.File_Names
(Spec
).Project
);
1361 Path
:= Unit
.File_Names
(Spec
).Path
.Display_Name
;
1363 if Current_Verbosity
> Default
then
1364 Write_Str
("Done: Spec.");
1370 elsif Unit
.File_Names
(Impl
) /= null
1371 and then Unit
.File_Names
(Impl
).File
/= No_File
1372 and then not Unit
.File_Names
(Impl
).Locally_Removed
1374 (Namet
.Get_Name_String
1375 (Unit
.File_Names
(Impl
).File
) = Original_Name
1376 or else (Unit
.File_Names
(Impl
).Path
/= No_Path_Information
1377 and then Namet
.Get_Name_String
1378 (Unit
.File_Names
(Impl
).Path
.Name
) =
1382 Ultimate_Extending_Project_Of
1383 (Unit
.File_Names
(Impl
).Project
);
1384 Path
:= Unit
.File_Names
(Impl
).Path
.Display_Name
;
1386 if Current_Verbosity
> Default
then
1387 Write_Str
("Done: Body.");
1394 Unit
:= Units_Htable
.Get_Next
(In_Tree
.Units_HT
);
1398 Project
:= No_Project
;
1401 if Current_Verbosity
> Default
then
1402 Write_Str
("Cannot be found.");
1407 ----------------------
1408 -- Get_Runtime_Path --
1409 ----------------------
1411 function Get_Runtime_Path
1412 (Self
: Project_Search_Path
;
1413 Name
: String) return String_Access
1415 function Is_Base_Name
(Path
: String) return Boolean;
1416 -- Returns True if Path has no directory separator
1422 function Is_Base_Name
(Path
: String) return Boolean is
1424 for J
in Path
'Range loop
1425 if Path
(J
) = Directory_Separator
or else Path
(J
) = '/' then
1433 function Find_Rts_In_Path
is new Prj
.Env
.Find_Name_In_Path
1434 (Check_Filename
=> Is_Directory
);
1436 -- Start of processing for Get_Runtime_Path
1439 if not Is_Base_Name
(Name
) then
1440 return Find_Rts_In_Path
(Self
, Name
);
1444 end Get_Runtime_Path
;
1450 procedure Initialize
(In_Tree
: Project_Tree_Ref
) is
1452 In_Tree
.Shared
.Private_Part
.Current_Source_Path_File
:= No_Path
;
1453 In_Tree
.Shared
.Private_Part
.Current_Object_Path_File
:= No_Path
;
1460 -- Could use some comments in this body ???
1462 procedure Print_Sources
(In_Tree
: Project_Tree_Ref
) is
1466 Write_Line
("List of Sources:");
1468 Unit
:= Units_Htable
.Get_First
(In_Tree
.Units_HT
);
1470 while Unit
/= No_Unit_Index
loop
1472 Write_Line
(Namet
.Get_Name_String
(Unit
.Name
));
1474 if Unit
.File_Names
(Spec
).File
/= No_File
then
1475 if Unit
.File_Names
(Spec
).Project
= No_Project
then
1476 Write_Line
(" No project");
1479 Write_Str
(" Project: ");
1481 (Unit
.File_Names
(Spec
).Project
.Path
.Name
);
1482 Write_Line
(Name_Buffer
(1 .. Name_Len
));
1485 Write_Str
(" spec: ");
1487 (Namet
.Get_Name_String
1488 (Unit
.File_Names
(Spec
).File
));
1491 if Unit
.File_Names
(Impl
).File
/= No_File
then
1492 if Unit
.File_Names
(Impl
).Project
= No_Project
then
1493 Write_Line
(" No project");
1496 Write_Str
(" Project: ");
1498 (Unit
.File_Names
(Impl
).Project
.Path
.Name
);
1499 Write_Line
(Name_Buffer
(1 .. Name_Len
));
1502 Write_Str
(" body: ");
1504 (Namet
.Get_Name_String
(Unit
.File_Names
(Impl
).File
));
1507 Unit
:= Units_Htable
.Get_Next
(In_Tree
.Units_HT
);
1510 Write_Line
("end of List of Sources.");
1519 Main_Project
: Project_Id
;
1520 In_Tree
: Project_Tree_Ref
) return Project_Id
1522 Result
: Project_Id
:= No_Project
;
1524 Original_Name
: String := Name
;
1526 Lang
: constant Language_Ptr
:=
1527 Get_Language_From_Name
(Main_Project
, "ada");
1531 Current_Name
: File_Name_Type
;
1532 The_Original_Name
: File_Name_Type
;
1533 The_Spec_Name
: File_Name_Type
;
1534 The_Body_Name
: File_Name_Type
;
1537 -- ??? Same block in File_Name_Of_Library_Unit_Body
1538 Canonical_Case_File_Name
(Original_Name
);
1539 Name_Len
:= Original_Name
'Length;
1540 Name_Buffer
(1 .. Name_Len
) := Original_Name
;
1541 The_Original_Name
:= Name_Find
;
1543 if Lang
/= null then
1545 Naming
: Lang_Naming_Data
renames Lang
.Config
.Naming_Data
;
1546 Extended_Spec_Name
: String :=
1547 Name
& Namet
.Get_Name_String
1548 (Naming
.Spec_Suffix
);
1549 Extended_Body_Name
: String :=
1550 Name
& Namet
.Get_Name_String
1551 (Naming
.Body_Suffix
);
1554 Canonical_Case_File_Name
(Extended_Spec_Name
);
1555 Name_Len
:= Extended_Spec_Name
'Length;
1556 Name_Buffer
(1 .. Name_Len
) := Extended_Spec_Name
;
1557 The_Spec_Name
:= Name_Find
;
1559 Canonical_Case_File_Name
(Extended_Body_Name
);
1560 Name_Len
:= Extended_Body_Name
'Length;
1561 Name_Buffer
(1 .. Name_Len
) := Extended_Body_Name
;
1562 The_Body_Name
:= Name_Find
;
1566 The_Spec_Name
:= The_Original_Name
;
1567 The_Body_Name
:= The_Original_Name
;
1570 Unit
:= Units_Htable
.Get_First
(In_Tree
.Units_HT
);
1571 while Unit
/= null loop
1573 -- Case of a body present
1575 if Unit
.File_Names
(Impl
) /= null then
1576 Current_Name
:= Unit
.File_Names
(Impl
).File
;
1578 -- If it has the name of the original name or the body name,
1579 -- we have found the project.
1581 if Unit
.Name
= Name_Id
(The_Original_Name
)
1582 or else Current_Name
= The_Original_Name
1583 or else Current_Name
= The_Body_Name
1585 Result
:= Unit
.File_Names
(Impl
).Project
;
1592 if Unit
.File_Names
(Spec
) /= null then
1593 Current_Name
:= Unit
.File_Names
(Spec
).File
;
1595 -- If name same as the original name, or the spec name, we have
1596 -- found the project.
1598 if Unit
.Name
= Name_Id
(The_Original_Name
)
1599 or else Current_Name
= The_Original_Name
1600 or else Current_Name
= The_Spec_Name
1602 Result
:= Unit
.File_Names
(Spec
).Project
;
1607 Unit
:= Units_Htable
.Get_Next
(In_Tree
.Units_HT
);
1610 return Ultimate_Extending_Project_Of
(Result
);
1617 procedure Set_Ada_Paths
1618 (Project
: Project_Id
;
1619 In_Tree
: Project_Tree_Ref
;
1620 Including_Libraries
: Boolean;
1621 Include_Path
: Boolean := True;
1622 Objects_Path
: Boolean := True)
1625 Shared
: constant Shared_Project_Tree_Data_Access
:= In_Tree
.Shared
;
1627 Source_Paths
: Source_Path_Table
.Instance
;
1628 Object_Paths
: Object_Path_Table
.Instance
;
1629 -- List of source or object dirs. Only computed the first time this
1630 -- procedure is called (since Source_FD is then reused)
1632 Source_FD
: File_Descriptor
:= Invalid_FD
;
1633 Object_FD
: File_Descriptor
:= Invalid_FD
;
1634 -- The temporary files to store the paths. These are only created the
1635 -- first time this procedure is called, and reused from then on.
1637 Process_Source_Dirs
: Boolean := False;
1638 Process_Object_Dirs
: Boolean := False;
1641 -- For calls to Close
1644 Buffer
: String_Access
:= new String (1 .. Buffer_Initial
);
1645 Buffer_Last
: Natural := 0;
1647 procedure Recursive_Add
1648 (Project
: Project_Id
;
1649 In_Tree
: Project_Tree_Ref
;
1650 Dummy
: in out Boolean);
1651 -- Recursive procedure to add the source/object paths of extended/
1652 -- imported projects.
1658 procedure Recursive_Add
1659 (Project
: Project_Id
;
1660 In_Tree
: Project_Tree_Ref
;
1661 Dummy
: in out Boolean)
1663 pragma Unreferenced
(Dummy
, In_Tree
);
1665 Path
: Path_Name_Type
;
1668 -- ??? This is almost the equivalent of For_All_Source_Dirs
1670 if Process_Source_Dirs
then
1672 -- Add to path all source directories of this project if there are
1675 if Has_Ada_Sources
(Project
) then
1676 Add_To_Source_Path
(Project
.Source_Dirs
, Shared
, Source_Paths
);
1680 if Process_Object_Dirs
then
1681 Path
:= Get_Object_Directory
1683 Including_Libraries
=> Including_Libraries
,
1684 Only_If_Ada
=> True);
1686 if Path
/= No_Path
then
1687 Add_To_Object_Path
(Path
, Object_Paths
);
1692 procedure For_All_Projects
is
1693 new For_Every_Project_Imported
(Boolean, Recursive_Add
);
1695 Dummy
: Boolean := False;
1697 -- Start of processing for Set_Ada_Paths
1700 -- If it is the first time we call this procedure for this project,
1701 -- compute the source path and/or the object path.
1703 if Include_Path
and then Project
.Include_Path_File
= No_Path
then
1704 Source_Path_Table
.Init
(Source_Paths
);
1705 Process_Source_Dirs
:= True;
1706 Create_New_Path_File
(Shared
, Source_FD
, Project
.Include_Path_File
);
1709 -- For the object path, we make a distinction depending on
1710 -- Including_Libraries.
1712 if Objects_Path
and Including_Libraries
then
1713 if Project
.Objects_Path_File_With_Libs
= No_Path
then
1714 Object_Path_Table
.Init
(Object_Paths
);
1715 Process_Object_Dirs
:= True;
1716 Create_New_Path_File
1717 (Shared
, Object_FD
, Project
.Objects_Path_File_With_Libs
);
1720 elsif Objects_Path
then
1721 if Project
.Objects_Path_File_Without_Libs
= No_Path
then
1722 Object_Path_Table
.Init
(Object_Paths
);
1723 Process_Object_Dirs
:= True;
1724 Create_New_Path_File
1725 (Shared
, Object_FD
, Project
.Objects_Path_File_Without_Libs
);
1729 -- If there is something to do, set Seen to False for all projects,
1730 -- then call the recursive procedure Add for Project.
1732 if Process_Source_Dirs
or Process_Object_Dirs
then
1733 For_All_Projects
(Project
, In_Tree
, Dummy
);
1736 -- Write and close any file that has been created. Source_FD is not set
1737 -- when this subprogram is called a second time or more, since we reuse
1738 -- the previous version of the file.
1740 if Source_FD
/= Invalid_FD
then
1744 Source_Path_Table
.First
.. Source_Path_Table
.Last
(Source_Paths
)
1746 Get_Name_String
(Source_Paths
.Table
(Index
));
1747 Name_Len
:= Name_Len
+ 1;
1748 Name_Buffer
(Name_Len
) := ASCII
.LF
;
1749 Add_To_Buffer
(Name_Buffer
(1 .. Name_Len
), Buffer
, Buffer_Last
);
1752 Last
:= Write
(Source_FD
, Buffer
(1)'Address, Buffer_Last
);
1754 if Last
= Buffer_Last
then
1755 Close
(Source_FD
, Status
);
1762 Prj
.Com
.Fail
("could not write temporary file");
1766 if Object_FD
/= Invalid_FD
then
1770 Object_Path_Table
.First
.. Object_Path_Table
.Last
(Object_Paths
)
1772 Get_Name_String
(Object_Paths
.Table
(Index
));
1773 Name_Len
:= Name_Len
+ 1;
1774 Name_Buffer
(Name_Len
) := ASCII
.LF
;
1775 Add_To_Buffer
(Name_Buffer
(1 .. Name_Len
), Buffer
, Buffer_Last
);
1778 Last
:= Write
(Object_FD
, Buffer
(1)'Address, Buffer_Last
);
1780 if Last
= Buffer_Last
then
1781 Close
(Object_FD
, Status
);
1787 Prj
.Com
.Fail
("could not write temporary file");
1791 -- Set the env vars, if they need to be changed, and set the
1792 -- corresponding flags.
1796 Shared
.Private_Part
.Current_Source_Path_File
/=
1797 Project
.Include_Path_File
1799 Shared
.Private_Part
.Current_Source_Path_File
:=
1800 Project
.Include_Path_File
;
1802 (Project_Include_Path_File
,
1803 Get_Name_String
(Shared
.Private_Part
.Current_Source_Path_File
));
1806 if Objects_Path
then
1807 if Including_Libraries
then
1808 if Shared
.Private_Part
.Current_Object_Path_File
/=
1809 Project
.Objects_Path_File_With_Libs
1811 Shared
.Private_Part
.Current_Object_Path_File
:=
1812 Project
.Objects_Path_File_With_Libs
;
1814 (Project_Objects_Path_File
,
1816 (Shared
.Private_Part
.Current_Object_Path_File
));
1820 if Shared
.Private_Part
.Current_Object_Path_File
/=
1821 Project
.Objects_Path_File_Without_Libs
1823 Shared
.Private_Part
.Current_Object_Path_File
:=
1824 Project
.Objects_Path_File_Without_Libs
;
1826 (Project_Objects_Path_File
,
1828 (Shared
.Private_Part
.Current_Object_Path_File
));
1836 ---------------------
1837 -- Add_Directories --
1838 ---------------------
1840 procedure Add_Directories
1841 (Self
: in out Project_Search_Path
;
1843 Prepend
: Boolean := False)
1845 Tmp
: String_Access
;
1847 if Self
.Path
= null then
1848 Self
.Path
:= new String'(Uninitialized_Prefix & Path);
1852 Self.Path := new String'(Path
& Path_Separator
& Tmp
.all);
1854 Self
.Path
:= new String'(Tmp.all & Path_Separator & Path);
1859 if Current_Verbosity = High then
1860 Debug_Output ("Adding directories to Project_Path: """
1863 end Add_Directories;
1865 --------------------
1866 -- Is_Initialized --
1867 --------------------
1869 function Is_Initialized (Self : Project_Search_Path) return Boolean is
1871 return Self.Path /= null
1872 and then (Self.Path'Length = 0
1873 or else Self.Path (Self.Path'First) /= '#');
1876 ----------------------
1877 -- Initialize_Empty --
1878 ----------------------
1880 procedure Initialize_Empty (Self : in out Project_Search_Path) is
1883 Self.Path := new String'("");
1884 end Initialize_Empty;
1886 -------------------------------------
1887 -- Initialize_Default_Project_Path --
1888 -------------------------------------
1890 procedure Initialize_Default_Project_Path
1891 (Self : in out Project_Search_Path;
1892 Target_Name : String)
1894 Add_Default_Dir : Boolean := True;
1898 New_Last : Positive;
1900 Ada_Project_Path : constant String := "ADA_PROJECT_PATH
";
1901 Gpr_Project_Path : constant String := "GPR_PROJECT_PATH
";
1902 Gpr_Project_Path_File : constant String := "GPR_PROJECT_PATH_FILE
";
1903 -- Names of alternate env. variable that contain path name(s) of
1904 -- directories where project files may reside. They are taken into
1905 -- account in this order: GPR_PROJECT_PATH_FILE, GPR_PROJECT_PATH,
1906 -- ADA_PROJECT_PATH.
1908 Gpr_Prj_Path_File : String_Access;
1909 Gpr_Prj_Path : String_Access;
1910 Ada_Prj_Path : String_Access;
1911 -- The path name(s) of directories where project files may reside.
1915 if Is_Initialized (Self) then
1919 -- The current directory is always first in the search path. Since the
1920 -- Project_Path currently starts with '#:' as a sign that it isn't
1921 -- initialized, we simply replace '#' with '.'
1923 if Self.Path = null then
1924 Self.Path := new String'('.' & Path_Separator);
1926 Self.Path (Self.Path'First) := '.';
1929 -- Then the reset of the project path (if any) currently contains the
1930 -- directories added through Add_Search_Project_Directory
1932 -- If environment variables are defined and not empty, add their content
1934 Gpr_Prj_Path_File := Getenv (Gpr_Project_Path_File);
1935 Gpr_Prj_Path := Getenv (Gpr_Project_Path);
1936 Ada_Prj_Path := Getenv (Ada_Project_Path);
1938 if Gpr_Prj_Path_File.all /= "" then
1940 File : Ada.Text_IO.File_Type;
1941 Line : String (1 .. 10_000);
1944 Tmp : String_Access;
1947 Open (File, In_File, Gpr_Prj_Path_File.all);
1949 while not End_Of_File (File) loop
1950 Get_Line (File, Line, Last);
1953 and then (Last = 1 or else Line (1 .. 2) /= "--")
1958 (Tmp.all & Path_Separator & Line (1 .. Last));
1962 if Current_Verbosity = High then
1963 Debug_Output ("Adding directory to Project_Path: """
1964 & Line (1 .. Last) & '"');
1972 Write_Str ("warning
: could
not read project path file
""");
1973 Write_Str (Gpr_Prj_Path_File.all);
1979 if Gpr_Prj_Path.all /= "" then
1980 Add_Directories (Self, Gpr_Prj_Path.all);
1983 Free (Gpr_Prj_Path);
1985 if Ada_Prj_Path.all /= "" then
1986 Add_Directories (Self, Ada_Prj_Path.all);
1989 Free (Ada_Prj_Path);
1991 -- Copy to Name_Buffer, since we will need to manipulate the path
1993 Name_Len := Self.Path'Length;
1994 Name_Buffer (1 .. Name_Len) := Self.Path.all;
1996 -- Scan the directory path to see if "-" is one of the directories.
1997 -- Remove each occurrence of "-" and set Add_Default_Dir to False.
1998 -- Also resolve relative paths and symbolic links.
2002 while First <= Name_Len
2003 and then (Name_Buffer (First) = Path_Separator)
2008 exit when First > Name_Len;
2012 while Last < Name_Len
2013 and then Name_Buffer (Last + 1) /= Path_Separator
2018 -- If the directory is "-", set Add_Default_Dir to False and
2019 -- remove from path.
2021 if Name_Buffer (First .. Last) = No_Project_Default_Dir then
2022 Add_Default_Dir := False;
2024 for J in Last + 1 .. Name_Len loop
2025 Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
2029 Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
2031 -- After removing the '-', go back one character to get the next
2032 -- directory correctly.
2036 elsif not Hostparm.OpenVMS
2037 or else not Is_Absolute_Path (Name_Buffer (First .. Last))
2039 -- On VMS, only expand relative path names, as absolute paths
2040 -- may correspond to multi-valued VMS logical names.
2043 New_Dir : constant String :=
2045 (Name_Buffer (First .. Last),
2046 Resolve_Links => Opt.Follow_Links_For_Dirs);
2049 -- If the absolute path was resolved and is different from
2050 -- the original, replace original with the resolved path.
2052 if New_Dir /= Name_Buffer (First .. Last)
2053 and then New_Dir'Length /= 0
2055 New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
2056 New_Last := First + New_Dir'Length - 1;
2057 Name_Buffer (New_Last + 1 .. New_Len) :=
2058 Name_Buffer (Last + 1 .. Name_Len);
2059 Name_Buffer (First .. New_Last) := New_Dir;
2060 Name_Len := New_Len;
2071 -- Set the initial value of Current_Project_Path
2073 if Add_Default_Dir then
2075 Prefix : String_Ptr;
2078 if Sdefault.Search_Dir_Prefix = null then
2082 Prefix := new String'(Executable_Prefix_Path);
2085 Prefix := new String'(Sdefault.Search_Dir_Prefix.all
2086 & ".." & Dir_Separator
2087 & ".." & Dir_Separator
2088 & ".." & Dir_Separator
2089 & ".." & Dir_Separator);
2092 if Prefix.all /= "" then
2093 if Target_Name /= "" then
2095 -- $prefix/$target/lib/gnat
2097 Add_Str_To_Name_Buffer
2098 (Path_Separator & Prefix.all & Target_Name);
2100 -- Note: Target_Name has a trailing / when it comes from
2103 if Name_Buffer (Name_Len) /= '/' then
2104 Add_Char_To_Name_Buffer (Directory_Separator);
2107 Add_Str_To_Name_Buffer
2108 ("lib
" & Directory_Separator & "gnat
");
2111 -- $prefix/share/gpr
2113 Add_Str_To_Name_Buffer
2114 (Path_Separator & Prefix.all &
2115 "share
" & Directory_Separator & "gpr
");
2119 Add_Str_To_Name_Buffer
2120 (Path_Separator & Prefix.all &
2121 "lib
" & Directory_Separator & "gnat
");
2128 Self.Path := new String'(Name_Buffer (1 .. Name_Len));
2129 end Initialize_Default_Project_Path;
2135 procedure Get_Path (Self : Project_Search_Path; Path : out String_Access) is
2137 pragma Assert (Is_Initialized (Self));
2145 procedure Set_Path (Self : in out Project_Search_Path; Path : String) is
2148 Self.Path := new String'(Path);
2149 Projects_Paths.Reset (Self.Cache);
2152 -----------------------
2153 -- Find_Name_In_Path --
2154 -----------------------
2156 function Find_Name_In_Path
2157 (Self : Project_Search_Path;
2158 Path : String) return String_Access
2164 if Current_Verbosity = High then
2165 Debug_Output ("Trying
" & Path);
2168 if Is_Absolute_Path (Path) then
2169 if Check_Filename (Path) then
2170 return new String'(Path);
2176 -- Because we don't want to resolve symbolic links, we cannot use
2177 -- Locate_Regular_File. So, we try each possible path successively.
2179 First := Self.Path'First;
2180 while First <= Self.Path'Last loop
2181 while First <= Self.Path'Last
2182 and then Self.Path (First) = Path_Separator
2187 exit when First > Self.Path'Last;
2190 while Last < Self.Path'Last
2191 and then Self.Path (Last + 1) /= Path_Separator
2198 if not Is_Absolute_Path (Self.Path (First .. Last)) then
2199 Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call
2200 Add_Char_To_Name_Buffer (Directory_Separator);
2203 Add_Str_To_Name_Buffer (Self.Path (First .. Last));
2204 Add_Char_To_Name_Buffer (Directory_Separator);
2205 Add_Str_To_Name_Buffer (Path);
2207 if Current_Verbosity = High then
2208 Debug_Output ("Testing file
" & Name_Buffer (1 .. Name_Len));
2211 if Check_Filename (Name_Buffer (1 .. Name_Len)) then
2212 return new String'(Name_Buffer (1 .. Name_Len));
2220 end Find_Name_In_Path;
2226 procedure Find_Project
2227 (Self : in out Project_Search_Path;
2228 Project_File_Name : String;
2230 Path : out Namet.Path_Name_Type)
2232 File : constant String := Project_File_Name;
2233 -- Have to do a copy, in case the parameter is Name_Buffer, which we
2236 function Try_Path_Name is new Find_Name_In_Path
2237 (Check_Filename => Is_Regular_File);
2238 -- Find a file in the project search path
2240 -- Local Declarations
2242 Result : String_Access;
2243 Has_Dot : Boolean := False;
2246 -- Start of processing for Find_Project
2249 pragma Assert (Is_Initialized (Self));
2251 if Current_Verbosity = High then
2252 Debug_Increase_Indent
2253 ("Searching
for project
""" & File & """ in """
2257 -- Check the project cache
2259 Name_Len := File'Length;
2260 Name_Buffer (1 .. Name_Len) := File;
2262 Path := Projects_Paths.Get (Self.Cache, Key);
2264 if Path /= No_Path then
2265 Debug_Decrease_Indent;
2269 -- Check if File contains an extension (a dot before a
2270 -- directory separator). If it is the case we do not try project file
2271 -- with an added extension as it is not possible to have multiple dots
2272 -- on a project file name.
2274 Check_Dot : for K in reverse File'Range loop
2275 if File (K) = '.' then
2280 exit Check_Dot when File (K) = Directory_Separator
2281 or else File (K) = '/';
2284 if not Is_Absolute_Path (File) then
2286 -- First we try <directory>/<file_name>.<extension>
2289 Result := Try_Path_Name
2291 Directory & Directory_Separator &
2292 File & Project_File_Extension);
2295 -- Then we try <directory>/<file_name>
2297 if Result = null then
2298 Result := Try_Path_Name
2299 (Self, Directory & Directory_Separator & File);
2303 -- Then we try <file_name>.<extension>
2305 if Result = null and then not Has_Dot then
2306 Result := Try_Path_Name (Self, File & Project_File_Extension);
2309 -- Then we try <file_name>
2311 if Result = null then
2312 Result := Try_Path_Name (Self, File);
2315 -- If we cannot find the project file, we return an empty string
2317 if Result = null then
2318 Path := Namet.No_Path;
2323 Final_Result : constant String :=
2324 GNAT.OS_Lib.Normalize_Pathname
2326 Directory => Directory,
2327 Resolve_Links => Opt.Follow_Links_For_Files,
2328 Case_Sensitive => True);
2331 Name_Len := Final_Result'Length;
2332 Name_Buffer (1 .. Name_Len) := Final_Result;
2334 Projects_Paths.Set (Self.Cache, Key, Path);
2338 Debug_Decrease_Indent;
2345 procedure Free (Self : in out Project_Search_Path) is
2348 Projects_Paths.Reset (Self.Cache);
2355 procedure Copy (From : Project_Search_Path; To : out Project_Search_Path) is
2359 if From.Path /= null then
2360 To.Path := new String'(From
.Path
.all);
2363 -- No need to copy the Cache, it will be recomputed as needed