1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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 ------------------------------------------------------------------------------
30 with Osint; use Osint;
35 with Prj.Tree; use Prj.Tree;
36 with Prj.Util; use Prj.Util;
37 with Snames; use Snames;
38 with Table; use Table;
40 with Ada.Characters.Handling; use Ada.Characters.Handling;
41 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
43 with System.Case_Util; use System.Case_Util;
45 with System.Regexp; use System.Regexp;
47 package body Prj.Makr is
49 -- Packages of project files where unknown attributes are errors
51 -- All the following need comments ??? All global variables and
52 -- subprograms must be fully commented.
54 Naming_String : aliased String := "naming";
56 Gnatname_Packages : aliased String_List := (1 => Naming_String'Access);
58 Packages_To_Check_By_Gnatname : constant String_List_Access :=
59 Gnatname_Packages'Access;
61 function Dup (Fd : File_Descriptor) return File_Descriptor;
63 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
65 Gcc : constant String := "gcc";
66 Gcc_Path : String_Access := null;
68 Non_Empty_Node : constant Project_Node_Id := 1;
69 -- Used for the With_Clause of the naming project
71 type Matched_Type is (True, False, Excluded);
73 Naming_File_Suffix : constant String := "_naming";
74 Source_List_File_Suffix : constant String := "_source_list.txt";
76 Output_FD : File_Descriptor;
77 -- To save the project file and its naming project file
80 -- Output an empty line
82 procedure Write_A_Char (C : Character);
83 -- Write one character to Output_FD
85 procedure Write_A_String (S : String);
86 -- Write a String to Output_FD
88 package Processed_Directories is new Table.Table
89 (Table_Component_Type => String_Access,
90 Table_Index_Type => Natural,
93 Table_Increment => 100,
94 Table_Name => "Prj.Makr.Processed_Directories");
100 function Dup (Fd : File_Descriptor) return File_Descriptor is
102 return File_Descriptor (System.CRTL.dup (Integer (Fd)));
109 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor) is
111 pragma Warnings (Off, Fd);
113 Fd := System.CRTL.dup2 (Integer (Old_Fd), Integer (New_Fd));
122 Project_File : Boolean;
123 Directories : Argument_List;
124 Name_Patterns : Argument_List;
125 Excluded_Patterns : Argument_List;
126 Foreign_Patterns : Argument_List;
127 Preproc_Switches : Argument_List;
128 Very_Verbose : Boolean)
130 Tree : constant Project_Node_Tree_Ref := new Project_Node_Tree_Data;
132 Path_Name : String (1 .. File_Path'Length +
133 Project_File_Extension'Length);
134 Path_Last : Natural := File_Path'Length;
136 Directory_Last : Natural := 0;
138 Output_Name : String (Path_Name'Range);
139 Output_Name_Last : Natural;
140 Output_Name_Id : Name_Id;
142 Project_Node : Project_Node_Id := Empty_Node;
143 Project_Declaration : Project_Node_Id := Empty_Node;
144 Source_Dirs_List : Project_Node_Id := Empty_Node;
145 Current_Source_Dir : Project_Node_Id := Empty_Node;
147 Project_Naming_Node : Project_Node_Id := Empty_Node;
148 Project_Naming_Decl : Project_Node_Id := Empty_Node;
149 Naming_Package : Project_Node_Id := Empty_Node;
150 Naming_Package_Comments : Project_Node_Id := Empty_Node;
152 Source_Files_Comments : Project_Node_Id := Empty_Node;
153 Source_Dirs_Comments : Project_Node_Id := Empty_Node;
154 Source_List_File_Comments : Project_Node_Id := Empty_Node;
156 Project_Naming_File_Name : String (1 .. Output_Name'Length +
157 Naming_File_Suffix'Length);
159 Project_Naming_Last : Natural;
160 Project_Naming_Id : Name_Id := No_Name;
162 Excluded_Expressions : array (Excluded_Patterns'Range) of Regexp;
163 Regular_Expressions : array (Name_Patterns'Range) of Regexp;
164 Foreign_Expressions : array (Foreign_Patterns'Range) of Regexp;
166 Source_List_Path : String (1 .. Output_Name'Length +
167 Source_List_File_Suffix'Length);
168 Source_List_Last : Natural;
170 Source_List_FD : File_Descriptor;
172 Args : Argument_List (1 .. Preproc_Switches'Length + 6);
174 type SFN_Pragma is record
181 package SFN_Pragmas is new Table.Table
182 (Table_Component_Type => SFN_Pragma,
183 Table_Index_Type => Natural,
184 Table_Low_Bound => 0,
186 Table_Increment => 100,
187 Table_Name => "Prj.Makr.SFN_Pragmas");
189 procedure Process_Directory (Dir_Name : String; Recursively : Boolean);
190 -- Look for Ada and foreign sources in a directory, according to the
191 -- patterns. When Recursively is True, after looking for sources in
192 -- Dir_Name, look also in its subdirectories, if any.
194 -----------------------
195 -- Process_Directory --
196 -----------------------
198 procedure Process_Directory (Dir_Name : String; Recursively : Boolean) is
199 Matched : Matched_Type := False;
200 Str : String (1 .. 2_000);
201 Canon : String (1 .. 2_000);
204 Process : Boolean := True;
206 Temp_File_Name : String_Access := null;
207 Save_Last_Pragma_Index : Natural := 0;
208 File_Name_Id : Name_Id := No_Name;
209 SFN_Prag : SFN_Pragma;
212 -- Avoid processing the same directory more than once
214 for Index in 1 .. Processed_Directories.Last loop
215 if Processed_Directories.Table (Index).all = Dir_Name then
222 if Opt.Verbose_Mode then
223 Output.Write_Str ("Processing directory """);
224 Output.Write_Str (Dir_Name);
225 Output.Write_Line ("""");
228 Processed_Directories. Increment_Last;
229 Processed_Directories.Table (Processed_Directories.Last) :=
230 new String'(Dir_Name);
232 -- Get the source file names from the directory. Fails if the
233 -- directory does not exist.
236 Open (Dir, Dir_Name);
238 when Directory_Error =>
239 Prj.Com.Fail ("cannot open directory """, Dir_Name, """");
242 -- Process each regular file in the directory
245 Read (Dir, Str, Last);
246 exit File_Loop when Last = 0;
248 -- Copy the file name and put it in canonical case to match
249 -- against the patterns that have themselves already been put
250 -- in canonical case.
252 Canon (1 .. Last) := Str (1 .. Last);
253 Canonical_Case_File_Name (Canon (1 .. Last));
256 (Dir_Name & Directory_Separator & Str (1 .. Last))
261 Name_Buffer (1 .. Name_Len) := Str (1 .. Last);
262 File_Name_Id := Name_Find;
264 -- First, check if the file name matches at least one of
265 -- the excluded expressions;
267 for Index in Excluded_Expressions'Range loop
269 Match (Canon (1 .. Last), Excluded_Expressions (Index))
276 -- If it does not match any of the excluded expressions,
277 -- check if the file name matches at least one of the
278 -- regular expressions.
280 if Matched = True then
283 for Index in Regular_Expressions'Range loop
286 (Canon (1 .. Last), Regular_Expressions (Index))
295 or else (Matched = True and then Opt.Verbose_Mode)
297 Output.Write_Str (" Checking """);
298 Output.Write_Str (Str (1 .. Last));
299 Output.Write_Line (""": ");
302 -- If the file name matches one of the regular expressions,
303 -- parse it to get its unit name.
305 if Matched = True then
307 FD : File_Descriptor;
309 Saved_Output : File_Descriptor;
310 Saved_Error : File_Descriptor;
313 -- If we don't have the path of the compiler yet,
314 -- get it now. The compiler name may have a prefix,
315 -- so we get the potentially prefixed name.
317 if Gcc_Path = null then
319 Prefix_Gcc : String_Access :=
323 Locate_Exec_On_Path (Prefix_Gcc.all);
327 if Gcc_Path = null then
328 Prj.Com.Fail ("could not locate " & Gcc);
332 -- If we don't have yet the file name of the
333 -- temporary file, get it now.
335 if Temp_File_Name = null then
336 Create_Temp_File (FD, Temp_File_Name);
338 if FD = Invalid_FD then
340 ("could not create temporary file");
344 Delete_File (Temp_File_Name.all, Success);
347 Args (Args'Last) := new String'
349 Directory_Separator &
352 -- Create the temporary file
354 FD := Create_Output_Text_File
355 (Name => Temp_File_Name.all);
357 if FD = Invalid_FD then
359 ("could not create temporary file");
362 -- Save the standard output and error
364 Saved_Output := Dup (Standout);
365 Saved_Error := Dup (Standerr);
367 -- Set standard output and error to the temporary file
372 -- And spawn the compiler
374 Spawn (Gcc_Path.all, Args, Success);
376 -- Restore the standard output and error
378 Dup2 (Saved_Output, Standout);
379 Dup2 (Saved_Error, Standerr);
381 -- Close the temporary file
385 -- And close the saved standard output and error to
386 -- avoid too many file descriptors.
388 Close (Saved_Output);
391 -- Now that standard output is restored, check if
392 -- the compiler ran correctly.
394 -- Read the lines of the temporary file:
395 -- they should contain the kind and name of the unit.
399 Text_Line : String (1 .. 1_000);
403 Open (File, Temp_File_Name.all);
405 if not Is_Valid (File) then
407 ("could not read temporary file");
410 Save_Last_Pragma_Index := SFN_Pragmas.Last;
412 if End_Of_File (File) then
413 if Opt.Verbose_Mode then
415 Output.Write_Str (" (process died) ");
420 Line_Loop : while not End_Of_File (File) loop
421 Get_Line (File, Text_Line, Text_Last);
423 -- Find the first closing parenthesis
425 Char_Loop : for J in 1 .. Text_Last loop
426 if Text_Line (J) = ')' then
428 Text_Line (1 .. 4) = "Unit"
430 -- Add entry to SFN_Pragmas table
433 Name_Buffer (1 .. Name_Len) :=
434 Text_Line (6 .. J - 7);
437 File => File_Name_Id,
439 Spec => Text_Line (J - 5 .. J) =
442 SFN_Pragmas.Increment_Last;
444 (SFN_Pragmas.Last) := SFN_Prag;
452 if Save_Last_Pragma_Index = SFN_Pragmas.Last then
453 if Opt.Verbose_Mode then
454 Output.Write_Line (" not a unit");
458 if SFN_Pragmas.Last >
459 Save_Last_Pragma_Index + 1
461 for Index in Save_Last_Pragma_Index + 1 ..
464 SFN_Pragmas.Table (Index).Index :=
465 Int (Index - Save_Last_Pragma_Index);
469 for Index in Save_Last_Pragma_Index + 1 ..
472 SFN_Prag := SFN_Pragmas.Table (Index);
474 if Opt.Verbose_Mode then
475 if SFN_Prag.Spec then
476 Output.Write_Str (" spec of ");
479 Output.Write_Str (" body of ");
483 (Get_Name_String (SFN_Prag.Unit));
488 -- Add the corresponding attribute in the
489 -- Naming package of the naming project.
492 Decl_Item : constant Project_Node_Id :=
498 Attribute : constant Project_Node_Id :=
501 N_Attribute_Declaration,
504 Expression : constant Project_Node_Id :=
506 (Of_Kind => N_Expression,
507 And_Expr_Kind => Single,
510 Term : constant Project_Node_Id :=
513 And_Expr_Kind => Single,
516 Value : constant Project_Node_Id :=
518 (Of_Kind => N_Literal_String,
519 And_Expr_Kind => Single,
523 Set_Next_Declarative_Item
525 To => First_Declarative_Item_Of
526 (Naming_Package, Tree),
528 Set_First_Declarative_Item_Of
532 Set_Current_Item_Node
537 -- Is it a spec or a body?
539 if SFN_Prag.Spec then
549 -- Get the name of the unit
551 Get_Name_String (SFN_Prag.Unit);
552 To_Lower (Name_Buffer (1 .. Name_Len));
553 Set_Associative_Array_Index_Of
554 (Attribute, Tree, To => Name_Find);
557 (Attribute, Tree, To => Expression);
559 (Expression, Tree, To => Term);
561 (Term, Tree, To => Value);
563 -- And set the name of the file
566 (Value, Tree, To => File_Name_Id);
568 (Value, Tree, To => SFN_Prag.Index);
574 -- Add source file name to source list
578 Str (Last) := ASCII.LF;
580 if Write (Source_List_FD,
584 Prj.Com.Fail ("disk full");
591 Delete_File (Temp_File_Name.all, Success);
595 -- File name matches none of the regular expressions
598 -- If file is not excluded, see if this is foreign source
600 if Matched /= Excluded then
601 for Index in Foreign_Expressions'Range loop
602 if Match (Canon (1 .. Last),
603 Foreign_Expressions (Index))
614 Output.Write_Line ("no match");
617 Output.Write_Line ("excluded");
620 Output.Write_Line ("foreign source");
624 if Project_File and Matched = True then
626 -- Add source file name to source list file
629 Str (Last) := ASCII.LF;
631 if Write (Source_List_FD,
635 Prj.Com.Fail ("disk full");
645 -- If Recursively is True, call itself for each subdirectory.
646 -- We do that, even when this directory has already been processed,
647 -- because all of its subdirectories may not have been processed.
650 Open (Dir, Dir_Name);
653 Read (Dir, Str, Last);
656 -- Do not call itself for "." or ".."
659 (Dir_Name & Directory_Separator & Str (1 .. Last))
660 and then Str (1 .. Last) /= "."
661 and then Str (1 .. Last) /= ".."
664 (Dir_Name & Directory_Separator & Str (1 .. Last),
665 Recursively => True);
671 end Process_Directory;
673 -- Start of processing for Make
676 -- Do some needed initializations
681 Prj.Initialize (No_Project_Tree);
682 Prj.Tree.Initialize (Tree);
684 SFN_Pragmas.Set_Last (0);
686 Processed_Directories.Set_Last (0);
688 -- Initialize the compiler switches
690 Args (1) := new String'("-c");
691 Args (2) := new String'("-gnats");
692 Args (3) := new String'("-gnatu");
693 Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches;
694 Args (4 + Preproc_Switches'Length) := new String'("-x");
695 Args (5 + Preproc_Switches'Length) := new String'("ada");
697 -- Get the path and file names
699 if File_Names_Case_Sensitive then
700 Path_Name (1 .. Path_Last) := File_Path;
702 Path_Name (1 .. Path_Last) := To_Lower (File_Path);
705 Path_Name (Path_Last + 1 .. Path_Name'Last) :=
706 Project_File_Extension;
708 -- Get the end of directory information, if any
710 for Index in reverse 1 .. Path_Last loop
711 if Path_Name (Index) = Directory_Separator then
712 Directory_Last := Index;
718 if Path_Last < Project_File_Extension'Length + 1
720 (Path_Last - Project_File_Extension'Length + 1 .. Path_Last)
721 /= Project_File_Extension
723 Path_Last := Path_Name'Last;
726 Output_Name (1 .. Path_Last) := To_Lower (Path_Name (1 .. Path_Last));
727 Output_Name_Last := Path_Last - Project_File_Extension'Length;
729 -- If there is already a project file with the specified name, parse
730 -- it to get the components that are not automatically generated.
732 if Is_Regular_File (Output_Name (1 .. Path_Last)) then
733 if Opt.Verbose_Mode then
734 Output.Write_Str ("Parsing already existing project file """);
735 Output.Write_Str (Output_Name (1 .. Output_Name_Last));
736 Output.Write_Line ("""");
741 Project => Project_Node,
742 Project_File_Name => Output_Name (1 .. Output_Name_Last),
743 Always_Errout_Finalize => False,
744 Store_Comments => True,
745 Packages_To_Check => Packages_To_Check_By_Gnatname);
747 -- Fail if parsing was not successful
749 if Project_Node = Empty_Node then
750 Fail ("parsing of existing project file failed");
753 -- If parsing was successful, remove the components that are
754 -- automatically generated, if any, so that they will be
755 -- unconditionally added later.
757 -- Remove the with clause for the naming project file
760 With_Clause : Project_Node_Id :=
761 First_With_Clause_Of (Project_Node, Tree);
762 Previous : Project_Node_Id := Empty_Node;
765 while With_Clause /= Empty_Node loop
766 if Prj.Tree.Name_Of (With_Clause, Tree) =
769 if Previous = Empty_Node then
770 Set_First_With_Clause_Of
772 To => Next_With_Clause_Of (With_Clause, Tree));
774 Set_Next_With_Clause_Of
776 To => Next_With_Clause_Of (With_Clause, Tree));
782 Previous := With_Clause;
783 With_Clause := Next_With_Clause_Of (With_Clause, Tree);
787 -- Remove attribute declarations of Source_Files,
788 -- Source_List_File, Source_Dirs, and the declaration of
789 -- package Naming, if they exist, but preserve the comments
790 -- attached to these nodes.
793 Declaration : Project_Node_Id :=
794 First_Declarative_Item_Of
795 (Project_Declaration_Of
796 (Project_Node, Tree),
798 Previous : Project_Node_Id := Empty_Node;
799 Current_Node : Project_Node_Id := Empty_Node;
802 Kind_Of_Node : Project_Node_Kind;
803 Comments : Project_Node_Id;
806 while Declaration /= Empty_Node loop
807 Current_Node := Current_Item_Node (Declaration, Tree);
809 Kind_Of_Node := Kind_Of (Current_Node, Tree);
811 if Kind_Of_Node = N_Attribute_Declaration or else
812 Kind_Of_Node = N_Package_Declaration
814 Name := Prj.Tree.Name_Of (Current_Node, Tree);
816 if Name = Name_Source_Files or else
817 Name = Name_Source_List_File or else
818 Name = Name_Source_Dirs or else
822 Tree.Project_Nodes.Table (Current_Node).Comments;
824 if Name = Name_Source_Files then
825 Source_Files_Comments := Comments;
827 elsif Name = Name_Source_List_File then
828 Source_List_File_Comments := Comments;
830 elsif Name = Name_Source_Dirs then
831 Source_Dirs_Comments := Comments;
833 elsif Name = Name_Naming then
834 Naming_Package_Comments := Comments;
837 if Previous = Empty_Node then
838 Set_First_Declarative_Item_Of
839 (Project_Declaration_Of (Project_Node, Tree),
841 To => Next_Declarative_Item
842 (Declaration, Tree));
845 Set_Next_Declarative_Item
847 To => Next_Declarative_Item
848 (Declaration, Tree));
852 Previous := Declaration;
856 Declaration := Next_Declarative_Item (Declaration, Tree);
862 if Directory_Last /= 0 then
863 Output_Name (1 .. Output_Name_Last - Directory_Last) :=
864 Output_Name (Directory_Last + 1 .. Output_Name_Last);
865 Output_Name_Last := Output_Name_Last - Directory_Last;
868 -- Get the project name id
870 Name_Len := Output_Name_Last;
871 Name_Buffer (1 .. Name_Len) := Output_Name (1 .. Name_Len);
872 Output_Name_Id := Name_Find;
874 -- Create the project naming file name
876 Project_Naming_Last := Output_Name_Last;
877 Project_Naming_File_Name (1 .. Project_Naming_Last) :=
878 Output_Name (1 .. Project_Naming_Last);
879 Project_Naming_File_Name
880 (Project_Naming_Last + 1 ..
881 Project_Naming_Last + Naming_File_Suffix'Length) :=
883 Project_Naming_Last :=
884 Project_Naming_Last + Naming_File_Suffix'Length;
886 -- Get the project naming id
888 Name_Len := Project_Naming_Last;
889 Name_Buffer (1 .. Name_Len) :=
890 Project_Naming_File_Name (1 .. Name_Len);
891 Project_Naming_Id := Name_Find;
893 Project_Naming_File_Name
894 (Project_Naming_Last + 1 ..
895 Project_Naming_Last + Project_File_Extension'Length) :=
896 Project_File_Extension;
897 Project_Naming_Last :=
898 Project_Naming_Last + Project_File_Extension'Length;
900 -- Create the source list file name
902 Source_List_Last := Output_Name_Last;
903 Source_List_Path (1 .. Source_List_Last) :=
904 Output_Name (1 .. Source_List_Last);
906 (Source_List_Last + 1 ..
907 Source_List_Last + Source_List_File_Suffix'Length) :=
908 Source_List_File_Suffix;
909 Source_List_Last := Source_List_Last + Source_List_File_Suffix'Length;
911 -- Add the project file extension to the project name
914 (Output_Name_Last + 1 ..
915 Output_Name_Last + Project_File_Extension'Length) :=
916 Project_File_Extension;
917 Output_Name_Last := Output_Name_Last + Project_File_Extension'Length;
920 -- Change the current directory to the directory of the project file,
921 -- if any directory information is specified.
923 if Directory_Last /= 0 then
925 Change_Dir (Path_Name (1 .. Directory_Last));
927 when Directory_Error =>
929 ("unknown directory """,
930 Path_Name (1 .. Directory_Last),
937 -- Delete the source list file, if it already exists
943 (Source_List_Path (1 .. Source_List_Last),
947 -- And create a new source list file.
948 -- Fail if file cannot be created.
950 Source_List_FD := Create_New_File
951 (Name => Source_List_Path (1 .. Source_List_Last),
954 if Source_List_FD = Invalid_FD then
956 ("cannot create file """,
957 Source_List_Path (1 .. Source_List_Last),
962 -- Compile the regular expressions. Fails immediately if any of
963 -- the specified strings is in error.
965 for Index in Excluded_Expressions'Range loop
967 Output.Write_Str ("Excluded pattern: """);
968 Output.Write_Str (Excluded_Patterns (Index).all);
969 Output.Write_Line ("""");
973 Excluded_Expressions (Index) :=
974 Compile (Pattern => Excluded_Patterns (Index).all, Glob => True);
976 when Error_In_Regexp =>
978 ("invalid regular expression """,
979 Excluded_Patterns (Index).all,
984 for Index in Foreign_Expressions'Range loop
986 Output.Write_Str ("Foreign pattern: """);
987 Output.Write_Str (Foreign_Patterns (Index).all);
988 Output.Write_Line ("""");
992 Foreign_Expressions (Index) :=
993 Compile (Pattern => Foreign_Patterns (Index).all, Glob => True);
995 when Error_In_Regexp =>
997 ("invalid regular expression """,
998 Foreign_Patterns (Index).all,
1003 for Index in Regular_Expressions'Range loop
1004 if Very_Verbose then
1005 Output.Write_Str ("Pattern: """);
1006 Output.Write_Str (Name_Patterns (Index).all);
1007 Output.Write_Line ("""");
1011 Regular_Expressions (Index) :=
1012 Compile (Pattern => Name_Patterns (Index).all, Glob => True);
1015 when Error_In_Regexp =>
1017 ("invalid regular expression """,
1018 Name_Patterns (Index).all,
1023 if Project_File then
1024 if Opt.Verbose_Mode then
1025 Output.Write_Str ("Naming project file name is """);
1027 (Project_Naming_File_Name (1 .. Project_Naming_Last));
1028 Output.Write_Line ("""");
1031 -- If there were no already existing project file, or if the parsing
1032 -- was unsuccessful, create an empty project node with the correct
1033 -- name and its project declaration node.
1035 if Project_Node = Empty_Node then
1037 Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree);
1038 Set_Name_Of (Project_Node, Tree, To => Output_Name_Id);
1039 Set_Project_Declaration_Of
1040 (Project_Node, Tree,
1041 To => Default_Project_Node
1042 (Of_Kind => N_Project_Declaration, In_Tree => Tree));
1046 -- Create the naming project node, and add an attribute declaration
1047 -- for Source_Files as an empty list, to indicate there are no
1048 -- sources in the naming project.
1050 Project_Naming_Node :=
1051 Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree);
1052 Set_Name_Of (Project_Naming_Node, Tree, To => Project_Naming_Id);
1053 Project_Naming_Decl :=
1054 Default_Project_Node
1055 (Of_Kind => N_Project_Declaration, In_Tree => Tree);
1056 Set_Project_Declaration_Of
1057 (Project_Naming_Node, Tree, Project_Naming_Decl);
1059 Default_Project_Node
1060 (Of_Kind => N_Package_Declaration, In_Tree => Tree);
1061 Set_Name_Of (Naming_Package, Tree, To => Name_Naming);
1064 Decl_Item : constant Project_Node_Id :=
1065 Default_Project_Node
1066 (Of_Kind => N_Declarative_Item, In_Tree => Tree);
1068 Attribute : constant Project_Node_Id :=
1069 Default_Project_Node
1070 (Of_Kind => N_Attribute_Declaration,
1072 And_Expr_Kind => List);
1074 Expression : constant Project_Node_Id :=
1075 Default_Project_Node
1076 (Of_Kind => N_Expression,
1078 And_Expr_Kind => List);
1080 Term : constant Project_Node_Id :=
1081 Default_Project_Node
1084 And_Expr_Kind => List);
1086 Empty_List : constant Project_Node_Id :=
1087 Default_Project_Node
1088 (Of_Kind => N_Literal_String_List,
1092 Set_First_Declarative_Item_Of
1093 (Project_Naming_Decl, Tree, To => Decl_Item);
1094 Set_Next_Declarative_Item (Decl_Item, Tree, Naming_Package);
1095 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
1096 Set_Name_Of (Attribute, Tree, To => Name_Source_Files);
1097 Set_Expression_Of (Attribute, Tree, To => Expression);
1098 Set_First_Term (Expression, Tree, To => Term);
1099 Set_Current_Term (Term, Tree, To => Empty_List);
1102 -- Add a with clause on the naming project in the main project, if
1103 -- there is not already one.
1106 With_Clause : Project_Node_Id :=
1107 First_With_Clause_Of (Project_Node, Tree);
1110 while With_Clause /= Empty_Node loop
1112 Prj.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id;
1113 With_Clause := Next_With_Clause_Of (With_Clause, Tree);
1116 if With_Clause = Empty_Node then
1117 With_Clause := Default_Project_Node
1118 (Of_Kind => N_With_Clause, In_Tree => Tree);
1119 Set_Next_With_Clause_Of
1121 To => First_With_Clause_Of (Project_Node, Tree));
1122 Set_First_With_Clause_Of
1123 (Project_Node, Tree, To => With_Clause);
1124 Set_Name_Of (With_Clause, Tree, To => Project_Naming_Id);
1126 -- We set the project node to something different than
1127 -- Empty_Node, so that Prj.PP does not generate a limited
1130 Set_Project_Node_Of (With_Clause, Tree, Non_Empty_Node);
1132 Name_Len := Project_Naming_Last;
1133 Name_Buffer (1 .. Name_Len) :=
1134 Project_Naming_File_Name (1 .. Project_Naming_Last);
1135 Set_String_Value_Of (With_Clause, Tree, To => Name_Find);
1139 Project_Declaration := Project_Declaration_Of (Project_Node, Tree);
1141 -- Add a renaming declaration for package Naming in the main project
1144 Decl_Item : constant Project_Node_Id :=
1145 Default_Project_Node
1146 (Of_Kind => N_Declarative_Item,
1149 Naming : constant Project_Node_Id :=
1150 Default_Project_Node
1151 (Of_Kind => N_Package_Declaration,
1155 Set_Next_Declarative_Item
1157 To => First_Declarative_Item_Of (Project_Declaration, Tree));
1158 Set_First_Declarative_Item_Of
1159 (Project_Declaration, Tree, To => Decl_Item);
1160 Set_Current_Item_Node (Decl_Item, Tree, To => Naming);
1161 Set_Name_Of (Naming, Tree, To => Name_Naming);
1162 Set_Project_Of_Renamed_Package_Of
1163 (Naming, Tree, To => Project_Naming_Node);
1165 -- Attach the comments, if any, that were saved for package
1168 Tree.Project_Nodes.Table (Naming).Comments :=
1169 Naming_Package_Comments;
1172 -- Add an attribute declaration for Source_Dirs, initialized as an
1173 -- empty list. Directories will be added as they are read from the
1174 -- directory list file.
1177 Decl_Item : constant Project_Node_Id :=
1178 Default_Project_Node
1179 (Of_Kind => N_Declarative_Item,
1182 Attribute : constant Project_Node_Id :=
1183 Default_Project_Node
1184 (Of_Kind => N_Attribute_Declaration,
1186 And_Expr_Kind => List);
1188 Expression : constant Project_Node_Id :=
1189 Default_Project_Node
1190 (Of_Kind => N_Expression,
1192 And_Expr_Kind => List);
1194 Term : constant Project_Node_Id :=
1195 Default_Project_Node
1196 (Of_Kind => N_Term, In_Tree => Tree,
1197 And_Expr_Kind => List);
1200 Set_Next_Declarative_Item
1202 To => First_Declarative_Item_Of (Project_Declaration, Tree));
1203 Set_First_Declarative_Item_Of
1204 (Project_Declaration, Tree, To => Decl_Item);
1205 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
1206 Set_Name_Of (Attribute, Tree, To => Name_Source_Dirs);
1207 Set_Expression_Of (Attribute, Tree, To => Expression);
1208 Set_First_Term (Expression, Tree, To => Term);
1210 Default_Project_Node
1211 (Of_Kind => N_Literal_String_List,
1213 And_Expr_Kind => List);
1214 Set_Current_Term (Term, Tree, To => Source_Dirs_List);
1216 -- Attach the comments, if any, that were saved for attribute
1219 Tree.Project_Nodes.Table (Attribute).Comments :=
1220 Source_Dirs_Comments;
1223 -- Add an attribute declaration for Source_List_File with the
1224 -- source list file name that will be created.
1227 Decl_Item : constant Project_Node_Id :=
1228 Default_Project_Node
1229 (Of_Kind => N_Declarative_Item,
1232 Attribute : constant Project_Node_Id :=
1233 Default_Project_Node
1234 (Of_Kind => N_Attribute_Declaration,
1236 And_Expr_Kind => Single);
1238 Expression : constant Project_Node_Id :=
1239 Default_Project_Node
1240 (Of_Kind => N_Expression,
1242 And_Expr_Kind => Single);
1244 Term : constant Project_Node_Id :=
1245 Default_Project_Node
1248 And_Expr_Kind => Single);
1250 Value : constant Project_Node_Id :=
1251 Default_Project_Node
1252 (Of_Kind => N_Literal_String,
1254 And_Expr_Kind => Single);
1257 Set_Next_Declarative_Item
1259 To => First_Declarative_Item_Of (Project_Declaration, Tree));
1260 Set_First_Declarative_Item_Of
1261 (Project_Declaration, Tree, To => Decl_Item);
1262 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
1263 Set_Name_Of (Attribute, Tree, To => Name_Source_List_File);
1264 Set_Expression_Of (Attribute, Tree, To => Expression);
1265 Set_First_Term (Expression, Tree, To => Term);
1266 Set_Current_Term (Term, Tree, To => Value);
1267 Name_Len := Source_List_Last;
1268 Name_Buffer (1 .. Name_Len) :=
1269 Source_List_Path (1 .. Source_List_Last);
1270 Set_String_Value_Of (Value, Tree, To => Name_Find);
1272 -- If there was no comments for attribute Source_List_File, put
1273 -- those for Source_Files, if they exist.
1275 if Source_List_File_Comments /= Empty_Node then
1276 Tree.Project_Nodes.Table (Attribute).Comments :=
1277 Source_List_File_Comments;
1279 Tree.Project_Nodes.Table (Attribute).Comments :=
1280 Source_Files_Comments;
1285 -- Process each directory
1287 for Index in Directories'Range loop
1290 Dir_Name : constant String := Directories (Index).all;
1291 Last : Natural := Dir_Name'Last;
1292 Recursively : Boolean := False;
1295 if Dir_Name'Length >= 4
1296 and then (Dir_Name (Last - 2 .. Last) = "/**")
1299 Recursively := True;
1302 if Project_File then
1304 -- Add the directory in the list for attribute Source_Dirs
1307 Expression : constant Project_Node_Id :=
1308 Default_Project_Node
1309 (Of_Kind => N_Expression,
1311 And_Expr_Kind => Single);
1313 Term : constant Project_Node_Id :=
1314 Default_Project_Node
1317 And_Expr_Kind => Single);
1319 Value : constant Project_Node_Id :=
1320 Default_Project_Node
1321 (Of_Kind => N_Literal_String,
1323 And_Expr_Kind => Single);
1326 if Current_Source_Dir = Empty_Node then
1327 Set_First_Expression_In_List
1328 (Source_Dirs_List, Tree, To => Expression);
1330 Set_Next_Expression_In_List
1331 (Current_Source_Dir, Tree, To => Expression);
1334 Current_Source_Dir := Expression;
1335 Set_First_Term (Expression, Tree, To => Term);
1336 Set_Current_Term (Term, Tree, To => Value);
1337 Name_Len := Dir_Name'Length;
1338 Name_Buffer (1 .. Name_Len) := Dir_Name;
1339 Set_String_Value_Of (Value, Tree, To => Name_Find);
1343 Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively);
1348 if Project_File then
1349 Close (Source_List_FD);
1356 -- Delete the file if it already exists
1359 (Path_Name (Directory_Last + 1 .. Path_Last),
1360 Success => Discard);
1364 if Opt.Verbose_Mode then
1365 Output.Write_Str ("Creating new file """);
1366 Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last));
1367 Output.Write_Line ("""");
1370 Output_FD := Create_New_File
1371 (Path_Name (Directory_Last + 1 .. Path_Last),
1374 -- Fails if project file cannot be created
1376 if Output_FD = Invalid_FD then
1378 ("cannot create new """, Path_Name (1 .. Path_Last), """");
1381 if Project_File then
1383 -- Output the project file
1386 (Project_Node, Tree,
1387 W_Char => Write_A_Char'Access,
1388 W_Eol => Write_Eol'Access,
1389 W_Str => Write_A_String'Access,
1390 Backward_Compatibility => False);
1393 -- Delete the naming project file if it already exists
1396 (Project_Naming_File_Name (1 .. Project_Naming_Last),
1397 Success => Discard);
1401 if Opt.Verbose_Mode then
1402 Output.Write_Str ("Creating new naming project file """);
1403 Output.Write_Str (Project_Naming_File_Name
1404 (1 .. Project_Naming_Last));
1405 Output.Write_Line ("""");
1408 Output_FD := Create_New_File
1409 (Project_Naming_File_Name (1 .. Project_Naming_Last),
1412 -- Fails if naming project file cannot be created
1414 if Output_FD = Invalid_FD then
1416 ("cannot create new """,
1417 Project_Naming_File_Name (1 .. Project_Naming_Last),
1421 -- Output the naming project file
1424 (Project_Naming_Node, Tree,
1425 W_Char => Write_A_Char'Access,
1426 W_Eol => Write_Eol'Access,
1427 W_Str => Write_A_String'Access,
1428 Backward_Compatibility => False);
1432 -- Write to the output file each entry in the SFN_Pragmas table
1433 -- as an pragma Source_File_Name.
1435 for Index in 1 .. SFN_Pragmas.Last loop
1436 Write_A_String ("pragma Source_File_Name");
1438 Write_A_String (" (");
1440 (Get_Name_String (SFN_Pragmas.Table (Index).Unit));
1441 Write_A_String (",");
1444 if SFN_Pragmas.Table (Index).Spec then
1445 Write_A_String (" Spec_File_Name => """);
1448 Write_A_String (" Body_File_Name => """);
1452 (Get_Name_String (SFN_Pragmas.Table (Index).File));
1454 Write_A_String ("""");
1456 if SFN_Pragmas.Table (Index).Index /= 0 then
1457 Write_A_String (", Index =>");
1458 Write_A_String (SFN_Pragmas.Table (Index).Index'Img);
1461 Write_A_String (");");
1474 procedure Write_A_Char (C : Character) is
1476 Write_A_String ((1 => C));
1483 procedure Write_Eol is
1485 Write_A_String ((1 => ASCII.LF));
1488 --------------------
1489 -- Write_A_String --
1490 --------------------
1492 procedure Write_A_String (S : String) is
1493 Str : String (1 .. S'Length);
1496 if S'Length > 0 then
1499 if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then
1500 Prj.Com.Fail ("disk full");