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
.Directory_Operations
; use GNAT
.Directory_Operations
;
36 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
38 package body Prj
.Env
is
40 type Naming_Id
is new Nat
;
42 Current_Source_Path_File
: Name_Id
:= No_Name
;
43 -- Current value of project source path file env var.
44 -- Used to avoid setting the env var to the same value.
46 Current_Object_Path_File
: Name_Id
:= No_Name
;
47 -- Current value of project object path file env var.
48 -- Used to avoid setting the env var to the same value.
50 Ada_Path_Buffer
: String_Access
:= new String (1 .. 1024);
51 -- A buffer where values for ADA_INCLUDE_PATH
52 -- and ADA_OBJECTS_PATH are stored.
54 Ada_Path_Length
: Natural := 0;
55 -- Index of the last valid character in Ada_Path_Buffer.
57 Ada_Prj_Include_File_Set
: Boolean := False;
58 Ada_Prj_Objects_File_Set
: Boolean := False;
59 -- These flags are set to True when the corresponding environment variables
60 -- are set and are used to give these environment variables an empty string
61 -- value at the end of the program. This has no practical effect on most
62 -- platforms, except on VMS where the logical names are deassigned, thus
63 -- avoiding the pollution of the environment of the caller.
65 package Namings
is new Table
.Table
66 (Table_Component_Type
=> Naming_Data
,
67 Table_Index_Type
=> Naming_Id
,
70 Table_Increment
=> 100,
71 Table_Name
=> "Prj.Env.Namings");
73 Default_Naming
: constant Naming_Id
:= Namings
.First
;
75 Fill_Mapping_File
: Boolean := True;
77 package Path_Files
is new Table
.Table
78 (Table_Component_Type
=> Name_Id
,
79 Table_Index_Type
=> Natural,
82 Table_Increment
=> 50,
83 Table_Name
=> "Prj.Env.Path_Files");
84 -- Table storing all the temp path file names.
85 -- Used by Delete_All_Path_Files.
87 type Project_Flags
is array (Project_Id
range <>) of Boolean;
88 -- A Boolean array type used in Create_Mapping_File to select the projects
89 -- in the closure of a specific project.
91 package Source_Paths
is new Table
.Table
92 (Table_Component_Type
=> Name_Id
,
93 Table_Index_Type
=> Natural,
96 Table_Increment
=> 50,
97 Table_Name
=> "Prj.Env.Source_Paths");
98 -- A table to store the source dirs before creating the source path file
100 package Object_Paths
is new Table
.Table
101 (Table_Component_Type
=> Name_Id
,
102 Table_Index_Type
=> Natural,
103 Table_Low_Bound
=> 1,
105 Table_Increment
=> 50,
106 Table_Name
=> "Prj.Env.Source_Paths");
107 -- A table to store the object dirs, before creating the object path file
109 -----------------------
110 -- Local Subprograms --
111 -----------------------
113 function Body_Path_Name_Of
(Unit
: Unit_Id
) return String;
114 -- Returns the path name of the body of a unit.
115 -- Compute it first, if necessary.
117 function Spec_Path_Name_Of
(Unit
: Unit_Id
) return String;
118 -- Returns the path name of the spec of a unit.
119 -- Compute it first, if necessary.
121 procedure Add_To_Path
(Source_Dirs
: String_List_Id
);
122 -- Add to Ada_Path_Buffer all the source directories in string list
123 -- Source_Dirs, if any. Increment Ada_Path_Length.
125 procedure Add_To_Path
(Dir
: String);
126 -- If Dir is not already in the global variable Ada_Path_Buffer, add it.
127 -- Increment Ada_Path_Length.
128 -- If Ada_Path_Length /= 0, prepend a Path_Separator character to
131 procedure Add_To_Source_Path
(Source_Dirs
: String_List_Id
);
132 -- Add to Ada_Path_B all the source directories in string list
133 -- Source_Dirs, if any. Increment Ada_Path_Length.
135 procedure Add_To_Object_Path
(Object_Dir
: Name_Id
);
136 -- Add Object_Dir to object path table. Make sure it is not duplicate
137 -- and it is the last one in the current table.
139 function Contains_ALI_Files
(Dir
: Name_Id
) return Boolean;
140 -- Return True if there is at least one ALI file in the directory Dir
142 procedure Create_New_Path_File
143 (Path_FD
: out File_Descriptor
;
144 Path_Name
: out Name_Id
);
145 -- Create a new temporary path file. Get the file name in Path_Name.
146 -- The name is normally obtained by increasing the number in
147 -- Temp_Path_File_Name by 1.
149 procedure Set_Path_File_Var
(Name
: String; Value
: String);
150 -- Call Setenv, after calling To_Host_File_Spec
152 function Ultimate_Extension_Of
(Project
: in Project_Id
) return Project_Id
;
153 -- Return a project that is either Project or an extended ancestor of
154 -- Project that itself is not extended.
156 ----------------------
157 -- Ada_Include_Path --
158 ----------------------
160 function Ada_Include_Path
(Project
: Project_Id
) return String_Access
is
162 procedure Add
(Project
: Project_Id
);
163 -- Add all the source directories of a project to the path only if
164 -- this project has not been visited. Calls itself recursively for
165 -- projects being extended, and imported projects. Adds the project
166 -- to the list Seen if this is the call to Add for this project.
172 procedure Add
(Project
: Project_Id
) is
174 -- If Seen is empty, then the project cannot have been visited
176 if not Projects
.Table
(Project
).Seen
then
177 Projects
.Table
(Project
).Seen
:= True;
180 Data
: constant Project_Data
:= Projects
.Table
(Project
);
181 List
: Project_List
:= Data
.Imported_Projects
;
184 -- Add to path all source directories of this project
186 Add_To_Path
(Data
.Source_Dirs
);
188 -- Call Add to the project being extended, if any
190 if Data
.Extends
/= No_Project
then
194 -- Call Add for each imported project, if any
196 while List
/= Empty_Project_List
loop
197 Add
(Project_Lists
.Table
(List
).Project
);
198 List
:= Project_Lists
.Table
(List
).Next
;
204 -- Start of processing for Ada_Include_Path
207 -- If it is the first time we call this function for
208 -- this project, compute the source path
210 if Projects
.Table
(Project
).Ada_Include_Path
= null then
211 Ada_Path_Length
:= 0;
213 for Index
in 1 .. Projects
.Last
loop
214 Projects
.Table
(Index
).Seen
:= False;
218 Projects
.Table
(Project
).Ada_Include_Path
:=
219 new String'(Ada_Path_Buffer (1 .. Ada_Path_Length));
222 return Projects.Table (Project).Ada_Include_Path;
223 end Ada_Include_Path;
225 ----------------------
226 -- Ada_Include_Path --
227 ----------------------
229 function Ada_Include_Path
230 (Project : Project_Id;
231 Recursive : Boolean) return String
235 return Ada_Include_Path (Project).all;
237 Ada_Path_Length := 0;
238 Add_To_Path (Projects.Table (Project).Source_Dirs);
239 return Ada_Path_Buffer (1 .. Ada_Path_Length);
241 end Ada_Include_Path;
243 ----------------------
244 -- Ada_Objects_Path --
245 ----------------------
247 function Ada_Objects_Path
248 (Project : Project_Id;
249 Including_Libraries : Boolean := True) return String_Access
251 procedure Add (Project : Project_Id);
252 -- Add all the object directories of a project to the path only if
253 -- this project has not been visited. Calls itself recursively for
254 -- projects being extended, and imported projects. Adds the project
255 -- to the list Seen if this is the first call to Add for this project.
261 procedure Add (Project : Project_Id) is
263 -- If this project has not been seen yet
265 if not Projects.Table (Project).Seen then
266 Projects.Table (Project).Seen := True;
269 Data : constant Project_Data := Projects.Table (Project);
270 List : Project_List := Data.Imported_Projects;
273 -- Add to path the object directory of this project
274 -- except if we don't include library project and
275 -- this is a library project.
277 if (Data.Library and then Including_Libraries)
279 (Data.Object_Directory /= No_Name
281 (not Including_Libraries or else not Data.Library))
283 -- For a library project, add the library directory,
284 -- if there is no object directory or if it contains ALI
285 -- files; otherwise add the object directory.
288 if Data.Object_Directory = No_Name
289 or else Contains_ALI_Files (Data.Library_Dir)
291 Add_To_Path (Get_Name_String (Data.Library_Dir));
293 Add_To_Path (Get_Name_String (Data.Object_Directory));
297 -- For a non library project, add the object directory
299 Add_To_Path (Get_Name_String (Data.Object_Directory));
303 -- Call Add to the project being extended, if any
305 if Data.Extends /= No_Project then
309 -- Call Add for each imported project, if any
311 while List /= Empty_Project_List loop
312 Add (Project_Lists.Table (List).Project);
313 List := Project_Lists.Table (List).Next;
320 -- Start of processing for Ada_Objects_Path
323 -- If it is the first time we call this function for
324 -- this project, compute the objects path
326 if Projects.Table (Project).Ada_Objects_Path = null then
327 Ada_Path_Length := 0;
329 for Index in 1 .. Projects.Last loop
330 Projects.Table (Index).Seen := False;
334 Projects.Table (Project).Ada_Objects_Path :=
335 new String'(Ada_Path_Buffer
(1 .. Ada_Path_Length
));
338 return Projects
.Table
(Project
).Ada_Objects_Path
;
339 end Ada_Objects_Path
;
341 ------------------------
342 -- Add_To_Object_Path --
343 ------------------------
345 procedure Add_To_Object_Path
(Object_Dir
: Name_Id
) is
347 -- Check if the directory is already in the table
349 for Index
in 1 .. Object_Paths
.Last
loop
351 -- If it is, remove it, and add it as the last one
353 if Object_Paths
.Table
(Index
) = Object_Dir
then
354 for Index2
in Index
+ 1 .. Object_Paths
.Last
loop
355 Object_Paths
.Table
(Index2
- 1) :=
356 Object_Paths
.Table
(Index2
);
359 Object_Paths
.Table
(Object_Paths
.Last
) := Object_Dir
;
364 -- The directory is not already in the table, add it
366 Object_Paths
.Increment_Last
;
367 Object_Paths
.Table
(Object_Paths
.Last
) := Object_Dir
;
368 end Add_To_Object_Path
;
374 procedure Add_To_Path
(Source_Dirs
: String_List_Id
) is
375 Current
: String_List_Id
:= Source_Dirs
;
376 Source_Dir
: String_Element
;
378 while Current
/= Nil_String
loop
379 Source_Dir
:= String_Elements
.Table
(Current
);
380 Add_To_Path
(Get_Name_String
(Source_Dir
.Display_Value
));
381 Current
:= Source_Dir
.Next
;
385 procedure Add_To_Path
(Dir
: String) is
387 New_Buffer
: String_Access
;
390 function Is_Present
(Path
: String; Dir
: String) return Boolean;
391 -- Return True if Dir is part of Path
397 function Is_Present
(Path
: String; Dir
: String) return Boolean is
398 Last
: constant Integer := Path
'Last - Dir
'Length + 1;
401 for J
in Path
'First .. Last
loop
403 -- Note: the order of the conditions below is important, since
404 -- it ensures a minimal number of string comparisons.
407 or else Path
(J
- 1) = Path_Separator
)
409 (J
+ Dir
'Length > Path
'Last
410 or else Path
(J
+ Dir
'Length) = Path_Separator
)
411 and then Dir
= Path
(J
.. J
+ Dir
'Length - 1)
420 -- Start of processing for Add_To_Path
423 if Is_Present
(Ada_Path_Buffer
(1 .. Ada_Path_Length
), Dir
) then
425 -- Dir is already in the path, nothing to do
430 Min_Len
:= Ada_Path_Length
+ Dir
'Length;
432 if Ada_Path_Length
> 0 then
434 -- Add 1 for the Path_Separator character
436 Min_Len
:= Min_Len
+ 1;
439 -- If Ada_Path_Buffer is too small, increase it
441 Len
:= Ada_Path_Buffer
'Last;
443 if Len
< Min_Len
then
446 exit when Len
>= Min_Len
;
449 New_Buffer
:= new String (1 .. Len
);
450 New_Buffer
(1 .. Ada_Path_Length
) :=
451 Ada_Path_Buffer
(1 .. Ada_Path_Length
);
452 Free
(Ada_Path_Buffer
);
453 Ada_Path_Buffer
:= New_Buffer
;
456 if Ada_Path_Length
> 0 then
457 Ada_Path_Length
:= Ada_Path_Length
+ 1;
458 Ada_Path_Buffer
(Ada_Path_Length
) := Path_Separator
;
462 (Ada_Path_Length
+ 1 .. Ada_Path_Length
+ Dir
'Length) := Dir
;
463 Ada_Path_Length
:= Ada_Path_Length
+ Dir
'Length;
466 ------------------------
467 -- Add_To_Source_Path --
468 ------------------------
470 procedure Add_To_Source_Path
(Source_Dirs
: String_List_Id
) is
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
:= String_Elements
.Table
(Current
);
482 -- Check if the source directory is already in the table
484 for Index
in 1 .. Source_Paths
.Last
loop
485 -- If it is already, no need to add it
487 if Source_Paths
.Table
(Index
) = Source_Dir
.Value
then
494 Source_Paths
.Increment_Last
;
495 Source_Paths
.Table
(Source_Paths
.Last
) := Source_Dir
.Value
;
498 -- Next source directory
500 Current
:= Source_Dir
.Next
;
502 end Add_To_Source_Path
;
504 -----------------------
505 -- Body_Path_Name_Of --
506 -----------------------
508 function Body_Path_Name_Of
(Unit
: Unit_Id
) return String is
509 Data
: Unit_Data
:= Units
.Table
(Unit
);
512 -- If we don't know the path name of the body of this unit,
513 -- we compute it, and we store it.
515 if Data
.File_Names
(Body_Part
).Path
= No_Name
then
517 Current_Source
: String_List_Id
:=
518 Projects
.Table
(Data
.File_Names
(Body_Part
).Project
).Sources
;
519 Path
: GNAT
.OS_Lib
.String_Access
;
522 -- By default, put the file name
524 Data
.File_Names
(Body_Part
).Path
:=
525 Data
.File_Names
(Body_Part
).Name
;
527 -- For each source directory
529 while Current_Source
/= Nil_String
loop
532 (Namet
.Get_Name_String
533 (Data
.File_Names
(Body_Part
).Name
),
534 Namet
.Get_Name_String
535 (String_Elements
.Table
(Current_Source
).Value
));
537 -- If the file is in this directory,
538 -- then we store the path, and we are done.
541 Name_Len
:= Path
'Length;
542 Name_Buffer
(1 .. Name_Len
) := Path
.all;
543 Data
.File_Names
(Body_Part
).Path
:= Name_Enter
;
548 String_Elements
.Table
(Current_Source
).Next
;
552 Units
.Table
(Unit
) := Data
;
556 -- Returned the stored value
558 return Namet
.Get_Name_String
(Data
.File_Names
(Body_Part
).Path
);
559 end Body_Path_Name_Of
;
561 ------------------------
562 -- Contains_ALI_Files --
563 ------------------------
565 function Contains_ALI_Files
(Dir
: Name_Id
) return Boolean is
566 Dir_Name
: constant String := Get_Name_String
(Dir
);
568 Name
: String (1 .. 1_000
);
570 Result
: Boolean := False;
573 Open
(Direct
, Dir_Name
);
575 -- For each file in the directory, check if it is an ALI file
578 Read
(Direct
, Name
, Last
);
580 Canonical_Case_File_Name
(Name
(1 .. Last
));
581 Result
:= Last
>= 5 and then Name
(Last
- 3 .. Last
) = ".ali";
589 -- If there is any problem, close the directory if open and return
590 -- True; the library directory will be added to the path.
593 if Is_Open
(Direct
) then
598 end Contains_ALI_Files
;
600 --------------------------------
601 -- Create_Config_Pragmas_File --
602 --------------------------------
604 procedure Create_Config_Pragmas_File
605 (For_Project
: Project_Id
;
606 Main_Project
: Project_Id
;
607 Include_Config_Files
: Boolean := True)
609 pragma Unreferenced
(Main_Project
);
610 pragma Unreferenced
(Include_Config_Files
);
612 File_Name
: Name_Id
:= No_Name
;
613 File
: File_Descriptor
:= Invalid_FD
;
615 Current_Unit
: Unit_Id
:= Units
.First
;
617 First_Project
: Project_List
:= Empty_Project_List
;
619 Current_Project
: Project_List
;
620 Current_Naming
: Naming_Id
;
625 procedure Check
(Project
: Project_Id
);
626 -- Recursive procedure that put in the config pragmas file any non
627 -- standard naming schemes, if it is not already in the file, then call
628 -- itself for any imported project.
630 procedure Check_Temp_File
;
631 -- Check that a temporary file has been opened.
632 -- If not, create one, and put its name in the project data,
633 -- with the indication that it is a temporary file.
636 (Unit_Name
: Name_Id
;
638 Unit_Kind
: Spec_Or_Body
;
640 -- Put an SFN pragma in the temporary file
642 procedure Put
(File
: File_Descriptor
; S
: String);
643 procedure Put_Line
(File
: File_Descriptor
; S
: String);
644 -- Output procedures, analogous to normal Text_IO procs of same name
650 procedure Check
(Project
: Project_Id
) is
651 Data
: constant Project_Data
:= Projects
.Table
(Project
);
654 if Current_Verbosity
= High
then
655 Write_Str
("Checking project file """);
656 Write_Str
(Namet
.Get_Name_String
(Data
.Name
));
661 -- Is this project in the list of the visited project?
663 Current_Project
:= First_Project
;
664 while Current_Project
/= Empty_Project_List
665 and then Project_Lists
.Table
(Current_Project
).Project
/= Project
667 Current_Project
:= Project_Lists
.Table
(Current_Project
).Next
;
670 -- If it is not, put it in the list, and visit it
672 if Current_Project
= Empty_Project_List
then
673 Project_Lists
.Increment_Last
;
674 Project_Lists
.Table
(Project_Lists
.Last
) :=
675 (Project
=> Project
, Next
=> First_Project
);
676 First_Project
:= Project_Lists
.Last
;
678 -- Is the naming scheme of this project one that we know?
680 Current_Naming
:= Default_Naming
;
681 while Current_Naming
<= Namings
.Last
and then
682 not Same_Naming_Scheme
683 (Left
=> Namings
.Table
(Current_Naming
),
684 Right
=> Data
.Naming
) loop
685 Current_Naming
:= Current_Naming
+ 1;
688 -- If we don't know it, add it
690 if Current_Naming
> Namings
.Last
then
691 Namings
.Increment_Last
;
692 Namings
.Table
(Namings
.Last
) := Data
.Naming
;
694 -- We need a temporary file to be created
698 -- Put the SFN pragmas for the naming scheme
703 (File
, "pragma Source_File_Name_Project");
705 (File
, " (Spec_File_Name => ""*" &
706 Namet
.Get_Name_String
(Data
.Naming
.Ada_Spec_Suffix
) &
709 (File
, " Casing => " &
710 Image
(Data
.Naming
.Casing
) & ",");
712 (File
, " Dot_Replacement => """ &
713 Namet
.Get_Name_String
(Data
.Naming
.Dot_Replacement
) &
719 (File
, "pragma Source_File_Name_Project");
721 (File
, " (Body_File_Name => ""*" &
722 Namet
.Get_Name_String
(Data
.Naming
.Ada_Body_Suffix
) &
725 (File
, " Casing => " &
726 Image
(Data
.Naming
.Casing
) & ",");
728 (File
, " Dot_Replacement => """ &
729 Namet
.Get_Name_String
(Data
.Naming
.Dot_Replacement
) &
732 -- and maybe separate
735 Data
.Naming
.Ada_Body_Suffix
/= Data
.Naming
.Separate_Suffix
738 (File
, "pragma Source_File_Name_Project");
740 (File
, " (Subunit_File_Name => ""*" &
741 Namet
.Get_Name_String
(Data
.Naming
.Separate_Suffix
) &
744 (File
, " Casing => " &
745 Image
(Data
.Naming
.Casing
) &
748 (File
, " Dot_Replacement => """ &
749 Namet
.Get_Name_String
(Data
.Naming
.Dot_Replacement
) &
754 if Data
.Extends
/= No_Project
then
755 Check
(Data
.Extends
);
759 Current
: Project_List
:= Data
.Imported_Projects
;
762 while Current
/= Empty_Project_List
loop
763 Check
(Project_Lists
.Table
(Current
).Project
);
764 Current
:= Project_Lists
.Table
(Current
).Next
;
770 ---------------------
771 -- Check_Temp_File --
772 ---------------------
774 procedure Check_Temp_File
is
776 if File
= Invalid_FD
then
777 Tempdir
.Create_Temp_File
(File
, Name
=> File_Name
);
779 if File
= Invalid_FD
then
781 ("unable to create temporary configuration pragmas file");
782 elsif Opt
.Verbose_Mode
then
783 Write_Str
("Creating temp file """);
784 Write_Str
(Get_Name_String
(File_Name
));
795 (Unit_Name
: Name_Id
;
797 Unit_Kind
: Spec_Or_Body
;
801 -- A temporary file needs to be open
805 -- Put the pragma SFN for the unit kind (spec or body)
807 Put
(File
, "pragma Source_File_Name_Project (");
808 Put
(File
, Namet
.Get_Name_String
(Unit_Name
));
810 if Unit_Kind
= Specification
then
811 Put
(File
, ", Spec_File_Name => """);
813 Put
(File
, ", Body_File_Name => """);
816 Put
(File
, Namet
.Get_Name_String
(File_Name
));
820 Put
(File
, ", Index =>");
821 Put
(File
, Index
'Img);
824 Put_Line
(File
, ");");
827 procedure Put
(File
: File_Descriptor
; S
: String) is
831 Last
:= Write
(File
, S
(S
'First)'Address, S
'Length);
833 if Last
/= S
'Length then
834 Prj
.Com
.Fail
("Disk full");
837 if Current_Verbosity
= High
then
846 procedure Put_Line
(File
: File_Descriptor
; S
: String) is
847 S0
: String (1 .. S
'Length + 1);
851 -- Add an ASCII.LF to the string. As this config file is supposed to
852 -- be used only by the compiler, we don't care about the characters
853 -- for the end of line. In fact we could have put a space, but
854 -- it is more convenient to be able to read gnat.adc during
855 -- development, for which the ASCII.LF is fine.
857 S0
(1 .. S
'Length) := S
;
858 S0
(S0
'Last) := ASCII
.LF
;
859 Last
:= Write
(File
, S0
'Address, S0
'Length);
861 if Last
/= S
'Length + 1 then
862 Prj
.Com
.Fail
("Disk full");
865 if Current_Verbosity
= High
then
870 -- Start of processing for Create_Config_Pragmas_File
873 if not Projects
.Table
(For_Project
).Config_Checked
then
875 -- Remove any memory of processed naming schemes, if any
877 Namings
.Set_Last
(Default_Naming
);
879 -- Check the naming schemes
883 -- Visit all the units and process those that need an SFN pragma
885 while Current_Unit
<= Units
.Last
loop
887 Unit
: constant Unit_Data
:=
888 Units
.Table
(Current_Unit
);
891 if Unit
.File_Names
(Specification
).Needs_Pragma
then
893 Unit
.File_Names
(Specification
).Name
,
895 Unit
.File_Names
(Specification
).Index
);
898 if Unit
.File_Names
(Body_Part
).Needs_Pragma
then
900 Unit
.File_Names
(Body_Part
).Name
,
902 Unit
.File_Names
(Body_Part
).Index
);
905 Current_Unit
:= Current_Unit
+ 1;
909 -- If there are no non standard naming scheme, issue the GNAT
910 -- standard naming scheme. This will tell the compiler that
911 -- a project file is used and will forbid any pragma SFN.
913 if File
= Invalid_FD
then
916 Put_Line
(File
, "pragma Source_File_Name_Project");
917 Put_Line
(File
, " (Spec_File_Name => ""*.ads"",");
918 Put_Line
(File
, " Dot_Replacement => ""-"",");
919 Put_Line
(File
, " Casing => lowercase);");
921 Put_Line
(File
, "pragma Source_File_Name_Project");
922 Put_Line
(File
, " (Body_File_Name => ""*.adb"",");
923 Put_Line
(File
, " Dot_Replacement => ""-"",");
924 Put_Line
(File
, " Casing => lowercase);");
927 -- Close the temporary file
929 GNAT
.OS_Lib
.Close
(File
, Status
);
932 Prj
.Com
.Fail
("disk full");
935 if Opt
.Verbose_Mode
then
936 Write_Str
("Closing configuration file """);
937 Write_Str
(Get_Name_String
(File_Name
));
941 Projects
.Table
(For_Project
).Config_File_Name
:= File_Name
;
942 Projects
.Table
(For_Project
).Config_File_Temp
:= True;
944 Projects
.Table
(For_Project
).Config_Checked
:= True;
946 end Create_Config_Pragmas_File
;
948 -------------------------
949 -- Create_Mapping_File --
950 -------------------------
952 procedure Create_Mapping_File
953 (Project
: Project_Id
;
956 File
: File_Descriptor
:= Invalid_FD
;
957 The_Unit_Data
: Unit_Data
;
958 Data
: File_Name_Data
;
963 Present
: Project_Flags
(No_Project
.. Projects
.Last
) :=
965 -- For each project in the closure of Project, the corresponding flag
966 -- will be set to True;
968 procedure Put_Name_Buffer
;
969 -- Put the line contained in the Name_Buffer in the mapping file
971 procedure Put_Data
(Spec
: Boolean);
972 -- Put the mapping of the spec or body contained in Data in the file
975 procedure Recursive_Flag
(Prj
: Project_Id
);
976 -- Set the flags corresponding to Prj, the projects it imports
977 -- (directly or indirectly) or extends to True. Call itself recursively.
983 procedure Put_Name_Buffer
is
987 Name_Len
:= Name_Len
+ 1;
988 Name_Buffer
(Name_Len
) := ASCII
.LF
;
989 Last
:= Write
(File
, Name_Buffer
(1)'Address, Name_Len
);
991 if Last
/= Name_Len
then
992 Prj
.Com
.Fail
("Disk full");
1000 procedure Put_Data
(Spec
: Boolean) is
1002 -- Line with the unit name
1004 Get_Name_String
(The_Unit_Data
.Name
);
1005 Name_Len
:= Name_Len
+ 1;
1006 Name_Buffer
(Name_Len
) := '%';
1007 Name_Len
:= Name_Len
+ 1;
1010 Name_Buffer
(Name_Len
) := 's';
1012 Name_Buffer
(Name_Len
) := 'b';
1017 -- Line with the file name
1019 Get_Name_String
(Data
.Name
);
1022 -- Line with the path name
1024 Get_Name_String
(Data
.Path
);
1029 --------------------
1030 -- Recursive_Flag --
1031 --------------------
1033 procedure Recursive_Flag
(Prj
: Project_Id
) is
1034 Imported
: Project_List
;
1038 -- Nothing to do for non existent project or project that has
1039 -- already been flagged.
1041 if Prj
= No_Project
or else Present
(Prj
) then
1045 -- Flag the current project
1047 Present
(Prj
) := True;
1048 Imported
:= Projects
.Table
(Prj
).Imported_Projects
;
1050 -- Call itself for each project directly imported
1052 while Imported
/= Empty_Project_List
loop
1053 Proj
:= Project_Lists
.Table
(Imported
).Project
;
1054 Imported
:= Project_Lists
.Table
(Imported
).Next
;
1055 Recursive_Flag
(Proj
);
1058 -- Call itself for an eventual project being extended
1060 Recursive_Flag
(Projects
.Table
(Prj
).Extends
);
1063 -- Start of processing for Create_Mapping_File
1066 -- Flag the necessary projects
1068 Recursive_Flag
(Project
);
1070 -- Create the temporary file
1072 Tempdir
.Create_Temp_File
(File
, Name
=> Name
);
1074 if File
= Invalid_FD
then
1075 Prj
.Com
.Fail
("unable to create temporary mapping file");
1077 elsif Opt
.Verbose_Mode
then
1078 Write_Str
("Creating temp mapping file """);
1079 Write_Str
(Get_Name_String
(Name
));
1083 if Fill_Mapping_File
then
1084 -- For all units in table Units
1086 for Unit
in 1 .. Units
.Last
loop
1087 The_Unit_Data
:= Units
.Table
(Unit
);
1089 -- If the unit has a valid name
1091 if The_Unit_Data
.Name
/= No_Name
then
1092 Data
:= The_Unit_Data
.File_Names
(Specification
);
1094 -- If there is a spec, put it mapping in the file if it is
1095 -- from a project in the closure of Project.
1097 if Data
.Name
/= No_Name
and then Present
(Data
.Project
) then
1098 Put_Data
(Spec
=> True);
1101 Data
:= The_Unit_Data
.File_Names
(Body_Part
);
1103 -- If there is a body (or subunit) put its mapping in the file
1104 -- if it is from a project in the closure of Project.
1106 if Data
.Name
/= No_Name
and then Present
(Data
.Project
) then
1107 Put_Data
(Spec
=> False);
1114 GNAT
.OS_Lib
.Close
(File
, Status
);
1117 Prj
.Com
.Fail
("disk full");
1119 end Create_Mapping_File
;
1121 --------------------------
1122 -- Create_New_Path_File --
1123 --------------------------
1125 procedure Create_New_Path_File
1126 (Path_FD
: out File_Descriptor
;
1127 Path_Name
: out Name_Id
)
1130 Tempdir
.Create_Temp_File
(Path_FD
, Path_Name
);
1132 if Path_Name
/= No_Name
then
1134 -- Record the name, so that the temp path file will be deleted
1135 -- at the end of the program.
1137 Path_Files
.Increment_Last
;
1138 Path_Files
.Table
(Path_Files
.Last
) := Path_Name
;
1140 end Create_New_Path_File
;
1142 ---------------------------
1143 -- Delete_All_Path_Files --
1144 ---------------------------
1146 procedure Delete_All_Path_Files
is
1147 Disregard
: Boolean := True;
1150 for Index
in 1 .. Path_Files
.Last
loop
1151 if Path_Files
.Table
(Index
) /= No_Name
then
1153 (Get_Name_String
(Path_Files
.Table
(Index
)), Disregard
);
1157 -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or
1158 -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
1159 -- the empty string. On VMS, this has the effect of deassigning
1160 -- the logical names.
1162 if Ada_Prj_Include_File_Set
then
1163 Setenv
(Project_Include_Path_File
, "");
1164 Ada_Prj_Include_File_Set
:= False;
1167 if Ada_Prj_Objects_File_Set
then
1168 Setenv
(Project_Objects_Path_File
, "");
1169 Ada_Prj_Objects_File_Set
:= False;
1171 end Delete_All_Path_Files
;
1173 ------------------------------------
1174 -- File_Name_Of_Library_Unit_Body --
1175 ------------------------------------
1177 function File_Name_Of_Library_Unit_Body
1179 Project
: Project_Id
;
1180 Main_Project_Only
: Boolean := True;
1181 Full_Path
: Boolean := False) return String
1183 The_Project
: Project_Id
:= Project
;
1184 Data
: Project_Data
:= Projects
.Table
(Project
);
1185 Original_Name
: String := Name
;
1187 Extended_Spec_Name
: String :=
1188 Name
& Namet
.Get_Name_String
1189 (Data
.Naming
.Ada_Spec_Suffix
);
1190 Extended_Body_Name
: String :=
1191 Name
& Namet
.Get_Name_String
1192 (Data
.Naming
.Ada_Body_Suffix
);
1196 The_Original_Name
: Name_Id
;
1197 The_Spec_Name
: Name_Id
;
1198 The_Body_Name
: Name_Id
;
1201 Canonical_Case_File_Name
(Original_Name
);
1202 Name_Len
:= Original_Name
'Length;
1203 Name_Buffer
(1 .. Name_Len
) := Original_Name
;
1204 The_Original_Name
:= Name_Find
;
1206 Canonical_Case_File_Name
(Extended_Spec_Name
);
1207 Name_Len
:= Extended_Spec_Name
'Length;
1208 Name_Buffer
(1 .. Name_Len
) := Extended_Spec_Name
;
1209 The_Spec_Name
:= Name_Find
;
1211 Canonical_Case_File_Name
(Extended_Body_Name
);
1212 Name_Len
:= Extended_Body_Name
'Length;
1213 Name_Buffer
(1 .. Name_Len
) := Extended_Body_Name
;
1214 The_Body_Name
:= Name_Find
;
1216 if Current_Verbosity
= High
then
1217 Write_Str
("Looking for file name of """);
1221 Write_Str
(" Extended Spec Name = """);
1222 Write_Str
(Extended_Spec_Name
);
1225 Write_Str
(" Extended Body Name = """);
1226 Write_Str
(Extended_Body_Name
);
1231 -- For extending project, search in the extended project
1232 -- if the source is not found. For non extending projects,
1233 -- this loop will be run only once.
1236 -- Loop through units
1237 -- Should have comment explaining reverse ???
1239 for Current
in reverse Units
.First
.. Units
.Last
loop
1240 Unit
:= Units
.Table
(Current
);
1244 if not Main_Project_Only
1245 or else Unit
.File_Names
(Body_Part
).Project
= The_Project
1248 Current_Name
: constant Name_Id
:=
1249 Unit
.File_Names
(Body_Part
).Name
;
1252 -- Case of a body present
1254 if Current_Name
/= No_Name
then
1255 if Current_Verbosity
= High
then
1256 Write_Str
(" Comparing with """);
1257 Write_Str
(Get_Name_String
(Current_Name
));
1262 -- If it has the name of the original name,
1263 -- return the original name
1265 if Unit
.Name
= The_Original_Name
1266 or else Current_Name
= The_Original_Name
1268 if Current_Verbosity
= High
then
1273 return Get_Name_String
1274 (Unit
.File_Names
(Body_Part
).Path
);
1277 return Get_Name_String
(Current_Name
);
1280 -- If it has the name of the extended body name,
1281 -- return the extended body name
1283 elsif Current_Name
= The_Body_Name
then
1284 if Current_Verbosity
= High
then
1289 return Get_Name_String
1290 (Unit
.File_Names
(Body_Part
).Path
);
1293 return Extended_Body_Name
;
1297 if Current_Verbosity
= High
then
1298 Write_Line
(" not good");
1307 if not Main_Project_Only
1308 or else Unit
.File_Names
(Specification
).Project
= The_Project
1311 Current_Name
: constant Name_Id
:=
1312 Unit
.File_Names
(Specification
).Name
;
1315 -- Case of spec present
1317 if Current_Name
/= No_Name
then
1318 if Current_Verbosity
= High
then
1319 Write_Str
(" Comparing with """);
1320 Write_Str
(Get_Name_String
(Current_Name
));
1325 -- If name same as original name, return original name
1327 if Unit
.Name
= The_Original_Name
1328 or else Current_Name
= The_Original_Name
1330 if Current_Verbosity
= High
then
1335 return Get_Name_String
1336 (Unit
.File_Names
(Specification
).Path
);
1338 return Get_Name_String
(Current_Name
);
1341 -- If it has the same name as the extended spec name,
1342 -- return the extended spec name.
1344 elsif Current_Name
= The_Spec_Name
then
1345 if Current_Verbosity
= High
then
1350 return Get_Name_String
1351 (Unit
.File_Names
(Specification
).Path
);
1353 return Extended_Spec_Name
;
1357 if Current_Verbosity
= High
then
1358 Write_Line
(" not good");
1366 -- If we are not in an extending project, give up
1368 exit when (not Main_Project_Only
) or else Data
.Extends
= No_Project
;
1370 -- Otherwise, look in the project we are extending
1372 The_Project
:= Data
.Extends
;
1373 Data
:= Projects
.Table
(The_Project
);
1376 -- We don't know this file name, return an empty string
1379 end File_Name_Of_Library_Unit_Body
;
1381 -------------------------
1382 -- For_All_Object_Dirs --
1383 -------------------------
1385 procedure For_All_Object_Dirs
(Project
: Project_Id
) is
1386 Seen
: Project_List
:= Empty_Project_List
;
1388 procedure Add
(Project
: Project_Id
);
1389 -- Process a project. Remember the processes visited to avoid
1390 -- processing a project twice. Recursively process an eventual
1391 -- extended project, and all imported projects.
1397 procedure Add
(Project
: Project_Id
) is
1398 Data
: constant Project_Data
:= Projects
.Table
(Project
);
1399 List
: Project_List
:= Data
.Imported_Projects
;
1402 -- If the list of visited project is empty, then
1403 -- for sure we never visited this project.
1405 if Seen
= Empty_Project_List
then
1406 Project_Lists
.Increment_Last
;
1407 Seen
:= Project_Lists
.Last
;
1408 Project_Lists
.Table
(Seen
) :=
1409 (Project
=> Project
, Next
=> Empty_Project_List
);
1412 -- Check if the project is in the list
1415 Current
: Project_List
:= Seen
;
1419 -- If it is, then there is nothing else to do
1421 if Project_Lists
.Table
(Current
).Project
= Project
then
1425 exit when Project_Lists
.Table
(Current
).Next
=
1427 Current
:= Project_Lists
.Table
(Current
).Next
;
1430 -- This project has never been visited, add it
1433 Project_Lists
.Increment_Last
;
1434 Project_Lists
.Table
(Current
).Next
:= Project_Lists
.Last
;
1435 Project_Lists
.Table
(Project_Lists
.Last
) :=
1436 (Project
=> Project
, Next
=> Empty_Project_List
);
1440 -- If there is an object directory, call Action
1443 if Data
.Object_Directory
/= No_Name
then
1444 Get_Name_String
(Data
.Object_Directory
);
1445 Action
(Name_Buffer
(1 .. Name_Len
));
1448 -- If we are extending a project, visit it
1450 if Data
.Extends
/= No_Project
then
1454 -- And visit all imported projects
1456 while List
/= Empty_Project_List
loop
1457 Add
(Project_Lists
.Table
(List
).Project
);
1458 List
:= Project_Lists
.Table
(List
).Next
;
1462 -- Start of processing for For_All_Object_Dirs
1465 -- Visit this project, and its imported projects,
1469 end For_All_Object_Dirs
;
1471 -------------------------
1472 -- For_All_Source_Dirs --
1473 -------------------------
1475 procedure For_All_Source_Dirs
(Project
: Project_Id
) is
1476 Seen
: Project_List
:= Empty_Project_List
;
1478 procedure Add
(Project
: Project_Id
);
1479 -- Process a project. Remember the processes visited to avoid
1480 -- processing a project twice. Recursively process an eventual
1481 -- extended project, and all imported projects.
1487 procedure Add
(Project
: Project_Id
) is
1488 Data
: constant Project_Data
:= Projects
.Table
(Project
);
1489 List
: Project_List
:= Data
.Imported_Projects
;
1492 -- If the list of visited project is empty, then
1493 -- for sure we never visited this project.
1495 if Seen
= Empty_Project_List
then
1496 Project_Lists
.Increment_Last
;
1497 Seen
:= Project_Lists
.Last
;
1498 Project_Lists
.Table
(Seen
) :=
1499 (Project
=> Project
, Next
=> Empty_Project_List
);
1502 -- Check if the project is in the list
1505 Current
: Project_List
:= Seen
;
1509 -- If it is, then there is nothing else to do
1511 if Project_Lists
.Table
(Current
).Project
= Project
then
1515 exit when Project_Lists
.Table
(Current
).Next
=
1517 Current
:= Project_Lists
.Table
(Current
).Next
;
1520 -- This project has never been visited, add it
1523 Project_Lists
.Increment_Last
;
1524 Project_Lists
.Table
(Current
).Next
:= Project_Lists
.Last
;
1525 Project_Lists
.Table
(Project_Lists
.Last
) :=
1526 (Project
=> Project
, Next
=> Empty_Project_List
);
1531 Current
: String_List_Id
:= Data
.Source_Dirs
;
1532 The_String
: String_Element
;
1535 -- If there are Ada sources, call action with the name of every
1536 -- source directory.
1538 if Projects
.Table
(Project
).Ada_Sources_Present
then
1539 while Current
/= Nil_String
loop
1540 The_String
:= String_Elements
.Table
(Current
);
1541 Action
(Get_Name_String
(The_String
.Value
));
1542 Current
:= The_String
.Next
;
1547 -- If we are extending a project, visit it
1549 if Data
.Extends
/= No_Project
then
1553 -- And visit all imported projects
1555 while List
/= Empty_Project_List
loop
1556 Add
(Project_Lists
.Table
(List
).Project
);
1557 List
:= Project_Lists
.Table
(List
).Next
;
1561 -- Start of processing for For_All_Source_Dirs
1564 -- Visit this project, and its imported projects recursively
1567 end For_All_Source_Dirs
;
1573 procedure Get_Reference
1574 (Source_File_Name
: String;
1575 Project
: out Project_Id
;
1579 -- Body below could use some comments ???
1581 if Current_Verbosity
> Default
then
1582 Write_Str
("Getting Reference_Of (""");
1583 Write_Str
(Source_File_Name
);
1584 Write_Str
(""") ... ");
1588 Original_Name
: String := Source_File_Name
;
1592 Canonical_Case_File_Name
(Original_Name
);
1594 for Id
in Units
.First
.. Units
.Last
loop
1595 Unit
:= Units
.Table
(Id
);
1597 if (Unit
.File_Names
(Specification
).Name
/= No_Name
1599 Namet
.Get_Name_String
1600 (Unit
.File_Names
(Specification
).Name
) = Original_Name
)
1601 or else (Unit
.File_Names
(Specification
).Path
/= No_Name
1603 Namet
.Get_Name_String
1604 (Unit
.File_Names
(Specification
).Path
) =
1607 Project
:= Ultimate_Extension_Of
1608 (Unit
.File_Names
(Specification
).Project
);
1609 Path
:= Unit
.File_Names
(Specification
).Display_Path
;
1611 if Current_Verbosity
> Default
then
1612 Write_Str
("Done: Specification.");
1618 elsif (Unit
.File_Names
(Body_Part
).Name
/= No_Name
1620 Namet
.Get_Name_String
1621 (Unit
.File_Names
(Body_Part
).Name
) = Original_Name
)
1622 or else (Unit
.File_Names
(Body_Part
).Path
/= No_Name
1623 and then Namet
.Get_Name_String
1624 (Unit
.File_Names
(Body_Part
).Path
) =
1627 Project
:= Ultimate_Extension_Of
1628 (Unit
.File_Names
(Body_Part
).Project
);
1629 Path
:= Unit
.File_Names
(Body_Part
).Display_Path
;
1631 if Current_Verbosity
> Default
then
1632 Write_Str
("Done: Body.");
1641 Project
:= No_Project
;
1644 if Current_Verbosity
> Default
then
1645 Write_Str
("Cannot be found.");
1654 -- This is a place holder for possible required initialization in
1655 -- the future. In the current version no initialization is required.
1657 procedure Initialize
is
1662 ------------------------------------
1663 -- Path_Name_Of_Library_Unit_Body --
1664 ------------------------------------
1666 -- Could use some comments in the body here ???
1668 function Path_Name_Of_Library_Unit_Body
1670 Project
: Project_Id
) return String
1672 Data
: constant Project_Data
:= Projects
.Table
(Project
);
1673 Original_Name
: String := Name
;
1675 Extended_Spec_Name
: String :=
1676 Name
& Namet
.Get_Name_String
1677 (Data
.Naming
.Ada_Spec_Suffix
);
1678 Extended_Body_Name
: String :=
1679 Name
& Namet
.Get_Name_String
1680 (Data
.Naming
.Ada_Body_Suffix
);
1682 First
: Unit_Id
:= Units
.First
;
1687 Canonical_Case_File_Name
(Original_Name
);
1688 Canonical_Case_File_Name
(Extended_Spec_Name
);
1689 Canonical_Case_File_Name
(Extended_Body_Name
);
1691 if Current_Verbosity
= High
then
1692 Write_Str
("Looking for path name of """);
1696 Write_Str
(" Extended Spec Name = """);
1697 Write_Str
(Extended_Spec_Name
);
1700 Write_Str
(" Extended Body Name = """);
1701 Write_Str
(Extended_Body_Name
);
1706 while First
<= Units
.Last
1707 and then Units
.Table
(First
).File_Names
(Body_Part
).Project
/= Project
1713 while Current
<= Units
.Last
loop
1714 Unit
:= Units
.Table
(Current
);
1716 if Unit
.File_Names
(Body_Part
).Project
= Project
1717 and then Unit
.File_Names
(Body_Part
).Name
/= No_Name
1720 Current_Name
: constant String :=
1721 Namet
.Get_Name_String
(Unit
.File_Names
(Body_Part
).Name
);
1723 if Current_Verbosity
= High
then
1724 Write_Str
(" Comparing with """);
1725 Write_Str
(Current_Name
);
1730 if Current_Name
= Original_Name
then
1731 if Current_Verbosity
= High
then
1735 return Body_Path_Name_Of
(Current
);
1737 elsif Current_Name
= Extended_Body_Name
then
1738 if Current_Verbosity
= High
then
1742 return Body_Path_Name_Of
(Current
);
1745 if Current_Verbosity
= High
then
1746 Write_Line
(" not good");
1751 elsif Unit
.File_Names
(Specification
).Name
/= No_Name
then
1753 Current_Name
: constant String :=
1754 Namet
.Get_Name_String
1755 (Unit
.File_Names
(Specification
).Name
);
1758 if Current_Verbosity
= High
then
1759 Write_Str
(" Comparing with """);
1760 Write_Str
(Current_Name
);
1765 if Current_Name
= Original_Name
then
1766 if Current_Verbosity
= High
then
1770 return Spec_Path_Name_Of
(Current
);
1772 elsif Current_Name
= Extended_Spec_Name
then
1773 if Current_Verbosity
= High
then
1777 return Spec_Path_Name_Of
(Current
);
1780 if Current_Verbosity
= High
then
1781 Write_Line
(" not good");
1786 Current
:= Current
+ 1;
1790 end Path_Name_Of_Library_Unit_Body
;
1796 -- Could use some comments in this body ???
1798 procedure Print_Sources
is
1802 Write_Line
("List of Sources:");
1804 for Id
in Units
.First
.. Units
.Last
loop
1805 Unit
:= Units
.Table
(Id
);
1807 Write_Line
(Namet
.Get_Name_String
(Unit
.Name
));
1809 if Unit
.File_Names
(Specification
).Name
/= No_Name
then
1810 if Unit
.File_Names
(Specification
).Project
= No_Project
then
1811 Write_Line
(" No project");
1814 Write_Str
(" Project: ");
1817 (Unit
.File_Names
(Specification
).Project
).Path_Name
);
1818 Write_Line
(Name_Buffer
(1 .. Name_Len
));
1821 Write_Str
(" spec: ");
1823 (Namet
.Get_Name_String
1824 (Unit
.File_Names
(Specification
).Name
));
1827 if Unit
.File_Names
(Body_Part
).Name
/= No_Name
then
1828 if Unit
.File_Names
(Body_Part
).Project
= No_Project
then
1829 Write_Line
(" No project");
1832 Write_Str
(" Project: ");
1835 (Unit
.File_Names
(Body_Part
).Project
).Path_Name
);
1836 Write_Line
(Name_Buffer
(1 .. Name_Len
));
1839 Write_Str
(" body: ");
1841 (Namet
.Get_Name_String
1842 (Unit
.File_Names
(Body_Part
).Name
));
1846 Write_Line
("end of List of Sources.");
1855 Main_Project
: Project_Id
) return Project_Id
1857 Result
: Project_Id
:= No_Project
;
1859 Original_Name
: String := Name
;
1861 Data
: constant Project_Data
:= Projects
.Table
(Main_Project
);
1863 Extended_Spec_Name
: String :=
1864 Name
& Namet
.Get_Name_String
1865 (Data
.Naming
.Ada_Spec_Suffix
);
1866 Extended_Body_Name
: String :=
1867 Name
& Namet
.Get_Name_String
1868 (Data
.Naming
.Ada_Body_Suffix
);
1872 Current_Name
: Name_Id
;
1874 The_Original_Name
: Name_Id
;
1875 The_Spec_Name
: Name_Id
;
1876 The_Body_Name
: Name_Id
;
1879 Canonical_Case_File_Name
(Original_Name
);
1880 Name_Len
:= Original_Name
'Length;
1881 Name_Buffer
(1 .. Name_Len
) := Original_Name
;
1882 The_Original_Name
:= Name_Find
;
1884 Canonical_Case_File_Name
(Extended_Spec_Name
);
1885 Name_Len
:= Extended_Spec_Name
'Length;
1886 Name_Buffer
(1 .. Name_Len
) := Extended_Spec_Name
;
1887 The_Spec_Name
:= Name_Find
;
1889 Canonical_Case_File_Name
(Extended_Body_Name
);
1890 Name_Len
:= Extended_Body_Name
'Length;
1891 Name_Buffer
(1 .. Name_Len
) := Extended_Body_Name
;
1892 The_Body_Name
:= Name_Find
;
1894 for Current
in reverse Units
.First
.. Units
.Last
loop
1895 Unit
:= Units
.Table
(Current
);
1899 Current_Name
:= Unit
.File_Names
(Body_Part
).Name
;
1901 -- Case of a body present
1903 if Current_Name
/= No_Name
then
1905 -- If it has the name of the original name or the body name,
1906 -- we have found the project.
1908 if Unit
.Name
= The_Original_Name
1909 or else Current_Name
= The_Original_Name
1910 or else Current_Name
= The_Body_Name
1912 Result
:= Unit
.File_Names
(Body_Part
).Project
;
1919 Current_Name
:= Unit
.File_Names
(Specification
).Name
;
1921 if Current_Name
/= No_Name
then
1923 -- If name same as the original name, or the spec name, we have
1924 -- found the project.
1926 if Unit
.Name
= The_Original_Name
1927 or else Current_Name
= The_Original_Name
1928 or else Current_Name
= The_Spec_Name
1930 Result
:= Unit
.File_Names
(Specification
).Project
;
1936 -- Get the ultimate extending project
1938 if Result
/= No_Project
then
1939 while Projects
.Table
(Result
).Extended_By
/= No_Project
loop
1940 Result
:= Projects
.Table
(Result
).Extended_By
;
1951 procedure Set_Ada_Paths
1952 (Project
: Project_Id
;
1953 Including_Libraries
: Boolean)
1955 Source_FD
: File_Descriptor
:= Invalid_FD
;
1956 Object_FD
: File_Descriptor
:= Invalid_FD
;
1958 Process_Source_Dirs
: Boolean := False;
1959 Process_Object_Dirs
: Boolean := False;
1962 -- For calls to Close
1966 procedure Add
(Proj
: Project_Id
);
1967 -- Add all the source/object directories of a project to the path only
1968 -- if this project has not been visited. Calls an internal procedure
1969 -- recursively for projects being extended, and imported projects.
1975 procedure Add
(Proj
: Project_Id
) is
1977 procedure Recursive_Add
(Project
: Project_Id
);
1978 -- Recursive procedure to add the source/object paths of extended/
1979 -- imported projects.
1985 procedure Recursive_Add
(Project
: Project_Id
) is
1987 -- If Seen is False, then the project has not yet been visited
1989 if not Projects
.Table
(Project
).Seen
then
1990 Projects
.Table
(Project
).Seen
:= True;
1993 Data
: constant Project_Data
:= Projects
.Table
(Project
);
1994 List
: Project_List
:= Data
.Imported_Projects
;
1997 if Process_Source_Dirs
then
1999 -- Add to path all source directories of this project
2000 -- if there are Ada sources.
2002 if Projects
.Table
(Project
).Ada_Sources_Present
then
2003 Add_To_Source_Path
(Data
.Source_Dirs
);
2007 if Process_Object_Dirs
then
2009 -- Add to path the object directory of this project
2010 -- except if we don't include library project and
2011 -- this is a library project.
2013 if (Data
.Library
and then Including_Libraries
)
2015 (Data
.Object_Directory
/= No_Name
2017 (not Including_Libraries
or else not Data
.Library
))
2019 -- For a library project, add the library directory
2020 -- if there is no object directory or if the library
2021 -- directory contains ALI files; otherwise add the
2022 -- object directory.
2024 if Data
.Library
then
2025 if Data
.Object_Directory
= No_Name
2026 or else Contains_ALI_Files
(Data
.Library_Dir
)
2028 Add_To_Object_Path
(Data
.Library_Dir
);
2030 Add_To_Object_Path
(Data
.Object_Directory
);
2033 -- For a non-library project, add the object
2034 -- directory, if it is not a virtual project.
2036 elsif not Data
.Virtual
then
2037 Add_To_Object_Path
(Data
.Object_Directory
);
2042 -- Call Add to the project being extended, if any
2044 if Data
.Extends
/= No_Project
then
2045 Recursive_Add
(Data
.Extends
);
2048 -- Call Add for each imported project, if any
2050 while List
/= Empty_Project_List
loop
2051 Recursive_Add
(Project_Lists
.Table
(List
).Project
);
2052 List
:= Project_Lists
.Table
(List
).Next
;
2059 Source_Paths
.Set_Last
(0);
2060 Object_Paths
.Set_Last
(0);
2062 for Index
in 1 .. Projects
.Last
loop
2063 Projects
.Table
(Index
).Seen
:= False;
2066 Recursive_Add
(Proj
);
2069 -- Start of processing for Set_Ada_Paths
2072 -- If it is the first time we call this procedure for
2073 -- this project, compute the source path and/or the object path.
2075 if Projects
.Table
(Project
).Include_Path_File
= No_Name
then
2076 Process_Source_Dirs
:= True;
2077 Create_New_Path_File
2078 (Source_FD
, Projects
.Table
(Project
).Include_Path_File
);
2081 -- For the object path, we make a distinction depending on
2082 -- Including_Libraries.
2084 if Including_Libraries
then
2085 if Projects
.Table
(Project
).Objects_Path_File_With_Libs
= No_Name
then
2086 Process_Object_Dirs
:= True;
2087 Create_New_Path_File
2088 (Object_FD
, Projects
.Table
(Project
).
2089 Objects_Path_File_With_Libs
);
2094 Projects
.Table
(Project
).Objects_Path_File_Without_Libs
= No_Name
2096 Process_Object_Dirs
:= True;
2097 Create_New_Path_File
2098 (Object_FD
, Projects
.Table
(Project
).
2099 Objects_Path_File_Without_Libs
);
2103 -- If there is something to do, set Seen to False for all projects,
2104 -- then call the recursive procedure Add for Project.
2106 if Process_Source_Dirs
or Process_Object_Dirs
then
2110 -- Write and close any file that has been created.
2112 if Source_FD
/= Invalid_FD
then
2113 for Index
in 1 .. Source_Paths
.Last
loop
2114 Get_Name_String
(Source_Paths
.Table
(Index
));
2115 Name_Len
:= Name_Len
+ 1;
2116 Name_Buffer
(Name_Len
) := ASCII
.LF
;
2117 Len
:= Write
(Source_FD
, Name_Buffer
(1)'Address, Name_Len
);
2119 if Len
/= Name_Len
then
2120 Prj
.Com
.Fail
("disk full");
2124 Close
(Source_FD
, Status
);
2127 Prj
.Com
.Fail
("disk full");
2131 if Object_FD
/= Invalid_FD
then
2132 for Index
in 1 .. Object_Paths
.Last
loop
2133 Get_Name_String
(Object_Paths
.Table
(Index
));
2134 Name_Len
:= Name_Len
+ 1;
2135 Name_Buffer
(Name_Len
) := ASCII
.LF
;
2136 Len
:= Write
(Object_FD
, Name_Buffer
(1)'Address, Name_Len
);
2138 if Len
/= Name_Len
then
2139 Prj
.Com
.Fail
("disk full");
2143 Close
(Object_FD
, Status
);
2146 Prj
.Com
.Fail
("disk full");
2150 -- Set the env vars, if they need to be changed, and set the
2151 -- corresponding flags.
2153 if Current_Source_Path_File
/=
2154 Projects
.Table
(Project
).Include_Path_File
2156 Current_Source_Path_File
:=
2157 Projects
.Table
(Project
).Include_Path_File
;
2159 (Project_Include_Path_File
,
2160 Get_Name_String
(Current_Source_Path_File
));
2161 Ada_Prj_Include_File_Set
:= True;
2164 if Including_Libraries
then
2165 if Current_Object_Path_File
2166 /= Projects
.Table
(Project
).Objects_Path_File_With_Libs
2168 Current_Object_Path_File
:=
2169 Projects
.Table
(Project
).Objects_Path_File_With_Libs
;
2171 (Project_Objects_Path_File
,
2172 Get_Name_String
(Current_Object_Path_File
));
2173 Ada_Prj_Objects_File_Set
:= True;
2177 if Current_Object_Path_File
2178 /= Projects
.Table
(Project
).Objects_Path_File_Without_Libs
2180 Current_Object_Path_File
:=
2181 Projects
.Table
(Project
).Objects_Path_File_Without_Libs
;
2183 (Project_Objects_Path_File
,
2184 Get_Name_String
(Current_Object_Path_File
));
2185 Ada_Prj_Objects_File_Set
:= True;
2190 ---------------------------------------------
2191 -- Set_Mapping_File_Initial_State_To_Empty --
2192 ---------------------------------------------
2194 procedure Set_Mapping_File_Initial_State_To_Empty
is
2196 Fill_Mapping_File
:= False;
2197 end Set_Mapping_File_Initial_State_To_Empty
;
2199 -----------------------
2200 -- Set_Path_File_Var --
2201 -----------------------
2203 procedure Set_Path_File_Var
(Name
: String; Value
: String) is
2204 Host_Spec
: String_Access
:= To_Host_File_Spec
(Value
);
2207 if Host_Spec
= null then
2209 ("could not convert file name """, Value
, """ to host spec");
2211 Setenv
(Name
, Host_Spec
.all);
2214 end Set_Path_File_Var
;
2216 -----------------------
2217 -- Spec_Path_Name_Of --
2218 -----------------------
2220 function Spec_Path_Name_Of
(Unit
: Unit_Id
) return String is
2221 Data
: Unit_Data
:= Units
.Table
(Unit
);
2224 if Data
.File_Names
(Specification
).Path
= No_Name
then
2226 Current_Source
: String_List_Id
:=
2227 Projects
.Table
(Data
.File_Names
(Specification
).Project
).Sources
;
2228 Path
: GNAT
.OS_Lib
.String_Access
;
2231 Data
.File_Names
(Specification
).Path
:=
2232 Data
.File_Names
(Specification
).Name
;
2234 while Current_Source
/= Nil_String
loop
2235 Path
:= Locate_Regular_File
2236 (Namet
.Get_Name_String
2237 (Data
.File_Names
(Specification
).Name
),
2238 Namet
.Get_Name_String
2239 (String_Elements
.Table
(Current_Source
).Value
));
2241 if Path
/= null then
2242 Name_Len
:= Path
'Length;
2243 Name_Buffer
(1 .. Name_Len
) := Path
.all;
2244 Data
.File_Names
(Specification
).Path
:= Name_Enter
;
2248 String_Elements
.Table
(Current_Source
).Next
;
2252 Units
.Table
(Unit
) := Data
;
2256 return Namet
.Get_Name_String
(Data
.File_Names
(Specification
).Path
);
2257 end Spec_Path_Name_Of
;
2259 ---------------------------
2260 -- Ultimate_Extension_Of --
2261 ---------------------------
2263 function Ultimate_Extension_Of
(Project
: in Project_Id
) return Project_Id
2265 Result
: Project_Id
:= Project
;
2268 while Projects
.Table
(Result
).Extended_By
/= No_Project
loop
2269 Result
:= Projects
.Table
(Result
).Extended_By
;
2273 end Ultimate_Extension_Of
;
2275 -- Package initialization
2276 -- What is relationshiop to procedure Initialize
2279 Path_Files
.Set_Last
(0);