X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fvms_conv.adb;h=0772a494f123f3c00d02183225543bfe7ee025de;hb=17052c8f8f63239deccec6d06ff1d9a9ebfc4640;hp=459d3a115187b68c174747177dc81f217262e2c6;hpb=5dad4396b3a90fa1f39465301b0842378fa8083e;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/vms_conv.adb b/gcc/ada/vms_conv.adb index 459d3a11518..0772a494f12 100644 --- a/gcc/ada/vms_conv.adb +++ b/gcc/ada/vms_conv.adb @@ -6,27 +6,28 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -with Gnatvsn; +with Gnatvsn; use Gnatvsn; with Hostparm; -with Osint; use Osint; +with Opt; +with Osint; use Osint; +with Targparm; use Targparm; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Command_Line; use Ada.Command_Line; @@ -34,12 +35,152 @@ with Ada.Text_IO; use Ada.Text_IO; package body VMS_Conv is + ------------------------- + -- Internal Structures -- + ------------------------- + + -- The switches and commands are defined by strings in the previous + -- section so that they are easy to modify, but internally, they are + -- kept in a more conveniently accessible form described in this + -- section. + + -- Commands, command qualifiers and options have a similar common format + -- so that searching for matching names can be done in a common manner. + + type Item_Id is (Id_Command, Id_Switch, Id_Option); + + type Translation_Type is + ( + T_Direct, + -- A qualifier with no options. + -- Example: GNAT MAKE /VERBOSE + + T_Directories, + -- A qualifier followed by a list of directories + -- Example: GNAT COMPILE /SEARCH=([], [.FOO], [.BAR]) + + T_Directory, + -- A qualifier followed by one directory + -- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB] + + T_File, + -- A qualifier followed by a filename + -- Example: GNAT LINK /EXECUTABLE=FOO.EXE + + T_No_Space_File, + -- A qualifier followed by a filename + -- Example: GNAT MAKE /PROJECT_FILE=PRJ.GPR + + T_Numeric, + -- A qualifier followed by a numeric value. + -- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39 + + T_String, + -- A qualifier followed by a quoted string. Only used by + -- /IDENTIFICATION qualifier. + -- Example: GNAT LINK /IDENTIFICATION="3.14a1 version" + + T_Options, + -- A qualifier followed by a list of options. + -- Example: GNAT COMPILE /REPRESENTATION_INFO=(ARRAYS,OBJECTS) + + T_Commands, + -- A qualifier followed by a list. Only used for + -- MAKE /COMPILER_QUALIFIERS /BINDER_QUALIFIERS /LINKER_QUALIFIERS + -- (gnatmake -cargs -bargs -largs ) + -- Example: GNAT MAKE ... /LINKER_QUALIFIERS /VERBOSE FOOBAR.OBJ + + T_Other, + -- A qualifier passed directly to the linker. Only used + -- for LINK and SHARED if no other match is found. + -- Example: GNAT LINK FOO.ALI /SYSSHR + + T_Alphanumplus + -- A qualifier followed by a legal linker symbol prefix. Only used + -- for BIND /BUILD_LIBRARY (gnatbind -Lxyz). + -- Example: GNAT BIND /BUILD_LIBRARY=foobar + ); + + type Item (Id : Item_Id); + type Item_Ptr is access all Item; + + type Item (Id : Item_Id) is record + Name : String_Ptr; + -- Name of the command, switch (with slash) or option + + Next : Item_Ptr; + -- Pointer to next item on list, always has the same Id value + + Command : Command_Type := Undefined; + + Unix_String : String_Ptr := null; + -- Corresponding Unix string. For a command, this is the unix command + -- name and possible default switches. For a switch or option it is + -- the unix switch string. + + case Id is + + when Id_Command => + + Switches : Item_Ptr; + -- Pointer to list of switch items for the command, linked + -- through the Next fields with null terminating the list. + + Usage : String_Ptr; + -- Usage information, used only for errors and the default + -- list of commands output. + + Params : Parameter_Ref; + -- Array of parameters + + Defext : String (1 .. 3); + -- Default extension. If non-blank, then this extension is + -- supplied by default as the extension for any file parameter + -- which does not have an extension already. + + when Id_Switch => + + Translation : Translation_Type; + -- Type of switch translation. For all cases, except Options, + -- this is the only field needed, since the Unix translation + -- is found in Unix_String. + + Options : Item_Ptr; + -- For the Options case, this field is set to point to a list + -- of options item (for this case Unix_String is null in the + -- main switch item). The end of the list is marked by null. + + when Id_Option => + + null; + -- No special fields needed, since Name and Unix_String are + -- sufficient to completely described an option. + + end case; + end record; + + subtype Command_Item is Item (Id_Command); + subtype Switch_Item is Item (Id_Switch); + subtype Option_Item is Item (Id_Option); + + Keep_Temps_Option : constant Item_Ptr := + new Item' + (Id => Id_Option, + Name => + new String'("/KEEP_TEMPORARY_FILES"), + Next => null, + Command => Undefined, + Unix_String => null); + Param_Count : Natural := 0; -- Number of parameter arguments so far Arg_Num : Natural; -- Argument number + Arg_File : Ada.Text_IO.File_Type; + -- A file where arguments are read from + Commands : Item_Ptr; -- Pointer to head of list of command items, one for each command, with -- the end of the list marked by a null pointer. @@ -55,13 +196,30 @@ package body VMS_Conv is -- if a COMMANDS_TRANSLATION switch has been encountered while processing -- a MAKE Command. + Output_File_Expected : Boolean := False; + -- True for GNAT LINK after -o switch, so that the ".ali" extension is + -- not added to the executable file name. + package Buffer is new Table.Table (Table_Component_Type => Character, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => 4096, - Table_Increment => 2, + Table_Increment => 100, Table_Name => "Buffer"); + -- Table to store the command to be used + + package Cargs_Buffer is new Table.Table + (Table_Component_Type => Character, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 4096, + Table_Increment => 100, + Table_Name => "Cargs_Buffer"); + -- Table to store the compiler switches for GNAT COMPILE + + Cargs : Boolean := False; + -- When True, commands should go to Cargs_Buffer instead of Buffer table function Init_Object_Dirs return Argument_List; -- Get the list of the object directories @@ -72,10 +230,10 @@ package body VMS_Conv is -- the allocated result on the heap. function Is_Extensionless (F : String) return Boolean; - -- Returns true if the filename has no extension. + -- Returns true if the filename has no extension function Match (S1, S2 : String) return Boolean; - -- Determines whether S1 and S2 match. This is a case insensitive match. + -- Determines whether S1 and S2 match (this is a case insensitive match) function Match_Prefix (S1, S2 : String) return Boolean; -- Determines whether S1 matches a prefix of S2. This is also a case @@ -116,9 +274,21 @@ package body VMS_Conv is procedure Place_Unix_Switches (S : VMS_Data.String_Ptr); -- Given a unix switch string, place corresponding switches in Buffer, - -- updating Ptr appropriatelly. Note that in the case of use of ! the + -- updating Ptr appropriately. Note that in the case of use of ! the -- result may be to remove a previously placed switch. + procedure Preprocess_Command_Data; + -- Preprocess the string form of the command and options list into the + -- internal form. + + procedure Process_Argument (The_Command : in out Command_Type); + -- Process one argument from the command line, or one line from + -- from a command line file. For the first call, set The_Command. + + procedure Process_Buffer (S : String); + -- Process the characters in the Buffer table or the Cargs_Buffer table + -- to convert these into arguments. + procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr); -- Check that N is a valid command or option name, i.e. that it is of the -- form of an Ada identifier with upper case letters and underscores. @@ -160,7 +330,7 @@ package body VMS_Conv is Object_Dirs := Object_Dirs + 1; Object_Dir (Object_Dirs) := new String'("-lgnat"); - if Hostparm.OpenVMS then + if OpenVMS_On_Target then Object_Dirs := Object_Dirs + 1; Object_Dir (Object_Dirs) := new String'("-ldecgnat"); end if; @@ -182,7 +352,7 @@ package body VMS_Conv is Unixcmd => new S'("gnatbind"), Unixsws => null, Switches => Bind_Switches'Access, - Params => new Parameter_Array'(1 => File), + Params => new Parameter_Array'(1 => Unlimited_Files), Defext => "ali"), Chop => @@ -217,6 +387,26 @@ package body VMS_Conv is Params => new Parameter_Array'(1 => Files_Or_Wildcard), Defext => " "), + Check => + (Cname => new S'("CHECK"), + Usage => new S'("GNAT CHECK name /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatcheck"), + Unixsws => null, + Switches => Check_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => " "), + + Sync => + (Cname => new S'("SYNC"), + Usage => new S'("GNAT SYNC name /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatsync"), + Unixsws => null, + Switches => Sync_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => " "), + Elim => (Cname => new S'("ELIM"), Usage => new S'("GNAT ELIM name /qualifiers"), @@ -249,17 +439,6 @@ package body VMS_Conv is Params => new Parameter_Array'(1 => File), Defext => " "), - Library => - (Cname => new S'("LIBRARY"), - Usage => new S'("GNAT LIBRARY /[CREATE | SET | DELETE]" - & "=directory [/CONFIG=file]"), - VMS_Only => True, - Unixcmd => new S'("gnatlbr"), - Unixsws => null, - Switches => Lbr_Switches'Access, - Params => new Parameter_Array'(1 .. 0 => File), - Defext => " "), - Link => (Cname => new S'("LINK"), Usage => new S'("GNAT LINK file[.ali]" @@ -293,6 +472,16 @@ package body VMS_Conv is Params => new Parameter_Array'(1 => Unlimited_Files), Defext => " "), + Metric => + (Cname => new S'("METRIC"), + Usage => new S'("GNAT METRIC /qualifiers source_file"), + VMS_Only => False, + Unixcmd => new S'("gnatmetric"), + Unixsws => null, + Switches => Metric_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => " "), + Name => (Cname => new S'("NAME"), Usage => new S'("GNAT NAME /qualifiers naming-pattern " @@ -322,7 +511,7 @@ package body VMS_Conv is Unixcmd => new S'("gnatpp"), Unixsws => null, Switches => Pretty_Switches'Access, - Params => new Parameter_Array'(1 => File), + Params => new Parameter_Array'(1 => Unlimited_Files), Defext => " "), Shared => @@ -337,6 +526,16 @@ package body VMS_Conv is Params => new Parameter_Array'(1 => Unlimited_Files), Defext => " "), + Stack => + (Cname => new S'("STACK"), + Usage => new S'("GNAT STACK /qualifiers ci_files"), + VMS_Only => False, + Unixcmd => new S'("gnatstack"), + Unixsws => null, + Switches => Stack_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => "ci" & ASCII.NUL), + Stub => (Cname => new S'("STUB"), Usage => new S'("GNAT STUB file [directory]/qualifiers"), @@ -615,9 +814,16 @@ package body VMS_Conv is procedure Output_Version is begin - Put ("GNAT "); - Put (Gnatvsn.Gnat_Version_String); - Put_Line (" Copyright 1996-2004 Free Software Foundation, Inc."); + if AAMP_On_Target then + Put ("GNAAMP "); + else + Put ("GNAT "); + end if; + + Put_Line (Gnatvsn.Gnat_Version_String); + Put_Line ("Copyright 1996-" & + Current_Year & + ", Free Software Foundation, Inc."); end Output_Version; ----------- @@ -626,8 +832,11 @@ package body VMS_Conv is procedure Place (C : Character) is begin - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := C; + if Cargs then + Cargs_Buffer.Append (C); + else + Buffer.Append (C); + end if; end Place; procedure Place (S : String) is @@ -736,61 +945,12 @@ package body VMS_Conv is end loop; end Place_Unix_Switches; - -------------------------------- - -- Validate_Command_Or_Option -- - -------------------------------- - - procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is - begin - pragma Assert (N'Length > 0); - - for J in N'Range loop - if N (J) = '_' then - pragma Assert (N (J - 1) /= '_'); - null; - else - pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J))); - null; - end if; - end loop; - end Validate_Command_Or_Option; - - -------------------------- - -- Validate_Unix_Switch -- - -------------------------- - - procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is - begin - if S (S'First) = '`' then - return; - end if; - - pragma Assert (S (S'First) = '-' or else S (S'First) = '!'); - - for J in S'First + 1 .. S'Last loop - pragma Assert (S (J) /= ' '); - - if S (J) = '!' then - pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-'); - null; - end if; - end loop; - end Validate_Unix_Switch; - - -------------------- - -- VMS_Conversion -- - -------------------- - - -- This function is *far* too long and *far* too heavily nested, it - -- needs procedural abstraction ??? + ----------------------------- + -- Preprocess_Command_Data -- + ----------------------------- - procedure VMS_Conversion (The_Command : out Command_Type) is + procedure Preprocess_Command_Data is begin - Buffer.Init; - - -- First we must preprocess the string form of the command and options - -- list into the internal form that we use. - for C in Real_Command_Type loop declare Command : constant Item_Ptr := new Command_Item; @@ -871,7 +1031,7 @@ package body VMS_Conv is -- Process switch string, first get name - while SS (P) /= ' ' and SS (P) /= '=' loop + while SS (P) /= ' ' and then SS (P) /= '=' loop P := P + 1; end loop; @@ -1016,288 +1176,498 @@ package body VMS_Conv is end loop; end; end loop; + end Preprocess_Command_Data; - -- If no parameters, give complete list of commands - - if Argument_Count = 0 then - Output_Version; - New_Line; - Put_Line ("List of available commands"); - New_Line; + ---------------------- + -- Process_Argument -- + ---------------------- - while Commands /= null loop - Put (Commands.Usage.all); - Set_Col (53); - Put_Line (Commands.Unix_String.all); - Commands := Commands.Next; + procedure Process_Argument (The_Command : in out Command_Type) is + Argv : String_Access; + Arg_Idx : Integer; + + function Get_Arg_End + (Argv : String; + Arg_Idx : Integer) return Integer; + -- Begins looking at Arg_Idx + 1 and returns the index of the + -- last character before a slash or else the index of the last + -- character in the string Argv. + + ----------------- + -- Get_Arg_End -- + ----------------- + + function Get_Arg_End + (Argv : String; + Arg_Idx : Integer) return Integer + is + begin + for J in Arg_Idx + 1 .. Argv'Last loop + if Argv (J) = '/' then + return J - 1; + end if; end loop; - raise Normal_Exit; - end if; + return Argv'Last; + end Get_Arg_End; - Arg_Num := 1; + -- Start of processing for Process_Argument - -- Loop through arguments + begin + Cargs := False; - while Arg_Num <= Argument_Count loop + -- If an argument file is open, read the next non empty line - Process_Argument : declare - Argv : String_Access; - Arg_Idx : Integer; - - function Get_Arg_End - (Argv : String; - Arg_Idx : Integer) return Integer; - -- Begins looking at Arg_Idx + 1 and returns the index of the - -- last character before a slash or else the index of the last - -- character in the string Argv. - - ----------------- - -- Get_Arg_End -- - ----------------- - - function Get_Arg_End - (Argv : String; - Arg_Idx : Integer) return Integer - is - begin - for J in Arg_Idx + 1 .. Argv'Last loop - if Argv (J) = '/' then - return J - 1; - end if; - end loop; + if Is_Open (Arg_File) then + declare + Line : String (1 .. 256); + Last : Natural; + begin + loop + Get_Line (Arg_File, Line, Last); + exit when Last /= 0 or else End_Of_File (Arg_File); + end loop; - return Argv'Last; - end Get_Arg_End; + -- If the end of the argument file has been reached, close it - -- Start of processing for Process_Argument + if End_Of_File (Arg_File) then + Close (Arg_File); - begin - Argv := new String'(Argument (Arg_Num)); - Arg_Idx := Argv'First; + -- If the last line was empty, return after increasing Arg_Num + -- to go to the next argument on the comment line. - <> - loop - declare - Next_Arg_Idx : Integer; - Arg : String_Access; + if Last = 0 then + Arg_Num := Arg_Num + 1; + return; + end if; + end if; - begin - Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); - Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx)); + Argv := new String'(Line (1 .. Last)); + Arg_Idx := 1; - -- The first one must be a command name + if Argv (1) = '@' then + Put_Line (Standard_Error, "argument file cannot contain @cmd"); + raise Error_Exit; + end if; + end; - if Arg_Num = 1 and then Arg_Idx = Argv'First then - Command := Matching_Name (Arg.all, Commands); + else + -- No argument file is open, get the argument on the command line - if Command = null then - raise Error_Exit; - end if; + Argv := new String'(Argument (Arg_Num)); + Arg_Idx := Argv'First; - The_Command := Command.Command; + -- Check if this is the specification of an argument file - -- Give usage information if only command given + if Argv (Arg_Idx) = '@' then + -- The first argument on the command line cannot be an argument + -- file. - if Argument_Count = 1 - and then Next_Arg_Idx = Argv'Last - then - Output_Version; - New_Line; - Put_Line - ("List of available qualifiers and options"); - New_Line; + if Arg_Num = 1 then + Put_Line + (Standard_Error, + "Cannot specify argument line before command"); + raise Error_Exit; + end if; - Put (Command.Usage.all); - Set_Col (53); - Put_Line (Command.Unix_String.all); + -- Open the file, after conversion of the name to canonical form. + -- Fail if file is not found. - declare - Sw : Item_Ptr := Command.Switches; + declare + Canonical_File_Name : String_Access := + To_Canonical_File_Spec (Argv (Arg_Idx + 1 .. Argv'Last)); + begin + Open (Arg_File, In_File, Canonical_File_Name.all); + Free (Canonical_File_Name); + return; + + exception + when others => + Put (Standard_Error, "Cannot open argument file """); + Put (Standard_Error, Argv (Arg_Idx + 1 .. Argv'Last)); + Put_Line (Standard_Error, """"); + raise Error_Exit; + end; + end if; + end if; - begin - while Sw /= null loop - Put (" "); - Put (Sw.Name.all); + <> + loop + declare + Next_Arg_Idx : Integer; + Arg : String_Access; - case Sw.Translation is + begin + Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); + Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx)); - when T_Other => - Set_Col (53); - Put_Line (Sw.Unix_String.all & - "/"); + -- The first one must be a command name - when T_Direct => - Set_Col (53); - Put_Line (Sw.Unix_String.all); + if Arg_Num = 1 and then Arg_Idx = Argv'First then + Command := Matching_Name (Arg.all, Commands); - when T_Directories => - Put ("=(direc,direc,..direc)"); - Set_Col (53); - Put (Sw.Unix_String.all); - Put (" direc "); - Put (Sw.Unix_String.all); - Put_Line (" direc ..."); + if Command = null then + raise Error_Exit; + end if; - when T_Directory => - Put ("=directory"); - Set_Col (53); - Put (Sw.Unix_String.all); + The_Command := Command.Command; + Output_File_Expected := False; - if Sw.Unix_String (Sw.Unix_String'Last) - /= '=' - then - Put (' '); - end if; + -- Give usage information if only command given - Put_Line ("directory "); + if Argument_Count = 1 + and then Next_Arg_Idx = Argv'Last + then + Output_Version; + New_Line; + Put_Line + ("List of available qualifiers and options"); + New_Line; + + Put (Command.Usage.all); + Set_Col (53); + Put_Line (Command.Unix_String.all); + + declare + Sw : Item_Ptr := Command.Switches; + + begin + while Sw /= null loop + Put (" "); + Put (Sw.Name.all); + + case Sw.Translation is + + when T_Other => + Set_Col (53); + Put_Line (Sw.Unix_String.all & + "/"); + + when T_Direct => + Set_Col (53); + Put_Line (Sw.Unix_String.all); + + when T_Directories => + Put ("=(direc,direc,..direc)"); + Set_Col (53); + Put (Sw.Unix_String.all); + Put (" direc "); + Put (Sw.Unix_String.all); + Put_Line (" direc ..."); + + when T_Directory => + Put ("=directory"); + Set_Col (53); + Put (Sw.Unix_String.all); + + if Sw.Unix_String (Sw.Unix_String'Last) + /= '=' + then + Put (' '); + end if; + + Put_Line ("directory "); + + when T_File | T_No_Space_File => + Put ("=file"); + Set_Col (53); + Put (Sw.Unix_String.all); + + if Sw.Translation = T_File + and then Sw.Unix_String + (Sw.Unix_String'Last) /= '=' + then + Put (' '); + end if; + + Put_Line ("file "); + + when T_Numeric => + Put ("=nnn"); + Set_Col (53); + + if Sw.Unix_String + (Sw.Unix_String'First) = '`' + then + Put (Sw.Unix_String + (Sw.Unix_String'First + 1 + .. Sw.Unix_String'Last)); + else + Put (Sw.Unix_String.all); + end if; + + Put_Line ("nnn"); + + when T_Alphanumplus => + Put ("=xyz"); + Set_Col (53); + + if Sw.Unix_String + (Sw.Unix_String'First) = '`' + then + Put (Sw.Unix_String + (Sw.Unix_String'First + 1 + .. Sw.Unix_String'Last)); + else + Put (Sw.Unix_String.all); + end if; + + Put_Line ("xyz"); + + when T_String => + Put ("="); + Put ('"'); + Put (""); + Put ('"'); + Set_Col (53); + + Put (Sw.Unix_String.all); + + if Sw.Unix_String + (Sw.Unix_String'Last) /= '=' + then + Put (' '); + end if; + + Put (""); + New_Line; + + when T_Commands => + Put (" (switches for "); + Put (Sw.Unix_String + (Sw.Unix_String'First + 7 + .. Sw.Unix_String'Last)); + Put (')'); + Set_Col (53); + Put (Sw.Unix_String + (Sw.Unix_String'First + .. Sw.Unix_String'First + 5)); + Put_Line (" switches"); + + when T_Options => + declare + Opt : Item_Ptr := Sw.Options; - when T_File | T_No_Space_File => - Put ("=file"); - Set_Col (53); - Put (Sw.Unix_String.all); + begin + Put_Line ("=(option,option..)"); - if Sw.Translation = T_File - and then Sw.Unix_String - (Sw.Unix_String'Last) /= '=' - then - Put (' '); - end if; + while Opt /= null loop + Put (" "); + Put (Opt.Name.all); - Put_Line ("file "); + if Opt = Sw.Options then + Put (" (D)"); + end if; - when T_Numeric => - Put ("=nnn"); Set_Col (53); + Put_Line (Opt.Unix_String.all); + Opt := Opt.Next; + end loop; + end; - if Sw.Unix_String - (Sw.Unix_String'First) = '`' - then - Put (Sw.Unix_String - (Sw.Unix_String'First + 1 - .. Sw.Unix_String'Last)); - else - Put (Sw.Unix_String.all); - end if; + end case; - Put_Line ("nnn"); + Sw := Sw.Next; + end loop; + end; - when T_Alphanumplus => - Put ("=xyz"); - Set_Col (53); + raise Normal_Exit; + end if; - if Sw.Unix_String - (Sw.Unix_String'First) = '`' - then - Put (Sw.Unix_String - (Sw.Unix_String'First + 1 - .. Sw.Unix_String'Last)); - else - Put (Sw.Unix_String.all); - end if; + -- Special handling for internal debugging switch /? - Put_Line ("xyz"); + elsif Arg.all = "/?" then + Display_Command := True; + Output_File_Expected := False; - when T_String => - Put ("="); - Put ('"'); - Put (""); - Put ('"'); - Set_Col (53); + -- Special handling of internal option /KEEP_TEMPORARY_FILES - Put (Sw.Unix_String.all); + elsif Arg'Length >= 7 + and then Matching_Name + (Arg.all, Keep_Temps_Option, True) /= null + then + Opt.Keep_Temporary_Files := True; - if Sw.Unix_String - (Sw.Unix_String'Last) /= '=' - then - Put (' '); - end if; + -- Copy -switch unchanged, as well as +rule - Put (""); - New_Line; + elsif Arg (Arg'First) = '-' or else Arg (Arg'First) = '+' then + Place (' '); + Place (Arg.all); - when T_Commands => - Put (" (switches for "); - Put (Sw.Unix_String - (Sw.Unix_String'First + 7 - .. Sw.Unix_String'Last)); - Put (')'); - Set_Col (53); - Put (Sw.Unix_String - (Sw.Unix_String'First - .. Sw.Unix_String'First + 5)); - Put_Line (" switches"); + -- Set Output_File_Expected for the next argument - when T_Options => - declare - Opt : Item_Ptr := Sw.Options; + Output_File_Expected := + Arg.all = "-o" and then The_Command = Link; - begin - Put_Line ("=(option,option..)"); + -- Copy quoted switch with quotes stripped - while Opt /= null loop - Put (" "); - Put (Opt.Name.all); + elsif Arg (Arg'First) = '"' then + if Arg (Arg'Last) /= '"' then + Put (Standard_Error, "misquoted argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; - if Opt = Sw.Options then - Put (" (D)"); - end if; + else + Place (' '); + Place (Arg (Arg'First + 1 .. Arg'Last - 1)); + end if; - Set_Col (53); - Put_Line (Opt.Unix_String.all); - Opt := Opt.Next; - end loop; - end; + Output_File_Expected := False; - end case; + -- Parameter Argument - Sw := Sw.Next; - end loop; + elsif Arg (Arg'First) /= '/' + and then Make_Commands_Active = null + then + Param_Count := Param_Count + 1; + + if Param_Count <= Command.Params'Length then + + case Command.Params (Param_Count) is + + when File | Optional_File => + declare + Normal_File : constant String_Access := + To_Canonical_File_Spec + (Arg.all); + + begin + Place (' '); + Place_Lower (Normal_File.all); + + if Is_Extensionless (Normal_File.all) + and then Command.Defext /= " " + then + Place ('.'); + Place (Command.Defext); + end if; end; - raise Normal_Exit; - end if; + when Unlimited_Files => + declare + Normal_File : constant String_Access := + To_Canonical_File_Spec + (Arg.all); + + File_Is_Wild : Boolean := False; + File_List : String_Access_List_Access; - -- Special handling for internal debugging switch /? + begin + for J in Arg'Range loop + if Arg (J) = '*' + or else Arg (J) = '%' + then + File_Is_Wild := True; + end if; + end loop; - elsif Arg.all = "/?" then - Display_Command := True; + if File_Is_Wild then + File_List := To_Canonical_File_List + (Arg.all, False); - -- Copy -switch unchanged + for J in File_List.all'Range loop + Place (' '); + Place_Lower (File_List.all (J).all); + end loop; - elsif Arg (Arg'First) = '-' then - Place (' '); - Place (Arg.all); + else + Place (' '); + Place_Lower (Normal_File.all); + + -- Add extension if not present, except after + -- switch -o. + + if Is_Extensionless (Normal_File.all) + and then Command.Defext /= " " + and then not Output_File_Expected + then + Place ('.'); + Place (Command.Defext); + end if; + end if; - -- Copy quoted switch with quotes stripped + Param_Count := Param_Count - 1; + end; - elsif Arg (Arg'First) = '"' then - if Arg (Arg'Last) /= '"' then - Put (Standard_Error, "misquoted argument: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; + when Other_As_Is => + Place (' '); + Place (Arg.all); - else + when Unlimited_As_Is => Place (' '); - Place (Arg (Arg'First + 1 .. Arg'Last - 1)); - end if; + Place (Arg.all); + Param_Count := Param_Count - 1; + + when Files_Or_Wildcard => - -- Parameter Argument + -- Remove spaces from a comma separated list + -- of file names and adjust control variables + -- accordingly. - elsif Arg (Arg'First) /= '/' - and then Make_Commands_Active = null - then - Param_Count := Param_Count + 1; + while Arg_Num < Argument_Count and then + (Argv (Argv'Last) = ',' xor + Argument (Arg_Num + 1) + (Argument (Arg_Num + 1)'First) = ',') + loop + Argv := new String' + (Argv.all & Argument (Arg_Num + 1)); + Arg_Num := Arg_Num + 1; + Arg_Idx := Argv'First; + Next_Arg_Idx := + Get_Arg_End (Argv.all, Arg_Idx); + Arg := new String' + (Argv (Arg_Idx .. Next_Arg_Idx)); + end loop; - if Param_Count <= Command.Params'Length then + -- Parse the comma separated list of VMS + -- filenames and place them on the command + -- line as space separated Unix style + -- filenames. Lower case and add default + -- extension as appropriate. + + declare + Arg1_Idx : Integer := Arg'First; + + function Get_Arg1_End + (Arg : String; + Arg_Idx : Integer) return Integer; + -- Begins looking at Arg_Idx + 1 and + -- returns the index of the last character + -- before a comma or else the index of the + -- last character in the string Arg. + + ------------------ + -- Get_Arg1_End -- + ------------------ + + function Get_Arg1_End + (Arg : String; + Arg_Idx : Integer) return Integer + is + begin + for J in Arg_Idx + 1 .. Arg'Last loop + if Arg (J) = ',' then + return J - 1; + end if; + end loop; - case Command.Params (Param_Count) is + return Arg'Last; + end Get_Arg1_End; - when File | Optional_File => + begin + loop declare - Normal_File : constant String_Access := - To_Canonical_File_Spec - (Arg.all); + Next_Arg1_Idx : + constant Integer := + Get_Arg1_End (Arg.all, Arg1_Idx); + + Arg1 : + constant String := + Arg (Arg1_Idx .. Next_Arg1_Idx); + + Normal_File : + constant String_Access := + To_Canonical_File_Spec (Arg1); begin Place (' '); @@ -1309,584 +1679,620 @@ package body VMS_Conv is Place ('.'); Place (Command.Defext); end if; + + Arg1_Idx := Next_Arg1_Idx + 1; end; - when Unlimited_Files => - declare - Normal_File : constant String_Access := - To_Canonical_File_Spec - (Arg.all); + exit when Arg1_Idx > Arg'Last; - File_Is_Wild : Boolean := False; - File_List : String_Access_List_Access; + -- Don't allow two or more commas in + -- a row - begin - for J in Arg'Range loop - if Arg (J) = '*' - or else Arg (J) = '%' - then - File_Is_Wild := True; - end if; - end loop; + if Arg (Arg1_Idx) = ',' then + Arg1_Idx := Arg1_Idx + 1; + if Arg1_Idx > Arg'Last or else + Arg (Arg1_Idx) = ',' + then + Put_Line + (Standard_Error, + "Malformed Parameter: " & + Arg.all); + Put (Standard_Error, "usage: "); + Put_Line (Standard_Error, + Command.Usage.all); + raise Error_Exit; + end if; + end if; - if File_Is_Wild then - File_List := To_Canonical_File_List - (Arg.all, False); + end loop; + end; + end case; + end if; - for J in File_List.all'Range loop - Place (' '); - Place_Lower (File_List.all (J).all); - end loop; + -- Reset Output_File_Expected, in case it was True - else - Place (' '); - Place_Lower (Normal_File.all); + Output_File_Expected := False; - if Is_Extensionless (Normal_File.all) - and then Command.Defext /= " " - then - Place ('.'); - Place (Command.Defext); - end if; - end if; + -- Qualifier argument - Param_Count := Param_Count - 1; - end; + else + Output_File_Expected := False; - when Other_As_Is => - Place (' '); - Place (Arg.all); + Cargs := Command.Name.all = "COMPILE"; - when Unlimited_As_Is => - Place (' '); - Place (Arg.all); - Param_Count := Param_Count - 1; + -- This code is too heavily nested, should be + -- separated out as separate subprogram ??? + + declare + Sw : Item_Ptr; + SwP : Natural; + P2 : Natural; + Endp : Natural := 0; -- avoid warning! + Opt : Item_Ptr; + + begin + SwP := Arg'First; + while SwP < Arg'Last + and then Arg (SwP + 1) /= '=' + loop + SwP := SwP + 1; + end loop; - when Files_Or_Wildcard => + -- At this point, the switch name is in + -- Arg (Arg'First..SwP) and if that is not the + -- whole switch, then there is an equal sign at + -- Arg (SwP + 1) and the rest of Arg is what comes + -- after the equal sign. + + -- If make commands are active, see if we have + -- another COMMANDS_TRANSLATION switch belonging + -- to gnatmake. + + if Make_Commands_Active /= null then + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Command.Switches, + Quiet => True); + + if Sw /= null + and then Sw.Translation = T_Commands + then + null; + + else + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Make_Commands_Active.Switches, + Quiet => False); + end if; + + -- For case of GNAT MAKE or CHOP, if we cannot + -- find the switch, then see if it is a + -- recognized compiler switch instead, and if + -- so process the compiler switch. + + elsif Command.Name.all = "MAKE" + or else Command.Name.all = "CHOP" then + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Command.Switches, + Quiet => True); + + if Sw = null then + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Matching_Name + ("COMPILE", Commands).Switches, + Quiet => False); + end if; - -- Remove spaces from a comma separated list - -- of file names and adjust control variables - -- accordingly. + -- For all other cases, just search the relevant + -- command. - while Arg_Num < Argument_Count and then + else + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Command.Switches, + Quiet => False); + end if; + + if Sw /= null then + if Cargs + and then Sw.Name /= null + and then + (Sw.Name.all = "/PROJECT_FILE" or else + Sw.Name.all = "/MESSAGES_PROJECT_FILE" or else + Sw.Name.all = "/EXTERNAL_REFERENCE") + then + Cargs := False; + end if; + + case Sw.Translation is + when T_Direct => + Place_Unix_Switches (Sw.Unix_String); + if SwP < Arg'Last + and then Arg (SwP + 1) = '=' + then + Put (Standard_Error, + "qualifier options ignored: "); + Put_Line (Standard_Error, Arg.all); + end if; + + when T_Directories => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing directories for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + elsif Arg (SwP + 2) /= '(' then + SwP := SwP + 2; + Endp := Arg'Last; + + elsif Arg (Arg'Last) /= ')' then + + -- Remove spaces from a comma separated + -- list of file names and adjust + -- control variables accordingly. + + if Arg_Num < Argument_Count and then (Argv (Argv'Last) = ',' xor Argument (Arg_Num + 1) (Argument (Arg_Num + 1)'First) = ',') - loop - Argv := new String' - (Argv.all & Argument (Arg_Num + 1)); + then + Argv := + new String'(Argv.all + & Argument + (Arg_Num + 1)); Arg_Num := Arg_Num + 1; Arg_Idx := Argv'First; Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); Arg := new String' (Argv (Arg_Idx .. Next_Arg_Idx)); - end loop; + goto Tryagain_After_Coalesce; + end if; - -- Parse the comma separated list of VMS - -- filenames and place them on the command - -- line as space separated Unix style - -- filenames. Lower case and add default - -- extension as appropriate. + Put (Standard_Error, + "incorrectly parenthesized " & + "or malformed argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + else + SwP := SwP + 3; + Endp := Arg'Last - 1; + end if; + + while SwP <= Endp loop declare - Arg1_Idx : Integer := Arg'First; - - function Get_Arg1_End - (Arg : String; - Arg_Idx : Integer) return Integer; - -- Begins looking at Arg_Idx + 1 and - -- returns the index of the last character - -- before a comma or else the index of the - -- last character in the string Arg. - - ------------------ - -- Get_Arg1_End -- - ------------------ - - function Get_Arg1_End - (Arg : String; - Arg_Idx : Integer) return Integer - is - begin - for J in Arg_Idx + 1 .. Arg'Last loop - if Arg (J) = ',' then - return J - 1; - end if; - end loop; + Dir_Is_Wild : Boolean := False; + Dir_Maybe_Is_Wild : Boolean := False; - return Arg'Last; - end Get_Arg1_End; + Dir_List : String_Access_List_Access; begin + P2 := SwP; + + while P2 < Endp + and then Arg (P2 + 1) /= ',' loop - declare - Next_Arg1_Idx : - constant Integer := - Get_Arg1_End (Arg.all, Arg1_Idx); - - Arg1 : - constant String := - Arg (Arg1_Idx .. Next_Arg1_Idx); - - Normal_File : - constant String_Access := - To_Canonical_File_Spec (Arg1); - - begin - Place (' '); - Place_Lower (Normal_File.all); - - if Is_Extensionless (Normal_File.all) - and then Command.Defext /= " " - then - Place ('.'); - Place (Command.Defext); - end if; - - Arg1_Idx := Next_Arg1_Idx + 1; - end; - - exit when Arg1_Idx > Arg'Last; - - -- Don't allow two or more commas in - -- a row - - if Arg (Arg1_Idx) = ',' then - Arg1_Idx := Arg1_Idx + 1; - if Arg1_Idx > Arg'Last or else - Arg (Arg1_Idx) = ',' - then - Put_Line - (Standard_Error, - "Malformed Parameter: " & - Arg.all); - Put (Standard_Error, "usage: "); - Put_Line (Standard_Error, - Command.Usage.all); - raise Error_Exit; - end if; + -- A wildcard directory spec on + -- VMS will contain either * or + -- % or ... + + if Arg (P2) = '*' then + Dir_Is_Wild := True; + + elsif Arg (P2) = '%' then + Dir_Is_Wild := True; + + elsif Dir_Maybe_Is_Wild + and then Arg (P2) = '.' + and then Arg (P2 + 1) = '.' + then + Dir_Is_Wild := True; + Dir_Maybe_Is_Wild := False; + + elsif Dir_Maybe_Is_Wild then + Dir_Maybe_Is_Wild := False; + + elsif Arg (P2) = '.' + and then Arg (P2 + 1) = '.' + then + Dir_Maybe_Is_Wild := True; + end if; + P2 := P2 + 1; end loop; + + if Dir_Is_Wild then + Dir_List := + To_Canonical_File_List + (Arg (SwP .. P2), True); + + for J in Dir_List.all'Range loop + Place_Unix_Switches + (Sw.Unix_String); + Place_Lower + (Dir_List.all (J).all); + end loop; + + else + Place_Unix_Switches + (Sw.Unix_String); + Place_Lower + (To_Canonical_Dir_Spec + (Arg (SwP .. P2), False).all); + end if; + + SwP := P2 + 2; end; - end case; - end if; + end loop; - -- Qualifier argument + when T_Directory => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing directory for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; - else - -- This code is too heavily nested, should be - -- separated out as separate subprogram ??? - - declare - Sw : Item_Ptr; - SwP : Natural; - P2 : Natural; - Endp : Natural := 0; -- avoid warning! - Opt : Item_Ptr; - - begin - SwP := Arg'First; - while SwP < Arg'Last - and then Arg (SwP + 1) /= '=' - loop - SwP := SwP + 1; - end loop; + else + Place_Unix_Switches (Sw.Unix_String); - -- At this point, the switch name is in - -- Arg (Arg'First..SwP) and if that is not the - -- whole switch, then there is an equal sign at - -- Arg (SwP + 1) and the rest of Arg is what comes - -- after the equal sign. + -- Some switches end in "=". No space + -- here - -- If make commands are active, see if we have - -- another COMMANDS_TRANSLATION switch belonging - -- to gnatmake. + if Sw.Unix_String + (Sw.Unix_String'Last) /= '=' + then + Place (' '); + end if; - if Make_Commands_Active /= null then - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Command.Switches, - Quiet => True); + Place_Lower + (To_Canonical_Dir_Spec + (Arg (SwP + 2 .. Arg'Last), + False).all); + end if; + + when T_File | T_No_Space_File => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing file for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + else + Place_Unix_Switches (Sw.Unix_String); + + -- Some switches end in "=". No space + -- here. + + if Sw.Translation = T_File + and then Sw.Unix_String + (Sw.Unix_String'Last) /= '=' + then + Place (' '); + end if; + + Place_Lower + (To_Canonical_File_Spec + (Arg (SwP + 2 .. Arg'Last)).all); + end if; + + when T_Numeric => + if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then + Place_Unix_Switches (Sw.Unix_String); + Place (Arg (SwP + 2 .. Arg'Last)); - if Sw /= null - and then Sw.Translation = T_Commands + else + Put (Standard_Error, "argument for "); + Put (Standard_Error, Sw.Name.all); + Put_Line + (Standard_Error, " must be numeric"); + Errors := Errors + 1; + end if; + + when T_Alphanumplus => + if OK_Alphanumerplus + (Arg (SwP + 2 .. Arg'Last)) then - null; + Place_Unix_Switches (Sw.Unix_String); + Place (Arg (SwP + 2 .. Arg'Last)); else - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Make_Commands_Active.Switches, - Quiet => False); + Put (Standard_Error, "argument for "); + Put (Standard_Error, Sw.Name.all); + Put_Line (Standard_Error, + " must be alphanumeric"); + Errors := Errors + 1; end if; - -- For case of GNAT MAKE or CHOP, if we cannot - -- find the switch, then see if it is a - -- recognized compiler switch instead, and if - -- so process the compiler switch. + when T_String => - elsif Command.Name.all = "MAKE" - or else Command.Name.all = "CHOP" then - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Command.Switches, - Quiet => True); + -- A String value must be extended to the + -- end of the Argv, otherwise strings like + -- "foo/bar" get split at the slash. - if Sw = null then - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Matching_Name - ("COMPILE", Commands).Switches, - Quiet => False); + -- The beginning and ending of the string + -- are flagged with embedded nulls which + -- are removed when building the Spawn + -- call. Nulls are use because they won't + -- show up in a /? output. Quotes aren't + -- used because that would make it + -- difficult to embed them. + + Place_Unix_Switches (Sw.Unix_String); + + if Next_Arg_Idx /= Argv'Last then + Next_Arg_Idx := Argv'Last; + Arg := new String' + (Argv (Arg_Idx .. Next_Arg_Idx)); + + SwP := Arg'First; + while SwP < Arg'Last and then + Arg (SwP + 1) /= '=' loop + SwP := SwP + 1; + end loop; end if; - -- For all other cases, just search the relevant - -- command. + Place (ASCII.NUL); + Place (Arg (SwP + 2 .. Arg'Last)); + Place (ASCII.NUL); - else - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Command.Switches, - Quiet => False); - end if; + when T_Commands => - if Sw /= null then - case Sw.Translation is + -- Output -largs/-bargs/-cargs - when T_Direct => - Place_Unix_Switches (Sw.Unix_String); - if SwP < Arg'Last - and then Arg (SwP + 1) = '=' - then - Put (Standard_Error, - "qualifier options ignored: "); - Put_Line (Standard_Error, Arg.all); - end if; + Place (' '); + Place (Sw.Unix_String + (Sw.Unix_String'First .. + Sw.Unix_String'First + 5)); - when T_Directories => - if SwP + 1 > Arg'Last then - Put (Standard_Error, - "missing directories for: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; + if Sw.Unix_String + (Sw.Unix_String'First + 7 .. + Sw.Unix_String'Last) = "MAKE" + then + Make_Commands_Active := null; - elsif Arg (SwP + 2) /= '(' then - SwP := SwP + 2; - Endp := Arg'Last; + else + -- Set source of new commands, also + -- setting this non-null indicates that + -- we are in the special commands mode + -- for processing the -xargs case. - elsif Arg (Arg'Last) /= ')' then + Make_Commands_Active := + Matching_Name + (Sw.Unix_String + (Sw.Unix_String'First + 7 .. + Sw.Unix_String'Last), + Commands); + end if; - -- Remove spaces from a comma separated - -- list of file names and adjust - -- control variables accordingly. + when T_Options => + if SwP + 1 > Arg'Last then + Place_Unix_Switches + (Sw.Options.Unix_String); + SwP := Endp + 1; - if Arg_Num < Argument_Count and then - (Argv (Argv'Last) = ',' xor - Argument (Arg_Num + 1) - (Argument (Arg_Num + 1)'First) = ',') - then - Argv := - new String'(Argv.all - & Argument - (Arg_Num + 1)); - Arg_Num := Arg_Num + 1; - Arg_Idx := Argv'First; - Next_Arg_Idx := - Get_Arg_End (Argv.all, Arg_Idx); - Arg := new String' - (Argv (Arg_Idx .. Next_Arg_Idx)); - goto Tryagain_After_Coalesce; - end if; + elsif Arg (SwP + 2) /= '(' then + SwP := SwP + 2; + Endp := Arg'Last; - Put (Standard_Error, - "incorrectly parenthesized " & - "or malformed argument: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; + elsif Arg (Arg'Last) /= ')' then + Put (Standard_Error, + "incorrectly parenthesized argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + SwP := Endp + 1; - else - SwP := SwP + 3; - Endp := Arg'Last - 1; - end if; + else + SwP := SwP + 3; + Endp := Arg'Last - 1; + end if; - while SwP <= Endp loop - declare - Dir_Is_Wild : Boolean := False; - Dir_Maybe_Is_Wild : Boolean := False; - - Dir_List : String_Access_List_Access; - - begin - P2 := SwP; - - while P2 < Endp - and then Arg (P2 + 1) /= ',' - loop - -- A wildcard directory spec on - -- VMS will contain either * or - -- % or ... - - if Arg (P2) = '*' then - Dir_Is_Wild := True; - - elsif Arg (P2) = '%' then - Dir_Is_Wild := True; - - elsif Dir_Maybe_Is_Wild - and then Arg (P2) = '.' - and then Arg (P2 + 1) = '.' - then - Dir_Is_Wild := True; - Dir_Maybe_Is_Wild := False; - - elsif Dir_Maybe_Is_Wild then - Dir_Maybe_Is_Wild := False; - - elsif Arg (P2) = '.' - and then Arg (P2 + 1) = '.' - then - Dir_Maybe_Is_Wild := True; - - end if; - - P2 := P2 + 1; - end loop; - - if Dir_Is_Wild then - Dir_List := - To_Canonical_File_List - (Arg (SwP .. P2), True); - - for J in Dir_List.all'Range loop - Place_Unix_Switches - (Sw.Unix_String); - Place_Lower - (Dir_List.all (J).all); - end loop; - - else - Place_Unix_Switches - (Sw.Unix_String); - Place_Lower - (To_Canonical_Dir_Spec - (Arg (SwP .. P2), False).all); - end if; - - SwP := P2 + 2; - end; - end loop; + while SwP <= Endp loop + P2 := SwP; - when T_Directory => - if SwP + 1 > Arg'Last then - Put (Standard_Error, - "missing directory for: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; + while P2 < Endp + and then Arg (P2 + 1) /= ',' + loop + P2 := P2 + 1; + end loop; - else - Place_Unix_Switches (Sw.Unix_String); + -- Option name is in Arg (SwP .. P2) - -- Some switches end in "=". No space - -- here + Opt := Matching_Name (Arg (SwP .. P2), + Sw.Options); - if Sw.Unix_String - (Sw.Unix_String'Last) /= '=' - then - Place (' '); - end if; + if Opt /= null then + Place_Unix_Switches + (Opt.Unix_String); + end if; - Place_Lower - (To_Canonical_Dir_Spec - (Arg (SwP + 2 .. Arg'Last), - False).all); - end if; + SwP := P2 + 2; + end loop; - when T_File | T_No_Space_File => - if SwP + 1 > Arg'Last then - Put (Standard_Error, - "missing file for: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; + when T_Other => + Place_Unix_Switches + (new String'(Sw.Unix_String.all & + Arg.all)); - else - Place_Unix_Switches (Sw.Unix_String); + end case; + end if; + end; + end if; - -- Some switches end in "=". No space - -- here. + Arg_Idx := Next_Arg_Idx + 1; + end; - if Sw.Translation = T_File - and then Sw.Unix_String - (Sw.Unix_String'Last) /= '=' - then - Place (' '); - end if; + exit when Arg_Idx > Argv'Last; - Place_Lower - (To_Canonical_File_Spec - (Arg (SwP + 2 .. Arg'Last)).all); - end if; + end loop; - when T_Numeric => - if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then - Place_Unix_Switches (Sw.Unix_String); - Place (Arg (SwP + 2 .. Arg'Last)); + if not Is_Open (Arg_File) then + Arg_Num := Arg_Num + 1; + end if; + end Process_Argument; - else - Put (Standard_Error, "argument for "); - Put (Standard_Error, Sw.Name.all); - Put_Line - (Standard_Error, " must be numeric"); - Errors := Errors + 1; - end if; + -------------------- + -- Process_Buffer -- + -------------------- - when T_Alphanumplus => - if OK_Alphanumerplus - (Arg (SwP + 2 .. Arg'Last)) - then - Place_Unix_Switches (Sw.Unix_String); - Place (Arg (SwP + 2 .. Arg'Last)); + procedure Process_Buffer (S : String) is + P1, P2 : Natural; + Inside_Nul : Boolean := False; + Arg : String (1 .. 1024); + Arg_Ctr : Natural; - else - Put (Standard_Error, "argument for "); - Put (Standard_Error, Sw.Name.all); - Put_Line (Standard_Error, - " must be alphanumeric"); - Errors := Errors + 1; - end if; + begin + P1 := 1; + while P1 <= S'Last and then S (P1) = ' ' loop + P1 := P1 + 1; + end loop; - when T_String => + Arg_Ctr := 1; + Arg (Arg_Ctr) := S (P1); - -- A String value must be extended to the - -- end of the Argv, otherwise strings like - -- "foo/bar" get split at the slash. + while P1 <= S'Last loop + if S (P1) = ASCII.NUL then + if Inside_Nul then + Inside_Nul := False; + else + Inside_Nul := True; + end if; + end if; - -- The begining and ending of the string - -- are flagged with embedded nulls which - -- are removed when building the Spawn - -- call. Nulls are use because they won't - -- show up in a /? output. Quotes aren't - -- used because that would make it - -- difficult to embed them. + if S (P1) = ' ' and then not Inside_Nul then + P1 := P1 + 1; + Arg_Ctr := Arg_Ctr + 1; + Arg (Arg_Ctr) := S (P1); - Place_Unix_Switches (Sw.Unix_String); + else + Last_Switches.Increment_Last; + P2 := P1; - if Next_Arg_Idx /= Argv'Last then - Next_Arg_Idx := Argv'Last; - Arg := new String' - (Argv (Arg_Idx .. Next_Arg_Idx)); + while P2 < S'Last + and then (S (P2 + 1) /= ' ' or else + Inside_Nul) + loop + P2 := P2 + 1; + Arg_Ctr := Arg_Ctr + 1; + Arg (Arg_Ctr) := S (P2); + if S (P2) = ASCII.NUL then + Arg_Ctr := Arg_Ctr - 1; - SwP := Arg'First; - while SwP < Arg'Last and then - Arg (SwP + 1) /= '=' loop - SwP := SwP + 1; - end loop; - end if; + if Inside_Nul then + Inside_Nul := False; + else + Inside_Nul := True; + end if; + end if; + end loop; - Place (ASCII.NUL); - Place (Arg (SwP + 2 .. Arg'Last)); - Place (ASCII.NUL); + Last_Switches.Table (Last_Switches.Last) := + new String'(String (Arg (1 .. Arg_Ctr))); + P1 := P2 + 2; - when T_Commands => + exit when P1 > S'Last; - -- Output -largs/-bargs/-cargs + Arg_Ctr := 1; + Arg (Arg_Ctr) := S (P1); + end if; + end loop; + end Process_Buffer; - Place (' '); - Place (Sw.Unix_String - (Sw.Unix_String'First .. - Sw.Unix_String'First + 5)); + -------------------------------- + -- Validate_Command_Or_Option -- + -------------------------------- - if Sw.Unix_String - (Sw.Unix_String'First + 7 .. - Sw.Unix_String'Last) = "MAKE" - then - Make_Commands_Active := null; + procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is + begin + pragma Assert (N'Length > 0); - else - -- Set source of new commands, also - -- setting this non-null indicates that - -- we are in the special commands mode - -- for processing the -xargs case. - - Make_Commands_Active := - Matching_Name - (Sw.Unix_String - (Sw.Unix_String'First + 7 .. - Sw.Unix_String'Last), - Commands); - end if; + for J in N'Range loop + if N (J) = '_' then + pragma Assert (N (J - 1) /= '_'); + null; + else + pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J))); + null; + end if; + end loop; + end Validate_Command_Or_Option; - when T_Options => - if SwP + 1 > Arg'Last then - Place_Unix_Switches - (Sw.Options.Unix_String); - SwP := Endp + 1; + -------------------------- + -- Validate_Unix_Switch -- + -------------------------- - elsif Arg (SwP + 2) /= '(' then - SwP := SwP + 2; - Endp := Arg'Last; + procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is + begin + if S (S'First) = '`' then + return; + end if; - elsif Arg (Arg'Last) /= ')' then - Put - (Standard_Error, - "incorrectly parenthesized " & - "argument: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; - SwP := Endp + 1; + pragma Assert (S (S'First) = '-' or else S (S'First) = '!'); - else - SwP := SwP + 3; - Endp := Arg'Last - 1; - end if; + for J in S'First + 1 .. S'Last loop + pragma Assert (S (J) /= ' '); + + if S (J) = '!' then + pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-'); + null; + end if; + end loop; + end Validate_Unix_Switch; - while SwP <= Endp loop - P2 := SwP; + -------------------- + -- VMS_Conversion -- + -------------------- - while P2 < Endp - and then Arg (P2 + 1) /= ',' - loop - P2 := P2 + 1; - end loop; + procedure VMS_Conversion (The_Command : out Command_Type) is + Result : Command_Type := Undefined; + Result_Set : Boolean := False; - -- Option name is in Arg (SwP .. P2) + begin + Buffer.Init; - Opt := Matching_Name (Arg (SwP .. P2), - Sw.Options); + -- First we must preprocess the string form of the command and options + -- list into the internal form that we use. - if Opt /= null then - Place_Unix_Switches - (Opt.Unix_String); - end if; + Preprocess_Command_Data; - SwP := P2 + 2; - end loop; + -- If no parameters, give complete list of commands - when T_Other => - Place_Unix_Switches - (new String'(Sw.Unix_String.all & - Arg.all)); + if Argument_Count = 0 then + Output_Version; + New_Line; + Put_Line ("List of available commands"); + New_Line; - end case; - end if; - end; - end if; + while Commands /= null loop + Put (Commands.Usage.all); + Set_Col (53); + Put_Line (Commands.Unix_String.all); + Commands := Commands.Next; + end loop; - Arg_Idx := Next_Arg_Idx + 1; - end; + raise Normal_Exit; + end if; - exit when Arg_Idx > Argv'Last; + -- Loop through arguments - end loop; - end Process_Argument; + Arg_Num := 1; + while Arg_Num <= Argument_Count loop + Process_Argument (Result); - Arg_Num := Arg_Num + 1; + if not Result_Set then + The_Command := Result; + Result_Set := True; + end if; end loop; -- Gross error checking that the number of parameters is correct. @@ -1915,66 +2321,13 @@ package body VMS_Conv is -- Prepare arguments for a call to spawn, filtering out -- embedded nulls place there to delineate strings. - declare - P1, P2 : Natural; - Inside_Nul : Boolean := False; - Arg : String (1 .. 1024); - Arg_Ctr : Natural; - - begin - P1 := 1; + Process_Buffer (String (Buffer.Table (1 .. Buffer.Last))); - while P1 <= Buffer.Last and then Buffer.Table (P1) = ' ' loop - P1 := P1 + 1; - end loop; - - Arg_Ctr := 1; - Arg (Arg_Ctr) := Buffer.Table (P1); - - while P1 <= Buffer.Last loop - - if Buffer.Table (P1) = ASCII.NUL then - if Inside_Nul then - Inside_Nul := False; - else - Inside_Nul := True; - end if; - end if; - - if Buffer.Table (P1) = ' ' and then not Inside_Nul then - P1 := P1 + 1; - Arg_Ctr := Arg_Ctr + 1; - Arg (Arg_Ctr) := Buffer.Table (P1); - - else - Last_Switches.Increment_Last; - P2 := P1; - - while P2 < Buffer.Last - and then (Buffer.Table (P2 + 1) /= ' ' or else - Inside_Nul) - loop - P2 := P2 + 1; - Arg_Ctr := Arg_Ctr + 1; - Arg (Arg_Ctr) := Buffer.Table (P2); - if Buffer.Table (P2) = ASCII.NUL then - Arg_Ctr := Arg_Ctr - 1; - if Inside_Nul then - Inside_Nul := False; - else - Inside_Nul := True; - end if; - end if; - end loop; - - Last_Switches.Table (Last_Switches.Last) := - new String'(String (Arg (1 .. Arg_Ctr))); - P1 := P2 + 2; - Arg_Ctr := 1; - Arg (Arg_Ctr) := Buffer.Table (P1); - end if; - end loop; - end; + if Cargs_Buffer.Last > 1 then + Last_Switches.Append (new String'("-cargs")); + Process_Buffer + (String (Cargs_Buffer.Table (1 .. Cargs_Buffer.Last))); + end if; end if; end VMS_Conversion;