-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2008, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with Csets;
-with MLib.Tgt;
+with MLib.Tgt; use MLib.Tgt;
with MLib.Utl;
+with MLib.Fil;
with Namet; use Namet;
-with Opt;
+with Opt; use Opt;
with Osint; use Osint;
with Output;
with Prj; use Prj;
with Prj.Ext; use Prj.Ext;
with Prj.Pars;
with Prj.Util; use Prj.Util;
-with Sdefault; use Sdefault;
+with Sinput.P;
with Snames; use Snames;
-with Stringt; use Stringt;
with Table;
+with Targparm;
+with Tempdir;
with Types; use Types;
with Hostparm; use Hostparm;
-- Used to determine if we are in VMS or not for error message purposes
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
-with Gnatvsn;
with GNAT.OS_Lib; use GNAT.OS_Lib;
-with Table;
+with VMS_Conv; use VMS_Conv;
procedure GNATCmd is
-
- Ada_Include_Path : constant String := "ADA_INCLUDE_PATH";
- Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH";
-
+ Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data;
Project_File : String_Access;
Project : Prj.Project_Id;
Current_Verbosity : Prj.Verbosity := Prj.Default;
Tool_Package_Name : Name_Id := No_Name;
+ B_Start : String_Ptr := new String'("b~");
+ -- Prefix of binder generated file, changed to b__ for VMS
+
+ Old_Project_File_Used : Boolean := False;
-- This flag indicates a switch -p (for gnatxref and gnatfind) for
- -- an old fashioned project file. -p cannot be used in conjonction
+ -- an old fashioned project file. -p cannot be used in conjunction
-- with -P.
- Old_Project_File_Used : Boolean := False;
+ Max_Files_On_The_Command_Line : constant := 30; -- Arbitrary
- -- A table to keep the switches on the command line
+ Temp_File_Name : String_Access := null;
+ -- The name of the temporary text file to put a list of source/object
+ -- files to pass to a tool, when there are more than
+ -- Max_Files_On_The_Command_Line files.
- package Last_Switches is new Table.Table
+ ASIS_Main : String_Access := null;
+ -- Main for commands Check, Metric and Pretty, when -U is used
+
+ 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.Last_Switches");
-
+ Table_Name => "Gnatcmd.First_Switches");
-- A table to keep the switches from the project file
- package First_Switches is new Table.Table
+ package Carg_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");
+ Table_Name => "Gnatcmd.Carg_Switches");
+ -- A table to keep the switches following -cargs for ASIS tools
- ------------------
- -- SWITCH TABLE --
- ------------------
-
- -- The switch tables contain an entry for each switch recognized by the
- -- command processor. The syntax of entries is as follows:
-
- -- SWITCH_STRING ::= "/ command-qualifier-name TRANSLATION"
+ package Rules_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.Rules_Switches");
+ -- A table to keep the switches following -rules for gnatcheck
- -- TRANSLATION ::=
- -- DIRECT_TRANSLATION
- -- | DIRECTORIES_TRANSLATION
- -- | FILE_TRANSLATION
- -- | NO_SPACE_FILE_TRANSL
- -- | NUMERIC_TRANSLATION
- -- | STRING_TRANSLATION
- -- | OPTIONS_TRANSLATION
- -- | COMMANDS_TRANSLATION
- -- | ALPHANUMPLUS_TRANSLATION
- -- | OTHER_TRANSLATION
+ 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");
- -- DIRECT_TRANSLATION ::= space UNIX_SWITCHES
- -- DIRECTORIES_TRANSLATION ::= =* UNIX_SWITCH *
- -- DIRECTORY_TRANSLATION ::= =% UNIX_SWITCH %
- -- FILE_TRANSLATION ::= =@ UNIX_SWITCH @
- -- NO_SPACE_FILE_TRANSL ::= =< UNIX_SWITCH >
- -- NUMERIC_TRANSLATION ::= =# UNIX_SWITCH # | # number #
- -- STRING_TRANSLATION ::= =" UNIX_SWITCH "
- -- OPTIONS_TRANSLATION ::= =OPTION {space OPTION}
- -- COMMANDS_TRANSLATION ::= =? ARGS space command-name
- -- ALPHANUMPLUS_TRANSLATION ::= =| UNIX_SWITCH |
+ -- 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.
- -- UNIX_SWITCHES ::= UNIX_SWITCH {, UNIX_SWITCH}
+ subtype SA is String_Access;
- -- UNIX_SWITCH ::= unix-switch-string | !unix-switch-string | `string'
+ Naming_String : constant SA := new String'("naming");
+ Binder_String : constant SA := new String'("binder");
+ Compiler_String : constant SA := new String'("compiler");
+ Check_String : constant SA := new String'("check");
+ Synchronize_String : constant SA := new String'("synchronize");
+ Eliminate_String : constant SA := new String'("eliminate");
+ Finder_String : constant SA := new String'("finder");
+ Linker_String : constant SA := new String'("linker");
+ Gnatls_String : constant SA := new String'("gnatls");
+ Pretty_String : constant SA := new String'("pretty_printer");
+ Stack_String : constant SA := new String'("stack");
+ Gnatstub_String : constant SA := new String'("gnatstub");
+ Metric_String : constant SA := new String'("metrics");
+ Xref_String : constant SA := new String'("cross_reference");
- -- OPTION ::= option-name space UNIX_SWITCHES
+ Packages_To_Check_By_Binder : constant String_List_Access :=
+ new String_List'((Naming_String, Binder_String));
- -- ARGS ::= -cargs | -bargs | -largs
+ Packages_To_Check_By_Check : constant String_List_Access :=
+ new String_List'((Naming_String, Check_String, Compiler_String));
- -- 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_Sync : constant String_List_Access :=
+ new String_List'((Naming_String, Synchronize_String, Compiler_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, Compiler_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, Compiler_String));
- -- the NO_SPACE_FILE_TRANSL is similar to FILE_TRANSLATION, except that
- -- no space is inserted between the switch and the file name.
+ Packages_To_Check_By_Stack : constant String_List_Access :=
+ new String_List'((Naming_String, Stack_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, Compiler_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_Metric : constant String_List_Access :=
+ new String_List'((Naming_String, Metric_String, Compiler_String));
- -- /ERRORS=BRIEF
- -- /ERRORS=(FULL,VERBOSE)
- -- /ERRORS=(BRIEF IMMEDIATE)
+ Packages_To_Check_By_Xref : constant String_List_Access :=
+ new String_List'((Naming_String, Xref_String));
- -- If no option is provided (e.g. just /ERRORS is written), then the
- -- first option in the list is the default option. For /ERRORS this
- -- is NORMAL, so /ERRORS with no option is equivalent to /ERRORS=NORMAL.
+ Packages_To_Check : String_List_Access := Prj.All_Packages;
- -- 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
+ ----------------------------------
+ -- Declarations for GNATCMD use --
+ ----------------------------------
- -- /COMPILER_QUALIFIERS /LIST /BINDER_QUALIFIERS /MAIN
- -- /COMPILER_QUALIFIERS /NOLIST /COMPILE_CHECKS=SYNTAX
+ The_Command : Command_Type;
+ -- The command specified in the invocation of the GNAT driver
- -- Clearly these switches must come at the end of the list of switches
- -- since all subsequent switches apply to an issued command.
+ Command_Arg : Positive := 1;
+ -- The index of the command in the arguments of the GNAT driver
- -- 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:
+ My_Exit_Status : Exit_Status := Success;
+ -- The exit status of the spawned tool. Used to set the correct VMS
+ -- exit status.
- -- "/LIST -gnatl"
+ Current_Work_Dir : constant String := Get_Current_Dir;
+ -- The path of the working directory
- -- An implicit entry is created:
+ All_Projects : Boolean := False;
+ -- Flag used for GNAT CHECK, GNAT PRETTY, GNAT METRIC, and GNAT STACK to
+ -- indicate that the underlying tool (gnatcheck, gnatpp or gnatmetric)
+ -- should be invoked for all sources of all projects.
- -- "/NOLIST !-gnatl"
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
- -- In the case where, a ! is already present, inverting the sense of the
- -- switch means removing it.
+ procedure Add_To_Carg_Switches (Switch : String_Access);
+ -- Add a switch to the Carg_Switches table. If it is the first one, put the
+ -- switch "-cargs" at the beginning of the table.
+
+ procedure Add_To_Rules_Switches (Switch : String_Access);
+ -- Add a switch to the Rules_Switches table. If it is the first one, put
+ -- the switch "-crules" at the beginning of the table.
+
+ procedure Check_Files;
+ -- For GNAT LIST, GNAT PRETTY, GNAT METRIC, and GNAT STACK, check if a
+ -- project file is specified, without any file arguments. If it is the
+ -- case, invoke the GNAT tool with the proper list of files, derived from
+ -- the sources of the project.
+
+ function Check_Project
+ (Project : Project_Id;
+ Root_Project : Project_Id) return Boolean;
+ -- Returns True if Project = Root_Project or if we want to consider all
+ -- sources of all projects. For GNAT METRIC, also returns True if Project
+ -- is extended by Root_Project.
+
+ 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 Path_Name_Type;
+ -- 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), gnatelim (GNAT ELIM), and gnatmetric (GNAT
+ -- METRIC).
+
+ procedure Delete_Temp_Config_Files;
+ -- Delete all temporary config files. The caller is responsible for
+ -- ensuring that Keep_Temporary_Files is False.
+
+ procedure Get_Closure;
+ -- Get the sources in the closure of the ASIS_Main and add them to the
+ -- list of arguments.
- subtype S is String;
- -- A synonym to shorten the table
+ function Index (Char : Character; Str : String) return Natural;
+ -- Returns first occurrence of Char in Str, returns 0 if Char not in Str
- type String_Ptr is access constant String;
- -- String pointer type used throughout
+ procedure Non_VMS_Usage;
+ -- Display usage for platforms other than VMS
- type Switches is array (Natural range <>) of String_Ptr;
- -- Type used for array of swtiches
+ procedure Process_Link;
+ -- Process GNAT LINK, when there is a project file specified
- type Switches_Ptr is access constant Switches;
+ 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.
- --------------------------------
- -- Switches for project files --
- --------------------------------
+ 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.
- 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";
+ 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.
- S_Bind_DebugX : aliased constant S := "/NODEBUG " &
- "!-g";
+ --------------------------
+ -- Add_To_Carg_Switches --
+ --------------------------
- S_Bind_Elab : aliased constant S := "/ELABORATION_DEPENDENCIES " &
- "-e";
+ procedure Add_To_Carg_Switches (Switch : String_Access) is
+ begin
+ -- If the Carg_Switches table is empty, put "-cargs" at the beginning
- S_Bind_Error : aliased constant S := "/ERROR_LIMIT=#" &
- "-m#";
+ if Carg_Switches.Last = 0 then
+ Carg_Switches.Increment_Last;
+ Carg_Switches.Table (Carg_Switches.Last) := new String'("-cargs");
+ end if;
- S_Bind_Help : aliased constant S := "/HELP " &
- "-h";
-
- S_Bind_Init : aliased constant S := "/INITIALIZE_SCALARS=" &
- "INVALID " &
- "-Sin " &
- "LOW " &
- "-Slo " &
- "HIGH " &
- "-Shi";
-
- S_Bind_Library : aliased constant S := "/LIBRARY_SEARCH=*" &
- "-aO*";
-
- S_Bind_Linker : aliased constant S := "/LINKER_OPTION_LIST " &
- "-K";
-
- S_Bind_List : aliased constant S := "/LIST_RESTRICTIONS " &
- "-r";
-
- S_Bind_Main : aliased constant S := "/MAIN " &
- "!-n";
-
- S_Bind_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
- "-nostdinc";
-
- S_Bind_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
- "-nostdlib";
-
- S_Bind_No_Time : aliased constant S := "/NO_TIME_STAMP_CHECK " &
- "-t";
-
- S_Bind_Object : aliased constant S := "/OBJECT_LIST " &
- "-O";
-
- S_Bind_Order : aliased constant S := "/ORDER_OF_ELABORATION " &
- "-l";
-
- S_Bind_Output : aliased constant S := "/OUTPUT=@" &
- "-o@";
-
- S_Bind_OutputX : aliased constant S := "/NOOUTPUT " &
- "-c";
-
- S_Bind_Pess : aliased constant S := "/PESSIMISTIC_ELABORATION " &
- "-p";
-
- S_Bind_Read : aliased constant S := "/READ_SOURCES=" &
- "ALL " &
- "-s " &
- "NONE " &
- "-x " &
- "AVAILABLE " &
- "!-x,!-s";
-
- S_Bind_ReadX : aliased constant S := "/NOREAD_SOURCES " &
- "-x";
-
- S_Bind_Rename : aliased constant S := "/RENAME_MAIN=<" &
- "-M>";
-
- S_Bind_Report : aliased constant S := "/REPORT_ERRORS=" &
- "VERBOSE " &
- "-v " &
- "BRIEF " &
- "-b " &
- "DEFAULT " &
- "!-b,!-v";
-
- S_Bind_ReportX : aliased constant S := "/NOREPORT_ERRORS " &
- "!-b,!-v";
-
- S_Bind_Restr : aliased constant S := "/RESTRICTION_LIST " &
- "-r";
-
- S_Bind_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" &
- "--RTS=|";
-
- S_Bind_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
-
- S_Bind_Shared : aliased constant S := "/SHARED " &
- "-shared";
-
- S_Bind_Slice : aliased constant S := "/TIME_SLICE=#" &
- "-T#";
-
- S_Bind_Source : aliased constant S := "/SOURCE_SEARCH=*" &
- "-aI*";
-
- S_Bind_Time : aliased constant S := "/TIME_STAMP_CHECK " &
- "!-t";
-
- S_Bind_Verbose : aliased constant S := "/VERBOSE " &
- "-v";
-
- S_Bind_Warn : aliased constant S := "/WARNINGS=" &
- "NORMAL " &
- "!-ws,!-we " &
- "SUPPRESS " &
- "-ws " &
- "ERROR " &
- "-we";
-
- S_Bind_WarnX : aliased constant S := "/NOWARNINGS " &
- "-ws";
-
- Bind_Switches : aliased constant Switches :=
- (S_Bind_Bind 'Access,
- S_Bind_Build 'Access,
- S_Bind_Current 'Access,
- S_Bind_Debug 'Access,
- S_Bind_DebugX 'Access,
- S_Bind_Elab 'Access,
- S_Bind_Error 'Access,
- S_Ext_Ref 'Access,
- S_Bind_Help 'Access,
- S_Bind_Init 'Access,
- S_Bind_Library 'Access,
- S_Bind_Linker 'Access,
- S_Bind_List 'Access,
- S_Bind_Main 'Access,
- S_Bind_Nostinc 'Access,
- S_Bind_Nostlib 'Access,
- S_Bind_No_Time 'Access,
- S_Bind_Object 'Access,
- S_Bind_Order 'Access,
- S_Bind_Output 'Access,
- S_Bind_OutputX 'Access,
- S_Bind_Pess 'Access,
- S_Project_File 'Access,
- S_Project_Verb 'Access,
- S_Bind_Read 'Access,
- S_Bind_ReadX 'Access,
- S_Bind_Rename 'Access,
- S_Bind_Report 'Access,
- S_Bind_ReportX 'Access,
- S_Bind_Restr 'Access,
- S_Bind_RTS 'Access,
- S_Bind_Search 'Access,
- S_Bind_Shared 'Access,
- S_Bind_Slice 'Access,
- S_Bind_Source 'Access,
- S_Bind_Time 'Access,
- S_Bind_Verbose 'Access,
- S_Bind_Warn 'Access,
- S_Bind_WarnX 'Access);
-
- ----------------------------
- -- Switches for GNAT CHOP --
- ----------------------------
-
- S_Chop_Comp : aliased constant S := "/COMPILATION " &
- "-c";
-
- S_Chop_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" &
- "-k#";
-
- S_Chop_Help : aliased constant S := "/HELP " &
- "-h";
-
- S_Chop_Over : aliased constant S := "/OVERWRITE " &
- "-w";
-
- S_Chop_Pres : aliased constant S := "/PRESERVE " &
- "-p";
-
- S_Chop_Quiet : aliased constant S := "/QUIET " &
- "-q";
-
- S_Chop_Ref : aliased constant S := "/REFERENCE " &
- "-r";
-
- S_Chop_Verb : aliased constant S := "/VERBOSE " &
- "-v";
-
- Chop_Switches : aliased constant Switches :=
- (S_Chop_Comp 'Access,
- S_Chop_File 'Access,
- S_Chop_Help 'Access,
- S_Chop_Over 'Access,
- S_Chop_Pres 'Access,
- S_Chop_Quiet 'Access,
- S_Chop_Ref 'Access,
- S_Chop_Verb 'Access);
+ Carg_Switches.Increment_Last;
+ Carg_Switches.Table (Carg_Switches.Last) := Switch;
+ end Add_To_Carg_Switches;
- -------------------------------
- -- Switches for GNAT COMPILE --
- -------------------------------
+ ---------------------------
+ -- Add_To_Rules_Switches --
+ ---------------------------
- S_GCC_Ada_83 : aliased constant S := "/83 " &
- "-gnat83";
-
- S_GCC_Ada_95 : aliased constant S := "/95 " &
- "!-gnat83";
-
- S_GCC_Asm : aliased constant S := "/ASM " &
- "-S,!-c";
-
- S_GCC_Checks : aliased constant S := "/CHECKS=" &
- "FULL " &
- "-gnato,!-gnatE,!-gnatp " &
- "OVERFLOW " &
- "-gnato " &
- "ELABORATION " &
- "-gnatE " &
- "ASSERTIONS " &
- "-gnata " &
- "DEFAULT " &
- "!-gnato,!-gnatp " &
- "SUPPRESS_ALL " &
- "-gnatp";
-
- S_GCC_ChecksX : aliased constant S := "/NOCHECKS " &
- "-gnatp,!-gnato,!-gnatE";
-
- S_GCC_Compres : aliased constant S := "/COMPRESS_NAMES " &
- "-gnatC";
-
- S_GCC_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" &
- "-gnatec>";
-
- S_GCC_Current : aliased constant S := "/CURRENT_DIRECTORY " &
- "!-I-";
-
- S_GCC_Debug : aliased constant S := "/DEBUG=" &
- "SYMBOLS " &
- "-g2 " &
- "NOSYMBOLS " &
- "!-g2 " &
- "TRACEBACK " &
- "-g1 " &
- "ALL " &
- "-g3 " &
- "NONE " &
- "-g0 " &
- "NOTRACEBACK " &
- "-g0";
-
- S_GCC_DebugX : aliased constant S := "/NODEBUG " &
- "!-g";
-
- S_GCC_Dist : aliased constant S := "/DISTRIBUTION_STUBS=" &
- "RECEIVER " &
- "-gnatzr " &
- "CALLER " &
- "-gnatzc";
-
- S_GCC_DistX : aliased constant S := "/NODISTRIBUTION_STUBS " &
- "!-gnatzr,!-gnatzc";
-
- S_GCC_Error : aliased constant S := "/ERROR_LIMIT=#" &
- "-gnatm#";
-
- S_GCC_ErrorX : aliased constant S := "/NOERROR_LIMIT " &
- "-gnatm999";
-
- S_GCC_Expand : aliased constant S := "/EXPAND_SOURCE " &
- "-gnatG";
-
- S_GCC_Extend : aliased constant S := "/EXTENSIONS_ALLOWED " &
- "-gnatX";
-
- S_GCC_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" &
- "-gnatk#";
-
- S_GCC_Force : aliased constant S := "/FORCE_ALI " &
- "-gnatQ";
-
- S_GCC_Help : aliased constant S := "/HELP " &
- "-gnath";
-
- S_GCC_Ident : aliased constant S := "/IDENTIFIER_CHARACTER_SET=" &
- "DEFAULT " &
- "-gnati1 " &
- "1 " &
- "-gnati1 " &
- "2 " &
- "-gnati2 " &
- "3 " &
- "-gnati3 " &
- "4 " &
- "-gnati4 " &
- "5 " &
- "-gnati5 " &
- "PC " &
- "-gnatip " &
- "PC850 " &
- "-gnati8 " &
- "FULL_UPPER " &
- "-gnatif " &
- "NO_UPPER " &
- "-gnatin " &
- "WIDE " &
- "-gnatiw";
-
- S_GCC_IdentX : aliased constant S := "/NOIDENTIFIER_CHARACTER_SET " &
- "-gnati1";
-
- S_GCC_Immed : aliased constant S := "/IMMEDIATE_ERRORS " &
- "-gnatdO";
-
- S_GCC_Inline : aliased constant S := "/INLINE=" &
- "PRAGMA " &
- "-gnatn " &
- "FULL " &
- "-gnatN " &
- "SUPPRESS " &
- "-fno-inline";
-
- S_GCC_InlineX : aliased constant S := "/NOINLINE " &
- "!-gnatn";
-
- S_GCC_Jumps : aliased constant S := "/LONGJMP_SETJMP " &
- "-gnatL";
-
- S_GCC_Length : aliased constant S := "/MAX_LINE_LENGTH=#" &
- "-gnatyM#";
-
- S_GCC_List : aliased constant S := "/LIST " &
- "-gnatl";
-
- S_GCC_Noadc : aliased constant S := "/NO_GNAT_ADC " &
- "-gnatA";
-
- S_GCC_Noload : aliased constant S := "/NOLOAD " &
- "-gnatc";
-
- S_GCC_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
- "-nostdinc";
-
- S_GCC_Opt : aliased constant S := "/OPTIMIZE=" &
- "ALL " &
- "-O2,!-O0,!-O1,!-O3 " &
- "NONE " &
- "-O0,!-O1,!-O2,!-O3 " &
- "SOME " &
- "-O1,!-O0,!-O2,!-O3 " &
- "DEVELOPMENT " &
- "-O1,!-O0,!-O2,!-O3 " &
- "UNROLL_LOOPS " &
- "-funroll-loops " &
- "INLINING " &
- "-O3,!-O0,!-O1,!-O2";
-
- S_GCC_OptX : aliased constant S := "/NOOPTIMIZE " &
- "-O0,!-O1,!-O2,!-O3";
-
- S_GCC_Polling : aliased constant S := "/POLLING " &
- "-gnatP";
-
- S_GCC_Report : aliased constant S := "/REPORT_ERRORS=" &
- "VERBOSE " &
- "-gnatv " &
- "BRIEF " &
- "-gnatb " &
- "FULL " &
- "-gnatf " &
- "IMMEDIATE " &
- "-gnate " &
- "DEFAULT " &
- "!-gnatb,!-gnatv";
-
- S_GCC_ReportX : aliased constant S := "/NOREPORT_ERRORS " &
- "!-gnatb,!-gnatv";
-
- S_GCC_Repinfo : aliased constant S := "/REPRESENTATION_INFO=" &
- "ARRAYS " &
- "-gnatR1 " &
- "NONE " &
- "-gnatR0 " &
- "OBJECTS " &
- "-gnatR2 " &
- "SYMBOLIC " &
- "-gnatR3 " &
- "DEFAULT " &
- "-gnatR";
-
- S_GCC_RepinfX : aliased constant S := "/NOREPRESENTATION_INFO " &
- "!-gnatR";
-
- S_GCC_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
-
- S_GCC_Style : aliased constant S := "/STYLE_CHECKS=" &
- "ALL_BUILTIN " &
- "-gnaty " &
- "1 " &
- "-gnaty1 " &
- "2 " &
- "-gnaty2 " &
- "3 " &
- "-gnaty3 " &
- "4 " &
- "-gnaty4 " &
- "5 " &
- "-gnaty5 " &
- "6 " &
- "-gnaty6 " &
- "7 " &
- "-gnaty7 " &
- "8 " &
- "-gnaty8 " &
- "9 " &
- "-gnaty9 " &
- "ATTRIBUTE " &
- "-gnatya " &
- "BLANKS " &
- "-gnatyb " &
- "COMMENTS " &
- "-gnatyc " &
- "END " &
- "-gnatye " &
- "VTABS " &
- "-gnatyf " &
- "GNAT " &
- "-gnatg " &
- "HTABS " &
- "-gnatyh " &
- "IF_THEN " &
- "-gnatyi " &
- "KEYWORD " &
- "-gnatyk " &
- "LAYOUT " &
- "-gnatyl " &
- "LINE_LENGTH " &
- "-gnatym " &
- "STANDARD_CASING " &
- "-gnatyn " &
- "ORDERED_SUBPROGRAMS " &
- "-gnatyo " &
- "NONE " &
- "!-gnatg,!-gnatr " &
- "PRAGMA " &
- "-gnatyp " &
- "RM_COLUMN_LAYOUT " &
- "-gnatr " &
- "SPECS " &
- "-gnatys " &
- "TOKEN " &
- "-gnatyt ";
-
- S_GCC_StyleX : aliased constant S := "/NOSTYLE_CHECKS " &
- "!-gnatg,!-gnatr";
-
- S_GCC_Syntax : aliased constant S := "/SYNTAX_ONLY " &
- "-gnats";
-
- S_GCC_Trace : aliased constant S := "/TRACE_UNITS " &
- "-gnatdc";
-
- S_GCC_Tree : aliased constant S := "/TREE_OUTPUT " &
- "-gnatt";
-
- S_GCC_Trys : aliased constant S := "/TRY_SEMANTICS " &
- "-gnatq";
-
- S_GCC_Units : aliased constant S := "/UNITS_LIST " &
- "-gnatu";
-
- S_GCC_Unique : aliased constant S := "/UNIQUE_ERROR_TAG " &
- "-gnatU";
-
- S_GCC_Upcase : aliased constant S := "/UPPERCASE_EXTERNALS " &
- "-gnatF";
-
- S_GCC_Valid : aliased constant S := "/VALIDITY_CHECKING=" &
- "DEFAULT " &
- "-gnatVd " &
- "NODEFAULT " &
- "-gnatVD " &
- "COPIES " &
- "-gnatVc " &
- "NOCOPIES " &
- "-gnatVC " &
- "FLOATS " &
- "-gnatVf " &
- "NOFLOATS " &
- "-gnatVF " &
- "IN_PARAMS " &
- "-gnatVi " &
- "NOIN_PARAMS " &
- "-gnatVI " &
- "MOD_PARAMS " &
- "-gnatVm " &
- "NOMOD_PARAMS " &
- "-gnatVM " &
- "OPERANDS " &
- "-gnatVo " &
- "NOOPERANDS " &
- "-gnatVO " &
- "RETURNS " &
- "-gnatVr " &
- "NORETURNS " &
- "-gnatVR " &
- "SUBSCRIPTS " &
- "-gnatVs " &
- "NOSUBSCRIPTS " &
- "-gnatVS " &
- "TESTS " &
- "-gnatVt " &
- "NOTESTS " &
- "-gnatVT " &
- "ALL " &
- "-gnatVa " &
- "NONE " &
- "-gnatVn";
-
- S_GCC_Verbose : aliased constant S := "/VERBOSE " &
- "-v";
-
- S_GCC_Warn : aliased constant S := "/WARNINGS=" &
- "DEFAULT " &
- "!-gnatws,!-gnatwe " &
- "ALL_GCC " &
- "-Wall " &
- "BIASED_ROUNDING " &
- "-gnatwb " &
- "NOBIASED_ROUNDING " &
- "-gnatwB " &
- "CONDITIONALS " &
- "-gnatwc " &
- "NOCONDITIONALS " &
- "-gnatwC " &
- "IMPLICIT_DEREFERENCE " &
- "-gnatwd " &
- "NO_IMPLICIT_DEREFERENCE " &
- "-gnatwD " &
- "ELABORATION " &
- "-gnatwl " &
- "NOELABORATION " &
- "-gnatwL " &
- "ERRORS " &
- "-gnatwe " &
- "HIDING " &
- "-gnatwh " &
- "NOHIDING " &
- "-gnatwH " &
- "IMPLEMENTATION " &
- "-gnatwi " &
- "NOIMPLEMENTATION " &
- "-gnatwI " &
- "INEFFECTIVE_INLINE " &
- "-gnatwp " &
- "NOINEFFECTIVE_INLINE " &
- "-gnatwP " &
- "OPTIONAL " &
- "-gnatwa " &
- "NOOPTIONAL " &
- "-gnatwA " &
- "OVERLAYS " &
- "-gnatwo " &
- "NOOVERLAYS " &
- "-gnatwO " &
- "REDUNDANT " &
- "-gnatwr " &
- "NOREDUNDANT " &
- "-gnatwR " &
- "SUPPRESS " &
- "-gnatws " &
- "UNINITIALIZED " &
- "-Wuninitialized " &
- "UNREFERENCED_FORMALS " &
- "-gnatwf " &
- "NOUNREFERENCED_FORMALS " &
- "-gnatwF " &
- "UNUSED " &
- "-gnatwu " &
- "NOUNUSED " &
- "-gnatwU";
-
- S_GCC_WarnX : aliased constant S := "/NOWARNINGS " &
- "-gnatws";
-
- S_GCC_Wide : aliased constant S := "/WIDE_CHARACTER_ENCODING=" &
- "BRACKETS " &
- "-gnatWb " &
- "NONE " &
- "-gnatWn " &
- "HEX " &
- "-gnatWh " &
- "UPPER " &
- "-gnatWu " &
- "SHIFT_JIS " &
- "-gnatWs " &
- "UTF8 " &
- "-gnatW8 " &
- "EUC " &
- "-gnatWe";
-
- S_GCC_WideX : aliased constant S := "/NOWIDE_CHARACTER_ENCODING " &
- "-gnatWn";
-
- S_GCC_Xdebug : aliased constant S := "/XDEBUG " &
- "-gnatD";
-
- S_GCC_Xref : aliased constant S := "/XREF=" &
- "GENERATE " &
- "!-gnatx " &
- "SUPPRESS " &
- "-gnatx";
-
- GCC_Switches : aliased constant Switches :=
- (S_GCC_Ada_83 'Access,
- S_GCC_Ada_95 'Access,
- S_GCC_Asm 'Access,
- S_GCC_Checks 'Access,
- S_GCC_ChecksX 'Access,
- S_GCC_Compres 'Access,
- S_GCC_Config 'Access,
- S_GCC_Current 'Access,
- S_GCC_Debug 'Access,
- S_GCC_DebugX 'Access,
- S_GCC_Dist 'Access,
- S_GCC_DistX 'Access,
- S_GCC_Error 'Access,
- S_GCC_ErrorX 'Access,
- S_GCC_Expand 'Access,
- S_GCC_Extend 'Access,
- S_Ext_Ref 'Access,
- S_GCC_File 'Access,
- S_GCC_Force 'Access,
- S_GCC_Help 'Access,
- S_GCC_Ident 'Access,
- S_GCC_IdentX 'Access,
- S_GCC_Immed 'Access,
- S_GCC_Inline 'Access,
- S_GCC_InlineX 'Access,
- S_GCC_Jumps 'Access,
- S_GCC_Length 'Access,
- S_GCC_List 'Access,
- S_GCC_Noadc 'Access,
- S_GCC_Noload 'Access,
- S_GCC_Nostinc 'Access,
- S_GCC_Opt 'Access,
- S_GCC_OptX 'Access,
- S_GCC_Polling 'Access,
- S_Project_File'Access,
- S_Project_Verb'Access,
- S_GCC_Report 'Access,
- S_GCC_ReportX 'Access,
- S_GCC_Repinfo 'Access,
- S_GCC_RepinfX 'Access,
- S_GCC_Search 'Access,
- S_GCC_Style 'Access,
- S_GCC_StyleX 'Access,
- S_GCC_Syntax 'Access,
- S_GCC_Trace 'Access,
- S_GCC_Tree 'Access,
- S_GCC_Trys 'Access,
- S_GCC_Units 'Access,
- S_GCC_Unique 'Access,
- S_GCC_Upcase 'Access,
- S_GCC_Valid 'Access,
- S_GCC_Verbose 'Access,
- S_GCC_Warn 'Access,
- S_GCC_WarnX 'Access,
- S_GCC_Wide 'Access,
- S_GCC_WideX 'Access,
- S_GCC_Xdebug 'Access,
- S_GCC_Xref 'Access);
-
- ----------------------------
- -- Switches for GNAT ELIM --
- ----------------------------
-
- S_Elim_All : aliased constant S := "/ALL " &
- "-a";
-
- S_Elim_Bind : aliased constant S := "/BIND_FILE=<" &
- "-b>";
-
- S_Elim_Miss : aliased constant S := "/MISSED " &
- "-m";
-
- S_Elim_Quiet : aliased constant S := "/QUIET " &
- "-q";
-
- S_Elim_Tree : aliased constant S := "/TREE_DIRS=*" &
- "-T*";
-
- S_Elim_Verb : aliased constant S := "/VERBOSE " &
- "-v";
-
- Elim_Switches : aliased constant Switches :=
- (S_Elim_All 'Access,
- S_Elim_Bind 'Access,
- S_Elim_Miss 'Access,
- S_Elim_Quiet 'Access,
- S_Elim_Tree 'Access,
- S_Elim_Verb 'Access);
-
- ----------------------------
- -- Switches for GNAT FIND --
- ----------------------------
-
- S_Find_All : aliased constant S := "/ALL_FILES " &
- "-a";
-
- S_Find_Deriv : aliased constant S := "/DERIVED_TYPE_INFORMATION " &
- "-d";
-
- S_Find_Expr : aliased constant S := "/EXPRESSIONS " &
- "-e";
-
- S_Find_Full : aliased constant S := "/FULL_PATHNAME " &
- "-f";
-
- S_Find_Ignore : aliased constant S := "/IGNORE_LOCALS " &
- "-g";
-
- S_Find_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
- "-nostdinc";
-
- S_Find_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
- "-nostdlib";
-
- S_Find_Object : aliased constant S := "/OBJECT_SEARCH=*" &
- "-aO*";
-
- S_Find_Print : aliased constant S := "/PRINT_LINES " &
- "-s";
-
- S_Find_Project : aliased constant S := "/PROJECT=@" &
- "-p@";
-
- S_Find_Ref : aliased constant S := "/REFERENCES " &
- "-r";
-
- S_Find_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
-
- S_Find_Source : aliased constant S := "/SOURCE_SEARCH=*" &
- "-aI*";
-
- S_Find_Types : aliased constant S := "/TYPE_HIERARCHY " &
- "-t";
-
- Find_Switches : aliased constant Switches :=
- (S_Find_All 'Access,
- S_Find_Deriv 'Access,
- S_Find_Expr 'Access,
- S_Ext_Ref 'Access,
- S_Find_Full 'Access,
- S_Find_Ignore 'Access,
- S_Find_Nostinc 'Access,
- S_Find_Nostlib 'Access,
- S_Find_Object 'Access,
- S_Find_Print 'Access,
- S_Find_Project 'Access,
- S_Project_File 'Access,
- S_Project_Verb 'Access,
- S_Find_Ref 'Access,
- S_Find_Search 'Access,
- S_Find_Source 'Access,
- S_Find_Types 'Access);
+ procedure Add_To_Rules_Switches (Switch : String_Access) is
+ begin
+ -- If the Rules_Switches table is empty, put "-rules" at the beginning
- ------------------------------
- -- Switches for GNAT KRUNCH --
- ------------------------------
+ if Rules_Switches.Last = 0 then
+ Rules_Switches.Increment_Last;
+ Rules_Switches.Table (Rules_Switches.Last) := new String'("-rules");
+ end if;
- S_Krunch_Count : aliased constant S := "/COUNT=#" &
- "`#";
+ Rules_Switches.Increment_Last;
+ Rules_Switches.Table (Rules_Switches.Last) := Switch;
+ end Add_To_Rules_Switches;
- Krunch_Switches : aliased constant Switches :=
- (1 .. 1 => S_Krunch_Count 'Access);
+ -----------------
+ -- Check_Files --
+ -----------------
- -------------------------------
- -- Switches for GNAT LIBRARY --
- -------------------------------
+ procedure Check_Files is
+ Add_Sources : Boolean := True;
+ Unit_Data : Prj.Unit_Data;
+ Subunit : Boolean := False;
- S_Lbr_Config : aliased constant S := "/CONFIG=@" &
- "--config=@";
-
- S_Lbr_Create : aliased constant S := "/CREATE=%" &
- "--create=%";
-
- S_Lbr_Delete : aliased constant S := "/DELETE=%" &
- "--delete=%";
-
- S_Lbr_Set : aliased constant S := "/SET=%" &
- "--set=%";
-
- Lbr_Switches : aliased constant Switches :=
- (S_Lbr_Config 'Access,
- S_Lbr_Create 'Access,
- S_Lbr_Delete 'Access,
- S_Lbr_Set 'Access);
-
- ----------------------------
- -- Switches for GNAT LINK --
- ----------------------------
-
- S_Link_Bind : aliased constant S := "/BIND_FILE=" &
- "ADA " &
- "-A " &
- "C " &
- "-C";
-
- S_Link_Debug : aliased constant S := "/DEBUG=" &
- "ALL " &
- "-g3 " &
- "NONE " &
- "-g0 " &
- "TRACEBACK " &
- "-g1 " &
- "NOTRACEBACK " &
- "-g0";
-
- S_Link_Execut : aliased constant S := "/EXECUTABLE=@" &
- "-o@";
-
- S_Link_Force : aliased constant S := "/FORCE_OBJECT_FILE_LIST " &
- "-f";
-
- S_Link_Ident : aliased constant S := "/IDENTIFICATION=" & '"' &
- "--for-linker=IDENT=" &
- '"';
-
- S_Link_Nocomp : aliased constant S := "/NOCOMPILE " &
- "-n";
-
- S_Link_Nofiles : aliased constant S := "/NOSTART_FILES " &
- "-nostartfiles";
-
- S_Link_Noinhib : aliased constant S := "/NOINHIBIT-EXEC " &
- "--for-linker=--noinhibit-exec";
-
- S_Link_Static : aliased constant S := "/STATIC " &
- "--for-linker=-static";
-
- S_Link_Verb : aliased constant S := "/VERBOSE " &
- "-v";
-
- S_Link_ZZZZZ : aliased constant S := "/<other> " &
- "--for-linker=";
-
- Link_Switches : aliased constant Switches :=
- (S_Link_Bind 'Access,
- S_Link_Debug 'Access,
- S_Link_Execut 'Access,
- S_Ext_Ref 'Access,
- S_Link_Force 'Access,
- S_Link_Ident 'Access,
- S_Link_Nocomp 'Access,
- S_Link_Nofiles 'Access,
- S_Link_Noinhib 'Access,
- S_Project_File 'Access,
- S_Project_Verb 'Access,
- S_Link_Static 'Access,
- S_Link_Verb 'Access,
- S_Link_ZZZZZ 'Access);
-
- ----------------------------
- -- Switches for GNAT LIST --
- ----------------------------
-
- S_List_All : aliased constant S := "/ALL_UNITS " &
- "-a";
-
- S_List_Current : aliased constant S := "/CURRENT_DIRECTORY " &
- "!-I-";
-
- S_List_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
- "-nostdinc";
-
- S_List_Object : aliased constant S := "/OBJECT_SEARCH=*" &
- "-aO*";
-
- S_List_Output : aliased constant S := "/OUTPUT=" &
- "SOURCES " &
- "-s " &
- "DEPEND " &
- "-d " &
- "OBJECTS " &
- "-o " &
- "UNITS " &
- "-u " &
- "OPTIONS " &
- "-h " &
- "VERBOSE " &
- "-v ";
-
- S_List_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
-
- S_List_Source : aliased constant S := "/SOURCE_SEARCH=*" &
- "-aI*";
+ begin
+ -- Check if there is at least one argument that is not a switch
- List_Switches : aliased constant Switches :=
- (S_List_All 'Access,
- S_List_Current 'Access,
- S_Ext_Ref 'Access,
- S_List_Nostinc 'Access,
- S_List_Object 'Access,
- S_List_Output 'Access,
- S_Project_File 'Access,
- S_Project_Verb 'Access,
- S_List_Search 'Access,
- S_List_Source 'Access);
+ for Index in 1 .. Last_Switches.Last loop
+ if Last_Switches.Table (Index) (1) /= '-' then
+ Add_Sources := False;
+ exit;
+ end if;
+ end loop;
- ----------------------------
- -- Switches for GNAT MAKE --
- ----------------------------
+ -- If all arguments were switches, add the path names of all the sources
+ -- of the main project.
- S_Make_Actions : aliased constant S := "/ACTIONS=" &
- "COMPILE " &
- "-c " &
- "BIND " &
- "-b " &
- "LINK " &
- "-l ";
+ if Add_Sources then
+ declare
+ Current_Last : constant Integer := Last_Switches.Last;
+ begin
+ -- Gnatstack needs to add the .ci file for the binder
+ -- generated files corresponding to all of the library projects
+ -- and main units belonging to the application.
- S_Make_All : aliased constant S := "/ALL_FILES " &
- "-a";
+ if The_Command = Stack then
+ for Proj in Project_Table.First ..
+ Project_Table.Last (Project_Tree.Projects)
+ loop
+ if Check_Project (Proj, Project) then
+ declare
+ Data : Project_Data renames
+ Project_Tree.Projects.Table (Proj);
+ Main : String_List_Id := Data.Mains;
+ File : String_Access;
- S_Make_Bind : aliased constant S := "/BINDER_QUALIFIERS=?" &
- "-bargs BIND";
+ begin
+ -- Include binder generated files for main programs
+
+ while Main /= Nil_String loop
+ File :=
+ new String'
+ (Get_Name_String (Data.Object_Directory.Name) &
+ Directory_Separator &
+ B_Start.all &
+ MLib.Fil.Ext_To
+ (Get_Name_String
+ (Project_Tree.String_Elements.Table
+ (Main).Value),
+ "ci"));
+
+ if Is_Regular_File (File.all) then
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) := File;
+ end if;
- S_Make_Comp : aliased constant S := "/COMPILER_QUALIFIERS=?" &
- "-cargs COMPILE";
-
- S_Make_Cond : aliased constant S := "/CONDITIONAL_SOURCE_SEARCH=*" &
- "-A*";
-
- S_Make_Cont : aliased constant S := "/CONTINUE_ON_ERROR " &
- "-k";
-
- S_Make_Current : aliased constant S := "/CURRENT_DIRECTORY " &
- "!-I-";
-
- S_Make_Dep : aliased constant S := "/DEPENDENCIES_LIST " &
- "-M";
-
- S_Make_Doobj : aliased constant S := "/DO_OBJECT_CHECK " &
- "-n";
-
- S_Make_Execut : aliased constant S := "/EXECUTABLE=@" &
- "-o@";
-
- S_Make_Force : aliased constant S := "/FORCE_COMPILE " &
- "-f";
-
- S_Make_Inplace : aliased constant S := "/IN_PLACE " &
- "-i";
-
- S_Make_Library : aliased constant S := "/LIBRARY_SEARCH=*" &
- "-L*";
-
- S_Make_Link : aliased constant S := "/LINKER_QUALIFIERS=?" &
- "-largs LINK";
-
- S_Make_Mapping : aliased constant S := "/MAPPING " &
- "-C";
-
- S_Make_Minimal : aliased constant S := "/MINIMAL_RECOMPILATION " &
- "-m";
-
- S_Make_Nolink : aliased constant S := "/NOLINK " &
- "-c";
-
- S_Make_Nomain : aliased constant S := "/NOMAIN " &
- "-z";
-
- S_Make_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
- "-nostdinc";
-
- S_Make_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
- "-nostdlib";
-
- S_Make_Object : aliased constant S := "/OBJECT_SEARCH=*" &
- "-aO*";
-
- S_Make_Proc : aliased constant S := "/PROCESSES=#" &
- "-j#";
-
- S_Make_Nojobs : aliased constant S := "/NOPROCESSES " &
- "-j1";
-
- S_Make_Quiet : aliased constant S := "/QUIET " &
- "-q";
-
- S_Make_Reason : aliased constant S := "/REASONS " &
- "-v";
-
- S_Make_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" &
- "--RTS=|";
-
- S_Make_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
-
- S_Make_Skip : aliased constant S := "/SKIP_MISSING=*" &
- "-aL*";
-
- S_Make_Source : aliased constant S := "/SOURCE_SEARCH=*" &
- "-aI*";
-
- S_Make_Switch : aliased constant S := "/SWITCH_CHECK " &
- "-s";
+ Main :=
+ Project_Tree.String_Elements.Table (Main).Next;
+ end loop;
- S_Make_Unique : aliased constant S := "/UNIQUE " &
- "-u";
+ if Data.Library then
- S_Make_Verbose : aliased constant S := "/VERBOSE " &
- "-v";
-
- Make_Switches : aliased constant Switches :=
- (S_Make_Actions 'Access,
- S_Make_All 'Access,
- S_Make_Bind 'Access,
- S_Make_Comp 'Access,
- S_Make_Cond 'Access,
- S_Make_Cont 'Access,
- S_Make_Current 'Access,
- S_Make_Dep 'Access,
- S_Make_Doobj 'Access,
- S_Make_Execut 'Access,
- S_Ext_Ref 'Access,
- S_Make_Force 'Access,
- S_Make_Inplace 'Access,
- S_Make_Library 'Access,
- S_Make_Link 'Access,
- S_Make_Mapping 'Access,
- S_Make_Minimal 'Access,
- S_Make_Nolink 'Access,
- S_Make_Nomain 'Access,
- S_Make_Nostinc 'Access,
- S_Make_Nostlib 'Access,
- S_Make_Object 'Access,
- S_Make_Proc 'Access,
- S_Project_File 'Access,
- S_Project_Verb 'Access,
- S_Make_Nojobs 'Access,
- S_Make_Quiet 'Access,
- S_Make_Reason 'Access,
- S_Make_RTS 'Access,
- S_Make_Search 'Access,
- S_Make_Skip 'Access,
- S_Make_Source 'Access,
- S_Make_Switch 'Access,
- S_Make_Unique 'Access,
- S_Make_Verbose 'Access);
-
- ----------------------------
- -- Switches for GNAT Name --
- ----------------------------
-
- S_Name_Conf : aliased constant S := "/CONFIG_FILE=<" &
- "-c>";
-
- S_Name_Dirs : aliased constant S := "/SOURCE_DIRS=*" &
- "-d*";
-
- S_Name_Dfile : aliased constant S := "/DIRS_FILE=<" &
- "-D>";
-
- S_Name_Help : aliased constant S := "/HELP" &
- " -h";
-
- S_Name_Proj : aliased constant S := "/PROJECT_FILE=<" &
- "-P>";
-
- S_Name_Verbose : aliased constant S := "/VERBOSE" &
- " -v";
-
- Name_Switches : aliased constant Switches :=
- (S_Name_Conf 'Access,
- S_Name_Dirs 'Access,
- S_Name_Dfile 'Access,
- S_Name_Help 'Access,
- S_Name_Proj 'Access,
- S_Name_Verbose 'Access);
+ -- Include the .ci file for the binder generated
+ -- files that contains the initialization and
+ -- finalization of the library.
- ----------------------------------
- -- Switches for GNAT PREPROCESS --
- ----------------------------------
+ File :=
+ new String'
+ (Get_Name_String (Data.Object_Directory.Name) &
+ Directory_Separator &
+ B_Start.all &
+ Get_Name_String (Data.Library_Name) &
+ ".ci");
- S_Prep_Assoc : aliased constant S := "/ASSOCIATE=" & '"' &
- "-D" & '"';
+ if Is_Regular_File (File.all) then
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) := File;
+ end if;
+ end if;
+ end;
+ end if;
+ end loop;
+ end if;
- S_Prep_Blank : aliased constant S := "/BLANK_LINES " &
- "-b";
+ for Unit in Unit_Table.First ..
+ Unit_Table.Last (Project_Tree.Units)
+ loop
+ Unit_Data := Project_Tree.Units.Table (Unit);
- S_Prep_Com : aliased constant S := "/COMMENTS " &
- "-c";
+ -- For gnatls, we only need to put the library units, body or
+ -- spec, but not the subunits.
- S_Prep_Ref : aliased constant S := "/REFERENCE " &
- "-r";
+ if The_Command = List then
+ if
+ Unit_Data.File_Names (Body_Part).Name /= No_File
+ and then
+ Unit_Data.File_Names (Body_Part).Path.Name /= Slash
+ then
+ -- There is a body, check if it is for this project
- S_Prep_Remove : aliased constant S := "/REMOVE " &
- "!-b,!-c";
+ if All_Projects or else
+ Unit_Data.File_Names (Body_Part).Project = Project
+ then
+ Subunit := False;
- S_Prep_Symbols : aliased constant S := "/SYMBOLS " &
- "-s";
+ if
+ Unit_Data.File_Names (Specification).Name = No_File
+ or else
+ Unit_Data.File_Names
+ (Specification).Path.Name = Slash
+ then
+ -- We have a body with no spec: we need to check if
+ -- this is a subunit, because gnatls will complain
+ -- about subunits.
- S_Prep_Undef : aliased constant S := "/UNDEFINED " &
- "-u";
+ declare
+ Src_Ind : Source_File_Index;
- Prep_Switches : aliased constant Switches :=
- (S_Prep_Assoc 'Access,
- S_Prep_Blank 'Access,
- S_Prep_Com 'Access,
- S_Prep_Ref 'Access,
- S_Prep_Remove 'Access,
- S_Prep_Symbols 'Access,
- S_Prep_Undef 'Access);
+ begin
+ Src_Ind := Sinput.P.Load_Project_File
+ (Get_Name_String
+ (Unit_Data.File_Names
+ (Body_Part).Path.Name));
+
+ Subunit :=
+ Sinput.P.Source_File_Is_Subunit
+ (Src_Ind);
+ end;
+ end if;
- ------------------------------
- -- Switches for GNAT SHARED --
- ------------------------------
+ if not Subunit then
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'
+ (Get_Name_String
+ (Unit_Data.File_Names
+ (Body_Part).Display_Name));
+ end if;
+ end if;
- S_Shared_Debug : aliased constant S := "/DEBUG=" &
- "ALL " &
- "-g3 " &
- "NONE " &
- "-g0 " &
- "TRACEBACK " &
- "-g1 " &
- "NOTRACEBACK " &
- "-g0";
+ elsif
+ Unit_Data.File_Names (Specification).Name /= No_File
+ and then
+ Unit_Data.File_Names (Specification).Path.Name /= Slash
+ then
+ -- We have a spec with no body; check if it is for this
+ -- project.
- S_Shared_Image : aliased constant S := "/IMAGE=@" &
- "-o@";
+ if All_Projects or else
+ Unit_Data.File_Names (Specification).Project = Project
+ then
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'
+ (Get_Name_String
+ (Unit_Data.File_Names
+ (Specification).Display_Name));
+ end if;
+ end if;
- S_Shared_Ident : aliased constant S := "/IDENTIFICATION=" & '"' &
- "--for-linker=IDENT=" &
- '"';
+ -- For gnatstack, we put the .ci files corresponding to the
+ -- different units, including the binder generated files. We
+ -- only need to do that for the library units, body or spec,
+ -- but not the subunits.
- S_Shared_Nofiles : aliased constant S := "/NOSTART_FILES " &
- "-nostartfiles";
+ elsif The_Command = Stack then
+ if
+ Unit_Data.File_Names (Body_Part).Name /= No_File
+ and then
+ Unit_Data.File_Names (Body_Part).Path.Name /= Slash
+ then
+ -- There is a body. Check if .ci files for this project
+ -- must be added.
- S_Shared_Noinhib : aliased constant S := "/NOINHIBIT-IMAGE " &
- "--for-linker=--noinhibit-exec";
+ if
+ Check_Project
+ (Unit_Data.File_Names (Body_Part).Project, Project)
+ then
+ Subunit := False;
- S_Shared_Verb : aliased constant S := "/VERBOSE " &
- "-v";
+ if
+ Unit_Data.File_Names (Specification).Name = No_File
+ or else
+ Unit_Data.File_Names
+ (Specification).Path.Name = Slash
+ then
+ -- We have a body with no spec: we need to check
+ -- if this is a subunit, because .ci files are not
+ -- generated for subunits.
- S_Shared_ZZZZZ : aliased constant S := "/<other> " &
- "--for-linker=";
+ declare
+ Src_Ind : Source_File_Index;
- 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);
+ begin
+ Src_Ind := Sinput.P.Load_Project_File
+ (Get_Name_String
+ (Unit_Data.File_Names
+ (Body_Part).Path.Name));
- --------------------------------
- -- Switches for GNAT STANDARD --
- --------------------------------
+ Subunit :=
+ Sinput.P.Source_File_Is_Subunit (Src_Ind);
+ end;
+ end if;
- Standard_Switches : aliased constant Switches := (1 .. 0 => null);
+ if not Subunit then
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'
+ (Get_Name_String
+ (Project_Tree.Projects.Table
+ (Unit_Data.File_Names
+ (Body_Part).Project).
+ Object_Directory.Name) &
+ Directory_Separator &
+ MLib.Fil.Ext_To
+ (Get_Name_String
+ (Unit_Data.File_Names
+ (Body_Part).Display_Name),
+ "ci"));
+ end if;
+ end if;
- ----------------------------
- -- Switches for GNAT STUB --
- ----------------------------
+ elsif
+ Unit_Data.File_Names (Specification).Name /= No_File
+ and then
+ Unit_Data.File_Names (Specification).Path.Name /= Slash
+ then
+ -- We have a spec with no body. Check if it is for this
+ -- project.
- S_Stub_Current : aliased constant S := "/CURRENT_DIRECTORY " &
- "!-I-";
+ if
+ Check_Project
+ (Unit_Data.File_Names (Specification).Project,
+ Project)
+ then
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'
+ (Get_Name_String
+ (Project_Tree.Projects.Table
+ (Unit_Data.File_Names
+ (Specification).Project).
+ Object_Directory.Name) &
+ Dir_Separator &
+ MLib.Fil.Ext_To
+ (Get_Name_String
+ (Unit_Data.File_Names
+ (Specification).Name),
+ "ci"));
+ end if;
+ end if;
- S_Stub_Full : aliased constant S := "/FULL " &
- "-f";
+ else
+ -- For gnatcheck, gnatsync, gnatpp and gnatmetric, put all
+ -- sources of the project, or of all projects if -U was
+ -- specified.
+
+ for Kind in Spec_Or_Body loop
+ if Check_Project
+ (Unit_Data.File_Names (Kind).Project, Project)
+ and then Unit_Data.File_Names (Kind).Name /= No_File
+ and then Unit_Data.File_Names (Kind).Path.Name /= Slash
+ then
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'
+ (Get_Name_String
+ (Unit_Data.File_Names
+ (Kind).Path.Display_Name));
+ end if;
+ end loop;
+ end if;
+ end loop;
- S_Stub_Header : aliased constant S := "/HEADER=" &
- "GENERAL " &
- "-hg " &
- "SPEC " &
- "-hs";
+ -- If the list of files is too long, create a temporary text file
+ -- that lists these files, and pass this temp file to gnatcheck,
+ -- gnatpp or gnatmetric using switch -files=.
- S_Stub_Indent : aliased constant S := "/INDENTATION=#" &
- "-i#";
+ if Last_Switches.Last - Current_Last >
+ Max_Files_On_The_Command_Line
+ then
+ declare
+ Temp_File_FD : File_Descriptor;
+ Buffer : String (1 .. 1_000);
+ Len : Natural;
+ OK : Boolean := True;
- S_Stub_Length : aliased constant S := "/LINE_LENGTH=#" &
- "-l#";
+ begin
+ Create_Temp_File (Temp_File_FD, Temp_File_Name);
+
+ if Temp_File_Name /= null then
+ for Index in Current_Last + 1 ..
+ Last_Switches.Last
+ loop
+ Len := Last_Switches.Table (Index)'Length;
+ Buffer (1 .. Len) := Last_Switches.Table (Index).all;
+ Len := Len + 1;
+ Buffer (Len) := ASCII.LF;
+ Buffer (Len + 1) := ASCII.NUL;
+ OK :=
+ Write (Temp_File_FD,
+ Buffer (1)'Address,
+ Len) = Len;
+ exit when not OK;
+ end loop;
- S_Stub_Quiet : aliased constant S := "/QUIET " &
- "-q";
+ if OK then
+ Close (Temp_File_FD, OK);
+ else
+ Close (Temp_File_FD, OK);
+ OK := False;
+ end if;
- S_Stub_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
+ -- If there were any problem creating the temp file, then
+ -- pass the list of files.
- S_Stub_Tree : aliased constant S := "/TREE_FILE=" &
- "OVERWRITE " &
- "-t " &
- "SAVE " &
- "-k " &
- "REUSE " &
- "-r";
+ if OK then
- S_Stub_Verbose : aliased constant S := "/VERBOSE " &
- "-v";
+ -- Replace list of files with -files=<temp file name>
- 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);
+ Last_Switches.Set_Last (Current_Last + 1);
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'("-files=" & Temp_File_Name.all);
+ end if;
+ end if;
+ end;
+ end if;
+ end;
+ end if;
+ end Check_Files;
- ----------------------------
- -- Switches for GNAT XREF --
- ----------------------------
+ -------------------
+ -- Check_Project --
+ -------------------
- S_Xref_All : aliased constant S := "/ALL_FILES " &
- "-a";
+ function Check_Project
+ (Project : Project_Id;
+ Root_Project : Project_Id) return Boolean
+ is
+ begin
+ if Project = No_Project then
+ return False;
- S_Xref_Deriv : aliased constant S := "/DERIVED_TYPES " &
- "-d";
+ elsif All_Projects or Project = Root_Project then
+ return True;
- S_Xref_Full : aliased constant S := "/FULL_PATHNAME " &
- "-f";
+ elsif The_Command = Metric then
+ declare
+ Data : Project_Data;
- S_Xref_Global : aliased constant S := "/IGNORE_LOCALS " &
- "-g";
+ begin
+ Data := Project_Tree.Projects.Table (Root_Project);
+ while Data.Extends /= No_Project loop
+ if Project = Data.Extends then
+ return True;
+ end if;
- S_Xref_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
- "-nostdinc";
+ Data := Project_Tree.Projects.Table (Data.Extends);
+ end loop;
+ end;
+ end if;
- S_Xref_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
- "-nostdlib";
+ return False;
+ end Check_Project;
- S_Xref_Object : aliased constant S := "/OBJECT_SEARCH=*" &
- "-aO*";
+ -------------------------------
+ -- Check_Relative_Executable --
+ -------------------------------
- S_Xref_Project : aliased constant S := "/PROJECT=@" &
- "-p@";
+ procedure Check_Relative_Executable (Name : in out String_Access) is
+ Exec_File_Name : constant String := Name.all;
- S_Xref_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
+ 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;
- S_Xref_Source : aliased constant S := "/SOURCE_SEARCH=*" &
- "-aI*";
+ Get_Name_String (Project_Tree.Projects.Table
+ (Project).Exec_Directory.Name);
- S_Xref_Output : aliased constant S := "/UNUSED " &
- "-u";
+ if Name_Buffer (Name_Len) /= Directory_Separator then
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Directory_Separator;
+ end if;
- S_Xref_Tags : aliased constant S := "/TAGS " &
- "-v";
+ 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;
- Xref_Switches : aliased constant Switches :=
- (S_Xref_All 'Access,
- S_Xref_Deriv 'Access,
- S_Ext_Ref 'Access,
- S_Xref_Full 'Access,
- S_Xref_Global 'Access,
- S_Xref_Nostinc 'Access,
- S_Xref_Nostlib 'Access,
- S_Xref_Object 'Access,
- S_Xref_Project 'Access,
- S_Project_File 'Access,
- S_Project_Verb 'Access,
- S_Xref_Search 'Access,
- S_Xref_Source 'Access,
- S_Xref_Output 'Access,
- S_Xref_Tags 'Access);
+ --------------------------------
+ -- Configuration_Pragmas_File --
+ --------------------------------
- -------------------
- -- COMMAND TABLE --
- -------------------
+ function Configuration_Pragmas_File return Path_Name_Type is
+ begin
+ Prj.Env.Create_Config_Pragmas_File
+ (Project, Project, Project_Tree, Include_Config_Files => False);
+ return Project_Tree.Projects.Table (Project).Config_File_Name;
+ end Configuration_Pragmas_File;
- -- The command table contains an entry for each command recognized by
- -- GNATCmd. The entries are represented by an array of records.
+ ------------------------------
+ -- Delete_Temp_Config_Files --
+ ------------------------------
- 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.
+ procedure Delete_Temp_Config_Files is
+ Success : Boolean;
+ pragma Warnings (Off, Success);
- Optional_File,
- -- An optional file or directory parameter.
+ begin
+ -- This should only be called if Keep_Temporary_Files is False
- Other_As_Is,
- -- A parameter that's passed through as is (not canonicalized)
+ pragma Assert (not Keep_Temporary_Files);
- Unlimited_Files,
- -- An unlimited number of whitespace separate file or directory
- -- parameters including wildcard specifications.
+ if Project /= No_Project then
+ for Prj in Project_Table.First ..
+ Project_Table.Last (Project_Tree.Projects)
+ loop
+ if
+ Project_Tree.Projects.Table (Prj).Config_File_Temp
+ then
+ if Verbose_Mode then
+ Output.Write_Str ("Deleting temp configuration file """);
+ Output.Write_Str
+ (Get_Name_String
+ (Project_Tree.Projects.Table
+ (Prj).Config_File_Name));
+ Output.Write_Line ("""");
+ end if;
- Unlimited_As_Is,
- -- Un unlimited number of whitespace separated paameters that are
- -- passed through as is (not canonicalized).
+ Delete_File
+ (Name =>
+ Get_Name_String
+ (Project_Tree.Projects.Table (Prj).Config_File_Name),
+ Success => Success);
+ end if;
+ end loop;
+ end if;
- 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.
+ -- If a temporary text file that contains a list of files for a tool
+ -- has been created, delete this temporary file.
- type Parameter_Array is array (Natural range <>) of Parameter_Type;
- type Parameter_Ref is access all Parameter_Array;
+ if Temp_File_Name /= null then
+ Delete_File (Temp_File_Name.all, Success);
+ end if;
+ end Delete_Temp_Config_Files;
- type Command_Type is
- (Bind, Chop, Compile, Elim, Find, Krunch, Library, Link, List,
- Make, Name, Preprocess, Shared, Standard, Stub, Xref, Undefined);
+ -----------------
+ -- Get_Closure --
+ -----------------
- type Alternate_Command is (Comp, Ls, Kr, Prep, Psta);
- -- Alternate command libel for non VMS system
+ procedure Get_Closure is
+ Args : constant Argument_List :=
+ (1 => new String'("-q"),
+ 2 => new String'("-b"),
+ 3 => new String'("-P"),
+ 4 => Project_File,
+ 5 => ASIS_Main,
+ 6 => new String'("-bargs"),
+ 7 => new String'("-R"),
+ 8 => new String'("-Z"));
+ -- Arguments for the invocation of gnatmake which are added to the
+ -- Last_Arguments list by this procedure.
- Corresponding_To : constant array (Alternate_Command) of Command_Type :=
- (Comp => Compile,
- Ls => List,
- Kr => Krunch,
- Prep => Preprocess,
- Psta => Standard);
- -- Mapping of alternate commands to commands
+ FD : File_Descriptor;
+ -- File descriptor for the temp file that will get the output of the
+ -- invocation of gnatmake.
- subtype Real_Command_Type is Command_Type range Bind .. Xref;
+ Name : Path_Name_Type;
+ -- Path of the file FD
- type Command_Entry is record
- Cname : String_Ptr;
- -- Command name for GNAT xxx command
+ GN_Name : constant String := Program_Name ("gnatmake", "gnat").all;
+ -- Name for gnatmake
- Usage : String_Ptr;
- -- A usage string, used for error messages
+ GN_Path : constant String_Access := Locate_Exec_On_Path (GN_Name);
+ -- Path of gnatmake
- Unixcmd : String_Ptr;
- -- Corresponding Unix command
+ Return_Code : Integer;
- Unixsws : Argument_List_Access;
- -- Switches for the Unix command
+ Unused : Boolean;
+ pragma Warnings (Off, Unused);
- VMS_Only : Boolean;
- -- When True, the command can only be used on VMS
+ File : Ada.Text_IO.File_Type;
+ Line : String (1 .. 250);
+ Last : Natural;
+ -- Used to read file if there is an error, it is good enough to display
+ -- just 250 characters if the first line of the file is very long.
- Switches : Switches_Ptr;
- -- Pointer to array of switch strings
+ Udata : Unit_Data;
+ Path : Path_Name_Type;
- 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.
+ begin
+ if GN_Path = null then
+ Put_Line (Standard_Error, "could not locate " & GN_Name);
+ raise Error_Exit;
+ end if;
- 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;
+ -- Create the temp file
- -------------------------
- -- INTERNAL STRUCTURES --
- -------------------------
+ Tempdir.Create_Temp_File (FD, Name);
- -- 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.
+ -- And close it, because on VMS Spawn with a file descriptor created
+ -- with Create_Temp_File does not redirect output.
- -- Commands, command qualifers and options have a similar common format
- -- so that searching for matching names can be done in a common manner.
+ Close (FD);
- type Item_Id is (Id_Command, Id_Switch, Id_Option);
+ -- Spawn "gnatmake -q -b -P <project> <main> -bargs -R -Z"
- type Translation_Type is
- (
- T_Direct,
- -- A qualifier with no options.
- -- Example: GNAT MAKE /VERBOSE
+ Spawn
+ (Program_Name => GN_Path.all,
+ Args => Args,
+ Output_File => Get_Name_String (Name),
+ Success => Unused,
+ Return_Code => Return_Code,
+ Err_To_Out => True);
- T_Directories,
- -- A qualifier followed by a list of directories
- -- Example: GNAT COMPILE /SEARCH=([], [.FOO], [.BAR])
+ Close (FD);
- T_Directory,
- -- A qualifier followed by one directory
- -- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB]
+ -- Read the output of the invocation of gnatmake
- T_File,
- -- A qualifier followed by a filename
- -- Example: GNAT LINK /EXECUTABLE=FOO.EXE
+ Open (File, In_File, Get_Name_String (Name));
- T_No_Space_File,
- -- A qualifier followed by a filename
- -- Example: GNAT MAKE /PROJECT_FILE=PRJ.GPR
+ -- If it was unsuccessful, display the first line in the file and exit
+ -- with error.
- T_Numeric,
- -- A qualifier followed by a numeric value.
- -- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39
+ if Return_Code /= 0 then
+ Get_Line (File, Line, Last);
- T_String,
- -- A qualifier followed by a quoted string. Only used by
- -- /IDENTIFICATION qualfier.
- -- Example: GNAT LINK /IDENTIFICATION="3.14a1 version"
+ if not Keep_Temporary_Files then
+ Delete (File);
+ else
+ Close (File);
+ end if;
- T_Options,
- -- A qualifier followed by a list of options.
- -- Example: GNAT COMPILE /REPRESENTATION_INFO=(ARRAYS,OBJECTS)
+ Put_Line (Standard_Error, Line (1 .. Last));
+ Put_Line
+ (Standard_Error, "could not get closure of " & ASIS_Main.all);
+ raise Error_Exit;
- 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
+ else
+ -- Get each file name in the file, find its path and add it the
+ -- list of arguments.
+
+ while not End_Of_File (File) loop
+ Get_Line (File, Line, Last);
+ Path := No_Path;
+
+ for Unit in Unit_Table.First ..
+ Unit_Table.Last (Project_Tree.Units)
+ loop
+ Udata := Project_Tree.Units.Table (Unit);
+
+ if Udata.File_Names (Specification).Name /= No_File
+ and then
+ Get_Name_String (Udata.File_Names (Specification).Name) =
+ Line (1 .. Last)
+ then
+ Path := Udata.File_Names (Specification).Path.Name;
+ exit;
- 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 Udata.File_Names (Body_Part).Name /= No_File
+ and then
+ Get_Name_String (Udata.File_Names (Body_Part).Name) =
+ Line (1 .. Last)
+ then
+ Path := Udata.File_Names (Body_Part).Path.Name;
+ exit;
+ end if;
+ end loop;
- 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
- );
+ Last_Switches.Increment_Last;
- type Item (Id : Item_Id);
- type Item_Ptr is access all Item;
+ if Path /= No_Path then
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'(Get_Name_String (Path));
- type Item (Id : Item_Id) is record
- Name : String_Ptr;
- -- Name of the command, switch (with slash) or option
+ else
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'(Line (1 .. Last));
+ end if;
+ end loop;
- Next : Item_Ptr;
- -- Pointer to next item on list, always has the same Id value
+ if not Keep_Temporary_Files then
+ Delete (File);
+ else
+ Close (File);
+ end if;
+ end if;
+ end Get_Closure;
- Command : Command_Type := Undefined;
+ -----------
+ -- Index --
+ -----------
- Unix_String : String_Ptr := null;
- -- Corresponding Unix string. For a command, this is the unix command
- -- name and possible default switches. For a switch or option it is
- -- the unix switch string.
+ 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;
- case Id is
+ return 0;
+ end Index;
- when Id_Command =>
+ ------------------
+ -- Process_Link --
+ ------------------
- Switches : Item_Ptr;
- -- Pointer to list of switch items for the command, linked
- -- through the Next fields with null terminating the list.
+ procedure Process_Link is
+ Look_For_Executable : Boolean := True;
+ There_Are_Libraries : Boolean := False;
+ Path_Option : constant String_Access :=
+ MLib.Linker_Library_Path_Option;
+ Prj : Project_Id := Project;
+ Arg : String_Access;
+ Last : Natural := 0;
+ Skip_Executable : Boolean := False;
- Usage : String_Ptr;
- -- Usage information, used only for errors and the default
- -- list of commands output.
+ begin
+ -- Add the default search directories, to be able to find
+ -- libgnat in call to MLib.Utl.Lib_Directory.
- Params : Parameter_Ref;
- -- Array of parameters
+ Add_Default_Search_Dirs;
- 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.
+ Library_Paths.Set_Last (0);
- when Id_Switch =>
+ -- Check if there are library project files
- 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.
+ if MLib.Tgt.Support_For_Libraries /= None then
+ Set_Libraries (Project, Project_Tree, There_Are_Libraries);
+ 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.
+ -- If there are, add the necessary additional switches
- when Id_Option =>
+ if There_Are_Libraries then
- null;
- -- No special fields needed, since Name and Unix_String are
- -- sufficient to completely described an option.
+ -- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir>
- end case;
- end record;
+ 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");
- subtype Command_Item is Item (Id_Command);
- subtype Switch_Item is Item (Id_Switch);
- subtype Option_Item is Item (Id_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.
- ----------------------------------
- -- Declarations for GNATCMD use --
- ----------------------------------
+ if Path_Option /= null then
+ declare
+ Option : String_Access;
+ Length : Natural := Path_Option'Length;
+ Current : Natural;
- 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.
+ begin
+ -- First, compute the exact length for the switch
- Last_Command : Item_Ptr;
- -- Pointer to last item in Commands list
+ for Index in
+ Library_Paths.First .. Library_Paths.Last
+ loop
+ -- Add the length of the library dir plus one for the
+ -- directory separator.
- Normal_Exit : exception;
- -- Raise this exception for normal program termination
+ Length :=
+ Length +
+ Library_Paths.Table (Index)'Length + 1;
+ end loop;
- Error_Exit : exception;
- -- Raise this exception if error detected
+ -- Finally, add the length of the standard GNAT library dir
- Errors : Natural := 0;
- -- Count errors detected
+ Length := Length + MLib.Utl.Lib_Directory'Length;
+ Option := new String (1 .. Length);
+ Option (1 .. Path_Option'Length) := Path_Option.all;
+ Current := Path_Option'Length;
- Command_Arg : Positive := 1;
+ -- Put each library dir followed by a dir separator
- Command : Item_Ptr;
- -- Pointer to command item for current command
+ 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;
- 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.
+ -- Finally put the standard GNAT library dir
- My_Exit_Status : Exit_Status := Success;
+ Option
+ (Current + 1 ..
+ Current + MLib.Utl.Lib_Directory'Length) :=
+ MLib.Utl.Lib_Directory;
- 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");
+ -- And add the switch to the last switches
- Param_Count : Natural := 0;
- -- Number of parameter arguments so far
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ Option;
+ end;
+ end if;
+ end if;
- Arg_Num : Natural;
- -- Argument number
+ -- 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.
- Display_Command : Boolean := False;
- -- Set true if /? switch causes display of generated command (on VMS)
+ Skip_Executable := False;
- The_Command : Command_Type;
- -- The command used
+ Switch_Loop : for J in 1 .. Last_Switches.Last loop
- -----------------------
- -- Local Subprograms --
- -----------------------
+ -- If we have an executable just reset the flag
- function Index (Char : Character; Str : String) return Natural;
- -- Returns the first occurrence of Char in Str.
- -- Returns 0 if Char is not in Str.
-
- function Init_Object_Dirs return Argument_List;
-
- function Invert_Sense (S : String) return String_Ptr;
- -- Given a unix switch string S, computes the inverse (adding or
- -- removing ! characters as required), and returns a pointer to
- -- the allocated result on the heap.
-
- function Is_Extensionless (F : String) return Boolean;
- -- Returns true if the filename has no extension.
-
- function Match (S1, S2 : String) return Boolean;
- -- Determines whether S1 and S2 match. This is a case insensitive match.
-
- function Match_Prefix (S1, S2 : String) return Boolean;
- -- Determines whether S1 matches a prefix of S2. This is also a case
- -- insensitive match (for example Match ("AB","abc") is True).
-
- function Matching_Name
- (S : String;
- Itm : Item_Ptr;
- Quiet : Boolean := False)
- return Item_Ptr;
- -- Determines if the item list headed by Itm and threaded through the
- -- Next fields (with null marking the end of the list), contains an
- -- entry that uniquely matches the given string. The match is case
- -- insensitive and permits unique abbreviation. If the match succeeds,
- -- then a pointer to the matching item is returned. Otherwise, an
- -- appropriate error message is written. Note that the discriminant
- -- of Itm is used to determine the appropriate form of this message.
- -- Quiet is normally False as shown, if it is set to True, then no
- -- error message is generated in a not found situation (null is still
- -- returned to indicate the not-found situation).
+ if Skip_Executable then
+ Skip_Executable := False;
- procedure Non_VMS_Usage;
- -- Display usage for platforms other than VMS
+ -- If -o, set flag so that next switch is not processed
- 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.
+ elsif Last_Switches.Table (J).all = "-o" then
+ Skip_Executable := True;
- 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.
+ -- Normal case
- procedure Output_Version;
- -- Output the version of this program
+ else
+ declare
+ Switch : constant String :=
+ Last_Switches.Table (J).all;
- procedure Place (C : Character);
- -- Place a single character in the buffer, updating Ptr
+ ALI_File : constant String (1 .. Switch'Length + 4) :=
+ Switch & ".ali";
- procedure Place (S : String);
- -- Place a string character in the buffer, updating Ptr
+ Test_Existence : Boolean := False;
- procedure Place_Lower (S : String);
- -- Place string in buffer, forcing letters to lower case, updating Ptr
+ begin
+ Last := Switch'Length;
- 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.
+ -- Skip real switches
- 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.
+ if Switch'Length /= 0
+ and then Switch (Switch'First) /= '-'
+ then
+ -- Append ".ali" if file name does not end with it
- 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.
+ if Switch'Length <= 4
+ or else Switch (Switch'Last - 3 .. Switch'Last)
+ /= ".ali"
+ then
+ Last := ALI_File'Last;
+ end if;
- 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.
+ -- If file name includes directory information, stop if ALI
+ -- file exists.
- 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.
+ if Is_Absolute_Path (ALI_File (1 .. Last)) then
+ Test_Existence := True;
- procedure VMS_Conversion (The_Command : out Command_Type);
- -- Converts VMS command line to equivalent Unix command line
+ 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;
- -----------
- -- Index --
- -----------
+ if Test_Existence then
+ if Is_Regular_File (ALI_File (1 .. Last)) then
+ exit Switch_Loop;
+ end if;
- 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;
+ -- Look in object directories if ALI file exists
- return 0;
- end Index;
-
- ----------------------
- -- Init_Object_Dirs --
- ----------------------
-
- function Init_Object_Dirs return Argument_List is
- Object_Dirs : Integer;
- Object_Dir : Argument_List (1 .. 256);
- Object_Dir_Name : String_Access;
-
- begin
- Object_Dirs := 0;
- Object_Dir_Name := String_Access (Object_Dir_Default_Name);
- Get_Next_Dir_In_Path_Init (Object_Dir_Name);
-
- loop
- declare
- Dir : String_Access := String_Access
- (Get_Next_Dir_In_Path (Object_Dir_Name));
- begin
- exit when Dir = null;
- Object_Dirs := Object_Dirs + 1;
- Object_Dir (Object_Dirs) :=
- new String'("-L" &
- To_Canonical_Dir_Spec
- (To_Host_Dir_Spec
- (Normalize_Directory_Name (Dir.all).all,
- True).all, True).all);
- end;
- end loop;
-
- Object_Dirs := Object_Dirs + 1;
- Object_Dir (Object_Dirs) := new String'("-lgnat");
-
- if Hostparm.OpenVMS then
- Object_Dirs := Object_Dirs + 1;
- Object_Dir (Object_Dirs) := new String'("-ldecgnat");
- end if;
-
- return Object_Dir (1 .. Object_Dirs);
- end Init_Object_Dirs;
-
- ------------------
- -- Invert_Sense --
- ------------------
-
- function Invert_Sense (S : String) return String_Ptr is
- Sinv : String (1 .. S'Length * 2);
- -- Result (for sure long enough)
-
- Sinvp : Natural := 0;
- -- Pointer to output string
-
- begin
- for Sp in S'Range loop
- if Sp = S'First or else S (Sp - 1) = ',' then
- if S (Sp) = '!' then
- null;
- else
- Sinv (Sinvp + 1) := '!';
- Sinv (Sinvp + 2) := S (Sp);
- Sinvp := Sinvp + 2;
- end if;
-
- else
- Sinv (Sinvp + 1) := S (Sp);
- Sinvp := Sinvp + 1;
- end if;
- end loop;
-
- return new String'(Sinv (1 .. Sinvp));
- end Invert_Sense;
-
- ----------------------
- -- Is_Extensionless --
- ----------------------
-
- function Is_Extensionless (F : String) return Boolean is
- begin
- for J in reverse F'Range loop
- if F (J) = '.' then
- return False;
- elsif F (J) = '/' or else F (J) = ']' or else F (J) = ':' then
- return True;
- end if;
- end loop;
-
- return True;
- end Is_Extensionless;
-
- -----------
- -- Match --
- -----------
-
- function Match (S1, S2 : String) return Boolean is
- Dif : constant Integer := S2'First - S1'First;
-
- begin
-
- if S1'Length /= S2'Length then
- return False;
-
- else
- for J in S1'Range loop
- if To_Lower (S1 (J)) /= To_Lower (S2 (J + Dif)) then
- return False;
- end if;
- end loop;
-
- return True;
- end if;
- end Match;
-
- ------------------
- -- Match_Prefix --
- ------------------
-
- function Match_Prefix (S1, S2 : String) return Boolean is
- begin
- if S1'Length > S2'Length then
- return False;
- else
- return Match (S1, S2 (S2'First .. S2'First + S1'Length - 1));
- end if;
- end Match_Prefix;
-
- -------------------
- -- Matching_Name --
- -------------------
-
- function Matching_Name
- (S : String;
- Itm : Item_Ptr;
- Quiet : Boolean := False)
- return Item_Ptr
- is
- P1, P2 : Item_Ptr;
-
- procedure Err;
- -- Little procedure to output command/qualifier/option as appropriate
- -- and bump error count.
-
- ---------
- -- Err --
- ---------
-
- procedure Err is
- begin
- if Quiet then
- return;
- end if;
-
- Errors := Errors + 1;
-
- if Itm /= null then
- case Itm.Id is
- when Id_Command =>
- Put (Standard_Error, "command");
-
- when Id_Switch =>
- if OpenVMS then
- Put (Standard_Error, "qualifier");
else
- Put (Standard_Error, "switch");
- end if;
-
- when Id_Option =>
- Put (Standard_Error, "option");
-
- end case;
- else
- Put (Standard_Error, "input");
-
- end if;
-
- Put (Standard_Error, ": ");
- Put (Standard_Error, S);
- end Err;
-
- -- Start of processing for Matching_Name
-
- begin
- -- If exact match, that's the one we want
-
- P1 := Itm;
- while P1 /= null loop
- if Match (S, P1.Name.all) then
- return P1;
- else
- P1 := P1.Next;
- end if;
- end loop;
-
- -- Now check for prefix matches
-
- P1 := Itm;
- while P1 /= null loop
- if P1.Name.all = "/<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;
+ Project_Loop : loop
+ declare
+ Dir : constant String :=
+ Get_Name_String
+ (Project_Tree.Projects.Table
+ (Prj).Object_Directory.Name);
+ begin
+ if Is_Regular_File
+ (Dir &
+ Directory_Separator &
+ ALI_File (1 .. Last))
+ then
+ -- We have found the correct project, so we
+ -- replace the file with the absolute path.
+
+ Last_Switches.Table (J) :=
+ new String'
+ (Dir & Directory_Separator &
+ ALI_File (1 .. Last));
+
+ -- And we are done
+
+ exit Switch_Loop;
+ end if;
+ end;
- P2 := P2.Next;
- end loop;
+ -- Go to the project being extended, if any
- Put_Line (Standard_Error, ")");
+ Prj :=
+ Project_Tree.Projects.Table (Prj).Extends;
+ exit Project_Loop when Prj = No_Project;
+ end loop Project_Loop;
end if;
-
- return null;
end if;
+ end;
+ end if;
+ end loop Switch_Loop;
- P2 := P2.Next;
- end loop;
-
- -- If we fall through that loop, then there was only one match
+ -- If a relative path output file has been specified, we add the exec
+ -- directory.
- return P1;
+ for J in reverse 1 .. Last_Switches.Last - 1 loop
+ if Last_Switches.Table (J).all = "-o" then
+ Check_Relative_Executable
+ (Name => Last_Switches.Table (J + 1));
+ Look_For_Executable := False;
+ exit;
end if;
end loop;
- -- If we fall through outer loop, there was no match
-
- if not Quiet then
- Put (Standard_Error, "unrecognized ");
- Err;
- New_Line (Standard_Error);
- end if;
-
- return null;
- end Matching_Name;
-
- -----------------------
- -- OK_Alphanumerplus --
- -----------------------
-
- function OK_Alphanumerplus (S : String) return Boolean is
- begin
- if S'Length = 0 then
- return False;
-
- else
- for J in S'Range loop
- if not (Is_Alphanumeric (S (J)) or else
- S (J) = '_' or else S (J) = '$')
- then
- return False;
+ 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;
-
- return True;
end if;
- end OK_Alphanumerplus;
- ----------------
- -- OK_Integer --
- ----------------
+ -- 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.
- function OK_Integer (S : String) return Boolean is
- begin
- if S'Length = 0 then
- return False;
-
- else
- for J in S'Range loop
- if not Is_Digit (S (J)) then
- return False;
- end if;
- end loop;
-
- return True;
- end if;
- end OK_Integer;
-
- --------------------
- -- Output_Version --
- --------------------
-
- procedure Output_Version is
- begin
- Put ("GNAT ");
- Put (Gnatvsn.Gnat_Version_String);
- Put_Line (" Copyright 1996-2002 Free Software Foundation, Inc.");
- end Output_Version;
-
- -----------
- -- Place --
- -----------
-
- procedure Place (C : Character) is
- begin
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := C;
-
- -- Do not put a space as the first character in the buffer
- if C = ' ' and then Buffer.Last = 1 then
- Buffer.Decrement_Last;
- end if;
- end Place;
-
- procedure Place (S : String) is
- begin
- for J in S'Range loop
- Place (S (J));
- end loop;
- end Place;
-
- -----------------
- -- Place_Lower --
- -----------------
-
- procedure Place_Lower (S : String) is
- begin
- for J in S'Range loop
- Place (To_Lower (S (J)));
- end loop;
- end Place_Lower;
-
- -------------------------
- -- Place_Unix_Switches --
- -------------------------
-
- procedure Place_Unix_Switches (S : String_Ptr) is
- P1, P2, P3 : Natural;
- Remove : Boolean;
- Slen : Natural;
-
- begin
- P1 := S'First;
- while P1 <= S'Last loop
- if S (P1) = '!' then
- P1 := P1 + 1;
- Remove := True;
- else
- Remove := False;
- end if;
-
- P2 := P1;
- pragma Assert (S (P1) = '-' or else S (P1) = '`');
-
- while P2 < S'Last and then S (P2 + 1) /= ',' loop
- P2 := P2 + 1;
- end loop;
-
- -- Switch is now in S (P1 .. P2)
-
- Slen := P2 - P1 + 1;
+ if Look_For_Executable then
+ for J in 1 .. Last_Switches.Last loop
+ Arg := Last_Switches.Table (J);
+ Last := 0;
- 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) = ' ')
+ if Arg'Length /= 0 and then Arg (Arg'First) /= '-' then
+ if Arg'Length > 4
+ and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali"
then
- Buffer.Table (P3 .. Buffer.Last - Slen - 1) :=
- Buffer.Table (P3 + Slen + 1 .. Buffer.Last);
- Buffer.Set_Last (Buffer.Last - Slen - 1);
+ Last := Arg'Last - 4;
- else
- P3 := P3 + 1;
+ elsif Is_Regular_File (Arg.all & ".ali") then
+ Last := Arg'Last;
end if;
- end loop;
-
- else
- Place (' ');
- if S (P1) = '`' then
- P1 := P1 + 1;
+ if Last /= 0 then
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'("-o");
+ Get_Name_String
+ (Project_Tree.Projects.Table
+ (Project).Exec_Directory.Name);
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'(Name_Buffer (1 .. Name_Len) &
+ Directory_Separator &
+ Executable_Name
+ (Base_Name (Arg (Arg'First .. Last))));
+ exit;
+ end if;
end if;
-
- Place (S (P1 .. P2));
- end if;
-
- P1 := P2 + 2;
- end loop;
- end Place_Unix_Switches;
+ end loop;
+ end if;
+ end Process_Link;
---------------------
-- Set_Library_For --
(Project : Project_Id;
There_Are_Libraries : in out Boolean)
is
+ Path_Option : constant String_Access :=
+ MLib.Linker_Library_Path_Option;
+
begin
-- Case of library project
- if Projects.Table (Project).Library then
+ if Project_Tree.Projects.Table (Project).Library then
There_Are_Libraries := True;
-- Add the -L switch
Last_Switches.Table (Last_Switches.Last) :=
new String'("-L" &
Get_Name_String
- (Projects.Table (Project).Library_Dir));
+ (Project_Tree.Projects.Table
+ (Project).Library_Dir.Name));
-- Add the -l switch
Last_Switches.Table (Last_Switches.Last) :=
new String'("-l" &
Get_Name_String
- (Projects.Table (Project).Library_Name));
-
- -- Add the Wl,-rpath switch if library non static
-
- if Projects.Table (Project).Library_Kind /= Static then
- declare
- Option : constant String_Access :=
- MLib.Tgt.Linker_Library_Path_Option
- (Get_Name_String
- (Projects.Table (Project).Library_Dir));
-
- begin
- if Option /= null then
- Last_Switches.Increment_Last;
- Last_Switches.Table (Last_Switches.Last) :=
- Option;
- end if;
-
- end;
-
+ (Project_Tree.Projects.Table
+ (Project).Library_Name));
+
+ -- Add the directory to table Library_Paths, to be processed later
+ -- if library is not static and if Path_Option is not null.
+
+ if Project_Tree.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
+ (Project_Tree.Projects.Table
+ (Project).Library_Dir.Name));
end if;
-
end if;
end Set_Library_For;
- --------------------------------
- -- Validate_Command_Or_Option --
- --------------------------------
+ ---------------------------
+ -- Test_If_Relative_Path --
+ ---------------------------
- procedure Validate_Command_Or_Option (N : String_Ptr) is
+ procedure Test_If_Relative_Path
+ (Switch : in out String_Access;
+ Parent : String)
+ is
begin
- pragma Assert (N'Length > 0);
+ if Switch /= null then
- 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;
+ declare
+ Sw : String (1 .. Switch'Length);
+ Start : Positive := 1;
- --------------------------
- -- Validate_Unix_Switch --
- --------------------------
+ begin
+ Sw := Switch.all;
- procedure Validate_Unix_Switch (S : String_Ptr) is
- begin
- if S (S'First) = '`' then
- return;
- end if;
+ if Sw (1) = '-' then
+ if Sw'Length >= 3
+ and then (Sw (2) = 'A' or else
+ Sw (2) = 'I' or else
+ Sw (2) = 'L')
+ then
+ Start := 3;
- pragma Assert (S (S'First) = '-' or else S (S'First) = '!');
+ if Sw = "-I-" then
+ return;
+ end if;
- for J in S'First + 1 .. S'Last loop
- pragma Assert (S (J) /= ' ');
+ elsif Sw'Length >= 4
+ and then (Sw (2 .. 3) = "aL" or else
+ Sw (2 .. 3) = "aO" or else
+ Sw (2 .. 3) = "aI")
+ then
+ Start := 4;
- if S (J) = '!' then
- pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-');
- null;
- end if;
- end loop;
- end Validate_Unix_Switch;
-
- ----------------------
- -- List of Commands --
- ----------------------
-
- -- Note that we put this after all the local bodies (except Non_VMS_Usage
- -- and VMS_Conversion that use Command_List) to avoid some access before
- -- elaboration problems.
-
- Command_List : constant array (Real_Command_Type) of Command_Entry :=
- (Bind =>
- (Cname => new S'("BIND"),
- Usage => new S'("GNAT BIND file[.ali] /qualifiers"),
- VMS_Only => False,
- Unixcmd => new S'("gnatbind"),
- Unixsws => null,
- Switches => Bind_Switches'Access,
- Params => new Parameter_Array'(1 => File),
- Defext => "ali"),
-
- Chop =>
- (Cname => new S'("CHOP"),
- Usage => new S'("GNAT CHOP file [directory] /qualifiers"),
- VMS_Only => False,
- Unixcmd => new S'("gnatchop"),
- Unixsws => null,
- Switches => Chop_Switches'Access,
- Params => new Parameter_Array'(1 => File, 2 => Optional_File),
- Defext => " "),
-
- Compile =>
- (Cname => new S'("COMPILE"),
- Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"),
- VMS_Only => False,
- Unixcmd => new S'("gnatmake"),
- Unixsws => new Argument_List' (1 => new String'("-f"),
- 2 => new String'("-u"),
- 3 => new String'("-c")),
- Switches => GCC_Switches'Access,
- Params => new Parameter_Array'(1 => Files_Or_Wildcard),
- Defext => " "),
-
- Elim =>
- (Cname => new S'("ELIM"),
- Usage => new S'("GNAT ELIM name /qualifiers"),
- VMS_Only => False,
- Unixcmd => new S'("gnatelim"),
- Unixsws => null,
- Switches => Elim_Switches'Access,
- Params => new Parameter_Array'(1 => Other_As_Is),
- Defext => "ali"),
-
- Find =>
- (Cname => new S'("FIND"),
- Usage => new S'("GNAT FIND pattern[:sourcefile[:line"
- & "[:column]]] filespec[,...] /qualifiers"),
- VMS_Only => False,
- Unixcmd => new S'("gnatfind"),
- Unixsws => null,
- Switches => Find_Switches'Access,
- Params => new Parameter_Array'(1 => Other_As_Is,
- 2 => Files_Or_Wildcard),
- Defext => "ali"),
-
- Krunch =>
- (Cname => new S'("KRUNCH"),
- Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"),
- VMS_Only => False,
- Unixcmd => new S'("gnatkr"),
- Unixsws => null,
- Switches => Krunch_Switches'Access,
- Params => new Parameter_Array'(1 => File),
- Defext => " "),
-
- Library =>
- (Cname => new S'("LIBRARY"),
- Usage => new S'("GNAT LIBRARY /[CREATE | SET | DELETE]"
- & "=directory [/CONFIG=file]"),
- VMS_Only => True,
- Unixcmd => new S'("gnatlbr"),
- Unixsws => null,
- Switches => Lbr_Switches'Access,
- Params => new Parameter_Array'(1 .. 0 => File),
- Defext => " "),
-
- Link =>
- (Cname => new S'("LINK"),
- Usage => new S'("GNAT LINK file[.ali]"
- & " [extra obj_&_lib_&_exe_&_opt files]"
- & " /qualifiers"),
- VMS_Only => False,
- Unixcmd => new S'("gnatlink"),
- Unixsws => null,
- Switches => Link_Switches'Access,
- Params => new Parameter_Array'(1 => Unlimited_Files),
- Defext => "ali"),
-
- List =>
- (Cname => new S'("LIST"),
- Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"),
- VMS_Only => False,
- Unixcmd => new S'("gnatls"),
- Unixsws => null,
- Switches => List_Switches'Access,
- Params => new Parameter_Array'(1 => File),
- Defext => "ali"),
-
- Make =>
- (Cname => new S'("MAKE"),
- Usage => new S'("GNAT MAKE file /qualifiers (includes "
- & "COMPILE /qualifiers)"),
- VMS_Only => False,
- Unixcmd => new S'("gnatmake"),
- Unixsws => null,
- Switches => Make_Switches'Access,
- Params => new Parameter_Array'(1 => File),
- Defext => " "),
-
- Name =>
- (Cname => new S'("NAME"),
- Usage => new S'("GNAT NAME /qualifiers naming-pattern "
- & "[naming-patterns]"),
- VMS_Only => False,
- Unixcmd => new S'("gnatname"),
- Unixsws => null,
- Switches => Name_Switches'Access,
- Params => new Parameter_Array'(1 => Unlimited_As_Is),
- Defext => " "),
-
- Preprocess =>
- (Cname => new S'("PREPROCESS"),
- Usage => new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"),
- VMS_Only => False,
- Unixcmd => new S'("gnatprep"),
- Unixsws => null,
- Switches => Prep_Switches'Access,
- Params => new Parameter_Array'(1 .. 3 => File),
- Defext => " "),
-
- Shared =>
- (Cname => new S'("SHARED"),
- Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt"
- & "files] /qualifiers"),
- VMS_Only => True,
- Unixcmd => new S'("gcc"),
- Unixsws => new Argument_List'(new String'("-shared")
- & Init_Object_Dirs),
- Switches => Shared_Switches'Access,
- Params => new Parameter_Array'(1 => Unlimited_Files),
- Defext => " "),
-
- Standard =>
- (Cname => new S'("STANDARD"),
- Usage => new S'("GNAT STANDARD"),
- VMS_Only => False,
- Unixcmd => new S'("gnatpsta"),
- Unixsws => null,
- Switches => Standard_Switches'Access,
- Params => new Parameter_Array'(1 .. 0 => File),
- Defext => " "),
-
- Stub =>
- (Cname => new S'("STUB"),
- Usage => new S'("GNAT STUB file [directory]/qualifiers"),
- VMS_Only => False,
- Unixcmd => new S'("gnatstub"),
- Unixsws => null,
- Switches => Stub_Switches'Access,
- Params => new Parameter_Array'(1 => File, 2 => Optional_File),
- Defext => " "),
-
- Xref =>
- (Cname => new S'("XREF"),
- Usage => new S'("GNAT XREF filespec[,...] /qualifiers"),
- VMS_Only => False,
- Unixcmd => new S'("gnatxref"),
- Unixsws => null,
- Switches => Xref_Switches'Access,
- Params => new Parameter_Array'(1 => Files_Or_Wildcard),
- Defext => "ali")
- );
+ elsif Sw'Length >= 7
+ and then Sw (2 .. 6) = "-RTS="
+ then
+ Start := 7;
+ else
+ return;
+ end if;
+ end if;
+
+ -- If the path is relative, test if it includes directory
+ -- information. If it does, prepend Parent to the path.
+
+ if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
+ for J in Start .. Sw'Last loop
+ if Sw (J) = Directory_Separator then
+ Switch :=
+ new String'
+ (Sw (1 .. Start - 1) &
+ Parent &
+ Directory_Separator &
+ Sw (Start .. Sw'Last));
+ return;
+ end if;
+ end loop;
+ end if;
+ end;
+ end if;
+ end Test_If_Relative_Path;
-------------------
-- Non_VMS_Usage --
for C in Command_List'Range loop
if not Command_List (C).VMS_Only then
- Put ("GNAT " & Command_List (C).Cname.all);
+ if Targparm.AAMP_On_Target then
+ Put ("gnaampcmd ");
+ else
+ Put ("gnat ");
+ end if;
+
+ Put (To_Lower (Command_List (C).Cname.all));
Set_Col (25);
- Put (Command_List (C).Unixcmd.all);
+
+ -- Never call gnatstack with a prefix
+
+ if C = Stack then
+ Put (Command_List (C).Unixcmd.all);
+ else
+ Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all);
+ end if;
declare
Sws : Argument_List_Access renames Command_List (C).Unixsws;
end loop;
New_Line;
- Put_Line ("Commands FIND, LIST and XREF accept project file " &
- "switches -vPx, -Pprj and -Xnam=val");
+ Put_Line ("Commands find, list, metric, pretty, stack, stub and xref " &
+ "accept project file switches -vPx, -Pprj and -Xnam=val");
New_Line;
end Non_VMS_Usage;
- --------------------
- -- VMS_Conversion --
- --------------------
-
- procedure VMS_Conversion (The_Command : out Command_Type) is
- begin
- Buffer.Init;
-
- -- First we must preprocess the string form of the command and options
- -- list into the internal form that we use.
-
- for C in Real_Command_Type loop
+ -------------------------------------
+ -- Start of processing for GNATCmd --
+ -------------------------------------
- declare
- Command : Item_Ptr := new Command_Item;
+begin
+ -- Initializations
- Last_Switch : Item_Ptr;
- -- Last switch in list
+ Namet.Initialize;
+ Csets.Initialize;
- begin
- -- Link new command item into list of commands
+ Snames.Initialize;
- if Last_Command = null then
- Commands := Command;
- else
- Last_Command.Next := Command;
- end if;
+ Prj.Initialize (Project_Tree);
- Last_Command := Command;
+ Last_Switches.Init;
+ Last_Switches.Set_Last (0);
- -- Fill in fields of new command item
+ First_Switches.Init;
+ First_Switches.Set_Last (0);
+ Carg_Switches.Init;
+ Carg_Switches.Set_Last (0);
+ Rules_Switches.Init;
+ Rules_Switches.Set_Last (0);
- Command.Name := Command_List (C).Cname;
- Command.Usage := Command_List (C).Usage;
- Command.Command := C;
+ VMS_Conv.Initialize;
- if Command_List (C).Unixsws = null then
- Command.Unix_String := Command_List (C).Unixcmd;
- else
- declare
- Cmd : String (1 .. 5_000);
- Last : Natural := 0;
- Sws : Argument_List_Access := Command_List (C).Unixsws;
+ Set_Mode (Ada_Only);
- begin
- Cmd (1 .. Command_List (C).Unixcmd'Length) :=
- Command_List (C).Unixcmd.all;
- Last := Command_List (C).Unixcmd'Length;
+ -- Add the default search directories, to be able to find system.ads in the
+ -- subsequent call to Targparm.Get_Target_Parameters.
- for J in Sws'Range loop
- Last := Last + 1;
- Cmd (Last) := ' ';
- Cmd (Last + 1 .. Last + Sws (J)'Length) :=
- Sws (J).all;
- Last := Last + Sws (J)'Length;
- end loop;
+ Add_Default_Search_Dirs;
- Command.Unix_String := new String'(Cmd (1 .. Last));
- end;
- end if;
+ -- Get target parameters so that AAMP_On_Target will be set, for testing in
+ -- Osint.Program_Name to handle the mapping of GNAAMP tool names.
- Command.Params := Command_List (C).Params;
- Command.Defext := Command_List (C).Defext;
+ Targparm.Get_Target_Parameters;
- Validate_Command_Or_Option (Command.Name);
+ -- Add the directory where the GNAT driver is invoked in front of the path,
+ -- if the GNAT driver is invoked with directory information. Do not do this
+ -- for VMS, where the notion of path does not really exist.
- -- Process the switch list
+ if not OpenVMS then
+ declare
+ Command : constant String := Command_Name;
- for S in Command_List (C).Switches'Range loop
+ begin
+ for Index in reverse Command'Range loop
+ if Command (Index) = Directory_Separator then
declare
- SS : constant String_Ptr := Command_List (C).Switches (S);
-
- P : Natural := SS'First;
- Sw : Item_Ptr := new Switch_Item;
+ Absolute_Dir : constant String :=
+ Normalize_Pathname
+ (Command (Command'First .. Index));
- Last_Opt : Item_Ptr;
- -- Pointer to last option
+ PATH : constant String :=
+ Absolute_Dir &
+ Path_Separator &
+ Getenv ("PATH").all;
begin
- -- Link new switch item into list of switches
-
- if Last_Switch = null then
- Command.Switches := Sw;
- else
- Last_Switch.Next := Sw;
- end if;
-
- Last_Switch := Sw;
-
- -- Process switch string, first get name
-
- while SS (P) /= ' ' and SS (P) /= '=' loop
- P := P + 1;
- end loop;
-
- Sw.Name := new String'(SS (SS'First .. P - 1));
-
- -- Direct translation case
-
- if SS (P) = ' ' then
- Sw.Translation := T_Direct;
- Sw.Unix_String := new String'(SS (P + 1 .. SS'Last));
- Validate_Unix_Switch (Sw.Unix_String);
-
- if SS (P - 1) = '>' then
- Sw.Translation := T_Other;
-
- elsif SS (P + 1) = '`' then
- null;
-
- -- Create the inverted case (/NO ..)
-
- elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then
- Sw := new Switch_Item;
- Last_Switch.Next := Sw;
- Last_Switch := Sw;
-
- Sw.Name :=
- new String'("/NO" & SS (SS'First + 1 .. P - 1));
- Sw.Translation := T_Direct;
- Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last));
- Validate_Unix_Switch (Sw.Unix_String);
- end if;
-
- -- Directories translation case
-
- elsif SS (P + 1) = '*' then
- pragma Assert (SS (SS'Last) = '*');
- Sw.Translation := T_Directories;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- Directory translation case
-
- elsif SS (P + 1) = '%' then
- pragma Assert (SS (SS'Last) = '%');
- Sw.Translation := T_Directory;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- File translation case
-
- elsif SS (P + 1) = '@' then
- pragma Assert (SS (SS'Last) = '@');
- Sw.Translation := T_File;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- No space file translation case
-
- elsif SS (P + 1) = '<' then
- pragma Assert (SS (SS'Last) = '>');
- Sw.Translation := T_No_Space_File;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- Numeric translation case
-
- elsif SS (P + 1) = '#' then
- pragma Assert (SS (SS'Last) = '#');
- Sw.Translation := T_Numeric;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- Alphanumerplus translation case
-
- elsif SS (P + 1) = '|' then
- pragma Assert (SS (SS'Last) = '|');
- Sw.Translation := T_Alphanumplus;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- String translation case
-
- elsif SS (P + 1) = '"' then
- pragma Assert (SS (SS'Last) = '"');
- Sw.Translation := T_String;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- Commands translation case
-
- elsif SS (P + 1) = '?' then
- Sw.Translation := T_Commands;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last));
-
- -- Options translation case
-
- else
- Sw.Translation := T_Options;
- Sw.Unix_String := new String'("");
-
- P := P + 1; -- bump past =
- while P <= SS'Last loop
- declare
- Opt : Item_Ptr := new Option_Item;
- Q : Natural;
-
- begin
- -- Link new option item into options list
-
- if Last_Opt = null then
- Sw.Options := Opt;
- else
- Last_Opt.Next := Opt;
- end if;
-
- Last_Opt := Opt;
-
- -- Fill in fields of new option item
-
- Q := P;
- while SS (Q) /= ' ' loop
- Q := Q + 1;
- end loop;
-
- Opt.Name := new String'(SS (P .. Q - 1));
- Validate_Command_Or_Option (Opt.Name);
-
- P := Q + 1;
- Q := P;
-
- while Q <= SS'Last and then SS (Q) /= ' ' loop
- Q := Q + 1;
- end loop;
-
- Opt.Unix_String := new String'(SS (P .. Q - 1));
- Validate_Unix_Switch (Opt.Unix_String);
- P := Q + 1;
- end;
- end loop;
- end if;
+ Setenv ("PATH", PATH);
end;
- end loop;
- end;
- end loop;
-
- -- If no parameters, give complete list of commands
- if Argument_Count = 0 then
- Output_Version;
- New_Line;
- Put_Line ("List of available commands");
- New_Line;
-
- while Commands /= null loop
- Put (Commands.Usage.all);
- Set_Col (53);
- Put_Line (Commands.Unix_String.all);
- Commands := Commands.Next;
+ exit;
+ end if;
end loop;
-
- raise Normal_Exit;
- end if;
-
- Arg_Num := 1;
-
- -- Loop through arguments
-
- while Arg_Num <= Argument_Count loop
-
- Process_Argument : declare
- Argv : String_Access;
- Arg_Idx : Integer;
-
- function Get_Arg_End
- (Argv : String;
- Arg_Idx : Integer)
- return Integer;
- -- Begins looking at Arg_Idx + 1 and returns the index of the
- -- last character before a slash or else the index of the last
- -- character in the string Argv.
-
- -----------------
- -- Get_Arg_End --
- -----------------
-
- function Get_Arg_End
- (Argv : String;
- Arg_Idx : Integer)
- return Integer
- is
- begin
- for J in Arg_Idx + 1 .. Argv'Last loop
- if Argv (J) = '/' then
- return J - 1;
- end if;
- end loop;
-
- return Argv'Last;
- end Get_Arg_End;
-
- -- Start of processing for Process_Argument
-
- begin
- Argv := new String'(Argument (Arg_Num));
- Arg_Idx := Argv'First;
-
- <<Tryagain_After_Coalesce>>
- loop
- declare
- Next_Arg_Idx : Integer;
- Arg : String_Access;
-
- begin
- Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx);
- Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx));
-
- -- The first one must be a command name
-
- if Arg_Num = 1 and then Arg_Idx = Argv'First then
-
- Command := Matching_Name (Arg.all, Commands);
-
- if Command = null then
- raise Error_Exit;
- end if;
-
- The_Command := Command.Command;
-
- -- Give usage information if only command given
-
- if Argument_Count = 1 and then Next_Arg_Idx = Argv'Last
- and then Command.Command /= Standard
- then
- Output_Version;
- New_Line;
- Put_Line
- ("List of available qualifiers and options");
- New_Line;
-
- Put (Command.Usage.all);
- Set_Col (53);
- Put_Line (Command.Unix_String.all);
-
- declare
- Sw : Item_Ptr := Command.Switches;
-
- begin
- while Sw /= null loop
- Put (" ");
- Put (Sw.Name.all);
-
- case Sw.Translation is
-
- when T_Other =>
- Set_Col (53);
- Put_Line (Sw.Unix_String.all &
- "/<other>");
-
- when T_Direct =>
- Set_Col (53);
- Put_Line (Sw.Unix_String.all);
-
- when T_Directories =>
- Put ("=(direc,direc,..direc)");
- Set_Col (53);
- Put (Sw.Unix_String.all);
- Put (" direc ");
- Put (Sw.Unix_String.all);
- Put_Line (" direc ...");
-
- when T_Directory =>
- Put ("=directory");
- Set_Col (53);
- Put (Sw.Unix_String.all);
-
- if Sw.Unix_String (Sw.Unix_String'Last)
- /= '='
- then
- Put (' ');
- end if;
-
- Put_Line ("directory ");
-
- when T_File | T_No_Space_File =>
- Put ("=file");
- Set_Col (53);
- Put (Sw.Unix_String.all);
-
- if Sw.Translation = T_File
- and then Sw.Unix_String
- (Sw.Unix_String'Last)
- /= '='
- then
- Put (' ');
- end if;
-
- Put_Line ("file ");
-
- when T_Numeric =>
- Put ("=nnn");
- Set_Col (53);
-
- if Sw.Unix_String (Sw.Unix_String'First)
- = '`'
- then
- Put (Sw.Unix_String
- (Sw.Unix_String'First + 1
- .. Sw.Unix_String'Last));
- else
- Put (Sw.Unix_String.all);
- end if;
-
- Put_Line ("nnn");
-
- when T_Alphanumplus =>
- Put ("=xyz");
- Set_Col (53);
-
- if Sw.Unix_String (Sw.Unix_String'First)
- = '`'
- then
- Put (Sw.Unix_String
- (Sw.Unix_String'First + 1
- .. Sw.Unix_String'Last));
- else
- Put (Sw.Unix_String.all);
- end if;
-
- Put_Line ("xyz");
-
- when T_String =>
- Put ("=");
- Put ('"');
- Put ("<string>");
- Put ('"');
- Set_Col (53);
-
- Put (Sw.Unix_String.all);
-
- if Sw.Unix_String (Sw.Unix_String'Last)
- /= '='
- then
- Put (' ');
- end if;
-
- Put ("<string>");
- New_Line;
-
- when T_Commands =>
- Put (" (switches for ");
- Put (Sw.Unix_String
- (Sw.Unix_String'First + 7
- .. Sw.Unix_String'Last));
- Put (')');
- Set_Col (53);
- Put (Sw.Unix_String
- (Sw.Unix_String'First
- .. Sw.Unix_String'First + 5));
- Put_Line (" switches");
-
- when T_Options =>
- declare
- Opt : Item_Ptr := Sw.Options;
-
- begin
- Put_Line ("=(option,option..)");
-
- while Opt /= null loop
- Put (" ");
- Put (Opt.Name.all);
-
- if Opt = Sw.Options then
- Put (" (D)");
- end if;
-
- Set_Col (53);
- Put_Line (Opt.Unix_String.all);
- Opt := Opt.Next;
- end loop;
- end;
-
- end case;
-
- Sw := Sw.Next;
- end loop;
- end;
-
- raise Normal_Exit;
- end if;
-
- -- Place (Command.Unix_String.all);
-
- -- Special handling for internal debugging switch /?
-
- elsif Arg.all = "/?" then
- Display_Command := True;
-
- -- Copy -switch unchanged
-
- elsif Arg (Arg'First) = '-' then
- Place (' ');
- Place (Arg.all);
-
- -- Copy quoted switch with quotes stripped
-
- elsif Arg (Arg'First) = '"' then
- if Arg (Arg'Last) /= '"' then
- Put (Standard_Error, "misquoted argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- else
- Place (' ');
- Place (Arg (Arg'First + 1 .. Arg'Last - 1));
- end if;
-
- -- Parameter Argument
-
- elsif Arg (Arg'First) /= '/'
- and then Make_Commands_Active = null
- then
- Param_Count := Param_Count + 1;
-
- if Param_Count <= Command.Params'Length then
-
- case Command.Params (Param_Count) is
-
- when File | Optional_File =>
- declare
- Normal_File : String_Access
- := To_Canonical_File_Spec (Arg.all);
- begin
- Place (' ');
- Place_Lower (Normal_File.all);
-
- if Is_Extensionless (Normal_File.all)
- and then Command.Defext /= " "
- then
- Place ('.');
- Place (Command.Defext);
- end if;
- end;
-
- when Unlimited_Files =>
- declare
- Normal_File : String_Access
- := To_Canonical_File_Spec (Arg.all);
-
- File_Is_Wild : Boolean := False;
- File_List : String_Access_List_Access;
- begin
- for I in Arg'Range loop
- if Arg (I) = '*'
- or else Arg (I) = '%'
- then
- File_Is_Wild := True;
- end if;
- end loop;
-
- if File_Is_Wild then
- File_List := To_Canonical_File_List
- (Arg.all, False);
-
- for I in File_List.all'Range loop
- Place (' ');
- Place_Lower (File_List.all (I).all);
- end loop;
- else
- Place (' ');
- Place_Lower (Normal_File.all);
-
- if Is_Extensionless (Normal_File.all)
- and then Command.Defext /= " "
- then
- Place ('.');
- Place (Command.Defext);
- end if;
- end if;
-
- Param_Count := Param_Count - 1;
- end;
-
- when Other_As_Is =>
- Place (' ');
- Place (Arg.all);
-
- when Unlimited_As_Is =>
- Place (' ');
- Place (Arg.all);
- Param_Count := Param_Count - 1;
-
- when Files_Or_Wildcard =>
-
- -- Remove spaces from a comma separated list
- -- of file names and adjust control variables
- -- accordingly.
-
- while Arg_Num < Argument_Count and then
- (Argv (Argv'Last) = ',' xor
- Argument (Arg_Num + 1)
- (Argument (Arg_Num + 1)'First) = ',')
- loop
- Argv := new String'
- (Argv.all & Argument (Arg_Num + 1));
- Arg_Num := Arg_Num + 1;
- Arg_Idx := Argv'First;
- Next_Arg_Idx :=
- Get_Arg_End (Argv.all, Arg_Idx);
- Arg := new String'
- (Argv (Arg_Idx .. Next_Arg_Idx));
- end loop;
-
- -- Parse the comma separated list of VMS
- -- filenames and place them on the command
- -- line as space separated Unix style
- -- filenames. Lower case and add default
- -- extension as appropriate.
-
- declare
- Arg1_Idx : Integer := Arg'First;
-
- function Get_Arg1_End
- (Arg : String; Arg_Idx : Integer)
- return Integer;
- -- Begins looking at Arg_Idx + 1 and
- -- returns the index of the last character
- -- before a comma or else the index of the
- -- last character in the string Arg.
-
- function Get_Arg1_End
- (Arg : String; Arg_Idx : Integer)
- return Integer
- is
- begin
- for I in Arg_Idx + 1 .. Arg'Last loop
- if Arg (I) = ',' then
- return I - 1;
- end if;
- end loop;
-
- return Arg'Last;
- end Get_Arg1_End;
-
- begin
- loop
- declare
- Next_Arg1_Idx : Integer :=
- Get_Arg1_End (Arg.all, Arg1_Idx);
-
- Arg1 : String :=
- Arg (Arg1_Idx .. Next_Arg1_Idx);
-
- Normal_File : String_Access :=
- To_Canonical_File_Spec (Arg1);
-
- begin
- Place (' ');
- Place_Lower (Normal_File.all);
-
- if Is_Extensionless (Normal_File.all)
- and then Command.Defext /= " "
- then
- Place ('.');
- Place (Command.Defext);
- end if;
-
- Arg1_Idx := Next_Arg1_Idx + 1;
- end;
-
- exit when Arg1_Idx > Arg'Last;
-
- -- Don't allow two or more commas in
- -- a row
-
- if Arg (Arg1_Idx) = ',' then
- Arg1_Idx := Arg1_Idx + 1;
- if Arg1_Idx > Arg'Last or else
- Arg (Arg1_Idx) = ','
- then
- Put_Line
- (Standard_Error,
- "Malformed Parameter: " &
- Arg.all);
- Put (Standard_Error, "usage: ");
- Put_Line (Standard_Error,
- Command.Usage.all);
- raise Error_Exit;
- end if;
- end if;
-
- end loop;
- end;
- end case;
- end if;
-
- -- Qualifier argument
-
- else
- declare
- Sw : Item_Ptr;
- SwP : Natural;
- P2 : Natural;
- Endp : Natural := 0; -- avoid warning!
- Opt : Item_Ptr;
-
- begin
- SwP := Arg'First;
- while SwP < Arg'Last
- and then Arg (SwP + 1) /= '='
- loop
- SwP := SwP + 1;
- end loop;
-
- -- At this point, the switch name is in
- -- Arg (Arg'First..SwP) and if that is not the
- -- whole switch, then there is an equal sign at
- -- Arg (SwP + 1) and the rest of Arg is what comes
- -- after the equal sign.
-
- -- If make commands are active, see if we have
- -- another COMMANDS_TRANSLATION switch belonging
- -- to gnatmake.
-
- if Make_Commands_Active /= null then
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Command.Switches,
- Quiet => True);
-
- if Sw /= null
- and then Sw.Translation = T_Commands
- then
- null;
-
- else
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Make_Commands_Active.Switches,
- Quiet => False);
- end if;
-
- -- For case of GNAT MAKE or CHOP, if we cannot
- -- find the switch, then see if it is a
- -- recognized compiler switch instead, and if
- -- so process the compiler switch.
-
- elsif Command.Name.all = "MAKE"
- or else Command.Name.all = "CHOP" then
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Command.Switches,
- Quiet => True);
-
- if Sw = null then
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Matching_Name
- ("COMPILE", Commands).Switches,
- Quiet => False);
- end if;
-
- -- For all other cases, just search the relevant
- -- command.
-
- else
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Command.Switches,
- Quiet => False);
- end if;
-
- if Sw /= null then
- case Sw.Translation is
-
- when T_Direct =>
- Place_Unix_Switches (Sw.Unix_String);
- if SwP < Arg'Last
- and then Arg (SwP + 1) = '='
- then
- Put (Standard_Error,
- "qualifier options ignored: ");
- Put_Line (Standard_Error, Arg.all);
- end if;
-
- when T_Directories =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error,
- "missing directories for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- elsif Arg (SwP + 2) /= '(' then
- SwP := SwP + 2;
- Endp := Arg'Last;
-
- elsif Arg (Arg'Last) /= ')' then
-
- -- Remove spaces from a comma separated
- -- list of file names and adjust
- -- control variables accordingly.
-
- if Arg_Num < Argument_Count and then
- (Argv (Argv'Last) = ',' xor
- Argument (Arg_Num + 1)
- (Argument (Arg_Num + 1)'First) = ',')
- then
- Argv :=
- new String'(Argv.all
- & Argument
- (Arg_Num + 1));
- Arg_Num := Arg_Num + 1;
- Arg_Idx := Argv'First;
- Next_Arg_Idx
- := Get_Arg_End (Argv.all, Arg_Idx);
- Arg := new String'
- (Argv (Arg_Idx .. Next_Arg_Idx));
- goto Tryagain_After_Coalesce;
- end if;
-
- Put (Standard_Error,
- "incorrectly parenthesized " &
- "or malformed argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- else
- SwP := SwP + 3;
- Endp := Arg'Last - 1;
- end if;
-
- while SwP <= Endp loop
- declare
- Dir_Is_Wild : Boolean := False;
- Dir_Maybe_Is_Wild : Boolean := False;
- Dir_List : String_Access_List_Access;
- begin
- P2 := SwP;
-
- while P2 < Endp
- and then Arg (P2 + 1) /= ','
- loop
-
- -- A wildcard directory spec on
- -- VMS will contain either * or
- -- % or ...
-
- if Arg (P2) = '*' then
- Dir_Is_Wild := True;
-
- elsif Arg (P2) = '%' then
- Dir_Is_Wild := True;
-
- elsif Dir_Maybe_Is_Wild
- and then Arg (P2) = '.'
- and then Arg (P2 + 1) = '.'
- then
- Dir_Is_Wild := True;
- Dir_Maybe_Is_Wild := False;
-
- elsif Dir_Maybe_Is_Wild then
- Dir_Maybe_Is_Wild := False;
-
- elsif Arg (P2) = '.'
- and then Arg (P2 + 1) = '.'
- then
- Dir_Maybe_Is_Wild := True;
-
- end if;
-
- P2 := P2 + 1;
- end loop;
-
- if (Dir_Is_Wild) then
- Dir_List := To_Canonical_File_List
- (Arg (SwP .. P2), True);
-
- for I in Dir_List.all'Range loop
- Place_Unix_Switches
- (Sw.Unix_String);
- Place_Lower
- (Dir_List.all (I).all);
- end loop;
- else
- Place_Unix_Switches
- (Sw.Unix_String);
- Place_Lower
- (To_Canonical_Dir_Spec
- (Arg (SwP .. P2), False).all);
- end if;
-
- SwP := P2 + 2;
- end;
- end loop;
-
- when T_Directory =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error,
- "missing directory for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- else
- Place_Unix_Switches (Sw.Unix_String);
-
- -- Some switches end in "=". No space
- -- here
-
- if Sw.Unix_String
- (Sw.Unix_String'Last) /= '='
- then
- Place (' ');
- end if;
-
- Place_Lower
- (To_Canonical_Dir_Spec
- (Arg (SwP + 2 .. Arg'Last),
- False).all);
- end if;
-
- when T_File | T_No_Space_File =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error,
- "missing file for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- else
- Place_Unix_Switches (Sw.Unix_String);
-
- -- Some switches end in "=". No space
- -- here.
-
- if Sw.Translation = T_File
- and then Sw.Unix_String
- (Sw.Unix_String'Last) /= '='
- then
- Place (' ');
- end if;
-
- Place_Lower
- (To_Canonical_File_Spec
- (Arg (SwP + 2 .. Arg'Last)).all);
- end if;
-
- when T_Numeric =>
- if
- OK_Integer (Arg (SwP + 2 .. Arg'Last))
- then
- Place_Unix_Switches (Sw.Unix_String);
- Place (Arg (SwP + 2 .. Arg'Last));
-
- else
- Put (Standard_Error, "argument for ");
- Put (Standard_Error, Sw.Name.all);
- Put_Line
- (Standard_Error, " must be numeric");
- Errors := Errors + 1;
- end if;
-
- when T_Alphanumplus =>
- if
- OK_Alphanumerplus
- (Arg (SwP + 2 .. Arg'Last))
- then
- Place_Unix_Switches (Sw.Unix_String);
- Place (Arg (SwP + 2 .. Arg'Last));
-
- else
- Put (Standard_Error, "argument for ");
- Put (Standard_Error, Sw.Name.all);
- Put_Line (Standard_Error,
- " must be alphanumeric");
- Errors := Errors + 1;
- end if;
-
- when T_String =>
-
- -- A String value must be extended to the
- -- end of the Argv, otherwise strings like
- -- "foo/bar" get split at the slash.
- --
- -- The begining and ending of the string
- -- are flagged with embedded nulls which
- -- are removed when building the Spawn
- -- call. Nulls are use because they won't
- -- show up in a /? output. Quotes aren't
- -- used because that would make it
- -- difficult to embed them.
-
- Place_Unix_Switches (Sw.Unix_String);
- if Next_Arg_Idx /= Argv'Last then
- Next_Arg_Idx := Argv'Last;
- Arg := new String'
- (Argv (Arg_Idx .. Next_Arg_Idx));
-
- SwP := Arg'First;
- while SwP < Arg'Last and then
- Arg (SwP + 1) /= '=' loop
- SwP := SwP + 1;
- end loop;
- end if;
- Place (ASCII.NUL);
- Place (Arg (SwP + 2 .. Arg'Last));
- Place (ASCII.NUL);
-
- when T_Commands =>
-
- -- Output -largs/-bargs/-cargs
-
- Place (' ');
- Place (Sw.Unix_String
- (Sw.Unix_String'First ..
- Sw.Unix_String'First + 5));
-
- -- Set source of new commands, also
- -- setting this non-null indicates that
- -- we are in the special commands mode
- -- for processing the -xargs case.
-
- Make_Commands_Active :=
- Matching_Name
- (Sw.Unix_String
- (Sw.Unix_String'First + 7 ..
- Sw.Unix_String'Last),
- Commands);
-
- when T_Options =>
- if SwP + 1 > Arg'Last then
- Place_Unix_Switches
- (Sw.Options.Unix_String);
- SwP := Endp + 1;
-
- elsif Arg (SwP + 2) /= '(' then
- SwP := SwP + 2;
- Endp := Arg'Last;
-
- elsif Arg (Arg'Last) /= ')' then
- Put
- (Standard_Error,
- "incorrectly parenthesized " &
- "argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
- SwP := Endp + 1;
-
- else
- SwP := SwP + 3;
- Endp := Arg'Last - 1;
- end if;
-
- while SwP <= Endp loop
- P2 := SwP;
-
- while P2 < Endp
- and then Arg (P2 + 1) /= ','
- loop
- P2 := P2 + 1;
- end loop;
-
- -- Option name is in Arg (SwP .. P2)
-
- Opt := Matching_Name (Arg (SwP .. P2),
- Sw.Options);
-
- if Opt /= null then
- Place_Unix_Switches
- (Opt.Unix_String);
- end if;
-
- SwP := P2 + 2;
- end loop;
-
- when T_Other =>
- Place_Unix_Switches
- (new String'(Sw.Unix_String.all &
- Arg.all));
-
- end case;
- end if;
- end;
- end if;
-
- Arg_Idx := Next_Arg_Idx + 1;
- end;
-
- exit when Arg_Idx > Argv'Last;
-
- end loop;
- end Process_Argument;
-
- Arg_Num := Arg_Num + 1;
- end loop;
-
- if Display_Command then
- Put (Standard_Error, "generated command -->");
- Put (Standard_Error, Command_List (The_Command).Unixcmd.all);
-
- if Command_List (The_Command).Unixsws /= null then
- for J in Command_List (The_Command).Unixsws'Range loop
- Put (Standard_Error, " ");
- Put (Standard_Error,
- Command_List (The_Command).Unixsws (J).all);
- end loop;
- end if;
-
- Put (Standard_Error, " ");
- Put (Standard_Error, String (Buffer.Table (1 .. Buffer.Last)));
- Put (Standard_Error, "<--");
- New_Line (Standard_Error);
- raise Normal_Exit;
- end if;
-
- -- Gross error checking that the number of parameters is correct.
- -- Not applicable to Unlimited_Files parameters.
-
- if (Param_Count = Command.Params'Length - 1
- and then Command.Params (Param_Count + 1) = Unlimited_Files)
- or else Param_Count <= Command.Params'Length
- then
- null;
-
- else
- Put_Line (Standard_Error,
- "Parameter count of "
- & Integer'Image (Param_Count)
- & " not equal to expected "
- & Integer'Image (Command.Params'Length));
- Put (Standard_Error, "usage: ");
- Put_Line (Standard_Error, Command.Usage.all);
- Errors := Errors + 1;
- end if;
-
- if Errors > 0 then
- raise Error_Exit;
- else
- -- Prepare arguments for a call to spawn, filtering out
- -- embedded nulls place there to delineate strings.
-
- declare
- P1, P2 : Natural;
- Inside_Nul : Boolean := False;
- Arg : String (1 .. 1024);
- Arg_Ctr : Natural;
-
- begin
- P1 := 1;
-
- while P1 <= Buffer.Last and then Buffer.Table (P1) = ' ' loop
- P1 := P1 + 1;
- end loop;
-
- Arg_Ctr := 1;
- Arg (Arg_Ctr) := Buffer.Table (P1);
-
- while P1 <= Buffer.Last loop
-
- if Buffer.Table (P1) = ASCII.NUL then
- if Inside_Nul then
- Inside_Nul := False;
- else
- Inside_Nul := True;
- end if;
- end if;
-
- if Buffer.Table (P1) = ' ' and then not Inside_Nul then
- P1 := P1 + 1;
- Arg_Ctr := Arg_Ctr + 1;
- Arg (Arg_Ctr) := Buffer.Table (P1);
-
- else
- Last_Switches.Increment_Last;
- P2 := P1;
-
- while P2 < Buffer.Last
- and then (Buffer.Table (P2 + 1) /= ' ' or else
- Inside_Nul)
- loop
- P2 := P2 + 1;
- Arg_Ctr := Arg_Ctr + 1;
- Arg (Arg_Ctr) := Buffer.Table (P2);
- if Buffer.Table (P2) = ASCII.NUL then
- Arg_Ctr := Arg_Ctr - 1;
- if Inside_Nul then
- Inside_Nul := False;
- else
- Inside_Nul := True;
- end if;
- end if;
- end loop;
-
- Last_Switches.Table (Last_Switches.Last) :=
- new String'(String (Arg (1 .. Arg_Ctr)));
- P1 := P2 + 2;
- Arg_Ctr := 1;
- Arg (Arg_Ctr) := Buffer.Table (P1);
- end if;
- end loop;
- end;
- end if;
- end VMS_Conversion;
-
- -------------------------------------
- -- Start of processing for GNATCmd --
- -------------------------------------
-
-begin
- -- Initializations
-
- Namet.Initialize;
- Csets.Initialize;
-
- Snames.Initialize;
-
- Prj.Initialize;
-
- Last_Switches.Init;
- Last_Switches.Set_Last (0);
-
- First_Switches.Init;
- First_Switches.Set_Last (0);
+ end;
+ end if;
-- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers,
-- filenames and pathnames to Unix style.
then
VMS_Conversion (The_Command);
+ B_Start := new String'("b__");
+
-- If not on VMS, scan the command line directly
else
return;
else
begin
- if Argument_Count > 1 and then Argument (1) = "-v" then
- Opt.Verbose_Mode := True;
- Command_Arg := 2;
- end if;
+ loop
+ if Argument_Count > Command_Arg
+ and then Argument (Command_Arg) = "-v"
+ then
+ Verbose_Mode := True;
+ Command_Arg := Command_Arg + 1;
+
+ elsif Argument_Count > Command_Arg
+ and then Argument (Command_Arg) = "-dn"
+ then
+ Keep_Temporary_Files := True;
+ Command_Arg := Command_Arg + 1;
+
+ else
+ exit;
+ end if;
+ end loop;
The_Command := Real_Command_Type'Value (Argument (Command_Arg));
if Command_List (The_Command).VMS_Only then
Non_VMS_Usage;
- Fail ("Command """ & Command_List (The_Command).Cname.all &
- """ can only be used on VMS");
+ Fail
+ ("Command """,
+ Command_List (The_Command).Cname.all,
+ """ can only be used on VMS");
end if;
+
exception
when Constraint_Error =>
-- Check if it is an alternate command
+
declare
Alternate : Alternate_Command;
exception
when Constraint_Error =>
Non_VMS_Usage;
- Fail ("Unknown command: " & Argument (Command_Arg));
+ Fail ("Unknown command: ", Argument (Command_Arg));
end;
end;
+ -- Get the arguments from the command line and from the eventual
+ -- argument file(s) specified on the command line.
+
for Arg in Command_Arg + 1 .. Argument_Count loop
- Last_Switches.Increment_Last;
- Last_Switches.Table (Last_Switches.Last) :=
- new String'(Argument (Arg));
+ declare
+ The_Arg : constant String := Argument (Arg);
+
+ begin
+ -- Check if an argument file is specified
+
+ if The_Arg (The_Arg'First) = '@' then
+ declare
+ Arg_File : Ada.Text_IO.File_Type;
+ Line : String (1 .. 256);
+ Last : Natural;
+
+ begin
+ -- Open the file and fail if the file cannot be found
+
+ 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;
+
+ -- Read line by line and put the content of each non-
+ -- empty line in the Last_Switches table.
+
+ while not End_Of_File (Arg_File) loop
+ Get_Line (Arg_File, Line, Last);
+
+ if Last /= 0 then
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'(Line (1 .. Last));
+ end if;
+ end loop;
+
+ Close (Arg_File);
+ end;
+
+ else
+ -- It is not an argument file; just put the argument in
+ -- the Last_Switches table.
+
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'(The_Arg);
+ end if;
+ end;
end loop;
end if;
end if;
declare
- Program : constant String :=
- Program_Name (Command_List (The_Command).Unixcmd.all).all;
-
+ Program : String_Access;
Exec_Path : String_Access;
begin
+ if The_Command = Stack then
+ -- Never call gnatstack with a prefix
+
+ Program := new String'(Command_List (The_Command).Unixcmd.all);
+
+ else
+ Program :=
+ Program_Name (Command_List (The_Command).Unixcmd.all, "gnat");
+ end if;
+
-- Locate the executable for the command
- Exec_Path := Locate_Exec_On_Path (Program);
+ Exec_Path := Locate_Exec_On_Path (Program.all);
if Exec_Path = null then
- Put_Line (Standard_Error, "Couldn't locate " & Program);
+ Put_Line (Standard_Error, "could not locate " & Program.all);
raise Error_Exit;
end if;
end loop;
end if;
- -- For BIND, FIND, LINK, LIST and XREF, look for project file related
- -- switches.
+ -- For BIND, CHECK, ELIM, FIND, LINK, LIST, PRETTY, STACK, STUB,
+ -- METRIC ad XREF, look for project file related switches.
if The_Command = Bind
+ or else The_Command = Check
+ or else The_Command = Sync
+ 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 = Stack
+ or else The_Command = Stub
+ or else The_Command = Metric
then
case The_Command is
when Bind =>
Tool_Package_Name := Name_Binder;
+ Packages_To_Check := Packages_To_Check_By_Binder;
+ when Check =>
+ Tool_Package_Name := Name_Check;
+ Packages_To_Check := Packages_To_Check_By_Check;
+ when Sync =>
+ Tool_Package_Name := Name_Synchronize;
+ Packages_To_Check := Packages_To_Check_By_Sync;
+ 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 Metric =>
+ Tool_Package_Name := Name_Metrics;
+ Packages_To_Check := Packages_To_Check_By_Metric;
+ when Pretty =>
+ Tool_Package_Name := Name_Pretty_Printer;
+ Packages_To_Check := Packages_To_Check_By_Pretty;
+ when Stack =>
+ Tool_Package_Name := Name_Stack;
+ Packages_To_Check := Packages_To_Check_By_Stack;
+ when Stub =>
+ Tool_Package_Name := Name_Gnatstub;
+ Packages_To_Check := Packages_To_Check_By_Gnatstub;
when Xref =>
Tool_Package_Name := Name_Cross_Reference;
+ Packages_To_Check := Packages_To_Check_By_Xref;
when others =>
null;
end case;
+ -- Check that the switches are consistent. Detect project file
+ -- related switches.
+
+ Inspect_Switches :
declare
Arg_Num : Positive := 1;
Argv : String_Access;
Last_Switches.Decrement_Last;
end Remove_Switch;
- -- Start of processing for ??? (need block name here)
+ -- Start of processing for Inspect_Switches
begin
while Arg_Num <= Last_Switches.Last loop
if Argv (Argv'First) = '-' then
if Argv'Length = 1 then
- Fail ("switch character cannot be followed by a blank");
+ Fail
+ ("switch character cannot be followed by a blank");
end if;
-- The two style project files (-p and -P) cannot be used
end if;
end if;
+ -- --subdirs=... Specify Subdirs
+
+ if Argv'Length > Subdirs_Option'Length and then
+ Argv
+ (Argv'First .. Argv'First + Subdirs_Option'Length - 1) =
+ Subdirs_Option
+ then
+ Subdirs :=
+ new String'
+ (Argv
+ (Argv'First + Subdirs_Option'Length .. Argv'Last));
+
+ Remove_Switch (Arg_Num);
+
+ -- -aPdir Add dir to the project search path
+
+ elsif Argv'Length > 3
+ and then Argv (Argv'First + 1 .. Argv'First + 2) = "aP"
+ then
+ Add_Search_Project_Directory
+ (Argv (Argv'First + 3 .. Argv'Last));
+
+ Remove_Switch (Arg_Num);
+
+ -- -eL Follow links for files
+
+ elsif Argv.all = "-eL" then
+ Follow_Links_For_Files := True;
+
+ Remove_Switch (Arg_Num);
+
-- -vPx Specify verbosity while parsing project files
- if Argv'Length = 4
+ elsif Argv'Length = 4
and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
then
case Argv (Argv'Last) is
when '2' =>
Current_Verbosity := Prj.High;
when others =>
- Fail ("Invalid switch: " & Argv.all);
+ Fail ("Invalid switch: ", Argv.all);
end case;
Remove_Switch (Arg_Num);
-- -Pproject_file Specify project file to be used
- elsif Argv'Length >= 3
- and then Argv (Argv'First + 1) = 'P'
- then
+ elsif Argv (Argv'First + 1) = 'P' then
-- Only one -P switch can be used
if Project_File /= null then
- Fail (Argv.all &
- ": second project file forbidden (first is """ &
- Project_File.all & """)");
+ Fail
+ (Argv.all,
+ ": second project file forbidden (first is """,
+ Project_File.all & """)");
-- The two style project files (-p and -P) cannot be
-- used together.
elsif Old_Project_File_Used then
Fail ("-p and -P cannot be used together");
+ elsif Argv'Length = 2 then
+
+ -- There is space between -P and the project file
+ -- name. -P cannot be the last option.
+
+ if Arg_Num = Last_Switches.Last then
+ Fail ("project file name missing after -P");
+
+ else
+ Remove_Switch (Arg_Num);
+ Argv := Last_Switches.Table (Arg_Num);
+
+ -- After -P, there must be a project file name,
+ -- not another switch.
+
+ if Argv (Argv'First) = '-' then
+ Fail ("project file name missing after -P");
+
+ else
+ Project_File := new String'(Argv.all);
+ end if;
+ end if;
+
else
+ -- No space between -P and project file name
+
Project_File :=
new String'(Argv (Argv'First + 2 .. Argv'Last));
end if;
then
declare
Equal_Pos : constant Natural :=
- Index ('=', Argv (Argv'First + 2 .. Argv'Last));
+ Index
+ ('=',
+ Argv (Argv'First + 2 .. Argv'Last));
begin
if Equal_Pos >= Argv'First + 3 and then
Equal_Pos /= Argv'Last then
Argv (Argv'First + 2 .. Equal_Pos - 1),
Value => Argv (Equal_Pos + 1 .. Argv'Last));
else
- Fail (Argv.all &
- " is not a valid external assignment.");
+ Fail
+ (Argv.all,
+ " is not a valid external assignment.");
end if;
end;
Remove_Switch (Arg_Num);
+ elsif
+ (The_Command = Check or else
+ The_Command = Sync or else
+ The_Command = Pretty or else
+ The_Command = Metric or else
+ The_Command = Stack or else
+ The_Command = List)
+ and then Argv'Length = 2
+ and then Argv (2) = 'U'
+ then
+ All_Projects := True;
+ Remove_Switch (Arg_Num);
+
else
Arg_Num := Arg_Num + 1;
end if;
+ elsif ((The_Command = Check and then Argv (Argv'First) /= '+')
+ or else The_Command = Sync
+ or else The_Command = Metric
+ or else The_Command = Pretty)
+ and then Project_File /= null
+ and then All_Projects
+ then
+ if ASIS_Main /= null then
+ Fail ("cannot specify more than one main after -U");
+ else
+ ASIS_Main := Argv;
+ Remove_Switch (Arg_Num);
+ end if;
+
else
Arg_Num := Arg_Num + 1;
end if;
end loop;
- end;
+ end Inspect_Switches;
end if;
-- If there is a project file specified, parse it, get the switches
Prj.Pars.Parse
(Project => Project,
- Project_File_Name => Project_File.all);
+ In_Tree => Project_Tree,
+ Project_File_Name => Project_File.all,
+ Packages_To_Check => Packages_To_Check);
if Project = Prj.No_Project then
- Fail ("""" & Project_File.all & """ processing failed");
+ Fail ("""", Project_File.all, """ processing failed");
end if;
-- Check if a package with the name of the tool is in the project
-- file and if there is one, get the switches, if any, and scan them.
declare
- Data : Prj.Project_Data := Prj.Projects.Table (Project);
- Pkg : Prj.Package_Id :=
- Prj.Util.Value_Of
- (Name => Tool_Package_Name,
- In_Packages => Data.Decl.Packages);
+ Data : constant Prj.Project_Data :=
+ Project_Tree.Projects.Table (Project);
+
+ Pkg : constant Prj.Package_Id :=
+ Prj.Util.Value_Of
+ (Name => Tool_Package_Name,
+ In_Packages => Data.Decl.Packages,
+ In_Tree => Project_Tree);
Element : Package_Element;
begin
if Pkg /= No_Package then
- Element := Packages.Table (Pkg);
+ Element := Project_Tree.Packages.Table (Pkg);
- -- Packages Gnatls has a single attribute Switches, that is
- -- not an associative array.
+ -- Packages Gnatls and Gnatstack have a single attribute
+ -- Switches, that is not an associative array.
- if The_Command = List then
+ if The_Command = List or else The_Command = Stack then
The_Switches :=
Prj.Util.Value_Of
(Variable_Name => Snames.Name_Switches,
- In_Variables => Element.Decl.Attributes);
+ In_Variables => Element.Decl.Attributes,
+ In_Tree => Project_Tree);
-- Packages Binder (for gnatbind), Cross_Reference (for
- -- gnatxref), Linker (for gnatlink) and Finder
- -- (for gnatfind) have an attributed Default_Switches,
- -- an associative array, indexed by the name of the
- -- programming language.
- else
- Default_Switches_Array :=
- Prj.Util.Value_Of
- (Name => Name_Default_Switches,
- In_Arrays => Packages.Table (Pkg).Decl.Arrays);
- The_Switches := Prj.Util.Value_Of
- (Index => Name_Ada,
- In_Array => Default_Switches_Array);
+ -- gnatxref), Linker (for gnatlink), Finder (for gnatfind),
+ -- Pretty_Printer (for gnatpp), Eliminate (for gnatelim), Check
+ -- (for gnatcheck), and Metric (for gnatmetric) have an
+ -- attributed Switches, an associative array, indexed by the
+ -- name of the file.
+
+ -- They also have an attribute Default_Switches, indexed by the
+ -- name of the programming language.
+ else
+ if The_Switches.Kind = Prj.Undefined then
+ Default_Switches_Array :=
+ Prj.Util.Value_Of
+ (Name => Name_Default_Switches,
+ In_Arrays => Element.Decl.Arrays,
+ In_Tree => Project_Tree);
+ The_Switches := Prj.Util.Value_Of
+ (Index => Name_Ada,
+ Src_Index => 0,
+ In_Array => Default_Switches_Array,
+ In_Tree => Project_Tree);
+ end if;
end if;
-- If there are switches specified in the package of the
null;
when Prj.Single =>
- if String_Length (The_Switches.Value) > 0 then
- String_To_Name_Buffer (The_Switches.Value);
- First_Switches.Increment_Last;
- First_Switches.Table (First_Switches.Last) :=
- new String'(Name_Buffer (1 .. Name_Len));
- end if;
+ declare
+ Switch : constant String :=
+ Get_Name_String (The_Switches.Value);
+
+ begin
+ if Switch'Length > 0 then
+ First_Switches.Increment_Last;
+ First_Switches.Table (First_Switches.Last) :=
+ new String'(Switch);
+ end if;
+ end;
when Prj.List =>
Current := The_Switches.Values;
while Current /= Prj.Nil_String loop
- The_String := String_Elements.Table (Current);
+ The_String := Project_Tree.String_Elements.
+ Table (Current);
- if String_Length (The_String.Value) > 0 then
- String_To_Name_Buffer (The_String.Value);
- First_Switches.Increment_Last;
- First_Switches.Table (First_Switches.Last) :=
- new String'(Name_Buffer (1 .. Name_Len));
- end if;
+ declare
+ Switch : constant String :=
+ Get_Name_String (The_String.Value);
+
+ begin
+ if Switch'Length > 0 then
+ First_Switches.Increment_Last;
+ First_Switches.Table (First_Switches.Last) :=
+ new String'(Switch);
+ end if;
+ end;
Current := The_String.Next;
end loop;
end if;
end;
- -- Set up the environment variables ADA_INCLUDE_PATH and
- -- ADA_OBJECTS_PATH.
-
- Setenv
- (Name => Ada_Include_Path,
- Value => Prj.Env.Ada_Include_Path (Project).all);
- Setenv
- (Name => Ada_Objects_Path,
- Value => Prj.Env.Ada_Objects_Path
- (Project, Including_Libraries => False).all);
-
- if The_Command = Bind or else The_Command = Link then
+ if The_Command = Bind
+ or else The_Command = Link
+ or else The_Command = Elim
+ then
Change_Dir
(Get_Name_String
- (Projects.Table (Project).Object_Directory));
+ (Project_Tree.Projects.Table
+ (Project).Object_Directory.Name));
end if;
- if The_Command = Link then
+ -- Set up the env vars for project path files
+
+ Prj.Env.Set_Ada_Paths
+ (Project, Project_Tree, Including_Libraries => False);
- -- Add the default search directories, to be able to find
- -- libgnat in call to MLib.Utl.Lib_Directory.
+ -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create
+ -- a configuration pragmas file, if necessary.
- Add_Default_Search_Dirs;
+ if The_Command = Pretty
+ or else The_Command = Metric
+ or else The_Command = Stub
+ or else The_Command = Elim
+ or else The_Command = Check
+ or else The_Command = Sync
+ then
+ -- If there are switches in package Compiler, put them in the
+ -- Carg_Switches table.
declare
- There_Are_Libraries : Boolean := False;
+ Data : constant Prj.Project_Data :=
+ Project_Tree.Projects.Table (Project);
+
+ Pkg : constant Prj.Package_Id :=
+ Prj.Util.Value_Of
+ (Name => Name_Compiler,
+ In_Packages => Data.Decl.Packages,
+ In_Tree => Project_Tree);
+
+ Element : Package_Element;
+
+ Default_Switches_Array : Array_Element_Id;
+
+ The_Switches : Prj.Variable_Value;
+ Current : Prj.String_List_Id;
+ The_String : String_Element;
begin
- -- Check if there are library project files
+ if Pkg /= No_Package then
+ Element := Project_Tree.Packages.Table (Pkg);
+
+ Default_Switches_Array :=
+ Prj.Util.Value_Of
+ (Name => Name_Default_Switches,
+ In_Arrays => Element.Decl.Arrays,
+ In_Tree => Project_Tree);
+ The_Switches := Prj.Util.Value_Of
+ (Index => Name_Ada,
+ Src_Index => 0,
+ In_Array => Default_Switches_Array,
+ In_Tree => Project_Tree);
- if MLib.Tgt.Libraries_Are_Supported then
- Set_Libraries (Project, There_Are_Libraries);
+ -- If there are switches specified in the package of the
+ -- project file corresponding to the tool, scan them.
+
+ case The_Switches.Kind is
+ when Prj.Undefined =>
+ null;
+
+ when Prj.Single =>
+ declare
+ Switch : constant String :=
+ Get_Name_String (The_Switches.Value);
+ begin
+ if Switch'Length > 0 then
+ Add_To_Carg_Switches (new String'(Switch));
+ end if;
+ end;
+
+ when Prj.List =>
+ Current := The_Switches.Values;
+ while Current /= Prj.Nil_String loop
+ The_String :=
+ Project_Tree.String_Elements.Table (Current);
+
+ declare
+ Switch : constant String :=
+ Get_Name_String (The_String.Value);
+ begin
+ if Switch'Length > 0 then
+ Add_To_Carg_Switches (new String'(Switch));
+ end if;
+ end;
+
+ Current := The_String.Next;
+ end loop;
+ end case;
end if;
+ end;
+
+ -- If -cargs is one of the switches, move the following switches
+ -- to the Carg_Switches table.
- -- If there are, add the necessary additional switches
+ for J in 1 .. First_Switches.Last loop
+ if First_Switches.Table (J).all = "-cargs" then
+ declare
+ K : Positive;
+ Last : Natural;
- if There_Are_Libraries then
+ begin
+ -- Move the switches that are before -rules when the
+ -- command is CHECK.
+
+ K := J + 1;
+ while K <= First_Switches.Last
+ and then
+ (The_Command /= Check
+ or else First_Switches.Table (K).all /= "-rules")
+ loop
+ Add_To_Carg_Switches (First_Switches.Table (K));
+ K := K + 1;
+ end loop;
- -- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir>
+ if K > First_Switches.Last then
+ First_Switches.Set_Last (J - 1);
- 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");
+ else
+ Last := J - 1;
+ while K <= First_Switches.Last loop
+ Last := Last + 1;
+ First_Switches.Table (Last) :=
+ First_Switches.Table (K);
+ K := K + 1;
+ end loop;
+
+ First_Switches.Set_Last (Last);
+ end if;
+ end;
+ exit;
+ end if;
+ end loop;
+
+ for J in 1 .. Last_Switches.Last loop
+ if Last_Switches.Table (J).all = "-cargs" then
declare
- Option : constant String_Access :=
- MLib.Tgt.Linker_Library_Path_Option
- (MLib.Utl.Lib_Directory);
+ K : Positive;
+ Last : Natural;
begin
- if Option /= null then
- Last_Switches.Increment_Last;
- Last_Switches.Table (Last_Switches.Last) :=
- Option;
+ -- Move the switches that are before -rules when the
+ -- command is CHECK.
+
+ K := J + 1;
+ while K <= Last_Switches.Last
+ and then
+ (The_Command /= Check
+ or else
+ Last_Switches.Table (K).all /= "-rules")
+ loop
+ Add_To_Carg_Switches (Last_Switches.Table (K));
+ K := K + 1;
+ end loop;
+
+ if K > Last_Switches.Last then
+ Last_Switches.Set_Last (J - 1);
+
+ else
+ Last := J - 1;
+ while K <= Last_Switches.Last loop
+ Last := Last + 1;
+ Last_Switches.Table (Last) :=
+ Last_Switches.Table (K);
+ K := K + 1;
+ end loop;
+
+ Last_Switches.Set_Last (Last);
end if;
end;
+
+ exit;
+ end if;
+ end loop;
+
+ declare
+ CP_File : constant Path_Name_Type := Configuration_Pragmas_File;
+
+ begin
+ if CP_File /= No_Path then
+ if The_Command = Elim then
+ First_Switches.Increment_Last;
+ First_Switches.Table (First_Switches.Last) :=
+ new String'("-C" & Get_Name_String (CP_File));
+
+ else
+ Add_To_Carg_Switches
+ (new String'("-gnatec=" & Get_Name_String (CP_File)));
+ end if;
+ end if;
+ end;
+ end if;
+
+ if The_Command = Link then
+ Process_Link;
+ end if;
+
+ if The_Command = Link or The_Command = Bind then
+
+ -- For files that are specified as relative paths with directory
+ -- information, we convert them to absolute paths, with parent
+ -- being the current working directory if specified on the command
+ -- line and the project directory if specified in the project
+ -- file. This is what gnatmake is doing for linker and binder
+ -- arguments.
+
+ for J in 1 .. Last_Switches.Last loop
+ Test_If_Relative_Path
+ (Last_Switches.Table (J), Current_Work_Dir);
+ end loop;
+
+ Get_Name_String
+ (Project_Tree.Projects.Table (Project).Directory.Name);
+
+ declare
+ Project_Dir : constant String := Name_Buffer (1 .. Name_Len);
+ begin
+ for J in 1 .. First_Switches.Last loop
+ Test_If_Relative_Path
+ (First_Switches.Table (J), Project_Dir);
+ end loop;
+ end;
+
+ elsif The_Command = Stub then
+ declare
+ Data : constant Prj.Project_Data :=
+ Project_Tree.Projects.Table (Project);
+ File_Index : Integer := 0;
+ Dir_Index : Integer := 0;
+ Last : constant Integer := Last_Switches.Last;
+
+ begin
+ for Index in 1 .. Last loop
+ if Last_Switches.Table (Index)
+ (Last_Switches.Table (Index)'First) /= '-'
+ then
+ File_Index := Index;
+ exit;
+ end if;
+ end loop;
+
+ -- If the naming scheme of the project file is not standard,
+ -- and if the file name ends with the spec suffix, then
+ -- indicate to gnatstub the name of the body file with
+ -- a -o switch.
+
+ if Body_Suffix_Id_Of (Project_Tree, "ada", Data.Naming) /=
+ Prj.Default_Ada_Spec_Suffix
+ then
+ if File_Index /= 0 then
+ declare
+ Spec : constant String :=
+ Base_Name (Last_Switches.Table (File_Index).all);
+ Last : Natural := Spec'Last;
+
+ begin
+ Get_Name_String
+ (Spec_Suffix_Id_Of
+ (Project_Tree, "ada", Data.Naming));
+
+ 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
+ (Body_Suffix_Id_Of
+ (Project_Tree, "ada", Data.Naming));
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'("-o");
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'(Spec (Spec'First .. Last) &
+ Name_Buffer (1 .. Name_Len));
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- Add the directory of the spec as the destination directory
+ -- of the body, if there is no destination directory already
+ -- specified.
+
+ if File_Index /= 0 then
+ for Index in File_Index + 1 .. Last loop
+ if Last_Switches.Table (Index)
+ (Last_Switches.Table (Index)'First) /= '-'
+ then
+ Dir_Index := Index;
+ exit;
+ end if;
+ end loop;
+
+ if Dir_Index = 0 then
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'
+ (Dir_Name (Last_Switches.Table (File_Index).all));
+ end if;
+ end if;
+ end;
+ end if;
+
+ -- For gnatmetric, the generated files should be put in the object
+ -- directory. This must be the first switch, because it may be
+ -- overridden by a switch in package Metrics in the project file or
+ -- by a command line option. Note that we don't add the -d= switch
+ -- if there is no object directory available.
+
+ if The_Command = Metric
+ and then
+ Project_Tree.Projects.Table (Project).Object_Directory /=
+ No_Path_Information
+ then
+ First_Switches.Increment_Last;
+ First_Switches.Table (2 .. First_Switches.Last) :=
+ First_Switches.Table (1 .. First_Switches.Last - 1);
+ First_Switches.Table (1) :=
+ new String'("-d=" &
+ Get_Name_String
+ (Project_Tree.Projects.Table
+ (Project).Object_Directory.Name));
+ end if;
+
+ -- For gnat check, -rules and the following switches need to be the
+ -- last options. So, we move all these switches to table
+ -- Rules_Switches.
+
+ if The_Command = Check then
+ declare
+ New_Last : Natural;
+ -- Set to rank of options preceding "-rules"
+
+ In_Rules_Switches : Boolean;
+ -- Set to True when options "-rules" is found
+
+ begin
+ New_Last := First_Switches.Last;
+ In_Rules_Switches := False;
+
+ for J in 1 .. First_Switches.Last loop
+ if In_Rules_Switches then
+ Add_To_Rules_Switches (First_Switches.Table (J));
+
+ elsif First_Switches.Table (J).all = "-rules" then
+ New_Last := J - 1;
+ In_Rules_Switches := True;
+ end if;
+ end loop;
+
+ if In_Rules_Switches then
+ First_Switches.Set_Last (New_Last);
+ end if;
+
+ New_Last := Last_Switches.Last;
+ In_Rules_Switches := False;
+
+ for J in 1 .. Last_Switches.Last loop
+ if In_Rules_Switches then
+ Add_To_Rules_Switches (Last_Switches.Table (J));
+
+ elsif Last_Switches.Table (J).all = "-rules" then
+ New_Last := J - 1;
+ In_Rules_Switches := True;
+ end if;
+ end loop;
+
+ if In_Rules_Switches then
+ Last_Switches.Set_Last (New_Last);
end if;
end;
end if;
+
+ -- For gnat check, sync, metric or pretty with -U + a main, get the
+ -- list of sources from the closure and add them to the arguments.
+
+ if ASIS_Main /= null then
+ Get_Closure;
+
+ -- On VMS, set up the env var again for source dirs file. This is
+ -- because the call to gnatmake has set this env var to another
+ -- file that has now been deleted.
+
+ if Hostparm.OpenVMS then
+
+ -- First make sure that the recorded file names are empty
+
+ Prj.Env.Initialize;
+
+ Prj.Env.Set_Ada_Paths
+ (Project, Project_Tree, Including_Libraries => False);
+ end if;
+
+ -- For gnat check, gnat sync, gnat pretty, gnat metric, gnat list,
+ -- and gnat stack, if no file has been put on the command line, call
+ -- tool with all the sources of the main project.
+
+ elsif The_Command = Check or else
+ The_Command = Sync or else
+ The_Command = Pretty or else
+ The_Command = Metric or else
+ The_Command = List or else
+ The_Command = Stack
+ then
+ Check_Files;
+ end if;
end if;
-- Gather all the arguments and invoke the executable
declare
The_Args : Argument_List
- (1 .. First_Switches.Last + Last_Switches.Last);
- Arg_Num : Natural := 0;
+ (1 .. First_Switches.Last +
+ Last_Switches.Last +
+ Carg_Switches.Last +
+ Rules_Switches.Last);
+ Arg_Num : Natural := 0;
+
begin
for J in 1 .. First_Switches.Last loop
Arg_Num := Arg_Num + 1;
The_Args (Arg_Num) := Last_Switches.Table (J);
end loop;
- if Opt.Verbose_Mode then
+ for J in 1 .. Carg_Switches.Last loop
+ Arg_Num := Arg_Num + 1;
+ The_Args (Arg_Num) := Carg_Switches.Table (J);
+ end loop;
+
+ for J in 1 .. Rules_Switches.Last loop
+ Arg_Num := Arg_Num + 1;
+ The_Args (Arg_Num) := Rules_Switches.Table (J);
+ end loop;
+
+ -- If Display_Command is on, only display the generated command
+
+ if Display_Command then
+ Put (Standard_Error, "generated command -->");
+ Put (Standard_Error, Exec_Path.all);
+
+ for Arg in The_Args'Range loop
+ Put (Standard_Error, " ");
+ Put (Standard_Error, The_Args (Arg).all);
+ end loop;
+
+ Put (Standard_Error, "<--");
+ New_Line (Standard_Error);
+ raise Normal_Exit;
+ end if;
+
+ if Verbose_Mode then
Output.Write_Str (Exec_Path.all);
for Arg in The_Args'Range loop
Output.Write_Eol;
end if;
- My_Exit_Status
- := Exit_Status (Spawn (Exec_Path.all, The_Args));
+ My_Exit_Status :=
+ Exit_Status (Spawn (Exec_Path.all, The_Args));
raise Normal_Exit;
end;
end;
exception
when Error_Exit =>
+ if not Keep_Temporary_Files then
+ Prj.Env.Delete_All_Path_Files (Project_Tree);
+ Delete_Temp_Config_Files;
+ end if;
+
Set_Exit_Status (Failure);
when Normal_Exit =>
- Set_Exit_Status (My_Exit_Status);
+ if not Keep_Temporary_Files then
+ Prj.Env.Delete_All_Path_Files (Project_Tree);
+ Delete_Temp_Config_Files;
+ end if;
+
+ -- 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
