1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2008, 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_Information
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_Information
265 Contains_ALI_Files (Data.Library_ALI_Dir.Name)
268 (Get_Name_String (Data.Library_ALI_Dir.Name));
271 (Get_Name_String (Data.Object_Directory.Name));
275 -- For a non library project, add the object directory
278 (Get_Name_String (Data.Object_Directory.Name));
282 -- Call Add to the project being extended, if any
284 if Data.Extends /= No_Project then
288 -- Call Add for each imported project, if any
290 while List /= Empty_Project_List loop
292 (In_Tree.Project_Lists.Table (List).Project);
293 List := In_Tree.Project_Lists.Table (List).Next;
300 -- Start of processing for Ada_Objects_Path
303 -- If it is the first time we call this function for
304 -- this project, compute the objects path
307 In_Tree.Projects.Table (Project).Ada_Objects_Path = null
309 Ada_Path_Length := 0;
311 for Index in Project_Table.First ..
312 Project_Table.Last (In_Tree.Projects)
314 In_Tree.Projects.Table (Index).Seen := False;
318 In_Tree.Projects.Table (Project).Ada_Objects_Path :=
319 new String'(Ada_Path_Buffer
(1 .. Ada_Path_Length
));
322 return In_Tree
.Projects
.Table
(Project
).Ada_Objects_Path
;
323 end Ada_Objects_Path
;
325 ------------------------
326 -- Add_To_Object_Path --
327 ------------------------
329 procedure Add_To_Object_Path
330 (Object_Dir
: Path_Name_Type
; In_Tree
: Project_Tree_Ref
)
333 -- Check if the directory is already in the table
335 for Index
in Object_Path_Table
.First
..
336 Object_Path_Table
.Last
(In_Tree
.Private_Part
.Object_Paths
)
339 -- If it is, remove it, and add it as the last one
341 if In_Tree
.Private_Part
.Object_Paths
.Table
(Index
) = Object_Dir
then
342 for Index2
in Index
+ 1 ..
343 Object_Path_Table
.Last
344 (In_Tree
.Private_Part
.Object_Paths
)
346 In_Tree
.Private_Part
.Object_Paths
.Table
(Index2
- 1) :=
347 In_Tree
.Private_Part
.Object_Paths
.Table
(Index2
);
350 In_Tree
.Private_Part
.Object_Paths
.Table
351 (Object_Path_Table
.Last
(In_Tree
.Private_Part
.Object_Paths
)) :=
357 -- The directory is not already in the table, add it
359 Object_Path_Table
.Increment_Last
(In_Tree
.Private_Part
.Object_Paths
);
360 In_Tree
.Private_Part
.Object_Paths
.Table
361 (Object_Path_Table
.Last
(In_Tree
.Private_Part
.Object_Paths
)) :=
363 end Add_To_Object_Path
;
369 procedure Add_To_Path
370 (Source_Dirs
: String_List_Id
;
371 In_Tree
: Project_Tree_Ref
)
373 Current
: String_List_Id
:= Source_Dirs
;
374 Source_Dir
: String_Element
;
376 while Current
/= Nil_String
loop
377 Source_Dir
:= In_Tree
.String_Elements
.Table
(Current
);
378 Add_To_Path
(Get_Name_String
(Source_Dir
.Display_Value
));
379 Current
:= Source_Dir
.Next
;
383 procedure Add_To_Path
(Dir
: String) is
385 New_Buffer
: String_Access
;
388 function Is_Present
(Path
: String; Dir
: String) return Boolean;
389 -- Return True if Dir is part of Path
395 function Is_Present
(Path
: String; Dir
: String) return Boolean is
396 Last
: constant Integer := Path
'Last - Dir
'Length + 1;
399 for J
in Path
'First .. Last
loop
401 -- Note: the order of the conditions below is important, since
402 -- it ensures a minimal number of string comparisons.
405 or else Path
(J
- 1) = Path_Separator
)
407 (J
+ Dir
'Length > Path
'Last
408 or else Path
(J
+ Dir
'Length) = Path_Separator
)
409 and then Dir
= Path
(J
.. J
+ Dir
'Length - 1)
418 -- Start of processing for Add_To_Path
421 if Is_Present
(Ada_Path_Buffer
(1 .. Ada_Path_Length
), Dir
) then
423 -- Dir is already in the path, nothing to do
428 Min_Len
:= Ada_Path_Length
+ Dir
'Length;
430 if Ada_Path_Length
> 0 then
432 -- Add 1 for the Path_Separator character
434 Min_Len
:= Min_Len
+ 1;
437 -- If Ada_Path_Buffer is too small, increase it
439 Len
:= Ada_Path_Buffer
'Last;
441 if Len
< Min_Len
then
444 exit when Len
>= Min_Len
;
447 New_Buffer
:= new String (1 .. Len
);
448 New_Buffer
(1 .. Ada_Path_Length
) :=
449 Ada_Path_Buffer
(1 .. Ada_Path_Length
);
450 Free
(Ada_Path_Buffer
);
451 Ada_Path_Buffer
:= New_Buffer
;
454 if Ada_Path_Length
> 0 then
455 Ada_Path_Length
:= Ada_Path_Length
+ 1;
456 Ada_Path_Buffer
(Ada_Path_Length
) := Path_Separator
;
460 (Ada_Path_Length
+ 1 .. Ada_Path_Length
+ Dir
'Length) := Dir
;
461 Ada_Path_Length
:= Ada_Path_Length
+ Dir
'Length;
464 ------------------------
465 -- Add_To_Source_Path --
466 ------------------------
468 procedure Add_To_Source_Path
469 (Source_Dirs
: String_List_Id
; In_Tree
: Project_Tree_Ref
)
471 Current
: String_List_Id
:= Source_Dirs
;
472 Source_Dir
: String_Element
;
476 -- Add each source directory
478 while Current
/= Nil_String
loop
479 Source_Dir
:= In_Tree
.String_Elements
.Table
(Current
);
482 -- Check if the source directory is already in the table
484 for Index
in Source_Path_Table
.First
..
485 Source_Path_Table
.Last
486 (In_Tree
.Private_Part
.Source_Paths
)
488 -- If it is already, no need to add it
490 if In_Tree
.Private_Part
.Source_Paths
.Table
(Index
) =
499 Source_Path_Table
.Increment_Last
500 (In_Tree
.Private_Part
.Source_Paths
);
501 In_Tree
.Private_Part
.Source_Paths
.Table
502 (Source_Path_Table
.Last
(In_Tree
.Private_Part
.Source_Paths
)) :=
506 -- Next source directory
508 Current
:= Source_Dir
.Next
;
510 end Add_To_Source_Path
;
512 -----------------------
513 -- Body_Path_Name_Of --
514 -----------------------
516 function Body_Path_Name_Of
518 In_Tree
: Project_Tree_Ref
) return String
520 Data
: Unit_Data
:= In_Tree
.Units
.Table
(Unit
);
523 -- If we don't know the path name of the body of this unit,
524 -- we compute it, and we store it.
526 if Data
.File_Names
(Body_Part
).Path
= No_Path_Information
then
528 Current_Source
: String_List_Id
:=
529 In_Tree
.Projects
.Table
530 (Data
.File_Names
(Body_Part
).Project
).Ada_Sources
;
531 Path
: GNAT
.OS_Lib
.String_Access
;
534 -- By default, put the file name
536 Data
.File_Names
(Body_Part
).Path
.Name
:=
537 Path_Name_Type
(Data
.File_Names
(Body_Part
).Name
);
539 -- For each source directory
541 while Current_Source
/= Nil_String
loop
544 (Namet
.Get_Name_String
545 (Data
.File_Names
(Body_Part
).Name
),
546 Namet
.Get_Name_String
547 (In_Tree
.String_Elements
.Table
548 (Current_Source
).Value
));
550 -- If the file is in this directory, then we store the path,
554 Name_Len
:= Path
'Length;
555 Name_Buffer
(1 .. Name_Len
) := Path
.all;
556 Data
.File_Names
(Body_Part
).Path
.Name
:= Name_Enter
;
561 In_Tree
.String_Elements
.Table
562 (Current_Source
).Next
;
566 In_Tree
.Units
.Table
(Unit
) := Data
;
570 -- Returned the stored value
572 return Namet
.Get_Name_String
(Data
.File_Names
(Body_Part
).Path
.Name
);
573 end Body_Path_Name_Of
;
575 ------------------------
576 -- Contains_ALI_Files --
577 ------------------------
579 function Contains_ALI_Files
(Dir
: Path_Name_Type
) return Boolean is
580 Dir_Name
: constant String := Get_Name_String
(Dir
);
582 Name
: String (1 .. 1_000
);
584 Result
: Boolean := False;
587 Open
(Direct
, Dir_Name
);
589 -- For each file in the directory, check if it is an ALI file
592 Read
(Direct
, Name
, Last
);
594 Canonical_Case_File_Name
(Name
(1 .. Last
));
595 Result
:= Last
>= 5 and then Name
(Last
- 3 .. Last
) = ".ali";
603 -- If there is any problem, close the directory if open and return
604 -- True; the library directory will be added to the path.
607 if Is_Open
(Direct
) then
612 end Contains_ALI_Files
;
614 --------------------------------
615 -- Create_Config_Pragmas_File --
616 --------------------------------
618 procedure Create_Config_Pragmas_File
619 (For_Project
: Project_Id
;
620 Main_Project
: Project_Id
;
621 In_Tree
: Project_Tree_Ref
;
622 Include_Config_Files
: Boolean := True)
624 pragma Unreferenced
(Main_Project
);
625 pragma Unreferenced
(Include_Config_Files
);
627 File_Name
: Path_Name_Type
:= No_Path
;
628 File
: File_Descriptor
:= Invalid_FD
;
630 Current_Unit
: Unit_Index
:= Unit_Table
.First
;
632 First_Project
: Project_List
:= Empty_Project_List
;
634 Current_Project
: Project_List
;
635 Current_Naming
: Naming_Id
;
640 procedure Check
(Project
: Project_Id
);
641 -- Recursive procedure that put in the config pragmas file any non
642 -- standard naming schemes, if it is not already in the file, then call
643 -- itself for any imported project.
645 procedure Check_Temp_File
;
646 -- Check that a temporary file has been opened.
647 -- If not, create one, and put its name in the project data,
648 -- with the indication that it is a temporary file.
651 (Unit_Name
: Name_Id
;
652 File_Name
: File_Name_Type
;
653 Unit_Kind
: Spec_Or_Body
;
655 -- Put an SFN pragma in the temporary file
657 procedure Put
(File
: File_Descriptor
; S
: String);
658 procedure Put_Line
(File
: File_Descriptor
; S
: String);
659 -- Output procedures, analogous to normal Text_IO procs of same name
665 procedure Check
(Project
: Project_Id
) is
666 Data
: constant Project_Data
:=
667 In_Tree
.Projects
.Table
(Project
);
670 if Current_Verbosity
= High
then
671 Write_Str
("Checking project file """);
672 Write_Str
(Namet
.Get_Name_String
(Data
.Name
));
677 -- Is this project in the list of the visited project?
679 Current_Project
:= First_Project
;
680 while Current_Project
/= Empty_Project_List
681 and then In_Tree
.Project_Lists
.Table
682 (Current_Project
).Project
/= Project
685 In_Tree
.Project_Lists
.Table
(Current_Project
).Next
;
688 -- If it is not, put it in the list, and visit it
690 if Current_Project
= Empty_Project_List
then
691 Project_List_Table
.Increment_Last
692 (In_Tree
.Project_Lists
);
693 In_Tree
.Project_Lists
.Table
694 (Project_List_Table
.Last
(In_Tree
.Project_Lists
)) :=
695 (Project
=> Project
, Next
=> First_Project
);
697 Project_List_Table
.Last
(In_Tree
.Project_Lists
);
699 -- Is the naming scheme of this project one that we know?
701 Current_Naming
:= Default_Naming
;
702 while Current_Naming
<=
703 Naming_Table
.Last
(In_Tree
.Private_Part
.Namings
)
704 and then not Same_Naming_Scheme
705 (Left
=> In_Tree
.Private_Part
.Namings
.Table
(Current_Naming
),
706 Right
=> Data
.Naming
) loop
707 Current_Naming
:= Current_Naming
+ 1;
710 -- If we don't know it, add it
713 Naming_Table
.Last
(In_Tree
.Private_Part
.Namings
)
715 Naming_Table
.Increment_Last
(In_Tree
.Private_Part
.Namings
);
716 In_Tree
.Private_Part
.Namings
.Table
717 (Naming_Table
.Last
(In_Tree
.Private_Part
.Namings
)) :=
720 -- We need a temporary file to be created
724 -- Put the SFN pragmas for the naming scheme
729 (File
, "pragma Source_File_Name_Project");
731 (File
, " (Spec_File_Name => ""*" &
732 Spec_Suffix_Of
(In_Tree
, "ada", Data
.Naming
) &
735 (File
, " Casing => " &
736 Image
(Data
.Naming
.Casing
) & ",");
738 (File
, " Dot_Replacement => """ &
739 Namet
.Get_Name_String
(Data
.Naming
.Dot_Replacement
) &
745 (File
, "pragma Source_File_Name_Project");
747 (File
, " (Body_File_Name => ""*" &
748 Body_Suffix_Of
(In_Tree
, "ada", Data
.Naming
) &
751 (File
, " Casing => " &
752 Image
(Data
.Naming
.Casing
) & ",");
754 (File
, " Dot_Replacement => """ &
755 Namet
.Get_Name_String
(Data
.Naming
.Dot_Replacement
) &
758 -- and maybe separate
760 if Body_Suffix_Of
(In_Tree
, "ada", Data
.Naming
) /=
761 Get_Name_String
(Data
.Naming
.Separate_Suffix
)
764 (File
, "pragma Source_File_Name_Project");
766 (File
, " (Subunit_File_Name => ""*" &
767 Namet
.Get_Name_String
(Data
.Naming
.Separate_Suffix
) &
770 (File
, " Casing => " &
771 Image
(Data
.Naming
.Casing
) &
774 (File
, " Dot_Replacement => """ &
775 Namet
.Get_Name_String
(Data
.Naming
.Dot_Replacement
) &
780 if Data
.Extends
/= No_Project
then
781 Check
(Data
.Extends
);
785 Current
: Project_List
:= Data
.Imported_Projects
;
788 while Current
/= Empty_Project_List
loop
790 (In_Tree
.Project_Lists
.Table
792 Current
:= In_Tree
.Project_Lists
.Table
799 ---------------------
800 -- Check_Temp_File --
801 ---------------------
803 procedure Check_Temp_File
is
805 if File
= Invalid_FD
then
806 Tempdir
.Create_Temp_File
(File
, Name
=> File_Name
);
808 if File
= Invalid_FD
then
810 ("unable to create temporary configuration pragmas file");
813 Record_Temp_File
(File_Name
);
815 if Opt
.Verbose_Mode
then
816 Write_Str
("Creating temp file """);
817 Write_Str
(Get_Name_String
(File_Name
));
829 (Unit_Name
: Name_Id
;
830 File_Name
: File_Name_Type
;
831 Unit_Kind
: Spec_Or_Body
;
835 -- A temporary file needs to be open
839 -- Put the pragma SFN for the unit kind (spec or body)
841 Put
(File
, "pragma Source_File_Name_Project (");
842 Put
(File
, Namet
.Get_Name_String
(Unit_Name
));
844 if Unit_Kind
= Specification
then
845 Put
(File
, ", Spec_File_Name => """);
847 Put
(File
, ", Body_File_Name => """);
850 Put
(File
, Namet
.Get_Name_String
(File_Name
));
854 Put
(File
, ", Index =>");
855 Put
(File
, Index
'Img);
858 Put_Line
(File
, ");");
861 procedure Put
(File
: File_Descriptor
; S
: String) is
865 Last
:= Write
(File
, S
(S
'First)'Address, S
'Length);
867 if Last
/= S
'Length then
868 Prj
.Com
.Fail
("Disk full");
871 if Current_Verbosity
= High
then
880 procedure Put_Line
(File
: File_Descriptor
; S
: String) is
881 S0
: String (1 .. S
'Length + 1);
885 -- Add an ASCII.LF to the string. As this config file is supposed to
886 -- be used only by the compiler, we don't care about the characters
887 -- for the end of line. In fact we could have put a space, but
888 -- it is more convenient to be able to read gnat.adc during
889 -- development, for which the ASCII.LF is fine.
891 S0
(1 .. S
'Length) := S
;
892 S0
(S0
'Last) := ASCII
.LF
;
893 Last
:= Write
(File
, S0
'Address, S0
'Length);
895 if Last
/= S
'Length + 1 then
896 Prj
.Com
.Fail
("Disk full");
899 if Current_Verbosity
= High
then
904 -- Start of processing for Create_Config_Pragmas_File
908 In_Tree
.Projects
.Table
(For_Project
).Config_Checked
911 -- Remove any memory of processed naming schemes, if any
913 Naming_Table
.Set_Last
(In_Tree
.Private_Part
.Namings
, Default_Naming
);
915 -- Check the naming schemes
919 -- Visit all the units and process those that need an SFN pragma
922 Current_Unit
<= Unit_Table
.Last
(In_Tree
.Units
)
925 Unit
: constant Unit_Data
:=
926 In_Tree
.Units
.Table
(Current_Unit
);
929 if Unit
.File_Names
(Specification
).Needs_Pragma
then
931 Unit
.File_Names
(Specification
).Name
,
933 Unit
.File_Names
(Specification
).Index
);
936 if Unit
.File_Names
(Body_Part
).Needs_Pragma
then
938 Unit
.File_Names
(Body_Part
).Name
,
940 Unit
.File_Names
(Body_Part
).Index
);
943 Current_Unit
:= Current_Unit
+ 1;
947 -- If there are no non standard naming scheme, issue the GNAT
948 -- standard naming scheme. This will tell the compiler that
949 -- a project file is used and will forbid any pragma SFN.
951 if File
= Invalid_FD
then
954 Put_Line
(File
, "pragma Source_File_Name_Project");
955 Put_Line
(File
, " (Spec_File_Name => ""*.ads"",");
956 Put_Line
(File
, " Dot_Replacement => ""-"",");
957 Put_Line
(File
, " Casing => lowercase);");
959 Put_Line
(File
, "pragma Source_File_Name_Project");
960 Put_Line
(File
, " (Body_File_Name => ""*.adb"",");
961 Put_Line
(File
, " Dot_Replacement => ""-"",");
962 Put_Line
(File
, " Casing => lowercase);");
965 -- Close the temporary file
967 GNAT
.OS_Lib
.Close
(File
, Status
);
970 Prj
.Com
.Fail
("disk full");
973 if Opt
.Verbose_Mode
then
974 Write_Str
("Closing configuration file """);
975 Write_Str
(Get_Name_String
(File_Name
));
979 In_Tree
.Projects
.Table
(For_Project
).Config_File_Name
:=
981 In_Tree
.Projects
.Table
(For_Project
).Config_File_Temp
:=
984 In_Tree
.Projects
.Table
(For_Project
).Config_Checked
:=
987 end Create_Config_Pragmas_File
;
993 procedure Create_Mapping
(In_Tree
: Project_Tree_Ref
) is
994 The_Unit_Data
: Unit_Data
;
995 Data
: File_Name_Data
;
1000 for Unit
in 1 .. Unit_Table
.Last
(In_Tree
.Units
) loop
1001 The_Unit_Data
:= In_Tree
.Units
.Table
(Unit
);
1003 -- Process only if the unit has a valid name
1005 if The_Unit_Data
.Name
/= No_Name
then
1006 Data
:= The_Unit_Data
.File_Names
(Specification
);
1008 -- If there is a spec, put it in the mapping
1010 if Data
.Name
/= No_File
then
1011 if Data
.Path
.Name
= Slash
then
1012 Fmap
.Add_Forbidden_File_Name
(Data
.Name
);
1014 Fmap
.Add_To_File_Map
1015 (Unit_Name
=> Unit_Name_Type
(The_Unit_Data
.Name
),
1016 File_Name
=> Data
.Name
,
1017 Path_Name
=> File_Name_Type
(Data
.Path
.Name
));
1021 Data
:= The_Unit_Data
.File_Names
(Body_Part
);
1023 -- If there is a body (or subunit) put it in the mapping
1025 if Data
.Name
/= No_File
then
1026 if Data
.Path
.Name
= Slash
then
1027 Fmap
.Add_Forbidden_File_Name
(Data
.Name
);
1029 Fmap
.Add_To_File_Map
1030 (Unit_Name
=> Unit_Name_Type
(The_Unit_Data
.Name
),
1031 File_Name
=> Data
.Name
,
1032 Path_Name
=> File_Name_Type
(Data
.Path
.Name
));
1039 -------------------------
1040 -- Create_Mapping_File --
1041 -------------------------
1043 procedure Create_Mapping_File
1044 (Project
: Project_Id
;
1045 In_Tree
: Project_Tree_Ref
;
1046 Name
: out Path_Name_Type
)
1048 File
: File_Descriptor
:= Invalid_FD
;
1049 The_Unit_Data
: Unit_Data
;
1050 Data
: File_Name_Data
;
1053 -- For call to Close
1055 Present
: Project_Flags
1056 (No_Project
.. Project_Table
.Last
(In_Tree
.Projects
)) :=
1058 -- For each project in the closure of Project, the corresponding flag
1059 -- will be set to True;
1061 procedure Put_Name_Buffer
;
1062 -- Put the line contained in the Name_Buffer in the mapping file
1064 procedure Put_Data
(Spec
: Boolean);
1065 -- Put the mapping of the spec or body contained in Data in the file
1068 procedure Recursive_Flag
(Prj
: Project_Id
);
1069 -- Set the flags corresponding to Prj, the projects it imports
1070 -- (directly or indirectly) or extends to True. Call itself recursively.
1076 procedure Put_Name_Buffer
is
1080 Name_Len
:= Name_Len
+ 1;
1081 Name_Buffer
(Name_Len
) := ASCII
.LF
;
1082 Last
:= Write
(File
, Name_Buffer
(1)'Address, Name_Len
);
1084 if Last
/= Name_Len
then
1085 Prj
.Com
.Fail
("Disk full");
1087 end Put_Name_Buffer
;
1093 procedure Put_Data
(Spec
: Boolean) is
1095 -- Line with the unit name
1097 Get_Name_String
(The_Unit_Data
.Name
);
1098 Name_Len
:= Name_Len
+ 1;
1099 Name_Buffer
(Name_Len
) := '%';
1100 Name_Len
:= Name_Len
+ 1;
1103 Name_Buffer
(Name_Len
) := 's';
1105 Name_Buffer
(Name_Len
) := 'b';
1110 -- Line with the file name
1112 Get_Name_String
(Data
.Name
);
1115 -- Line with the path name
1117 Get_Name_String
(Data
.Path
.Name
);
1122 --------------------
1123 -- Recursive_Flag --
1124 --------------------
1126 procedure Recursive_Flag
(Prj
: Project_Id
) is
1127 Imported
: Project_List
;
1131 -- Nothing to do for non existent project or project that has
1132 -- already been flagged.
1134 if Prj
= No_Project
or else Present
(Prj
) then
1138 -- Flag the current project
1140 Present
(Prj
) := True;
1142 In_Tree
.Projects
.Table
(Prj
).Imported_Projects
;
1144 -- Call itself for each project directly imported
1146 while Imported
/= Empty_Project_List
loop
1148 In_Tree
.Project_Lists
.Table
(Imported
).Project
;
1150 In_Tree
.Project_Lists
.Table
(Imported
).Next
;
1151 Recursive_Flag
(Proj
);
1154 -- Call itself for an eventual project being extended
1156 Recursive_Flag
(In_Tree
.Projects
.Table
(Prj
).Extends
);
1159 -- Start of processing for Create_Mapping_File
1162 -- Flag the necessary projects
1164 Recursive_Flag
(Project
);
1166 -- Create the temporary file
1168 Tempdir
.Create_Temp_File
(File
, Name
=> Name
);
1170 if File
= Invalid_FD
then
1171 Prj
.Com
.Fail
("unable to create temporary mapping file");
1174 Record_Temp_File
(Name
);
1176 if Opt
.Verbose_Mode
then
1177 Write_Str
("Creating temp mapping file """);
1178 Write_Str
(Get_Name_String
(Name
));
1183 if Fill_Mapping_File
then
1185 -- For all units in table Units
1187 for Unit
in 1 .. Unit_Table
.Last
(In_Tree
.Units
) loop
1188 The_Unit_Data
:= In_Tree
.Units
.Table
(Unit
);
1190 -- If the unit has a valid name
1192 if The_Unit_Data
.Name
/= No_Name
then
1193 Data
:= The_Unit_Data
.File_Names
(Specification
);
1195 -- If there is a spec, put it mapping in the file if it is
1196 -- from a project in the closure of Project.
1198 if Data
.Name
/= No_File
and then Present
(Data
.Project
) then
1199 Put_Data
(Spec
=> True);
1202 Data
:= The_Unit_Data
.File_Names
(Body_Part
);
1204 -- If there is a body (or subunit) put its mapping in the file
1205 -- if it is from a project in the closure of Project.
1207 if Data
.Name
/= No_File
and then Present
(Data
.Project
) then
1208 Put_Data
(Spec
=> False);
1215 GNAT
.OS_Lib
.Close
(File
, Status
);
1218 Prj
.Com
.Fail
("disk full");
1220 end Create_Mapping_File
;
1222 procedure Create_Mapping_File
1223 (Project
: Project_Id
;
1225 In_Tree
: Project_Tree_Ref
;
1226 Name
: out Path_Name_Type
)
1228 File
: File_Descriptor
:= Invalid_FD
;
1231 -- For call to Close
1233 Present
: Project_Flags
1234 (No_Project
.. Project_Table
.Last
(In_Tree
.Projects
)) :=
1236 -- For each project in the closure of Project, the corresponding flag
1237 -- will be set to True.
1240 Src_Data
: Source_Data
;
1241 Suffix
: File_Name_Type
;
1243 procedure Put_Name_Buffer
;
1244 -- Put the line contained in the Name_Buffer in the mapping file
1246 procedure Recursive_Flag
(Prj
: Project_Id
);
1247 -- Set the flags corresponding to Prj, the projects it imports
1248 -- (directly or indirectly) or extends to True. Call itself recursively.
1254 procedure Put_Name_Buffer
is
1258 Name_Len
:= Name_Len
+ 1;
1259 Name_Buffer
(Name_Len
) := ASCII
.LF
;
1260 Last
:= Write
(File
, Name_Buffer
(1)'Address, Name_Len
);
1262 if Last
/= Name_Len
then
1263 Prj
.Com
.Fail
("Disk full");
1265 end Put_Name_Buffer
;
1267 --------------------
1268 -- Recursive_Flag --
1269 --------------------
1271 procedure Recursive_Flag
(Prj
: Project_Id
) is
1272 Imported
: Project_List
;
1276 -- Nothing to do for non existent project or project that has already
1279 if Prj
= No_Project
or else Present
(Prj
) then
1283 -- Flag the current project
1285 Present
(Prj
) := True;
1287 In_Tree
.Projects
.Table
(Prj
).Imported_Projects
;
1289 -- Call itself for each project directly imported
1291 while Imported
/= Empty_Project_List
loop
1293 In_Tree
.Project_Lists
.Table
(Imported
).Project
;
1295 In_Tree
.Project_Lists
.Table
(Imported
).Next
;
1296 Recursive_Flag
(Proj
);
1299 -- Call itself for an eventual project being extended
1301 Recursive_Flag
(In_Tree
.Projects
.Table
(Prj
).Extends
);
1304 -- Start of processing for Create_Mapping_File
1307 -- Flag the necessary projects
1309 Recursive_Flag
(Project
);
1311 -- Create the temporary file
1313 Tempdir
.Create_Temp_File
(File
, Name
=> Name
);
1315 if File
= Invalid_FD
then
1316 Prj
.Com
.Fail
("unable to create temporary mapping file");
1319 Record_Temp_File
(Name
);
1321 if Opt
.Verbose_Mode
then
1322 Write_Str
("Creating temp mapping file """);
1323 Write_Str
(Get_Name_String
(Name
));
1328 -- For all source of the Language of all projects in the closure
1330 for Proj
in Present
'Range loop
1331 if Present
(Proj
) then
1332 Source
:= In_Tree
.Projects
.Table
(Proj
).First_Source
;
1334 while Source
/= No_Source
loop
1335 Src_Data
:= In_Tree
.Sources
.Table
(Source
);
1337 if Src_Data
.Language_Name
= Language
1338 and then not Src_Data
.Locally_Removed
1339 and then Src_Data
.Replaced_By
= No_Source
1340 and then Src_Data
.Path
.Name
/= No_Path
1342 if Src_Data
.Unit
/= No_Name
then
1343 Get_Name_String
(Src_Data
.Unit
);
1345 if Src_Data
.Kind
= Spec
then
1347 In_Tree
.Languages_Data
.Table
1348 (Src_Data
.Language
).Config
.Mapping_Spec_Suffix
;
1351 In_Tree
.Languages_Data
.Table
1352 (Src_Data
.Language
).Config
.Mapping_Body_Suffix
;
1355 if Suffix
/= No_File
then
1356 Add_Str_To_Name_Buffer
(Get_Name_String
(Suffix
));
1362 Get_Name_String
(Src_Data
.File
);
1365 Get_Name_String
(Src_Data
.Path
.Name
);
1369 Source
:= Src_Data
.Next_In_Project
;
1374 GNAT
.OS_Lib
.Close
(File
, Status
);
1377 Prj
.Com
.Fail
("disk full");
1379 end Create_Mapping_File
;
1381 --------------------------
1382 -- Create_New_Path_File --
1383 --------------------------
1385 procedure Create_New_Path_File
1386 (In_Tree
: Project_Tree_Ref
;
1387 Path_FD
: out File_Descriptor
;
1388 Path_Name
: out Path_Name_Type
)
1391 Tempdir
.Create_Temp_File
(Path_FD
, Path_Name
);
1393 if Path_Name
/= No_Path
then
1394 Record_Temp_File
(Path_Name
);
1396 -- Record the name, so that the temp path file will be deleted at the
1397 -- end of the program.
1399 Path_File_Table
.Increment_Last
(In_Tree
.Private_Part
.Path_Files
);
1400 In_Tree
.Private_Part
.Path_Files
.Table
1401 (Path_File_Table
.Last
(In_Tree
.Private_Part
.Path_Files
)) :=
1404 end Create_New_Path_File
;
1406 ---------------------------
1407 -- Delete_All_Path_Files --
1408 ---------------------------
1410 procedure Delete_All_Path_Files
(In_Tree
: Project_Tree_Ref
) is
1411 Disregard
: Boolean := True;
1412 pragma Warnings
(Off
, Disregard
);
1415 for Index
in Path_File_Table
.First
..
1416 Path_File_Table
.Last
(In_Tree
.Private_Part
.Path_Files
)
1418 if In_Tree
.Private_Part
.Path_Files
.Table
(Index
) /= No_Path
then
1421 (In_Tree
.Private_Part
.Path_Files
.Table
(Index
)),
1426 -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or
1427 -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
1428 -- the empty string. On VMS, this has the effect of deassigning
1429 -- the logical names.
1431 if Ada_Prj_Include_File_Set
then
1432 Setenv
(Project_Include_Path_File
, "");
1433 Ada_Prj_Include_File_Set
:= False;
1436 if Ada_Prj_Objects_File_Set
then
1437 Setenv
(Project_Objects_Path_File
, "");
1438 Ada_Prj_Objects_File_Set
:= False;
1440 end Delete_All_Path_Files
;
1442 ------------------------------------
1443 -- File_Name_Of_Library_Unit_Body --
1444 ------------------------------------
1446 function File_Name_Of_Library_Unit_Body
1448 Project
: Project_Id
;
1449 In_Tree
: Project_Tree_Ref
;
1450 Main_Project_Only
: Boolean := True;
1451 Full_Path
: Boolean := False) return String
1453 The_Project
: Project_Id
:= Project
;
1454 Data
: Project_Data
:=
1455 In_Tree
.Projects
.Table
(Project
);
1456 Original_Name
: String := Name
;
1458 Extended_Spec_Name
: String :=
1460 Spec_Suffix_Of
(In_Tree
, "ada", Data
.Naming
);
1461 Extended_Body_Name
: String :=
1463 Body_Suffix_Of
(In_Tree
, "ada", Data
.Naming
);
1467 The_Original_Name
: Name_Id
;
1468 The_Spec_Name
: Name_Id
;
1469 The_Body_Name
: Name_Id
;
1472 Canonical_Case_File_Name
(Original_Name
);
1473 Name_Len
:= Original_Name
'Length;
1474 Name_Buffer
(1 .. Name_Len
) := Original_Name
;
1475 The_Original_Name
:= Name_Find
;
1477 Canonical_Case_File_Name
(Extended_Spec_Name
);
1478 Name_Len
:= Extended_Spec_Name
'Length;
1479 Name_Buffer
(1 .. Name_Len
) := Extended_Spec_Name
;
1480 The_Spec_Name
:= Name_Find
;
1482 Canonical_Case_File_Name
(Extended_Body_Name
);
1483 Name_Len
:= Extended_Body_Name
'Length;
1484 Name_Buffer
(1 .. Name_Len
) := Extended_Body_Name
;
1485 The_Body_Name
:= Name_Find
;
1487 if Current_Verbosity
= High
then
1488 Write_Str
("Looking for file name of """);
1492 Write_Str
(" Extended Spec Name = """);
1493 Write_Str
(Extended_Spec_Name
);
1496 Write_Str
(" Extended Body Name = """);
1497 Write_Str
(Extended_Body_Name
);
1502 -- For extending project, search in the extended project if the source
1503 -- is not found. For non extending projects, this loop will be run only
1507 -- Loop through units
1508 -- Should have comment explaining reverse ???
1510 for Current
in reverse Unit_Table
.First
..
1511 Unit_Table
.Last
(In_Tree
.Units
)
1513 Unit
:= In_Tree
.Units
.Table
(Current
);
1517 if not Main_Project_Only
1518 or else Unit
.File_Names
(Body_Part
).Project
= The_Project
1521 Current_Name
: constant File_Name_Type
:=
1522 Unit
.File_Names
(Body_Part
).Name
;
1525 -- Case of a body present
1527 if Current_Name
/= No_File
then
1528 if Current_Verbosity
= High
then
1529 Write_Str
(" Comparing with """);
1530 Write_Str
(Get_Name_String
(Current_Name
));
1535 -- If it has the name of the original name, return the
1538 if Unit
.Name
= The_Original_Name
1540 Current_Name
= File_Name_Type
(The_Original_Name
)
1542 if Current_Verbosity
= High
then
1547 return Get_Name_String
1548 (Unit
.File_Names
(Body_Part
).Path
.Name
);
1551 return Get_Name_String
(Current_Name
);
1554 -- If it has the name of the extended body name,
1555 -- return the extended body name
1557 elsif Current_Name
= File_Name_Type
(The_Body_Name
) then
1558 if Current_Verbosity
= High
then
1563 return Get_Name_String
1564 (Unit
.File_Names
(Body_Part
).Path
.Name
);
1567 return Extended_Body_Name
;
1571 if Current_Verbosity
= High
then
1572 Write_Line
(" not good");
1581 if not Main_Project_Only
1582 or else Unit
.File_Names
(Specification
).Project
= The_Project
1585 Current_Name
: constant File_Name_Type
:=
1586 Unit
.File_Names
(Specification
).Name
;
1589 -- Case of spec present
1591 if Current_Name
/= No_File
then
1592 if Current_Verbosity
= High
then
1593 Write_Str
(" Comparing with """);
1594 Write_Str
(Get_Name_String
(Current_Name
));
1599 -- If name same as original name, return original name
1601 if Unit
.Name
= The_Original_Name
1603 Current_Name
= File_Name_Type
(The_Original_Name
)
1605 if Current_Verbosity
= High
then
1610 return Get_Name_String
1611 (Unit
.File_Names
(Specification
).Path
.Name
);
1613 return Get_Name_String
(Current_Name
);
1616 -- If it has the same name as the extended spec name,
1617 -- return the extended spec name.
1619 elsif Current_Name
= File_Name_Type
(The_Spec_Name
) then
1620 if Current_Verbosity
= High
then
1625 return Get_Name_String
1626 (Unit
.File_Names
(Specification
).Path
.Name
);
1628 return Extended_Spec_Name
;
1632 if Current_Verbosity
= High
then
1633 Write_Line
(" not good");
1641 -- If we are not in an extending project, give up
1643 exit when (not Main_Project_Only
) or else Data
.Extends
= No_Project
;
1645 -- Otherwise, look in the project we are extending
1647 The_Project
:= Data
.Extends
;
1648 Data
:= In_Tree
.Projects
.Table
(The_Project
);
1651 -- We don't know this file name, return an empty string
1654 end File_Name_Of_Library_Unit_Body
;
1656 -------------------------
1657 -- For_All_Object_Dirs --
1658 -------------------------
1660 procedure For_All_Object_Dirs
1661 (Project
: Project_Id
;
1662 In_Tree
: Project_Tree_Ref
)
1664 Seen
: Project_List
:= Empty_Project_List
;
1666 procedure Add
(Project
: Project_Id
);
1667 -- Process a project. Remember the processes visited to avoid processing
1668 -- a project twice. Recursively process an eventual extended project,
1669 -- and all imported projects.
1675 procedure Add
(Project
: Project_Id
) is
1676 Data
: constant Project_Data
:=
1677 In_Tree
.Projects
.Table
(Project
);
1678 List
: Project_List
:= Data
.Imported_Projects
;
1681 -- If the list of visited project is empty, then
1682 -- for sure we never visited this project.
1684 if Seen
= Empty_Project_List
then
1685 Project_List_Table
.Increment_Last
(In_Tree
.Project_Lists
);
1686 Seen
:= Project_List_Table
.Last
(In_Tree
.Project_Lists
);
1687 In_Tree
.Project_Lists
.Table
(Seen
) :=
1688 (Project
=> Project
, Next
=> Empty_Project_List
);
1691 -- Check if the project is in the list
1694 Current
: Project_List
:= Seen
;
1698 -- If it is, then there is nothing else to do
1700 if In_Tree
.Project_Lists
.Table
1701 (Current
).Project
= Project
1707 In_Tree
.Project_Lists
.Table
(Current
).Next
=
1710 In_Tree
.Project_Lists
.Table
(Current
).Next
;
1713 -- This project has never been visited, add it
1716 Project_List_Table
.Increment_Last
1717 (In_Tree
.Project_Lists
);
1718 In_Tree
.Project_Lists
.Table
(Current
).Next
:=
1719 Project_List_Table
.Last
(In_Tree
.Project_Lists
);
1720 In_Tree
.Project_Lists
.Table
1721 (Project_List_Table
.Last
1722 (In_Tree
.Project_Lists
)) :=
1723 (Project
=> Project
, Next
=> Empty_Project_List
);
1727 -- If there is an object directory, call Action with its name
1729 if Data
.Object_Directory
/= No_Path_Information
then
1730 Get_Name_String
(Data
.Object_Directory
.Display_Name
);
1731 Action
(Name_Buffer
(1 .. Name_Len
));
1734 -- If we are extending a project, visit it
1736 if Data
.Extends
/= No_Project
then
1740 -- And visit all imported projects
1742 while List
/= Empty_Project_List
loop
1743 Add
(In_Tree
.Project_Lists
.Table
(List
).Project
);
1744 List
:= In_Tree
.Project_Lists
.Table
(List
).Next
;
1748 -- Start of processing for For_All_Object_Dirs
1751 -- Visit this project, and its imported projects, recursively
1754 end For_All_Object_Dirs
;
1756 -------------------------
1757 -- For_All_Source_Dirs --
1758 -------------------------
1760 procedure For_All_Source_Dirs
1761 (Project
: Project_Id
;
1762 In_Tree
: Project_Tree_Ref
)
1764 Seen
: Project_List
:= Empty_Project_List
;
1766 procedure Add
(Project
: Project_Id
);
1767 -- Process a project. Remember the processes visited to avoid processing
1768 -- a project twice. Recursively process an eventual extended project,
1769 -- and all imported projects.
1775 procedure Add
(Project
: Project_Id
) is
1776 Data
: constant Project_Data
:=
1777 In_Tree
.Projects
.Table
(Project
);
1778 List
: Project_List
:= Data
.Imported_Projects
;
1781 -- If the list of visited project is empty, then for sure we never
1782 -- visited this project.
1784 if Seen
= Empty_Project_List
then
1785 Project_List_Table
.Increment_Last
1786 (In_Tree
.Project_Lists
);
1787 Seen
:= Project_List_Table
.Last
1788 (In_Tree
.Project_Lists
);
1789 In_Tree
.Project_Lists
.Table
(Seen
) :=
1790 (Project
=> Project
, Next
=> Empty_Project_List
);
1793 -- Check if the project is in the list
1796 Current
: Project_List
:= Seen
;
1800 -- If it is, then there is nothing else to do
1802 if In_Tree
.Project_Lists
.Table
1803 (Current
).Project
= Project
1809 In_Tree
.Project_Lists
.Table
(Current
).Next
=
1812 In_Tree
.Project_Lists
.Table
(Current
).Next
;
1815 -- This project has never been visited, add it to the list
1817 Project_List_Table
.Increment_Last
1818 (In_Tree
.Project_Lists
);
1819 In_Tree
.Project_Lists
.Table
(Current
).Next
:=
1820 Project_List_Table
.Last
(In_Tree
.Project_Lists
);
1821 In_Tree
.Project_Lists
.Table
1822 (Project_List_Table
.Last
1823 (In_Tree
.Project_Lists
)) :=
1824 (Project
=> Project
, Next
=> Empty_Project_List
);
1829 Current
: String_List_Id
:= Data
.Source_Dirs
;
1830 The_String
: String_Element
;
1833 -- If there are Ada sources, call action with the name of every
1834 -- source directory.
1837 In_Tree
.Projects
.Table
(Project
).Ada_Sources
/= Nil_String
1839 while Current
/= Nil_String
loop
1841 In_Tree
.String_Elements
.Table
(Current
);
1842 Action
(Get_Name_String
(The_String
.Display_Value
));
1843 Current
:= The_String
.Next
;
1848 -- If we are extending a project, visit it
1850 if Data
.Extends
/= No_Project
then
1854 -- And visit all imported projects
1856 while List
/= Empty_Project_List
loop
1857 Add
(In_Tree
.Project_Lists
.Table
(List
).Project
);
1858 List
:= In_Tree
.Project_Lists
.Table
(List
).Next
;
1862 -- Start of processing for For_All_Source_Dirs
1865 -- Visit this project, and its imported projects recursively
1868 end For_All_Source_Dirs
;
1874 procedure Get_Reference
1875 (Source_File_Name
: String;
1876 In_Tree
: Project_Tree_Ref
;
1877 Project
: out Project_Id
;
1878 Path
: out Path_Name_Type
)
1881 -- Body below could use some comments ???
1883 if Current_Verbosity
> Default
then
1884 Write_Str
("Getting Reference_Of (""");
1885 Write_Str
(Source_File_Name
);
1886 Write_Str
(""") ... ");
1890 Original_Name
: String := Source_File_Name
;
1894 Canonical_Case_File_Name
(Original_Name
);
1896 for Id
in Unit_Table
.First
..
1897 Unit_Table
.Last
(In_Tree
.Units
)
1899 Unit
:= In_Tree
.Units
.Table
(Id
);
1901 if (Unit
.File_Names
(Specification
).Name
/= No_File
1903 Namet
.Get_Name_String
1904 (Unit
.File_Names
(Specification
).Name
) = Original_Name
)
1905 or else (Unit
.File_Names
(Specification
).Path
/=
1908 Namet
.Get_Name_String
1909 (Unit
.File_Names
(Specification
).Path
.Name
) =
1912 Project
:= Ultimate_Extension_Of
1913 (Project
=> Unit
.File_Names
(Specification
).Project
,
1914 In_Tree
=> In_Tree
);
1915 Path
:= Unit
.File_Names
(Specification
).Path
.Display_Name
;
1917 if Current_Verbosity
> Default
then
1918 Write_Str
("Done: Specification.");
1924 elsif (Unit
.File_Names
(Body_Part
).Name
/= No_File
1926 Namet
.Get_Name_String
1927 (Unit
.File_Names
(Body_Part
).Name
) = Original_Name
)
1928 or else (Unit
.File_Names
(Body_Part
).Path
/= No_Path_Information
1929 and then Namet
.Get_Name_String
1930 (Unit
.File_Names
(Body_Part
).Path
.Name
) =
1933 Project
:= Ultimate_Extension_Of
1934 (Project
=> Unit
.File_Names
(Body_Part
).Project
,
1935 In_Tree
=> In_Tree
);
1936 Path
:= Unit
.File_Names
(Body_Part
).Path
.Display_Name
;
1938 if Current_Verbosity
> Default
then
1939 Write_Str
("Done: Body.");
1948 Project
:= No_Project
;
1951 if Current_Verbosity
> Default
then
1952 Write_Str
("Cannot be found.");
1961 procedure Initialize
is
1963 Fill_Mapping_File
:= True;
1964 Current_Source_Path_File
:= No_Path
;
1965 Current_Object_Path_File
:= No_Path
;
1968 ------------------------------------
1969 -- Path_Name_Of_Library_Unit_Body --
1970 ------------------------------------
1972 -- Could use some comments in the body here ???
1974 function Path_Name_Of_Library_Unit_Body
1976 Project
: Project_Id
;
1977 In_Tree
: Project_Tree_Ref
) return String
1979 Data
: constant Project_Data
:=
1980 In_Tree
.Projects
.Table
(Project
);
1981 Original_Name
: String := Name
;
1983 Extended_Spec_Name
: String :=
1985 Spec_Suffix_Of
(In_Tree
, "ada", Data
.Naming
);
1986 Extended_Body_Name
: String :=
1988 Body_Suffix_Of
(In_Tree
, "ada", Data
.Naming
);
1990 First
: Unit_Index
:= Unit_Table
.First
;
1991 Current
: Unit_Index
;
1995 Canonical_Case_File_Name
(Original_Name
);
1996 Canonical_Case_File_Name
(Extended_Spec_Name
);
1997 Canonical_Case_File_Name
(Extended_Body_Name
);
1999 if Current_Verbosity
= High
then
2000 Write_Str
("Looking for path name of """);
2004 Write_Str
(" Extended Spec Name = """);
2005 Write_Str
(Extended_Spec_Name
);
2008 Write_Str
(" Extended Body Name = """);
2009 Write_Str
(Extended_Body_Name
);
2014 while First
<= Unit_Table
.Last
(In_Tree
.Units
)
2015 and then In_Tree
.Units
.Table
2016 (First
).File_Names
(Body_Part
).Project
/= Project
2022 while Current
<= Unit_Table
.Last
(In_Tree
.Units
) loop
2023 Unit
:= In_Tree
.Units
.Table
(Current
);
2025 if Unit
.File_Names
(Body_Part
).Project
= Project
2026 and then Unit
.File_Names
(Body_Part
).Name
/= No_File
2029 Current_Name
: constant String :=
2030 Namet
.Get_Name_String
(Unit
.File_Names
(Body_Part
).Name
);
2032 if Current_Verbosity
= High
then
2033 Write_Str
(" Comparing with """);
2034 Write_Str
(Current_Name
);
2039 if Current_Name
= Original_Name
then
2040 if Current_Verbosity
= High
then
2044 return Body_Path_Name_Of
(Current
, In_Tree
);
2046 elsif Current_Name
= Extended_Body_Name
then
2047 if Current_Verbosity
= High
then
2051 return Body_Path_Name_Of
(Current
, In_Tree
);
2054 if Current_Verbosity
= High
then
2055 Write_Line
(" not good");
2060 elsif Unit
.File_Names
(Specification
).Name
/= No_File
then
2062 Current_Name
: constant String :=
2063 Namet
.Get_Name_String
2064 (Unit
.File_Names
(Specification
).Name
);
2067 if Current_Verbosity
= High
then
2068 Write_Str
(" Comparing with """);
2069 Write_Str
(Current_Name
);
2074 if Current_Name
= Original_Name
then
2075 if Current_Verbosity
= High
then
2079 return Spec_Path_Name_Of
(Current
, In_Tree
);
2081 elsif Current_Name
= Extended_Spec_Name
then
2082 if Current_Verbosity
= High
then
2086 return Spec_Path_Name_Of
(Current
, In_Tree
);
2089 if Current_Verbosity
= High
then
2090 Write_Line
(" not good");
2095 Current
:= Current
+ 1;
2099 end Path_Name_Of_Library_Unit_Body
;
2105 -- Could use some comments in this body ???
2107 procedure Print_Sources
(In_Tree
: Project_Tree_Ref
) is
2111 Write_Line
("List of Sources:");
2113 for Id
in Unit_Table
.First
..
2114 Unit_Table
.Last
(In_Tree
.Units
)
2116 Unit
:= In_Tree
.Units
.Table
(Id
);
2118 Write_Line
(Namet
.Get_Name_String
(Unit
.Name
));
2120 if Unit
.File_Names
(Specification
).Name
/= No_File
then
2121 if Unit
.File_Names
(Specification
).Project
= No_Project
then
2122 Write_Line
(" No project");
2125 Write_Str
(" Project: ");
2127 (In_Tree
.Projects
.Table
2128 (Unit
.File_Names
(Specification
).Project
).Path
.Name
);
2129 Write_Line
(Name_Buffer
(1 .. Name_Len
));
2132 Write_Str
(" spec: ");
2134 (Namet
.Get_Name_String
2135 (Unit
.File_Names
(Specification
).Name
));
2138 if Unit
.File_Names
(Body_Part
).Name
/= No_File
then
2139 if Unit
.File_Names
(Body_Part
).Project
= No_Project
then
2140 Write_Line
(" No project");
2143 Write_Str
(" Project: ");
2145 (In_Tree
.Projects
.Table
2146 (Unit
.File_Names
(Body_Part
).Project
).Path
.Name
);
2147 Write_Line
(Name_Buffer
(1 .. Name_Len
));
2150 Write_Str
(" body: ");
2152 (Namet
.Get_Name_String
2153 (Unit
.File_Names
(Body_Part
).Name
));
2157 Write_Line
("end of List of Sources.");
2166 Main_Project
: Project_Id
;
2167 In_Tree
: Project_Tree_Ref
) return Project_Id
2169 Result
: Project_Id
:= No_Project
;
2171 Original_Name
: String := Name
;
2173 Data
: constant Project_Data
:=
2174 In_Tree
.Projects
.Table
(Main_Project
);
2176 Extended_Spec_Name
: String :=
2178 Spec_Suffix_Of
(In_Tree
, "ada", Data
.Naming
);
2179 Extended_Body_Name
: String :=
2181 Body_Suffix_Of
(In_Tree
, "ada", Data
.Naming
);
2185 Current_Name
: File_Name_Type
;
2186 The_Original_Name
: File_Name_Type
;
2187 The_Spec_Name
: File_Name_Type
;
2188 The_Body_Name
: File_Name_Type
;
2191 Canonical_Case_File_Name
(Original_Name
);
2192 Name_Len
:= Original_Name
'Length;
2193 Name_Buffer
(1 .. Name_Len
) := Original_Name
;
2194 The_Original_Name
:= Name_Find
;
2196 Canonical_Case_File_Name
(Extended_Spec_Name
);
2197 Name_Len
:= Extended_Spec_Name
'Length;
2198 Name_Buffer
(1 .. Name_Len
) := Extended_Spec_Name
;
2199 The_Spec_Name
:= Name_Find
;
2201 Canonical_Case_File_Name
(Extended_Body_Name
);
2202 Name_Len
:= Extended_Body_Name
'Length;
2203 Name_Buffer
(1 .. Name_Len
) := Extended_Body_Name
;
2204 The_Body_Name
:= Name_Find
;
2206 for Current
in reverse Unit_Table
.First
..
2207 Unit_Table
.Last
(In_Tree
.Units
)
2209 Unit
:= In_Tree
.Units
.Table
(Current
);
2213 Current_Name
:= Unit
.File_Names
(Body_Part
).Name
;
2215 -- Case of a body present
2217 if Current_Name
/= No_File
then
2219 -- If it has the name of the original name or the body name,
2220 -- we have found the project.
2222 if Unit
.Name
= Name_Id
(The_Original_Name
)
2223 or else Current_Name
= The_Original_Name
2224 or else Current_Name
= The_Body_Name
2226 Result
:= Unit
.File_Names
(Body_Part
).Project
;
2233 Current_Name
:= Unit
.File_Names
(Specification
).Name
;
2235 if Current_Name
/= No_File
then
2237 -- If name same as the original name, or the spec name, we have
2238 -- found the project.
2240 if Unit
.Name
= Name_Id
(The_Original_Name
)
2241 or else Current_Name
= The_Original_Name
2242 or else Current_Name
= The_Spec_Name
2244 Result
:= Unit
.File_Names
(Specification
).Project
;
2250 -- Get the ultimate extending project
2252 if Result
/= No_Project
then
2253 while In_Tree
.Projects
.Table
(Result
).Extended_By
/=
2256 Result
:= In_Tree
.Projects
.Table
(Result
).Extended_By
;
2267 procedure Set_Ada_Paths
2268 (Project
: Project_Id
;
2269 In_Tree
: Project_Tree_Ref
;
2270 Including_Libraries
: Boolean)
2272 Source_FD
: File_Descriptor
:= Invalid_FD
;
2273 Object_FD
: File_Descriptor
:= Invalid_FD
;
2275 Process_Source_Dirs
: Boolean := False;
2276 Process_Object_Dirs
: Boolean := False;
2279 -- For calls to Close
2283 procedure Add
(Proj
: Project_Id
);
2284 -- Add all the source/object directories of a project to the path only
2285 -- if this project has not been visited. Calls an internal procedure
2286 -- recursively for projects being extended, and imported projects.
2292 procedure Add
(Proj
: Project_Id
) is
2294 procedure Recursive_Add
(Project
: Project_Id
);
2295 -- Recursive procedure to add the source/object paths of extended/
2296 -- imported projects.
2302 procedure Recursive_Add
(Project
: Project_Id
) is
2304 -- If Seen is False, then the project has not yet been visited
2306 if not In_Tree
.Projects
.Table
(Project
).Seen
then
2307 In_Tree
.Projects
.Table
(Project
).Seen
:= True;
2310 Data
: constant Project_Data
:=
2311 In_Tree
.Projects
.Table
(Project
);
2312 List
: Project_List
:= Data
.Imported_Projects
;
2315 if Process_Source_Dirs
then
2317 -- Add to path all source directories of this project if
2318 -- there are Ada sources.
2320 if In_Tree
.Projects
.Table
(Project
).Ada_Sources
/=
2323 Add_To_Source_Path
(Data
.Source_Dirs
, In_Tree
);
2327 if Process_Object_Dirs
then
2329 -- Add to path the object directory of this project
2330 -- except if we don't include library project and this
2331 -- is a library project.
2333 if (Data
.Library
and Including_Libraries
)
2335 (Data
.Object_Directory
/= No_Path_Information
2337 (not Including_Libraries
or else not Data
.Library
))
2339 -- For a library project, add the library ALI
2340 -- directory if there is no object directory or
2341 -- if the library ALI directory contains ALI files;
2342 -- otherwise add the object directory.
2344 if Data
.Library
then
2345 if Data
.Object_Directory
= No_Path_Information
2346 or else Contains_ALI_Files
2347 (Data
.Library_ALI_Dir
.Name
)
2350 (Data
.Library_ALI_Dir
.Name
, In_Tree
);
2353 (Data
.Object_Directory
.Name
, In_Tree
);
2356 -- For a non-library project, add the object
2357 -- directory, if it is not a virtual project, and if
2358 -- there are Ada sources or if the project is an
2359 -- extending project. If there are no Ada sources,
2360 -- adding the object directory could disrupt the order
2361 -- of the object dirs in the path.
2363 elsif not Data
.Virtual
2364 and then There_Are_Ada_Sources
(In_Tree
, Project
)
2367 (Data
.Object_Directory
.Name
, In_Tree
);
2372 -- Call Add to the project being extended, if any
2374 if Data
.Extends
/= No_Project
then
2375 Recursive_Add
(Data
.Extends
);
2378 -- Call Add for each imported project, if any
2380 while List
/= Empty_Project_List
loop
2382 (In_Tree
.Project_Lists
.Table
2385 In_Tree
.Project_Lists
.Table
(List
).Next
;
2392 Source_Path_Table
.Set_Last
(In_Tree
.Private_Part
.Source_Paths
, 0);
2393 Object_Path_Table
.Set_Last
(In_Tree
.Private_Part
.Object_Paths
, 0);
2395 for Index
in Project_Table
.First
..
2396 Project_Table
.Last
(In_Tree
.Projects
)
2398 In_Tree
.Projects
.Table
(Index
).Seen
:= False;
2401 Recursive_Add
(Proj
);
2404 -- Start of processing for Set_Ada_Paths
2407 -- If it is the first time we call this procedure for
2408 -- this project, compute the source path and/or the object path.
2410 if In_Tree
.Projects
.Table
(Project
).Include_Path_File
= No_Path
then
2411 Process_Source_Dirs
:= True;
2412 Create_New_Path_File
2413 (In_Tree
, Source_FD
,
2414 In_Tree
.Projects
.Table
(Project
).Include_Path_File
);
2417 -- For the object path, we make a distinction depending on
2418 -- Including_Libraries.
2420 if Including_Libraries
then
2421 if In_Tree
.Projects
.Table
2422 (Project
).Objects_Path_File_With_Libs
= No_Path
2424 Process_Object_Dirs
:= True;
2425 Create_New_Path_File
2426 (In_Tree
, Object_FD
, In_Tree
.Projects
.Table
(Project
).
2427 Objects_Path_File_With_Libs
);
2431 if In_Tree
.Projects
.Table
2432 (Project
).Objects_Path_File_Without_Libs
= No_Path
2434 Process_Object_Dirs
:= True;
2435 Create_New_Path_File
2436 (In_Tree
, Object_FD
, In_Tree
.Projects
.Table
(Project
).
2437 Objects_Path_File_Without_Libs
);
2441 -- If there is something to do, set Seen to False for all projects,
2442 -- then call the recursive procedure Add for Project.
2444 if Process_Source_Dirs
or Process_Object_Dirs
then
2448 -- Write and close any file that has been created
2450 if Source_FD
/= Invalid_FD
then
2451 for Index
in Source_Path_Table
.First
..
2452 Source_Path_Table
.Last
2453 (In_Tree
.Private_Part
.Source_Paths
)
2455 Get_Name_String
(In_Tree
.Private_Part
.Source_Paths
.Table
(Index
));
2456 Name_Len
:= Name_Len
+ 1;
2457 Name_Buffer
(Name_Len
) := ASCII
.LF
;
2458 Len
:= Write
(Source_FD
, Name_Buffer
(1)'Address, Name_Len
);
2460 if Len
/= Name_Len
then
2461 Prj
.Com
.Fail
("disk full");
2465 Close
(Source_FD
, Status
);
2468 Prj
.Com
.Fail
("disk full");
2472 if Object_FD
/= Invalid_FD
then
2473 for Index
in Object_Path_Table
.First
..
2474 Object_Path_Table
.Last
2475 (In_Tree
.Private_Part
.Object_Paths
)
2477 Get_Name_String
(In_Tree
.Private_Part
.Object_Paths
.Table
(Index
));
2478 Name_Len
:= Name_Len
+ 1;
2479 Name_Buffer
(Name_Len
) := ASCII
.LF
;
2480 Len
:= Write
(Object_FD
, Name_Buffer
(1)'Address, Name_Len
);
2482 if Len
/= Name_Len
then
2483 Prj
.Com
.Fail
("disk full");
2487 Close
(Object_FD
, Status
);
2490 Prj
.Com
.Fail
("disk full");
2494 -- Set the env vars, if they need to be changed, and set the
2495 -- corresponding flags.
2497 if Current_Source_Path_File
/=
2498 In_Tree
.Projects
.Table
(Project
).Include_Path_File
2500 Current_Source_Path_File
:=
2501 In_Tree
.Projects
.Table
(Project
).Include_Path_File
;
2503 (Project_Include_Path_File
,
2504 Get_Name_String
(Current_Source_Path_File
));
2505 Ada_Prj_Include_File_Set
:= True;
2508 if Including_Libraries
then
2509 if Current_Object_Path_File
2510 /= In_Tree
.Projects
.Table
2511 (Project
).Objects_Path_File_With_Libs
2513 Current_Object_Path_File
:=
2514 In_Tree
.Projects
.Table
2515 (Project
).Objects_Path_File_With_Libs
;
2517 (Project_Objects_Path_File
,
2518 Get_Name_String
(Current_Object_Path_File
));
2519 Ada_Prj_Objects_File_Set
:= True;
2523 if Current_Object_Path_File
/=
2524 In_Tree
.Projects
.Table
2525 (Project
).Objects_Path_File_Without_Libs
2527 Current_Object_Path_File
:=
2528 In_Tree
.Projects
.Table
2529 (Project
).Objects_Path_File_Without_Libs
;
2531 (Project_Objects_Path_File
,
2532 Get_Name_String
(Current_Object_Path_File
));
2533 Ada_Prj_Objects_File_Set
:= True;
2538 ---------------------------------------------
2539 -- Set_Mapping_File_Initial_State_To_Empty --
2540 ---------------------------------------------
2542 procedure Set_Mapping_File_Initial_State_To_Empty
is
2544 Fill_Mapping_File
:= False;
2545 end Set_Mapping_File_Initial_State_To_Empty
;
2547 -----------------------
2548 -- Set_Path_File_Var --
2549 -----------------------
2551 procedure Set_Path_File_Var
(Name
: String; Value
: String) is
2552 Host_Spec
: String_Access
:= To_Host_File_Spec
(Value
);
2555 if Host_Spec
= null then
2557 ("could not convert file name """, Value
, """ to host spec");
2559 Setenv
(Name
, Host_Spec
.all);
2562 end Set_Path_File_Var
;
2564 -----------------------
2565 -- Spec_Path_Name_Of --
2566 -----------------------
2568 function Spec_Path_Name_Of
2569 (Unit
: Unit_Index
; In_Tree
: Project_Tree_Ref
) return String
2571 Data
: Unit_Data
:= In_Tree
.Units
.Table
(Unit
);
2574 if Data
.File_Names
(Specification
).Path
.Name
= No_Path
then
2576 Current_Source
: String_List_Id
:=
2577 In_Tree
.Projects
.Table
2578 (Data
.File_Names
(Specification
).Project
).Ada_Sources
;
2579 Path
: GNAT
.OS_Lib
.String_Access
;
2582 Data
.File_Names
(Specification
).Path
.Name
:=
2583 Path_Name_Type
(Data
.File_Names
(Specification
).Name
);
2585 while Current_Source
/= Nil_String
loop
2586 Path
:= Locate_Regular_File
2587 (Namet
.Get_Name_String
2588 (Data
.File_Names
(Specification
).Name
),
2589 Namet
.Get_Name_String
2590 (In_Tree
.String_Elements
.Table
2591 (Current_Source
).Value
));
2593 if Path
/= null then
2594 Name_Len
:= Path
'Length;
2595 Name_Buffer
(1 .. Name_Len
) := Path
.all;
2596 Data
.File_Names
(Specification
).Path
.Name
:= Name_Enter
;
2600 In_Tree
.String_Elements
.Table
2601 (Current_Source
).Next
;
2605 In_Tree
.Units
.Table
(Unit
) := Data
;
2609 return Namet
.Get_Name_String
(Data
.File_Names
(Specification
).Path
.Name
);
2610 end Spec_Path_Name_Of
;
2612 ---------------------------
2613 -- Ultimate_Extension_Of --
2614 ---------------------------
2616 function Ultimate_Extension_Of
2617 (Project
: Project_Id
;
2618 In_Tree
: Project_Tree_Ref
) return Project_Id
2620 Result
: Project_Id
:= Project
;
2623 while In_Tree
.Projects
.Table
(Result
).Extended_By
/=
2626 Result
:= In_Tree
.Projects
.Table
(Result
).Extended_By
;
2630 end Ultimate_Extension_Of
;