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");