OSDN Git Service

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