1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2014, 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 ------------------------------------------------------------------------------
27 with Makeutl; use Makeutl;
30 with Osint; use Osint;
36 with Prj.Tree; use Prj.Tree;
37 with Prj.Util; use Prj.Util;
39 with Snames; use Snames;
41 with Table; use Table;
44 with Ada.Characters.Handling; use Ada.Characters.Handling;
45 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
47 with System.Case_Util; use System.Case_Util;
51 package body Prj.Makr is
53 -- Packages of project files where unknown attributes are errors
55 -- All the following need comments ??? All global variables and
56 -- subprograms must be fully commented.
58 Very_Verbose : Boolean := False;
59 -- Set in call to Initialize to indicate very verbose output
61 Project_File : Boolean := False;
62 -- True when gnatname is creating/modifying a project file. False when
63 -- gnatname is creating a configuration pragmas file.
65 Tree : constant Project_Node_Tree_Ref := new Project_Node_Tree_Data;
66 -- The project tree where the project file is parsed
68 Args : Argument_List_Access;
69 -- The list of arguments for calls to the compiler to get the unit names
70 -- and kinds (spec or body) in the Ada sources.
72 Path_Name : String_Access;
76 Directory_Last : Natural := 0;
78 Output_Name : String_Access;
79 Output_Name_Last : Natural;
80 Output_Name_Id : Name_Id;
82 Project_Naming_File_Name : String_Access;
83 -- String (1 .. Output_Name'Length + Naming_File_Suffix'Length);
85 Project_Naming_Last : Natural;
86 Project_Naming_Id : Name_Id := No_Name;
88 Source_List_Path : String_Access;
89 -- (1 .. Output_Name'Length + Source_List_File_Suffix'Length);
90 Source_List_Last : Natural;
92 Source_List_FD : File_Descriptor;
94 Project_Node : Project_Node_Id := Empty_Node;
95 Project_Declaration : Project_Node_Id := Empty_Node;
96 Source_Dirs_List : Project_Node_Id := Empty_Node;
98 Project_Naming_Node : Project_Node_Id := Empty_Node;
99 Project_Naming_Decl : Project_Node_Id := Empty_Node;
100 Naming_Package : Project_Node_Id := Empty_Node;
101 Naming_Package_Comments : Project_Node_Id := Empty_Node;
103 Source_Files_Comments : Project_Node_Id := Empty_Node;
104 Source_Dirs_Comments : Project_Node_Id := Empty_Node;
105 Source_List_File_Comments : Project_Node_Id := Empty_Node;
107 Naming_String : aliased String := "naming";
109 Gnatname_Packages : aliased String_List := (1 => Naming_String'Access);
111 Packages_To_Check_By_Gnatname : constant String_List_Access :=
112 Gnatname_Packages'Access;
114 function Dup (Fd : File_Descriptor) return File_Descriptor;
116 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
118 Gcc : constant String := "gcc";
119 Gcc_Path : String_Access := null;
121 Non_Empty_Node : constant Project_Node_Id := 1;
122 -- Used for the With_Clause of the naming project
124 -- Turn off warnings for now around this redefinition of True and False,
125 -- but it really seems a bit horrible to do this redefinition ???
127 pragma Warnings (Off);
128 type Matched_Type is (True, False, Excluded);
129 pragma Warnings (On);
131 Naming_File_Suffix : constant String := "_naming";
132 Source_List_File_Suffix : constant String := "_source_list.txt";
134 Output_FD : File_Descriptor;
135 -- To save the project file and its naming project file
138 -- Output an empty line
140 procedure Write_A_Char (C : Character);
141 -- Write one character to Output_FD
143 procedure Write_A_String (S : String);
144 -- Write a String to Output_FD
146 package Processed_Directories is new Table.Table
147 (Table_Component_Type => String_Access,
148 Table_Index_Type => Natural,
149 Table_Low_Bound => 0,
151 Table_Increment => 100,
152 Table_Name => "Prj.Makr.Processed_Directories");
153 -- The list of already processed directories for each section, to avoid
154 -- processing several times the same directory in the same section.
156 package Source_Directories is new Table.Table
157 (Table_Component_Type => String_Access,
158 Table_Index_Type => Natural,
159 Table_Low_Bound => 0,
161 Table_Increment => 100,
162 Table_Name => "Prj.Makr.Source_Directories");
163 -- The complete list of directories to be put in attribute Source_Dirs in
166 type Source is record
173 package Sources is new Table.Table
174 (Table_Component_Type => Source,
175 Table_Index_Type => Natural,
176 Table_Low_Bound => 0,
178 Table_Increment => 100,
179 Table_Name => "Prj.Makr.Sources");
180 -- The list of Ada sources found, with their unit name and kind, to be put
181 -- in the source attribute and package Naming of the project file, or in
182 -- the pragmas Source_File_Name in the configuration pragmas file.
184 package Source_Files is new System.HTable.Simple_HTable
185 (Header_Num => Prj.Header_Num,
191 -- Hash table to keep track of source file names, to avoid putting several
192 -- times the same file name in case of multi-unit files.
198 function Dup (Fd : File_Descriptor) return File_Descriptor is
200 return File_Descriptor (System.CRTL.dup (Integer (Fd)));
207 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor) is
209 pragma Warnings (Off, Fd);
211 Fd := System.CRTL.dup2 (Integer (Old_Fd), Integer (New_Fd));
218 procedure Finalize is
220 pragma Warnings (Off, Discard);
222 Current_Source_Dir : Project_Node_Id := Empty_Node;
226 -- If there were no already existing project file, or if the parsing
227 -- was unsuccessful, create an empty project node with the correct
228 -- name and its project declaration node.
230 if No (Project_Node) then
232 Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree);
233 Set_Name_Of (Project_Node, Tree, To => Output_Name_Id);
234 Set_Project_Declaration_Of
236 To => Default_Project_Node
237 (Of_Kind => N_Project_Declaration, In_Tree => Tree));
243 -- Delete the file if it already exists
246 (Path_Name (Directory_Last + 1 .. Path_Last),
251 if Opt.Verbose_Mode then
252 Output.Write_Str ("Creating new file """);
253 Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last));
254 Output.Write_Line ("""");
257 Output_FD := Create_New_File
258 (Path_Name (Directory_Last + 1 .. Path_Last),
261 -- Fails if project file cannot be created
263 if Output_FD = Invalid_FD then
265 ("cannot create new """ & Path_Name (1 .. Path_Last) & """");
270 -- Delete the source list file, if it already exists
274 pragma Warnings (Off, Discard);
277 (Source_List_Path (1 .. Source_List_Last),
281 -- And create a new source list file, fail if file cannot be created
283 Source_List_FD := Create_New_File
284 (Name => Source_List_Path (1 .. Source_List_Last),
287 if Source_List_FD = Invalid_FD then
289 ("cannot create file """
290 & Source_List_Path (1 .. Source_List_Last)
294 if Opt.Verbose_Mode then
295 Output.Write_Str ("Naming project file name is """);
297 (Project_Naming_File_Name (1 .. Project_Naming_Last));
298 Output.Write_Line ("""");
301 -- Create the naming project node
303 Project_Naming_Node :=
304 Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree);
305 Set_Name_Of (Project_Naming_Node, Tree, To => Project_Naming_Id);
306 Project_Naming_Decl :=
308 (Of_Kind => N_Project_Declaration, In_Tree => Tree);
309 Set_Project_Declaration_Of
310 (Project_Naming_Node, Tree, Project_Naming_Decl);
313 (Of_Kind => N_Package_Declaration, In_Tree => Tree);
314 Set_Name_Of (Naming_Package, Tree, To => Name_Naming);
316 -- Add an attribute declaration for Source_Files as an empty list (to
317 -- indicate there are no sources in the naming project) and a package
318 -- Naming (that will be filled later).
321 Decl_Item : constant Project_Node_Id :=
323 (Of_Kind => N_Declarative_Item, In_Tree => Tree);
325 Attribute : constant Project_Node_Id :=
327 (Of_Kind => N_Attribute_Declaration,
329 And_Expr_Kind => List);
331 Expression : constant Project_Node_Id :=
333 (Of_Kind => N_Expression,
335 And_Expr_Kind => List);
337 Term : constant Project_Node_Id :=
341 And_Expr_Kind => List);
343 Empty_List : constant Project_Node_Id :=
345 (Of_Kind => N_Literal_String_List,
349 Set_First_Declarative_Item_Of
350 (Project_Naming_Decl, Tree, To => Decl_Item);
351 Set_Next_Declarative_Item (Decl_Item, Tree, Naming_Package);
352 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
353 Set_Name_Of (Attribute, Tree, To => Name_Source_Files);
354 Set_Expression_Of (Attribute, Tree, To => Expression);
355 Set_First_Term (Expression, Tree, To => Term);
356 Set_Current_Term (Term, Tree, To => Empty_List);
359 -- Add a with clause on the naming project in the main project, if
360 -- there is not already one.
363 With_Clause : Project_Node_Id :=
364 First_With_Clause_Of (Project_Node, Tree);
367 while Present (With_Clause) loop
369 Prj.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id;
370 With_Clause := Next_With_Clause_Of (With_Clause, Tree);
373 if No (With_Clause) then
374 With_Clause := Default_Project_Node
375 (Of_Kind => N_With_Clause, In_Tree => Tree);
376 Set_Next_With_Clause_Of
378 To => First_With_Clause_Of (Project_Node, Tree));
379 Set_First_With_Clause_Of
380 (Project_Node, Tree, To => With_Clause);
381 Set_Name_Of (With_Clause, Tree, To => Project_Naming_Id);
383 -- We set the project node to something different than
384 -- Empty_Node, so that Prj.PP does not generate a limited
387 Set_Project_Node_Of (With_Clause, Tree, Non_Empty_Node);
389 Name_Len := Project_Naming_Last;
390 Name_Buffer (1 .. Name_Len) :=
391 Project_Naming_File_Name (1 .. Project_Naming_Last);
392 Set_String_Value_Of (With_Clause, Tree, To => Name_Find);
396 Project_Declaration := Project_Declaration_Of (Project_Node, Tree);
398 -- Add a package Naming in the main project, that is a renaming of
399 -- package Naming in the naming project.
402 Decl_Item : constant Project_Node_Id :=
404 (Of_Kind => N_Declarative_Item,
407 Naming : constant Project_Node_Id :=
409 (Of_Kind => N_Package_Declaration,
413 Set_Next_Declarative_Item
415 To => First_Declarative_Item_Of (Project_Declaration, Tree));
416 Set_First_Declarative_Item_Of
417 (Project_Declaration, Tree, To => Decl_Item);
418 Set_Current_Item_Node (Decl_Item, Tree, To => Naming);
419 Set_Name_Of (Naming, Tree, To => Name_Naming);
420 Set_Project_Of_Renamed_Package_Of
421 (Naming, Tree, To => Project_Naming_Node);
423 -- Attach the comments, if any, that were saved for package
426 Tree.Project_Nodes.Table (Naming).Comments :=
427 Naming_Package_Comments;
430 -- Add an attribute declaration for Source_Dirs, initialized as an
434 Decl_Item : constant Project_Node_Id :=
436 (Of_Kind => N_Declarative_Item,
439 Attribute : constant Project_Node_Id :=
441 (Of_Kind => N_Attribute_Declaration,
443 And_Expr_Kind => List);
445 Expression : constant Project_Node_Id :=
447 (Of_Kind => N_Expression,
449 And_Expr_Kind => List);
451 Term : constant Project_Node_Id :=
453 (Of_Kind => N_Term, In_Tree => Tree,
454 And_Expr_Kind => List);
457 Set_Next_Declarative_Item
459 To => First_Declarative_Item_Of (Project_Declaration, Tree));
460 Set_First_Declarative_Item_Of
461 (Project_Declaration, Tree, To => Decl_Item);
462 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
463 Set_Name_Of (Attribute, Tree, To => Name_Source_Dirs);
464 Set_Expression_Of (Attribute, Tree, To => Expression);
465 Set_First_Term (Expression, Tree, To => Term);
468 (Of_Kind => N_Literal_String_List,
470 And_Expr_Kind => List);
471 Set_Current_Term (Term, Tree, To => Source_Dirs_List);
473 -- Attach the comments, if any, that were saved for attribute
476 Tree.Project_Nodes.Table (Attribute).Comments :=
477 Source_Dirs_Comments;
480 -- Put the source directories in attribute Source_Dirs
482 for Source_Dir_Index in 1 .. Source_Directories.Last loop
484 Expression : constant Project_Node_Id :=
486 (Of_Kind => N_Expression,
488 And_Expr_Kind => Single);
490 Term : constant Project_Node_Id :=
494 And_Expr_Kind => Single);
496 Value : constant Project_Node_Id :=
498 (Of_Kind => N_Literal_String,
500 And_Expr_Kind => Single);
503 if No (Current_Source_Dir) then
504 Set_First_Expression_In_List
505 (Source_Dirs_List, Tree, To => Expression);
507 Set_Next_Expression_In_List
508 (Current_Source_Dir, Tree, To => Expression);
511 Current_Source_Dir := Expression;
512 Set_First_Term (Expression, Tree, To => Term);
513 Set_Current_Term (Term, Tree, To => Value);
515 Add_Str_To_Name_Buffer
516 (Source_Directories.Table (Source_Dir_Index).all);
517 Set_String_Value_Of (Value, Tree, To => Name_Find);
521 -- Add an attribute declaration for Source_Files or Source_List_File
522 -- with the source list file name that will be created.
525 Decl_Item : constant Project_Node_Id :=
527 (Of_Kind => N_Declarative_Item,
530 Attribute : constant Project_Node_Id :=
532 (Of_Kind => N_Attribute_Declaration,
534 And_Expr_Kind => Single);
536 Expression : constant Project_Node_Id :=
538 (Of_Kind => N_Expression,
540 And_Expr_Kind => Single);
542 Term : constant Project_Node_Id :=
546 And_Expr_Kind => Single);
548 Value : constant Project_Node_Id :=
550 (Of_Kind => N_Literal_String,
552 And_Expr_Kind => Single);
555 Set_Next_Declarative_Item
557 To => First_Declarative_Item_Of (Project_Declaration, Tree));
558 Set_First_Declarative_Item_Of
559 (Project_Declaration, Tree, To => Decl_Item);
560 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
562 Set_Name_Of (Attribute, Tree, To => Name_Source_List_File);
563 Set_Expression_Of (Attribute, Tree, To => Expression);
564 Set_First_Term (Expression, Tree, To => Term);
565 Set_Current_Term (Term, Tree, To => Value);
566 Name_Len := Source_List_Last;
567 Name_Buffer (1 .. Name_Len) :=
568 Source_List_Path (1 .. Source_List_Last);
569 Set_String_Value_Of (Value, Tree, To => Name_Find);
571 -- If there was no comments for attribute Source_List_File, put
572 -- those for Source_Files, if they exist.
574 if Present (Source_List_File_Comments) then
575 Tree.Project_Nodes.Table (Attribute).Comments :=
576 Source_List_File_Comments;
578 Tree.Project_Nodes.Table (Attribute).Comments :=
579 Source_Files_Comments;
583 -- Put the sources in the source list files and in the naming
586 for Source_Index in 1 .. Sources.Last loop
588 -- Add the corresponding attribute in the
589 -- Naming package of the naming project.
592 Current_Source : constant Source :=
593 Sources.Table (Source_Index);
595 Decl_Item : constant Project_Node_Id :=
601 Attribute : constant Project_Node_Id :=
604 N_Attribute_Declaration,
607 Expression : constant Project_Node_Id :=
609 (Of_Kind => N_Expression,
610 And_Expr_Kind => Single,
613 Term : constant Project_Node_Id :=
616 And_Expr_Kind => Single,
619 Value : constant Project_Node_Id :=
621 (Of_Kind => N_Literal_String,
622 And_Expr_Kind => Single,
626 -- Add source file name to the source list file if it is not
629 if not Source_Files.Get (Current_Source.File_Name) then
630 Source_Files.Set (Current_Source.File_Name, True);
631 Get_Name_String (Current_Source.File_Name);
632 Add_Char_To_Name_Buffer (ASCII.LF);
634 if Write (Source_List_FD,
635 Name_Buffer (1)'Address,
636 Name_Len) /= Name_Len
638 Prj.Com.Fail ("disk full");
642 -- For an Ada source, add entry in package Naming
644 if Current_Source.Unit_Name /= No_Name then
645 Set_Next_Declarative_Item
647 To => First_Declarative_Item_Of
648 (Naming_Package, Tree),
650 Set_First_Declarative_Item_Of
654 Set_Current_Item_Node
659 -- Is it a spec or a body?
661 if Current_Source.Spec then
671 -- Get the name of the unit
673 Get_Name_String (Current_Source.Unit_Name);
674 To_Lower (Name_Buffer (1 .. Name_Len));
675 Set_Associative_Array_Index_Of
676 (Attribute, Tree, To => Name_Find);
679 (Attribute, Tree, To => Expression);
681 (Expression, Tree, To => Term);
683 (Term, Tree, To => Value);
685 -- And set the name of the file
688 (Value, Tree, To => Current_Source.File_Name);
690 (Value, Tree, To => Current_Source.Index);
695 -- Close the source list file
697 Close (Source_List_FD);
699 -- Output the project file
703 W_Char => Write_A_Char'Access,
704 W_Eol => Write_Eol'Access,
705 W_Str => Write_A_String'Access,
706 Backward_Compatibility => False,
707 Max_Line_Length => 79);
710 -- Delete the naming project file if it already exists
713 (Project_Naming_File_Name (1 .. Project_Naming_Last),
718 if Opt.Verbose_Mode then
719 Output.Write_Str ("Creating new naming project file """);
720 Output.Write_Str (Project_Naming_File_Name
721 (1 .. Project_Naming_Last));
722 Output.Write_Line ("""");
725 Output_FD := Create_New_File
726 (Project_Naming_File_Name (1 .. Project_Naming_Last),
729 -- Fails if naming project file cannot be created
731 if Output_FD = Invalid_FD then
733 ("cannot create new """
734 & Project_Naming_File_Name (1 .. Project_Naming_Last)
738 -- Output the naming project file
741 (Project_Naming_Node, Tree,
742 W_Char => Write_A_Char'Access,
743 W_Eol => Write_Eol'Access,
744 W_Str => Write_A_String'Access,
745 Backward_Compatibility => False);
749 -- For each Ada source, write a pragma Source_File_Name to the
750 -- configuration pragmas file.
752 for Index in 1 .. Sources.Last loop
753 if Sources.Table (Index).Unit_Name /= No_Name then
754 Write_A_String ("pragma Source_File_Name");
756 Write_A_String (" (");
758 (Get_Name_String (Sources.Table (Index).Unit_Name));
759 Write_A_String (",");
762 if Sources.Table (Index).Spec then
763 Write_A_String (" Spec_File_Name => """);
766 Write_A_String (" Body_File_Name => """);
770 (Get_Name_String (Sources.Table (Index).File_Name));
772 Write_A_String ("""");
774 if Sources.Table (Index).Index /= 0 then
775 Write_A_String (", Index =>");
776 Write_A_String (Sources.Table (Index).Index'Img);
779 Write_A_String (");");
794 Project_File : Boolean;
795 Preproc_Switches : Argument_List;
796 Very_Verbose : Boolean;
797 Flags : Processing_Flags)
800 Makr.Very_Verbose := Initialize.Very_Verbose;
801 Makr.Project_File := Initialize.Project_File;
803 -- Do some needed initializations
809 Prj.Initialize (No_Project_Tree);
811 Prj.Tree.Initialize (Root_Environment, Flags);
812 Prj.Env.Initialize_Default_Project_Path
813 (Root_Environment.Project_Path,
814 Target_Name => Sdefault.Target_Name.all);
816 Prj.Tree.Initialize (Tree);
818 Sources.Set_Last (0);
819 Source_Directories.Set_Last (0);
821 -- Initialize the compiler switches
823 Args := new Argument_List (1 .. Preproc_Switches'Length + 6);
824 Args (1) := new String'("-c");
825 Args (2) := new String'("-gnats");
826 Args (3) := new String'("-gnatu");
827 Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches;
828 Args (4 + Preproc_Switches'Length) := new String'("-x");
829 Args (5 + Preproc_Switches'Length) := new String'("ada");
831 -- Get the path and file names
834 String (1 .. File_Path'Length + Project_File_Extension'Length);
835 Path_Last := File_Path'Length;
837 if File_Names_Case_Sensitive then
838 Path_Name (1 .. Path_Last) := File_Path;
840 Path_Name (1 .. Path_Last) := To_Lower (File_Path);
843 Path_Name (Path_Last + 1 .. Path_Name'Last) :=
844 Project_File_Extension;
846 -- Get the end of directory information, if any
848 for Index in reverse 1 .. Path_Last loop
849 if Path_Name (Index) = Directory_Separator then
850 Directory_Last := Index;
856 if Path_Last < Project_File_Extension'Length + 1
858 (Path_Last - Project_File_Extension'Length + 1 .. Path_Last)
859 /= Project_File_Extension
861 Path_Last := Path_Name'Last;
864 Output_Name := new String'(To_Lower (Path_Name (1 .. Path_Last)));
865 Output_Name_Last := Output_Name'Last - 4;
867 -- If there is already a project file with the specified name, parse
868 -- it to get the components that are not automatically generated.
870 if Is_Regular_File (Output_Name (1 .. Path_Last)) then
871 if Opt.Verbose_Mode then
872 Output.Write_Str ("Parsing already existing project file """);
873 Output.Write_Str (Output_Name.all);
874 Output.Write_Line ("""");
879 Project => Project_Node,
880 Project_File_Name => Output_Name.all,
881 Errout_Handling => Part.Finalize_If_Error,
882 Store_Comments => True,
883 Is_Config_File => False,
884 Env => Root_Environment,
885 Current_Directory => Get_Current_Dir,
886 Packages_To_Check => Packages_To_Check_By_Gnatname);
888 -- Fail if parsing was not successful
890 if No (Project_Node) then
891 Prj.Com.Fail ("parsing of existing project file failed");
893 elsif Project_Qualifier_Of (Project_Node, Tree) = Aggregate then
894 Prj.Com.Fail ("aggregate projects are not supported");
896 elsif Project_Qualifier_Of (Project_Node, Tree) =
899 Prj.Com.Fail ("aggregate library projects are not supported");
902 -- If parsing was successful, remove the components that are
903 -- automatically generated, if any, so that they will be
904 -- unconditionally added later.
906 -- Remove the with clause for the naming project file
909 With_Clause : Project_Node_Id :=
910 First_With_Clause_Of (Project_Node, Tree);
911 Previous : Project_Node_Id := Empty_Node;
914 while Present (With_Clause) loop
915 if Prj.Tree.Name_Of (With_Clause, Tree) =
918 if No (Previous) then
919 Set_First_With_Clause_Of
921 To => Next_With_Clause_Of (With_Clause, Tree));
923 Set_Next_With_Clause_Of
925 To => Next_With_Clause_Of (With_Clause, Tree));
931 Previous := With_Clause;
932 With_Clause := Next_With_Clause_Of (With_Clause, Tree);
936 -- Remove attribute declarations of Source_Files,
937 -- Source_List_File, Source_Dirs, and the declaration of
938 -- package Naming, if they exist, but preserve the comments
939 -- attached to these nodes.
942 Declaration : Project_Node_Id :=
943 First_Declarative_Item_Of
944 (Project_Declaration_Of
945 (Project_Node, Tree),
947 Previous : Project_Node_Id := Empty_Node;
948 Current_Node : Project_Node_Id := Empty_Node;
951 Kind_Of_Node : Project_Node_Kind;
952 Comments : Project_Node_Id;
955 while Present (Declaration) loop
956 Current_Node := Current_Item_Node (Declaration, Tree);
958 Kind_Of_Node := Kind_Of (Current_Node, Tree);
960 if Kind_Of_Node = N_Attribute_Declaration or else
961 Kind_Of_Node = N_Package_Declaration
963 Name := Prj.Tree.Name_Of (Current_Node, Tree);
965 if Nam_In (Name, Name_Source_Files,
966 Name_Source_List_File,
971 Tree.Project_Nodes.Table (Current_Node).Comments;
973 if Name = Name_Source_Files then
974 Source_Files_Comments := Comments;
976 elsif Name = Name_Source_List_File then
977 Source_List_File_Comments := Comments;
979 elsif Name = Name_Source_Dirs then
980 Source_Dirs_Comments := Comments;
982 elsif Name = Name_Naming then
983 Naming_Package_Comments := Comments;
986 if No (Previous) then
987 Set_First_Declarative_Item_Of
988 (Project_Declaration_Of (Project_Node, Tree),
990 To => Next_Declarative_Item
991 (Declaration, Tree));
994 Set_Next_Declarative_Item
996 To => Next_Declarative_Item
997 (Declaration, Tree));
1001 Previous := Declaration;
1005 Declaration := Next_Declarative_Item (Declaration, Tree);
1011 if Directory_Last /= 0 then
1012 Output_Name (1 .. Output_Name_Last - Directory_Last) :=
1013 Output_Name (Directory_Last + 1 .. Output_Name_Last);
1014 Output_Name_Last := Output_Name_Last - Directory_Last;
1017 -- Get the project name id
1019 Name_Len := Output_Name_Last;
1020 Name_Buffer (1 .. Name_Len) := Output_Name (1 .. Name_Len);
1021 Output_Name_Id := Name_Find;
1023 -- Create the project naming file name
1025 Project_Naming_Last := Output_Name_Last;
1026 Project_Naming_File_Name :=
1027 new String'(Output_Name (1 .. Output_Name_Last) &
1028 Naming_File_Suffix &
1029 Project_File_Extension);
1030 Project_Naming_Last :=
1031 Project_Naming_Last + Naming_File_Suffix'Length;
1033 -- Get the project naming id
1035 Name_Len := Project_Naming_Last;
1036 Name_Buffer (1 .. Name_Len) :=
1037 Project_Naming_File_Name (1 .. Name_Len);
1038 Project_Naming_Id := Name_Find;
1040 Project_Naming_Last :=
1041 Project_Naming_Last + Project_File_Extension'Length;
1043 -- Create the source list file name
1045 Source_List_Last := Output_Name_Last;
1047 new String'(Output_Name (1 .. Output_Name_Last) &
1048 Source_List_File_Suffix);
1050 Output_Name_Last + Source_List_File_Suffix'Length;
1052 -- Add the project file extension to the project name
1055 (Output_Name_Last + 1 ..
1056 Output_Name_Last + Project_File_Extension'Length) :=
1057 Project_File_Extension;
1058 Output_Name_Last := Output_Name_Last + Project_File_Extension'Length;
1060 -- Back up project file if it already exists
1062 if not Opt.No_Backup
1063 and then Is_Regular_File (Path_Name (1 .. Path_Last))
1067 Saved_Path : constant String :=
1068 Path_Name (1 .. Path_Last) & ".saved_";
1075 Img : constant String := Nmb'Img;
1078 if not Is_Regular_File
1079 (Saved_Path & Img (2 .. Img'Last))
1082 (Name => Path_Name (1 .. Path_Last),
1083 Pathname => Saved_Path & Img (2 .. Img'Last),
1085 Success => Discard);
1096 -- Change the current directory to the directory of the project file,
1097 -- if any directory information is specified.
1099 if Directory_Last /= 0 then
1101 Change_Dir (Path_Name (1 .. Directory_Last));
1103 when Directory_Error =>
1105 ("unknown directory """
1106 & Path_Name (1 .. Directory_Last)
1117 (Directories : Argument_List;
1118 Name_Patterns : Regexp_List;
1119 Excluded_Patterns : Regexp_List;
1120 Foreign_Patterns : Regexp_List)
1122 procedure Process_Directory (Dir_Name : String; Recursively : Boolean);
1123 -- Look for Ada and foreign sources in a directory, according to the
1124 -- patterns. When Recursively is True, after looking for sources in
1125 -- Dir_Name, look also in its subdirectories, if any.
1127 -----------------------
1128 -- Process_Directory --
1129 -----------------------
1131 procedure Process_Directory (Dir_Name : String; Recursively : Boolean) is
1132 Matched : Matched_Type := False;
1133 Str : String (1 .. 2_000);
1134 Canon : String (1 .. 2_000);
1137 Do_Process : Boolean := True;
1139 Temp_File_Name : String_Access := null;
1140 Save_Last_Source_Index : Natural := 0;
1141 File_Name_Id : Name_Id := No_Name;
1143 Current_Source : Source;
1146 -- Avoid processing the same directory more than once
1148 for Index in 1 .. Processed_Directories.Last loop
1149 if Processed_Directories.Table (Index).all = Dir_Name then
1150 Do_Process := False;
1156 if Opt.Verbose_Mode then
1157 Output.Write_Str ("Processing directory """);
1158 Output.Write_Str (Dir_Name);
1159 Output.Write_Line ("""");
1162 Processed_Directories. Increment_Last;
1163 Processed_Directories.Table (Processed_Directories.Last) :=
1164 new String'(Dir_Name);
1166 -- Get the source file names from the directory. Fails if the
1167 -- directory does not exist.
1170 Open (Dir, Dir_Name);
1172 when Directory_Error =>
1173 Prj.Com.Fail ("cannot open directory """ & Dir_Name & """");
1176 -- Process each regular file in the directory
1179 Read (Dir, Str, Last);
1180 exit File_Loop when Last = 0;
1182 -- Copy the file name and put it in canonical case to match
1183 -- against the patterns that have themselves already been put
1184 -- in canonical case.
1186 Canon (1 .. Last) := Str (1 .. Last);
1187 Canonical_Case_File_Name (Canon (1 .. Last));
1190 (Dir_Name & Directory_Separator & Str (1 .. Last))
1195 Name_Buffer (1 .. Name_Len) := Str (1 .. Last);
1196 File_Name_Id := Name_Find;
1198 -- First, check if the file name matches at least one of
1199 -- the excluded expressions;
1201 for Index in Excluded_Patterns'Range loop
1203 Match (Canon (1 .. Last), Excluded_Patterns (Index))
1205 Matched := Excluded;
1210 -- If it does not match any of the excluded expressions,
1211 -- check if the file name matches at least one of the
1212 -- regular expressions.
1214 if Matched = True then
1217 for Index in Name_Patterns'Range loop
1220 (Canon (1 .. Last), Name_Patterns (Index))
1229 or else (Matched = True and then Opt.Verbose_Mode)
1231 Output.Write_Str (" Checking """);
1232 Output.Write_Str (Str (1 .. Last));
1233 Output.Write_Line (""": ");
1236 -- If the file name matches one of the regular expressions,
1237 -- parse it to get its unit name.
1239 if Matched = True then
1241 FD : File_Descriptor;
1243 Saved_Output : File_Descriptor;
1244 Saved_Error : File_Descriptor;
1245 Tmp_File : Path_Name_Type;
1248 -- If we don't have the path of the compiler yet,
1249 -- get it now. The compiler name may have a prefix,
1250 -- so we get the potentially prefixed name.
1252 if Gcc_Path = null then
1254 Prefix_Gcc : String_Access :=
1255 Program_Name (Gcc, "gnatname");
1258 Locate_Exec_On_Path (Prefix_Gcc.all);
1262 if Gcc_Path = null then
1263 Prj.Com.Fail ("could not locate " & Gcc);
1267 -- Create the temporary file
1269 Tempdir.Create_Temp_File (FD, Tmp_File);
1271 if FD = Invalid_FD then
1273 ("could not create temporary file");
1277 new String'(Get_Name_String (Tmp_File));
1282 (Dir_Name & Directory_Separator & Str (1 .. Last));
1284 -- Save the standard output and error
1286 Saved_Output := Dup (Standout);
1287 Saved_Error := Dup (Standerr);
1289 -- Set standard output and error to the temporary file
1291 Dup2 (FD, Standout);
1292 Dup2 (FD, Standerr);
1294 -- And spawn the compiler
1296 Spawn (Gcc_Path.all, Args.all, Success);
1298 -- Restore the standard output and error
1300 Dup2 (Saved_Output, Standout);
1301 Dup2 (Saved_Error, Standerr);
1303 -- Close the temporary file
1307 -- And close the saved standard output and error to
1308 -- avoid too many file descriptors.
1310 Close (Saved_Output);
1311 Close (Saved_Error);
1313 -- Now that standard output is restored, check if
1314 -- the compiler ran correctly.
1316 -- Read the lines of the temporary file:
1317 -- they should contain the kind and name of the unit.
1321 Text_Line : String (1 .. 1_000);
1322 Text_Last : Natural;
1325 Open (File, Temp_File_Name.all);
1327 if not Is_Valid (File) then
1329 ("could not read temporary file " &
1330 Temp_File_Name.all);
1333 Save_Last_Source_Index := Sources.Last;
1335 if End_Of_File (File) then
1336 if Opt.Verbose_Mode then
1338 Output.Write_Str (" (process died) ");
1343 Line_Loop : while not End_Of_File (File) loop
1344 Get_Line (File, Text_Line, Text_Last);
1346 -- Find the first closing parenthesis
1348 Char_Loop : for J in 1 .. Text_Last loop
1349 if Text_Line (J) = ')' then
1351 Text_Line (1 .. 4) = "Unit"
1353 -- Add entry to Sources table
1356 Name_Buffer (1 .. Name_Len) :=
1357 Text_Line (6 .. J - 7);
1359 (Unit_Name => Name_Find,
1360 File_Name => File_Name_Id,
1362 Spec => Text_Line (J - 5 .. J) =
1365 Sources.Append (Current_Source);
1374 if Save_Last_Source_Index = Sources.Last then
1375 if Opt.Verbose_Mode then
1376 Output.Write_Line (" not a unit");
1381 Save_Last_Source_Index + 1
1383 for Index in Save_Last_Source_Index + 1 ..
1386 Sources.Table (Index).Index :=
1387 Int (Index - Save_Last_Source_Index);
1391 for Index in Save_Last_Source_Index + 1 ..
1394 Current_Source := Sources.Table (Index);
1396 if Opt.Verbose_Mode then
1397 if Current_Source.Spec then
1398 Output.Write_Str (" spec of ");
1401 Output.Write_Str (" body of ");
1406 (Current_Source.Unit_Name));
1413 Delete_File (Temp_File_Name.all, Success);
1417 -- File name matches none of the regular expressions
1420 -- If file is not excluded, see if this is foreign source
1422 if Matched /= Excluded then
1423 for Index in Foreign_Patterns'Range loop
1424 if Match (Canon (1 .. Last),
1425 Foreign_Patterns (Index))
1433 if Very_Verbose then
1436 Output.Write_Line ("no match");
1439 Output.Write_Line ("excluded");
1442 Output.Write_Line ("foreign source");
1446 if Matched = True then
1448 -- Add source file name without unit name
1451 Add_Str_To_Name_Buffer (Canon (1 .. Last));
1453 ((File_Name => Name_Find,
1454 Unit_Name => No_Name,
1465 -- If Recursively is True, call itself for each subdirectory.
1466 -- We do that, even when this directory has already been processed,
1467 -- because all of its subdirectories may not have been processed.
1470 Open (Dir, Dir_Name);
1473 Read (Dir, Str, Last);
1476 -- Do not call itself for "." or ".."
1479 (Dir_Name & Directory_Separator & Str (1 .. Last))
1480 and then Str (1 .. Last) /= "."
1481 and then Str (1 .. Last) /= ".."
1484 (Dir_Name & Directory_Separator & Str (1 .. Last),
1485 Recursively => True);
1491 end Process_Directory;
1493 -- Start of processing for Process
1496 Processed_Directories.Set_Last (0);
1498 -- Process each directory
1500 for Index in Directories'Range loop
1503 Dir_Name : constant String := Directories (Index).all;
1504 Last : Natural := Dir_Name'Last;
1505 Recursively : Boolean := False;
1507 Canonical : String (1 .. Dir_Name'Length) := Dir_Name;
1510 Canonical_Case_File_Name (Canonical);
1513 for J in 1 .. Source_Directories.Last loop
1514 if Source_Directories.Table (J).all = Canonical then
1521 Source_Directories.Append (new String'(Canonical));
1524 if Dir_Name'Length >= 4
1525 and then (Dir_Name (Last - 2 .. Last) = "/**")
1528 Recursively := True;
1531 Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively);
1540 procedure Write_A_Char (C : Character) is
1542 Write_A_String ((1 => C));
1549 procedure Write_Eol is
1551 Write_A_String ((1 => ASCII.LF));
1554 --------------------
1555 -- Write_A_String --
1556 --------------------
1558 procedure Write_A_String (S : String) is
1559 Str : String (1 .. S'Length);
1562 if S'Length > 0 then
1565 if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then
1566 Prj.Com.Fail ("disk full");