1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2004 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Namet
; use Namet
;
29 with Osint
; use Osint
;
30 with Output
; use Output
;
31 with Prj
.Com
; use Prj
.Com
;
35 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
37 package body Prj
.Env
is
39 type Naming_Id
is new Nat
;
41 Current_Source_Path_File
: Name_Id
:= No_Name
;
42 -- Current value of project source path file env var.
43 -- Used to avoid setting the env var to the same value.
45 Current_Object_Path_File
: Name_Id
:= No_Name
;
46 -- Current value of project object path file env var.
47 -- Used to avoid setting the env var to the same value.
49 Ada_Path_Buffer
: String_Access
:= new String (1 .. 1024);
50 -- A buffer where values for ADA_INCLUDE_PATH
51 -- and ADA_OBJECTS_PATH are stored.
53 Ada_Path_Length
: Natural := 0;
54 -- Index of the last valid character in Ada_Path_Buffer.
56 Ada_Prj_Include_File_Set
: Boolean := False;
57 Ada_Prj_Objects_File_Set
: Boolean := False;
58 -- These flags are set to True when the corresponding environment variables
59 -- are set and are used to give these environment variables an empty string
60 -- value at the end of the program. This has no practical effect on most
61 -- platforms, except on VMS where the logical names are deassigned, thus
62 -- avoiding the pollution of the environment of the caller.
64 package Namings
is new Table
.Table
65 (Table_Component_Type
=> Naming_Data
,
66 Table_Index_Type
=> Naming_Id
,
69 Table_Increment
=> 100,
70 Table_Name
=> "Prj.Env.Namings");
72 Default_Naming
: constant Naming_Id
:= Namings
.First
;
74 Fill_Mapping_File
: Boolean := True;
76 package Path_Files
is new Table
.Table
77 (Table_Component_Type
=> Name_Id
,
78 Table_Index_Type
=> Natural,
81 Table_Increment
=> 50,
82 Table_Name
=> "Prj.Env.Path_Files");
83 -- Table storing all the temp path file names.
84 -- Used by Delete_All_Path_Files.
86 type Project_Flags
is array (Project_Id
range <>) of Boolean;
87 -- A Boolean array type used in Create_Mapping_File to select the projects
88 -- in the closure of a specific project.
90 package Source_Paths
is new Table
.Table
91 (Table_Component_Type
=> Name_Id
,
92 Table_Index_Type
=> Natural,
95 Table_Increment
=> 50,
96 Table_Name
=> "Prj.Env.Source_Paths");
97 -- A table to store the source dirs before creating the source path file
99 package Object_Paths
is new Table
.Table
100 (Table_Component_Type
=> Name_Id
,
101 Table_Index_Type
=> Natural,
102 Table_Low_Bound
=> 1,
104 Table_Increment
=> 50,
105 Table_Name
=> "Prj.Env.Source_Paths");
106 -- A table to store the object dirs, before creating the object path file
108 -----------------------
109 -- Local Subprograms --
110 -----------------------
112 function Body_Path_Name_Of
(Unit
: Unit_Id
) return String;
113 -- Returns the path name of the body of a unit.
114 -- Compute it first, if necessary.
116 function Spec_Path_Name_Of
(Unit
: Unit_Id
) return String;
117 -- Returns the path name of the spec of a unit.
118 -- Compute it first, if necessary.
120 procedure Add_To_Path
(Source_Dirs
: String_List_Id
);
121 -- Add to Ada_Path_Buffer all the source directories in string list
122 -- Source_Dirs, if any. Increment Ada_Path_Length.
124 procedure Add_To_Path
(Dir
: String);
125 -- If Dir is not already in the global variable Ada_Path_Buffer, add it.
126 -- Increment Ada_Path_Length.
127 -- If Ada_Path_Length /= 0, prepend a Path_Separator character to
130 procedure Add_To_Source_Path
(Source_Dirs
: String_List_Id
);
131 -- Add to Ada_Path_B all the source directories in string list
132 -- Source_Dirs, if any. Increment Ada_Path_Length.
134 procedure Add_To_Object_Path
(Object_Dir
: Name_Id
);
135 -- Add Object_Dir to object path table. Make sure it is not duplicate
136 -- and it is the last one in the current table.
138 procedure Create_New_Path_File
139 (Path_FD
: out File_Descriptor
;
140 Path_Name
: out Name_Id
);
141 -- Create a new temporary path file. Get the file name in Path_Name.
142 -- The name is normally obtained by increasing the number in
143 -- Temp_Path_File_Name by 1.
145 procedure Set_Path_File_Var
(Name
: String; Value
: String);
146 -- Call Setenv, after calling To_Host_File_Spec
148 function Ultimate_Extension_Of
(Project
: in Project_Id
) return Project_Id
;
149 -- Return a project that is either Project or an extended ancestor of
150 -- Project that itself is not extended.
152 ----------------------
153 -- Ada_Include_Path --
154 ----------------------
156 function Ada_Include_Path
(Project
: Project_Id
) return String_Access
is
158 procedure Add
(Project
: Project_Id
);
159 -- Add all the source directories of a project to the path only if
160 -- this project has not been visited. Calls itself recursively for
161 -- projects being extended, and imported projects. Adds the project
162 -- to the list Seen if this is the call to Add for this project.
168 procedure Add
(Project
: Project_Id
) is
170 -- If Seen is empty, then the project cannot have been visited
172 if not Projects
.Table
(Project
).Seen
then
173 Projects
.Table
(Project
).Seen
:= True;
176 Data
: constant Project_Data
:= Projects
.Table
(Project
);
177 List
: Project_List
:= Data
.Imported_Projects
;
180 -- Add to path all source directories of this project
182 Add_To_Path
(Data
.Source_Dirs
);
184 -- Call Add to the project being extended, if any
186 if Data
.Extends
/= No_Project
then
190 -- Call Add for each imported project, if any
192 while List
/= Empty_Project_List
loop
193 Add
(Project_Lists
.Table
(List
).Project
);
194 List
:= Project_Lists
.Table
(List
).Next
;
200 -- Start of processing for Ada_Include_Path
203 -- If it is the first time we call this function for
204 -- this project, compute the source path
206 if Projects
.Table
(Project
).Ada_Include_Path
= null then
207 Ada_Path_Length
:= 0;
209 for Index
in 1 .. Projects
.Last
loop
210 Projects
.Table
(Index
).Seen
:= False;
214 Projects
.Table
(Project
).Ada_Include_Path
:=
215 new String'(Ada_Path_Buffer (1 .. Ada_Path_Length));
218 return Projects.Table (Project).Ada_Include_Path;
219 end Ada_Include_Path;
221 ----------------------
222 -- Ada_Include_Path --
223 ----------------------
225 function Ada_Include_Path
226 (Project : Project_Id;
227 Recursive : Boolean) return String
231 return Ada_Include_Path (Project).all;
233 Ada_Path_Length := 0;
234 Add_To_Path (Projects.Table (Project).Source_Dirs);
235 return Ada_Path_Buffer (1 .. Ada_Path_Length);
237 end Ada_Include_Path;
239 ----------------------
240 -- Ada_Objects_Path --
241 ----------------------
243 function Ada_Objects_Path
244 (Project : Project_Id;
245 Including_Libraries : Boolean := True) return String_Access
247 procedure Add (Project : Project_Id);
248 -- Add all the object directories of a project to the path only if
249 -- this project has not been visited. Calls itself recursively for
250 -- projects being extended, and imported projects. Adds the project
251 -- to the list Seen if this is the first call to Add for this project.
257 procedure Add (Project : Project_Id) is
259 -- If this project has not been seen yet
261 if not Projects.Table (Project).Seen then
262 Projects.Table (Project).Seen := True;
265 Data : constant Project_Data := Projects.Table (Project);
266 List : Project_List := Data.Imported_Projects;
269 -- Add to path the object directory of this project
270 -- except if we don't include library project and
271 -- this is a library project.
273 if (Data.Library and then Including_Libraries)
275 (Data.Object_Directory /= No_Name
277 (not Including_Libraries or else not Data.Library))
279 -- For a library project, add the library directory
282 Add_To_Path (Get_Name_String (Data.Library_Dir));
285 -- For a non library project, add the object directory
287 Add_To_Path (Get_Name_String (Data.Object_Directory));
291 -- Call Add to the project being extended, if any
293 if Data.Extends /= No_Project then
297 -- Call Add for each imported project, if any
299 while List /= Empty_Project_List loop
300 Add (Project_Lists.Table (List).Project);
301 List := Project_Lists.Table (List).Next;
308 -- Start of processing for Ada_Objects_Path
311 -- If it is the first time we call this function for
312 -- this project, compute the objects path
314 if Projects.Table (Project).Ada_Objects_Path = null then
315 Ada_Path_Length := 0;
317 for Index in 1 .. Projects.Last loop
318 Projects.Table (Index).Seen := False;
322 Projects.Table (Project).Ada_Objects_Path :=
323 new String'(Ada_Path_Buffer
(1 .. Ada_Path_Length
));
326 return Projects
.Table
(Project
).Ada_Objects_Path
;
327 end Ada_Objects_Path
;
329 ------------------------
330 -- Add_To_Object_Path --
331 ------------------------
333 procedure Add_To_Object_Path
(Object_Dir
: Name_Id
) is
335 -- Check if the directory is already in the table
337 for Index
in 1 .. Object_Paths
.Last
loop
339 -- If it is, remove it, and add it as the last one
341 if Object_Paths
.Table
(Index
) = Object_Dir
then
342 for Index2
in Index
+ 1 .. Object_Paths
.Last
loop
343 Object_Paths
.Table
(Index2
- 1) :=
344 Object_Paths
.Table
(Index2
);
347 Object_Paths
.Table
(Object_Paths
.Last
) := Object_Dir
;
352 -- The directory is not already in the table, add it
354 Object_Paths
.Increment_Last
;
355 Object_Paths
.Table
(Object_Paths
.Last
) := Object_Dir
;
356 end Add_To_Object_Path
;
362 procedure Add_To_Path
(Source_Dirs
: String_List_Id
) is
363 Current
: String_List_Id
:= Source_Dirs
;
364 Source_Dir
: String_Element
;
366 while Current
/= Nil_String
loop
367 Source_Dir
:= String_Elements
.Table
(Current
);
368 Add_To_Path
(Get_Name_String
(Source_Dir
.Display_Value
));
369 Current
:= Source_Dir
.Next
;
373 procedure Add_To_Path
(Dir
: String) is
375 New_Buffer
: String_Access
;
378 function Is_Present
(Path
: String; Dir
: String) return Boolean;
379 -- Return True if Dir is part of Path
385 function Is_Present
(Path
: String; Dir
: String) return Boolean is
386 Last
: constant Integer := Path
'Last - Dir
'Length + 1;
389 for J
in Path
'First .. Last
loop
391 -- Note: the order of the conditions below is important, since
392 -- it ensures a minimal number of string comparisons.
395 or else Path
(J
- 1) = Path_Separator
)
397 (J
+ Dir
'Length > Path
'Last
398 or else Path
(J
+ Dir
'Length) = Path_Separator
)
399 and then Dir
= Path
(J
.. J
+ Dir
'Length - 1)
408 -- Start of processing for Add_To_Path
411 if Is_Present
(Ada_Path_Buffer
(1 .. Ada_Path_Length
), Dir
) then
413 -- Dir is already in the path, nothing to do
418 Min_Len
:= Ada_Path_Length
+ Dir
'Length;
420 if Ada_Path_Length
> 0 then
422 -- Add 1 for the Path_Separator character
424 Min_Len
:= Min_Len
+ 1;
427 -- If Ada_Path_Buffer is too small, increase it
429 Len
:= Ada_Path_Buffer
'Last;
431 if Len
< Min_Len
then
434 exit when Len
>= Min_Len
;
437 New_Buffer
:= new String (1 .. Len
);
438 New_Buffer
(1 .. Ada_Path_Length
) :=
439 Ada_Path_Buffer
(1 .. Ada_Path_Length
);
440 Free
(Ada_Path_Buffer
);
441 Ada_Path_Buffer
:= New_Buffer
;
444 if Ada_Path_Length
> 0 then
445 Ada_Path_Length
:= Ada_Path_Length
+ 1;
446 Ada_Path_Buffer
(Ada_Path_Length
) := Path_Separator
;
450 (Ada_Path_Length
+ 1 .. Ada_Path_Length
+ Dir
'Length) := Dir
;
451 Ada_Path_Length
:= Ada_Path_Length
+ Dir
'Length;
454 ------------------------
455 -- Add_To_Source_Path --
456 ------------------------
458 procedure Add_To_Source_Path
(Source_Dirs
: String_List_Id
) is
459 Current
: String_List_Id
:= Source_Dirs
;
460 Source_Dir
: String_Element
;
464 -- Add each source directory
466 while Current
/= Nil_String
loop
467 Source_Dir
:= String_Elements
.Table
(Current
);
470 -- Check if the source directory is already in the table
472 for Index
in 1 .. Source_Paths
.Last
loop
473 -- If it is already, no need to add it
475 if Source_Paths
.Table
(Index
) = Source_Dir
.Value
then
482 Source_Paths
.Increment_Last
;
483 Source_Paths
.Table
(Source_Paths
.Last
) := Source_Dir
.Value
;
486 -- Next source directory
488 Current
:= Source_Dir
.Next
;
490 end Add_To_Source_Path
;
492 -----------------------
493 -- Body_Path_Name_Of --
494 -----------------------
496 function Body_Path_Name_Of
(Unit
: Unit_Id
) return String is
497 Data
: Unit_Data
:= Units
.Table
(Unit
);
500 -- If we don't know the path name of the body of this unit,
501 -- we compute it, and we store it.
503 if Data
.File_Names
(Body_Part
).Path
= No_Name
then
505 Current_Source
: String_List_Id
:=
506 Projects
.Table
(Data
.File_Names
(Body_Part
).Project
).Sources
;
507 Path
: GNAT
.OS_Lib
.String_Access
;
510 -- By default, put the file name
512 Data
.File_Names
(Body_Part
).Path
:=
513 Data
.File_Names
(Body_Part
).Name
;
515 -- For each source directory
517 while Current_Source
/= Nil_String
loop
520 (Namet
.Get_Name_String
521 (Data
.File_Names
(Body_Part
).Name
),
522 Namet
.Get_Name_String
523 (String_Elements
.Table
(Current_Source
).Value
));
525 -- If the file is in this directory,
526 -- then we store the path, and we are done.
529 Name_Len
:= Path
'Length;
530 Name_Buffer
(1 .. Name_Len
) := Path
.all;
531 Data
.File_Names
(Body_Part
).Path
:= Name_Enter
;
536 String_Elements
.Table
(Current_Source
).Next
;
540 Units
.Table
(Unit
) := Data
;
544 -- Returned the stored value
546 return Namet
.Get_Name_String
(Data
.File_Names
(Body_Part
).Path
);
547 end Body_Path_Name_Of
;
549 --------------------------------
550 -- Create_Config_Pragmas_File --
551 --------------------------------
553 procedure Create_Config_Pragmas_File
554 (For_Project
: Project_Id
;
555 Main_Project
: Project_Id
;
556 Include_Config_Files
: Boolean := True)
558 pragma Unreferenced
(Main_Project
);
559 pragma Unreferenced
(Include_Config_Files
);
561 File_Name
: Name_Id
:= No_Name
;
562 File
: File_Descriptor
:= Invalid_FD
;
564 Current_Unit
: Unit_Id
:= Units
.First
;
566 First_Project
: Project_List
:= Empty_Project_List
;
568 Current_Project
: Project_List
;
569 Current_Naming
: Naming_Id
;
574 procedure Check
(Project
: Project_Id
);
575 -- Recursive procedure that put in the config pragmas file any non
576 -- standard naming schemes, if it is not already in the file, then call
577 -- itself for any imported project.
579 procedure Check_Temp_File
;
580 -- Check that a temporary file has been opened.
581 -- If not, create one, and put its name in the project data,
582 -- with the indication that it is a temporary file.
585 (Unit_Name
: Name_Id
;
587 Unit_Kind
: Spec_Or_Body
;
589 -- Put an SFN pragma in the temporary file
591 procedure Put
(File
: File_Descriptor
; S
: String);
592 procedure Put_Line
(File
: File_Descriptor
; S
: String);
593 -- Output procedures, analogous to normal Text_IO procs of same name
599 procedure Check
(Project
: Project_Id
) is
600 Data
: constant Project_Data
:= Projects
.Table
(Project
);
603 if Current_Verbosity
= High
then
604 Write_Str
("Checking project file """);
605 Write_Str
(Namet
.Get_Name_String
(Data
.Name
));
610 -- Is this project in the list of the visited project?
612 Current_Project
:= First_Project
;
613 while Current_Project
/= Empty_Project_List
614 and then Project_Lists
.Table
(Current_Project
).Project
/= Project
616 Current_Project
:= Project_Lists
.Table
(Current_Project
).Next
;
619 -- If it is not, put it in the list, and visit it
621 if Current_Project
= Empty_Project_List
then
622 Project_Lists
.Increment_Last
;
623 Project_Lists
.Table
(Project_Lists
.Last
) :=
624 (Project
=> Project
, Next
=> First_Project
);
625 First_Project
:= Project_Lists
.Last
;
627 -- Is the naming scheme of this project one that we know?
629 Current_Naming
:= Default_Naming
;
630 while Current_Naming
<= Namings
.Last
and then
631 not Same_Naming_Scheme
632 (Left
=> Namings
.Table
(Current_Naming
),
633 Right
=> Data
.Naming
) loop
634 Current_Naming
:= Current_Naming
+ 1;
637 -- If we don't know it, add it
639 if Current_Naming
> Namings
.Last
then
640 Namings
.Increment_Last
;
641 Namings
.Table
(Namings
.Last
) := Data
.Naming
;
643 -- We need a temporary file to be created
647 -- Put the SFN pragmas for the naming scheme
652 (File
, "pragma Source_File_Name_Project");
654 (File
, " (Spec_File_Name => ""*" &
655 Namet
.Get_Name_String
(Data
.Naming
.Current_Spec_Suffix
) &
658 (File
, " Casing => " &
659 Image
(Data
.Naming
.Casing
) & ",");
661 (File
, " Dot_Replacement => """ &
662 Namet
.Get_Name_String
(Data
.Naming
.Dot_Replacement
) &
668 (File
, "pragma Source_File_Name_Project");
670 (File
, " (Body_File_Name => ""*" &
671 Namet
.Get_Name_String
(Data
.Naming
.Current_Body_Suffix
) &
674 (File
, " Casing => " &
675 Image
(Data
.Naming
.Casing
) & ",");
677 (File
, " Dot_Replacement => """ &
678 Namet
.Get_Name_String
(Data
.Naming
.Dot_Replacement
) &
681 -- and maybe separate
684 Data
.Naming
.Current_Body_Suffix
/= Data
.Naming
.Separate_Suffix
687 (File
, "pragma Source_File_Name_Project");
689 (File
, " (Subunit_File_Name => ""*" &
690 Namet
.Get_Name_String
(Data
.Naming
.Separate_Suffix
) &
693 (File
, " Casing => " &
694 Image
(Data
.Naming
.Casing
) &
697 (File
, " Dot_Replacement => """ &
698 Namet
.Get_Name_String
(Data
.Naming
.Dot_Replacement
) &
703 if Data
.Extends
/= No_Project
then
704 Check
(Data
.Extends
);
708 Current
: Project_List
:= Data
.Imported_Projects
;
711 while Current
/= Empty_Project_List
loop
712 Check
(Project_Lists
.Table
(Current
).Project
);
713 Current
:= Project_Lists
.Table
(Current
).Next
;
719 ---------------------
720 -- Check_Temp_File --
721 ---------------------
723 procedure Check_Temp_File
is
725 if File
= Invalid_FD
then
726 Tempdir
.Create_Temp_File
(File
, Name
=> File_Name
);
728 if File
= Invalid_FD
then
730 ("unable to create temporary configuration pragmas file");
731 elsif Opt
.Verbose_Mode
then
732 Write_Str
("Creating temp file """);
733 Write_Str
(Get_Name_String
(File_Name
));
744 (Unit_Name
: Name_Id
;
746 Unit_Kind
: Spec_Or_Body
;
750 -- A temporary file needs to be open
754 -- Put the pragma SFN for the unit kind (spec or body)
756 Put
(File
, "pragma Source_File_Name_Project (");
757 Put
(File
, Namet
.Get_Name_String
(Unit_Name
));
759 if Unit_Kind
= Specification
then
760 Put
(File
, ", Spec_File_Name => """);
762 Put
(File
, ", Body_File_Name => """);
765 Put
(File
, Namet
.Get_Name_String
(File_Name
));
769 Put
(File
, ", Index =>");
770 Put
(File
, Index
'Img);
773 Put_Line
(File
, ");");
776 procedure Put
(File
: File_Descriptor
; S
: String) is
780 Last
:= Write
(File
, S
(S
'First)'Address, S
'Length);
782 if Last
/= S
'Length then
783 Prj
.Com
.Fail
("Disk full");
786 if Current_Verbosity
= High
then
795 procedure Put_Line
(File
: File_Descriptor
; S
: String) is
796 S0
: String (1 .. S
'Length + 1);
800 -- Add an ASCII.LF to the string. As this config file is supposed to
801 -- be used only by the compiler, we don't care about the characters
802 -- for the end of line. In fact we could have put a space, but
803 -- it is more convenient to be able to read gnat.adc during
804 -- development, for which the ASCII.LF is fine.
806 S0
(1 .. S
'Length) := S
;
807 S0
(S0
'Last) := ASCII
.LF
;
808 Last
:= Write
(File
, S0
'Address, S0
'Length);
810 if Last
/= S
'Length + 1 then
811 Prj
.Com
.Fail
("Disk full");
814 if Current_Verbosity
= High
then
819 -- Start of processing for Create_Config_Pragmas_File
822 if not Projects
.Table
(For_Project
).Config_Checked
then
824 -- Remove any memory of processed naming schemes, if any
826 Namings
.Set_Last
(Default_Naming
);
828 -- Check the naming schemes
832 -- Visit all the units and process those that need an SFN pragma
834 while Current_Unit
<= Units
.Last
loop
836 Unit
: constant Unit_Data
:=
837 Units
.Table
(Current_Unit
);
840 if Unit
.File_Names
(Specification
).Needs_Pragma
then
842 Unit
.File_Names
(Specification
).Name
,
844 Unit
.File_Names
(Specification
).Index
);
847 if Unit
.File_Names
(Body_Part
).Needs_Pragma
then
849 Unit
.File_Names
(Body_Part
).Name
,
851 Unit
.File_Names
(Body_Part
).Index
);
854 Current_Unit
:= Current_Unit
+ 1;
858 -- If there are no non standard naming scheme, issue the GNAT
859 -- standard naming scheme. This will tell the compiler that
860 -- a project file is used and will forbid any pragma SFN.
862 if File
= Invalid_FD
then
865 Put_Line
(File
, "pragma Source_File_Name_Project");
866 Put_Line
(File
, " (Spec_File_Name => ""*.ads"",");
867 Put_Line
(File
, " Dot_Replacement => ""-"",");
868 Put_Line
(File
, " Casing => lowercase);");
870 Put_Line
(File
, "pragma Source_File_Name_Project");
871 Put_Line
(File
, " (Body_File_Name => ""*.adb"",");
872 Put_Line
(File
, " Dot_Replacement => ""-"",");
873 Put_Line
(File
, " Casing => lowercase);");
876 -- Close the temporary file
878 GNAT
.OS_Lib
.Close
(File
, Status
);
881 Prj
.Com
.Fail
("disk full");
884 if Opt
.Verbose_Mode
then
885 Write_Str
("Closing configuration file """);
886 Write_Str
(Get_Name_String
(File_Name
));
890 Projects
.Table
(For_Project
).Config_File_Name
:= File_Name
;
891 Projects
.Table
(For_Project
).Config_File_Temp
:= True;
893 Projects
.Table
(For_Project
).Config_Checked
:= True;
895 end Create_Config_Pragmas_File
;
897 -------------------------
898 -- Create_Mapping_File --
899 -------------------------
901 procedure Create_Mapping_File
902 (Project
: Project_Id
;
905 File
: File_Descriptor
:= Invalid_FD
;
906 The_Unit_Data
: Unit_Data
;
907 Data
: File_Name_Data
;
912 Present
: Project_Flags
(No_Project
.. Projects
.Last
) :=
914 -- For each project in the closure of Project, the corresponding flag
915 -- will be set to True;
917 procedure Put_Name_Buffer
;
918 -- Put the line contained in the Name_Buffer in the mapping file
920 procedure Put_Data
(Spec
: Boolean);
921 -- Put the mapping of the spec or body contained in Data in the file
924 procedure Recursive_Flag
(Prj
: Project_Id
);
925 -- Set the flags corresponding to Prj, the projects it imports
926 -- (directly or indirectly) or extends to True. Call itself recursively.
932 procedure Put_Name_Buffer
is
936 Name_Len
:= Name_Len
+ 1;
937 Name_Buffer
(Name_Len
) := ASCII
.LF
;
938 Last
:= Write
(File
, Name_Buffer
(1)'Address, Name_Len
);
940 if Last
/= Name_Len
then
941 Prj
.Com
.Fail
("Disk full");
949 procedure Put_Data
(Spec
: Boolean) is
951 -- Line with the unit name
953 Get_Name_String
(The_Unit_Data
.Name
);
954 Name_Len
:= Name_Len
+ 1;
955 Name_Buffer
(Name_Len
) := '%';
956 Name_Len
:= Name_Len
+ 1;
959 Name_Buffer
(Name_Len
) := 's';
961 Name_Buffer
(Name_Len
) := 'b';
966 -- Line with the file name
968 Get_Name_String
(Data
.Name
);
971 -- Line with the path name
973 Get_Name_String
(Data
.Path
);
982 procedure Recursive_Flag
(Prj
: Project_Id
) is
983 Imported
: Project_List
;
987 -- Nothing to do for non existent project or project that has
988 -- already been flagged.
990 if Prj
= No_Project
or else Present
(Prj
) then
994 -- Flag the current project
996 Present
(Prj
) := True;
997 Imported
:= Projects
.Table
(Prj
).Imported_Projects
;
999 -- Call itself for each project directly imported
1001 while Imported
/= Empty_Project_List
loop
1002 Proj
:= Project_Lists
.Table
(Imported
).Project
;
1003 Imported
:= Project_Lists
.Table
(Imported
).Next
;
1004 Recursive_Flag
(Proj
);
1007 -- Call itself for an eventual project being extended
1009 Recursive_Flag
(Projects
.Table
(Prj
).Extends
);
1012 -- Start of processing for Create_Mapping_File
1015 -- Flag the necessary projects
1017 Recursive_Flag
(Project
);
1019 -- Create the temporary file
1021 Tempdir
.Create_Temp_File
(File
, Name
=> Name
);
1023 if File
= Invalid_FD
then
1024 Prj
.Com
.Fail
("unable to create temporary mapping file");
1026 elsif Opt
.Verbose_Mode
then
1027 Write_Str
("Creating temp mapping file """);
1028 Write_Str
(Get_Name_String
(Name
));
1032 if Fill_Mapping_File
then
1033 -- For all units in table Units
1035 for Unit
in 1 .. Units
.Last
loop
1036 The_Unit_Data
:= Units
.Table
(Unit
);
1038 -- If the unit has a valid name
1040 if The_Unit_Data
.Name
/= No_Name
then
1041 Data
:= The_Unit_Data
.File_Names
(Specification
);
1043 -- If there is a spec, put it mapping in the file if it is
1044 -- from a project in the closure of Project.
1046 if Data
.Name
/= No_Name
and then Present
(Data
.Project
) then
1047 Put_Data
(Spec
=> True);
1050 Data
:= The_Unit_Data
.File_Names
(Body_Part
);
1052 -- If there is a body (or subunit) put its mapping in the file
1053 -- if it is from a project in the closure of Project.
1055 if Data
.Name
/= No_Name
and then Present
(Data
.Project
) then
1056 Put_Data
(Spec
=> False);
1063 GNAT
.OS_Lib
.Close
(File
, Status
);
1066 Prj
.Com
.Fail
("disk full");
1068 end Create_Mapping_File
;
1070 --------------------------
1071 -- Create_New_Path_File --
1072 --------------------------
1074 procedure Create_New_Path_File
1075 (Path_FD
: out File_Descriptor
;
1076 Path_Name
: out Name_Id
)
1079 Tempdir
.Create_Temp_File
(Path_FD
, Path_Name
);
1081 if Path_Name
/= No_Name
then
1083 -- Record the name, so that the temp path file will be deleted
1084 -- at the end of the program.
1086 Path_Files
.Increment_Last
;
1087 Path_Files
.Table
(Path_Files
.Last
) := Path_Name
;
1089 end Create_New_Path_File
;
1091 ---------------------------
1092 -- Delete_All_Path_Files --
1093 ---------------------------
1095 procedure Delete_All_Path_Files
is
1096 Disregard
: Boolean := True;
1099 for Index
in 1 .. Path_Files
.Last
loop
1100 if Path_Files
.Table
(Index
) /= No_Name
then
1102 (Get_Name_String
(Path_Files
.Table
(Index
)), Disregard
);
1106 -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or
1107 -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
1108 -- the empty string. On VMS, this has the effect of deassigning
1109 -- the logical names.
1111 if Ada_Prj_Include_File_Set
then
1112 Setenv
(Project_Include_Path_File
, "");
1113 Ada_Prj_Include_File_Set
:= False;
1116 if Ada_Prj_Objects_File_Set
then
1117 Setenv
(Project_Objects_Path_File
, "");
1118 Ada_Prj_Objects_File_Set
:= False;
1120 end Delete_All_Path_Files
;
1122 ------------------------------------
1123 -- File_Name_Of_Library_Unit_Body --
1124 ------------------------------------
1126 function File_Name_Of_Library_Unit_Body
1128 Project
: Project_Id
;
1129 Main_Project_Only
: Boolean := True;
1130 Full_Path
: Boolean := False) return String
1132 The_Project
: Project_Id
:= Project
;
1133 Data
: Project_Data
:= Projects
.Table
(Project
);
1134 Original_Name
: String := Name
;
1136 Extended_Spec_Name
: String :=
1137 Name
& Namet
.Get_Name_String
1138 (Data
.Naming
.Current_Spec_Suffix
);
1139 Extended_Body_Name
: String :=
1140 Name
& Namet
.Get_Name_String
1141 (Data
.Naming
.Current_Body_Suffix
);
1145 The_Original_Name
: Name_Id
;
1146 The_Spec_Name
: Name_Id
;
1147 The_Body_Name
: Name_Id
;
1150 Canonical_Case_File_Name
(Original_Name
);
1151 Name_Len
:= Original_Name
'Length;
1152 Name_Buffer
(1 .. Name_Len
) := Original_Name
;
1153 The_Original_Name
:= Name_Find
;
1155 Canonical_Case_File_Name
(Extended_Spec_Name
);
1156 Name_Len
:= Extended_Spec_Name
'Length;
1157 Name_Buffer
(1 .. Name_Len
) := Extended_Spec_Name
;
1158 The_Spec_Name
:= Name_Find
;
1160 Canonical_Case_File_Name
(Extended_Body_Name
);
1161 Name_Len
:= Extended_Body_Name
'Length;
1162 Name_Buffer
(1 .. Name_Len
) := Extended_Body_Name
;
1163 The_Body_Name
:= Name_Find
;
1165 if Current_Verbosity
= High
then
1166 Write_Str
("Looking for file name of """);
1170 Write_Str
(" Extended Spec Name = """);
1171 Write_Str
(Extended_Spec_Name
);
1174 Write_Str
(" Extended Body Name = """);
1175 Write_Str
(Extended_Body_Name
);
1180 -- For extending project, search in the extended project
1181 -- if the source is not found. For non extending projects,
1182 -- this loop will be run only once.
1185 -- Loop through units
1186 -- Should have comment explaining reverse ???
1188 for Current
in reverse Units
.First
.. Units
.Last
loop
1189 Unit
:= Units
.Table
(Current
);
1193 if not Main_Project_Only
1194 or else Unit
.File_Names
(Body_Part
).Project
= The_Project
1197 Current_Name
: constant Name_Id
:=
1198 Unit
.File_Names
(Body_Part
).Name
;
1201 -- Case of a body present
1203 if Current_Name
/= No_Name
then
1204 if Current_Verbosity
= High
then
1205 Write_Str
(" Comparing with """);
1206 Write_Str
(Get_Name_String
(Current_Name
));
1211 -- If it has the name of the original name,
1212 -- return the original name
1214 if Unit
.Name
= The_Original_Name
1215 or else Current_Name
= The_Original_Name
1217 if Current_Verbosity
= High
then
1222 return Get_Name_String
1223 (Unit
.File_Names
(Body_Part
).Path
);
1226 return Get_Name_String
(Current_Name
);
1229 -- If it has the name of the extended body name,
1230 -- return the extended body name
1232 elsif Current_Name
= The_Body_Name
then
1233 if Current_Verbosity
= High
then
1238 return Get_Name_String
1239 (Unit
.File_Names
(Body_Part
).Path
);
1242 return Extended_Body_Name
;
1246 if Current_Verbosity
= High
then
1247 Write_Line
(" not good");
1256 if not Main_Project_Only
1257 or else Unit
.File_Names
(Specification
).Project
= The_Project
1260 Current_Name
: constant Name_Id
:=
1261 Unit
.File_Names
(Specification
).Name
;
1264 -- Case of spec present
1266 if Current_Name
/= No_Name
then
1267 if Current_Verbosity
= High
then
1268 Write_Str
(" Comparing with """);
1269 Write_Str
(Get_Name_String
(Current_Name
));
1274 -- If name same as original name, return original name
1276 if Unit
.Name
= The_Original_Name
1277 or else Current_Name
= The_Original_Name
1279 if Current_Verbosity
= High
then
1284 return Get_Name_String
1285 (Unit
.File_Names
(Specification
).Path
);
1287 return Get_Name_String
(Current_Name
);
1290 -- If it has the same name as the extended spec name,
1291 -- return the extended spec name.
1293 elsif Current_Name
= The_Spec_Name
then
1294 if Current_Verbosity
= High
then
1299 return Get_Name_String
1300 (Unit
.File_Names
(Specification
).Path
);
1302 return Extended_Spec_Name
;
1306 if Current_Verbosity
= High
then
1307 Write_Line
(" not good");
1315 -- If we are not in an extending project, give up
1317 exit when (not Main_Project_Only
) or else Data
.Extends
= No_Project
;
1319 -- Otherwise, look in the project we are extending
1321 The_Project
:= Data
.Extends
;
1322 Data
:= Projects
.Table
(The_Project
);
1325 -- We don't know this file name, return an empty string
1328 end File_Name_Of_Library_Unit_Body
;
1330 -------------------------
1331 -- For_All_Object_Dirs --
1332 -------------------------
1334 procedure For_All_Object_Dirs
(Project
: Project_Id
) is
1335 Seen
: Project_List
:= Empty_Project_List
;
1337 procedure Add
(Project
: Project_Id
);
1338 -- Process a project. Remember the processes visited to avoid
1339 -- processing a project twice. Recursively process an eventual
1340 -- extended project, and all imported projects.
1346 procedure Add
(Project
: Project_Id
) is
1347 Data
: constant Project_Data
:= Projects
.Table
(Project
);
1348 List
: Project_List
:= Data
.Imported_Projects
;
1351 -- If the list of visited project is empty, then
1352 -- for sure we never visited this project.
1354 if Seen
= Empty_Project_List
then
1355 Project_Lists
.Increment_Last
;
1356 Seen
:= Project_Lists
.Last
;
1357 Project_Lists
.Table
(Seen
) :=
1358 (Project
=> Project
, Next
=> Empty_Project_List
);
1361 -- Check if the project is in the list
1364 Current
: Project_List
:= Seen
;
1368 -- If it is, then there is nothing else to do
1370 if Project_Lists
.Table
(Current
).Project
= Project
then
1374 exit when Project_Lists
.Table
(Current
).Next
=
1376 Current
:= Project_Lists
.Table
(Current
).Next
;
1379 -- This project has never been visited, add it
1382 Project_Lists
.Increment_Last
;
1383 Project_Lists
.Table
(Current
).Next
:= Project_Lists
.Last
;
1384 Project_Lists
.Table
(Project_Lists
.Last
) :=
1385 (Project
=> Project
, Next
=> Empty_Project_List
);
1389 -- If there is an object directory, call Action
1392 if Data
.Object_Directory
/= No_Name
then
1393 Get_Name_String
(Data
.Object_Directory
);
1394 Action
(Name_Buffer
(1 .. Name_Len
));
1397 -- If we are extending a project, visit it
1399 if Data
.Extends
/= No_Project
then
1403 -- And visit all imported projects
1405 while List
/= Empty_Project_List
loop
1406 Add
(Project_Lists
.Table
(List
).Project
);
1407 List
:= Project_Lists
.Table
(List
).Next
;
1411 -- Start of processing for For_All_Object_Dirs
1414 -- Visit this project, and its imported projects,
1418 end For_All_Object_Dirs
;
1420 -------------------------
1421 -- For_All_Source_Dirs --
1422 -------------------------
1424 procedure For_All_Source_Dirs
(Project
: Project_Id
) is
1425 Seen
: Project_List
:= Empty_Project_List
;
1427 procedure Add
(Project
: Project_Id
);
1428 -- Process a project. Remember the processes visited to avoid
1429 -- processing a project twice. Recursively process an eventual
1430 -- extended project, and all imported projects.
1436 procedure Add
(Project
: Project_Id
) is
1437 Data
: constant Project_Data
:= Projects
.Table
(Project
);
1438 List
: Project_List
:= Data
.Imported_Projects
;
1441 -- If the list of visited project is empty, then
1442 -- for sure we never visited this project.
1444 if Seen
= Empty_Project_List
then
1445 Project_Lists
.Increment_Last
;
1446 Seen
:= Project_Lists
.Last
;
1447 Project_Lists
.Table
(Seen
) :=
1448 (Project
=> Project
, Next
=> Empty_Project_List
);
1451 -- Check if the project is in the list
1454 Current
: Project_List
:= Seen
;
1458 -- If it is, then there is nothing else to do
1460 if Project_Lists
.Table
(Current
).Project
= Project
then
1464 exit when Project_Lists
.Table
(Current
).Next
=
1466 Current
:= Project_Lists
.Table
(Current
).Next
;
1469 -- This project has never been visited, add it
1472 Project_Lists
.Increment_Last
;
1473 Project_Lists
.Table
(Current
).Next
:= Project_Lists
.Last
;
1474 Project_Lists
.Table
(Project_Lists
.Last
) :=
1475 (Project
=> Project
, Next
=> Empty_Project_List
);
1480 Current
: String_List_Id
:= Data
.Source_Dirs
;
1481 The_String
: String_Element
;
1484 -- If there are Ada sources, call action with the name of every
1485 -- source directory.
1487 if Projects
.Table
(Project
).Ada_Sources_Present
then
1488 while Current
/= Nil_String
loop
1489 The_String
:= String_Elements
.Table
(Current
);
1490 Action
(Get_Name_String
(The_String
.Value
));
1491 Current
:= The_String
.Next
;
1496 -- If we are extending a project, visit it
1498 if Data
.Extends
/= No_Project
then
1502 -- And visit all imported projects
1504 while List
/= Empty_Project_List
loop
1505 Add
(Project_Lists
.Table
(List
).Project
);
1506 List
:= Project_Lists
.Table
(List
).Next
;
1510 -- Start of processing for For_All_Source_Dirs
1513 -- Visit this project, and its imported projects recursively
1516 end For_All_Source_Dirs
;
1522 procedure Get_Reference
1523 (Source_File_Name
: String;
1524 Project
: out Project_Id
;
1528 -- Body below could use some comments ???
1530 if Current_Verbosity
> Default
then
1531 Write_Str
("Getting Reference_Of (""");
1532 Write_Str
(Source_File_Name
);
1533 Write_Str
(""") ... ");
1537 Original_Name
: String := Source_File_Name
;
1541 Canonical_Case_File_Name
(Original_Name
);
1543 for Id
in Units
.First
.. Units
.Last
loop
1544 Unit
:= Units
.Table
(Id
);
1546 if (Unit
.File_Names
(Specification
).Name
/= No_Name
1548 Namet
.Get_Name_String
1549 (Unit
.File_Names
(Specification
).Name
) = Original_Name
)
1550 or else (Unit
.File_Names
(Specification
).Path
/= No_Name
1552 Namet
.Get_Name_String
1553 (Unit
.File_Names
(Specification
).Path
) =
1556 Project
:= Ultimate_Extension_Of
1557 (Unit
.File_Names
(Specification
).Project
);
1558 Path
:= Unit
.File_Names
(Specification
).Display_Path
;
1560 if Current_Verbosity
> Default
then
1561 Write_Str
("Done: Specification.");
1567 elsif (Unit
.File_Names
(Body_Part
).Name
/= No_Name
1569 Namet
.Get_Name_String
1570 (Unit
.File_Names
(Body_Part
).Name
) = Original_Name
)
1571 or else (Unit
.File_Names
(Body_Part
).Path
/= No_Name
1572 and then Namet
.Get_Name_String
1573 (Unit
.File_Names
(Body_Part
).Path
) =
1576 Project
:= Ultimate_Extension_Of
1577 (Unit
.File_Names
(Body_Part
).Project
);
1578 Path
:= Unit
.File_Names
(Body_Part
).Display_Path
;
1580 if Current_Verbosity
> Default
then
1581 Write_Str
("Done: Body.");
1590 Project
:= No_Project
;
1593 if Current_Verbosity
> Default
then
1594 Write_Str
("Cannot be found.");
1603 -- This is a place holder for possible required initialization in
1604 -- the future. In the current version no initialization is required.
1606 procedure Initialize
is
1611 ------------------------------------
1612 -- Path_Name_Of_Library_Unit_Body --
1613 ------------------------------------
1615 -- Could use some comments in the body here ???
1617 function Path_Name_Of_Library_Unit_Body
1619 Project
: Project_Id
) return String
1621 Data
: constant Project_Data
:= Projects
.Table
(Project
);
1622 Original_Name
: String := Name
;
1624 Extended_Spec_Name
: String :=
1625 Name
& Namet
.Get_Name_String
1626 (Data
.Naming
.Current_Spec_Suffix
);
1627 Extended_Body_Name
: String :=
1628 Name
& Namet
.Get_Name_String
1629 (Data
.Naming
.Current_Body_Suffix
);
1631 First
: Unit_Id
:= Units
.First
;
1636 Canonical_Case_File_Name
(Original_Name
);
1637 Canonical_Case_File_Name
(Extended_Spec_Name
);
1638 Canonical_Case_File_Name
(Extended_Body_Name
);
1640 if Current_Verbosity
= High
then
1641 Write_Str
("Looking for path name of """);
1645 Write_Str
(" Extended Spec Name = """);
1646 Write_Str
(Extended_Spec_Name
);
1649 Write_Str
(" Extended Body Name = """);
1650 Write_Str
(Extended_Body_Name
);
1655 while First
<= Units
.Last
1656 and then Units
.Table
(First
).File_Names
(Body_Part
).Project
/= Project
1662 while Current
<= Units
.Last
loop
1663 Unit
:= Units
.Table
(Current
);
1665 if Unit
.File_Names
(Body_Part
).Project
= Project
1666 and then Unit
.File_Names
(Body_Part
).Name
/= No_Name
1669 Current_Name
: constant String :=
1670 Namet
.Get_Name_String
(Unit
.File_Names
(Body_Part
).Name
);
1672 if Current_Verbosity
= High
then
1673 Write_Str
(" Comparing with """);
1674 Write_Str
(Current_Name
);
1679 if Current_Name
= Original_Name
then
1680 if Current_Verbosity
= High
then
1684 return Body_Path_Name_Of
(Current
);
1686 elsif Current_Name
= Extended_Body_Name
then
1687 if Current_Verbosity
= High
then
1691 return Body_Path_Name_Of
(Current
);
1694 if Current_Verbosity
= High
then
1695 Write_Line
(" not good");
1700 elsif Unit
.File_Names
(Specification
).Name
/= No_Name
then
1702 Current_Name
: constant String :=
1703 Namet
.Get_Name_String
1704 (Unit
.File_Names
(Specification
).Name
);
1707 if Current_Verbosity
= High
then
1708 Write_Str
(" Comparing with """);
1709 Write_Str
(Current_Name
);
1714 if Current_Name
= Original_Name
then
1715 if Current_Verbosity
= High
then
1719 return Spec_Path_Name_Of
(Current
);
1721 elsif Current_Name
= Extended_Spec_Name
then
1722 if Current_Verbosity
= High
then
1726 return Spec_Path_Name_Of
(Current
);
1729 if Current_Verbosity
= High
then
1730 Write_Line
(" not good");
1735 Current
:= Current
+ 1;
1739 end Path_Name_Of_Library_Unit_Body
;
1745 -- Could use some comments in this body ???
1747 procedure Print_Sources
is
1751 Write_Line
("List of Sources:");
1753 for Id
in Units
.First
.. Units
.Last
loop
1754 Unit
:= Units
.Table
(Id
);
1756 Write_Line
(Namet
.Get_Name_String
(Unit
.Name
));
1758 if Unit
.File_Names
(Specification
).Name
/= No_Name
then
1759 if Unit
.File_Names
(Specification
).Project
= No_Project
then
1760 Write_Line
(" No project");
1763 Write_Str
(" Project: ");
1766 (Unit
.File_Names
(Specification
).Project
).Path_Name
);
1767 Write_Line
(Name_Buffer
(1 .. Name_Len
));
1770 Write_Str
(" spec: ");
1772 (Namet
.Get_Name_String
1773 (Unit
.File_Names
(Specification
).Name
));
1776 if Unit
.File_Names
(Body_Part
).Name
/= No_Name
then
1777 if Unit
.File_Names
(Body_Part
).Project
= No_Project
then
1778 Write_Line
(" No project");
1781 Write_Str
(" Project: ");
1784 (Unit
.File_Names
(Body_Part
).Project
).Path_Name
);
1785 Write_Line
(Name_Buffer
(1 .. Name_Len
));
1788 Write_Str
(" body: ");
1790 (Namet
.Get_Name_String
1791 (Unit
.File_Names
(Body_Part
).Name
));
1795 Write_Line
("end of List of Sources.");
1804 Main_Project
: Project_Id
) return Project_Id
1806 Result
: Project_Id
:= No_Project
;
1808 Original_Name
: String := Name
;
1810 Data
: constant Project_Data
:= Projects
.Table
(Main_Project
);
1812 Extended_Spec_Name
: String :=
1813 Name
& Namet
.Get_Name_String
1814 (Data
.Naming
.Current_Spec_Suffix
);
1815 Extended_Body_Name
: String :=
1816 Name
& Namet
.Get_Name_String
1817 (Data
.Naming
.Current_Body_Suffix
);
1821 Current_Name
: Name_Id
;
1823 The_Original_Name
: Name_Id
;
1824 The_Spec_Name
: Name_Id
;
1825 The_Body_Name
: Name_Id
;
1828 Canonical_Case_File_Name
(Original_Name
);
1829 Name_Len
:= Original_Name
'Length;
1830 Name_Buffer
(1 .. Name_Len
) := Original_Name
;
1831 The_Original_Name
:= Name_Find
;
1833 Canonical_Case_File_Name
(Extended_Spec_Name
);
1834 Name_Len
:= Extended_Spec_Name
'Length;
1835 Name_Buffer
(1 .. Name_Len
) := Extended_Spec_Name
;
1836 The_Spec_Name
:= Name_Find
;
1838 Canonical_Case_File_Name
(Extended_Body_Name
);
1839 Name_Len
:= Extended_Body_Name
'Length;
1840 Name_Buffer
(1 .. Name_Len
) := Extended_Body_Name
;
1841 The_Body_Name
:= Name_Find
;
1843 for Current
in reverse Units
.First
.. Units
.Last
loop
1844 Unit
:= Units
.Table
(Current
);
1848 Current_Name
:= Unit
.File_Names
(Body_Part
).Name
;
1850 -- Case of a body present
1852 if Current_Name
/= No_Name
then
1854 -- If it has the name of the original name or the body name,
1855 -- we have found the project.
1857 if Unit
.Name
= The_Original_Name
1858 or else Current_Name
= The_Original_Name
1859 or else Current_Name
= The_Body_Name
1861 Result
:= Unit
.File_Names
(Body_Part
).Project
;
1868 Current_Name
:= Unit
.File_Names
(Specification
).Name
;
1870 if Current_Name
/= No_Name
then
1872 -- If name same as the original name, or the spec name, we have
1873 -- found the project.
1875 if Unit
.Name
= The_Original_Name
1876 or else Current_Name
= The_Original_Name
1877 or else Current_Name
= The_Spec_Name
1879 Result
:= Unit
.File_Names
(Specification
).Project
;
1885 -- Get the ultimate extending project
1887 if Result
/= No_Project
then
1888 while Projects
.Table
(Result
).Extended_By
/= No_Project
loop
1889 Result
:= Projects
.Table
(Result
).Extended_By
;
1900 procedure Set_Ada_Paths
1901 (Project
: Project_Id
;
1902 Including_Libraries
: Boolean)
1904 Source_FD
: File_Descriptor
:= Invalid_FD
;
1905 Object_FD
: File_Descriptor
:= Invalid_FD
;
1907 Process_Source_Dirs
: Boolean := False;
1908 Process_Object_Dirs
: Boolean := False;
1911 -- For calls to Close
1915 procedure Add
(Proj
: Project_Id
);
1916 -- Add all the source/object directories of a project to the path only
1917 -- if this project has not been visited. Calls an internal procedure
1918 -- recursively for projects being extended, and imported projects.
1924 procedure Add
(Proj
: Project_Id
) is
1926 procedure Recursive_Add
(Project
: Project_Id
);
1927 -- Recursive procedure to add the source/object paths of extended/
1928 -- imported projects.
1934 procedure Recursive_Add
(Project
: Project_Id
) is
1936 -- If Seen is False, then the project has not yet been visited
1938 if not Projects
.Table
(Project
).Seen
then
1939 Projects
.Table
(Project
).Seen
:= True;
1942 Data
: constant Project_Data
:= Projects
.Table
(Project
);
1943 List
: Project_List
:= Data
.Imported_Projects
;
1946 if Process_Source_Dirs
then
1948 -- Add to path all source directories of this project
1949 -- if there are Ada sources.
1951 if Projects
.Table
(Project
).Ada_Sources_Present
then
1952 Add_To_Source_Path
(Data
.Source_Dirs
);
1956 if Process_Object_Dirs
then
1958 -- Add to path the object directory of this project
1959 -- except if we don't include library project and
1960 -- this is a library project.
1962 if (Data
.Library
and then Including_Libraries
)
1964 (Data
.Object_Directory
/= No_Name
1966 (not Including_Libraries
or else not Data
.Library
))
1968 -- For a library project, add the library directory
1970 if Data
.Library
then
1971 Add_To_Object_Path
(Data
.Library_Dir
);
1974 -- For a non library project, add the object
1977 Add_To_Object_Path
(Data
.Object_Directory
);
1982 -- Call Add to the project being extended, if any
1984 if Data
.Extends
/= No_Project
then
1985 Recursive_Add
(Data
.Extends
);
1988 -- Call Add for each imported project, if any
1990 while List
/= Empty_Project_List
loop
1991 Recursive_Add
(Project_Lists
.Table
(List
).Project
);
1992 List
:= Project_Lists
.Table
(List
).Next
;
1999 Source_Paths
.Set_Last
(0);
2000 Object_Paths
.Set_Last
(0);
2002 for Index
in 1 .. Projects
.Last
loop
2003 Projects
.Table
(Index
).Seen
:= False;
2006 Recursive_Add
(Proj
);
2009 -- Start of processing for Set_Ada_Paths
2012 -- If it is the first time we call this procedure for
2013 -- this project, compute the source path and/or the object path.
2015 if Projects
.Table
(Project
).Include_Path_File
= No_Name
then
2016 Process_Source_Dirs
:= True;
2017 Create_New_Path_File
2018 (Source_FD
, Projects
.Table
(Project
).Include_Path_File
);
2021 -- For the object path, we make a distinction depending on
2022 -- Including_Libraries.
2024 if Including_Libraries
then
2025 if Projects
.Table
(Project
).Objects_Path_File_With_Libs
= No_Name
then
2026 Process_Object_Dirs
:= True;
2027 Create_New_Path_File
2028 (Object_FD
, Projects
.Table
(Project
).
2029 Objects_Path_File_With_Libs
);
2034 Projects
.Table
(Project
).Objects_Path_File_Without_Libs
= No_Name
2036 Process_Object_Dirs
:= True;
2037 Create_New_Path_File
2038 (Object_FD
, Projects
.Table
(Project
).
2039 Objects_Path_File_Without_Libs
);
2043 -- If there is something to do, set Seen to False for all projects,
2044 -- then call the recursive procedure Add for Project.
2046 if Process_Source_Dirs
or Process_Object_Dirs
then
2050 -- Write and close any file that has been created.
2052 if Source_FD
/= Invalid_FD
then
2053 for Index
in 1 .. Source_Paths
.Last
loop
2054 Get_Name_String
(Source_Paths
.Table
(Index
));
2055 Name_Len
:= Name_Len
+ 1;
2056 Name_Buffer
(Name_Len
) := ASCII
.LF
;
2057 Len
:= Write
(Source_FD
, Name_Buffer
(1)'Address, Name_Len
);
2059 if Len
/= Name_Len
then
2060 Prj
.Com
.Fail
("disk full");
2064 Close
(Source_FD
, Status
);
2067 Prj
.Com
.Fail
("disk full");
2071 if Object_FD
/= Invalid_FD
then
2072 for Index
in 1 .. Object_Paths
.Last
loop
2073 Get_Name_String
(Object_Paths
.Table
(Index
));
2074 Name_Len
:= Name_Len
+ 1;
2075 Name_Buffer
(Name_Len
) := ASCII
.LF
;
2076 Len
:= Write
(Object_FD
, Name_Buffer
(1)'Address, Name_Len
);
2078 if Len
/= Name_Len
then
2079 Prj
.Com
.Fail
("disk full");
2083 Close
(Object_FD
, Status
);
2086 Prj
.Com
.Fail
("disk full");
2090 -- Set the env vars, if they need to be changed, and set the
2091 -- corresponding flags.
2093 if Current_Source_Path_File
/=
2094 Projects
.Table
(Project
).Include_Path_File
2096 Current_Source_Path_File
:=
2097 Projects
.Table
(Project
).Include_Path_File
;
2099 (Project_Include_Path_File
,
2100 Get_Name_String
(Current_Source_Path_File
));
2101 Ada_Prj_Include_File_Set
:= True;
2104 if Including_Libraries
then
2105 if Current_Object_Path_File
2106 /= Projects
.Table
(Project
).Objects_Path_File_With_Libs
2108 Current_Object_Path_File
:=
2109 Projects
.Table
(Project
).Objects_Path_File_With_Libs
;
2111 (Project_Objects_Path_File
,
2112 Get_Name_String
(Current_Object_Path_File
));
2113 Ada_Prj_Objects_File_Set
:= True;
2117 if Current_Object_Path_File
2118 /= Projects
.Table
(Project
).Objects_Path_File_Without_Libs
2120 Current_Object_Path_File
:=
2121 Projects
.Table
(Project
).Objects_Path_File_Without_Libs
;
2123 (Project_Objects_Path_File
,
2124 Get_Name_String
(Current_Object_Path_File
));
2125 Ada_Prj_Objects_File_Set
:= True;
2130 ---------------------------------------------
2131 -- Set_Mapping_File_Initial_State_To_Empty --
2132 ---------------------------------------------
2134 procedure Set_Mapping_File_Initial_State_To_Empty
is
2136 Fill_Mapping_File
:= False;
2137 end Set_Mapping_File_Initial_State_To_Empty
;
2139 -----------------------
2140 -- Set_Path_File_Var --
2141 -----------------------
2143 procedure Set_Path_File_Var
(Name
: String; Value
: String) is
2144 Host_Spec
: String_Access
:= To_Host_File_Spec
(Value
);
2147 if Host_Spec
= null then
2149 ("could not convert file name """, Value
, """ to host spec");
2151 Setenv
(Name
, Host_Spec
.all);
2154 end Set_Path_File_Var
;
2156 -----------------------
2157 -- Spec_Path_Name_Of --
2158 -----------------------
2160 function Spec_Path_Name_Of
(Unit
: Unit_Id
) return String is
2161 Data
: Unit_Data
:= Units
.Table
(Unit
);
2164 if Data
.File_Names
(Specification
).Path
= No_Name
then
2166 Current_Source
: String_List_Id
:=
2167 Projects
.Table
(Data
.File_Names
(Specification
).Project
).Sources
;
2168 Path
: GNAT
.OS_Lib
.String_Access
;
2171 Data
.File_Names
(Specification
).Path
:=
2172 Data
.File_Names
(Specification
).Name
;
2174 while Current_Source
/= Nil_String
loop
2175 Path
:= Locate_Regular_File
2176 (Namet
.Get_Name_String
2177 (Data
.File_Names
(Specification
).Name
),
2178 Namet
.Get_Name_String
2179 (String_Elements
.Table
(Current_Source
).Value
));
2181 if Path
/= null then
2182 Name_Len
:= Path
'Length;
2183 Name_Buffer
(1 .. Name_Len
) := Path
.all;
2184 Data
.File_Names
(Specification
).Path
:= Name_Enter
;
2188 String_Elements
.Table
(Current_Source
).Next
;
2192 Units
.Table
(Unit
) := Data
;
2196 return Namet
.Get_Name_String
(Data
.File_Names
(Specification
).Path
);
2197 end Spec_Path_Name_Of
;
2199 ---------------------------
2200 -- Ultimate_Extension_Of --
2201 ---------------------------
2203 function Ultimate_Extension_Of
(Project
: in Project_Id
) return Project_Id
2205 Result
: Project_Id
:= Project
;
2208 while Projects
.Table
(Result
).Extended_By
/= No_Project
loop
2209 Result
:= Projects
.Table
(Result
).Extended_By
;
2213 end Ultimate_Extension_Of
;
2215 -- Package initialization
2216 -- What is relationshiop to procedure Initialize
2219 Path_Files
.Set_Last
(0);