1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G N A T C M D -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1996-2013, 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 GNAT.Directory_Operations; use GNAT.Directory_Operations; 27 28with Csets; 29with Hostparm; use Hostparm; 30with Makeutl; use Makeutl; 31with MLib.Tgt; use MLib.Tgt; 32with MLib.Utl; 33with MLib.Fil; 34with Namet; use Namet; 35with Opt; use Opt; 36with Osint; use Osint; 37with Output; use Output; 38with Prj; use Prj; 39with Prj.Env; 40with Prj.Ext; use Prj.Ext; 41with Prj.Pars; 42with Prj.Tree; use Prj.Tree; 43with Prj.Util; use Prj.Util; 44with Sdefault; 45with Sinput.P; 46with Snames; use Snames; 47with Table; 48with Targparm; 49with Tempdir; 50with Types; use Types; 51with VMS_Conv; use VMS_Conv; 52with VMS_Cmds; use VMS_Cmds; 53 54with Ada.Characters.Handling; use Ada.Characters.Handling; 55with Ada.Command_Line; use Ada.Command_Line; 56with Ada.Text_IO; use Ada.Text_IO; 57 58with GNAT.OS_Lib; use GNAT.OS_Lib; 59 60procedure GNATCmd is 61 Project_Node_Tree : Project_Node_Tree_Ref; 62 Root_Environment : Prj.Tree.Environment; 63 Project_File : String_Access; 64 Project : Prj.Project_Id; 65 Current_Verbosity : Prj.Verbosity := Prj.Default; 66 Tool_Package_Name : Name_Id := No_Name; 67 68 B_Start : String_Ptr := new String'("b~"); 69 -- Prefix of binder generated file, changed to b__ for VMS 70 71 Project_Tree : constant Project_Tree_Ref := 72 new Project_Tree_Data (Is_Root_Tree => True); 73 -- The project tree 74 75 Old_Project_File_Used : Boolean := False; 76 -- This flag indicates a switch -p (for gnatxref and gnatfind) for 77 -- an old fashioned project file. -p cannot be used in conjunction 78 -- with -P. 79 80 Temp_File_Name : Path_Name_Type := No_Path; 81 -- The name of the temporary text file to put a list of source/object 82 -- files to pass to a tool. 83 84 ASIS_Main : String_Access := null; 85 -- Main for commands Check, Metric and Pretty, when -U is used 86 87 package First_Switches is new Table.Table 88 (Table_Component_Type => String_Access, 89 Table_Index_Type => Integer, 90 Table_Low_Bound => 1, 91 Table_Initial => 20, 92 Table_Increment => 100, 93 Table_Name => "Gnatcmd.First_Switches"); 94 -- A table to keep the switches from the project file 95 96 package Carg_Switches is new Table.Table 97 (Table_Component_Type => String_Access, 98 Table_Index_Type => Integer, 99 Table_Low_Bound => 1, 100 Table_Initial => 20, 101 Table_Increment => 100, 102 Table_Name => "Gnatcmd.Carg_Switches"); 103 -- A table to keep the switches following -cargs for ASIS tools 104 105 package Rules_Switches is new Table.Table 106 (Table_Component_Type => String_Access, 107 Table_Index_Type => Integer, 108 Table_Low_Bound => 1, 109 Table_Initial => 20, 110 Table_Increment => 100, 111 Table_Name => "Gnatcmd.Rules_Switches"); 112 -- A table to keep the switches following -rules for gnatcheck 113 114 package Library_Paths is new Table.Table ( 115 Table_Component_Type => String_Access, 116 Table_Index_Type => Integer, 117 Table_Low_Bound => 1, 118 Table_Initial => 20, 119 Table_Increment => 100, 120 Table_Name => "Make.Library_Path"); 121 122 -- Packages of project files to pass to Prj.Pars.Parse, depending on the 123 -- tool. We allocate objects because we cannot declare aliased objects 124 -- as we are in a procedure, not a library level package. 125 126 subtype SA is String_Access; 127 128 Naming_String : constant SA := new String'("naming"); 129 Binder_String : constant SA := new String'("binder"); 130 Builder_String : constant SA := new String'("builder"); 131 Compiler_String : constant SA := new String'("compiler"); 132 Check_String : constant SA := new String'("check"); 133 Synchronize_String : constant SA := new String'("synchronize"); 134 Eliminate_String : constant SA := new String'("eliminate"); 135 Finder_String : constant SA := new String'("finder"); 136 Linker_String : constant SA := new String'("linker"); 137 Gnatls_String : constant SA := new String'("gnatls"); 138 Pretty_String : constant SA := new String'("pretty_printer"); 139 Stack_String : constant SA := new String'("stack"); 140 Gnatstub_String : constant SA := new String'("gnatstub"); 141 Metric_String : constant SA := new String'("metrics"); 142 Xref_String : constant SA := new String'("cross_reference"); 143 144 Packages_To_Check_By_Binder : constant String_List_Access := 145 new String_List'((Naming_String, Binder_String)); 146 147 Packages_To_Check_By_Check : constant String_List_Access := 148 new String_List' 149 ((Naming_String, Builder_String, Check_String, Compiler_String)); 150 151 Packages_To_Check_By_Sync : constant String_List_Access := 152 new String_List'((Naming_String, Synchronize_String, Compiler_String)); 153 154 Packages_To_Check_By_Eliminate : constant String_List_Access := 155 new String_List'((Naming_String, Eliminate_String, Compiler_String)); 156 157 Packages_To_Check_By_Finder : constant String_List_Access := 158 new String_List'((Naming_String, Finder_String)); 159 160 Packages_To_Check_By_Linker : constant String_List_Access := 161 new String_List'((Naming_String, Linker_String)); 162 163 Packages_To_Check_By_Gnatls : constant String_List_Access := 164 new String_List'((Naming_String, Gnatls_String)); 165 166 Packages_To_Check_By_Pretty : constant String_List_Access := 167 new String_List'((Naming_String, Pretty_String, Compiler_String)); 168 169 Packages_To_Check_By_Stack : constant String_List_Access := 170 new String_List'((Naming_String, Stack_String)); 171 172 Packages_To_Check_By_Gnatstub : constant String_List_Access := 173 new String_List'((Naming_String, Gnatstub_String, Compiler_String)); 174 175 Packages_To_Check_By_Metric : constant String_List_Access := 176 new String_List'((Naming_String, Metric_String, Compiler_String)); 177 178 Packages_To_Check_By_Xref : constant String_List_Access := 179 new String_List'((Naming_String, Xref_String)); 180 181 Packages_To_Check : String_List_Access := Prj.All_Packages; 182 183 ---------------------------------- 184 -- Declarations for GNATCMD use -- 185 ---------------------------------- 186 187 The_Command : Command_Type; 188 -- The command specified in the invocation of the GNAT driver 189 190 Command_Arg : Positive := 1; 191 -- The index of the command in the arguments of the GNAT driver 192 193 My_Exit_Status : Exit_Status := Success; 194 -- The exit status of the spawned tool. Used to set the correct VMS 195 -- exit status. 196 197 Current_Work_Dir : constant String := Get_Current_Dir; 198 -- The path of the working directory 199 200 All_Projects : Boolean := False; 201 -- Flag used for GNAT CHECK, GNAT PRETTY, GNAT METRIC, and GNAT STACK to 202 -- indicate that the underlying tool (gnatcheck, gnatpp or gnatmetric) 203 -- should be invoked for all sources of all projects. 204 205 Max_OpenVMS_Logical_Length : constant Integer := 255; 206 -- The maximum length of OpenVMS logicals 207 208 ----------------------- 209 -- Local Subprograms -- 210 ----------------------- 211 212 procedure Add_To_Carg_Switches (Switch : String_Access); 213 -- Add a switch to the Carg_Switches table. If it is the first one, put the 214 -- switch "-cargs" at the beginning of the table. 215 216 procedure Add_To_Rules_Switches (Switch : String_Access); 217 -- Add a switch to the Rules_Switches table. If it is the first one, put 218 -- the switch "-crules" at the beginning of the table. 219 220 procedure Check_Files; 221 -- For GNAT LIST, GNAT PRETTY, GNAT METRIC, and GNAT STACK, check if a 222 -- project file is specified, without any file arguments and without a 223 -- switch -files=. If it is the case, invoke the GNAT tool with the proper 224 -- list of files, derived from the sources of the project. 225 226 function Check_Project 227 (Project : Project_Id; 228 Root_Project : Project_Id) return Boolean; 229 -- Returns True if Project = Root_Project or if we want to consider all 230 -- sources of all projects. For GNAT METRIC, also returns True if Project 231 -- is extended by Root_Project. 232 233 procedure Check_Relative_Executable (Name : in out String_Access); 234 -- Check if an executable is specified as a relative path. If it is, and 235 -- the path contains directory information, fail. Otherwise, prepend the 236 -- exec directory. This procedure is only used for GNAT LINK when a project 237 -- file is specified. 238 239 function Configuration_Pragmas_File return Path_Name_Type; 240 -- Return an argument, if there is a configuration pragmas file to be 241 -- specified for Project, otherwise return No_Name. Used for gnatstub 242 -- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric 243 -- (GNAT METRIC). 244 245 procedure Delete_Temp_Config_Files; 246 -- Delete all temporary config files. The caller is responsible for 247 -- ensuring that Keep_Temporary_Files is False. 248 249 procedure Ensure_Absolute_Path 250 (Switch : in out String_Access; 251 Parent : String); 252 -- Test if Switch is a relative search path switch. If it is and it 253 -- includes directory information, prepend the path with Parent. This 254 -- subprogram is only called when using project files. 255 256 procedure Get_Closure; 257 -- Get the sources in the closure of the ASIS_Main and add them to the 258 -- list of arguments. 259 260 function Mapping_File return Path_Name_Type; 261 -- Create and return the path name of a mapping file. Used for gnatstub 262 -- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric 263 -- (GNAT METRIC). 264 265 procedure Non_VMS_Usage; 266 -- Display usage for platforms other than VMS 267 268 procedure Process_Link; 269 -- Process GNAT LINK, when there is a project file specified 270 271 procedure Set_Library_For 272 (Project : Project_Id; 273 Tree : Project_Tree_Ref; 274 Libraries_Present : in out Boolean); 275 -- If Project is a library project, add the correct -L and -l switches to 276 -- the linker invocation. 277 278 procedure Set_Libraries is new 279 For_Every_Project_Imported (Boolean, Set_Library_For); 280 -- Add the -L and -l switches to the linker for all the library projects 281 282 -------------------------- 283 -- Add_To_Carg_Switches -- 284 -------------------------- 285 286 procedure Add_To_Carg_Switches (Switch : String_Access) is 287 begin 288 -- If the Carg_Switches table is empty, put "-cargs" at the beginning 289 290 if Carg_Switches.Last = 0 then 291 Carg_Switches.Increment_Last; 292 Carg_Switches.Table (Carg_Switches.Last) := new String'("-cargs"); 293 end if; 294 295 Carg_Switches.Increment_Last; 296 Carg_Switches.Table (Carg_Switches.Last) := Switch; 297 end Add_To_Carg_Switches; 298 299 --------------------------- 300 -- Add_To_Rules_Switches -- 301 --------------------------- 302 303 procedure Add_To_Rules_Switches (Switch : String_Access) is 304 begin 305 -- If the Rules_Switches table is empty, put "-rules" at the beginning 306 307 if Rules_Switches.Last = 0 then 308 Rules_Switches.Increment_Last; 309 Rules_Switches.Table (Rules_Switches.Last) := new String'("-rules"); 310 end if; 311 312 Rules_Switches.Increment_Last; 313 Rules_Switches.Table (Rules_Switches.Last) := Switch; 314 end Add_To_Rules_Switches; 315 316 ----------------- 317 -- Check_Files -- 318 ----------------- 319 320 procedure Check_Files is 321 Add_Sources : Boolean := True; 322 Unit : Prj.Unit_Index; 323 Subunit : Boolean := False; 324 FD : File_Descriptor := Invalid_FD; 325 Status : Integer; 326 Success : Boolean; 327 328 procedure Add_To_Response_File 329 (File_Name : String; 330 Check_File : Boolean := True); 331 -- Include the file name passed as parameter in the response file for 332 -- the tool being called. If the response file can not be written then 333 -- the file name is passed in the parameter list of the tool. If the 334 -- Check_File parameter is True then the procedure verifies the 335 -- existence of the file before adding it to the response file. 336 337 -------------------------- 338 -- Add_To_Response_File -- 339 -------------------------- 340 341 procedure Add_To_Response_File 342 (File_Name : String; 343 Check_File : Boolean := True) 344 is 345 begin 346 Name_Len := 0; 347 348 Add_Str_To_Name_Buffer (File_Name); 349 350 if not Check_File or else 351 Is_Regular_File (Name_Buffer (1 .. Name_Len)) 352 then 353 if FD /= Invalid_FD then 354 Name_Len := Name_Len + 1; 355 Name_Buffer (Name_Len) := ASCII.LF; 356 357 Status := Write (FD, Name_Buffer (1)'Address, Name_Len); 358 359 if Status /= Name_Len then 360 Osint.Fail ("disk full"); 361 end if; 362 else 363 Last_Switches.Increment_Last; 364 Last_Switches.Table (Last_Switches.Last) := 365 new String'(File_Name); 366 end if; 367 end if; 368 end Add_To_Response_File; 369 370 -- Start of processing for Check_Files 371 372 begin 373 -- Check if there is at least one argument that is not a switch or if 374 -- there is a -files= switch. 375 376 for Index in 1 .. Last_Switches.Last loop 377 if Last_Switches.Table (Index).all'Length > 7 378 and then Last_Switches.Table (Index) (1 .. 7) = "-files=" 379 then 380 Add_Sources := False; 381 exit; 382 383 elsif Last_Switches.Table (Index) (1) /= '-' then 384 if Index = 1 385 or else 386 (The_Command = Check 387 and then Last_Switches.Table (Index - 1).all /= "-o") 388 or else 389 (The_Command = Pretty 390 and then Last_Switches.Table (Index - 1).all /= "-o" 391 and then Last_Switches.Table (Index - 1).all /= "-of") 392 or else 393 (The_Command = Metric 394 and then 395 Last_Switches.Table (Index - 1).all /= "-o" and then 396 Last_Switches.Table (Index - 1).all /= "-og" and then 397 Last_Switches.Table (Index - 1).all /= "-ox" and then 398 Last_Switches.Table (Index - 1).all /= "-d") 399 or else 400 (The_Command /= Check and then 401 The_Command /= Pretty and then 402 The_Command /= Metric) 403 then 404 Add_Sources := False; 405 exit; 406 end if; 407 end if; 408 end loop; 409 410 -- If all arguments are switches and there is no switch -files=, add 411 -- the path names of all the sources of the main project. 412 413 if Add_Sources then 414 415 -- For gnatcheck, gnatpp, and gnatmetric, create a temporary file 416 -- and put the list of sources in it. For gnatstack create a 417 -- temporary file with the list of .ci files. 418 419 if The_Command = Check or else 420 The_Command = Pretty or else 421 The_Command = Metric or else 422 The_Command = Stack 423 then 424 Tempdir.Create_Temp_File (FD, Temp_File_Name); 425 Last_Switches.Increment_Last; 426 Last_Switches.Table (Last_Switches.Last) := 427 new String'("-files=" & Get_Name_String (Temp_File_Name)); 428 end if; 429 430 declare 431 Proj : Project_List; 432 433 begin 434 -- Gnatstack needs to add the .ci file for the binder generated 435 -- files corresponding to all of the library projects and main 436 -- units belonging to the application. 437 438 if The_Command = Stack then 439 Proj := Project_Tree.Projects; 440 while Proj /= null loop 441 if Check_Project (Proj.Project, Project) then 442 declare 443 Main : String_List_Id; 444 445 begin 446 -- Include binder generated files for main programs 447 448 Main := Proj.Project.Mains; 449 while Main /= Nil_String loop 450 Add_To_Response_File 451 (Get_Name_String 452 (Proj.Project.Object_Directory.Name) & 453 B_Start.all & 454 MLib.Fil.Ext_To 455 (Get_Name_String 456 (Project_Tree.Shared.String_Elements.Table 457 (Main).Value), 458 "ci")); 459 460 -- When looking for the .ci file for a binder 461 -- generated file, look for both b~xxx and b__xxx 462 -- as gprbuild always uses b__ as the prefix of 463 -- such files. 464 465 if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) 466 and then B_Start.all /= "b__" 467 then 468 Add_To_Response_File 469 (Get_Name_String 470 (Proj.Project.Object_Directory.Name) & 471 "b__" & 472 MLib.Fil.Ext_To 473 (Get_Name_String 474 (Project_Tree.Shared 475 .String_Elements.Table (Main).Value), 476 "ci")); 477 end if; 478 479 Main := Project_Tree.Shared.String_Elements.Table 480 (Main).Next; 481 end loop; 482 483 if Proj.Project.Library then 484 485 -- Include the .ci file for the binder generated 486 -- files that contains the initialization and 487 -- finalization of the library. 488 489 Add_To_Response_File 490 (Get_Name_String 491 (Proj.Project.Object_Directory.Name) & 492 B_Start.all & 493 Get_Name_String (Proj.Project.Library_Name) & 494 ".ci"); 495 496 -- When looking for the .ci file for a binder 497 -- generated file, look for both b~xxx and b__xxx 498 -- as gprbuild always uses b__ as the prefix of 499 -- such files. 500 501 if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) 502 and then B_Start.all /= "b__" 503 then 504 Add_To_Response_File 505 (Get_Name_String 506 (Proj.Project.Object_Directory.Name) & 507 "b__" & 508 Get_Name_String (Proj.Project.Library_Name) & 509 ".ci"); 510 end if; 511 end if; 512 end; 513 end if; 514 515 Proj := Proj.Next; 516 end loop; 517 end if; 518 519 Unit := Units_Htable.Get_First (Project_Tree.Units_HT); 520 while Unit /= No_Unit_Index loop 521 522 -- For gnatls, we only need to put the library units, body or 523 -- spec, but not the subunits. 524 525 if The_Command = List then 526 if Unit.File_Names (Impl) /= null 527 and then not Unit.File_Names (Impl).Locally_Removed 528 then 529 -- There is a body, check if it is for this project 530 531 if All_Projects 532 or else Unit.File_Names (Impl).Project = Project 533 then 534 Subunit := False; 535 536 if Unit.File_Names (Spec) = null 537 or else Unit.File_Names (Spec).Locally_Removed 538 then 539 -- We have a body with no spec: we need to check if 540 -- this is a subunit, because gnatls will complain 541 -- about subunits. 542 543 declare 544 Src_Ind : constant Source_File_Index := 545 Sinput.P.Load_Project_File 546 (Get_Name_String 547 (Unit.File_Names 548 (Impl).Path.Name)); 549 begin 550 Subunit := 551 Sinput.P.Source_File_Is_Subunit (Src_Ind); 552 end; 553 end if; 554 555 if not Subunit then 556 Last_Switches.Increment_Last; 557 Last_Switches.Table (Last_Switches.Last) := 558 new String' 559 (Get_Name_String 560 (Unit.File_Names 561 (Impl).Display_File)); 562 end if; 563 end if; 564 565 elsif Unit.File_Names (Spec) /= null 566 and then not Unit.File_Names (Spec).Locally_Removed 567 then 568 -- We have a spec with no body. Check if it is for this 569 -- project. 570 571 if All_Projects or else 572 Unit.File_Names (Spec).Project = Project 573 then 574 Last_Switches.Increment_Last; 575 Last_Switches.Table (Last_Switches.Last) := 576 new String'(Get_Name_String 577 (Unit.File_Names (Spec).Display_File)); 578 end if; 579 end if; 580 581 -- For gnatstack, we put the .ci files corresponding to the 582 -- different units, including the binder generated files. We 583 -- only need to do that for the library units, body or spec, 584 -- but not the subunits. 585 586 elsif The_Command = Stack then 587 if Unit.File_Names (Impl) /= null 588 and then not Unit.File_Names (Impl).Locally_Removed 589 then 590 -- There is a body. Check if .ci files for this project 591 -- must be added. 592 593 if Check_Project 594 (Unit.File_Names (Impl).Project, Project) 595 then 596 Subunit := False; 597 598 if Unit.File_Names (Spec) = null 599 or else Unit.File_Names (Spec).Locally_Removed 600 then 601 -- We have a body with no spec: we need to check 602 -- if this is a subunit, because .ci files are not 603 -- generated for subunits. 604 605 declare 606 Src_Ind : constant Source_File_Index := 607 Sinput.P.Load_Project_File 608 (Get_Name_String 609 (Unit.File_Names 610 (Impl).Path.Name)); 611 begin 612 Subunit := 613 Sinput.P.Source_File_Is_Subunit (Src_Ind); 614 end; 615 end if; 616 617 if not Subunit then 618 Add_To_Response_File 619 (Get_Name_String 620 (Unit.File_Names 621 (Impl).Project. Object_Directory.Name) & 622 MLib.Fil.Ext_To 623 (Get_Name_String 624 (Unit.File_Names (Impl).Display_File), 625 "ci")); 626 end if; 627 end if; 628 629 elsif Unit.File_Names (Spec) /= null 630 and then not Unit.File_Names (Spec).Locally_Removed 631 then 632 -- Spec with no body, check if it is for this project 633 634 if Check_Project 635 (Unit.File_Names (Spec).Project, Project) 636 then 637 Add_To_Response_File 638 (Get_Name_String 639 (Unit.File_Names 640 (Spec).Project. Object_Directory.Name) & 641 Dir_Separator & 642 MLib.Fil.Ext_To 643 (Get_Name_String (Unit.File_Names (Spec).File), 644 "ci")); 645 end if; 646 end if; 647 648 else 649 -- For gnatcheck, gnatsync, gnatpp and gnatmetric, put all 650 -- sources of the project, or of all projects if -U was 651 -- specified. 652 653 for Kind in Spec_Or_Body loop 654 if Unit.File_Names (Kind) /= null 655 and then Check_Project 656 (Unit.File_Names (Kind).Project, Project) 657 and then not Unit.File_Names (Kind).Locally_Removed 658 then 659 Add_To_Response_File 660 ("""" & 661 Get_Name_String 662 (Unit.File_Names (Kind).Path.Display_Name) & 663 """", 664 Check_File => False); 665 end if; 666 end loop; 667 end if; 668 669 Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); 670 end loop; 671 end; 672 673 if FD /= Invalid_FD then 674 Close (FD, Success); 675 676 if not Success then 677 Osint.Fail ("disk full"); 678 end if; 679 end if; 680 end if; 681 end Check_Files; 682 683 ------------------- 684 -- Check_Project -- 685 ------------------- 686 687 function Check_Project 688 (Project : Project_Id; 689 Root_Project : Project_Id) return Boolean 690 is 691 Proj : Project_Id; 692 693 begin 694 if Project = No_Project then 695 return False; 696 697 elsif All_Projects or else Project = Root_Project then 698 return True; 699 700 elsif The_Command = Metric then 701 Proj := Root_Project; 702 while Proj.Extends /= No_Project loop 703 if Project = Proj.Extends then 704 return True; 705 end if; 706 707 Proj := Proj.Extends; 708 end loop; 709 end if; 710 711 return False; 712 end Check_Project; 713 714 ------------------------------- 715 -- Check_Relative_Executable -- 716 ------------------------------- 717 718 procedure Check_Relative_Executable (Name : in out String_Access) is 719 Exec_File_Name : constant String := Name.all; 720 721 begin 722 if not Is_Absolute_Path (Exec_File_Name) then 723 for Index in Exec_File_Name'Range loop 724 if Exec_File_Name (Index) = Directory_Separator then 725 Fail ("relative executable (""" & 726 Exec_File_Name & 727 """) with directory part not allowed " & 728 "when using project files"); 729 end if; 730 end loop; 731 732 Get_Name_String (Project.Exec_Directory.Name); 733 734 if Name_Buffer (Name_Len) /= Directory_Separator then 735 Name_Len := Name_Len + 1; 736 Name_Buffer (Name_Len) := Directory_Separator; 737 end if; 738 739 Name_Buffer (Name_Len + 1 .. 740 Name_Len + Exec_File_Name'Length) := 741 Exec_File_Name; 742 Name_Len := Name_Len + Exec_File_Name'Length; 743 Name := new String'(Name_Buffer (1 .. Name_Len)); 744 end if; 745 end Check_Relative_Executable; 746 747 -------------------------------- 748 -- Configuration_Pragmas_File -- 749 -------------------------------- 750 751 function Configuration_Pragmas_File return Path_Name_Type is 752 begin 753 Prj.Env.Create_Config_Pragmas_File (Project, Project_Tree); 754 return Project.Config_File_Name; 755 end Configuration_Pragmas_File; 756 757 ------------------------------ 758 -- Delete_Temp_Config_Files -- 759 ------------------------------ 760 761 procedure Delete_Temp_Config_Files is 762 Success : Boolean; 763 Proj : Project_List; 764 pragma Warnings (Off, Success); 765 766 begin 767 -- This should only be called if Keep_Temporary_Files is False 768 769 pragma Assert (not Keep_Temporary_Files); 770 771 if Project /= No_Project then 772 Proj := Project_Tree.Projects; 773 while Proj /= null loop 774 if Proj.Project.Config_File_Temp then 775 Delete_Temporary_File 776 (Project_Tree.Shared, Proj.Project.Config_File_Name); 777 end if; 778 779 Proj := Proj.Next; 780 end loop; 781 end if; 782 783 -- If a temporary text file that contains a list of files for a tool 784 -- has been created, delete this temporary file. 785 786 if Temp_File_Name /= No_Path then 787 Delete_Temporary_File (Project_Tree.Shared, Temp_File_Name); 788 end if; 789 end Delete_Temp_Config_Files; 790 791 --------------------------- 792 -- Ensure_Absolute_Path -- 793 --------------------------- 794 795 procedure Ensure_Absolute_Path 796 (Switch : in out String_Access; 797 Parent : String) 798 is 799 begin 800 Makeutl.Ensure_Absolute_Path 801 (Switch, Parent, 802 Do_Fail => Osint.Fail'Access, 803 Including_Non_Switch => False, 804 Including_RTS => True); 805 end Ensure_Absolute_Path; 806 807 ----------------- 808 -- Get_Closure -- 809 ----------------- 810 811 procedure Get_Closure is 812 Args : constant Argument_List := 813 (1 => new String'("-q"), 814 2 => new String'("-b"), 815 3 => new String'("-P"), 816 4 => Project_File, 817 5 => ASIS_Main, 818 6 => new String'("-bargs"), 819 7 => new String'("-R"), 820 8 => new String'("-Z")); 821 -- Arguments for the invocation of gnatmake which are added to the 822 -- Last_Arguments list by this procedure. 823 824 FD : File_Descriptor; 825 -- File descriptor for the temp file that will get the output of the 826 -- invocation of gnatmake. 827 828 Name : Path_Name_Type; 829 -- Path of the file FD 830 831 GN_Name : constant String := Program_Name ("gnatmake", "gnat").all; 832 -- Name for gnatmake 833 834 GN_Path : constant String_Access := Locate_Exec_On_Path (GN_Name); 835 -- Path of gnatmake 836 837 Return_Code : Integer; 838 839 Unused : Boolean; 840 pragma Warnings (Off, Unused); 841 842 File : Ada.Text_IO.File_Type; 843 Line : String (1 .. 250); 844 Last : Natural; 845 -- Used to read file if there is an error, it is good enough to display 846 -- just 250 characters if the first line of the file is very long. 847 848 Unit : Unit_Index; 849 Path : Path_Name_Type; 850 851 Files_File : Ada.Text_IO.File_Type; 852 Temp_File_Name : Path_Name_Type; 853 854 begin 855 if GN_Path = null then 856 Put_Line (Standard_Error, "could not locate " & GN_Name); 857 raise Error_Exit; 858 end if; 859 860 -- Create the temp file 861 862 Prj.Env.Create_Temp_File (Project_Tree.Shared, FD, Name, "files"); 863 864 -- And close it, because on VMS Spawn with a file descriptor created 865 -- with Create_Temp_File does not redirect output. 866 867 Close (FD); 868 869 -- Spawn "gnatmake -q -b -P <project> <main> -bargs -R -Z" 870 871 Spawn 872 (Program_Name => GN_Path.all, 873 Args => Args, 874 Output_File => Get_Name_String (Name), 875 Success => Unused, 876 Return_Code => Return_Code, 877 Err_To_Out => True); 878 879 -- Read the output of the invocation of gnatmake 880 881 Open (File, In_File, Get_Name_String (Name)); 882 883 -- If it was unsuccessful, display the first line in the file and exit 884 -- with error. 885 886 if Return_Code /= 0 then 887 Get_Line (File, Line, Last); 888 889 begin 890 if not Keep_Temporary_Files then 891 Delete (File); 892 else 893 Close (File); 894 end if; 895 896 -- Don't crash if it is not possible to delete or close the file, 897 -- just ignore the situation. 898 899 exception 900 when others => 901 null; 902 end; 903 904 Put_Line (Standard_Error, Line (1 .. Last)); 905 Put_Line 906 (Standard_Error, "could not get closure of " & ASIS_Main.all); 907 raise Error_Exit; 908 909 else 910 -- Create a temporary file to put the list of files in the closure 911 912 Tempdir.Create_Temp_File (FD, Temp_File_Name); 913 Last_Switches.Increment_Last; 914 Last_Switches.Table (Last_Switches.Last) := 915 new String'("-files=" & Get_Name_String (Temp_File_Name)); 916 917 Close (FD); 918 919 Open (Files_File, Out_File, Get_Name_String (Temp_File_Name)); 920 921 -- Get each file name in the file, find its path and add it the list 922 -- of arguments. 923 924 while not End_Of_File (File) loop 925 Get_Line (File, Line, Last); 926 Path := No_Path; 927 928 Unit := Units_Htable.Get_First (Project_Tree.Units_HT); 929 while Unit /= No_Unit_Index loop 930 if Unit.File_Names (Spec) /= null 931 and then 932 Get_Name_String (Unit.File_Names (Spec).File) = 933 Line (1 .. Last) 934 then 935 Path := Unit.File_Names (Spec).Path.Name; 936 exit; 937 938 elsif Unit.File_Names (Impl) /= null 939 and then 940 Get_Name_String (Unit.File_Names (Impl).File) = 941 Line (1 .. Last) 942 then 943 Path := Unit.File_Names (Impl).Path.Name; 944 exit; 945 end if; 946 947 Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); 948 end loop; 949 950 if Path /= No_Path then 951 Put_Line (Files_File, Get_Name_String (Path)); 952 953 else 954 Put_Line (Files_File, Line (1 .. Last)); 955 end if; 956 end loop; 957 958 Close (Files_File); 959 960 begin 961 if not Keep_Temporary_Files then 962 Delete (File); 963 else 964 Close (File); 965 end if; 966 967 -- Don't crash if it is not possible to delete or close the file, 968 -- just ignore the situation. 969 970 exception 971 when others => 972 null; 973 end; 974 end if; 975 end Get_Closure; 976 977 ------------------ 978 -- Mapping_File -- 979 ------------------ 980 981 function Mapping_File return Path_Name_Type is 982 Result : Path_Name_Type; 983 begin 984 Prj.Env.Create_Mapping_File 985 (Project => Project, 986 Language => Name_Ada, 987 In_Tree => Project_Tree, 988 Name => Result); 989 return Result; 990 end Mapping_File; 991 992 ------------------- 993 -- Non_VMS_Usage -- 994 ------------------- 995 996 procedure Non_VMS_Usage is 997 begin 998 Output_Version; 999 New_Line; 1000 Put_Line ("List of available commands"); 1001 New_Line; 1002 1003 for C in Command_List'Range loop 1004 1005 -- No usage for VMS only command or for Sync 1006 1007 if not Command_List (C).VMS_Only and then C /= Sync then 1008 if Targparm.AAMP_On_Target then 1009 Put ("gnaampcmd "); 1010 else 1011 Put ("gnat "); 1012 end if; 1013 1014 Put (To_Lower (Command_List (C).Cname.all)); 1015 Set_Col (25); 1016 1017 -- Never call gnatstack with a prefix 1018 1019 if C = Stack then 1020 Put (Command_List (C).Unixcmd.all); 1021 else 1022 Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all); 1023 end if; 1024 1025 declare 1026 Sws : Argument_List_Access renames Command_List (C).Unixsws; 1027 begin 1028 if Sws /= null then 1029 for J in Sws'Range loop 1030 Put (' '); 1031 Put (Sws (J).all); 1032 end loop; 1033 end if; 1034 end; 1035 1036 New_Line; 1037 end if; 1038 end loop; 1039 1040 New_Line; 1041 Put_Line ("All commands except chop, krunch and preprocess " & 1042 "accept project file switches -vPx, -Pprj and -Xnam=val"); 1043 New_Line; 1044 end Non_VMS_Usage; 1045 ------------------ 1046 -- Process_Link -- 1047 ------------------ 1048 1049 procedure Process_Link is 1050 Look_For_Executable : Boolean := True; 1051 Libraries_Present : Boolean := False; 1052 Path_Option : constant String_Access := 1053 MLib.Linker_Library_Path_Option; 1054 Prj : Project_Id := Project; 1055 Arg : String_Access; 1056 Last : Natural := 0; 1057 Skip_Executable : Boolean := False; 1058 1059 begin 1060 -- Add the default search directories, to be able to find 1061 -- libgnat in call to MLib.Utl.Lib_Directory. 1062 1063 Add_Default_Search_Dirs; 1064 1065 Library_Paths.Set_Last (0); 1066 1067 -- Check if there are library project files 1068 1069 if MLib.Tgt.Support_For_Libraries /= None then 1070 Set_Libraries (Project, Project_Tree, Libraries_Present); 1071 end if; 1072 1073 -- If there are, add the necessary additional switches 1074 1075 if Libraries_Present then 1076 1077 -- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir> 1078 1079 Last_Switches.Increment_Last; 1080 Last_Switches.Table (Last_Switches.Last) := 1081 new String'("-L" & MLib.Utl.Lib_Directory); 1082 Last_Switches.Increment_Last; 1083 Last_Switches.Table (Last_Switches.Last) := 1084 new String'("-lgnarl"); 1085 Last_Switches.Increment_Last; 1086 Last_Switches.Table (Last_Switches.Last) := 1087 new String'("-lgnat"); 1088 1089 -- If Path_Option is not null, create the switch ("-Wl,-rpath," or 1090 -- equivalent) with all the library dirs plus the standard GNAT 1091 -- library dir. 1092 1093 if Path_Option /= null then 1094 declare 1095 Option : String_Access; 1096 Length : Natural := Path_Option'Length; 1097 Current : Natural; 1098 1099 begin 1100 if MLib.Separate_Run_Path_Options then 1101 1102 -- We are going to create one switch of the form 1103 -- "-Wl,-rpath,dir_N" for each directory to consider. 1104 1105 -- One switch for each library directory 1106 1107 for Index in 1108 Library_Paths.First .. Library_Paths.Last 1109 loop 1110 Last_Switches.Increment_Last; 1111 Last_Switches.Table 1112 (Last_Switches.Last) := new String' 1113 (Path_Option.all & 1114 Last_Switches.Table (Index).all); 1115 end loop; 1116 1117 -- One switch for the standard GNAT library dir 1118 1119 Last_Switches.Increment_Last; 1120 Last_Switches.Table 1121 (Last_Switches.Last) := new String' 1122 (Path_Option.all & MLib.Utl.Lib_Directory); 1123 1124 else 1125 -- First, compute the exact length for the switch 1126 1127 for Index in 1128 Library_Paths.First .. Library_Paths.Last 1129 loop 1130 -- Add the length of the library dir plus one for the 1131 -- directory separator. 1132 1133 Length := 1134 Length + 1135 Library_Paths.Table (Index)'Length + 1; 1136 end loop; 1137 1138 -- Finally, add the length of the standard GNAT library dir 1139 1140 Length := Length + MLib.Utl.Lib_Directory'Length; 1141 Option := new String (1 .. Length); 1142 Option (1 .. Path_Option'Length) := Path_Option.all; 1143 Current := Path_Option'Length; 1144 1145 -- Put each library dir followed by a dir separator 1146 1147 for Index in 1148 Library_Paths.First .. Library_Paths.Last 1149 loop 1150 Option 1151 (Current + 1 .. 1152 Current + 1153 Library_Paths.Table (Index)'Length) := 1154 Library_Paths.Table (Index).all; 1155 Current := 1156 Current + 1157 Library_Paths.Table (Index)'Length + 1; 1158 Option (Current) := Path_Separator; 1159 end loop; 1160 1161 -- Finally put the standard GNAT library dir 1162 1163 Option 1164 (Current + 1 .. 1165 Current + MLib.Utl.Lib_Directory'Length) := 1166 MLib.Utl.Lib_Directory; 1167 1168 -- And add the switch to the last switches 1169 1170 Last_Switches.Increment_Last; 1171 Last_Switches.Table (Last_Switches.Last) := 1172 Option; 1173 end if; 1174 end; 1175 end if; 1176 end if; 1177 1178 -- Check if the first ALI file specified can be found, either in the 1179 -- object directory of the main project or in an object directory of a 1180 -- project file extended by the main project. If the ALI file can be 1181 -- found, replace its name with its absolute path. 1182 1183 Skip_Executable := False; 1184 1185 Switch_Loop : for J in 1 .. Last_Switches.Last loop 1186 1187 -- If we have an executable just reset the flag 1188 1189 if Skip_Executable then 1190 Skip_Executable := False; 1191 1192 -- If -o, set flag so that next switch is not processed 1193 1194 elsif Last_Switches.Table (J).all = "-o" then 1195 Skip_Executable := True; 1196 1197 -- Normal case 1198 1199 else 1200 declare 1201 Switch : constant String := 1202 Last_Switches.Table (J).all; 1203 ALI_File : constant String (1 .. Switch'Length + 4) := 1204 Switch & ".ali"; 1205 1206 Test_Existence : Boolean := False; 1207 1208 begin 1209 Last := Switch'Length; 1210 1211 -- Skip real switches 1212 1213 if Switch'Length /= 0 1214 and then Switch (Switch'First) /= '-' 1215 then 1216 -- Append ".ali" if file name does not end with it 1217 1218 if Switch'Length <= 4 1219 or else Switch (Switch'Last - 3 .. Switch'Last) /= ".ali" 1220 then 1221 Last := ALI_File'Last; 1222 end if; 1223 1224 -- If file name includes directory information, stop if ALI 1225 -- file exists. 1226 1227 if Is_Absolute_Path (ALI_File (1 .. Last)) then 1228 Test_Existence := True; 1229 1230 else 1231 for K in Switch'Range loop 1232 if Switch (K) = '/' 1233 or else Switch (K) = Directory_Separator 1234 then 1235 Test_Existence := True; 1236 exit; 1237 end if; 1238 end loop; 1239 end if; 1240 1241 if Test_Existence then 1242 if Is_Regular_File (ALI_File (1 .. Last)) then 1243 exit Switch_Loop; 1244 end if; 1245 1246 -- Look in object directories if ALI file exists 1247 1248 else 1249 Project_Loop : loop 1250 declare 1251 Dir : constant String := 1252 Get_Name_String (Prj.Object_Directory.Name); 1253 begin 1254 if Is_Regular_File 1255 (Dir & 1256 ALI_File (1 .. Last)) 1257 then 1258 -- We have found the correct project, so we 1259 -- replace the file with the absolute path. 1260 1261 Last_Switches.Table (J) := 1262 new String'(Dir & ALI_File (1 .. Last)); 1263 1264 -- And we are done 1265 1266 exit Switch_Loop; 1267 end if; 1268 end; 1269 1270 -- Go to the project being extended, if any 1271 1272 Prj := Prj.Extends; 1273 exit Project_Loop when Prj = No_Project; 1274 end loop Project_Loop; 1275 end if; 1276 end if; 1277 end; 1278 end if; 1279 end loop Switch_Loop; 1280 1281 -- If a relative path output file has been specified, we add the exec 1282 -- directory. 1283 1284 for J in reverse 1 .. Last_Switches.Last - 1 loop 1285 if Last_Switches.Table (J).all = "-o" then 1286 Check_Relative_Executable 1287 (Name => Last_Switches.Table (J + 1)); 1288 Look_For_Executable := False; 1289 exit; 1290 end if; 1291 end loop; 1292 1293 if Look_For_Executable then 1294 for J in reverse 1 .. First_Switches.Last - 1 loop 1295 if First_Switches.Table (J).all = "-o" then 1296 Look_For_Executable := False; 1297 Check_Relative_Executable 1298 (Name => First_Switches.Table (J + 1)); 1299 exit; 1300 end if; 1301 end loop; 1302 end if; 1303 1304 -- If no executable is specified, then find the name of the first ALI 1305 -- file on the command line and issue a -o switch with the absolute path 1306 -- of the executable in the exec directory. 1307 1308 if Look_For_Executable then 1309 for J in 1 .. Last_Switches.Last loop 1310 Arg := Last_Switches.Table (J); 1311 Last := 0; 1312 1313 if Arg'Length /= 0 and then Arg (Arg'First) /= '-' then 1314 if Arg'Length > 4 1315 and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali" 1316 then 1317 Last := Arg'Last - 4; 1318 1319 elsif Is_Regular_File (Arg.all & ".ali") then 1320 Last := Arg'Last; 1321 end if; 1322 1323 if Last /= 0 then 1324 Last_Switches.Increment_Last; 1325 Last_Switches.Table (Last_Switches.Last) := 1326 new String'("-o"); 1327 Get_Name_String (Project.Exec_Directory.Name); 1328 Last_Switches.Increment_Last; 1329 Last_Switches.Table (Last_Switches.Last) := 1330 new String'(Name_Buffer (1 .. Name_Len) & 1331 Executable_Name 1332 (Base_Name (Arg (Arg'First .. Last)))); 1333 exit; 1334 end if; 1335 end if; 1336 end loop; 1337 end if; 1338 end Process_Link; 1339 1340 --------------------- 1341 -- Set_Library_For -- 1342 --------------------- 1343 1344 procedure Set_Library_For 1345 (Project : Project_Id; 1346 Tree : Project_Tree_Ref; 1347 Libraries_Present : in out Boolean) 1348 is 1349 pragma Unreferenced (Tree); 1350 1351 Path_Option : constant String_Access := 1352 MLib.Linker_Library_Path_Option; 1353 1354 begin 1355 -- Case of library project 1356 1357 if Project.Library then 1358 Libraries_Present := True; 1359 1360 -- Add the -L switch 1361 1362 Last_Switches.Increment_Last; 1363 Last_Switches.Table (Last_Switches.Last) := 1364 new String'("-L" & Get_Name_String (Project.Library_Dir.Name)); 1365 1366 -- Add the -l switch 1367 1368 Last_Switches.Increment_Last; 1369 Last_Switches.Table (Last_Switches.Last) := 1370 new String'("-l" & Get_Name_String (Project.Library_Name)); 1371 1372 -- Add the directory to table Library_Paths, to be processed later 1373 -- if library is not static and if Path_Option is not null. 1374 1375 if Project.Library_Kind /= Static 1376 and then Path_Option /= null 1377 then 1378 Library_Paths.Increment_Last; 1379 Library_Paths.Table (Library_Paths.Last) := 1380 new String'(Get_Name_String (Project.Library_Dir.Name)); 1381 end if; 1382 end if; 1383 end Set_Library_For; 1384 1385-- Start of processing for GNATCmd 1386 1387begin 1388 -- All output from GNATCmd is debugging or error output: send to stderr 1389 1390 Set_Standard_Error; 1391 1392 -- Initializations 1393 1394 Csets.Initialize; 1395 Snames.Initialize; 1396 1397 Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags); 1398 Prj.Env.Initialize_Default_Project_Path 1399 (Root_Environment.Project_Path, 1400 Target_Name => Sdefault.Target_Name.all); 1401 1402 Project_Node_Tree := new Project_Node_Tree_Data; 1403 Prj.Tree.Initialize (Project_Node_Tree); 1404 1405 Prj.Initialize (Project_Tree); 1406 1407 Last_Switches.Init; 1408 Last_Switches.Set_Last (0); 1409 1410 First_Switches.Init; 1411 First_Switches.Set_Last (0); 1412 Carg_Switches.Init; 1413 Carg_Switches.Set_Last (0); 1414 Rules_Switches.Init; 1415 Rules_Switches.Set_Last (0); 1416 1417 VMS_Conv.Initialize; 1418 1419 -- Add the default search directories, to be able to find system.ads in the 1420 -- subsequent call to Targparm.Get_Target_Parameters. 1421 1422 Add_Default_Search_Dirs; 1423 1424 -- Get target parameters so that AAMP_On_Target will be set, for testing in 1425 -- Osint.Program_Name to handle the mapping of GNAAMP tool names. 1426 1427 Targparm.Get_Target_Parameters; 1428 1429 -- Put the command line in environment variable GNAT_DRIVER_COMMAND_LINE, 1430 -- so that the spawned tool may know the way the GNAT driver was invoked. 1431 1432 Name_Len := 0; 1433 Add_Str_To_Name_Buffer (Command_Name); 1434 1435 for J in 1 .. Argument_Count loop 1436 Add_Char_To_Name_Buffer (' '); 1437 Add_Str_To_Name_Buffer (Argument (J)); 1438 end loop; 1439 1440 -- On OpenVMS, setenv creates a logical whose length is limited to 1441 -- 255 bytes. 1442 1443 if OpenVMS and then Name_Len > Max_OpenVMS_Logical_Length then 1444 Name_Buffer (Max_OpenVMS_Logical_Length - 2 1445 .. Max_OpenVMS_Logical_Length) := "..."; 1446 Name_Len := Max_OpenVMS_Logical_Length; 1447 end if; 1448 1449 Setenv ("GNAT_DRIVER_COMMAND_LINE", Name_Buffer (1 .. Name_Len)); 1450 1451 -- Add the directory where the GNAT driver is invoked in front of the path, 1452 -- if the GNAT driver is invoked with directory information. Do not do this 1453 -- for VMS, where the notion of path does not really exist. 1454 1455 if not OpenVMS then 1456 declare 1457 Command : constant String := Command_Name; 1458 1459 begin 1460 for Index in reverse Command'Range loop 1461 if Command (Index) = Directory_Separator then 1462 declare 1463 Absolute_Dir : constant String := 1464 Normalize_Pathname 1465 (Command (Command'First .. Index)); 1466 1467 PATH : constant String := 1468 Absolute_Dir & Path_Separator & Getenv ("PATH").all; 1469 1470 begin 1471 Setenv ("PATH", PATH); 1472 end; 1473 1474 exit; 1475 end if; 1476 end loop; 1477 end; 1478 end if; 1479 1480 -- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers, 1481 -- filenames and pathnames to Unix style. 1482 1483 if Hostparm.OpenVMS 1484 or else To_Lower (Getenv ("EMULATE_VMS").all) = "true" 1485 then 1486 VMS_Conversion (The_Command); 1487 1488 B_Start := new String'("b__"); 1489 1490 -- If not on VMS, scan the command line directly 1491 1492 else 1493 if Argument_Count = 0 then 1494 Non_VMS_Usage; 1495 return; 1496 else 1497 begin 1498 loop 1499 if Argument_Count > Command_Arg 1500 and then Argument (Command_Arg) = "-v" 1501 then 1502 Verbose_Mode := True; 1503 Command_Arg := Command_Arg + 1; 1504 1505 elsif Argument_Count > Command_Arg 1506 and then Argument (Command_Arg) = "-dn" 1507 then 1508 Keep_Temporary_Files := True; 1509 Command_Arg := Command_Arg + 1; 1510 1511 else 1512 exit; 1513 end if; 1514 end loop; 1515 1516 The_Command := Real_Command_Type'Value (Argument (Command_Arg)); 1517 1518 if Command_List (The_Command).VMS_Only then 1519 Non_VMS_Usage; 1520 Fail 1521 ("Command """ 1522 & Command_List (The_Command).Cname.all 1523 & """ can only be used on VMS"); 1524 end if; 1525 1526 exception 1527 when Constraint_Error => 1528 1529 -- Check if it is an alternate command 1530 1531 declare 1532 Alternate : Alternate_Command; 1533 1534 begin 1535 Alternate := Alternate_Command'Value 1536 (Argument (Command_Arg)); 1537 The_Command := Corresponding_To (Alternate); 1538 1539 exception 1540 when Constraint_Error => 1541 Non_VMS_Usage; 1542 Fail ("Unknown command: " & Argument (Command_Arg)); 1543 end; 1544 end; 1545 1546 -- Get the arguments from the command line and from the eventual 1547 -- argument file(s) specified on the command line. 1548 1549 for Arg in Command_Arg + 1 .. Argument_Count loop 1550 declare 1551 The_Arg : constant String := Argument (Arg); 1552 1553 begin 1554 -- Check if an argument file is specified 1555 1556 if The_Arg (The_Arg'First) = '@' then 1557 declare 1558 Arg_File : Ada.Text_IO.File_Type; 1559 Line : String (1 .. 256); 1560 Last : Natural; 1561 1562 begin 1563 -- Open the file and fail if the file cannot be found 1564 1565 begin 1566 Open 1567 (Arg_File, In_File, 1568 The_Arg (The_Arg'First + 1 .. The_Arg'Last)); 1569 1570 exception 1571 when others => 1572 Put 1573 (Standard_Error, "Cannot open argument file """); 1574 Put 1575 (Standard_Error, 1576 The_Arg (The_Arg'First + 1 .. The_Arg'Last)); 1577 1578 Put_Line (Standard_Error, """"); 1579 raise Error_Exit; 1580 end; 1581 1582 -- Read line by line and put the content of each non- 1583 -- empty line in the Last_Switches table. 1584 1585 while not End_Of_File (Arg_File) loop 1586 Get_Line (Arg_File, Line, Last); 1587 1588 if Last /= 0 then 1589 Last_Switches.Increment_Last; 1590 Last_Switches.Table (Last_Switches.Last) := 1591 new String'(Line (1 .. Last)); 1592 end if; 1593 end loop; 1594 1595 Close (Arg_File); 1596 end; 1597 1598 else 1599 -- It is not an argument file; just put the argument in 1600 -- the Last_Switches table. 1601 1602 Last_Switches.Increment_Last; 1603 Last_Switches.Table (Last_Switches.Last) := 1604 new String'(The_Arg); 1605 end if; 1606 end; 1607 end loop; 1608 end if; 1609 end if; 1610 1611 declare 1612 Program : String_Access; 1613 Exec_Path : String_Access; 1614 1615 begin 1616 if The_Command = Stack then 1617 1618 -- Never call gnatstack with a prefix 1619 1620 Program := new String'(Command_List (The_Command).Unixcmd.all); 1621 1622 else 1623 Program := 1624 Program_Name (Command_List (The_Command).Unixcmd.all, "gnat"); 1625 end if; 1626 1627 -- For the tools where the GNAT driver processes the project files, 1628 -- allow shared library projects to import projects that are not shared 1629 -- library projects, to avoid adding a switch for these tools. For the 1630 -- builder (gnatmake), if a shared library project imports a project 1631 -- that is not a shared library project and the appropriate switch is 1632 -- not specified, the invocation of gnatmake will fail. 1633 1634 Opt.Unchecked_Shared_Lib_Imports := True; 1635 1636 -- Locate the executable for the command 1637 1638 Exec_Path := Locate_Exec_On_Path (Program.all); 1639 1640 if Exec_Path = null then 1641 Put_Line (Standard_Error, "could not locate " & Program.all); 1642 raise Error_Exit; 1643 end if; 1644 1645 -- If there are switches for the executable, put them as first switches 1646 1647 if Command_List (The_Command).Unixsws /= null then 1648 for J in Command_List (The_Command).Unixsws'Range loop 1649 First_Switches.Increment_Last; 1650 First_Switches.Table (First_Switches.Last) := 1651 Command_List (The_Command).Unixsws (J); 1652 end loop; 1653 end if; 1654 1655 -- For BIND, CHECK, ELIM, FIND, LINK, LIST, METRIC, PRETTY, STACK, STUB, 1656 -- SYNC and XREF, look for project file related switches. 1657 1658 case The_Command is 1659 when Bind => 1660 Tool_Package_Name := Name_Binder; 1661 Packages_To_Check := Packages_To_Check_By_Binder; 1662 when Check => 1663 Tool_Package_Name := Name_Check; 1664 Packages_To_Check := Packages_To_Check_By_Check; 1665 when Elim => 1666 Tool_Package_Name := Name_Eliminate; 1667 Packages_To_Check := Packages_To_Check_By_Eliminate; 1668 when Find => 1669 Tool_Package_Name := Name_Finder; 1670 Packages_To_Check := Packages_To_Check_By_Finder; 1671 when Link => 1672 Tool_Package_Name := Name_Linker; 1673 Packages_To_Check := Packages_To_Check_By_Linker; 1674 when List => 1675 Tool_Package_Name := Name_Gnatls; 1676 Packages_To_Check := Packages_To_Check_By_Gnatls; 1677 when Metric => 1678 Tool_Package_Name := Name_Metrics; 1679 Packages_To_Check := Packages_To_Check_By_Metric; 1680 when Pretty => 1681 Tool_Package_Name := Name_Pretty_Printer; 1682 Packages_To_Check := Packages_To_Check_By_Pretty; 1683 when Stack => 1684 Tool_Package_Name := Name_Stack; 1685 Packages_To_Check := Packages_To_Check_By_Stack; 1686 when Stub => 1687 Tool_Package_Name := Name_Gnatstub; 1688 Packages_To_Check := Packages_To_Check_By_Gnatstub; 1689 when Sync => 1690 Tool_Package_Name := Name_Synchronize; 1691 Packages_To_Check := Packages_To_Check_By_Sync; 1692 when Xref => 1693 Tool_Package_Name := Name_Cross_Reference; 1694 Packages_To_Check := Packages_To_Check_By_Xref; 1695 when others => 1696 Tool_Package_Name := No_Name; 1697 end case; 1698 1699 if Tool_Package_Name /= No_Name then 1700 1701 -- Check that the switches are consistent. Detect project file 1702 -- related switches. 1703 1704 Inspect_Switches : declare 1705 Arg_Num : Positive := 1; 1706 Argv : String_Access; 1707 1708 procedure Remove_Switch (Num : Positive); 1709 -- Remove a project related switch from table Last_Switches 1710 1711 ------------------- 1712 -- Remove_Switch -- 1713 ------------------- 1714 1715 procedure Remove_Switch (Num : Positive) is 1716 begin 1717 Last_Switches.Table (Num .. Last_Switches.Last - 1) := 1718 Last_Switches.Table (Num + 1 .. Last_Switches.Last); 1719 Last_Switches.Decrement_Last; 1720 end Remove_Switch; 1721 1722 -- Start of processing for Inspect_Switches 1723 1724 begin 1725 while Arg_Num <= Last_Switches.Last loop 1726 Argv := Last_Switches.Table (Arg_Num); 1727 1728 if Argv (Argv'First) = '-' then 1729 if Argv'Length = 1 then 1730 Fail 1731 ("switch character cannot be followed by a blank"); 1732 end if; 1733 1734 -- The two style project files (-p and -P) cannot be used 1735 -- together 1736 1737 if (The_Command = Find or else The_Command = Xref) 1738 and then Argv (2) = 'p' 1739 then 1740 Old_Project_File_Used := True; 1741 if Project_File /= null then 1742 Fail ("-P and -p cannot be used together"); 1743 end if; 1744 end if; 1745 1746 -- --subdirs=... Specify Subdirs 1747 1748 if Argv'Length > Makeutl.Subdirs_Option'Length 1749 and then 1750 Argv 1751 (Argv'First .. 1752 Argv'First + Makeutl.Subdirs_Option'Length - 1) = 1753 Makeutl.Subdirs_Option 1754 then 1755 Subdirs := 1756 new String' 1757 (Argv 1758 (Argv'First + Makeutl.Subdirs_Option'Length .. 1759 Argv'Last)); 1760 1761 Remove_Switch (Arg_Num); 1762 1763 -- -aPdir Add dir to the project search path 1764 1765 elsif Argv'Length > 3 1766 and then Argv (Argv'First + 1 .. Argv'First + 2) = "aP" 1767 then 1768 Prj.Env.Add_Directories 1769 (Root_Environment.Project_Path, 1770 Argv (Argv'First + 3 .. Argv'Last)); 1771 1772 Remove_Switch (Arg_Num); 1773 1774 -- -eL Follow links for files 1775 1776 elsif Argv.all = "-eL" then 1777 Follow_Links_For_Files := True; 1778 Follow_Links_For_Dirs := True; 1779 1780 Remove_Switch (Arg_Num); 1781 1782 -- -vPx Specify verbosity while parsing project files 1783 1784 elsif Argv'Length >= 3 1785 and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP" 1786 then 1787 if Argv'Length = 4 1788 and then Argv (Argv'Last) in '0' .. '2' 1789 then 1790 case Argv (Argv'Last) is 1791 when '0' => 1792 Current_Verbosity := Prj.Default; 1793 when '1' => 1794 Current_Verbosity := Prj.Medium; 1795 when '2' => 1796 Current_Verbosity := Prj.High; 1797 when others => 1798 1799 -- Cannot happen 1800 1801 raise Program_Error; 1802 end case; 1803 else 1804 Fail ("invalid verbosity level: " 1805 & Argv (Argv'First + 3 .. Argv'Last)); 1806 end if; 1807 1808 Remove_Switch (Arg_Num); 1809 1810 -- -Pproject_file Specify project file to be used 1811 1812 elsif Argv (Argv'First + 1) = 'P' then 1813 1814 -- Only one -P switch can be used 1815 1816 if Project_File /= null then 1817 Fail 1818 (Argv.all 1819 & ": second project file forbidden (first is """ 1820 & Project_File.all 1821 & """)"); 1822 1823 -- The two style project files (-p and -P) cannot be 1824 -- used together. 1825 1826 elsif Old_Project_File_Used then 1827 Fail ("-p and -P cannot be used together"); 1828 1829 elsif Argv'Length = 2 then 1830 1831 -- There is space between -P and the project file 1832 -- name. -P cannot be the last option. 1833 1834 if Arg_Num = Last_Switches.Last then 1835 Fail ("project file name missing after -P"); 1836 1837 else 1838 Remove_Switch (Arg_Num); 1839 Argv := Last_Switches.Table (Arg_Num); 1840 1841 -- After -P, there must be a project file name, 1842 -- not another switch. 1843 1844 if Argv (Argv'First) = '-' then 1845 Fail ("project file name missing after -P"); 1846 1847 else 1848 Project_File := new String'(Argv.all); 1849 end if; 1850 end if; 1851 1852 else 1853 -- No space between -P and project file name 1854 1855 Project_File := 1856 new String'(Argv (Argv'First + 2 .. Argv'Last)); 1857 end if; 1858 1859 Remove_Switch (Arg_Num); 1860 1861 -- -Xexternal=value Specify an external reference to be 1862 -- used in project files 1863 1864 elsif Argv'Length >= 5 1865 and then Argv (Argv'First + 1) = 'X' 1866 then 1867 if not Check (Root_Environment.External, 1868 Argv (Argv'First + 2 .. Argv'Last)) 1869 then 1870 Fail (Argv.all 1871 & " is not a valid external assignment."); 1872 end if; 1873 1874 Remove_Switch (Arg_Num); 1875 1876 elsif 1877 (The_Command = Check or else 1878 The_Command = Sync or else 1879 The_Command = Pretty or else 1880 The_Command = Metric or else 1881 The_Command = Stack or else 1882 The_Command = List) 1883 and then Argv'Length = 2 1884 and then Argv (2) = 'U' 1885 then 1886 All_Projects := True; 1887 Remove_Switch (Arg_Num); 1888 1889 else 1890 Arg_Num := Arg_Num + 1; 1891 end if; 1892 1893 elsif ((The_Command = Check and then Argv (Argv'First) /= '+') 1894 or else The_Command = Sync 1895 or else The_Command = Metric 1896 or else The_Command = Pretty) 1897 and then Project_File /= null 1898 and then All_Projects 1899 then 1900 if ASIS_Main /= null then 1901 Fail ("cannot specify more than one main after -U"); 1902 else 1903 ASIS_Main := Argv; 1904 Remove_Switch (Arg_Num); 1905 end if; 1906 1907 else 1908 Arg_Num := Arg_Num + 1; 1909 end if; 1910 end loop; 1911 end Inspect_Switches; 1912 end if; 1913 1914 -- If there is a project file specified, parse it, get the switches 1915 -- for the tool and setup PATH environment variables. 1916 1917 if Project_File /= null then 1918 Prj.Pars.Set_Verbosity (To => Current_Verbosity); 1919 1920 Prj.Pars.Parse 1921 (Project => Project, 1922 In_Tree => Project_Tree, 1923 In_Node_Tree => Project_Node_Tree, 1924 Project_File_Name => Project_File.all, 1925 Env => Root_Environment, 1926 Packages_To_Check => Packages_To_Check); 1927 1928 -- Prj.Pars.Parse calls Set_Standard_Output, reset to stderr 1929 1930 Set_Standard_Error; 1931 1932 if Project = Prj.No_Project then 1933 Fail ("""" & Project_File.all & """ processing failed"); 1934 end if; 1935 1936 -- Check if a package with the name of the tool is in the project 1937 -- file and if there is one, get the switches, if any, and scan them. 1938 1939 declare 1940 Pkg : constant Prj.Package_Id := 1941 Prj.Util.Value_Of 1942 (Name => Tool_Package_Name, 1943 In_Packages => Project.Decl.Packages, 1944 Shared => Project_Tree.Shared); 1945 1946 Element : Package_Element; 1947 1948 Switches_Array : Array_Element_Id; 1949 1950 The_Switches : Prj.Variable_Value; 1951 Current : Prj.String_List_Id; 1952 The_String : String_Element; 1953 1954 Main : String_Access := null; 1955 1956 begin 1957 if Pkg /= No_Package then 1958 Element := Project_Tree.Shared.Packages.Table (Pkg); 1959 1960 -- Packages Gnatls and Gnatstack have a single attribute 1961 -- Switches, that is not an associative array. 1962 1963 if The_Command = List or else The_Command = Stack then 1964 The_Switches := 1965 Prj.Util.Value_Of 1966 (Variable_Name => Snames.Name_Switches, 1967 In_Variables => Element.Decl.Attributes, 1968 Shared => Project_Tree.Shared); 1969 1970 -- Packages Binder (for gnatbind), Cross_Reference (for 1971 -- gnatxref), Linker (for gnatlink), Finder (for gnatfind), 1972 -- Pretty_Printer (for gnatpp), Eliminate (for gnatelim), Check 1973 -- (for gnatcheck), and Metric (for gnatmetric) have an 1974 -- attributed Switches, an associative array, indexed by the 1975 -- name of the file. 1976 1977 -- They also have an attribute Default_Switches, indexed by the 1978 -- name of the programming language. 1979 1980 else 1981 -- First check if there is a single main 1982 1983 for J in 1 .. Last_Switches.Last loop 1984 if Last_Switches.Table (J) (1) /= '-' then 1985 if Main = null then 1986 Main := Last_Switches.Table (J); 1987 1988 else 1989 Main := null; 1990 exit; 1991 end if; 1992 end if; 1993 end loop; 1994 1995 if Main /= null then 1996 Switches_Array := 1997 Prj.Util.Value_Of 1998 (Name => Name_Switches, 1999 In_Arrays => Element.Decl.Arrays, 2000 Shared => Project_Tree.Shared); 2001 Name_Len := 0; 2002 2003 -- If the single main has been specified as an absolute 2004 -- path, use only the simple file name. If the absolute 2005 -- path is incorrect, an error will be reported by the 2006 -- underlying tool and it does not make a difference 2007 -- what switches are used. 2008 2009 if Is_Absolute_Path (Main.all) then 2010 Add_Str_To_Name_Buffer (File_Name (Main.all)); 2011 else 2012 Add_Str_To_Name_Buffer (Main.all); 2013 end if; 2014 2015 The_Switches := Prj.Util.Value_Of 2016 (Index => Name_Find, 2017 Src_Index => 0, 2018 In_Array => Switches_Array, 2019 Shared => Project_Tree.Shared); 2020 end if; 2021 2022 if The_Switches.Kind = Prj.Undefined then 2023 Switches_Array := 2024 Prj.Util.Value_Of 2025 (Name => Name_Default_Switches, 2026 In_Arrays => Element.Decl.Arrays, 2027 Shared => Project_Tree.Shared); 2028 The_Switches := Prj.Util.Value_Of 2029 (Index => Name_Ada, 2030 Src_Index => 0, 2031 In_Array => Switches_Array, 2032 Shared => Project_Tree.Shared); 2033 end if; 2034 end if; 2035 2036 -- If there are switches specified in the package of the 2037 -- project file corresponding to the tool, scan them. 2038 2039 case The_Switches.Kind is 2040 when Prj.Undefined => 2041 null; 2042 2043 when Prj.Single => 2044 declare 2045 Switch : constant String := 2046 Get_Name_String (The_Switches.Value); 2047 2048 begin 2049 if Switch'Length > 0 then 2050 First_Switches.Increment_Last; 2051 First_Switches.Table (First_Switches.Last) := 2052 new String'(Switch); 2053 end if; 2054 end; 2055 2056 when Prj.List => 2057 Current := The_Switches.Values; 2058 while Current /= Prj.Nil_String loop 2059 The_String := Project_Tree.Shared.String_Elements. 2060 Table (Current); 2061 2062 declare 2063 Switch : constant String := 2064 Get_Name_String (The_String.Value); 2065 2066 begin 2067 if Switch'Length > 0 then 2068 First_Switches.Increment_Last; 2069 First_Switches.Table (First_Switches.Last) := 2070 new String'(Switch); 2071 end if; 2072 end; 2073 2074 Current := The_String.Next; 2075 end loop; 2076 end case; 2077 end if; 2078 end; 2079 2080 if The_Command = Bind 2081 or else The_Command = Link 2082 or else The_Command = Elim 2083 then 2084 if Project.Object_Directory.Name = No_Path then 2085 Fail ("project " & Get_Name_String (Project.Display_Name) & 2086 " has no object directory"); 2087 end if; 2088 2089 Change_Dir (Get_Name_String (Project.Object_Directory.Name)); 2090 end if; 2091 2092 -- Set up the env vars for project path files 2093 2094 Prj.Env.Set_Ada_Paths 2095 (Project, Project_Tree, Including_Libraries => False); 2096 2097 -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create 2098 -- a configuration pragmas file, if necessary. 2099 2100 if The_Command = Pretty 2101 or else The_Command = Metric 2102 or else The_Command = Stub 2103 or else The_Command = Elim 2104 or else The_Command = Check 2105 or else The_Command = Sync 2106 then 2107 -- If there are switches in package Compiler, put them in the 2108 -- Carg_Switches table. 2109 2110 declare 2111 Pkg : constant Prj.Package_Id := 2112 Prj.Util.Value_Of 2113 (Name => Name_Compiler, 2114 In_Packages => Project.Decl.Packages, 2115 Shared => Project_Tree.Shared); 2116 2117 Element : Package_Element; 2118 2119 Switches_Array : Array_Element_Id; 2120 2121 The_Switches : Prj.Variable_Value; 2122 Current : Prj.String_List_Id; 2123 The_String : String_Element; 2124 2125 Main : String_Access := null; 2126 Main_Id : Name_Id; 2127 2128 begin 2129 if Pkg /= No_Package then 2130 2131 -- First, check if there is a single main specified 2132 2133 for J in 1 .. Last_Switches.Last loop 2134 if Last_Switches.Table (J) (1) /= '-' then 2135 if Main = null then 2136 Main := Last_Switches.Table (J); 2137 2138 else 2139 Main := null; 2140 exit; 2141 end if; 2142 end if; 2143 end loop; 2144 2145 Element := Project_Tree.Shared.Packages.Table (Pkg); 2146 2147 -- If there is a single main and there is compilation 2148 -- switches specified in the project file, use them. 2149 2150 if Main /= null and then not All_Projects then 2151 Name_Len := Main'Length; 2152 Name_Buffer (1 .. Name_Len) := Main.all; 2153 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 2154 Main_Id := Name_Find; 2155 2156 Switches_Array := 2157 Prj.Util.Value_Of 2158 (Name => Name_Switches, 2159 In_Arrays => Element.Decl.Arrays, 2160 Shared => Project_Tree.Shared); 2161 The_Switches := Prj.Util.Value_Of 2162 (Index => Main_Id, 2163 Src_Index => 0, 2164 In_Array => Switches_Array, 2165 Shared => Project_Tree.Shared); 2166 end if; 2167 2168 -- Otherwise, get the Default_Switches ("Ada") 2169 2170 if The_Switches.Kind = Undefined then 2171 Switches_Array := 2172 Prj.Util.Value_Of 2173 (Name => Name_Default_Switches, 2174 In_Arrays => Element.Decl.Arrays, 2175 Shared => Project_Tree.Shared); 2176 The_Switches := Prj.Util.Value_Of 2177 (Index => Name_Ada, 2178 Src_Index => 0, 2179 In_Array => Switches_Array, 2180 Shared => Project_Tree.Shared); 2181 end if; 2182 2183 -- If there are switches specified, put them in the 2184 -- Carg_Switches table. 2185 2186 case The_Switches.Kind is 2187 when Prj.Undefined => 2188 null; 2189 2190 when Prj.Single => 2191 declare 2192 Switch : constant String := 2193 Get_Name_String (The_Switches.Value); 2194 begin 2195 if Switch'Length > 0 then 2196 Add_To_Carg_Switches (new String'(Switch)); 2197 end if; 2198 end; 2199 2200 when Prj.List => 2201 Current := The_Switches.Values; 2202 while Current /= Prj.Nil_String loop 2203 The_String := Project_Tree.Shared.String_Elements 2204 .Table (Current); 2205 2206 declare 2207 Switch : constant String := 2208 Get_Name_String (The_String.Value); 2209 begin 2210 if Switch'Length > 0 then 2211 Add_To_Carg_Switches (new String'(Switch)); 2212 end if; 2213 end; 2214 2215 Current := The_String.Next; 2216 end loop; 2217 end case; 2218 end if; 2219 end; 2220 2221 -- If -cargs is one of the switches, move the following switches 2222 -- to the Carg_Switches table. 2223 2224 for J in 1 .. First_Switches.Last loop 2225 if First_Switches.Table (J).all = "-cargs" then 2226 declare 2227 K : Positive; 2228 Last : Natural; 2229 2230 begin 2231 -- Move the switches that are before -rules when the 2232 -- command is CHECK. 2233 2234 K := J + 1; 2235 while K <= First_Switches.Last 2236 and then 2237 (The_Command /= Check 2238 or else First_Switches.Table (K).all /= "-rules") 2239 loop 2240 Add_To_Carg_Switches (First_Switches.Table (K)); 2241 K := K + 1; 2242 end loop; 2243 2244 if K > First_Switches.Last then 2245 First_Switches.Set_Last (J - 1); 2246 2247 else 2248 Last := J - 1; 2249 while K <= First_Switches.Last loop 2250 Last := Last + 1; 2251 First_Switches.Table (Last) := 2252 First_Switches.Table (K); 2253 K := K + 1; 2254 end loop; 2255 2256 First_Switches.Set_Last (Last); 2257 end if; 2258 end; 2259 2260 exit; 2261 end if; 2262 end loop; 2263 2264 for J in 1 .. Last_Switches.Last loop 2265 if Last_Switches.Table (J).all = "-cargs" then 2266 declare 2267 K : Positive; 2268 Last : Natural; 2269 2270 begin 2271 -- Move the switches that are before -rules when the 2272 -- command is CHECK. 2273 2274 K := J + 1; 2275 while K <= Last_Switches.Last 2276 and then 2277 (The_Command /= Check 2278 or else Last_Switches.Table (K).all /= "-rules") 2279 loop 2280 Add_To_Carg_Switches (Last_Switches.Table (K)); 2281 K := K + 1; 2282 end loop; 2283 2284 if K > Last_Switches.Last then 2285 Last_Switches.Set_Last (J - 1); 2286 2287 else 2288 Last := J - 1; 2289 while K <= Last_Switches.Last loop 2290 Last := Last + 1; 2291 Last_Switches.Table (Last) := 2292 Last_Switches.Table (K); 2293 K := K + 1; 2294 end loop; 2295 2296 Last_Switches.Set_Last (Last); 2297 end if; 2298 end; 2299 2300 exit; 2301 end if; 2302 end loop; 2303 2304 declare 2305 CP_File : constant Path_Name_Type := Configuration_Pragmas_File; 2306 M_File : constant Path_Name_Type := Mapping_File; 2307 2308 begin 2309 if CP_File /= No_Path then 2310 if The_Command = Elim then 2311 First_Switches.Increment_Last; 2312 First_Switches.Table (First_Switches.Last) := 2313 new String'("-C" & Get_Name_String (CP_File)); 2314 2315 else 2316 Add_To_Carg_Switches 2317 (new String'("-gnatec=" & Get_Name_String (CP_File))); 2318 end if; 2319 end if; 2320 2321 if M_File /= No_Path then 2322 Add_To_Carg_Switches 2323 (new String'("-gnatem=" & Get_Name_String (M_File))); 2324 end if; 2325 2326 -- For gnatcheck, gnatpp, gnatstub and gnatmetric, also 2327 -- indicate a global configuration pragmas file and, if -U 2328 -- is not used, a local one. 2329 2330 if The_Command = Check or else 2331 The_Command = Pretty or else 2332 The_Command = Stub or else 2333 The_Command = Metric 2334 then 2335 declare 2336 Pkg : constant Prj.Package_Id := 2337 Prj.Util.Value_Of 2338 (Name => Name_Builder, 2339 In_Packages => Project.Decl.Packages, 2340 Shared => Project_Tree.Shared); 2341 2342 Variable : Variable_Value := 2343 Prj.Util.Value_Of 2344 (Name => No_Name, 2345 Attribute_Or_Array_Name => 2346 Name_Global_Configuration_Pragmas, 2347 In_Package => Pkg, 2348 Shared => Project_Tree.Shared); 2349 2350 begin 2351 if (Variable = Nil_Variable_Value 2352 or else Length_Of_Name (Variable.Value) = 0) 2353 and then Pkg /= No_Package 2354 then 2355 Variable := 2356 Prj.Util.Value_Of 2357 (Name => Name_Ada, 2358 Attribute_Or_Array_Name => 2359 Name_Global_Config_File, 2360 In_Package => Pkg, 2361 Shared => Project_Tree.Shared); 2362 end if; 2363 2364 if Variable /= Nil_Variable_Value 2365 and then Length_Of_Name (Variable.Value) /= 0 2366 then 2367 declare 2368 Path : constant String := 2369 Absolute_Path 2370 (Path_Name_Type (Variable.Value), 2371 Variable.Project); 2372 begin 2373 Add_To_Carg_Switches 2374 (new String'("-gnatec=" & Path)); 2375 end; 2376 end if; 2377 end; 2378 2379 if not All_Projects then 2380 declare 2381 Pkg : constant Prj.Package_Id := 2382 Prj.Util.Value_Of 2383 (Name => Name_Compiler, 2384 In_Packages => Project.Decl.Packages, 2385 Shared => Project_Tree.Shared); 2386 2387 Variable : Variable_Value := 2388 Prj.Util.Value_Of 2389 (Name => No_Name, 2390 Attribute_Or_Array_Name => 2391 Name_Local_Configuration_Pragmas, 2392 In_Package => Pkg, 2393 Shared => Project_Tree.Shared); 2394 2395 begin 2396 if (Variable = Nil_Variable_Value 2397 or else Length_Of_Name (Variable.Value) = 0) 2398 and then Pkg /= No_Package 2399 then 2400 Variable := 2401 Prj.Util.Value_Of 2402 (Name => Name_Ada, 2403 Attribute_Or_Array_Name => 2404 Name_Local_Config_File, 2405 In_Package => Pkg, 2406 Shared => 2407 Project_Tree.Shared); 2408 end if; 2409 2410 if Variable /= Nil_Variable_Value 2411 and then Length_Of_Name (Variable.Value) /= 0 2412 then 2413 declare 2414 Path : constant String := 2415 Absolute_Path 2416 (Path_Name_Type (Variable.Value), 2417 Variable.Project); 2418 begin 2419 Add_To_Carg_Switches 2420 (new String'("-gnatec=" & Path)); 2421 end; 2422 end if; 2423 end; 2424 end if; 2425 end if; 2426 end; 2427 end if; 2428 2429 if The_Command = Link then 2430 Process_Link; 2431 end if; 2432 2433 if The_Command = Link or else The_Command = Bind then 2434 2435 -- For files that are specified as relative paths with directory 2436 -- information, we convert them to absolute paths, with parent 2437 -- being the current working directory if specified on the command 2438 -- line and the project directory if specified in the project 2439 -- file. This is what gnatmake is doing for linker and binder 2440 -- arguments. 2441 2442 for J in 1 .. Last_Switches.Last loop 2443 GNATCmd.Ensure_Absolute_Path 2444 (Last_Switches.Table (J), Current_Work_Dir); 2445 end loop; 2446 2447 Get_Name_String (Project.Directory.Name); 2448 2449 declare 2450 Project_Dir : constant String := Name_Buffer (1 .. Name_Len); 2451 begin 2452 for J in 1 .. First_Switches.Last loop 2453 GNATCmd.Ensure_Absolute_Path 2454 (First_Switches.Table (J), Project_Dir); 2455 end loop; 2456 end; 2457 2458 elsif The_Command = Stub then 2459 declare 2460 File_Index : Integer := 0; 2461 Dir_Index : Integer := 0; 2462 Last : constant Integer := Last_Switches.Last; 2463 Lang : constant Language_Ptr := 2464 Get_Language_From_Name (Project, "ada"); 2465 2466 begin 2467 for Index in 1 .. Last loop 2468 if Last_Switches.Table (Index) 2469 (Last_Switches.Table (Index)'First) /= '-' 2470 then 2471 File_Index := Index; 2472 exit; 2473 end if; 2474 end loop; 2475 2476 -- If the project file naming scheme is not standard, and if 2477 -- the file name ends with the spec suffix, then indicate to 2478 -- gnatstub the name of the body file with a -o switch. 2479 2480 if Lang /= No_Language_Index 2481 and then not Is_Standard_GNAT_Naming (Lang.Config.Naming_Data) 2482 then 2483 if File_Index /= 0 then 2484 declare 2485 Spec : constant String := 2486 Base_Name 2487 (Last_Switches.Table (File_Index).all); 2488 Last : Natural := Spec'Last; 2489 2490 begin 2491 Get_Name_String (Lang.Config.Naming_Data.Spec_Suffix); 2492 2493 if Spec'Length > Name_Len 2494 and then Spec (Last - Name_Len + 1 .. Last) = 2495 Name_Buffer (1 .. Name_Len) 2496 then 2497 Last := Last - Name_Len; 2498 Get_Name_String 2499 (Lang.Config.Naming_Data.Body_Suffix); 2500 Last_Switches.Increment_Last; 2501 Last_Switches.Table (Last_Switches.Last) := 2502 new String'("-o"); 2503 Last_Switches.Increment_Last; 2504 Last_Switches.Table (Last_Switches.Last) := 2505 new String'(Spec (Spec'First .. Last) & 2506 Name_Buffer (1 .. Name_Len)); 2507 end if; 2508 end; 2509 end if; 2510 end if; 2511 2512 -- Add the directory of the spec as the destination directory 2513 -- of the body, if there is no destination directory already 2514 -- specified. 2515 2516 if File_Index /= 0 then 2517 for Index in File_Index + 1 .. Last loop 2518 if Last_Switches.Table (Index) 2519 (Last_Switches.Table (Index)'First) /= '-' 2520 then 2521 Dir_Index := Index; 2522 exit; 2523 end if; 2524 end loop; 2525 2526 if Dir_Index = 0 then 2527 Last_Switches.Increment_Last; 2528 Last_Switches.Table (Last_Switches.Last) := 2529 new String' 2530 (Dir_Name (Last_Switches.Table (File_Index).all)); 2531 end if; 2532 end if; 2533 end; 2534 end if; 2535 2536 -- For gnatmetric, the generated files should be put in the object 2537 -- directory. This must be the first switch, because it may be 2538 -- overridden by a switch in package Metrics in the project file or 2539 -- by a command line option. Note that we don't add the -d= switch 2540 -- if there is no object directory available. 2541 2542 if The_Command = Metric 2543 and then Project.Object_Directory /= No_Path_Information 2544 then 2545 First_Switches.Increment_Last; 2546 First_Switches.Table (2 .. First_Switches.Last) := 2547 First_Switches.Table (1 .. First_Switches.Last - 1); 2548 First_Switches.Table (1) := 2549 new String'("-d=" & 2550 Get_Name_String (Project.Object_Directory.Name)); 2551 end if; 2552 2553 -- For gnat check, -rules and the following switches need to be the 2554 -- last options, so move all these switches to table Rules_Switches. 2555 2556 if The_Command = Check then 2557 declare 2558 New_Last : Natural; 2559 -- Set to rank of options preceding "-rules" 2560 2561 In_Rules_Switches : Boolean; 2562 -- Set to True when options "-rules" is found 2563 2564 begin 2565 New_Last := First_Switches.Last; 2566 In_Rules_Switches := False; 2567 2568 for J in 1 .. First_Switches.Last loop 2569 if In_Rules_Switches then 2570 Add_To_Rules_Switches (First_Switches.Table (J)); 2571 2572 elsif First_Switches.Table (J).all = "-rules" then 2573 New_Last := J - 1; 2574 In_Rules_Switches := True; 2575 end if; 2576 end loop; 2577 2578 if In_Rules_Switches then 2579 First_Switches.Set_Last (New_Last); 2580 end if; 2581 2582 New_Last := Last_Switches.Last; 2583 In_Rules_Switches := False; 2584 2585 for J in 1 .. Last_Switches.Last loop 2586 if In_Rules_Switches then 2587 Add_To_Rules_Switches (Last_Switches.Table (J)); 2588 2589 elsif Last_Switches.Table (J).all = "-rules" then 2590 New_Last := J - 1; 2591 In_Rules_Switches := True; 2592 end if; 2593 end loop; 2594 2595 if In_Rules_Switches then 2596 Last_Switches.Set_Last (New_Last); 2597 end if; 2598 end; 2599 end if; 2600 2601 -- For gnat check, sync, metric or pretty with -U + a main, get the 2602 -- list of sources from the closure and add them to the arguments. 2603 2604 if ASIS_Main /= null then 2605 Get_Closure; 2606 2607 -- On VMS, set up the env var again for source dirs file. This is 2608 -- because the call to gnatmake has set this env var to another 2609 -- file that has now been deleted. 2610 2611 if Hostparm.OpenVMS then 2612 2613 -- First make sure that the recorded file names are empty 2614 2615 Prj.Env.Initialize (Project_Tree); 2616 2617 Prj.Env.Set_Ada_Paths 2618 (Project, Project_Tree, Including_Libraries => False); 2619 end if; 2620 2621 -- For gnat check, gnat sync, gnat pretty, gnat metric, gnat list, 2622 -- and gnat stack, if no file has been put on the command line, call 2623 -- tool with all the sources of the main project. 2624 2625 elsif The_Command = Check or else 2626 The_Command = Sync or else 2627 The_Command = Pretty or else 2628 The_Command = Metric or else 2629 The_Command = List or else 2630 The_Command = Stack 2631 then 2632 Check_Files; 2633 end if; 2634 end if; 2635 2636 -- Gather all the arguments and invoke the executable 2637 2638 declare 2639 The_Args : Argument_List 2640 (1 .. First_Switches.Last + 2641 Last_Switches.Last + 2642 Carg_Switches.Last + 2643 Rules_Switches.Last); 2644 Arg_Num : Natural := 0; 2645 2646 begin 2647 for J in 1 .. First_Switches.Last loop 2648 Arg_Num := Arg_Num + 1; 2649 The_Args (Arg_Num) := First_Switches.Table (J); 2650 end loop; 2651 2652 for J in 1 .. Last_Switches.Last loop 2653 Arg_Num := Arg_Num + 1; 2654 The_Args (Arg_Num) := Last_Switches.Table (J); 2655 end loop; 2656 2657 for J in 1 .. Carg_Switches.Last loop 2658 Arg_Num := Arg_Num + 1; 2659 The_Args (Arg_Num) := Carg_Switches.Table (J); 2660 end loop; 2661 2662 for J in 1 .. Rules_Switches.Last loop 2663 Arg_Num := Arg_Num + 1; 2664 The_Args (Arg_Num) := Rules_Switches.Table (J); 2665 end loop; 2666 2667 -- If Display_Command is on, only display the generated command 2668 2669 if Display_Command then 2670 Put (Standard_Error, "generated command -->"); 2671 Put (Standard_Error, Exec_Path.all); 2672 2673 for Arg in The_Args'Range loop 2674 Put (Standard_Error, " "); 2675 Put (Standard_Error, The_Args (Arg).all); 2676 end loop; 2677 2678 Put (Standard_Error, "<--"); 2679 New_Line (Standard_Error); 2680 raise Normal_Exit; 2681 end if; 2682 2683 if Verbose_Mode then 2684 Output.Write_Str (Exec_Path.all); 2685 2686 for Arg in The_Args'Range loop 2687 Output.Write_Char (' '); 2688 Output.Write_Str (The_Args (Arg).all); 2689 end loop; 2690 2691 Output.Write_Eol; 2692 end if; 2693 2694 My_Exit_Status := 2695 Exit_Status (Spawn (Exec_Path.all, The_Args)); 2696 raise Normal_Exit; 2697 end; 2698 end; 2699 2700exception 2701 when Error_Exit => 2702 if not Keep_Temporary_Files then 2703 Prj.Delete_All_Temp_Files (Project_Tree.Shared); 2704 Delete_Temp_Config_Files; 2705 end if; 2706 2707 Set_Exit_Status (Failure); 2708 2709 when Normal_Exit => 2710 if not Keep_Temporary_Files then 2711 Prj.Delete_All_Temp_Files (Project_Tree.Shared); 2712 Delete_Temp_Config_Files; 2713 end if; 2714 2715 -- Since GNATCmd is normally called from DCL (the VMS shell), it must 2716 -- return an understandable VMS exit status. However the exit status 2717 -- returned *to* GNATCmd is a Posix style code, so we test it and return 2718 -- just a simple success or failure on VMS. 2719 2720 if Hostparm.OpenVMS and then My_Exit_Status /= Success then 2721 Set_Exit_Status (Failure); 2722 else 2723 Set_Exit_Status (My_Exit_Status); 2724 end if; 2725end GNATCmd; 2726