X-Git-Url: https://oss.titaniummirror.com/gitweb?a=blobdiff_plain;f=gcc%2Fada%2Fgnatcmd.adb;fp=gcc%2Fada%2Fgnatcmd.adb;h=0000000000000000000000000000000000000000;hb=6fed43773c9b0ce596dca5686f37ac3fc0fa11c0;hp=90dbffe1d47c70004685552fd7ca561dbe5b9f38;hpb=27b11d56b743098deb193d510b337ba22dc52e5c;p=msp430-gcc.git diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb deleted file mode 100644 index 90dbffe1..00000000 --- a/gcc/ada/gnatcmd.adb +++ /dev/null @@ -1,3319 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T C M D -- --- -- --- B o d y -- --- -- --- $Revision: 1.8.10.1 $ --- -- --- 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. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -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 project files -- - -------------------------------- - - S_Ext_Ref : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & - "-X" & '"'; - - S_Project_File : aliased constant S := "/PROJECT_FILE=*" & - "-P*"; - S_Project_Verb : aliased constant S := "/PROJECT_FILE_VERBOSITY=" & - "DEFAULT " & - "-vP0 " & - "MEDIUM " & - "-vP1 " & - "HIGH " & - "-vP2"; - - ---------------------------- - -- 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_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_Ext_Ref '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_Project_File 'Access, - S_Project_Verb '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_Pres : aliased constant S := "/PRESERVE " & - "-p"; - - 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_Pres '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 " & - "5 " & - "-gnati5 " & - "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=" & - "DEFAULT " & - "-gnatVd " & - "NODEFAULT " & - "-gnatVD " & - "COPIES " & - "-gnatVc " & - "NOCOPIES " & - "-gnatVC " & - "FLOATS " & - "-gnatVf " & - "NOFLOATS " & - "-gnatVF " & - "IN_PARAMS " & - "-gnatVi " & - "NOIN_PARAMS " & - "-gnatVI " & - "MOD_PARAMS " & - "-gnatVm " & - "NOMOD_PARAMS " & - "-gnatVM " & - "OPERANDS " & - "-gnatVo " & - "NOOPERANDS " & - "-gnatVO " & - "RETURNS " & - "-gnatVr " & - "NORETURNS " & - "-gnatVR " & - "SUBSCRIPTS " & - "-gnatVs " & - "NOSUBSCRIPTS " & - "-gnatVS " & - "TESTS " & - "-gnatVt " & - "NOTESTS " & - "-gnatVT " & - "ALL " & - "-gnatVa " & - "NONE " & - "-gnatVn"; - - 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_Ext_Ref 'Access, - S_Find_Full 'Access, - S_Find_Ignore 'Access, - S_Find_Object 'Access, - S_Find_Print 'Access, - S_Find_Project 'Access, - S_Project_File 'Access, - S_Project_Verb '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 := "/ " & - "--for-linker="; - - Link_Switches : aliased constant Switches := ( - S_Link_Bind 'Access, - S_Link_Debug 'Access, - S_Link_Execut 'Access, - S_Ext_Ref 'Access, - S_Link_Ident 'Access, - S_Link_Nocomp 'Access, - S_Link_Nofiles 'Access, - S_Link_Noinhib 'Access, - S_Project_File 'Access, - S_Project_Verb '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_Ext_Ref 'Access, - S_List_Nostinc 'Access, - S_List_Object 'Access, - S_List_Output 'Access, - S_Project_File 'Access, - S_Project_Verb 'Access, - S_List_Search 'Access, - S_List_Source 'Access); - - ---------------------------- - -- Switches for GNAT MAKE -- - ---------------------------- - - S_Make_Actions : aliased constant S := "/ACTIONS=" & - "COMPILE " & - "-c " & - "BIND " & - "-b " & - "LINK " & - "-l "; - - 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_Actions 'Access, - 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_Ext_Ref '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_Project_File 'Access, - S_Project_Verb '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 := "/ " & - "--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_Ext_Ref 'Access, - S_Xref_Full 'Access, - S_Xref_Global 'Access, - S_Xref_Object 'Access, - S_Xref_Project 'Access, - S_Project_File 'Access, - S_Project_Verb '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 = "/" 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; - - <> - 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 & "/"); - - 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 (""); - Put ('"'); - Set_Col (53); - - Put (Sw.Unix_String.all); - - if Sw.Unix_String (Sw.Unix_String'Last) - /= '=' - then - Put (' '); - end if; - - Put (""); - New_Line; - - when T_Commands => - Put (" (switches for "); - Put (Sw.Unix_String ( - Sw.Unix_String'First + 7 - .. Sw.Unix_String'Last)); - Put (')'); - Set_Col (53); - Put (Sw.Unix_String ( - Sw.Unix_String'First - .. Sw.Unix_String'First + 5)); - Put_Line (" switches"); - - when T_Options => - declare - Opt : Item_Ptr := Sw.Options; - - 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;