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-2017, 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
 685                                  if Opt.Verbose_Mode then
 686                                     if Current_Source.Spec then
 687                                        Output.Write_Str ("      spec of ");
 688
 689                                     else
 690                                        Output.Write_Str ("      body of ");
 691                                     end if;
 692
 693                                     Output.Write_Line
 694                                       (Get_Name_String
 695                                          (Current_Source.Unit_Name));
 696                                  end if;
 697                               end loop;
 698                            end if;
 699
 700                            Close (File);
 701
 702                            Delete_File (Temp_File_Name.all, Success);
 703                         end;
 704                      end;
 705
 706                   --  File name matches none of the regular expressions
 707
 708                   else
 709                      --  If file is not excluded, see if this is foreign source
 710
 711                      if Matched /= Excluded then
 712                         for Index in Foreign_Patterns'Range loop
 713                            if Match (Canon (1 .. Last),
 714                                      Foreign_Patterns (Index))
 715                            then
 716                               Matched := True;
 717                               exit;
 718                            end if;
 719                         end loop;
 720                      end if;
 721
 722                      if Very_Verbose then
 723                         case Matched is
 724                            when False =>
 725                               Output.Write_Line ("no match");
 726
 727                            when Excluded =>
 728                               Output.Write_Line ("excluded");
 729
 730                            when True =>
 731                               Output.Write_Line ("foreign source");
 732                         end case;
 733                      end if;
 734
 735                      if Matched = True then
 736
 737                         --  Add source file name without unit name
 738
 739                         Name_Len := 0;
 740                         Add_Str_To_Name_Buffer (Canon (1 .. Last));
 741                         Sources.Append
 742                           ((File_Name => Name_Find,
 743                             Unit_Name => No_Name,
 744                             Index     => 0,
 745                             Spec      => False));
 746                      end if;
 747                   end if;
 748                end if;
 749             end loop File_Loop;
 750
 751             Close (Dir);
 752          end if;
 753
 754       end Process_Directory;
 755
 756    --  Start of processing for Process
 757
 758    begin
 759       Processed_Directories.Set_Last (0);
 760
 761       --  Process each directory
 762
 763       for Index in Directories'Range  loop
 764          Process_Directory (Directories (Index).all);
 765       end loop;
 766    end Process;
 767
 768    --------------------
 769    -- Output_Version --
 770    --------------------
 771
 772    procedure Output_Version is
 773    begin
 774       if not Version_Output then
 775          Version_Output := True;
 776          Output.Write_Eol;
 777          Display_Version ("GNATNAME", "2001");
 778       end if;
 779    end Output_Version;
 780
 781    ---------------
 782    -- Scan_Args --
 783    ---------------
 784
 785    procedure Scan_Args is
 786
 787       procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
 788
 789       Project_File_Name_Expected : Boolean;
 790
 791       Pragmas_File_Expected : Boolean;
 792
 793       Directory_Expected : Boolean;
 794
 795       Dir_File_Name_Expected : Boolean;
 796
 797       Foreign_Pattern_Expected : Boolean;
 798
 799       Excluded_Pattern_Expected : Boolean;
 800
 801       procedure Check_Regular_Expression (S : String);
 802       --  Compile string S into a Regexp, fail if any error
 803
 804       -----------------------------
 805       -- Check_Regular_Expression--
 806       -----------------------------
 807
 808       procedure Check_Regular_Expression (S : String) is
 809          Dummy : Regexp;
 810          pragma Warnings (Off, Dummy);
 811       begin
 812          Dummy := Compile (S, Glob => True);
 813       exception
 814          when Error_In_Regexp =>
 815             Fail ("invalid regular expression """ & S & """");
 816       end Check_Regular_Expression;
 817
 818    --  Start of processing for Scan_Args
 819
 820    begin
 821       --  First check for --version or --help
 822
 823       Check_Version_And_Help ("GNATNAME", "2001");
 824
 825       --  Now scan the other switches
 826
 827       Project_File_Name_Expected := False;
 828       Pragmas_File_Expected      := False;
 829       Directory_Expected         := False;
 830       Dir_File_Name_Expected     := False;
 831       Foreign_Pattern_Expected   := False;
 832       Excluded_Pattern_Expected  := False;
 833
 834       for Next_Arg in 1 .. Argument_Count loop
 835          declare
 836             Next_Argv : constant String := Argument (Next_Arg);
 837             Arg       : String (1 .. Next_Argv'Length) := Next_Argv;
 838
 839          begin
 840             if Arg'Length > 0 then
 841
 842                --  -P xxx
 843
 844                if Project_File_Name_Expected then
 845                   if Arg (1) = '-' then
 846                      Fail ("project file name missing");
 847
 848                   else
 849                      File_Set       := True;
 850                      File_Path      := new String'(Arg);
 851                      Project_File_Name_Expected := False;
 852                   end if;
 853
 854                --  -c file
 855
 856                elsif Pragmas_File_Expected then
 857                   File_Set := True;
 858                   File_Path := new String'(Arg);
 859                   Pragmas_File_Expected := False;
 860
 861                --  -d xxx
 862
 863                elsif Directory_Expected then
 864                   Add_Source_Directory (Arg);
 865                   Directory_Expected := False;
 866
 867                --  -D xxx
 868
 869                elsif Dir_File_Name_Expected then
 870                   Get_Directories (Arg);
 871                   Dir_File_Name_Expected := False;
 872
 873                --  -f xxx
 874
 875                elsif Foreign_Pattern_Expected then
 876                   Patterns.Append
 877                     (Arguments.Table (Arguments.Last).Foreign_Patterns,
 878                      new String'(Arg));
 879                   Check_Regular_Expression (Arg);
 880                   Foreign_Pattern_Expected := False;
 881
 882                --  -x xxx
 883
 884                elsif Excluded_Pattern_Expected then
 885                   Patterns.Append
 886                     (Arguments.Table (Arguments.Last).Excluded_Patterns,
 887                      new String'(Arg));
 888                   Check_Regular_Expression (Arg);
 889                   Excluded_Pattern_Expected := False;
 890
 891                --  There must be at least one Ada pattern or one foreign
 892                --  pattern for the previous section.
 893
 894                --  --and
 895
 896                elsif Arg = "--and" then
 897
 898                   if Patterns.Last
 899                     (Arguments.Table (Arguments.Last).Name_Patterns) = 0
 900                     and then
 901                       Patterns.Last
 902                         (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0
 903                   then
 904                      Try_Help;
 905                      return;
 906                   end if;
 907
 908                   --  If no directory were specified for the previous section,
 909                   --  then the directory is the project directory.
 910
 911                   if Patterns.Last
 912                     (Arguments.Table (Arguments.Last).Directories) = 0
 913                   then
 914                      Patterns.Append
 915                        (Arguments.Table (Arguments.Last).Directories,
 916                         new String'("."));
 917                   end if;
 918
 919                   --  Add and initialize another component to Arguments table
 920
 921                   declare
 922                      New_Arguments : Argument_Data;
 923                      pragma Warnings (Off, New_Arguments);
 924                      --  Declaring this defaulted initialized object ensures
 925                      --  that the new allocated component of table Arguments
 926                      --  is correctly initialized.
 927
 928                      --  This is VERY ugly, Table should never be used with
 929                      --  data requiring default initialization. We should
 930                      --  find a way to avoid violating this rule ???
 931
 932                   begin
 933                      Arguments.Append (New_Arguments);
 934                   end;
 935
 936                   Patterns.Init
 937                     (Arguments.Table (Arguments.Last).Directories);
 938                   Patterns.Set_Last
 939                     (Arguments.Table (Arguments.Last).Directories, 0);
 940                   Patterns.Init
 941                     (Arguments.Table (Arguments.Last).Name_Patterns);
 942                   Patterns.Set_Last
 943                     (Arguments.Table (Arguments.Last).Name_Patterns, 0);
 944                   Patterns.Init
 945                     (Arguments.Table (Arguments.Last).Excluded_Patterns);
 946                   Patterns.Set_Last
 947                     (Arguments.Table (Arguments.Last).Excluded_Patterns, 0);
 948                   Patterns.Init
 949                     (Arguments.Table (Arguments.Last).Foreign_Patterns);
 950                   Patterns.Set_Last
 951                     (Arguments.Table (Arguments.Last).Foreign_Patterns, 0);
 952
 953                --  Subdirectory switch
 954
 955                elsif Arg'Length > Subdirs_Switch'Length
 956                  and then Arg (1 .. Subdirs_Switch'Length) = Subdirs_Switch
 957                then
 958                   null;
 959                   --  Subdirs are only used in gprname
 960
 961                --  --no-backup
 962
 963                elsif Arg = "--no-backup" then
 964                   Opt.No_Backup := True;
 965
 966                --  -c
 967
 968                elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-c" then
 969                   if File_Set then
 970                      Fail ("only one -P or -c switch may be specified");
 971                   end if;
 972
 973                   if Arg'Length = 2 then
 974                      Pragmas_File_Expected := True;
 975
 976                      if Next_Arg = Argument_Count then
 977                         Fail ("configuration pragmas file name missing");
 978                      end if;
 979
 980                   else
 981                      File_Set := True;
 982                      File_Path := new String'(Arg (3 .. Arg'Last));
 983                   end if;
 984
 985                --  -d
 986
 987                elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-d" then
 988                   if Arg'Length = 2 then
 989                      Directory_Expected := True;
 990
 991                      if Next_Arg = Argument_Count then
 992                         Fail ("directory name missing");
 993                      end if;
 994
 995                   else
 996                      Add_Source_Directory (Arg (3 .. Arg'Last));
 997                   end if;
 998
 999                --  -D
1000
1001                elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-D" then
1002                   if Arg'Length = 2 then
1003                      Dir_File_Name_Expected := True;
1004
1005                      if Next_Arg = Argument_Count then
1006                         Fail ("directory list file name missing");
1007                      end if;
1008
1009                   else
1010                      Get_Directories (Arg (3 .. Arg'Last));
1011                   end if;
1012
1013                --  -eL
1014
1015                elsif Arg = "-eL" then
1016                   Opt.Follow_Links_For_Files := True;
1017                   Opt.Follow_Links_For_Dirs  := True;
1018
1019                --  -f
1020
1021                elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-f" then
1022                   if Arg'Length = 2 then
1023                      Foreign_Pattern_Expected := True;
1024
1025                      if Next_Arg = Argument_Count then
1026                         Fail ("foreign pattern missing");
1027                      end if;
1028
1029                   else
1030                      Patterns.Append
1031                        (Arguments.Table (Arguments.Last).Foreign_Patterns,
1032                         new String'(Arg (3 .. Arg'Last)));
1033                      Check_Regular_Expression (Arg (3 .. Arg'Last));
1034                   end if;
1035
1036                --  -gnatep or -gnateD
1037
1038                elsif Arg'Length > 7 and then
1039                  (Arg  (1 .. 7) = "-gnatep" or else Arg (1 .. 7) = "-gnateD")
1040                then
1041                   Preprocessor_Switches.Append (new String'(Arg));
1042
1043                --  -h
1044
1045                elsif Arg = "-h" then
1046                   Usage_Needed := True;
1047
1048                --  -P
1049
1050                elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-P" then
1051                   if File_Set then
1052                      Fail ("only one -c or -P switch may be specified");
1053                   end if;
1054
1055                   if Arg'Length = 2 then
1056                      if Next_Arg = Argument_Count then
1057                         Fail ("project file name missing");
1058
1059                      else
1060                         Project_File_Name_Expected := True;
1061                      end if;
1062
1063                   else
1064                      File_Set       := True;
1065                      File_Path      := new String'(Arg (3 .. Arg'Last));
1066                   end if;
1067
1068                   Create_Project := True;
1069
1070                --  -v
1071
1072                elsif Arg = "-v" then
1073                   if Opt.Verbose_Mode then
1074                      Very_Verbose := True;
1075                   else
1076                      Opt.Verbose_Mode := True;
1077                   end if;
1078
1079                --  -x
1080
1081                elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-x" then
1082                   if Arg'Length = 2 then
1083                      Excluded_Pattern_Expected := True;
1084
1085                      if Next_Arg = Argument_Count then
1086                         Fail ("excluded pattern missing");
1087                      end if;
1088
1089                   else
1090                      Patterns.Append
1091                        (Arguments.Table (Arguments.Last).Excluded_Patterns,
1092                         new String'(Arg (3 .. Arg'Last)));
1093                      Check_Regular_Expression (Arg (3 .. Arg'Last));
1094                   end if;
1095
1096                --  Junk switch starting with minus
1097
1098                elsif Arg (1) = '-' then
1099                   Fail ("wrong switch: " & Arg);
1100
1101                --  Not a recognized switch, assume file name
1102
1103                else
1104                   Canonical_Case_File_Name (Arg);
1105                   Patterns.Append
1106                     (Arguments.Table (Arguments.Last).Name_Patterns,
1107                      new String'(Arg));
1108                   Check_Regular_Expression (Arg);
1109                end if;
1110             end if;
1111          end;
1112       end loop;
1113    end Scan_Args;
1114
1115    -----------
1116    -- Usage --
1117    -----------
1118
1119    procedure Usage is
1120    begin
1121       if not Usage_Output then
1122          Usage_Needed := False;
1123          Usage_Output := True;
1124          Output.Write_Str ("Usage: ");
1125          Osint.Write_Program_Name;
1126          Output.Write_Line (" [switches] naming-pattern [naming-patterns]");
1127          Output.Write_Line
1128            ("   {--and [switches] naming-pattern [naming-patterns]}");
1129          Output.Write_Eol;
1130          Output.Write_Line ("switches:");
1131
1132          Display_Usage_Version_And_Help;
1133
1134          Output.Write_Line
1135            ("  --subdirs=dir real obj/lib/exec dirs are subdirs");
1136          Output.Write_Line
1137            ("  --no-backup   do not create backup of project file");
1138          Output.Write_Eol;
1139
1140          Output.Write_Line ("  --and        use different patterns");
1141          Output.Write_Eol;
1142
1143          Output.Write_Line
1144            ("  -cfile       create configuration pragmas file");
1145          Output.Write_Line ("  -ddir        use dir as one of the source " &
1146                             "directories");
1147          Output.Write_Line ("  -Dfile       get source directories from file");
1148          Output.Write_Line
1149            ("  -eL          follow symbolic links when processing " &
1150             "project files");
1151          Output.Write_Line ("  -fpat        foreign pattern");
1152          Output.Write_Line
1153            ("  -gnateDsym=v preprocess with symbol definition");
1154          Output.Write_Line ("  -gnatep=data preprocess files with data file");
1155          Output.Write_Line ("  -h           output this help message");
1156          Output.Write_Line
1157            ("  -Pproj       update or create project file proj");
1158          Output.Write_Line ("  -v           verbose output");
1159          Output.Write_Line ("  -v -v        very verbose output");
1160          Output.Write_Line ("  -xpat        exclude pattern pat");
1161       end if;
1162    end Usage;
1163
1164    ---------------
1165    -- Write_Eol --
1166    ---------------
1167
1168    procedure Write_Eol is
1169    begin
1170       Write_A_String ((1 => ASCII.LF));
1171    end Write_Eol;
1172
1173    --------------------
1174    -- Write_A_String --
1175    --------------------
1176
1177    procedure Write_A_String (S : String) is
1178       Str : String (1 .. S'Length);
1179
1180    begin
1181       if S'Length > 0 then
1182          Str := S;
1183
1184          if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then
1185             Fail_Program ("disk full");
1186          end if;
1187       end if;
1188    end Write_A_String;
1189
1190 --  Start of processing for Gnatname
1191
1192 begin
1193    --  Add the directory where gnatname is invoked in front of the
1194    --  path, if gnatname is invoked with directory information.
1195
1196    declare
1197       Command : constant String := Command_Name;
1198
1199    begin
1200       for Index in reverse Command'Range loop
1201          if Command (Index) = Directory_Separator then
1202             declare
1203                Absolute_Dir : constant String :=
1204                                 Normalize_Pathname
1205                                   (Command (Command'First .. Index));
1206
1207                PATH         : constant String :=
1208                                 Absolute_Dir &
1209                                 Path_Separator &
1210                                 Getenv ("PATH").all;
1211
1212             begin
1213                Setenv ("PATH", PATH);
1214             end;
1215
1216             exit;
1217          end if;
1218       end loop;
1219    end;
1220
1221    --  Initialize tables
1222
1223    Arguments.Set_Last (0);
1224    declare
1225       New_Arguments : Argument_Data;
1226       pragma Warnings (Off, New_Arguments);
1227       --  Declaring this defaulted initialized object ensures that the new
1228       --  allocated component of table Arguments is correctly initialized.
1229    begin
1230       Arguments.Append (New_Arguments);
1231    end;
1232
1233    Patterns.Init (Arguments.Table (1).Directories);
1234    Patterns.Set_Last (Arguments.Table (1).Directories, 0);
1235    Patterns.Init (Arguments.Table (1).Name_Patterns);
1236    Patterns.Set_Last (Arguments.Table (1).Name_Patterns, 0);
1237    Patterns.Init (Arguments.Table (1).Excluded_Patterns);
1238    Patterns.Set_Last (Arguments.Table (1).Excluded_Patterns, 0);
1239    Patterns.Init (Arguments.Table (1).Foreign_Patterns);
1240    Patterns.Set_Last (Arguments.Table (1).Foreign_Patterns, 0);
1241
1242    Preprocessor_Switches.Set_Last (0);
1243
1244    --  Get the arguments
1245
1246    Scan_Args;
1247
1248    if Create_Project then
1249       declare
1250          Gprname_Path : constant String_Access :=
1251            Locate_Exec_On_Path ("gprname");
1252          Arg_Len : Natural       := Argument_Count;
1253          Pos     : Natural       := 0;
1254          Target  : String_Access := null;
1255          Success : Boolean       := False;
1256       begin
1257          if Gprname_Path = null then
1258             Fail_Program
1259               ("project files are no longer supported by gnatname;" &
1260                " use gprname instead");
1261          end if;
1262
1263          Find_Program_Name;
1264
1265          if Name_Len > 9
1266             and then Name_Buffer (Name_Len - 7 .. Name_Len) = "gnatname"
1267          then
1268             Target  := new String'(Name_Buffer (1 .. Name_Len - 9));
1269             Arg_Len := Arg_Len + 1;
1270          end if;
1271
1272          declare
1273             Args : Argument_List (1 .. Arg_Len);
1274          begin
1275             if Target /= null then
1276                Args (1) := new String'("--target=" & Target.all);
1277                Pos := 1;
1278             end if;
1279
1280             for J in 1 .. Argument_Count loop
1281                Pos := Pos + 1;
1282                Args (Pos) := new String'(Argument (J));
1283             end loop;
1284
1285             Spawn (Gprname_Path.all, Args, Success);
1286
1287             if Success then
1288                Exit_Program (E_Success);
1289             else
1290                Exit_Program (E_Errors);
1291             end if;
1292          end;
1293       end;
1294    end if;
1295
1296    if Opt.Verbose_Mode then
1297       Output_Version;
1298    end if;
1299
1300    if Usage_Needed then
1301       Usage;
1302    end if;
1303
1304    --  If no Ada or foreign pattern was specified, print the usage and return
1305
1306    if Patterns.Last (Arguments.Table (Arguments.Last).Name_Patterns) = 0
1307         and then
1308       Patterns.Last (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0
1309    then
1310       if Argument_Count = 0 then
1311          Usage;
1312       elsif not Usage_Output then
1313          Try_Help;
1314       end if;
1315
1316       return;
1317    end if;
1318
1319    --  If no source directory was specified, use the current directory as the
1320    --  unique directory. Note that if a file was specified with directory
1321    --  information, the current directory is the directory of the specified
1322    --  file.
1323
1324    if Patterns.Last (Arguments.Table (Arguments.Last).Directories) = 0 then
1325       Patterns.Append
1326         (Arguments.Table (Arguments.Last).Directories, new String'("."));
1327    end if;
1328
1329    --  Initialize
1330
1331    declare
1332       Prep_Switches : Argument_List
1333                         (1 .. Integer (Preprocessor_Switches.Last));
1334
1335    begin
1336       for Index in Prep_Switches'Range loop
1337          Prep_Switches (Index) := Preprocessor_Switches.Table (Index);
1338       end loop;
1339
1340       Initialize
1341         (File_Path         => File_Path.all,
1342          Preproc_Switches  => Prep_Switches);
1343    end;
1344
1345    --  Process each section successively
1346
1347    for J in 1 .. Arguments.Last loop
1348       declare
1349          Directories   : Argument_List
1350            (1 .. Integer
1351                    (Patterns.Last (Arguments.Table (J).Directories)));
1352          Name_Patterns : Regexp_List
1353            (1 .. Integer
1354                    (Patterns.Last (Arguments.Table (J).Name_Patterns)));
1355          Excl_Patterns : Regexp_List
1356            (1 .. Integer
1357                    (Patterns.Last (Arguments.Table (J).Excluded_Patterns)));
1358          Frgn_Patterns : Regexp_List
1359            (1 .. Integer
1360                    (Patterns.Last (Arguments.Table (J).Foreign_Patterns)));
1361
1362       begin
1363          --  Build the Directories and Patterns arguments
1364
1365          for Index in Directories'Range loop
1366             Directories (Index) :=
1367               Arguments.Table (J).Directories.Table (Index);
1368          end loop;
1369
1370          for Index in Name_Patterns'Range loop
1371             Name_Patterns (Index) :=
1372               Compile
1373                 (Arguments.Table (J).Name_Patterns.Table (Index).all,
1374                  Glob => True);
1375          end loop;
1376
1377          for Index in Excl_Patterns'Range loop
1378             Excl_Patterns (Index) :=
1379               Compile
1380                 (Arguments.Table (J).Excluded_Patterns.Table (Index).all,
1381                  Glob => True);
1382          end loop;
1383
1384          for Index in Frgn_Patterns'Range loop
1385             Frgn_Patterns (Index) :=
1386               Compile
1387                 (Arguments.Table (J).Foreign_Patterns.Table (Index).all,
1388                  Glob => True);
1389          end loop;
1390
1391          --  Call Prj.Makr.Process where the real work is done
1392
1393          Process
1394            (Directories       => Directories,
1395             Name_Patterns     => Name_Patterns,
1396             Excluded_Patterns => Excl_Patterns,
1397             Foreign_Patterns  => Frgn_Patterns);
1398       end;
1399    end loop;
1400
1401    --  Finalize
1402
1403    Finalize;
1404
1405    if Opt.Verbose_Mode then
1406       Output.Write_Eol;
1407    end if;
1408 end Gnatname;