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);