1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2008, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
29 with Osint; use Osint;
34 with Prj.Tree; use Prj.Tree;
35 with Prj.Util; use Prj.Util;
36 with Snames; use Snames;
37 with Table; use Table;
39 with Ada.Characters.Handling; use Ada.Characters.Handling;
40 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
42 with System.Case_Util; use System.Case_Util;
45 package body Prj.Makr is
47 -- Packages of project files where unknown attributes are errors
49 -- All the following need comments ??? All global variables and
50 -- subprograms must be fully commented.
52 Very_Verbose : Boolean := False;
53 -- Set in call to Initialize to indicate very verbose output
55 Project_File : Boolean := False;
56 -- True when gnatname is creating/modifying a project file. False when
57 -- gnatname is creating a configuration pragmas file.
59 Tree : constant Project_Node_Tree_Ref := new Project_Node_Tree_Data;
60 -- The project tree where the project file is parsed
62 Args : Argument_List_Access;
63 -- The list of arguments for calls to the compiler to get the unit names
64 -- and kinds (spec or body) in the Ada sources.
66 Path_Name : String_Access;
70 Directory_Last : Natural := 0;
72 Output_Name : String_Access;
73 Output_Name_Last : Natural;
74 Output_Name_Id : Name_Id;
76 Project_Naming_File_Name : String_Access;
77 -- String (1 .. Output_Name'Length + Naming_File_Suffix'Length);
79 Project_Naming_Last : Natural;
80 Project_Naming_Id : Name_Id := No_Name;
82 Source_List_Path : String_Access;
83 -- (1 .. Output_Name'Length + Source_List_File_Suffix'Length);
84 Source_List_Last : Natural;
86 Source_List_FD : File_Descriptor;
88 Project_Node : Project_Node_Id := Empty_Node;
89 Project_Declaration : Project_Node_Id := Empty_Node;
90 Source_Dirs_List : Project_Node_Id := Empty_Node;
92 Project_Naming_Node : Project_Node_Id := Empty_Node;
93 Project_Naming_Decl : Project_Node_Id := Empty_Node;
94 Naming_Package : Project_Node_Id := Empty_Node;
95 Naming_Package_Comments : Project_Node_Id := Empty_Node;
97 Source_Files_Comments : Project_Node_Id := Empty_Node;
98 Source_Dirs_Comments : Project_Node_Id := Empty_Node;
99 Source_List_File_Comments : Project_Node_Id := Empty_Node;
101 Naming_String : aliased String := "naming";
103 Gnatname_Packages : aliased String_List := (1 => Naming_String'Access);
105 Packages_To_Check_By_Gnatname : constant String_List_Access :=
106 Gnatname_Packages'Access;
108 function Dup (Fd : File_Descriptor) return File_Descriptor;
110 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
112 Gcc : constant String := "gcc";
113 Gcc_Path : String_Access := null;
115 Non_Empty_Node : constant Project_Node_Id := 1;
116 -- Used for the With_Clause of the naming project
118 type Matched_Type is (True, False, Excluded);
120 Naming_File_Suffix : constant String := "_naming";
121 Source_List_File_Suffix : constant String := "_source_list.txt";
123 Output_FD : File_Descriptor;
124 -- To save the project file and its naming project file
127 -- Output an empty line
129 procedure Write_A_Char (C : Character);
130 -- Write one character to Output_FD
132 procedure Write_A_String (S : String);
133 -- Write a String to Output_FD
135 package Processed_Directories is new Table.Table
136 (Table_Component_Type => String_Access,
137 Table_Index_Type => Natural,
138 Table_Low_Bound => 0,
140 Table_Increment => 100,
141 Table_Name => "Prj.Makr.Processed_Directories");
142 -- The list of already processed directories for each section, to avoid
143 -- processing several times the same directory in the same section.
145 package Source_Directories is new Table.Table
146 (Table_Component_Type => String_Access,
147 Table_Index_Type => Natural,
148 Table_Low_Bound => 0,
150 Table_Increment => 100,
151 Table_Name => "Prj.Makr.Source_Directories");
152 -- The complete list of directories to be put in attribute Source_Dirs in
155 type Source is record
162 package Sources is new Table.Table
163 (Table_Component_Type => Source,
164 Table_Index_Type => Natural,
165 Table_Low_Bound => 0,
167 Table_Increment => 100,
168 Table_Name => "Prj.Makr.Sources");
169 -- The list of Ada sources found, with their unit name and kind, to be put
170 -- in the source attribute and package Naming of the project file, or in
171 -- the pragmas Source_File_Name in the configuration pragmas file.
177 function Dup (Fd : File_Descriptor) return File_Descriptor is
179 return File_Descriptor (System.CRTL.dup (Integer (Fd)));
186 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor) is
188 pragma Warnings (Off, Fd);
190 Fd := System.CRTL.dup2 (Integer (Old_Fd), Integer (New_Fd));
197 procedure Finalize is
199 pragma Warnings (Off, Discard);
201 Current_Source_Dir : Project_Node_Id := Empty_Node;
205 -- If there were no already existing project file, or if the parsing
206 -- was unsuccessful, create an empty project node with the correct
207 -- name and its project declaration node.
209 if No (Project_Node) then
211 Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree);
212 Set_Name_Of (Project_Node, Tree, To => Output_Name_Id);
213 Set_Project_Declaration_Of
215 To => Default_Project_Node
216 (Of_Kind => N_Project_Declaration, In_Tree => Tree));
222 -- Delete the file if it already exists
225 (Path_Name (Directory_Last + 1 .. Path_Last),
230 if Opt.Verbose_Mode then
231 Output.Write_Str ("Creating new file """);
232 Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last));
233 Output.Write_Line ("""");
236 Output_FD := Create_New_File
237 (Path_Name (Directory_Last + 1 .. Path_Last),
240 -- Fails if project file cannot be created
242 if Output_FD = Invalid_FD then
244 ("cannot create new """, Path_Name (1 .. Path_Last), """");
249 -- Delete the source list file, if it already exists
253 pragma Warnings (Off, Discard);
256 (Source_List_Path (1 .. Source_List_Last),
260 -- And create a new source list file. Fail if file cannot be created.
262 Source_List_FD := Create_New_File
263 (Name => Source_List_Path (1 .. Source_List_Last),
266 if Source_List_FD = Invalid_FD then
268 ("cannot create file """,
269 Source_List_Path (1 .. Source_List_Last),
273 if Opt.Verbose_Mode then
274 Output.Write_Str ("Naming project file name is """);
276 (Project_Naming_File_Name (1 .. Project_Naming_Last));
277 Output.Write_Line ("""");
280 -- Create the naming project node
282 Project_Naming_Node :=
283 Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree);
284 Set_Name_Of (Project_Naming_Node, Tree, To => Project_Naming_Id);
285 Project_Naming_Decl :=
287 (Of_Kind => N_Project_Declaration, In_Tree => Tree);
288 Set_Project_Declaration_Of
289 (Project_Naming_Node, Tree, Project_Naming_Decl);
292 (Of_Kind => N_Package_Declaration, In_Tree => Tree);
293 Set_Name_Of (Naming_Package, Tree, To => Name_Naming);
295 -- Add an attribute declaration for Source_Files as an empty list (to
296 -- indicate there are no sources in the naming project) and a package
297 -- Naming (that will be filled later).
300 Decl_Item : constant Project_Node_Id :=
302 (Of_Kind => N_Declarative_Item, In_Tree => Tree);
304 Attribute : constant Project_Node_Id :=
306 (Of_Kind => N_Attribute_Declaration,
308 And_Expr_Kind => List);
310 Expression : constant Project_Node_Id :=
312 (Of_Kind => N_Expression,
314 And_Expr_Kind => List);
316 Term : constant Project_Node_Id :=
320 And_Expr_Kind => List);
322 Empty_List : constant Project_Node_Id :=
324 (Of_Kind => N_Literal_String_List,
328 Set_First_Declarative_Item_Of
329 (Project_Naming_Decl, Tree, To => Decl_Item);
330 Set_Next_Declarative_Item (Decl_Item, Tree, Naming_Package);
331 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
332 Set_Name_Of (Attribute, Tree, To => Name_Source_Files);
333 Set_Expression_Of (Attribute, Tree, To => Expression);
334 Set_First_Term (Expression, Tree, To => Term);
335 Set_Current_Term (Term, Tree, To => Empty_List);
338 -- Add a with clause on the naming project in the main project, if
339 -- there is not already one.
342 With_Clause : Project_Node_Id :=
343 First_With_Clause_Of (Project_Node, Tree);
346 while Present (With_Clause) loop
348 Prj.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id;
349 With_Clause := Next_With_Clause_Of (With_Clause, Tree);
352 if No (With_Clause) then
353 With_Clause := Default_Project_Node
354 (Of_Kind => N_With_Clause, In_Tree => Tree);
355 Set_Next_With_Clause_Of
357 To => First_With_Clause_Of (Project_Node, Tree));
358 Set_First_With_Clause_Of
359 (Project_Node, Tree, To => With_Clause);
360 Set_Name_Of (With_Clause, Tree, To => Project_Naming_Id);
362 -- We set the project node to something different than
363 -- Empty_Node, so that Prj.PP does not generate a limited
366 Set_Project_Node_Of (With_Clause, Tree, Non_Empty_Node);
368 Name_Len := Project_Naming_Last;
369 Name_Buffer (1 .. Name_Len) :=
370 Project_Naming_File_Name (1 .. Project_Naming_Last);
371 Set_String_Value_Of (With_Clause, Tree, To => Name_Find);
375 Project_Declaration := Project_Declaration_Of (Project_Node, Tree);
377 -- Add a package Naming in the main project, that is a renaming of
378 -- package Naming in the naming project.
381 Decl_Item : constant Project_Node_Id :=
383 (Of_Kind => N_Declarative_Item,
386 Naming : constant Project_Node_Id :=
388 (Of_Kind => N_Package_Declaration,
392 Set_Next_Declarative_Item
394 To => First_Declarative_Item_Of (Project_Declaration, Tree));
395 Set_First_Declarative_Item_Of
396 (Project_Declaration, Tree, To => Decl_Item);
397 Set_Current_Item_Node (Decl_Item, Tree, To => Naming);
398 Set_Name_Of (Naming, Tree, To => Name_Naming);
399 Set_Project_Of_Renamed_Package_Of
400 (Naming, Tree, To => Project_Naming_Node);
402 -- Attach the comments, if any, that were saved for package
405 Tree.Project_Nodes.Table (Naming).Comments :=
406 Naming_Package_Comments;
409 -- Add an attribute declaration for Source_Dirs, initialized as an
413 Decl_Item : constant Project_Node_Id :=
415 (Of_Kind => N_Declarative_Item,
418 Attribute : constant Project_Node_Id :=
420 (Of_Kind => N_Attribute_Declaration,
422 And_Expr_Kind => List);
424 Expression : constant Project_Node_Id :=
426 (Of_Kind => N_Expression,
428 And_Expr_Kind => List);
430 Term : constant Project_Node_Id :=
432 (Of_Kind => N_Term, In_Tree => Tree,
433 And_Expr_Kind => List);
436 Set_Next_Declarative_Item
438 To => First_Declarative_Item_Of (Project_Declaration, Tree));
439 Set_First_Declarative_Item_Of
440 (Project_Declaration, Tree, To => Decl_Item);
441 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
442 Set_Name_Of (Attribute, Tree, To => Name_Source_Dirs);
443 Set_Expression_Of (Attribute, Tree, To => Expression);
444 Set_First_Term (Expression, Tree, To => Term);
447 (Of_Kind => N_Literal_String_List,
449 And_Expr_Kind => List);
450 Set_Current_Term (Term, Tree, To => Source_Dirs_List);
452 -- Attach the comments, if any, that were saved for attribute
455 Tree.Project_Nodes.Table (Attribute).Comments :=
456 Source_Dirs_Comments;
459 -- Put the source directories in attribute Source_Dirs
461 for Source_Dir_Index in 1 .. Source_Directories.Last loop
463 Expression : constant Project_Node_Id :=
465 (Of_Kind => N_Expression,
467 And_Expr_Kind => Single);
469 Term : constant Project_Node_Id :=
473 And_Expr_Kind => Single);
475 Value : constant Project_Node_Id :=
477 (Of_Kind => N_Literal_String,
479 And_Expr_Kind => Single);
482 if No (Current_Source_Dir) then
483 Set_First_Expression_In_List
484 (Source_Dirs_List, Tree, To => Expression);
486 Set_Next_Expression_In_List
487 (Current_Source_Dir, Tree, To => Expression);
490 Current_Source_Dir := Expression;
491 Set_First_Term (Expression, Tree, To => Term);
492 Set_Current_Term (Term, Tree, To => Value);
494 Add_Str_To_Name_Buffer
495 (Source_Directories.Table (Source_Dir_Index).all);
496 Set_String_Value_Of (Value, Tree, To => Name_Find);
500 -- Add an attribute declaration for Source_Files or Source_List_File
501 -- with the source list file name that will be created.
504 Decl_Item : constant Project_Node_Id :=
506 (Of_Kind => N_Declarative_Item,
509 Attribute : constant Project_Node_Id :=
511 (Of_Kind => N_Attribute_Declaration,
513 And_Expr_Kind => Single);
515 Expression : constant Project_Node_Id :=
517 (Of_Kind => N_Expression,
519 And_Expr_Kind => Single);
521 Term : constant Project_Node_Id :=
525 And_Expr_Kind => Single);
527 Value : constant Project_Node_Id :=
529 (Of_Kind => N_Literal_String,
531 And_Expr_Kind => Single);
534 Set_Next_Declarative_Item
536 To => First_Declarative_Item_Of (Project_Declaration, Tree));
537 Set_First_Declarative_Item_Of
538 (Project_Declaration, Tree, To => Decl_Item);
539 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
541 Set_Name_Of (Attribute, Tree, To => Name_Source_List_File);
542 Set_Expression_Of (Attribute, Tree, To => Expression);
543 Set_First_Term (Expression, Tree, To => Term);
544 Set_Current_Term (Term, Tree, To => Value);
545 Name_Len := Source_List_Last;
546 Name_Buffer (1 .. Name_Len) :=
547 Source_List_Path (1 .. Source_List_Last);
548 Set_String_Value_Of (Value, Tree, To => Name_Find);
550 -- If there was no comments for attribute Source_List_File, put
551 -- those for Source_Files, if they exist.
553 if Present (Source_List_File_Comments) then
554 Tree.Project_Nodes.Table (Attribute).Comments :=
555 Source_List_File_Comments;
557 Tree.Project_Nodes.Table (Attribute).Comments :=
558 Source_Files_Comments;
562 -- Put the sources in the source list files and in the naming
565 for Source_Index in 1 .. Sources.Last loop
567 -- Add the corresponding attribute in the
568 -- Naming package of the naming project.
571 Current_Source : constant Source :=
572 Sources.Table (Source_Index);
574 Decl_Item : constant Project_Node_Id :=
580 Attribute : constant Project_Node_Id :=
583 N_Attribute_Declaration,
586 Expression : constant Project_Node_Id :=
588 (Of_Kind => N_Expression,
589 And_Expr_Kind => Single,
592 Term : constant Project_Node_Id :=
595 And_Expr_Kind => Single,
598 Value : constant Project_Node_Id :=
600 (Of_Kind => N_Literal_String,
601 And_Expr_Kind => Single,
605 -- Add source file name to the source list file
607 Get_Name_String (Current_Source.File_Name);
608 Add_Char_To_Name_Buffer (ASCII.LF);
609 if Write (Source_List_FD,
610 Name_Buffer (1)'Address,
611 Name_Len) /= Name_Len
613 Prj.Com.Fail ("disk full");
616 -- For an Ada source, add entry in package Naming
618 if Current_Source.Unit_Name /= No_Name then
619 Set_Next_Declarative_Item
621 To => First_Declarative_Item_Of
622 (Naming_Package, Tree),
624 Set_First_Declarative_Item_Of
628 Set_Current_Item_Node
633 -- Is it a spec or a body?
635 if Current_Source.Spec then
645 -- Get the name of the unit
647 Get_Name_String (Current_Source.Unit_Name);
648 To_Lower (Name_Buffer (1 .. Name_Len));
649 Set_Associative_Array_Index_Of
650 (Attribute, Tree, To => Name_Find);
653 (Attribute, Tree, To => Expression);
655 (Expression, Tree, To => Term);
657 (Term, Tree, To => Value);
659 -- And set the name of the file
662 (Value, Tree, To => Current_Source.File_Name);
664 (Value, Tree, To => Current_Source.Index);
669 -- Close the source list file
671 Close (Source_List_FD);
673 -- Output the project file
677 W_Char => Write_A_Char'Access,
678 W_Eol => Write_Eol'Access,
679 W_Str => Write_A_String'Access,
680 Backward_Compatibility => False);
683 -- Delete the naming project file if it already exists
686 (Project_Naming_File_Name (1 .. Project_Naming_Last),
691 if Opt.Verbose_Mode then
692 Output.Write_Str ("Creating new naming project file """);
693 Output.Write_Str (Project_Naming_File_Name
694 (1 .. Project_Naming_Last));
695 Output.Write_Line ("""");
698 Output_FD := Create_New_File
699 (Project_Naming_File_Name (1 .. Project_Naming_Last),
702 -- Fails if naming project file cannot be created
704 if Output_FD = Invalid_FD then
706 ("cannot create new """,
707 Project_Naming_File_Name (1 .. Project_Naming_Last),
711 -- Output the naming project file
714 (Project_Naming_Node, Tree,
715 W_Char => Write_A_Char'Access,
716 W_Eol => Write_Eol'Access,
717 W_Str => Write_A_String'Access,
718 Backward_Compatibility => False);
722 -- For each Ada source, write a pragma Source_File_Name to the
723 -- configuration pragmas file.
725 for Index in 1 .. Sources.Last loop
726 if Sources.Table (Index).Unit_Name /= No_Name then
727 Write_A_String ("pragma Source_File_Name");
729 Write_A_String (" (");
731 (Get_Name_String (Sources.Table (Index).Unit_Name));
732 Write_A_String (",");
735 if Sources.Table (Index).Spec then
736 Write_A_String (" Spec_File_Name => """);
739 Write_A_String (" Body_File_Name => """);
743 (Get_Name_String (Sources.Table (Index).File_Name));
745 Write_A_String ("""");
747 if Sources.Table (Index).Index /= 0 then
748 Write_A_String (", Index =>");
749 Write_A_String (Sources.Table (Index).Index'Img);
752 Write_A_String (");");
767 Project_File : Boolean;
768 Preproc_Switches : Argument_List;
769 Very_Verbose : Boolean)
772 Makr.Very_Verbose := Initialize.Very_Verbose;
773 Makr.Project_File := Initialize.Project_File;
775 -- Do some needed initializations
780 Prj.Initialize (No_Project_Tree);
781 Prj.Tree.Initialize (Tree);
783 Sources.Set_Last (0);
784 Source_Directories.Set_Last (0);
786 -- Initialize the compiler switches
788 Args := new Argument_List (1 .. Preproc_Switches'Length + 6);
789 Args (1) := new String'("-c");
790 Args (2) := new String'("-gnats");
791 Args (3) := new String'("-gnatu");
792 Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches;
793 Args (4 + Preproc_Switches'Length) := new String'("-x");
794 Args (5 + Preproc_Switches'Length) := new String'("ada");
796 -- Get the path and file names
799 String (1 .. File_Path'Length + Project_File_Extension'Length);
800 Path_Last := File_Path'Length;
802 if File_Names_Case_Sensitive then
803 Path_Name (1 .. Path_Last) := File_Path;
805 Path_Name (1 .. Path_Last) := To_Lower (File_Path);
808 Path_Name (Path_Last + 1 .. Path_Name'Last) :=
809 Project_File_Extension;
811 -- Get the end of directory information, if any
813 for Index in reverse 1 .. Path_Last loop
814 if Path_Name (Index) = Directory_Separator then
815 Directory_Last := Index;
821 if Path_Last < Project_File_Extension'Length + 1
823 (Path_Last - Project_File_Extension'Length + 1 .. Path_Last)
824 /= Project_File_Extension
826 Path_Last := Path_Name'Last;
829 Output_Name := new String'(To_Lower (Path_Name (1 .. Path_Last)));
830 Output_Name_Last := Output_Name'Last - 4;
832 -- If there is already a project file with the specified name, parse
833 -- it to get the components that are not automatically generated.
835 if Is_Regular_File (Output_Name (1 .. Path_Last)) then
836 if Opt.Verbose_Mode then
837 Output.Write_Str ("Parsing already existing project file """);
838 Output.Write_Str (Output_Name.all);
839 Output.Write_Line ("""");
844 Project => Project_Node,
845 Project_File_Name => Output_Name.all,
846 Always_Errout_Finalize => False,
847 Store_Comments => True,
848 Current_Directory => Get_Current_Dir,
849 Packages_To_Check => Packages_To_Check_By_Gnatname);
851 -- Fail if parsing was not successful
853 if No (Project_Node) then
854 Fail ("parsing of existing project file failed");
857 -- If parsing was successful, remove the components that are
858 -- automatically generated, if any, so that they will be
859 -- unconditionally added later.
861 -- Remove the with clause for the naming project file
864 With_Clause : Project_Node_Id :=
865 First_With_Clause_Of (Project_Node, Tree);
866 Previous : Project_Node_Id := Empty_Node;
869 while Present (With_Clause) loop
870 if Prj.Tree.Name_Of (With_Clause, Tree) =
873 if No (Previous) then
874 Set_First_With_Clause_Of
876 To => Next_With_Clause_Of (With_Clause, Tree));
878 Set_Next_With_Clause_Of
880 To => Next_With_Clause_Of (With_Clause, Tree));
886 Previous := With_Clause;
887 With_Clause := Next_With_Clause_Of (With_Clause, Tree);
891 -- Remove attribute declarations of Source_Files,
892 -- Source_List_File, Source_Dirs, and the declaration of
893 -- package Naming, if they exist, but preserve the comments
894 -- attached to these nodes.
897 Declaration : Project_Node_Id :=
898 First_Declarative_Item_Of
899 (Project_Declaration_Of
900 (Project_Node, Tree),
902 Previous : Project_Node_Id := Empty_Node;
903 Current_Node : Project_Node_Id := Empty_Node;
906 Kind_Of_Node : Project_Node_Kind;
907 Comments : Project_Node_Id;
910 while Present (Declaration) loop
911 Current_Node := Current_Item_Node (Declaration, Tree);
913 Kind_Of_Node := Kind_Of (Current_Node, Tree);
915 if Kind_Of_Node = N_Attribute_Declaration or else
916 Kind_Of_Node = N_Package_Declaration
918 Name := Prj.Tree.Name_Of (Current_Node, Tree);
920 if Name = Name_Source_Files or else
921 Name = Name_Source_List_File or else
922 Name = Name_Source_Dirs or else
926 Tree.Project_Nodes.Table (Current_Node).Comments;
928 if Name = Name_Source_Files then
929 Source_Files_Comments := Comments;
931 elsif Name = Name_Source_List_File then
932 Source_List_File_Comments := Comments;
934 elsif Name = Name_Source_Dirs then
935 Source_Dirs_Comments := Comments;
937 elsif Name = Name_Naming then
938 Naming_Package_Comments := Comments;
941 if No (Previous) then
942 Set_First_Declarative_Item_Of
943 (Project_Declaration_Of (Project_Node, Tree),
945 To => Next_Declarative_Item
946 (Declaration, Tree));
949 Set_Next_Declarative_Item
951 To => Next_Declarative_Item
952 (Declaration, Tree));
956 Previous := Declaration;
960 Declaration := Next_Declarative_Item (Declaration, Tree);
966 if Directory_Last /= 0 then
967 Output_Name (1 .. Output_Name_Last - Directory_Last) :=
968 Output_Name (Directory_Last + 1 .. Output_Name_Last);
969 Output_Name_Last := Output_Name_Last - Directory_Last;
972 -- Get the project name id
974 Name_Len := Output_Name_Last;
975 Name_Buffer (1 .. Name_Len) := Output_Name (1 .. Name_Len);
976 Output_Name_Id := Name_Find;
978 -- Create the project naming file name
980 Project_Naming_Last := Output_Name_Last;
981 Project_Naming_File_Name :=
982 new String'(Output_Name (1 .. Output_Name_Last) &
984 Project_File_Extension);
985 Project_Naming_Last :=
986 Project_Naming_Last + Naming_File_Suffix'Length;
988 -- Get the project naming id
990 Name_Len := Project_Naming_Last;
991 Name_Buffer (1 .. Name_Len) :=
992 Project_Naming_File_Name (1 .. Name_Len);
993 Project_Naming_Id := Name_Find;
995 Project_Naming_Last :=
996 Project_Naming_Last + Project_File_Extension'Length;
998 -- Create the source list file name
1000 Source_List_Last := Output_Name_Last;
1002 new String'(Output_Name (1 .. Output_Name_Last) &
1003 Source_List_File_Suffix);
1005 Output_Name_Last + Source_List_File_Suffix'Length;
1007 -- Add the project file extension to the project name
1010 (Output_Name_Last + 1 ..
1011 Output_Name_Last + Project_File_Extension'Length) :=
1012 Project_File_Extension;
1013 Output_Name_Last := Output_Name_Last + Project_File_Extension'Length;
1017 -- Change the current directory to the directory of the project file,
1018 -- if any directory information is specified.
1020 if Directory_Last /= 0 then
1022 Change_Dir (Path_Name (1 .. Directory_Last));
1024 when Directory_Error =>
1026 ("unknown directory """,
1027 Path_Name (1 .. Directory_Last),
1038 (Directories : Argument_List;
1039 Name_Patterns : Regexp_List;
1040 Excluded_Patterns : Regexp_List;
1041 Foreign_Patterns : Regexp_List)
1043 procedure Process_Directory (Dir_Name : String; Recursively : Boolean);
1044 -- Look for Ada and foreign sources in a directory, according to the
1045 -- patterns. When Recursively is True, after looking for sources in
1046 -- Dir_Name, look also in its subdirectories, if any.
1048 -----------------------
1049 -- Process_Directory --
1050 -----------------------
1052 procedure Process_Directory (Dir_Name : String; Recursively : Boolean) is
1053 Matched : Matched_Type := False;
1054 Str : String (1 .. 2_000);
1055 Canon : String (1 .. 2_000);
1058 Do_Process : Boolean := True;
1060 Temp_File_Name : String_Access := null;
1061 Save_Last_Source_Index : Natural := 0;
1062 File_Name_Id : Name_Id := No_Name;
1064 Current_Source : Source;
1067 -- Avoid processing the same directory more than once
1069 for Index in 1 .. Processed_Directories.Last loop
1070 if Processed_Directories.Table (Index).all = Dir_Name then
1071 Do_Process := False;
1077 if Opt.Verbose_Mode then
1078 Output.Write_Str ("Processing directory """);
1079 Output.Write_Str (Dir_Name);
1080 Output.Write_Line ("""");
1083 Processed_Directories. Increment_Last;
1084 Processed_Directories.Table (Processed_Directories.Last) :=
1085 new String'(Dir_Name);
1087 -- Get the source file names from the directory. Fails if the
1088 -- directory does not exist.
1091 Open (Dir, Dir_Name);
1093 when Directory_Error =>
1094 Prj.Com.Fail ("cannot open directory """, Dir_Name, """");
1097 -- Process each regular file in the directory
1100 Read (Dir, Str, Last);
1101 exit File_Loop when Last = 0;
1103 -- Copy the file name and put it in canonical case to match
1104 -- against the patterns that have themselves already been put
1105 -- in canonical case.
1107 Canon (1 .. Last) := Str (1 .. Last);
1108 Canonical_Case_File_Name (Canon (1 .. Last));
1111 (Dir_Name & Directory_Separator & Str (1 .. Last))
1116 Name_Buffer (1 .. Name_Len) := Str (1 .. Last);
1117 File_Name_Id := Name_Find;
1119 -- First, check if the file name matches at least one of
1120 -- the excluded expressions;
1122 for Index in Excluded_Patterns'Range loop
1124 Match (Canon (1 .. Last), Excluded_Patterns (Index))
1126 Matched := Excluded;
1131 -- If it does not match any of the excluded expressions,
1132 -- check if the file name matches at least one of the
1133 -- regular expressions.
1135 if Matched = True then
1138 for Index in Name_Patterns'Range loop
1141 (Canon (1 .. Last), Name_Patterns (Index))
1150 or else (Matched = True and then Opt.Verbose_Mode)
1152 Output.Write_Str (" Checking """);
1153 Output.Write_Str (Str (1 .. Last));
1154 Output.Write_Line (""": ");
1157 -- If the file name matches one of the regular expressions,
1158 -- parse it to get its unit name.
1160 if Matched = True then
1162 FD : File_Descriptor;
1164 Saved_Output : File_Descriptor;
1165 Saved_Error : File_Descriptor;
1168 -- If we don't have the path of the compiler yet,
1169 -- get it now. The compiler name may have a prefix,
1170 -- so we get the potentially prefixed name.
1172 if Gcc_Path = null then
1174 Prefix_Gcc : String_Access :=
1175 Program_Name (Gcc, "gnatname");
1178 Locate_Exec_On_Path (Prefix_Gcc.all);
1182 if Gcc_Path = null then
1183 Prj.Com.Fail ("could not locate " & Gcc);
1187 -- If we don't have yet the file name of the
1188 -- temporary file, get it now.
1190 if Temp_File_Name = null then
1191 Create_Temp_File (FD, Temp_File_Name);
1193 if FD = Invalid_FD then
1195 ("could not create temporary file");
1199 Delete_File (Temp_File_Name.all, Success);
1202 Args (Args'Last) := new String'
1204 Directory_Separator &
1207 -- Create the temporary file
1209 FD := Create_Output_Text_File
1210 (Name => Temp_File_Name.all);
1212 if FD = Invalid_FD then
1214 ("could not create temporary file");
1217 -- Save the standard output and error
1219 Saved_Output := Dup (Standout);
1220 Saved_Error := Dup (Standerr);
1222 -- Set standard output and error to the temporary file
1224 Dup2 (FD, Standout);
1225 Dup2 (FD, Standerr);
1227 -- And spawn the compiler
1229 Spawn (Gcc_Path.all, Args.all, Success);
1231 -- Restore the standard output and error
1233 Dup2 (Saved_Output, Standout);
1234 Dup2 (Saved_Error, Standerr);
1236 -- Close the temporary file
1240 -- And close the saved standard output and error to
1241 -- avoid too many file descriptors.
1243 Close (Saved_Output);
1244 Close (Saved_Error);
1246 -- Now that standard output is restored, check if
1247 -- the compiler ran correctly.
1249 -- Read the lines of the temporary file:
1250 -- they should contain the kind and name of the unit.
1254 Text_Line : String (1 .. 1_000);
1255 Text_Last : Natural;
1258 Open (File, Temp_File_Name.all);
1260 if not Is_Valid (File) then
1262 ("could not read temporary file");
1265 Save_Last_Source_Index := Sources.Last;
1267 if End_Of_File (File) then
1268 if Opt.Verbose_Mode then
1270 Output.Write_Str (" (process died) ");
1275 Line_Loop : while not End_Of_File (File) loop
1276 Get_Line (File, Text_Line, Text_Last);
1278 -- Find the first closing parenthesis
1280 Char_Loop : for J in 1 .. Text_Last loop
1281 if Text_Line (J) = ')' then
1283 Text_Line (1 .. 4) = "Unit"
1285 -- Add entry to Sources table
1288 Name_Buffer (1 .. Name_Len) :=
1289 Text_Line (6 .. J - 7);
1291 (Unit_Name => Name_Find,
1292 File_Name => File_Name_Id,
1294 Spec => Text_Line (J - 5 .. J) =
1297 Sources.Append (Current_Source);
1306 if Save_Last_Source_Index = Sources.Last then
1307 if Opt.Verbose_Mode then
1308 Output.Write_Line (" not a unit");
1313 Save_Last_Source_Index + 1
1315 for Index in Save_Last_Source_Index + 1 ..
1318 Sources.Table (Index).Index :=
1319 Int (Index - Save_Last_Source_Index);
1323 for Index in Save_Last_Source_Index + 1 ..
1326 Current_Source := Sources.Table (Index);
1328 if Opt.Verbose_Mode then
1329 if Current_Source.Spec then
1330 Output.Write_Str (" spec of ");
1333 Output.Write_Str (" body of ");
1338 (Current_Source.Unit_Name));
1345 Delete_File (Temp_File_Name.all, Success);
1349 -- File name matches none of the regular expressions
1352 -- If file is not excluded, see if this is foreign source
1354 if Matched /= Excluded then
1355 for Index in Foreign_Patterns'Range loop
1356 if Match (Canon (1 .. Last),
1357 Foreign_Patterns (Index))
1365 if Very_Verbose then
1368 Output.Write_Line ("no match");
1371 Output.Write_Line ("excluded");
1374 Output.Write_Line ("foreign source");
1378 if Matched = True then
1380 -- Add source file name without unit name
1383 Add_Str_To_Name_Buffer (Canon (1 .. Last));
1385 ((File_Name => Name_Find,
1386 Unit_Name => No_Name,
1397 -- If Recursively is True, call itself for each subdirectory.
1398 -- We do that, even when this directory has already been processed,
1399 -- because all of its subdirectories may not have been processed.
1402 Open (Dir, Dir_Name);
1405 Read (Dir, Str, Last);
1408 -- Do not call itself for "." or ".."
1411 (Dir_Name & Directory_Separator & Str (1 .. Last))
1412 and then Str (1 .. Last) /= "."
1413 and then Str (1 .. Last) /= ".."
1416 (Dir_Name & Directory_Separator & Str (1 .. Last),
1417 Recursively => True);
1423 end Process_Directory;
1425 -- Start of processing for Process
1428 Processed_Directories.Set_Last (0);
1430 -- Process each directory
1432 for Index in Directories'Range loop
1435 Dir_Name : constant String := Directories (Index).all;
1436 Last : Natural := Dir_Name'Last;
1437 Recursively : Boolean := False;
1439 Canonical : String (1 .. Dir_Name'Length) := Dir_Name;
1442 Canonical_Case_File_Name (Canonical);
1445 for J in 1 .. Source_Directories.Last loop
1446 if Source_Directories.Table (J).all = Canonical then
1453 Source_Directories.Append (new String'(Canonical));
1456 if Dir_Name'Length >= 4
1457 and then (Dir_Name (Last - 2 .. Last) = "/**")
1460 Recursively := True;
1463 Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively);
1472 procedure Write_A_Char (C : Character) is
1474 Write_A_String ((1 => C));
1481 procedure Write_Eol is
1483 Write_A_String ((1 => ASCII.LF));
1486 --------------------
1487 -- Write_A_String --
1488 --------------------
1490 procedure Write_A_String (S : String) is
1491 Str : String (1 .. S'Length);
1494 if S'Length > 0 then
1497 if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then
1498 Prj.Com.Fail ("disk full");