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