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-2020, 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 26with Ada.Characters.Handling; use Ada.Characters.Handling; 27with Ada.Command_Line; use Ada.Command_Line; 28with Ada.Text_IO; use Ada.Text_IO; 29 30with GNAT.Command_Line; use GNAT.Command_Line; 31with GNAT.Directory_Operations; use GNAT.Directory_Operations; 32with GNAT.Dynamic_Tables; 33with GNAT.OS_Lib; use GNAT.OS_Lib; 34 35with Make_Util; use Make_Util; 36with Namet; use Namet; 37with Opt; 38with Osint; use Osint; 39with Output; 40with Switch; use Switch; 41with Table; 42with Tempdir; 43with Types; use Types; 44 45with System.CRTL; 46with System.Regexp; use System.Regexp; 47 48procedure 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 1194begin 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; 1410end Gnatname; 1411