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