1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2004 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;
48 package body Prj.Makr is
50 function Dup (Fd : File_Descriptor) return File_Descriptor;
51 pragma Import (C, Dup);
53 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
54 pragma Import (C, Dup2);
56 Gcc : constant String := "gcc";
57 Gcc_Path : String_Access := null;
59 Non_Empty_Node : constant Project_Node_Id := 1;
60 -- Used for the With_Clause of the naming project
62 type Matched_Type is (True, False, Excluded);
64 Naming_File_Suffix : constant String := "_naming";
65 Source_List_File_Suffix : constant String := "_source_list.txt";
67 Output_FD : File_Descriptor;
68 -- To save the project file and its naming project file.
71 -- Output an empty line.
73 procedure Write_A_Char (C : Character);
74 -- Write one character to Output_FD
76 procedure Write_A_String (S : String);
77 -- Write a String to Output_FD
79 package Processed_Directories is new Table.Table
80 (Table_Component_Type => String_Access,
81 Table_Index_Type => Natural,
84 Table_Increment => 10,
85 Table_Name => "Prj.Makr.Processed_Directories");
93 Project_File : Boolean;
94 Directories : Argument_List;
95 Name_Patterns : Argument_List;
96 Excluded_Patterns : Argument_List;
97 Foreign_Patterns : Argument_List;
98 Preproc_Switches : Argument_List;
99 Very_Verbose : Boolean)
101 Path_Name : String (1 .. File_Path'Length +
102 Project_File_Extension'Length);
103 Path_Last : Natural := File_Path'Length;
105 Directory_Last : Natural := 0;
107 Output_Name : String (Path_Name'Range);
108 Output_Name_Last : Natural;
109 Output_Name_Id : Name_Id;
111 Project_Node : Project_Node_Id := Empty_Node;
112 Project_Declaration : Project_Node_Id := Empty_Node;
113 Source_Dirs_List : Project_Node_Id := Empty_Node;
114 Current_Source_Dir : Project_Node_Id := Empty_Node;
116 Project_Naming_Node : Project_Node_Id := Empty_Node;
117 Project_Naming_Decl : Project_Node_Id := Empty_Node;
118 Naming_Package : Project_Node_Id := Empty_Node;
120 Project_Naming_File_Name : String (1 .. Output_Name'Length +
121 Naming_File_Suffix'Length);
123 Project_Naming_Last : Natural;
124 Project_Naming_Id : Name_Id := No_Name;
126 Excluded_Expressions : array (Excluded_Patterns'Range) of Regexp;
127 Regular_Expressions : array (Name_Patterns'Range) of Regexp;
128 Foreign_Expressions : array (Foreign_Patterns'Range) of Regexp;
130 Source_List_Path : String (1 .. Output_Name'Length +
131 Source_List_File_Suffix'Length);
132 Source_List_Last : Natural;
134 Source_List_FD : File_Descriptor;
136 Args : Argument_List (1 .. Preproc_Switches'Length + 6);
138 type SFN_Pragma is record
144 package SFN_Pragmas is new Table.Table
145 (Table_Component_Type => SFN_Pragma,
146 Table_Index_Type => Natural,
147 Table_Low_Bound => 0,
149 Table_Increment => 50,
150 Table_Name => "Prj.Makr.SFN_Pragmas");
152 procedure Process_Directory (Dir_Name : String; Recursively : Boolean);
153 -- Look for Ada and foreign sources in a directory, according to the
154 -- patterns. When Recursively is True, after looking for sources in
155 -- Dir_Name, look also in its subdirectories, if any.
157 -----------------------
158 -- Process_Directory --
159 -----------------------
161 procedure Process_Directory (Dir_Name : String; Recursively : Boolean) is
162 Matched : Matched_Type := False;
163 Str : String (1 .. 2_000);
166 Process : Boolean := True;
168 Temp_File_Name : String_Access := null;
170 Save_Last_Pragma_Index : Natural := 0;
172 File_Name_Id : Name_Id := No_Name;
174 SFN_Prag : SFN_Pragma;
177 -- Avoid processing the same directory more than once
179 for Index in 1 .. Processed_Directories.Last loop
180 if Processed_Directories.Table (Index).all = Dir_Name then
187 if Opt.Verbose_Mode then
188 Output.Write_Str ("Processing directory """);
189 Output.Write_Str (Dir_Name);
190 Output.Write_Line ("""");
193 Processed_Directories. Increment_Last;
194 Processed_Directories.Table (Processed_Directories.Last) :=
195 new String'(Dir_Name);
197 -- Get the source file names from the directory.
198 -- Fails if the directory does not exist.
201 Open (Dir, Dir_Name);
204 when Directory_Error =>
205 Prj.Com.Fail ("cannot open directory """, Dir_Name, """");
208 -- Process each regular file in the directory
211 Read (Dir, Str, Last);
212 exit File_Loop when Last = 0;
215 (Dir_Name & Directory_Separator & Str (1 .. Last))
220 Name_Buffer (1 .. Name_Len) := Str (1 .. Last);
221 File_Name_Id := Name_Find;
223 -- First, check if the file name matches at least one of
224 -- the excluded expressions;
226 for Index in Excluded_Expressions'Range loop
228 Match (Str (1 .. Last), Excluded_Expressions (Index))
235 -- If it does not match any of the excluded expressions,
236 -- check if the file name matches at least one of the
237 -- regular expressions.
239 if Matched = True then
242 for Index in Regular_Expressions'Range loop
244 Match (Str (1 .. Last), Regular_Expressions (Index))
253 or else (Matched = True and then Opt.Verbose_Mode)
255 Output.Write_Str (" Checking """);
256 Output.Write_Str (Str (1 .. Last));
257 Output.Write_Str (""": ");
260 -- If the file name matches one of the regular expressions,
261 -- parse it to get its unit name.
263 if Matched = True then
265 FD : File_Descriptor;
267 Saved_Output : File_Descriptor;
268 Saved_Error : File_Descriptor;
271 -- If we don't have the path of the compiler yet,
274 if Gcc_Path = null then
275 Gcc_Path := Locate_Exec_On_Path (Gcc);
277 if Gcc_Path = null then
278 Prj.Com.Fail ("could not locate " & Gcc);
282 -- If we don't have yet the file name of the
283 -- temporary file, get it now.
285 if Temp_File_Name = null then
286 Create_Temp_File (FD, Temp_File_Name);
288 if FD = Invalid_FD then
290 ("could not create temporary file");
294 Delete_File (Temp_File_Name.all, Success);
297 Args (Args'Last) := new String'
299 Directory_Separator &
302 -- Create the temporary file
304 FD := Create_Output_Text_File
305 (Name => Temp_File_Name.all);
307 if FD = Invalid_FD then
309 ("could not create temporary file");
312 -- Save the standard output and error
314 Saved_Output := Dup (Standout);
315 Saved_Error := Dup (Standerr);
317 -- Set standard output and error to the temporary file
322 -- And spawn the compiler
324 Spawn (Gcc_Path.all, Args, Success);
326 -- Restore the standard output and error
328 Dup2 (Saved_Output, Standout);
329 Dup2 (Saved_Error, Standerr);
331 -- Close the temporary file
335 -- And close the saved standard output and error to
336 -- avoid too many file descriptors.
338 Close (Saved_Output);
341 -- Now that standard output is restored, check if
342 -- the compiler ran correctly.
344 -- Read the lines of the temporary file:
345 -- they should contain the kind and name of the unit.
349 Text_Line : String (1 .. 1_000);
353 Open (File, Temp_File_Name.all);
355 if not Is_Valid (File) then
357 ("could not read temporary file");
360 Save_Last_Pragma_Index := SFN_Pragmas.Last;
362 if End_Of_File (File) then
363 if Opt.Verbose_Mode then
365 Output.Write_Str ("(process died) ");
370 Line_Loop : while not End_Of_File (File) loop
371 Get_Line (File, Text_Line, Text_Last);
373 -- Find the first closing parenthesis
375 Char_Loop : for J in 1 .. Text_Last loop
376 if Text_Line (J) = ')' then
378 Text_Line (1 .. 4) = "Unit"
380 -- Add entry to SFN_Pragmas table
383 Name_Buffer (1 .. Name_Len) :=
384 Text_Line (6 .. J - 7);
387 File => File_Name_Id,
388 Spec => Text_Line (J - 5 .. J) =
391 SFN_Pragmas.Increment_Last;
393 (SFN_Pragmas.Last) := SFN_Prag;
401 if Save_Last_Pragma_Index = SFN_Pragmas.Last then
402 if Opt.Verbose_Mode then
403 Output.Write_Line ("not a unit");
406 elsif SFN_Pragmas.Last >
407 Save_Last_Pragma_Index + 1
409 SFN_Pragmas.Set_Last (Save_Last_Pragma_Index);
411 if Opt.Verbose_Mode then
413 ("file contains multiple units");
417 SFN_Prag := SFN_Pragmas.Table
420 if Opt.Verbose_Mode then
421 if SFN_Prag.Spec then
422 Output.Write_Str ("spec of ");
425 Output.Write_Str ("body of ");
429 (Get_Name_String (SFN_Prag.Unit));
434 -- Add the corresponding attribute in the
435 -- Naming package of the naming project.
438 Decl_Item : constant Project_Node_Id :=
443 Attribute : constant Project_Node_Id :=
446 N_Attribute_Declaration);
448 Expression : constant Project_Node_Id :=
450 (Of_Kind => N_Expression,
451 And_Expr_Kind => Single);
453 Term : constant Project_Node_Id :=
456 And_Expr_Kind => Single);
458 Value : constant Project_Node_Id :=
460 (Of_Kind => N_Literal_String,
461 And_Expr_Kind => Single);
464 Set_Next_Declarative_Item
466 To => First_Declarative_Item_Of
468 Set_First_Declarative_Item_Of
469 (Naming_Package, To => Decl_Item);
470 Set_Current_Item_Node
471 (Decl_Item, To => Attribute);
473 -- Is it a spec or a body?
475 if SFN_Prag.Spec then
477 (Attribute, To => Name_Spec);
484 -- Get the name of the unit
486 Get_Name_String (SFN_Prag.Unit);
487 To_Lower (Name_Buffer (1 .. Name_Len));
488 Set_Associative_Array_Index_Of
489 (Attribute, To => Name_Find);
492 (Attribute, To => Expression);
494 (Expression, To => Term);
495 Set_Current_Term (Term, To => Value);
497 -- And set the name of the file
500 (Value, To => File_Name_Id);
503 -- Add source file name to source list file
506 Str (Last) := ASCII.LF;
508 if Write (Source_List_FD,
512 Prj.Com.Fail ("disk full");
519 Delete_File (Temp_File_Name.all, Success);
523 -- File name matches none of the regular expressions
526 -- If file is not excluded, see if this is foreign source
528 if Matched /= Excluded then
529 for Index in Foreign_Expressions'Range loop
530 if Match (Str (1 .. Last),
531 Foreign_Expressions (Index))
542 Output.Write_Line ("no match");
545 Output.Write_Line ("excluded");
548 Output.Write_Line ("foreign source");
552 if Project_File and Matched = True then
554 -- Add source file name to source list file
557 Str (Last) := ASCII.LF;
559 if Write (Source_List_FD,
563 Prj.Com.Fail ("disk full");
573 -- If Recursively is True, call itself for each subdirectory.
574 -- We do that, even when this directory has already been processed,
575 -- because all of its subdirectories may not have been processed.
578 Open (Dir, Dir_Name);
581 Read (Dir, Str, Last);
584 -- Do not call itself for "." or ".."
587 (Dir_Name & Directory_Separator & Str (1 .. Last))
588 and then Str (1 .. Last) /= "."
589 and then Str (1 .. Last) /= ".."
592 (Dir_Name & Directory_Separator & Str (1 .. Last),
593 Recursively => True);
599 end Process_Directory;
601 -- Start of processing for Make
604 -- Do some needed initializations
611 SFN_Pragmas.Set_Last (0);
613 Processed_Directories.Set_Last (0);
615 -- Initialize the compiler switches
617 Args (1) := new String'("-c");
618 Args (2) := new String'("-gnats");
619 Args (3) := new String'("-gnatu");
620 Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches;
621 Args (4 + Preproc_Switches'Length) := new String'("-x");
622 Args (5 + Preproc_Switches'Length) := new String'("ada");
624 -- Get the path and file names
626 if File_Names_Case_Sensitive then
627 Path_Name (1 .. Path_Last) := File_Path;
629 Path_Name (1 .. Path_Last) := To_Lower (File_Path);
632 Path_Name (Path_Last + 1 .. Path_Name'Last) :=
633 Project_File_Extension;
635 -- Get the end of directory information, if any
637 for Index in reverse 1 .. Path_Last loop
638 if Path_Name (Index) = Directory_Separator then
639 Directory_Last := Index;
645 if Path_Last < Project_File_Extension'Length + 1
647 (Path_Last - Project_File_Extension'Length + 1 .. Path_Last)
648 /= Project_File_Extension
650 Path_Last := Path_Name'Last;
653 Output_Name (1 .. Path_Last) := To_Lower (Path_Name (1 .. Path_Last));
654 Output_Name_Last := Path_Last - Project_File_Extension'Length;
656 if Directory_Last /= 0 then
657 Output_Name (1 .. Output_Name_Last - Directory_Last) :=
658 Output_Name (Directory_Last + 1 .. Output_Name_Last);
659 Output_Name_Last := Output_Name_Last - Directory_Last;
662 -- Get the project name id
664 Name_Len := Output_Name_Last;
665 Name_Buffer (1 .. Name_Len) := Output_Name (1 .. Name_Len);
666 Output_Name_Id := Name_Find;
668 -- Create the project naming file name
670 Project_Naming_Last := Output_Name_Last;
671 Project_Naming_File_Name (1 .. Project_Naming_Last) :=
672 Output_Name (1 .. Project_Naming_Last);
673 Project_Naming_File_Name
674 (Project_Naming_Last + 1 ..
675 Project_Naming_Last + Naming_File_Suffix'Length) :=
677 Project_Naming_Last :=
678 Project_Naming_Last + Naming_File_Suffix'Length;
680 -- Get the project naming id
682 Name_Len := Project_Naming_Last;
683 Name_Buffer (1 .. Name_Len) :=
684 Project_Naming_File_Name (1 .. Name_Len);
685 Project_Naming_Id := Name_Find;
687 Project_Naming_File_Name
688 (Project_Naming_Last + 1 ..
689 Project_Naming_Last + Project_File_Extension'Length) :=
690 Project_File_Extension;
691 Project_Naming_Last :=
692 Project_Naming_Last + Project_File_Extension'Length;
694 -- Create the source list file name
696 Source_List_Last := Output_Name_Last;
697 Source_List_Path (1 .. Source_List_Last) :=
698 Output_Name (1 .. Source_List_Last);
700 (Source_List_Last + 1 ..
701 Source_List_Last + Source_List_File_Suffix'Length) :=
702 Source_List_File_Suffix;
703 Source_List_Last := Source_List_Last + Source_List_File_Suffix'Length;
705 -- Add the project file extension to the project name
708 (Output_Name_Last + 1 ..
709 Output_Name_Last + Project_File_Extension'Length) :=
710 Project_File_Extension;
711 Output_Name_Last := Output_Name_Last + Project_File_Extension'Length;
714 -- Change the current directory to the directory of the project file,
715 -- if any directory information is specified.
717 if Directory_Last /= 0 then
719 Change_Dir (Path_Name (1 .. Directory_Last));
721 when Directory_Error =>
723 ("unknown directory """,
724 Path_Name (1 .. Directory_Last),
731 -- Delete the source list file, if it already exists
737 (Source_List_Path (1 .. Source_List_Last),
741 -- And create a new source list file.
742 -- Fail if file cannot be created.
744 Source_List_FD := Create_New_File
745 (Name => Source_List_Path (1 .. Source_List_Last),
748 if Source_List_FD = Invalid_FD then
750 ("cannot create file """,
751 Source_List_Path (1 .. Source_List_Last),
756 -- Compile the regular expressions. Fails immediately if any of
757 -- the specified strings is in error.
759 for Index in Excluded_Expressions'Range loop
761 Output.Write_Str ("Excluded pattern: """);
762 Output.Write_Str (Excluded_Patterns (Index).all);
763 Output.Write_Line ("""");
767 Excluded_Expressions (Index) :=
768 Compile (Pattern => Excluded_Patterns (Index).all, Glob => True);
770 when Error_In_Regexp =>
772 ("invalid regular expression """,
773 Excluded_Patterns (Index).all,
778 for Index in Foreign_Expressions'Range loop
780 Output.Write_Str ("Foreign pattern: """);
781 Output.Write_Str (Foreign_Patterns (Index).all);
782 Output.Write_Line ("""");
786 Foreign_Expressions (Index) :=
787 Compile (Pattern => Foreign_Patterns (Index).all, Glob => True);
789 when Error_In_Regexp =>
791 ("invalid regular expression """,
792 Foreign_Patterns (Index).all,
797 for Index in Regular_Expressions'Range loop
799 Output.Write_Str ("Pattern: """);
800 Output.Write_Str (Name_Patterns (Index).all);
801 Output.Write_Line ("""");
805 Regular_Expressions (Index) :=
806 Compile (Pattern => Name_Patterns (Index).all, Glob => True);
809 when Error_In_Regexp =>
811 ("invalid regular expression """,
812 Name_Patterns (Index).all,
818 if Opt.Verbose_Mode then
819 Output.Write_Str ("Naming project file name is """);
821 (Project_Naming_File_Name (1 .. Project_Naming_Last));
822 Output.Write_Line ("""");
825 -- If there is already a project file with the specified name,
826 -- parse it to get the components that are not automatically
829 if Is_Regular_File (Output_Name (1 .. Output_Name_Last)) then
830 if Opt.Verbose_Mode then
831 Output.Write_Str ("Parsing already existing project file """);
832 Output.Write_Str (Output_Name (1 .. Output_Name_Last));
833 Output.Write_Line ("""");
837 (Project => Project_Node,
838 Project_File_Name => Output_Name (1 .. Output_Name_Last),
839 Always_Errout_Finalize => False);
841 -- If parsing was successful, remove the components that are
842 -- automatically generated, if any, so that they will be
843 -- unconditionally added later.
845 if Project_Node /= Empty_Node then
847 -- Remove the with clause for the naming project file
850 With_Clause : Project_Node_Id :=
851 First_With_Clause_Of (Project_Node);
852 Previous : Project_Node_Id := Empty_Node;
855 while With_Clause /= Empty_Node loop
856 if Tree.Name_Of (With_Clause) = Project_Naming_Id then
857 if Previous = Empty_Node then
858 Set_First_With_Clause_Of
860 To => Next_With_Clause_Of (With_Clause));
862 Set_Next_With_Clause_Of
864 To => Next_With_Clause_Of (With_Clause));
870 Previous := With_Clause;
871 With_Clause := Next_With_Clause_Of (With_Clause);
875 -- Remove attribute declarations of Source_Files,
876 -- Source_List_File, Source_Dirs, and the declaration of
877 -- package Naming, if they exist.
880 Declaration : Project_Node_Id :=
881 First_Declarative_Item_Of
882 (Project_Declaration_Of
884 Previous : Project_Node_Id := Empty_Node;
885 Current_Node : Project_Node_Id := Empty_Node;
888 while Declaration /= Empty_Node loop
889 Current_Node := Current_Item_Node (Declaration);
891 if (Kind_Of (Current_Node) = N_Attribute_Declaration
893 (Tree.Name_Of (Current_Node) = Name_Source_Files
894 or else Tree.Name_Of (Current_Node) =
895 Name_Source_List_File
896 or else Tree.Name_Of (Current_Node) =
899 (Kind_Of (Current_Node) = N_Package_Declaration
900 and then Tree.Name_Of (Current_Node) = Name_Naming)
902 if Previous = Empty_Node then
903 Set_First_Declarative_Item_Of
904 (Project_Declaration_Of (Project_Node),
905 To => Next_Declarative_Item (Declaration));
908 Set_Next_Declarative_Item
910 To => Next_Declarative_Item (Declaration));
914 Previous := Declaration;
917 Declaration := Next_Declarative_Item (Declaration);
923 -- If there were no already existing project file, or if the parsing
924 -- was unsuccessful, create an empty project node with the correct
925 -- name and its project declaration node.
927 if Project_Node = Empty_Node then
928 Project_Node := Default_Project_Node (Of_Kind => N_Project);
929 Set_Name_Of (Project_Node, To => Output_Name_Id);
930 Set_Project_Declaration_Of
932 To => Default_Project_Node (Of_Kind => N_Project_Declaration));
936 -- Create the naming project node, and add an attribute declaration
937 -- for Source_Files as an empty list, to indicate there are no
938 -- sources in the naming project.
940 Project_Naming_Node := Default_Project_Node (Of_Kind => N_Project);
941 Set_Name_Of (Project_Naming_Node, To => Project_Naming_Id);
942 Project_Naming_Decl :=
943 Default_Project_Node (Of_Kind => N_Project_Declaration);
944 Set_Project_Declaration_Of (Project_Naming_Node, Project_Naming_Decl);
946 Default_Project_Node (Of_Kind => N_Package_Declaration);
947 Set_Name_Of (Naming_Package, To => Name_Naming);
950 Decl_Item : constant Project_Node_Id :=
951 Default_Project_Node (Of_Kind => N_Declarative_Item);
953 Attribute : constant Project_Node_Id :=
955 (Of_Kind => N_Attribute_Declaration,
956 And_Expr_Kind => List);
958 Expression : constant Project_Node_Id :=
960 (Of_Kind => N_Expression,
961 And_Expr_Kind => List);
963 Term : constant Project_Node_Id :=
966 And_Expr_Kind => List);
968 Empty_List : constant Project_Node_Id :=
970 (Of_Kind => N_Literal_String_List);
973 Set_First_Declarative_Item_Of
974 (Project_Naming_Decl, To => Decl_Item);
975 Set_Next_Declarative_Item (Decl_Item, Naming_Package);
976 Set_Current_Item_Node (Decl_Item, To => Attribute);
977 Set_Name_Of (Attribute, To => Name_Source_Files);
978 Set_Expression_Of (Attribute, To => Expression);
979 Set_First_Term (Expression, To => Term);
980 Set_Current_Term (Term, To => Empty_List);
983 -- Add a with clause on the naming project in the main project
986 With_Clause : constant Project_Node_Id :=
987 Default_Project_Node (Of_Kind => N_With_Clause);
990 Set_Next_With_Clause_Of
991 (With_Clause, To => First_With_Clause_Of (Project_Node));
992 Set_First_With_Clause_Of (Project_Node, To => With_Clause);
993 Set_Name_Of (With_Clause, To => Project_Naming_Id);
995 -- We set the project node to something different than
996 -- Empty_Node, so that Prj.PP does not generate a limited
999 Set_Project_Node_Of (With_Clause, Non_Empty_Node);
1001 Name_Len := Project_Naming_Last;
1002 Name_Buffer (1 .. Name_Len) :=
1003 Project_Naming_File_Name (1 .. Project_Naming_Last);
1004 Set_String_Value_Of (With_Clause, To => Name_Find);
1007 Project_Declaration := Project_Declaration_Of (Project_Node);
1009 -- Add a renaming declaration for package Naming in the main project
1012 Decl_Item : constant Project_Node_Id :=
1013 Default_Project_Node (Of_Kind => N_Declarative_Item);
1015 Naming : constant Project_Node_Id :=
1016 Default_Project_Node (Of_Kind => N_Package_Declaration);
1018 Set_Next_Declarative_Item
1020 To => First_Declarative_Item_Of (Project_Declaration));
1021 Set_First_Declarative_Item_Of
1022 (Project_Declaration, To => Decl_Item);
1023 Set_Current_Item_Node (Decl_Item, To => Naming);
1024 Set_Name_Of (Naming, To => Name_Naming);
1025 Set_Project_Of_Renamed_Package_Of
1026 (Naming, To => Project_Naming_Node);
1029 -- Add an attribute declaration for Source_Dirs, initialized as an
1030 -- empty list. Directories will be added as they are read from the
1031 -- directory list file.
1034 Decl_Item : constant Project_Node_Id :=
1035 Default_Project_Node (Of_Kind => N_Declarative_Item);
1037 Attribute : constant Project_Node_Id :=
1038 Default_Project_Node
1039 (Of_Kind => N_Attribute_Declaration,
1040 And_Expr_Kind => List);
1042 Expression : constant Project_Node_Id :=
1043 Default_Project_Node
1044 (Of_Kind => N_Expression,
1045 And_Expr_Kind => List);
1047 Term : constant Project_Node_Id :=
1048 Default_Project_Node
1049 (Of_Kind => N_Term, And_Expr_Kind => List);
1052 Set_Next_Declarative_Item
1054 To => First_Declarative_Item_Of (Project_Declaration));
1055 Set_First_Declarative_Item_Of
1056 (Project_Declaration, To => Decl_Item);
1057 Set_Current_Item_Node (Decl_Item, To => Attribute);
1058 Set_Name_Of (Attribute, To => Name_Source_Dirs);
1059 Set_Expression_Of (Attribute, To => Expression);
1060 Set_First_Term (Expression, To => Term);
1062 Default_Project_Node (Of_Kind => N_Literal_String_List,
1063 And_Expr_Kind => List);
1064 Set_Current_Term (Term, To => Source_Dirs_List);
1067 -- Add an attribute declaration for Source_List_File with the
1068 -- source list file name that will be created.
1071 Decl_Item : constant Project_Node_Id :=
1072 Default_Project_Node (Of_Kind => N_Declarative_Item);
1074 Attribute : constant Project_Node_Id :=
1075 Default_Project_Node
1076 (Of_Kind => N_Attribute_Declaration,
1077 And_Expr_Kind => Single);
1079 Expression : constant Project_Node_Id :=
1080 Default_Project_Node
1081 (Of_Kind => N_Expression,
1082 And_Expr_Kind => Single);
1084 Term : constant Project_Node_Id :=
1085 Default_Project_Node
1087 And_Expr_Kind => Single);
1089 Value : constant Project_Node_Id :=
1090 Default_Project_Node
1091 (Of_Kind => N_Literal_String,
1092 And_Expr_Kind => Single);
1095 Set_Next_Declarative_Item
1097 To => First_Declarative_Item_Of (Project_Declaration));
1098 Set_First_Declarative_Item_Of
1099 (Project_Declaration, To => Decl_Item);
1100 Set_Current_Item_Node (Decl_Item, To => Attribute);
1101 Set_Name_Of (Attribute, To => Name_Source_List_File);
1102 Set_Expression_Of (Attribute, To => Expression);
1103 Set_First_Term (Expression, To => Term);
1104 Set_Current_Term (Term, To => Value);
1105 Name_Len := Source_List_Last;
1106 Name_Buffer (1 .. Name_Len) :=
1107 Source_List_Path (1 .. Source_List_Last);
1108 Set_String_Value_Of (Value, To => Name_Find);
1112 -- Process each directory
1114 for Index in Directories'Range loop
1117 Dir_Name : constant String := Directories (Index).all;
1118 Last : Natural := Dir_Name'Last;
1119 Recursively : Boolean := False;
1121 if Dir_Name'Length >= 4
1122 and then (Dir_Name (Last - 2 .. Last) = "/**")
1125 Recursively := True;
1128 if Project_File then
1130 -- Add the directory in the list for attribute Source_Dirs
1133 Expression : constant Project_Node_Id :=
1134 Default_Project_Node
1135 (Of_Kind => N_Expression,
1136 And_Expr_Kind => Single);
1138 Term : constant Project_Node_Id :=
1139 Default_Project_Node
1141 And_Expr_Kind => Single);
1143 Value : constant Project_Node_Id :=
1144 Default_Project_Node
1145 (Of_Kind => N_Literal_String,
1146 And_Expr_Kind => Single);
1149 if Current_Source_Dir = Empty_Node then
1150 Set_First_Expression_In_List
1151 (Source_Dirs_List, To => Expression);
1153 Set_Next_Expression_In_List
1154 (Current_Source_Dir, To => Expression);
1157 Current_Source_Dir := Expression;
1158 Set_First_Term (Expression, To => Term);
1159 Set_Current_Term (Term, To => Value);
1160 Name_Len := Dir_Name'Length;
1161 Name_Buffer (1 .. Name_Len) := Dir_Name;
1162 Set_String_Value_Of (Value, To => Name_Find);
1166 Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively);
1171 if Project_File then
1172 Close (Source_List_FD);
1179 -- Delete the file if it already exists
1182 (Path_Name (Directory_Last + 1 .. Path_Last),
1183 Success => Discard);
1187 if Opt.Verbose_Mode then
1188 Output.Write_Str ("Creating new file """);
1189 Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last));
1190 Output.Write_Line ("""");
1193 Output_FD := Create_New_File
1194 (Path_Name (Directory_Last + 1 .. Path_Last),
1197 -- Fails if project file cannot be created
1199 if Output_FD = Invalid_FD then
1201 ("cannot create new """, Path_Name (1 .. Path_Last), """");
1204 if Project_File then
1206 -- Output the project file
1210 W_Char => Write_A_Char'Access,
1211 W_Eol => Write_Eol'Access,
1212 W_Str => Write_A_String'Access,
1213 Backward_Compatibility => False);
1216 -- Delete the naming project file if it already exists
1219 (Project_Naming_File_Name (1 .. Project_Naming_Last),
1220 Success => Discard);
1224 if Opt.Verbose_Mode then
1225 Output.Write_Str ("Creating new naming project file """);
1226 Output.Write_Str (Project_Naming_File_Name
1227 (1 .. Project_Naming_Last));
1228 Output.Write_Line ("""");
1231 Output_FD := Create_New_File
1232 (Project_Naming_File_Name (1 .. Project_Naming_Last),
1235 -- Fails if naming project file cannot be created
1237 if Output_FD = Invalid_FD then
1239 ("cannot create new """,
1240 Project_Naming_File_Name (1 .. Project_Naming_Last),
1244 -- Output the naming project file
1247 (Project_Naming_Node,
1248 W_Char => Write_A_Char'Access,
1249 W_Eol => Write_Eol'Access,
1250 W_Str => Write_A_String'Access,
1251 Backward_Compatibility => False);
1255 -- Write to the output file each entry in the SFN_Pragmas table
1256 -- as an pragma Source_File_Name.
1258 for Index in 1 .. SFN_Pragmas.Last loop
1259 Write_A_String ("pragma Source_File_Name");
1261 Write_A_String (" (");
1263 (Get_Name_String (SFN_Pragmas.Table (Index).Unit));
1264 Write_A_String (",");
1267 if SFN_Pragmas.Table (Index).Spec then
1268 Write_A_String (" Spec_File_Name => """);
1271 Write_A_String (" Body_File_Name => """);
1275 (Get_Name_String (SFN_Pragmas.Table (Index).File));
1276 Write_A_String (""");");
1289 procedure Write_A_Char (C : Character) is
1291 Write_A_String ((1 => C));
1298 procedure Write_Eol is
1300 Write_A_String ((1 => ASCII.LF));
1303 --------------------
1304 -- Write_A_String --
1305 --------------------
1307 procedure Write_A_String (S : String) is
1308 Str : String (1 .. S'Length);
1311 if S'Length > 0 then
1314 if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then
1315 Prj.Com.Fail ("disk full");