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