1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
28 with Osint
; use Osint
;
29 with Output
; use Output
;
30 with Prj
.Com
; use Prj
.Com
;
33 with GNAT
.Directory_Operations
; use GNAT
.Directory_Operations
;
35 package body Prj
.Env
is
37 Current_Source_Path_File
: Path_Name_Type
:= No_Path
;
38 -- Current value of project source path file env var.
39 -- Used to avoid setting the env var to the same value.
41 Current_Object_Path_File
: Path_Name_Type
:= No_Path
;
42 -- Current value of project object path file env var.
43 -- Used to avoid setting the env var to the same value.
45 Ada_Path_Buffer
: String_Access
:= new String (1 .. 1024);
46 -- A buffer where values for ADA_INCLUDE_PATH
47 -- and ADA_OBJECTS_PATH are stored.
49 Ada_Path_Length
: Natural := 0;
50 -- Index of the last valid character in Ada_Path_Buffer
52 Ada_Prj_Include_File_Set
: Boolean := False;
53 Ada_Prj_Objects_File_Set
: Boolean := False;
54 -- These flags are set to True when the corresponding environment variables
55 -- are set and are used to give these environment variables an empty string
56 -- value at the end of the program. This has no practical effect on most
57 -- platforms, except on VMS where the logical names are deassigned, thus
58 -- avoiding the pollution of the environment of the caller.
60 Default_Naming
: constant Naming_Id
:= Naming_Table
.First
;
62 Fill_Mapping_File
: Boolean := True;
64 type Project_Flags
is array (Project_Id
range <>) of Boolean;
65 -- A Boolean array type used in Create_Mapping_File to select the projects
66 -- in the closure of a specific project.
68 -----------------------
69 -- Local Subprograms --
70 -----------------------
72 function Body_Path_Name_Of
74 In_Tree
: Project_Tree_Ref
) return String;
75 -- Returns the path name of the body of a unit.
76 -- Compute it first, if necessary.
78 function Spec_Path_Name_Of
80 In_Tree
: Project_Tree_Ref
) return String;
81 -- Returns the path name of the spec of a unit.
82 -- Compute it first, if necessary.
85 (Source_Dirs
: String_List_Id
;
86 In_Tree
: Project_Tree_Ref
);
87 -- Add to Ada_Path_Buffer all the source directories in string list
88 -- Source_Dirs, if any. Increment Ada_Path_Length.
90 procedure Add_To_Path
(Dir
: String);
91 -- If Dir is not already in the global variable Ada_Path_Buffer, add it.
92 -- Increment Ada_Path_Length.
93 -- If Ada_Path_Length /= 0, prepend a Path_Separator character to
96 procedure Add_To_Source_Path
97 (Source_Dirs
: String_List_Id
; In_Tree
: Project_Tree_Ref
);
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 In_Tree
: Project_Tree_Ref
);
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 function Contains_ALI_Files
(Dir
: Path_Name_Type
) return Boolean;
108 -- Return True if there is at least one ALI file in the directory Dir
110 procedure Set_Path_File_Var
(Name
: String; Value
: String);
111 -- Call Setenv, after calling To_Host_File_Spec
113 function Ultimate_Extension_Of
114 (Project
: Project_Id
;
115 In_Tree
: Project_Tree_Ref
) return Project_Id
;
116 -- Return a project that is either Project or an extended ancestor of
117 -- Project that itself is not extended.
119 ----------------------
120 -- Ada_Include_Path --
121 ----------------------
123 function Ada_Include_Path
124 (Project
: Project_Id
;
125 In_Tree
: Project_Tree_Ref
) return String_Access
is
127 procedure Add
(Project
: Project_Id
);
128 -- Add all the source directories of a project to the path only if
129 -- this project has not been visited. Calls itself recursively for
130 -- projects being extended, and imported projects. Adds the project
131 -- to the list Seen if this is the call to Add for this project.
137 procedure Add
(Project
: Project_Id
) is
139 -- If Seen is empty, then the project cannot have been visited
141 if not In_Tree
.Projects
.Table
(Project
).Seen
then
142 In_Tree
.Projects
.Table
(Project
).Seen
:= True;
145 Data
: constant Project_Data
:=
146 In_Tree
.Projects
.Table
(Project
);
147 List
: Project_List
:= Data
.Imported_Projects
;
150 -- Add to path all source directories of this project
152 Add_To_Path
(Data
.Source_Dirs
, In_Tree
);
154 -- Call Add to the project being extended, if any
156 if Data
.Extends
/= No_Project
then
160 -- Call Add for each imported project, if any
162 while List
/= Empty_Project_List
loop
164 (In_Tree
.Project_Lists
.Table
(List
).Project
);
165 List
:= In_Tree
.Project_Lists
.Table
(List
).Next
;
171 -- Start of processing for Ada_Include_Path
174 -- If it is the first time we call this function for
175 -- this project, compute the source path
178 In_Tree
.Projects
.Table
(Project
).Ada_Include_Path
= null
180 Ada_Path_Length
:= 0;
182 for Index
in Project_Table
.First
..
183 Project_Table
.Last
(In_Tree
.Projects
)
185 In_Tree
.Projects
.Table
(Index
).Seen
:= False;
189 In_Tree
.Projects
.Table
(Project
).Ada_Include_Path
:=
190 new String'(Ada_Path_Buffer (1 .. Ada_Path_Length));
193 return In_Tree.Projects.Table (Project).Ada_Include_Path;
194 end Ada_Include_Path;
196 ----------------------
197 -- Ada_Include_Path --
198 ----------------------
200 function Ada_Include_Path
201 (Project : Project_Id;
202 In_Tree : Project_Tree_Ref;
203 Recursive : Boolean) return String
207 return Ada_Include_Path (Project, In_Tree).all;
209 Ada_Path_Length := 0;
211 (In_Tree.Projects.Table (Project).Source_Dirs, In_Tree);
212 return Ada_Path_Buffer (1 .. Ada_Path_Length);
214 end Ada_Include_Path;
216 ----------------------
217 -- Ada_Objects_Path --
218 ----------------------
220 function Ada_Objects_Path
221 (Project : Project_Id;
222 In_Tree : Project_Tree_Ref;
223 Including_Libraries : Boolean := True) return String_Access
225 procedure Add (Project : Project_Id);
226 -- Add all the object directories of a project to the path only if
227 -- this project has not been visited. Calls itself recursively for
228 -- projects being extended, and imported projects. Adds the project
229 -- to the list Seen if this is the first call to Add for this project.
235 procedure Add (Project : Project_Id) is
237 -- If this project has not been seen yet
239 if not In_Tree.Projects.Table (Project).Seen then
240 In_Tree.Projects.Table (Project).Seen := True;
243 Data : constant Project_Data :=
244 In_Tree.Projects.Table (Project);
245 List : Project_List := Data.Imported_Projects;
248 -- Add to path the object directory of this project
249 -- except if we don't include library project and
250 -- this is a library project.
252 if (Data.Library and then Including_Libraries)
254 (Data.Object_Directory /= No_Path
256 (not Including_Libraries or else not Data.Library))
258 -- For a library project, add the library directory,
259 -- if there is no object directory or if it contains ALI
260 -- files; otherwise add the object directory.
263 if Data.Object_Directory = No_Path
265 Contains_ALI_Files (Data.Library_ALI_Dir)
267 Add_To_Path (Get_Name_String (Data.Library_ALI_Dir));
269 Add_To_Path (Get_Name_String (Data.Object_Directory));
273 -- For a non library project, add the object directory
275 Add_To_Path (Get_Name_String (Data.Object_Directory));
279 -- Call Add to the project being extended, if any
281 if Data.Extends /= No_Project then
285 -- Call Add for each imported project, if any
287 while List /= Empty_Project_List loop
289 (In_Tree.Project_Lists.Table (List).Project);
290 List := In_Tree.Project_Lists.Table (List).Next;
297 -- Start of processing for Ada_Objects_Path
300 -- If it is the first time we call this function for
301 -- this project, compute the objects path
304 In_Tree.Projects.Table (Project).Ada_Objects_Path = null
306 Ada_Path_Length := 0;
308 for Index in Project_Table.First ..
309 Project_Table.Last (In_Tree.Projects)
311 In_Tree.Projects.Table (Index).Seen := False;
315 In_Tree.Projects.Table (Project).Ada_Objects_Path :=
316 new String'(Ada_Path_Buffer
(1 .. Ada_Path_Length
));
319 return In_Tree
.Projects
.Table
(Project
).Ada_Objects_Path
;
320 end Ada_Objects_Path
;
322 ------------------------
323 -- Add_To_Object_Path --
324 ------------------------
326 procedure Add_To_Object_Path
327 (Object_Dir
: Path_Name_Type
; In_Tree
: Project_Tree_Ref
)
330 -- Check if the directory is already in the table
332 for Index
in Object_Path_Table
.First
..
333 Object_Path_Table
.Last
(In_Tree
.Private_Part
.Object_Paths
)
336 -- If it is, remove it, and add it as the last one
338 if In_Tree
.Private_Part
.Object_Paths
.Table
(Index
) = Object_Dir
then
339 for Index2
in Index
+ 1 ..
340 Object_Path_Table
.Last
341 (In_Tree
.Private_Part
.Object_Paths
)
343 In_Tree
.Private_Part
.Object_Paths
.Table
(Index2
- 1) :=
344 In_Tree
.Private_Part
.Object_Paths
.Table
(Index2
);
347 In_Tree
.Private_Part
.Object_Paths
.Table
348 (Object_Path_Table
.Last
(In_Tree
.Private_Part
.Object_Paths
)) :=
354 -- The directory is not already in the table, add it
356 Object_Path_Table
.Increment_Last
(In_Tree
.Private_Part
.Object_Paths
);
357 In_Tree
.Private_Part
.Object_Paths
.Table
358 (Object_Path_Table
.Last
(In_Tree
.Private_Part
.Object_Paths
)) :=
360 end Add_To_Object_Path
;
366 procedure Add_To_Path
367 (Source_Dirs
: String_List_Id
;
368 In_Tree
: Project_Tree_Ref
)
370 Current
: String_List_Id
:= Source_Dirs
;
371 Source_Dir
: String_Element
;
373 while Current
/= Nil_String
loop
374 Source_Dir
:= In_Tree
.String_Elements
.Table
(Current
);
375 Add_To_Path
(Get_Name_String
(Source_Dir
.Display_Value
));
376 Current
:= Source_Dir
.Next
;
380 procedure Add_To_Path
(Dir
: String) is
382 New_Buffer
: String_Access
;
385 function Is_Present
(Path
: String; Dir
: String) return Boolean;
386 -- Return True if Dir is part of Path
392 function Is_Present
(Path
: String; Dir
: String) return Boolean is
393 Last
: constant Integer := Path
'Last - Dir
'Length + 1;
396 for J
in Path
'First .. Last
loop
398 -- Note: the order of the conditions below is important, since
399 -- it ensures a minimal number of string comparisons.
402 or else Path
(J
- 1) = Path_Separator
)
404 (J
+ Dir
'Length > Path
'Last
405 or else Path
(J
+ Dir
'Length) = Path_Separator
)
406 and then Dir
= Path
(J
.. J
+ Dir
'Length - 1)
415 -- Start of processing for Add_To_Path
418 if Is_Present
(Ada_Path_Buffer
(1 .. Ada_Path_Length
), Dir
) then
420 -- Dir is already in the path, nothing to do
425 Min_Len
:= Ada_Path_Length
+ Dir
'Length;
427 if Ada_Path_Length
> 0 then
429 -- Add 1 for the Path_Separator character
431 Min_Len
:= Min_Len
+ 1;
434 -- If Ada_Path_Buffer is too small, increase it
436 Len
:= Ada_Path_Buffer
'Last;
438 if Len
< Min_Len
then
441 exit when Len
>= Min_Len
;
444 New_Buffer
:= new String (1 .. Len
);
445 New_Buffer
(1 .. Ada_Path_Length
) :=
446 Ada_Path_Buffer
(1 .. Ada_Path_Length
);
447 Free
(Ada_Path_Buffer
);
448 Ada_Path_Buffer
:= New_Buffer
;
451 if Ada_Path_Length
> 0 then
452 Ada_Path_Length
:= Ada_Path_Length
+ 1;
453 Ada_Path_Buffer
(Ada_Path_Length
) := Path_Separator
;
457 (Ada_Path_Length
+ 1 .. Ada_Path_Length
+ Dir
'Length) := Dir
;
458 Ada_Path_Length
:= Ada_Path_Length
+ Dir
'Length;
461 ------------------------
462 -- Add_To_Source_Path --
463 ------------------------
465 procedure Add_To_Source_Path
466 (Source_Dirs
: String_List_Id
; In_Tree
: Project_Tree_Ref
)
468 Current
: String_List_Id
:= Source_Dirs
;
469 Source_Dir
: String_Element
;
473 -- Add each source directory
475 while Current
/= Nil_String
loop
476 Source_Dir
:= In_Tree
.String_Elements
.Table
(Current
);
479 -- Check if the source directory is already in the table
481 for Index
in Source_Path_Table
.First
..
482 Source_Path_Table
.Last
483 (In_Tree
.Private_Part
.Source_Paths
)
485 -- If it is already, no need to add it
487 if In_Tree
.Private_Part
.Source_Paths
.Table
(Index
) =
496 Source_Path_Table
.Increment_Last
497 (In_Tree
.Private_Part
.Source_Paths
);
498 In_Tree
.Private_Part
.Source_Paths
.Table
499 (Source_Path_Table
.Last
(In_Tree
.Private_Part
.Source_Paths
)) :=
503 -- Next source directory
505 Current
:= Source_Dir
.Next
;
507 end Add_To_Source_Path
;
509 -----------------------
510 -- Body_Path_Name_Of --
511 -----------------------
513 function Body_Path_Name_Of
515 In_Tree
: Project_Tree_Ref
) return String
517 Data
: Unit_Data
:= In_Tree
.Units
.Table
(Unit
);
520 -- If we don't know the path name of the body of this unit,
521 -- we compute it, and we store it.
523 if Data
.File_Names
(Body_Part
).Path
= No_Path
then
525 Current_Source
: String_List_Id
:=
526 In_Tree
.Projects
.Table
527 (Data
.File_Names
(Body_Part
).Project
).Ada_Sources
;
528 Path
: GNAT
.OS_Lib
.String_Access
;
531 -- By default, put the file name
533 Data
.File_Names
(Body_Part
).Path
:=
534 Path_Name_Type
(Data
.File_Names
(Body_Part
).Name
);
536 -- For each source directory
538 while Current_Source
/= Nil_String
loop
541 (Namet
.Get_Name_String
542 (Data
.File_Names
(Body_Part
).Name
),
543 Namet
.Get_Name_String
544 (In_Tree
.String_Elements
.Table
545 (Current_Source
).Value
));
547 -- If the file is in this directory, then we store the path,
551 Name_Len
:= Path
'Length;
552 Name_Buffer
(1 .. Name_Len
) := Path
.all;
553 Data
.File_Names
(Body_Part
).Path
:= Name_Enter
;
558 In_Tree
.String_Elements
.Table
559 (Current_Source
).Next
;
563 In_Tree
.Units
.Table
(Unit
) := Data
;
567 -- Returned the stored value
569 return Namet
.Get_Name_String
(Data
.File_Names
(Body_Part
).Path
);
570 end Body_Path_Name_Of
;
572 ------------------------
573 -- Contains_ALI_Files --
574 ------------------------
576 function Contains_ALI_Files
(Dir
: Path_Name_Type
) return Boolean is
577 Dir_Name
: constant String := Get_Name_String
(Dir
);
579 Name
: String (1 .. 1_000
);
581 Result
: Boolean := False;
584 Open
(Direct
, Dir_Name
);
586 -- For each file in the directory, check if it is an ALI file
589 Read
(Direct
, Name
, Last
);
591 Canonical_Case_File_Name
(Name
(1 .. Last
));
592 Result
:= Last
>= 5 and then Name
(Last
- 3 .. Last
) = ".ali";
600 -- If there is any problem, close the directory if open and return
601 -- True; the library directory will be added to the path.
604 if Is_Open
(Direct
) then
609 end Contains_ALI_Files
;
611 --------------------------------
612 -- Create_Config_Pragmas_File --
613 --------------------------------
615 procedure Create_Config_Pragmas_File
616 (For_Project
: Project_Id
;
617 Main_Project
: Project_Id
;
618 In_Tree
: Project_Tree_Ref
;
619 Include_Config_Files
: Boolean := True)
621 pragma Unreferenced
(Main_Project
);
622 pragma Unreferenced
(Include_Config_Files
);
624 File_Name
: Path_Name_Type
:= No_Path
;
625 File
: File_Descriptor
:= Invalid_FD
;
627 Current_Unit
: Unit_Index
:= Unit_Table
.First
;
629 First_Project
: Project_List
:= Empty_Project_List
;
631 Current_Project
: Project_List
;
632 Current_Naming
: Naming_Id
;
637 procedure Check
(Project
: Project_Id
);
638 -- Recursive procedure that put in the config pragmas file any non
639 -- standard naming schemes, if it is not already in the file, then call
640 -- itself for any imported project.
642 procedure Check_Temp_File
;
643 -- Check that a temporary file has been opened.
644 -- If not, create one, and put its name in the project data,
645 -- with the indication that it is a temporary file.
648 (Unit_Name
: Name_Id
;
649 File_Name
: File_Name_Type
;
650 Unit_Kind
: Spec_Or_Body
;
652 -- Put an SFN pragma in the temporary file
654 procedure Put
(File
: File_Descriptor
; S
: String);
655 procedure Put_Line
(File
: File_Descriptor
; S
: String);
656 -- Output procedures, analogous to normal Text_IO procs of same name
662 procedure Check
(Project
: Project_Id
) is
663 Data
: constant Project_Data
:=
664 In_Tree
.Projects
.Table
(Project
);
667 if Current_Verbosity
= High
then
668 Write_Str
("Checking project file """);
669 Write_Str
(Namet
.Get_Name_String
(Data
.Name
));
674 -- Is this project in the list of the visited project?
676 Current_Project
:= First_Project
;
677 while Current_Project
/= Empty_Project_List
678 and then In_Tree
.Project_Lists
.Table
679 (Current_Project
).Project
/= Project
682 In_Tree
.Project_Lists
.Table
(Current_Project
).Next
;
685 -- If it is not, put it in the list, and visit it
687 if Current_Project
= Empty_Project_List
then
688 Project_List_Table
.Increment_Last
689 (In_Tree
.Project_Lists
);
690 In_Tree
.Project_Lists
.Table
691 (Project_List_Table
.Last
(In_Tree
.Project_Lists
)) :=
692 (Project
=> Project
, Next
=> First_Project
);
694 Project_List_Table
.Last
(In_Tree
.Project_Lists
);
696 -- Is the naming scheme of this project one that we know?
698 Current_Naming
:= Default_Naming
;
699 while Current_Naming
<=
700 Naming_Table
.Last
(In_Tree
.Private_Part
.Namings
)
701 and then not Same_Naming_Scheme
702 (Left
=> In_Tree
.Private_Part
.Namings
.Table
(Current_Naming
),
703 Right
=> Data
.Naming
) loop
704 Current_Naming
:= Current_Naming
+ 1;
707 -- If we don't know it, add it
710 Naming_Table
.Last
(In_Tree
.Private_Part
.Namings
)
712 Naming_Table
.Increment_Last
(In_Tree
.Private_Part
.Namings
);
713 In_Tree
.Private_Part
.Namings
.Table
714 (Naming_Table
.Last
(In_Tree
.Private_Part
.Namings
)) :=
717 -- We need a temporary file to be created
721 -- Put the SFN pragmas for the naming scheme
726 (File
, "pragma Source_File_Name_Project");
728 (File
, " (Spec_File_Name => ""*" &
729 Spec_Suffix_Of
(In_Tree
, "ada", Data
.Naming
) &
732 (File
, " Casing => " &
733 Image
(Data
.Naming
.Casing
) & ",");
735 (File
, " Dot_Replacement => """ &
736 Namet
.Get_Name_String
(Data
.Naming
.Dot_Replacement
) &
742 (File
, "pragma Source_File_Name_Project");
744 (File
, " (Body_File_Name => ""*" &
745 Body_Suffix_Of
(In_Tree
, "ada", Data
.Naming
) &
748 (File
, " Casing => " &
749 Image
(Data
.Naming
.Casing
) & ",");
751 (File
, " Dot_Replacement => """ &
752 Namet
.Get_Name_String
(Data
.Naming
.Dot_Replacement
) &
755 -- and maybe separate
757 if Body_Suffix_Of
(In_Tree
, "ada", Data
.Naming
) /=
758 Get_Name_String
(Data
.Naming
.Separate_Suffix
)
761 (File
, "pragma Source_File_Name_Project");
763 (File
, " (Subunit_File_Name => ""*" &
764 Namet
.Get_Name_String
(Data
.Naming
.Separate_Suffix
) &
767 (File
, " Casing => " &
768 Image
(Data
.Naming
.Casing
) &
771 (File
, " Dot_Replacement => """ &
772 Namet
.Get_Name_String
(Data
.Naming
.Dot_Replacement
) &
777 if Data
.Extends
/= No_Project
then
778 Check
(Data
.Extends
);
782 Current
: Project_List
:= Data
.Imported_Projects
;
785 while Current
/= Empty_Project_List
loop
787 (In_Tree
.Project_Lists
.Table
789 Current
:= In_Tree
.Project_Lists
.Table
796 ---------------------
797 -- Check_Temp_File --
798 ---------------------
800 procedure Check_Temp_File
is
802 if File
= Invalid_FD
then
803 Tempdir
.Create_Temp_File
(File
, Name
=> File_Name
);
805 if File
= Invalid_FD
then
807 ("unable to create temporary configuration pragmas file");
810 Record_Temp_File
(File_Name
);
812 if Opt
.Verbose_Mode
then
813 Write_Str
("Creating temp file """);
814 Write_Str
(Get_Name_String
(File_Name
));
826 (Unit_Name
: Name_Id
;
827 File_Name
: File_Name_Type
;
828 Unit_Kind
: Spec_Or_Body
;
832 -- A temporary file needs to be open
836 -- Put the pragma SFN for the unit kind (spec or body)
838 Put
(File
, "pragma Source_File_Name_Project (");
839 Put
(File
, Namet
.Get_Name_String
(Unit_Name
));
841 if Unit_Kind
= Specification
then
842 Put
(File
, ", Spec_File_Name => """);
844 Put
(File
, ", Body_File_Name => """);
847 Put
(File
, Namet
.Get_Name_String
(File_Name
));
851 Put
(File
, ", Index =>");
852 Put
(File
, Index
'Img);
855 Put_Line
(File
, ");");
858 procedure Put
(File
: File_Descriptor
; S
: String) is
862 Last
:= Write
(File
, S
(S
'First)'Address, S
'Length);
864 if Last
/= S
'Length then
865 Prj
.Com
.Fail
("Disk full");
868 if Current_Verbosity
= High
then
877 procedure Put_Line
(File
: File_Descriptor
; S
: String) is
878 S0
: String (1 .. S
'Length + 1);
882 -- Add an ASCII.LF to the string. As this config file is supposed to
883 -- be used only by the compiler, we don't care about the characters
884 -- for the end of line. In fact we could have put a space, but
885 -- it is more convenient to be able to read gnat.adc during
886 -- development, for which the ASCII.LF is fine.
888 S0
(1 .. S
'Length) := S
;
889 S0
(S0
'Last) := ASCII
.LF
;
890 Last
:= Write
(File
, S0
'Address, S0
'Length);
892 if Last
/= S
'Length + 1 then
893 Prj
.Com
.Fail
("Disk full");
896 if Current_Verbosity
= High
then
901 -- Start of processing for Create_Config_Pragmas_File
905 In_Tree
.Projects
.Table
(For_Project
).Config_Checked
908 -- Remove any memory of processed naming schemes, if any
910 Naming_Table
.Set_Last
(In_Tree
.Private_Part
.Namings
, Default_Naming
);
912 -- Check the naming schemes
916 -- Visit all the units and process those that need an SFN pragma
919 Current_Unit
<= Unit_Table
.Last
(In_Tree
.Units
)
922 Unit
: constant Unit_Data
:=
923 In_Tree
.Units
.Table
(Current_Unit
);
926 if Unit
.File_Names
(Specification
).Needs_Pragma
then
928 Unit
.File_Names
(Specification
).Name
,
930 Unit
.File_Names
(Specification
).Index
);
933 if Unit
.File_Names
(Body_Part
).Needs_Pragma
then
935 Unit
.File_Names
(Body_Part
).Name
,
937 Unit
.File_Names
(Body_Part
).Index
);
940 Current_Unit
:= Current_Unit
+ 1;
944 -- If there are no non standard naming scheme, issue the GNAT
945 -- standard naming scheme. This will tell the compiler that
946 -- a project file is used and will forbid any pragma SFN.
948 if File
= Invalid_FD
then
951 Put_Line
(File
, "pragma Source_File_Name_Project");
952 Put_Line
(File
, " (Spec_File_Name => ""*.ads"",");
953 Put_Line
(File
, " Dot_Replacement => ""-"",");
954 Put_Line
(File
, " Casing => lowercase);");
956 Put_Line
(File
, "pragma Source_File_Name_Project");
957 Put_Line
(File
, " (Body_File_Name => ""*.adb"",");
958 Put_Line
(File
, " Dot_Replacement => ""-"",");
959 Put_Line
(File
, " Casing => lowercase);");
962 -- Close the temporary file
964 GNAT
.OS_Lib
.Close
(File
, Status
);
967 Prj
.Com
.Fail
("disk full");
970 if Opt
.Verbose_Mode
then
971 Write_Str
("Closing configuration file """);
972 Write_Str
(Get_Name_String
(File_Name
));
976 In_Tree
.Projects
.Table
(For_Project
).Config_File_Name
:=
978 In_Tree
.Projects
.Table
(For_Project
).Config_File_Temp
:=
981 In_Tree
.Projects
.Table
(For_Project
).Config_Checked
:=
984 end Create_Config_Pragmas_File
;
990 procedure Create_Mapping
(In_Tree
: Project_Tree_Ref
) is
991 The_Unit_Data
: Unit_Data
;
992 Data
: File_Name_Data
;
997 for Unit
in 1 .. Unit_Table
.Last
(In_Tree
.Units
) loop
998 The_Unit_Data
:= In_Tree
.Units
.Table
(Unit
);
1000 -- Process only if the unit has a valid name
1002 if The_Unit_Data
.Name
/= No_Name
then
1003 Data
:= The_Unit_Data
.File_Names
(Specification
);
1005 -- If there is a spec, put it in the mapping
1007 if Data
.Name
/= No_File
then
1008 if Data
.Path
= Slash
then
1009 Fmap
.Add_Forbidden_File_Name
(Data
.Name
);
1011 Fmap
.Add_To_File_Map
1012 (Unit_Name
=> Unit_Name_Type
(The_Unit_Data
.Name
),
1013 File_Name
=> Data
.Name
,
1014 Path_Name
=> File_Name_Type
(Data
.Path
));
1018 Data
:= The_Unit_Data
.File_Names
(Body_Part
);
1020 -- If there is a body (or subunit) put it in the mapping
1022 if Data
.Name
/= No_File
then
1023 if Data
.Path
= Slash
then
1024 Fmap
.Add_Forbidden_File_Name
(Data
.Name
);
1026 Fmap
.Add_To_File_Map
1027 (Unit_Name
=> Unit_Name_Type
(The_Unit_Data
.Name
),
1028 File_Name
=> Data
.Name
,
1029 Path_Name
=> File_Name_Type
(Data
.Path
));
1036 -------------------------
1037 -- Create_Mapping_File --
1038 -------------------------
1040 procedure Create_Mapping_File
1041 (Project
: Project_Id
;
1042 In_Tree
: Project_Tree_Ref
;
1043 Name
: out Path_Name_Type
)
1045 File
: File_Descriptor
:= Invalid_FD
;
1046 The_Unit_Data
: Unit_Data
;
1047 Data
: File_Name_Data
;
1050 -- For call to Close
1052 Present
: Project_Flags
1053 (No_Project
.. Project_Table
.Last
(In_Tree
.Projects
)) :=
1055 -- For each project in the closure of Project, the corresponding flag
1056 -- will be set to True;
1058 procedure Put_Name_Buffer
;
1059 -- Put the line contained in the Name_Buffer in the mapping file
1061 procedure Put_Data
(Spec
: Boolean);
1062 -- Put the mapping of the spec or body contained in Data in the file
1065 procedure Recursive_Flag
(Prj
: Project_Id
);
1066 -- Set the flags corresponding to Prj, the projects it imports
1067 -- (directly or indirectly) or extends to True. Call itself recursively.
1073 procedure Put_Name_Buffer
is
1077 Name_Len
:= Name_Len
+ 1;
1078 Name_Buffer
(Name_Len
) := ASCII
.LF
;
1079 Last
:= Write
(File
, Name_Buffer
(1)'Address, Name_Len
);
1081 if Last
/= Name_Len
then
1082 Prj
.Com
.Fail
("Disk full");
1084 end Put_Name_Buffer
;
1090 procedure Put_Data
(Spec
: Boolean) is
1092 -- Line with the unit name
1094 Get_Name_String
(The_Unit_Data
.Name
);
1095 Name_Len
:= Name_Len
+ 1;
1096 Name_Buffer
(Name_Len
) := '%';
1097 Name_Len
:= Name_Len
+ 1;
1100 Name_Buffer
(Name_Len
) := 's';
1102 Name_Buffer
(Name_Len
) := 'b';
1107 -- Line with the file name
1109 Get_Name_String
(Data
.Name
);
1112 -- Line with the path name
1114 Get_Name_String
(Data
.Path
);
1119 --------------------
1120 -- Recursive_Flag --
1121 --------------------
1123 procedure Recursive_Flag
(Prj
: Project_Id
) is
1124 Imported
: Project_List
;
1128 -- Nothing to do for non existent project or project that has
1129 -- already been flagged.
1131 if Prj
= No_Project
or else Present
(Prj
) then
1135 -- Flag the current project
1137 Present
(Prj
) := True;
1139 In_Tree
.Projects
.Table
(Prj
).Imported_Projects
;
1141 -- Call itself for each project directly imported
1143 while Imported
/= Empty_Project_List
loop
1145 In_Tree
.Project_Lists
.Table
(Imported
).Project
;
1147 In_Tree
.Project_Lists
.Table
(Imported
).Next
;
1148 Recursive_Flag
(Proj
);
1151 -- Call itself for an eventual project being extended
1153 Recursive_Flag
(In_Tree
.Projects
.Table
(Prj
).Extends
);
1156 -- Start of processing for Create_Mapping_File
1159 -- Flag the necessary projects
1161 Recursive_Flag
(Project
);
1163 -- Create the temporary file
1165 Tempdir
.Create_Temp_File
(File
, Name
=> Name
);
1167 if File
= Invalid_FD
then
1168 Prj
.Com
.Fail
("unable to create temporary mapping file");
1171 Record_Temp_File
(Name
);
1173 if Opt
.Verbose_Mode
then
1174 Write_Str
("Creating temp mapping file """);
1175 Write_Str
(Get_Name_String
(Name
));
1180 if Fill_Mapping_File
then
1182 -- For all units in table Units
1184 for Unit
in 1 .. Unit_Table
.Last
(In_Tree
.Units
) loop
1185 The_Unit_Data
:= In_Tree
.Units
.Table
(Unit
);
1187 -- If the unit has a valid name
1189 if The_Unit_Data
.Name
/= No_Name
then
1190 Data
:= The_Unit_Data
.File_Names
(Specification
);
1192 -- If there is a spec, put it mapping in the file if it is
1193 -- from a project in the closure of Project.
1195 if Data
.Name
/= No_File
and then Present
(Data
.Project
) then
1196 Put_Data
(Spec
=> True);
1199 Data
:= The_Unit_Data
.File_Names
(Body_Part
);
1201 -- If there is a body (or subunit) put its mapping in the file
1202 -- if it is from a project in the closure of Project.
1204 if Data
.Name
/= No_File
and then Present
(Data
.Project
) then
1205 Put_Data
(Spec
=> False);
1212 GNAT
.OS_Lib
.Close
(File
, Status
);
1215 Prj
.Com
.Fail
("disk full");
1217 end Create_Mapping_File
;
1219 procedure Create_Mapping_File
1220 (Project
: Project_Id
;
1222 In_Tree
: Project_Tree_Ref
;
1223 Name
: out Path_Name_Type
)
1225 File
: File_Descriptor
:= Invalid_FD
;
1228 -- For call to Close
1230 Present
: Project_Flags
1231 (No_Project
.. Project_Table
.Last
(In_Tree
.Projects
)) :=
1233 -- For each project in the closure of Project, the corresponding flag
1234 -- will be set to True.
1237 Src_Data
: Source_Data
;
1238 Suffix
: File_Name_Type
;
1240 procedure Put_Name_Buffer
;
1241 -- Put the line contained in the Name_Buffer in the mapping file
1243 procedure Recursive_Flag
(Prj
: Project_Id
);
1244 -- Set the flags corresponding to Prj, the projects it imports
1245 -- (directly or indirectly) or extends to True. Call itself recursively.
1251 procedure Put_Name_Buffer
is
1255 Name_Len
:= Name_Len
+ 1;
1256 Name_Buffer
(Name_Len
) := ASCII
.LF
;
1257 Last
:= Write
(File
, Name_Buffer
(1)'Address, Name_Len
);
1259 if Last
/= Name_Len
then
1260 Prj
.Com
.Fail
("Disk full");
1262 end Put_Name_Buffer
;
1264 --------------------
1265 -- Recursive_Flag --
1266 --------------------
1268 procedure Recursive_Flag
(Prj
: Project_Id
) is
1269 Imported
: Project_List
;
1273 -- Nothing to do for non existent project or project that has already
1276 if Prj
= No_Project
or else Present
(Prj
) then
1280 -- Flag the current project
1282 Present
(Prj
) := True;
1284 In_Tree
.Projects
.Table
(Prj
).Imported_Projects
;
1286 -- Call itself for each project directly imported
1288 while Imported
/= Empty_Project_List
loop
1290 In_Tree
.Project_Lists
.Table
(Imported
).Project
;
1292 In_Tree
.Project_Lists
.Table
(Imported
).Next
;
1293 Recursive_Flag
(Proj
);
1296 -- Call itself for an eventual project being extended
1298 Recursive_Flag
(In_Tree
.Projects
.Table
(Prj
).Extends
);
1301 -- Start of processing for Create_Mapping_File
1304 -- Flag the necessary projects
1306 Recursive_Flag
(Project
);
1308 -- Create the temporary file
1310 Tempdir
.Create_Temp_File
(File
, Name
=> Name
);
1312 if File
= Invalid_FD
then
1313 Prj
.Com
.Fail
("unable to create temporary mapping file");
1316 Record_Temp_File
(Name
);
1318 if Opt
.Verbose_Mode
then
1319 Write_Str
("Creating temp mapping file """);
1320 Write_Str
(Get_Name_String
(Name
));
1325 -- For all source of the Language of all projects in the closure
1327 for Proj
in Present
'Range loop
1328 if Present
(Proj
) then
1329 Source
:= In_Tree
.Projects
.Table
(Proj
).First_Source
;
1331 while Source
/= No_Source
loop
1332 Src_Data
:= In_Tree
.Sources
.Table
(Source
);
1334 if Src_Data
.Language_Name
= Language
1335 and then not Src_Data
.Locally_Removed
1336 and then Src_Data
.Replaced_By
= No_Source
1337 and then Src_Data
.Path
/= No_Path
1339 if Src_Data
.Unit
/= No_Name
then
1340 Get_Name_String
(Src_Data
.Unit
);
1342 if Src_Data
.Kind
= Spec
then
1344 In_Tree
.Languages_Data
.Table
1345 (Src_Data
.Language
).Config
.Mapping_Spec_Suffix
;
1348 In_Tree
.Languages_Data
.Table
1349 (Src_Data
.Language
).Config
.Mapping_Body_Suffix
;
1352 if Suffix
/= No_File
then
1353 Add_Str_To_Name_Buffer
(Get_Name_String
(Suffix
));
1359 Get_Name_String
(Src_Data
.File
);
1362 Get_Name_String
(Src_Data
.Path
);
1366 Source
:= Src_Data
.Next_In_Project
;
1371 GNAT
.OS_Lib
.Close
(File
, Status
);
1374 Prj
.Com
.Fail
("disk full");
1376 end Create_Mapping_File
;
1378 --------------------------
1379 -- Create_New_Path_File --
1380 --------------------------
1382 procedure Create_New_Path_File
1383 (In_Tree
: Project_Tree_Ref
;
1384 Path_FD
: out File_Descriptor
;
1385 Path_Name
: out Path_Name_Type
)
1388 Tempdir
.Create_Temp_File
(Path_FD
, Path_Name
);
1390 if Path_Name
/= No_Path
then
1391 Record_Temp_File
(Path_Name
);
1393 -- Record the name, so that the temp path file will be deleted at the
1394 -- end of the program.
1396 Path_File_Table
.Increment_Last
(In_Tree
.Private_Part
.Path_Files
);
1397 In_Tree
.Private_Part
.Path_Files
.Table
1398 (Path_File_Table
.Last
(In_Tree
.Private_Part
.Path_Files
)) :=
1401 end Create_New_Path_File
;
1403 ---------------------------
1404 -- Delete_All_Path_Files --
1405 ---------------------------
1407 procedure Delete_All_Path_Files
(In_Tree
: Project_Tree_Ref
) is
1408 Disregard
: Boolean := True;
1409 pragma Warnings
(Off
, Disregard
);
1412 for Index
in Path_File_Table
.First
..
1413 Path_File_Table
.Last
(In_Tree
.Private_Part
.Path_Files
)
1415 if In_Tree
.Private_Part
.Path_Files
.Table
(Index
) /= No_Path
then
1418 (In_Tree
.Private_Part
.Path_Files
.Table
(Index
)),
1423 -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or
1424 -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
1425 -- the empty string. On VMS, this has the effect of deassigning
1426 -- the logical names.
1428 if Ada_Prj_Include_File_Set
then
1429 Setenv
(Project_Include_Path_File
, "");
1430 Ada_Prj_Include_File_Set
:= False;
1433 if Ada_Prj_Objects_File_Set
then
1434 Setenv
(Project_Objects_Path_File
, "");
1435 Ada_Prj_Objects_File_Set
:= False;
1437 end Delete_All_Path_Files
;
1439 ------------------------------------
1440 -- File_Name_Of_Library_Unit_Body --
1441 ------------------------------------
1443 function File_Name_Of_Library_Unit_Body
1445 Project
: Project_Id
;
1446 In_Tree
: Project_Tree_Ref
;
1447 Main_Project_Only
: Boolean := True;
1448 Full_Path
: Boolean := False) return String
1450 The_Project
: Project_Id
:= Project
;
1451 Data
: Project_Data
:=
1452 In_Tree
.Projects
.Table
(Project
);
1453 Original_Name
: String := Name
;
1455 Extended_Spec_Name
: String :=
1457 Spec_Suffix_Of
(In_Tree
, "ada", Data
.Naming
);
1458 Extended_Body_Name
: String :=
1460 Body_Suffix_Of
(In_Tree
, "ada", Data
.Naming
);
1464 The_Original_Name
: Name_Id
;
1465 The_Spec_Name
: Name_Id
;
1466 The_Body_Name
: Name_Id
;
1469 Canonical_Case_File_Name
(Original_Name
);
1470 Name_Len
:= Original_Name
'Length;
1471 Name_Buffer
(1 .. Name_Len
) := Original_Name
;
1472 The_Original_Name
:= Name_Find
;
1474 Canonical_Case_File_Name
(Extended_Spec_Name
);
1475 Name_Len
:= Extended_Spec_Name
'Length;
1476 Name_Buffer
(1 .. Name_Len
) := Extended_Spec_Name
;
1477 The_Spec_Name
:= Name_Find
;
1479 Canonical_Case_File_Name
(Extended_Body_Name
);
1480 Name_Len
:= Extended_Body_Name
'Length;
1481 Name_Buffer
(1 .. Name_Len
) := Extended_Body_Name
;
1482 The_Body_Name
:= Name_Find
;
1484 if Current_Verbosity
= High
then
1485 Write_Str
("Looking for file name of """);
1489 Write_Str
(" Extended Spec Name = """);
1490 Write_Str
(Extended_Spec_Name
);
1493 Write_Str
(" Extended Body Name = """);
1494 Write_Str
(Extended_Body_Name
);
1499 -- For extending project, search in the extended project if the source
1500 -- is not found. For non extending projects, this loop will be run only
1504 -- Loop through units
1505 -- Should have comment explaining reverse ???
1507 for Current
in reverse Unit_Table
.First
..
1508 Unit_Table
.Last
(In_Tree
.Units
)
1510 Unit
:= In_Tree
.Units
.Table
(Current
);
1514 if not Main_Project_Only
1515 or else Unit
.File_Names
(Body_Part
).Project
= The_Project
1518 Current_Name
: constant File_Name_Type
:=
1519 Unit
.File_Names
(Body_Part
).Name
;
1522 -- Case of a body present
1524 if Current_Name
/= No_File
then
1525 if Current_Verbosity
= High
then
1526 Write_Str
(" Comparing with """);
1527 Write_Str
(Get_Name_String
(Current_Name
));
1532 -- If it has the name of the original name, return the
1535 if Unit
.Name
= The_Original_Name
1537 Current_Name
= File_Name_Type
(The_Original_Name
)
1539 if Current_Verbosity
= High
then
1544 return Get_Name_String
1545 (Unit
.File_Names
(Body_Part
).Path
);
1548 return Get_Name_String
(Current_Name
);
1551 -- If it has the name of the extended body name,
1552 -- return the extended body name
1554 elsif Current_Name
= File_Name_Type
(The_Body_Name
) then
1555 if Current_Verbosity
= High
then
1560 return Get_Name_String
1561 (Unit
.File_Names
(Body_Part
).Path
);
1564 return Extended_Body_Name
;
1568 if Current_Verbosity
= High
then
1569 Write_Line
(" not good");
1578 if not Main_Project_Only
1579 or else Unit
.File_Names
(Specification
).Project
= The_Project
1582 Current_Name
: constant File_Name_Type
:=
1583 Unit
.File_Names
(Specification
).Name
;
1586 -- Case of spec present
1588 if Current_Name
/= No_File
then
1589 if Current_Verbosity
= High
then
1590 Write_Str
(" Comparing with """);
1591 Write_Str
(Get_Name_String
(Current_Name
));
1596 -- If name same as original name, return original name
1598 if Unit
.Name
= The_Original_Name
1600 Current_Name
= File_Name_Type
(The_Original_Name
)
1602 if Current_Verbosity
= High
then
1607 return Get_Name_String
1608 (Unit
.File_Names
(Specification
).Path
);
1610 return Get_Name_String
(Current_Name
);
1613 -- If it has the same name as the extended spec name,
1614 -- return the extended spec name.
1616 elsif Current_Name
= File_Name_Type
(The_Spec_Name
) then
1617 if Current_Verbosity
= High
then
1622 return Get_Name_String
1623 (Unit
.File_Names
(Specification
).Path
);
1625 return Extended_Spec_Name
;
1629 if Current_Verbosity
= High
then
1630 Write_Line
(" not good");
1638 -- If we are not in an extending project, give up
1640 exit when (not Main_Project_Only
) or else Data
.Extends
= No_Project
;
1642 -- Otherwise, look in the project we are extending
1644 The_Project
:= Data
.Extends
;
1645 Data
:= In_Tree
.Projects
.Table
(The_Project
);
1648 -- We don't know this file name, return an empty string
1651 end File_Name_Of_Library_Unit_Body
;
1653 -------------------------
1654 -- For_All_Object_Dirs --
1655 -------------------------
1657 procedure For_All_Object_Dirs
1658 (Project
: Project_Id
;
1659 In_Tree
: Project_Tree_Ref
)
1661 Seen
: Project_List
:= Empty_Project_List
;
1663 procedure Add
(Project
: Project_Id
);
1664 -- Process a project. Remember the processes visited to avoid processing
1665 -- a project twice. Recursively process an eventual extended project,
1666 -- and all imported projects.
1672 procedure Add
(Project
: Project_Id
) is
1673 Data
: constant Project_Data
:=
1674 In_Tree
.Projects
.Table
(Project
);
1675 List
: Project_List
:= Data
.Imported_Projects
;
1678 -- If the list of visited project is empty, then
1679 -- for sure we never visited this project.
1681 if Seen
= Empty_Project_List
then
1682 Project_List_Table
.Increment_Last
(In_Tree
.Project_Lists
);
1683 Seen
:= Project_List_Table
.Last
(In_Tree
.Project_Lists
);
1684 In_Tree
.Project_Lists
.Table
(Seen
) :=
1685 (Project
=> Project
, Next
=> Empty_Project_List
);
1688 -- Check if the project is in the list
1691 Current
: Project_List
:= Seen
;
1695 -- If it is, then there is nothing else to do
1697 if In_Tree
.Project_Lists
.Table
1698 (Current
).Project
= Project
1704 In_Tree
.Project_Lists
.Table
(Current
).Next
=
1707 In_Tree
.Project_Lists
.Table
(Current
).Next
;
1710 -- This project has never been visited, add it
1713 Project_List_Table
.Increment_Last
1714 (In_Tree
.Project_Lists
);
1715 In_Tree
.Project_Lists
.Table
(Current
).Next
:=
1716 Project_List_Table
.Last
(In_Tree
.Project_Lists
);
1717 In_Tree
.Project_Lists
.Table
1718 (Project_List_Table
.Last
1719 (In_Tree
.Project_Lists
)) :=
1720 (Project
=> Project
, Next
=> Empty_Project_List
);
1724 -- If there is an object directory, call Action with its name
1726 if Data
.Object_Directory
/= No_Path
then
1727 Get_Name_String
(Data
.Display_Object_Dir
);
1728 Action
(Name_Buffer
(1 .. Name_Len
));
1731 -- If we are extending a project, visit it
1733 if Data
.Extends
/= No_Project
then
1737 -- And visit all imported projects
1739 while List
/= Empty_Project_List
loop
1740 Add
(In_Tree
.Project_Lists
.Table
(List
).Project
);
1741 List
:= In_Tree
.Project_Lists
.Table
(List
).Next
;
1745 -- Start of processing for For_All_Object_Dirs
1748 -- Visit this project, and its imported projects, recursively
1751 end For_All_Object_Dirs
;
1753 -------------------------
1754 -- For_All_Source_Dirs --
1755 -------------------------
1757 procedure For_All_Source_Dirs
1758 (Project
: Project_Id
;
1759 In_Tree
: Project_Tree_Ref
)
1761 Seen
: Project_List
:= Empty_Project_List
;
1763 procedure Add
(Project
: Project_Id
);
1764 -- Process a project. Remember the processes visited to avoid processing
1765 -- a project twice. Recursively process an eventual extended project,
1766 -- and all imported projects.
1772 procedure Add
(Project
: Project_Id
) is
1773 Data
: constant Project_Data
:=
1774 In_Tree
.Projects
.Table
(Project
);
1775 List
: Project_List
:= Data
.Imported_Projects
;
1778 -- If the list of visited project is empty, then for sure we never
1779 -- visited this project.
1781 if Seen
= Empty_Project_List
then
1782 Project_List_Table
.Increment_Last
1783 (In_Tree
.Project_Lists
);
1784 Seen
:= Project_List_Table
.Last
1785 (In_Tree
.Project_Lists
);
1786 In_Tree
.Project_Lists
.Table
(Seen
) :=
1787 (Project
=> Project
, Next
=> Empty_Project_List
);
1790 -- Check if the project is in the list
1793 Current
: Project_List
:= Seen
;
1797 -- If it is, then there is nothing else to do
1799 if In_Tree
.Project_Lists
.Table
1800 (Current
).Project
= Project
1806 In_Tree
.Project_Lists
.Table
(Current
).Next
=
1809 In_Tree
.Project_Lists
.Table
(Current
).Next
;
1812 -- This project has never been visited, add it to the list
1814 Project_List_Table
.Increment_Last
1815 (In_Tree
.Project_Lists
);
1816 In_Tree
.Project_Lists
.Table
(Current
).Next
:=
1817 Project_List_Table
.Last
(In_Tree
.Project_Lists
);
1818 In_Tree
.Project_Lists
.Table
1819 (Project_List_Table
.Last
1820 (In_Tree
.Project_Lists
)) :=
1821 (Project
=> Project
, Next
=> Empty_Project_List
);
1826 Current
: String_List_Id
:= Data
.Source_Dirs
;
1827 The_String
: String_Element
;
1830 -- If there are Ada sources, call action with the name of every
1831 -- source directory.
1834 In_Tree
.Projects
.Table
(Project
).Ada_Sources
/= Nil_String
1836 while Current
/= Nil_String
loop
1838 In_Tree
.String_Elements
.Table
(Current
);
1839 Action
(Get_Name_String
(The_String
.Display_Value
));
1840 Current
:= The_String
.Next
;
1845 -- If we are extending a project, visit it
1847 if Data
.Extends
/= No_Project
then
1851 -- And visit all imported projects
1853 while List
/= Empty_Project_List
loop
1854 Add
(In_Tree
.Project_Lists
.Table
(List
).Project
);
1855 List
:= In_Tree
.Project_Lists
.Table
(List
).Next
;
1859 -- Start of processing for For_All_Source_Dirs
1862 -- Visit this project, and its imported projects recursively
1865 end For_All_Source_Dirs
;
1871 procedure Get_Reference
1872 (Source_File_Name
: String;
1873 In_Tree
: Project_Tree_Ref
;
1874 Project
: out Project_Id
;
1875 Path
: out Path_Name_Type
)
1878 -- Body below could use some comments ???
1880 if Current_Verbosity
> Default
then
1881 Write_Str
("Getting Reference_Of (""");
1882 Write_Str
(Source_File_Name
);
1883 Write_Str
(""") ... ");
1887 Original_Name
: String := Source_File_Name
;
1891 Canonical_Case_File_Name
(Original_Name
);
1893 for Id
in Unit_Table
.First
..
1894 Unit_Table
.Last
(In_Tree
.Units
)
1896 Unit
:= In_Tree
.Units
.Table
(Id
);
1898 if (Unit
.File_Names
(Specification
).Name
/= No_File
1900 Namet
.Get_Name_String
1901 (Unit
.File_Names
(Specification
).Name
) = Original_Name
)
1902 or else (Unit
.File_Names
(Specification
).Path
/= No_Path
1904 Namet
.Get_Name_String
1905 (Unit
.File_Names
(Specification
).Path
) =
1908 Project
:= Ultimate_Extension_Of
1909 (Project
=> Unit
.File_Names
(Specification
).Project
,
1910 In_Tree
=> In_Tree
);
1911 Path
:= Unit
.File_Names
(Specification
).Display_Path
;
1913 if Current_Verbosity
> Default
then
1914 Write_Str
("Done: Specification.");
1920 elsif (Unit
.File_Names
(Body_Part
).Name
/= No_File
1922 Namet
.Get_Name_String
1923 (Unit
.File_Names
(Body_Part
).Name
) = Original_Name
)
1924 or else (Unit
.File_Names
(Body_Part
).Path
/= No_Path
1925 and then Namet
.Get_Name_String
1926 (Unit
.File_Names
(Body_Part
).Path
) =
1929 Project
:= Ultimate_Extension_Of
1930 (Project
=> Unit
.File_Names
(Body_Part
).Project
,
1931 In_Tree
=> In_Tree
);
1932 Path
:= Unit
.File_Names
(Body_Part
).Display_Path
;
1934 if Current_Verbosity
> Default
then
1935 Write_Str
("Done: Body.");
1944 Project
:= No_Project
;
1947 if Current_Verbosity
> Default
then
1948 Write_Str
("Cannot be found.");
1957 procedure Initialize
is
1959 Fill_Mapping_File
:= True;
1960 Current_Source_Path_File
:= No_Path
;
1961 Current_Object_Path_File
:= No_Path
;
1964 ------------------------------------
1965 -- Path_Name_Of_Library_Unit_Body --
1966 ------------------------------------
1968 -- Could use some comments in the body here ???
1970 function Path_Name_Of_Library_Unit_Body
1972 Project
: Project_Id
;
1973 In_Tree
: Project_Tree_Ref
) return String
1975 Data
: constant Project_Data
:=
1976 In_Tree
.Projects
.Table
(Project
);
1977 Original_Name
: String := Name
;
1979 Extended_Spec_Name
: String :=
1981 Spec_Suffix_Of
(In_Tree
, "ada", Data
.Naming
);
1982 Extended_Body_Name
: String :=
1984 Body_Suffix_Of
(In_Tree
, "ada", Data
.Naming
);
1986 First
: Unit_Index
:= Unit_Table
.First
;
1987 Current
: Unit_Index
;
1991 Canonical_Case_File_Name
(Original_Name
);
1992 Canonical_Case_File_Name
(Extended_Spec_Name
);
1993 Canonical_Case_File_Name
(Extended_Body_Name
);
1995 if Current_Verbosity
= High
then
1996 Write_Str
("Looking for path name of """);
2000 Write_Str
(" Extended Spec Name = """);
2001 Write_Str
(Extended_Spec_Name
);
2004 Write_Str
(" Extended Body Name = """);
2005 Write_Str
(Extended_Body_Name
);
2010 while First
<= Unit_Table
.Last
(In_Tree
.Units
)
2011 and then In_Tree
.Units
.Table
2012 (First
).File_Names
(Body_Part
).Project
/= Project
2018 while Current
<= Unit_Table
.Last
(In_Tree
.Units
) loop
2019 Unit
:= In_Tree
.Units
.Table
(Current
);
2021 if Unit
.File_Names
(Body_Part
).Project
= Project
2022 and then Unit
.File_Names
(Body_Part
).Name
/= No_File
2025 Current_Name
: constant String :=
2026 Namet
.Get_Name_String
(Unit
.File_Names
(Body_Part
).Name
);
2028 if Current_Verbosity
= High
then
2029 Write_Str
(" Comparing with """);
2030 Write_Str
(Current_Name
);
2035 if Current_Name
= Original_Name
then
2036 if Current_Verbosity
= High
then
2040 return Body_Path_Name_Of
(Current
, In_Tree
);
2042 elsif Current_Name
= Extended_Body_Name
then
2043 if Current_Verbosity
= High
then
2047 return Body_Path_Name_Of
(Current
, In_Tree
);
2050 if Current_Verbosity
= High
then
2051 Write_Line
(" not good");
2056 elsif Unit
.File_Names
(Specification
).Name
/= No_File
then
2058 Current_Name
: constant String :=
2059 Namet
.Get_Name_String
2060 (Unit
.File_Names
(Specification
).Name
);
2063 if Current_Verbosity
= High
then
2064 Write_Str
(" Comparing with """);
2065 Write_Str
(Current_Name
);
2070 if Current_Name
= Original_Name
then
2071 if Current_Verbosity
= High
then
2075 return Spec_Path_Name_Of
(Current
, In_Tree
);
2077 elsif Current_Name
= Extended_Spec_Name
then
2078 if Current_Verbosity
= High
then
2082 return Spec_Path_Name_Of
(Current
, In_Tree
);
2085 if Current_Verbosity
= High
then
2086 Write_Line
(" not good");
2091 Current
:= Current
+ 1;
2095 end Path_Name_Of_Library_Unit_Body
;
2101 -- Could use some comments in this body ???
2103 procedure Print_Sources
(In_Tree
: Project_Tree_Ref
) is
2107 Write_Line
("List of Sources:");
2109 for Id
in Unit_Table
.First
..
2110 Unit_Table
.Last
(In_Tree
.Units
)
2112 Unit
:= In_Tree
.Units
.Table
(Id
);
2114 Write_Line
(Namet
.Get_Name_String
(Unit
.Name
));
2116 if Unit
.File_Names
(Specification
).Name
/= No_File
then
2117 if Unit
.File_Names
(Specification
).Project
= No_Project
then
2118 Write_Line
(" No project");
2121 Write_Str
(" Project: ");
2123 (In_Tree
.Projects
.Table
2124 (Unit
.File_Names
(Specification
).Project
).Path_Name
);
2125 Write_Line
(Name_Buffer
(1 .. Name_Len
));
2128 Write_Str
(" spec: ");
2130 (Namet
.Get_Name_String
2131 (Unit
.File_Names
(Specification
).Name
));
2134 if Unit
.File_Names
(Body_Part
).Name
/= No_File
then
2135 if Unit
.File_Names
(Body_Part
).Project
= No_Project
then
2136 Write_Line
(" No project");
2139 Write_Str
(" Project: ");
2141 (In_Tree
.Projects
.Table
2142 (Unit
.File_Names
(Body_Part
).Project
).Path_Name
);
2143 Write_Line
(Name_Buffer
(1 .. Name_Len
));
2146 Write_Str
(" body: ");
2148 (Namet
.Get_Name_String
2149 (Unit
.File_Names
(Body_Part
).Name
));
2153 Write_Line
("end of List of Sources.");
2162 Main_Project
: Project_Id
;
2163 In_Tree
: Project_Tree_Ref
) return Project_Id
2165 Result
: Project_Id
:= No_Project
;
2167 Original_Name
: String := Name
;
2169 Data
: constant Project_Data
:=
2170 In_Tree
.Projects
.Table
(Main_Project
);
2172 Extended_Spec_Name
: String :=
2174 Spec_Suffix_Of
(In_Tree
, "ada", Data
.Naming
);
2175 Extended_Body_Name
: String :=
2177 Body_Suffix_Of
(In_Tree
, "ada", Data
.Naming
);
2181 Current_Name
: File_Name_Type
;
2182 The_Original_Name
: File_Name_Type
;
2183 The_Spec_Name
: File_Name_Type
;
2184 The_Body_Name
: File_Name_Type
;
2187 Canonical_Case_File_Name
(Original_Name
);
2188 Name_Len
:= Original_Name
'Length;
2189 Name_Buffer
(1 .. Name_Len
) := Original_Name
;
2190 The_Original_Name
:= Name_Find
;
2192 Canonical_Case_File_Name
(Extended_Spec_Name
);
2193 Name_Len
:= Extended_Spec_Name
'Length;
2194 Name_Buffer
(1 .. Name_Len
) := Extended_Spec_Name
;
2195 The_Spec_Name
:= Name_Find
;
2197 Canonical_Case_File_Name
(Extended_Body_Name
);
2198 Name_Len
:= Extended_Body_Name
'Length;
2199 Name_Buffer
(1 .. Name_Len
) := Extended_Body_Name
;
2200 The_Body_Name
:= Name_Find
;
2202 for Current
in reverse Unit_Table
.First
..
2203 Unit_Table
.Last
(In_Tree
.Units
)
2205 Unit
:= In_Tree
.Units
.Table
(Current
);
2209 Current_Name
:= Unit
.File_Names
(Body_Part
).Name
;
2211 -- Case of a body present
2213 if Current_Name
/= No_File
then
2215 -- If it has the name of the original name or the body name,
2216 -- we have found the project.
2218 if Unit
.Name
= Name_Id
(The_Original_Name
)
2219 or else Current_Name
= The_Original_Name
2220 or else Current_Name
= The_Body_Name
2222 Result
:= Unit
.File_Names
(Body_Part
).Project
;
2229 Current_Name
:= Unit
.File_Names
(Specification
).Name
;
2231 if Current_Name
/= No_File
then
2233 -- If name same as the original name, or the spec name, we have
2234 -- found the project.
2236 if Unit
.Name
= Name_Id
(The_Original_Name
)
2237 or else Current_Name
= The_Original_Name
2238 or else Current_Name
= The_Spec_Name
2240 Result
:= Unit
.File_Names
(Specification
).Project
;
2246 -- Get the ultimate extending project
2248 if Result
/= No_Project
then
2249 while In_Tree
.Projects
.Table
(Result
).Extended_By
/=
2252 Result
:= In_Tree
.Projects
.Table
(Result
).Extended_By
;
2263 procedure Set_Ada_Paths
2264 (Project
: Project_Id
;
2265 In_Tree
: Project_Tree_Ref
;
2266 Including_Libraries
: Boolean)
2268 Source_FD
: File_Descriptor
:= Invalid_FD
;
2269 Object_FD
: File_Descriptor
:= Invalid_FD
;
2271 Process_Source_Dirs
: Boolean := False;
2272 Process_Object_Dirs
: Boolean := False;
2275 -- For calls to Close
2279 procedure Add
(Proj
: Project_Id
);
2280 -- Add all the source/object directories of a project to the path only
2281 -- if this project has not been visited. Calls an internal procedure
2282 -- recursively for projects being extended, and imported projects.
2288 procedure Add
(Proj
: Project_Id
) is
2290 procedure Recursive_Add
(Project
: Project_Id
);
2291 -- Recursive procedure to add the source/object paths of extended/
2292 -- imported projects.
2298 procedure Recursive_Add
(Project
: Project_Id
) is
2300 -- If Seen is False, then the project has not yet been visited
2302 if not In_Tree
.Projects
.Table
(Project
).Seen
then
2303 In_Tree
.Projects
.Table
(Project
).Seen
:= True;
2306 Data
: constant Project_Data
:=
2307 In_Tree
.Projects
.Table
(Project
);
2308 List
: Project_List
:= Data
.Imported_Projects
;
2311 if Process_Source_Dirs
then
2313 -- Add to path all source directories of this project if
2314 -- there are Ada sources.
2316 if In_Tree
.Projects
.Table
(Project
).Ada_Sources
/=
2319 Add_To_Source_Path
(Data
.Source_Dirs
, In_Tree
);
2323 if Process_Object_Dirs
then
2325 -- Add to path the object directory of this project
2326 -- except if we don't include library project and this
2327 -- is a library project.
2329 if (Data
.Library
and Including_Libraries
)
2331 (Data
.Object_Directory
/= No_Path
2333 (not Including_Libraries
or else not Data
.Library
))
2335 -- For a library project, add the library ALI
2336 -- directory if there is no object directory or
2337 -- if the library ALI directory contains ALI files;
2338 -- otherwise add the object directory.
2340 if Data
.Library
then
2341 if Data
.Object_Directory
= No_Path
2342 or else Contains_ALI_Files
(Data
.Library_ALI_Dir
)
2345 (Data
.Library_ALI_Dir
, In_Tree
);
2348 (Data
.Object_Directory
, In_Tree
);
2351 -- For a non-library project, add the object
2352 -- directory, if it is not a virtual project, and if
2353 -- there are Ada sources or if the project is an
2354 -- extending project. If there are no Ada sources,
2355 -- adding the object directory could disrupt the order
2356 -- of the object dirs in the path.
2358 elsif not Data
.Virtual
2359 and then There_Are_Ada_Sources
(In_Tree
, Project
)
2362 (Data
.Object_Directory
, In_Tree
);
2367 -- Call Add to the project being extended, if any
2369 if Data
.Extends
/= No_Project
then
2370 Recursive_Add
(Data
.Extends
);
2373 -- Call Add for each imported project, if any
2375 while List
/= Empty_Project_List
loop
2377 (In_Tree
.Project_Lists
.Table
2380 In_Tree
.Project_Lists
.Table
(List
).Next
;
2387 Source_Path_Table
.Set_Last
(In_Tree
.Private_Part
.Source_Paths
, 0);
2388 Object_Path_Table
.Set_Last
(In_Tree
.Private_Part
.Object_Paths
, 0);
2390 for Index
in Project_Table
.First
..
2391 Project_Table
.Last
(In_Tree
.Projects
)
2393 In_Tree
.Projects
.Table
(Index
).Seen
:= False;
2396 Recursive_Add
(Proj
);
2399 -- Start of processing for Set_Ada_Paths
2402 -- If it is the first time we call this procedure for
2403 -- this project, compute the source path and/or the object path.
2405 if In_Tree
.Projects
.Table
(Project
).Include_Path_File
= No_Path
then
2406 Process_Source_Dirs
:= True;
2407 Create_New_Path_File
2408 (In_Tree
, Source_FD
,
2409 In_Tree
.Projects
.Table
(Project
).Include_Path_File
);
2412 -- For the object path, we make a distinction depending on
2413 -- Including_Libraries.
2415 if Including_Libraries
then
2416 if In_Tree
.Projects
.Table
2417 (Project
).Objects_Path_File_With_Libs
= No_Path
2419 Process_Object_Dirs
:= True;
2420 Create_New_Path_File
2421 (In_Tree
, Object_FD
, In_Tree
.Projects
.Table
(Project
).
2422 Objects_Path_File_With_Libs
);
2426 if In_Tree
.Projects
.Table
2427 (Project
).Objects_Path_File_Without_Libs
= No_Path
2429 Process_Object_Dirs
:= True;
2430 Create_New_Path_File
2431 (In_Tree
, Object_FD
, In_Tree
.Projects
.Table
(Project
).
2432 Objects_Path_File_Without_Libs
);
2436 -- If there is something to do, set Seen to False for all projects,
2437 -- then call the recursive procedure Add for Project.
2439 if Process_Source_Dirs
or Process_Object_Dirs
then
2443 -- Write and close any file that has been created
2445 if Source_FD
/= Invalid_FD
then
2446 for Index
in Source_Path_Table
.First
..
2447 Source_Path_Table
.Last
2448 (In_Tree
.Private_Part
.Source_Paths
)
2450 Get_Name_String
(In_Tree
.Private_Part
.Source_Paths
.Table
(Index
));
2451 Name_Len
:= Name_Len
+ 1;
2452 Name_Buffer
(Name_Len
) := ASCII
.LF
;
2453 Len
:= Write
(Source_FD
, Name_Buffer
(1)'Address, Name_Len
);
2455 if Len
/= Name_Len
then
2456 Prj
.Com
.Fail
("disk full");
2460 Close
(Source_FD
, Status
);
2463 Prj
.Com
.Fail
("disk full");
2467 if Object_FD
/= Invalid_FD
then
2468 for Index
in Object_Path_Table
.First
..
2469 Object_Path_Table
.Last
2470 (In_Tree
.Private_Part
.Object_Paths
)
2472 Get_Name_String
(In_Tree
.Private_Part
.Object_Paths
.Table
(Index
));
2473 Name_Len
:= Name_Len
+ 1;
2474 Name_Buffer
(Name_Len
) := ASCII
.LF
;
2475 Len
:= Write
(Object_FD
, Name_Buffer
(1)'Address, Name_Len
);
2477 if Len
/= Name_Len
then
2478 Prj
.Com
.Fail
("disk full");
2482 Close
(Object_FD
, Status
);
2485 Prj
.Com
.Fail
("disk full");
2489 -- Set the env vars, if they need to be changed, and set the
2490 -- corresponding flags.
2492 if Current_Source_Path_File
/=
2493 In_Tree
.Projects
.Table
(Project
).Include_Path_File
2495 Current_Source_Path_File
:=
2496 In_Tree
.Projects
.Table
(Project
).Include_Path_File
;
2498 (Project_Include_Path_File
,
2499 Get_Name_String
(Current_Source_Path_File
));
2500 Ada_Prj_Include_File_Set
:= True;
2503 if Including_Libraries
then
2504 if Current_Object_Path_File
2505 /= In_Tree
.Projects
.Table
2506 (Project
).Objects_Path_File_With_Libs
2508 Current_Object_Path_File
:=
2509 In_Tree
.Projects
.Table
2510 (Project
).Objects_Path_File_With_Libs
;
2512 (Project_Objects_Path_File
,
2513 Get_Name_String
(Current_Object_Path_File
));
2514 Ada_Prj_Objects_File_Set
:= True;
2518 if Current_Object_Path_File
/=
2519 In_Tree
.Projects
.Table
2520 (Project
).Objects_Path_File_Without_Libs
2522 Current_Object_Path_File
:=
2523 In_Tree
.Projects
.Table
2524 (Project
).Objects_Path_File_Without_Libs
;
2526 (Project_Objects_Path_File
,
2527 Get_Name_String
(Current_Object_Path_File
));
2528 Ada_Prj_Objects_File_Set
:= True;
2533 ---------------------------------------------
2534 -- Set_Mapping_File_Initial_State_To_Empty --
2535 ---------------------------------------------
2537 procedure Set_Mapping_File_Initial_State_To_Empty
is
2539 Fill_Mapping_File
:= False;
2540 end Set_Mapping_File_Initial_State_To_Empty
;
2542 -----------------------
2543 -- Set_Path_File_Var --
2544 -----------------------
2546 procedure Set_Path_File_Var
(Name
: String; Value
: String) is
2547 Host_Spec
: String_Access
:= To_Host_File_Spec
(Value
);
2550 if Host_Spec
= null then
2552 ("could not convert file name """, Value
, """ to host spec");
2554 Setenv
(Name
, Host_Spec
.all);
2557 end Set_Path_File_Var
;
2559 -----------------------
2560 -- Spec_Path_Name_Of --
2561 -----------------------
2563 function Spec_Path_Name_Of
2564 (Unit
: Unit_Index
; In_Tree
: Project_Tree_Ref
) return String
2566 Data
: Unit_Data
:= In_Tree
.Units
.Table
(Unit
);
2569 if Data
.File_Names
(Specification
).Path
= No_Path
then
2571 Current_Source
: String_List_Id
:=
2572 In_Tree
.Projects
.Table
2573 (Data
.File_Names
(Specification
).Project
).Ada_Sources
;
2574 Path
: GNAT
.OS_Lib
.String_Access
;
2577 Data
.File_Names
(Specification
).Path
:=
2578 Path_Name_Type
(Data
.File_Names
(Specification
).Name
);
2580 while Current_Source
/= Nil_String
loop
2581 Path
:= Locate_Regular_File
2582 (Namet
.Get_Name_String
2583 (Data
.File_Names
(Specification
).Name
),
2584 Namet
.Get_Name_String
2585 (In_Tree
.String_Elements
.Table
2586 (Current_Source
).Value
));
2588 if Path
/= null then
2589 Name_Len
:= Path
'Length;
2590 Name_Buffer
(1 .. Name_Len
) := Path
.all;
2591 Data
.File_Names
(Specification
).Path
:= Name_Enter
;
2595 In_Tree
.String_Elements
.Table
2596 (Current_Source
).Next
;
2600 In_Tree
.Units
.Table
(Unit
) := Data
;
2604 return Namet
.Get_Name_String
(Data
.File_Names
(Specification
).Path
);
2605 end Spec_Path_Name_Of
;
2607 ---------------------------
2608 -- Ultimate_Extension_Of --
2609 ---------------------------
2611 function Ultimate_Extension_Of
2612 (Project
: Project_Id
;
2613 In_Tree
: Project_Tree_Ref
) return Project_Id
2615 Result
: Project_Id
:= Project
;
2618 while In_Tree
.Projects
.Table
(Result
).Extended_By
/=
2621 Result
:= In_Tree
.Projects
.Table
(Result
).Extended_By
;
2625 end Ultimate_Extension_Of
;