summaryrefslogtreecommitdiff
path: root/gcc/ada/gnatcmd.adb
diff options
context:
space:
mode:
authorkenner <kenner@138bc75d-0d04-0410-961f-82ee72b054a4>2001-10-02 14:18:40 +0000
committerkenner <kenner@138bc75d-0d04-0410-961f-82ee72b054a4>2001-10-02 14:18:40 +0000
commit83cce46b47d48de4c71b02a20f5bf36296a48568 (patch)
tree6570bc15069492ca4f53a85c5d09a36d099fd63f /gcc/ada/gnatcmd.adb
parentee6ba406bdc83a0b016ec0099d84035d7fd26fd7 (diff)
downloadgcc-83cce46b47d48de4c71b02a20f5bf36296a48568.tar.gz
New Language: Ada
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45955 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/gnatcmd.adb')
-rw-r--r--gcc/ada/gnatcmd.adb3239
1 files changed, 3239 insertions, 0 deletions
diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb
new file mode 100644
index 00000000000..ac4e302f252
--- /dev/null
+++ b/gcc/ada/gnatcmd.adb
@@ -0,0 +1,3239 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T C M D --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.84 $
+-- --
+-- Copyright (C) 1996-2001 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- --
+-- 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 Osint; use Osint;
+with Sdefault; use Sdefault;
+with Hostparm; use Hostparm;
+-- Used to determine if we are in VMS or not for error message purposes
+
+with Gnatvsn;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+with Table;
+
+procedure GNATCmd is
+ pragma Ident (Gnatvsn.Gnat_Version_String);
+
+ ------------------
+ -- SWITCH TABLE --
+ ------------------
+
+ -- The switch tables contain an entry for each switch recognized by the
+ -- command processor. The syntax of entries is as follows:
+
+ -- SWITCH_STRING ::= "/ command-qualifier-name TRANSLATION"
+
+ -- TRANSLATION ::=
+ -- DIRECT_TRANSLATION
+ -- | DIRECTORIES_TRANSLATION
+ -- | FILE_TRANSLATION
+ -- | NUMERIC_TRANSLATION
+ -- | STRING_TRANSLATION
+ -- | OPTIONS_TRANSLATION
+ -- | COMMANDS_TRANSLATION
+ -- | ALPHANUMPLUS_TRANSLATION
+ -- | OTHER_TRANSLATION
+
+ -- DIRECT_TRANSLATION ::= space UNIX_SWITCHES
+ -- DIRECTORIES_TRANSLATION ::= =* UNIX_SWITCH *
+ -- DIRECTORY_TRANSLATION ::= =% UNIX_SWITCH %
+ -- FILE_TRANSLATION ::= =@ UNIX_SWITCH @
+ -- NUMERIC_TRANSLATION ::= =# UNIX_SWITCH # | # number #
+ -- STRING_TRANSLATION ::= =" UNIX_SWITCH "
+ -- OPTIONS_TRANSLATION ::= =OPTION {space OPTION}
+ -- COMMANDS_TRANSLATION ::= =? ARGS space command-name
+ -- ALPHANUMPLUS_TRANSLATION ::= =| UNIX_SWITCH |
+
+ -- UNIX_SWITCHES ::= UNIX_SWITCH {, UNIX_SWITCH}
+
+ -- UNIX_SWITCH ::= unix-switch-string | !unix-switch-string | `string'
+
+ -- OPTION ::= option-name space UNIX_SWITCHES
+
+ -- ARGS ::= -cargs | -bargs | -largs
+
+ -- Here command-qual is the name of the switch recognized by the GNATCmd.
+ -- This is always given in upper case in the templates, although in the
+ -- actual commands, either upper or lower case is allowed.
+
+ -- The unix-switch-string always starts with a minus, and has no commas
+ -- or spaces in it. Case is significant in the unix switch string. If a
+ -- unix switch string is preceded by the not sign (!) it means that the
+ -- effect of the corresponding command qualifer is to remove any previous
+ -- occurrence of the given switch in the command line.
+
+ -- The DIRECTORIES_TRANSLATION format is used where a list of directories
+ -- is given. This possible corresponding formats recognized by GNATCmd are
+ -- as shown by the following example for the case of PATH
+
+ -- PATH=direc
+ -- PATH=(direc,direc,direc,direc)
+
+ -- When more than one directory is present for the DIRECTORIES case, then
+ -- multiple instances of the corresponding unix switch are generated,
+ -- with the file name being substituted for the occurrence of *.
+
+ -- The FILE_TRANSLATION format is similar except that only a single
+ -- file is allowed, not a list of files, and only one unix switch is
+ -- generated as a result.
+
+ -- The NUMERIC_TRANSLATION format is similar to the FILE_TRANSLATION case
+ -- except that the parameter is a decimal integer in the range 0 to 999.
+
+ -- For the OPTIONS_TRANSLATION case, GNATCmd similarly permits one or
+ -- more options to appear (although only in some cases does the use of
+ -- multiple options make logical sense). For example, taking the
+ -- case of ERRORS for GCC, the following are all allowed:
+
+ -- /ERRORS=BRIEF
+ -- /ERRORS=(FULL,VERBOSE)
+ -- /ERRORS=(BRIEF IMMEDIATE)
+
+ -- If no option is provided (e.g. just /ERRORS is written), then the
+ -- first option in the list is the default option. For /ERRORS this
+ -- is NORMAL, so /ERRORS with no option is equivalent to /ERRORS=NORMAL.
+
+ -- The COMMANDS_TRANSLATION case is only used for gnatmake, to correspond
+ -- to the use of -cargs, -bargs and -largs (the ARGS string as indicated
+ -- is one of these three possibilities). The name given by COMMAND is the
+ -- corresponding command name to be used to interprete the switches to be
+ -- passed on. Switches of this type set modes, e.g. /COMPILER_QUALIFIERS
+ -- sets the mode so that all subsequent switches, up to another switch
+ -- with COMMANDS_TRANSLATION apply to the corresponding commands issued
+ -- by the make utility. For example
+
+ -- /COMPILER_QUALIFIERS /LIST /BINDER_QUALIFIERS /MAIN
+ -- /COMPILER_QUALIFIERS /NOLIST /COMPILE_CHECKS=SYNTAX
+
+ -- Clearly these switches must come at the end of the list of switches
+ -- since all subsequent switches apply to an issued command.
+
+ -- For the DIRECT_TRANSLATION case, an implicit additional entry is
+ -- created by prepending NO to the name of the qualifer, and then
+ -- inverting the sense of the UNIX_SWITCHES string. For example,
+ -- given the entry:
+
+ -- "/LIST -gnatl"
+
+ -- An implicit entry is created:
+
+ -- "/NOLIST !-gnatl"
+
+ -- In the case where, a ! is already present, inverting the sense of the
+ -- switch means removing it.
+
+ subtype S is String;
+ -- A synonym to shorten the table
+
+ type String_Ptr is access constant String;
+ -- String pointer type used throughout
+
+ type Switches is array (Natural range <>) of String_Ptr;
+ -- Type used for array of swtiches
+
+ type Switches_Ptr is access constant Switches;
+
+ ----------------------------
+ -- Switches for GNAT BIND --
+ ----------------------------
+
+ S_Bind_Bind : aliased constant S := "/BIND_FILE=" &
+ "ADA " &
+ "-A " &
+ "C " &
+ "-C";
+
+ S_Bind_Build : aliased constant S := "/BUILD_LIBRARY=|" &
+ "-L|";
+
+ S_Bind_Current : aliased constant S := "/CURRENT_DIRECTORY " &
+ "!-I-";
+
+ S_Bind_Debug : aliased constant S := "/DEBUG=" &
+ "TRACEBACK " &
+ "-g2 " &
+ "ALL " &
+ "-g3 " &
+ "NONE " &
+ "-g0 " &
+ "SYMBOLS " &
+ "-g1 " &
+ "NOSYMBOLS " &
+ "!-g1 " &
+ "LINK " &
+ "-g3 " &
+ "NOTRACEBACK " &
+ "!-g2";
+
+ S_Bind_DebugX : aliased constant S := "/NODEBUG " &
+ "!-g";
+
+ S_Bind_Elab : aliased constant S := "/ELABORATION_DEPENDENCIES " &
+ "-e";
+
+ S_Bind_Error : aliased constant S := "/ERROR_LIMIT=#" &
+ "-m#";
+
+ S_Bind_Full : aliased constant S := "/FULL_ELABORATION " &
+ "-f";
+
+ S_Bind_Library : aliased constant S := "/LIBRARY_SEARCH=*" &
+ "-aO*";
+
+ S_Bind_Linker : aliased constant S := "/LINKER_OPTION_LIST " &
+ "-K";
+
+ S_Bind_Main : aliased constant S := "/MAIN " &
+ "!-n";
+
+ S_Bind_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
+ "-nostdinc";
+
+ S_Bind_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
+ "-nostdlib";
+
+ S_Bind_Object : aliased constant S := "/OBJECT_LIST " &
+ "-O";
+
+ S_Bind_Order : aliased constant S := "/ORDER_OF_ELABORATION " &
+ "-l";
+
+ S_Bind_Output : aliased constant S := "/OUTPUT=@" &
+ "-o@";
+
+ S_Bind_OutputX : aliased constant S := "/NOOUTPUT " &
+ "-c";
+
+ S_Bind_Pess : aliased constant S := "/PESSIMISTIC_ELABORATION " &
+ "-p";
+
+ S_Bind_Read : aliased constant S := "/READ_SOURCES=" &
+ "ALL " &
+ "-s " &
+ "NONE " &
+ "-x " &
+ "AVAILABLE " &
+ "!-x,!-s";
+
+ S_Bind_ReadX : aliased constant S := "/NOREAD_SOURCES " &
+ "-x";
+
+ S_Bind_Rename : aliased constant S := "/RENAME_MAIN " &
+ "-r";
+
+ S_Bind_Report : aliased constant S := "/REPORT_ERRORS=" &
+ "VERBOSE " &
+ "-v " &
+ "BRIEF " &
+ "-b " &
+ "DEFAULT " &
+ "!-b,!-v";
+
+ S_Bind_ReportX : aliased constant S := "/NOREPORT_ERRORS " &
+ "!-b,!-v";
+
+ S_Bind_Search : aliased constant S := "/SEARCH=*" &
+ "-I*";
+
+ S_Bind_Shared : aliased constant S := "/SHARED " &
+ "-shared";
+
+ S_Bind_Source : aliased constant S := "/SOURCE_SEARCH=*" &
+ "-aI*";
+
+ S_Bind_Time : aliased constant S := "/TIME_STAMP_CHECK " &
+ "!-t";
+
+ S_Bind_Verbose : aliased constant S := "/VERBOSE " &
+ "-v";
+
+ S_Bind_Warn : aliased constant S := "/WARNINGS=" &
+ "NORMAL " &
+ "!-ws,!-we " &
+ "SUPPRESS " &
+ "-ws " &
+ "ERROR " &
+ "-we";
+
+ S_Bind_WarnX : aliased constant S := "/NOWARNINGS " &
+ "-ws";
+
+ Bind_Switches : aliased constant Switches := (
+ S_Bind_Bind 'Access,
+ S_Bind_Build 'Access,
+ S_Bind_Current 'Access,
+ S_Bind_Debug 'Access,
+ S_Bind_DebugX 'Access,
+ S_Bind_Elab 'Access,
+ S_Bind_Error 'Access,
+ S_Bind_Full 'Access,
+ S_Bind_Library 'Access,
+ S_Bind_Linker 'Access,
+ S_Bind_Main 'Access,
+ S_Bind_Nostinc 'Access,
+ S_Bind_Nostlib 'Access,
+ S_Bind_Object 'Access,
+ S_Bind_Order 'Access,
+ S_Bind_Output 'Access,
+ S_Bind_OutputX 'Access,
+ S_Bind_Pess 'Access,
+ S_Bind_Read 'Access,
+ S_Bind_ReadX 'Access,
+ S_Bind_Rename 'Access,
+ S_Bind_Report 'Access,
+ S_Bind_ReportX 'Access,
+ S_Bind_Search 'Access,
+ S_Bind_Shared 'Access,
+ S_Bind_Source 'Access,
+ S_Bind_Time 'Access,
+ S_Bind_Verbose 'Access,
+ S_Bind_Warn 'Access,
+ S_Bind_WarnX 'Access);
+
+ ----------------------------
+ -- Switches for GNAT CHOP --
+ ----------------------------
+
+ S_Chop_Comp : aliased constant S := "/COMPILATION " &
+ "-c";
+
+ S_Chop_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" &
+ "-k#";
+
+ S_Chop_Help : aliased constant S := "/HELP " &
+ "-h";
+
+ S_Chop_Over : aliased constant S := "/OVERWRITE " &
+ "-w";
+
+ S_Chop_Quiet : aliased constant S := "/QUIET " &
+ "-q";
+
+ S_Chop_Ref : aliased constant S := "/REFERENCE " &
+ "-r";
+
+ S_Chop_Verb : aliased constant S := "/VERBOSE " &
+ "-v";
+
+ Chop_Switches : aliased constant Switches := (
+ S_Chop_Comp 'Access,
+ S_Chop_File 'Access,
+ S_Chop_Help 'Access,
+ S_Chop_Over 'Access,
+ S_Chop_Quiet 'Access,
+ S_Chop_Ref 'Access,
+ S_Chop_Verb 'Access);
+
+ -------------------------------
+ -- Switches for GNAT COMPILE --
+ -------------------------------
+
+ S_GCC_Ada_83 : aliased constant S := "/83 " &
+ "-gnat83";
+
+ S_GCC_Ada_95 : aliased constant S := "/95 " &
+ "!-gnat83";
+
+ S_GCC_Asm : aliased constant S := "/ASM " &
+ "-S,!-c";
+
+ S_GCC_Checks : aliased constant S := "/CHECKS=" &
+ "FULL " &
+ "-gnato,!-gnatE,!-gnatp " &
+ "OVERFLOW " &
+ "-gnato " &
+ "ELABORATION " &
+ "-gnatE " &
+ "ASSERTIONS " &
+ "-gnata " &
+ "DEFAULT " &
+ "!-gnato,!-gnatp " &
+ "SUPPRESS_ALL " &
+ "-gnatp";
+
+ S_GCC_ChecksX : aliased constant S := "/NOCHECKS " &
+ "-gnatp,!-gnato,!-gnatE";
+
+ S_GCC_Compres : aliased constant S := "/COMPRESS_NAMES " &
+ "-gnatC";
+
+ S_GCC_Current : aliased constant S := "/CURRENT_DIRECTORY " &
+ "!-I-";
+
+ S_GCC_Debug : aliased constant S := "/DEBUG=" &
+ "SYMBOLS " &
+ "-g2 " &
+ "NOSYMBOLS " &
+ "!-g2 " &
+ "TRACEBACK " &
+ "-g1 " &
+ "ALL " &
+ "-g3 " &
+ "NONE " &
+ "-g0 " &
+ "NOTRACEBACK " &
+ "-g0";
+
+ S_GCC_DebugX : aliased constant S := "/NODEBUG " &
+ "!-g";
+
+ S_GCC_Dist : aliased constant S := "/DISTRIBUTION_STUBS=" &
+ "RECEIVER " &
+ "-gnatzr " &
+ "CALLER " &
+ "-gnatzc";
+
+ S_GCC_DistX : aliased constant S := "/NODISTRIBUTION_STUBS " &
+ "!-gnatzr,!-gnatzc";
+
+ S_GCC_Error : aliased constant S := "/ERROR_LIMIT=#" &
+ "-gnatm#";
+
+ S_GCC_ErrorX : aliased constant S := "/NOERROR_LIMIT " &
+ "-gnatm999";
+
+ S_GCC_Expand : aliased constant S := "/EXPAND_SOURCE " &
+ "-gnatG";
+
+ S_GCC_Extend : aliased constant S := "/EXTENSIONS_ALLOWED " &
+ "-gnatX";
+
+ S_GCC_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" &
+ "-gnatk#";
+
+ S_GCC_Force : aliased constant S := "/FORCE_ALI " &
+ "-gnatQ";
+
+ S_GCC_Ident : aliased constant S := "/IDENTIFIER_CHARACTER_SET=" &
+ "DEFAULT " &
+ "-gnati1 " &
+ "1 " &
+ "-gnati1 " &
+ "2 " &
+ "-gnati2 " &
+ "3 " &
+ "-gnati3 " &
+ "4 " &
+ "-gnati4 " &
+ "PC " &
+ "-gnatip " &
+ "PC850 " &
+ "-gnati8 " &
+ "FULL_UPPER " &
+ "-gnatif " &
+ "NO_UPPER " &
+ "-gnatin " &
+ "WIDE " &
+ "-gnatiw";
+
+ S_GCC_IdentX : aliased constant S := "/NOIDENTIFIER_CHARACTER_SET " &
+ "-gnati1";
+
+ S_GCC_Inline : aliased constant S := "/INLINE=" &
+ "PRAGMA " &
+ "-gnatn " &
+ "SUPPRESS " &
+ "-fno-inline";
+
+ S_GCC_InlineX : aliased constant S := "/NOINLINE " &
+ "!-gnatn";
+
+ S_GCC_List : aliased constant S := "/LIST " &
+ "-gnatl";
+
+ S_GCC_Noload : aliased constant S := "/NOLOAD " &
+ "-gnatc";
+
+ S_GCC_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
+ "-nostdinc";
+
+ S_GCC_Opt : aliased constant S := "/OPTIMIZE=" &
+ "ALL " &
+ "-O2,!-O0,!-O1,!-O3 " &
+ "NONE " &
+ "-O0,!-O1,!-O2,!-O3 " &
+ "SOME " &
+ "-O1,!-O0,!-O2,!-O3 " &
+ "DEVELOPMENT " &
+ "-O1,!-O0,!-O2,!-O3 " &
+ "UNROLL_LOOPS " &
+ "-funroll-loops " &
+ "INLINING " &
+ "-O3,!-O0,!-O1,!-O2";
+
+ S_GCC_OptX : aliased constant S := "/NOOPTIMIZE " &
+ "-O0,!-O1,!-O2,!-O3";
+
+ S_GCC_Report : aliased constant S := "/REPORT_ERRORS=" &
+ "VERBOSE " &
+ "-gnatv " &
+ "BRIEF " &
+ "-gnatb " &
+ "FULL " &
+ "-gnatf " &
+ "IMMEDIATE " &
+ "-gnate " &
+ "DEFAULT " &
+ "!-gnatb,!-gnatv";
+
+ S_GCC_ReportX : aliased constant S := "/NOREPORT_ERRORS " &
+ "!-gnatb,!-gnatv";
+
+ S_GCC_Repinfo : aliased constant S := "/REPRESENTATION_INFO=" &
+ "ARRAYS " &
+ "-gnatR1 " &
+ "NONE " &
+ "-gnatR0 " &
+ "OBJECTS " &
+ "-gnatR2 " &
+ "SYMBOLIC " &
+ "-gnatR3 " &
+ "DEFAULT " &
+ "-gnatR";
+
+ S_GCC_RepinfX : aliased constant S := "/NOREPRESENTATION_INFO " &
+ "!-gnatR";
+
+ S_GCC_Search : aliased constant S := "/SEARCH=*" &
+ "-I*";
+
+ S_GCC_Style : aliased constant S := "/STYLE_CHECKS=" &
+ "ALL_BUILTIN " &
+ "-gnaty " &
+ "1 " &
+ "-gnaty1 " &
+ "2 " &
+ "-gnaty2 " &
+ "3 " &
+ "-gnaty3 " &
+ "4 " &
+ "-gnaty4 " &
+ "5 " &
+ "-gnaty5 " &
+ "6 " &
+ "-gnaty6 " &
+ "7 " &
+ "-gnaty7 " &
+ "8 " &
+ "-gnaty8 " &
+ "9 " &
+ "-gnaty9 " &
+ "ATTRIBUTE " &
+ "-gnatya " &
+ "BLANKS " &
+ "-gnatyb " &
+ "COMMENTS " &
+ "-gnatyc " &
+ "END " &
+ "-gnatye " &
+ "VTABS " &
+ "-gnatyf " &
+ "GNAT " &
+ "-gnatg " &
+ "HTABS " &
+ "-gnatyh " &
+ "IF_THEN " &
+ "-gnatyi " &
+ "KEYWORD " &
+ "-gnatyk " &
+ "LAYOUT " &
+ "-gnatyl " &
+ "LINE_LENGTH " &
+ "-gnatym " &
+ "STANDARD_CASING " &
+ "-gnatyn " &
+ "ORDERED_SUBPROGRAMS " &
+ "-gnatyo " &
+ "NONE " &
+ "!-gnatg,!-gnatr " &
+ "PRAGMA " &
+ "-gnatyp " &
+ "REFERENCES " &
+ "-gnatr " &
+ "SPECS " &
+ "-gnatys " &
+ "TOKEN " &
+ "-gnatyt ";
+
+ S_GCC_StyleX : aliased constant S := "/NOSTYLE_CHECKS " &
+ "!-gnatg,!-gnatr";
+
+ S_GCC_Syntax : aliased constant S := "/SYNTAX_ONLY " &
+ "-gnats";
+
+ S_GCC_Trace : aliased constant S := "/TRACE_UNITS " &
+ "-gnatdc";
+
+ S_GCC_Tree : aliased constant S := "/TREE_OUTPUT " &
+ "-gnatt";
+
+ S_GCC_Trys : aliased constant S := "/TRY_SEMANTICS " &
+ "-gnatq";
+
+ S_GCC_Units : aliased constant S := "/UNITS_LIST " &
+ "-gnatu";
+
+ S_GCC_Unique : aliased constant S := "/UNIQUE_ERROR_TAG " &
+ "-gnatU";
+
+ S_GCC_Upcase : aliased constant S := "/UPPERCASE_EXTERNALS " &
+ "-gnatF";
+
+ S_GCC_Valid : aliased constant S := "/VALIDITY_CHECKING=" &
+ "RM " &
+ "-gnatVd " &
+ "NONE " &
+ "-gnatV0 " &
+ "FULL " &
+ "-gnatVf";
+
+ S_GCC_Verbose : aliased constant S := "/VERBOSE " &
+ "-v";
+
+ S_GCC_Warn : aliased constant S := "/WARNINGS=" &
+ "DEFAULT " &
+ "!-gnatws,!-gnatwe " &
+ "ALL_GCC " &
+ "-Wall " &
+ "CONDITIONALS " &
+ "-gnatwc " &
+ "NOCONDITIONALS " &
+ "-gnatwC " &
+ "ELABORATION " &
+ "-gnatwl " &
+ "NOELABORATION " &
+ "-gnatwL " &
+ "ERRORS " &
+ "-gnatwe " &
+ "HIDING " &
+ "-gnatwh " &
+ "NOHIDING " &
+ "-gnatwH " &
+ "IMPLEMENTATION " &
+ "-gnatwi " &
+ "NOIMPLEMENTATION " &
+ "-gnatwI " &
+ "OPTIONAL " &
+ "-gnatwa " &
+ "NOOPTIONAL " &
+ "-gnatwA " &
+ "OVERLAYS " &
+ "-gnatwo " &
+ "NOOVERLAYS " &
+ "-gnatwO " &
+ "REDUNDANT " &
+ "-gnatwr " &
+ "NOREDUNDANT " &
+ "-gnatwR " &
+ "SUPPRESS " &
+ "-gnatws " &
+ "UNINITIALIZED " &
+ "-Wuninitialized " &
+ "UNUSED " &
+ "-gnatwu " &
+ "NOUNUSED " &
+ "-gnatwU";
+
+ S_GCC_WarnX : aliased constant S := "/NOWARNINGS " &
+ "-gnatws";
+
+ S_GCC_Wide : aliased constant S := "/WIDE_CHARACTER_ENCODING=" &
+ "BRACKETS " &
+ "-gnatWb " &
+ "NONE " &
+ "-gnatWn " &
+ "HEX " &
+ "-gnatWh " &
+ "UPPER " &
+ "-gnatWu " &
+ "SHIFT_JIS " &
+ "-gnatWs " &
+ "UTF8 " &
+ "-gnatW8 " &
+ "EUC " &
+ "-gnatWe";
+
+ S_GCC_WideX : aliased constant S := "/NOWIDE_CHARACTER_ENCODING " &
+ "-gnatWn";
+
+ S_GCC_Xdebug : aliased constant S := "/XDEBUG " &
+ "-gnatD";
+
+ S_GCC_Xref : aliased constant S := "/XREF=" &
+ "GENERATE " &
+ "!-gnatx " &
+ "SUPPRESS " &
+ "-gnatx";
+
+ GCC_Switches : aliased constant Switches := (
+ S_GCC_Ada_83 'Access,
+ S_GCC_Ada_95 'Access,
+ S_GCC_Asm 'Access,
+ S_GCC_Checks 'Access,
+ S_GCC_ChecksX 'Access,
+ S_GCC_Compres 'Access,
+ S_GCC_Current 'Access,
+ S_GCC_Debug 'Access,
+ S_GCC_DebugX 'Access,
+ S_GCC_Dist 'Access,
+ S_GCC_DistX 'Access,
+ S_GCC_Error 'Access,
+ S_GCC_ErrorX 'Access,
+ S_GCC_Expand 'Access,
+ S_GCC_Extend 'Access,
+ S_GCC_File 'Access,
+ S_GCC_Force 'Access,
+ S_GCC_Ident 'Access,
+ S_GCC_IdentX 'Access,
+ S_GCC_Inline 'Access,
+ S_GCC_InlineX 'Access,
+ S_GCC_List 'Access,
+ S_GCC_Noload 'Access,
+ S_GCC_Nostinc 'Access,
+ S_GCC_Opt 'Access,
+ S_GCC_OptX 'Access,
+ S_GCC_Report 'Access,
+ S_GCC_ReportX 'Access,
+ S_GCC_Repinfo 'Access,
+ S_GCC_RepinfX 'Access,
+ S_GCC_Search 'Access,
+ S_GCC_Style 'Access,
+ S_GCC_StyleX 'Access,
+ S_GCC_Syntax 'Access,
+ S_GCC_Trace 'Access,
+ S_GCC_Tree 'Access,
+ S_GCC_Trys 'Access,
+ S_GCC_Units 'Access,
+ S_GCC_Unique 'Access,
+ S_GCC_Upcase 'Access,
+ S_GCC_Valid 'Access,
+ S_GCC_Verbose 'Access,
+ S_GCC_Warn 'Access,
+ S_GCC_WarnX 'Access,
+ S_GCC_Wide 'Access,
+ S_GCC_WideX 'Access,
+ S_GCC_Xdebug 'Access,
+ S_GCC_Xref 'Access);
+
+ ----------------------------
+ -- Switches for GNAT ELIM --
+ ----------------------------
+
+ S_Elim_All : aliased constant S := "/ALL " &
+ "-a";
+
+ S_Elim_Miss : aliased constant S := "/MISSED " &
+ "-m";
+
+ S_Elim_Verb : aliased constant S := "/VERBOSE " &
+ "-v";
+
+ Elim_Switches : aliased constant Switches := (
+ S_Elim_All 'Access,
+ S_Elim_Miss 'Access,
+ S_Elim_Verb 'Access);
+
+ ----------------------------
+ -- Switches for GNAT FIND --
+ ----------------------------
+
+ S_Find_All : aliased constant S := "/ALL_FILES " &
+ "-a";
+
+ S_Find_Expr : aliased constant S := "/EXPRESSIONS " &
+ "-e";
+
+ S_Find_Full : aliased constant S := "/FULL_PATHNAME " &
+ "-f";
+
+ S_Find_Ignore : aliased constant S := "/IGNORE_LOCALS " &
+ "-g";
+
+ S_Find_Object : aliased constant S := "/OBJECT_SEARCH=*" &
+ "-aO*";
+
+ S_Find_Print : aliased constant S := "/PRINT_LINES " &
+ "-s";
+
+ S_Find_Project : aliased constant S := "/PROJECT=@" &
+ "-p@";
+
+ S_Find_Ref : aliased constant S := "/REFERENCES " &
+ "-r";
+
+ S_Find_Search : aliased constant S := "/SEARCH=*" &
+ "-I*";
+
+ S_Find_Source : aliased constant S := "/SOURCE_SEARCH=*" &
+ "-aI*";
+
+ Find_Switches : aliased constant Switches := (
+ S_Find_All 'Access,
+ S_Find_Expr 'Access,
+ S_Find_Full 'Access,
+ S_Find_Ignore 'Access,
+ S_Find_Object 'Access,
+ S_Find_Print 'Access,
+ S_Find_Project 'Access,
+ S_Find_Ref 'Access,
+ S_Find_Search 'Access,
+ S_Find_Source 'Access);
+
+ ------------------------------
+ -- Switches for GNAT KRUNCH --
+ ------------------------------
+
+ S_Krunch_Count : aliased constant S := "/COUNT=#" &
+ "`#";
+
+ Krunch_Switches : aliased constant Switches := (1 .. 1 =>
+ S_Krunch_Count 'Access);
+
+ -------------------------------
+ -- Switches for GNAT LIBRARY --
+ -------------------------------
+
+ S_Lbr_Config : aliased constant S := "/CONFIG=@" &
+ "--config=@";
+
+ S_Lbr_Create : aliased constant S := "/CREATE=%" &
+ "--create=%";
+
+ S_Lbr_Delete : aliased constant S := "/DELETE=%" &
+ "--delete=%";
+
+ S_Lbr_Set : aliased constant S := "/SET=%" &
+ "--set=%";
+
+ Lbr_Switches : aliased constant Switches := (
+ S_Lbr_Config 'Access,
+ S_Lbr_Create 'Access,
+ S_Lbr_Delete 'Access,
+ S_Lbr_Set 'Access);
+
+ ----------------------------
+ -- Switches for GNAT LINK --
+ ----------------------------
+
+ S_Link_Bind : aliased constant S := "/BIND_FILE=" &
+ "ADA " &
+ "-A " &
+ "C " &
+ "-C";
+
+ S_Link_Debug : aliased constant S := "/DEBUG=" &
+ "ALL " &
+ "-g3 " &
+ "NONE " &
+ "-g0 " &
+ "TRACEBACK " &
+ "-g1 " &
+ "NOTRACEBACK " &
+ "-g0";
+
+ S_Link_Execut : aliased constant S := "/EXECUTABLE=@" &
+ "-o@";
+
+ S_Link_Ident : aliased constant S := "/IDENTIFICATION=" & '"' &
+ "--for-linker=IDENT=" &
+ '"';
+
+ S_Link_Nocomp : aliased constant S := "/NOCOMPILE " &
+ "-n";
+
+ S_Link_Nofiles : aliased constant S := "/NOSTART_FILES " &
+ "-nostartfiles";
+
+ S_Link_Noinhib : aliased constant S := "/NOINHIBIT-EXEC " &
+ "--for-linker=--noinhibit-exec";
+
+ S_Link_Static : aliased constant S := "/STATIC " &
+ "--for-linker=-static";
+
+ S_Link_Verb : aliased constant S := "/VERBOSE " &
+ "-v";
+
+ S_Link_ZZZZZ : aliased constant S := "/<other> " &
+ "--for-linker=";
+
+ Link_Switches : aliased constant Switches := (
+ S_Link_Bind 'Access,
+ S_Link_Debug 'Access,
+ S_Link_Execut 'Access,
+ S_Link_Ident 'Access,
+ S_Link_Nocomp 'Access,
+ S_Link_Nofiles 'Access,
+ S_Link_Noinhib 'Access,
+ S_Link_Static 'Access,
+ S_Link_Verb 'Access,
+ S_Link_ZZZZZ 'Access);
+
+ ----------------------------
+ -- Switches for GNAT LIST --
+ ----------------------------
+
+ S_List_All : aliased constant S := "/ALL_UNITS " &
+ "-a";
+
+ S_List_Current : aliased constant S := "/CURRENT_DIRECTORY " &
+ "!-I-";
+
+ S_List_Depend : aliased constant S := "/DEPENDENCIES " &
+ "-d";
+
+ S_List_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
+ "-nostdinc";
+
+ S_List_Object : aliased constant S := "/OBJECT_SEARCH=*" &
+ "-aO*";
+
+ S_List_Output : aliased constant S := "/OUTPUT=" &
+ "SOURCES " &
+ "-s " &
+ "OBJECTS " &
+ "-o " &
+ "UNITS " &
+ "-u " &
+ "OPTIONS " &
+ "-h " &
+ "VERBOSE " &
+ "-v ";
+
+ S_List_Search : aliased constant S := "/SEARCH=*" &
+ "-I*";
+
+ S_List_Source : aliased constant S := "/SOURCE_SEARCH=*" &
+ "-aI*";
+
+ List_Switches : aliased constant Switches := (
+ S_List_All 'Access,
+ S_List_Current 'Access,
+ S_List_Depend 'Access,
+ S_List_Nostinc 'Access,
+ S_List_Object 'Access,
+ S_List_Output 'Access,
+ S_List_Search 'Access,
+ S_List_Source 'Access);
+
+ ----------------------------
+ -- Switches for GNAT MAKE --
+ ----------------------------
+
+ S_Make_All : aliased constant S := "/ALL_FILES " &
+ "-a";
+
+ S_Make_Bind : aliased constant S := "/BINDER_QUALIFIERS=?" &
+ "-bargs BIND";
+
+ S_Make_Comp : aliased constant S := "/COMPILER_QUALIFIERS=?" &
+ "-cargs COMPILE";
+
+ S_Make_Cond : aliased constant S := "/CONDITIONAL_SOURCE_SEARCH=*" &
+ "-A*";
+
+ S_Make_Cont : aliased constant S := "/CONTINUE_ON_ERROR " &
+ "-k";
+
+ S_Make_Current : aliased constant S := "/CURRENT_DIRECTORY " &
+ "!-I-";
+
+ S_Make_Dep : aliased constant S := "/DEPENDENCIES_LIST " &
+ "-M";
+
+ S_Make_Doobj : aliased constant S := "/DO_OBJECT_CHECK " &
+ "-n";
+
+ S_Make_Execut : aliased constant S := "/EXECUTABLE=@" &
+ "-o@";
+
+ S_Make_Force : aliased constant S := "/FORCE_COMPILE " &
+ "-f";
+
+ S_Make_Inplace : aliased constant S := "/IN_PLACE " &
+ "-i";
+
+ S_Make_Library : aliased constant S := "/LIBRARY_SEARCH=*" &
+ "-L*";
+
+ S_Make_Link : aliased constant S := "/LINKER_QUALIFIERS=?" &
+ "-largs LINK";
+
+ S_Make_Minimal : aliased constant S := "/MINIMAL_RECOMPILATION " &
+ "-m";
+
+ S_Make_Nolink : aliased constant S := "/NOLINK " &
+ "-c";
+
+ S_Make_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
+ "-nostdinc";
+
+ S_Make_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
+ "-nostdlib";
+
+ S_Make_Object : aliased constant S := "/OBJECT_SEARCH=*" &
+ "-aO*";
+
+ S_Make_Proc : aliased constant S := "/PROCESSES=#" &
+ "-j#";
+
+ S_Make_Nojobs : aliased constant S := "/NOPROCESSES " &
+ "-j1";
+
+ S_Make_Quiet : aliased constant S := "/QUIET " &
+ "-q";
+
+ S_Make_Reason : aliased constant S := "/REASONS " &
+ "-v";
+
+ S_Make_Search : aliased constant S := "/SEARCH=*" &
+ "-I*";
+
+ S_Make_Skip : aliased constant S := "/SKIP_MISSING=*" &
+ "-aL*";
+
+ S_Make_Source : aliased constant S := "/SOURCE_SEARCH=*" &
+ "-aI*";
+
+ S_Make_Verbose : aliased constant S := "/VERBOSE " &
+ "-v";
+
+ Make_Switches : aliased constant Switches := (
+ S_Make_All 'Access,
+ S_Make_Bind 'Access,
+ S_Make_Comp 'Access,
+ S_Make_Cond 'Access,
+ S_Make_Cont 'Access,
+ S_Make_Current 'Access,
+ S_Make_Dep 'Access,
+ S_Make_Doobj 'Access,
+ S_Make_Execut 'Access,
+ S_Make_Force 'Access,
+ S_Make_Inplace 'Access,
+ S_Make_Library 'Access,
+ S_Make_Link 'Access,
+ S_Make_Minimal 'Access,
+ S_Make_Nolink 'Access,
+ S_Make_Nostinc 'Access,
+ S_Make_Nostlib 'Access,
+ S_Make_Object 'Access,
+ S_Make_Proc 'Access,
+ S_Make_Nojobs 'Access,
+ S_Make_Quiet 'Access,
+ S_Make_Reason 'Access,
+ S_Make_Search 'Access,
+ S_Make_Skip 'Access,
+ S_Make_Source 'Access,
+ S_Make_Verbose 'Access);
+
+ ----------------------------------
+ -- Switches for GNAT PREPROCESS --
+ ----------------------------------
+
+ S_Prep_Blank : aliased constant S := "/BLANK_LINES " &
+ "-b";
+
+ S_Prep_Com : aliased constant S := "/COMMENTS " &
+ "-c";
+
+ S_Prep_Ref : aliased constant S := "/REFERENCE " &
+ "-r";
+
+ S_Prep_Remove : aliased constant S := "/REMOVE " &
+ "!-b,!-c";
+
+ S_Prep_Symbols : aliased constant S := "/SYMBOLS " &
+ "-s";
+
+ S_Prep_Undef : aliased constant S := "/UNDEFINED " &
+ "-u";
+
+ S_Prep_Verbose : aliased constant S := "/VERBOSE " &
+ "-v";
+
+ S_Prep_Version : aliased constant S := "/VERSION " &
+ "-v";
+
+ Prep_Switches : aliased constant Switches := (
+ S_Prep_Blank 'Access,
+ S_Prep_Com 'Access,
+ S_Prep_Ref 'Access,
+ S_Prep_Remove 'Access,
+ S_Prep_Symbols 'Access,
+ S_Prep_Undef 'Access,
+ S_Prep_Verbose 'Access,
+ S_Prep_Version 'Access);
+
+ ------------------------------
+ -- Switches for GNAT SHARED --
+ ------------------------------
+
+ S_Shared_Debug : aliased constant S := "/DEBUG=" &
+ "ALL " &
+ "-g3 " &
+ "NONE " &
+ "-g0 " &
+ "TRACEBACK " &
+ "-g1 " &
+ "NOTRACEBACK " &
+ "-g0";
+
+ S_Shared_Image : aliased constant S := "/IMAGE=@" &
+ "-o@";
+
+ S_Shared_Ident : aliased constant S := "/IDENTIFICATION=" & '"' &
+ "--for-linker=IDENT=" &
+ '"';
+
+ S_Shared_Nofiles : aliased constant S := "/NOSTART_FILES " &
+ "-nostartfiles";
+
+ S_Shared_Noinhib : aliased constant S := "/NOINHIBIT-IMAGE " &
+ "--for-linker=--noinhibit-exec";
+
+ S_Shared_Verb : aliased constant S := "/VERBOSE " &
+ "-v";
+
+ S_Shared_ZZZZZ : aliased constant S := "/<other> " &
+ "--for-linker=";
+
+ Shared_Switches : aliased constant Switches := (
+ S_Shared_Debug 'Access,
+ S_Shared_Image 'Access,
+ S_Shared_Ident 'Access,
+ S_Shared_Nofiles 'Access,
+ S_Shared_Noinhib 'Access,
+ S_Shared_Verb 'Access,
+ S_Shared_ZZZZZ 'Access);
+
+ --------------------------------
+ -- Switches for GNAT STANDARD --
+ --------------------------------
+
+ Standard_Switches : aliased constant Switches := (1 .. 0 => null);
+
+ ----------------------------
+ -- Switches for GNAT STUB --
+ ----------------------------
+
+ S_Stub_Current : aliased constant S := "/CURRENT_DIRECTORY " &
+ "!-I-";
+
+ S_Stub_Full : aliased constant S := "/FULL " &
+ "-f";
+
+ S_Stub_Header : aliased constant S := "/HEADER=" &
+ "GENERAL " &
+ "-hg " &
+ "SPEC " &
+ "-hs";
+
+ S_Stub_Indent : aliased constant S := "/INDENTATION=#" &
+ "-i#";
+
+ S_Stub_Length : aliased constant S := "/LINE_LENGTH=#" &
+ "-l#";
+
+ S_Stub_Quiet : aliased constant S := "/QUIET " &
+ "-q";
+
+ S_Stub_Search : aliased constant S := "/SEARCH=*" &
+ "-I*";
+
+ S_Stub_Tree : aliased constant S := "/TREE_FILE=" &
+ "OVERWRITE " &
+ "-t " &
+ "SAVE " &
+ "-k " &
+ "REUSE " &
+ "-r";
+
+ S_Stub_Verbose : aliased constant S := "/VERBOSE " &
+ "-v";
+
+ Stub_Switches : aliased constant Switches := (
+ S_Stub_Current 'Access,
+ S_Stub_Full 'Access,
+ S_Stub_Header 'Access,
+ S_Stub_Indent 'Access,
+ S_Stub_Length 'Access,
+ S_Stub_Quiet 'Access,
+ S_Stub_Search 'Access,
+ S_Stub_Tree 'Access,
+ S_Stub_Verbose 'Access);
+
+ ------------------------------
+ -- Switches for GNAT SYSTEM --
+ ------------------------------
+
+ System_Switches : aliased constant Switches := (1 .. 0 => null);
+
+ ----------------------------
+ -- Switches for GNAT XREF --
+ ----------------------------
+
+ S_Xref_All : aliased constant S := "/ALL_FILES " &
+ "-a";
+
+ S_Xref_Full : aliased constant S := "/FULL_PATHNAME " &
+ "-f";
+
+ S_Xref_Global : aliased constant S := "/IGNORE_LOCALS " &
+ "-g";
+
+ S_Xref_Object : aliased constant S := "/OBJECT_SEARCH=*" &
+ "-aO*";
+
+ S_Xref_Project : aliased constant S := "/PROJECT=@" &
+ "-p@";
+
+ S_Xref_Search : aliased constant S := "/SEARCH=*" &
+ "-I*";
+
+ S_Xref_Source : aliased constant S := "/SOURCE_SEARCH=*" &
+ "-aI*";
+
+ S_Xref_Output : aliased constant S := "/UNUSED " &
+ "-u";
+
+ Xref_Switches : aliased constant Switches := (
+ S_Xref_All 'Access,
+ S_Xref_Full 'Access,
+ S_Xref_Global 'Access,
+ S_Xref_Object 'Access,
+ S_Xref_Project 'Access,
+ S_Xref_Search 'Access,
+ S_Xref_Source 'Access,
+ S_Xref_Output 'Access);
+
+ -------------------
+ -- COMMAND TABLE --
+ -------------------
+
+ -- The command table contains an entry for each command recognized by
+ -- GNATCmd. The entries are represented by an array of records.
+
+ type Parameter_Type is
+ -- A parameter is defined as a whitespace bounded string, not begining
+ -- with a slash. (But see note under FILES_OR_WILDCARD).
+ (File,
+ -- A required file or directory parameter.
+
+ Optional_File,
+ -- An optional file or directory parameter.
+
+ Other_As_Is,
+ -- A parameter that's passed through as is (not canonicalized)
+
+ Unlimited_Files,
+ -- An unlimited number of writespace separate file or directory
+ -- parameters including wildcard specifications.
+
+ Files_Or_Wildcard);
+ -- A comma separated list of files and/or wildcard file specifications.
+ -- A comma preceded by or followed by whitespace is considered as a
+ -- single comma character w/o whitespace.
+
+ type Parameter_Array is array (Natural range <>) of Parameter_Type;
+ type Parameter_Ref is access all Parameter_Array;
+
+ type Command_Entry is record
+ Cname : String_Ptr;
+ -- Command name for GNAT xxx command
+
+ Usage : String_Ptr;
+ -- A usage string, used for error messages
+
+ Unixcmd : String_Ptr;
+ -- Corresponding Unix command
+
+ Switches : Switches_Ptr;
+ -- Pointer to array of switch strings
+
+ Params : Parameter_Ref;
+ -- Describes the allowable types of parameters.
+ -- Params (1) is the type of the first parameter, etc.
+ -- An empty parameter array means this command takes no 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.
+ end record;
+
+ -------------------------
+ -- 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 qualifers 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 quailifier followed by a filename
+ -- Example: GNAT LINK /EXECUTABLE=FOO.EXE
+
+ 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 qualfier.
+ -- 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
+
+ Unix_String : String_Ptr;
+ -- 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);
+
+ ----------------------------------
+ -- Declarations for GNATCMD use --
+ ----------------------------------
+
+ 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.
+
+ Last_Command : Item_Ptr;
+ -- Pointer to last item in Commands list
+
+ Normal_Exit : exception;
+ -- Raise this exception for normal program termination
+
+ Error_Exit : exception;
+ -- Raise this exception if error detected
+
+ Errors : Natural := 0;
+ -- Count errors detected
+
+ Command : Item_Ptr;
+ -- Pointer to command item for current command
+
+ Make_Commands_Active : Item_Ptr := null;
+ -- Set to point to Command entry for COMPILE, BIND, or LINK as appropriate
+ -- if a COMMANDS_TRANSLATION switch has been encountered while processing
+ -- a MAKE Command.
+
+ My_Exit_Status : Exit_Status := Success;
+
+ 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_Name => "Buffer");
+
+ Param_Count : Natural := 0;
+ -- Number of parameter arguments so far
+
+ Arg_Num : Natural;
+ -- Argument number
+
+ Display_Command : Boolean := False;
+ -- Set true if /? switch causes display of generated command
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Init_Object_Dirs return String_Ptr;
+
+ function Invert_Sense (S : String) return String_Ptr;
+ -- Given a unix switch string S, computes the inverse (adding or
+ -- removing ! characters as required), and returns a pointer to
+ -- the allocated result on the heap.
+
+ function Is_Extensionless (F : String) return Boolean;
+ -- 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.
+
+ function Match_Prefix (S1, S2 : String) return Boolean;
+ -- Determines whether S1 matches a prefix of S2. This is also a case
+ -- insensitive match (for example Match ("AB","abc") is True).
+
+ function Matching_Name
+ (S : String;
+ Itm : 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
+ -- insensitive and permits unique abbreviation. If the match succeeds,
+ -- then a pointer to the matching item is returned. Otherwise, an
+ -- appropriate error message is written. Note that the discriminant
+ -- of Itm is used to determine the appropriate form of this message.
+ -- Quiet is normally False as shown, if it is set to True, then no
+ -- error message is generated in a not found situation (null is still
+ -- returned to indicate the not-found situation).
+
+ function OK_Alphanumerplus (S : String) return Boolean;
+ -- Checks that S is a string of alphanumeric characters,
+ -- returning True if all alphanumeric characters,
+ -- False if empty or a non-alphanumeric character is present.
+
+ function OK_Integer (S : String) return Boolean;
+ -- Checks that S is a string of digits, returning True if all digits,
+ -- False if empty or a non-digit is present.
+
+ procedure Place (C : Character);
+ -- Place a single character in the buffer, updating Ptr
+
+ procedure Place (S : String);
+ -- Place a string character in the buffer, updating Ptr
+
+ procedure Place_Lower (S : String);
+ -- Place string in buffer, forcing letters to lower case, updating Ptr
+
+ procedure Place_Unix_Switches (S : String_Ptr);
+ -- Given a unix switch string, place corresponding switches in Buffer,
+ -- updating Ptr appropriatelly. Note that in the case of use of ! the
+ -- result may be to remove a previously placed switch.
+
+ procedure Validate_Command_Or_Option (N : 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.
+
+ procedure Validate_Unix_Switch (S : String_Ptr);
+ -- Check that S is a valid switch string as described in the syntax for
+ -- the switch table item UNIX_SWITCH or else begins with a backquote.
+
+ ----------------------
+ -- Init_Object_Dirs --
+ ----------------------
+
+ function Init_Object_Dirs return String_Ptr is
+ Object_Dirs : Integer;
+ Object_Dir : array (Integer range 1 .. 256) of String_Access;
+ Object_Dir_Name : String_Access;
+
+ begin
+ Object_Dirs := 0;
+ Object_Dir_Name := String_Access (Object_Dir_Default_Name);
+ Get_Next_Dir_In_Path_Init (Object_Dir_Name);
+
+ loop
+ declare
+ Dir : String_Access := String_Access
+ (Get_Next_Dir_In_Path (Object_Dir_Name));
+ begin
+ exit when Dir = null;
+ Object_Dirs := Object_Dirs + 1;
+ Object_Dir (Object_Dirs)
+ := String_Access (Normalize_Directory_Name (Dir.all));
+ end;
+ end loop;
+
+ for Dirs in 1 .. Object_Dirs loop
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := '-';
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := 'L';
+ Object_Dir_Name := new String'(
+ To_Canonical_Dir_Spec
+ (To_Host_Dir_Spec (Object_Dir (Dirs).all, True).all, True).all);
+
+ for J in Object_Dir_Name'Range loop
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := Object_Dir_Name (J);
+ end loop;
+
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := ' ';
+ end loop;
+
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := '-';
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := 'l';
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := 'g';
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := 'n';
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := 'a';
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := 't';
+
+ if Hostparm.OpenVMS then
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := ' ';
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := '-';
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := 'l';
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := 'd';
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := 'e';
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := 'c';
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := 'g';
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := 'n';
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := 'a';
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := 't';
+ end if;
+
+ return new String'(String (Buffer.Table (1 .. Buffer.Last)));
+ end Init_Object_Dirs;
+
+ ------------------
+ -- Invert_Sense --
+ ------------------
+
+ function Invert_Sense (S : String) return String_Ptr is
+ Sinv : String (1 .. S'Length * 2);
+ -- Result (for sure long enough)
+
+ Sinvp : Natural := 0;
+ -- Pointer to output string
+
+ begin
+ for Sp in S'Range loop
+ if Sp = S'First or else S (Sp - 1) = ',' then
+ if S (Sp) = '!' then
+ null;
+ else
+ Sinv (Sinvp + 1) := '!';
+ Sinv (Sinvp + 2) := S (Sp);
+ Sinvp := Sinvp + 2;
+ end if;
+
+ else
+ Sinv (Sinvp + 1) := S (Sp);
+ Sinvp := Sinvp + 1;
+ end if;
+ end loop;
+
+ return new String'(Sinv (1 .. Sinvp));
+ end Invert_Sense;
+
+ ----------------------
+ -- Is_Extensionless --
+ ----------------------
+
+ function Is_Extensionless (F : String) return Boolean is
+ begin
+ for J in reverse F'Range loop
+ if F (J) = '.' then
+ return False;
+ elsif F (J) = '/' or else F (J) = ']' or else F (J) = ':' then
+ return True;
+ end if;
+ end loop;
+
+ return True;
+ end Is_Extensionless;
+
+ -----------
+ -- Match --
+ -----------
+
+ function Match (S1, S2 : String) return Boolean is
+ Dif : constant Integer := S2'First - S1'First;
+
+ begin
+
+ if S1'Length /= S2'Length then
+ return False;
+
+ else
+ for J in S1'Range loop
+ if To_Lower (S1 (J)) /= To_Lower (S2 (J + Dif)) then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end if;
+ end Match;
+
+ ------------------
+ -- Match_Prefix --
+ ------------------
+
+ function Match_Prefix (S1, S2 : String) return Boolean is
+ begin
+ if S1'Length > S2'Length then
+ return False;
+ else
+ return Match (S1, S2 (S2'First .. S2'First + S1'Length - 1));
+ end if;
+ end Match_Prefix;
+
+ -------------------
+ -- Matching_Name --
+ -------------------
+
+ function Matching_Name
+ (S : String;
+ Itm : Item_Ptr;
+ Quiet : Boolean := False)
+ return Item_Ptr
+ is
+ P1, P2 : Item_Ptr;
+
+ procedure Err;
+ -- Little procedure to output command/qualifier/option as appropriate
+ -- and bump error count.
+
+ procedure Err is
+ begin
+ if Quiet then
+ return;
+ end if;
+
+ Errors := Errors + 1;
+
+ if Itm /= null then
+ case Itm.Id is
+ when Id_Command =>
+ Put (Standard_Error, "command");
+
+ when Id_Switch =>
+ if OpenVMS then
+ Put (Standard_Error, "qualifier");
+ else
+ Put (Standard_Error, "switch");
+ end if;
+
+ when Id_Option =>
+ Put (Standard_Error, "option");
+
+ end case;
+ else
+ Put (Standard_Error, "input");
+
+ end if;
+
+ Put (Standard_Error, ": ");
+ Put (Standard_Error, S);
+
+ end Err;
+
+ -- Start of processing for Matching_Name
+
+ begin
+ -- If exact match, that's the one we want
+
+ P1 := Itm;
+ while P1 /= null loop
+ if Match (S, P1.Name.all) then
+ return P1;
+ else
+ P1 := P1.Next;
+ end if;
+ end loop;
+
+ -- Now check for prefix matches
+
+ P1 := Itm;
+ while P1 /= null loop
+ if P1.Name.all = "/<other>" then
+ return P1;
+
+ elsif not Match_Prefix (S, P1.Name.all) then
+ P1 := P1.Next;
+
+ else
+ -- Here we have found one matching prefix, so see if there is
+ -- another one (which is an ambiguity)
+
+ P2 := P1.Next;
+ while P2 /= null loop
+ if Match_Prefix (S, P2.Name.all) then
+ if not Quiet then
+ Put (Standard_Error, "ambiguous ");
+ Err;
+ Put (Standard_Error, " (matches ");
+ Put (Standard_Error, P1.Name.all);
+
+ while P2 /= null loop
+ if Match_Prefix (S, P2.Name.all) then
+ Put (Standard_Error, ',');
+ Put (Standard_Error, P2.Name.all);
+ end if;
+
+ P2 := P2.Next;
+ end loop;
+
+ Put_Line (Standard_Error, ")");
+ end if;
+
+ return null;
+ end if;
+
+ P2 := P2.Next;
+ end loop;
+
+ -- If we fall through that loop, then there was only one match
+
+ return P1;
+ end if;
+ end loop;
+
+ -- If we fall through outer loop, there was no match
+
+ if not Quiet then
+ Put (Standard_Error, "unrecognized ");
+ Err;
+ New_Line (Standard_Error);
+ end if;
+
+ return null;
+ end Matching_Name;
+
+ -----------------------
+ -- OK_Alphanumerplus --
+ -----------------------
+
+ function OK_Alphanumerplus (S : String) return Boolean is
+ begin
+ if S'Length = 0 then
+ return False;
+
+ else
+ for J in S'Range loop
+ if not (Is_Alphanumeric (S (J)) or else
+ S (J) = '_' or else S (J) = '$')
+ then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end if;
+ end OK_Alphanumerplus;
+
+ ----------------
+ -- OK_Integer --
+ ----------------
+
+ function OK_Integer (S : String) return Boolean is
+ begin
+ if S'Length = 0 then
+ return False;
+
+ else
+ for J in S'Range loop
+ if not Is_Digit (S (J)) then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end if;
+ end OK_Integer;
+
+ -----------
+ -- Place --
+ -----------
+
+ procedure Place (C : Character) is
+ begin
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := C;
+ end Place;
+
+ procedure Place (S : String) is
+ begin
+ for J in S'Range loop
+ Place (S (J));
+ end loop;
+ end Place;
+
+ -----------------
+ -- Place_Lower --
+ -----------------
+
+ procedure Place_Lower (S : String) is
+ begin
+ for J in S'Range loop
+ Place (To_Lower (S (J)));
+ end loop;
+ end Place_Lower;
+
+ -------------------------
+ -- Place_Unix_Switches --
+ -------------------------
+
+ procedure Place_Unix_Switches (S : String_Ptr) is
+ P1, P2, P3 : Natural;
+ Remove : Boolean;
+ Slen : Natural;
+
+ begin
+ P1 := S'First;
+ while P1 <= S'Last loop
+ if S (P1) = '!' then
+ P1 := P1 + 1;
+ Remove := True;
+ else
+ Remove := False;
+ end if;
+
+ P2 := P1;
+ pragma Assert (S (P1) = '-' or else S (P1) = '`');
+
+ while P2 < S'Last and then S (P2 + 1) /= ',' loop
+ P2 := P2 + 1;
+ end loop;
+
+ -- Switch is now in S (P1 .. P2)
+
+ Slen := P2 - P1 + 1;
+
+ if Remove then
+ P3 := 2;
+ while P3 <= Buffer.Last - Slen loop
+ if Buffer.Table (P3) = ' '
+ and then String (Buffer.Table (P3 + 1 .. P3 + Slen))
+ = S (P1 .. P2)
+ and then (P3 + Slen = Buffer.Last
+ or else
+ Buffer.Table (P3 + Slen + 1) = ' ')
+ then
+ Buffer.Table (P3 .. Buffer.Last - Slen - 1) :=
+ Buffer.Table (P3 + Slen + 1 .. Buffer.Last);
+ Buffer.Set_Last (Buffer.Last - Slen - 1);
+
+ else
+ P3 := P3 + 1;
+ end if;
+ end loop;
+
+ else
+ Place (' ');
+
+ if S (P1) = '`' then
+ P1 := P1 + 1;
+ end if;
+
+ Place (S (P1 .. P2));
+ end if;
+
+ P1 := P2 + 2;
+ end loop;
+ end Place_Unix_Switches;
+
+ --------------------------------
+ -- Validate_Command_Or_Option --
+ --------------------------------
+
+ procedure Validate_Command_Or_Option (N : 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 : 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;
+
+ ----------------------
+ -- List of Commands --
+ ----------------------
+
+ -- Note that we put this after all the local bodies to avoid
+ -- some access before elaboration problems.
+
+ Command_List : array (Natural range <>) of Command_Entry := (
+
+ (Cname => new S'("BIND"),
+ Usage => new S'("GNAT BIND file[.ali] /qualifiers"),
+ Unixcmd => new S'("gnatbind"),
+ Switches => Bind_Switches'Access,
+ Params => new Parameter_Array'(1 => File),
+ Defext => "ali"),
+
+ (Cname => new S'("CHOP"),
+ Usage => new S'("GNAT CHOP file [directory] /qualifiers"),
+ Unixcmd => new S'("gnatchop"),
+ Switches => Chop_Switches'Access,
+ Params => new Parameter_Array'(1 => File, 2 => Optional_File),
+ Defext => " "),
+
+ (Cname => new S'("COMPILE"),
+ Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"),
+ Unixcmd => new S'("gcc -c -x ada"),
+ Switches => GCC_Switches'Access,
+ Params => new Parameter_Array'(1 => Files_Or_Wildcard),
+ Defext => " "),
+
+ (Cname => new S'("ELIM"),
+ Usage => new S'("GNAT ELIM name /qualifiers"),
+ Unixcmd => new S'("gnatelim"),
+ Switches => Elim_Switches'Access,
+ Params => new Parameter_Array'(1 => Other_As_Is),
+ Defext => "ali"),
+
+ (Cname => new S'("FIND"),
+ Usage => new S'("GNAT FIND pattern[:sourcefile[:line[:column]]]" &
+ " filespec[,...] /qualifiers"),
+ Unixcmd => new S'("gnatfind"),
+ Switches => Find_Switches'Access,
+ Params => new Parameter_Array'(1 => Other_As_Is,
+ 2 => Files_Or_Wildcard),
+ Defext => "ali"),
+
+ (Cname => new S'("KRUNCH"),
+ Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"),
+ Unixcmd => new S'("gnatkr"),
+ Switches => Krunch_Switches'Access,
+ Params => new Parameter_Array'(1 => File),
+ Defext => " "),
+
+ (Cname => new S'("LIBRARY"),
+ Usage => new S'("GNAT LIBRARY /[CREATE | SET | DELETE]=directory"
+ & " [/CONFIG=file]"),
+ Unixcmd => new S'("gnatlbr"),
+ Switches => Lbr_Switches'Access,
+ Params => new Parameter_Array'(1 .. 0 => File),
+ Defext => " "),
+
+ (Cname => new S'("LINK"),
+ Usage => new S'("GNAT LINK file[.ali]"
+ & " [extra obj_&_lib_&_exe_&_opt files]"
+ & " /qualifiers"),
+ Unixcmd => new S'("gnatlink"),
+ Switches => Link_Switches'Access,
+ Params => new Parameter_Array'(1 => Unlimited_Files),
+ Defext => "ali"),
+
+ (Cname => new S'("LIST"),
+ Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"),
+ Unixcmd => new S'("gnatls"),
+ Switches => List_Switches'Access,
+ Params => new Parameter_Array'(1 => File),
+ Defext => "ali"),
+
+ (Cname => new S'("MAKE"),
+ Usage =>
+ new S'("GNAT MAKE file /qualifiers (includes COMPILE /qualifiers)"),
+ Unixcmd => new S'("gnatmake"),
+ Switches => Make_Switches'Access,
+ Params => new Parameter_Array'(1 => File),
+ Defext => " "),
+
+ (Cname => new S'("PREPROCESS"),
+ Usage => new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"),
+ Unixcmd => new S'("gnatprep"),
+ Switches => Prep_Switches'Access,
+ Params => new Parameter_Array'(1 .. 3 => File),
+ Defext => " "),
+
+ (Cname => new S'("SHARED"),
+ Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt files]"
+ & " /qualifiers"),
+ Unixcmd => new S'("gcc -shared " & Init_Object_Dirs.all),
+ Switches => Shared_Switches'Access,
+ Params => new Parameter_Array'(1 => Unlimited_Files),
+ Defext => " "),
+
+ (Cname => new S'("STANDARD"),
+ Usage => new S'("GNAT STANDARD"),
+ Unixcmd => new S'("gnatpsta"),
+ Switches => Standard_Switches'Access,
+ Params => new Parameter_Array'(1 .. 0 => File),
+ Defext => " "),
+
+ (Cname => new S'("STUB"),
+ Usage => new S'("GNAT STUB file [directory] /qualifiers"),
+ Unixcmd => new S'("gnatstub"),
+ Switches => Stub_Switches'Access,
+ Params => new Parameter_Array'(1 => File, 2 => Optional_File),
+ Defext => " "),
+
+ (Cname => new S'("SYSTEM"),
+ Usage => new S'("GNAT SYSTEM"),
+ Unixcmd => new S'("gnatpsys"),
+ Switches => System_Switches'Access,
+ Params => new Parameter_Array'(1 .. 0 => File),
+ Defext => " "),
+
+ (Cname => new S'("XREF"),
+ Usage => new S'("GNAT XREF filespec[,...] /qualifiers"),
+ Unixcmd => new S'("gnatxref"),
+ Switches => Xref_Switches'Access,
+ Params => new Parameter_Array'(1 => Files_Or_Wildcard),
+ Defext => "ali")
+ );
+
+-------------------------------------
+-- Start of processing for GNATCmd --
+-------------------------------------
+
+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 Command_List'Range loop
+
+ declare
+ Command : Item_Ptr := new Command_Item;
+
+ Last_Switch : Item_Ptr;
+ -- Last switch in list
+
+ begin
+ -- Link new command item into list of commands
+
+ if Last_Command = null then
+ Commands := Command;
+ else
+ Last_Command.Next := Command;
+ end if;
+
+ Last_Command := Command;
+
+ -- Fill in fields of new command item
+
+ Command.Name := Command_List (C).Cname;
+ Command.Usage := Command_List (C).Usage;
+ Command.Unix_String := Command_List (C).Unixcmd;
+ Command.Params := Command_List (C).Params;
+ Command.Defext := Command_List (C).Defext;
+
+ Validate_Command_Or_Option (Command.Name);
+
+ -- Process the switch list
+
+ for S in Command_List (C).Switches'Range loop
+ declare
+ SS : constant String_Ptr := Command_List (C).Switches (S);
+
+ P : Natural := SS'First;
+ Sw : Item_Ptr := new Switch_Item;
+
+ Last_Opt : Item_Ptr;
+ -- Pointer to last option
+
+ begin
+ -- Link new switch item into list of switches
+
+ if Last_Switch = null then
+ Command.Switches := Sw;
+ else
+ Last_Switch.Next := Sw;
+ end if;
+
+ Last_Switch := Sw;
+
+ -- Process switch string, first get name
+
+ while SS (P) /= ' ' and SS (P) /= '=' loop
+ P := P + 1;
+ end loop;
+
+ Sw.Name := new String'(SS (SS'First .. P - 1));
+
+ -- Direct translation case
+
+ if SS (P) = ' ' then
+ Sw.Translation := T_Direct;
+ Sw.Unix_String := new String'(SS (P + 1 .. SS'Last));
+ Validate_Unix_Switch (Sw.Unix_String);
+
+ if SS (P - 1) = '>' then
+ Sw.Translation := T_Other;
+
+ elsif SS (P + 1) = '`' then
+ null;
+
+ -- Create the inverted case (/NO ..)
+
+ elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then
+ Sw := new Switch_Item;
+ Last_Switch.Next := Sw;
+ Last_Switch := Sw;
+
+ Sw.Name :=
+ new String'("/NO" & SS (SS'First + 1 .. P - 1));
+ Sw.Translation := T_Direct;
+ Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last));
+ Validate_Unix_Switch (Sw.Unix_String);
+ end if;
+
+ -- Directories translation case
+
+ elsif SS (P + 1) = '*' then
+ pragma Assert (SS (SS'Last) = '*');
+ Sw.Translation := T_Directories;
+ Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
+ Validate_Unix_Switch (Sw.Unix_String);
+
+ -- Directory translation case
+
+ elsif SS (P + 1) = '%' then
+ pragma Assert (SS (SS'Last) = '%');
+ Sw.Translation := T_Directory;
+ Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
+ Validate_Unix_Switch (Sw.Unix_String);
+
+ -- File translation case
+
+ elsif SS (P + 1) = '@' then
+ pragma Assert (SS (SS'Last) = '@');
+ Sw.Translation := T_File;
+ Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
+ Validate_Unix_Switch (Sw.Unix_String);
+
+ -- Numeric translation case
+
+ elsif SS (P + 1) = '#' then
+ pragma Assert (SS (SS'Last) = '#');
+ Sw.Translation := T_Numeric;
+ Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
+ Validate_Unix_Switch (Sw.Unix_String);
+
+ -- Alphanumerplus translation case
+
+ elsif SS (P + 1) = '|' then
+ pragma Assert (SS (SS'Last) = '|');
+ Sw.Translation := T_Alphanumplus;
+ Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
+ Validate_Unix_Switch (Sw.Unix_String);
+
+ -- String translation case
+
+ elsif SS (P + 1) = '"' then
+ pragma Assert (SS (SS'Last) = '"');
+ Sw.Translation := T_String;
+ Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
+ Validate_Unix_Switch (Sw.Unix_String);
+
+ -- Commands translation case
+
+ elsif SS (P + 1) = '?' then
+ Sw.Translation := T_Commands;
+ Sw.Unix_String := new String'(SS (P + 2 .. SS'Last));
+
+ -- Options translation case
+
+ else
+ Sw.Translation := T_Options;
+ Sw.Unix_String := new String'("");
+
+ P := P + 1; -- bump past =
+ while P <= SS'Last loop
+ declare
+ Opt : Item_Ptr := new Option_Item;
+ Q : Natural;
+
+ begin
+ -- Link new option item into options list
+
+ if Last_Opt = null then
+ Sw.Options := Opt;
+ else
+ Last_Opt.Next := Opt;
+ end if;
+
+ Last_Opt := Opt;
+
+ -- Fill in fields of new option item
+
+ Q := P;
+ while SS (Q) /= ' ' loop
+ Q := Q + 1;
+ end loop;
+
+ Opt.Name := new String'(SS (P .. Q - 1));
+ Validate_Command_Or_Option (Opt.Name);
+
+ P := Q + 1;
+ Q := P;
+
+ while Q <= SS'Last and then SS (Q) /= ' ' loop
+ Q := Q + 1;
+ end loop;
+
+ Opt.Unix_String := new String'(SS (P .. Q - 1));
+ Validate_Unix_Switch (Opt.Unix_String);
+ P := Q + 1;
+ end;
+ end loop;
+ end if;
+ end;
+ end loop;
+ end;
+ end loop;
+
+ -- If no parameters, give complete list of commands
+
+ if Argument_Count = 0 then
+ 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;
+
+ Arg_Num := 1;
+
+ loop
+ exit when Arg_Num > Argument_Count;
+
+ 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.
+
+ 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;
+
+ return Argv'Last;
+ end Get_Arg_End;
+
+ begin
+ Argv := new String'(Argument (Arg_Num));
+ Arg_Idx := Argv'First;
+
+ <<Tryagain_After_Coalesce>>
+ loop
+ declare
+ Next_Arg_Idx : Integer;
+ Arg : String_Access;
+
+ begin
+ Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx);
+ Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx));
+
+ -- The first one must be a command name
+
+ if Arg_Num = 1 and then Arg_Idx = Argv'First then
+
+ Command := Matching_Name (Arg.all, Commands);
+
+ if Command = null then
+ raise Error_Exit;
+ end if;
+
+ -- Give usage information if only command given
+
+ if Argument_Count = 1 and then Next_Arg_Idx = Argv'Last
+ and then
+ not (Command.Name.all = "SYSTEM"
+ or else Command.Name.all = "STANDARD")
+ then
+ 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 & "/<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 =>
+ Put ("=file");
+ Set_Col (53);
+ Put (Sw.Unix_String.all);
+
+ if 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;
+
+ raise Normal_Exit;
+ end if;
+
+ Place (Command.Unix_String.all);
+
+ -- Special handling for internal debugging switch /?
+
+ elsif Arg.all = "/?" then
+ Display_Command := True;
+
+ -- Copy -switch unchanged
+
+ elsif Arg (Arg'First) = '-' then
+ Place (' ');
+ Place (Arg.all);
+
+ -- Copy quoted switch with quotes stripped
+
+ elsif Arg (Arg'First) = '"' then
+ if Arg (Arg'Last) /= '"' then
+ Put (Standard_Error, "misquoted argument: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
+
+ else
+ Put (Arg (Arg'First + 1 .. Arg'Last - 1));
+ end if;
+
+ -- Parameter Argument
+
+ 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 : 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;
+
+ when Unlimited_Files =>
+ declare
+ Normal_File : String_Access
+ := To_Canonical_File_Spec (Arg.all);
+
+ File_Is_Wild : Boolean := False;
+ File_List : String_Access_List_Access;
+ begin
+ for I in Arg'Range loop
+ if Arg (I) = '*'
+ or else Arg (I) = '%'
+ then
+ File_Is_Wild := True;
+ end if;
+ end loop;
+
+ if File_Is_Wild then
+ File_List := To_Canonical_File_List
+ (Arg.all, False);
+
+ for I in File_List.all'Range loop
+ Place (' ');
+ Place_Lower (File_List.all (I).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;
+
+ Param_Count := Param_Count - 1;
+ end;
+
+ when Other_As_Is =>
+ Place (' ');
+ Place (Arg.all);
+
+ 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.
+
+ function Get_Arg1_End
+ (Arg : String; Arg_Idx : Integer)
+ return Integer
+ is
+ begin
+ for I in Arg_Idx + 1 .. Arg'Last loop
+ if Arg (I) = ',' then
+ return I - 1;
+ end if;
+ end loop;
+
+ return Arg'Last;
+ end Get_Arg1_End;
+
+ begin
+ loop
+ declare
+ Next_Arg1_Idx : Integer
+ := Get_Arg1_End (Arg.all, Arg1_Idx);
+
+ Arg1 : String
+ := Arg (Arg1_Idx .. Next_Arg1_Idx);
+
+ Normal_File : 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;
+
+ -- Qualifier argument
+
+ else
+ 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
+ case Sw.Translation is
+
+ when T_Direct =>
+ Place_Unix_Switches (Sw.Unix_String);
+ if 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;
+ 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 I in Dir_List.all'Range loop
+ Place_Unix_Switches (Sw.Unix_String);
+ Place_Lower (Dir_List.all (I).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;
+
+ 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
+ Place_Unix_Switches (Sw.Unix_String);
+
+ -- Some switches end in "=". No space here
+
+ if Sw.Unix_String
+ (Sw.Unix_String'Last) /= '='
+ then
+ Place (' ');
+ end if;
+
+ Place_Lower (To_Canonical_Dir_Spec
+ (Arg (SwP + 2 .. Arg'Last), False).all);
+ end if;
+
+ when T_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.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));
+
+ 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 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);
+
+ when T_Commands =>
+
+ -- Output -largs/-bargs/-cargs
+
+ Place (' ');
+ Place (Sw.Unix_String
+ (Sw.Unix_String'First ..
+ Sw.Unix_String'First + 5));
+
+ -- 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);
+
+ 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;
+ end;
+
+ Arg_Num := Arg_Num + 1;
+ end loop;
+
+ if Display_Command then
+ Put (Standard_Error, "generated command -->");
+ Put (Standard_Error, String (Buffer.Table (1 .. Buffer.Last)));
+ Put (Standard_Error, "<--");
+ New_Line (Standard_Error);
+ raise Normal_Exit;
+ end if;
+
+ -- Gross error checking that the number of parameters is correct.
+ -- Not applicable to Unlimited_Files parameters.
+
+ if not ((Param_Count = Command.Params'Length - 1 and then
+ Command.Params (Param_Count + 1) = Unlimited_Files)
+ or else (Param_Count <= Command.Params'Length))
+ then
+ Put_Line (Standard_Error,
+ "Parameter count of "
+ & Integer'Image (Param_Count)
+ & " not equal to expected "
+ & Integer'Image (Command.Params'Length));
+ Put (Standard_Error, "usage: ");
+ Put_Line (Standard_Error, Command.Usage.all);
+ Errors := Errors + 1;
+ end if;
+
+ if Errors > 0 then
+ raise Error_Exit;
+ else
+ -- Prepare arguments for a call to spawn, filtering out
+ -- embedded nulls place there to delineate strings.
+
+ declare
+ Pname_Ptr : Natural;
+ Args : Argument_List (1 .. 500);
+ Nargs : Natural;
+ P1, P2 : Natural;
+ Exec_Path : String_Access;
+ Inside_Nul : Boolean := False;
+ Arg : String (1 .. 1024);
+ Arg_Ctr : Natural;
+
+ begin
+ Pname_Ptr := 1;
+
+ while Pname_Ptr < Buffer.Last
+ and then Buffer.Table (Pname_Ptr + 1) /= ' '
+ loop
+ Pname_Ptr := Pname_Ptr + 1;
+ end loop;
+
+ P1 := Pname_Ptr + 2;
+ Arg_Ctr := 1;
+ Arg (Arg_Ctr) := Buffer.Table (P1);
+
+ Nargs := 0;
+ 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
+ Nargs := Nargs + 1;
+ 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;
+
+ Args (Nargs) := new String'(String (Arg (1 .. Arg_Ctr)));
+ P1 := P2 + 2;
+ Arg_Ctr := 1;
+ Arg (Arg_Ctr) := Buffer.Table (P1);
+ end if;
+ end loop;
+
+ Exec_Path := Locate_Exec_On_Path
+ (String (Buffer.Table (1 .. Pname_Ptr)));
+
+ if Exec_Path = null then
+ Put_Line (Standard_Error,
+ "Couldn't locate "
+ & String (Buffer.Table (1 .. Pname_Ptr)));
+ raise Error_Exit;
+ end if;
+
+ My_Exit_Status
+ := Exit_Status (Spawn (Exec_Path.all, Args (1 .. Nargs)));
+
+ end;
+
+ raise Normal_Exit;
+ end if;
+
+exception
+ when Error_Exit =>
+ Set_Exit_Status (Failure);
+
+ when Normal_Exit =>
+ Set_Exit_Status (My_Exit_Status);
+
+end GNATCmd;