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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
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
.OS_Lib
; use GNAT
.OS_Lib
;
44 with GNAT
.Regexp
; use GNAT
.Regexp
;
46 with System
.Case_Util
; use System
.Case_Util
;
49 package body Prj
.Makr
is
51 function Dup
(Fd
: File_Descriptor
) return File_Descriptor
;
53 procedure Dup2
(Old_Fd
, New_Fd
: File_Descriptor
);
55 Gcc
: constant String := "gcc";
56 Gcc_Path
: String_Access
:= null;
58 Non_Empty_Node
: constant Project_Node_Id
:= 1;
59 -- Used for the With_Clause of the naming project
61 type Matched_Type
is (True, False, Excluded
);
63 Naming_File_Suffix
: constant String := "_naming";
64 Source_List_File_Suffix
: constant String := "_source_list.txt";
66 Output_FD
: File_Descriptor
;
67 -- To save the project file and its naming project file
70 -- Output an empty line
72 procedure Write_A_Char
(C
: Character);
73 -- Write one character to Output_FD
75 procedure Write_A_String
(S
: String);
76 -- Write a String to Output_FD
78 package Processed_Directories
is new Table
.Table
79 (Table_Component_Type
=> String_Access
,
80 Table_Index_Type
=> Natural,
83 Table_Increment
=> 10,
84 Table_Name
=> "Prj.Makr.Processed_Directories");
90 function Dup
(Fd
: File_Descriptor
) return File_Descriptor
is
92 return File_Descriptor
(System
.CRTL
.dup
(Integer (Fd
)));
99 procedure Dup2
(Old_Fd
, New_Fd
: File_Descriptor
) is
101 pragma Warnings
(Off
, Fd
);
103 Fd
:= System
.CRTL
.dup2
(Integer (Old_Fd
), Integer (New_Fd
));
112 Project_File
: Boolean;
113 Directories
: Argument_List
;
114 Name_Patterns
: Argument_List
;
115 Excluded_Patterns
: Argument_List
;
116 Foreign_Patterns
: Argument_List
;
117 Preproc_Switches
: Argument_List
;
118 Very_Verbose
: Boolean)
120 Path_Name
: String (1 .. File_Path
'Length +
121 Project_File_Extension
'Length);
122 Path_Last
: Natural := File_Path
'Length;
124 Directory_Last
: Natural := 0;
126 Output_Name
: String (Path_Name
'Range);
127 Output_Name_Last
: Natural;
128 Output_Name_Id
: Name_Id
;
130 Project_Node
: Project_Node_Id
:= Empty_Node
;
131 Project_Declaration
: Project_Node_Id
:= Empty_Node
;
132 Source_Dirs_List
: Project_Node_Id
:= Empty_Node
;
133 Current_Source_Dir
: Project_Node_Id
:= Empty_Node
;
135 Project_Naming_Node
: Project_Node_Id
:= Empty_Node
;
136 Project_Naming_Decl
: Project_Node_Id
:= Empty_Node
;
137 Naming_Package
: Project_Node_Id
:= Empty_Node
;
139 Project_Naming_File_Name
: String (1 .. Output_Name
'Length +
140 Naming_File_Suffix
'Length);
142 Project_Naming_Last
: Natural;
143 Project_Naming_Id
: Name_Id
:= No_Name
;
145 Excluded_Expressions
: array (Excluded_Patterns
'Range) of Regexp
;
146 Regular_Expressions
: array (Name_Patterns
'Range) of Regexp
;
147 Foreign_Expressions
: array (Foreign_Patterns
'Range) of Regexp
;
149 Source_List_Path
: String (1 .. Output_Name
'Length +
150 Source_List_File_Suffix
'Length);
151 Source_List_Last
: Natural;
153 Source_List_FD
: File_Descriptor
;
155 Args
: Argument_List
(1 .. Preproc_Switches
'Length + 6);
157 type SFN_Pragma
is record
164 package SFN_Pragmas
is new Table
.Table
165 (Table_Component_Type
=> SFN_Pragma
,
166 Table_Index_Type
=> Natural,
167 Table_Low_Bound
=> 0,
169 Table_Increment
=> 50,
170 Table_Name
=> "Prj.Makr.SFN_Pragmas");
172 procedure Process_Directory
(Dir_Name
: String; Recursively
: Boolean);
173 -- Look for Ada and foreign sources in a directory, according to the
174 -- patterns. When Recursively is True, after looking for sources in
175 -- Dir_Name, look also in its subdirectories, if any.
177 -----------------------
178 -- Process_Directory --
179 -----------------------
181 procedure Process_Directory
(Dir_Name
: String; Recursively
: Boolean) is
182 Matched
: Matched_Type
:= False;
183 Str
: String (1 .. 2_000
);
184 Canon
: String (1 .. 2_000
);
187 Process
: Boolean := True;
189 Temp_File_Name
: String_Access
:= null;
190 Save_Last_Pragma_Index
: Natural := 0;
191 File_Name_Id
: Name_Id
:= No_Name
;
192 SFN_Prag
: SFN_Pragma
;
195 -- Avoid processing the same directory more than once
197 for Index
in 1 .. Processed_Directories
.Last
loop
198 if Processed_Directories
.Table
(Index
).all = Dir_Name
then
205 if Opt
.Verbose_Mode
then
206 Output
.Write_Str
("Processing directory """);
207 Output
.Write_Str
(Dir_Name
);
208 Output
.Write_Line
("""");
211 Processed_Directories
. Increment_Last
;
212 Processed_Directories
.Table
(Processed_Directories
.Last
) :=
213 new String'(Dir_Name);
215 -- Get the source file names from the directory. Fails if the
216 -- directory does not exist.
219 Open (Dir, Dir_Name);
221 when Directory_Error =>
222 Prj.Com.Fail ("cannot open directory """, Dir_Name, """");
225 -- Process each regular file in the directory
228 Read (Dir, Str, Last);
229 exit File_Loop when Last = 0;
231 -- Copy the file name and put it in canonical case to match
232 -- against the patterns that have themselves already been put
233 -- in canonical case.
235 Canon (1 .. Last) := Str (1 .. Last);
236 Canonical_Case_File_Name (Canon (1 .. Last));
239 (Dir_Name & Directory_Separator & Str (1 .. Last))
244 Name_Buffer (1 .. Name_Len) := Str (1 .. Last);
245 File_Name_Id := Name_Find;
247 -- First, check if the file name matches at least one of
248 -- the excluded expressions;
250 for Index in Excluded_Expressions'Range loop
252 Match (Canon (1 .. Last), Excluded_Expressions (Index))
259 -- If it does not match any of the excluded expressions,
260 -- check if the file name matches at least one of the
261 -- regular expressions.
263 if Matched = True then
266 for Index in Regular_Expressions'Range loop
269 (Canon (1 .. Last), Regular_Expressions (Index))
278 or else (Matched = True and then Opt.Verbose_Mode)
280 Output.Write_Str (" Checking """);
281 Output.Write_Str (Str (1 .. Last));
282 Output.Write_Line (""": ");
285 -- If the file name matches one of the regular expressions,
286 -- parse it to get its unit name.
288 if Matched = True then
290 FD : File_Descriptor;
292 Saved_Output : File_Descriptor;
293 Saved_Error : File_Descriptor;
296 -- If we don't have the path of the compiler yet,
297 -- get it now. The compiler name may have a prefix,
298 -- so we get the potentially prefixed name.
300 if Gcc_Path = null then
302 Prefix_Gcc : String_Access :=
306 Locate_Exec_On_Path (Prefix_Gcc.all);
310 if Gcc_Path = null then
311 Prj.Com.Fail ("could not locate " & Gcc);
315 -- If we don't have yet the file name of the
316 -- temporary file, get it now.
318 if Temp_File_Name = null then
319 Create_Temp_File (FD, Temp_File_Name);
321 if FD = Invalid_FD then
323 ("could not create temporary file");
327 Delete_File (Temp_File_Name.all, Success);
330 Args (Args'Last) := new String'
332 Directory_Separator
&
335 -- Create the temporary file
337 FD
:= Create_Output_Text_File
338 (Name
=> Temp_File_Name
.all);
340 if FD
= Invalid_FD
then
342 ("could not create temporary file");
345 -- Save the standard output and error
347 Saved_Output
:= Dup
(Standout
);
348 Saved_Error
:= Dup
(Standerr
);
350 -- Set standard output and error to the temporary file
355 -- And spawn the compiler
357 Spawn
(Gcc_Path
.all, Args
, Success
);
359 -- Restore the standard output and error
361 Dup2
(Saved_Output
, Standout
);
362 Dup2
(Saved_Error
, Standerr
);
364 -- Close the temporary file
368 -- And close the saved standard output and error to
369 -- avoid too many file descriptors.
371 Close
(Saved_Output
);
374 -- Now that standard output is restored, check if
375 -- the compiler ran correctly.
377 -- Read the lines of the temporary file:
378 -- they should contain the kind and name of the unit.
382 Text_Line
: String (1 .. 1_000
);
386 Open
(File
, Temp_File_Name
.all);
388 if not Is_Valid
(File
) then
390 ("could not read temporary file");
393 Save_Last_Pragma_Index
:= SFN_Pragmas
.Last
;
395 if End_Of_File
(File
) then
396 if Opt
.Verbose_Mode
then
398 Output
.Write_Str
(" (process died) ");
403 Line_Loop
: while not End_Of_File
(File
) loop
404 Get_Line
(File
, Text_Line
, Text_Last
);
406 -- Find the first closing parenthesis
408 Char_Loop
: for J
in 1 .. Text_Last
loop
409 if Text_Line
(J
) = ')' then
411 Text_Line
(1 .. 4) = "Unit"
413 -- Add entry to SFN_Pragmas table
416 Name_Buffer
(1 .. Name_Len
) :=
417 Text_Line
(6 .. J
- 7);
420 File
=> File_Name_Id
,
422 Spec
=> Text_Line
(J
- 5 .. J
) =
425 SFN_Pragmas
.Increment_Last
;
427 (SFN_Pragmas
.Last
) := SFN_Prag
;
435 if Save_Last_Pragma_Index
= SFN_Pragmas
.Last
then
436 if Opt
.Verbose_Mode
then
437 Output
.Write_Line
(" not a unit");
441 if SFN_Pragmas
.Last
>
442 Save_Last_Pragma_Index
+ 1
444 for Index
in Save_Last_Pragma_Index
+ 1 ..
447 SFN_Pragmas
.Table
(Index
).Index
:=
448 Int
(Index
- Save_Last_Pragma_Index
);
452 for Index
in Save_Last_Pragma_Index
+ 1 ..
455 SFN_Prag
:= SFN_Pragmas
.Table
(Index
);
457 if Opt
.Verbose_Mode
then
458 if SFN_Prag
.Spec
then
459 Output
.Write_Str
(" spec of ");
462 Output
.Write_Str
(" body of ");
466 (Get_Name_String
(SFN_Prag
.Unit
));
471 -- Add the corresponding attribute in the
472 -- Naming package of the naming project.
475 Decl_Item
: constant Project_Node_Id
:=
480 Attribute
: constant Project_Node_Id
:=
483 N_Attribute_Declaration
);
485 Expression
: constant Project_Node_Id
:=
487 (Of_Kind
=> N_Expression
,
488 And_Expr_Kind
=> Single
);
490 Term
: constant Project_Node_Id
:=
493 And_Expr_Kind
=> Single
);
495 Value
: constant Project_Node_Id
:=
497 (Of_Kind
=> N_Literal_String
,
498 And_Expr_Kind
=> Single
);
501 Set_Next_Declarative_Item
503 To
=> First_Declarative_Item_Of
505 Set_First_Declarative_Item_Of
506 (Naming_Package
, To
=> Decl_Item
);
507 Set_Current_Item_Node
508 (Decl_Item
, To
=> Attribute
);
510 -- Is it a spec or a body?
512 if SFN_Prag
.Spec
then
514 (Attribute
, To
=> Name_Spec
);
521 -- Get the name of the unit
523 Get_Name_String
(SFN_Prag
.Unit
);
524 To_Lower
(Name_Buffer
(1 .. Name_Len
));
525 Set_Associative_Array_Index_Of
526 (Attribute
, To
=> Name_Find
);
529 (Attribute
, To
=> Expression
);
531 (Expression
, To
=> Term
);
532 Set_Current_Term
(Term
, To
=> Value
);
534 -- And set the name of the file
537 (Value
, To
=> File_Name_Id
);
539 (Value
, To
=> SFN_Prag
.Index
);
545 -- Add source file name to source list
549 Str
(Last
) := ASCII
.LF
;
551 if Write
(Source_List_FD
,
555 Prj
.Com
.Fail
("disk full");
562 Delete_File
(Temp_File_Name
.all, Success
);
566 -- File name matches none of the regular expressions
569 -- If file is not excluded, see if this is foreign source
571 if Matched
/= Excluded
then
572 for Index
in Foreign_Expressions
'Range loop
573 if Match
(Canon
(1 .. Last
),
574 Foreign_Expressions
(Index
))
585 Output
.Write_Line
("no match");
588 Output
.Write_Line
("excluded");
591 Output
.Write_Line
("foreign source");
595 if Project_File
and Matched
= True then
597 -- Add source file name to source list file
600 Str
(Last
) := ASCII
.LF
;
602 if Write
(Source_List_FD
,
606 Prj
.Com
.Fail
("disk full");
616 -- If Recursively is True, call itself for each subdirectory.
617 -- We do that, even when this directory has already been processed,
618 -- because all of its subdirectories may not have been processed.
621 Open
(Dir
, Dir_Name
);
624 Read
(Dir
, Str
, Last
);
627 -- Do not call itself for "." or ".."
630 (Dir_Name
& Directory_Separator
& Str
(1 .. Last
))
631 and then Str
(1 .. Last
) /= "."
632 and then Str
(1 .. Last
) /= ".."
635 (Dir_Name
& Directory_Separator
& Str
(1 .. Last
),
636 Recursively
=> True);
642 end Process_Directory
;
644 -- Start of processing for Make
647 -- Do some needed initializations
654 SFN_Pragmas
.Set_Last
(0);
656 Processed_Directories
.Set_Last
(0);
658 -- Initialize the compiler switches
660 Args
(1) := new String'("-c");
661 Args (2) := new String'("-gnats");
662 Args
(3) := new String'("-gnatu");
663 Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches;
664 Args (4 + Preproc_Switches'Length) := new String'("-x");
665 Args
(5 + Preproc_Switches
'Length) := new String'("ada");
667 -- Get the path and file names
669 if File_Names_Case_Sensitive then
670 Path_Name (1 .. Path_Last) := File_Path;
672 Path_Name (1 .. Path_Last) := To_Lower (File_Path);
675 Path_Name (Path_Last + 1 .. Path_Name'Last) :=
676 Project_File_Extension;
678 -- Get the end of directory information, if any
680 for Index in reverse 1 .. Path_Last loop
681 if Path_Name (Index) = Directory_Separator then
682 Directory_Last := Index;
688 if Path_Last < Project_File_Extension'Length + 1
690 (Path_Last - Project_File_Extension'Length + 1 .. Path_Last)
691 /= Project_File_Extension
693 Path_Last := Path_Name'Last;
696 Output_Name (1 .. Path_Last) := To_Lower (Path_Name (1 .. Path_Last));
697 Output_Name_Last := Path_Last - Project_File_Extension'Length;
699 -- If there is already a project file with the specified name, parse
700 -- it to get the components that are not automatically generated.
702 if Is_Regular_File (Output_Name (1 .. Path_Last)) then
703 if Opt.Verbose_Mode then
704 Output.Write_Str ("Parsing already existing project file """);
705 Output.Write_Str (Output_Name (1 .. Output_Name_Last));
706 Output.Write_Line ("""");
710 (Project => Project_Node,
711 Project_File_Name => Output_Name (1 .. Output_Name_Last),
712 Always_Errout_Finalize => False);
714 -- Fail if parsing was not successful
716 if Project_Node = Empty_Node then
717 Fail ("parsing of existing project file failed");
720 -- If parsing was successful, remove the components that are
721 -- automatically generated, if any, so that they will be
722 -- unconditionally added later.
724 -- Remove the with clause for the naming project file
727 With_Clause : Project_Node_Id :=
728 First_With_Clause_Of (Project_Node);
729 Previous : Project_Node_Id := Empty_Node;
732 while With_Clause /= Empty_Node loop
733 if Tree.Name_Of (With_Clause) = Project_Naming_Id then
734 if Previous = Empty_Node then
735 Set_First_With_Clause_Of
737 To => Next_With_Clause_Of (With_Clause));
739 Set_Next_With_Clause_Of
741 To => Next_With_Clause_Of (With_Clause));
747 Previous := With_Clause;
748 With_Clause := Next_With_Clause_Of (With_Clause);
752 -- Remove attribute declarations of Source_Files,
753 -- Source_List_File, Source_Dirs, and the declaration of
754 -- package Naming, if they exist.
757 Declaration : Project_Node_Id :=
758 First_Declarative_Item_Of
759 (Project_Declaration_Of
761 Previous : Project_Node_Id := Empty_Node;
762 Current_Node : Project_Node_Id := Empty_Node;
765 while Declaration /= Empty_Node loop
766 Current_Node := Current_Item_Node (Declaration);
768 if (Kind_Of (Current_Node) = N_Attribute_Declaration
770 (Tree.Name_Of (Current_Node) = Name_Source_Files
771 or else Tree.Name_Of (Current_Node) =
772 Name_Source_List_File
773 or else Tree.Name_Of (Current_Node) =
776 (Kind_Of (Current_Node) = N_Package_Declaration
777 and then Tree.Name_Of (Current_Node) = Name_Naming)
779 if Previous = Empty_Node then
780 Set_First_Declarative_Item_Of
781 (Project_Declaration_Of (Project_Node),
782 To => Next_Declarative_Item (Declaration));
785 Set_Next_Declarative_Item
787 To => Next_Declarative_Item (Declaration));
791 Previous := Declaration;
794 Declaration := Next_Declarative_Item (Declaration);
800 if Directory_Last /= 0 then
801 Output_Name (1 .. Output_Name_Last - Directory_Last) :=
802 Output_Name (Directory_Last + 1 .. Output_Name_Last);
803 Output_Name_Last := Output_Name_Last - Directory_Last;
806 -- Get the project name id
808 Name_Len := Output_Name_Last;
809 Name_Buffer (1 .. Name_Len) := Output_Name (1 .. Name_Len);
810 Output_Name_Id := Name_Find;
812 -- Create the project naming file name
814 Project_Naming_Last := Output_Name_Last;
815 Project_Naming_File_Name (1 .. Project_Naming_Last) :=
816 Output_Name (1 .. Project_Naming_Last);
817 Project_Naming_File_Name
818 (Project_Naming_Last + 1 ..
819 Project_Naming_Last + Naming_File_Suffix'Length) :=
821 Project_Naming_Last :=
822 Project_Naming_Last + Naming_File_Suffix'Length;
824 -- Get the project naming id
826 Name_Len := Project_Naming_Last;
827 Name_Buffer (1 .. Name_Len) :=
828 Project_Naming_File_Name (1 .. Name_Len);
829 Project_Naming_Id := Name_Find;
831 Project_Naming_File_Name
832 (Project_Naming_Last + 1 ..
833 Project_Naming_Last + Project_File_Extension'Length) :=
834 Project_File_Extension;
835 Project_Naming_Last :=
836 Project_Naming_Last + Project_File_Extension'Length;
838 -- Create the source list file name
840 Source_List_Last := Output_Name_Last;
841 Source_List_Path (1 .. Source_List_Last) :=
842 Output_Name (1 .. Source_List_Last);
844 (Source_List_Last + 1 ..
845 Source_List_Last + Source_List_File_Suffix'Length) :=
846 Source_List_File_Suffix;
847 Source_List_Last := Source_List_Last + Source_List_File_Suffix'Length;
849 -- Add the project file extension to the project name
852 (Output_Name_Last + 1 ..
853 Output_Name_Last + Project_File_Extension'Length) :=
854 Project_File_Extension;
855 Output_Name_Last := Output_Name_Last + Project_File_Extension'Length;
858 -- Change the current directory to the directory of the project file,
859 -- if any directory information is specified.
861 if Directory_Last /= 0 then
863 Change_Dir (Path_Name (1 .. Directory_Last));
865 when Directory_Error =>
867 ("unknown directory """,
868 Path_Name (1 .. Directory_Last),
875 -- Delete the source list file, if it already exists
881 (Source_List_Path (1 .. Source_List_Last),
885 -- And create a new source list file.
886 -- Fail if file cannot be created.
888 Source_List_FD := Create_New_File
889 (Name => Source_List_Path (1 .. Source_List_Last),
892 if Source_List_FD = Invalid_FD then
894 ("cannot create file """,
895 Source_List_Path (1 .. Source_List_Last),
900 -- Compile the regular expressions. Fails immediately if any of
901 -- the specified strings is in error.
903 for Index in Excluded_Expressions'Range loop
905 Output.Write_Str ("Excluded pattern: """);
906 Output.Write_Str (Excluded_Patterns (Index).all);
907 Output.Write_Line ("""");
911 Excluded_Expressions (Index) :=
912 Compile (Pattern => Excluded_Patterns (Index).all, Glob => True);
914 when Error_In_Regexp =>
916 ("invalid regular expression """,
917 Excluded_Patterns (Index).all,
922 for Index in Foreign_Expressions'Range loop
924 Output.Write_Str ("Foreign pattern: """);
925 Output.Write_Str (Foreign_Patterns (Index).all);
926 Output.Write_Line ("""");
930 Foreign_Expressions (Index) :=
931 Compile (Pattern => Foreign_Patterns (Index).all, Glob => True);
933 when Error_In_Regexp =>
935 ("invalid regular expression """,
936 Foreign_Patterns (Index).all,
941 for Index in Regular_Expressions'Range loop
943 Output.Write_Str ("Pattern: """);
944 Output.Write_Str (Name_Patterns (Index).all);
945 Output.Write_Line ("""");
949 Regular_Expressions (Index) :=
950 Compile (Pattern => Name_Patterns (Index).all, Glob => True);
953 when Error_In_Regexp =>
955 ("invalid regular expression """,
956 Name_Patterns (Index).all,
962 if Opt.Verbose_Mode then
963 Output.Write_Str ("Naming project file name is """);
965 (Project_Naming_File_Name (1 .. Project_Naming_Last));
966 Output.Write_Line ("""");
969 -- If there were no already existing project file, or if the parsing
970 -- was unsuccessful, create an empty project node with the correct
971 -- name and its project declaration node.
973 if Project_Node = Empty_Node then
974 Project_Node := Default_Project_Node (Of_Kind => N_Project);
975 Set_Name_Of (Project_Node, To => Output_Name_Id);
976 Set_Project_Declaration_Of
978 To => Default_Project_Node (Of_Kind => N_Project_Declaration));
982 -- Create the naming project node, and add an attribute declaration
983 -- for Source_Files as an empty list, to indicate there are no
984 -- sources in the naming project.
986 Project_Naming_Node := Default_Project_Node (Of_Kind => N_Project);
987 Set_Name_Of (Project_Naming_Node, To => Project_Naming_Id);
988 Project_Naming_Decl :=
989 Default_Project_Node (Of_Kind => N_Project_Declaration);
990 Set_Project_Declaration_Of (Project_Naming_Node, Project_Naming_Decl);
992 Default_Project_Node (Of_Kind => N_Package_Declaration);
993 Set_Name_Of (Naming_Package, To => Name_Naming);
996 Decl_Item : constant Project_Node_Id :=
997 Default_Project_Node (Of_Kind => N_Declarative_Item);
999 Attribute : constant Project_Node_Id :=
1000 Default_Project_Node
1001 (Of_Kind => N_Attribute_Declaration,
1002 And_Expr_Kind => List);
1004 Expression : constant Project_Node_Id :=
1005 Default_Project_Node
1006 (Of_Kind => N_Expression,
1007 And_Expr_Kind => List);
1009 Term : constant Project_Node_Id :=
1010 Default_Project_Node
1012 And_Expr_Kind => List);
1014 Empty_List : constant Project_Node_Id :=
1015 Default_Project_Node
1016 (Of_Kind => N_Literal_String_List);
1019 Set_First_Declarative_Item_Of
1020 (Project_Naming_Decl, To => Decl_Item);
1021 Set_Next_Declarative_Item (Decl_Item, Naming_Package);
1022 Set_Current_Item_Node (Decl_Item, To => Attribute);
1023 Set_Name_Of (Attribute, To => Name_Source_Files);
1024 Set_Expression_Of (Attribute, To => Expression);
1025 Set_First_Term (Expression, To => Term);
1026 Set_Current_Term (Term, To => Empty_List);
1029 -- Add a with clause on the naming project in the main project
1032 With_Clause : constant Project_Node_Id :=
1033 Default_Project_Node (Of_Kind => N_With_Clause);
1036 Set_Next_With_Clause_Of
1037 (With_Clause, To => First_With_Clause_Of (Project_Node));
1038 Set_First_With_Clause_Of (Project_Node, To => With_Clause);
1039 Set_Name_Of (With_Clause, To => Project_Naming_Id);
1041 -- We set the project node to something different than
1042 -- Empty_Node, so that Prj.PP does not generate a limited
1045 Set_Project_Node_Of (With_Clause, Non_Empty_Node);
1047 Name_Len := Project_Naming_Last;
1048 Name_Buffer (1 .. Name_Len) :=
1049 Project_Naming_File_Name (1 .. Project_Naming_Last);
1050 Set_String_Value_Of (With_Clause, To => Name_Find);
1053 Project_Declaration := Project_Declaration_Of (Project_Node);
1055 -- Add a renaming declaration for package Naming in the main project
1058 Decl_Item : constant Project_Node_Id :=
1059 Default_Project_Node (Of_Kind => N_Declarative_Item);
1061 Naming : constant Project_Node_Id :=
1062 Default_Project_Node (Of_Kind => N_Package_Declaration);
1064 Set_Next_Declarative_Item
1066 To => First_Declarative_Item_Of (Project_Declaration));
1067 Set_First_Declarative_Item_Of
1068 (Project_Declaration, To => Decl_Item);
1069 Set_Current_Item_Node (Decl_Item, To => Naming);
1070 Set_Name_Of (Naming, To => Name_Naming);
1071 Set_Project_Of_Renamed_Package_Of
1072 (Naming, To => Project_Naming_Node);
1075 -- Add an attribute declaration for Source_Dirs, initialized as an
1076 -- empty list. Directories will be added as they are read from the
1077 -- directory list file.
1080 Decl_Item : constant Project_Node_Id :=
1081 Default_Project_Node (Of_Kind => N_Declarative_Item);
1083 Attribute : constant Project_Node_Id :=
1084 Default_Project_Node
1085 (Of_Kind => N_Attribute_Declaration,
1086 And_Expr_Kind => List);
1088 Expression : constant Project_Node_Id :=
1089 Default_Project_Node
1090 (Of_Kind => N_Expression,
1091 And_Expr_Kind => List);
1093 Term : constant Project_Node_Id :=
1094 Default_Project_Node
1095 (Of_Kind => N_Term, And_Expr_Kind => List);
1098 Set_Next_Declarative_Item
1100 To => First_Declarative_Item_Of (Project_Declaration));
1101 Set_First_Declarative_Item_Of
1102 (Project_Declaration, To => Decl_Item);
1103 Set_Current_Item_Node (Decl_Item, To => Attribute);
1104 Set_Name_Of (Attribute, To => Name_Source_Dirs);
1105 Set_Expression_Of (Attribute, To => Expression);
1106 Set_First_Term (Expression, To => Term);
1108 Default_Project_Node (Of_Kind => N_Literal_String_List,
1109 And_Expr_Kind => List);
1110 Set_Current_Term (Term, To => Source_Dirs_List);
1113 -- Add an attribute declaration for Source_List_File with the
1114 -- source list file name that will be created.
1117 Decl_Item : constant Project_Node_Id :=
1118 Default_Project_Node (Of_Kind => N_Declarative_Item);
1120 Attribute : constant Project_Node_Id :=
1121 Default_Project_Node
1122 (Of_Kind => N_Attribute_Declaration,
1123 And_Expr_Kind => Single);
1125 Expression : constant Project_Node_Id :=
1126 Default_Project_Node
1127 (Of_Kind => N_Expression,
1128 And_Expr_Kind => Single);
1130 Term : constant Project_Node_Id :=
1131 Default_Project_Node
1133 And_Expr_Kind => Single);
1135 Value : constant Project_Node_Id :=
1136 Default_Project_Node
1137 (Of_Kind => N_Literal_String,
1138 And_Expr_Kind => Single);
1141 Set_Next_Declarative_Item
1143 To => First_Declarative_Item_Of (Project_Declaration));
1144 Set_First_Declarative_Item_Of
1145 (Project_Declaration, To => Decl_Item);
1146 Set_Current_Item_Node (Decl_Item, To => Attribute);
1147 Set_Name_Of (Attribute, To => Name_Source_List_File);
1148 Set_Expression_Of (Attribute, To => Expression);
1149 Set_First_Term (Expression, To => Term);
1150 Set_Current_Term (Term, To => Value);
1151 Name_Len := Source_List_Last;
1152 Name_Buffer (1 .. Name_Len) :=
1153 Source_List_Path (1 .. Source_List_Last);
1154 Set_String_Value_Of (Value, To => Name_Find);
1158 -- Process each directory
1160 for Index in Directories'Range loop
1163 Dir_Name : constant String := Directories (Index).all;
1164 Last : Natural := Dir_Name'Last;
1165 Recursively : Boolean := False;
1167 if Dir_Name'Length >= 4
1168 and then (Dir_Name (Last - 2 .. Last) = "/**")
1171 Recursively := True;
1174 if Project_File then
1176 -- Add the directory in the list for attribute Source_Dirs
1179 Expression : constant Project_Node_Id :=
1180 Default_Project_Node
1181 (Of_Kind => N_Expression,
1182 And_Expr_Kind => Single);
1184 Term : constant Project_Node_Id :=
1185 Default_Project_Node
1187 And_Expr_Kind => Single);
1189 Value : constant Project_Node_Id :=
1190 Default_Project_Node
1191 (Of_Kind => N_Literal_String,
1192 And_Expr_Kind => Single);
1195 if Current_Source_Dir = Empty_Node then
1196 Set_First_Expression_In_List
1197 (Source_Dirs_List, To => Expression);
1199 Set_Next_Expression_In_List
1200 (Current_Source_Dir, To => Expression);
1203 Current_Source_Dir := Expression;
1204 Set_First_Term (Expression, To => Term);
1205 Set_Current_Term (Term, To => Value);
1206 Name_Len := Dir_Name'Length;
1207 Name_Buffer (1 .. Name_Len) := Dir_Name;
1208 Set_String_Value_Of (Value, To => Name_Find);
1212 Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively);
1217 if Project_File then
1218 Close (Source_List_FD);
1225 -- Delete the file if it already exists
1228 (Path_Name (Directory_Last + 1 .. Path_Last),
1229 Success => Discard);
1233 if Opt.Verbose_Mode then
1234 Output.Write_Str ("Creating new file """);
1235 Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last));
1236 Output.Write_Line ("""");
1239 Output_FD := Create_New_File
1240 (Path_Name (Directory_Last + 1 .. Path_Last),
1243 -- Fails if project file cannot be created
1245 if Output_FD = Invalid_FD then
1247 ("cannot create new """, Path_Name (1 .. Path_Last), """");
1250 if Project_File then
1252 -- Output the project file
1256 W_Char => Write_A_Char'Access,
1257 W_Eol => Write_Eol'Access,
1258 W_Str => Write_A_String'Access,
1259 Backward_Compatibility => False);
1262 -- Delete the naming project file if it already exists
1265 (Project_Naming_File_Name (1 .. Project_Naming_Last),
1266 Success => Discard);
1270 if Opt.Verbose_Mode then
1271 Output.Write_Str ("Creating new naming project file """);
1272 Output.Write_Str (Project_Naming_File_Name
1273 (1 .. Project_Naming_Last));
1274 Output.Write_Line ("""");
1277 Output_FD := Create_New_File
1278 (Project_Naming_File_Name (1 .. Project_Naming_Last),
1281 -- Fails if naming project file cannot be created
1283 if Output_FD = Invalid_FD then
1285 ("cannot create new """,
1286 Project_Naming_File_Name (1 .. Project_Naming_Last),
1290 -- Output the naming project file
1293 (Project_Naming_Node,
1294 W_Char => Write_A_Char'Access,
1295 W_Eol => Write_Eol'Access,
1296 W_Str => Write_A_String'Access,
1297 Backward_Compatibility => False);
1301 -- Write to the output file each entry in the SFN_Pragmas table
1302 -- as an pragma Source_File_Name.
1304 for Index in 1 .. SFN_Pragmas.Last loop
1305 Write_A_String ("pragma Source_File_Name");
1307 Write_A_String (" (");
1309 (Get_Name_String (SFN_Pragmas.Table (Index).Unit));
1310 Write_A_String (",");
1313 if SFN_Pragmas.Table (Index).Spec then
1314 Write_A_String (" Spec_File_Name => """);
1317 Write_A_String (" Body_File_Name => """);
1321 (Get_Name_String (SFN_Pragmas.Table (Index).File));
1323 Write_A_String ("""");
1325 if SFN_Pragmas.Table (Index).Index /= 0 then
1326 Write_A_String (", Index =>");
1327 Write_A_String (SFN_Pragmas.Table (Index).Index'Img);
1330 Write_A_String (");");
1343 procedure Write_A_Char (C : Character) is
1345 Write_A_String ((1 => C));
1352 procedure Write_Eol is
1354 Write_A_String ((1 => ASCII.LF));
1357 --------------------
1358 -- Write_A_String --
1359 --------------------
1361 procedure Write_A_String (S : String) is
1362 Str : String (1 .. S'Length);
1365 if S'Length > 0 then
1368 if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then
1369 Prj.Com.Fail ("disk full");