-- --
-- B o d y --
-- --
--- $Revision$
--- --
--- Copyright (C) 1996-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2004 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- --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-with Ada.Characters.Handling; use Ada.Characters.Handling;
-with Ada.Command_Line; use Ada.Command_Line;
-with Ada.Text_IO; use Ada.Text_IO;
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with Csets;
+with MLib.Tgt; use MLib.Tgt;
+with MLib.Utl;
+with Namet; use Namet;
+with Opt;
with Osint; use Osint;
-with Sdefault; use Sdefault;
+with Output;
+with Prj; use Prj;
+with Prj.Env;
+with Prj.Ext; use Prj.Ext;
+with Prj.Pars;
+with Prj.Util; use Prj.Util;
+with Snames; use Snames;
+with Table;
+with Types; use Types;
with Hostparm; use Hostparm;
-- Used to determine if we are in VMS or not for error message purposes
-with Gnatvsn;
+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 GNAT.OS_Lib; use GNAT.OS_Lib;
with Table;
-procedure GNATCmd is
- pragma Ident (Gnatvsn.Gnat_Version_String);
-
- ------------------
- -- SWITCH TABLE --
- ------------------
+with VMS_Conv; use VMS_Conv;
- -- The switch tables contain an entry for each switch recognized by the
- -- command processor. The syntax of entries is as follows:
+procedure GNATCmd is
+ Project_File : String_Access;
+ Project : Prj.Project_Id;
+ Current_Verbosity : Prj.Verbosity := Prj.Default;
+ Tool_Package_Name : Name_Id := No_Name;
- -- SWITCH_STRING ::= "/ command-qualifier-name TRANSLATION"
+ -- This flag indicates a switch -p (for gnatxref and gnatfind) for
+ -- an old fashioned project file. -p cannot be used in conjonction
+ -- with -P.
- -- TRANSLATION ::=
- -- DIRECT_TRANSLATION
- -- | DIRECTORIES_TRANSLATION
- -- | FILE_TRANSLATION
- -- | NUMERIC_TRANSLATION
- -- | STRING_TRANSLATION
- -- | OPTIONS_TRANSLATION
- -- | COMMANDS_TRANSLATION
- -- | ALPHANUMPLUS_TRANSLATION
- -- | OTHER_TRANSLATION
+ Old_Project_File_Used : Boolean := False;
- -- DIRECT_TRANSLATION ::= space UNIX_SWITCHES
- -- DIRECTORIES_TRANSLATION ::= =* UNIX_SWITCH *
- -- DIRECTORY_TRANSLATION ::= =% UNIX_SWITCH %
- -- FILE_TRANSLATION ::= =@ UNIX_SWITCH @
- -- NUMERIC_TRANSLATION ::= =# UNIX_SWITCH # | # number #
- -- STRING_TRANSLATION ::= =" UNIX_SWITCH "
- -- OPTIONS_TRANSLATION ::= =OPTION {space OPTION}
- -- COMMANDS_TRANSLATION ::= =? ARGS space command-name
- -- ALPHANUMPLUS_TRANSLATION ::= =| UNIX_SWITCH |
+ -- A table to keep the switches from the project file
- -- UNIX_SWITCHES ::= UNIX_SWITCH {, UNIX_SWITCH}
+ package First_Switches is new Table.Table
+ (Table_Component_Type => String_Access,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 20,
+ Table_Increment => 100,
+ Table_Name => "Gnatcmd.First_Switches");
- -- UNIX_SWITCH ::= unix-switch-string | !unix-switch-string | `string'
+ 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");
- -- OPTION ::= option-name space UNIX_SWITCHES
+ -- 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.
- -- ARGS ::= -cargs | -bargs | -largs
+ 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");
- -- 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.
+ Packages_To_Check_By_Binder : constant String_List_Access :=
+ new String_List'((Naming_String, Binder_String));
- -- 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.
+ Packages_To_Check_By_Eliminate : constant String_List_Access :=
+ new String_List'((Naming_String, Eliminate_String));
- -- 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
+ Packages_To_Check_By_Finder : constant String_List_Access :=
+ new String_List'((Naming_String, Finder_String));
- -- PATH=direc
- -- PATH=(direc,direc,direc,direc)
+ Packages_To_Check_By_Linker : constant String_List_Access :=
+ new String_List'((Naming_String, Linker_String));
- -- 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 *.
+ Packages_To_Check_By_Gnatls : constant String_List_Access :=
+ new String_List'((Naming_String, Gnatls_String));
- -- 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.
+ Packages_To_Check_By_Pretty : constant String_List_Access :=
+ new String_List'((Naming_String, Pretty_String));
- -- 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.
+ Packages_To_Check_By_Gnatstub : constant String_List_Access :=
+ new String_List'((Naming_String, Gnatstub_String));
- -- 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:
+ Packages_To_Check_By_Xref : constant String_List_Access :=
+ new String_List'((Naming_String, Xref_String));
- -- /ERRORS=BRIEF
- -- /ERRORS=(FULL,VERBOSE)
- -- /ERRORS=(BRIEF IMMEDIATE)
+ Packages_To_Check : String_List_Access := Prj.All_Packages;
- -- 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.
+ ----------------------------------
+ -- Declarations for GNATCMD use --
+ ----------------------------------
- -- 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
+ The_Command : Command_Type;
- -- /COMPILER_QUALIFIERS /LIST /BINDER_QUALIFIERS /MAIN
- -- /COMPILER_QUALIFIERS /NOLIST /COMPILE_CHECKS=SYNTAX
+ Command_Arg : Positive := 1;
- -- Clearly these switches must come at the end of the list of switches
- -- since all subsequent switches apply to an issued command.
+ My_Exit_Status : Exit_Status := Success;
- -- 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:
+ Current_Work_Dir : constant String := Get_Current_Dir;
- -- "/LIST -gnatl"
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
- -- An implicit entry is created:
+ 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.
+
+ procedure Non_VMS_Usage;
+ -- Display usage for platforms other than VMS
+
+ procedure Set_Library_For
+ (Project : Project_Id;
+ There_Are_Libraries : in out Boolean);
+ -- If Project is a library project, add the correct
+ -- -L and -l switches to the linker invocation.
+
+ procedure Set_Libraries is
+ new For_Every_Project_Imported (Boolean, Set_Library_For);
+ -- Add the -L and -l switches to the linker for all
+ -- of the library projects.
+
+ procedure 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.
- -- "/NOLIST !-gnatl"
+ -------------------------------
+ -- Check_Relative_Executable --
+ -------------------------------
- -- In the case where, a ! is already present, inverting the sense of the
- -- switch means removing it.
+ procedure Check_Relative_Executable (Name : in out String_Access) is
+ Exec_File_Name : constant String := Name.all;
- subtype S is String;
- -- A synonym to shorten the table
+ begin
+ 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;
- type String_Ptr is access constant String;
- -- String pointer type used throughout
+ Get_Name_String (Projects.Table
+ (Project).Exec_Directory);
- type Switches is array (Natural range <>) of String_Ptr;
- -- Type used for array of swtiches
+ if Name_Buffer (Name_Len) /= Directory_Separator then
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Directory_Separator;
+ end if;
- type Switches_Ptr is access constant Switches;
+ 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;
--------------------------------
- -- Switches for project files --
+ -- Configuration_Pragmas_File --
--------------------------------
- S_Ext_Ref : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' &
- "-X" & '"';
-
- S_Project_File : aliased constant S := "/PROJECT_FILE=*" &
- "-P*";
- S_Project_Verb : aliased constant S := "/PROJECT_FILE_VERBOSITY=" &
- "DEFAULT " &
- "-vP0 " &
- "MEDIUM " &
- "-vP1 " &
- "HIGH " &
- "-vP2";
-
- ----------------------------
- -- Switches for GNAT BIND --
- ----------------------------
-
- S_Bind_Bind : aliased constant S := "/BIND_FILE=" &
- "ADA " &
- "-A " &
- "C " &
- "-C";
-
- S_Bind_Build : aliased constant S := "/BUILD_LIBRARY=|" &
- "-L|";
-
- S_Bind_Current : aliased constant S := "/CURRENT_DIRECTORY " &
- "!-I-";
-
- S_Bind_Debug : aliased constant S := "/DEBUG=" &
- "TRACEBACK " &
- "-g2 " &
- "ALL " &
- "-g3 " &
- "NONE " &
- "-g0 " &
- "SYMBOLS " &
- "-g1 " &
- "NOSYMBOLS " &
- "!-g1 " &
- "LINK " &
- "-g3 " &
- "NOTRACEBACK " &
- "!-g2";
-
- S_Bind_DebugX : aliased constant S := "/NODEBUG " &
- "!-g";
-
- S_Bind_Elab : aliased constant S := "/ELABORATION_DEPENDENCIES " &
- "-e";
-
- S_Bind_Error : aliased constant S := "/ERROR_LIMIT=#" &
- "-m#";
-
- S_Bind_Library : aliased constant S := "/LIBRARY_SEARCH=*" &
- "-aO*";
-
- S_Bind_Linker : aliased constant S := "/LINKER_OPTION_LIST " &
- "-K";
-
- S_Bind_Main : aliased constant S := "/MAIN " &
- "!-n";
-
- S_Bind_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
- "-nostdinc";
-
- S_Bind_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
- "-nostdlib";
-
- S_Bind_Object : aliased constant S := "/OBJECT_LIST " &
- "-O";
-
- S_Bind_Order : aliased constant S := "/ORDER_OF_ELABORATION " &
- "-l";
-
- S_Bind_Output : aliased constant S := "/OUTPUT=@" &
- "-o@";
-
- S_Bind_OutputX : aliased constant S := "/NOOUTPUT " &
- "-c";
-
- S_Bind_Pess : aliased constant S := "/PESSIMISTIC_ELABORATION " &
- "-p";
-
- S_Bind_Read : aliased constant S := "/READ_SOURCES=" &
- "ALL " &
- "-s " &
- "NONE " &
- "-x " &
- "AVAILABLE " &
- "!-x,!-s";
-
- S_Bind_ReadX : aliased constant S := "/NOREAD_SOURCES " &
- "-x";
-
- S_Bind_Rename : aliased constant S := "/RENAME_MAIN " &
- "-r";
-
- S_Bind_Report : aliased constant S := "/REPORT_ERRORS=" &
- "VERBOSE " &
- "-v " &
- "BRIEF " &
- "-b " &
- "DEFAULT " &
- "!-b,!-v";
-
- S_Bind_ReportX : aliased constant S := "/NOREPORT_ERRORS " &
- "!-b,!-v";
-
- S_Bind_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
-
- S_Bind_Shared : aliased constant S := "/SHARED " &
- "-shared";
-
- S_Bind_Source : aliased constant S := "/SOURCE_SEARCH=*" &
- "-aI*";
-
- S_Bind_Time : aliased constant S := "/TIME_STAMP_CHECK " &
- "!-t";
-
- S_Bind_Verbose : aliased constant S := "/VERBOSE " &
- "-v";
-
- S_Bind_Warn : aliased constant S := "/WARNINGS=" &
- "NORMAL " &
- "!-ws,!-we " &
- "SUPPRESS " &
- "-ws " &
- "ERROR " &
- "-we";
-
- S_Bind_WarnX : aliased constant S := "/NOWARNINGS " &
- "-ws";
-
- Bind_Switches : aliased constant Switches := (
- S_Bind_Bind 'Access,
- S_Bind_Build 'Access,
- S_Bind_Current 'Access,
- S_Bind_Debug 'Access,
- S_Bind_DebugX 'Access,
- S_Bind_Elab 'Access,
- S_Bind_Error 'Access,
- S_Ext_Ref 'Access,
- S_Bind_Library 'Access,
- S_Bind_Linker 'Access,
- S_Bind_Main 'Access,
- S_Bind_Nostinc 'Access,
- S_Bind_Nostlib 'Access,
- S_Bind_Object 'Access,
- S_Bind_Order 'Access,
- S_Bind_Output 'Access,
- S_Bind_OutputX 'Access,
- S_Bind_Pess 'Access,
- S_Project_File 'Access,
- S_Project_Verb 'Access,
- S_Bind_Read 'Access,
- S_Bind_ReadX 'Access,
- S_Bind_Rename 'Access,
- S_Bind_Report 'Access,
- S_Bind_ReportX 'Access,
- S_Bind_Search 'Access,
- S_Bind_Shared 'Access,
- S_Bind_Source 'Access,
- S_Bind_Time 'Access,
- S_Bind_Verbose 'Access,
- S_Bind_Warn 'Access,
- S_Bind_WarnX 'Access);
-
- ----------------------------
- -- Switches for GNAT CHOP --
- ----------------------------
-
- S_Chop_Comp : aliased constant S := "/COMPILATION " &
- "-c";
-
- S_Chop_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" &
- "-k#";
-
- S_Chop_Help : aliased constant S := "/HELP " &
- "-h";
-
- S_Chop_Over : aliased constant S := "/OVERWRITE " &
- "-w";
-
- S_Chop_Pres : aliased constant S := "/PRESERVE " &
- "-p";
-
- S_Chop_Quiet : aliased constant S := "/QUIET " &
- "-q";
-
- S_Chop_Ref : aliased constant S := "/REFERENCE " &
- "-r";
-
- S_Chop_Verb : aliased constant S := "/VERBOSE " &
- "-v";
-
- Chop_Switches : aliased constant Switches := (
- S_Chop_Comp 'Access,
- S_Chop_File 'Access,
- S_Chop_Help 'Access,
- S_Chop_Over 'Access,
- S_Chop_Pres 'Access,
- S_Chop_Quiet 'Access,
- S_Chop_Ref 'Access,
- S_Chop_Verb 'Access);
-
- -------------------------------
- -- Switches for GNAT COMPILE --
- -------------------------------
-
- S_GCC_Ada_83 : aliased constant S := "/83 " &
- "-gnat83";
-
- S_GCC_Ada_95 : aliased constant S := "/95 " &
- "!-gnat83";
-
- S_GCC_Asm : aliased constant S := "/ASM " &
- "-S,!-c";
-
- S_GCC_Checks : aliased constant S := "/CHECKS=" &
- "FULL " &
- "-gnato,!-gnatE,!-gnatp " &
- "OVERFLOW " &
- "-gnato " &
- "ELABORATION " &
- "-gnatE " &
- "ASSERTIONS " &
- "-gnata " &
- "DEFAULT " &
- "!-gnato,!-gnatp " &
- "SUPPRESS_ALL " &
- "-gnatp";
-
- S_GCC_ChecksX : aliased constant S := "/NOCHECKS " &
- "-gnatp,!-gnato,!-gnatE";
-
- S_GCC_Compres : aliased constant S := "/COMPRESS_NAMES " &
- "-gnatC";
-
- S_GCC_Current : aliased constant S := "/CURRENT_DIRECTORY " &
- "!-I-";
-
- S_GCC_Debug : aliased constant S := "/DEBUG=" &
- "SYMBOLS " &
- "-g2 " &
- "NOSYMBOLS " &
- "!-g2 " &
- "TRACEBACK " &
- "-g1 " &
- "ALL " &
- "-g3 " &
- "NONE " &
- "-g0 " &
- "NOTRACEBACK " &
- "-g0";
-
- S_GCC_DebugX : aliased constant S := "/NODEBUG " &
- "!-g";
-
- S_GCC_Dist : aliased constant S := "/DISTRIBUTION_STUBS=" &
- "RECEIVER " &
- "-gnatzr " &
- "CALLER " &
- "-gnatzc";
-
- S_GCC_DistX : aliased constant S := "/NODISTRIBUTION_STUBS " &
- "!-gnatzr,!-gnatzc";
-
- S_GCC_Error : aliased constant S := "/ERROR_LIMIT=#" &
- "-gnatm#";
-
- S_GCC_ErrorX : aliased constant S := "/NOERROR_LIMIT " &
- "-gnatm999";
-
- S_GCC_Expand : aliased constant S := "/EXPAND_SOURCE " &
- "-gnatG";
-
- S_GCC_Extend : aliased constant S := "/EXTENSIONS_ALLOWED " &
- "-gnatX";
-
- S_GCC_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" &
- "-gnatk#";
-
- S_GCC_Force : aliased constant S := "/FORCE_ALI " &
- "-gnatQ";
-
- S_GCC_Ident : aliased constant S := "/IDENTIFIER_CHARACTER_SET=" &
- "DEFAULT " &
- "-gnati1 " &
- "1 " &
- "-gnati1 " &
- "2 " &
- "-gnati2 " &
- "3 " &
- "-gnati3 " &
- "4 " &
- "-gnati4 " &
- "PC " &
- "-gnatip " &
- "PC850 " &
- "-gnati8 " &
- "FULL_UPPER " &
- "-gnatif " &
- "NO_UPPER " &
- "-gnatin " &
- "WIDE " &
- "-gnatiw";
-
- S_GCC_IdentX : aliased constant S := "/NOIDENTIFIER_CHARACTER_SET " &
- "-gnati1";
-
- S_GCC_Inline : aliased constant S := "/INLINE=" &
- "PRAGMA " &
- "-gnatn " &
- "SUPPRESS " &
- "-fno-inline";
-
- S_GCC_InlineX : aliased constant S := "/NOINLINE " &
- "!-gnatn";
-
- S_GCC_List : aliased constant S := "/LIST " &
- "-gnatl";
-
- S_GCC_Noload : aliased constant S := "/NOLOAD " &
- "-gnatc";
-
- S_GCC_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
- "-nostdinc";
-
- S_GCC_Opt : aliased constant S := "/OPTIMIZE=" &
- "ALL " &
- "-O2,!-O0,!-O1,!-O3 " &
- "NONE " &
- "-O0,!-O1,!-O2,!-O3 " &
- "SOME " &
- "-O1,!-O0,!-O2,!-O3 " &
- "DEVELOPMENT " &
- "-O1,!-O0,!-O2,!-O3 " &
- "UNROLL_LOOPS " &
- "-funroll-loops " &
- "INLINING " &
- "-O3,!-O0,!-O1,!-O2";
-
- S_GCC_OptX : aliased constant S := "/NOOPTIMIZE " &
- "-O0,!-O1,!-O2,!-O3";
-
- S_GCC_Report : aliased constant S := "/REPORT_ERRORS=" &
- "VERBOSE " &
- "-gnatv " &
- "BRIEF " &
- "-gnatb " &
- "FULL " &
- "-gnatf " &
- "IMMEDIATE " &
- "-gnate " &
- "DEFAULT " &
- "!-gnatb,!-gnatv";
-
- S_GCC_ReportX : aliased constant S := "/NOREPORT_ERRORS " &
- "!-gnatb,!-gnatv";
-
- S_GCC_Repinfo : aliased constant S := "/REPRESENTATION_INFO=" &
- "ARRAYS " &
- "-gnatR1 " &
- "NONE " &
- "-gnatR0 " &
- "OBJECTS " &
- "-gnatR2 " &
- "SYMBOLIC " &
- "-gnatR3 " &
- "DEFAULT " &
- "-gnatR";
-
- S_GCC_RepinfX : aliased constant S := "/NOREPRESENTATION_INFO " &
- "!-gnatR";
-
- S_GCC_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
-
- S_GCC_Style : aliased constant S := "/STYLE_CHECKS=" &
- "ALL_BUILTIN " &
- "-gnaty " &
- "1 " &
- "-gnaty1 " &
- "2 " &
- "-gnaty2 " &
- "3 " &
- "-gnaty3 " &
- "4 " &
- "-gnaty4 " &
- "5 " &
- "-gnaty5 " &
- "6 " &
- "-gnaty6 " &
- "7 " &
- "-gnaty7 " &
- "8 " &
- "-gnaty8 " &
- "9 " &
- "-gnaty9 " &
- "ATTRIBUTE " &
- "-gnatya " &
- "BLANKS " &
- "-gnatyb " &
- "COMMENTS " &
- "-gnatyc " &
- "END " &
- "-gnatye " &
- "VTABS " &
- "-gnatyf " &
- "GNAT " &
- "-gnatg " &
- "HTABS " &
- "-gnatyh " &
- "IF_THEN " &
- "-gnatyi " &
- "KEYWORD " &
- "-gnatyk " &
- "LAYOUT " &
- "-gnatyl " &
- "LINE_LENGTH " &
- "-gnatym " &
- "STANDARD_CASING " &
- "-gnatyn " &
- "ORDERED_SUBPROGRAMS " &
- "-gnatyo " &
- "NONE " &
- "!-gnatg,!-gnatr " &
- "PRAGMA " &
- "-gnatyp " &
- "REFERENCES " &
- "-gnatr " &
- "SPECS " &
- "-gnatys " &
- "TOKEN " &
- "-gnatyt ";
-
- S_GCC_StyleX : aliased constant S := "/NOSTYLE_CHECKS " &
- "!-gnatg,!-gnatr";
-
- S_GCC_Syntax : aliased constant S := "/SYNTAX_ONLY " &
- "-gnats";
-
- S_GCC_Trace : aliased constant S := "/TRACE_UNITS " &
- "-gnatdc";
-
- S_GCC_Tree : aliased constant S := "/TREE_OUTPUT " &
- "-gnatt";
-
- S_GCC_Trys : aliased constant S := "/TRY_SEMANTICS " &
- "-gnatq";
-
- S_GCC_Units : aliased constant S := "/UNITS_LIST " &
- "-gnatu";
-
- S_GCC_Unique : aliased constant S := "/UNIQUE_ERROR_TAG " &
- "-gnatU";
-
- S_GCC_Upcase : aliased constant S := "/UPPERCASE_EXTERNALS " &
- "-gnatF";
-
- S_GCC_Valid : aliased constant S := "/VALIDITY_CHECKING=" &
- "DEFAULT " &
- "-gnatVd " &
- "NODEFAULT " &
- "-gnatVD " &
- "COPIES " &
- "-gnatVc " &
- "NOCOPIES " &
- "-gnatVC " &
- "FLOATS " &
- "-gnatVf " &
- "NOFLOATS " &
- "-gnatVF " &
- "IN_PARAMS " &
- "-gnatVi " &
- "NOIN_PARAMS " &
- "-gnatVI " &
- "MOD_PARAMS " &
- "-gnatVm " &
- "NOMOD_PARAMS " &
- "-gnatVM " &
- "OPERANDS " &
- "-gnatVo " &
- "NOOPERANDS " &
- "-gnatVO " &
- "RETURNS " &
- "-gnatVr " &
- "NORETURNS " &
- "-gnatVR " &
- "SUBSCRIPTS " &
- "-gnatVs " &
- "NOSUBSCRIPTS " &
- "-gnatVS " &
- "TESTS " &
- "-gnatVt " &
- "NOTESTS " &
- "-gnatVT " &
- "ALL " &
- "-gnatVa " &
- "NONE " &
- "-gnatVn";
-
- S_GCC_Verbose : aliased constant S := "/VERBOSE " &
- "-v";
-
- S_GCC_Warn : aliased constant S := "/WARNINGS=" &
- "DEFAULT " &
- "!-gnatws,!-gnatwe " &
- "ALL_GCC " &
- "-Wall " &
- "CONDITIONALS " &
- "-gnatwc " &
- "NOCONDITIONALS " &
- "-gnatwC " &
- "ELABORATION " &
- "-gnatwl " &
- "NOELABORATION " &
- "-gnatwL " &
- "ERRORS " &
- "-gnatwe " &
- "HIDING " &
- "-gnatwh " &
- "NOHIDING " &
- "-gnatwH " &
- "IMPLEMENTATION " &
- "-gnatwi " &
- "NOIMPLEMENTATION " &
- "-gnatwI " &
- "OPTIONAL " &
- "-gnatwa " &
- "NOOPTIONAL " &
- "-gnatwA " &
- "OVERLAYS " &
- "-gnatwo " &
- "NOOVERLAYS " &
- "-gnatwO " &
- "REDUNDANT " &
- "-gnatwr " &
- "NOREDUNDANT " &
- "-gnatwR " &
- "SUPPRESS " &
- "-gnatws " &
- "UNINITIALIZED " &
- "-Wuninitialized " &
- "UNUSED " &
- "-gnatwu " &
- "NOUNUSED " &
- "-gnatwU";
-
- S_GCC_WarnX : aliased constant S := "/NOWARNINGS " &
- "-gnatws";
-
- S_GCC_Wide : aliased constant S := "/WIDE_CHARACTER_ENCODING=" &
- "BRACKETS " &
- "-gnatWb " &
- "NONE " &
- "-gnatWn " &
- "HEX " &
- "-gnatWh " &
- "UPPER " &
- "-gnatWu " &
- "SHIFT_JIS " &
- "-gnatWs " &
- "UTF8 " &
- "-gnatW8 " &
- "EUC " &
- "-gnatWe";
-
- S_GCC_WideX : aliased constant S := "/NOWIDE_CHARACTER_ENCODING " &
- "-gnatWn";
-
- S_GCC_Xdebug : aliased constant S := "/XDEBUG " &
- "-gnatD";
-
- S_GCC_Xref : aliased constant S := "/XREF=" &
- "GENERATE " &
- "!-gnatx " &
- "SUPPRESS " &
- "-gnatx";
-
- GCC_Switches : aliased constant Switches := (
- S_GCC_Ada_83 'Access,
- S_GCC_Ada_95 'Access,
- S_GCC_Asm 'Access,
- S_GCC_Checks 'Access,
- S_GCC_ChecksX 'Access,
- S_GCC_Compres 'Access,
- S_GCC_Current 'Access,
- S_GCC_Debug 'Access,
- S_GCC_DebugX 'Access,
- S_GCC_Dist 'Access,
- S_GCC_DistX 'Access,
- S_GCC_Error 'Access,
- S_GCC_ErrorX 'Access,
- S_GCC_Expand 'Access,
- S_GCC_Extend 'Access,
- S_GCC_File 'Access,
- S_GCC_Force 'Access,
- S_GCC_Ident 'Access,
- S_GCC_IdentX 'Access,
- S_GCC_Inline 'Access,
- S_GCC_InlineX 'Access,
- S_GCC_List 'Access,
- S_GCC_Noload 'Access,
- S_GCC_Nostinc 'Access,
- S_GCC_Opt 'Access,
- S_GCC_OptX 'Access,
- S_GCC_Report 'Access,
- S_GCC_ReportX 'Access,
- S_GCC_Repinfo 'Access,
- S_GCC_RepinfX 'Access,
- S_GCC_Search 'Access,
- S_GCC_Style 'Access,
- S_GCC_StyleX 'Access,
- S_GCC_Syntax 'Access,
- S_GCC_Trace 'Access,
- S_GCC_Tree 'Access,
- S_GCC_Trys 'Access,
- S_GCC_Units 'Access,
- S_GCC_Unique 'Access,
- S_GCC_Upcase 'Access,
- S_GCC_Valid 'Access,
- S_GCC_Verbose 'Access,
- S_GCC_Warn 'Access,
- S_GCC_WarnX 'Access,
- S_GCC_Wide 'Access,
- S_GCC_WideX 'Access,
- S_GCC_Xdebug 'Access,
- S_GCC_Xref 'Access);
-
- ----------------------------
- -- Switches for GNAT ELIM --
- ----------------------------
-
- S_Elim_All : aliased constant S := "/ALL " &
- "-a";
-
- S_Elim_Miss : aliased constant S := "/MISSED " &
- "-m";
-
- S_Elim_Verb : aliased constant S := "/VERBOSE " &
- "-v";
-
- Elim_Switches : aliased constant Switches := (
- S_Elim_All 'Access,
- S_Elim_Miss 'Access,
- S_Elim_Verb 'Access);
-
- ----------------------------
- -- Switches for GNAT FIND --
- ----------------------------
-
- S_Find_All : aliased constant S := "/ALL_FILES " &
- "-a";
-
- S_Find_Expr : aliased constant S := "/EXPRESSIONS " &
- "-e";
-
- S_Find_Full : aliased constant S := "/FULL_PATHNAME " &
- "-f";
-
- S_Find_Ignore : aliased constant S := "/IGNORE_LOCALS " &
- "-g";
-
- S_Find_Object : aliased constant S := "/OBJECT_SEARCH=*" &
- "-aO*";
-
- S_Find_Print : aliased constant S := "/PRINT_LINES " &
- "-s";
-
- S_Find_Project : aliased constant S := "/PROJECT=@" &
- "-p@";
-
- S_Find_Ref : aliased constant S := "/REFERENCES " &
- "-r";
-
- S_Find_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
-
- S_Find_Source : aliased constant S := "/SOURCE_SEARCH=*" &
- "-aI*";
-
- Find_Switches : aliased constant Switches := (
- S_Find_All 'Access,
- S_Find_Expr 'Access,
- S_Ext_Ref 'Access,
- S_Find_Full 'Access,
- S_Find_Ignore 'Access,
- S_Find_Object 'Access,
- S_Find_Print 'Access,
- S_Find_Project 'Access,
- S_Project_File 'Access,
- S_Project_Verb 'Access,
- S_Find_Ref 'Access,
- S_Find_Search 'Access,
- S_Find_Source 'Access);
+ function Configuration_Pragmas_File return Name_Id is
+ begin
+ Prj.Env.Create_Config_Pragmas_File
+ (Project, Project, Include_Config_Files => False);
+ return Projects.Table (Project).Config_File_Name;
+ end Configuration_Pragmas_File;
------------------------------
- -- Switches for GNAT KRUNCH --
+ -- Delete_Temp_Config_Files --
------------------------------
- S_Krunch_Count : aliased constant S := "/COUNT=#" &
- "`#";
+ procedure Delete_Temp_Config_Files is
+ Success : Boolean;
- Krunch_Switches : aliased constant Switches := (1 .. 1 =>
- S_Krunch_Count 'Access);
+ begin
+ 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;
- -------------------------------
- -- Switches for GNAT LIBRARY --
- -------------------------------
+ Delete_File
+ (Name => Get_Name_String
+ (Projects.Table (Prj).Config_File_Name),
+ Success => Success);
+ end if;
+ end loop;
+ end if;
+ end Delete_Temp_Config_Files;
- S_Lbr_Config : aliased constant S := "/CONFIG=@" &
- "--config=@";
-
- S_Lbr_Create : aliased constant S := "/CREATE=%" &
- "--create=%";
-
- S_Lbr_Delete : aliased constant S := "/DELETE=%" &
- "--delete=%";
-
- S_Lbr_Set : aliased constant S := "/SET=%" &
- "--set=%";
-
- Lbr_Switches : aliased constant Switches := (
- S_Lbr_Config 'Access,
- S_Lbr_Create 'Access,
- S_Lbr_Delete 'Access,
- S_Lbr_Set 'Access);
-
- ----------------------------
- -- Switches for GNAT LINK --
- ----------------------------
-
- S_Link_Bind : aliased constant S := "/BIND_FILE=" &
- "ADA " &
- "-A " &
- "C " &
- "-C";
-
- S_Link_Debug : aliased constant S := "/DEBUG=" &
- "ALL " &
- "-g3 " &
- "NONE " &
- "-g0 " &
- "TRACEBACK " &
- "-g1 " &
- "NOTRACEBACK " &
- "-g0";
-
- S_Link_Execut : aliased constant S := "/EXECUTABLE=@" &
- "-o@";
-
- S_Link_Ident : aliased constant S := "/IDENTIFICATION=" & '"' &
- "--for-linker=IDENT=" &
- '"';
-
- S_Link_Nocomp : aliased constant S := "/NOCOMPILE " &
- "-n";
-
- S_Link_Nofiles : aliased constant S := "/NOSTART_FILES " &
- "-nostartfiles";
-
- S_Link_Noinhib : aliased constant S := "/NOINHIBIT-EXEC " &
- "--for-linker=--noinhibit-exec";
-
- S_Link_Static : aliased constant S := "/STATIC " &
- "--for-linker=-static";
-
- S_Link_Verb : aliased constant S := "/VERBOSE " &
- "-v";
-
- S_Link_ZZZZZ : aliased constant S := "/<other> " &
- "--for-linker=";
-
- Link_Switches : aliased constant Switches := (
- S_Link_Bind 'Access,
- S_Link_Debug 'Access,
- S_Link_Execut 'Access,
- S_Ext_Ref 'Access,
- S_Link_Ident 'Access,
- S_Link_Nocomp 'Access,
- S_Link_Nofiles 'Access,
- S_Link_Noinhib 'Access,
- S_Project_File 'Access,
- S_Project_Verb 'Access,
- S_Link_Static 'Access,
- S_Link_Verb 'Access,
- S_Link_ZZZZZ 'Access);
+ -----------
+ -- 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;
- ----------------------------
- -- Switches for GNAT LIST --
- ----------------------------
+ return 0;
+ end Index;
- S_List_All : aliased constant S := "/ALL_UNITS " &
- "-a";
+ ---------------------
+ -- Set_Library_For --
+ ---------------------
- S_List_Current : aliased constant S := "/CURRENT_DIRECTORY " &
- "!-I-";
+ procedure Set_Library_For
+ (Project : Project_Id;
+ There_Are_Libraries : in out Boolean)
+ is
+ Path_Option : constant String_Access :=
+ MLib.Tgt.Linker_Library_Path_Option;
- S_List_Depend : aliased constant S := "/DEPENDENCIES " &
- "-d";
+ begin
+ -- Case of library project
- S_List_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
- "-nostdinc";
+ if Projects.Table (Project).Library then
+ There_Are_Libraries := True;
- S_List_Object : aliased constant S := "/OBJECT_SEARCH=*" &
- "-aO*";
+ -- Add the -L switch
- S_List_Output : aliased constant S := "/OUTPUT=" &
- "SOURCES " &
- "-s " &
- "OBJECTS " &
- "-o " &
- "UNITS " &
- "-u " &
- "OPTIONS " &
- "-h " &
- "VERBOSE " &
- "-v ";
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'("-L" &
+ Get_Name_String
+ (Projects.Table (Project).Library_Dir));
- S_List_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
+ -- Add the -l switch
- S_List_Source : aliased constant S := "/SOURCE_SEARCH=*" &
- "-aI*";
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'("-l" &
+ Get_Name_String
+ (Projects.Table (Project).Library_Name));
- List_Switches : aliased constant Switches := (
- S_List_All 'Access,
- S_List_Current 'Access,
- S_List_Depend 'Access,
- S_Ext_Ref 'Access,
- S_List_Nostinc 'Access,
- S_List_Object 'Access,
- S_List_Output 'Access,
- S_Project_File 'Access,
- S_Project_Verb 'Access,
- S_List_Search 'Access,
- S_List_Source 'Access);
+ -- Add the directory to table Library_Paths, to be processed later
+ -- if library is not static and if Path_Option is not null.
- ----------------------------
- -- Switches for GNAT MAKE --
- ----------------------------
+ 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;
- S_Make_All : aliased constant S := "/ALL_FILES " &
- "-a";
+ end if;
+ end Set_Library_For;
- S_Make_Bind_Only : aliased constant S := "/BIND_ONLY " &
- "-b";
+ ---------------------------
+ -- Test_If_Relative_Path --
+ ---------------------------
- S_Make_Bind : aliased constant S := "/BINDER_QUALIFIERS=?" &
- "-bargs BIND";
-
- S_Make_Compile_Only : aliased constant S := "/COMPILE_ONLY " &
- "-c";
-
- 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_Link_Only : aliased constant S := "/LINK_ONLY " &
- "-l";
-
- S_Make_Minimal : aliased constant S := "/MINIMAL_RECOMPILATION " &
- "-m";
-
- S_Make_Nolink : aliased constant S := "/NOLINK " &
- "-c";
-
- S_Make_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
- "-nostdinc";
-
- S_Make_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
- "-nostdlib";
-
- S_Make_Object : aliased constant S := "/OBJECT_SEARCH=*" &
- "-aO*";
-
- S_Make_Proc : aliased constant S := "/PROCESSES=#" &
- "-j#";
-
- S_Make_Nojobs : aliased constant S := "/NOPROCESSES " &
- "-j1";
-
- S_Make_Quiet : aliased constant S := "/QUIET " &
- "-q";
-
- S_Make_Reason : aliased constant S := "/REASONS " &
- "-v";
-
- S_Make_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
-
- S_Make_Skip : aliased constant S := "/SKIP_MISSING=*" &
- "-aL*";
-
- S_Make_Source : aliased constant S := "/SOURCE_SEARCH=*" &
- "-aI*";
-
- S_Make_Verbose : aliased constant S := "/VERBOSE " &
- "-v";
-
- Make_Switches : aliased constant Switches := (
- S_Make_All 'Access,
- S_Make_Bind 'Access,
- S_Make_Bind_Only'Access,
- S_Make_Comp 'Access,
- S_Make_Compile_Only'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_Link_Only'Access,
- S_Make_Minimal 'Access,
- S_Make_Nolink 'Access,
- S_Make_Nostinc 'Access,
- S_Make_Nostlib 'Access,
- S_Make_Object 'Access,
- S_Make_Proc 'Access,
- S_Project_File 'Access,
- S_Project_Verb 'Access,
- S_Make_Nojobs 'Access,
- S_Make_Quiet 'Access,
- S_Make_Reason 'Access,
- S_Make_Search 'Access,
- S_Make_Skip 'Access,
- S_Make_Source 'Access,
- S_Make_Verbose 'Access);
+ procedure Test_If_Relative_Path
+ (Switch : in out String_Access;
+ Parent : String)
+ is
+ begin
+ if Switch /= null then
- ----------------------------------
- -- Switches for GNAT PREPROCESS --
- ----------------------------------
+ declare
+ Sw : String (1 .. Switch'Length);
+ Start : Positive := 1;
- S_Prep_Blank : aliased constant S := "/BLANK_LINES " &
- "-b";
+ begin
+ Sw := Switch.all;
- S_Prep_Com : aliased constant S := "/COMMENTS " &
- "-c";
+ 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;
- S_Prep_Ref : aliased constant S := "/REFERENCE " &
- "-r";
+ if Sw = "-I-" then
+ return;
+ end if;
- S_Prep_Remove : aliased constant S := "/REMOVE " &
- "!-b,!-c";
+ 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;
- S_Prep_Symbols : aliased constant S := "/SYMBOLS " &
- "-s";
+ elsif Sw'Length >= 7
+ and then Sw (2 .. 6) = "-RTS="
+ then
+ Start := 7;
+ else
+ return;
+ end if;
+ end if;
- S_Prep_Undef : aliased constant S := "/UNDEFINED " &
- "-u";
+ -- 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;
- S_Prep_Verbose : aliased constant S := "/VERBOSE " &
- "-v";
+ -------------------
+ -- Non_VMS_Usage --
+ -------------------
- S_Prep_Version : aliased constant S := "/VERSION " &
- "-v";
+ procedure Non_VMS_Usage is
+ begin
+ Output_Version;
+ New_Line;
+ Put_Line ("List of available commands");
+ New_Line;
- Prep_Switches : aliased constant Switches := (
- S_Prep_Blank 'Access,
- S_Prep_Com 'Access,
- S_Prep_Ref 'Access,
- S_Prep_Remove 'Access,
- S_Prep_Symbols 'Access,
- S_Prep_Undef 'Access,
- S_Prep_Verbose 'Access,
- S_Prep_Version 'Access);
+ for C in Command_List'Range loop
+ if not Command_List (C).VMS_Only then
+ Put ("GNAT " & Command_List (C).Cname.all);
+ Set_Col (25);
+ Put (Command_List (C).Unixcmd.all);
- ------------------------------
- -- Switches for GNAT SHARED --
- ------------------------------
+ declare
+ Sws : Argument_List_Access renames Command_List (C).Unixsws;
+ begin
+ if Sws /= null then
+ for J in Sws'Range loop
+ Put (' ');
+ Put (Sws (J).all);
+ end loop;
+ end if;
+ end;
- S_Shared_Debug : aliased constant S := "/DEBUG=" &
- "ALL " &
- "-g3 " &
- "NONE " &
- "-g0 " &
- "TRACEBACK " &
- "-g1 " &
- "NOTRACEBACK " &
- "-g0";
+ New_Line;
+ end if;
+ end loop;
- S_Shared_Image : aliased constant S := "/IMAGE=@" &
- "-o@";
+ New_Line;
+ Put_Line ("Commands FIND, LIST, PRETTY, STUB and XREF accept " &
+ "project file switches -vPx, -Pprj and -Xnam=val");
+ New_Line;
+ end Non_VMS_Usage;
- S_Shared_Ident : aliased constant S := "/IDENTIFICATION=" & '"' &
- "--for-linker=IDENT=" &
- '"';
+ -------------------------------------
+ -- Start of processing for GNATCmd --
+ -------------------------------------
- S_Shared_Nofiles : aliased constant S := "/NOSTART_FILES " &
- "-nostartfiles";
+begin
+ -- Initializations
- S_Shared_Noinhib : aliased constant S := "/NOINHIBIT-IMAGE " &
- "--for-linker=--noinhibit-exec";
+ Namet.Initialize;
+ Csets.Initialize;
- S_Shared_Verb : aliased constant S := "/VERBOSE " &
- "-v";
+ Snames.Initialize;
- S_Shared_ZZZZZ : aliased constant S := "/<other> " &
- "--for-linker=";
+ Prj.Initialize;
- 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);
+ Last_Switches.Init;
+ Last_Switches.Set_Last (0);
- --------------------------------
- -- Switches for GNAT STANDARD --
- --------------------------------
+ First_Switches.Init;
+ First_Switches.Set_Last (0);
- Standard_Switches : aliased constant Switches := (1 .. 0 => null);
+ VMS_Conv.Initialize;
- ----------------------------
- -- Switches for GNAT STUB --
- ----------------------------
+ -- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers,
+ -- filenames and pathnames to Unix style.
- S_Stub_Current : aliased constant S := "/CURRENT_DIRECTORY " &
- "!-I-";
+ if Hostparm.OpenVMS
+ or else To_Lower (Getenv ("EMULATE_VMS").all) = "true"
+ then
+ VMS_Conversion (The_Command);
- S_Stub_Full : aliased constant S := "/FULL " &
- "-f";
+ -- If not on VMS, scan the command line directly
- S_Stub_Header : aliased constant S := "/HEADER=" &
- "GENERAL " &
- "-hg " &
- "SPEC " &
- "-hs";
+ else
+ if Argument_Count = 0 then
+ Non_VMS_Usage;
+ return;
+ else
+ begin
+ if Argument_Count > 1 and then Argument (1) = "-v" then
+ Opt.Verbose_Mode := True;
+ Command_Arg := 2;
+ end if;
- S_Stub_Indent : aliased constant S := "/INDENTATION=#" &
- "-i#";
+ The_Command := Real_Command_Type'Value (Argument (Command_Arg));
- S_Stub_Length : aliased constant S := "/LINE_LENGTH=#" &
- "-l#";
+ if Command_List (The_Command).VMS_Only then
+ Non_VMS_Usage;
+ Fail
+ ("Command """,
+ Command_List (The_Command).Cname.all,
+ """ can only be used on VMS");
+ end if;
- S_Stub_Quiet : aliased constant S := "/QUIET " &
- "-q";
+ exception
+ when Constraint_Error =>
- S_Stub_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
+ -- Check if it is an alternate command
- S_Stub_Tree : aliased constant S := "/TREE_FILE=" &
- "OVERWRITE " &
- "-t " &
- "SAVE " &
- "-k " &
- "REUSE " &
- "-r";
+ declare
+ Alternate : Alternate_Command;
- S_Stub_Verbose : aliased constant S := "/VERBOSE " &
- "-v";
+ begin
+ Alternate := Alternate_Command'Value
+ (Argument (Command_Arg));
+ The_Command := Corresponding_To (Alternate);
- 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);
+ exception
+ when Constraint_Error =>
+ Non_VMS_Usage;
+ Fail ("Unknown command: ", Argument (Command_Arg));
+ end;
+ end;
- ------------------------------
- -- Switches for GNAT SYSTEM --
- ------------------------------
+ -- Get the arguments from the command line and from the eventual
+ -- argument file(s) specified on the command line.
- System_Switches : aliased constant Switches := (1 .. 0 => null);
+ for Arg in Command_Arg + 1 .. Argument_Count loop
+ declare
+ The_Arg : constant String := Argument (Arg);
- ----------------------------
- -- Switches for GNAT XREF --
- ----------------------------
+ begin
+ -- Check if an argument file is specified
- S_Xref_All : aliased constant S := "/ALL_FILES " &
- "-a";
+ if The_Arg (The_Arg'First) = '@' then
+ declare
+ Arg_File : Ada.Text_IO.File_Type;
+ Line : String (1 .. 256);
+ Last : Natural;
- S_Xref_Full : aliased constant S := "/FULL_PATHNAME " &
- "-f";
+ begin
+ -- Open the file and fail if the file cannot be found
- S_Xref_Global : aliased constant S := "/IGNORE_LOCALS " &
- "-g";
+ begin
+ Open
+ (Arg_File, In_File,
+ The_Arg (The_Arg'First + 1 .. The_Arg'Last));
+
+ exception
+ when others =>
+ Put
+ (Standard_Error, "Cannot open argument file """);
+ Put
+ (Standard_Error,
+ The_Arg (The_Arg'First + 1 .. The_Arg'Last));
+
+ Put_Line (Standard_Error, """");
+ raise Error_Exit;
+ end;
- S_Xref_Object : aliased constant S := "/OBJECT_SEARCH=*" &
- "-aO*";
+ -- Read line by line and put the content of each
+ -- non empty line in the Last_Switches table.
- S_Xref_Project : aliased constant S := "/PROJECT=@" &
- "-p@";
+ while not End_Of_File (Arg_File) loop
+ Get_Line (Arg_File, Line, Last);
- S_Xref_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
+ if Last /= 0 then
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'(Line (1 .. Last));
+ end if;
+ end loop;
- S_Xref_Source : aliased constant S := "/SOURCE_SEARCH=*" &
- "-aI*";
+ Close (Arg_File);
+ end;
- S_Xref_Output : aliased constant S := "/UNUSED " &
- "-u";
+ else
+ -- It is not an argument file; just put the argument in
+ -- the Last_Switches table.
- Xref_Switches : aliased constant Switches := (
- S_Xref_All 'Access,
- S_Ext_Ref 'Access,
- S_Xref_Full 'Access,
- S_Xref_Global 'Access,
- S_Xref_Object 'Access,
- S_Xref_Project 'Access,
- S_Project_File 'Access,
- S_Project_Verb 'Access,
- S_Xref_Search 'Access,
- S_Xref_Source 'Access,
- S_Xref_Output 'Access);
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'(The_Arg);
+ end if;
+ end;
+ end loop;
+ end if;
+ end if;
- -------------------
- -- COMMAND TABLE --
- -------------------
+ declare
+ Program : constant String :=
+ Program_Name (Command_List (The_Command).Unixcmd.all).all;
- -- The command table contains an entry for each command recognized by
- -- GNATCmd. The entries are represented by an array of records.
+ Exec_Path : String_Access;
- 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.
+ begin
+ -- Locate the executable for the command
- Optional_File,
- -- An optional file or directory parameter.
-
- Other_As_Is,
- -- A parameter that's passed through as is (not canonicalized)
-
- Unlimited_Files,
- -- An unlimited number of writespace separate file or directory
- -- parameters including wildcard specifications.
-
- Files_Or_Wildcard);
- -- A comma separated list of files and/or wildcard file specifications.
- -- A comma preceded by or followed by whitespace is considered as a
- -- single comma character w/o whitespace.
+ Exec_Path := Locate_Exec_On_Path (Program);
- type Parameter_Array is array (Natural range <>) of Parameter_Type;
- type Parameter_Ref is access all Parameter_Array;
-
- type Command_Entry is record
- Cname : String_Ptr;
- -- Command name for GNAT xxx command
+ if Exec_Path = null then
+ Put_Line (Standard_Error, "Couldn't locate " & Program);
+ raise Error_Exit;
+ end if;
- Usage : String_Ptr;
- -- A usage string, used for error messages
+ -- If there are switches for the executable, put them as first switches
- Unixcmd : String_Ptr;
- -- Corresponding Unix command
+ if Command_List (The_Command).Unixsws /= null then
+ for J in Command_List (The_Command).Unixsws'Range loop
+ First_Switches.Increment_Last;
+ First_Switches.Table (First_Switches.Last) :=
+ Command_List (The_Command).Unixsws (J);
+ end loop;
+ end if;
- Switches : Switches_Ptr;
- -- Pointer to array of switch strings
+ -- 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;
- 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.
+ -- Check that the switches are consistent.
+ -- Detect project file related switches.
- 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;
+ Inspect_Switches :
+ declare
+ Arg_Num : Positive := 1;
+ Argv : String_Access;
- -------------------------
- -- INTERNAL STRUCTURES --
- -------------------------
+ procedure Remove_Switch (Num : Positive);
+ -- Remove a project related switch from table Last_Switches
- -- 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.
+ -------------------
+ -- Remove_Switch --
+ -------------------
- -- Commands, command qualifers and options have a similar common format
- -- so that searching for matching names can be done in a common manner.
+ procedure Remove_Switch (Num : Positive) is
+ begin
+ Last_Switches.Table (Num .. Last_Switches.Last - 1) :=
+ Last_Switches.Table (Num + 1 .. Last_Switches.Last);
+ Last_Switches.Decrement_Last;
+ end Remove_Switch;
- type Item_Id is (Id_Command, Id_Switch, Id_Option);
+ -- Start of processing for Inspect_Switches
- type Translation_Type is
- (
- T_Direct,
- -- A qualifier with no options.
- -- Example: GNAT MAKE /VERBOSE
+ begin
+ while Arg_Num <= Last_Switches.Last loop
+ Argv := Last_Switches.Table (Arg_Num);
- T_Directories,
- -- A qualifier followed by a list of directories
- -- Example: GNAT COMPILE /SEARCH=([], [.FOO], [.BAR])
+ if Argv (Argv'First) = '-' then
+ if Argv'Length = 1 then
+ Fail
+ ("switch character cannot be followed by a blank");
+ end if;
- T_Directory,
- -- A qualifier followed by one directory
- -- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB]
+ -- The two style project files (-p and -P) cannot be used
+ -- together
- T_File,
- -- A quailifier followed by a filename
- -- Example: GNAT LINK /EXECUTABLE=FOO.EXE
+ if (The_Command = Find or else The_Command = Xref)
+ and then Argv (2) = 'p'
+ then
+ Old_Project_File_Used := True;
+ if Project_File /= null then
+ Fail ("-P and -p cannot be used together");
+ end if;
+ end if;
- T_Numeric,
- -- A qualifier followed by a numeric value.
- -- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39
+ -- -vPx Specify verbosity while parsing project files
- T_String,
- -- A qualifier followed by a quoted string. Only used by
- -- /IDENTIFICATION qualfier.
- -- Example: GNAT LINK /IDENTIFICATION="3.14a1 version"
+ if Argv'Length = 4
+ and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
+ then
+ case Argv (Argv'Last) is
+ when '0' =>
+ Current_Verbosity := Prj.Default;
+ when '1' =>
+ Current_Verbosity := Prj.Medium;
+ when '2' =>
+ Current_Verbosity := Prj.High;
+ when others =>
+ Fail ("Invalid switch: ", Argv.all);
+ end case;
- T_Options,
- -- A qualifier followed by a list of options.
- -- Example: GNAT COMPILE /REPRESENTATION_INFO=(ARRAYS,OBJECTS)
+ Remove_Switch (Arg_Num);
- 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
+ -- -Pproject_file Specify project file to be used
- 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
+ elsif Argv (Argv'First + 1) = 'P' then
- 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
- );
+ -- Only one -P switch can be used
- type Item (Id : Item_Id);
- type Item_Ptr is access all Item;
+ if Project_File /= null then
+ Fail
+ (Argv.all,
+ ": second project file forbidden (first is """,
+ Project_File.all & """)");
- type Item (Id : Item_Id) is record
- Name : String_Ptr;
- -- Name of the command, switch (with slash) or option
+ -- The two style project files (-p and -P) cannot be
+ -- used together.
- Next : Item_Ptr;
- -- Pointer to next item on list, always has the same Id value
+ elsif Old_Project_File_Used then
+ Fail ("-p and -P cannot be used together");
- Unix_String : String_Ptr;
- -- Corresponding Unix string. For a command, this is the unix command
- -- name and possible default switches. For a switch or option it is
- -- the unix switch string.
+ elsif Argv'Length = 2 then
- case Id is
+ -- There is space between -P and the project file
+ -- name. -P cannot be the last option.
- when Id_Command =>
+ if Arg_Num = Last_Switches.Last then
+ Fail ("project file name missing after -P");
- Switches : Item_Ptr;
- -- Pointer to list of switch items for the command, linked
- -- through the Next fields with null terminating the list.
+ else
+ Remove_Switch (Arg_Num);
+ Argv := Last_Switches.Table (Arg_Num);
- Usage : String_Ptr;
- -- Usage information, used only for errors and the default
- -- list of commands output.
+ -- After -P, there must be a project file name,
+ -- not another switch.
- Params : Parameter_Ref;
- -- Array of parameters
+ if Argv (Argv'First) = '-' then
+ Fail ("project file name missing after -P");
- 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.
+ else
+ Project_File := new String'(Argv.all);
+ end if;
+ end if;
- when Id_Switch =>
+ else
+ -- No space between -P and project file name
- 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.
+ Project_File :=
+ new String'(Argv (Argv'First + 2 .. Argv'Last));
+ end if;
- 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.
+ Remove_Switch (Arg_Num);
- when Id_Option =>
+ -- -Xexternal=value Specify an external reference to be
+ -- used in project files
- null;
- -- No special fields needed, since Name and Unix_String are
- -- sufficient to completely described an option.
+ elsif Argv'Length >= 5
+ and then Argv (Argv'First + 1) = 'X'
+ then
+ declare
+ Equal_Pos : constant Natural :=
+ Index ('=', Argv (Argv'First + 2 .. Argv'Last));
+ begin
+ if Equal_Pos >= Argv'First + 3 and then
+ Equal_Pos /= Argv'Last then
+ Add (External_Name =>
+ Argv (Argv'First + 2 .. Equal_Pos - 1),
+ Value => Argv (Equal_Pos + 1 .. Argv'Last));
+ else
+ Fail
+ (Argv.all,
+ " is not a valid external assignment.");
+ end if;
+ end;
- end case;
- end record;
+ Remove_Switch (Arg_Num);
- subtype Command_Item is Item (Id_Command);
- subtype Switch_Item is Item (Id_Switch);
- subtype Option_Item is Item (Id_Option);
+ else
+ Arg_Num := Arg_Num + 1;
+ end if;
- ----------------------------------
- -- Declarations for GNATCMD use --
- ----------------------------------
+ else
+ Arg_Num := Arg_Num + 1;
+ end if;
+ end loop;
+ end Inspect_Switches;
+ end if;
- 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.
+ -- If there is a project file specified, parse it, get the switches
+ -- for the tool and setup PATH environment variables.
- Last_Command : Item_Ptr;
- -- Pointer to last item in Commands list
+ if Project_File /= null then
+ Prj.Pars.Set_Verbosity (To => Current_Verbosity);
- Normal_Exit : exception;
- -- Raise this exception for normal program termination
+ Prj.Pars.Parse
+ (Project => Project,
+ Project_File_Name => Project_File.all,
+ Packages_To_Check => Packages_To_Check);
- Error_Exit : exception;
- -- Raise this exception if error detected
+ if Project = Prj.No_Project then
+ Fail ("""", Project_File.all, """ processing failed");
+ end if;
- Errors : Natural := 0;
- -- Count errors detected
+ -- 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.
- Command : Item_Ptr;
- -- Pointer to command item for current command
+ declare
+ Data : constant Prj.Project_Data :=
+ Prj.Projects.Table (Project);
- 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.
+ Pkg : constant Prj.Package_Id :=
+ Prj.Util.Value_Of
+ (Name => Tool_Package_Name,
+ In_Packages => Data.Decl.Packages);
- My_Exit_Status : Exit_Status := Success;
+ Element : Package_Element;
- 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");
+ Default_Switches_Array : Array_Element_Id;
- Param_Count : Natural := 0;
- -- Number of parameter arguments so far
+ The_Switches : Prj.Variable_Value;
+ Current : Prj.String_List_Id;
+ The_String : String_Element;
- Arg_Num : Natural;
- -- Argument number
+ begin
+ if Pkg /= No_Package then
+ Element := Packages.Table (Pkg);
- Display_Command : Boolean := False;
- -- Set true if /? switch causes display of generated command
+ -- Packages Gnatls has a single attribute Switches, that is
+ -- not an associative array.
- -----------------------
- -- Local Subprograms --
- -----------------------
+ if The_Command = List then
+ The_Switches :=
+ Prj.Util.Value_Of
+ (Variable_Name => Snames.Name_Switches,
+ In_Variables => Element.Decl.Attributes);
- function Init_Object_Dirs return String_Ptr;
-
- function Invert_Sense (S : String) return String_Ptr;
- -- Given a unix switch string S, computes the inverse (adding or
- -- removing ! characters as required), and returns a pointer to
- -- the allocated result on the heap.
-
- function Is_Extensionless (F : String) return Boolean;
- -- Returns true if the filename has no extension.
-
- function Match (S1, S2 : String) return Boolean;
- -- Determines whether S1 and S2 match. This is a case insensitive match.
-
- function Match_Prefix (S1, S2 : String) return Boolean;
- -- Determines whether S1 matches a prefix of S2. This is also a case
- -- insensitive match (for example Match ("AB","abc") is True).
-
- function Matching_Name
- (S : String;
- Itm : Item_Ptr;
- Quiet : Boolean := False)
- return Item_Ptr;
- -- Determines if the item list headed by Itm and threaded through the
- -- Next fields (with null marking the end of the list), contains an
- -- entry that uniquely matches the given string. The match is case
- -- insensitive and permits unique abbreviation. If the match succeeds,
- -- then a pointer to the matching item is returned. Otherwise, an
- -- appropriate error message is written. Note that the discriminant
- -- of Itm is used to determine the appropriate form of this message.
- -- Quiet is normally False as shown, if it is set to True, then no
- -- error message is generated in a not found situation (null is still
- -- returned to indicate the not-found situation).
-
- function OK_Alphanumerplus (S : String) return Boolean;
- -- Checks that S is a string of alphanumeric characters,
- -- returning True if all alphanumeric characters,
- -- False if empty or a non-alphanumeric character is present.
-
- function OK_Integer (S : String) return Boolean;
- -- Checks that S is a string of digits, returning True if all digits,
- -- False if empty or a non-digit is present.
-
- procedure Place (C : Character);
- -- Place a single character in the buffer, updating Ptr
-
- procedure Place (S : String);
- -- Place a string character in the buffer, updating Ptr
-
- procedure Place_Lower (S : String);
- -- Place string in buffer, forcing letters to lower case, updating Ptr
-
- procedure Place_Unix_Switches (S : String_Ptr);
- -- Given a unix switch string, place corresponding switches in Buffer,
- -- updating Ptr appropriatelly. Note that in the case of use of ! the
- -- result may be to remove a previously placed switch.
-
- procedure Validate_Command_Or_Option (N : String_Ptr);
- -- Check that N is a valid command or option name, i.e. that it is of the
- -- form of an Ada identifier with upper case letters and underscores.
-
- procedure Validate_Unix_Switch (S : String_Ptr);
- -- Check that S is a valid switch string as described in the syntax for
- -- the switch table item UNIX_SWITCH or else begins with a backquote.
-
- ----------------------
- -- Init_Object_Dirs --
- ----------------------
-
- function Init_Object_Dirs return String_Ptr is
- Object_Dirs : Integer;
- Object_Dir : array (Integer range 1 .. 256) of String_Access;
- Object_Dir_Name : String_Access;
+ -- Packages Binder (for gnatbind), Cross_Reference (for
+ -- 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.
- begin
- Object_Dirs := 0;
- Object_Dir_Name := String_Access (Object_Dir_Default_Name);
- Get_Next_Dir_In_Path_Init (Object_Dir_Name);
+ -- They also have an attribute Default_Switches, indexed
+ -- by the name of the programming language.
- loop
- declare
- Dir : String_Access := String_Access
- (Get_Next_Dir_In_Path (Object_Dir_Name));
- begin
- exit when Dir = null;
- Object_Dirs := Object_Dirs + 1;
- Object_Dir (Object_Dirs)
- := String_Access (Normalize_Directory_Name (Dir.all));
- end;
- end loop;
+ 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;
- for Dirs in 1 .. Object_Dirs loop
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := '-';
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := 'L';
- Object_Dir_Name := new String'(
- To_Canonical_Dir_Spec
- (To_Host_Dir_Spec (Object_Dir (Dirs).all, True).all, True).all);
-
- for J in Object_Dir_Name'Range loop
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := Object_Dir_Name (J);
- end loop;
+ -- If there are switches specified in the package of the
+ -- project file corresponding to the tool, scan them.
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := ' ';
- end loop;
+ case The_Switches.Kind is
+ when Prj.Undefined =>
+ null;
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := '-';
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := 'l';
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := 'g';
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := 'n';
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := 'a';
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := 't';
-
- if Hostparm.OpenVMS then
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := ' ';
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := '-';
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := 'l';
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := 'd';
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := 'e';
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := 'c';
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := 'g';
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := 'n';
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := 'a';
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := 't';
- end if;
+ when Prj.Single =>
+ declare
+ Switch : constant String :=
+ Get_Name_String (The_Switches.Value);
- return new String'(String (Buffer.Table (1 .. Buffer.Last)));
- end Init_Object_Dirs;
+ begin
+ if Switch'Length > 0 then
+ First_Switches.Increment_Last;
+ First_Switches.Table (First_Switches.Last) :=
+ new String'(Switch);
+ end if;
+ end;
- ------------------
- -- Invert_Sense --
- ------------------
+ when Prj.List =>
+ Current := The_Switches.Values;
+ while Current /= Prj.Nil_String loop
+ The_String := String_Elements.Table (Current);
- function Invert_Sense (S : String) return String_Ptr is
- Sinv : String (1 .. S'Length * 2);
- -- Result (for sure long enough)
+ declare
+ Switch : constant String :=
+ Get_Name_String (The_String.Value);
- Sinvp : Natural := 0;
- -- Pointer to output string
+ begin
+ if Switch'Length > 0 then
+ First_Switches.Increment_Last;
+ First_Switches.Table (First_Switches.Last) :=
+ new String'(Switch);
+ end if;
+ end;
- 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;
+ Current := The_String.Next;
+ end loop;
+ end case;
end if;
+ end;
- else
- Sinv (Sinvp + 1) := S (Sp);
- Sinvp := Sinvp + 1;
+ 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;
- end loop;
- return new String'(Sinv (1 .. Sinvp));
- end Invert_Sense;
+ -- Set up the env vars for project path files
- ----------------------
- -- Is_Extensionless --
- ----------------------
-
- function Is_Extensionless (F : String) return Boolean is
- begin
- for J in reverse F'Range loop
- if F (J) = '.' then
- return False;
- elsif F (J) = '/' or else F (J) = ']' or else F (J) = ':' then
- return True;
- end if;
- end loop;
+ Prj.Env.Set_Ada_Paths (Project, Including_Libraries => False);
- return True;
- end Is_Extensionless;
+ -- For gnatstub, gnatpp and gnatelim, create a configuration pragmas
+ -- file, if necessary.
- -----------
- -- Match --
- -----------
+ if The_Command = Pretty
+ or else The_Command = Stub
+ or else The_Command = Elim
+ then
+ declare
+ CP_File : constant Name_Id := Configuration_Pragmas_File;
- function Match (S1, S2 : String) return Boolean is
- Dif : constant Integer := S2'First - S1'First;
+ begin
+ if CP_File /= No_Name then
+ First_Switches.Increment_Last;
- begin
+ if The_Command = Elim then
+ First_Switches.Table (First_Switches.Last) :=
+ new String'("-C" & Get_Name_String (CP_File));
- if S1'Length /= S2'Length then
- return False;
+ else
+ First_Switches.Table (First_Switches.Last) :=
+ new String'("-gnatec=" & Get_Name_String (CP_File));
+ end if;
+ end if;
+ end;
+ end if;
- else
- for J in S1'Range loop
- if To_Lower (S1 (J)) /= To_Lower (S2 (J + Dif)) then
- return False;
- end if;
- end loop;
+ if The_Command = Link then
- return True;
- end if;
- end Match;
+ -- Add the default search directories, to be able to find
+ -- libgnat in call to MLib.Utl.Lib_Directory.
- ------------------
- -- Match_Prefix --
- ------------------
+ Add_Default_Search_Dirs;
- 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;
+ declare
+ There_Are_Libraries : Boolean := False;
+ Path_Option : constant String_Access :=
+ MLib.Tgt.Linker_Library_Path_Option;
- -------------------
- -- Matching_Name --
- -------------------
+ begin
+ Library_Paths.Set_Last (0);
- function Matching_Name
- (S : String;
- Itm : Item_Ptr;
- Quiet : Boolean := False)
- return Item_Ptr
- is
- P1, P2 : Item_Ptr;
+ -- Check if there are library project files
- procedure Err;
- -- Little procedure to output command/qualifier/option as appropriate
- -- and bump error count.
+ if MLib.Tgt.Support_For_Libraries /= MLib.Tgt.None then
+ Set_Libraries (Project, There_Are_Libraries);
+ end if;
- procedure Err is
- begin
- if Quiet then
- return;
- end if;
+ -- If there are, add the necessary additional switches
- Errors := Errors + 1;
+ if There_Are_Libraries then
- if Itm /= null then
- case Itm.Id is
- when Id_Command =>
- Put (Standard_Error, "command");
+ -- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir>
- when Id_Switch =>
- if OpenVMS then
- Put (Standard_Error, "qualifier");
- else
- Put (Standard_Error, "switch");
- end if;
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'("-L" & MLib.Utl.Lib_Directory);
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'("-lgnarl");
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'("-lgnat");
- when Id_Option =>
- Put (Standard_Error, "option");
+ -- If Path_Option is not null, create the switch
+ -- ("-Wl,-rpath," or equivalent) with all the library dirs
+ -- plus the standard GNAT library dir.
- end case;
- else
- Put (Standard_Error, "input");
+ if Path_Option /= null then
+ declare
+ Option : String_Access;
+ Length : Natural := Path_Option'Length;
+ Current : Natural;
- end if;
+ begin
+ -- First, compute the exact length for the switch
- Put (Standard_Error, ": ");
- Put (Standard_Error, S);
+ for Index in
+ Library_Paths.First .. Library_Paths.Last
+ loop
+ -- Add the length of the library dir plus one
+ -- for the directory separator.
- end Err;
+ Length :=
+ Length +
+ Library_Paths.Table (Index)'Length + 1;
+ end loop;
- -- Start of processing for Matching_Name
+ -- 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;
- 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;
+ -- Finally put the standard GNAT library dir
- -- 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;
+ Option
+ (Current + 1 ..
+ Current + MLib.Utl.Lib_Directory'Length) :=
+ MLib.Utl.Lib_Directory;
- P2 := P2.Next;
- end loop;
+ -- And add the switch to the last switches
- Put_Line (Standard_Error, ")");
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ Option;
+ end;
end if;
-
- return null;
end if;
+ end;
- P2 := P2.Next;
- end loop;
-
- -- If we fall through that loop, then there was only one match
-
- return P1;
- end if;
- end loop;
+ -- 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.
- -- If we fall through outer loop, there was no match
+ declare
+ Skip_Executable : Boolean := False;
- if not Quiet then
- Put (Standard_Error, "unrecognized ");
- Err;
- New_Line (Standard_Error);
- end if;
+ begin
+ Switch_Loop : for J in 1 .. Last_Switches.Last loop
- return null;
- end Matching_Name;
+ -- If we have an executable just reset the flag
- -----------------------
- -- OK_Alphanumerplus --
- -----------------------
+ if Skip_Executable then
+ Skip_Executable := False;
- function OK_Alphanumerplus (S : String) return Boolean is
- begin
- if S'Length = 0 then
- return False;
+ -- If -o, set flag so that next switch is not processed
- 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;
+ elsif Last_Switches.Table (J).all = "-o" then
+ Skip_Executable := True;
- return True;
- end if;
- end OK_Alphanumerplus;
+ -- Normal case
- ----------------
- -- OK_Integer --
- ----------------
+ else
+ declare
+ Switch : constant String :=
+ Last_Switches.Table (J).all;
- function OK_Integer (S : String) return Boolean is
- begin
- if S'Length = 0 then
- return False;
+ ALI_File : constant String (1 .. Switch'Length + 4) :=
+ Switch & ".ali";
- else
- for J in S'Range loop
- if not Is_Digit (S (J)) then
- return False;
- end if;
- end loop;
+ Last : Natural := Switch'Length;
+ Test_Existence : Boolean := False;
- return True;
- end if;
- end OK_Integer;
+ begin
+ -- Skip real switches
- -----------
- -- Place --
- -----------
+ if Switch'Length /= 0 and then
+ Switch (Switch'First) /= '-'
+ then
+ -- Append ".ali" if file name does not end with it
- procedure Place (C : Character) is
- begin
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := C;
- end Place;
+ if Switch'Length <= 4 or else
+ Switch (Switch'Last - 3 .. Switch'Last) /= ".ali"
+ then
+ Last := ALI_File'Last;
+ end if;
- procedure Place (S : String) is
- begin
- for J in S'Range loop
- Place (S (J));
- end loop;
- end Place;
+ -- If file name includes directory information,
+ -- stop if ALI file exists.
- -----------------
- -- Place_Lower --
- -----------------
+ if Is_Absolute_Path (ALI_File (1 .. Last)) then
+ Test_Existence := True;
- procedure Place_Lower (S : String) is
- begin
- for J in S'Range loop
- Place (To_Lower (S (J)));
- end loop;
- end Place_Lower;
+ 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;
- -------------------------
- -- Place_Unix_Switches --
- -------------------------
+ if Test_Existence then
+ if Is_Regular_File (ALI_File (1 .. Last)) then
+ exit Switch_Loop;
+ end if;
- procedure Place_Unix_Switches (S : String_Ptr) is
- P1, P2, P3 : Natural;
- Remove : Boolean;
- Slen : Natural;
+ else
+ -- Look in the object directories if the ALI
+ -- file exists.
- begin
- P1 := S'First;
- while P1 <= S'Last loop
- if S (P1) = '!' then
- P1 := P1 + 1;
- Remove := True;
- else
- Remove := False;
- end if;
-
- P2 := P1;
- pragma Assert (S (P1) = '-' or else S (P1) = '`');
-
- while P2 < S'Last and then S (P2 + 1) /= ',' loop
- P2 := P2 + 1;
- end loop;
-
- -- Switch is now in S (P1 .. P2)
-
- Slen := P2 - P1 + 1;
-
- if Remove then
- P3 := 2;
- while P3 <= Buffer.Last - Slen loop
- if Buffer.Table (P3) = ' '
- and then String (Buffer.Table (P3 + 1 .. P3 + Slen))
- = S (P1 .. P2)
- and then (P3 + Slen = Buffer.Last
- or else
- Buffer.Table (P3 + Slen + 1) = ' ')
- then
- Buffer.Table (P3 .. Buffer.Last - Slen - 1) :=
- Buffer.Table (P3 + Slen + 1 .. Buffer.Last);
- Buffer.Set_Last (Buffer.Last - Slen - 1);
-
- else
- P3 := P3 + 1;
- end if;
- end loop;
-
- else
- Place (' ');
-
- if S (P1) = '`' then
- P1 := P1 + 1;
- end if;
-
- Place (S (P1 .. P2));
- end if;
-
- P1 := P2 + 2;
- end loop;
- end Place_Unix_Switches;
-
- --------------------------------
- -- Validate_Command_Or_Option --
- --------------------------------
-
- procedure Validate_Command_Or_Option (N : String_Ptr) is
- begin
- pragma Assert (N'Length > 0);
-
- for J in N'Range loop
- if N (J) = '_' then
- pragma Assert (N (J - 1) /= '_');
- null;
- else
- pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J)));
- null;
- end if;
- end loop;
- end Validate_Command_Or_Option;
-
- --------------------------
- -- Validate_Unix_Switch --
- --------------------------
-
- procedure Validate_Unix_Switch (S : String_Ptr) is
- begin
- if S (S'First) = '`' then
- return;
- end if;
-
- pragma Assert (S (S'First) = '-' or else S (S'First) = '!');
-
- for J in S'First + 1 .. S'Last loop
- pragma Assert (S (J) /= ' ');
-
- if S (J) = '!' then
- pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-');
- null;
- end if;
- end loop;
- end Validate_Unix_Switch;
-
- ----------------------
- -- List of Commands --
- ----------------------
-
- -- Note that we put this after all the local bodies to avoid
- -- some access before elaboration problems.
-
- Command_List : array (Natural range <>) of Command_Entry := (
-
- (Cname => new S'("BIND"),
- Usage => new S'("GNAT BIND file[.ali] /qualifiers"),
- Unixcmd => new S'("gnatbind"),
- Switches => Bind_Switches'Access,
- Params => new Parameter_Array'(1 => File),
- Defext => "ali"),
-
- (Cname => new S'("CHOP"),
- Usage => new S'("GNAT CHOP file [directory] /qualifiers"),
- Unixcmd => new S'("gnatchop"),
- Switches => Chop_Switches'Access,
- Params => new Parameter_Array'(1 => File, 2 => Optional_File),
- Defext => " "),
-
- (Cname => new S'("COMPILE"),
- Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"),
- Unixcmd => new S'("gcc -c -x ada"),
- Switches => GCC_Switches'Access,
- Params => new Parameter_Array'(1 => Files_Or_Wildcard),
- Defext => " "),
-
- (Cname => new S'("ELIM"),
- Usage => new S'("GNAT ELIM name /qualifiers"),
- Unixcmd => new S'("gnatelim"),
- Switches => Elim_Switches'Access,
- Params => new Parameter_Array'(1 => Other_As_Is),
- Defext => "ali"),
-
- (Cname => new S'("FIND"),
- Usage => new S'("GNAT FIND pattern[:sourcefile[:line[:column]]]" &
- " filespec[,...] /qualifiers"),
- Unixcmd => new S'("gnatfind"),
- Switches => Find_Switches'Access,
- Params => new Parameter_Array'(1 => Other_As_Is,
- 2 => Files_Or_Wildcard),
- Defext => "ali"),
-
- (Cname => new S'("KRUNCH"),
- Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"),
- Unixcmd => new S'("gnatkr"),
- Switches => Krunch_Switches'Access,
- Params => new Parameter_Array'(1 => File),
- Defext => " "),
-
- (Cname => new S'("LIBRARY"),
- Usage => new S'("GNAT LIBRARY /[CREATE | SET | DELETE]=directory"
- & " [/CONFIG=file]"),
- Unixcmd => new S'("gnatlbr"),
- Switches => Lbr_Switches'Access,
- Params => new Parameter_Array'(1 .. 0 => File),
- Defext => " "),
-
- (Cname => new S'("LINK"),
- Usage => new S'("GNAT LINK file[.ali]"
- & " [extra obj_&_lib_&_exe_&_opt files]"
- & " /qualifiers"),
- Unixcmd => new S'("gnatlink"),
- Switches => Link_Switches'Access,
- Params => new Parameter_Array'(1 => Unlimited_Files),
- Defext => "ali"),
-
- (Cname => new S'("LIST"),
- Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"),
- Unixcmd => new S'("gnatls"),
- Switches => List_Switches'Access,
- Params => new Parameter_Array'(1 => File),
- Defext => "ali"),
-
- (Cname => new S'("MAKE"),
- Usage =>
- new S'("GNAT MAKE file /qualifiers (includes COMPILE /qualifiers)"),
- Unixcmd => new S'("gnatmake"),
- Switches => Make_Switches'Access,
- Params => new Parameter_Array'(1 => File),
- Defext => " "),
-
- (Cname => new S'("PREPROCESS"),
- Usage => new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"),
- Unixcmd => new S'("gnatprep"),
- Switches => Prep_Switches'Access,
- Params => new Parameter_Array'(1 .. 3 => File),
- Defext => " "),
-
- (Cname => new S'("SHARED"),
- Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt files]"
- & " /qualifiers"),
- Unixcmd => new S'("gcc -shared " & Init_Object_Dirs.all),
- Switches => Shared_Switches'Access,
- Params => new Parameter_Array'(1 => Unlimited_Files),
- Defext => " "),
-
- (Cname => new S'("STANDARD"),
- Usage => new S'("GNAT STANDARD"),
- Unixcmd => new S'("gnatpsta"),
- Switches => Standard_Switches'Access,
- Params => new Parameter_Array'(1 .. 0 => File),
- Defext => " "),
-
- (Cname => new S'("STUB"),
- Usage => new S'("GNAT STUB file [directory] /qualifiers"),
- Unixcmd => new S'("gnatstub"),
- Switches => Stub_Switches'Access,
- Params => new Parameter_Array'(1 => File, 2 => Optional_File),
- Defext => " "),
-
- (Cname => new S'("SYSTEM"),
- Usage => new S'("GNAT SYSTEM"),
- Unixcmd => new S'("gnatpsys"),
- Switches => System_Switches'Access,
- Params => new Parameter_Array'(1 .. 0 => File),
- Defext => " "),
-
- (Cname => new S'("XREF"),
- Usage => new S'("GNAT XREF filespec[,...] /qualifiers"),
- Unixcmd => new S'("gnatxref"),
- Switches => Xref_Switches'Access,
- Params => new Parameter_Array'(1 => Files_Or_Wildcard),
- Defext => "ali")
- );
-
--------------------------------------
--- Start of processing for GNATCmd --
--------------------------------------
-
-begin
- Buffer.Init;
-
- -- First we must preprocess the string form of the command and options
- -- list into the internal form that we use.
-
- for C in Command_List'Range loop
-
- declare
- Command : Item_Ptr := new Command_Item;
-
- Last_Switch : Item_Ptr;
- -- Last switch in list
-
- begin
- -- Link new command item into list of commands
+ 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.
- if Last_Command = null then
- Commands := Command;
- else
- Last_Command.Next := Command;
- end if;
+ Last_Switches.Table (J) :=
+ new String'
+ (Dir & Directory_Separator &
+ ALI_File (1 .. Last));
- Last_Command := Command;
+ -- And we are done
- -- Fill in fields of new command item
+ exit Switch_Loop;
+ end if;
+ end;
- Command.Name := Command_List (C).Cname;
- Command.Usage := Command_List (C).Usage;
- Command.Unix_String := Command_List (C).Unixcmd;
- Command.Params := Command_List (C).Params;
- Command.Defext := Command_List (C).Defext;
+ -- Go to the project being extended,
+ -- if any.
- Validate_Command_Or_Option (Command.Name);
+ 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;
- -- Process the switch list
+ -- If a relative path output file has been specified, we add
+ -- the exec directory.
- 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
+ Look_For_Executable : Boolean := True;
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);
+ 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;
- -- Directories translation case
-
- elsif SS (P + 1) = '*' then
- pragma Assert (SS (SS'Last) = '*');
- Sw.Translation := T_Directories;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- Directory translation case
-
- elsif SS (P + 1) = '%' then
- pragma Assert (SS (SS'Last) = '%');
- Sw.Translation := T_Directory;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- File translation case
-
- elsif SS (P + 1) = '@' then
- pragma Assert (SS (SS'Last) = '@');
- Sw.Translation := T_File;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- Numeric translation case
-
- elsif SS (P + 1) = '#' then
- pragma Assert (SS (SS'Last) = '#');
- Sw.Translation := T_Numeric;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- Alphanumerplus translation case
-
- elsif SS (P + 1) = '|' then
- pragma Assert (SS (SS'Last) = '|');
- Sw.Translation := T_Alphanumplus;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- String translation case
-
- elsif SS (P + 1) = '"' then
- pragma Assert (SS (SS'Last) = '"');
- Sw.Translation := T_String;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- Commands translation case
-
- elsif SS (P + 1) = '?' then
- Sw.Translation := T_Commands;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last));
-
- -- Options translation case
+ 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;
- else
- Sw.Translation := T_Options;
- Sw.Unix_String := new String'("");
+ -- 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.
- P := P + 1; -- bump past =
- while P <= SS'Last loop
+ if Look_For_Executable then
+ for J in 1 .. Last_Switches.Last loop
declare
- Opt : Item_Ptr := new Option_Item;
- Q : Natural;
+ Arg : constant String_Access :=
+ Last_Switches.Table (J);
+ Last : Natural := 0;
begin
- -- Link new option item into options list
-
- if Last_Opt = null then
- Sw.Options := Opt;
- else
- Last_Opt.Next := Opt;
+ 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;
-
- Last_Opt := Opt;
-
- -- Fill in fields of new option item
-
- Q := P;
- while SS (Q) /= ' ' loop
- Q := Q + 1;
- end loop;
-
- Opt.Name := new String'(SS (P .. Q - 1));
- Validate_Command_Or_Option (Opt.Name);
-
- P := Q + 1;
- Q := P;
-
- while Q <= SS'Last and then SS (Q) /= ' ' loop
- Q := Q + 1;
- end loop;
-
- Opt.Unix_String := new String'(SS (P .. Q - 1));
- Validate_Unix_Switch (Opt.Unix_String);
- P := Q + 1;
end;
end loop;
end if;
end;
- end loop;
- end;
- end loop;
-
- -- If no parameters, give complete list of commands
-
- if Argument_Count = 0 then
- Put_Line ("List of available commands");
- New_Line;
-
- while Commands /= null loop
- Put (Commands.Usage.all);
- Set_Col (53);
- Put_Line (Commands.Unix_String.all);
- Commands := Commands.Next;
- end loop;
-
- raise Normal_Exit;
- end if;
+ end if;
- Arg_Num := 1;
+ if The_Command = Link or The_Command = Bind then
- loop
- exit when Arg_Num > Argument_Count;
+ -- 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.
- declare
- Argv : String_Access;
- Arg_Idx : Integer;
-
- function Get_Arg_End
- (Argv : String;
- Arg_Idx : Integer)
- return Integer;
- -- Begins looking at Arg_Idx + 1 and returns the index of the
- -- last character before a slash or else the index of the last
- -- character in the string Argv.
-
- function Get_Arg_End
- (Argv : String;
- Arg_Idx : Integer)
- return Integer
- is
- begin
- for J in Arg_Idx + 1 .. Argv'Last loop
- if Argv (J) = '/' then
- return J - 1;
- end if;
+ for J in 1 .. Last_Switches.Last loop
+ Test_If_Relative_Path
+ (Last_Switches.Table (J), Current_Work_Dir);
end loop;
- return Argv'Last;
- end Get_Arg_End;
-
- begin
- Argv := new String'(Argument (Arg_Num));
- Arg_Idx := Argv'First;
+ Get_Name_String (Projects.Table (Project).Directory);
- <<Tryagain_After_Coalesce>>
- loop
declare
- Next_Arg_Idx : Integer;
- Arg : String_Access;
+ Project_Dir : constant String := Name_Buffer (1 .. Name_Len);
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;
+ for J in 1 .. First_Switches.Last loop
+ Test_If_Relative_Path
+ (First_Switches.Table (J), Project_Dir);
+ end loop;
+ end;
- -- Give usage information if only command given
+ 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;
- if Argument_Count = 1 and then Next_Arg_Idx = Argv'Last
- and then
- not (Command.Name.all = "SYSTEM"
- or else Command.Name.all = "STANDARD")
+ begin
+ for Index in 1 .. Last loop
+ if Last_Switches.Table (Index)
+ (Last_Switches.Table (Index)'First) /= '-'
then
- Put_Line ("List of available qualifiers and options");
- New_Line;
+ File_Index := Index;
+ exit;
+ end if;
+ end loop;
- Put (Command.Usage.all);
- Set_Col (53);
- Put_Line (Command.Unix_String.all);
+ -- 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
- Sw : Item_Ptr := Command.Switches;
+ Spec : constant String :=
+ Base_Name (Last_Switches.Table (File_Index).all);
+ Last : Natural := Spec'Last;
begin
- while Sw /= null loop
- Put (" ");
- Put (Sw.Name.all);
-
- case Sw.Translation is
-
- when T_Other =>
- Set_Col (53);
- Put_Line (Sw.Unix_String.all & "/<other>");
-
- when T_Direct =>
- Set_Col (53);
- Put_Line (Sw.Unix_String.all);
-
- when T_Directories =>
- Put ("=(direc,direc,..direc)");
- Set_Col (53);
- Put (Sw.Unix_String.all);
- Put (" direc ");
- Put (Sw.Unix_String.all);
- Put_Line (" direc ...");
-
- when T_Directory =>
- Put ("=directory");
- Set_Col (53);
- Put (Sw.Unix_String.all);
-
- if Sw.Unix_String (Sw.Unix_String'Last)
- /= '='
- then
- Put (' ');
- end if;
-
- Put_Line ("directory ");
-
- when T_File =>
- Put ("=file");
- Set_Col (53);
- Put (Sw.Unix_String.all);
-
- if Sw.Unix_String (Sw.Unix_String'Last)
- /= '='
- then
- Put (' ');
- end if;
-
- Put_Line ("file ");
-
- when T_Numeric =>
- Put ("=nnn");
- Set_Col (53);
-
- if Sw.Unix_String (Sw.Unix_String'First)
- = '`'
- then
- Put (Sw.Unix_String
- (Sw.Unix_String'First + 1
- .. Sw.Unix_String'Last));
- else
- Put (Sw.Unix_String.all);
- end if;
-
- Put_Line ("nnn");
-
- when T_Alphanumplus =>
- Put ("=xyz");
- Set_Col (53);
-
- if Sw.Unix_String (Sw.Unix_String'First)
- = '`'
- then
- Put (Sw.Unix_String
- (Sw.Unix_String'First + 1
- .. Sw.Unix_String'Last));
- else
- Put (Sw.Unix_String.all);
- end if;
-
- Put_Line ("xyz");
-
- when T_String =>
- Put ("=");
- Put ('"');
- Put ("<string>");
- Put ('"');
- Set_Col (53);
-
- Put (Sw.Unix_String.all);
-
- if Sw.Unix_String (Sw.Unix_String'Last)
- /= '='
- then
- Put (' ');
- end if;
-
- Put ("<string>");
- New_Line;
-
- when T_Commands =>
- Put (" (switches for ");
- Put (Sw.Unix_String (
- Sw.Unix_String'First + 7
- .. Sw.Unix_String'Last));
- Put (')');
- Set_Col (53);
- Put (Sw.Unix_String (
- Sw.Unix_String'First
- .. Sw.Unix_String'First + 5));
- Put_Line (" switches");
-
- when T_Options =>
- declare
- Opt : Item_Ptr := Sw.Options;
-
- begin
- Put_Line ("=(option,option..)");
-
- while Opt /= null loop
- Put (" ");
- Put (Opt.Name.all);
-
- if Opt = Sw.Options then
- Put (" (D)");
- end if;
-
- Set_Col (53);
- Put_Line (Opt.Unix_String.all);
- Opt := Opt.Next;
- end loop;
- end;
-
- end case;
-
- Sw := Sw.Next;
- end loop;
+ 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;
-
- raise Normal_Exit;
- end if;
-
- Place (Command.Unix_String.all);
-
- -- Special handling for internal debugging switch /?
-
- elsif Arg.all = "/?" then
- Display_Command := True;
-
- -- Copy -switch unchanged
-
- elsif Arg (Arg'First) = '-' then
- Place (' ');
- Place (Arg.all);
-
- -- Copy quoted switch with quotes stripped
-
- elsif Arg (Arg'First) = '"' then
- if Arg (Arg'Last) /= '"' then
- Put (Standard_Error, "misquoted argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- else
- Put (Arg (Arg'First + 1 .. Arg'Last - 1));
- end if;
-
- -- Parameter Argument
-
- elsif Arg (Arg'First) /= '/'
- and then Make_Commands_Active = null
- then
- Param_Count := Param_Count + 1;
-
- if Param_Count <= Command.Params'Length then
-
- case Command.Params (Param_Count) is
-
- when File | Optional_File =>
- declare
- Normal_File : String_Access
- := To_Canonical_File_Spec (Arg.all);
- begin
- Place (' ');
- Place_Lower (Normal_File.all);
-
- if Is_Extensionless (Normal_File.all)
- and then Command.Defext /= " "
- then
- Place ('.');
- Place (Command.Defext);
- end if;
- end;
-
- when Unlimited_Files =>
- declare
- Normal_File : String_Access
- := To_Canonical_File_Spec (Arg.all);
-
- File_Is_Wild : Boolean := False;
- File_List : String_Access_List_Access;
- begin
- for I in Arg'Range loop
- if Arg (I) = '*'
- or else Arg (I) = '%'
- then
- File_Is_Wild := True;
- end if;
- end loop;
-
- if File_Is_Wild then
- File_List := To_Canonical_File_List
- (Arg.all, False);
-
- for I in File_List.all'Range loop
- Place (' ');
- Place_Lower (File_List.all (I).all);
- end loop;
- else
- Place (' ');
- Place_Lower (Normal_File.all);
-
- if Is_Extensionless (Normal_File.all)
- and then Command.Defext /= " "
- then
- Place ('.');
- Place (Command.Defext);
- end if;
- end if;
-
- Param_Count := Param_Count - 1;
- end;
-
- when Other_As_Is =>
- Place (' ');
- Place (Arg.all);
-
- when Files_Or_Wildcard =>
-
- -- Remove spaces from a comma separated list
- -- of file names and adjust control variables
- -- accordingly.
-
- while Arg_Num < Argument_Count and then
- (Argv (Argv'Last) = ',' xor
- Argument (Arg_Num + 1)
- (Argument (Arg_Num + 1)'First) = ',')
- loop
- Argv := new String'(Argv.all
- & Argument (Arg_Num + 1));
- Arg_Num := Arg_Num + 1;
- Arg_Idx := Argv'First;
- Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx);
- Arg :=
- new String'(Argv (Arg_Idx .. Next_Arg_Idx));
- end loop;
-
- -- Parse the comma separated list of VMS filenames
- -- and place them on the command line as space
- -- separated Unix style filenames. Lower case and
- -- add default extension as appropriate.
-
- declare
- Arg1_Idx : Integer := Arg'First;
-
- function Get_Arg1_End
- (Arg : String; Arg_Idx : Integer)
- return Integer;
- -- Begins looking at Arg_Idx + 1 and
- -- returns the index of the last character
- -- before a comma or else the index of the
- -- last character in the string Arg.
-
- function Get_Arg1_End
- (Arg : String; Arg_Idx : Integer)
- return Integer
- is
- begin
- for I in Arg_Idx + 1 .. Arg'Last loop
- if Arg (I) = ',' then
- return I - 1;
- end if;
- end loop;
-
- return Arg'Last;
- end Get_Arg1_End;
-
- begin
- loop
- declare
- Next_Arg1_Idx : Integer
- := Get_Arg1_End (Arg.all, Arg1_Idx);
-
- Arg1 : String
- := Arg (Arg1_Idx .. Next_Arg1_Idx);
-
- Normal_File : String_Access
- := To_Canonical_File_Spec (Arg1);
-
- begin
- Place (' ');
- Place_Lower (Normal_File.all);
-
- if Is_Extensionless (Normal_File.all)
- and then Command.Defext /= " "
- then
- Place ('.');
- Place (Command.Defext);
- end if;
-
- Arg1_Idx := Next_Arg1_Idx + 1;
- end;
-
- exit when Arg1_Idx > Arg'Last;
-
- -- Don't allow two or more commas in a row
-
- if Arg (Arg1_Idx) = ',' then
- Arg1_Idx := Arg1_Idx + 1;
- if Arg1_Idx > Arg'Last or else
- Arg (Arg1_Idx) = ','
- then
- Put_Line (Standard_Error,
- "Malformed Parameter: " & Arg.all);
- Put (Standard_Error, "usage: ");
- Put_Line (Standard_Error,
- Command.Usage.all);
- raise Error_Exit;
- end if;
- end if;
-
- end loop;
- end;
- end case;
end if;
+ 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);
+ -- 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 loop;
- if Sw /= null then
- case Sw.Translation is
-
- when T_Direct =>
- Place_Unix_Switches (Sw.Unix_String);
- if Arg (SwP + 1) = '=' then
- Put (Standard_Error,
- "qualifier options ignored: ");
- Put_Line (Standard_Error, Arg.all);
- end if;
-
- when T_Directories =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error,
- "missing directories for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- elsif Arg (SwP + 2) /= '(' then
- SwP := SwP + 2;
- Endp := Arg'Last;
-
- elsif Arg (Arg'Last) /= ')' then
-
- -- Remove spaces from a comma separated list
- -- of file names and adjust control
- -- variables accordingly.
-
- if Arg_Num < Argument_Count and then
- (Argv (Argv'Last) = ',' xor
- Argument (Arg_Num + 1)
- (Argument (Arg_Num + 1)'First) = ',')
- then
- Argv := new String'(Argv.all
- & Argument (Arg_Num + 1));
- Arg_Num := Arg_Num + 1;
- Arg_Idx := Argv'First;
- Next_Arg_Idx
- := Get_Arg_End (Argv.all, Arg_Idx);
- Arg := new String'
- (Argv (Arg_Idx .. Next_Arg_Idx));
- goto Tryagain_After_Coalesce;
- end if;
-
- Put (Standard_Error,
- "incorrectly parenthesized " &
- "or malformed argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- else
- SwP := SwP + 3;
- Endp := Arg'Last - 1;
- end if;
-
- while SwP <= Endp loop
- declare
- Dir_Is_Wild : Boolean := False;
- Dir_Maybe_Is_Wild : Boolean := False;
- Dir_List : String_Access_List_Access;
- begin
- P2 := SwP;
-
- while P2 < Endp
- and then Arg (P2 + 1) /= ','
- loop
-
- -- A wildcard directory spec on VMS
- -- will contain either * or % or ...
-
- if Arg (P2) = '*' then
- Dir_Is_Wild := True;
-
- elsif Arg (P2) = '%' then
- Dir_Is_Wild := True;
-
- elsif Dir_Maybe_Is_Wild
- and then Arg (P2) = '.'
- and then Arg (P2 + 1) = '.'
- then
- Dir_Is_Wild := True;
- Dir_Maybe_Is_Wild := False;
-
- elsif Dir_Maybe_Is_Wild then
- Dir_Maybe_Is_Wild := False;
-
- elsif Arg (P2) = '.'
- and then Arg (P2 + 1) = '.'
- then
- Dir_Maybe_Is_Wild := True;
-
- end if;
-
- P2 := P2 + 1;
- end loop;
-
- if (Dir_Is_Wild) then
- Dir_List := To_Canonical_File_List
- (Arg (SwP .. P2), True);
-
- for I in Dir_List.all'Range loop
- Place_Unix_Switches (Sw.Unix_String);
- Place_Lower (Dir_List.all (I).all);
- end loop;
- else
- Place_Unix_Switches (Sw.Unix_String);
- Place_Lower (To_Canonical_Dir_Spec
- (Arg (SwP .. P2), False).all);
- end if;
-
- SwP := P2 + 2;
- end;
- end loop;
-
- when T_Directory =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error,
- "missing directory for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- else
- Place_Unix_Switches (Sw.Unix_String);
-
- -- Some switches end in "=". No space here
-
- if Sw.Unix_String
- (Sw.Unix_String'Last) /= '='
- then
- Place (' ');
- end if;
-
- Place_Lower (To_Canonical_Dir_Spec
- (Arg (SwP + 2 .. Arg'Last), False).all);
- end if;
-
- when T_File =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error, "missing file for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- else
- Place_Unix_Switches (Sw.Unix_String);
-
- -- Some switches end in "=". No space here
-
- if Sw.Unix_String
- (Sw.Unix_String'Last) /= '='
- then
- Place (' ');
- end if;
-
- Place_Lower (To_Canonical_File_Spec
- (Arg (SwP + 2 .. Arg'Last)).all);
- end if;
-
- when T_Numeric =>
- if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then
- Place_Unix_Switches (Sw.Unix_String);
- Place (Arg (SwP + 2 .. Arg'Last));
-
- else
- Put (Standard_Error, "argument for ");
- Put (Standard_Error, Sw.Name.all);
- Put_Line (Standard_Error, " must be numeric");
- Errors := Errors + 1;
- end if;
-
- when T_Alphanumplus =>
- if
- OK_Alphanumerplus (Arg (SwP + 2 .. Arg'Last))
- then
- Place_Unix_Switches (Sw.Unix_String);
- Place (Arg (SwP + 2 .. Arg'Last));
-
- else
- Put (Standard_Error, "argument for ");
- Put (Standard_Error, Sw.Name.all);
- Put_Line (Standard_Error,
- " must be alphanumeric");
- Errors := Errors + 1;
- end if;
-
- when T_String =>
-
- -- A String value must be extended to the
- -- end of the Argv, otherwise strings like
- -- "foo/bar" get split at the slash.
- --
- -- The begining and ending of the string
- -- are flagged with embedded nulls which
- -- are removed when building the Spawn
- -- call. Nulls are use because they won't
- -- show up in a /? output. Quotes aren't
- -- used because that would make it difficult
- -- to embed them.
-
- Place_Unix_Switches (Sw.Unix_String);
- if Next_Arg_Idx /= Argv'Last then
- Next_Arg_Idx := Argv'Last;
- Arg := new String'
- (Argv (Arg_Idx .. Next_Arg_Idx));
-
- SwP := Arg'First;
- while SwP < Arg'Last and then
- Arg (SwP + 1) /= '=' loop
- SwP := SwP + 1;
- end loop;
- end if;
- Place (ASCII.NUL);
- Place (Arg (SwP + 2 .. Arg'Last));
- Place (ASCII.NUL);
-
- when T_Commands =>
-
- -- Output -largs/-bargs/-cargs
-
- Place (' ');
- Place (Sw.Unix_String
- (Sw.Unix_String'First ..
- Sw.Unix_String'First + 5));
-
- -- Set source of new commands, also setting this
- -- non-null indicates that we are in the special
- -- commands mode for processing the -xargs case.
-
- Make_Commands_Active :=
- Matching_Name
- (Sw.Unix_String
- (Sw.Unix_String'First + 7 ..
- Sw.Unix_String'Last),
- Commands);
-
- when T_Options =>
- if SwP + 1 > Arg'Last then
- Place_Unix_Switches (Sw.Options.Unix_String);
- SwP := Endp + 1;
-
- elsif Arg (SwP + 2) /= '(' then
- SwP := SwP + 2;
- Endp := Arg'Last;
-
- elsif Arg (Arg'Last) /= ')' then
- Put (Standard_Error,
- "incorrectly parenthesized argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
- SwP := Endp + 1;
-
- else
- SwP := SwP + 3;
- Endp := Arg'Last - 1;
- end if;
-
- while SwP <= Endp loop
- P2 := SwP;
-
- while P2 < Endp
- and then Arg (P2 + 1) /= ','
- loop
- P2 := P2 + 1;
- end loop;
-
- -- Option name is in Arg (SwP .. P2)
-
- Opt := Matching_Name (Arg (SwP .. P2),
- Sw.Options);
-
- if Opt /= null then
- Place_Unix_Switches (Opt.Unix_String);
- end if;
-
- SwP := P2 + 2;
- end loop;
-
- when T_Other =>
- Place_Unix_Switches
- (new String'(Sw.Unix_String.all & Arg.all));
-
- end case;
- end if;
- end;
+ 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;
-
- Arg_Idx := Next_Arg_Idx + 1;
end;
+ end if;
+ end if;
- exit when Arg_Idx > Argv'Last;
-
- end loop;
- end;
-
- Arg_Num := Arg_Num + 1;
- end loop;
-
- if Display_Command then
- Put (Standard_Error, "generated command -->");
- Put (Standard_Error, String (Buffer.Table (1 .. Buffer.Last)));
- Put (Standard_Error, "<--");
- New_Line (Standard_Error);
- raise Normal_Exit;
- end if;
-
- -- Gross error checking that the number of parameters is correct.
- -- Not applicable to Unlimited_Files parameters.
-
- if not ((Param_Count = Command.Params'Length - 1 and then
- Command.Params (Param_Count + 1) = Unlimited_Files)
- or else (Param_Count <= Command.Params'Length))
- then
- Put_Line (Standard_Error,
- "Parameter count of "
- & Integer'Image (Param_Count)
- & " not equal to expected "
- & Integer'Image (Command.Params'Length));
- Put (Standard_Error, "usage: ");
- Put_Line (Standard_Error, Command.Usage.all);
- Errors := Errors + 1;
- end if;
-
- if Errors > 0 then
- raise Error_Exit;
- else
- -- Prepare arguments for a call to spawn, filtering out
- -- embedded nulls place there to delineate strings.
+ -- Gather all the arguments and invoke the executable
declare
- Pname_Ptr : Natural;
- Args : Argument_List (1 .. 500);
- Nargs : Natural;
- P1, P2 : Natural;
- Exec_Path : String_Access;
- Inside_Nul : Boolean := False;
- Arg : String (1 .. 1024);
- Arg_Ctr : Natural;
-
+ The_Args : Argument_List
+ (1 .. First_Switches.Last + Last_Switches.Last);
+ Arg_Num : Natural := 0;
begin
- Pname_Ptr := 1;
+ for J in 1 .. First_Switches.Last loop
+ Arg_Num := Arg_Num + 1;
+ The_Args (Arg_Num) := First_Switches.Table (J);
+ end loop;
- while Pname_Ptr < Buffer.Last
- and then Buffer.Table (Pname_Ptr + 1) /= ' '
- loop
- Pname_Ptr := Pname_Ptr + 1;
+ for J in 1 .. Last_Switches.Last loop
+ Arg_Num := Arg_Num + 1;
+ The_Args (Arg_Num) := Last_Switches.Table (J);
end loop;
- P1 := Pname_Ptr + 2;
- Arg_Ctr := 1;
- Arg (Arg_Ctr) := Buffer.Table (P1);
+ -- If Display_Command is on, only display the generated command
- Nargs := 0;
- while P1 <= Buffer.Last loop
+ if Display_Command then
+ Put (Standard_Error, "generated command -->");
+ Put (Standard_Error, Exec_Path.all);
- if Buffer.Table (P1) = ASCII.NUL then
- if Inside_Nul then
- Inside_Nul := False;
- else
- Inside_Nul := True;
- end if;
- end if;
+ for Arg in The_Args'Range loop
+ Put (Standard_Error, " ");
+ Put (Standard_Error, The_Args (Arg).all);
+ end loop;
- if Buffer.Table (P1) = ' ' and then not Inside_Nul then
- P1 := P1 + 1;
- Arg_Ctr := Arg_Ctr + 1;
- Arg (Arg_Ctr) := Buffer.Table (P1);
-
- else
- Nargs := Nargs + 1;
- P2 := P1;
-
- while P2 < Buffer.Last
- and then (Buffer.Table (P2 + 1) /= ' ' or else
- Inside_Nul)
- loop
- P2 := P2 + 1;
- Arg_Ctr := Arg_Ctr + 1;
- Arg (Arg_Ctr) := Buffer.Table (P2);
- if Buffer.Table (P2) = ASCII.NUL then
- Arg_Ctr := Arg_Ctr - 1;
- if Inside_Nul then
- Inside_Nul := False;
- else
- Inside_Nul := True;
- end if;
- end if;
- end loop;
+ Put (Standard_Error, "<--");
+ New_Line (Standard_Error);
+ raise Normal_Exit;
+ end if;
- Args (Nargs) := new String'(String (Arg (1 .. Arg_Ctr)));
- P1 := P2 + 2;
- Arg_Ctr := 1;
- Arg (Arg_Ctr) := Buffer.Table (P1);
- end if;
- end loop;
+ if Opt.Verbose_Mode then
+ Output.Write_Str (Exec_Path.all);
- Exec_Path := Locate_Exec_On_Path
- (String (Buffer.Table (1 .. Pname_Ptr)));
+ for Arg in The_Args'Range loop
+ Output.Write_Char (' ');
+ Output.Write_Str (The_Args (Arg).all);
+ end loop;
- if Exec_Path = null then
- Put_Line (Standard_Error,
- "Couldn't locate "
- & String (Buffer.Table (1 .. Pname_Ptr)));
- raise Error_Exit;
+ Output.Write_Eol;
end if;
- My_Exit_Status
- := Exit_Status (Spawn (Exec_Path.all, Args (1 .. Nargs)));
-
+ My_Exit_Status :=
+ Exit_Status (Spawn (Exec_Path.all, The_Args));
+ raise Normal_Exit;
end;
-
- raise Normal_Exit;
- end if;
+ 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;
OSDN Git Service
