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