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