1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- V M S _ C O N V -- 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 Gnatvsn; use Gnatvsn; 27with Hostparm; 28with Opt; 29with Osint; use Osint; 30with Targparm; use Targparm; 31 32with Ada.Characters.Handling; use Ada.Characters.Handling; 33with Ada.Command_Line; use Ada.Command_Line; 34with Ada.Text_IO; use Ada.Text_IO; 35 36package body VMS_Conv is 37 38 ------------------------- 39 -- Internal Structures -- 40 ------------------------- 41 42 -- The switches and commands are defined by strings in the previous 43 -- section so that they are easy to modify, but internally, they are 44 -- kept in a more conveniently accessible form described in this 45 -- section. 46 47 -- Commands, command qualifiers and options have a similar common format 48 -- so that searching for matching names can be done in a common manner. 49 50 type Item_Id is (Id_Command, Id_Switch, Id_Option); 51 52 type Translation_Type is 53 ( 54 T_Direct, 55 -- A qualifier with no options. 56 -- Example: GNAT MAKE /VERBOSE 57 58 T_Directories, 59 -- A qualifier followed by a list of directories 60 -- Example: GNAT COMPILE /SEARCH=([], [.FOO], [.BAR]) 61 62 T_Directory, 63 -- A qualifier followed by one directory 64 -- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB] 65 66 T_File, 67 -- A qualifier followed by a filename 68 -- Example: GNAT LINK /EXECUTABLE=FOO.EXE 69 70 T_No_Space_File, 71 -- A qualifier followed by a filename 72 -- Example: GNAT MAKE /PROJECT_FILE=PRJ.GPR 73 74 T_Numeric, 75 -- A qualifier followed by a numeric value. 76 -- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39 77 78 T_String, 79 -- A qualifier followed by a quoted string. Only used by 80 -- /IDENTIFICATION qualifier. 81 -- Example: GNAT LINK /IDENTIFICATION="3.14a1 version" 82 83 T_Options, 84 -- A qualifier followed by a list of options. 85 -- Example: GNAT COMPILE /REPRESENTATION_INFO=(ARRAYS,OBJECTS) 86 87 T_Commands, 88 -- A qualifier followed by a list. Only used for 89 -- MAKE /COMPILER_QUALIFIERS /BINDER_QUALIFIERS /LINKER_QUALIFIERS 90 -- (gnatmake -cargs -bargs -largs ) 91 -- Example: GNAT MAKE ... /LINKER_QUALIFIERS /VERBOSE FOOBAR.OBJ 92 93 T_Other, 94 -- A qualifier passed directly to the linker. Only used 95 -- for LINK and SHARED if no other match is found. 96 -- Example: GNAT LINK FOO.ALI /SYSSHR 97 98 T_Alphanumplus 99 -- A qualifier followed by a legal linker symbol prefix. Only used 100 -- for BIND /BUILD_LIBRARY (gnatbind -Lxyz). 101 -- Example: GNAT BIND /BUILD_LIBRARY=foobar 102 ); 103 104 type Item (Id : Item_Id); 105 type Item_Ptr is access all Item; 106 107 type Item (Id : Item_Id) is record 108 Name : String_Ptr; 109 -- Name of the command, switch (with slash) or option 110 111 Next : Item_Ptr; 112 -- Pointer to next item on list, always has the same Id value 113 114 Command : Command_Type := Undefined; 115 116 Unix_String : String_Ptr := null; 117 -- Corresponding Unix string. For a command, this is the unix command 118 -- name and possible default switches. For a switch or option it is 119 -- the unix switch string. 120 121 case Id is 122 123 when Id_Command => 124 125 Switches : Item_Ptr; 126 -- Pointer to list of switch items for the command, linked 127 -- through the Next fields with null terminating the list. 128 129 Usage : String_Ptr; 130 -- Usage information, used only for errors and the default 131 -- list of commands output. 132 133 Params : Parameter_Ref; 134 -- Array of parameters 135 136 Defext : String (1 .. 3); 137 -- Default extension. If non-blank, then this extension is 138 -- supplied by default as the extension for any file parameter 139 -- which does not have an extension already. 140 141 when Id_Switch => 142 143 Translation : Translation_Type; 144 -- Type of switch translation. For all cases, except Options, 145 -- this is the only field needed, since the Unix translation 146 -- is found in Unix_String. 147 148 Options : Item_Ptr; 149 -- For the Options case, this field is set to point to a list 150 -- of options item (for this case Unix_String is null in the 151 -- main switch item). The end of the list is marked by null. 152 153 when Id_Option => 154 155 null; 156 -- No special fields needed, since Name and Unix_String are 157 -- sufficient to completely described an option. 158 159 end case; 160 end record; 161 162 subtype Command_Item is Item (Id_Command); 163 subtype Switch_Item is Item (Id_Switch); 164 subtype Option_Item is Item (Id_Option); 165 166 Keep_Temps_Option : constant Item_Ptr := 167 new Item' 168 (Id => Id_Option, 169 Name => 170 new String'("/KEEP_TEMPORARY_FILES"), 171 Next => null, 172 Command => Undefined, 173 Unix_String => null); 174 175 Param_Count : Natural := 0; 176 -- Number of parameter arguments so far 177 178 Arg_Num : Natural; 179 -- Argument number 180 181 Arg_File : Ada.Text_IO.File_Type; 182 -- A file where arguments are read from 183 184 Commands : Item_Ptr; 185 -- Pointer to head of list of command items, one for each command, with 186 -- the end of the list marked by a null pointer. 187 188 Last_Command : Item_Ptr; 189 -- Pointer to last item in Commands list 190 191 Command : Item_Ptr; 192 -- Pointer to command item for current command 193 194 Make_Commands_Active : Item_Ptr := null; 195 -- Set to point to Command entry for COMPILE, BIND, or LINK as appropriate 196 -- if a COMMANDS_TRANSLATION switch has been encountered while processing 197 -- a MAKE Command. 198 199 Output_File_Expected : Boolean := False; 200 -- True for GNAT LINK after -o switch, so that the ".ali" extension is 201 -- not added to the executable file name. 202 203 package Buffer is new Table.Table 204 (Table_Component_Type => Character, 205 Table_Index_Type => Integer, 206 Table_Low_Bound => 1, 207 Table_Initial => 4096, 208 Table_Increment => 100, 209 Table_Name => "Buffer"); 210 -- Table to store the command to be used 211 212 package Cargs_Buffer is new Table.Table 213 (Table_Component_Type => Character, 214 Table_Index_Type => Integer, 215 Table_Low_Bound => 1, 216 Table_Initial => 4096, 217 Table_Increment => 100, 218 Table_Name => "Cargs_Buffer"); 219 -- Table to store the compiler switches for GNAT COMPILE 220 221 Cargs : Boolean := False; 222 -- When True, commands should go to Cargs_Buffer instead of Buffer table 223 224 function Init_Object_Dirs return Argument_List; 225 -- Get the list of the object directories 226 227 function Invert_Sense (S : String) return VMS_Data.String_Ptr; 228 -- Given a unix switch string S, computes the inverse (adding or 229 -- removing ! characters as required), and returns a pointer to 230 -- the allocated result on the heap. 231 232 function Is_Extensionless (F : String) return Boolean; 233 -- Returns true if the filename has no extension 234 235 function Match (S1, S2 : String) return Boolean; 236 -- Determines whether S1 and S2 match (this is a case insensitive match) 237 238 function Match_Prefix (S1, S2 : String) return Boolean; 239 -- Determines whether S1 matches a prefix of S2. This is also a case 240 -- insensitive match (for example Match ("AB","abc") is True). 241 242 function Matching_Name 243 (S : String; 244 Itm : Item_Ptr; 245 Quiet : Boolean := False) return Item_Ptr; 246 -- Determines if the item list headed by Itm and threaded through the 247 -- Next fields (with null marking the end of the list), contains an 248 -- entry that uniquely matches the given string. The match is case 249 -- insensitive and permits unique abbreviation. If the match succeeds, 250 -- then a pointer to the matching item is returned. Otherwise, an 251 -- appropriate error message is written. Note that the discriminant 252 -- of Itm is used to determine the appropriate form of this message. 253 -- Quiet is normally False as shown, if it is set to True, then no 254 -- error message is generated in a not found situation (null is still 255 -- returned to indicate the not-found situation). 256 257 function OK_Alphanumerplus (S : String) return Boolean; 258 -- Checks that S is a string of alphanumeric characters, 259 -- returning True if all alphanumeric characters, 260 -- False if empty or a non-alphanumeric character is present. 261 262 function OK_Integer (S : String) return Boolean; 263 -- Checks that S is a string of digits, returning True if all digits, 264 -- False if empty or a non-digit is present. 265 266 procedure Place (C : Character); 267 -- Place a single character in the buffer, updating Ptr 268 269 procedure Place (S : String); 270 -- Place a string character in the buffer, updating Ptr 271 272 procedure Place_Lower (S : String); 273 -- Place string in buffer, forcing letters to lower case, updating Ptr 274 275 procedure Place_Unix_Switches (S : VMS_Data.String_Ptr); 276 -- Given a unix switch string, place corresponding switches in Buffer, 277 -- updating Ptr appropriately. Note that in the case of use of ! the 278 -- result may be to remove a previously placed switch. 279 280 procedure Preprocess_Command_Data; 281 -- Preprocess the string form of the command and options list into the 282 -- internal form. 283 284 procedure Process_Argument (The_Command : in out Command_Type); 285 -- Process one argument from the command line, or one line from 286 -- from a command line file. For the first call, set The_Command. 287 288 procedure Process_Buffer (S : String); 289 -- Process the characters in the Buffer table or the Cargs_Buffer table 290 -- to convert these into arguments. 291 292 procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr); 293 -- Check that N is a valid command or option name, i.e. that it is of the 294 -- form of an Ada identifier with upper case letters and underscores. 295 296 procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr); 297 -- Check that S is a valid switch string as described in the syntax for 298 -- the switch table item UNIX_SWITCH or else begins with a backquote. 299 300 ---------------------- 301 -- Init_Object_Dirs -- 302 ---------------------- 303 304 function Init_Object_Dirs return Argument_List is 305 Object_Dirs : Integer; 306 Object_Dir : Argument_List (1 .. 256); 307 Object_Dir_Name : String_Access; 308 309 begin 310 Object_Dirs := 0; 311 Object_Dir_Name := new String'(Object_Dir_Default_Prefix); 312 Get_Next_Dir_In_Path_Init (Object_Dir_Name); 313 314 loop 315 declare 316 Dir : constant String_Access := 317 Get_Next_Dir_In_Path (Object_Dir_Name); 318 begin 319 exit when Dir = null; 320 Object_Dirs := Object_Dirs + 1; 321 Object_Dir (Object_Dirs) := 322 new String'("-L" & 323 To_Canonical_Dir_Spec 324 (To_Host_Dir_Spec 325 (Normalize_Directory_Name (Dir.all).all, 326 True).all, True).all); 327 end; 328 end loop; 329 330 Object_Dirs := Object_Dirs + 1; 331 Object_Dir (Object_Dirs) := new String'("-lgnat"); 332 333 if OpenVMS_On_Target then 334 Object_Dirs := Object_Dirs + 1; 335 Object_Dir (Object_Dirs) := new String'("-ldecgnat"); 336 end if; 337 338 return Object_Dir (1 .. Object_Dirs); 339 end Init_Object_Dirs; 340 341 ---------------- 342 -- Initialize -- 343 ---------------- 344 345 procedure Initialize is 346 begin 347 Command_List := 348 (Bind => 349 (Cname => new S'("BIND"), 350 Usage => new S'("GNAT BIND file[.ali] /qualifiers"), 351 VMS_Only => False, 352 Unixcmd => new S'("gnatbind"), 353 Unixsws => null, 354 Switches => Bind_Switches'Access, 355 Params => new Parameter_Array'(1 => Unlimited_Files), 356 Defext => "ali"), 357 358 Chop => 359 (Cname => new S'("CHOP"), 360 Usage => new S'("GNAT CHOP file [directory] /qualifiers"), 361 VMS_Only => False, 362 Unixcmd => new S'("gnatchop"), 363 Unixsws => null, 364 Switches => Chop_Switches'Access, 365 Params => new Parameter_Array'(1 => File, 2 => Optional_File), 366 Defext => " "), 367 368 Clean => 369 (Cname => new S'("CLEAN"), 370 Usage => new S'("GNAT CLEAN /qualifiers files"), 371 VMS_Only => False, 372 Unixcmd => new S'("gnatclean"), 373 Unixsws => null, 374 Switches => Clean_Switches'Access, 375 Params => new Parameter_Array'(1 => File), 376 Defext => " "), 377 378 Compile => 379 (Cname => new S'("COMPILE"), 380 Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"), 381 VMS_Only => False, 382 Unixcmd => new S'("gnatmake"), 383 Unixsws => new Argument_List'(1 => new String'("-f"), 384 2 => new String'("-u"), 385 3 => new String'("-c")), 386 Switches => GCC_Switches'Access, 387 Params => new Parameter_Array'(1 => Files_Or_Wildcard), 388 Defext => " "), 389 390 Check => 391 (Cname => new S'("CHECK"), 392 Usage => new S'("GNAT CHECK name /qualifiers"), 393 VMS_Only => False, 394 Unixcmd => new S'("gnatcheck"), 395 Unixsws => null, 396 Switches => Check_Switches'Access, 397 Params => new Parameter_Array'(1 => Unlimited_Files), 398 Defext => " "), 399 400 Sync => 401 (Cname => new S'("SYNC"), 402 Usage => new S'("GNAT SYNC name /qualifiers"), 403 VMS_Only => False, 404 Unixcmd => new S'("gnatsync"), 405 Unixsws => null, 406 Switches => Sync_Switches'Access, 407 Params => new Parameter_Array'(1 => Unlimited_Files), 408 Defext => " "), 409 410 Elim => 411 (Cname => new S'("ELIM"), 412 Usage => new S'("GNAT ELIM name /qualifiers"), 413 VMS_Only => False, 414 Unixcmd => new S'("gnatelim"), 415 Unixsws => null, 416 Switches => Elim_Switches'Access, 417 Params => new Parameter_Array'(1 => Other_As_Is), 418 Defext => "ali"), 419 420 Find => 421 (Cname => new S'("FIND"), 422 Usage => new S'("GNAT FIND pattern[:sourcefile[:line" 423 & "[:column]]] filespec[,...] /qualifiers"), 424 VMS_Only => False, 425 Unixcmd => new S'("gnatfind"), 426 Unixsws => null, 427 Switches => Find_Switches'Access, 428 Params => new Parameter_Array'(1 => Other_As_Is, 429 2 => Files_Or_Wildcard), 430 Defext => "ali"), 431 432 Krunch => 433 (Cname => new S'("KRUNCH"), 434 Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"), 435 VMS_Only => False, 436 Unixcmd => new S'("gnatkr"), 437 Unixsws => null, 438 Switches => Krunch_Switches'Access, 439 Params => new Parameter_Array'(1 => File), 440 Defext => " "), 441 442 Link => 443 (Cname => new S'("LINK"), 444 Usage => new S'("GNAT LINK file[.ali]" 445 & " [extra obj_&_lib_&_exe_&_opt files]" 446 & " /qualifiers"), 447 VMS_Only => False, 448 Unixcmd => new S'("gnatlink"), 449 Unixsws => null, 450 Switches => Link_Switches'Access, 451 Params => new Parameter_Array'(1 => Unlimited_Files), 452 Defext => "ali"), 453 454 List => 455 (Cname => new S'("LIST"), 456 Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"), 457 VMS_Only => False, 458 Unixcmd => new S'("gnatls"), 459 Unixsws => null, 460 Switches => List_Switches'Access, 461 Params => new Parameter_Array'(1 => Unlimited_Files), 462 Defext => "ali"), 463 464 Make => 465 (Cname => new S'("MAKE"), 466 Usage => new S'("GNAT MAKE file(s) /qualifiers (includes " 467 & "COMPILE /qualifiers)"), 468 VMS_Only => False, 469 Unixcmd => new S'("gnatmake"), 470 Unixsws => null, 471 Switches => Make_Switches'Access, 472 Params => new Parameter_Array'(1 => Unlimited_Files), 473 Defext => " "), 474 475 Metric => 476 (Cname => new S'("METRIC"), 477 Usage => new S'("GNAT METRIC /qualifiers source_file"), 478 VMS_Only => False, 479 Unixcmd => new S'("gnatmetric"), 480 Unixsws => null, 481 Switches => Metric_Switches'Access, 482 Params => new Parameter_Array'(1 => Unlimited_Files), 483 Defext => " "), 484 485 Name => 486 (Cname => new S'("NAME"), 487 Usage => new S'("GNAT NAME /qualifiers naming-pattern " 488 & "[naming-patterns]"), 489 VMS_Only => False, 490 Unixcmd => new S'("gnatname"), 491 Unixsws => null, 492 Switches => Name_Switches'Access, 493 Params => new Parameter_Array'(1 => Unlimited_As_Is), 494 Defext => " "), 495 496 Preprocess => 497 (Cname => new S'("PREPROCESS"), 498 Usage => 499 new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"), 500 VMS_Only => False, 501 Unixcmd => new S'("gnatprep"), 502 Unixsws => null, 503 Switches => Prep_Switches'Access, 504 Params => new Parameter_Array'(1 .. 3 => File), 505 Defext => " "), 506 507 Pretty => 508 (Cname => new S'("PRETTY"), 509 Usage => new S'("GNAT PRETTY /qualifiers source_file"), 510 VMS_Only => False, 511 Unixcmd => new S'("gnatpp"), 512 Unixsws => null, 513 Switches => Pretty_Switches'Access, 514 Params => new Parameter_Array'(1 => Unlimited_Files), 515 Defext => " "), 516 517 Shared => 518 (Cname => new S'("SHARED"), 519 Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt" 520 & "files] /qualifiers"), 521 VMS_Only => True, 522 Unixcmd => new S'("gcc"), 523 Unixsws => 524 new Argument_List'(new String'("-shared") & Init_Object_Dirs), 525 Switches => Shared_Switches'Access, 526 Params => new Parameter_Array'(1 => Unlimited_Files), 527 Defext => " "), 528 529 Stack => 530 (Cname => new S'("STACK"), 531 Usage => new S'("GNAT STACK /qualifiers ci_files"), 532 VMS_Only => False, 533 Unixcmd => new S'("gnatstack"), 534 Unixsws => null, 535 Switches => Stack_Switches'Access, 536 Params => new Parameter_Array'(1 => Unlimited_Files), 537 Defext => "ci" & ASCII.NUL), 538 539 Stub => 540 (Cname => new S'("STUB"), 541 Usage => new S'("GNAT STUB file [directory]/qualifiers"), 542 VMS_Only => False, 543 Unixcmd => new S'("gnatstub"), 544 Unixsws => null, 545 Switches => Stub_Switches'Access, 546 Params => new Parameter_Array'(1 => File, 2 => Optional_File), 547 Defext => " "), 548 549 Test => 550 (Cname => new S'("TEST"), 551 Usage => new S'("GNAT TEST file(s) /qualifiers"), 552 VMS_Only => False, 553 Unixcmd => new S'("gnattest"), 554 Unixsws => null, 555 Switches => Make_Switches'Access, 556 Params => new Parameter_Array'(1 => Unlimited_Files), 557 Defext => " "), 558 559 Xref => 560 (Cname => new S'("XREF"), 561 Usage => new S'("GNAT XREF filespec[,...] /qualifiers"), 562 VMS_Only => False, 563 Unixcmd => new S'("gnatxref"), 564 Unixsws => null, 565 Switches => Xref_Switches'Access, 566 Params => new Parameter_Array'(1 => Files_Or_Wildcard), 567 Defext => "ali") 568 ); 569 end Initialize; 570 571 ------------------ 572 -- Invert_Sense -- 573 ------------------ 574 575 function Invert_Sense (S : String) return VMS_Data.String_Ptr is 576 Sinv : String (1 .. S'Length * 2); 577 -- Result (for sure long enough) 578 579 Sinvp : Natural := 0; 580 -- Pointer to output string 581 582 begin 583 for Sp in S'Range loop 584 if Sp = S'First or else S (Sp - 1) = ',' then 585 if S (Sp) = '!' then 586 null; 587 else 588 Sinv (Sinvp + 1) := '!'; 589 Sinv (Sinvp + 2) := S (Sp); 590 Sinvp := Sinvp + 2; 591 end if; 592 593 else 594 Sinv (Sinvp + 1) := S (Sp); 595 Sinvp := Sinvp + 1; 596 end if; 597 end loop; 598 599 return new String'(Sinv (1 .. Sinvp)); 600 end Invert_Sense; 601 602 ---------------------- 603 -- Is_Extensionless -- 604 ---------------------- 605 606 function Is_Extensionless (F : String) return Boolean is 607 begin 608 for J in reverse F'Range loop 609 if F (J) = '.' then 610 return False; 611 elsif F (J) = '/' or else F (J) = ']' or else F (J) = ':' then 612 return True; 613 end if; 614 end loop; 615 616 return True; 617 end Is_Extensionless; 618 619 ----------- 620 -- Match -- 621 ----------- 622 623 function Match (S1, S2 : String) return Boolean is 624 Dif : constant Integer := S2'First - S1'First; 625 626 begin 627 628 if S1'Length /= S2'Length then 629 return False; 630 631 else 632 for J in S1'Range loop 633 if To_Lower (S1 (J)) /= To_Lower (S2 (J + Dif)) then 634 return False; 635 end if; 636 end loop; 637 638 return True; 639 end if; 640 end Match; 641 642 ------------------ 643 -- Match_Prefix -- 644 ------------------ 645 646 function Match_Prefix (S1, S2 : String) return Boolean is 647 begin 648 if S1'Length > S2'Length then 649 return False; 650 else 651 return Match (S1, S2 (S2'First .. S2'First + S1'Length - 1)); 652 end if; 653 end Match_Prefix; 654 655 ------------------- 656 -- Matching_Name -- 657 ------------------- 658 659 function Matching_Name 660 (S : String; 661 Itm : Item_Ptr; 662 Quiet : Boolean := False) return Item_Ptr 663 is 664 P1, P2 : Item_Ptr; 665 666 procedure Err; 667 -- Little procedure to output command/qualifier/option as appropriate 668 -- and bump error count. 669 670 --------- 671 -- Err -- 672 --------- 673 674 procedure Err is 675 begin 676 if Quiet then 677 return; 678 end if; 679 680 Errors := Errors + 1; 681 682 if Itm /= null then 683 case Itm.Id is 684 when Id_Command => 685 Put (Standard_Error, "command"); 686 687 when Id_Switch => 688 if Hostparm.OpenVMS then 689 Put (Standard_Error, "qualifier"); 690 else 691 Put (Standard_Error, "switch"); 692 end if; 693 694 when Id_Option => 695 Put (Standard_Error, "option"); 696 697 end case; 698 else 699 Put (Standard_Error, "input"); 700 701 end if; 702 703 Put (Standard_Error, ": "); 704 Put (Standard_Error, S); 705 end Err; 706 707 -- Start of processing for Matching_Name 708 709 begin 710 -- If exact match, that's the one we want 711 712 P1 := Itm; 713 while P1 /= null loop 714 if Match (S, P1.Name.all) then 715 return P1; 716 else 717 P1 := P1.Next; 718 end if; 719 end loop; 720 721 -- Now check for prefix matches 722 723 P1 := Itm; 724 while P1 /= null loop 725 if P1.Name.all = "/<other>" then 726 return P1; 727 728 elsif not Match_Prefix (S, P1.Name.all) then 729 P1 := P1.Next; 730 731 else 732 -- Here we have found one matching prefix, so see if there is 733 -- another one (which is an ambiguity) 734 735 P2 := P1.Next; 736 while P2 /= null loop 737 if Match_Prefix (S, P2.Name.all) then 738 if not Quiet then 739 Put (Standard_Error, "ambiguous "); 740 Err; 741 Put (Standard_Error, " (matches "); 742 Put (Standard_Error, P1.Name.all); 743 744 while P2 /= null loop 745 if Match_Prefix (S, P2.Name.all) then 746 Put (Standard_Error, ','); 747 Put (Standard_Error, P2.Name.all); 748 end if; 749 750 P2 := P2.Next; 751 end loop; 752 753 Put_Line (Standard_Error, ")"); 754 end if; 755 756 return null; 757 end if; 758 759 P2 := P2.Next; 760 end loop; 761 762 -- If we fall through that loop, then there was only one match 763 764 return P1; 765 end if; 766 end loop; 767 768 -- If we fall through outer loop, there was no match 769 770 if not Quiet then 771 Put (Standard_Error, "unrecognized "); 772 Err; 773 New_Line (Standard_Error); 774 end if; 775 776 return null; 777 end Matching_Name; 778 779 ----------------------- 780 -- OK_Alphanumerplus -- 781 ----------------------- 782 783 function OK_Alphanumerplus (S : String) return Boolean is 784 begin 785 if S'Length = 0 then 786 return False; 787 788 else 789 for J in S'Range loop 790 if not (Is_Alphanumeric (S (J)) or else 791 S (J) = '_' or else S (J) = '$') 792 then 793 return False; 794 end if; 795 end loop; 796 797 return True; 798 end if; 799 end OK_Alphanumerplus; 800 801 ---------------- 802 -- OK_Integer -- 803 ---------------- 804 805 function OK_Integer (S : String) return Boolean is 806 begin 807 if S'Length = 0 then 808 return False; 809 810 else 811 for J in S'Range loop 812 if not Is_Digit (S (J)) then 813 return False; 814 end if; 815 end loop; 816 817 return True; 818 end if; 819 end OK_Integer; 820 821 -------------------- 822 -- Output_Version -- 823 -------------------- 824 825 procedure Output_Version is 826 begin 827 if AAMP_On_Target then 828 Put ("GNAAMP "); 829 else 830 Put ("GNAT "); 831 end if; 832 833 Put_Line (Gnatvsn.Gnat_Version_String); 834 Put_Line ("Copyright 1996-" & 835 Current_Year & 836 ", Free Software Foundation, Inc."); 837 end Output_Version; 838 839 ----------- 840 -- Place -- 841 ----------- 842 843 procedure Place (C : Character) is 844 begin 845 if Cargs then 846 Cargs_Buffer.Append (C); 847 else 848 Buffer.Append (C); 849 end if; 850 end Place; 851 852 procedure Place (S : String) is 853 begin 854 for J in S'Range loop 855 Place (S (J)); 856 end loop; 857 end Place; 858 859 ----------------- 860 -- Place_Lower -- 861 ----------------- 862 863 procedure Place_Lower (S : String) is 864 begin 865 for J in S'Range loop 866 Place (To_Lower (S (J))); 867 end loop; 868 end Place_Lower; 869 870 ------------------------- 871 -- Place_Unix_Switches -- 872 ------------------------- 873 874 procedure Place_Unix_Switches (S : VMS_Data.String_Ptr) is 875 P1, P2, P3 : Natural; 876 Remove : Boolean; 877 Slen, Sln2 : Natural; 878 Wild_Card : Boolean := False; 879 880 begin 881 P1 := S'First; 882 while P1 <= S'Last loop 883 if S (P1) = '!' then 884 P1 := P1 + 1; 885 Remove := True; 886 else 887 Remove := False; 888 end if; 889 890 P2 := P1; 891 pragma Assert (S (P1) = '-' or else S (P1) = '`'); 892 893 while P2 < S'Last and then S (P2 + 1) /= ',' loop 894 P2 := P2 + 1; 895 end loop; 896 897 -- Switch is now in S (P1 .. P2) 898 899 Slen := P2 - P1 + 1; 900 901 if Remove then 902 Wild_Card := S (P2) = '*'; 903 904 if Wild_Card then 905 Slen := Slen - 1; 906 P2 := P2 - 1; 907 end if; 908 909 P3 := 1; 910 while P3 <= Buffer.Last - Slen loop 911 if Buffer.Table (P3) = ' ' 912 and then String (Buffer.Table (P3 + 1 .. P3 + Slen)) = 913 S (P1 .. P2) 914 and then (Wild_Card 915 or else 916 P3 + Slen = Buffer.Last 917 or else 918 Buffer.Table (P3 + Slen + 1) = ' ') 919 then 920 Sln2 := Slen; 921 922 if Wild_Card then 923 while P3 + Sln2 /= Buffer.Last 924 and then Buffer.Table (P3 + Sln2 + 1) /= ' ' 925 loop 926 Sln2 := Sln2 + 1; 927 end loop; 928 end if; 929 930 Buffer.Table (P3 .. Buffer.Last - Sln2 - 1) := 931 Buffer.Table (P3 + Sln2 + 1 .. Buffer.Last); 932 Buffer.Set_Last (Buffer.Last - Sln2 - 1); 933 934 else 935 P3 := P3 + 1; 936 end if; 937 end loop; 938 939 if Wild_Card then 940 P2 := P2 + 1; 941 end if; 942 943 else 944 pragma Assert (S (P2) /= '*'); 945 Place (' '); 946 947 if S (P1) = '`' then 948 P1 := P1 + 1; 949 end if; 950 951 Place (S (P1 .. P2)); 952 end if; 953 954 P1 := P2 + 2; 955 end loop; 956 end Place_Unix_Switches; 957 958 ----------------------------- 959 -- Preprocess_Command_Data -- 960 ----------------------------- 961 962 procedure Preprocess_Command_Data is 963 begin 964 for C in Real_Command_Type loop 965 declare 966 Command : constant Item_Ptr := new Command_Item; 967 968 Last_Switch : Item_Ptr; 969 -- Last switch in list 970 971 begin 972 -- Link new command item into list of commands 973 974 if Last_Command = null then 975 Commands := Command; 976 else 977 Last_Command.Next := Command; 978 end if; 979 980 Last_Command := Command; 981 982 -- Fill in fields of new command item 983 984 Command.Name := Command_List (C).Cname; 985 Command.Usage := Command_List (C).Usage; 986 Command.Command := C; 987 988 if Command_List (C).Unixsws = null then 989 Command.Unix_String := Command_List (C).Unixcmd; 990 else 991 declare 992 Cmd : String (1 .. 5_000); 993 Last : Natural := 0; 994 Sws : constant Argument_List_Access := 995 Command_List (C).Unixsws; 996 997 begin 998 Cmd (1 .. Command_List (C).Unixcmd'Length) := 999 Command_List (C).Unixcmd.all; 1000 Last := Command_List (C).Unixcmd'Length; 1001 1002 for J in Sws'Range loop 1003 Last := Last + 1; 1004 Cmd (Last) := ' '; 1005 Cmd (Last + 1 .. Last + Sws (J)'Length) := 1006 Sws (J).all; 1007 Last := Last + Sws (J)'Length; 1008 end loop; 1009 1010 Command.Unix_String := new String'(Cmd (1 .. Last)); 1011 end; 1012 end if; 1013 1014 Command.Params := Command_List (C).Params; 1015 Command.Defext := Command_List (C).Defext; 1016 1017 Validate_Command_Or_Option (Command.Name); 1018 1019 -- Process the switch list 1020 1021 for S in Command_List (C).Switches'Range loop 1022 declare 1023 SS : constant VMS_Data.String_Ptr := 1024 Command_List (C).Switches (S); 1025 P : Natural := SS'First; 1026 Sw : Item_Ptr := new Switch_Item; 1027 1028 Last_Opt : Item_Ptr; 1029 -- Pointer to last option 1030 1031 begin 1032 -- Link new switch item into list of switches 1033 1034 if Last_Switch = null then 1035 Command.Switches := Sw; 1036 else 1037 Last_Switch.Next := Sw; 1038 end if; 1039 1040 Last_Switch := Sw; 1041 1042 -- Process switch string, first get name 1043 1044 while SS (P) /= ' ' and then SS (P) /= '=' loop 1045 P := P + 1; 1046 end loop; 1047 1048 Sw.Name := new String'(SS (SS'First .. P - 1)); 1049 1050 -- Direct translation case 1051 1052 if SS (P) = ' ' then 1053 Sw.Translation := T_Direct; 1054 Sw.Unix_String := new String'(SS (P + 1 .. SS'Last)); 1055 Validate_Unix_Switch (Sw.Unix_String); 1056 1057 if SS (P - 1) = '>' then 1058 Sw.Translation := T_Other; 1059 1060 elsif SS (P + 1) = '`' then 1061 null; 1062 1063 -- Create the inverted case (/NO ..) 1064 1065 elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then 1066 Sw := new Switch_Item; 1067 Last_Switch.Next := Sw; 1068 Last_Switch := Sw; 1069 1070 Sw.Name := 1071 new String'("/NO" & SS (SS'First + 1 .. P - 1)); 1072 Sw.Translation := T_Direct; 1073 Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last)); 1074 Validate_Unix_Switch (Sw.Unix_String); 1075 end if; 1076 1077 -- Directories translation case 1078 1079 elsif SS (P + 1) = '*' then 1080 pragma Assert (SS (SS'Last) = '*'); 1081 Sw.Translation := T_Directories; 1082 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); 1083 Validate_Unix_Switch (Sw.Unix_String); 1084 1085 -- Directory translation case 1086 1087 elsif SS (P + 1) = '%' then 1088 pragma Assert (SS (SS'Last) = '%'); 1089 Sw.Translation := T_Directory; 1090 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); 1091 Validate_Unix_Switch (Sw.Unix_String); 1092 1093 -- File translation case 1094 1095 elsif SS (P + 1) = '@' then 1096 pragma Assert (SS (SS'Last) = '@'); 1097 Sw.Translation := T_File; 1098 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); 1099 Validate_Unix_Switch (Sw.Unix_String); 1100 1101 -- No space file translation case 1102 1103 elsif SS (P + 1) = '<' then 1104 pragma Assert (SS (SS'Last) = '>'); 1105 Sw.Translation := T_No_Space_File; 1106 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); 1107 Validate_Unix_Switch (Sw.Unix_String); 1108 1109 -- Numeric translation case 1110 1111 elsif SS (P + 1) = '#' then 1112 pragma Assert (SS (SS'Last) = '#'); 1113 Sw.Translation := T_Numeric; 1114 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); 1115 Validate_Unix_Switch (Sw.Unix_String); 1116 1117 -- Alphanumerplus translation case 1118 1119 elsif SS (P + 1) = '|' then 1120 pragma Assert (SS (SS'Last) = '|'); 1121 Sw.Translation := T_Alphanumplus; 1122 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); 1123 Validate_Unix_Switch (Sw.Unix_String); 1124 1125 -- String translation case 1126 1127 elsif SS (P + 1) = '"' then 1128 pragma Assert (SS (SS'Last) = '"'); 1129 Sw.Translation := T_String; 1130 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); 1131 Validate_Unix_Switch (Sw.Unix_String); 1132 1133 -- Commands translation case 1134 1135 elsif SS (P + 1) = '?' then 1136 Sw.Translation := T_Commands; 1137 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last)); 1138 1139 -- Options translation case 1140 1141 else 1142 Sw.Translation := T_Options; 1143 Sw.Unix_String := new String'(""); 1144 1145 P := P + 1; -- bump past = 1146 while P <= SS'Last loop 1147 declare 1148 Opt : constant Item_Ptr := new Option_Item; 1149 Q : Natural; 1150 1151 begin 1152 -- Link new option item into options list 1153 1154 if Last_Opt = null then 1155 Sw.Options := Opt; 1156 else 1157 Last_Opt.Next := Opt; 1158 end if; 1159 1160 Last_Opt := Opt; 1161 1162 -- Fill in fields of new option item 1163 1164 Q := P; 1165 while SS (Q) /= ' ' loop 1166 Q := Q + 1; 1167 end loop; 1168 1169 Opt.Name := new String'(SS (P .. Q - 1)); 1170 Validate_Command_Or_Option (Opt.Name); 1171 1172 P := Q + 1; 1173 Q := P; 1174 1175 while Q <= SS'Last and then SS (Q) /= ' ' loop 1176 Q := Q + 1; 1177 end loop; 1178 1179 Opt.Unix_String := new String'(SS (P .. Q - 1)); 1180 Validate_Unix_Switch (Opt.Unix_String); 1181 P := Q + 1; 1182 end; 1183 end loop; 1184 end if; 1185 end; 1186 end loop; 1187 end; 1188 end loop; 1189 end Preprocess_Command_Data; 1190 1191 ---------------------- 1192 -- Process_Argument -- 1193 ---------------------- 1194 1195 procedure Process_Argument (The_Command : in out Command_Type) is 1196 Argv : String_Access; 1197 Arg_Idx : Integer; 1198 1199 function Get_Arg_End 1200 (Argv : String; 1201 Arg_Idx : Integer) return Integer; 1202 -- Begins looking at Arg_Idx + 1 and returns the index of the 1203 -- last character before a slash or else the index of the last 1204 -- character in the string Argv. 1205 1206 ----------------- 1207 -- Get_Arg_End -- 1208 ----------------- 1209 1210 function Get_Arg_End 1211 (Argv : String; 1212 Arg_Idx : Integer) return Integer 1213 is 1214 begin 1215 for J in Arg_Idx + 1 .. Argv'Last loop 1216 if Argv (J) = '/' then 1217 return J - 1; 1218 end if; 1219 end loop; 1220 1221 return Argv'Last; 1222 end Get_Arg_End; 1223 1224 -- Start of processing for Process_Argument 1225 1226 begin 1227 Cargs := False; 1228 1229 -- If an argument file is open, read the next non empty line 1230 1231 if Is_Open (Arg_File) then 1232 declare 1233 Line : String (1 .. 256); 1234 Last : Natural; 1235 begin 1236 loop 1237 Get_Line (Arg_File, Line, Last); 1238 exit when Last /= 0 or else End_Of_File (Arg_File); 1239 end loop; 1240 1241 -- If the end of the argument file has been reached, close it 1242 1243 if End_Of_File (Arg_File) then 1244 Close (Arg_File); 1245 1246 -- If the last line was empty, return after increasing Arg_Num 1247 -- to go to the next argument on the comment line. 1248 1249 if Last = 0 then 1250 Arg_Num := Arg_Num + 1; 1251 return; 1252 end if; 1253 end if; 1254 1255 Argv := new String'(Line (1 .. Last)); 1256 Arg_Idx := 1; 1257 1258 if Argv (1) = '@' then 1259 Put_Line (Standard_Error, "argument file cannot contain @cmd"); 1260 raise Error_Exit; 1261 end if; 1262 end; 1263 1264 else 1265 -- No argument file is open, get the argument on the command line 1266 1267 Argv := new String'(Argument (Arg_Num)); 1268 Arg_Idx := Argv'First; 1269 1270 -- Check if this is the specification of an argument file 1271 1272 if Argv (Arg_Idx) = '@' then 1273 -- The first argument on the command line cannot be an argument 1274 -- file. 1275 1276 if Arg_Num = 1 then 1277 Put_Line 1278 (Standard_Error, 1279 "Cannot specify argument line before command"); 1280 raise Error_Exit; 1281 end if; 1282 1283 -- Open the file, after conversion of the name to canonical form. 1284 -- Fail if file is not found. 1285 1286 declare 1287 Canonical_File_Name : String_Access := 1288 To_Canonical_File_Spec (Argv (Arg_Idx + 1 .. Argv'Last)); 1289 begin 1290 Open (Arg_File, In_File, Canonical_File_Name.all); 1291 Free (Canonical_File_Name); 1292 return; 1293 1294 exception 1295 when others => 1296 Put (Standard_Error, "Cannot open argument file """); 1297 Put (Standard_Error, Argv (Arg_Idx + 1 .. Argv'Last)); 1298 Put_Line (Standard_Error, """"); 1299 raise Error_Exit; 1300 end; 1301 end if; 1302 end if; 1303 1304 <<Tryagain_After_Coalesce>> 1305 loop 1306 declare 1307 Next_Arg_Idx : Integer; 1308 Arg : String_Access; 1309 1310 begin 1311 Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); 1312 Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx)); 1313 1314 -- The first one must be a command name 1315 1316 if Arg_Num = 1 and then Arg_Idx = Argv'First then 1317 Command := Matching_Name (Arg.all, Commands); 1318 1319 if Command = null then 1320 raise Error_Exit; 1321 end if; 1322 1323 The_Command := Command.Command; 1324 Output_File_Expected := False; 1325 1326 -- Give usage information if only command given 1327 1328 if Argument_Count = 1 1329 and then Next_Arg_Idx = Argv'Last 1330 then 1331 Output_Version; 1332 New_Line; 1333 Put_Line 1334 ("List of available qualifiers and options"); 1335 New_Line; 1336 1337 Put (Command.Usage.all); 1338 Set_Col (53); 1339 Put_Line (Command.Unix_String.all); 1340 1341 declare 1342 Sw : Item_Ptr := Command.Switches; 1343 1344 begin 1345 while Sw /= null loop 1346 Put (" "); 1347 Put (Sw.Name.all); 1348 1349 case Sw.Translation is 1350 1351 when T_Other => 1352 Set_Col (53); 1353 Put_Line (Sw.Unix_String.all & 1354 "/<other>"); 1355 1356 when T_Direct => 1357 Set_Col (53); 1358 Put_Line (Sw.Unix_String.all); 1359 1360 when T_Directories => 1361 Put ("=(direc,direc,..direc)"); 1362 Set_Col (53); 1363 Put (Sw.Unix_String.all); 1364 Put (" direc "); 1365 Put (Sw.Unix_String.all); 1366 Put_Line (" direc ..."); 1367 1368 when T_Directory => 1369 Put ("=directory"); 1370 Set_Col (53); 1371 Put (Sw.Unix_String.all); 1372 1373 if Sw.Unix_String (Sw.Unix_String'Last) 1374 /= '=' 1375 then 1376 Put (' '); 1377 end if; 1378 1379 Put_Line ("directory "); 1380 1381 when T_File | T_No_Space_File => 1382 Put ("=file"); 1383 Set_Col (53); 1384 Put (Sw.Unix_String.all); 1385 1386 if Sw.Translation = T_File 1387 and then Sw.Unix_String 1388 (Sw.Unix_String'Last) /= '=' 1389 then 1390 Put (' '); 1391 end if; 1392 1393 Put_Line ("file "); 1394 1395 when T_Numeric => 1396 Put ("=nnn"); 1397 Set_Col (53); 1398 1399 if Sw.Unix_String 1400 (Sw.Unix_String'First) = '`' 1401 then 1402 Put (Sw.Unix_String 1403 (Sw.Unix_String'First + 1 1404 .. Sw.Unix_String'Last)); 1405 else 1406 Put (Sw.Unix_String.all); 1407 end if; 1408 1409 Put_Line ("nnn"); 1410 1411 when T_Alphanumplus => 1412 Put ("=xyz"); 1413 Set_Col (53); 1414 1415 if Sw.Unix_String 1416 (Sw.Unix_String'First) = '`' 1417 then 1418 Put (Sw.Unix_String 1419 (Sw.Unix_String'First + 1 1420 .. Sw.Unix_String'Last)); 1421 else 1422 Put (Sw.Unix_String.all); 1423 end if; 1424 1425 Put_Line ("xyz"); 1426 1427 when T_String => 1428 Put ("="); 1429 Put ('"'); 1430 Put ("<string>"); 1431 Put ('"'); 1432 Set_Col (53); 1433 1434 Put (Sw.Unix_String.all); 1435 1436 if Sw.Unix_String 1437 (Sw.Unix_String'Last) /= '=' 1438 then 1439 Put (' '); 1440 end if; 1441 1442 Put ("<string>"); 1443 New_Line; 1444 1445 when T_Commands => 1446 Put (" (switches for "); 1447 Put (Sw.Unix_String 1448 (Sw.Unix_String'First + 7 1449 .. Sw.Unix_String'Last)); 1450 Put (')'); 1451 Set_Col (53); 1452 Put (Sw.Unix_String 1453 (Sw.Unix_String'First 1454 .. Sw.Unix_String'First + 5)); 1455 Put_Line (" switches"); 1456 1457 when T_Options => 1458 declare 1459 Opt : Item_Ptr := Sw.Options; 1460 1461 begin 1462 Put_Line ("=(option,option..)"); 1463 1464 while Opt /= null loop 1465 Put (" "); 1466 Put (Opt.Name.all); 1467 1468 if Opt = Sw.Options then 1469 Put (" (D)"); 1470 end if; 1471 1472 Set_Col (53); 1473 Put_Line (Opt.Unix_String.all); 1474 Opt := Opt.Next; 1475 end loop; 1476 end; 1477 1478 end case; 1479 1480 Sw := Sw.Next; 1481 end loop; 1482 end; 1483 1484 raise Normal_Exit; 1485 end if; 1486 1487 -- Special handling for internal debugging switch /? 1488 1489 elsif Arg.all = "/?" then 1490 Display_Command := True; 1491 Output_File_Expected := False; 1492 1493 -- Special handling of internal option /KEEP_TEMPORARY_FILES 1494 1495 elsif Arg'Length >= 7 1496 and then Matching_Name 1497 (Arg.all, Keep_Temps_Option, True) /= null 1498 then 1499 Opt.Keep_Temporary_Files := True; 1500 1501 -- Copy -switch unchanged, as well as +rule 1502 1503 elsif Arg (Arg'First) = '-' or else Arg (Arg'First) = '+' then 1504 Place (' '); 1505 Place (Arg.all); 1506 1507 -- Set Output_File_Expected for the next argument 1508 1509 Output_File_Expected := 1510 Arg.all = "-o" and then The_Command = Link; 1511 1512 -- Copy quoted switch with quotes stripped 1513 1514 elsif Arg (Arg'First) = '"' then 1515 if Arg (Arg'Last) /= '"' then 1516 Put (Standard_Error, "misquoted argument: "); 1517 Put_Line (Standard_Error, Arg.all); 1518 Errors := Errors + 1; 1519 1520 else 1521 Place (' '); 1522 Place (Arg (Arg'First + 1 .. Arg'Last - 1)); 1523 end if; 1524 1525 Output_File_Expected := False; 1526 1527 -- Parameter Argument 1528 1529 elsif Arg (Arg'First) /= '/' 1530 and then Make_Commands_Active = null 1531 then 1532 Param_Count := Param_Count + 1; 1533 1534 if Param_Count <= Command.Params'Length then 1535 1536 case Command.Params (Param_Count) is 1537 1538 when File | Optional_File => 1539 declare 1540 Normal_File : constant String_Access := 1541 To_Canonical_File_Spec 1542 (Arg.all); 1543 1544 begin 1545 Place (' '); 1546 Place_Lower (Normal_File.all); 1547 1548 if Is_Extensionless (Normal_File.all) 1549 and then Command.Defext /= " " 1550 then 1551 Place ('.'); 1552 Place (Command.Defext); 1553 end if; 1554 end; 1555 1556 when Unlimited_Files => 1557 declare 1558 Normal_File : constant String_Access := 1559 To_Canonical_File_Spec 1560 (Arg.all); 1561 1562 File_Is_Wild : Boolean := False; 1563 File_List : String_Access_List_Access; 1564 1565 begin 1566 for J in Arg'Range loop 1567 if Arg (J) = '*' 1568 or else Arg (J) = '%' 1569 then 1570 File_Is_Wild := True; 1571 end if; 1572 end loop; 1573 1574 if File_Is_Wild then 1575 File_List := To_Canonical_File_List 1576 (Arg.all, False); 1577 1578 for J in File_List.all'Range loop 1579 Place (' '); 1580 Place_Lower (File_List.all (J).all); 1581 end loop; 1582 1583 else 1584 Place (' '); 1585 Place_Lower (Normal_File.all); 1586 1587 -- Add extension if not present, except after 1588 -- switch -o. 1589 1590 if Is_Extensionless (Normal_File.all) 1591 and then Command.Defext /= " " 1592 and then not Output_File_Expected 1593 then 1594 Place ('.'); 1595 Place (Command.Defext); 1596 end if; 1597 end if; 1598 1599 Param_Count := Param_Count - 1; 1600 end; 1601 1602 when Other_As_Is => 1603 Place (' '); 1604 Place (Arg.all); 1605 1606 when Unlimited_As_Is => 1607 Place (' '); 1608 Place (Arg.all); 1609 Param_Count := Param_Count - 1; 1610 1611 when Files_Or_Wildcard => 1612 1613 -- Remove spaces from a comma separated list 1614 -- of file names and adjust control variables 1615 -- accordingly. 1616 1617 while Arg_Num < Argument_Count and then 1618 (Argv (Argv'Last) = ',' xor 1619 Argument (Arg_Num + 1) 1620 (Argument (Arg_Num + 1)'First) = ',') 1621 loop 1622 Argv := new String' 1623 (Argv.all & Argument (Arg_Num + 1)); 1624 Arg_Num := Arg_Num + 1; 1625 Arg_Idx := Argv'First; 1626 Next_Arg_Idx := 1627 Get_Arg_End (Argv.all, Arg_Idx); 1628 Arg := new String' 1629 (Argv (Arg_Idx .. Next_Arg_Idx)); 1630 end loop; 1631 1632 -- Parse the comma separated list of VMS 1633 -- filenames and place them on the command 1634 -- line as space separated Unix style 1635 -- filenames. Lower case and add default 1636 -- extension as appropriate. 1637 1638 declare 1639 Arg1_Idx : Integer := Arg'First; 1640 1641 function Get_Arg1_End 1642 (Arg : String; 1643 Arg_Idx : Integer) return Integer; 1644 -- Begins looking at Arg_Idx + 1 and 1645 -- returns the index of the last character 1646 -- before a comma or else the index of the 1647 -- last character in the string Arg. 1648 1649 ------------------ 1650 -- Get_Arg1_End -- 1651 ------------------ 1652 1653 function Get_Arg1_End 1654 (Arg : String; 1655 Arg_Idx : Integer) return Integer 1656 is 1657 begin 1658 for J in Arg_Idx + 1 .. Arg'Last loop 1659 if Arg (J) = ',' then 1660 return J - 1; 1661 end if; 1662 end loop; 1663 1664 return Arg'Last; 1665 end Get_Arg1_End; 1666 1667 begin 1668 loop 1669 declare 1670 Next_Arg1_Idx : 1671 constant Integer := 1672 Get_Arg1_End (Arg.all, Arg1_Idx); 1673 1674 Arg1 : 1675 constant String := 1676 Arg (Arg1_Idx .. Next_Arg1_Idx); 1677 1678 Normal_File : 1679 constant String_Access := 1680 To_Canonical_File_Spec (Arg1); 1681 1682 begin 1683 Place (' '); 1684 Place_Lower (Normal_File.all); 1685 1686 if Is_Extensionless (Normal_File.all) 1687 and then Command.Defext /= " " 1688 then 1689 Place ('.'); 1690 Place (Command.Defext); 1691 end if; 1692 1693 Arg1_Idx := Next_Arg1_Idx + 1; 1694 end; 1695 1696 exit when Arg1_Idx > Arg'Last; 1697 1698 -- Don't allow two or more commas in 1699 -- a row 1700 1701 if Arg (Arg1_Idx) = ',' then 1702 Arg1_Idx := Arg1_Idx + 1; 1703 if Arg1_Idx > Arg'Last or else 1704 Arg (Arg1_Idx) = ',' 1705 then 1706 Put_Line 1707 (Standard_Error, 1708 "Malformed Parameter: " & 1709 Arg.all); 1710 Put (Standard_Error, "usage: "); 1711 Put_Line (Standard_Error, 1712 Command.Usage.all); 1713 raise Error_Exit; 1714 end if; 1715 end if; 1716 1717 end loop; 1718 end; 1719 end case; 1720 end if; 1721 1722 -- Reset Output_File_Expected, in case it was True 1723 1724 Output_File_Expected := False; 1725 1726 -- Qualifier argument 1727 1728 else 1729 Output_File_Expected := False; 1730 1731 Cargs := Command.Name.all = "COMPILE"; 1732 1733 -- This code is too heavily nested, should be 1734 -- separated out as separate subprogram ??? 1735 1736 declare 1737 Sw : Item_Ptr; 1738 SwP : Natural; 1739 P2 : Natural; 1740 Endp : Natural := 0; -- avoid warning 1741 Opt : Item_Ptr; 1742 1743 begin 1744 SwP := Arg'First; 1745 while SwP < Arg'Last 1746 and then Arg (SwP + 1) /= '=' 1747 loop 1748 SwP := SwP + 1; 1749 end loop; 1750 1751 -- At this point, the switch name is in 1752 -- Arg (Arg'First..SwP) and if that is not the 1753 -- whole switch, then there is an equal sign at 1754 -- Arg (SwP + 1) and the rest of Arg is what comes 1755 -- after the equal sign. 1756 1757 -- If make commands are active, see if we have 1758 -- another COMMANDS_TRANSLATION switch belonging 1759 -- to gnatmake. 1760 1761 if Make_Commands_Active /= null then 1762 Sw := 1763 Matching_Name 1764 (Arg (Arg'First .. SwP), 1765 Command.Switches, 1766 Quiet => True); 1767 1768 if Sw /= null 1769 and then Sw.Translation = T_Commands 1770 then 1771 null; 1772 1773 else 1774 Sw := 1775 Matching_Name 1776 (Arg (Arg'First .. SwP), 1777 Make_Commands_Active.Switches, 1778 Quiet => False); 1779 end if; 1780 1781 -- For case of GNAT MAKE or CHOP, if we cannot 1782 -- find the switch, then see if it is a 1783 -- recognized compiler switch instead, and if 1784 -- so process the compiler switch. 1785 1786 elsif Command.Name.all = "MAKE" 1787 or else 1788 Command.Name.all = "CHOP" 1789 then 1790 Sw := 1791 Matching_Name 1792 (Arg (Arg'First .. SwP), 1793 Command.Switches, 1794 Quiet => True); 1795 1796 if Sw = null then 1797 Sw := 1798 Matching_Name 1799 (Arg (Arg'First .. SwP), 1800 Matching_Name 1801 ("COMPILE", Commands).Switches, 1802 Quiet => False); 1803 end if; 1804 1805 -- For all other cases, just search the relevant 1806 -- command. 1807 1808 else 1809 Sw := 1810 Matching_Name 1811 (Arg (Arg'First .. SwP), 1812 Command.Switches, 1813 Quiet => False); 1814 1815 -- Special case for GNAT COMPILE /UNCHECKED... 1816 -- because the corresponding switch --unchecked... is 1817 -- for gnatmake, not for the compiler. 1818 1819 if Cargs 1820 and then Sw.Name.all = "/UNCHECKED_SHARED_LIB_IMPORTS" 1821 then 1822 Cargs := False; 1823 end if; 1824 end if; 1825 1826 if Sw /= null then 1827 if Cargs 1828 and then Sw.Name /= null 1829 and then 1830 (Sw.Name.all = "/PROJECT_FILE" or else 1831 Sw.Name.all = "/MESSAGES_PROJECT_FILE" or else 1832 Sw.Name.all = "/EXTERNAL_REFERENCE") 1833 then 1834 Cargs := False; 1835 end if; 1836 1837 case Sw.Translation is 1838 when T_Direct => 1839 Place_Unix_Switches (Sw.Unix_String); 1840 1841 if SwP < Arg'Last 1842 and then Arg (SwP + 1) = '=' 1843 then 1844 Put (Standard_Error, 1845 "qualifier options ignored: "); 1846 Put_Line (Standard_Error, Arg.all); 1847 end if; 1848 1849 when T_Directories => 1850 if SwP + 1 > Arg'Last then 1851 Put (Standard_Error, 1852 "missing directories for: "); 1853 Put_Line (Standard_Error, Arg.all); 1854 Errors := Errors + 1; 1855 1856 elsif Arg (SwP + 2) /= '(' then 1857 SwP := SwP + 2; 1858 Endp := Arg'Last; 1859 1860 elsif Arg (Arg'Last) /= ')' then 1861 1862 -- Remove spaces from a comma separated 1863 -- list of file names and adjust 1864 -- control variables accordingly. 1865 1866 if Arg_Num < Argument_Count and then 1867 (Argv (Argv'Last) = ',' xor 1868 Argument (Arg_Num + 1) 1869 (Argument (Arg_Num + 1)'First) = ',') 1870 then 1871 Argv := 1872 new String'(Argv.all 1873 & Argument 1874 (Arg_Num + 1)); 1875 Arg_Num := Arg_Num + 1; 1876 Arg_Idx := Argv'First; 1877 Next_Arg_Idx := 1878 Get_Arg_End (Argv.all, Arg_Idx); 1879 Arg := 1880 new String'(Argv (Arg_Idx .. Next_Arg_Idx)); 1881 goto Tryagain_After_Coalesce; 1882 end if; 1883 1884 Put (Standard_Error, 1885 "incorrectly parenthesized " & 1886 "or malformed argument: "); 1887 Put_Line (Standard_Error, Arg.all); 1888 Errors := Errors + 1; 1889 1890 else 1891 SwP := SwP + 3; 1892 Endp := Arg'Last - 1; 1893 end if; 1894 1895 while SwP <= Endp loop 1896 declare 1897 Dir_Is_Wild : Boolean := False; 1898 Dir_Maybe_Is_Wild : Boolean := False; 1899 1900 Dir_List : String_Access_List_Access; 1901 1902 begin 1903 P2 := SwP; 1904 1905 while P2 < Endp 1906 and then Arg (P2 + 1) /= ',' 1907 loop 1908 -- A wildcard directory spec on VMS will 1909 -- contain either * or % or ... 1910 1911 if Arg (P2) = '*' then 1912 Dir_Is_Wild := True; 1913 1914 elsif Arg (P2) = '%' then 1915 Dir_Is_Wild := True; 1916 1917 elsif Dir_Maybe_Is_Wild 1918 and then Arg (P2) = '.' 1919 and then Arg (P2 + 1) = '.' 1920 then 1921 Dir_Is_Wild := True; 1922 Dir_Maybe_Is_Wild := False; 1923 1924 elsif Dir_Maybe_Is_Wild then 1925 Dir_Maybe_Is_Wild := False; 1926 1927 elsif Arg (P2) = '.' 1928 and then Arg (P2 + 1) = '.' 1929 then 1930 Dir_Maybe_Is_Wild := True; 1931 1932 end if; 1933 1934 P2 := P2 + 1; 1935 end loop; 1936 1937 if Dir_Is_Wild then 1938 Dir_List := 1939 To_Canonical_File_List 1940 (Arg (SwP .. P2), True); 1941 1942 for J in Dir_List.all'Range loop 1943 Place_Unix_Switches (Sw.Unix_String); 1944 Place_Lower (Dir_List.all (J).all); 1945 end loop; 1946 1947 else 1948 Place_Unix_Switches (Sw.Unix_String); 1949 Place_Lower 1950 (To_Canonical_Dir_Spec 1951 (Arg (SwP .. P2), False).all); 1952 end if; 1953 1954 SwP := P2 + 2; 1955 end; 1956 end loop; 1957 1958 when T_Directory => 1959 if SwP + 1 > Arg'Last then 1960 Put (Standard_Error, 1961 "missing directory for: "); 1962 Put_Line (Standard_Error, Arg.all); 1963 Errors := Errors + 1; 1964 1965 else 1966 Place_Unix_Switches (Sw.Unix_String); 1967 1968 -- Some switches end in "=", no space here 1969 1970 if Sw.Unix_String 1971 (Sw.Unix_String'Last) /= '=' 1972 then 1973 Place (' '); 1974 end if; 1975 1976 Place_Lower 1977 (To_Canonical_Dir_Spec 1978 (Arg (SwP + 2 .. Arg'Last), False).all); 1979 end if; 1980 1981 when T_File | T_No_Space_File => 1982 if SwP + 2 > Arg'Last then 1983 Put (Standard_Error, "missing file for: "); 1984 Put_Line (Standard_Error, Arg.all); 1985 Errors := Errors + 1; 1986 1987 else 1988 Place_Unix_Switches (Sw.Unix_String); 1989 1990 -- Some switches end in "=", no space here. 1991 1992 if Sw.Translation = T_File 1993 and then Sw.Unix_String 1994 (Sw.Unix_String'Last) /= '=' 1995 then 1996 Place (' '); 1997 end if; 1998 1999 Place_Lower 2000 (To_Canonical_File_Spec 2001 (Arg (SwP + 2 .. Arg'Last)).all); 2002 end if; 2003 2004 when T_Numeric => 2005 if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then 2006 Place_Unix_Switches (Sw.Unix_String); 2007 Place (Arg (SwP + 2 .. Arg'Last)); 2008 2009 else 2010 Put (Standard_Error, "argument for "); 2011 Put (Standard_Error, Sw.Name.all); 2012 Put_Line (Standard_Error, " must be numeric"); 2013 Errors := Errors + 1; 2014 end if; 2015 2016 when T_Alphanumplus => 2017 if OK_Alphanumerplus 2018 (Arg (SwP + 2 .. Arg'Last)) 2019 then 2020 Place_Unix_Switches (Sw.Unix_String); 2021 Place (Arg (SwP + 2 .. Arg'Last)); 2022 2023 else 2024 Put (Standard_Error, "argument for "); 2025 Put (Standard_Error, Sw.Name.all); 2026 Put_Line (Standard_Error, 2027 " must be alphanumeric"); 2028 Errors := Errors + 1; 2029 end if; 2030 2031 when T_String => 2032 2033 -- A String value must be extended to the end of 2034 -- the Argv, otherwise strings like "foo/bar" get 2035 -- split at the slash. 2036 2037 -- The beginning and ending of the string are 2038 -- flagged with embedded nulls which are removed 2039 -- when building the Spawn call. Nulls are use 2040 -- because they won't show up in a /? output. 2041 -- Quotes aren't used because that would make it 2042 -- difficult to embed them. 2043 2044 Place_Unix_Switches (Sw.Unix_String); 2045 2046 if Next_Arg_Idx /= Argv'Last then 2047 Next_Arg_Idx := Argv'Last; 2048 Arg := 2049 new String'(Argv (Arg_Idx .. Next_Arg_Idx)); 2050 2051 SwP := Arg'First; 2052 while SwP < Arg'Last 2053 and then Arg (SwP + 1) /= '=' 2054 loop 2055 SwP := SwP + 1; 2056 end loop; 2057 end if; 2058 2059 Place (ASCII.NUL); 2060 Place (Arg (SwP + 2 .. Arg'Last)); 2061 Place (ASCII.NUL); 2062 2063 when T_Commands => 2064 2065 -- Output -largs/-bargs/-cargs 2066 2067 Place (' '); 2068 Place (Sw.Unix_String 2069 (Sw.Unix_String'First .. 2070 Sw.Unix_String'First + 5)); 2071 2072 if Sw.Unix_String 2073 (Sw.Unix_String'First + 7 .. 2074 Sw.Unix_String'Last) = "MAKE" 2075 then 2076 Make_Commands_Active := null; 2077 2078 else 2079 -- Set source of new commands, also setting this 2080 -- non-null indicates that we are in the special 2081 -- commands mode for processing the -xargs case. 2082 2083 Make_Commands_Active := 2084 Matching_Name 2085 (Sw.Unix_String 2086 (Sw.Unix_String'First + 7 .. 2087 Sw.Unix_String'Last), 2088 Commands); 2089 end if; 2090 2091 when T_Options => 2092 if SwP + 1 > Arg'Last then 2093 Place_Unix_Switches (Sw.Options.Unix_String); 2094 SwP := Endp + 1; 2095 2096 elsif Arg (SwP + 2) /= '(' then 2097 SwP := SwP + 2; 2098 Endp := Arg'Last; 2099 2100 elsif Arg (Arg'Last) /= ')' then 2101 Put (Standard_Error, 2102 "incorrectly parenthesized argument: "); 2103 Put_Line (Standard_Error, Arg.all); 2104 Errors := Errors + 1; 2105 SwP := Endp + 1; 2106 2107 else 2108 SwP := SwP + 3; 2109 Endp := Arg'Last - 1; 2110 end if; 2111 2112 while SwP <= Endp loop 2113 P2 := SwP; 2114 while P2 < Endp 2115 and then Arg (P2 + 1) /= ',' 2116 loop 2117 P2 := P2 + 1; 2118 end loop; 2119 2120 -- Option name is in Arg (SwP .. P2) 2121 2122 Opt := Matching_Name (Arg (SwP .. P2), 2123 Sw.Options); 2124 2125 if Opt /= null then 2126 Place_Unix_Switches (Opt.Unix_String); 2127 end if; 2128 2129 SwP := P2 + 2; 2130 end loop; 2131 2132 when T_Other => 2133 Place_Unix_Switches 2134 (new String'(Sw.Unix_String.all & Arg.all)); 2135 2136 end case; 2137 end if; 2138 end; 2139 end if; 2140 2141 Arg_Idx := Next_Arg_Idx + 1; 2142 end; 2143 2144 exit when Arg_Idx > Argv'Last; 2145 2146 end loop; 2147 2148 if not Is_Open (Arg_File) then 2149 Arg_Num := Arg_Num + 1; 2150 end if; 2151 end Process_Argument; 2152 2153 -------------------- 2154 -- Process_Buffer -- 2155 -------------------- 2156 2157 procedure Process_Buffer (S : String) is 2158 P1, P2 : Natural; 2159 Inside_Nul : Boolean := False; 2160 Arg : String (1 .. 1024); 2161 Arg_Ctr : Natural; 2162 2163 begin 2164 P1 := 1; 2165 while P1 <= S'Last and then S (P1) = ' ' loop 2166 P1 := P1 + 1; 2167 end loop; 2168 2169 Arg_Ctr := 1; 2170 Arg (Arg_Ctr) := S (P1); 2171 2172 while P1 <= S'Last loop 2173 if S (P1) = ASCII.NUL then 2174 if Inside_Nul then 2175 Inside_Nul := False; 2176 else 2177 Inside_Nul := True; 2178 end if; 2179 end if; 2180 2181 if S (P1) = ' ' and then not Inside_Nul then 2182 P1 := P1 + 1; 2183 Arg_Ctr := Arg_Ctr + 1; 2184 Arg (Arg_Ctr) := S (P1); 2185 2186 else 2187 Last_Switches.Increment_Last; 2188 P2 := P1; 2189 2190 while P2 < S'Last 2191 and then (S (P2 + 1) /= ' ' or else 2192 Inside_Nul) 2193 loop 2194 P2 := P2 + 1; 2195 Arg_Ctr := Arg_Ctr + 1; 2196 Arg (Arg_Ctr) := S (P2); 2197 if S (P2) = ASCII.NUL then 2198 Arg_Ctr := Arg_Ctr - 1; 2199 2200 if Inside_Nul then 2201 Inside_Nul := False; 2202 else 2203 Inside_Nul := True; 2204 end if; 2205 end if; 2206 end loop; 2207 2208 Last_Switches.Table (Last_Switches.Last) := 2209 new String'(String (Arg (1 .. Arg_Ctr))); 2210 P1 := P2 + 2; 2211 2212 exit when P1 > S'Last; 2213 2214 Arg_Ctr := 1; 2215 Arg (Arg_Ctr) := S (P1); 2216 end if; 2217 end loop; 2218 end Process_Buffer; 2219 2220 -------------------------------- 2221 -- Validate_Command_Or_Option -- 2222 -------------------------------- 2223 2224 procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is 2225 begin 2226 pragma Assert (N'Length > 0); 2227 2228 for J in N'Range loop 2229 if N (J) = '_' then 2230 pragma Assert (N (J - 1) /= '_'); 2231 null; 2232 else 2233 pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J))); 2234 null; 2235 end if; 2236 end loop; 2237 end Validate_Command_Or_Option; 2238 2239 -------------------------- 2240 -- Validate_Unix_Switch -- 2241 -------------------------- 2242 2243 procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is 2244 begin 2245 if S (S'First) = '`' then 2246 return; 2247 end if; 2248 2249 pragma Assert (S (S'First) = '-' or else S (S'First) = '!'); 2250 2251 for J in S'First + 1 .. S'Last loop 2252 pragma Assert (S (J) /= ' '); 2253 2254 if S (J) = '!' then 2255 pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-'); 2256 null; 2257 end if; 2258 end loop; 2259 end Validate_Unix_Switch; 2260 2261 -------------------- 2262 -- VMS_Conversion -- 2263 -------------------- 2264 2265 procedure VMS_Conversion (The_Command : out Command_Type) is 2266 Result : Command_Type := Undefined; 2267 Result_Set : Boolean := False; 2268 2269 begin 2270 Buffer.Init; 2271 2272 -- First we must preprocess the string form of the command and options 2273 -- list into the internal form that we use. 2274 2275 Preprocess_Command_Data; 2276 2277 -- If no parameters, give complete list of commands 2278 2279 if Argument_Count = 0 then 2280 Output_Version; 2281 New_Line; 2282 Put_Line ("List of available commands"); 2283 New_Line; 2284 2285 while Commands /= null loop 2286 2287 -- No usage for GNAT SYNC 2288 2289 if Commands.Command /= Sync then 2290 Put (Commands.Usage.all); 2291 Set_Col (53); 2292 Put_Line (Commands.Unix_String.all); 2293 end if; 2294 2295 Commands := Commands.Next; 2296 end loop; 2297 2298 raise Normal_Exit; 2299 end if; 2300 2301 -- Loop through arguments 2302 2303 Arg_Num := 1; 2304 while Arg_Num <= Argument_Count loop 2305 Process_Argument (Result); 2306 2307 if not Result_Set then 2308 The_Command := Result; 2309 Result_Set := True; 2310 end if; 2311 end loop; 2312 2313 -- Gross error checking that the number of parameters is correct. 2314 -- Not applicable to Unlimited_Files parameters. 2315 2316 if (Param_Count = Command.Params'Length - 1 2317 and then Command.Params (Param_Count + 1) = Unlimited_Files) 2318 or else Param_Count <= Command.Params'Length 2319 then 2320 null; 2321 2322 else 2323 Put_Line (Standard_Error, 2324 "Parameter count of " 2325 & Integer'Image (Param_Count) 2326 & " not equal to expected " 2327 & Integer'Image (Command.Params'Length)); 2328 Put (Standard_Error, "usage: "); 2329 Put_Line (Standard_Error, Command.Usage.all); 2330 Errors := Errors + 1; 2331 end if; 2332 2333 if Errors > 0 then 2334 raise Error_Exit; 2335 else 2336 -- Prepare arguments for a call to spawn, filtering out 2337 -- embedded nulls place there to delineate strings. 2338 2339 Process_Buffer (String (Buffer.Table (1 .. Buffer.Last))); 2340 2341 if Cargs_Buffer.Last > 1 then 2342 Last_Switches.Append (new String'("-cargs")); 2343 Process_Buffer 2344 (String (Cargs_Buffer.Table (1 .. Cargs_Buffer.Last))); 2345 end if; 2346 end if; 2347 end VMS_Conversion; 2348 2349end VMS_Conv; 2350