gcc/ada/prj-makr.adb

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