gcc/ada/prj-makr.adb

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