?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
PR tree-optimization/43833
[official-gcc/alias-decl.git] / gcc / ada / prj-makr.adb
blob50cd0703d675733e3596464452937d477d0ae34a
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P R J . M A K R --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2009, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Csets;
27 with Opt;
28 with Output;
29 with Osint; use Osint;
30 with Prj; use Prj;
31 with Prj.Com;
32 with Prj.Part;
33 with Prj.PP;
34 with Prj.Tree; use Prj.Tree;
35 with Prj.Util; use Prj.Util;
36 with Snames; use Snames;
37 with Table; use Table;
38
39 with Ada.Characters.Handling; use Ada.Characters.Handling;
40 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
41
42 with System.Case_Util; use System.Case_Util;
43 with System.CRTL;
44 with System.HTable;
45
46 package body Prj.Makr is
47
48 -- Packages of project files where unknown attributes are errors
49
50 -- All the following need comments ??? All global variables and
51 -- subprograms must be fully commented.
52
53 Very_Verbose : Boolean := False;
54 -- Set in call to Initialize to indicate very verbose output
55
56 Project_File : Boolean := False;
57 -- True when gnatname is creating/modifying a project file. False when
58 -- gnatname is creating a configuration pragmas file.
59
60 Tree : constant Project_Node_Tree_Ref := new Project_Node_Tree_Data;
61 -- The project tree where the project file is parsed
62
63 Args : Argument_List_Access;
64 -- The list of arguments for calls to the compiler to get the unit names
65 -- and kinds (spec or body) in the Ada sources.
66
67 Path_Name : String_Access;
68
69 Path_Last : Natural;
70
71 Directory_Last : Natural := 0;
72
73 Output_Name : String_Access;
74 Output_Name_Last : Natural;
75 Output_Name_Id : Name_Id;
76
77 Project_Naming_File_Name : String_Access;
78 -- String (1 .. Output_Name'Length + Naming_File_Suffix'Length);
79
80 Project_Naming_Last : Natural;
81 Project_Naming_Id : Name_Id := No_Name;
82
83 Source_List_Path : String_Access;
84 -- (1 .. Output_Name'Length + Source_List_File_Suffix'Length);
85 Source_List_Last : Natural;
86
87 Source_List_FD : File_Descriptor;
88
89 Project_Node : Project_Node_Id := Empty_Node;
90 Project_Declaration : Project_Node_Id := Empty_Node;
91 Source_Dirs_List : Project_Node_Id := Empty_Node;
92
93 Project_Naming_Node : Project_Node_Id := Empty_Node;
94 Project_Naming_Decl : Project_Node_Id := Empty_Node;
95 Naming_Package : Project_Node_Id := Empty_Node;
96 Naming_Package_Comments : Project_Node_Id := Empty_Node;
97
98 Source_Files_Comments : Project_Node_Id := Empty_Node;
99 Source_Dirs_Comments : Project_Node_Id := Empty_Node;
100 Source_List_File_Comments : Project_Node_Id := Empty_Node;
101
102 Naming_String : aliased String := "naming";
103
104 Gnatname_Packages : aliased String_List := (1 => Naming_String'Access);
105
106 Packages_To_Check_By_Gnatname : constant String_List_Access :=
107 Gnatname_Packages'Access;
108
109 function Dup (Fd : File_Descriptor) return File_Descriptor;
110
111 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
112
113 Gcc : constant String := "gcc";
114 Gcc_Path : String_Access := null;
115
116 Non_Empty_Node : constant Project_Node_Id := 1;
117 -- Used for the With_Clause of the naming project
118
119 type Matched_Type is (True, False, Excluded);
120
121 Naming_File_Suffix : constant String := "_naming";
122 Source_List_File_Suffix : constant String := "_source_list.txt";
123
124 Output_FD : File_Descriptor;
125 -- To save the project file and its naming project file
126
127 procedure Write_Eol;
128 -- Output an empty line
129
130 procedure Write_A_Char (C : Character);
131 -- Write one character to Output_FD
132
133 procedure Write_A_String (S : String);
134 -- Write a String to Output_FD
135
136 package Processed_Directories is new Table.Table
137 (Table_Component_Type => String_Access,
138 Table_Index_Type => Natural,
139 Table_Low_Bound => 0,
140 Table_Initial => 10,
141 Table_Increment => 100,
142 Table_Name => "Prj.Makr.Processed_Directories");
143 -- The list of already processed directories for each section, to avoid
144 -- processing several times the same directory in the same section.
145
146 package Source_Directories is new Table.Table
147 (Table_Component_Type => String_Access,
148 Table_Index_Type => Natural,
149 Table_Low_Bound => 0,
150 Table_Initial => 10,
151 Table_Increment => 100,
152 Table_Name => "Prj.Makr.Source_Directories");
153 -- The complete list of directories to be put in attribute Source_Dirs in
154 -- the project file.
155
156 type Source is record
157 File_Name : Name_Id;
158 Unit_Name : Name_Id;
159 Index : Int := 0;
160 Spec : Boolean;
161 end record;
162
163 package Sources is new Table.Table
164 (Table_Component_Type => Source,
165 Table_Index_Type => Natural,
166 Table_Low_Bound => 0,
167 Table_Initial => 10,
168 Table_Increment => 100,
169 Table_Name => "Prj.Makr.Sources");
170 -- The list of Ada sources found, with their unit name and kind, to be put
171 -- in the source attribute and package Naming of the project file, or in
172 -- the pragmas Source_File_Name in the configuration pragmas file.
173
174 package Source_Files is new System.HTable.Simple_HTable
175 (Header_Num => Prj.Header_Num,
176 Element => Boolean,
177 No_Element => False,
178 Key => Name_Id,
179 Hash => Prj.Hash,
180 Equal => "=");
181 -- Hash table to keep track of source file names, to avoid putting several
182 -- times the same file name in case of multi-unit files.
183
184 ---------
185 -- Dup --
186 ---------
187
188 function Dup (Fd : File_Descriptor) return File_Descriptor is
189 begin
190 return File_Descriptor (System.CRTL.dup (Integer (Fd)));
191 end Dup;
192
193 ----------
194 -- Dup2 --
195 ----------
196
197 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor) is
198 Fd : Integer;
199 pragma Warnings (Off, Fd);
200 begin
201 Fd := System.CRTL.dup2 (Integer (Old_Fd), Integer (New_Fd));
202 end Dup2;
203
204 --------------
205 -- Finalize --
206 --------------
207
208 procedure Finalize is
209 Discard : Boolean;
210 pragma Warnings (Off, Discard);
211
212 Current_Source_Dir : Project_Node_Id := Empty_Node;
213
214 begin
215 if Project_File then
216 -- If there were no already existing project file, or if the parsing
217 -- was unsuccessful, create an empty project node with the correct
218 -- name and its project declaration node.
219
220 if No (Project_Node) then
221 Project_Node :=
222 Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree);
223 Set_Name_Of (Project_Node, Tree, To => Output_Name_Id);
224 Set_Project_Declaration_Of
225 (Project_Node, Tree,
226 To => Default_Project_Node
227 (Of_Kind => N_Project_Declaration, In_Tree => Tree));
228
229 end if;
230
231 end if;
232
233 -- Delete the file if it already exists
234
235 Delete_File
236 (Path_Name (Directory_Last + 1 .. Path_Last),
237 Success => Discard);
238
239 -- Create a new one
240
241 if Opt.Verbose_Mode then
242 Output.Write_Str ("Creating new file """);
243 Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last));
244 Output.Write_Line ("""");
245 end if;
246
247 Output_FD := Create_New_File
248 (Path_Name (Directory_Last + 1 .. Path_Last),
249 Fmode => Text);
250
251 -- Fails if project file cannot be created
252
253 if Output_FD = Invalid_FD then
254 Prj.Com.Fail
255 ("cannot create new """ & Path_Name (1 .. Path_Last) & """");
256 end if;
257
258 if Project_File then
259
260 -- Delete the source list file, if it already exists
261
262 declare
263 Discard : Boolean;
264 pragma Warnings (Off, Discard);
265 begin
266 Delete_File
267 (Source_List_Path (1 .. Source_List_Last),
268 Success => Discard);
269 end;
270
271 -- And create a new source list file, fail if file cannot be created
272
273 Source_List_FD := Create_New_File
274 (Name => Source_List_Path (1 .. Source_List_Last),
275 Fmode => Text);
276
277 if Source_List_FD = Invalid_FD then
278 Prj.Com.Fail
279 ("cannot create file """
280 & Source_List_Path (1 .. Source_List_Last)
281 & """");
282 end if;
283
284 if Opt.Verbose_Mode then
285 Output.Write_Str ("Naming project file name is """);
286 Output.Write_Str
287 (Project_Naming_File_Name (1 .. Project_Naming_Last));
288 Output.Write_Line ("""");
289 end if;
290
291 -- Create the naming project node
292
293 Project_Naming_Node :=
294 Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree);
295 Set_Name_Of (Project_Naming_Node, Tree, To => Project_Naming_Id);
296 Project_Naming_Decl :=
297 Default_Project_Node
298 (Of_Kind => N_Project_Declaration, In_Tree => Tree);
299 Set_Project_Declaration_Of
300 (Project_Naming_Node, Tree, Project_Naming_Decl);
301 Naming_Package :=
302 Default_Project_Node
303 (Of_Kind => N_Package_Declaration, In_Tree => Tree);
304 Set_Name_Of (Naming_Package, Tree, To => Name_Naming);
305
306 -- Add an attribute declaration for Source_Files as an empty list (to
307 -- indicate there are no sources in the naming project) and a package
308 -- Naming (that will be filled later).
309
310 declare
311 Decl_Item : constant Project_Node_Id :=
312 Default_Project_Node
313 (Of_Kind => N_Declarative_Item, In_Tree => Tree);
314
315 Attribute : constant Project_Node_Id :=
316 Default_Project_Node
317 (Of_Kind => N_Attribute_Declaration,
318 In_Tree => Tree,
319 And_Expr_Kind => List);
320
321 Expression : constant Project_Node_Id :=
322 Default_Project_Node
323 (Of_Kind => N_Expression,
324 In_Tree => Tree,
325 And_Expr_Kind => List);
326
327 Term : constant Project_Node_Id :=
328 Default_Project_Node
329 (Of_Kind => N_Term,
330 In_Tree => Tree,
331 And_Expr_Kind => List);
332
333 Empty_List : constant Project_Node_Id :=
334 Default_Project_Node
335 (Of_Kind => N_Literal_String_List,
336 In_Tree => Tree);
337
338 begin
339 Set_First_Declarative_Item_Of
340 (Project_Naming_Decl, Tree, To => Decl_Item);
341 Set_Next_Declarative_Item (Decl_Item, Tree, Naming_Package);
342 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
343 Set_Name_Of (Attribute, Tree, To => Name_Source_Files);
344 Set_Expression_Of (Attribute, Tree, To => Expression);
345 Set_First_Term (Expression, Tree, To => Term);
346 Set_Current_Term (Term, Tree, To => Empty_List);
347 end;
348
349 -- Add a with clause on the naming project in the main project, if
350 -- there is not already one.
351
352 declare
353 With_Clause : Project_Node_Id :=
354 First_With_Clause_Of (Project_Node, Tree);
355
356 begin
357 while Present (With_Clause) loop
358 exit when
359 Prj.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id;
360 With_Clause := Next_With_Clause_Of (With_Clause, Tree);
361 end loop;
362
363 if No (With_Clause) then
364 With_Clause := Default_Project_Node
365 (Of_Kind => N_With_Clause, In_Tree => Tree);
366 Set_Next_With_Clause_Of
367 (With_Clause, Tree,
368 To => First_With_Clause_Of (Project_Node, Tree));
369 Set_First_With_Clause_Of
370 (Project_Node, Tree, To => With_Clause);
371 Set_Name_Of (With_Clause, Tree, To => Project_Naming_Id);
372
373 -- We set the project node to something different than
374 -- Empty_Node, so that Prj.PP does not generate a limited
375 -- with clause.
376
377 Set_Project_Node_Of (With_Clause, Tree, Non_Empty_Node);
378
379 Name_Len := Project_Naming_Last;
380 Name_Buffer (1 .. Name_Len) :=
381 Project_Naming_File_Name (1 .. Project_Naming_Last);
382 Set_String_Value_Of (With_Clause, Tree, To => Name_Find);
383 end if;
384 end;
385
386 Project_Declaration := Project_Declaration_Of (Project_Node, Tree);
387
388 -- Add a package Naming in the main project, that is a renaming of
389 -- package Naming in the naming project.
390
391 declare
392 Decl_Item : constant Project_Node_Id :=
393 Default_Project_Node
394 (Of_Kind => N_Declarative_Item,
395 In_Tree => Tree);
396
397 Naming : constant Project_Node_Id :=
398 Default_Project_Node
399 (Of_Kind => N_Package_Declaration,
400 In_Tree => Tree);
401
402 begin
403 Set_Next_Declarative_Item
404 (Decl_Item, Tree,
405 To => First_Declarative_Item_Of (Project_Declaration, Tree));
406 Set_First_Declarative_Item_Of
407 (Project_Declaration, Tree, To => Decl_Item);
408 Set_Current_Item_Node (Decl_Item, Tree, To => Naming);
409 Set_Name_Of (Naming, Tree, To => Name_Naming);
410 Set_Project_Of_Renamed_Package_Of
411 (Naming, Tree, To => Project_Naming_Node);
412
413 -- Attach the comments, if any, that were saved for package
414 -- Naming.
415
416 Tree.Project_Nodes.Table (Naming).Comments :=
417 Naming_Package_Comments;
418 end;
419
420 -- Add an attribute declaration for Source_Dirs, initialized as an
421 -- empty list.
422
423 declare
424 Decl_Item : constant Project_Node_Id :=
425 Default_Project_Node
426 (Of_Kind => N_Declarative_Item,
427 In_Tree => Tree);
428
429 Attribute : constant Project_Node_Id :=
430 Default_Project_Node
431 (Of_Kind => N_Attribute_Declaration,
432 In_Tree => Tree,
433 And_Expr_Kind => List);
434
435 Expression : constant Project_Node_Id :=
436 Default_Project_Node
437 (Of_Kind => N_Expression,
438 In_Tree => Tree,
439 And_Expr_Kind => List);
440
441 Term : constant Project_Node_Id :=
442 Default_Project_Node
443 (Of_Kind => N_Term, In_Tree => Tree,
444 And_Expr_Kind => List);
445
446 begin
447 Set_Next_Declarative_Item
448 (Decl_Item, Tree,
449 To => First_Declarative_Item_Of (Project_Declaration, Tree));
450 Set_First_Declarative_Item_Of
451 (Project_Declaration, Tree, To => Decl_Item);
452 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
453 Set_Name_Of (Attribute, Tree, To => Name_Source_Dirs);
454 Set_Expression_Of (Attribute, Tree, To => Expression);
455 Set_First_Term (Expression, Tree, To => Term);
456 Source_Dirs_List :=
457 Default_Project_Node
458 (Of_Kind => N_Literal_String_List,
459 In_Tree => Tree,
460 And_Expr_Kind => List);
461 Set_Current_Term (Term, Tree, To => Source_Dirs_List);
462
463 -- Attach the comments, if any, that were saved for attribute
464 -- Source_Dirs.
465
466 Tree.Project_Nodes.Table (Attribute).Comments :=
467 Source_Dirs_Comments;
468 end;
469
470 -- Put the source directories in attribute Source_Dirs
471
472 for Source_Dir_Index in 1 .. Source_Directories.Last loop
473 declare
474 Expression : constant Project_Node_Id :=
475 Default_Project_Node
476 (Of_Kind => N_Expression,
477 In_Tree => Tree,
478 And_Expr_Kind => Single);
479
480 Term : constant Project_Node_Id :=
481 Default_Project_Node
482 (Of_Kind => N_Term,
483 In_Tree => Tree,
484 And_Expr_Kind => Single);
485
486 Value : constant Project_Node_Id :=
487 Default_Project_Node
488 (Of_Kind => N_Literal_String,
489 In_Tree => Tree,
490 And_Expr_Kind => Single);
491
492 begin
493 if No (Current_Source_Dir) then
494 Set_First_Expression_In_List
495 (Source_Dirs_List, Tree, To => Expression);
496 else
497 Set_Next_Expression_In_List
498 (Current_Source_Dir, Tree, To => Expression);
499 end if;
500
501 Current_Source_Dir := Expression;
502 Set_First_Term (Expression, Tree, To => Term);
503 Set_Current_Term (Term, Tree, To => Value);
504 Name_Len := 0;
505 Add_Str_To_Name_Buffer
506 (Source_Directories.Table (Source_Dir_Index).all);
507 Set_String_Value_Of (Value, Tree, To => Name_Find);
508 end;
509 end loop;
510
511 -- Add an attribute declaration for Source_Files or Source_List_File
512 -- with the source list file name that will be created.
513
514 declare
515 Decl_Item : constant Project_Node_Id :=
516 Default_Project_Node
517 (Of_Kind => N_Declarative_Item,
518 In_Tree => Tree);
519
520 Attribute : constant Project_Node_Id :=
521 Default_Project_Node
522 (Of_Kind => N_Attribute_Declaration,
523 In_Tree => Tree,
524 And_Expr_Kind => Single);
525
526 Expression : constant Project_Node_Id :=
527 Default_Project_Node
528 (Of_Kind => N_Expression,
529 In_Tree => Tree,
530 And_Expr_Kind => Single);
531
532 Term : constant Project_Node_Id :=
533 Default_Project_Node
534 (Of_Kind => N_Term,
535 In_Tree => Tree,
536 And_Expr_Kind => Single);
537
538 Value : constant Project_Node_Id :=
539 Default_Project_Node
540 (Of_Kind => N_Literal_String,
541 In_Tree => Tree,
542 And_Expr_Kind => Single);
543
544 begin
545 Set_Next_Declarative_Item
546 (Decl_Item, Tree,
547 To => First_Declarative_Item_Of (Project_Declaration, Tree));
548 Set_First_Declarative_Item_Of
549 (Project_Declaration, Tree, To => Decl_Item);
550 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
551
552 Set_Name_Of (Attribute, Tree, To => Name_Source_List_File);
553 Set_Expression_Of (Attribute, Tree, To => Expression);
554 Set_First_Term (Expression, Tree, To => Term);
555 Set_Current_Term (Term, Tree, To => Value);
556 Name_Len := Source_List_Last;
557 Name_Buffer (1 .. Name_Len) :=
558 Source_List_Path (1 .. Source_List_Last);
559 Set_String_Value_Of (Value, Tree, To => Name_Find);
560
561 -- If there was no comments for attribute Source_List_File, put
562 -- those for Source_Files, if they exist.
563
564 if Present (Source_List_File_Comments) then
565 Tree.Project_Nodes.Table (Attribute).Comments :=
566 Source_List_File_Comments;
567 else
568 Tree.Project_Nodes.Table (Attribute).Comments :=
569 Source_Files_Comments;
570 end if;
571 end;
572
573 -- Put the sources in the source list files and in the naming
574 -- project.
575
576 for Source_Index in 1 .. Sources.Last loop
577
578 -- Add the corresponding attribute in the
579 -- Naming package of the naming project.
580
581 declare
582 Current_Source : constant Source :=
583 Sources.Table (Source_Index);
584
585 Decl_Item : constant Project_Node_Id :=
586 Default_Project_Node
587 (Of_Kind =>
588 N_Declarative_Item,
589 In_Tree => Tree);
590
591 Attribute : constant Project_Node_Id :=
592 Default_Project_Node
593 (Of_Kind =>
594 N_Attribute_Declaration,
595 In_Tree => Tree);
596
597 Expression : constant Project_Node_Id :=
598 Default_Project_Node
599 (Of_Kind => N_Expression,
600 And_Expr_Kind => Single,
601 In_Tree => Tree);
602
603 Term : constant Project_Node_Id :=
604 Default_Project_Node
605 (Of_Kind => N_Term,
606 And_Expr_Kind => Single,
607 In_Tree => Tree);
608
609 Value : constant Project_Node_Id :=
610 Default_Project_Node
611 (Of_Kind => N_Literal_String,
612 And_Expr_Kind => Single,
613 In_Tree => Tree);
614
615 begin
616 -- Add source file name to the source list file if it is not
617 -- already there.
618
619 if not Source_Files.Get (Current_Source.File_Name) then
620 Source_Files.Set (Current_Source.File_Name, True);
621 Get_Name_String (Current_Source.File_Name);
622 Add_Char_To_Name_Buffer (ASCII.LF);
623
624 if Write (Source_List_FD,
625 Name_Buffer (1)'Address,
626 Name_Len) /= Name_Len
627 then
628 Prj.Com.Fail ("disk full");
629 end if;
630 end if;
631
632 -- For an Ada source, add entry in package Naming
633
634 if Current_Source.Unit_Name /= No_Name then
635 Set_Next_Declarative_Item
636 (Decl_Item,
637 To => First_Declarative_Item_Of
638 (Naming_Package, Tree),
639 In_Tree => Tree);
640 Set_First_Declarative_Item_Of
641 (Naming_Package,
642 To => Decl_Item,
643 In_Tree => Tree);
644 Set_Current_Item_Node
645 (Decl_Item,
646 To => Attribute,
647 In_Tree => Tree);
648
649 -- Is it a spec or a body?
650
651 if Current_Source.Spec then
652 Set_Name_Of
653 (Attribute, Tree,
654 To => Name_Spec);
655 else
656 Set_Name_Of
657 (Attribute, Tree,
658 To => Name_Body);
659 end if;
660
661 -- Get the name of the unit
662
663 Get_Name_String (Current_Source.Unit_Name);
664 To_Lower (Name_Buffer (1 .. Name_Len));
665 Set_Associative_Array_Index_Of
666 (Attribute, Tree, To => Name_Find);
667
668 Set_Expression_Of
669 (Attribute, Tree, To => Expression);
670 Set_First_Term
671 (Expression, Tree, To => Term);
672 Set_Current_Term
673 (Term, Tree, To => Value);
674
675 -- And set the name of the file
676
677 Set_String_Value_Of
678 (Value, Tree, To => Current_Source.File_Name);
679 Set_Source_Index_Of
680 (Value, Tree, To => Current_Source.Index);
681 end if;
682 end;
683 end loop;
684
685 -- Close the source list file
686
687 Close (Source_List_FD);
688
689 -- Output the project file
690
691 Prj.PP.Pretty_Print
692 (Project_Node, Tree,
693 W_Char => Write_A_Char'Access,
694 W_Eol => Write_Eol'Access,
695 W_Str => Write_A_String'Access,
696 Backward_Compatibility => False);
697 Close (Output_FD);
698
699 -- Delete the naming project file if it already exists
700
701 Delete_File
702 (Project_Naming_File_Name (1 .. Project_Naming_Last),
703 Success => Discard);
704
705 -- Create a new one
706
707 if Opt.Verbose_Mode then
708 Output.Write_Str ("Creating new naming project file """);
709 Output.Write_Str (Project_Naming_File_Name
710 (1 .. Project_Naming_Last));
711 Output.Write_Line ("""");
712 end if;
713
714 Output_FD := Create_New_File
715 (Project_Naming_File_Name (1 .. Project_Naming_Last),
716 Fmode => Text);
717
718 -- Fails if naming project file cannot be created
719
720 if Output_FD = Invalid_FD then
721 Prj.Com.Fail
722 ("cannot create new """
723 & Project_Naming_File_Name (1 .. Project_Naming_Last)
724 & """");
725 end if;
726
727 -- Output the naming project file
728
729 Prj.PP.Pretty_Print
730 (Project_Naming_Node, Tree,
731 W_Char => Write_A_Char'Access,
732 W_Eol => Write_Eol'Access,
733 W_Str => Write_A_String'Access,
734 Backward_Compatibility => False);
735 Close (Output_FD);
736
737 else
738 -- For each Ada source, write a pragma Source_File_Name to the
739 -- configuration pragmas file.
740
741 for Index in 1 .. Sources.Last loop
742 if Sources.Table (Index).Unit_Name /= No_Name then
743 Write_A_String ("pragma Source_File_Name");
744 Write_Eol;
745 Write_A_String (" (");
746 Write_A_String
747 (Get_Name_String (Sources.Table (Index).Unit_Name));
748 Write_A_String (",");
749 Write_Eol;
750
751 if Sources.Table (Index).Spec then
752 Write_A_String (" Spec_File_Name => """);
753
754 else
755 Write_A_String (" Body_File_Name => """);
756 end if;
757
758 Write_A_String
759 (Get_Name_String (Sources.Table (Index).File_Name));
760
761 Write_A_String ("""");
762
763 if Sources.Table (Index).Index /= 0 then
764 Write_A_String (", Index =>");
765 Write_A_String (Sources.Table (Index).Index'Img);
766 end if;
767
768 Write_A_String (");");
769 Write_Eol;
770 end if;
771 end loop;
772
773 Close (Output_FD);
774 end if;
775 end Finalize;
776
777 ----------------
778 -- Initialize --
779 ----------------
780
781 procedure Initialize
782 (File_Path : String;
783 Project_File : Boolean;
784 Preproc_Switches : Argument_List;
785 Very_Verbose : Boolean;
786 Flags : Processing_Flags)
787 is
788 begin
789 Makr.Very_Verbose := Initialize.Very_Verbose;
790 Makr.Project_File := Initialize.Project_File;
791
792 -- Do some needed initializations
793
794 Csets.Initialize;
795 Namet.Initialize;
796 Snames.Initialize;
797 Prj.Initialize (No_Project_Tree);
798 Prj.Tree.Initialize (Tree);
799
800 Sources.Set_Last (0);
801 Source_Directories.Set_Last (0);
802
803 -- Initialize the compiler switches
804
805 Args := new Argument_List (1 .. Preproc_Switches'Length + 6);
806 Args (1) := new String'("-c");
807 Args (2) := new String'("-gnats");
808 Args (3) := new String'("-gnatu");
809 Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches;
810 Args (4 + Preproc_Switches'Length) := new String'("-x");
811 Args (5 + Preproc_Switches'Length) := new String'("ada");
812
813 -- Get the path and file names
814
815 Path_Name := new
816 String (1 .. File_Path'Length + Project_File_Extension'Length);
817 Path_Last := File_Path'Length;
818
819 if File_Names_Case_Sensitive then
820 Path_Name (1 .. Path_Last) := File_Path;
821 else
822 Path_Name (1 .. Path_Last) := To_Lower (File_Path);
823 end if;
824
825 Path_Name (Path_Last + 1 .. Path_Name'Last) :=
826 Project_File_Extension;
827
828 -- Get the end of directory information, if any
829
830 for Index in reverse 1 .. Path_Last loop
831 if Path_Name (Index) = Directory_Separator then
832 Directory_Last := Index;
833 exit;
834 end if;
835 end loop;
836
837 if Project_File then
838 if Path_Last < Project_File_Extension'Length + 1
839 or else Path_Name
840 (Path_Last - Project_File_Extension'Length + 1 .. Path_Last)
841 /= Project_File_Extension
842 then
843 Path_Last := Path_Name'Last;
844 end if;
845
846 Output_Name := new String'(To_Lower (Path_Name (1 .. Path_Last)));
847 Output_Name_Last := Output_Name'Last - 4;
848
849 -- If there is already a project file with the specified name, parse
850 -- it to get the components that are not automatically generated.
851
852 if Is_Regular_File (Output_Name (1 .. Path_Last)) then
853 if Opt.Verbose_Mode then
854 Output.Write_Str ("Parsing already existing project file """);
855 Output.Write_Str (Output_Name.all);
856 Output.Write_Line ("""");
857 end if;
858
859 Part.Parse
860 (In_Tree => Tree,
861 Project => Project_Node,
862 Project_File_Name => Output_Name.all,
863 Always_Errout_Finalize => False,
864 Store_Comments => True,
865 Is_Config_File => False,
866 Flags => Flags,
867 Current_Directory => Get_Current_Dir,
868 Packages_To_Check => Packages_To_Check_By_Gnatname);
869
870 -- Fail if parsing was not successful
871
872 if No (Project_Node) then
873 Prj.Com.Fail ("parsing of existing project file failed");
874
875 else
876 -- If parsing was successful, remove the components that are
877 -- automatically generated, if any, so that they will be
878 -- unconditionally added later.
879
880 -- Remove the with clause for the naming project file
881
882 declare
883 With_Clause : Project_Node_Id :=
884 First_With_Clause_Of (Project_Node, Tree);
885 Previous : Project_Node_Id := Empty_Node;
886
887 begin
888 while Present (With_Clause) loop
889 if Prj.Tree.Name_Of (With_Clause, Tree) =
890 Project_Naming_Id
891 then
892 if No (Previous) then
893 Set_First_With_Clause_Of
894 (Project_Node, Tree,
895 To => Next_With_Clause_Of (With_Clause, Tree));
896 else
897 Set_Next_With_Clause_Of
898 (Previous, Tree,
899 To => Next_With_Clause_Of (With_Clause, Tree));
900 end if;
901
902 exit;
903 end if;
904
905 Previous := With_Clause;
906 With_Clause := Next_With_Clause_Of (With_Clause, Tree);
907 end loop;
908 end;
909
910 -- Remove attribute declarations of Source_Files,
911 -- Source_List_File, Source_Dirs, and the declaration of
912 -- package Naming, if they exist, but preserve the comments
913 -- attached to these nodes.
914
915 declare
916 Declaration : Project_Node_Id :=
917 First_Declarative_Item_Of
918 (Project_Declaration_Of
919 (Project_Node, Tree),
920 Tree);
921 Previous : Project_Node_Id := Empty_Node;
922 Current_Node : Project_Node_Id := Empty_Node;
923
924 Name : Name_Id;
925 Kind_Of_Node : Project_Node_Kind;
926 Comments : Project_Node_Id;
927
928 begin
929 while Present (Declaration) loop
930 Current_Node := Current_Item_Node (Declaration, Tree);
931
932 Kind_Of_Node := Kind_Of (Current_Node, Tree);
933
934 if Kind_Of_Node = N_Attribute_Declaration or else
935 Kind_Of_Node = N_Package_Declaration
936 then
937 Name := Prj.Tree.Name_Of (Current_Node, Tree);
938
939 if Name = Name_Source_Files or else
940 Name = Name_Source_List_File or else
941 Name = Name_Source_Dirs or else
942 Name = Name_Naming
943 then
944 Comments :=
945 Tree.Project_Nodes.Table (Current_Node).Comments;
946
947 if Name = Name_Source_Files then
948 Source_Files_Comments := Comments;
949
950 elsif Name = Name_Source_List_File then
951 Source_List_File_Comments := Comments;
952
953 elsif Name = Name_Source_Dirs then
954 Source_Dirs_Comments := Comments;
955
956 elsif Name = Name_Naming then
957 Naming_Package_Comments := Comments;
958 end if;
959
960 if No (Previous) then
961 Set_First_Declarative_Item_Of
962 (Project_Declaration_Of (Project_Node, Tree),
963 Tree,
964 To => Next_Declarative_Item
965 (Declaration, Tree));
966
967 else
968 Set_Next_Declarative_Item
969 (Previous, Tree,
970 To => Next_Declarative_Item
971 (Declaration, Tree));
972 end if;
973
974 else
975 Previous := Declaration;
976 end if;
977 end if;
978
979 Declaration := Next_Declarative_Item (Declaration, Tree);
980 end loop;
981 end;
982 end if;
983 end if;
984
985 if Directory_Last /= 0 then
986 Output_Name (1 .. Output_Name_Last - Directory_Last) :=
987 Output_Name (Directory_Last + 1 .. Output_Name_Last);
988 Output_Name_Last := Output_Name_Last - Directory_Last;
989 end if;
990
991 -- Get the project name id
992
993 Name_Len := Output_Name_Last;
994 Name_Buffer (1 .. Name_Len) := Output_Name (1 .. Name_Len);
995 Output_Name_Id := Name_Find;
996
997 -- Create the project naming file name
998
999 Project_Naming_Last := Output_Name_Last;
1000 Project_Naming_File_Name :=
1001 new String'(Output_Name (1 .. Output_Name_Last) &
1002 Naming_File_Suffix &
1003 Project_File_Extension);
1004 Project_Naming_Last :=
1005 Project_Naming_Last + Naming_File_Suffix'Length;
1006
1007 -- Get the project naming id
1008
1009 Name_Len := Project_Naming_Last;
1010 Name_Buffer (1 .. Name_Len) :=
1011 Project_Naming_File_Name (1 .. Name_Len);
1012 Project_Naming_Id := Name_Find;
1013
1014 Project_Naming_Last :=
1015 Project_Naming_Last + Project_File_Extension'Length;
1016
1017 -- Create the source list file name
1018
1019 Source_List_Last := Output_Name_Last;
1020 Source_List_Path :=
1021 new String'(Output_Name (1 .. Output_Name_Last) &
1022 Source_List_File_Suffix);
1023 Source_List_Last :=
1024 Output_Name_Last + Source_List_File_Suffix'Length;
1025
1026 -- Add the project file extension to the project name
1027
1028 Output_Name
1029 (Output_Name_Last + 1 ..
1030 Output_Name_Last + Project_File_Extension'Length) :=
1031 Project_File_Extension;
1032 Output_Name_Last := Output_Name_Last + Project_File_Extension'Length;
1033
1034 end if;
1035
1036 -- Change the current directory to the directory of the project file,
1037 -- if any directory information is specified.
1038
1039 if Directory_Last /= 0 then
1040 begin
1041 Change_Dir (Path_Name (1 .. Directory_Last));
1042 exception
1043 when Directory_Error =>
1044 Prj.Com.Fail
1045 ("unknown directory """
1046 & Path_Name (1 .. Directory_Last)
1047 & """");
1048 end;
1049 end if;
1050 end Initialize;
1051
1052 -------------
1053 -- Process --
1054 -------------
1055
1056 procedure Process
1057 (Directories : Argument_List;
1058 Name_Patterns : Regexp_List;
1059 Excluded_Patterns : Regexp_List;
1060 Foreign_Patterns : Regexp_List)
1061 is
1062 procedure Process_Directory (Dir_Name : String; Recursively : Boolean);
1063 -- Look for Ada and foreign sources in a directory, according to the
1064 -- patterns. When Recursively is True, after looking for sources in
1065 -- Dir_Name, look also in its subdirectories, if any.
1066
1067 -----------------------
1068 -- Process_Directory --
1069 -----------------------
1070
1071 procedure Process_Directory (Dir_Name : String; Recursively : Boolean) is
1072 Matched : Matched_Type := False;
1073 Str : String (1 .. 2_000);
1074 Canon : String (1 .. 2_000);
1075 Last : Natural;
1076 Dir : Dir_Type;
1077 Do_Process : Boolean := True;
1078
1079 Temp_File_Name : String_Access := null;
1080 Save_Last_Source_Index : Natural := 0;
1081 File_Name_Id : Name_Id := No_Name;
1082
1083 Current_Source : Source;
1084
1085 begin
1086 -- Avoid processing the same directory more than once
1087
1088 for Index in 1 .. Processed_Directories.Last loop
1089 if Processed_Directories.Table (Index).all = Dir_Name then
1090 Do_Process := False;
1091 exit;
1092 end if;
1093 end loop;
1094
1095 if Do_Process then
1096 if Opt.Verbose_Mode then
1097 Output.Write_Str ("Processing directory """);
1098 Output.Write_Str (Dir_Name);
1099 Output.Write_Line ("""");
1100 end if;
1101
1102 Processed_Directories. Increment_Last;
1103 Processed_Directories.Table (Processed_Directories.Last) :=
1104 new String'(Dir_Name);
1105
1106 -- Get the source file names from the directory. Fails if the
1107 -- directory does not exist.
1108
1109 begin
1110 Open (Dir, Dir_Name);
1111 exception
1112 when Directory_Error =>
1113 Prj.Com.Fail ("cannot open directory """ & Dir_Name & """");
1114 end;
1115
1116 -- Process each regular file in the directory
1117
1118 File_Loop : loop
1119 Read (Dir, Str, Last);
1120 exit File_Loop when Last = 0;
1121
1122 -- Copy the file name and put it in canonical case to match
1123 -- against the patterns that have themselves already been put
1124 -- in canonical case.
1125
1126 Canon (1 .. Last) := Str (1 .. Last);
1127 Canonical_Case_File_Name (Canon (1 .. Last));
1128
1129 if Is_Regular_File
1130 (Dir_Name & Directory_Separator & Str (1 .. Last))
1131 then
1132 Matched := True;
1133
1134 Name_Len := Last;
1135 Name_Buffer (1 .. Name_Len) := Str (1 .. Last);
1136 File_Name_Id := Name_Find;
1137
1138 -- First, check if the file name matches at least one of
1139 -- the excluded expressions;
1140
1141 for Index in Excluded_Patterns'Range loop
1142 if
1143 Match (Canon (1 .. Last), Excluded_Patterns (Index))
1144 then
1145 Matched := Excluded;
1146 exit;
1147 end if;
1148 end loop;
1149
1150 -- If it does not match any of the excluded expressions,
1151 -- check if the file name matches at least one of the
1152 -- regular expressions.
1153
1154 if Matched = True then
1155 Matched := False;
1156
1157 for Index in Name_Patterns'Range loop
1158 if
1159 Match
1160 (Canon (1 .. Last), Name_Patterns (Index))
1161 then
1162 Matched := True;
1163 exit;
1164 end if;
1165 end loop;
1166 end if;
1167
1168 if Very_Verbose
1169 or else (Matched = True and then Opt.Verbose_Mode)
1170 then
1171 Output.Write_Str (" Checking """);
1172 Output.Write_Str (Str (1 .. Last));
1173 Output.Write_Line (""": ");
1174 end if;
1175
1176 -- If the file name matches one of the regular expressions,
1177 -- parse it to get its unit name.
1178
1179 if Matched = True then
1180 declare
1181 FD : File_Descriptor;
1182 Success : Boolean;
1183 Saved_Output : File_Descriptor;
1184 Saved_Error : File_Descriptor;
1185
1186 begin
1187 -- If we don't have the path of the compiler yet,
1188 -- get it now. The compiler name may have a prefix,
1189 -- so we get the potentially prefixed name.
1190
1191 if Gcc_Path = null then
1192 declare
1193 Prefix_Gcc : String_Access :=
1194 Program_Name (Gcc, "gnatname");
1195 begin
1196 Gcc_Path :=
1197 Locate_Exec_On_Path (Prefix_Gcc.all);
1198 Free (Prefix_Gcc);
1199 end;
1200
1201 if Gcc_Path = null then
1202 Prj.Com.Fail ("could not locate " & Gcc);
1203 end if;
1204 end if;
1205
1206 -- If we don't have yet the file name of the
1207 -- temporary file, get it now.
1208
1209 if Temp_File_Name = null then
1210 Create_Temp_File (FD, Temp_File_Name);
1211
1212 if FD = Invalid_FD then
1213 Prj.Com.Fail
1214 ("could not create temporary file");
1215 end if;
1216
1217 Close (FD);
1218 Delete_File (Temp_File_Name.all, Success);
1219 end if;
1220
1221 Args (Args'Last) := new String'
1222 (Dir_Name &
1223 Directory_Separator &
1224 Str (1 .. Last));
1225
1226 -- Create the temporary file
1227
1228 FD := Create_Output_Text_File
1229 (Name => Temp_File_Name.all);
1230
1231 if FD = Invalid_FD then
1232 Prj.Com.Fail
1233 ("could not create temporary file");
1234 end if;
1235
1236 -- Save the standard output and error
1237
1238 Saved_Output := Dup (Standout);
1239 Saved_Error := Dup (Standerr);
1240
1241 -- Set standard output and error to the temporary file
1242
1243 Dup2 (FD, Standout);
1244 Dup2 (FD, Standerr);
1245
1246 -- And spawn the compiler
1247
1248 Spawn (Gcc_Path.all, Args.all, Success);
1249
1250 -- Restore the standard output and error
1251
1252 Dup2 (Saved_Output, Standout);
1253 Dup2 (Saved_Error, Standerr);
1254
1255 -- Close the temporary file
1256
1257 Close (FD);
1258
1259 -- And close the saved standard output and error to
1260 -- avoid too many file descriptors.
1261
1262 Close (Saved_Output);
1263 Close (Saved_Error);
1264
1265 -- Now that standard output is restored, check if
1266 -- the compiler ran correctly.
1267
1268 -- Read the lines of the temporary file:
1269 -- they should contain the kind and name of the unit.
1270
1271 declare
1272 File : Text_File;
1273 Text_Line : String (1 .. 1_000);
1274 Text_Last : Natural;
1275
1276 begin
1277 Open (File, Temp_File_Name.all);
1278
1279 if not Is_Valid (File) then
1280 Prj.Com.Fail
1281 ("could not read temporary file");
1282 end if;
1283
1284 Save_Last_Source_Index := Sources.Last;
1285
1286 if End_Of_File (File) then
1287 if Opt.Verbose_Mode then
1288 if not Success then
1289 Output.Write_Str (" (process died) ");
1290 end if;
1291 end if;
1292
1293 else
1294 Line_Loop : while not End_Of_File (File) loop
1295 Get_Line (File, Text_Line, Text_Last);
1296
1297 -- Find the first closing parenthesis
1298
1299 Char_Loop : for J in 1 .. Text_Last loop
1300 if Text_Line (J) = ')' then
1301 if J >= 13 and then
1302 Text_Line (1 .. 4) = "Unit"
1303 then
1304 -- Add entry to Sources table
1305
1306 Name_Len := J - 12;
1307 Name_Buffer (1 .. Name_Len) :=
1308 Text_Line (6 .. J - 7);
1309 Current_Source :=
1310 (Unit_Name => Name_Find,
1311 File_Name => File_Name_Id,
1312 Index => 0,
1313 Spec => Text_Line (J - 5 .. J) =
1314 "(spec)");
1315
1316 Sources.Append (Current_Source);
1317 end if;
1318
1319 exit Char_Loop;
1320 end if;
1321 end loop Char_Loop;
1322 end loop Line_Loop;
1323 end if;
1324
1325 if Save_Last_Source_Index = Sources.Last then
1326 if Opt.Verbose_Mode then
1327 Output.Write_Line (" not a unit");
1328 end if;
1329
1330 else
1331 if Sources.Last >
1332 Save_Last_Source_Index + 1
1333 then
1334 for Index in Save_Last_Source_Index + 1 ..
1335 Sources.Last
1336 loop
1337 Sources.Table (Index).Index :=
1338 Int (Index - Save_Last_Source_Index);
1339 end loop;
1340 end if;
1341
1342 for Index in Save_Last_Source_Index + 1 ..
1343 Sources.Last
1344 loop
1345 Current_Source := Sources.Table (Index);
1346
1347 if Opt.Verbose_Mode then
1348 if Current_Source.Spec then
1349 Output.Write_Str (" spec of ");
1350
1351 else
1352 Output.Write_Str (" body of ");
1353 end if;
1354
1355 Output.Write_Line
1356 (Get_Name_String
1357 (Current_Source.Unit_Name));
1358 end if;
1359 end loop;
1360 end if;
1361
1362 Close (File);
1363
1364 Delete_File (Temp_File_Name.all, Success);
1365 end;
1366 end;
1367
1368 -- File name matches none of the regular expressions
1369
1370 else
1371 -- If file is not excluded, see if this is foreign source
1372
1373 if Matched /= Excluded then
1374 for Index in Foreign_Patterns'Range loop
1375 if Match (Canon (1 .. Last),
1376 Foreign_Patterns (Index))
1377 then
1378 Matched := True;
1379 exit;
1380 end if;
1381 end loop;
1382 end if;
1383
1384 if Very_Verbose then
1385 case Matched is
1386 when False =>
1387 Output.Write_Line ("no match");
1388
1389 when Excluded =>
1390 Output.Write_Line ("excluded");
1391
1392 when True =>
1393 Output.Write_Line ("foreign source");
1394 end case;
1395 end if;
1396
1397 if Matched = True then
1398
1399 -- Add source file name without unit name
1400
1401 Name_Len := 0;
1402 Add_Str_To_Name_Buffer (Canon (1 .. Last));
1403 Sources.Append
1404 ((File_Name => Name_Find,
1405 Unit_Name => No_Name,
1406 Index => 0,
1407 Spec => False));
1408 end if;
1409 end if;
1410 end if;
1411 end loop File_Loop;
1412
1413 Close (Dir);
1414 end if;
1415
1416 -- If Recursively is True, call itself for each subdirectory.
1417 -- We do that, even when this directory has already been processed,
1418 -- because all of its subdirectories may not have been processed.
1419
1420 if Recursively then
1421 Open (Dir, Dir_Name);
1422
1423 loop
1424 Read (Dir, Str, Last);
1425 exit when Last = 0;
1426
1427 -- Do not call itself for "." or ".."
1428
1429 if Is_Directory
1430 (Dir_Name & Directory_Separator & Str (1 .. Last))
1431 and then Str (1 .. Last) /= "."
1432 and then Str (1 .. Last) /= ".."
1433 then
1434 Process_Directory
1435 (Dir_Name & Directory_Separator & Str (1 .. Last),
1436 Recursively => True);
1437 end if;
1438 end loop;
1439
1440 Close (Dir);
1441 end if;
1442 end Process_Directory;
1443
1444 -- Start of processing for Process
1445
1446 begin
1447 Processed_Directories.Set_Last (0);
1448
1449 -- Process each directory
1450
1451 for Index in Directories'Range loop
1452
1453 declare
1454 Dir_Name : constant String := Directories (Index).all;
1455 Last : Natural := Dir_Name'Last;
1456 Recursively : Boolean := False;
1457 Found : Boolean;
1458 Canonical : String (1 .. Dir_Name'Length) := Dir_Name;
1459
1460 begin
1461 Canonical_Case_File_Name (Canonical);
1462
1463 Found := False;
1464 for J in 1 .. Source_Directories.Last loop
1465 if Source_Directories.Table (J).all = Canonical then
1466 Found := True;
1467 exit;
1468 end if;
1469 end loop;
1470
1471 if not Found then
1472 Source_Directories.Append (new String'(Canonical));
1473 end if;
1474
1475 if Dir_Name'Length >= 4
1476 and then (Dir_Name (Last - 2 .. Last) = "/**")
1477 then
1478 Last := Last - 3;
1479 Recursively := True;
1480 end if;
1481
1482 Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively);
1483 end;
1484
1485 end loop;
1486 end Process;
1487
1488 ----------------
1489 -- Write_Char --
1490 ----------------
1491 procedure Write_A_Char (C : Character) is
1492 begin
1493 Write_A_String ((1 => C));
1494 end Write_A_Char;
1495
1496 ---------------
1497 -- Write_Eol --
1498 ---------------
1499
1500 procedure Write_Eol is
1501 begin
1502 Write_A_String ((1 => ASCII.LF));
1503 end Write_Eol;
1504
1505 --------------------
1506 -- Write_A_String --
1507 --------------------
1508
1509 procedure Write_A_String (S : String) is
1510 Str : String (1 .. S'Length);
1511
1512 begin
1513 if S'Length > 0 then
1514 Str := S;
1515
1516 if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then
1517 Prj.Com.Fail ("disk full");
1518 end if;
1519 end if;
1520 end Write_A_String;
1521
1522 end Prj.Makr;