------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- G N A T C M D -- -- -- -- B o d y -- -- -- -- $Revision: 1.1.1.5 $ -- -- -- 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 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;