gcc/ada/gnatname.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             G N A T N A M E                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2001-2024, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Ada.Characters.Handling;   use Ada.Characters.Handling;
  27 with Ada.Command_Line;          use Ada.Command_Line;
  28 with Ada.Text_IO;               use Ada.Text_IO;
  29
  30 with GNAT.Command_Line;         use GNAT.Command_Line;
  31 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  32 with GNAT.Dynamic_Tables;
  33 with GNAT.OS_Lib;               use GNAT.OS_Lib;
  34
  35 with Make_Util; use Make_Util;
  36 with Namet;     use Namet;
  37 with Opt;
  38 with Osint;     use Osint;
  39 with Output;
  40 with Switch;    use Switch;
  41 with Table;
  42 with Tempdir;
  43 with Types;     use Types;
  44
  45 with System.CRTL;
  46 with System.Regexp;    use System.Regexp;
  47
  48 procedure Gnatname is
  49
  50    pragma Warnings (Off);
  51    type Matched_Type is (True, False, Excluded);
  52    pragma Warnings (On);
  53
  54    Create_Project : Boolean := False;
  55
  56    Subdirs_Switch : constant String := "--subdirs=";
  57
  58    Usage_Output : Boolean := False;
  59    --  Set to True when usage is output, to avoid multiple output
  60
  61    Usage_Needed : Boolean := False;
  62    --  Set to True by -h switch
  63
  64    Version_Output : Boolean := False;
  65    --  Set to True when version is output, to avoid multiple output
  66
  67    Very_Verbose : Boolean := False;
  68    --  Set to True with -v -v
  69
  70    File_Path : String_Access := new String'("gnat.adc");
  71    --  Path name of the file specified by -c or -P switch
  72
  73    File_Set : Boolean := False;
  74    --  Set to True by -c or -P switch.
  75    --  Used to detect multiple -c/-P switches.
  76
  77    Args : Argument_List_Access;
  78    --  The list of arguments for calls to the compiler to get the unit names
  79    --  and kinds (spec or body) in the Ada sources.
  80
  81    Path_Name : String_Access;
  82
  83    Path_Last : Natural;
  84
  85    Directory_Last    : Natural := 0;
  86
  87    function Dup (Fd : File_Descriptor) return File_Descriptor;
  88
  89    procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
  90
  91    Gcc      : constant String := "gcc";
  92    Gcc_Path : String_Access := null;
  93
  94    package Patterns is new GNAT.Dynamic_Tables
  95      (Table_Component_Type => String_Access,
  96       Table_Index_Type     => Natural,
  97       Table_Low_Bound      => 0,
  98       Table_Initial        => 10,
  99       Table_Increment      => 100);
 100    --  Table to accumulate the patterns
 101
 102    type Argument_Data is record
 103       Directories       : Patterns.Instance;
 104       Name_Patterns     : Patterns.Instance;
 105       Excluded_Patterns : Patterns.Instance;
 106       Foreign_Patterns  : Patterns.Instance;
 107    end record;
 108
 109    package Arguments is new Table.Table
 110      (Table_Component_Type => Argument_Data,
 111       Table_Index_Type     => Natural,
 112       Table_Low_Bound      => 0,
 113       Table_Initial        => 10,
 114       Table_Increment      => 100,
 115       Table_Name           => "Gnatname.Arguments");
 116    --  Table to accumulate directories and patterns
 117
 118    package Preprocessor_Switches is new Table.Table
 119      (Table_Component_Type => String_Access,
 120       Table_Index_Type     => Natural,
 121       Table_Low_Bound      => 0,
 122       Table_Initial        => 10,
 123       Table_Increment      => 100,
 124       Table_Name           => "Gnatname.Preprocessor_Switches");
 125    --  Table to store the preprocessor switches to be used in the call
 126    --  to the compiler.
 127
 128    type Source is record
 129       File_Name : Name_Id;
 130       Unit_Name : Name_Id;
 131       Index     : Int := 0;
 132       Spec      : Boolean;
 133    end record;
 134
 135    package Processed_Directories is new Table.Table
 136      (Table_Component_Type => String_Access,
 137       Table_Index_Type     => Natural,
 138       Table_Low_Bound      => 0,
 139       Table_Initial        => 10,
 140       Table_Increment      => 100,
 141       Table_Name           => "Prj.Makr.Processed_Directories");
 142    --  The list of already processed directories for each section, to avoid
 143    --  processing several times the same directory in the same section.
 144
 145    package Sources is new Table.Table
 146      (Table_Component_Type => Source,
 147       Table_Index_Type     => Natural,
 148       Table_Low_Bound      => 0,
 149       Table_Initial        => 10,
 150       Table_Increment      => 100,
 151       Table_Name           => "Gnatname.Sources");
 152    --  The list of Ada sources found, with their unit name and kind, to be put
 153    --  in the pragmas Source_File_Name in the configuration pragmas file.
 154
 155    procedure Output_Version;
 156    --  Print name and version
 157
 158    procedure Usage;
 159    --  Print usage
 160
 161    procedure Scan_Args;
 162    --  Scan the command line arguments
 163
 164    procedure Add_Source_Directory (S : String);
 165    --  Add S in the Source_Directories table
 166
 167    procedure Get_Directories (From_File : String);
 168    --  Read a source directory text file
 169
 170    procedure Write_Eol;
 171    --  Output an empty line
 172
 173    procedure Write_A_String (S : String);
 174    --  Write a String to Output_FD
 175
 176    procedure Initialize
 177      (File_Path         : String;
 178       Preproc_Switches  : Argument_List);
 179    --  Start the creation of a configuration pragmas file
 180    --
 181    --  File_Path is the name of the configuration pragmas file to create
 182    --
 183    --  Preproc_Switches is a list of switches to be used when invoking the
 184    --  compiler to get the name and kind of unit of a source file.
 185
 186    type Regexp_List is array (Positive range <>) of Regexp;
 187
 188    procedure Process
 189      (Directories       : Argument_List;
 190       Name_Patterns     : Regexp_List;
 191       Excluded_Patterns : Regexp_List;
 192       Foreign_Patterns  : Regexp_List);
 193    --  Look for source files in the specified directories, with the specified
 194    --  patterns.
 195    --
 196    --  Directories is the list of source directories where to look for sources.
 197    --
 198    --  Name_Patterns is a potentially empty list of file name patterns to check
 199    --  for Ada Sources.
 200    --
 201    --  Excluded_Patterns is a potentially empty list of file name patterns that
 202    --  should not be checked for Ada or non Ada sources.
 203    --
 204    --  Foreign_Patterns is a potentially empty list of file name patterns to
 205    --  check for non Ada sources.
 206    --
 207    --  At least one of Name_Patterns and Foreign_Patterns is not empty
 208
 209    procedure Finalize;
 210    --  Write the configuration pragmas file indicated in a call to procedure
 211    --  Initialize, after one or several calls to procedure Process.
 212
 213    --------------------------
 214    -- Add_Source_Directory --
 215    --------------------------
 216
 217    procedure Add_Source_Directory (S : String) is
 218    begin
 219       Patterns.Append
 220         (Arguments.Table (Arguments.Last).Directories, new String'(S));
 221    end Add_Source_Directory;
 222
 223    ---------
 224    -- Dup --
 225    ---------
 226
 227    function Dup  (Fd : File_Descriptor) return File_Descriptor is
 228    begin
 229       return File_Descriptor (System.CRTL.dup (Integer (Fd)));
 230    end Dup;
 231
 232    ----------
 233    -- Dup2 --
 234    ----------
 235
 236    procedure Dup2 (Old_Fd, New_Fd : File_Descriptor) is
 237       Fd : Integer;
 238       pragma Warnings (Off, Fd);
 239    begin
 240       Fd := System.CRTL.dup2 (Integer (Old_Fd), Integer (New_Fd));
 241    end Dup2;
 242
 243    ---------------------
 244    -- Get_Directories --
 245    ---------------------
 246
 247    procedure Get_Directories (From_File : String) is
 248       File : Ada.Text_IO.File_Type;
 249       Line : String (1 .. 2_000);
 250       Last : Natural;
 251
 252    begin
 253       Open (File, In_File, From_File);
 254
 255       while not End_Of_File (File) loop
 256          Get_Line (File, Line, Last);
 257
 258          if Last /= 0 then
 259             Add_Source_Directory (Line (1 .. Last));
 260          end if;
 261       end loop;
 262
 263       Close (File);
 264
 265    exception
 266       when Name_Error =>
 267          Fail ("cannot open source directory file """ & From_File & '"');
 268    end Get_Directories;
 269
 270    --------------
 271    -- Finalize --
 272    --------------
 273
 274    procedure Finalize is
 275       Discard : Boolean;
 276       pragma Warnings (Off, Discard);
 277
 278    begin
 279       --  Delete the file if it already exists
 280
 281       Delete_File
 282         (Path_Name (Directory_Last + 1 .. Path_Last),
 283          Success => Discard);
 284
 285       --  Create a new one
 286
 287       if Opt.Verbose_Mode then
 288          Output.Write_Str ("Creating new file """);
 289          Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last));
 290          Output.Write_Line ("""");
 291       end if;
 292
 293       Output_FD := Create_New_File
 294         (Path_Name (Directory_Last + 1 .. Path_Last),
 295          Fmode => Text);
 296
 297       --  Fails if file cannot be created
 298
 299       if Output_FD = Invalid_FD then
 300          Fail_Program
 301            ("cannot create new """ & Path_Name (1 .. Path_Last) & """");
 302       end if;
 303
 304       --  For each Ada source, write a pragma Source_File_Name to the
 305       --  configuration pragmas file.
 306
 307       for Index in 1 .. Sources.Last loop
 308          if Sources.Table (Index).Unit_Name /= No_Name then
 309             Write_A_String ("pragma Source_File_Name");
 310             Write_Eol;
 311             Write_A_String ("  (");
 312             Write_A_String
 313               (Get_Name_String (Sources.Table (Index).Unit_Name));
 314             Write_A_String (",");
 315             Write_Eol;
 316
 317             if Sources.Table (Index).Spec then
 318                Write_A_String ("   Spec_File_Name => """);
 319
 320             else
 321                Write_A_String ("   Body_File_Name => """);
 322             end if;
 323
 324             Write_A_String
 325               (Get_Name_String (Sources.Table (Index).File_Name));
 326
 327             Write_A_String ("""");
 328
 329             if Sources.Table (Index).Index /= 0 then
 330                Write_A_String (", Index =>");
 331                Write_A_String (Sources.Table (Index).Index'Img);
 332             end if;
 333
 334             Write_A_String (");");
 335             Write_Eol;
 336          end if;
 337       end loop;
 338
 339       Close (Output_FD);
 340    end Finalize;
 341
 342    ----------------
 343    -- Initialize --
 344    ----------------
 345
 346    procedure Initialize
 347      (File_Path         : String;
 348       Preproc_Switches  : Argument_List)
 349    is
 350    begin
 351       Sources.Set_Last (0);
 352
 353       --  Initialize the compiler switches
 354
 355       Args := new Argument_List (1 .. Preproc_Switches'Length + 6);
 356       Args (1) := new String'("-c");
 357       Args (2) := new String'("-gnats");
 358       Args (3) := new String'("-gnatu");
 359       Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches;
 360       Args (4 + Preproc_Switches'Length) := new String'("-x");
 361       Args (5 + Preproc_Switches'Length) := new String'("ada");
 362
 363       --  Get the path and file names
 364
 365       Path_Name := new
 366         String (1 .. File_Path'Length);
 367       Path_Last := File_Path'Length;
 368
 369       if File_Names_Case_Sensitive then
 370          Path_Name (1 .. Path_Last) := File_Path;
 371       else
 372          Path_Name (1 .. Path_Last) := To_Lower (File_Path);
 373       end if;
 374
 375       --  Get the end of directory information, if any
 376
 377       for Index in reverse 1 .. Path_Last loop
 378          if Path_Name (Index) = Directory_Separator then
 379             Directory_Last := Index;
 380             exit;
 381          end if;
 382       end loop;
 383
 384       --  Change the current directory to the directory of the project file,
 385       --  if any directory information is specified.
 386
 387       if Directory_Last /= 0 then
 388          begin
 389             Change_Dir (Path_Name (1 .. Directory_Last));
 390          exception
 391             when Directory_Error =>
 392                Fail_Program
 393                  ("unknown directory """
 394                   & Path_Name (1 .. Directory_Last)
 395                   & """");
 396          end;
 397       end if;
 398    end Initialize;
 399
 400    -------------
 401    -- Process --
 402    -------------
 403
 404    procedure Process
 405      (Directories       : Argument_List;
 406       Name_Patterns     : Regexp_List;
 407       Excluded_Patterns : Regexp_List;
 408       Foreign_Patterns  : Regexp_List)
 409   is
 410       procedure Process_Directory (Dir_Name : String);
 411       --  Look for Ada and foreign sources in a directory, according to the
 412       --  patterns.
 413
 414       -----------------------
 415       -- Process_Directory --
 416       -----------------------
 417
 418       procedure Process_Directory (Dir_Name : String) is
 419          Matched : Matched_Type := False;
 420          Str     : String (1 .. 2_000);
 421          Canon   : String (1 .. 2_000);
 422          Last    : Natural;
 423          Dir     : Dir_Type;
 424          Do_Process : Boolean := True;
 425
 426          Temp_File_Name         : String_Access := null;
 427          Save_Last_Source_Index : Natural := 0;
 428          File_Name_Id           : Name_Id := No_Name;
 429
 430          Current_Source : Source;
 431
 432       begin
 433          --  Avoid processing the same directory more than once
 434
 435          for Index in 1 .. Processed_Directories.Last loop
 436             if Processed_Directories.Table (Index).all = Dir_Name then
 437                Do_Process := False;
 438                exit;
 439             end if;
 440          end loop;
 441
 442          if Do_Process then
 443             if Opt.Verbose_Mode then
 444                Output.Write_Str ("Processing directory """);
 445                Output.Write_Str (Dir_Name);
 446                Output.Write_Line ("""");
 447             end if;
 448
 449             Processed_Directories. Increment_Last;
 450             Processed_Directories.Table (Processed_Directories.Last) :=
 451               new String'(Dir_Name);
 452
 453             --  Get the source file names from the directory. Fails if the
 454             --  directory does not exist.
 455
 456             begin
 457                Open (Dir, Dir_Name);
 458             exception
 459                when Directory_Error =>
 460                   Fail_Program ("cannot open directory """ & Dir_Name & """");
 461             end;
 462
 463             --  Process each regular file in the directory
 464
 465             File_Loop : loop
 466                Read (Dir, Str, Last);
 467                exit File_Loop when Last = 0;
 468
 469                --  Copy the file name and put it in canonical case to match
 470                --  against the patterns that have themselves already been put
 471                --  in canonical case.
 472
 473                Canon (1 .. Last) := Str (1 .. Last);
 474                Canonical_Case_File_Name (Canon (1 .. Last));
 475
 476                if Is_Regular_File
 477                     (Dir_Name & Directory_Separator & Str (1 .. Last))
 478                then
 479                   Matched := True;
 480
 481                   Name_Len := Last;
 482                   Name_Buffer (1 .. Name_Len) := Str (1 .. Last);
 483                   File_Name_Id := Name_Find;
 484
 485                   --  First, check if the file name matches at least one of
 486                   --  the excluded expressions;
 487
 488                   for Index in Excluded_Patterns'Range loop
 489                      if
 490                        Match (Canon (1 .. Last), Excluded_Patterns (Index))
 491                      then
 492                         Matched := Excluded;
 493                         exit;
 494                      end if;
 495                   end loop;
 496
 497                   --  If it does not match any of the excluded expressions,
 498                   --  check if the file name matches at least one of the
 499                   --  regular expressions.
 500
 501                   if Matched = True then
 502                      Matched := False;
 503
 504                      for Index in Name_Patterns'Range loop
 505                         if
 506                           Match
 507                             (Canon (1 .. Last), Name_Patterns (Index))
 508                         then
 509                            Matched := True;
 510                            exit;
 511                         end if;
 512                      end loop;
 513                   end if;
 514
 515                   if Very_Verbose
 516                     or else (Matched = True and then Opt.Verbose_Mode)
 517                   then
 518                      Output.Write_Str ("   Checking """);
 519                      Output.Write_Str (Str (1 .. Last));
 520                      Output.Write_Line (""": ");
 521                   end if;
 522
 523                   --  If the file name matches one of the regular expressions,
 524                   --  parse it to get its unit name.
 525
 526                   if Matched = True then
 527                      declare
 528                         FD : File_Descriptor;
 529                         Success : Boolean;
 530                         Saved_Output : File_Descriptor;
 531                         Saved_Error  : File_Descriptor;
 532                         Tmp_File     : Path_Name_Type;
 533
 534                      begin
 535                         --  If we don't have the path of the compiler yet,
 536                         --  get it now. The compiler name may have a prefix,
 537                         --  so we get the potentially prefixed name.
 538
 539                         if Gcc_Path = null then
 540                            declare
 541                               Prefix_Gcc : String_Access :=
 542                                              Program_Name (Gcc, "gnatname");
 543                            begin
 544                               Gcc_Path :=
 545                                 Locate_Exec_On_Path (Prefix_Gcc.all);
 546                               Free (Prefix_Gcc);
 547                            end;
 548
 549                            if Gcc_Path = null then
 550                               Fail_Program ("could not locate " & Gcc);
 551                            end if;
 552                         end if;
 553
 554                         --  Create the temporary file
 555
 556                         Tempdir.Create_Temp_File (FD, Tmp_File);
 557
 558                         if FD = Invalid_FD then
 559                            Fail_Program
 560                              ("could not create temporary file");
 561
 562                         else
 563                            Temp_File_Name :=
 564                              new String'(Get_Name_String (Tmp_File));
 565                         end if;
 566
 567                         Args (Args'Last) :=
 568                           new String'
 569                             (Dir_Name & Directory_Separator & Str (1 .. Last));
 570
 571                         --  Save the standard output and error
 572
 573                         Saved_Output := Dup (Standout);
 574                         Saved_Error  := Dup (Standerr);
 575
 576                         --  Set standard output and error to the temporary file
 577
 578                         Dup2 (FD, Standout);
 579                         Dup2 (FD, Standerr);
 580
 581                         --  And spawn the compiler
 582
 583                         Spawn (Gcc_Path.all, Args.all, Success);
 584
 585                         --  Restore the standard output and error
 586
 587                         Dup2 (Saved_Output, Standout);
 588                         Dup2 (Saved_Error, Standerr);
 589
 590                         --  Close the temporary file
 591
 592                         Close (FD);
 593
 594                         --  And close the saved standard output and error to
 595                         --  avoid too many file descriptors.
 596
 597                         Close (Saved_Output);
 598                         Close (Saved_Error);
 599
 600                         --  Now that standard output is restored, check if
 601                         --  the compiler ran correctly.
 602
 603                         --  Read the lines of the temporary file:
 604                         --  they should contain the kind and name of the unit.
 605
 606                         declare
 607                            File      : Ada.Text_IO.File_Type;
 608                            Text_Line : String (1 .. 1_000);
 609                            Text_Last : Natural;
 610
 611                         begin
 612                            begin
 613                               Open (File, In_File, Temp_File_Name.all);
 614
 615                            exception
 616                               when others =>
 617                                  Fail_Program
 618                                    ("could not read temporary file " &
 619                                       Temp_File_Name.all);
 620                            end;
 621
 622                            Save_Last_Source_Index := Sources.Last;
 623
 624                            if End_Of_File (File) then
 625                               if Opt.Verbose_Mode then
 626                                  if not Success then
 627                                     Output.Write_Str ("      (process died) ");
 628                                  end if;
 629                               end if;
 630
 631                            else
 632                               Line_Loop : while not End_Of_File (File) loop
 633                                  Get_Line (File, Text_Line, Text_Last);
 634
 635                                  --  Find the first closing parenthesis
 636
 637                                  Char_Loop : for J in 1 .. Text_Last loop
 638                                     if Text_Line (J) = ')' then
 639                                        if J >= 13 and then
 640                                          Text_Line (1 .. 4) = "Unit"
 641                                        then
 642                                           --  Add entry to Sources table
 643
 644                                           Name_Len := J - 12;
 645                                           Name_Buffer (1 .. Name_Len) :=
 646                                             Text_Line (6 .. J - 7);
 647                                           Current_Source :=
 648                                             (Unit_Name  => Name_Find,
 649                                              File_Name  => File_Name_Id,
 650                                              Index => 0,
 651                                              Spec  => Text_Line (J - 5 .. J) =
 652                                                         "(spec)");
 653
 654                                           Sources.Append (Current_Source);
 655                                        end if;
 656
 657                                        exit Char_Loop;
 658                                     end if;
 659                                  end loop Char_Loop;
 660                               end loop Line_Loop;
 661                            end if;
 662
 663                            if Save_Last_Source_Index = Sources.Last then
 664                               if Opt.Verbose_Mode then
 665                                  Output.Write_Line ("      not a unit");
 666                               end if;
 667
 668                            else
 669                               if Sources.Last >
 670                                    Save_Last_Source_Index + 1
 671                               then
 672                                  for Index in Save_Last_Source_Index + 1 ..
 673                                                 Sources.Last
 674                                  loop
 675                                     Sources.Table (Index).Index :=
 676                                       Int (Index - Save_Last_Source_Index);
 677                                  end loop;
 678                               end if;
 679
 680                               for Index in Save_Last_Source_Index + 1 ..
 681                                              Sources.Last
 682                               loop
 683                                  Current_Source := Sources.Table (Index);
 684                                  pragma Annotate
 685                                    (CodePeer, Modified, Current_Source);
 686
 687                                  if Opt.Verbose_Mode then
 688                                     if Current_Source.Spec then
 689                                        Output.Write_Str ("      spec of ");
 690
 691                                     else
 692                                        Output.Write_Str ("      body of ");
 693                                     end if;
 694
 695                                     Output.Write_Line
 696                                       (Get_Name_String
 697                                          (Current_Source.Unit_Name));
 698                                  end if;
 699                               end loop;
 700                            end if;
 701
 702                            Close (File);
 703
 704                            Delete_File (Temp_File_Name.all, Success);
 705                         end;
 706                      end;
 707
 708                   --  File name matches none of the regular expressions
 709
 710                   else
 711                      --  If file is not excluded, see if this is foreign source
 712
 713                      if Matched /= Excluded then
 714                         for Index in Foreign_Patterns'Range loop
 715                            if Match (Canon (1 .. Last),
 716                                      Foreign_Patterns (Index))
 717                            then
 718                               Matched := True;
 719                               exit;
 720                            end if;
 721                         end loop;
 722                      end if;
 723
 724                      if Very_Verbose then
 725                         case Matched is
 726                            when False =>
 727                               Output.Write_Line ("no match");
 728
 729                            when Excluded =>
 730                               Output.Write_Line ("excluded");
 731
 732                            when True =>
 733                               Output.Write_Line ("foreign source");
 734                         end case;
 735                      end if;
 736
 737                      if Matched = True then
 738
 739                         --  Add source file name without unit name
 740
 741                         Name_Len := 0;
 742                         Add_Str_To_Name_Buffer (Canon (1 .. Last));
 743                         Sources.Append
 744                           ((File_Name => Name_Find,
 745                             Unit_Name => No_Name,
 746                             Index     => 0,
 747                             Spec      => False));
 748                      end if;
 749                   end if;
 750                end if;
 751             end loop File_Loop;
 752
 753             Close (Dir);
 754          end if;
 755
 756       end Process_Directory;
 757
 758    --  Start of processing for Process
 759
 760    begin
 761       Processed_Directories.Set_Last (0);
 762
 763       --  Process each directory
 764
 765       for Index in Directories'Range  loop
 766          Process_Directory (Directories (Index).all);
 767       end loop;
 768    end Process;
 769
 770    --------------------
 771    -- Output_Version --
 772    --------------------
 773
 774    procedure Output_Version is
 775    begin
 776       if not Version_Output then
 777          Version_Output := True;
 778          Output.Write_Eol;
 779          Display_Version ("GNATNAME", "2001");
 780       end if;
 781    end Output_Version;
 782
 783    ---------------
 784    -- Scan_Args --
 785    ---------------
 786
 787    procedure Scan_Args is
 788
 789       procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
 790
 791       Project_File_Name_Expected : Boolean;
 792
 793       Pragmas_File_Expected : Boolean;
 794
 795       Directory_Expected : Boolean;
 796
 797       Dir_File_Name_Expected : Boolean;
 798
 799       Foreign_Pattern_Expected : Boolean;
 800
 801       Excluded_Pattern_Expected : Boolean;
 802
 803       procedure Check_Regular_Expression (S : String);
 804       --  Compile string S into a Regexp, fail if any error
 805
 806       -----------------------------
 807       -- Check_Regular_Expression--
 808       -----------------------------
 809
 810       procedure Check_Regular_Expression (S : String) is
 811          Dummy : Regexp;
 812          pragma Warnings (Off, Dummy);
 813       begin
 814          Dummy := Compile (S, Glob => True);
 815       exception
 816          when Error_In_Regexp =>
 817             Fail ("invalid regular expression """ & S & """");
 818       end Check_Regular_Expression;
 819
 820    --  Start of processing for Scan_Args
 821
 822    begin
 823       --  First check for --version or --help
 824
 825       Check_Version_And_Help ("GNATNAME", "2001");
 826
 827       --  Now scan the other switches
 828
 829       Project_File_Name_Expected := False;
 830       Pragmas_File_Expected      := False;
 831       Directory_Expected         := False;
 832       Dir_File_Name_Expected     := False;
 833       Foreign_Pattern_Expected   := False;
 834       Excluded_Pattern_Expected  := False;
 835
 836       for Next_Arg in 1 .. Argument_Count loop
 837          declare
 838             Next_Argv : constant String := Argument (Next_Arg);
 839             Arg       : String (1 .. Next_Argv'Length) := Next_Argv;
 840
 841          begin
 842             if Arg'Length > 0 then
 843
 844                --  -P xxx
 845
 846                if Project_File_Name_Expected then
 847                   if Arg (1) = '-' then
 848                      Fail ("project file name missing");
 849
 850                   else
 851                      File_Set       := True;
 852                      File_Path      := new String'(Arg);
 853                      Project_File_Name_Expected := False;
 854                   end if;
 855
 856                --  -c file
 857
 858                elsif Pragmas_File_Expected then
 859                   File_Set := True;
 860                   File_Path := new String'(Arg);
 861                   Pragmas_File_Expected := False;
 862
 863                --  -d xxx
 864
 865                elsif Directory_Expected then
 866                   Add_Source_Directory (Arg);
 867                   Directory_Expected := False;
 868
 869                --  -D xxx
 870
 871                elsif Dir_File_Name_Expected then
 872                   Get_Directories (Arg);
 873                   Dir_File_Name_Expected := False;
 874
 875                --  -f xxx
 876
 877                elsif Foreign_Pattern_Expected then
 878                   Patterns.Append
 879                     (Arguments.Table (Arguments.Last).Foreign_Patterns,
 880                      new String'(Arg));
 881                   Check_Regular_Expression (Arg);
 882                   Foreign_Pattern_Expected := False;
 883
 884                --  -x xxx
 885
 886                elsif Excluded_Pattern_Expected then
 887                   Patterns.Append
 888                     (Arguments.Table (Arguments.Last).Excluded_Patterns,
 889                      new String'(Arg));
 890                   Check_Regular_Expression (Arg);
 891                   Excluded_Pattern_Expected := False;
 892
 893                --  There must be at least one Ada pattern or one foreign
 894                --  pattern for the previous section.
 895
 896                --  --and
 897
 898                elsif Arg = "--and" then
 899
 900                   if Patterns.Last
 901                     (Arguments.Table (Arguments.Last).Name_Patterns) = 0
 902                     and then
 903                       Patterns.Last
 904                         (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0
 905                   then
 906                      Try_Help;
 907                      return;
 908                   end if;
 909
 910                   --  If no directory were specified for the previous section,
 911                   --  then the directory is the project directory.
 912
 913                   if Patterns.Last
 914                     (Arguments.Table (Arguments.Last).Directories) = 0
 915                   then
 916                      Patterns.Append
 917                        (Arguments.Table (Arguments.Last).Directories,
 918                         new String'("."));
 919                   end if;
 920
 921                   --  Add and initialize another component to Arguments table
 922
 923                   declare
 924                      New_Arguments : Argument_Data;
 925                      pragma Warnings (Off, New_Arguments);
 926                      --  Declaring this defaulted initialized object ensures
 927                      --  that the new allocated component of table Arguments
 928                      --  is correctly initialized.
 929
 930                      --  This is VERY ugly, Table should never be used with
 931                      --  data requiring default initialization. We should
 932                      --  find a way to avoid violating this rule ???
 933
 934                   begin
 935                      Arguments.Append (New_Arguments);
 936                   end;
 937
 938                   Patterns.Init
 939                     (Arguments.Table (Arguments.Last).Directories);
 940                   Patterns.Set_Last
 941                     (Arguments.Table (Arguments.Last).Directories, 0);
 942                   Patterns.Init
 943                     (Arguments.Table (Arguments.Last).Name_Patterns);
 944                   Patterns.Set_Last
 945                     (Arguments.Table (Arguments.Last).Name_Patterns, 0);
 946                   Patterns.Init
 947                     (Arguments.Table (Arguments.Last).Excluded_Patterns);
 948                   Patterns.Set_Last
 949                     (Arguments.Table (Arguments.Last).Excluded_Patterns, 0);
 950                   Patterns.Init
 951                     (Arguments.Table (Arguments.Last).Foreign_Patterns);
 952                   Patterns.Set_Last
 953                     (Arguments.Table (Arguments.Last).Foreign_Patterns, 0);
 954
 955                --  Subdirectory switch
 956
 957                elsif Arg'Length > Subdirs_Switch'Length
 958                  and then Arg (1 .. Subdirs_Switch'Length) = Subdirs_Switch
 959                then
 960                   null;
 961                   --  Subdirs are only used in gprname
 962
 963                --  --no-backup
 964
 965                elsif Arg = "--no-backup" then
 966                   Opt.No_Backup := True;
 967
 968                --  -c
 969
 970                elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-c" then
 971                   if File_Set then
 972                      Fail ("only one -P or -c switch may be specified");
 973                   end if;
 974
 975                   if Arg'Length = 2 then
 976                      Pragmas_File_Expected := True;
 977
 978                      if Next_Arg = Argument_Count then
 979                         Fail ("configuration pragmas file name missing");
 980                      end if;
 981
 982                   else
 983                      File_Set := True;
 984                      File_Path := new String'(Arg (3 .. Arg'Last));
 985                   end if;
 986
 987                --  -d
 988
 989                elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-d" then
 990                   if Arg'Length = 2 then
 991                      Directory_Expected := True;
 992
 993                      if Next_Arg = Argument_Count then
 994                         Fail ("directory name missing");
 995                      end if;
 996
 997                   else
 998                      Add_Source_Directory (Arg (3 .. Arg'Last));
 999                   end if;
1000
1001                --  -D
1002
1003                elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-D" then
1004                   if Arg'Length = 2 then
1005                      Dir_File_Name_Expected := True;
1006
1007                      if Next_Arg = Argument_Count then
1008                         Fail ("directory list file name missing");
1009                      end if;
1010
1011                   else
1012                      Get_Directories (Arg (3 .. Arg'Last));
1013                   end if;
1014
1015                --  -eL
1016
1017                elsif Arg = "-eL" then
1018                   Opt.Follow_Links_For_Files := True;
1019                   Opt.Follow_Links_For_Dirs  := True;
1020
1021                --  -f
1022
1023                elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-f" then
1024                   if Arg'Length = 2 then
1025                      Foreign_Pattern_Expected := True;
1026
1027                      if Next_Arg = Argument_Count then
1028                         Fail ("foreign pattern missing");
1029                      end if;
1030
1031                   else
1032                      Patterns.Append
1033                        (Arguments.Table (Arguments.Last).Foreign_Patterns,
1034                         new String'(Arg (3 .. Arg'Last)));
1035                      Check_Regular_Expression (Arg (3 .. Arg'Last));
1036                   end if;
1037
1038                --  -gnatep or -gnateD
1039
1040                elsif Arg'Length > 7 and then
1041                  (Arg  (1 .. 7) = "-gnatep" or else Arg (1 .. 7) = "-gnateD")
1042                then
1043                   Preprocessor_Switches.Append (new String'(Arg));
1044
1045                --  -h
1046
1047                elsif Arg = "-h" then
1048                   Usage_Needed := True;
1049
1050                --  -P
1051
1052                elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-P" then
1053                   if File_Set then
1054                      Fail ("only one -c or -P switch may be specified");
1055                   end if;
1056
1057                   if Arg'Length = 2 then
1058                      if Next_Arg = Argument_Count then
1059                         Fail ("project file name missing");
1060
1061                      else
1062                         Project_File_Name_Expected := True;
1063                      end if;
1064
1065                   else
1066                      File_Set       := True;
1067                      File_Path      := new String'(Arg (3 .. Arg'Last));
1068                   end if;
1069
1070                   Create_Project := True;
1071
1072                --  -v
1073
1074                elsif Arg = "-v" then
1075                   if Opt.Verbose_Mode then
1076                      Very_Verbose := True;
1077                   else
1078                      Opt.Verbose_Mode := True;
1079                   end if;
1080
1081                --  -x
1082
1083                elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-x" then
1084                   if Arg'Length = 2 then
1085                      Excluded_Pattern_Expected := True;
1086
1087                      if Next_Arg = Argument_Count then
1088                         Fail ("excluded pattern missing");
1089                      end if;
1090
1091                   else
1092                      Patterns.Append
1093                        (Arguments.Table (Arguments.Last).Excluded_Patterns,
1094                         new String'(Arg (3 .. Arg'Last)));
1095                      Check_Regular_Expression (Arg (3 .. Arg'Last));
1096                   end if;
1097
1098                --  Junk switch starting with minus
1099
1100                elsif Arg (1) = '-' then
1101                   Fail ("wrong switch: " & Arg);
1102
1103                --  Not a recognized switch, assume file name
1104
1105                else
1106                   Canonical_Case_File_Name (Arg);
1107                   Patterns.Append
1108                     (Arguments.Table (Arguments.Last).Name_Patterns,
1109                      new String'(Arg));
1110                   Check_Regular_Expression (Arg);
1111                end if;
1112             end if;
1113          end;
1114       end loop;
1115    end Scan_Args;
1116
1117    -----------
1118    -- Usage --
1119    -----------
1120
1121    procedure Usage is
1122    begin
1123       if not Usage_Output then
1124          Usage_Needed := False;
1125          Usage_Output := True;
1126          Output.Write_Str ("Usage: ");
1127          Osint.Write_Program_Name;
1128          Output.Write_Line (" [switches] naming-pattern [naming-patterns]");
1129          Output.Write_Line
1130            ("   {--and [switches] naming-pattern [naming-patterns]}");
1131          Output.Write_Eol;
1132          Output.Write_Line ("switches:");
1133
1134          Display_Usage_Version_And_Help;
1135
1136          Output.Write_Line
1137            ("  --subdirs=dir real obj/lib/exec dirs are subdirs");
1138          Output.Write_Line
1139            ("  --no-backup   do not create backup of project file");
1140          Output.Write_Eol;
1141
1142          Output.Write_Line ("  --and        use different patterns");
1143          Output.Write_Eol;
1144
1145          Output.Write_Line
1146            ("  -cfile       create configuration pragmas file");
1147          Output.Write_Line ("  -ddir        use dir as one of the source " &
1148                             "directories");
1149          Output.Write_Line ("  -Dfile       get source directories from file");
1150          Output.Write_Line
1151            ("  -eL          follow symbolic links when processing " &
1152             "project files");
1153          Output.Write_Line ("  -fpat        foreign pattern");
1154          Output.Write_Line
1155            ("  -gnateDsym=v preprocess with symbol definition");
1156          Output.Write_Line ("  -gnatep=data preprocess files with data file");
1157          Output.Write_Line ("  -h           output this help message");
1158          Output.Write_Line
1159            ("  -Pproj       update or create project file proj");
1160          Output.Write_Line ("  -v           verbose output");
1161          Output.Write_Line ("  -v -v        very verbose output");
1162          Output.Write_Line ("  -xpat        exclude pattern pat");
1163       end if;
1164    end Usage;
1165
1166    ---------------
1167    -- Write_Eol --
1168    ---------------
1169
1170    procedure Write_Eol is
1171    begin
1172       Write_A_String ((1 => ASCII.LF));
1173    end Write_Eol;
1174
1175    --------------------
1176    -- Write_A_String --
1177    --------------------
1178
1179    procedure Write_A_String (S : String) is
1180       Str : String (1 .. S'Length);
1181
1182    begin
1183       if S'Length > 0 then
1184          Str := S;
1185
1186          if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then
1187             Fail_Program ("disk full");
1188          end if;
1189       end if;
1190    end Write_A_String;
1191
1192 --  Start of processing for Gnatname
1193
1194 begin
1195    --  Add the directory where gnatname is invoked in front of the
1196    --  path, if gnatname is invoked with directory information.
1197
1198    declare
1199       Command : constant String := Command_Name;
1200
1201    begin
1202       for Index in reverse Command'Range loop
1203          if Command (Index) = Directory_Separator then
1204             declare
1205                Absolute_Dir : constant String :=
1206                                 Normalize_Pathname
1207                                   (Command (Command'First .. Index));
1208
1209                PATH         : constant String :=
1210                                 Absolute_Dir &
1211                                 Path_Separator &
1212                                 Getenv ("PATH").all;
1213
1214             begin
1215                Setenv ("PATH", PATH);
1216             end;
1217
1218             exit;
1219          end if;
1220       end loop;
1221    end;
1222
1223    --  Initialize tables
1224
1225    Arguments.Set_Last (0);
1226    declare
1227       New_Arguments : Argument_Data;
1228       pragma Warnings (Off, New_Arguments);
1229       --  Declaring this defaulted initialized object ensures that the new
1230       --  allocated component of table Arguments is correctly initialized.
1231    begin
1232       Arguments.Append (New_Arguments);
1233    end;
1234
1235    Patterns.Init (Arguments.Table (1).Directories);
1236    Patterns.Set_Last (Arguments.Table (1).Directories, 0);
1237    Patterns.Init (Arguments.Table (1).Name_Patterns);
1238    Patterns.Set_Last (Arguments.Table (1).Name_Patterns, 0);
1239    Patterns.Init (Arguments.Table (1).Excluded_Patterns);
1240    Patterns.Set_Last (Arguments.Table (1).Excluded_Patterns, 0);
1241    Patterns.Init (Arguments.Table (1).Foreign_Patterns);
1242    Patterns.Set_Last (Arguments.Table (1).Foreign_Patterns, 0);
1243
1244    Preprocessor_Switches.Set_Last (0);
1245
1246    --  Get the arguments
1247
1248    Scan_Args;
1249
1250    if Create_Project then
1251       declare
1252          Gprname_Path : constant String_Access :=
1253            Locate_Exec_On_Path ("gprname");
1254          Arg_Len : Natural       := Argument_Count;
1255          Pos     : Natural       := 0;
1256          Target  : String_Access := null;
1257          Success : Boolean       := False;
1258       begin
1259          if Gprname_Path = null then
1260             Fail_Program
1261               ("project files are no longer supported by gnatname;" &
1262                " use gprname instead");
1263          end if;
1264
1265          Find_Program_Name;
1266
1267          if Name_Len > 9
1268             and then Name_Buffer (Name_Len - 7 .. Name_Len) = "gnatname"
1269          then
1270             Target  := new String'(Name_Buffer (1 .. Name_Len - 9));
1271             Arg_Len := Arg_Len + 1;
1272          end if;
1273
1274          declare
1275             Args : Argument_List (1 .. Arg_Len);
1276          begin
1277             if Target /= null then
1278                Args (1) := new String'("--target=" & Target.all);
1279                Pos := 1;
1280             end if;
1281
1282             for J in 1 .. Argument_Count loop
1283                Pos := Pos + 1;
1284                Args (Pos) := new String'(Argument (J));
1285             end loop;
1286
1287             Spawn (Gprname_Path.all, Args, Success);
1288
1289             if Success then
1290                Exit_Program (E_Success);
1291             else
1292                Exit_Program (E_Errors);
1293             end if;
1294          end;
1295       end;
1296    end if;
1297
1298    if Opt.Verbose_Mode then
1299       Output_Version;
1300    end if;
1301
1302    if Usage_Needed then
1303       Usage;
1304    end if;
1305
1306    --  If no Ada or foreign pattern was specified, print the usage and return
1307
1308    if Patterns.Last (Arguments.Table (Arguments.Last).Name_Patterns) = 0
1309         and then
1310       Patterns.Last (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0
1311    then
1312       if Argument_Count = 0 then
1313          Usage;
1314       elsif not Usage_Output then
1315          Try_Help;
1316       end if;
1317
1318       return;
1319    end if;
1320
1321    --  If no source directory was specified, use the current directory as the
1322    --  unique directory. Note that if a file was specified with directory
1323    --  information, the current directory is the directory of the specified
1324    --  file.
1325
1326    if Patterns.Last (Arguments.Table (Arguments.Last).Directories) = 0 then
1327       Patterns.Append
1328         (Arguments.Table (Arguments.Last).Directories, new String'("."));
1329    end if;
1330
1331    --  Initialize
1332
1333    declare
1334       Prep_Switches : Argument_List
1335                         (1 .. Integer (Preprocessor_Switches.Last));
1336
1337    begin
1338       for Index in Prep_Switches'Range loop
1339          Prep_Switches (Index) := Preprocessor_Switches.Table (Index);
1340       end loop;
1341
1342       Initialize
1343         (File_Path         => File_Path.all,
1344          Preproc_Switches  => Prep_Switches);
1345    end;
1346
1347    --  Process each section successively
1348
1349    for J in 1 .. Arguments.Last loop
1350       declare
1351          Directories   : Argument_List
1352            (1 .. Integer
1353                    (Patterns.Last (Arguments.Table (J).Directories)));
1354          Name_Patterns : Regexp_List
1355            (1 .. Integer
1356                    (Patterns.Last (Arguments.Table (J).Name_Patterns)));
1357          Excl_Patterns : Regexp_List
1358            (1 .. Integer
1359                    (Patterns.Last (Arguments.Table (J).Excluded_Patterns)));
1360          Frgn_Patterns : Regexp_List
1361            (1 .. Integer
1362                    (Patterns.Last (Arguments.Table (J).Foreign_Patterns)));
1363
1364       begin
1365          --  Build the Directories and Patterns arguments
1366
1367          for Index in Directories'Range loop
1368             Directories (Index) :=
1369               Arguments.Table (J).Directories.Table (Index);
1370          end loop;
1371
1372          for Index in Name_Patterns'Range loop
1373             Name_Patterns (Index) :=
1374               Compile
1375                 (Arguments.Table (J).Name_Patterns.Table (Index).all,
1376                  Glob => True);
1377          end loop;
1378
1379          for Index in Excl_Patterns'Range loop
1380             Excl_Patterns (Index) :=
1381               Compile
1382                 (Arguments.Table (J).Excluded_Patterns.Table (Index).all,
1383                  Glob => True);
1384          end loop;
1385
1386          for Index in Frgn_Patterns'Range loop
1387             Frgn_Patterns (Index) :=
1388               Compile
1389                 (Arguments.Table (J).Foreign_Patterns.Table (Index).all,
1390                  Glob => True);
1391          end loop;
1392
1393          --  Call Prj.Makr.Process where the real work is done
1394
1395          Process
1396            (Directories       => Directories,
1397             Name_Patterns     => Name_Patterns,
1398             Excluded_Patterns => Excl_Patterns,
1399             Foreign_Patterns  => Frgn_Patterns);
1400       end;
1401    end loop;
1402
1403    --  Finalize
1404
1405    Finalize;
1406
1407    if Opt.Verbose_Mode then
1408       Output.Write_Eol;
1409    end if;
1410 end Gnatname;