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-2019, 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 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 1192begin 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; 1408end Gnatname; 1409