1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2005 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 ------------------------------------------------------------------------------
28 with Namet
; use Namet
;
31 with Osint
; use Osint
;
36 with Prj
.Tree
; use Prj
.Tree
;
37 with Prj
.Util
; use Prj
.Util
;
38 with Snames
; use Snames
;
39 with Table
; use Table
;
41 with Ada
.Characters
.Handling
; use Ada
.Characters
.Handling
;
42 with GNAT
.Directory_Operations
; use GNAT
.Directory_Operations
;
43 with GNAT
.Regexp
; use GNAT
.Regexp
;
45 with System
.Case_Util
; use System
.Case_Util
;
48 package body Prj
.Makr
is
50 function Dup
(Fd
: File_Descriptor
) return File_Descriptor
;
52 procedure Dup2
(Old_Fd
, New_Fd
: File_Descriptor
);
54 Gcc
: constant String := "gcc";
55 Gcc_Path
: String_Access
:= null;
57 Non_Empty_Node
: constant Project_Node_Id
:= 1;
58 -- Used for the With_Clause of the naming project
60 type Matched_Type
is (True, False, Excluded
);
62 Naming_File_Suffix
: constant String := "_naming";
63 Source_List_File_Suffix
: constant String := "_source_list.txt";
65 Output_FD
: File_Descriptor
;
66 -- To save the project file and its naming project file
69 -- Output an empty line
71 procedure Write_A_Char
(C
: Character);
72 -- Write one character to Output_FD
74 procedure Write_A_String
(S
: String);
75 -- Write a String to Output_FD
77 package Processed_Directories
is new Table
.Table
78 (Table_Component_Type
=> String_Access
,
79 Table_Index_Type
=> Natural,
82 Table_Increment
=> 10,
83 Table_Name
=> "Prj.Makr.Processed_Directories");
89 function Dup
(Fd
: File_Descriptor
) return File_Descriptor
is
91 return File_Descriptor
(System
.CRTL
.dup
(Integer (Fd
)));
98 procedure Dup2
(Old_Fd
, New_Fd
: File_Descriptor
) is
100 pragma Warnings
(Off
, Fd
);
102 Fd
:= System
.CRTL
.dup2
(Integer (Old_Fd
), Integer (New_Fd
));
111 Project_File
: Boolean;
112 Directories
: Argument_List
;
113 Name_Patterns
: Argument_List
;
114 Excluded_Patterns
: Argument_List
;
115 Foreign_Patterns
: Argument_List
;
116 Preproc_Switches
: Argument_List
;
117 Very_Verbose
: Boolean)
119 Tree
: constant Project_Node_Tree_Ref
:= new Project_Node_Tree_Data
;
121 Path_Name
: String (1 .. File_Path
'Length +
122 Project_File_Extension
'Length);
123 Path_Last
: Natural := File_Path
'Length;
125 Directory_Last
: Natural := 0;
127 Output_Name
: String (Path_Name
'Range);
128 Output_Name_Last
: Natural;
129 Output_Name_Id
: Name_Id
;
131 Project_Node
: Project_Node_Id
:= Empty_Node
;
132 Project_Declaration
: Project_Node_Id
:= Empty_Node
;
133 Source_Dirs_List
: Project_Node_Id
:= Empty_Node
;
134 Current_Source_Dir
: Project_Node_Id
:= Empty_Node
;
136 Project_Naming_Node
: Project_Node_Id
:= Empty_Node
;
137 Project_Naming_Decl
: Project_Node_Id
:= Empty_Node
;
138 Naming_Package
: Project_Node_Id
:= Empty_Node
;
140 Project_Naming_File_Name
: String (1 .. Output_Name
'Length +
141 Naming_File_Suffix
'Length);
143 Project_Naming_Last
: Natural;
144 Project_Naming_Id
: Name_Id
:= No_Name
;
146 Excluded_Expressions
: array (Excluded_Patterns
'Range) of Regexp
;
147 Regular_Expressions
: array (Name_Patterns
'Range) of Regexp
;
148 Foreign_Expressions
: array (Foreign_Patterns
'Range) of Regexp
;
150 Source_List_Path
: String (1 .. Output_Name
'Length +
151 Source_List_File_Suffix
'Length);
152 Source_List_Last
: Natural;
154 Source_List_FD
: File_Descriptor
;
156 Args
: Argument_List
(1 .. Preproc_Switches
'Length + 6);
158 type SFN_Pragma
is record
165 package SFN_Pragmas
is new Table
.Table
166 (Table_Component_Type
=> SFN_Pragma
,
167 Table_Index_Type
=> Natural,
168 Table_Low_Bound
=> 0,
170 Table_Increment
=> 50,
171 Table_Name
=> "Prj.Makr.SFN_Pragmas");
173 procedure Process_Directory
(Dir_Name
: String; Recursively
: Boolean);
174 -- Look for Ada and foreign sources in a directory, according to the
175 -- patterns. When Recursively is True, after looking for sources in
176 -- Dir_Name, look also in its subdirectories, if any.
178 -----------------------
179 -- Process_Directory --
180 -----------------------
182 procedure Process_Directory
(Dir_Name
: String; Recursively
: Boolean) is
183 Matched
: Matched_Type
:= False;
184 Str
: String (1 .. 2_000
);
185 Canon
: String (1 .. 2_000
);
188 Process
: Boolean := True;
190 Temp_File_Name
: String_Access
:= null;
191 Save_Last_Pragma_Index
: Natural := 0;
192 File_Name_Id
: Name_Id
:= No_Name
;
193 SFN_Prag
: SFN_Pragma
;
196 -- Avoid processing the same directory more than once
198 for Index
in 1 .. Processed_Directories
.Last
loop
199 if Processed_Directories
.Table
(Index
).all = Dir_Name
then
206 if Opt
.Verbose_Mode
then
207 Output
.Write_Str
("Processing directory """);
208 Output
.Write_Str
(Dir_Name
);
209 Output
.Write_Line
("""");
212 Processed_Directories
. Increment_Last
;
213 Processed_Directories
.Table
(Processed_Directories
.Last
) :=
214 new String'(Dir_Name);
216 -- Get the source file names from the directory. Fails if the
217 -- directory does not exist.
220 Open (Dir, Dir_Name);
222 when Directory_Error =>
223 Prj.Com.Fail ("cannot open directory """, Dir_Name, """");
226 -- Process each regular file in the directory
229 Read (Dir, Str, Last);
230 exit File_Loop when Last = 0;
232 -- Copy the file name and put it in canonical case to match
233 -- against the patterns that have themselves already been put
234 -- in canonical case.
236 Canon (1 .. Last) := Str (1 .. Last);
237 Canonical_Case_File_Name (Canon (1 .. Last));
240 (Dir_Name & Directory_Separator & Str (1 .. Last))
245 Name_Buffer (1 .. Name_Len) := Str (1 .. Last);
246 File_Name_Id := Name_Find;
248 -- First, check if the file name matches at least one of
249 -- the excluded expressions;
251 for Index in Excluded_Expressions'Range loop
253 Match (Canon (1 .. Last), Excluded_Expressions (Index))
260 -- If it does not match any of the excluded expressions,
261 -- check if the file name matches at least one of the
262 -- regular expressions.
264 if Matched = True then
267 for Index in Regular_Expressions'Range loop
270 (Canon (1 .. Last), Regular_Expressions (Index))
279 or else (Matched = True and then Opt.Verbose_Mode)
281 Output.Write_Str (" Checking """);
282 Output.Write_Str (Str (1 .. Last));
283 Output.Write_Line (""": ");
286 -- If the file name matches one of the regular expressions,
287 -- parse it to get its unit name.
289 if Matched = True then
291 FD : File_Descriptor;
293 Saved_Output : File_Descriptor;
294 Saved_Error : File_Descriptor;
297 -- If we don't have the path of the compiler yet,
298 -- get it now. The compiler name may have a prefix,
299 -- so we get the potentially prefixed name.
301 if Gcc_Path = null then
303 Prefix_Gcc : String_Access :=
307 Locate_Exec_On_Path (Prefix_Gcc.all);
311 if Gcc_Path = null then
312 Prj.Com.Fail ("could not locate " & Gcc);
316 -- If we don't have yet the file name of the
317 -- temporary file, get it now.
319 if Temp_File_Name = null then
320 Create_Temp_File (FD, Temp_File_Name);
322 if FD = Invalid_FD then
324 ("could not create temporary file");
328 Delete_File (Temp_File_Name.all, Success);
331 Args (Args'Last) := new String'
333 Directory_Separator
&
336 -- Create the temporary file
338 FD
:= Create_Output_Text_File
339 (Name
=> Temp_File_Name
.all);
341 if FD
= Invalid_FD
then
343 ("could not create temporary file");
346 -- Save the standard output and error
348 Saved_Output
:= Dup
(Standout
);
349 Saved_Error
:= Dup
(Standerr
);
351 -- Set standard output and error to the temporary file
356 -- And spawn the compiler
358 Spawn
(Gcc_Path
.all, Args
, Success
);
360 -- Restore the standard output and error
362 Dup2
(Saved_Output
, Standout
);
363 Dup2
(Saved_Error
, Standerr
);
365 -- Close the temporary file
369 -- And close the saved standard output and error to
370 -- avoid too many file descriptors.
372 Close
(Saved_Output
);
375 -- Now that standard output is restored, check if
376 -- the compiler ran correctly.
378 -- Read the lines of the temporary file:
379 -- they should contain the kind and name of the unit.
383 Text_Line
: String (1 .. 1_000
);
387 Open
(File
, Temp_File_Name
.all);
389 if not Is_Valid
(File
) then
391 ("could not read temporary file");
394 Save_Last_Pragma_Index
:= SFN_Pragmas
.Last
;
396 if End_Of_File
(File
) then
397 if Opt
.Verbose_Mode
then
399 Output
.Write_Str
(" (process died) ");
404 Line_Loop
: while not End_Of_File
(File
) loop
405 Get_Line
(File
, Text_Line
, Text_Last
);
407 -- Find the first closing parenthesis
409 Char_Loop
: for J
in 1 .. Text_Last
loop
410 if Text_Line
(J
) = ')' then
412 Text_Line
(1 .. 4) = "Unit"
414 -- Add entry to SFN_Pragmas table
417 Name_Buffer
(1 .. Name_Len
) :=
418 Text_Line
(6 .. J
- 7);
421 File
=> File_Name_Id
,
423 Spec
=> Text_Line
(J
- 5 .. J
) =
426 SFN_Pragmas
.Increment_Last
;
428 (SFN_Pragmas
.Last
) := SFN_Prag
;
436 if Save_Last_Pragma_Index
= SFN_Pragmas
.Last
then
437 if Opt
.Verbose_Mode
then
438 Output
.Write_Line
(" not a unit");
442 if SFN_Pragmas
.Last
>
443 Save_Last_Pragma_Index
+ 1
445 for Index
in Save_Last_Pragma_Index
+ 1 ..
448 SFN_Pragmas
.Table
(Index
).Index
:=
449 Int
(Index
- Save_Last_Pragma_Index
);
453 for Index
in Save_Last_Pragma_Index
+ 1 ..
456 SFN_Prag
:= SFN_Pragmas
.Table
(Index
);
458 if Opt
.Verbose_Mode
then
459 if SFN_Prag
.Spec
then
460 Output
.Write_Str
(" spec of ");
463 Output
.Write_Str
(" body of ");
467 (Get_Name_String
(SFN_Prag
.Unit
));
472 -- Add the corresponding attribute in the
473 -- Naming package of the naming project.
476 Decl_Item
: constant Project_Node_Id
:=
482 Attribute
: constant Project_Node_Id
:=
485 N_Attribute_Declaration
,
488 Expression
: constant Project_Node_Id
:=
490 (Of_Kind
=> N_Expression
,
491 And_Expr_Kind
=> Single
,
494 Term
: constant Project_Node_Id
:=
497 And_Expr_Kind
=> Single
,
500 Value
: constant Project_Node_Id
:=
502 (Of_Kind
=> N_Literal_String
,
503 And_Expr_Kind
=> Single
,
507 Set_Next_Declarative_Item
509 To
=> First_Declarative_Item_Of
510 (Naming_Package
, Tree
),
512 Set_First_Declarative_Item_Of
516 Set_Current_Item_Node
521 -- Is it a spec or a body?
523 if SFN_Prag
.Spec
then
533 -- Get the name of the unit
535 Get_Name_String
(SFN_Prag
.Unit
);
536 To_Lower
(Name_Buffer
(1 .. Name_Len
));
537 Set_Associative_Array_Index_Of
538 (Attribute
, Tree
, To
=> Name_Find
);
541 (Attribute
, Tree
, To
=> Expression
);
543 (Expression
, Tree
, To
=> Term
);
545 (Term
, Tree
, To
=> Value
);
547 -- And set the name of the file
550 (Value
, Tree
, To
=> File_Name_Id
);
552 (Value
, Tree
, To
=> SFN_Prag
.Index
);
558 -- Add source file name to source list
562 Str
(Last
) := ASCII
.LF
;
564 if Write
(Source_List_FD
,
568 Prj
.Com
.Fail
("disk full");
575 Delete_File
(Temp_File_Name
.all, Success
);
579 -- File name matches none of the regular expressions
582 -- If file is not excluded, see if this is foreign source
584 if Matched
/= Excluded
then
585 for Index
in Foreign_Expressions
'Range loop
586 if Match
(Canon
(1 .. Last
),
587 Foreign_Expressions
(Index
))
598 Output
.Write_Line
("no match");
601 Output
.Write_Line
("excluded");
604 Output
.Write_Line
("foreign source");
608 if Project_File
and Matched
= True then
610 -- Add source file name to source list file
613 Str
(Last
) := ASCII
.LF
;
615 if Write
(Source_List_FD
,
619 Prj
.Com
.Fail
("disk full");
629 -- If Recursively is True, call itself for each subdirectory.
630 -- We do that, even when this directory has already been processed,
631 -- because all of its subdirectories may not have been processed.
634 Open
(Dir
, Dir_Name
);
637 Read
(Dir
, Str
, Last
);
640 -- Do not call itself for "." or ".."
643 (Dir_Name
& Directory_Separator
& Str
(1 .. Last
))
644 and then Str
(1 .. Last
) /= "."
645 and then Str
(1 .. Last
) /= ".."
648 (Dir_Name
& Directory_Separator
& Str
(1 .. Last
),
649 Recursively
=> True);
655 end Process_Directory
;
657 -- Start of processing for Make
660 -- Do some needed initializations
665 Prj
.Initialize
(No_Project_Tree
);
666 Prj
.Tree
.Initialize
(Tree
);
668 SFN_Pragmas
.Set_Last
(0);
670 Processed_Directories
.Set_Last
(0);
672 -- Initialize the compiler switches
674 Args
(1) := new String'("-c");
675 Args (2) := new String'("-gnats");
676 Args
(3) := new String'("-gnatu");
677 Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches;
678 Args (4 + Preproc_Switches'Length) := new String'("-x");
679 Args
(5 + Preproc_Switches
'Length) := new String'("ada");
681 -- Get the path and file names
683 if File_Names_Case_Sensitive then
684 Path_Name (1 .. Path_Last) := File_Path;
686 Path_Name (1 .. Path_Last) := To_Lower (File_Path);
689 Path_Name (Path_Last + 1 .. Path_Name'Last) :=
690 Project_File_Extension;
692 -- Get the end of directory information, if any
694 for Index in reverse 1 .. Path_Last loop
695 if Path_Name (Index) = Directory_Separator then
696 Directory_Last := Index;
702 if Path_Last < Project_File_Extension'Length + 1
704 (Path_Last - Project_File_Extension'Length + 1 .. Path_Last)
705 /= Project_File_Extension
707 Path_Last := Path_Name'Last;
710 Output_Name (1 .. Path_Last) := To_Lower (Path_Name (1 .. Path_Last));
711 Output_Name_Last := Path_Last - Project_File_Extension'Length;
713 -- If there is already a project file with the specified name, parse
714 -- it to get the components that are not automatically generated.
716 if Is_Regular_File (Output_Name (1 .. Path_Last)) then
717 if Opt.Verbose_Mode then
718 Output.Write_Str ("Parsing already existing project file """);
719 Output.Write_Str (Output_Name (1 .. Output_Name_Last));
720 Output.Write_Line ("""");
725 Project => Project_Node,
726 Project_File_Name => Output_Name (1 .. Output_Name_Last),
727 Always_Errout_Finalize => False);
729 -- Fail if parsing was not successful
731 if Project_Node = Empty_Node then
732 Fail ("parsing of existing project file failed");
735 -- If parsing was successful, remove the components that are
736 -- automatically generated, if any, so that they will be
737 -- unconditionally added later.
739 -- Remove the with clause for the naming project file
742 With_Clause : Project_Node_Id :=
743 First_With_Clause_Of (Project_Node, Tree);
744 Previous : Project_Node_Id := Empty_Node;
747 while With_Clause /= Empty_Node loop
748 if Prj.Tree.Name_Of (With_Clause, Tree) =
751 if Previous = Empty_Node then
752 Set_First_With_Clause_Of
754 To => Next_With_Clause_Of (With_Clause, Tree));
756 Set_Next_With_Clause_Of
758 To => Next_With_Clause_Of (With_Clause, Tree));
764 Previous := With_Clause;
765 With_Clause := Next_With_Clause_Of (With_Clause, Tree);
769 -- Remove attribute declarations of Source_Files,
770 -- Source_List_File, Source_Dirs, and the declaration of
771 -- package Naming, if they exist.
774 Declaration : Project_Node_Id :=
775 First_Declarative_Item_Of
776 (Project_Declaration_Of
777 (Project_Node, Tree),
779 Previous : Project_Node_Id := Empty_Node;
780 Current_Node : Project_Node_Id := Empty_Node;
783 while Declaration /= Empty_Node loop
784 Current_Node := Current_Item_Node (Declaration, Tree);
786 if (Kind_Of (Current_Node, Tree) = N_Attribute_Declaration
788 (Prj.Tree.Name_Of (Current_Node, Tree) =
790 or else Prj.Tree.Name_Of (Current_Node, Tree) =
791 Name_Source_List_File
792 or else Prj.Tree.Name_Of (Current_Node, Tree) =
795 (Kind_Of (Current_Node, Tree) = N_Package_Declaration
796 and then Prj.Tree.Name_Of (Current_Node, Tree) =
799 if Previous = Empty_Node then
800 Set_First_Declarative_Item_Of
801 (Project_Declaration_Of (Project_Node, Tree),
803 To => Next_Declarative_Item (Declaration, Tree));
806 Set_Next_Declarative_Item
808 To => Next_Declarative_Item (Declaration, Tree));
812 Previous := Declaration;
815 Declaration := Next_Declarative_Item (Declaration, Tree);
821 if Directory_Last /= 0 then
822 Output_Name (1 .. Output_Name_Last - Directory_Last) :=
823 Output_Name (Directory_Last + 1 .. Output_Name_Last);
824 Output_Name_Last := Output_Name_Last - Directory_Last;
827 -- Get the project name id
829 Name_Len := Output_Name_Last;
830 Name_Buffer (1 .. Name_Len) := Output_Name (1 .. Name_Len);
831 Output_Name_Id := Name_Find;
833 -- Create the project naming file name
835 Project_Naming_Last := Output_Name_Last;
836 Project_Naming_File_Name (1 .. Project_Naming_Last) :=
837 Output_Name (1 .. Project_Naming_Last);
838 Project_Naming_File_Name
839 (Project_Naming_Last + 1 ..
840 Project_Naming_Last + Naming_File_Suffix'Length) :=
842 Project_Naming_Last :=
843 Project_Naming_Last + Naming_File_Suffix'Length;
845 -- Get the project naming id
847 Name_Len := Project_Naming_Last;
848 Name_Buffer (1 .. Name_Len) :=
849 Project_Naming_File_Name (1 .. Name_Len);
850 Project_Naming_Id := Name_Find;
852 Project_Naming_File_Name
853 (Project_Naming_Last + 1 ..
854 Project_Naming_Last + Project_File_Extension'Length) :=
855 Project_File_Extension;
856 Project_Naming_Last :=
857 Project_Naming_Last + Project_File_Extension'Length;
859 -- Create the source list file name
861 Source_List_Last := Output_Name_Last;
862 Source_List_Path (1 .. Source_List_Last) :=
863 Output_Name (1 .. Source_List_Last);
865 (Source_List_Last + 1 ..
866 Source_List_Last + Source_List_File_Suffix'Length) :=
867 Source_List_File_Suffix;
868 Source_List_Last := Source_List_Last + Source_List_File_Suffix'Length;
870 -- Add the project file extension to the project name
873 (Output_Name_Last + 1 ..
874 Output_Name_Last + Project_File_Extension'Length) :=
875 Project_File_Extension;
876 Output_Name_Last := Output_Name_Last + Project_File_Extension'Length;
879 -- Change the current directory to the directory of the project file,
880 -- if any directory information is specified.
882 if Directory_Last /= 0 then
884 Change_Dir (Path_Name (1 .. Directory_Last));
886 when Directory_Error =>
888 ("unknown directory """,
889 Path_Name (1 .. Directory_Last),
896 -- Delete the source list file, if it already exists
902 (Source_List_Path (1 .. Source_List_Last),
906 -- And create a new source list file.
907 -- Fail if file cannot be created.
909 Source_List_FD := Create_New_File
910 (Name => Source_List_Path (1 .. Source_List_Last),
913 if Source_List_FD = Invalid_FD then
915 ("cannot create file """,
916 Source_List_Path (1 .. Source_List_Last),
921 -- Compile the regular expressions. Fails immediately if any of
922 -- the specified strings is in error.
924 for Index in Excluded_Expressions'Range loop
926 Output.Write_Str ("Excluded pattern: """);
927 Output.Write_Str (Excluded_Patterns (Index).all);
928 Output.Write_Line ("""");
932 Excluded_Expressions (Index) :=
933 Compile (Pattern => Excluded_Patterns (Index).all, Glob => True);
935 when Error_In_Regexp =>
937 ("invalid regular expression """,
938 Excluded_Patterns (Index).all,
943 for Index in Foreign_Expressions'Range loop
945 Output.Write_Str ("Foreign pattern: """);
946 Output.Write_Str (Foreign_Patterns (Index).all);
947 Output.Write_Line ("""");
951 Foreign_Expressions (Index) :=
952 Compile (Pattern => Foreign_Patterns (Index).all, Glob => True);
954 when Error_In_Regexp =>
956 ("invalid regular expression """,
957 Foreign_Patterns (Index).all,
962 for Index in Regular_Expressions'Range loop
964 Output.Write_Str ("Pattern: """);
965 Output.Write_Str (Name_Patterns (Index).all);
966 Output.Write_Line ("""");
970 Regular_Expressions (Index) :=
971 Compile (Pattern => Name_Patterns (Index).all, Glob => True);
974 when Error_In_Regexp =>
976 ("invalid regular expression """,
977 Name_Patterns (Index).all,
983 if Opt.Verbose_Mode then
984 Output.Write_Str ("Naming project file name is """);
986 (Project_Naming_File_Name (1 .. Project_Naming_Last));
987 Output.Write_Line ("""");
990 -- If there were no already existing project file, or if the parsing
991 -- was unsuccessful, create an empty project node with the correct
992 -- name and its project declaration node.
994 if Project_Node = Empty_Node then
996 Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree);
997 Set_Name_Of (Project_Node, Tree, To => Output_Name_Id);
998 Set_Project_Declaration_Of
1000 To => Default_Project_Node
1001 (Of_Kind => N_Project_Declaration, In_Tree => Tree));
1005 -- Create the naming project node, and add an attribute declaration
1006 -- for Source_Files as an empty list, to indicate there are no
1007 -- sources in the naming project.
1009 Project_Naming_Node :=
1010 Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree);
1011 Set_Name_Of (Project_Naming_Node, Tree, To => Project_Naming_Id);
1012 Project_Naming_Decl :=
1013 Default_Project_Node
1014 (Of_Kind => N_Project_Declaration, In_Tree => Tree);
1015 Set_Project_Declaration_Of
1016 (Project_Naming_Node, Tree, Project_Naming_Decl);
1018 Default_Project_Node
1019 (Of_Kind => N_Package_Declaration, In_Tree => Tree);
1020 Set_Name_Of (Naming_Package, Tree, To => Name_Naming);
1023 Decl_Item : constant Project_Node_Id :=
1024 Default_Project_Node
1025 (Of_Kind => N_Declarative_Item, In_Tree => Tree);
1027 Attribute : constant Project_Node_Id :=
1028 Default_Project_Node
1029 (Of_Kind => N_Attribute_Declaration,
1031 And_Expr_Kind => List);
1033 Expression : constant Project_Node_Id :=
1034 Default_Project_Node
1035 (Of_Kind => N_Expression,
1037 And_Expr_Kind => List);
1039 Term : constant Project_Node_Id :=
1040 Default_Project_Node
1043 And_Expr_Kind => List);
1045 Empty_List : constant Project_Node_Id :=
1046 Default_Project_Node
1047 (Of_Kind => N_Literal_String_List,
1051 Set_First_Declarative_Item_Of
1052 (Project_Naming_Decl, Tree, To => Decl_Item);
1053 Set_Next_Declarative_Item (Decl_Item, Tree, Naming_Package);
1054 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
1055 Set_Name_Of (Attribute, Tree, To => Name_Source_Files);
1056 Set_Expression_Of (Attribute, Tree, To => Expression);
1057 Set_First_Term (Expression, Tree, To => Term);
1058 Set_Current_Term (Term, Tree, To => Empty_List);
1061 -- Add a with clause on the naming project in the main project
1064 With_Clause : constant Project_Node_Id :=
1065 Default_Project_Node
1066 (Of_Kind => N_With_Clause, In_Tree => Tree);
1069 Set_Next_With_Clause_Of
1071 To => First_With_Clause_Of (Project_Node, Tree));
1072 Set_First_With_Clause_Of (Project_Node, Tree, To => With_Clause);
1073 Set_Name_Of (With_Clause, Tree, To => Project_Naming_Id);
1075 -- We set the project node to something different than
1076 -- Empty_Node, so that Prj.PP does not generate a limited
1079 Set_Project_Node_Of (With_Clause, Tree, Non_Empty_Node);
1081 Name_Len := Project_Naming_Last;
1082 Name_Buffer (1 .. Name_Len) :=
1083 Project_Naming_File_Name (1 .. Project_Naming_Last);
1084 Set_String_Value_Of (With_Clause, Tree, To => Name_Find);
1087 Project_Declaration := Project_Declaration_Of (Project_Node, Tree);
1089 -- Add a renaming declaration for package Naming in the main project
1092 Decl_Item : constant Project_Node_Id :=
1093 Default_Project_Node
1094 (Of_Kind => N_Declarative_Item,
1097 Naming : constant Project_Node_Id :=
1098 Default_Project_Node
1099 (Of_Kind => N_Package_Declaration,
1103 Set_Next_Declarative_Item
1105 To => First_Declarative_Item_Of (Project_Declaration, Tree));
1106 Set_First_Declarative_Item_Of
1107 (Project_Declaration, Tree, To => Decl_Item);
1108 Set_Current_Item_Node (Decl_Item, Tree, To => Naming);
1109 Set_Name_Of (Naming, Tree, To => Name_Naming);
1110 Set_Project_Of_Renamed_Package_Of
1111 (Naming, Tree, To => Project_Naming_Node);
1114 -- Add an attribute declaration for Source_Dirs, initialized as an
1115 -- empty list. Directories will be added as they are read from the
1116 -- directory list file.
1119 Decl_Item : constant Project_Node_Id :=
1120 Default_Project_Node
1121 (Of_Kind => N_Declarative_Item,
1124 Attribute : constant Project_Node_Id :=
1125 Default_Project_Node
1126 (Of_Kind => N_Attribute_Declaration,
1128 And_Expr_Kind => List);
1130 Expression : constant Project_Node_Id :=
1131 Default_Project_Node
1132 (Of_Kind => N_Expression,
1134 And_Expr_Kind => List);
1136 Term : constant Project_Node_Id :=
1137 Default_Project_Node
1138 (Of_Kind => N_Term, In_Tree => Tree,
1139 And_Expr_Kind => List);
1142 Set_Next_Declarative_Item
1144 To => First_Declarative_Item_Of (Project_Declaration, Tree));
1145 Set_First_Declarative_Item_Of
1146 (Project_Declaration, Tree, To => Decl_Item);
1147 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
1148 Set_Name_Of (Attribute, Tree, To => Name_Source_Dirs);
1149 Set_Expression_Of (Attribute, Tree, To => Expression);
1150 Set_First_Term (Expression, Tree, To => Term);
1152 Default_Project_Node
1153 (Of_Kind => N_Literal_String_List,
1155 And_Expr_Kind => List);
1156 Set_Current_Term (Term, Tree, To => Source_Dirs_List);
1159 -- Add an attribute declaration for Source_List_File with the
1160 -- source list file name that will be created.
1163 Decl_Item : constant Project_Node_Id :=
1164 Default_Project_Node
1165 (Of_Kind => N_Declarative_Item,
1168 Attribute : constant Project_Node_Id :=
1169 Default_Project_Node
1170 (Of_Kind => N_Attribute_Declaration,
1172 And_Expr_Kind => Single);
1174 Expression : constant Project_Node_Id :=
1175 Default_Project_Node
1176 (Of_Kind => N_Expression,
1178 And_Expr_Kind => Single);
1180 Term : constant Project_Node_Id :=
1181 Default_Project_Node
1184 And_Expr_Kind => Single);
1186 Value : constant Project_Node_Id :=
1187 Default_Project_Node
1188 (Of_Kind => N_Literal_String,
1190 And_Expr_Kind => Single);
1193 Set_Next_Declarative_Item
1195 To => First_Declarative_Item_Of (Project_Declaration, Tree));
1196 Set_First_Declarative_Item_Of
1197 (Project_Declaration, Tree, To => Decl_Item);
1198 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
1199 Set_Name_Of (Attribute, Tree, To => Name_Source_List_File);
1200 Set_Expression_Of (Attribute, Tree, To => Expression);
1201 Set_First_Term (Expression, Tree, To => Term);
1202 Set_Current_Term (Term, Tree, To => Value);
1203 Name_Len := Source_List_Last;
1204 Name_Buffer (1 .. Name_Len) :=
1205 Source_List_Path (1 .. Source_List_Last);
1206 Set_String_Value_Of (Value, Tree, To => Name_Find);
1210 -- Process each directory
1212 for Index in Directories'Range loop
1215 Dir_Name : constant String := Directories (Index).all;
1216 Last : Natural := Dir_Name'Last;
1217 Recursively : Boolean := False;
1220 if Dir_Name'Length >= 4
1221 and then (Dir_Name (Last - 2 .. Last) = "/**")
1224 Recursively := True;
1227 if Project_File then
1229 -- Add the directory in the list for attribute Source_Dirs
1232 Expression : constant Project_Node_Id :=
1233 Default_Project_Node
1234 (Of_Kind => N_Expression,
1236 And_Expr_Kind => Single);
1238 Term : constant Project_Node_Id :=
1239 Default_Project_Node
1242 And_Expr_Kind => Single);
1244 Value : constant Project_Node_Id :=
1245 Default_Project_Node
1246 (Of_Kind => N_Literal_String,
1248 And_Expr_Kind => Single);
1251 if Current_Source_Dir = Empty_Node then
1252 Set_First_Expression_In_List
1253 (Source_Dirs_List, Tree, To => Expression);
1255 Set_Next_Expression_In_List
1256 (Current_Source_Dir, Tree, To => Expression);
1259 Current_Source_Dir := Expression;
1260 Set_First_Term (Expression, Tree, To => Term);
1261 Set_Current_Term (Term, Tree, To => Value);
1262 Name_Len := Dir_Name'Length;
1263 Name_Buffer (1 .. Name_Len) := Dir_Name;
1264 Set_String_Value_Of (Value, Tree, To => Name_Find);
1268 Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively);
1273 if Project_File then
1274 Close (Source_List_FD);
1281 -- Delete the file if it already exists
1284 (Path_Name (Directory_Last + 1 .. Path_Last),
1285 Success => Discard);
1289 if Opt.Verbose_Mode then
1290 Output.Write_Str ("Creating new file """);
1291 Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last));
1292 Output.Write_Line ("""");
1295 Output_FD := Create_New_File
1296 (Path_Name (Directory_Last + 1 .. Path_Last),
1299 -- Fails if project file cannot be created
1301 if Output_FD = Invalid_FD then
1303 ("cannot create new """, Path_Name (1 .. Path_Last), """");
1306 if Project_File then
1308 -- Output the project file
1311 (Project_Node, Tree,
1312 W_Char => Write_A_Char'Access,
1313 W_Eol => Write_Eol'Access,
1314 W_Str => Write_A_String'Access,
1315 Backward_Compatibility => False);
1318 -- Delete the naming project file if it already exists
1321 (Project_Naming_File_Name (1 .. Project_Naming_Last),
1322 Success => Discard);
1326 if Opt.Verbose_Mode then
1327 Output.Write_Str ("Creating new naming project file """);
1328 Output.Write_Str (Project_Naming_File_Name
1329 (1 .. Project_Naming_Last));
1330 Output.Write_Line ("""");
1333 Output_FD := Create_New_File
1334 (Project_Naming_File_Name (1 .. Project_Naming_Last),
1337 -- Fails if naming project file cannot be created
1339 if Output_FD = Invalid_FD then
1341 ("cannot create new """,
1342 Project_Naming_File_Name (1 .. Project_Naming_Last),
1346 -- Output the naming project file
1349 (Project_Naming_Node, Tree,
1350 W_Char => Write_A_Char'Access,
1351 W_Eol => Write_Eol'Access,
1352 W_Str => Write_A_String'Access,
1353 Backward_Compatibility => False);
1357 -- Write to the output file each entry in the SFN_Pragmas table
1358 -- as an pragma Source_File_Name.
1360 for Index in 1 .. SFN_Pragmas.Last loop
1361 Write_A_String ("pragma Source_File_Name");
1363 Write_A_String (" (");
1365 (Get_Name_String (SFN_Pragmas.Table (Index).Unit));
1366 Write_A_String (",");
1369 if SFN_Pragmas.Table (Index).Spec then
1370 Write_A_String (" Spec_File_Name => """);
1373 Write_A_String (" Body_File_Name => """);
1377 (Get_Name_String (SFN_Pragmas.Table (Index).File));
1379 Write_A_String ("""");
1381 if SFN_Pragmas.Table (Index).Index /= 0 then
1382 Write_A_String (", Index =>");
1383 Write_A_String (SFN_Pragmas.Table (Index).Index'Img);
1386 Write_A_String (");");
1399 procedure Write_A_Char (C : Character) is
1401 Write_A_String ((1 => C));
1408 procedure Write_Eol is
1410 Write_A_String ((1 => ASCII.LF));
1413 --------------------
1414 -- Write_A_String --
1415 --------------------
1417 procedure Write_A_String (S : String) is
1418 Str : String (1 .. S'Length);
1421 if S'Length > 0 then
1424 if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then
1425 Prj.Com.Fail ("disk full");