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-2015, 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.Command_Line; use Ada.Command_Line; 27with Ada.Text_IO; use Ada.Text_IO; 28 29with GNAT.Command_Line; use GNAT.Command_Line; 30with GNAT.Dynamic_Tables; 31with GNAT.OS_Lib; use GNAT.OS_Lib; 32 33with Opt; 34with Osint; use Osint; 35with Output; use Output; 36with Prj; use Prj; 37with Prj.Makr; 38with Switch; use Switch; 39with Table; 40 41with System.Regexp; use System.Regexp; 42 43procedure Gnatname is 44 45 Subdirs_Switch : constant String := "--subdirs="; 46 47 Usage_Output : Boolean := False; 48 -- Set to True when usage is output, to avoid multiple output 49 50 Usage_Needed : Boolean := False; 51 -- Set to True by -h switch 52 53 Version_Output : Boolean := False; 54 -- Set to True when version is output, to avoid multiple output 55 56 Very_Verbose : Boolean := False; 57 -- Set to True with -v -v 58 59 Create_Project : Boolean := False; 60 -- Set to True with a -P switch 61 62 File_Path : String_Access := new String'("gnat.adc"); 63 -- Path name of the file specified by -c or -P switch 64 65 File_Set : Boolean := False; 66 -- Set to True by -c or -P switch. 67 -- Used to detect multiple -c/-P switches. 68 69 package Patterns is new GNAT.Dynamic_Tables 70 (Table_Component_Type => String_Access, 71 Table_Index_Type => Natural, 72 Table_Low_Bound => 0, 73 Table_Initial => 10, 74 Table_Increment => 100); 75 -- Table to accumulate the patterns 76 77 type Argument_Data is record 78 Directories : Patterns.Instance; 79 Name_Patterns : Patterns.Instance; 80 Excluded_Patterns : Patterns.Instance; 81 Foreign_Patterns : Patterns.Instance; 82 end record; 83 84 package Arguments is new Table.Table 85 (Table_Component_Type => Argument_Data, 86 Table_Index_Type => Natural, 87 Table_Low_Bound => 0, 88 Table_Initial => 10, 89 Table_Increment => 100, 90 Table_Name => "Gnatname.Arguments"); 91 -- Table to accumulate directories and patterns 92 93 package Preprocessor_Switches is new Table.Table 94 (Table_Component_Type => String_Access, 95 Table_Index_Type => Natural, 96 Table_Low_Bound => 0, 97 Table_Initial => 10, 98 Table_Increment => 100, 99 Table_Name => "Gnatname.Preprocessor_Switches"); 100 -- Table to store the preprocessor switches to be used in the call 101 -- to the compiler. 102 103 procedure Output_Version; 104 -- Print name and version 105 106 procedure Usage; 107 -- Print usage 108 109 procedure Scan_Args; 110 -- Scan the command line arguments 111 112 procedure Add_Source_Directory (S : String); 113 -- Add S in the Source_Directories table 114 115 procedure Get_Directories (From_File : String); 116 -- Read a source directory text file 117 118 -------------------------- 119 -- Add_Source_Directory -- 120 -------------------------- 121 122 procedure Add_Source_Directory (S : String) is 123 begin 124 Patterns.Append 125 (Arguments.Table (Arguments.Last).Directories, new String'(S)); 126 end Add_Source_Directory; 127 128 --------------------- 129 -- Get_Directories -- 130 --------------------- 131 132 procedure Get_Directories (From_File : String) is 133 File : Ada.Text_IO.File_Type; 134 Line : String (1 .. 2_000); 135 Last : Natural; 136 137 begin 138 Open (File, In_File, From_File); 139 140 while not End_Of_File (File) loop 141 Get_Line (File, Line, Last); 142 143 if Last /= 0 then 144 Add_Source_Directory (Line (1 .. Last)); 145 end if; 146 end loop; 147 148 Close (File); 149 150 exception 151 when Name_Error => 152 Fail ("cannot open source directory file """ & From_File & '"'); 153 end Get_Directories; 154 155 -------------------- 156 -- Output_Version -- 157 -------------------- 158 159 procedure Output_Version is 160 begin 161 if not Version_Output then 162 Version_Output := True; 163 Output.Write_Eol; 164 Display_Version ("GNATNAME", "2001"); 165 end if; 166 end Output_Version; 167 168 --------------- 169 -- Scan_Args -- 170 --------------- 171 172 procedure Scan_Args is 173 174 procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); 175 176 Project_File_Name_Expected : Boolean; 177 178 Pragmas_File_Expected : Boolean; 179 180 Directory_Expected : Boolean; 181 182 Dir_File_Name_Expected : Boolean; 183 184 Foreign_Pattern_Expected : Boolean; 185 186 Excluded_Pattern_Expected : Boolean; 187 188 procedure Check_Regular_Expression (S : String); 189 -- Compile string S into a Regexp, fail if any error 190 191 ----------------------------- 192 -- Check_Regular_Expression-- 193 ----------------------------- 194 195 procedure Check_Regular_Expression (S : String) is 196 Dummy : Regexp; 197 pragma Warnings (Off, Dummy); 198 begin 199 Dummy := Compile (S, Glob => True); 200 exception 201 when Error_In_Regexp => 202 Fail ("invalid regular expression """ & S & """"); 203 end Check_Regular_Expression; 204 205 -- Start of processing for Scan_Args 206 207 begin 208 -- First check for --version or --help 209 210 Check_Version_And_Help ("GNATNAME", "2001"); 211 212 -- Now scan the other switches 213 214 Project_File_Name_Expected := False; 215 Pragmas_File_Expected := False; 216 Directory_Expected := False; 217 Dir_File_Name_Expected := False; 218 Foreign_Pattern_Expected := False; 219 Excluded_Pattern_Expected := False; 220 221 for Next_Arg in 1 .. Argument_Count loop 222 declare 223 Next_Argv : constant String := Argument (Next_Arg); 224 Arg : String (1 .. Next_Argv'Length) := Next_Argv; 225 226 begin 227 if Arg'Length > 0 then 228 229 -- -P xxx 230 231 if Project_File_Name_Expected then 232 if Arg (1) = '-' then 233 Fail ("project file name missing"); 234 235 else 236 File_Set := True; 237 File_Path := new String'(Arg); 238 Project_File_Name_Expected := False; 239 end if; 240 241 -- -c file 242 243 elsif Pragmas_File_Expected then 244 File_Set := True; 245 File_Path := new String'(Arg); 246 Create_Project := False; 247 Pragmas_File_Expected := False; 248 249 -- -d xxx 250 251 elsif Directory_Expected then 252 Add_Source_Directory (Arg); 253 Directory_Expected := False; 254 255 -- -D xxx 256 257 elsif Dir_File_Name_Expected then 258 Get_Directories (Arg); 259 Dir_File_Name_Expected := False; 260 261 -- -f xxx 262 263 elsif Foreign_Pattern_Expected then 264 Patterns.Append 265 (Arguments.Table (Arguments.Last).Foreign_Patterns, 266 new String'(Arg)); 267 Check_Regular_Expression (Arg); 268 Foreign_Pattern_Expected := False; 269 270 -- -x xxx 271 272 elsif Excluded_Pattern_Expected then 273 Patterns.Append 274 (Arguments.Table (Arguments.Last).Excluded_Patterns, 275 new String'(Arg)); 276 Check_Regular_Expression (Arg); 277 Excluded_Pattern_Expected := False; 278 279 -- There must be at least one Ada pattern or one foreign 280 -- pattern for the previous section. 281 282 -- --and 283 284 elsif Arg = "--and" then 285 286 if Patterns.Last 287 (Arguments.Table (Arguments.Last).Name_Patterns) = 0 288 and then 289 Patterns.Last 290 (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0 291 then 292 Try_Help; 293 return; 294 end if; 295 296 -- If no directory were specified for the previous section, 297 -- then the directory is the project directory. 298 299 if Patterns.Last 300 (Arguments.Table (Arguments.Last).Directories) = 0 301 then 302 Patterns.Append 303 (Arguments.Table (Arguments.Last).Directories, 304 new String'(".")); 305 end if; 306 307 -- Add and initialize another component to Arguments table 308 309 declare 310 New_Arguments : Argument_Data; 311 pragma Warnings (Off, New_Arguments); 312 -- Declaring this defaulted initialized object ensures 313 -- that the new allocated component of table Arguments 314 -- is correctly initialized. 315 316 -- This is VERY ugly, Table should never be used with 317 -- data requiring default initialization. We should 318 -- find a way to avoid violating this rule ??? 319 320 begin 321 Arguments.Append (New_Arguments); 322 end; 323 324 Patterns.Init 325 (Arguments.Table (Arguments.Last).Directories); 326 Patterns.Set_Last 327 (Arguments.Table (Arguments.Last).Directories, 0); 328 Patterns.Init 329 (Arguments.Table (Arguments.Last).Name_Patterns); 330 Patterns.Set_Last 331 (Arguments.Table (Arguments.Last).Name_Patterns, 0); 332 Patterns.Init 333 (Arguments.Table (Arguments.Last).Excluded_Patterns); 334 Patterns.Set_Last 335 (Arguments.Table (Arguments.Last).Excluded_Patterns, 0); 336 Patterns.Init 337 (Arguments.Table (Arguments.Last).Foreign_Patterns); 338 Patterns.Set_Last 339 (Arguments.Table (Arguments.Last).Foreign_Patterns, 0); 340 341 -- Subdirectory switch 342 343 elsif Arg'Length > Subdirs_Switch'Length 344 and then Arg (1 .. Subdirs_Switch'Length) = Subdirs_Switch 345 then 346 Subdirs := 347 new String'(Arg (Subdirs_Switch'Length + 1 .. Arg'Last)); 348 349 -- --no-backup 350 351 elsif Arg = "--no-backup" then 352 Opt.No_Backup := True; 353 354 -- -c 355 356 elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-c" then 357 if File_Set then 358 Fail ("only one -P or -c switch may be specified"); 359 end if; 360 361 if Arg'Length = 2 then 362 Pragmas_File_Expected := True; 363 364 if Next_Arg = Argument_Count then 365 Fail ("configuration pragmas file name missing"); 366 end if; 367 368 else 369 File_Set := True; 370 File_Path := new String'(Arg (3 .. Arg'Last)); 371 Create_Project := False; 372 end if; 373 374 -- -d 375 376 elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-d" then 377 if Arg'Length = 2 then 378 Directory_Expected := True; 379 380 if Next_Arg = Argument_Count then 381 Fail ("directory name missing"); 382 end if; 383 384 else 385 Add_Source_Directory (Arg (3 .. Arg'Last)); 386 end if; 387 388 -- -D 389 390 elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-D" then 391 if Arg'Length = 2 then 392 Dir_File_Name_Expected := True; 393 394 if Next_Arg = Argument_Count then 395 Fail ("directory list file name missing"); 396 end if; 397 398 else 399 Get_Directories (Arg (3 .. Arg'Last)); 400 end if; 401 402 -- -eL 403 404 elsif Arg = "-eL" then 405 Opt.Follow_Links_For_Files := True; 406 Opt.Follow_Links_For_Dirs := True; 407 408 -- -f 409 410 elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-f" then 411 if Arg'Length = 2 then 412 Foreign_Pattern_Expected := True; 413 414 if Next_Arg = Argument_Count then 415 Fail ("foreign pattern missing"); 416 end if; 417 418 else 419 Patterns.Append 420 (Arguments.Table (Arguments.Last).Foreign_Patterns, 421 new String'(Arg (3 .. Arg'Last))); 422 Check_Regular_Expression (Arg (3 .. Arg'Last)); 423 end if; 424 425 -- -gnatep or -gnateD 426 427 elsif Arg'Length > 7 and then 428 (Arg (1 .. 7) = "-gnatep" or else Arg (1 .. 7) = "-gnateD") 429 then 430 Preprocessor_Switches.Append (new String'(Arg)); 431 432 -- -h 433 434 elsif Arg = "-h" then 435 Usage_Needed := True; 436 437 -- -P 438 439 elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-P" then 440 if File_Set then 441 Fail ("only one -c or -P switch may be specified"); 442 end if; 443 444 if Arg'Length = 2 then 445 if Next_Arg = Argument_Count then 446 Fail ("project file name missing"); 447 448 else 449 Project_File_Name_Expected := True; 450 end if; 451 452 else 453 File_Set := True; 454 File_Path := new String'(Arg (3 .. Arg'Last)); 455 end if; 456 457 Create_Project := True; 458 459 -- -v 460 461 elsif Arg = "-v" then 462 if Opt.Verbose_Mode then 463 Very_Verbose := True; 464 else 465 Opt.Verbose_Mode := True; 466 end if; 467 468 -- -x 469 470 elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-x" then 471 if Arg'Length = 2 then 472 Excluded_Pattern_Expected := True; 473 474 if Next_Arg = Argument_Count then 475 Fail ("excluded pattern missing"); 476 end if; 477 478 else 479 Patterns.Append 480 (Arguments.Table (Arguments.Last).Excluded_Patterns, 481 new String'(Arg (3 .. Arg'Last))); 482 Check_Regular_Expression (Arg (3 .. Arg'Last)); 483 end if; 484 485 -- Junk switch starting with minus 486 487 elsif Arg (1) = '-' then 488 Fail ("wrong switch: " & Arg); 489 490 -- Not a recognized switch, assume file name 491 492 else 493 Canonical_Case_File_Name (Arg); 494 Patterns.Append 495 (Arguments.Table (Arguments.Last).Name_Patterns, 496 new String'(Arg)); 497 Check_Regular_Expression (Arg); 498 end if; 499 end if; 500 end; 501 end loop; 502 end Scan_Args; 503 504 ----------- 505 -- Usage -- 506 ----------- 507 508 procedure Usage is 509 begin 510 if not Usage_Output then 511 Usage_Needed := False; 512 Usage_Output := True; 513 Write_Str ("Usage: "); 514 Osint.Write_Program_Name; 515 Write_Line (" [switches] naming-pattern [naming-patterns]"); 516 Write_Line (" {--and [switches] naming-pattern [naming-patterns]}"); 517 Write_Eol; 518 Write_Line ("switches:"); 519 520 Display_Usage_Version_And_Help; 521 522 Write_Line (" --subdirs=dir real obj/lib/exec dirs are subdirs"); 523 Write_Line (" --no-backup do not create backup of project file"); 524 Write_Eol; 525 526 Write_Line (" --and use different patterns"); 527 Write_Eol; 528 529 Write_Line (" -cfile create configuration pragmas file"); 530 Write_Line (" -ddir use dir as one of the source " & 531 "directories"); 532 Write_Line (" -Dfile get source directories from file"); 533 Write_Line (" -eL follow symbolic links when processing " & 534 "project files"); 535 Write_Line (" -fpat foreign pattern"); 536 Write_Line (" -gnateDsym=v preprocess with symbol definition"); 537 Write_Line (" -gnatep=data preprocess files with data file"); 538 Write_Line (" -h output this help message"); 539 Write_Line (" -Pproj update or create project file proj"); 540 Write_Line (" -v verbose output"); 541 Write_Line (" -v -v very verbose output"); 542 Write_Line (" -xpat exclude pattern pat"); 543 end if; 544 end Usage; 545 546-- Start of processing for Gnatname 547 548begin 549 -- Add the directory where gnatname is invoked in front of the 550 -- path, if gnatname is invoked with directory information. 551 552 declare 553 Command : constant String := Command_Name; 554 555 begin 556 for Index in reverse Command'Range loop 557 if Command (Index) = Directory_Separator then 558 declare 559 Absolute_Dir : constant String := 560 Normalize_Pathname 561 (Command (Command'First .. Index)); 562 563 PATH : constant String := 564 Absolute_Dir & 565 Path_Separator & 566 Getenv ("PATH").all; 567 568 begin 569 Setenv ("PATH", PATH); 570 end; 571 572 exit; 573 end if; 574 end loop; 575 end; 576 577 -- Initialize tables 578 579 Arguments.Set_Last (0); 580 declare 581 New_Arguments : Argument_Data; 582 pragma Warnings (Off, New_Arguments); 583 -- Declaring this defaulted initialized object ensures that the new 584 -- allocated component of table Arguments is correctly initialized. 585 begin 586 Arguments.Append (New_Arguments); 587 end; 588 589 Patterns.Init (Arguments.Table (1).Directories); 590 Patterns.Set_Last (Arguments.Table (1).Directories, 0); 591 Patterns.Init (Arguments.Table (1).Name_Patterns); 592 Patterns.Set_Last (Arguments.Table (1).Name_Patterns, 0); 593 Patterns.Init (Arguments.Table (1).Excluded_Patterns); 594 Patterns.Set_Last (Arguments.Table (1).Excluded_Patterns, 0); 595 Patterns.Init (Arguments.Table (1).Foreign_Patterns); 596 Patterns.Set_Last (Arguments.Table (1).Foreign_Patterns, 0); 597 598 Preprocessor_Switches.Set_Last (0); 599 600 -- Get the arguments 601 602 Scan_Args; 603 604 if Opt.Verbose_Mode then 605 Output_Version; 606 end if; 607 608 if Usage_Needed then 609 Usage; 610 end if; 611 612 if Create_Project then 613 declare 614 Gnatname : constant String_Access := 615 Program_Name ("gnatname", "gnatname"); 616 Arg_Len : Positive := Argument_Count; 617 Target : String_Access := null; 618 619 begin 620 -- Find the target, if any 621 622 if Gnatname.all /= "gnatname" then 623 Target := 624 new String'(Gnatname (Gnatname'First .. Gnatname'Last - 9)); 625 Arg_Len := Arg_Len + 1; 626 end if; 627 628 declare 629 Args : Argument_List (1 .. Arg_Len); 630 Gprname : String_Access := 631 Locate_Exec_On_Path (Exec_Name => "gprname"); 632 Success : Boolean; 633 634 begin 635 if Gprname /= null then 636 for J in 1 .. Argument_Count loop 637 Args (J) := new String'(Argument (J)); 638 end loop; 639 640 -- Add the target if there is one 641 642 if Target /= null then 643 Args (Args'Last) := new String'("--target=" & Target.all); 644 end if; 645 646 Spawn (Gprname.all, Args, Success); 647 648 Free (Gprname); 649 650 if Success then 651 Exit_Program (E_Success); 652 end if; 653 end if; 654 end; 655 end; 656 end if; 657 658 -- This only happens if gprname is not found or if the invocation of 659 -- gprname did not succeed. 660 661 if Create_Project then 662 Write_Line 663 ("warning: gnatname -P is obsolete and will not be available in the " 664 & "next release; use gprname instead"); 665 end if; 666 667 -- If no Ada or foreign pattern was specified, print the usage and return 668 669 if Patterns.Last (Arguments.Table (Arguments.Last).Name_Patterns) = 0 670 and then 671 Patterns.Last (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0 672 then 673 if Argument_Count = 0 then 674 Usage; 675 elsif not Usage_Output then 676 Try_Help; 677 end if; 678 679 return; 680 end if; 681 682 -- If no source directory was specified, use the current directory as the 683 -- unique directory. Note that if a file was specified with directory 684 -- information, the current directory is the directory of the specified 685 -- file. 686 687 if Patterns.Last (Arguments.Table (Arguments.Last).Directories) = 0 then 688 Patterns.Append 689 (Arguments.Table (Arguments.Last).Directories, new String'(".")); 690 end if; 691 692 -- Initialize 693 694 declare 695 Prep_Switches : Argument_List 696 (1 .. Integer (Preprocessor_Switches.Last)); 697 698 begin 699 for Index in Prep_Switches'Range loop 700 Prep_Switches (Index) := Preprocessor_Switches.Table (Index); 701 end loop; 702 703 Prj.Makr.Initialize 704 (File_Path => File_Path.all, 705 Project_File => Create_Project, 706 Preproc_Switches => Prep_Switches, 707 Very_Verbose => Very_Verbose, 708 Flags => Gnatmake_Flags); 709 end; 710 711 -- Process each section successively 712 713 for J in 1 .. Arguments.Last loop 714 declare 715 Directories : Argument_List 716 (1 .. Integer 717 (Patterns.Last (Arguments.Table (J).Directories))); 718 Name_Patterns : Prj.Makr.Regexp_List 719 (1 .. Integer 720 (Patterns.Last (Arguments.Table (J).Name_Patterns))); 721 Excl_Patterns : Prj.Makr.Regexp_List 722 (1 .. Integer 723 (Patterns.Last (Arguments.Table (J).Excluded_Patterns))); 724 Frgn_Patterns : Prj.Makr.Regexp_List 725 (1 .. Integer 726 (Patterns.Last (Arguments.Table (J).Foreign_Patterns))); 727 728 begin 729 -- Build the Directories and Patterns arguments 730 731 for Index in Directories'Range loop 732 Directories (Index) := 733 Arguments.Table (J).Directories.Table (Index); 734 end loop; 735 736 for Index in Name_Patterns'Range loop 737 Name_Patterns (Index) := 738 Compile 739 (Arguments.Table (J).Name_Patterns.Table (Index).all, 740 Glob => True); 741 end loop; 742 743 for Index in Excl_Patterns'Range loop 744 Excl_Patterns (Index) := 745 Compile 746 (Arguments.Table (J).Excluded_Patterns.Table (Index).all, 747 Glob => True); 748 end loop; 749 750 for Index in Frgn_Patterns'Range loop 751 Frgn_Patterns (Index) := 752 Compile 753 (Arguments.Table (J).Foreign_Patterns.Table (Index).all, 754 Glob => True); 755 end loop; 756 757 -- Call Prj.Makr.Process where the real work is done 758 759 Prj.Makr.Process 760 (Directories => Directories, 761 Name_Patterns => Name_Patterns, 762 Excluded_Patterns => Excl_Patterns, 763 Foreign_Patterns => Frgn_Patterns); 764 end; 765 end loop; 766 767 -- Finalize 768 769 Prj.Makr.Finalize; 770 771 if Opt.Verbose_Mode then 772 Write_Eol; 773 end if; 774end Gnatname; 775