1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2011, 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
;
35 with Prj
.Tree
; use Prj
.Tree
;
36 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
;
44 with System
.Case_Util
; use System
.Case_Util
;
48 package body Prj
.Makr
is
50 -- Packages of project files where unknown attributes are errors
52 -- All the following need comments ??? All global variables and
53 -- subprograms must be fully commented.
55 Very_Verbose
: Boolean := False;
56 -- Set in call to Initialize to indicate very verbose output
58 Project_File
: Boolean := False;
59 -- True when gnatname is creating/modifying a project file. False when
60 -- gnatname is creating a configuration pragmas file.
62 Tree
: constant Project_Node_Tree_Ref
:= new Project_Node_Tree_Data
;
63 -- The project tree where the project file is parsed
65 Root_Environment
: Prj
.Tree
.Environment
;
67 Args
: Argument_List_Access
;
68 -- The list of arguments for calls to the compiler to get the unit names
69 -- and kinds (spec or body) in the Ada sources.
71 Path_Name
: String_Access
;
75 Directory_Last
: Natural := 0;
77 Output_Name
: String_Access
;
78 Output_Name_Last
: Natural;
79 Output_Name_Id
: Name_Id
;
81 Project_Naming_File_Name
: String_Access
;
82 -- String (1 .. Output_Name'Length + Naming_File_Suffix'Length);
84 Project_Naming_Last
: Natural;
85 Project_Naming_Id
: Name_Id
:= No_Name
;
87 Source_List_Path
: String_Access
;
88 -- (1 .. Output_Name'Length + Source_List_File_Suffix'Length);
89 Source_List_Last
: Natural;
91 Source_List_FD
: File_Descriptor
;
93 Project_Node
: Project_Node_Id
:= Empty_Node
;
94 Project_Declaration
: Project_Node_Id
:= Empty_Node
;
95 Source_Dirs_List
: Project_Node_Id
:= Empty_Node
;
97 Project_Naming_Node
: Project_Node_Id
:= Empty_Node
;
98 Project_Naming_Decl
: Project_Node_Id
:= Empty_Node
;
99 Naming_Package
: Project_Node_Id
:= Empty_Node
;
100 Naming_Package_Comments
: Project_Node_Id
:= Empty_Node
;
102 Source_Files_Comments
: Project_Node_Id
:= Empty_Node
;
103 Source_Dirs_Comments
: Project_Node_Id
:= Empty_Node
;
104 Source_List_File_Comments
: Project_Node_Id
:= Empty_Node
;
106 Naming_String
: aliased String := "naming";
108 Gnatname_Packages
: aliased String_List
:= (1 => Naming_String
'Access);
110 Packages_To_Check_By_Gnatname
: constant String_List_Access
:=
111 Gnatname_Packages
'Access;
113 function Dup
(Fd
: File_Descriptor
) return File_Descriptor
;
115 procedure Dup2
(Old_Fd
, New_Fd
: File_Descriptor
);
117 Gcc
: constant String := "gcc";
118 Gcc_Path
: String_Access
:= null;
120 Non_Empty_Node
: constant Project_Node_Id
:= 1;
121 -- Used for the With_Clause of the naming project
123 type Matched_Type
is (True, False, Excluded
);
125 Naming_File_Suffix
: constant String := "_naming";
126 Source_List_File_Suffix
: constant String := "_source_list.txt";
128 Output_FD
: File_Descriptor
;
129 -- To save the project file and its naming project file
132 -- Output an empty line
134 procedure Write_A_Char
(C
: Character);
135 -- Write one character to Output_FD
137 procedure Write_A_String
(S
: String);
138 -- Write a String to Output_FD
140 package Processed_Directories
is new Table
.Table
141 (Table_Component_Type
=> String_Access
,
142 Table_Index_Type
=> Natural,
143 Table_Low_Bound
=> 0,
145 Table_Increment
=> 100,
146 Table_Name
=> "Prj.Makr.Processed_Directories");
147 -- The list of already processed directories for each section, to avoid
148 -- processing several times the same directory in the same section.
150 package Source_Directories
is new Table
.Table
151 (Table_Component_Type
=> String_Access
,
152 Table_Index_Type
=> Natural,
153 Table_Low_Bound
=> 0,
155 Table_Increment
=> 100,
156 Table_Name
=> "Prj.Makr.Source_Directories");
157 -- The complete list of directories to be put in attribute Source_Dirs in
160 type Source
is record
167 package Sources
is new Table
.Table
168 (Table_Component_Type
=> Source
,
169 Table_Index_Type
=> Natural,
170 Table_Low_Bound
=> 0,
172 Table_Increment
=> 100,
173 Table_Name
=> "Prj.Makr.Sources");
174 -- The list of Ada sources found, with their unit name and kind, to be put
175 -- in the source attribute and package Naming of the project file, or in
176 -- the pragmas Source_File_Name in the configuration pragmas file.
178 package Source_Files
is new System
.HTable
.Simple_HTable
179 (Header_Num
=> Prj
.Header_Num
,
185 -- Hash table to keep track of source file names, to avoid putting several
186 -- times the same file name in case of multi-unit files.
192 function Dup
(Fd
: File_Descriptor
) return File_Descriptor
is
194 return File_Descriptor
(System
.CRTL
.dup
(Integer (Fd
)));
201 procedure Dup2
(Old_Fd
, New_Fd
: File_Descriptor
) is
203 pragma Warnings
(Off
, Fd
);
205 Fd
:= System
.CRTL
.dup2
(Integer (Old_Fd
), Integer (New_Fd
));
212 procedure Finalize
is
214 pragma Warnings
(Off
, Discard
);
216 Current_Source_Dir
: Project_Node_Id
:= Empty_Node
;
220 -- If there were no already existing project file, or if the parsing
221 -- was unsuccessful, create an empty project node with the correct
222 -- name and its project declaration node.
224 if No
(Project_Node
) then
226 Default_Project_Node
(Of_Kind
=> N_Project
, In_Tree
=> Tree
);
227 Set_Name_Of
(Project_Node
, Tree
, To
=> Output_Name_Id
);
228 Set_Project_Declaration_Of
230 To
=> Default_Project_Node
231 (Of_Kind
=> N_Project_Declaration
, In_Tree
=> Tree
));
237 -- Delete the file if it already exists
240 (Path_Name
(Directory_Last
+ 1 .. Path_Last
),
245 if Opt
.Verbose_Mode
then
246 Output
.Write_Str
("Creating new file """);
247 Output
.Write_Str
(Path_Name
(Directory_Last
+ 1 .. Path_Last
));
248 Output
.Write_Line
("""");
251 Output_FD
:= Create_New_File
252 (Path_Name
(Directory_Last
+ 1 .. Path_Last
),
255 -- Fails if project file cannot be created
257 if Output_FD
= Invalid_FD
then
259 ("cannot create new """ & Path_Name
(1 .. Path_Last
) & """");
264 -- Delete the source list file, if it already exists
268 pragma Warnings
(Off
, Discard
);
271 (Source_List_Path
(1 .. Source_List_Last
),
275 -- And create a new source list file, fail if file cannot be created
277 Source_List_FD
:= Create_New_File
278 (Name
=> Source_List_Path
(1 .. Source_List_Last
),
281 if Source_List_FD
= Invalid_FD
then
283 ("cannot create file """
284 & Source_List_Path
(1 .. Source_List_Last
)
288 if Opt
.Verbose_Mode
then
289 Output
.Write_Str
("Naming project file name is """);
291 (Project_Naming_File_Name
(1 .. Project_Naming_Last
));
292 Output
.Write_Line
("""");
295 -- Create the naming project node
297 Project_Naming_Node
:=
298 Default_Project_Node
(Of_Kind
=> N_Project
, In_Tree
=> Tree
);
299 Set_Name_Of
(Project_Naming_Node
, Tree
, To
=> Project_Naming_Id
);
300 Project_Naming_Decl
:=
302 (Of_Kind
=> N_Project_Declaration
, In_Tree
=> Tree
);
303 Set_Project_Declaration_Of
304 (Project_Naming_Node
, Tree
, Project_Naming_Decl
);
307 (Of_Kind
=> N_Package_Declaration
, In_Tree
=> Tree
);
308 Set_Name_Of
(Naming_Package
, Tree
, To
=> Name_Naming
);
310 -- Add an attribute declaration for Source_Files as an empty list (to
311 -- indicate there are no sources in the naming project) and a package
312 -- Naming (that will be filled later).
315 Decl_Item
: constant Project_Node_Id
:=
317 (Of_Kind
=> N_Declarative_Item
, In_Tree
=> Tree
);
319 Attribute
: constant Project_Node_Id
:=
321 (Of_Kind
=> N_Attribute_Declaration
,
323 And_Expr_Kind
=> List
);
325 Expression
: constant Project_Node_Id
:=
327 (Of_Kind
=> N_Expression
,
329 And_Expr_Kind
=> List
);
331 Term
: constant Project_Node_Id
:=
335 And_Expr_Kind
=> List
);
337 Empty_List
: constant Project_Node_Id
:=
339 (Of_Kind
=> N_Literal_String_List
,
343 Set_First_Declarative_Item_Of
344 (Project_Naming_Decl
, Tree
, To
=> Decl_Item
);
345 Set_Next_Declarative_Item
(Decl_Item
, Tree
, Naming_Package
);
346 Set_Current_Item_Node
(Decl_Item
, Tree
, To
=> Attribute
);
347 Set_Name_Of
(Attribute
, Tree
, To
=> Name_Source_Files
);
348 Set_Expression_Of
(Attribute
, Tree
, To
=> Expression
);
349 Set_First_Term
(Expression
, Tree
, To
=> Term
);
350 Set_Current_Term
(Term
, Tree
, To
=> Empty_List
);
353 -- Add a with clause on the naming project in the main project, if
354 -- there is not already one.
357 With_Clause
: Project_Node_Id
:=
358 First_With_Clause_Of
(Project_Node
, Tree
);
361 while Present
(With_Clause
) loop
363 Prj
.Tree
.Name_Of
(With_Clause
, Tree
) = Project_Naming_Id
;
364 With_Clause
:= Next_With_Clause_Of
(With_Clause
, Tree
);
367 if No
(With_Clause
) then
368 With_Clause
:= Default_Project_Node
369 (Of_Kind
=> N_With_Clause
, In_Tree
=> Tree
);
370 Set_Next_With_Clause_Of
372 To
=> First_With_Clause_Of
(Project_Node
, Tree
));
373 Set_First_With_Clause_Of
374 (Project_Node
, Tree
, To
=> With_Clause
);
375 Set_Name_Of
(With_Clause
, Tree
, To
=> Project_Naming_Id
);
377 -- We set the project node to something different than
378 -- Empty_Node, so that Prj.PP does not generate a limited
381 Set_Project_Node_Of
(With_Clause
, Tree
, Non_Empty_Node
);
383 Name_Len
:= Project_Naming_Last
;
384 Name_Buffer
(1 .. Name_Len
) :=
385 Project_Naming_File_Name
(1 .. Project_Naming_Last
);
386 Set_String_Value_Of
(With_Clause
, Tree
, To
=> Name_Find
);
390 Project_Declaration
:= Project_Declaration_Of
(Project_Node
, Tree
);
392 -- Add a package Naming in the main project, that is a renaming of
393 -- package Naming in the naming project.
396 Decl_Item
: constant Project_Node_Id
:=
398 (Of_Kind
=> N_Declarative_Item
,
401 Naming
: constant Project_Node_Id
:=
403 (Of_Kind
=> N_Package_Declaration
,
407 Set_Next_Declarative_Item
409 To
=> First_Declarative_Item_Of
(Project_Declaration
, Tree
));
410 Set_First_Declarative_Item_Of
411 (Project_Declaration
, Tree
, To
=> Decl_Item
);
412 Set_Current_Item_Node
(Decl_Item
, Tree
, To
=> Naming
);
413 Set_Name_Of
(Naming
, Tree
, To
=> Name_Naming
);
414 Set_Project_Of_Renamed_Package_Of
415 (Naming
, Tree
, To
=> Project_Naming_Node
);
417 -- Attach the comments, if any, that were saved for package
420 Tree
.Project_Nodes
.Table
(Naming
).Comments
:=
421 Naming_Package_Comments
;
424 -- Add an attribute declaration for Source_Dirs, initialized as an
428 Decl_Item
: constant Project_Node_Id
:=
430 (Of_Kind
=> N_Declarative_Item
,
433 Attribute
: constant Project_Node_Id
:=
435 (Of_Kind
=> N_Attribute_Declaration
,
437 And_Expr_Kind
=> List
);
439 Expression
: constant Project_Node_Id
:=
441 (Of_Kind
=> N_Expression
,
443 And_Expr_Kind
=> List
);
445 Term
: constant Project_Node_Id
:=
447 (Of_Kind
=> N_Term
, In_Tree
=> Tree
,
448 And_Expr_Kind
=> List
);
451 Set_Next_Declarative_Item
453 To
=> First_Declarative_Item_Of
(Project_Declaration
, Tree
));
454 Set_First_Declarative_Item_Of
455 (Project_Declaration
, Tree
, To
=> Decl_Item
);
456 Set_Current_Item_Node
(Decl_Item
, Tree
, To
=> Attribute
);
457 Set_Name_Of
(Attribute
, Tree
, To
=> Name_Source_Dirs
);
458 Set_Expression_Of
(Attribute
, Tree
, To
=> Expression
);
459 Set_First_Term
(Expression
, Tree
, To
=> Term
);
462 (Of_Kind
=> N_Literal_String_List
,
464 And_Expr_Kind
=> List
);
465 Set_Current_Term
(Term
, Tree
, To
=> Source_Dirs_List
);
467 -- Attach the comments, if any, that were saved for attribute
470 Tree
.Project_Nodes
.Table
(Attribute
).Comments
:=
471 Source_Dirs_Comments
;
474 -- Put the source directories in attribute Source_Dirs
476 for Source_Dir_Index
in 1 .. Source_Directories
.Last
loop
478 Expression
: constant Project_Node_Id
:=
480 (Of_Kind
=> N_Expression
,
482 And_Expr_Kind
=> Single
);
484 Term
: constant Project_Node_Id
:=
488 And_Expr_Kind
=> Single
);
490 Value
: constant Project_Node_Id
:=
492 (Of_Kind
=> N_Literal_String
,
494 And_Expr_Kind
=> Single
);
497 if No
(Current_Source_Dir
) then
498 Set_First_Expression_In_List
499 (Source_Dirs_List
, Tree
, To
=> Expression
);
501 Set_Next_Expression_In_List
502 (Current_Source_Dir
, Tree
, To
=> Expression
);
505 Current_Source_Dir
:= Expression
;
506 Set_First_Term
(Expression
, Tree
, To
=> Term
);
507 Set_Current_Term
(Term
, Tree
, To
=> Value
);
509 Add_Str_To_Name_Buffer
510 (Source_Directories
.Table
(Source_Dir_Index
).all);
511 Set_String_Value_Of
(Value
, Tree
, To
=> Name_Find
);
515 -- Add an attribute declaration for Source_Files or Source_List_File
516 -- with the source list file name that will be created.
519 Decl_Item
: constant Project_Node_Id
:=
521 (Of_Kind
=> N_Declarative_Item
,
524 Attribute
: constant Project_Node_Id
:=
526 (Of_Kind
=> N_Attribute_Declaration
,
528 And_Expr_Kind
=> Single
);
530 Expression
: constant Project_Node_Id
:=
532 (Of_Kind
=> N_Expression
,
534 And_Expr_Kind
=> Single
);
536 Term
: constant Project_Node_Id
:=
540 And_Expr_Kind
=> Single
);
542 Value
: constant Project_Node_Id
:=
544 (Of_Kind
=> N_Literal_String
,
546 And_Expr_Kind
=> Single
);
549 Set_Next_Declarative_Item
551 To
=> First_Declarative_Item_Of
(Project_Declaration
, Tree
));
552 Set_First_Declarative_Item_Of
553 (Project_Declaration
, Tree
, To
=> Decl_Item
);
554 Set_Current_Item_Node
(Decl_Item
, Tree
, To
=> Attribute
);
556 Set_Name_Of
(Attribute
, Tree
, To
=> Name_Source_List_File
);
557 Set_Expression_Of
(Attribute
, Tree
, To
=> Expression
);
558 Set_First_Term
(Expression
, Tree
, To
=> Term
);
559 Set_Current_Term
(Term
, Tree
, To
=> Value
);
560 Name_Len
:= Source_List_Last
;
561 Name_Buffer
(1 .. Name_Len
) :=
562 Source_List_Path
(1 .. Source_List_Last
);
563 Set_String_Value_Of
(Value
, Tree
, To
=> Name_Find
);
565 -- If there was no comments for attribute Source_List_File, put
566 -- those for Source_Files, if they exist.
568 if Present
(Source_List_File_Comments
) then
569 Tree
.Project_Nodes
.Table
(Attribute
).Comments
:=
570 Source_List_File_Comments
;
572 Tree
.Project_Nodes
.Table
(Attribute
).Comments
:=
573 Source_Files_Comments
;
577 -- Put the sources in the source list files and in the naming
580 for Source_Index
in 1 .. Sources
.Last
loop
582 -- Add the corresponding attribute in the
583 -- Naming package of the naming project.
586 Current_Source
: constant Source
:=
587 Sources
.Table
(Source_Index
);
589 Decl_Item
: constant Project_Node_Id
:=
595 Attribute
: constant Project_Node_Id
:=
598 N_Attribute_Declaration
,
601 Expression
: constant Project_Node_Id
:=
603 (Of_Kind
=> N_Expression
,
604 And_Expr_Kind
=> Single
,
607 Term
: constant Project_Node_Id
:=
610 And_Expr_Kind
=> Single
,
613 Value
: constant Project_Node_Id
:=
615 (Of_Kind
=> N_Literal_String
,
616 And_Expr_Kind
=> Single
,
620 -- Add source file name to the source list file if it is not
623 if not Source_Files
.Get
(Current_Source
.File_Name
) then
624 Source_Files
.Set
(Current_Source
.File_Name
, True);
625 Get_Name_String
(Current_Source
.File_Name
);
626 Add_Char_To_Name_Buffer
(ASCII
.LF
);
628 if Write
(Source_List_FD
,
629 Name_Buffer
(1)'Address,
630 Name_Len
) /= Name_Len
632 Prj
.Com
.Fail
("disk full");
636 -- For an Ada source, add entry in package Naming
638 if Current_Source
.Unit_Name
/= No_Name
then
639 Set_Next_Declarative_Item
641 To
=> First_Declarative_Item_Of
642 (Naming_Package
, Tree
),
644 Set_First_Declarative_Item_Of
648 Set_Current_Item_Node
653 -- Is it a spec or a body?
655 if Current_Source
.Spec
then
665 -- Get the name of the unit
667 Get_Name_String
(Current_Source
.Unit_Name
);
668 To_Lower
(Name_Buffer
(1 .. Name_Len
));
669 Set_Associative_Array_Index_Of
670 (Attribute
, Tree
, To
=> Name_Find
);
673 (Attribute
, Tree
, To
=> Expression
);
675 (Expression
, Tree
, To
=> Term
);
677 (Term
, Tree
, To
=> Value
);
679 -- And set the name of the file
682 (Value
, Tree
, To
=> Current_Source
.File_Name
);
684 (Value
, Tree
, To
=> Current_Source
.Index
);
689 -- Close the source list file
691 Close
(Source_List_FD
);
693 -- Output the project file
697 W_Char
=> Write_A_Char
'Access,
698 W_Eol
=> Write_Eol
'Access,
699 W_Str
=> Write_A_String
'Access,
700 Backward_Compatibility
=> False,
701 Max_Line_Length
=> 79);
704 -- Delete the naming project file if it already exists
707 (Project_Naming_File_Name
(1 .. Project_Naming_Last
),
712 if Opt
.Verbose_Mode
then
713 Output
.Write_Str
("Creating new naming project file """);
714 Output
.Write_Str
(Project_Naming_File_Name
715 (1 .. Project_Naming_Last
));
716 Output
.Write_Line
("""");
719 Output_FD
:= Create_New_File
720 (Project_Naming_File_Name
(1 .. Project_Naming_Last
),
723 -- Fails if naming project file cannot be created
725 if Output_FD
= Invalid_FD
then
727 ("cannot create new """
728 & Project_Naming_File_Name
(1 .. Project_Naming_Last
)
732 -- Output the naming project file
735 (Project_Naming_Node
, Tree
,
736 W_Char
=> Write_A_Char
'Access,
737 W_Eol
=> Write_Eol
'Access,
738 W_Str
=> Write_A_String
'Access,
739 Backward_Compatibility
=> False);
743 -- For each Ada source, write a pragma Source_File_Name to the
744 -- configuration pragmas file.
746 for Index
in 1 .. Sources
.Last
loop
747 if Sources
.Table
(Index
).Unit_Name
/= No_Name
then
748 Write_A_String
("pragma Source_File_Name");
750 Write_A_String
(" (");
752 (Get_Name_String
(Sources
.Table
(Index
).Unit_Name
));
753 Write_A_String
(",");
756 if Sources
.Table
(Index
).Spec
then
757 Write_A_String
(" Spec_File_Name => """);
760 Write_A_String
(" Body_File_Name => """);
764 (Get_Name_String
(Sources
.Table
(Index
).File_Name
));
766 Write_A_String
("""");
768 if Sources
.Table
(Index
).Index
/= 0 then
769 Write_A_String
(", Index =>");
770 Write_A_String
(Sources
.Table
(Index
).Index
'Img);
773 Write_A_String
(");");
788 Project_File
: Boolean;
789 Preproc_Switches
: Argument_List
;
790 Very_Verbose
: Boolean;
791 Flags
: Processing_Flags
)
794 Makr
.Very_Verbose
:= Initialize
.Very_Verbose
;
795 Makr
.Project_File
:= Initialize
.Project_File
;
797 -- Do some needed initializations
802 Prj
.Initialize
(No_Project_Tree
);
804 Prj
.Tree
.Initialize
(Root_Environment
, Flags
);
805 Prj
.Env
.Initialize_Default_Project_Path
806 (Root_Environment
.Project_Path
,
807 Target_Name
=> Sdefault
.Target_Name
.all);
809 Prj
.Tree
.Initialize
(Tree
);
811 Sources
.Set_Last
(0);
812 Source_Directories
.Set_Last
(0);
814 -- Initialize the compiler switches
816 Args
:= new Argument_List
(1 .. Preproc_Switches
'Length + 6);
817 Args
(1) := new String'("-c");
818 Args (2) := new String'("-gnats");
819 Args
(3) := new String'("-gnatu");
820 Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches;
821 Args (4 + Preproc_Switches'Length) := new String'("-x");
822 Args
(5 + Preproc_Switches
'Length) := new String'("ada");
824 -- Get the path and file names
827 String (1 .. File_Path'Length + Project_File_Extension'Length);
828 Path_Last := File_Path'Length;
830 if File_Names_Case_Sensitive then
831 Path_Name (1 .. Path_Last) := File_Path;
833 Path_Name (1 .. Path_Last) := To_Lower (File_Path);
836 Path_Name (Path_Last + 1 .. Path_Name'Last) :=
837 Project_File_Extension;
839 -- Get the end of directory information, if any
841 for Index in reverse 1 .. Path_Last loop
842 if Path_Name (Index) = Directory_Separator then
843 Directory_Last := Index;
849 if Path_Last < Project_File_Extension'Length + 1
851 (Path_Last - Project_File_Extension'Length + 1 .. Path_Last)
852 /= Project_File_Extension
854 Path_Last := Path_Name'Last;
857 Output_Name := new String'(To_Lower
(Path_Name
(1 .. Path_Last
)));
858 Output_Name_Last
:= Output_Name
'Last - 4;
860 -- If there is already a project file with the specified name, parse
861 -- it to get the components that are not automatically generated.
863 if Is_Regular_File
(Output_Name
(1 .. Path_Last
)) then
864 if Opt
.Verbose_Mode
then
865 Output
.Write_Str
("Parsing already existing project file """);
866 Output
.Write_Str
(Output_Name
.all);
867 Output
.Write_Line
("""");
872 Project
=> Project_Node
,
873 Project_File_Name
=> Output_Name
.all,
874 Errout_Handling
=> Part
.Finalize_If_Error
,
875 Store_Comments
=> True,
876 Is_Config_File
=> False,
877 Env
=> Root_Environment
,
878 Current_Directory
=> Get_Current_Dir
,
879 Packages_To_Check
=> Packages_To_Check_By_Gnatname
);
881 -- Fail if parsing was not successful
883 if No
(Project_Node
) then
884 Prj
.Com
.Fail
("parsing of existing project file failed");
887 -- If parsing was successful, remove the components that are
888 -- automatically generated, if any, so that they will be
889 -- unconditionally added later.
891 -- Remove the with clause for the naming project file
894 With_Clause
: Project_Node_Id
:=
895 First_With_Clause_Of
(Project_Node
, Tree
);
896 Previous
: Project_Node_Id
:= Empty_Node
;
899 while Present
(With_Clause
) loop
900 if Prj
.Tree
.Name_Of
(With_Clause
, Tree
) =
903 if No
(Previous
) then
904 Set_First_With_Clause_Of
906 To
=> Next_With_Clause_Of
(With_Clause
, Tree
));
908 Set_Next_With_Clause_Of
910 To
=> Next_With_Clause_Of
(With_Clause
, Tree
));
916 Previous
:= With_Clause
;
917 With_Clause
:= Next_With_Clause_Of
(With_Clause
, Tree
);
921 -- Remove attribute declarations of Source_Files,
922 -- Source_List_File, Source_Dirs, and the declaration of
923 -- package Naming, if they exist, but preserve the comments
924 -- attached to these nodes.
927 Declaration
: Project_Node_Id
:=
928 First_Declarative_Item_Of
929 (Project_Declaration_Of
930 (Project_Node
, Tree
),
932 Previous
: Project_Node_Id
:= Empty_Node
;
933 Current_Node
: Project_Node_Id
:= Empty_Node
;
936 Kind_Of_Node
: Project_Node_Kind
;
937 Comments
: Project_Node_Id
;
940 while Present
(Declaration
) loop
941 Current_Node
:= Current_Item_Node
(Declaration
, Tree
);
943 Kind_Of_Node
:= Kind_Of
(Current_Node
, Tree
);
945 if Kind_Of_Node
= N_Attribute_Declaration
or else
946 Kind_Of_Node
= N_Package_Declaration
948 Name
:= Prj
.Tree
.Name_Of
(Current_Node
, Tree
);
950 if Name
= Name_Source_Files
or else
951 Name
= Name_Source_List_File
or else
952 Name
= Name_Source_Dirs
or else
956 Tree
.Project_Nodes
.Table
(Current_Node
).Comments
;
958 if Name
= Name_Source_Files
then
959 Source_Files_Comments
:= Comments
;
961 elsif Name
= Name_Source_List_File
then
962 Source_List_File_Comments
:= Comments
;
964 elsif Name
= Name_Source_Dirs
then
965 Source_Dirs_Comments
:= Comments
;
967 elsif Name
= Name_Naming
then
968 Naming_Package_Comments
:= Comments
;
971 if No
(Previous
) then
972 Set_First_Declarative_Item_Of
973 (Project_Declaration_Of
(Project_Node
, Tree
),
975 To
=> Next_Declarative_Item
976 (Declaration
, Tree
));
979 Set_Next_Declarative_Item
981 To
=> Next_Declarative_Item
982 (Declaration
, Tree
));
986 Previous
:= Declaration
;
990 Declaration
:= Next_Declarative_Item
(Declaration
, Tree
);
996 if Directory_Last
/= 0 then
997 Output_Name
(1 .. Output_Name_Last
- Directory_Last
) :=
998 Output_Name
(Directory_Last
+ 1 .. Output_Name_Last
);
999 Output_Name_Last
:= Output_Name_Last
- Directory_Last
;
1002 -- Get the project name id
1004 Name_Len
:= Output_Name_Last
;
1005 Name_Buffer
(1 .. Name_Len
) := Output_Name
(1 .. Name_Len
);
1006 Output_Name_Id
:= Name_Find
;
1008 -- Create the project naming file name
1010 Project_Naming_Last
:= Output_Name_Last
;
1011 Project_Naming_File_Name
:=
1012 new String'(Output_Name (1 .. Output_Name_Last) &
1013 Naming_File_Suffix &
1014 Project_File_Extension);
1015 Project_Naming_Last :=
1016 Project_Naming_Last + Naming_File_Suffix'Length;
1018 -- Get the project naming id
1020 Name_Len := Project_Naming_Last;
1021 Name_Buffer (1 .. Name_Len) :=
1022 Project_Naming_File_Name (1 .. Name_Len);
1023 Project_Naming_Id := Name_Find;
1025 Project_Naming_Last :=
1026 Project_Naming_Last + Project_File_Extension'Length;
1028 -- Create the source list file name
1030 Source_List_Last := Output_Name_Last;
1032 new String'(Output_Name
(1 .. Output_Name_Last
) &
1033 Source_List_File_Suffix
);
1035 Output_Name_Last
+ Source_List_File_Suffix
'Length;
1037 -- Add the project file extension to the project name
1040 (Output_Name_Last
+ 1 ..
1041 Output_Name_Last
+ Project_File_Extension
'Length) :=
1042 Project_File_Extension
;
1043 Output_Name_Last
:= Output_Name_Last
+ Project_File_Extension
'Length;
1047 -- Change the current directory to the directory of the project file,
1048 -- if any directory information is specified.
1050 if Directory_Last
/= 0 then
1052 Change_Dir
(Path_Name
(1 .. Directory_Last
));
1054 when Directory_Error
=>
1056 ("unknown directory """
1057 & Path_Name
(1 .. Directory_Last
)
1068 (Directories
: Argument_List
;
1069 Name_Patterns
: Regexp_List
;
1070 Excluded_Patterns
: Regexp_List
;
1071 Foreign_Patterns
: Regexp_List
)
1073 procedure Process_Directory
(Dir_Name
: String; Recursively
: Boolean);
1074 -- Look for Ada and foreign sources in a directory, according to the
1075 -- patterns. When Recursively is True, after looking for sources in
1076 -- Dir_Name, look also in its subdirectories, if any.
1078 -----------------------
1079 -- Process_Directory --
1080 -----------------------
1082 procedure Process_Directory
(Dir_Name
: String; Recursively
: Boolean) is
1083 Matched
: Matched_Type
:= False;
1084 Str
: String (1 .. 2_000
);
1085 Canon
: String (1 .. 2_000
);
1088 Do_Process
: Boolean := True;
1090 Temp_File_Name
: String_Access
:= null;
1091 Save_Last_Source_Index
: Natural := 0;
1092 File_Name_Id
: Name_Id
:= No_Name
;
1094 Current_Source
: Source
;
1097 -- Avoid processing the same directory more than once
1099 for Index
in 1 .. Processed_Directories
.Last
loop
1100 if Processed_Directories
.Table
(Index
).all = Dir_Name
then
1101 Do_Process
:= False;
1107 if Opt
.Verbose_Mode
then
1108 Output
.Write_Str
("Processing directory """);
1109 Output
.Write_Str
(Dir_Name
);
1110 Output
.Write_Line
("""");
1113 Processed_Directories
. Increment_Last
;
1114 Processed_Directories
.Table
(Processed_Directories
.Last
) :=
1115 new String'(Dir_Name);
1117 -- Get the source file names from the directory. Fails if the
1118 -- directory does not exist.
1121 Open (Dir, Dir_Name);
1123 when Directory_Error =>
1124 Prj.Com.Fail ("cannot open directory """ & Dir_Name & """");
1127 -- Process each regular file in the directory
1130 Read (Dir, Str, Last);
1131 exit File_Loop when Last = 0;
1133 -- Copy the file name and put it in canonical case to match
1134 -- against the patterns that have themselves already been put
1135 -- in canonical case.
1137 Canon (1 .. Last) := Str (1 .. Last);
1138 Canonical_Case_File_Name (Canon (1 .. Last));
1141 (Dir_Name & Directory_Separator & Str (1 .. Last))
1146 Name_Buffer (1 .. Name_Len) := Str (1 .. Last);
1147 File_Name_Id := Name_Find;
1149 -- First, check if the file name matches at least one of
1150 -- the excluded expressions;
1152 for Index in Excluded_Patterns'Range loop
1154 Match (Canon (1 .. Last), Excluded_Patterns (Index))
1156 Matched := Excluded;
1161 -- If it does not match any of the excluded expressions,
1162 -- check if the file name matches at least one of the
1163 -- regular expressions.
1165 if Matched = True then
1168 for Index in Name_Patterns'Range loop
1171 (Canon (1 .. Last), Name_Patterns (Index))
1180 or else (Matched = True and then Opt.Verbose_Mode)
1182 Output.Write_Str (" Checking """);
1183 Output.Write_Str (Str (1 .. Last));
1184 Output.Write_Line (""": ");
1187 -- If the file name matches one of the regular expressions,
1188 -- parse it to get its unit name.
1190 if Matched = True then
1192 FD : File_Descriptor;
1194 Saved_Output : File_Descriptor;
1195 Saved_Error : File_Descriptor;
1198 -- If we don't have the path of the compiler yet,
1199 -- get it now. The compiler name may have a prefix,
1200 -- so we get the potentially prefixed name.
1202 if Gcc_Path = null then
1204 Prefix_Gcc : String_Access :=
1205 Program_Name (Gcc, "gnatname");
1208 Locate_Exec_On_Path (Prefix_Gcc.all);
1212 if Gcc_Path = null then
1213 Prj.Com.Fail ("could not locate " & Gcc);
1217 -- If we don't have yet the file name of the
1218 -- temporary file, get it now.
1220 if Temp_File_Name = null then
1221 Create_Temp_File (FD, Temp_File_Name);
1223 if FD = Invalid_FD then
1225 ("could not create temporary file");
1229 Delete_File (Temp_File_Name.all, Success);
1232 Args (Args'Last) := new String'
1234 Directory_Separator
&
1237 -- Create the temporary file
1239 FD
:= Create_Output_Text_File
1240 (Name
=> Temp_File_Name
.all);
1242 if FD
= Invalid_FD
then
1244 ("could not create temporary file");
1247 -- Save the standard output and error
1249 Saved_Output
:= Dup
(Standout
);
1250 Saved_Error
:= Dup
(Standerr
);
1252 -- Set standard output and error to the temporary file
1254 Dup2
(FD
, Standout
);
1255 Dup2
(FD
, Standerr
);
1257 -- And spawn the compiler
1259 Spawn
(Gcc_Path
.all, Args
.all, Success
);
1261 -- Restore the standard output and error
1263 Dup2
(Saved_Output
, Standout
);
1264 Dup2
(Saved_Error
, Standerr
);
1266 -- Close the temporary file
1270 -- And close the saved standard output and error to
1271 -- avoid too many file descriptors.
1273 Close
(Saved_Output
);
1274 Close
(Saved_Error
);
1276 -- Now that standard output is restored, check if
1277 -- the compiler ran correctly.
1279 -- Read the lines of the temporary file:
1280 -- they should contain the kind and name of the unit.
1284 Text_Line
: String (1 .. 1_000
);
1285 Text_Last
: Natural;
1288 Open
(File
, Temp_File_Name
.all);
1290 if not Is_Valid
(File
) then
1292 ("could not read temporary file");
1295 Save_Last_Source_Index
:= Sources
.Last
;
1297 if End_Of_File
(File
) then
1298 if Opt
.Verbose_Mode
then
1300 Output
.Write_Str
(" (process died) ");
1305 Line_Loop
: while not End_Of_File
(File
) loop
1306 Get_Line
(File
, Text_Line
, Text_Last
);
1308 -- Find the first closing parenthesis
1310 Char_Loop
: for J
in 1 .. Text_Last
loop
1311 if Text_Line
(J
) = ')' then
1313 Text_Line
(1 .. 4) = "Unit"
1315 -- Add entry to Sources table
1318 Name_Buffer
(1 .. Name_Len
) :=
1319 Text_Line
(6 .. J
- 7);
1321 (Unit_Name
=> Name_Find
,
1322 File_Name
=> File_Name_Id
,
1324 Spec
=> Text_Line
(J
- 5 .. J
) =
1327 Sources
.Append
(Current_Source
);
1336 if Save_Last_Source_Index
= Sources
.Last
then
1337 if Opt
.Verbose_Mode
then
1338 Output
.Write_Line
(" not a unit");
1343 Save_Last_Source_Index
+ 1
1345 for Index
in Save_Last_Source_Index
+ 1 ..
1348 Sources
.Table
(Index
).Index
:=
1349 Int
(Index
- Save_Last_Source_Index
);
1353 for Index
in Save_Last_Source_Index
+ 1 ..
1356 Current_Source
:= Sources
.Table
(Index
);
1358 if Opt
.Verbose_Mode
then
1359 if Current_Source
.Spec
then
1360 Output
.Write_Str
(" spec of ");
1363 Output
.Write_Str
(" body of ");
1368 (Current_Source
.Unit_Name
));
1375 Delete_File
(Temp_File_Name
.all, Success
);
1379 -- File name matches none of the regular expressions
1382 -- If file is not excluded, see if this is foreign source
1384 if Matched
/= Excluded
then
1385 for Index
in Foreign_Patterns
'Range loop
1386 if Match
(Canon
(1 .. Last
),
1387 Foreign_Patterns
(Index
))
1395 if Very_Verbose
then
1398 Output
.Write_Line
("no match");
1401 Output
.Write_Line
("excluded");
1404 Output
.Write_Line
("foreign source");
1408 if Matched
= True then
1410 -- Add source file name without unit name
1413 Add_Str_To_Name_Buffer
(Canon
(1 .. Last
));
1415 ((File_Name
=> Name_Find
,
1416 Unit_Name
=> No_Name
,
1427 -- If Recursively is True, call itself for each subdirectory.
1428 -- We do that, even when this directory has already been processed,
1429 -- because all of its subdirectories may not have been processed.
1432 Open
(Dir
, Dir_Name
);
1435 Read
(Dir
, Str
, Last
);
1438 -- Do not call itself for "." or ".."
1441 (Dir_Name
& Directory_Separator
& Str
(1 .. Last
))
1442 and then Str
(1 .. Last
) /= "."
1443 and then Str
(1 .. Last
) /= ".."
1446 (Dir_Name
& Directory_Separator
& Str
(1 .. Last
),
1447 Recursively
=> True);
1453 end Process_Directory
;
1455 -- Start of processing for Process
1458 Processed_Directories
.Set_Last
(0);
1460 -- Process each directory
1462 for Index
in Directories
'Range loop
1465 Dir_Name
: constant String := Directories
(Index
).all;
1466 Last
: Natural := Dir_Name
'Last;
1467 Recursively
: Boolean := False;
1469 Canonical
: String (1 .. Dir_Name
'Length) := Dir_Name
;
1472 Canonical_Case_File_Name
(Canonical
);
1475 for J
in 1 .. Source_Directories
.Last
loop
1476 if Source_Directories
.Table
(J
).all = Canonical
then
1483 Source_Directories
.Append
(new String'(Canonical));
1486 if Dir_Name'Length >= 4
1487 and then (Dir_Name (Last - 2 .. Last) = "/**")
1490 Recursively := True;
1493 Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively);
1502 procedure Write_A_Char (C : Character) is
1504 Write_A_String ((1 => C));
1511 procedure Write_Eol is
1513 Write_A_String ((1 => ASCII.LF));
1516 --------------------
1517 -- Write_A_String --
1518 --------------------
1520 procedure Write_A_String (S : String) is
1521 Str : String (1 .. S'Length);
1524 if S'Length > 0 then
1527 if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then
1528 Prj.Com.Fail ("disk full");