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