diff options
Diffstat (limited to 'gcc/ada/gnatcmd.adb')
| -rw-r--r-- | gcc/ada/gnatcmd.adb | 4399 |
1 files changed, 739 insertions, 3660 deletions
diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index b754aff..f1896d9 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2003 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- -- @@ -27,7 +27,7 @@ with GNAT.Directory_Operations; use GNAT.Directory_Operations; with Csets; -with MLib.Tgt; +with MLib.Tgt; use MLib.Tgt; with MLib.Utl; with Namet; use Namet; with Opt; @@ -38,9 +38,7 @@ 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; @@ -50,16 +48,13 @@ 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"; +with VMS_Conv; use VMS_Conv; +procedure GNATCmd is Project_File : String_Access; Project : Prj.Project_Id; Current_Verbosity : Prj.Verbosity := Prj.Default; @@ -71,16 +66,6 @@ procedure GNATCmd is 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 @@ -91,1782 +76,93 @@ procedure GNATCmd is 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) + package Library_Paths 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 => "Make.Library_Path"); - -- 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. + -- Packages of project files to pass to Prj.Pars.Parse, depending on the + -- tool. We allocate objects because we cannot declare aliased objects + -- as we are in a procedure, not a library level package. - -- 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 + Naming_String : constant String_Access := new String'("naming"); + Binder_String : constant String_Access := new String'("binder"); + Eliminate_String : constant String_Access := new String'("eliminate"); + Finder_String : constant String_Access := new String'("finder"); + Linker_String : constant String_Access := new String'("linker"); + Gnatls_String : constant String_Access := new String'("gnatls"); + Pretty_String : constant String_Access := new String'("pretty_printer"); + Gnatstub_String : constant String_Access := new String'("gnatstub"); + Xref_String : constant String_Access := new String'("cross_reference"); - -- /COMPILER_QUALIFIERS /LIST /BINDER_QUALIFIERS /MAIN - -- /COMPILER_QUALIFIERS /NOLIST /COMPILE_CHECKS=SYNTAX + Packages_To_Check_By_Binder : constant String_List_Access := + new String_List'((Naming_String, Binder_String)); - -- Clearly these switches must come at the end of the list of switches - -- since all subsequent switches apply to an issued command. + Packages_To_Check_By_Eliminate : constant String_List_Access := + new String_List'((Naming_String, Eliminate_String)); - -- 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: + Packages_To_Check_By_Finder : constant String_List_Access := + new String_List'((Naming_String, Finder_String)); - -- "/LIST -gnatl" + Packages_To_Check_By_Linker : constant String_List_Access := + new String_List'((Naming_String, Linker_String)); - -- 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 -- - ------------------------------- + Packages_To_Check_By_Gnatls : constant String_List_Access := + new String_List'((Naming_String, Gnatls_String)); - 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 := "/<other> " & - "--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*"; + Packages_To_Check_By_Pretty : constant String_List_Access := + new String_List'((Naming_String, Pretty_String)); - 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); + Packages_To_Check_By_Gnatstub : constant String_List_Access := + new String_List'((Naming_String, Gnatstub_String)); - ---------------------------- - -- Switches for GNAT MAKE -- - ---------------------------- + Packages_To_Check_By_Xref : constant String_List_Access := + new String_List'((Naming_String, Xref_String)); - 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 := "/<other> " & - "--for-linker="; - - Shared_Switches : aliased constant Switches := - (S_Shared_Debug 'Access, - S_Shared_Image 'Access, - S_Shared_Ident 'Access, - S_Shared_Nofiles 'Access, - S_Shared_Noinhib 'Access, - S_Shared_Verb 'Access, - S_Shared_ZZZZZ 'Access); - - -------------------------------- - -- Switches for GNAT STANDARD -- - -------------------------------- - - Standard_Switches : aliased constant Switches := (1 .. 0 => null); - - ---------------------------- - -- Switches for GNAT STUB -- - ---------------------------- - - S_Stub_Current : aliased constant S := "/CURRENT_DIRECTORY " & - "!-I-"; - - S_Stub_Full : aliased constant S := "/FULL " & - "-f"; - - S_Stub_Header : aliased constant S := "/HEADER=" & - "GENERAL " & - "-hg " & - "SPEC " & - "-hs"; - - S_Stub_Indent : aliased constant S := "/INDENTATION=#" & - "-i#"; - - S_Stub_Length : aliased constant S := "/LINE_LENGTH=#" & - "-l#"; - - S_Stub_Quiet : aliased constant S := "/QUIET " & - "-q"; - - S_Stub_Search : aliased constant S := "/SEARCH=*" & - "-I*"; - - S_Stub_Tree : aliased constant S := "/TREE_FILE=" & - "OVERWRITE " & - "-t " & - "SAVE " & - "-k " & - "REUSE " & - "-r"; - - S_Stub_Verbose : aliased constant S := "/VERBOSE " & - "-v"; - - Stub_Switches : aliased constant Switches := - (S_Stub_Current 'Access, - S_Stub_Full 'Access, - S_Stub_Header 'Access, - S_Stub_Indent 'Access, - S_Stub_Length 'Access, - S_Stub_Quiet 'Access, - S_Stub_Search 'Access, - S_Stub_Tree 'Access, - S_Stub_Verbose 'Access); - - ---------------------------- - -- Switches for GNAT 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); + Packages_To_Check : String_List_Access := Prj.All_Packages; ---------------------------------- -- 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 + The_Command : Command_Type; 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 + Current_Work_Dir : constant String := Get_Current_Dir; ----------------------- -- Local Subprograms -- ----------------------- + procedure Check_Relative_Executable (Name : in out String_Access); + -- Check if an executable is specified as a relative path. + -- If it is, and the path contains directory information, fail. + -- Otherwise, prepend the exec directory. + -- This procedure is only used for GNAT LINK when a project file + -- is specified. + + function Configuration_Pragmas_File return Name_Id; + -- Return an argument, if there is a configuration pragmas file to be + -- specified for Project, otherwise return No_Name. + -- Used for gnatstub (GNAT STUB), gnatpp (GNAT PRETTY) and gnatelim + -- (GNAT ELIM). + + procedure Delete_Temp_Config_Files; + -- Delete all temporary config files + 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); @@ -1878,430 +174,99 @@ procedure GNATCmd is -- 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 -- - ---------------------- + procedure Test_If_Relative_Path + (Switch : in out String_Access; + Parent : String); + -- Test if Switch is a relative search path switch. + -- If it is and it includes directory information, prepend the path with + -- Parent.This subprogram is only called when using project files. - 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 -- - ----------- + ------------------------------- + -- Check_Relative_Executable -- + ------------------------------- - function Match (S1, S2 : String) return Boolean is - Dif : constant Integer := S2'First - S1'First; + procedure Check_Relative_Executable (Name : in out String_Access) is + Exec_File_Name : constant String := Name.all; 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; + if not Is_Absolute_Path (Exec_File_Name) then + for Index in Exec_File_Name'Range loop + if Exec_File_Name (Index) = Directory_Separator then + Fail ("relative executable (""" & + Exec_File_Name & + """) with directory part not allowed " & + "when using project files"); end if; end loop; - return True; - end if; - end Match; - - ------------------ - -- Match_Prefix -- - ------------------ + Get_Name_String (Projects.Table + (Project).Exec_Directory); - 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; + if Name_Buffer (Name_Len) /= Directory_Separator then + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Directory_Separator; end if; - Errors := Errors + 1; - - if Itm /= null then - case Itm.Id is - when Id_Command => - Put (Standard_Error, "command"); - - when Id_Switch => - if OpenVMS then - Put (Standard_Error, "qualifier"); - else - Put (Standard_Error, "switch"); - end if; - - when Id_Option => - Put (Standard_Error, "option"); - - end case; - else - Put (Standard_Error, "input"); - - end if; - - Put (Standard_Error, ": "); - Put (Standard_Error, S); - end Err; - - -- Start of processing for Matching_Name - - begin - -- If exact match, that's the one we want - - P1 := Itm; - while P1 /= null loop - if Match (S, P1.Name.all) then - return P1; - else - P1 := P1.Next; - end if; - end loop; - - -- Now check for prefix matches - - P1 := Itm; - while P1 /= null loop - if P1.Name.all = "/<other>" then - return P1; - - elsif not Match_Prefix (S, P1.Name.all) then - P1 := P1.Next; - - else - -- Here we have found one matching prefix, so see if there is - -- another one (which is an ambiguity) - - P2 := P1.Next; - while P2 /= null loop - if Match_Prefix (S, P2.Name.all) then - if not Quiet then - Put (Standard_Error, "ambiguous "); - Err; - Put (Standard_Error, " (matches "); - Put (Standard_Error, P1.Name.all); - - while P2 /= null loop - if Match_Prefix (S, P2.Name.all) then - Put (Standard_Error, ','); - Put (Standard_Error, P2.Name.all); - end if; - - P2 := P2.Next; - end loop; - - Put_Line (Standard_Error, ")"); - end if; - - return null; - end if; - - P2 := P2.Next; - end loop; - - -- If we fall through that loop, then there was only one match - - return P1; - end if; - end loop; - - -- If we fall through outer loop, there was no match - - if not Quiet then - Put (Standard_Error, "unrecognized "); - Err; - New_Line (Standard_Error); + Name_Buffer (Name_Len + 1 .. + Name_Len + Exec_File_Name'Length) := + Exec_File_Name; + Name_Len := Name_Len + Exec_File_Name'Length; + Name := new String'(Name_Buffer (1 .. Name_Len)); end if; + end Check_Relative_Executable; - return null; - end Matching_Name; - - ----------------------- - -- OK_Alphanumerplus -- - ----------------------- + -------------------------------- + -- Configuration_Pragmas_File -- + -------------------------------- - function OK_Alphanumerplus (S : String) return Boolean is + function Configuration_Pragmas_File return Name_Id 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; + Prj.Env.Create_Config_Pragmas_File + (Project, Project, Include_Config_Files => False); + return Projects.Table (Project).Config_File_Name; + end Configuration_Pragmas_File; - return True; - end if; - end OK_Alphanumerplus; + ------------------------------ + -- Delete_Temp_Config_Files -- + ------------------------------ - ---------------- - -- OK_Integer -- - ---------------- + procedure Delete_Temp_Config_Files is + Success : Boolean; - function OK_Integer (S : String) return Boolean is begin - if S'Length = 0 then - return False; + if Project /= No_Project then + for Prj in 1 .. Projects.Last loop + if Projects.Table (Prj).Config_File_Temp then + if Opt.Verbose_Mode then + Output.Write_Str ("Deleting temp configuration file """); + Output.Write_Str (Get_Name_String + (Projects.Table (Prj).Config_File_Name)); + Output.Write_Line (""""); + end if; - else - for J in S'Range loop - if not Is_Digit (S (J)) then - return False; + Delete_File + (Name => Get_Name_String + (Projects.Table (Prj).Config_File_Name), + Success => Success); 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; + end Delete_Temp_Config_Files; ----------- - -- Place -- + -- Index -- ----------- - 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; - + function Index (Char : Character; Str : String) return Natural is 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)); + for Index in Str'Range loop + if Str (Index) = Char then + return Index; end if; - - P1 := P2 + 2; end loop; - end Place_Unix_Switches; + + return 0; + end Index; --------------------- -- Set_Library_For -- @@ -2311,6 +276,9 @@ procedure GNATCmd is (Project : Project_Id; There_Are_Libraries : in out Boolean) is + Path_Option : constant String_Access := + MLib.Tgt.Linker_Library_Path_Option; + begin -- Case of library project @@ -2333,250 +301,86 @@ procedure GNATCmd is 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; + -- Add the directory to table Library_Paths, to be processed later + -- if library is not static and if Path_Option is not null. + if Projects.Table (Project).Library_Kind /= Static + and then Path_Option /= null + then + Library_Paths.Increment_Last; + Library_Paths.Table (Library_Paths.Last) := + new String'(Get_Name_String + (Projects.Table (Project).Library_Dir)); end if; end if; end Set_Library_For; - -------------------------------- - -- Validate_Command_Or_Option -- - -------------------------------- + --------------------------- + -- Test_If_Relative_Path -- + --------------------------- - procedure Validate_Command_Or_Option (N : String_Ptr) is + procedure Test_If_Relative_Path + (Switch : in out String_Access; + Parent : String) + 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; + if Switch /= null then + + declare + Sw : String (1 .. Switch'Length); + Start : Positive := 1; - -------------------------- - -- Validate_Unix_Switch -- - -------------------------- + begin + Sw := Switch.all; - procedure Validate_Unix_Switch (S : String_Ptr) is - begin - if S (S'First) = '`' then - return; - end if; + if Sw (1) = '-' then + if Sw'Length >= 3 + and then (Sw (2) = 'A' + or else Sw (2) = 'I' + or else Sw (2) = 'L') + then + Start := 3; - pragma Assert (S (S'First) = '-' or else S (S'First) = '!'); + if Sw = "-I-" then + return; + end if; - for J in S'First + 1 .. S'Last loop - pragma Assert (S (J) /= ' '); + elsif Sw'Length >= 4 + and then (Sw (2 .. 3) = "aL" + or else Sw (2 .. 3) = "aO" + or else Sw (2 .. 3) = "aI") + then + Start := 4; - 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") - ); + elsif Sw'Length >= 7 + and then Sw (2 .. 6) = "-RTS=" + then + Start := 7; + else + return; + end if; + end if; + + -- If the path is relative, test if it includes directory + -- information. If it does, prepend Parent to the path. + + if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then + for J in Start .. Sw'Last loop + if Sw (J) = Directory_Separator then + Switch := + new String' + (Sw (1 .. Start - 1) & + Parent & + Directory_Separator & + Sw (Start .. Sw'Last)); + return; + end if; + end loop; + end if; + end; + end if; + end Test_If_Relative_Path; ------------------- -- Non_VMS_Usage -- @@ -2611,1209 +415,11 @@ procedure GNATCmd is end loop; New_Line; - Put_Line ("Commands FIND, LIST and XREF accept project file " & - "switches -vPx, -Pprj and -Xnam=val"); + Put_Line ("Commands FIND, LIST, PRETTY, STUB 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; - - <<Tryagain_After_Coalesce>> - loop - declare - Next_Arg_Idx : Integer; - Arg : String_Access; - - begin - Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); - Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx)); - - -- The first one must be a command name - - if Arg_Num = 1 and then Arg_Idx = Argv'First then - - Command := Matching_Name (Arg.all, Commands); - - if Command = null then - raise Error_Exit; - end if; - - 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 & - "/<other>"); - - when T_Direct => - Set_Col (53); - Put_Line (Sw.Unix_String.all); - - when T_Directories => - Put ("=(direc,direc,..direc)"); - Set_Col (53); - Put (Sw.Unix_String.all); - Put (" direc "); - Put (Sw.Unix_String.all); - Put_Line (" direc ..."); - - when T_Directory => - Put ("=directory"); - Set_Col (53); - Put (Sw.Unix_String.all); - - if Sw.Unix_String (Sw.Unix_String'Last) - /= '=' - then - Put (' '); - end if; - - Put_Line ("directory "); - - when T_File | T_No_Space_File => - Put ("=file"); - Set_Col (53); - Put (Sw.Unix_String.all); - - if Sw.Translation = T_File - and then Sw.Unix_String - (Sw.Unix_String'Last) - /= '=' - then - Put (' '); - end if; - - Put_Line ("file "); - - when T_Numeric => - Put ("=nnn"); - Set_Col (53); - - if Sw.Unix_String (Sw.Unix_String'First) - = '`' - then - Put (Sw.Unix_String - (Sw.Unix_String'First + 1 - .. Sw.Unix_String'Last)); - else - Put (Sw.Unix_String.all); - end if; - - Put_Line ("nnn"); - - when T_Alphanumplus => - Put ("=xyz"); - Set_Col (53); - - if Sw.Unix_String (Sw.Unix_String'First) - = '`' - then - Put (Sw.Unix_String - (Sw.Unix_String'First + 1 - .. Sw.Unix_String'Last)); - else - Put (Sw.Unix_String.all); - end if; - - Put_Line ("xyz"); - - when T_String => - Put ("="); - Put ('"'); - Put ("<string>"); - Put ('"'); - Set_Col (53); - - Put (Sw.Unix_String.all); - - if Sw.Unix_String (Sw.Unix_String'Last) - /= '=' - then - Put (' '); - end if; - - Put ("<string>"); - New_Line; - - when T_Commands => - Put (" (switches for "); - Put (Sw.Unix_String - (Sw.Unix_String'First + 7 - .. Sw.Unix_String'Last)); - Put (')'); - Set_Col (53); - Put (Sw.Unix_String - (Sw.Unix_String'First - .. Sw.Unix_String'First + 5)); - Put_Line (" switches"); - - when T_Options => - declare - Opt : Item_Ptr := Sw.Options; - - begin - Put_Line ("=(option,option..)"); - - while Opt /= null loop - Put (" "); - Put (Opt.Name.all); - - if Opt = Sw.Options then - Put (" (D)"); - end if; - - Set_Col (53); - Put_Line (Opt.Unix_String.all); - Opt := Opt.Next; - end loop; - end; - - end case; - - Sw := Sw.Next; - end loop; - end; - - 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 -- ------------------------------------- @@ -3834,6 +440,8 @@ begin First_Switches.Init; First_Switches.Set_Last (0); + VMS_Conv.Initialize; + -- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers, -- filenames and pathnames to Unix style. @@ -3859,13 +467,17 @@ begin 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"); + 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; @@ -3877,7 +489,7 @@ begin exception when Constraint_Error => Non_VMS_Usage; - Fail ("Unknown command: " & Argument (Command_Arg)); + Fail ("Unknown command: ", Argument (Command_Arg)); end; end; @@ -3891,7 +503,7 @@ begin declare Program : constant String := - Program_Name (Command_List (The_Command).Unixcmd.all).all; + Program_Name (Command_List (The_Command).Unixcmd.all).all; Exec_Path : String_Access; @@ -3915,30 +527,51 @@ begin end loop; end if; - -- For BIND, FIND, LINK, LIST and XREF, look for project file related - -- switches. + -- For BIND, FIND, LINK, LIST, PRETTY ad XREF, look for project file + -- related switches. if The_Command = Bind + or else The_Command = Elim or else The_Command = Find or else The_Command = Link or else The_Command = List or else The_Command = Xref + or else The_Command = Pretty + or else The_Command = Stub then case The_Command is when Bind => Tool_Package_Name := Name_Binder; + Packages_To_Check := Packages_To_Check_By_Binder; + when Elim => + Tool_Package_Name := Name_Eliminate; + Packages_To_Check := Packages_To_Check_By_Eliminate; when Find => Tool_Package_Name := Name_Finder; + Packages_To_Check := Packages_To_Check_By_Finder; when Link => Tool_Package_Name := Name_Linker; + Packages_To_Check := Packages_To_Check_By_Linker; when List => Tool_Package_Name := Name_Gnatls; + Packages_To_Check := Packages_To_Check_By_Gnatls; + when Pretty => + Tool_Package_Name := Name_Pretty_Printer; + Packages_To_Check := Packages_To_Check_By_Pretty; + when Stub => + Tool_Package_Name := Name_Gnatstub; + Packages_To_Check := Packages_To_Check_By_Gnatstub; when Xref => Tool_Package_Name := Name_Cross_Reference; + Packages_To_Check := Packages_To_Check_By_Xref; when others => null; end case; + -- Check that the switches are consistent. + -- Detect project file related switches. + + Inspect_Switches : declare Arg_Num : Positive := 1; Argv : String_Access; @@ -3957,7 +590,7 @@ begin Last_Switches.Decrement_Last; end Remove_Switch; - -- Start of processing for ??? (need block name here) + -- Start of processing for Inspect_Switches begin while Arg_Num <= Last_Switches.Last loop @@ -3965,7 +598,8 @@ begin if Argv (Argv'First) = '-' then if Argv'Length = 1 then - Fail ("switch character cannot be followed by a blank"); + Fail + ("switch character cannot be followed by a blank"); end if; -- The two style project files (-p and -P) cannot be used @@ -3993,23 +627,22 @@ begin when '2' => Current_Verbosity := Prj.High; when others => - Fail ("Invalid switch: " & Argv.all); + 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 + elsif 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 & """)"); + Fail + (Argv.all, + ": second project file forbidden (first is """, + Project_File.all & """)"); -- The two style project files (-p and -P) cannot be -- used together. @@ -4017,7 +650,31 @@ begin elsif Old_Project_File_Used then Fail ("-p and -P cannot be used together"); + elsif Argv'Length = 2 then + -- There is space between -P and the project file + -- name. -P cannot be the last option. + + if Arg_Num = Last_Switches.Last then + Fail ("project file name missing after -P"); + + else + Remove_Switch (Arg_Num); + Argv := Last_Switches.Table (Arg_Num); + + -- After -P, there must be a project file name, + -- not another switch. + + if Argv (Argv'First) = '-' then + Fail ("project file name missing after -P"); + + else + Project_File := new String'(Argv.all); + end if; + end if; + else + -- No space between -P and project file name + Project_File := new String'(Argv (Argv'First + 2 .. Argv'Last)); end if; @@ -4040,8 +697,9 @@ begin Argv (Argv'First + 2 .. Equal_Pos - 1), Value => Argv (Equal_Pos + 1 .. Argv'Last)); else - Fail (Argv.all & - " is not a valid external assignment."); + Fail + (Argv.all, + " is not a valid external assignment."); end if; end; @@ -4055,7 +713,7 @@ begin Arg_Num := Arg_Num + 1; end if; end loop; - end; + end Inspect_Switches; end if; -- If there is a project file specified, parse it, get the switches @@ -4066,21 +724,24 @@ begin Prj.Pars.Parse (Project => Project, - Project_File_Name => Project_File.all); + Project_File_Name => Project_File.all, + Packages_To_Check => Packages_To_Check); if Project = Prj.No_Project then - Fail ("""" & Project_File.all & """ processing failed"); + 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); + Data : constant Prj.Project_Data := + Prj.Projects.Table (Project); + + Pkg : constant Prj.Package_Id := + Prj.Util.Value_Of + (Name => Tool_Package_Name, + In_Packages => Data.Decl.Packages); Element : Package_Element; @@ -4104,19 +765,23 @@ begin 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); + -- gnatxref), Linker (for gnatlink) Finder (for gnatfind), + -- Pretty_Printer (for gnatpp) and Eliminate (for gnatelim) + -- have an attributed Switches, an associative array, indexed + -- by the name of the file. + -- They also have an attribute Default_Switches, indexed + -- by the name of the programming language. + else + if The_Switches.Kind = Prj.Undefined then + 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; end if; -- If there are switches specified in the package of the @@ -4127,24 +792,34 @@ begin 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; + declare + Switch : constant String := + Get_Name_String (The_Switches.Value); + + begin + if Switch'Length > 0 then + First_Switches.Increment_Last; + First_Switches.Table (First_Switches.Last) := + new String'(Switch); + end if; + end; 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; + declare + Switch : constant String := + Get_Name_String (The_String.Value); + + begin + if Switch'Length > 0 then + First_Switches.Increment_Last; + First_Switches.Table (First_Switches.Last) := + new String'(Switch); + end if; + end; Current := The_String.Next; end loop; @@ -4152,23 +827,45 @@ begin 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 + if The_Command = Bind + or else The_Command = Link + or else The_Command = Elim + then Change_Dir (Get_Name_String (Projects.Table (Project).Object_Directory)); end if; + -- Set up the env vars for project path files + + Prj.Env.Set_Ada_Paths (Project, Including_Libraries => False); + + -- For gnatstub, gnatpp and gnatelim, create a configuration pragmas + -- file, if necessary. + + if The_Command = Pretty + or else The_Command = Stub + or else The_Command = Elim + then + declare + CP_File : constant Name_Id := Configuration_Pragmas_File; + + begin + if CP_File /= No_Name then + First_Switches.Increment_Last; + + if The_Command = Elim then + First_Switches.Table (First_Switches.Last) := + new String'("-C" & Get_Name_String (CP_File)); + + else + First_Switches.Table (First_Switches.Last) := + new String'("-gnatec=" & Get_Name_String (CP_File)); + end if; + end if; + end; + end if; + if The_Command = Link then -- Add the default search directories, to be able to find @@ -4178,11 +875,15 @@ begin declare There_Are_Libraries : Boolean := False; + Path_Option : constant String_Access := + MLib.Tgt.Linker_Library_Path_Option; begin + Library_Paths.Set_Last (0); + -- Check if there are library project files - if MLib.Tgt.Libraries_Are_Supported then + if MLib.Tgt.Support_For_Libraries /= MLib.Tgt.None then Set_Libraries (Project, There_Are_Libraries); end if; @@ -4202,18 +903,366 @@ begin Last_Switches.Table (Last_Switches.Last) := new String'("-lgnat"); - declare - Option : constant String_Access := - MLib.Tgt.Linker_Library_Path_Option - (MLib.Utl.Lib_Directory); + -- If Path_Option is not null, create the switch + -- ("-Wl,-rpath," or equivalent) with all the library dirs + -- plus the standard GNAT library dir. + + if Path_Option /= null then + declare + Option : String_Access; + Length : Natural := Path_Option'Length; + Current : Natural; + + begin + -- First, compute the exact length for the switch + + for Index in + Library_Paths.First .. Library_Paths.Last + loop + -- Add the length of the library dir plus one + -- for the directory separator. + + Length := + Length + + Library_Paths.Table (Index)'Length + 1; + end loop; + + -- Finally, add the length of the standard GNAT + -- library dir. + + Length := Length + MLib.Utl.Lib_Directory'Length; + Option := new String (1 .. Length); + Option (1 .. Path_Option'Length) := Path_Option.all; + Current := Path_Option'Length; + + -- Put each library dir followed by a dir separator + + for Index in + Library_Paths.First .. Library_Paths.Last + loop + Option + (Current + 1 .. + Current + + Library_Paths.Table (Index)'Length) := + Library_Paths.Table (Index).all; + Current := + Current + + Library_Paths.Table (Index)'Length + 1; + Option (Current) := Path_Separator; + end loop; + + -- Finally put the standard GNAT library dir + + Option + (Current + 1 .. + Current + MLib.Utl.Lib_Directory'Length) := + MLib.Utl.Lib_Directory; + + -- And add the switch to the last switches - begin - if Option /= null then Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := Option; + end; + end if; + end if; + end; + + -- Check if the first ALI file specified can be found, either + -- in the object directory of the main project or in an object + -- directory of a project file extended by the main project. + -- If the ALI file can be found, replace its name with its + -- absolute path. + + declare + Skip_Executable : Boolean := False; + + begin + Switch_Loop : for J in 1 .. Last_Switches.Last loop + + -- If we have an executable just reset the flag + + if Skip_Executable then + Skip_Executable := False; + + -- If -o, set flag so that next switch is not processed + + elsif Last_Switches.Table (J).all = "-o" then + Skip_Executable := True; + + -- Normal case + + else + declare + Switch : constant String := + Last_Switches.Table (J).all; + + ALI_File : constant String (1 .. Switch'Length + 4) := + Switch & ".ali"; + + Last : Natural := Switch'Length; + Test_Existence : Boolean := False; + + begin + -- Skip real switches + + if Switch'Length /= 0 and then + Switch (Switch'First) /= '-' + then + -- Append ".ali" if file name does not end with it + + if Switch'Length <= 4 or else + Switch (Switch'Last - 3 .. Switch'Last) /= ".ali" + then + Last := ALI_File'Last; + end if; + + -- If file name includes directory information, + -- stop if ALI file exists. + + if Is_Absolute_Path (ALI_File (1 .. Last)) then + Test_Existence := True; + + else + for K in Switch'Range loop + if Switch (K) = '/' or else + Switch (K) = Directory_Separator + then + Test_Existence := True; + exit; + end if; + end loop; + end if; + + if Test_Existence then + if Is_Regular_File (ALI_File (1 .. Last)) then + exit Switch_Loop; + end if; + + else + -- Look in the object directories if the ALI + -- file exists. + + declare + Prj : Project_Id := Project; + begin + Project_Loop : + loop + declare + Dir : constant String := + Get_Name_String + (Projects.Table (Prj). + Object_Directory); + begin + if Is_Regular_File + (Dir & Directory_Separator & + ALI_File (1 .. Last)) + then + -- We have found the correct + -- project, so we replace the file + -- with the absolute path. + + Last_Switches.Table (J) := + new String' + (Dir & Directory_Separator & + ALI_File (1 .. Last)); + + -- And we are done + + exit Switch_Loop; + end if; + end; + + -- Go to the project being extended, + -- if any. + + Prj := Projects.Table (Prj).Extends; + exit Project_Loop when Prj = No_Project; + end loop Project_Loop; + end; + end if; + end if; + end; + end if; + end loop Switch_Loop; + end; + + -- If a relative path output file has been specified, we add + -- the exec directory. + + declare + Look_For_Executable : Boolean := True; + + begin + + for J in reverse 1 .. Last_Switches.Last - 1 loop + if Last_Switches.Table (J).all = "-o" then + Check_Relative_Executable + (Name => Last_Switches.Table (J + 1)); + Look_For_Executable := False; + exit; + end if; + end loop; + + if Look_For_Executable then + for J in reverse 1 .. First_Switches.Last - 1 loop + if First_Switches.Table (J).all = "-o" then + Look_For_Executable := False; + Check_Relative_Executable + (Name => First_Switches.Table (J + 1)); + exit; + end if; + end loop; + end if; + + -- If no executable is specified, then find the name + -- of the first ALI file on the command line and issue + -- a -o switch with the absolute path of the executable + -- in the exec directory. + + if Look_For_Executable then + for J in 1 .. Last_Switches.Last loop + declare + Arg : constant String_Access := + Last_Switches.Table (J); + Last : Natural := 0; + + begin + if Arg'Length /= 0 and then Arg (Arg'First) /= '-' then + if Arg'Length > 4 + and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali" + then + Last := Arg'Last - 4; + + elsif Is_Regular_File (Arg.all & ".ali") then + Last := Arg'Last; + end if; + + if Last /= 0 then + declare + Executable_Name : constant String := + Base_Name (Arg (Arg'First .. Last)); + begin + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-o"); + Get_Name_String + (Projects.Table (Project).Exec_Directory); + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'(Name_Buffer (1 .. Name_Len) & + Directory_Separator & + Executable_Name & + Get_Executable_Suffix.all); + exit; + end; + end if; + end if; + end; + end loop; + end if; + end; + end if; + + if The_Command = Link or The_Command = Bind then + + -- For files that are specified as relative paths with directory + -- information, we convert them to absolute paths, with parent + -- being the current working directory if specified on the command + -- line and the project directory if specified in the project + -- file. This is what gnatmake is doing for linker and binder + -- arguments. + + for J in 1 .. Last_Switches.Last loop + Test_If_Relative_Path + (Last_Switches.Table (J), Current_Work_Dir); + end loop; + + Get_Name_String (Projects.Table (Project).Directory); + + declare + Project_Dir : constant String := Name_Buffer (1 .. Name_Len); + + begin + for J in 1 .. First_Switches.Last loop + Test_If_Relative_Path + (First_Switches.Table (J), Project_Dir); + end loop; + end; + + elsif The_Command = Stub then + declare + Data : constant Prj.Project_Data := + Prj.Projects.Table (Project); + File_Index : Integer := 0; + Dir_Index : Integer := 0; + Last : constant Integer := Last_Switches.Last; + + begin + for Index in 1 .. Last loop + if Last_Switches.Table (Index) + (Last_Switches.Table (Index)'First) /= '-' + then + File_Index := Index; + exit; + end if; + end loop; + + -- If the naming scheme of the project file is not standard, + -- and if the file name ends with the spec suffix, then + -- indicate to gnatstub the name of the body file with + -- a -o switch. + + if Data.Naming.Current_Spec_Suffix /= + Prj.Default_Ada_Spec_Suffix + then + if File_Index /= 0 then + declare + Spec : constant String := + Base_Name (Last_Switches.Table (File_Index).all); + Last : Natural := Spec'Last; + + begin + Get_Name_String (Data.Naming.Current_Spec_Suffix); + + if Spec'Length > Name_Len + and then Spec (Last - Name_Len + 1 .. Last) = + Name_Buffer (1 .. Name_Len) + then + Last := Last - Name_Len; + Get_Name_String (Data.Naming.Current_Body_Suffix); + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-o"); + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'(Spec (Spec'First .. Last) & + Name_Buffer (1 .. Name_Len)); + end if; + end; + end if; + end if; + + -- Add the directory of the spec as the destination directory + -- of the body, if there is no destination directory already + -- specified. + + if File_Index /= 0 then + for Index in File_Index + 1 .. Last loop + if Last_Switches.Table (Index) + (Last_Switches.Table (Index)'First) /= '-' + then + Dir_Index := Index; + exit; end if; - end; + end loop; + + if Dir_Index = 0 then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String' + (Dir_Name (Last_Switches.Table (File_Index).all)); + end if; end if; end; end if; @@ -4236,6 +1285,22 @@ begin The_Args (Arg_Num) := Last_Switches.Table (J); end loop; + -- If Display_Command is on, only display the generated command + + if Display_Command then + Put (Standard_Error, "generated command -->"); + Put (Standard_Error, Exec_Path.all); + + for Arg in The_Args'Range loop + Put (Standard_Error, " "); + Put (Standard_Error, The_Args (Arg).all); + end loop; + + Put (Standard_Error, "<--"); + New_Line (Standard_Error); + raise Normal_Exit; + end if; + if Opt.Verbose_Mode then Output.Write_Str (Exec_Path.all); @@ -4247,17 +1312,31 @@ begin Output.Write_Eol; end if; - My_Exit_Status - := Exit_Status (Spawn (Exec_Path.all, The_Args)); + My_Exit_Status := + Exit_Status (Spawn (Exec_Path.all, The_Args)); raise Normal_Exit; end; end; exception when Error_Exit => + Prj.Env.Delete_All_Path_Files; + Delete_Temp_Config_Files; Set_Exit_Status (Failure); when Normal_Exit => - Set_Exit_Status (My_Exit_Status); + Prj.Env.Delete_All_Path_Files; + Delete_Temp_Config_Files; + + -- Since GNATCmd is normally called from DCL (the VMS shell), + -- it must return an understandable VMS exit status. However + -- the exit status returned *to* GNATCmd is a Posix style code, + -- so we test it and return just a simple success or failure on VMS. + + if Hostparm.OpenVMS and then My_Exit_Status /= Success then + Set_Exit_Status (Failure); + else + Set_Exit_Status (My_Exit_Status); + end if; end GNATCmd; |