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