-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2003 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; use Gnatvsn;
with Hostparm;
+with Opt;
with Osint; use Osint;
-with Sdefault; use Sdefault;
+with Targparm; use Targparm;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
-with Gnatvsn;
-
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.
-- 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
-- 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
function Matching_Name
(S : String;
Itm : Item_Ptr;
- Quiet : Boolean := False)
- return Item_Ptr;
+ Quiet : Boolean := False) return Item_Ptr;
-- Determines if the item list headed by Itm and threaded through the
-- Next fields (with null marking the end of the list), contains an
-- entry that uniquely matches the given string. The match is case
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.
begin
Object_Dirs := 0;
- Object_Dir_Name := String_Access (Object_Dir_Default_Name);
+ Object_Dir_Name := new String'(Object_Dir_Default_Prefix);
Get_Next_Dir_In_Path_Init (Object_Dir_Name);
loop
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;
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 =>
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"),
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]"
Make =>
(Cname => new S'("MAKE"),
- Usage => new S'("GNAT MAKE file /qualifiers (includes "
+ Usage => new S'("GNAT MAKE file(s) /qualifiers (includes "
& "COMPILE /qualifiers)"),
VMS_Only => False,
Unixcmd => new S'("gnatmake"),
Unixsws => null,
Switches => Make_Switches'Access,
- Params => new Parameter_Array'(1 => File),
+ 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 =>
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 =>
Params => new Parameter_Array'(1 => Unlimited_Files),
Defext => " "),
- Standard =>
- (Cname => new S'("STANDARD"),
- Usage => new S'("GNAT STANDARD"),
+ Stack =>
+ (Cname => new S'("STACK"),
+ Usage => new S'("GNAT STACK /qualifiers ci_files"),
VMS_Only => False,
- Unixcmd => new S'("gnatpsta"),
+ Unixcmd => new S'("gnatstack"),
Unixsws => null,
- Switches => Standard_Switches'Access,
- Params => new Parameter_Array'(1 .. 0 => File),
- Defext => " "),
+ Switches => Stack_Switches'Access,
+ Params => new Parameter_Array'(1 => Unlimited_Files),
+ Defext => "ci" & ASCII.NUL),
Stub =>
(Cname => new S'("STUB"),
function Matching_Name
(S : String;
Itm : Item_Ptr;
- Quiet : Boolean := False)
- return Item_Ptr
+ Quiet : Boolean := False) return Item_Ptr
is
P1, P2 : Item_Ptr;
procedure Output_Version is
begin
- Put ("GNAT ");
- Put (Gnatvsn.Gnat_Version_String);
- Put_Line (" Copyright 1996-2003 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;
-----------
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
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 : Item_Ptr := new Command_Item;
+ Command : constant Item_Ptr := new Command_Item;
Last_Switch : Item_Ptr;
-- Last switch in list
-- 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;
P := P + 1; -- bump past =
while P <= SS'Last loop
declare
- Opt : Item_Ptr := new Option_Item;
+ Opt : constant Item_Ptr := new Option_Item;
Q : Natural;
+
begin
-- Link new option item into options list
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.
- <<Tryagain_After_Coalesce>>
- 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
+ else
+ -- No argument file is open, get the argument on the command line
- Command := Matching_Name (Arg.all, Commands);
+ Argv := new String'(Argument (Arg_Num));
+ Arg_Idx := Argv'First;
- if Command = null then
- raise Error_Exit;
- end if;
+ -- Check if this is the specification of an argument file
- The_Command := Command.Command;
+ if Argv (Arg_Idx) = '@' then
+ -- The first argument on the command line cannot be an argument
+ -- file.
- -- Give usage information if only command given
+ if Arg_Num = 1 then
+ Put_Line
+ (Standard_Error,
+ "Cannot specify argument line before command");
+ raise Error_Exit;
+ end if;
- if Argument_Count = 1 and then Next_Arg_Idx = Argv'Last
- and then Command.Command /= VMS_Conv.Standard
- then
- Output_Version;
- New_Line;
- Put_Line
- ("List of available qualifiers and options");
- New_Line;
+ -- Open the file, after conversion of the name to canonical form.
+ -- Fail if file is not found.
- Put (Command.Usage.all);
- Set_Col (53);
- Put_Line (Command.Unix_String.all);
+ 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;
- declare
- Sw : Item_Ptr := Command.Switches;
+ <<Tryagain_After_Coalesce>>
+ loop
+ declare
+ Next_Arg_Idx : Integer;
+ Arg : String_Access;
- 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 &
- "/<other>");
-
- 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 ("<string>");
- Put ('"');
- Set_Col (53);
-
- Put (Sw.Unix_String.all);
-
- if Sw.Unix_String (Sw.Unix_String'Last)
- /= '='
- then
- Put (' ');
- end if;
-
- Put ("<string>");
- 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;
-
- begin
- Put_Line ("=(option,option..)");
-
- while Opt /= null loop
- Put (" ");
- Put (Opt.Name.all);
-
- if Opt = Sw.Options then
- Put (" (D)");
- end if;
-
- Set_Col (53);
- Put_Line (Opt.Unix_String.all);
- Opt := Opt.Next;
- end loop;
- end;
-
- end case;
-
- Sw := Sw.Next;
- end loop;
- end;
+ begin
+ Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx);
+ Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx));
- raise Normal_Exit;
- end if;
+ -- The first one must be a command name
- -- Special handling for internal debugging switch /?
+ if Arg_Num = 1 and then Arg_Idx = Argv'First then
+ Command := Matching_Name (Arg.all, Commands);
- elsif Arg.all = "/?" then
- Display_Command := True;
+ if Command = null then
+ raise Error_Exit;
+ end if;
- -- Copy -switch unchanged
+ The_Command := Command.Command;
+ Output_File_Expected := False;
- elsif Arg (Arg'First) = '-' then
- Place (' ');
- Place (Arg.all);
+ -- Give usage information if only command given
- -- Copy quoted switch with quotes stripped
+ 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;
- elsif Arg (Arg'First) = '"' then
- if Arg (Arg'Last) /= '"' then
- Put (Standard_Error, "misquoted argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
+ Put (Command.Usage.all);
+ Set_Col (53);
+ Put_Line (Command.Unix_String.all);
- else
- Place (' ');
- Place (Arg (Arg'First + 1 .. Arg'Last - 1));
- end if;
+ declare
+ Sw : Item_Ptr := Command.Switches;
- -- Parameter Argument
+ 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 &
+ "/<other>");
+
+ 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;
- elsif Arg (Arg'First) /= '/'
- and then Make_Commands_Active = null
- then
- Param_Count := Param_Count + 1;
+ Put_Line ("directory ");
- if Param_Count <= Command.Params'Length then
+ when T_File | T_No_Space_File =>
+ Put ("=file");
+ Set_Col (53);
+ Put (Sw.Unix_String.all);
- case Command.Params (Param_Count) is
+ if Sw.Translation = T_File
+ and then Sw.Unix_String
+ (Sw.Unix_String'Last) /= '='
+ then
+ Put (' ');
+ end if;
- when File | Optional_File =>
- declare
- Normal_File : constant String_Access :=
- To_Canonical_File_Spec
- (Arg.all);
+ Put_Line ("file ");
- begin
- Place (' ');
- Place_Lower (Normal_File.all);
+ when T_Numeric =>
+ Put ("=nnn");
+ Set_Col (53);
- if Is_Extensionless (Normal_File.all)
- and then Command.Defext /= " "
- then
- Place ('.');
- Place (Command.Defext);
- end if;
- end;
-
- 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;
-
- begin
- for J in Arg'Range loop
- if Arg (J) = '*'
- or else Arg (J) = '%'
- then
- File_Is_Wild := True;
- end if;
- end loop;
+ 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;
- if File_Is_Wild then
- File_List := To_Canonical_File_List
- (Arg.all, False);
-
- for J in File_List.all'Range loop
- Place (' ');
- Place_Lower (File_List.all (J).all);
- end loop;
-
- else
- Place (' ');
- Place_Lower (Normal_File.all);
-
- if Is_Extensionless (Normal_File.all)
- and then Command.Defext /= " "
- then
- Place ('.');
- Place (Command.Defext);
- end if;
- end if;
+ Put_Line ("nnn");
- Param_Count := Param_Count - 1;
- end;
+ when T_Alphanumplus =>
+ Put ("=xyz");
+ Set_Col (53);
- when Other_As_Is =>
- Place (' ');
- Place (Arg.all);
+ 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;
- when Unlimited_As_Is =>
- Place (' ');
- Place (Arg.all);
- Param_Count := Param_Count - 1;
+ Put_Line ("xyz");
- when Files_Or_Wildcard =>
+ when T_String =>
+ Put ("=");
+ Put ('"');
+ Put ("<string>");
+ Put ('"');
+ Set_Col (53);
- -- Remove spaces from a comma separated list
- -- of file names and adjust control variables
- -- accordingly.
+ Put (Sw.Unix_String.all);
- 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 Sw.Unix_String
+ (Sw.Unix_String'Last) /= '='
+ then
+ Put (' ');
+ 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.
-
- 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;
-
- return Arg'Last;
- end Get_Arg1_End;
-
- begin
- 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;
- end if;
+ Put ("<string>");
+ 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;
+
+ begin
+ Put_Line ("=(option,option..)");
+
+ while Opt /= null loop
+ Put (" ");
+ Put (Opt.Name.all);
+
+ if Opt = Sw.Options then
+ Put (" (D)");
+ end if;
- end loop;
- end;
- end case;
- end if;
+ Set_Col (53);
+ Put_Line (Opt.Unix_String.all);
+ Opt := Opt.Next;
+ end loop;
+ end;
- -- Qualifier argument
+ end case;
- else
- -- This code is too heavily nested, should be
- -- separated out as separate subprogram ???
+ Sw := Sw.Next;
+ end loop;
+ end;
- declare
- Sw : Item_Ptr;
- SwP : Natural;
- P2 : Natural;
- Endp : Natural := 0; -- avoid warning!
- Opt : Item_Ptr;
+ raise Normal_Exit;
+ end if;
- begin
- SwP := Arg'First;
- while SwP < Arg'Last
- and then Arg (SwP + 1) /= '='
- loop
- SwP := SwP + 1;
- end loop;
+ -- Special handling for internal debugging switch /?
- -- 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.
+ elsif Arg.all = "/?" then
+ Display_Command := True;
+ Output_File_Expected := False;
- -- If make commands are active, see if we have
- -- another COMMANDS_TRANSLATION switch belonging
- -- to gnatmake.
+ -- Special handling of internal option /KEEP_TEMPORARY_FILES
- if Make_Commands_Active /= null then
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Command.Switches,
- Quiet => True);
+ elsif Arg'Length >= 7
+ and then Matching_Name
+ (Arg.all, Keep_Temps_Option, True) /= null
+ then
+ Opt.Keep_Temporary_Files := True;
- if Sw /= null
- and then Sw.Translation = T_Commands
- then
- null;
+ -- Copy -switch unchanged, as well as +rule
- else
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Make_Commands_Active.Switches,
- Quiet => False);
- end if;
+ elsif Arg (Arg'First) = '-' or else Arg (Arg'First) = '+' then
+ Place (' ');
+ Place (Arg.all);
- -- 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.
+ -- Set Output_File_Expected for the next argument
- 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;
+ Output_File_Expected :=
+ Arg.all = "-o" and then The_Command = Link;
- -- For all other cases, just search the relevant
- -- command.
+ -- Copy quoted switch with quotes stripped
- else
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Command.Switches,
- Quiet => False);
- end if;
+ 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 Sw /= null then
- case Sw.Translation is
+ else
+ Place (' ');
+ Place (Arg (Arg'First + 1 .. Arg'Last - 1));
+ end if;
- 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;
+ Output_File_Expected := False;
- 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) = ',')
- 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;
-
- 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;
+ -- Parameter Argument
- 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;
+ elsif Arg (Arg'First) /= '/'
+ and then Make_Commands_Active = null
+ then
+ Param_Count := Param_Count + 1;
- when T_Directory =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error,
- "missing directory for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
+ if Param_Count <= Command.Params'Length then
- else
- Place_Unix_Switches (Sw.Unix_String);
+ case Command.Params (Param_Count) is
- -- Some switches end in "=". No space
- -- here
+ when File | Optional_File =>
+ declare
+ Normal_File : constant String_Access :=
+ To_Canonical_File_Spec
+ (Arg.all);
- if Sw.Unix_String
- (Sw.Unix_String'Last) /= '='
- then
- Place (' ');
- end if;
+ begin
+ Place (' ');
+ Place_Lower (Normal_File.all);
- Place_Lower
- (To_Canonical_Dir_Spec
- (Arg (SwP + 2 .. Arg'Last),
- False).all);
- end if;
+ if Is_Extensionless (Normal_File.all)
+ and then Command.Defext /= " "
+ then
+ Place ('.');
+ Place (Command.Defext);
+ end if;
+ end;
- 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 Unlimited_Files =>
+ declare
+ Normal_File : constant String_Access :=
+ To_Canonical_File_Spec
+ (Arg.all);
- else
- Place_Unix_Switches (Sw.Unix_String);
+ File_Is_Wild : Boolean := False;
+ File_List : String_Access_List_Access;
- -- Some switches end in "=". No space
- -- here.
+ begin
+ for J in Arg'Range loop
+ if Arg (J) = '*'
+ or else Arg (J) = '%'
+ then
+ File_Is_Wild := True;
+ end if;
+ end loop;
- if Sw.Translation = T_File
- and then Sw.Unix_String
- (Sw.Unix_String'Last) /= '='
- then
- Place (' ');
- end if;
+ if File_Is_Wild then
+ File_List := To_Canonical_File_List
+ (Arg.all, False);
- Place_Lower
- (To_Canonical_File_Spec
- (Arg (SwP + 2 .. Arg'Last)).all);
- end if;
+ for J in File_List.all'Range loop
+ Place (' ');
+ Place_Lower (File_List.all (J).all);
+ 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));
-
- else
- Put (Standard_Error, "argument for ");
- Put (Standard_Error, Sw.Name.all);
- Put_Line
- (Standard_Error, " must be numeric");
- Errors := Errors + 1;
- end if;
+ else
+ Place (' ');
+ Place_Lower (Normal_File.all);
- when T_Alphanumplus =>
- if
- OK_Alphanumerplus
- (Arg (SwP + 2 .. Arg'Last))
- then
- Place_Unix_Switches (Sw.Unix_String);
- Place (Arg (SwP + 2 .. Arg'Last));
-
- else
- Put (Standard_Error, "argument for ");
- Put (Standard_Error, Sw.Name.all);
- Put_Line (Standard_Error,
- " must be alphanumeric");
- Errors := Errors + 1;
- end if;
+ -- Add extension if not present, except after
+ -- switch -o.
- when T_String =>
-
- -- A String value must be extended to the
- -- end of the Argv, otherwise strings like
- -- "foo/bar" get split at the slash.
- --
- -- 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.
-
- 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;
- Place (ASCII.NUL);
- Place (Arg (SwP + 2 .. Arg'Last));
- Place (ASCII.NUL);
+ 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;
+
+ Param_Count := Param_Count - 1;
+ end;
+
+ when Other_As_Is =>
+ Place (' ');
+ Place (Arg.all);
+
+ when Unlimited_As_Is =>
+ Place (' ');
+ Place (Arg.all);
+ Param_Count := Param_Count - 1;
+
+ when Files_Or_Wildcard =>
+
+ -- Remove spaces from a comma separated list
+ -- of file names and adjust control variables
+ -- accordingly.
+
+ 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;
+
+ -- 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;
+
+ return Arg'Last;
+ end Get_Arg1_End;
+
+ begin
+ 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;
+ end if;
+
+ end loop;
+ end;
+ end case;
+ end if;
+
+ -- Reset Output_File_Expected, in case it was True
+
+ Output_File_Expected := False;
+
+ -- Qualifier argument
+
+ else
+ Output_File_Expected := False;
+
+ Cargs := Command.Name.all = "COMPILE";
+
+ -- 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;
+
+ -- 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;
+
+ -- For all other cases, just search the relevant
+ -- command.
+
+ 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) = ',')
+ 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;
+
+ 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
+ Dir_Is_Wild : Boolean := False;
+ Dir_Maybe_Is_Wild : Boolean := False;
+
+ Dir_List : String_Access_List_Access;
- when T_Commands =>
+ begin
+ P2 := SwP;
- -- Output -largs/-bargs/-cargs
+ 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;
- Place (' ');
- Place (Sw.Unix_String
- (Sw.Unix_String'First ..
- Sw.Unix_String'First + 5));
+ elsif Dir_Maybe_Is_Wild then
+ Dir_Maybe_Is_Wild := False;
- if Sw.Unix_String
- (Sw.Unix_String'First + 7 ..
- Sw.Unix_String'Last) =
- "MAKE"
+ elsif Arg (P2) = '.'
+ and then Arg (P2 + 1) = '.'
then
- Make_Commands_Active := null;
-
- 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);
+ Dir_Maybe_Is_Wild := True;
+
end if;
- when T_Options =>
- if SwP + 1 > Arg'Last then
+ 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.Options.Unix_String);
- SwP := Endp + 1;
-
- elsif Arg (SwP + 2) /= '(' then
- SwP := SwP + 2;
- Endp := Arg'Last;
-
- 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;
+ (Sw.Unix_String);
+ Place_Lower
+ (Dir_List.all (J).all);
+ end loop;
- while SwP <= Endp loop
- P2 := SwP;
+ 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 P2 < Endp
- and then Arg (P2 + 1) /= ','
- loop
- P2 := P2 + 1;
- end loop;
+ when T_Directory =>
+ if SwP + 1 > Arg'Last then
+ Put (Standard_Error,
+ "missing directory for: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
- -- Option name is in Arg (SwP .. P2)
+ else
+ Place_Unix_Switches (Sw.Unix_String);
- Opt := Matching_Name (Arg (SwP .. P2),
- Sw.Options);
+ -- Some switches end in "=". No space
+ -- here
- if Opt /= null then
- Place_Unix_Switches
- (Opt.Unix_String);
- end if;
+ if Sw.Unix_String
+ (Sw.Unix_String'Last) /= '='
+ then
+ Place (' ');
+ end if;
- SwP := P2 + 2;
- end loop;
+ Place_Lower
+ (To_Canonical_Dir_Spec
+ (Arg (SwP + 2 .. Arg'Last),
+ False).all);
+ end if;
- when T_Other =>
- Place_Unix_Switches
- (new String'(Sw.Unix_String.all &
- Arg.all));
+ 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;
- end case;
+ Place_Lower
+ (To_Canonical_File_Spec
+ (Arg (SwP + 2 .. Arg'Last)).all);
end if;
- end;
- end if;
- Arg_Idx := Next_Arg_Idx + 1;
- end;
+ when T_Numeric =>
+ if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then
+ Place_Unix_Switches (Sw.Unix_String);
+ Place (Arg (SwP + 2 .. Arg'Last));
+
+ 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
+ Place_Unix_Switches (Sw.Unix_String);
+ Place (Arg (SwP + 2 .. Arg'Last));
+
+ else
+ Put (Standard_Error, "argument for ");
+ Put (Standard_Error, Sw.Name.all);
+ Put_Line (Standard_Error,
+ " must be alphanumeric");
+ Errors := Errors + 1;
+ end if;
+
+ when T_String =>
+
+ -- A String value must be extended to the
+ -- end of the Argv, otherwise strings like
+ -- "foo/bar" get split at the slash.
+
+ -- 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;
+
+ Place (ASCII.NUL);
+ Place (Arg (SwP + 2 .. Arg'Last));
+ Place (ASCII.NUL);
- exit when Arg_Idx > Argv'Last;
+ when T_Commands =>
+
+ -- Output -largs/-bargs/-cargs
+
+ Place (' ');
+ Place (Sw.Unix_String
+ (Sw.Unix_String'First ..
+ Sw.Unix_String'First + 5));
+
+ if Sw.Unix_String
+ (Sw.Unix_String'First + 7 ..
+ Sw.Unix_String'Last) = "MAKE"
+ then
+ Make_Commands_Active := null;
+
+ 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;
- end loop;
- end Process_Argument;
+ when T_Options =>
+ if SwP + 1 > Arg'Last then
+ Place_Unix_Switches
+ (Sw.Options.Unix_String);
+ SwP := Endp + 1;
+ elsif Arg (SwP + 2) /= '(' then
+ SwP := SwP + 2;
+ Endp := Arg'Last;
+
+ 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;
+
+ while SwP <= Endp loop
+ P2 := SwP;
+
+ while P2 < Endp
+ and then Arg (P2 + 1) /= ','
+ loop
+ P2 := P2 + 1;
+ end loop;
+
+ -- Option name is in Arg (SwP .. P2)
+
+ Opt := Matching_Name (Arg (SwP .. P2),
+ Sw.Options);
+
+ if Opt /= null then
+ Place_Unix_Switches
+ (Opt.Unix_String);
+ end if;
+
+ SwP := P2 + 2;
+ end loop;
+
+ when T_Other =>
+ Place_Unix_Switches
+ (new String'(Sw.Unix_String.all &
+ Arg.all));
+
+ end case;
+ end if;
+ end;
+ end if;
+
+ Arg_Idx := Next_Arg_Idx + 1;
+ end;
+
+ exit when Arg_Idx > Argv'Last;
+
+ end loop;
+
+ if not Is_Open (Arg_File) then
Arg_Num := Arg_Num + 1;
+ end if;
+ end Process_Argument;
+
+ --------------------
+ -- Process_Buffer --
+ --------------------
+
+ procedure Process_Buffer (S : String) is
+ P1, P2 : Natural;
+ Inside_Nul : Boolean := False;
+ Arg : String (1 .. 1024);
+ Arg_Ctr : Natural;
+
+ begin
+ P1 := 1;
+ while P1 <= S'Last and then S (P1) = ' ' loop
+ P1 := P1 + 1;
+ end loop;
+
+ Arg_Ctr := 1;
+ Arg (Arg_Ctr) := S (P1);
+
+ 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;
+
+ if S (P1) = ' ' and then not Inside_Nul then
+ P1 := P1 + 1;
+ Arg_Ctr := Arg_Ctr + 1;
+ Arg (Arg_Ctr) := S (P1);
+
+ else
+ Last_Switches.Increment_Last;
+ P2 := P1;
+
+ 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;
+
+ 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;
+
+ exit when P1 > S'Last;
+
+ Arg_Ctr := 1;
+ Arg (Arg_Ctr) := S (P1);
+ end if;
+ end loop;
+ end Process_Buffer;
+
+ --------------------------------
+ -- 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 --
+ --------------------
+
+ procedure VMS_Conversion (The_Command : out Command_Type) is
+ Result : Command_Type := Undefined;
+ Result_Set : Boolean := False;
+
+ begin
+ Buffer.Init;
+
+ -- First we must preprocess the string form of the command and options
+ -- list into the internal form that we use.
+
+ 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;
+
+ while Commands /= null loop
+ Put (Commands.Usage.all);
+ Set_Col (53);
+ Put_Line (Commands.Unix_String.all);
+ Commands := Commands.Next;
+ end loop;
+
+ raise Normal_Exit;
+ end if;
+
+ -- Loop through arguments
+
+ Arg_Num := 1;
+ while Arg_Num <= Argument_Count loop
+ Process_Argument (Result);
+
+ 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.
-- 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;
-
- 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;
+ Process_Buffer (String (Buffer.Table (1 .. Buffer.Last)));
- 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;
OSDN Git Service
