------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- G N A T C M D -- -- -- -- B o d y -- -- -- -- -- -- Copyright (C) 1996-2002 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 GNAT.Directory_Operations; use GNAT.Directory_Operations; with Csets; with MLib.Tgt; with MLib.Utl; with Namet; use Namet; with Opt; with Osint; use Osint; with Output; with Prj; use Prj; with Prj.Env; with Prj.Ext; use Prj.Ext; with Prj.Pars; with Prj.Util; use Prj.Util; with Sdefault; use Sdefault; with Snames; use Snames; with Stringt; use Stringt; with Table; with Types; use Types; with Hostparm; use Hostparm; -- Used to determine if we are in VMS or not for error message purposes with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Gnatvsn; with GNAT.OS_Lib; use GNAT.OS_Lib; with Table; procedure GNATCmd is Ada_Include_Path : constant String := "ADA_INCLUDE_PATH"; Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH"; Project_File : String_Access; Project : Prj.Project_Id; Current_Verbosity : Prj.Verbosity := Prj.Default; Tool_Package_Name : Name_Id := No_Name; -- This flag indicates a switch -p (for gnatxref and gnatfind) for -- an old fashioned project file. -p cannot be used in conjonction -- with -P. Old_Project_File_Used : Boolean := False; -- A table to keep the switches on the command line package Last_Switches is new Table.Table (Table_Component_Type => String_Access, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => 20, Table_Increment => 100, Table_Name => "Gnatcmd.Last_Switches"); -- A table to keep the switches from the project file package First_Switches is new Table.Table (Table_Component_Type => String_Access, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => 20, Table_Increment => 100, Table_Name => "Gnatcmd.First_Switches"); ------------------ -- 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 -- | NO_SPACE_FILE_TRANSL -- | 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 @ -- NO_SPACE_FILE_TRANSL ::= =< 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 NO_SPACE_FILE_TRANSL is similar to FILE_TRANSLATION, except that -- no space is inserted between the switch and the file name. -- 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_Help : aliased constant S := "/HELP " & "-h"; S_Bind_Init : aliased constant S := "/INITIALIZE_SCALARS=" & "INVALID " & "-Sin " & "LOW " & "-Slo " & "HIGH " & "-Shi"; S_Bind_Library : aliased constant S := "/LIBRARY_SEARCH=*" & "-aO*"; S_Bind_Linker : aliased constant S := "/LINKER_OPTION_LIST " & "-K"; S_Bind_List : aliased constant S := "/LIST_RESTRICTIONS " & "-r"; 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_No_Time : aliased constant S := "/NO_TIME_STAMP_CHECK " & "-t"; 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=<" & "-M>"; 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_Restr : aliased constant S := "/RESTRICTION_LIST " & "-r"; S_Bind_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" & "--RTS=|"; S_Bind_Search : aliased constant S := "/SEARCH=*" & "-I*"; S_Bind_Shared : aliased constant S := "/SHARED " & "-shared"; S_Bind_Slice : aliased constant S := "/TIME_SLICE=#" & "-T#"; 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_Help 'Access, S_Bind_Init 'Access, S_Bind_Library 'Access, S_Bind_Linker 'Access, S_Bind_List 'Access, S_Bind_Main 'Access, S_Bind_Nostinc 'Access, S_Bind_Nostlib 'Access, S_Bind_No_Time '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_Restr 'Access, S_Bind_RTS 'Access, S_Bind_Search 'Access, S_Bind_Shared 'Access, S_Bind_Slice '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_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" & "-gnatec>"; 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_Help : aliased constant S := "/HELP " & "-gnath"; 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_Immed : aliased constant S := "/IMMEDIATE_ERRORS " & "-gnatdO"; S_GCC_Inline : aliased constant S := "/INLINE=" & "PRAGMA " & "-gnatn " & "FULL " & "-gnatN " & "SUPPRESS " & "-fno-inline"; S_GCC_InlineX : aliased constant S := "/NOINLINE " & "!-gnatn"; S_GCC_Jumps : aliased constant S := "/LONGJMP_SETJMP " & "-gnatL"; S_GCC_Length : aliased constant S := "/MAX_LINE_LENGTH=#" & "-gnatyM#"; S_GCC_List : aliased constant S := "/LIST " & "-gnatl"; S_GCC_Noadc : aliased constant S := "/NO_GNAT_ADC " & "-gnatA"; 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_Polling : aliased constant S := "/POLLING " & "-gnatP"; 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 " & "RM_COLUMN_LAYOUT " & "-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 " & "BIASED_ROUNDING " & "-gnatwb " & "NOBIASED_ROUNDING " & "-gnatwB " & "CONDITIONALS " & "-gnatwc " & "NOCONDITIONALS " & "-gnatwC " & "IMPLICIT_DEREFERENCE " & "-gnatwd " & "NO_IMPLICIT_DEREFERENCE " & "-gnatwD " & "ELABORATION " & "-gnatwl " & "NOELABORATION " & "-gnatwL " & "ERRORS " & "-gnatwe " & "HIDING " & "-gnatwh " & "NOHIDING " & "-gnatwH " & "IMPLEMENTATION " & "-gnatwi " & "NOIMPLEMENTATION " & "-gnatwI " & "INEFFECTIVE_INLINE " & "-gnatwp " & "NOINEFFECTIVE_INLINE " & "-gnatwP " & "OPTIONAL " & "-gnatwa " & "NOOPTIONAL " & "-gnatwA " & "OVERLAYS " & "-gnatwo " & "NOOVERLAYS " & "-gnatwO " & "REDUNDANT " & "-gnatwr " & "NOREDUNDANT " & "-gnatwR " & "SUPPRESS " & "-gnatws " & "UNINITIALIZED " & "-Wuninitialized " & "UNREFERENCED_FORMALS " & "-gnatwf " & "NOUNREFERENCED_FORMALS " & "-gnatwF " & "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_Config '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_Ext_Ref 'Access, S_GCC_File 'Access, S_GCC_Force 'Access, S_GCC_Help 'Access, S_GCC_Ident 'Access, S_GCC_IdentX 'Access, S_GCC_Immed 'Access, S_GCC_Inline 'Access, S_GCC_InlineX 'Access, S_GCC_Jumps 'Access, S_GCC_Length 'Access, S_GCC_List 'Access, S_GCC_Noadc 'Access, S_GCC_Noload 'Access, S_GCC_Nostinc 'Access, S_GCC_Opt 'Access, S_GCC_OptX 'Access, S_GCC_Polling 'Access, S_Project_File'Access, S_Project_Verb'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_Bind : aliased constant S := "/BIND_FILE=<" & "-b>"; S_Elim_Miss : aliased constant S := "/MISSED " & "-m"; S_Elim_Quiet : aliased constant S := "/QUIET " & "-q"; S_Elim_Tree : aliased constant S := "/TREE_DIRS=*" & "-T*"; S_Elim_Verb : aliased constant S := "/VERBOSE " & "-v"; Elim_Switches : aliased constant Switches := (S_Elim_All 'Access, S_Elim_Bind 'Access, S_Elim_Miss 'Access, S_Elim_Quiet 'Access, S_Elim_Tree 'Access, S_Elim_Verb 'Access); ---------------------------- -- Switches for GNAT FIND -- ---------------------------- S_Find_All : aliased constant S := "/ALL_FILES " & "-a"; S_Find_Deriv : aliased constant S := "/DERIVED_TYPE_INFORMATION " & "-d"; 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_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & "-nostdinc"; S_Find_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & "-nostdlib"; 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*"; S_Find_Types : aliased constant S := "/TYPE_HIERARCHY " & "-t"; Find_Switches : aliased constant Switches := (S_Find_All 'Access, S_Find_Deriv 'Access, S_Find_Expr 'Access, S_Ext_Ref 'Access, S_Find_Full 'Access, S_Find_Ignore 'Access, S_Find_Nostinc 'Access, S_Find_Nostlib '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, S_Find_Types '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_Force : aliased constant S := "/FORCE_OBJECT_FILE_LIST " & "-f"; 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_Force '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_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 " & "DEPEND " & "-d " & "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_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_Mapping : aliased constant S := "/MAPPING " & "-C"; S_Make_Minimal : aliased constant S := "/MINIMAL_RECOMPILATION " & "-m"; S_Make_Nolink : aliased constant S := "/NOLINK " & "-c"; S_Make_Nomain : aliased constant S := "/NOMAIN " & "-z"; 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_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" & "--RTS=|"; 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_Switch : aliased constant S := "/SWITCH_CHECK " & "-s"; S_Make_Unique : aliased constant S := "/UNIQUE " & "-u"; 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_Mapping 'Access, S_Make_Minimal 'Access, S_Make_Nolink 'Access, S_Make_Nomain '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_RTS 'Access, S_Make_Search 'Access, S_Make_Skip 'Access, S_Make_Source 'Access, S_Make_Switch 'Access, S_Make_Unique 'Access, S_Make_Verbose 'Access); ---------------------------- -- Switches for GNAT Name -- ---------------------------- S_Name_Conf : aliased constant S := "/CONFIG_FILE=<" & "-c>"; S_Name_Dirs : aliased constant S := "/SOURCE_DIRS=*" & "-d*"; S_Name_Dfile : aliased constant S := "/DIRS_FILE=<" & "-D>"; S_Name_Help : aliased constant S := "/HELP" & " -h"; S_Name_Proj : aliased constant S := "/PROJECT_FILE=<" & "-P>"; S_Name_Verbose : aliased constant S := "/VERBOSE" & " -v"; Name_Switches : aliased constant Switches := (S_Name_Conf 'Access, S_Name_Dirs 'Access, S_Name_Dfile 'Access, S_Name_Help 'Access, S_Name_Proj 'Access, S_Name_Verbose 'Access); ---------------------------------- -- Switches for GNAT PREPROCESS -- ---------------------------------- S_Prep_Assoc : aliased constant S := "/ASSOCIATE=" & '"' & "-D" & '"'; 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"; Prep_Switches : aliased constant Switches := (S_Prep_Assoc 'Access, S_Prep_Blank 'Access, S_Prep_Com 'Access, S_Prep_Ref 'Access, S_Prep_Remove 'Access, S_Prep_Symbols 'Access, S_Prep_Undef '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 XREF -- ---------------------------- S_Xref_All : aliased constant S := "/ALL_FILES " & "-a"; S_Xref_Deriv : aliased constant S := "/DERIVED_TYPES " & "-d"; S_Xref_Full : aliased constant S := "/FULL_PATHNAME " & "-f"; S_Xref_Global : aliased constant S := "/IGNORE_LOCALS " & "-g"; S_Xref_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & "-nostdinc"; S_Xref_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & "-nostdlib"; 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"; S_Xref_Tags : aliased constant S := "/TAGS " & "-v"; Xref_Switches : aliased constant Switches := (S_Xref_All 'Access, S_Xref_Deriv 'Access, S_Ext_Ref 'Access, S_Xref_Full 'Access, S_Xref_Global 'Access, S_Xref_Nostinc 'Access, S_Xref_Nostlib '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, S_Xref_Tags '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 whitespace separate file or directory -- parameters including wildcard specifications. Unlimited_As_Is, -- Un unlimited number of whitespace separated paameters that are -- passed through as is (not canonicalized). 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_Type is (Bind, Chop, Compile, Elim, Find, Krunch, Library, Link, List, Make, Name, Preprocess, Shared, Standard, Stub, Xref, Undefined); type Alternate_Command is (Comp, Ls, Kr, Prep, Psta); -- Alternate command libel for non VMS system Corresponding_To : constant array (Alternate_Command) of Command_Type := (Comp => Compile, Ls => List, Kr => Krunch, Prep => Preprocess, Psta => Standard); -- Mapping of alternate commands to commands subtype Real_Command_Type is Command_Type range Bind .. Xref; 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 Unixsws : Argument_List_Access; -- Switches for the Unix command VMS_Only : Boolean; -- When True, the command can only be used on VMS 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 qualifier followed by a filename -- Example: GNAT LINK /EXECUTABLE=FOO.EXE T_No_Space_File, -- A qualifier followed by a filename -- Example: GNAT MAKE /PROJECT_FILE=PRJ.GPR T_Numeric, -- A qualifier followed by a numeric value. -- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39 T_String, -- A qualifier followed by a quoted string. Only used by -- /IDENTIFICATION 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 Command : Command_Type := Undefined; Unix_String : String_Ptr := null; -- Corresponding Unix string. For a command, this is the unix command -- name and possible default switches. For a switch or option it is -- the unix switch string. case Id is when Id_Command => Switches : Item_Ptr; -- Pointer to list of switch items for the command, linked -- through the Next fields with null terminating the list. Usage : String_Ptr; -- Usage information, used only for errors and the default -- list of commands output. Params : Parameter_Ref; -- Array of parameters Defext : String (1 .. 3); -- Default extension. If non-blank, then this extension is -- supplied by default as the extension for any file parameter -- which does not have an extension already. when Id_Switch => Translation : Translation_Type; -- Type of switch translation. For all cases, except Options, -- this is the only field needed, since the Unix translation -- is found in Unix_String. Options : Item_Ptr; -- For the Options case, this field is set to point to a list -- of options item (for this case Unix_String is null in the -- main switch item). The end of the list is marked by null. when Id_Option => null; -- No special fields needed, since Name and Unix_String are -- sufficient to completely described an option. end case; end record; subtype Command_Item is Item (Id_Command); subtype Switch_Item is Item (Id_Switch); subtype Option_Item is Item (Id_Option); ---------------------------------- -- 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_Arg : Positive := 1; 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 (on VMS) The_Command : Command_Type; -- The command used ----------------------- -- Local Subprograms -- ----------------------- function Index (Char : Character; Str : String) return Natural; -- Returns the first occurrence of Char in Str. -- Returns 0 if Char is not in Str. function Init_Object_Dirs return Argument_List; 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). procedure Non_VMS_Usage; -- Display usage for platforms other than VMS 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 Output_Version; -- Output the version of this program 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 Set_Library_For (Project : Project_Id; There_Are_Libraries : in out Boolean); -- If Project is a library project, add the correct -- -L and -l switches to the linker invocation. procedure Set_Libraries is new For_Every_Project_Imported (Boolean, Set_Library_For); -- Add the -L and -l switches to the linker for all -- of the library projects. 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. procedure VMS_Conversion (The_Command : out Command_Type); -- Converts VMS command line to equivalent Unix command line ----------- -- Index -- ----------- function Index (Char : Character; Str : String) return Natural is begin for Index in Str'Range loop if Str (Index) = Char then return Index; end if; end loop; return 0; end Index; ---------------------- -- Init_Object_Dirs -- ---------------------- function Init_Object_Dirs return Argument_List is Object_Dirs : Integer; Object_Dir : Argument_List (1 .. 256); 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) := new String'("-L" & To_Canonical_Dir_Spec (To_Host_Dir_Spec (Normalize_Directory_Name (Dir.all).all, True).all, True).all); end; end loop; Object_Dirs := Object_Dirs + 1; Object_Dir (Object_Dirs) := new String'("-lgnat"); if Hostparm.OpenVMS then Object_Dirs := Object_Dirs + 1; Object_Dir (Object_Dirs) := new String'("-ldecgnat"); end if; return Object_Dir (1 .. Object_Dirs); 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. --------- -- Err -- --------- 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; -------------------- -- Output_Version -- -------------------- procedure Output_Version is begin Put ("GNAT "); Put (Gnatvsn.Gnat_Version_String); Put_Line (" Copyright 1996-2002 Free Software Foundation, Inc."); end Output_Version; ----------- -- Place -- ----------- procedure Place (C : Character) is begin Buffer.Increment_Last; Buffer.Table (Buffer.Last) := C; -- Do not put a space as the first character in the buffer if C = ' ' and then Buffer.Last = 1 then Buffer.Decrement_Last; end if; 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; --------------------- -- Set_Library_For -- --------------------- procedure Set_Library_For (Project : Project_Id; There_Are_Libraries : in out Boolean) is begin -- Case of library project if Projects.Table (Project).Library then There_Are_Libraries := True; -- Add the -L switch Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String'("-L" & Get_Name_String (Projects.Table (Project).Library_Dir)); -- Add the -l switch Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String'("-l" & Get_Name_String (Projects.Table (Project).Library_Name)); -- Add the Wl,-rpath switch if library non static if Projects.Table (Project).Library_Kind /= Static then declare Option : constant String_Access := MLib.Tgt.Linker_Library_Path_Option (Get_Name_String (Projects.Table (Project).Library_Dir)); begin if Option /= null then Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := Option; end if; end; end if; end if; end Set_Library_For; -------------------------------- -- 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 (except Non_VMS_Usage -- and VMS_Conversion that use Command_List) to avoid some access before -- elaboration problems. Command_List : constant array (Real_Command_Type) of Command_Entry := (Bind => (Cname => new S'("BIND"), Usage => new S'("GNAT BIND file[.ali] /qualifiers"), VMS_Only => False, Unixcmd => new S'("gnatbind"), Unixsws => null, Switches => Bind_Switches'Access, Params => new Parameter_Array'(1 => File), Defext => "ali"), Chop => (Cname => new S'("CHOP"), Usage => new S'("GNAT CHOP file [directory] /qualifiers"), VMS_Only => False, Unixcmd => new S'("gnatchop"), Unixsws => null, Switches => Chop_Switches'Access, Params => new Parameter_Array'(1 => File, 2 => Optional_File), Defext => " "), Compile => (Cname => new S'("COMPILE"), Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"), VMS_Only => False, Unixcmd => new S'("gnatmake"), Unixsws => new Argument_List' (1 => new String'("-f"), 2 => new String'("-u"), 3 => new String'("-c")), Switches => GCC_Switches'Access, Params => new Parameter_Array'(1 => Files_Or_Wildcard), Defext => " "), Elim => (Cname => new S'("ELIM"), Usage => new S'("GNAT ELIM name /qualifiers"), VMS_Only => False, Unixcmd => new S'("gnatelim"), Unixsws => null, Switches => Elim_Switches'Access, Params => new Parameter_Array'(1 => Other_As_Is), Defext => "ali"), Find => (Cname => new S'("FIND"), Usage => new S'("GNAT FIND pattern[:sourcefile[:line" & "[:column]]] filespec[,...] /qualifiers"), VMS_Only => False, Unixcmd => new S'("gnatfind"), Unixsws => null, Switches => Find_Switches'Access, Params => new Parameter_Array'(1 => Other_As_Is, 2 => Files_Or_Wildcard), Defext => "ali"), Krunch => (Cname => new S'("KRUNCH"), Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"), VMS_Only => False, Unixcmd => new S'("gnatkr"), Unixsws => null, Switches => Krunch_Switches'Access, Params => new Parameter_Array'(1 => File), Defext => " "), Library => (Cname => new S'("LIBRARY"), Usage => new S'("GNAT LIBRARY /[CREATE | SET | DELETE]" & "=directory [/CONFIG=file]"), VMS_Only => True, Unixcmd => new S'("gnatlbr"), Unixsws => null, Switches => Lbr_Switches'Access, Params => new Parameter_Array'(1 .. 0 => File), Defext => " "), Link => (Cname => new S'("LINK"), Usage => new S'("GNAT LINK file[.ali]" & " [extra obj_&_lib_&_exe_&_opt files]" & " /qualifiers"), VMS_Only => False, Unixcmd => new S'("gnatlink"), Unixsws => null, Switches => Link_Switches'Access, Params => new Parameter_Array'(1 => Unlimited_Files), Defext => "ali"), List => (Cname => new S'("LIST"), Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"), VMS_Only => False, Unixcmd => new S'("gnatls"), Unixsws => null, Switches => List_Switches'Access, Params => new Parameter_Array'(1 => File), Defext => "ali"), Make => (Cname => new S'("MAKE"), Usage => new S'("GNAT MAKE file /qualifiers (includes " & "COMPILE /qualifiers)"), VMS_Only => False, Unixcmd => new S'("gnatmake"), Unixsws => null, Switches => Make_Switches'Access, Params => new Parameter_Array'(1 => File), Defext => " "), Name => (Cname => new S'("NAME"), Usage => new S'("GNAT NAME /qualifiers naming-pattern " & "[naming-patterns]"), VMS_Only => False, Unixcmd => new S'("gnatname"), Unixsws => null, Switches => Name_Switches'Access, Params => new Parameter_Array'(1 => Unlimited_As_Is), Defext => " "), Preprocess => (Cname => new S'("PREPROCESS"), Usage => new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"), VMS_Only => False, Unixcmd => new S'("gnatprep"), Unixsws => null, Switches => Prep_Switches'Access, Params => new Parameter_Array'(1 .. 3 => File), Defext => " "), Shared => (Cname => new S'("SHARED"), Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt" & "files] /qualifiers"), VMS_Only => True, Unixcmd => new S'("gcc"), Unixsws => new Argument_List'(new String'("-shared") & Init_Object_Dirs), Switches => Shared_Switches'Access, Params => new Parameter_Array'(1 => Unlimited_Files), Defext => " "), Standard => (Cname => new S'("STANDARD"), Usage => new S'("GNAT STANDARD"), VMS_Only => False, Unixcmd => new S'("gnatpsta"), Unixsws => null, Switches => Standard_Switches'Access, Params => new Parameter_Array'(1 .. 0 => File), Defext => " "), Stub => (Cname => new S'("STUB"), Usage => new S'("GNAT STUB file [directory]/qualifiers"), VMS_Only => False, Unixcmd => new S'("gnatstub"), Unixsws => null, Switches => Stub_Switches'Access, Params => new Parameter_Array'(1 => File, 2 => Optional_File), Defext => " "), Xref => (Cname => new S'("XREF"), Usage => new S'("GNAT XREF filespec[,...] /qualifiers"), VMS_Only => False, Unixcmd => new S'("gnatxref"), Unixsws => null, Switches => Xref_Switches'Access, Params => new Parameter_Array'(1 => Files_Or_Wildcard), Defext => "ali") ); ------------------- -- Non_VMS_Usage -- ------------------- procedure Non_VMS_Usage is begin Output_Version; New_Line; Put_Line ("List of available commands"); New_Line; for C in Command_List'Range loop if not Command_List (C).VMS_Only then Put ("GNAT " & Command_List (C).Cname.all); Set_Col (25); Put (Command_List (C).Unixcmd.all); declare Sws : Argument_List_Access renames Command_List (C).Unixsws; begin if Sws /= null then for J in Sws'Range loop Put (' '); Put (Sws (J).all); end loop; end if; end; New_Line; end if; end loop; New_Line; Put_Line ("Commands FIND, LIST and XREF accept project file " & "switches -vPx, -Pprj and -Xnam=val"); New_Line; end Non_VMS_Usage; -------------------- -- VMS_Conversion -- -------------------- procedure VMS_Conversion (The_Command : out Command_Type) is begin Buffer.Init; -- First we must preprocess the string form of the command and options -- list into the internal form that we use. for C in Real_Command_Type loop declare Command : Item_Ptr := new Command_Item; 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.Command := C; if Command_List (C).Unixsws = null then Command.Unix_String := Command_List (C).Unixcmd; else declare Cmd : String (1 .. 5_000); Last : Natural := 0; Sws : Argument_List_Access := Command_List (C).Unixsws; begin Cmd (1 .. Command_List (C).Unixcmd'Length) := Command_List (C).Unixcmd.all; Last := Command_List (C).Unixcmd'Length; for J in Sws'Range loop Last := Last + 1; Cmd (Last) := ' '; Cmd (Last + 1 .. Last + Sws (J)'Length) := Sws (J).all; Last := Last + Sws (J)'Length; end loop; Command.Unix_String := new String'(Cmd (1 .. Last)); end; end if; 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); -- No space file translation case elsif SS (P + 1) = '<' then pragma Assert (SS (SS'Last) = '>'); Sw.Translation := T_No_Space_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 Output_Version; New_Line; Put_Line ("List of available commands"); New_Line; while Commands /= null loop Put (Commands.Usage.all); Set_Col (53); Put_Line (Commands.Unix_String.all); Commands := Commands.Next; end loop; raise Normal_Exit; end if; Arg_Num := 1; -- Loop through arguments while Arg_Num <= Argument_Count loop Process_Argument : declare Argv : String_Access; Arg_Idx : Integer; function Get_Arg_End (Argv : String; Arg_Idx : Integer) return Integer; -- Begins looking at Arg_Idx + 1 and returns the index of the -- last character before a slash or else the index of the last -- character in the string Argv. ----------------- -- Get_Arg_End -- ----------------- function Get_Arg_End (Argv : String; Arg_Idx : Integer) return Integer is begin for J in Arg_Idx + 1 .. Argv'Last loop if Argv (J) = '/' then return J - 1; end if; end loop; return Argv'Last; end Get_Arg_End; -- Start of processing for Process_Argument 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; The_Command := Command.Command; -- Give usage information if only command given if Argument_Count = 1 and then Next_Arg_Idx = Argv'Last and then Command.Command /= Standard then Output_Version; New_Line; Put_Line ("List of available qualifiers and options"); New_Line; Put (Command.Usage.all); Set_Col (53); Put_Line (Command.Unix_String.all); declare Sw : Item_Ptr := Command.Switches; begin while Sw /= null loop Put (" "); Put (Sw.Name.all); case Sw.Translation is when T_Other => Set_Col (53); Put_Line (Sw.Unix_String.all & "/"); when T_Direct => Set_Col (53); Put_Line (Sw.Unix_String.all); when T_Directories => Put ("=(direc,direc,..direc)"); Set_Col (53); Put (Sw.Unix_String.all); Put (" direc "); Put (Sw.Unix_String.all); Put_Line (" direc ..."); when T_Directory => Put ("=directory"); Set_Col (53); Put (Sw.Unix_String.all); if Sw.Unix_String (Sw.Unix_String'Last) /= '=' then Put (' '); end if; Put_Line ("directory "); when T_File | T_No_Space_File => Put ("=file"); Set_Col (53); Put (Sw.Unix_String.all); if Sw.Translation = T_File and then Sw.Unix_String (Sw.Unix_String'Last) /= '=' then Put (' '); end if; Put_Line ("file "); when T_Numeric => Put ("=nnn"); Set_Col (53); if Sw.Unix_String (Sw.Unix_String'First) = '`' then Put (Sw.Unix_String (Sw.Unix_String'First + 1 .. Sw.Unix_String'Last)); else Put (Sw.Unix_String.all); end if; Put_Line ("nnn"); when T_Alphanumplus => Put ("=xyz"); Set_Col (53); if Sw.Unix_String (Sw.Unix_String'First) = '`' then Put (Sw.Unix_String (Sw.Unix_String'First + 1 .. Sw.Unix_String'Last)); else Put (Sw.Unix_String.all); end if; Put_Line ("xyz"); when T_String => Put ("="); Put ('"'); Put (""); Put ('"'); Set_Col (53); Put (Sw.Unix_String.all); if Sw.Unix_String (Sw.Unix_String'Last) /= '=' then Put (' '); end if; Put (""); New_Line; when T_Commands => Put (" (switches for "); Put (Sw.Unix_String (Sw.Unix_String'First + 7 .. Sw.Unix_String'Last)); Put (')'); Set_Col (53); Put (Sw.Unix_String (Sw.Unix_String'First .. Sw.Unix_String'First + 5)); Put_Line (" switches"); when T_Options => declare Opt : Item_Ptr := Sw.Options; 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 Place (' '); Place (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 Unlimited_As_Is => Place (' '); Place (Arg.all); Param_Count := Param_Count - 1; when Files_Or_Wildcard => -- Remove spaces from a comma separated list -- of file names and adjust control variables -- accordingly. while Arg_Num < Argument_Count and then (Argv (Argv'Last) = ',' xor Argument (Arg_Num + 1) (Argument (Arg_Num + 1)'First) = ',') loop Argv := new String' (Argv.all & Argument (Arg_Num + 1)); Arg_Num := Arg_Num + 1; Arg_Idx := Argv'First; Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); Arg := new String' (Argv (Arg_Idx .. Next_Arg_Idx)); end loop; -- Parse the comma separated list of VMS -- filenames and place them on the command -- line as space separated Unix style -- filenames. Lower case and add default -- extension as appropriate. declare Arg1_Idx : Integer := Arg'First; function Get_Arg1_End (Arg : String; Arg_Idx : Integer) return Integer; -- Begins looking at Arg_Idx + 1 and -- returns the index of the last character -- before a comma or else the index of the -- last character in the string Arg. 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 SwP < Arg'Last and then Arg (SwP + 1) = '=' then Put (Standard_Error, "qualifier options ignored: "); Put_Line (Standard_Error, Arg.all); end if; when T_Directories => if SwP + 1 > Arg'Last then Put (Standard_Error, "missing directories for: "); Put_Line (Standard_Error, Arg.all); Errors := Errors + 1; elsif Arg (SwP + 2) /= '(' then SwP := SwP + 2; Endp := Arg'Last; elsif Arg (Arg'Last) /= ')' then -- Remove spaces from a comma separated -- list of file names and adjust -- control variables accordingly. if Arg_Num < Argument_Count and then (Argv (Argv'Last) = ',' xor Argument (Arg_Num + 1) (Argument (Arg_Num + 1)'First) = ',') then Argv := new String'(Argv.all & Argument (Arg_Num + 1)); Arg_Num := Arg_Num + 1; Arg_Idx := Argv'First; Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); Arg := new String' (Argv (Arg_Idx .. Next_Arg_Idx)); goto Tryagain_After_Coalesce; end if; Put (Standard_Error, "incorrectly parenthesized " & "or malformed argument: "); Put_Line (Standard_Error, Arg.all); Errors := Errors + 1; else SwP := SwP + 3; Endp := Arg'Last - 1; end if; while SwP <= Endp loop declare Dir_Is_Wild : Boolean := False; Dir_Maybe_Is_Wild : Boolean := False; Dir_List : String_Access_List_Access; 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 | T_No_Space_File => if SwP + 1 > Arg'Last then Put (Standard_Error, "missing file for: "); Put_Line (Standard_Error, Arg.all); Errors := Errors + 1; else Place_Unix_Switches (Sw.Unix_String); -- Some switches end in "=". No space -- here. if Sw.Translation = T_File and then Sw.Unix_String (Sw.Unix_String'Last) /= '=' then Place (' '); end if; Place_Lower (To_Canonical_File_Spec (Arg (SwP + 2 .. Arg'Last)).all); end if; when T_Numeric => if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then Place_Unix_Switches (Sw.Unix_String); Place (Arg (SwP + 2 .. Arg'Last)); 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 Process_Argument; Arg_Num := Arg_Num + 1; end loop; if Display_Command then Put (Standard_Error, "generated command -->"); Put (Standard_Error, Command_List (The_Command).Unixcmd.all); if Command_List (The_Command).Unixsws /= null then for J in Command_List (The_Command).Unixsws'Range loop Put (Standard_Error, " "); Put (Standard_Error, Command_List (The_Command).Unixsws (J).all); end loop; end if; Put (Standard_Error, " "); 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 (Param_Count = Command.Params'Length - 1 and then Command.Params (Param_Count + 1) = Unlimited_Files) or else Param_Count <= Command.Params'Length then null; else 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 P1, P2 : Natural; Inside_Nul : Boolean := False; Arg : String (1 .. 1024); Arg_Ctr : Natural; begin P1 := 1; while P1 <= Buffer.Last and then Buffer.Table (P1) = ' ' loop P1 := P1 + 1; end loop; Arg_Ctr := 1; Arg (Arg_Ctr) := Buffer.Table (P1); while P1 <= Buffer.Last loop if Buffer.Table (P1) = ASCII.NUL then if Inside_Nul then Inside_Nul := False; else Inside_Nul := True; end if; end if; if Buffer.Table (P1) = ' ' and then not Inside_Nul then P1 := P1 + 1; Arg_Ctr := Arg_Ctr + 1; Arg (Arg_Ctr) := Buffer.Table (P1); else Last_Switches.Increment_Last; P2 := P1; while P2 < Buffer.Last and then (Buffer.Table (P2 + 1) /= ' ' or else Inside_Nul) loop P2 := P2 + 1; Arg_Ctr := Arg_Ctr + 1; Arg (Arg_Ctr) := Buffer.Table (P2); if Buffer.Table (P2) = ASCII.NUL then Arg_Ctr := Arg_Ctr - 1; if Inside_Nul then Inside_Nul := False; else Inside_Nul := True; end if; end if; end loop; Last_Switches.Table (Last_Switches.Last) := new String'(String (Arg (1 .. Arg_Ctr))); P1 := P2 + 2; Arg_Ctr := 1; Arg (Arg_Ctr) := Buffer.Table (P1); end if; end loop; end; end if; end VMS_Conversion; ------------------------------------- -- Start of processing for GNATCmd -- ------------------------------------- begin -- Initializations Namet.Initialize; Csets.Initialize; Snames.Initialize; Prj.Initialize; Last_Switches.Init; Last_Switches.Set_Last (0); First_Switches.Init; First_Switches.Set_Last (0); -- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers, -- filenames and pathnames to Unix style. if Hostparm.OpenVMS or else To_Lower (Getenv ("EMULATE_VMS").all) = "true" then VMS_Conversion (The_Command); -- If not on VMS, scan the command line directly else if Argument_Count = 0 then Non_VMS_Usage; return; else begin if Argument_Count > 1 and then Argument (1) = "-v" then Opt.Verbose_Mode := True; Command_Arg := 2; end if; The_Command := Real_Command_Type'Value (Argument (Command_Arg)); if Command_List (The_Command).VMS_Only then Non_VMS_Usage; Fail ("Command """ & Command_List (The_Command).Cname.all & """ can only be used on VMS"); end if; exception when Constraint_Error => -- Check if it is an alternate command declare Alternate : Alternate_Command; begin Alternate := Alternate_Command'Value (Argument (Command_Arg)); The_Command := Corresponding_To (Alternate); exception when Constraint_Error => Non_VMS_Usage; Fail ("Unknown command: " & Argument (Command_Arg)); end; end; for Arg in Command_Arg + 1 .. Argument_Count loop Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String'(Argument (Arg)); end loop; end if; end if; declare Program : constant String := Program_Name (Command_List (The_Command).Unixcmd.all).all; Exec_Path : String_Access; begin -- Locate the executable for the command Exec_Path := Locate_Exec_On_Path (Program); if Exec_Path = null then Put_Line (Standard_Error, "Couldn't locate " & Program); raise Error_Exit; end if; -- If there are switches for the executable, put them as first switches if Command_List (The_Command).Unixsws /= null then for J in Command_List (The_Command).Unixsws'Range loop First_Switches.Increment_Last; First_Switches.Table (First_Switches.Last) := Command_List (The_Command).Unixsws (J); end loop; end if; -- For BIND, FIND, LINK, LIST and XREF, look for project file related -- switches. if The_Command = Bind or else The_Command = Find or else The_Command = Link or else The_Command = List or else The_Command = Xref then case The_Command is when Bind => Tool_Package_Name := Name_Binder; when Find => Tool_Package_Name := Name_Finder; when Link => Tool_Package_Name := Name_Linker; when List => Tool_Package_Name := Name_Gnatls; when Xref => Tool_Package_Name := Name_Cross_Reference; when others => null; end case; declare Arg_Num : Positive := 1; Argv : String_Access; procedure Remove_Switch (Num : Positive); -- Remove a project related switch from table Last_Switches ------------------- -- Remove_Switch -- ------------------- procedure Remove_Switch (Num : Positive) is begin Last_Switches.Table (Num .. Last_Switches.Last - 1) := Last_Switches.Table (Num + 1 .. Last_Switches.Last); Last_Switches.Decrement_Last; end Remove_Switch; -- Start of processing for ??? (need block name here) begin while Arg_Num <= Last_Switches.Last loop Argv := Last_Switches.Table (Arg_Num); if Argv (Argv'First) = '-' then if Argv'Length = 1 then Fail ("switch character cannot be followed by a blank"); end if; -- The two style project files (-p and -P) cannot be used -- together if (The_Command = Find or else The_Command = Xref) and then Argv (2) = 'p' then Old_Project_File_Used := True; if Project_File /= null then Fail ("-P and -p cannot be used together"); end if; end if; -- -vPx Specify verbosity while parsing project files if Argv'Length = 4 and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP" then case Argv (Argv'Last) is when '0' => Current_Verbosity := Prj.Default; when '1' => Current_Verbosity := Prj.Medium; when '2' => Current_Verbosity := Prj.High; when others => Fail ("Invalid switch: " & Argv.all); end case; Remove_Switch (Arg_Num); -- -Pproject_file Specify project file to be used elsif Argv'Length >= 3 and then Argv (Argv'First + 1) = 'P' then -- Only one -P switch can be used if Project_File /= null then Fail (Argv.all & ": second project file forbidden (first is """ & Project_File.all & """)"); -- The two style project files (-p and -P) cannot be -- used together. elsif Old_Project_File_Used then Fail ("-p and -P cannot be used together"); else Project_File := new String'(Argv (Argv'First + 2 .. Argv'Last)); end if; Remove_Switch (Arg_Num); -- -Xexternal=value Specify an external reference to be -- used in project files elsif Argv'Length >= 5 and then Argv (Argv'First + 1) = 'X' then declare Equal_Pos : constant Natural := Index ('=', Argv (Argv'First + 2 .. Argv'Last)); begin if Equal_Pos >= Argv'First + 3 and then Equal_Pos /= Argv'Last then Add (External_Name => Argv (Argv'First + 2 .. Equal_Pos - 1), Value => Argv (Equal_Pos + 1 .. Argv'Last)); else Fail (Argv.all & " is not a valid external assignment."); end if; end; Remove_Switch (Arg_Num); else Arg_Num := Arg_Num + 1; end if; else Arg_Num := Arg_Num + 1; end if; end loop; end; end if; -- If there is a project file specified, parse it, get the switches -- for the tool and setup PATH environment variables. if Project_File /= null then Prj.Pars.Set_Verbosity (To => Current_Verbosity); Prj.Pars.Parse (Project => Project, Project_File_Name => Project_File.all); if Project = Prj.No_Project then Fail ("""" & Project_File.all & """ processing failed"); end if; -- Check if a package with the name of the tool is in the project -- file and if there is one, get the switches, if any, and scan them. declare Data : Prj.Project_Data := Prj.Projects.Table (Project); Pkg : Prj.Package_Id := Prj.Util.Value_Of (Name => Tool_Package_Name, In_Packages => Data.Decl.Packages); Element : Package_Element; Default_Switches_Array : Array_Element_Id; The_Switches : Prj.Variable_Value; Current : Prj.String_List_Id; The_String : String_Element; begin if Pkg /= No_Package then Element := Packages.Table (Pkg); -- Packages Gnatls has a single attribute Switches, that is -- not an associative array. if The_Command = List then The_Switches := Prj.Util.Value_Of (Variable_Name => Snames.Name_Switches, In_Variables => Element.Decl.Attributes); -- Packages Binder (for gnatbind), Cross_Reference (for -- gnatxref), Linker (for gnatlink) and Finder -- (for gnatfind) have an attributed Default_Switches, -- an associative array, indexed by the name of the -- programming language. else Default_Switches_Array := Prj.Util.Value_Of (Name => Name_Default_Switches, In_Arrays => Packages.Table (Pkg).Decl.Arrays); The_Switches := Prj.Util.Value_Of (Index => Name_Ada, In_Array => Default_Switches_Array); end if; -- If there are switches specified in the package of the -- project file corresponding to the tool, scan them. case The_Switches.Kind is when Prj.Undefined => null; when Prj.Single => if String_Length (The_Switches.Value) > 0 then String_To_Name_Buffer (The_Switches.Value); First_Switches.Increment_Last; First_Switches.Table (First_Switches.Last) := new String'(Name_Buffer (1 .. Name_Len)); end if; when Prj.List => Current := The_Switches.Values; while Current /= Prj.Nil_String loop The_String := String_Elements.Table (Current); if String_Length (The_String.Value) > 0 then String_To_Name_Buffer (The_String.Value); First_Switches.Increment_Last; First_Switches.Table (First_Switches.Last) := new String'(Name_Buffer (1 .. Name_Len)); end if; Current := The_String.Next; end loop; end case; end if; end; -- Set up the environment variables ADA_INCLUDE_PATH and -- ADA_OBJECTS_PATH. Setenv (Name => Ada_Include_Path, Value => Prj.Env.Ada_Include_Path (Project).all); Setenv (Name => Ada_Objects_Path, Value => Prj.Env.Ada_Objects_Path (Project, Including_Libraries => False).all); if The_Command = Bind or else The_Command = Link then Change_Dir (Get_Name_String (Projects.Table (Project).Object_Directory)); end if; if The_Command = Link then -- Add the default search directories, to be able to find -- libgnat in call to MLib.Utl.Lib_Directory. Add_Default_Search_Dirs; declare There_Are_Libraries : Boolean := False; begin -- Check if there are library project files if MLib.Tgt.Libraries_Are_Supported then Set_Libraries (Project, There_Are_Libraries); end if; -- If there are, add the necessary additional switches if There_Are_Libraries then -- Add -L -lgnarl -lgnat -Wl,-rpath, Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String'("-L" & MLib.Utl.Lib_Directory); Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String'("-lgnarl"); Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String'("-lgnat"); declare Option : constant String_Access := MLib.Tgt.Linker_Library_Path_Option (MLib.Utl.Lib_Directory); begin if Option /= null then Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := Option; end if; end; end if; end; end if; end if; -- Gather all the arguments and invoke the executable declare The_Args : Argument_List (1 .. First_Switches.Last + Last_Switches.Last); Arg_Num : Natural := 0; begin for J in 1 .. First_Switches.Last loop Arg_Num := Arg_Num + 1; The_Args (Arg_Num) := First_Switches.Table (J); end loop; for J in 1 .. Last_Switches.Last loop Arg_Num := Arg_Num + 1; The_Args (Arg_Num) := Last_Switches.Table (J); end loop; if Opt.Verbose_Mode then Output.Write_Str (Exec_Path.all); for Arg in The_Args'Range loop Output.Write_Char (' '); Output.Write_Str (The_Args (Arg).all); end loop; Output.Write_Eol; end if; My_Exit_Status := Exit_Status (Spawn (Exec_Path.all, The_Args)); raise Normal_Exit; end; end; exception when Error_Exit => Set_Exit_Status (Failure); when Normal_Exit => Set_Exit_Status (My_Exit_Status); end GNATCmd;