1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2006, 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 -- Packages of project files where unknown attributes are errors
52 -- All the following need comments ??? All global variables and
53 -- subprograms must be fully commented.
55 Naming_String
: aliased String := "naming";
57 Gnatname_Packages
: aliased String_List
:= (1 => Naming_String
'Access);
59 Packages_To_Check_By_Gnatname
: constant String_List_Access
:=
60 Gnatname_Packages
'Access;
62 function Dup
(Fd
: File_Descriptor
) return File_Descriptor
;
64 procedure Dup2
(Old_Fd
, New_Fd
: File_Descriptor
);
66 Gcc
: constant String := "gcc";
67 Gcc_Path
: String_Access
:= null;
69 Non_Empty_Node
: constant Project_Node_Id
:= 1;
70 -- Used for the With_Clause of the naming project
72 type Matched_Type
is (True, False, Excluded
);
74 Naming_File_Suffix
: constant String := "_naming";
75 Source_List_File_Suffix
: constant String := "_source_list.txt";
77 Output_FD
: File_Descriptor
;
78 -- To save the project file and its naming project file
81 -- Output an empty line
83 procedure Write_A_Char
(C
: Character);
84 -- Write one character to Output_FD
86 procedure Write_A_String
(S
: String);
87 -- Write a String to Output_FD
89 package Processed_Directories
is new Table
.Table
90 (Table_Component_Type
=> String_Access
,
91 Table_Index_Type
=> Natural,
94 Table_Increment
=> 100,
95 Table_Name
=> "Prj.Makr.Processed_Directories");
101 function Dup
(Fd
: File_Descriptor
) return File_Descriptor
is
103 return File_Descriptor
(System
.CRTL
.dup
(Integer (Fd
)));
110 procedure Dup2
(Old_Fd
, New_Fd
: File_Descriptor
) is
112 pragma Warnings
(Off
, Fd
);
114 Fd
:= System
.CRTL
.dup2
(Integer (Old_Fd
), Integer (New_Fd
));
123 Project_File
: Boolean;
124 Directories
: Argument_List
;
125 Name_Patterns
: Argument_List
;
126 Excluded_Patterns
: Argument_List
;
127 Foreign_Patterns
: Argument_List
;
128 Preproc_Switches
: Argument_List
;
129 Very_Verbose
: Boolean)
131 Tree
: constant Project_Node_Tree_Ref
:= new Project_Node_Tree_Data
;
133 Path_Name
: String (1 .. File_Path
'Length +
134 Project_File_Extension
'Length);
135 Path_Last
: Natural := File_Path
'Length;
137 Directory_Last
: Natural := 0;
139 Output_Name
: String (Path_Name
'Range);
140 Output_Name_Last
: Natural;
141 Output_Name_Id
: Name_Id
;
143 Project_Node
: Project_Node_Id
:= Empty_Node
;
144 Project_Declaration
: Project_Node_Id
:= Empty_Node
;
145 Source_Dirs_List
: Project_Node_Id
:= Empty_Node
;
146 Current_Source_Dir
: Project_Node_Id
:= Empty_Node
;
148 Project_Naming_Node
: Project_Node_Id
:= Empty_Node
;
149 Project_Naming_Decl
: Project_Node_Id
:= Empty_Node
;
150 Naming_Package
: Project_Node_Id
:= Empty_Node
;
151 Naming_Package_Comments
: Project_Node_Id
:= Empty_Node
;
153 Source_Files_Comments
: Project_Node_Id
:= Empty_Node
;
154 Source_Dirs_Comments
: Project_Node_Id
:= Empty_Node
;
155 Source_List_File_Comments
: Project_Node_Id
:= Empty_Node
;
157 Project_Naming_File_Name
: String (1 .. Output_Name
'Length +
158 Naming_File_Suffix
'Length);
160 Project_Naming_Last
: Natural;
161 Project_Naming_Id
: Name_Id
:= No_Name
;
163 Excluded_Expressions
: array (Excluded_Patterns
'Range) of Regexp
;
164 Regular_Expressions
: array (Name_Patterns
'Range) of Regexp
;
165 Foreign_Expressions
: array (Foreign_Patterns
'Range) of Regexp
;
167 Source_List_Path
: String (1 .. Output_Name
'Length +
168 Source_List_File_Suffix
'Length);
169 Source_List_Last
: Natural;
171 Source_List_FD
: File_Descriptor
;
173 Args
: Argument_List
(1 .. Preproc_Switches
'Length + 6);
175 type SFN_Pragma
is record
182 package SFN_Pragmas
is new Table
.Table
183 (Table_Component_Type
=> SFN_Pragma
,
184 Table_Index_Type
=> Natural,
185 Table_Low_Bound
=> 0,
187 Table_Increment
=> 100,
188 Table_Name
=> "Prj.Makr.SFN_Pragmas");
190 procedure Process_Directory
(Dir_Name
: String; Recursively
: Boolean);
191 -- Look for Ada and foreign sources in a directory, according to the
192 -- patterns. When Recursively is True, after looking for sources in
193 -- Dir_Name, look also in its subdirectories, if any.
195 -----------------------
196 -- Process_Directory --
197 -----------------------
199 procedure Process_Directory
(Dir_Name
: String; Recursively
: Boolean) is
200 Matched
: Matched_Type
:= False;
201 Str
: String (1 .. 2_000
);
202 Canon
: String (1 .. 2_000
);
205 Process
: Boolean := True;
207 Temp_File_Name
: String_Access
:= null;
208 Save_Last_Pragma_Index
: Natural := 0;
209 File_Name_Id
: Name_Id
:= No_Name
;
210 SFN_Prag
: SFN_Pragma
;
213 -- Avoid processing the same directory more than once
215 for Index
in 1 .. Processed_Directories
.Last
loop
216 if Processed_Directories
.Table
(Index
).all = Dir_Name
then
223 if Opt
.Verbose_Mode
then
224 Output
.Write_Str
("Processing directory """);
225 Output
.Write_Str
(Dir_Name
);
226 Output
.Write_Line
("""");
229 Processed_Directories
. Increment_Last
;
230 Processed_Directories
.Table
(Processed_Directories
.Last
) :=
231 new String'(Dir_Name);
233 -- Get the source file names from the directory. Fails if the
234 -- directory does not exist.
237 Open (Dir, Dir_Name);
239 when Directory_Error =>
240 Prj.Com.Fail ("cannot open directory """, Dir_Name, """");
243 -- Process each regular file in the directory
246 Read (Dir, Str, Last);
247 exit File_Loop when Last = 0;
249 -- Copy the file name and put it in canonical case to match
250 -- against the patterns that have themselves already been put
251 -- in canonical case.
253 Canon (1 .. Last) := Str (1 .. Last);
254 Canonical_Case_File_Name (Canon (1 .. Last));
257 (Dir_Name & Directory_Separator & Str (1 .. Last))
262 Name_Buffer (1 .. Name_Len) := Str (1 .. Last);
263 File_Name_Id := Name_Find;
265 -- First, check if the file name matches at least one of
266 -- the excluded expressions;
268 for Index in Excluded_Expressions'Range loop
270 Match (Canon (1 .. Last), Excluded_Expressions (Index))
277 -- If it does not match any of the excluded expressions,
278 -- check if the file name matches at least one of the
279 -- regular expressions.
281 if Matched = True then
284 for Index in Regular_Expressions'Range loop
287 (Canon (1 .. Last), Regular_Expressions (Index))
296 or else (Matched = True and then Opt.Verbose_Mode)
298 Output.Write_Str (" Checking """);
299 Output.Write_Str (Str (1 .. Last));
300 Output.Write_Line (""": ");
303 -- If the file name matches one of the regular expressions,
304 -- parse it to get its unit name.
306 if Matched = True then
308 FD : File_Descriptor;
310 Saved_Output : File_Descriptor;
311 Saved_Error : File_Descriptor;
314 -- If we don't have the path of the compiler yet,
315 -- get it now. The compiler name may have a prefix,
316 -- so we get the potentially prefixed name.
318 if Gcc_Path = null then
320 Prefix_Gcc : String_Access :=
324 Locate_Exec_On_Path (Prefix_Gcc.all);
328 if Gcc_Path = null then
329 Prj.Com.Fail ("could not locate " & Gcc);
333 -- If we don't have yet the file name of the
334 -- temporary file, get it now.
336 if Temp_File_Name = null then
337 Create_Temp_File (FD, Temp_File_Name);
339 if FD = Invalid_FD then
341 ("could not create temporary file");
345 Delete_File (Temp_File_Name.all, Success);
348 Args (Args'Last) := new String'
350 Directory_Separator
&
353 -- Create the temporary file
355 FD
:= Create_Output_Text_File
356 (Name
=> Temp_File_Name
.all);
358 if FD
= Invalid_FD
then
360 ("could not create temporary file");
363 -- Save the standard output and error
365 Saved_Output
:= Dup
(Standout
);
366 Saved_Error
:= Dup
(Standerr
);
368 -- Set standard output and error to the temporary file
373 -- And spawn the compiler
375 Spawn
(Gcc_Path
.all, Args
, Success
);
377 -- Restore the standard output and error
379 Dup2
(Saved_Output
, Standout
);
380 Dup2
(Saved_Error
, Standerr
);
382 -- Close the temporary file
386 -- And close the saved standard output and error to
387 -- avoid too many file descriptors.
389 Close
(Saved_Output
);
392 -- Now that standard output is restored, check if
393 -- the compiler ran correctly.
395 -- Read the lines of the temporary file:
396 -- they should contain the kind and name of the unit.
400 Text_Line
: String (1 .. 1_000
);
404 Open
(File
, Temp_File_Name
.all);
406 if not Is_Valid
(File
) then
408 ("could not read temporary file");
411 Save_Last_Pragma_Index
:= SFN_Pragmas
.Last
;
413 if End_Of_File
(File
) then
414 if Opt
.Verbose_Mode
then
416 Output
.Write_Str
(" (process died) ");
421 Line_Loop
: while not End_Of_File
(File
) loop
422 Get_Line
(File
, Text_Line
, Text_Last
);
424 -- Find the first closing parenthesis
426 Char_Loop
: for J
in 1 .. Text_Last
loop
427 if Text_Line
(J
) = ')' then
429 Text_Line
(1 .. 4) = "Unit"
431 -- Add entry to SFN_Pragmas table
434 Name_Buffer
(1 .. Name_Len
) :=
435 Text_Line
(6 .. J
- 7);
438 File
=> File_Name_Id
,
440 Spec
=> Text_Line
(J
- 5 .. J
) =
443 SFN_Pragmas
.Increment_Last
;
445 (SFN_Pragmas
.Last
) := SFN_Prag
;
453 if Save_Last_Pragma_Index
= SFN_Pragmas
.Last
then
454 if Opt
.Verbose_Mode
then
455 Output
.Write_Line
(" not a unit");
459 if SFN_Pragmas
.Last
>
460 Save_Last_Pragma_Index
+ 1
462 for Index
in Save_Last_Pragma_Index
+ 1 ..
465 SFN_Pragmas
.Table
(Index
).Index
:=
466 Int
(Index
- Save_Last_Pragma_Index
);
470 for Index
in Save_Last_Pragma_Index
+ 1 ..
473 SFN_Prag
:= SFN_Pragmas
.Table
(Index
);
475 if Opt
.Verbose_Mode
then
476 if SFN_Prag
.Spec
then
477 Output
.Write_Str
(" spec of ");
480 Output
.Write_Str
(" body of ");
484 (Get_Name_String
(SFN_Prag
.Unit
));
489 -- Add the corresponding attribute in the
490 -- Naming package of the naming project.
493 Decl_Item
: constant Project_Node_Id
:=
499 Attribute
: constant Project_Node_Id
:=
502 N_Attribute_Declaration
,
505 Expression
: constant Project_Node_Id
:=
507 (Of_Kind
=> N_Expression
,
508 And_Expr_Kind
=> Single
,
511 Term
: constant Project_Node_Id
:=
514 And_Expr_Kind
=> Single
,
517 Value
: constant Project_Node_Id
:=
519 (Of_Kind
=> N_Literal_String
,
520 And_Expr_Kind
=> Single
,
524 Set_Next_Declarative_Item
526 To
=> First_Declarative_Item_Of
527 (Naming_Package
, Tree
),
529 Set_First_Declarative_Item_Of
533 Set_Current_Item_Node
538 -- Is it a spec or a body?
540 if SFN_Prag
.Spec
then
550 -- Get the name of the unit
552 Get_Name_String
(SFN_Prag
.Unit
);
553 To_Lower
(Name_Buffer
(1 .. Name_Len
));
554 Set_Associative_Array_Index_Of
555 (Attribute
, Tree
, To
=> Name_Find
);
558 (Attribute
, Tree
, To
=> Expression
);
560 (Expression
, Tree
, To
=> Term
);
562 (Term
, Tree
, To
=> Value
);
564 -- And set the name of the file
567 (Value
, Tree
, To
=> File_Name_Id
);
569 (Value
, Tree
, To
=> SFN_Prag
.Index
);
575 -- Add source file name to source list
579 Str
(Last
) := ASCII
.LF
;
581 if Write
(Source_List_FD
,
585 Prj
.Com
.Fail
("disk full");
592 Delete_File
(Temp_File_Name
.all, Success
);
596 -- File name matches none of the regular expressions
599 -- If file is not excluded, see if this is foreign source
601 if Matched
/= Excluded
then
602 for Index
in Foreign_Expressions
'Range loop
603 if Match
(Canon
(1 .. Last
),
604 Foreign_Expressions
(Index
))
615 Output
.Write_Line
("no match");
618 Output
.Write_Line
("excluded");
621 Output
.Write_Line
("foreign source");
625 if Project_File
and Matched
= True then
627 -- Add source file name to source list file
630 Str
(Last
) := ASCII
.LF
;
632 if Write
(Source_List_FD
,
636 Prj
.Com
.Fail
("disk full");
646 -- If Recursively is True, call itself for each subdirectory.
647 -- We do that, even when this directory has already been processed,
648 -- because all of its subdirectories may not have been processed.
651 Open
(Dir
, Dir_Name
);
654 Read
(Dir
, Str
, Last
);
657 -- Do not call itself for "." or ".."
660 (Dir_Name
& Directory_Separator
& Str
(1 .. Last
))
661 and then Str
(1 .. Last
) /= "."
662 and then Str
(1 .. Last
) /= ".."
665 (Dir_Name
& Directory_Separator
& Str
(1 .. Last
),
666 Recursively
=> True);
672 end Process_Directory
;
674 -- Start of processing for Make
677 -- Do some needed initializations
682 Prj
.Initialize
(No_Project_Tree
);
683 Prj
.Tree
.Initialize
(Tree
);
685 SFN_Pragmas
.Set_Last
(0);
687 Processed_Directories
.Set_Last
(0);
689 -- Initialize the compiler switches
691 Args
(1) := new String'("-c");
692 Args (2) := new String'("-gnats");
693 Args
(3) := new String'("-gnatu");
694 Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches;
695 Args (4 + Preproc_Switches'Length) := new String'("-x");
696 Args
(5 + Preproc_Switches
'Length) := new String'("ada");
698 -- Get the path and file names
700 if File_Names_Case_Sensitive then
701 Path_Name (1 .. Path_Last) := File_Path;
703 Path_Name (1 .. Path_Last) := To_Lower (File_Path);
706 Path_Name (Path_Last + 1 .. Path_Name'Last) :=
707 Project_File_Extension;
709 -- Get the end of directory information, if any
711 for Index in reverse 1 .. Path_Last loop
712 if Path_Name (Index) = Directory_Separator then
713 Directory_Last := Index;
719 if Path_Last < Project_File_Extension'Length + 1
721 (Path_Last - Project_File_Extension'Length + 1 .. Path_Last)
722 /= Project_File_Extension
724 Path_Last := Path_Name'Last;
727 Output_Name (1 .. Path_Last) := To_Lower (Path_Name (1 .. Path_Last));
728 Output_Name_Last := Path_Last - Project_File_Extension'Length;
730 -- If there is already a project file with the specified name, parse
731 -- it to get the components that are not automatically generated.
733 if Is_Regular_File (Output_Name (1 .. Path_Last)) then
734 if Opt.Verbose_Mode then
735 Output.Write_Str ("Parsing already existing project file """);
736 Output.Write_Str (Output_Name (1 .. Output_Name_Last));
737 Output.Write_Line ("""");
742 Project => Project_Node,
743 Project_File_Name => Output_Name (1 .. Output_Name_Last),
744 Always_Errout_Finalize => False,
745 Store_Comments => True,
746 Packages_To_Check => Packages_To_Check_By_Gnatname);
748 -- Fail if parsing was not successful
750 if Project_Node = Empty_Node then
751 Fail ("parsing of existing project file failed");
754 -- If parsing was successful, remove the components that are
755 -- automatically generated, if any, so that they will be
756 -- unconditionally added later.
758 -- Remove the with clause for the naming project file
761 With_Clause : Project_Node_Id :=
762 First_With_Clause_Of (Project_Node, Tree);
763 Previous : Project_Node_Id := Empty_Node;
766 while With_Clause /= Empty_Node loop
767 if Prj.Tree.Name_Of (With_Clause, Tree) =
770 if Previous = Empty_Node then
771 Set_First_With_Clause_Of
773 To => Next_With_Clause_Of (With_Clause, Tree));
775 Set_Next_With_Clause_Of
777 To => Next_With_Clause_Of (With_Clause, Tree));
783 Previous := With_Clause;
784 With_Clause := Next_With_Clause_Of (With_Clause, Tree);
788 -- Remove attribute declarations of Source_Files,
789 -- Source_List_File, Source_Dirs, and the declaration of
790 -- package Naming, if they exist, but preserve the comments
791 -- attached to these nodes.
794 Declaration : Project_Node_Id :=
795 First_Declarative_Item_Of
796 (Project_Declaration_Of
797 (Project_Node, Tree),
799 Previous : Project_Node_Id := Empty_Node;
800 Current_Node : Project_Node_Id := Empty_Node;
803 Kind_Of_Node : Project_Node_Kind;
804 Comments : Project_Node_Id;
807 while Declaration /= Empty_Node loop
808 Current_Node := Current_Item_Node (Declaration, Tree);
810 Kind_Of_Node := Kind_Of (Current_Node, Tree);
812 if Kind_Of_Node = N_Attribute_Declaration or else
813 Kind_Of_Node = N_Package_Declaration
815 Name := Prj.Tree.Name_Of (Current_Node, Tree);
817 if Name = Name_Source_Files or else
818 Name = Name_Source_List_File or else
819 Name = Name_Source_Dirs or else
823 Tree.Project_Nodes.Table (Current_Node).Comments;
825 if Name = Name_Source_Files then
826 Source_Files_Comments := Comments;
828 elsif Name = Name_Source_List_File then
829 Source_List_File_Comments := Comments;
831 elsif Name = Name_Source_Dirs then
832 Source_Dirs_Comments := Comments;
834 elsif Name = Name_Naming then
835 Naming_Package_Comments := Comments;
838 if Previous = Empty_Node then
839 Set_First_Declarative_Item_Of
840 (Project_Declaration_Of (Project_Node, Tree),
842 To => Next_Declarative_Item
843 (Declaration, Tree));
846 Set_Next_Declarative_Item
848 To => Next_Declarative_Item
849 (Declaration, Tree));
853 Previous := Declaration;
857 Declaration := Next_Declarative_Item (Declaration, Tree);
863 if Directory_Last /= 0 then
864 Output_Name (1 .. Output_Name_Last - Directory_Last) :=
865 Output_Name (Directory_Last + 1 .. Output_Name_Last);
866 Output_Name_Last := Output_Name_Last - Directory_Last;
869 -- Get the project name id
871 Name_Len := Output_Name_Last;
872 Name_Buffer (1 .. Name_Len) := Output_Name (1 .. Name_Len);
873 Output_Name_Id := Name_Find;
875 -- Create the project naming file name
877 Project_Naming_Last := Output_Name_Last;
878 Project_Naming_File_Name (1 .. Project_Naming_Last) :=
879 Output_Name (1 .. Project_Naming_Last);
880 Project_Naming_File_Name
881 (Project_Naming_Last + 1 ..
882 Project_Naming_Last + Naming_File_Suffix'Length) :=
884 Project_Naming_Last :=
885 Project_Naming_Last + Naming_File_Suffix'Length;
887 -- Get the project naming id
889 Name_Len := Project_Naming_Last;
890 Name_Buffer (1 .. Name_Len) :=
891 Project_Naming_File_Name (1 .. Name_Len);
892 Project_Naming_Id := Name_Find;
894 Project_Naming_File_Name
895 (Project_Naming_Last + 1 ..
896 Project_Naming_Last + Project_File_Extension'Length) :=
897 Project_File_Extension;
898 Project_Naming_Last :=
899 Project_Naming_Last + Project_File_Extension'Length;
901 -- Create the source list file name
903 Source_List_Last := Output_Name_Last;
904 Source_List_Path (1 .. Source_List_Last) :=
905 Output_Name (1 .. Source_List_Last);
907 (Source_List_Last + 1 ..
908 Source_List_Last + Source_List_File_Suffix'Length) :=
909 Source_List_File_Suffix;
910 Source_List_Last := Source_List_Last + Source_List_File_Suffix'Length;
912 -- Add the project file extension to the project name
915 (Output_Name_Last + 1 ..
916 Output_Name_Last + Project_File_Extension'Length) :=
917 Project_File_Extension;
918 Output_Name_Last := Output_Name_Last + Project_File_Extension'Length;
921 -- Change the current directory to the directory of the project file,
922 -- if any directory information is specified.
924 if Directory_Last /= 0 then
926 Change_Dir (Path_Name (1 .. Directory_Last));
928 when Directory_Error =>
930 ("unknown directory """,
931 Path_Name (1 .. Directory_Last),
938 -- Delete the source list file, if it already exists
944 (Source_List_Path (1 .. Source_List_Last),
948 -- And create a new source list file.
949 -- Fail if file cannot be created.
951 Source_List_FD := Create_New_File
952 (Name => Source_List_Path (1 .. Source_List_Last),
955 if Source_List_FD = Invalid_FD then
957 ("cannot create file """,
958 Source_List_Path (1 .. Source_List_Last),
963 -- Compile the regular expressions. Fails immediately if any of
964 -- the specified strings is in error.
966 for Index in Excluded_Expressions'Range loop
968 Output.Write_Str ("Excluded pattern: """);
969 Output.Write_Str (Excluded_Patterns (Index).all);
970 Output.Write_Line ("""");
974 Excluded_Expressions (Index) :=
975 Compile (Pattern => Excluded_Patterns (Index).all, Glob => True);
977 when Error_In_Regexp =>
979 ("invalid regular expression """,
980 Excluded_Patterns (Index).all,
985 for Index in Foreign_Expressions'Range loop
987 Output.Write_Str ("Foreign pattern: """);
988 Output.Write_Str (Foreign_Patterns (Index).all);
989 Output.Write_Line ("""");
993 Foreign_Expressions (Index) :=
994 Compile (Pattern => Foreign_Patterns (Index).all, Glob => True);
996 when Error_In_Regexp =>
998 ("invalid regular expression """,
999 Foreign_Patterns (Index).all,
1004 for Index in Regular_Expressions'Range loop
1005 if Very_Verbose then
1006 Output.Write_Str ("Pattern: """);
1007 Output.Write_Str (Name_Patterns (Index).all);
1008 Output.Write_Line ("""");
1012 Regular_Expressions (Index) :=
1013 Compile (Pattern => Name_Patterns (Index).all, Glob => True);
1016 when Error_In_Regexp =>
1018 ("invalid regular expression """,
1019 Name_Patterns (Index).all,
1024 if Project_File then
1025 if Opt.Verbose_Mode then
1026 Output.Write_Str ("Naming project file name is """);
1028 (Project_Naming_File_Name (1 .. Project_Naming_Last));
1029 Output.Write_Line ("""");
1032 -- If there were no already existing project file, or if the parsing
1033 -- was unsuccessful, create an empty project node with the correct
1034 -- name and its project declaration node.
1036 if Project_Node = Empty_Node then
1038 Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree);
1039 Set_Name_Of (Project_Node, Tree, To => Output_Name_Id);
1040 Set_Project_Declaration_Of
1041 (Project_Node, Tree,
1042 To => Default_Project_Node
1043 (Of_Kind => N_Project_Declaration, In_Tree => Tree));
1047 -- Create the naming project node, and add an attribute declaration
1048 -- for Source_Files as an empty list, to indicate there are no
1049 -- sources in the naming project.
1051 Project_Naming_Node :=
1052 Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree);
1053 Set_Name_Of (Project_Naming_Node, Tree, To => Project_Naming_Id);
1054 Project_Naming_Decl :=
1055 Default_Project_Node
1056 (Of_Kind => N_Project_Declaration, In_Tree => Tree);
1057 Set_Project_Declaration_Of
1058 (Project_Naming_Node, Tree, Project_Naming_Decl);
1060 Default_Project_Node
1061 (Of_Kind => N_Package_Declaration, In_Tree => Tree);
1062 Set_Name_Of (Naming_Package, Tree, To => Name_Naming);
1065 Decl_Item : constant Project_Node_Id :=
1066 Default_Project_Node
1067 (Of_Kind => N_Declarative_Item, In_Tree => Tree);
1069 Attribute : constant Project_Node_Id :=
1070 Default_Project_Node
1071 (Of_Kind => N_Attribute_Declaration,
1073 And_Expr_Kind => List);
1075 Expression : constant Project_Node_Id :=
1076 Default_Project_Node
1077 (Of_Kind => N_Expression,
1079 And_Expr_Kind => List);
1081 Term : constant Project_Node_Id :=
1082 Default_Project_Node
1085 And_Expr_Kind => List);
1087 Empty_List : constant Project_Node_Id :=
1088 Default_Project_Node
1089 (Of_Kind => N_Literal_String_List,
1093 Set_First_Declarative_Item_Of
1094 (Project_Naming_Decl, Tree, To => Decl_Item);
1095 Set_Next_Declarative_Item (Decl_Item, Tree, Naming_Package);
1096 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
1097 Set_Name_Of (Attribute, Tree, To => Name_Source_Files);
1098 Set_Expression_Of (Attribute, Tree, To => Expression);
1099 Set_First_Term (Expression, Tree, To => Term);
1100 Set_Current_Term (Term, Tree, To => Empty_List);
1103 -- Add a with clause on the naming project in the main project, if
1104 -- there is not already one.
1107 With_Clause : Project_Node_Id :=
1108 First_With_Clause_Of (Project_Node, Tree);
1111 while With_Clause /= Empty_Node loop
1113 Prj.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id;
1114 With_Clause := Next_With_Clause_Of (With_Clause, Tree);
1117 if With_Clause = Empty_Node then
1118 With_Clause := Default_Project_Node
1119 (Of_Kind => N_With_Clause, In_Tree => Tree);
1120 Set_Next_With_Clause_Of
1122 To => First_With_Clause_Of (Project_Node, Tree));
1123 Set_First_With_Clause_Of
1124 (Project_Node, Tree, To => With_Clause);
1125 Set_Name_Of (With_Clause, Tree, To => Project_Naming_Id);
1127 -- We set the project node to something different than
1128 -- Empty_Node, so that Prj.PP does not generate a limited
1131 Set_Project_Node_Of (With_Clause, Tree, Non_Empty_Node);
1133 Name_Len := Project_Naming_Last;
1134 Name_Buffer (1 .. Name_Len) :=
1135 Project_Naming_File_Name (1 .. Project_Naming_Last);
1136 Set_String_Value_Of (With_Clause, Tree, To => Name_Find);
1140 Project_Declaration := Project_Declaration_Of (Project_Node, Tree);
1142 -- Add a renaming declaration for package Naming in the main project
1145 Decl_Item : constant Project_Node_Id :=
1146 Default_Project_Node
1147 (Of_Kind => N_Declarative_Item,
1150 Naming : constant Project_Node_Id :=
1151 Default_Project_Node
1152 (Of_Kind => N_Package_Declaration,
1156 Set_Next_Declarative_Item
1158 To => First_Declarative_Item_Of (Project_Declaration, Tree));
1159 Set_First_Declarative_Item_Of
1160 (Project_Declaration, Tree, To => Decl_Item);
1161 Set_Current_Item_Node (Decl_Item, Tree, To => Naming);
1162 Set_Name_Of (Naming, Tree, To => Name_Naming);
1163 Set_Project_Of_Renamed_Package_Of
1164 (Naming, Tree, To => Project_Naming_Node);
1166 -- Attach the comments, if any, that were saved for package
1169 Tree.Project_Nodes.Table (Naming).Comments :=
1170 Naming_Package_Comments;
1173 -- Add an attribute declaration for Source_Dirs, initialized as an
1174 -- empty list. Directories will be added as they are read from the
1175 -- directory list file.
1178 Decl_Item : constant Project_Node_Id :=
1179 Default_Project_Node
1180 (Of_Kind => N_Declarative_Item,
1183 Attribute : constant Project_Node_Id :=
1184 Default_Project_Node
1185 (Of_Kind => N_Attribute_Declaration,
1187 And_Expr_Kind => List);
1189 Expression : constant Project_Node_Id :=
1190 Default_Project_Node
1191 (Of_Kind => N_Expression,
1193 And_Expr_Kind => List);
1195 Term : constant Project_Node_Id :=
1196 Default_Project_Node
1197 (Of_Kind => N_Term, In_Tree => Tree,
1198 And_Expr_Kind => List);
1201 Set_Next_Declarative_Item
1203 To => First_Declarative_Item_Of (Project_Declaration, Tree));
1204 Set_First_Declarative_Item_Of
1205 (Project_Declaration, Tree, To => Decl_Item);
1206 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
1207 Set_Name_Of (Attribute, Tree, To => Name_Source_Dirs);
1208 Set_Expression_Of (Attribute, Tree, To => Expression);
1209 Set_First_Term (Expression, Tree, To => Term);
1211 Default_Project_Node
1212 (Of_Kind => N_Literal_String_List,
1214 And_Expr_Kind => List);
1215 Set_Current_Term (Term, Tree, To => Source_Dirs_List);
1217 -- Attach the comments, if any, that were saved for attribute
1220 Tree.Project_Nodes.Table (Attribute).Comments :=
1221 Source_Dirs_Comments;
1224 -- Add an attribute declaration for Source_List_File with the
1225 -- source list file name that will be created.
1228 Decl_Item : constant Project_Node_Id :=
1229 Default_Project_Node
1230 (Of_Kind => N_Declarative_Item,
1233 Attribute : constant Project_Node_Id :=
1234 Default_Project_Node
1235 (Of_Kind => N_Attribute_Declaration,
1237 And_Expr_Kind => Single);
1239 Expression : constant Project_Node_Id :=
1240 Default_Project_Node
1241 (Of_Kind => N_Expression,
1243 And_Expr_Kind => Single);
1245 Term : constant Project_Node_Id :=
1246 Default_Project_Node
1249 And_Expr_Kind => Single);
1251 Value : constant Project_Node_Id :=
1252 Default_Project_Node
1253 (Of_Kind => N_Literal_String,
1255 And_Expr_Kind => Single);
1258 Set_Next_Declarative_Item
1260 To => First_Declarative_Item_Of (Project_Declaration, Tree));
1261 Set_First_Declarative_Item_Of
1262 (Project_Declaration, Tree, To => Decl_Item);
1263 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
1264 Set_Name_Of (Attribute, Tree, To => Name_Source_List_File);
1265 Set_Expression_Of (Attribute, Tree, To => Expression);
1266 Set_First_Term (Expression, Tree, To => Term);
1267 Set_Current_Term (Term, Tree, To => Value);
1268 Name_Len := Source_List_Last;
1269 Name_Buffer (1 .. Name_Len) :=
1270 Source_List_Path (1 .. Source_List_Last);
1271 Set_String_Value_Of (Value, Tree, To => Name_Find);
1273 -- If there was no comments for attribute Source_List_File, put
1274 -- those for Source_Files, if they exist.
1276 if Source_List_File_Comments /= Empty_Node then
1277 Tree.Project_Nodes.Table (Attribute).Comments :=
1278 Source_List_File_Comments;
1280 Tree.Project_Nodes.Table (Attribute).Comments :=
1281 Source_Files_Comments;
1286 -- Process each directory
1288 for Index in Directories'Range loop
1291 Dir_Name : constant String := Directories (Index).all;
1292 Last : Natural := Dir_Name'Last;
1293 Recursively : Boolean := False;
1296 if Dir_Name'Length >= 4
1297 and then (Dir_Name (Last - 2 .. Last) = "/**")
1300 Recursively := True;
1303 if Project_File then
1305 -- Add the directory in the list for attribute Source_Dirs
1308 Expression : constant Project_Node_Id :=
1309 Default_Project_Node
1310 (Of_Kind => N_Expression,
1312 And_Expr_Kind => Single);
1314 Term : constant Project_Node_Id :=
1315 Default_Project_Node
1318 And_Expr_Kind => Single);
1320 Value : constant Project_Node_Id :=
1321 Default_Project_Node
1322 (Of_Kind => N_Literal_String,
1324 And_Expr_Kind => Single);
1327 if Current_Source_Dir = Empty_Node then
1328 Set_First_Expression_In_List
1329 (Source_Dirs_List, Tree, To => Expression);
1331 Set_Next_Expression_In_List
1332 (Current_Source_Dir, Tree, To => Expression);
1335 Current_Source_Dir := Expression;
1336 Set_First_Term (Expression, Tree, To => Term);
1337 Set_Current_Term (Term, Tree, To => Value);
1338 Name_Len := Dir_Name'Length;
1339 Name_Buffer (1 .. Name_Len) := Dir_Name;
1340 Set_String_Value_Of (Value, Tree, To => Name_Find);
1344 Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively);
1349 if Project_File then
1350 Close (Source_List_FD);
1357 -- Delete the file if it already exists
1360 (Path_Name (Directory_Last + 1 .. Path_Last),
1361 Success => Discard);
1365 if Opt.Verbose_Mode then
1366 Output.Write_Str ("Creating new file """);
1367 Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last));
1368 Output.Write_Line ("""");
1371 Output_FD := Create_New_File
1372 (Path_Name (Directory_Last + 1 .. Path_Last),
1375 -- Fails if project file cannot be created
1377 if Output_FD = Invalid_FD then
1379 ("cannot create new """, Path_Name (1 .. Path_Last), """");
1382 if Project_File then
1384 -- Output the project file
1387 (Project_Node, Tree,
1388 W_Char => Write_A_Char'Access,
1389 W_Eol => Write_Eol'Access,
1390 W_Str => Write_A_String'Access,
1391 Backward_Compatibility => False);
1394 -- Delete the naming project file if it already exists
1397 (Project_Naming_File_Name (1 .. Project_Naming_Last),
1398 Success => Discard);
1402 if Opt.Verbose_Mode then
1403 Output.Write_Str ("Creating new naming project file """);
1404 Output.Write_Str (Project_Naming_File_Name
1405 (1 .. Project_Naming_Last));
1406 Output.Write_Line ("""");
1409 Output_FD := Create_New_File
1410 (Project_Naming_File_Name (1 .. Project_Naming_Last),
1413 -- Fails if naming project file cannot be created
1415 if Output_FD = Invalid_FD then
1417 ("cannot create new """,
1418 Project_Naming_File_Name (1 .. Project_Naming_Last),
1422 -- Output the naming project file
1425 (Project_Naming_Node, Tree,
1426 W_Char => Write_A_Char'Access,
1427 W_Eol => Write_Eol'Access,
1428 W_Str => Write_A_String'Access,
1429 Backward_Compatibility => False);
1433 -- Write to the output file each entry in the SFN_Pragmas table
1434 -- as an pragma Source_File_Name.
1436 for Index in 1 .. SFN_Pragmas.Last loop
1437 Write_A_String ("pragma Source_File_Name");
1439 Write_A_String (" (");
1441 (Get_Name_String (SFN_Pragmas.Table (Index).Unit));
1442 Write_A_String (",");
1445 if SFN_Pragmas.Table (Index).Spec then
1446 Write_A_String (" Spec_File_Name => """);
1449 Write_A_String (" Body_File_Name => """);
1453 (Get_Name_String (SFN_Pragmas.Table (Index).File));
1455 Write_A_String ("""");
1457 if SFN_Pragmas.Table (Index).Index /= 0 then
1458 Write_A_String (", Index =>");
1459 Write_A_String (SFN_Pragmas.Table (Index).Index'Img);
1462 Write_A_String (");");
1475 procedure Write_A_Char (C : Character) is
1477 Write_A_String ((1 => C));
1484 procedure Write_Eol is
1486 Write_A_String ((1 => ASCII.LF));
1489 --------------------
1490 -- Write_A_String --
1491 --------------------
1493 procedure Write_A_String (S : String) is
1494 Str : String (1 .. S'Length);
1497 if S'Length > 0 then
1500 if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then
1501 Prj.Com.Fail ("disk full");