MatCat.OpenSource/8sa1-gcc
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
3b56934fb9
8sa1-gcc/gcc/ada/gnatcmd.adb
Geert Bosch 226ada7a41 osint.adb (Create_Debug_File): When an object file is specified... 
* osint.adb(Create_Debug_File): When an object file is specified,
	put the .dg file in the same directory as the object file.

	* osint.adb: Minor reformatting

	* lib-xref.adb (Output_Instantiation): New procedure to generate
	instantiation references.

	* lib-xref.ads: Add documentation of handling of generic references.

	* ali.adb (Read_Instantiation_Ref): New procedure to read
	instantiation references

	* ali.ads: Add spec for storing instantiation references

	* bindusg.adb: Minor reformatting

	* switch.adb: Add entry for Latin-5 (Cyrillic ISO-8859-5)

	* usage.adb: Add entry for Latin-5 (Cyrillic ISO-8859-5)

	* gnatcmd.adb: Add entry for Latin-5 (Cyrillic ISO-8859-5)

	* csets.adb: Add entry for Latin-5 (Cyrillic ISO-8859-5)

	* csets.ads:
	Fix header format
	Add 2001 to copyright date
	Add entry for Latin-5 (Cyrillic ISO-8859-5)

	* adaint.c: mktemp is a macro on Lynx and can not be used as an
	expression.

	* misc.c (gnat_expand_constant): Do not strip UNCHECKED_CONVERT_EXPR
	if operand is CONSTRUCTOR.

	* trans.c (tree_transform, case N_Assignment_Statement): Set lineno
	before emiting check on right-hand side, so that exception information
	is correct.

	* utils.c (create_var_decl): Throw away initializing expression
	if just annotating types and non-constant.

	* prj-nmsc.adb: (Ada_Check): Migrate drom Ada_Default_... to
	Default_Ada_...

	* prj.adb: (Ada_Default_Spec_Suffix, Ada_Default_Impl_Suffix):
	Remove functions.
	(Default_Ada_Spec_Suffix, Default_Ada_Impl_Suffix): Move to spec.

	* prj.ads: (Ada_Default_Spec_Suffix, Ada_Default_Impl_Suffix):
	Remove functions.
	(Default_Ada_Spec_Suffix, Default_Ada_Impl_Suffix): Move from body.

From-SVN: r48052
2001-12-16 01:56:17 +01:00

3320 lines
131 KiB
Ada
Raw Blame History

------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T C M D --
-- --
-- B o d y --
-- --
-- $Revision$
-- --
-- Copyright (C) 1996-2001 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Osint; use Osint;
with Sdefault; use Sdefault;
with Hostparm; use Hostparm;
-- Used to determine if we are in VMS or not for error message purposes
with Gnatvsn;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Table;
procedure GNATCmd is
pragma Ident (Gnatvsn.Gnat_Version_String);
------------------
-- SWITCH TABLE --
------------------
-- The switch tables contain an entry for each switch recognized by the
-- command processor. The syntax of entries is as follows:
-- SWITCH_STRING ::= "/ command-qualifier-name TRANSLATION"
-- TRANSLATION ::=
-- DIRECT_TRANSLATION
-- | DIRECTORIES_TRANSLATION
-- | FILE_TRANSLATION
-- | NUMERIC_TRANSLATION
-- | STRING_TRANSLATION
-- | OPTIONS_TRANSLATION
-- | COMMANDS_TRANSLATION
-- | ALPHANUMPLUS_TRANSLATION
-- | OTHER_TRANSLATION
-- DIRECT_TRANSLATION ::= space UNIX_SWITCHES
-- DIRECTORIES_TRANSLATION ::= =* UNIX_SWITCH *
-- DIRECTORY_TRANSLATION ::= =% UNIX_SWITCH %
-- FILE_TRANSLATION ::= =@ UNIX_SWITCH @
-- NUMERIC_TRANSLATION ::= =# UNIX_SWITCH # | # number #
-- STRING_TRANSLATION ::= =" UNIX_SWITCH "
-- OPTIONS_TRANSLATION ::= =OPTION {space OPTION}
-- COMMANDS_TRANSLATION ::= =? ARGS space command-name
-- ALPHANUMPLUS_TRANSLATION ::= =| UNIX_SWITCH |
-- UNIX_SWITCHES ::= UNIX_SWITCH {, UNIX_SWITCH}
-- UNIX_SWITCH ::= unix-switch-string | !unix-switch-string | `string'
-- OPTION ::= option-name space UNIX_SWITCHES
-- ARGS ::= -cargs | -bargs | -largs
-- Here command-qual is the name of the switch recognized by the GNATCmd.
-- This is always given in upper case in the templates, although in the
-- actual commands, either upper or lower case is allowed.
-- The unix-switch-string always starts with a minus, and has no commas
-- or spaces in it. Case is significant in the unix switch string. If a
-- unix switch string is preceded by the not sign (!) it means that the
-- effect of the corresponding command qualifer is to remove any previous
-- occurrence of the given switch in the command line.
-- The DIRECTORIES_TRANSLATION format is used where a list of directories
-- is given. This possible corresponding formats recognized by GNATCmd are
-- as shown by the following example for the case of PATH
-- PATH=direc
-- PATH=(direc,direc,direc,direc)
-- When more than one directory is present for the DIRECTORIES case, then
-- multiple instances of the corresponding unix switch are generated,
-- with the file name being substituted for the occurrence of *.
-- The FILE_TRANSLATION format is similar except that only a single
-- file is allowed, not a list of files, and only one unix switch is
-- generated as a result.
-- The NUMERIC_TRANSLATION format is similar to the FILE_TRANSLATION case
-- except that the parameter is a decimal integer in the range 0 to 999.
-- For the OPTIONS_TRANSLATION case, GNATCmd similarly permits one or
-- more options to appear (although only in some cases does the use of
-- multiple options make logical sense). For example, taking the
-- case of ERRORS for GCC, the following are all allowed:
-- /ERRORS=BRIEF
-- /ERRORS=(FULL,VERBOSE)
-- /ERRORS=(BRIEF IMMEDIATE)
-- If no option is provided (e.g. just /ERRORS is written), then the
-- first option in the list is the default option. For /ERRORS this
-- is NORMAL, so /ERRORS with no option is equivalent to /ERRORS=NORMAL.
-- The COMMANDS_TRANSLATION case is only used for gnatmake, to correspond
-- to the use of -cargs, -bargs and -largs (the ARGS string as indicated
-- is one of these three possibilities). The name given by COMMAND is the
-- corresponding command name to be used to interprete the switches to be
-- passed on. Switches of this type set modes, e.g. /COMPILER_QUALIFIERS
-- sets the mode so that all subsequent switches, up to another switch
-- with COMMANDS_TRANSLATION apply to the corresponding commands issued
-- by the make utility. For example
-- /COMPILER_QUALIFIERS /LIST /BINDER_QUALIFIERS /MAIN
-- /COMPILER_QUALIFIERS /NOLIST /COMPILE_CHECKS=SYNTAX
-- Clearly these switches must come at the end of the list of switches
-- since all subsequent switches apply to an issued command.
-- For the DIRECT_TRANSLATION case, an implicit additional entry is
-- created by prepending NO to the name of the qualifer, and then
-- inverting the sense of the UNIX_SWITCHES string. For example,
-- given the entry:
-- "/LIST -gnatl"
-- An implicit entry is created:
-- "/NOLIST !-gnatl"
-- In the case where, a ! is already present, inverting the sense of the
-- switch means removing it.
subtype S is String;
-- A synonym to shorten the table
type String_Ptr is access constant String;
-- String pointer type used throughout
type Switches is array (Natural range <>) of String_Ptr;
-- Type used for array of swtiches
type Switches_Ptr is access constant Switches;
--------------------------------
-- Switches for project files --
--------------------------------
S_Ext_Ref : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' &
"-X" & '"';
S_Project_File : aliased constant S := "/PROJECT_FILE=*" &
"-P*";
S_Project_Verb : aliased constant S := "/PROJECT_FILE_VERBOSITY=" &
"DEFAULT " &
"-vP0 " &
"MEDIUM " &
"-vP1 " &
"HIGH " &
"-vP2";
----------------------------
-- Switches for GNAT BIND --
----------------------------
S_Bind_Bind : aliased constant S := "/BIND_FILE=" &
"ADA " &
"-A " &
"C " &
"-C";
S_Bind_Build : aliased constant S := "/BUILD_LIBRARY=|" &
"-L|";
S_Bind_Current : aliased constant S := "/CURRENT_DIRECTORY " &
"!-I-";
S_Bind_Debug : aliased constant S := "/DEBUG=" &
"TRACEBACK " &
"-g2 " &
"ALL " &
"-g3 " &
"NONE " &
"-g0 " &
"SYMBOLS " &
"-g1 " &
"NOSYMBOLS " &
"!-g1 " &
"LINK " &
"-g3 " &
"NOTRACEBACK " &
"!-g2";
S_Bind_DebugX : aliased constant S := "/NODEBUG " &
"!-g";
S_Bind_Elab : aliased constant S := "/ELABORATION_DEPENDENCIES " &
"-e";
S_Bind_Error : aliased constant S := "/ERROR_LIMIT=#" &
"-m#";
S_Bind_Library : aliased constant S := "/LIBRARY_SEARCH=*" &
"-aO*";
S_Bind_Linker : aliased constant S := "/LINKER_OPTION_LIST " &
"-K";
S_Bind_Main : aliased constant S := "/MAIN " &
"!-n";
S_Bind_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
"-nostdinc";
S_Bind_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
"-nostdlib";
S_Bind_Object : aliased constant S := "/OBJECT_LIST " &
"-O";
S_Bind_Order : aliased constant S := "/ORDER_OF_ELABORATION " &
"-l";
S_Bind_Output : aliased constant S := "/OUTPUT=@" &
"-o@";
S_Bind_OutputX : aliased constant S := "/NOOUTPUT " &
"-c";
S_Bind_Pess : aliased constant S := "/PESSIMISTIC_ELABORATION " &
"-p";
S_Bind_Read : aliased constant S := "/READ_SOURCES=" &
"ALL " &
"-s " &
"NONE " &
"-x " &
"AVAILABLE " &
"!-x,!-s";
S_Bind_ReadX : aliased constant S := "/NOREAD_SOURCES " &
"-x";
S_Bind_Rename : aliased constant S := "/RENAME_MAIN " &
"-r";
S_Bind_Report : aliased constant S := "/REPORT_ERRORS=" &
"VERBOSE " &
"-v " &
"BRIEF " &
"-b " &
"DEFAULT " &
"!-b,!-v";
S_Bind_ReportX : aliased constant S := "/NOREPORT_ERRORS " &
"!-b,!-v";
S_Bind_Search : aliased constant S := "/SEARCH=*" &
"-I*";
S_Bind_Shared : aliased constant S := "/SHARED " &
"-shared";
S_Bind_Source : aliased constant S := "/SOURCE_SEARCH=*" &
"-aI*";
S_Bind_Time : aliased constant S := "/TIME_STAMP_CHECK " &
"!-t";
S_Bind_Verbose : aliased constant S := "/VERBOSE " &
"-v";
S_Bind_Warn : aliased constant S := "/WARNINGS=" &
"NORMAL " &
"!-ws,!-we " &
"SUPPRESS " &
"-ws " &
"ERROR " &
"-we";
S_Bind_WarnX : aliased constant S := "/NOWARNINGS " &
"-ws";
Bind_Switches : aliased constant Switches := (
S_Bind_Bind 'Access,
S_Bind_Build 'Access,
S_Bind_Current 'Access,
S_Bind_Debug 'Access,
S_Bind_DebugX 'Access,
S_Bind_Elab 'Access,
S_Bind_Error 'Access,
S_Ext_Ref 'Access,
S_Bind_Library 'Access,
S_Bind_Linker 'Access,
S_Bind_Main 'Access,
S_Bind_Nostinc 'Access,
S_Bind_Nostlib 'Access,
S_Bind_Object 'Access,
S_Bind_Order 'Access,
S_Bind_Output 'Access,
S_Bind_OutputX 'Access,
S_Bind_Pess 'Access,
S_Project_File 'Access,
S_Project_Verb 'Access,
S_Bind_Read 'Access,
S_Bind_ReadX 'Access,
S_Bind_Rename 'Access,
S_Bind_Report 'Access,
S_Bind_ReportX 'Access,
S_Bind_Search 'Access,
S_Bind_Shared 'Access,
S_Bind_Source 'Access,
S_Bind_Time 'Access,
S_Bind_Verbose 'Access,
S_Bind_Warn 'Access,
S_Bind_WarnX 'Access);
----------------------------
-- Switches for GNAT CHOP --
----------------------------
S_Chop_Comp : aliased constant S := "/COMPILATION " &
"-c";
S_Chop_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" &
"-k#";
S_Chop_Help : aliased constant S := "/HELP " &
"-h";
S_Chop_Over : aliased constant S := "/OVERWRITE " &
"-w";
S_Chop_Pres : aliased constant S := "/PRESERVE " &
"-p";
S_Chop_Quiet : aliased constant S := "/QUIET " &
"-q";
S_Chop_Ref : aliased constant S := "/REFERENCE " &
"-r";
S_Chop_Verb : aliased constant S := "/VERBOSE " &
"-v";
Chop_Switches : aliased constant Switches := (
S_Chop_Comp 'Access,
S_Chop_File 'Access,
S_Chop_Help 'Access,
S_Chop_Over 'Access,
S_Chop_Pres 'Access,
S_Chop_Quiet 'Access,
S_Chop_Ref 'Access,
S_Chop_Verb 'Access);
-------------------------------
-- Switches for GNAT COMPILE --
-------------------------------
S_GCC_Ada_83 : aliased constant S := "/83 " &
"-gnat83";
S_GCC_Ada_95 : aliased constant S := "/95 " &
"!-gnat83";
S_GCC_Asm : aliased constant S := "/ASM " &
"-S,!-c";
S_GCC_Checks : aliased constant S := "/CHECKS=" &
"FULL " &
"-gnato,!-gnatE,!-gnatp " &
"OVERFLOW " &
"-gnato " &
"ELABORATION " &
"-gnatE " &
"ASSERTIONS " &
"-gnata " &
"DEFAULT " &
"!-gnato,!-gnatp " &
"SUPPRESS_ALL " &
"-gnatp";
S_GCC_ChecksX : aliased constant S := "/NOCHECKS " &
"-gnatp,!-gnato,!-gnatE";
S_GCC_Compres : aliased constant S := "/COMPRESS_NAMES " &
"-gnatC";
S_GCC_Current : aliased constant S := "/CURRENT_DIRECTORY " &
"!-I-";
S_GCC_Debug : aliased constant S := "/DEBUG=" &
"SYMBOLS " &
"-g2 " &
"NOSYMBOLS " &
"!-g2 " &
"TRACEBACK " &
"-g1 " &
"ALL " &
"-g3 " &
"NONE " &
"-g0 " &
"NOTRACEBACK " &
"-g0";
S_GCC_DebugX : aliased constant S := "/NODEBUG " &
"!-g";
S_GCC_Dist : aliased constant S := "/DISTRIBUTION_STUBS=" &
"RECEIVER " &
"-gnatzr " &
"CALLER " &
"-gnatzc";
S_GCC_DistX : aliased constant S := "/NODISTRIBUTION_STUBS " &
"!-gnatzr,!-gnatzc";
S_GCC_Error : aliased constant S := "/ERROR_LIMIT=#" &
"-gnatm#";
S_GCC_ErrorX : aliased constant S := "/NOERROR_LIMIT " &
"-gnatm999";
S_GCC_Expand : aliased constant S := "/EXPAND_SOURCE " &
"-gnatG";
S_GCC_Extend : aliased constant S := "/EXTENSIONS_ALLOWED " &
"-gnatX";
S_GCC_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" &
"-gnatk#";
S_GCC_Force : aliased constant S := "/FORCE_ALI " &
"-gnatQ";
S_GCC_Ident : aliased constant S := "/IDENTIFIER_CHARACTER_SET=" &
"DEFAULT " &
"-gnati1 " &
"1 " &
"-gnati1 " &
"2 " &
"-gnati2 " &
"3 " &
"-gnati3 " &
"4 " &
"-gnati4 " &
"5 " &
"-gnati5 " &
"PC " &
"-gnatip " &
"PC850 " &
"-gnati8 " &
"FULL_UPPER " &
"-gnatif " &
"NO_UPPER " &
"-gnatin " &
"WIDE " &
"-gnatiw";
S_GCC_IdentX : aliased constant S := "/NOIDENTIFIER_CHARACTER_SET " &
"-gnati1";
S_GCC_Inline : aliased constant S := "/INLINE=" &
"PRAGMA " &
"-gnatn " &
"SUPPRESS " &
"-fno-inline";
S_GCC_InlineX : aliased constant S := "/NOINLINE " &
"!-gnatn";
S_GCC_List : aliased constant S := "/LIST " &
"-gnatl";
S_GCC_Noload : aliased constant S := "/NOLOAD " &
"-gnatc";
S_GCC_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
"-nostdinc";
S_GCC_Opt : aliased constant S := "/OPTIMIZE=" &
"ALL " &
"-O2,!-O0,!-O1,!-O3 " &
"NONE " &
"-O0,!-O1,!-O2,!-O3 " &
"SOME " &
"-O1,!-O0,!-O2,!-O3 " &
"DEVELOPMENT " &
"-O1,!-O0,!-O2,!-O3 " &
"UNROLL_LOOPS " &
"-funroll-loops " &
"INLINING " &
"-O3,!-O0,!-O1,!-O2";
S_GCC_OptX : aliased constant S := "/NOOPTIMIZE " &
"-O0,!-O1,!-O2,!-O3";
S_GCC_Report : aliased constant S := "/REPORT_ERRORS=" &
"VERBOSE " &
"-gnatv " &
"BRIEF " &
"-gnatb " &
"FULL " &
"-gnatf " &
"IMMEDIATE " &
"-gnate " &
"DEFAULT " &
"!-gnatb,!-gnatv";
S_GCC_ReportX : aliased constant S := "/NOREPORT_ERRORS " &
"!-gnatb,!-gnatv";
S_GCC_Repinfo : aliased constant S := "/REPRESENTATION_INFO=" &
"ARRAYS " &
"-gnatR1 " &
"NONE " &
"-gnatR0 " &
"OBJECTS " &
"-gnatR2 " &
"SYMBOLIC " &
"-gnatR3 " &
"DEFAULT " &
"-gnatR";
S_GCC_RepinfX : aliased constant S := "/NOREPRESENTATION_INFO " &
"!-gnatR";
S_GCC_Search : aliased constant S := "/SEARCH=*" &
"-I*";
S_GCC_Style : aliased constant S := "/STYLE_CHECKS=" &
"ALL_BUILTIN " &
"-gnaty " &
"1 " &
"-gnaty1 " &
"2 " &
"-gnaty2 " &
"3 " &
"-gnaty3 " &
"4 " &
"-gnaty4 " &
"5 " &
"-gnaty5 " &
"6 " &
"-gnaty6 " &
"7 " &
"-gnaty7 " &
"8 " &
"-gnaty8 " &
"9 " &
"-gnaty9 " &
"ATTRIBUTE " &
"-gnatya " &
"BLANKS " &
"-gnatyb " &
"COMMENTS " &
"-gnatyc " &
"END " &
"-gnatye " &
"VTABS " &
"-gnatyf " &
"GNAT " &
"-gnatg " &
"HTABS " &
"-gnatyh " &
"IF_THEN " &
"-gnatyi " &
"KEYWORD " &
"-gnatyk " &
"LAYOUT " &
"-gnatyl " &
"LINE_LENGTH " &
"-gnatym " &
"STANDARD_CASING " &
"-gnatyn " &
"ORDERED_SUBPROGRAMS " &
"-gnatyo " &
"NONE " &
"!-gnatg,!-gnatr " &
"PRAGMA " &
"-gnatyp " &
"REFERENCES " &
"-gnatr " &
"SPECS " &
"-gnatys " &
"TOKEN " &
"-gnatyt ";
S_GCC_StyleX : aliased constant S := "/NOSTYLE_CHECKS " &
"!-gnatg,!-gnatr";
S_GCC_Syntax : aliased constant S := "/SYNTAX_ONLY " &
"-gnats";
S_GCC_Trace : aliased constant S := "/TRACE_UNITS " &
"-gnatdc";
S_GCC_Tree : aliased constant S := "/TREE_OUTPUT " &
"-gnatt";
S_GCC_Trys : aliased constant S := "/TRY_SEMANTICS " &
"-gnatq";
S_GCC_Units : aliased constant S := "/UNITS_LIST " &
"-gnatu";
S_GCC_Unique : aliased constant S := "/UNIQUE_ERROR_TAG " &
"-gnatU";
S_GCC_Upcase : aliased constant S := "/UPPERCASE_EXTERNALS " &
"-gnatF";
S_GCC_Valid : aliased constant S := "/VALIDITY_CHECKING=" &
"DEFAULT " &
"-gnatVd " &
"NODEFAULT " &
"-gnatVD " &
"COPIES " &
"-gnatVc " &
"NOCOPIES " &
"-gnatVC " &
"FLOATS " &
"-gnatVf " &
"NOFLOATS " &
"-gnatVF " &
"IN_PARAMS " &
"-gnatVi " &
"NOIN_PARAMS " &
"-gnatVI " &
"MOD_PARAMS " &
"-gnatVm " &
"NOMOD_PARAMS " &
"-gnatVM " &
"OPERANDS " &
"-gnatVo " &
"NOOPERANDS " &
"-gnatVO " &
"RETURNS " &
"-gnatVr " &
"NORETURNS " &
"-gnatVR " &
"SUBSCRIPTS " &
"-gnatVs " &
"NOSUBSCRIPTS " &
"-gnatVS " &
"TESTS " &
"-gnatVt " &
"NOTESTS " &
"-gnatVT " &
"ALL " &
"-gnatVa " &
"NONE " &
"-gnatVn";
S_GCC_Verbose : aliased constant S := "/VERBOSE " &
"-v";
S_GCC_Warn : aliased constant S := "/WARNINGS=" &
"DEFAULT " &
"!-gnatws,!-gnatwe " &
"ALL_GCC " &
"-Wall " &
"CONDITIONALS " &
"-gnatwc " &
"NOCONDITIONALS " &
"-gnatwC " &
"ELABORATION " &
"-gnatwl " &
"NOELABORATION " &
"-gnatwL " &
"ERRORS " &
"-gnatwe " &
"HIDING " &
"-gnatwh " &
"NOHIDING " &
"-gnatwH " &
"IMPLEMENTATION " &
"-gnatwi " &
"NOIMPLEMENTATION " &
"-gnatwI " &
"OPTIONAL " &
"-gnatwa " &
"NOOPTIONAL " &
"-gnatwA " &
"OVERLAYS " &
"-gnatwo " &
"NOOVERLAYS " &
"-gnatwO " &
"REDUNDANT " &
"-gnatwr " &
"NOREDUNDANT " &
"-gnatwR " &
"SUPPRESS " &
"-gnatws " &
"UNINITIALIZED " &
"-Wuninitialized " &
"UNUSED " &
"-gnatwu " &
"NOUNUSED " &
"-gnatwU";
S_GCC_WarnX : aliased constant S := "/NOWARNINGS " &
"-gnatws";
S_GCC_Wide : aliased constant S := "/WIDE_CHARACTER_ENCODING=" &
"BRACKETS " &
"-gnatWb " &
"NONE " &
"-gnatWn " &
"HEX " &
"-gnatWh " &
"UPPER " &
"-gnatWu " &
"SHIFT_JIS " &
"-gnatWs " &
"UTF8 " &
"-gnatW8 " &
"EUC " &
"-gnatWe";
S_GCC_WideX : aliased constant S := "/NOWIDE_CHARACTER_ENCODING " &
"-gnatWn";
S_GCC_Xdebug : aliased constant S := "/XDEBUG " &
"-gnatD";
S_GCC_Xref : aliased constant S := "/XREF=" &
"GENERATE " &
"!-gnatx " &
"SUPPRESS " &
"-gnatx";
GCC_Switches : aliased constant Switches := (
S_GCC_Ada_83 'Access,
S_GCC_Ada_95 'Access,
S_GCC_Asm 'Access,
S_GCC_Checks 'Access,
S_GCC_ChecksX 'Access,
S_GCC_Compres 'Access,
S_GCC_Current 'Access,
S_GCC_Debug 'Access,
S_GCC_DebugX 'Access,
S_GCC_Dist 'Access,
S_GCC_DistX 'Access,
S_GCC_Error 'Access,
S_GCC_ErrorX 'Access,
S_GCC_Expand 'Access,
S_GCC_Extend 'Access,
S_GCC_File 'Access,
S_GCC_Force 'Access,
S_GCC_Ident 'Access,
S_GCC_IdentX 'Access,
S_GCC_Inline 'Access,
S_GCC_InlineX 'Access,
S_GCC_List 'Access,
S_GCC_Noload 'Access,
S_GCC_Nostinc 'Access,
S_GCC_Opt 'Access,
S_GCC_OptX 'Access,
S_GCC_Report 'Access,
S_GCC_ReportX 'Access,
S_GCC_Repinfo 'Access,
S_GCC_RepinfX 'Access,
S_GCC_Search 'Access,
S_GCC_Style 'Access,
S_GCC_StyleX 'Access,
S_GCC_Syntax 'Access,
S_GCC_Trace 'Access,
S_GCC_Tree 'Access,
S_GCC_Trys 'Access,
S_GCC_Units 'Access,
S_GCC_Unique 'Access,
S_GCC_Upcase 'Access,
S_GCC_Valid 'Access,
S_GCC_Verbose 'Access,
S_GCC_Warn 'Access,
S_GCC_WarnX 'Access,
S_GCC_Wide 'Access,
S_GCC_WideX 'Access,
S_GCC_Xdebug 'Access,
S_GCC_Xref 'Access);
----------------------------
-- Switches for GNAT ELIM --
----------------------------
S_Elim_All : aliased constant S := "/ALL " &
"-a";
S_Elim_Miss : aliased constant S := "/MISSED " &
"-m";
S_Elim_Verb : aliased constant S := "/VERBOSE " &
"-v";
Elim_Switches : aliased constant Switches := (
S_Elim_All 'Access,
S_Elim_Miss 'Access,
S_Elim_Verb 'Access);
----------------------------
-- Switches for GNAT FIND --
----------------------------
S_Find_All : aliased constant S := "/ALL_FILES " &
"-a";
S_Find_Expr : aliased constant S := "/EXPRESSIONS " &
"-e";
S_Find_Full : aliased constant S := "/FULL_PATHNAME " &
"-f";
S_Find_Ignore : aliased constant S := "/IGNORE_LOCALS " &
"-g";
S_Find_Object : aliased constant S := "/OBJECT_SEARCH=*" &
"-aO*";
S_Find_Print : aliased constant S := "/PRINT_LINES " &
"-s";
S_Find_Project : aliased constant S := "/PROJECT=@" &
"-p@";
S_Find_Ref : aliased constant S := "/REFERENCES " &
"-r";
S_Find_Search : aliased constant S := "/SEARCH=*" &
"-I*";
S_Find_Source : aliased constant S := "/SOURCE_SEARCH=*" &
"-aI*";
Find_Switches : aliased constant Switches := (
S_Find_All 'Access,
S_Find_Expr 'Access,
S_Ext_Ref 'Access,
S_Find_Full 'Access,
S_Find_Ignore 'Access,
S_Find_Object 'Access,
S_Find_Print 'Access,
S_Find_Project 'Access,
S_Project_File 'Access,
S_Project_Verb 'Access,
S_Find_Ref 'Access,
S_Find_Search 'Access,
S_Find_Source 'Access);
------------------------------
-- Switches for GNAT KRUNCH --
------------------------------
S_Krunch_Count : aliased constant S := "/COUNT=#" &
"`#";
Krunch_Switches : aliased constant Switches := (1 .. 1 =>
S_Krunch_Count 'Access);
-------------------------------
-- Switches for GNAT LIBRARY --
-------------------------------
S_Lbr_Config : aliased constant S := "/CONFIG=@" &
"--config=@";
S_Lbr_Create : aliased constant S := "/CREATE=%" &
"--create=%";
S_Lbr_Delete : aliased constant S := "/DELETE=%" &
"--delete=%";
S_Lbr_Set : aliased constant S := "/SET=%" &
"--set=%";
Lbr_Switches : aliased constant Switches := (
S_Lbr_Config 'Access,
S_Lbr_Create 'Access,
S_Lbr_Delete 'Access,
S_Lbr_Set 'Access);
----------------------------
-- Switches for GNAT LINK --
----------------------------
S_Link_Bind : aliased constant S := "/BIND_FILE=" &
"ADA " &
"-A " &
"C " &
"-C";
S_Link_Debug : aliased constant S := "/DEBUG=" &
"ALL " &
"-g3 " &
"NONE " &
"-g0 " &
"TRACEBACK " &
"-g1 " &
"NOTRACEBACK " &
"-g0";
S_Link_Execut : aliased constant S := "/EXECUTABLE=@" &
"-o@";
S_Link_Ident : aliased constant S := "/IDENTIFICATION=" & '"' &
"--for-linker=IDENT=" &
'"';
S_Link_Nocomp : aliased constant S := "/NOCOMPILE " &
"-n";
S_Link_Nofiles : aliased constant S := "/NOSTART_FILES " &
"-nostartfiles";
S_Link_Noinhib : aliased constant S := "/NOINHIBIT-EXEC " &
"--for-linker=--noinhibit-exec";
S_Link_Static : aliased constant S := "/STATIC " &
"--for-linker=-static";
S_Link_Verb : aliased constant S := "/VERBOSE " &
"-v";
S_Link_ZZZZZ : aliased constant S := "/<other> " &
"--for-linker=";
Link_Switches : aliased constant Switches := (
S_Link_Bind 'Access,
S_Link_Debug 'Access,
S_Link_Execut 'Access,
S_Ext_Ref 'Access,
S_Link_Ident 'Access,
S_Link_Nocomp 'Access,
S_Link_Nofiles 'Access,
S_Link_Noinhib 'Access,
S_Project_File 'Access,
S_Project_Verb 'Access,
S_Link_Static 'Access,
S_Link_Verb 'Access,
S_Link_ZZZZZ 'Access);
----------------------------
-- Switches for GNAT LIST --
----------------------------
S_List_All : aliased constant S := "/ALL_UNITS " &
"-a";
S_List_Current : aliased constant S := "/CURRENT_DIRECTORY " &
"!-I-";
S_List_Depend : aliased constant S := "/DEPENDENCIES " &
"-d";
S_List_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
"-nostdinc";
S_List_Object : aliased constant S := "/OBJECT_SEARCH=*" &
"-aO*";
S_List_Output : aliased constant S := "/OUTPUT=" &
"SOURCES " &
"-s " &
"OBJECTS " &
"-o " &
"UNITS " &
"-u " &
"OPTIONS " &
"-h " &
"VERBOSE " &
"-v ";
S_List_Search : aliased constant S := "/SEARCH=*" &
"-I*";
S_List_Source : aliased constant S := "/SOURCE_SEARCH=*" &
"-aI*";
List_Switches : aliased constant Switches := (
S_List_All 'Access,
S_List_Current 'Access,
S_List_Depend 'Access,
S_Ext_Ref 'Access,
S_List_Nostinc 'Access,
S_List_Object 'Access,
S_List_Output 'Access,
S_Project_File 'Access,
S_Project_Verb 'Access,
S_List_Search 'Access,
S_List_Source 'Access);
----------------------------
-- Switches for GNAT MAKE --
----------------------------
S_Make_Actions : aliased constant S := "/ACTIONS=" &
"COMPILE " &
"-c " &
"BIND " &
"-b " &
"LINK " &
"-l ";
S_Make_All : aliased constant S := "/ALL_FILES " &
"-a";
S_Make_Bind : aliased constant S := "/BINDER_QUALIFIERS=?" &
"-bargs BIND";
S_Make_Comp : aliased constant S := "/COMPILER_QUALIFIERS=?" &
"-cargs COMPILE";
S_Make_Cond : aliased constant S := "/CONDITIONAL_SOURCE_SEARCH=*" &
"-A*";
S_Make_Cont : aliased constant S := "/CONTINUE_ON_ERROR " &
"-k";
S_Make_Current : aliased constant S := "/CURRENT_DIRECTORY " &
"!-I-";
S_Make_Dep : aliased constant S := "/DEPENDENCIES_LIST " &
"-M";
S_Make_Doobj : aliased constant S := "/DO_OBJECT_CHECK " &
"-n";
S_Make_Execut : aliased constant S := "/EXECUTABLE=@" &
"-o@";
S_Make_Force : aliased constant S := "/FORCE_COMPILE " &
"-f";
S_Make_Inplace : aliased constant S := "/IN_PLACE " &
"-i";
S_Make_Library : aliased constant S := "/LIBRARY_SEARCH=*" &
"-L*";
S_Make_Link : aliased constant S := "/LINKER_QUALIFIERS=?" &
"-largs LINK";
S_Make_Minimal : aliased constant S := "/MINIMAL_RECOMPILATION " &
"-m";
S_Make_Nolink : aliased constant S := "/NOLINK " &
"-c";
S_Make_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
"-nostdinc";
S_Make_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
"-nostdlib";
S_Make_Object : aliased constant S := "/OBJECT_SEARCH=*" &
"-aO*";
S_Make_Proc : aliased constant S := "/PROCESSES=#" &
"-j#";
S_Make_Nojobs : aliased constant S := "/NOPROCESSES " &
"-j1";
S_Make_Quiet : aliased constant S := "/QUIET " &
"-q";
S_Make_Reason : aliased constant S := "/REASONS " &
"-v";
S_Make_Search : aliased constant S := "/SEARCH=*" &
"-I*";
S_Make_Skip : aliased constant S := "/SKIP_MISSING=*" &
"-aL*";
S_Make_Source : aliased constant S := "/SOURCE_SEARCH=*" &
"-aI*";
S_Make_Verbose : aliased constant S := "/VERBOSE " &
"-v";
Make_Switches : aliased constant Switches := (
S_Make_Actions 'Access,
S_Make_All 'Access,
S_Make_Bind 'Access,
S_Make_Comp 'Access,
S_Make_Cond 'Access,
S_Make_Cont 'Access,
S_Make_Current 'Access,
S_Make_Dep 'Access,
S_Make_Doobj 'Access,
S_Make_Execut 'Access,
S_Ext_Ref 'Access,
S_Make_Force 'Access,
S_Make_Inplace 'Access,
S_Make_Library 'Access,
S_Make_Link 'Access,
S_Make_Minimal 'Access,
S_Make_Nolink 'Access,
S_Make_Nostinc 'Access,
S_Make_Nostlib 'Access,
S_Make_Object 'Access,
S_Make_Proc 'Access,
S_Project_File 'Access,
S_Project_Verb 'Access,
S_Make_Nojobs 'Access,
S_Make_Quiet 'Access,
S_Make_Reason 'Access,
S_Make_Search 'Access,
S_Make_Skip 'Access,
S_Make_Source 'Access,
S_Make_Verbose 'Access);
----------------------------------
-- Switches for GNAT PREPROCESS --
----------------------------------
S_Prep_Blank : aliased constant S := "/BLANK_LINES " &
"-b";
S_Prep_Com : aliased constant S := "/COMMENTS " &
"-c";
S_Prep_Ref : aliased constant S := "/REFERENCE " &
"-r";
S_Prep_Remove : aliased constant S := "/REMOVE " &
"!-b,!-c";
S_Prep_Symbols : aliased constant S := "/SYMBOLS " &
"-s";
S_Prep_Undef : aliased constant S := "/UNDEFINED " &
"-u";
S_Prep_Verbose : aliased constant S := "/VERBOSE " &
"-v";
S_Prep_Version : aliased constant S := "/VERSION " &
"-v";
Prep_Switches : aliased constant Switches := (
S_Prep_Blank 'Access,
S_Prep_Com 'Access,
S_Prep_Ref 'Access,
S_Prep_Remove 'Access,
S_Prep_Symbols 'Access,
S_Prep_Undef 'Access,
S_Prep_Verbose 'Access,
S_Prep_Version 'Access);
------------------------------
-- Switches for GNAT SHARED --
------------------------------
S_Shared_Debug : aliased constant S := "/DEBUG=" &
"ALL " &
"-g3 " &
"NONE " &
"-g0 " &
"TRACEBACK " &
"-g1 " &
"NOTRACEBACK " &
"-g0";
S_Shared_Image : aliased constant S := "/IMAGE=@" &
"-o@";
S_Shared_Ident : aliased constant S := "/IDENTIFICATION=" & '"' &
"--for-linker=IDENT=" &
'"';
S_Shared_Nofiles : aliased constant S := "/NOSTART_FILES " &
"-nostartfiles";
S_Shared_Noinhib : aliased constant S := "/NOINHIBIT-IMAGE " &
"--for-linker=--noinhibit-exec";
S_Shared_Verb : aliased constant S := "/VERBOSE " &
"-v";
S_Shared_ZZZZZ : aliased constant S := "/<other> " &
"--for-linker=";
Shared_Switches : aliased constant Switches := (
S_Shared_Debug 'Access,
S_Shared_Image 'Access,
S_Shared_Ident 'Access,
S_Shared_Nofiles 'Access,
S_Shared_Noinhib 'Access,
S_Shared_Verb 'Access,
S_Shared_ZZZZZ 'Access);
--------------------------------
-- Switches for GNAT STANDARD --
--------------------------------
Standard_Switches : aliased constant Switches := (1 .. 0 => null);
----------------------------
-- Switches for GNAT STUB --
----------------------------
S_Stub_Current : aliased constant S := "/CURRENT_DIRECTORY " &
"!-I-";
S_Stub_Full : aliased constant S := "/FULL " &
"-f";
S_Stub_Header : aliased constant S := "/HEADER=" &
"GENERAL " &
"-hg " &
"SPEC " &
"-hs";
S_Stub_Indent : aliased constant S := "/INDENTATION=#" &
"-i#";
S_Stub_Length : aliased constant S := "/LINE_LENGTH=#" &
"-l#";
S_Stub_Quiet : aliased constant S := "/QUIET " &
"-q";
S_Stub_Search : aliased constant S := "/SEARCH=*" &
"-I*";
S_Stub_Tree : aliased constant S := "/TREE_FILE=" &
"OVERWRITE " &
"-t " &
"SAVE " &
"-k " &
"REUSE " &
"-r";
S_Stub_Verbose : aliased constant S := "/VERBOSE " &
"-v";
Stub_Switches : aliased constant Switches := (
S_Stub_Current 'Access,
S_Stub_Full 'Access,
S_Stub_Header 'Access,
S_Stub_Indent 'Access,
S_Stub_Length 'Access,
S_Stub_Quiet 'Access,
S_Stub_Search 'Access,
S_Stub_Tree 'Access,
S_Stub_Verbose 'Access);
------------------------------
-- Switches for GNAT SYSTEM --
------------------------------
System_Switches : aliased constant Switches := (1 .. 0 => null);
----------------------------
-- Switches for GNAT XREF --
----------------------------
S_Xref_All : aliased constant S := "/ALL_FILES " &
"-a";
S_Xref_Full : aliased constant S := "/FULL_PATHNAME " &
"-f";
S_Xref_Global : aliased constant S := "/IGNORE_LOCALS " &
"-g";
S_Xref_Object : aliased constant S := "/OBJECT_SEARCH=*" &
"-aO*";
S_Xref_Project : aliased constant S := "/PROJECT=@" &
"-p@";
S_Xref_Search : aliased constant S := "/SEARCH=*" &
"-I*";
S_Xref_Source : aliased constant S := "/SOURCE_SEARCH=*" &
"-aI*";
S_Xref_Output : aliased constant S := "/UNUSED " &
"-u";
Xref_Switches : aliased constant Switches := (
S_Xref_All 'Access,
S_Ext_Ref 'Access,
S_Xref_Full 'Access,
S_Xref_Global 'Access,
S_Xref_Object 'Access,
S_Xref_Project 'Access,
S_Project_File 'Access,
S_Project_Verb 'Access,
S_Xref_Search 'Access,
S_Xref_Source 'Access,
S_Xref_Output 'Access);
-------------------
-- COMMAND TABLE --
-------------------
-- The command table contains an entry for each command recognized by
-- GNATCmd. The entries are represented by an array of records.
type Parameter_Type is
-- A parameter is defined as a whitespace bounded string, not begining
-- with a slash. (But see note under FILES_OR_WILDCARD).
(File,
-- A required file or directory parameter.
Optional_File,
-- An optional file or directory parameter.
Other_As_Is,
-- A parameter that's passed through as is (not canonicalized)
Unlimited_Files,
-- An unlimited number of writespace separate file or directory
-- parameters including wildcard specifications.
Files_Or_Wildcard);
-- A comma separated list of files and/or wildcard file specifications.
-- A comma preceded by or followed by whitespace is considered as a
-- single comma character w/o whitespace.
type Parameter_Array is array (Natural range <>) of Parameter_Type;
type Parameter_Ref is access all Parameter_Array;
type Command_Entry is record
Cname : String_Ptr;
-- Command name for GNAT xxx command
Usage : String_Ptr;
-- A usage string, used for error messages
Unixcmd : String_Ptr;
-- Corresponding Unix command
Switches : Switches_Ptr;
-- Pointer to array of switch strings
Params : Parameter_Ref;
-- Describes the allowable types of parameters.
-- Params (1) is the type of the first parameter, etc.
-- An empty parameter array means this command takes no parameters.
Defext : String (1 .. 3);
-- Default extension. If non-blank, then this extension is supplied by
-- default as the extension for any file parameter which does not have
-- an extension already.
end record;
-------------------------
-- INTERNAL STRUCTURES --
-------------------------
-- The switches and commands are defined by strings in the previous
-- section so that they are easy to modify, but internally, they are
-- kept in a more conveniently accessible form described in this
-- section.
-- Commands, command qualifers and options have a similar common format
-- so that searching for matching names can be done in a common manner.
type Item_Id is (Id_Command, Id_Switch, Id_Option);
type Translation_Type is
(
T_Direct,
-- A qualifier with no options.
-- Example: GNAT MAKE /VERBOSE
T_Directories,
-- A qualifier followed by a list of directories
-- Example: GNAT COMPILE /SEARCH=([], [.FOO], [.BAR])
T_Directory,
-- A qualifier followed by one directory
-- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB]
T_File,
-- A quailifier followed by a filename
-- Example: GNAT LINK /EXECUTABLE=FOO.EXE
T_Numeric,
-- A qualifier followed by a numeric value.
-- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39
T_String,
-- A qualifier followed by a quoted string. Only used by
-- /IDENTIFICATION qualfier.
-- Example: GNAT LINK /IDENTIFICATION="3.14a1 version"
T_Options,
-- A qualifier followed by a list of options.
-- Example: GNAT COMPILE /REPRESENTATION_INFO=(ARRAYS,OBJECTS)
T_Commands,
-- A qualifier followed by a list. Only used for
-- MAKE /COMPILER_QUALIFIERS /BINDER_QUALIFIERS /LINKER_QUALIFIERS
-- (gnatmake -cargs -bargs -largs )
-- Example: GNAT MAKE ... /LINKER_QUALIFIERS /VERBOSE FOOBAR.OBJ
T_Other,
-- A qualifier passed directly to the linker. Only used
-- for LINK and SHARED if no other match is found.
-- Example: GNAT LINK FOO.ALI /SYSSHR
T_Alphanumplus
-- A qualifier followed by a legal linker symbol prefix. Only used
-- for BIND /BUILD_LIBRARY (gnatbind -Lxyz).
-- Example: GNAT BIND /BUILD_LIBRARY=foobar
);
type Item (Id : Item_Id);
type Item_Ptr is access all Item;
type Item (Id : Item_Id) is record
Name : String_Ptr;
-- Name of the command, switch (with slash) or option
Next : Item_Ptr;
-- Pointer to next item on list, always has the same Id value
Unix_String : String_Ptr;
-- Corresponding Unix string. For a command, this is the unix command
-- name and possible default switches. For a switch or option it is
-- the unix switch string.
case Id is
when Id_Command =>
Switches : Item_Ptr;
-- Pointer to list of switch items for the command, linked
-- through the Next fields with null terminating the list.
Usage : String_Ptr;
-- Usage information, used only for errors and the default
-- list of commands output.
Params : Parameter_Ref;
-- Array of parameters
Defext : String (1 .. 3);
-- Default extension. If non-blank, then this extension is
-- supplied by default as the extension for any file parameter
-- which does not have an extension already.
when Id_Switch =>
Translation : Translation_Type;
-- Type of switch translation. For all cases, except Options,
-- this is the only field needed, since the Unix translation
-- is found in Unix_String.
Options : Item_Ptr;
-- For the Options case, this field is set to point to a list
-- of options item (for this case Unix_String is null in the
-- main switch item). The end of the list is marked by null.
when Id_Option =>
null;
-- No special fields needed, since Name and Unix_String are
-- sufficient to completely described an option.
end case;
end record;
subtype Command_Item is Item (Id_Command);
subtype Switch_Item is Item (Id_Switch);
subtype Option_Item is Item (Id_Option);
----------------------------------
-- Declarations for GNATCMD use --
----------------------------------
Commands : Item_Ptr;
-- Pointer to head of list of command items, one for each command, with
-- the end of the list marked by a null pointer.
Last_Command : Item_Ptr;
-- Pointer to last item in Commands list
Normal_Exit : exception;
-- Raise this exception for normal program termination
Error_Exit : exception;
-- Raise this exception if error detected
Errors : Natural := 0;
-- Count errors detected
Command : Item_Ptr;
-- Pointer to command item for current command
Make_Commands_Active : Item_Ptr := null;
-- Set to point to Command entry for COMPILE, BIND, or LINK as appropriate
-- if a COMMANDS_TRANSLATION switch has been encountered while processing
-- a MAKE Command.
My_Exit_Status : Exit_Status := Success;
package Buffer is new Table.Table (
Table_Component_Type => Character,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 4096,
Table_Increment => 2,
Table_Name => "Buffer");
Param_Count : Natural := 0;
-- Number of parameter arguments so far
Arg_Num : Natural;
-- Argument number
Display_Command : Boolean := False;
-- Set true if /? switch causes display of generated command
-----------------------
-- Local Subprograms --
-----------------------
function Init_Object_Dirs return String_Ptr;
function Invert_Sense (S : String) return String_Ptr;
-- Given a unix switch string S, computes the inverse (adding or
-- removing ! characters as required), and returns a pointer to
-- the allocated result on the heap.
function Is_Extensionless (F : String) return Boolean;
-- Returns true if the filename has no extension.
function Match (S1, S2 : String) return Boolean;
-- Determines whether S1 and S2 match. This is a case insensitive match.
function Match_Prefix (S1, S2 : String) return Boolean;
-- Determines whether S1 matches a prefix of S2. This is also a case
-- insensitive match (for example Match ("AB","abc") is True).
function Matching_Name
(S : String;
Itm : Item_Ptr;
Quiet : Boolean := False)
return Item_Ptr;
-- Determines if the item list headed by Itm and threaded through the
-- Next fields (with null marking the end of the list), contains an
-- entry that uniquely matches the given string. The match is case
-- insensitive and permits unique abbreviation. If the match succeeds,
-- then a pointer to the matching item is returned. Otherwise, an
-- appropriate error message is written. Note that the discriminant
-- of Itm is used to determine the appropriate form of this message.
-- Quiet is normally False as shown, if it is set to True, then no
-- error message is generated in a not found situation (null is still
-- returned to indicate the not-found situation).
function OK_Alphanumerplus (S : String) return Boolean;
-- Checks that S is a string of alphanumeric characters,
-- returning True if all alphanumeric characters,
-- False if empty or a non-alphanumeric character is present.
function OK_Integer (S : String) return Boolean;
-- Checks that S is a string of digits, returning True if all digits,
-- False if empty or a non-digit is present.
procedure Place (C : Character);
-- Place a single character in the buffer, updating Ptr
procedure Place (S : String);
-- Place a string character in the buffer, updating Ptr
procedure Place_Lower (S : String);
-- Place string in buffer, forcing letters to lower case, updating Ptr
procedure Place_Unix_Switches (S : String_Ptr);
-- Given a unix switch string, place corresponding switches in Buffer,
-- updating Ptr appropriatelly. Note that in the case of use of ! the
-- result may be to remove a previously placed switch.
procedure Validate_Command_Or_Option (N : String_Ptr);
-- Check that N is a valid command or option name, i.e. that it is of the
-- form of an Ada identifier with upper case letters and underscores.
procedure Validate_Unix_Switch (S : String_Ptr);
-- Check that S is a valid switch string as described in the syntax for
-- the switch table item UNIX_SWITCH or else begins with a backquote.
----------------------
-- Init_Object_Dirs --
----------------------
function Init_Object_Dirs return String_Ptr is
Object_Dirs : Integer;
Object_Dir : array (Integer range 1 .. 256) of String_Access;
Object_Dir_Name : String_Access;
begin
Object_Dirs := 0;
Object_Dir_Name := String_Access (Object_Dir_Default_Name);
Get_Next_Dir_In_Path_Init (Object_Dir_Name);
loop
declare
Dir : String_Access := String_Access
(Get_Next_Dir_In_Path (Object_Dir_Name));
begin
exit when Dir = null;
Object_Dirs := Object_Dirs + 1;
Object_Dir (Object_Dirs)
:= String_Access (Normalize_Directory_Name (Dir.all));
end;
end loop;
for Dirs in 1 .. Object_Dirs loop
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := '-';
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := 'L';
Object_Dir_Name := new String'(
To_Canonical_Dir_Spec
(To_Host_Dir_Spec (Object_Dir (Dirs).all, True).all, True).all);
for J in Object_Dir_Name'Range loop
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := Object_Dir_Name (J);
end loop;
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := ' ';
end loop;
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := '-';
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := 'l';
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := 'g';
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := 'n';
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := 'a';
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := 't';
if Hostparm.OpenVMS then
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := ' ';
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := '-';
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := 'l';
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := 'd';
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := 'e';
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := 'c';
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := 'g';
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := 'n';
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := 'a';
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := 't';
end if;
return new String'(String (Buffer.Table (1 .. Buffer.Last)));
end Init_Object_Dirs;
------------------
-- Invert_Sense --
------------------
function Invert_Sense (S : String) return String_Ptr is
Sinv : String (1 .. S'Length * 2);
-- Result (for sure long enough)
Sinvp : Natural := 0;
-- Pointer to output string
begin
for Sp in S'Range loop
if Sp = S'First or else S (Sp - 1) = ',' then
if S (Sp) = '!' then
null;
else
Sinv (Sinvp + 1) := '!';
Sinv (Sinvp + 2) := S (Sp);
Sinvp := Sinvp + 2;
end if;
else
Sinv (Sinvp + 1) := S (Sp);
Sinvp := Sinvp + 1;
end if;
end loop;
return new String'(Sinv (1 .. Sinvp));
end Invert_Sense;
----------------------
-- Is_Extensionless --
----------------------
function Is_Extensionless (F : String) return Boolean is
begin
for J in reverse F'Range loop
if F (J) = '.' then
return False;
elsif F (J) = '/' or else F (J) = ']' or else F (J) = ':' then
return True;
end if;
end loop;
return True;
end Is_Extensionless;
-----------
-- Match --
-----------
function Match (S1, S2 : String) return Boolean is
Dif : constant Integer := S2'First - S1'First;
begin
if S1'Length /= S2'Length then
return False;
else
for J in S1'Range loop
if To_Lower (S1 (J)) /= To_Lower (S2 (J + Dif)) then
return False;
end if;
end loop;
return True;
end if;
end Match;
------------------
-- Match_Prefix --
------------------
function Match_Prefix (S1, S2 : String) return Boolean is
begin
if S1'Length > S2'Length then
return False;
else
return Match (S1, S2 (S2'First .. S2'First + S1'Length - 1));
end if;
end Match_Prefix;
-------------------
-- Matching_Name --
-------------------
function Matching_Name
(S : String;
Itm : Item_Ptr;
Quiet : Boolean := False)
return Item_Ptr
is
P1, P2 : Item_Ptr;
procedure Err;
-- Little procedure to output command/qualifier/option as appropriate
-- and bump error count.
procedure Err is
begin
if Quiet then
return;
end if;
Errors := Errors + 1;
if Itm /= null then
case Itm.Id is
when Id_Command =>
Put (Standard_Error, "command");
when Id_Switch =>
if OpenVMS then
Put (Standard_Error, "qualifier");
else
Put (Standard_Error, "switch");
end if;
when Id_Option =>
Put (Standard_Error, "option");
end case;
else
Put (Standard_Error, "input");
end if;
Put (Standard_Error, ": ");
Put (Standard_Error, S);
end Err;
-- Start of processing for Matching_Name
begin
-- If exact match, that's the one we want
P1 := Itm;
while P1 /= null loop
if Match (S, P1.Name.all) then
return P1;
else
P1 := P1.Next;
end if;
end loop;
-- Now check for prefix matches
P1 := Itm;
while P1 /= null loop
if P1.Name.all = "/<other>" then
return P1;
elsif not Match_Prefix (S, P1.Name.all) then
P1 := P1.Next;
else
-- Here we have found one matching prefix, so see if there is
-- another one (which is an ambiguity)
P2 := P1.Next;
while P2 /= null loop
if Match_Prefix (S, P2.Name.all) then
if not Quiet then
Put (Standard_Error, "ambiguous ");
Err;
Put (Standard_Error, " (matches ");
Put (Standard_Error, P1.Name.all);
while P2 /= null loop
if Match_Prefix (S, P2.Name.all) then
Put (Standard_Error, ',');
Put (Standard_Error, P2.Name.all);
end if;
P2 := P2.Next;
end loop;
Put_Line (Standard_Error, ")");
end if;
return null;
end if;
P2 := P2.Next;
end loop;
-- If we fall through that loop, then there was only one match
return P1;
end if;
end loop;
-- If we fall through outer loop, there was no match
if not Quiet then
Put (Standard_Error, "unrecognized ");
Err;
New_Line (Standard_Error);
end if;
return null;
end Matching_Name;
-----------------------
-- OK_Alphanumerplus --
-----------------------
function OK_Alphanumerplus (S : String) return Boolean is
begin
if S'Length = 0 then
return False;
else
for J in S'Range loop
if not (Is_Alphanumeric (S (J)) or else
S (J) = '_' or else S (J) = '$')
then
return False;
end if;
end loop;
return True;
end if;
end OK_Alphanumerplus;
----------------
-- OK_Integer --
----------------
function OK_Integer (S : String) return Boolean is
begin
if S'Length = 0 then
return False;
else
for J in S'Range loop
if not Is_Digit (S (J)) then
return False;
end if;
end loop;
return True;
end if;
end OK_Integer;
-----------
-- Place --
-----------
procedure Place (C : Character) is
begin
Buffer.Increment_Last;
Buffer.Table (Buffer.Last) := C;
end Place;
procedure Place (S : String) is
begin
for J in S'Range loop
Place (S (J));
end loop;
end Place;
-----------------
-- Place_Lower --
-----------------
procedure Place_Lower (S : String) is
begin
for J in S'Range loop
Place (To_Lower (S (J)));
end loop;
end Place_Lower;
-------------------------
-- Place_Unix_Switches --
-------------------------
procedure Place_Unix_Switches (S : String_Ptr) is
P1, P2, P3 : Natural;
Remove : Boolean;
Slen : Natural;
begin
P1 := S'First;
while P1 <= S'Last loop
if S (P1) = '!' then
P1 := P1 + 1;
Remove := True;
else
Remove := False;
end if;
P2 := P1;
pragma Assert (S (P1) = '-' or else S (P1) = '`');
while P2 < S'Last and then S (P2 + 1) /= ',' loop
P2 := P2 + 1;
end loop;
-- Switch is now in S (P1 .. P2)
Slen := P2 - P1 + 1;
if Remove then
P3 := 2;
while P3 <= Buffer.Last - Slen loop
if Buffer.Table (P3) = ' '
and then String (Buffer.Table (P3 + 1 .. P3 + Slen))
= S (P1 .. P2)
and then (P3 + Slen = Buffer.Last
or else
Buffer.Table (P3 + Slen + 1) = ' ')
then
Buffer.Table (P3 .. Buffer.Last - Slen - 1) :=
Buffer.Table (P3 + Slen + 1 .. Buffer.Last);
Buffer.Set_Last (Buffer.Last - Slen - 1);
else
P3 := P3 + 1;
end if;
end loop;
else
Place (' ');
if S (P1) = '`' then
P1 := P1 + 1;
end if;
Place (S (P1 .. P2));
end if;
P1 := P2 + 2;
end loop;
end Place_Unix_Switches;
--------------------------------
-- Validate_Command_Or_Option --
--------------------------------
procedure Validate_Command_Or_Option (N : String_Ptr) is
begin
pragma Assert (N'Length > 0);
for J in N'Range loop
if N (J) = '_' then
pragma Assert (N (J - 1) /= '_');
null;
else
pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J)));
null;
end if;
end loop;
end Validate_Command_Or_Option;
--------------------------
-- Validate_Unix_Switch --
--------------------------
procedure Validate_Unix_Switch (S : String_Ptr) is
begin
if S (S'First) = '`' then
return;
end if;
pragma Assert (S (S'First) = '-' or else S (S'First) = '!');
for J in S'First + 1 .. S'Last loop
pragma Assert (S (J) /= ' ');
if S (J) = '!' then
pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-');
null;
end if;
end loop;
end Validate_Unix_Switch;
----------------------
-- List of Commands --
----------------------
-- Note that we put this after all the local bodies to avoid
-- some access before elaboration problems.
Command_List : array (Natural range <>) of Command_Entry := (
(Cname => new S'("BIND"),
Usage => new S'("GNAT BIND file[.ali] /qualifiers"),
Unixcmd => new S'("gnatbind"),
Switches => Bind_Switches'Access,
Params => new Parameter_Array'(1 => File),
Defext => "ali"),
(Cname => new S'("CHOP"),
Usage => new S'("GNAT CHOP file [directory] /qualifiers"),
Unixcmd => new S'("gnatchop"),
Switches => Chop_Switches'Access,
Params => new Parameter_Array'(1 => File, 2 => Optional_File),
Defext => " "),
(Cname => new S'("COMPILE"),
Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"),
Unixcmd => new S'("gcc -c -x ada"),
Switches => GCC_Switches'Access,
Params => new Parameter_Array'(1 => Files_Or_Wildcard),
Defext => " "),
(Cname => new S'("ELIM"),
Usage => new S'("GNAT ELIM name /qualifiers"),
Unixcmd => new S'("gnatelim"),
Switches => Elim_Switches'Access,
Params => new Parameter_Array'(1 => Other_As_Is),
Defext => "ali"),
(Cname => new S'("FIND"),
Usage => new S'("GNAT FIND pattern[:sourcefile[:line[:column]]]" &
" filespec[,...] /qualifiers"),
Unixcmd => new S'("gnatfind"),
Switches => Find_Switches'Access,
Params => new Parameter_Array'(1 => Other_As_Is,
2 => Files_Or_Wildcard),
Defext => "ali"),
(Cname => new S'("KRUNCH"),
Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"),
Unixcmd => new S'("gnatkr"),
Switches => Krunch_Switches'Access,
Params => new Parameter_Array'(1 => File),
Defext => " "),
(Cname => new S'("LIBRARY"),
Usage => new S'("GNAT LIBRARY /[CREATE | SET | DELETE]=directory"
& " [/CONFIG=file]"),
Unixcmd => new S'("gnatlbr"),
Switches => Lbr_Switches'Access,
Params => new Parameter_Array'(1 .. 0 => File),
Defext => " "),
(Cname => new S'("LINK"),
Usage => new S'("GNAT LINK file[.ali]"
& " [extra obj_&_lib_&_exe_&_opt files]"
& " /qualifiers"),
Unixcmd => new S'("gnatlink"),
Switches => Link_Switches'Access,
Params => new Parameter_Array'(1 => Unlimited_Files),
Defext => "ali"),
(Cname => new S'("LIST"),
Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"),
Unixcmd => new S'("gnatls"),
Switches => List_Switches'Access,
Params => new Parameter_Array'(1 => File),
Defext => "ali"),
(Cname => new S'("MAKE"),
Usage =>
new S'("GNAT MAKE file /qualifiers (includes COMPILE /qualifiers)"),
Unixcmd => new S'("gnatmake"),
Switches => Make_Switches'Access,
Params => new Parameter_Array'(1 => File),
Defext => " "),
(Cname => new S'("PREPROCESS"),
Usage => new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"),
Unixcmd => new S'("gnatprep"),
Switches => Prep_Switches'Access,
Params => new Parameter_Array'(1 .. 3 => File),
Defext => " "),
(Cname => new S'("SHARED"),
Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt files]"
& " /qualifiers"),
Unixcmd => new S'("gcc -shared " & Init_Object_Dirs.all),
Switches => Shared_Switches'Access,
Params => new Parameter_Array'(1 => Unlimited_Files),
Defext => " "),
(Cname => new S'("STANDARD"),
Usage => new S'("GNAT STANDARD"),
Unixcmd => new S'("gnatpsta"),
Switches => Standard_Switches'Access,
Params => new Parameter_Array'(1 .. 0 => File),
Defext => " "),
(Cname => new S'("STUB"),
Usage => new S'("GNAT STUB file [directory] /qualifiers"),
Unixcmd => new S'("gnatstub"),
Switches => Stub_Switches'Access,
Params => new Parameter_Array'(1 => File, 2 => Optional_File),
Defext => " "),
(Cname => new S'("SYSTEM"),
Usage => new S'("GNAT SYSTEM"),
Unixcmd => new S'("gnatpsys"),
Switches => System_Switches'Access,
Params => new Parameter_Array'(1 .. 0 => File),
Defext => " "),
(Cname => new S'("XREF"),
Usage => new S'("GNAT XREF filespec[,...] /qualifiers"),
Unixcmd => new S'("gnatxref"),
Switches => Xref_Switches'Access,
Params => new Parameter_Array'(1 => Files_Or_Wildcard),
Defext => "ali")
);
-------------------------------------
-- Start of processing for GNATCmd --
-------------------------------------
begin
Buffer.Init;
-- First we must preprocess the string form of the command and options
-- list into the internal form that we use.
for C in Command_List'Range loop
declare
Command : Item_Ptr := new Command_Item;
Last_Switch : Item_Ptr;
-- Last switch in list
begin
-- Link new command item into list of commands
if Last_Command = null then
Commands := Command;
else
Last_Command.Next := Command;
end if;
Last_Command := Command;
-- Fill in fields of new command item
Command.Name := Command_List (C).Cname;
Command.Usage := Command_List (C).Usage;
Command.Unix_String := Command_List (C).Unixcmd;
Command.Params := Command_List (C).Params;
Command.Defext := Command_List (C).Defext;
Validate_Command_Or_Option (Command.Name);
-- Process the switch list
for S in Command_List (C).Switches'Range loop
declare
SS : constant String_Ptr := Command_List (C).Switches (S);
P : Natural := SS'First;
Sw : Item_Ptr := new Switch_Item;
Last_Opt : Item_Ptr;
-- Pointer to last option
begin
-- Link new switch item into list of switches
if Last_Switch = null then
Command.Switches := Sw;
else
Last_Switch.Next := Sw;
end if;
Last_Switch := Sw;
-- Process switch string, first get name
while SS (P) /= ' ' and SS (P) /= '=' loop
P := P + 1;
end loop;
Sw.Name := new String'(SS (SS'First .. P - 1));
-- Direct translation case
if SS (P) = ' ' then
Sw.Translation := T_Direct;
Sw.Unix_String := new String'(SS (P + 1 .. SS'Last));
Validate_Unix_Switch (Sw.Unix_String);
if SS (P - 1) = '>' then
Sw.Translation := T_Other;
elsif SS (P + 1) = '`' then
null;
-- Create the inverted case (/NO ..)
elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then
Sw := new Switch_Item;
Last_Switch.Next := Sw;
Last_Switch := Sw;
Sw.Name :=
new String'("/NO" & SS (SS'First + 1 .. P - 1));
Sw.Translation := T_Direct;
Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last));
Validate_Unix_Switch (Sw.Unix_String);
end if;
-- Directories translation case
elsif SS (P + 1) = '*' then
pragma Assert (SS (SS'Last) = '*');
Sw.Translation := T_Directories;
Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
Validate_Unix_Switch (Sw.Unix_String);
-- Directory translation case
elsif SS (P + 1) = '%' then
pragma Assert (SS (SS'Last) = '%');
Sw.Translation := T_Directory;
Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
Validate_Unix_Switch (Sw.Unix_String);
-- File translation case
elsif SS (P + 1) = '@' then
pragma Assert (SS (SS'Last) = '@');
Sw.Translation := T_File;
Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
Validate_Unix_Switch (Sw.Unix_String);
-- Numeric translation case
elsif SS (P + 1) = '#' then
pragma Assert (SS (SS'Last) = '#');
Sw.Translation := T_Numeric;
Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
Validate_Unix_Switch (Sw.Unix_String);
-- Alphanumerplus translation case
elsif SS (P + 1) = '|' then
pragma Assert (SS (SS'Last) = '|');
Sw.Translation := T_Alphanumplus;
Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
Validate_Unix_Switch (Sw.Unix_String);
-- String translation case
elsif SS (P + 1) = '"' then
pragma Assert (SS (SS'Last) = '"');
Sw.Translation := T_String;
Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
Validate_Unix_Switch (Sw.Unix_String);
-- Commands translation case
elsif SS (P + 1) = '?' then
Sw.Translation := T_Commands;
Sw.Unix_String := new String'(SS (P + 2 .. SS'Last));
-- Options translation case
else
Sw.Translation := T_Options;
Sw.Unix_String := new String'("");
P := P + 1; -- bump past =
while P <= SS'Last loop
declare
Opt : Item_Ptr := new Option_Item;
Q : Natural;
begin
-- Link new option item into options list
if Last_Opt = null then
Sw.Options := Opt;
else
Last_Opt.Next := Opt;
end if;
Last_Opt := Opt;
-- Fill in fields of new option item
Q := P;
while SS (Q) /= ' ' loop
Q := Q + 1;
end loop;
Opt.Name := new String'(SS (P .. Q - 1));
Validate_Command_Or_Option (Opt.Name);
P := Q + 1;
Q := P;
while Q <= SS'Last and then SS (Q) /= ' ' loop
Q := Q + 1;
end loop;
Opt.Unix_String := new String'(SS (P .. Q - 1));
Validate_Unix_Switch (Opt.Unix_String);
P := Q + 1;
end;
end loop;
end if;
end;
end loop;
end;
end loop;
-- If no parameters, give complete list of commands
if Argument_Count = 0 then
Put_Line ("List of available commands");
New_Line;
while Commands /= null loop
Put (Commands.Usage.all);
Set_Col (53);
Put_Line (Commands.Unix_String.all);
Commands := Commands.Next;
end loop;
raise Normal_Exit;
end if;
Arg_Num := 1;
loop
exit when Arg_Num > Argument_Count;
declare
Argv : String_Access;
Arg_Idx : Integer;
function Get_Arg_End
(Argv : String;
Arg_Idx : Integer)
return Integer;
-- Begins looking at Arg_Idx + 1 and returns the index of the
-- last character before a slash or else the index of the last
-- character in the string Argv.
function Get_Arg_End
(Argv : String;
Arg_Idx : Integer)
return Integer
is
begin
for J in Arg_Idx + 1 .. Argv'Last loop
if Argv (J) = '/' then
return J - 1;
end if;
end loop;
return Argv'Last;
end Get_Arg_End;
begin
Argv := new String'(Argument (Arg_Num));
Arg_Idx := Argv'First;
<<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;
-- Give usage information if only command given
if Argument_Count = 1 and then Next_Arg_Idx = Argv'Last
and then
not (Command.Name.all = "SYSTEM"
or else Command.Name.all = "STANDARD")
then
Put_Line ("List of available qualifiers and options");
New_Line;
Put (Command.Usage.all);
Set_Col (53);
Put_Line (Command.Unix_String.all);
declare
Sw : Item_Ptr := Command.Switches;
begin
while Sw /= null loop
Put (" ");
Put (Sw.Name.all);
case Sw.Translation is
when T_Other =>
Set_Col (53);
Put_Line (Sw.Unix_String.all & "/<other>");
when T_Direct =>
Set_Col (53);
Put_Line (Sw.Unix_String.all);
when T_Directories =>
Put ("=(direc,direc,..direc)");
Set_Col (53);
Put (Sw.Unix_String.all);
Put (" direc ");
Put (Sw.Unix_String.all);
Put_Line (" direc ...");
when T_Directory =>
Put ("=directory");
Set_Col (53);
Put (Sw.Unix_String.all);
if Sw.Unix_String (Sw.Unix_String'Last)
/= '='
then
Put (' ');
end if;
Put_Line ("directory ");
when T_File =>
Put ("=file");
Set_Col (53);
Put (Sw.Unix_String.all);
if Sw.Unix_String (Sw.Unix_String'Last)
/= '='
then
Put (' ');
end if;
Put_Line ("file ");
when T_Numeric =>
Put ("=nnn");
Set_Col (53);
if Sw.Unix_String (Sw.Unix_String'First)
= '`'
then
Put (Sw.Unix_String
(Sw.Unix_String'First + 1
.. Sw.Unix_String'Last));
else
Put (Sw.Unix_String.all);
end if;
Put_Line ("nnn");
when T_Alphanumplus =>
Put ("=xyz");
Set_Col (53);
if Sw.Unix_String (Sw.Unix_String'First)
= '`'
then
Put (Sw.Unix_String
(Sw.Unix_String'First + 1
.. Sw.Unix_String'Last));
else
Put (Sw.Unix_String.all);
end if;
Put_Line ("xyz");
when T_String =>
Put ("=");
Put ('"');
Put ("<string>");
Put ('"');
Set_Col (53);
Put (Sw.Unix_String.all);
if Sw.Unix_String (Sw.Unix_String'Last)
/= '='
then
Put (' ');
end if;
Put ("<string>");
New_Line;
when T_Commands =>
Put (" (switches for ");
Put (Sw.Unix_String (
Sw.Unix_String'First + 7
.. Sw.Unix_String'Last));
Put (')');
Set_Col (53);
Put (Sw.Unix_String (
Sw.Unix_String'First
.. Sw.Unix_String'First + 5));
Put_Line (" switches");
when T_Options =>
declare
Opt : Item_Ptr := Sw.Options;
begin
Put_Line ("=(option,option..)");
while Opt /= null loop
Put (" ");
Put (Opt.Name.all);
if Opt = Sw.Options then
Put (" (D)");
end if;
Set_Col (53);
Put_Line (Opt.Unix_String.all);
Opt := Opt.Next;
end loop;
end;
end case;
Sw := Sw.Next;
end loop;
end;
raise Normal_Exit;
end if;
Place (Command.Unix_String.all);
-- Special handling for internal debugging switch /?
elsif Arg.all = "/?" then
Display_Command := True;
-- Copy -switch unchanged
elsif Arg (Arg'First) = '-' then
Place (' ');
Place (Arg.all);
-- Copy quoted switch with quotes stripped
elsif Arg (Arg'First) = '"' then
if Arg (Arg'Last) /= '"' then
Put (Standard_Error, "misquoted argument: ");
Put_Line (Standard_Error, Arg.all);
Errors := Errors + 1;
else
Put (Arg (Arg'First + 1 .. Arg'Last - 1));
end if;
-- Parameter Argument
elsif Arg (Arg'First) /= '/'
and then Make_Commands_Active = null
then
Param_Count := Param_Count + 1;
if Param_Count <= Command.Params'Length then
case Command.Params (Param_Count) is
when File | Optional_File =>
declare
Normal_File : String_Access
:= To_Canonical_File_Spec (Arg.all);
begin
Place (' ');
Place_Lower (Normal_File.all);
if Is_Extensionless (Normal_File.all)
and then Command.Defext /= " "
then
Place ('.');
Place (Command.Defext);
end if;
end;
when Unlimited_Files =>
declare
Normal_File : String_Access
:= To_Canonical_File_Spec (Arg.all);
File_Is_Wild : Boolean := False;
File_List : String_Access_List_Access;
begin
for I in Arg'Range loop
if Arg (I) = '*'
or else Arg (I) = '%'
then
File_Is_Wild := True;
end if;
end loop;
if File_Is_Wild then
File_List := To_Canonical_File_List
(Arg.all, False);
for I in File_List.all'Range loop
Place (' ');
Place_Lower (File_List.all (I).all);
end loop;
else
Place (' ');
Place_Lower (Normal_File.all);
if Is_Extensionless (Normal_File.all)
and then Command.Defext /= " "
then
Place ('.');
Place (Command.Defext);
end if;
end if;
Param_Count := Param_Count - 1;
end;
when Other_As_Is =>
Place (' ');
Place (Arg.all);
when Files_Or_Wildcard =>
-- Remove spaces from a comma separated list
-- of file names and adjust control variables
-- accordingly.
while Arg_Num < Argument_Count and then
(Argv (Argv'Last) = ',' xor
Argument (Arg_Num + 1)
(Argument (Arg_Num + 1)'First) = ',')
loop
Argv := new String'(Argv.all
& Argument (Arg_Num + 1));
Arg_Num := Arg_Num + 1;
Arg_Idx := Argv'First;
Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx);
Arg :=
new String'(Argv (Arg_Idx .. Next_Arg_Idx));
end loop;
-- Parse the comma separated list of VMS filenames
-- and place them on the command line as space
-- separated Unix style filenames. Lower case and
-- add default extension as appropriate.
declare
Arg1_Idx : Integer := Arg'First;
function Get_Arg1_End
(Arg : String; Arg_Idx : Integer)
return Integer;
-- Begins looking at Arg_Idx + 1 and
-- returns the index of the last character
-- before a comma or else the index of the
-- last character in the string Arg.
function Get_Arg1_End
(Arg : String; Arg_Idx : Integer)
return Integer
is
begin
for I in Arg_Idx + 1 .. Arg'Last loop
if Arg (I) = ',' then
return I - 1;
end if;
end loop;
return Arg'Last;
end Get_Arg1_End;
begin
loop
declare
Next_Arg1_Idx : Integer
:= Get_Arg1_End (Arg.all, Arg1_Idx);
Arg1 : String
:= Arg (Arg1_Idx .. Next_Arg1_Idx);
Normal_File : String_Access
:= To_Canonical_File_Spec (Arg1);
begin
Place (' ');
Place_Lower (Normal_File.all);
if Is_Extensionless (Normal_File.all)
and then Command.Defext /= " "
then
Place ('.');
Place (Command.Defext);
end if;
Arg1_Idx := Next_Arg1_Idx + 1;
end;
exit when Arg1_Idx > Arg'Last;
-- Don't allow two or more commas in a row
if Arg (Arg1_Idx) = ',' then
Arg1_Idx := Arg1_Idx + 1;
if Arg1_Idx > Arg'Last or else
Arg (Arg1_Idx) = ','
then
Put_Line (Standard_Error,
"Malformed Parameter: " & Arg.all);
Put (Standard_Error, "usage: ");
Put_Line (Standard_Error,
Command.Usage.all);
raise Error_Exit;
end if;
end if;
end loop;
end;
end case;
end if;
-- Qualifier argument
else
declare
Sw : Item_Ptr;
SwP : Natural;
P2 : Natural;
Endp : Natural := 0; -- avoid warning!
Opt : Item_Ptr;
begin
SwP := Arg'First;
while SwP < Arg'Last and then Arg (SwP + 1) /= '=' loop
SwP := SwP + 1;
end loop;
-- At this point, the switch name is in
-- Arg (Arg'First..SwP) and if that is not the whole
-- switch, then there is an equal sign at
-- Arg (SwP + 1) and the rest of Arg is what comes
-- after the equal sign.
-- If make commands are active, see if we have another
-- COMMANDS_TRANSLATION switch belonging to gnatmake.
if Make_Commands_Active /= null then
Sw :=
Matching_Name
(Arg (Arg'First .. SwP),
Command.Switches,
Quiet => True);
if Sw /= null and then Sw.Translation = T_Commands then
null;
else
Sw :=
Matching_Name
(Arg (Arg'First .. SwP),
Make_Commands_Active.Switches,
Quiet => False);
end if;
-- For case of GNAT MAKE or CHOP, if we cannot find the
-- switch, then see if it is a recognized compiler switch
-- instead, and if so process the compiler switch.
elsif Command.Name.all = "MAKE"
or else Command.Name.all = "CHOP" then
Sw :=
Matching_Name
(Arg (Arg'First .. SwP),
Command.Switches,
Quiet => True);
if Sw = null then
Sw :=
Matching_Name
(Arg (Arg'First .. SwP),
Matching_Name ("COMPILE", Commands).Switches,
Quiet => False);
end if;
-- For all other cases, just search the relevant command
else
Sw :=
Matching_Name
(Arg (Arg'First .. SwP),
Command.Switches,
Quiet => False);
end if;
if Sw /= null then
case Sw.Translation is
when T_Direct =>
Place_Unix_Switches (Sw.Unix_String);
if Arg (SwP + 1) = '=' then
Put (Standard_Error,
"qualifier options ignored: ");
Put_Line (Standard_Error, Arg.all);
end if;
when T_Directories =>
if SwP + 1 > Arg'Last then
Put (Standard_Error,
"missing directories for: ");
Put_Line (Standard_Error, Arg.all);
Errors := Errors + 1;
elsif Arg (SwP + 2) /= '(' then
SwP := SwP + 2;
Endp := Arg'Last;
elsif Arg (Arg'Last) /= ')' then
-- Remove spaces from a comma separated list
-- of file names and adjust control
-- variables accordingly.
if Arg_Num < Argument_Count and then
(Argv (Argv'Last) = ',' xor
Argument (Arg_Num + 1)
(Argument (Arg_Num + 1)'First) = ',')
then
Argv := new String'(Argv.all
& Argument (Arg_Num + 1));
Arg_Num := Arg_Num + 1;
Arg_Idx := Argv'First;
Next_Arg_Idx
:= Get_Arg_End (Argv.all, Arg_Idx);
Arg := new String'
(Argv (Arg_Idx .. Next_Arg_Idx));
goto Tryagain_After_Coalesce;
end if;
Put (Standard_Error,
"incorrectly parenthesized " &
"or malformed argument: ");
Put_Line (Standard_Error, Arg.all);
Errors := Errors + 1;
else
SwP := SwP + 3;
Endp := Arg'Last - 1;
end if;
while SwP <= Endp loop
declare
Dir_Is_Wild : Boolean := False;
Dir_Maybe_Is_Wild : Boolean := False;
Dir_List : String_Access_List_Access;
begin
P2 := SwP;
while P2 < Endp
and then Arg (P2 + 1) /= ','
loop
-- A wildcard directory spec on VMS
-- will contain either * or % or ...
if Arg (P2) = '*' then
Dir_Is_Wild := True;
elsif Arg (P2) = '%' then
Dir_Is_Wild := True;
elsif Dir_Maybe_Is_Wild
and then Arg (P2) = '.'
and then Arg (P2 + 1) = '.'
then
Dir_Is_Wild := True;
Dir_Maybe_Is_Wild := False;
elsif Dir_Maybe_Is_Wild then
Dir_Maybe_Is_Wild := False;
elsif Arg (P2) = '.'
and then Arg (P2 + 1) = '.'
then
Dir_Maybe_Is_Wild := True;
end if;
P2 := P2 + 1;
end loop;
if (Dir_Is_Wild) then
Dir_List := To_Canonical_File_List
(Arg (SwP .. P2), True);
for I in Dir_List.all'Range loop
Place_Unix_Switches (Sw.Unix_String);
Place_Lower (Dir_List.all (I).all);
end loop;
else
Place_Unix_Switches (Sw.Unix_String);
Place_Lower (To_Canonical_Dir_Spec
(Arg (SwP .. P2), False).all);
end if;
SwP := P2 + 2;
end;
end loop;
when T_Directory =>
if SwP + 1 > Arg'Last then
Put (Standard_Error,
"missing directory for: ");
Put_Line (Standard_Error, Arg.all);
Errors := Errors + 1;
else
Place_Unix_Switches (Sw.Unix_String);
-- Some switches end in "=". No space here
if Sw.Unix_String
(Sw.Unix_String'Last) /= '='
then
Place (' ');
end if;
Place_Lower (To_Canonical_Dir_Spec
(Arg (SwP + 2 .. Arg'Last), False).all);
end if;
when T_File =>
if SwP + 1 > Arg'Last then
Put (Standard_Error, "missing file for: ");
Put_Line (Standard_Error, Arg.all);
Errors := Errors + 1;
else
Place_Unix_Switches (Sw.Unix_String);
-- Some switches end in "=". No space here
if Sw.Unix_String
(Sw.Unix_String'Last) /= '='
then
Place (' ');
end if;
Place_Lower (To_Canonical_File_Spec
(Arg (SwP + 2 .. Arg'Last)).all);
end if;
when T_Numeric =>
if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then
Place_Unix_Switches (Sw.Unix_String);
Place (Arg (SwP + 2 .. Arg'Last));
else
Put (Standard_Error, "argument for ");
Put (Standard_Error, Sw.Name.all);
Put_Line (Standard_Error, " must be numeric");
Errors := Errors + 1;
end if;
when T_Alphanumplus =>
if
OK_Alphanumerplus (Arg (SwP + 2 .. Arg'Last))
then
Place_Unix_Switches (Sw.Unix_String);
Place (Arg (SwP + 2 .. Arg'Last));
else
Put (Standard_Error, "argument for ");
Put (Standard_Error, Sw.Name.all);
Put_Line (Standard_Error,
" must be alphanumeric");
Errors := Errors + 1;
end if;
when T_String =>
-- A String value must be extended to the
-- end of the Argv, otherwise strings like
-- "foo/bar" get split at the slash.
--
-- The begining and ending of the string
-- are flagged with embedded nulls which
-- are removed when building the Spawn
-- call. Nulls are use because they won't
-- show up in a /? output. Quotes aren't
-- used because that would make it difficult
-- to embed them.
Place_Unix_Switches (Sw.Unix_String);
if Next_Arg_Idx /= Argv'Last then
Next_Arg_Idx := Argv'Last;
Arg := new String'
(Argv (Arg_Idx .. Next_Arg_Idx));
SwP := Arg'First;
while SwP < Arg'Last and then
Arg (SwP + 1) /= '=' loop
SwP := SwP + 1;
end loop;
end if;
Place (ASCII.NUL);
Place (Arg (SwP + 2 .. Arg'Last));
Place (ASCII.NUL);
when T_Commands =>
-- Output -largs/-bargs/-cargs
Place (' ');
Place (Sw.Unix_String
(Sw.Unix_String'First ..
Sw.Unix_String'First + 5));
-- Set source of new commands, also setting this
-- non-null indicates that we are in the special
-- commands mode for processing the -xargs case.
Make_Commands_Active :=
Matching_Name
(Sw.Unix_String
(Sw.Unix_String'First + 7 ..
Sw.Unix_String'Last),
Commands);
when T_Options =>
if SwP + 1 > Arg'Last then
Place_Unix_Switches (Sw.Options.Unix_String);
SwP := Endp + 1;
elsif Arg (SwP + 2) /= '(' then
SwP := SwP + 2;
Endp := Arg'Last;
elsif Arg (Arg'Last) /= ')' then
Put (Standard_Error,
"incorrectly parenthesized argument: ");
Put_Line (Standard_Error, Arg.all);
Errors := Errors + 1;
SwP := Endp + 1;
else
SwP := SwP + 3;
Endp := Arg'Last - 1;
end if;
while SwP <= Endp loop
P2 := SwP;
while P2 < Endp
and then Arg (P2 + 1) /= ','
loop
P2 := P2 + 1;
end loop;
-- Option name is in Arg (SwP .. P2)
Opt := Matching_Name (Arg (SwP .. P2),
Sw.Options);
if Opt /= null then
Place_Unix_Switches (Opt.Unix_String);
end if;
SwP := P2 + 2;
end loop;
when T_Other =>
Place_Unix_Switches
(new String'(Sw.Unix_String.all & Arg.all));
end case;
end if;
end;
end if;
Arg_Idx := Next_Arg_Idx + 1;
end;
exit when Arg_Idx > Argv'Last;
end loop;
end;
Arg_Num := Arg_Num + 1;
end loop;
if Display_Command then
Put (Standard_Error, "generated command -->");
Put (Standard_Error, String (Buffer.Table (1 .. Buffer.Last)));
Put (Standard_Error, "<--");
New_Line (Standard_Error);
raise Normal_Exit;
end if;
-- Gross error checking that the number of parameters is correct.
-- Not applicable to Unlimited_Files parameters.
if not ((Param_Count = Command.Params'Length - 1 and then
Command.Params (Param_Count + 1) = Unlimited_Files)
or else (Param_Count <= Command.Params'Length))
then
Put_Line (Standard_Error,
"Parameter count of "
& Integer'Image (Param_Count)
& " not equal to expected "
& Integer'Image (Command.Params'Length));
Put (Standard_Error, "usage: ");
Put_Line (Standard_Error, Command.Usage.all);
Errors := Errors + 1;
end if;
if Errors > 0 then
raise Error_Exit;
else
-- Prepare arguments for a call to spawn, filtering out
-- embedded nulls place there to delineate strings.
declare
Pname_Ptr : Natural;
Args : Argument_List (1 .. 500);
Nargs : Natural;
P1, P2 : Natural;
Exec_Path : String_Access;
Inside_Nul : Boolean := False;
Arg : String (1 .. 1024);
Arg_Ctr : Natural;
begin
Pname_Ptr := 1;
while Pname_Ptr < Buffer.Last
and then Buffer.Table (Pname_Ptr + 1) /= ' '
loop
Pname_Ptr := Pname_Ptr + 1;
end loop;
P1 := Pname_Ptr + 2;
Arg_Ctr := 1;
Arg (Arg_Ctr) := Buffer.Table (P1);
Nargs := 0;
while P1 <= Buffer.Last loop
if Buffer.Table (P1) = ASCII.NUL then
if Inside_Nul then
Inside_Nul := False;
else
Inside_Nul := True;
end if;
end if;
if Buffer.Table (P1) = ' ' and then not Inside_Nul then
P1 := P1 + 1;
Arg_Ctr := Arg_Ctr + 1;
Arg (Arg_Ctr) := Buffer.Table (P1);
else
Nargs := Nargs + 1;
P2 := P1;
while P2 < Buffer.Last
and then (Buffer.Table (P2 + 1) /= ' ' or else
Inside_Nul)
loop
P2 := P2 + 1;
Arg_Ctr := Arg_Ctr + 1;
Arg (Arg_Ctr) := Buffer.Table (P2);
if Buffer.Table (P2) = ASCII.NUL then
Arg_Ctr := Arg_Ctr - 1;
if Inside_Nul then
Inside_Nul := False;
else
Inside_Nul := True;
end if;
end if;
end loop;
Args (Nargs) := new String'(String (Arg (1 .. Arg_Ctr)));
P1 := P2 + 2;
Arg_Ctr := 1;
Arg (Arg_Ctr) := Buffer.Table (P1);
end if;
end loop;
Exec_Path := Locate_Exec_On_Path
(String (Buffer.Table (1 .. Pname_Ptr)));
if Exec_Path = null then
Put_Line (Standard_Error,
"Couldn't locate "
& String (Buffer.Table (1 .. Pname_Ptr)));
raise Error_Exit;
end if;
My_Exit_Status
:= Exit_Status (Spawn (Exec_Path.all, Args (1 .. Nargs)));
end;
raise Normal_Exit;
end if;
exception
when Error_Exit =>
Set_Exit_Status (Failure);
when Normal_Exit =>
Set_Exit_Status (My_Exit_Status);
end GNATCmd;
Reference in New Issue View Git Blame Copy Permalink