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