diff options
Diffstat (limited to 'gcc/ada/gnatcmd.adb')
| -rw-r--r-- | gcc/ada/gnatcmd.adb | 3587 |
1 files changed, 2267 insertions, 1320 deletions
diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 8f7b2e25985..090bf426ce5 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1996-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2002 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -26,15 +26,32 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Characters.Handling; use Ada.Characters.Handling; -with Ada.Command_Line; use Ada.Command_Line; -with Ada.Text_IO; use Ada.Text_IO; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with Csets; +with MLib.Tgt; +with MLib.Utl; +with Namet; use Namet; +with Opt; with Osint; use Osint; +with Output; +with Prj; use Prj; +with Prj.Env; +with Prj.Ext; use Prj.Ext; +with Prj.Pars; +with Prj.Util; use Prj.Util; with Sdefault; use Sdefault; +with Snames; use Snames; +with Stringt; use Stringt; +with Table; +with Types; use Types; with Hostparm; use Hostparm; -- Used to determine if we are in VMS or not for error message purposes +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; + with Gnatvsn; with GNAT.OS_Lib; use GNAT.OS_Lib; @@ -43,6 +60,40 @@ with Table; procedure GNATCmd is pragma Ident (Gnatvsn.Gnat_Version_String); + Ada_Include_Path : constant String := "ADA_INCLUDE_PATH"; + Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH"; + + Project_File : String_Access; + Project : Prj.Project_Id; + Current_Verbosity : Prj.Verbosity := Prj.Default; + Tool_Package_Name : Name_Id := No_Name; + + -- This flag indicates a switch -p (for gnatxref and gnatfind) for + -- an old fashioned project file. -p cannot be used in conjonction + -- with -P. + + Old_Project_File_Used : Boolean := False; + + -- A table to keep the switches on the command line + + package Last_Switches is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatcmd.Last_Switches"); + + -- A table to keep the switches from the project file + + package First_Switches is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatcmd.First_Switches"); + ------------------ -- SWITCH TABLE -- ------------------ @@ -56,6 +107,7 @@ procedure GNATCmd is -- DIRECT_TRANSLATION -- | DIRECTORIES_TRANSLATION -- | FILE_TRANSLATION + -- | NO_SPACE_FILE_TRANSL -- | NUMERIC_TRANSLATION -- | STRING_TRANSLATION -- | OPTIONS_TRANSLATION @@ -67,6 +119,7 @@ procedure GNATCmd is -- 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} @@ -106,6 +159,9 @@ procedure GNATCmd is -- file is allowed, not a list of files, and only one unix switch is -- generated as a result. + -- the NO_SPACE_FILE_TRANSL is similar to FILE_TRANSLATION, except that + -- no space is inserted between the switch and the file name. + -- The NUMERIC_TRANSLATION format is similar to the FILE_TRANSLATION case -- except that the parameter is a decimal integer in the range 0 to 999. @@ -169,8 +225,8 @@ procedure GNATCmd is S_Ext_Ref : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & "-X" & '"'; - S_Project_File : aliased constant S := "/PROJECT_FILE=*" & - "-P*"; + S_Project_File : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; S_Project_Verb : aliased constant S := "/PROJECT_FILE_VERBOSITY=" & "DEFAULT " & "-vP0 " & @@ -220,12 +276,26 @@ procedure GNATCmd is S_Bind_Error : aliased constant S := "/ERROR_LIMIT=#" & "-m#"; + S_Bind_Help : aliased constant S := "/HELP " & + "-h"; + + S_Bind_Init : aliased constant S := "/INITIALIZE_SCALARS=" & + "INVALID " & + "-Sin " & + "LOW " & + "-Slo " & + "HIGH " & + "-Shi"; + S_Bind_Library : aliased constant S := "/LIBRARY_SEARCH=*" & "-aO*"; S_Bind_Linker : aliased constant S := "/LINKER_OPTION_LIST " & "-K"; + S_Bind_List : aliased constant S := "/LIST_RESTRICTIONS " & + "-r"; + S_Bind_Main : aliased constant S := "/MAIN " & "!-n"; @@ -235,6 +305,9 @@ procedure GNATCmd is 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"; @@ -261,8 +334,8 @@ procedure GNATCmd is S_Bind_ReadX : aliased constant S := "/NOREAD_SOURCES " & "-x"; - S_Bind_Rename : aliased constant S := "/RENAME_MAIN " & - "-r"; + S_Bind_Rename : aliased constant S := "/RENAME_MAIN=<" & + "-M>"; S_Bind_Report : aliased constant S := "/REPORT_ERRORS=" & "VERBOSE " & @@ -275,11 +348,20 @@ procedure GNATCmd is 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"; + "-shared"; + + S_Bind_Slice : aliased constant S := "/TIME_SLICE=#" & + "-T#"; S_Bind_Source : aliased constant S := "/SOURCE_SEARCH=*" & "-aI*"; @@ -299,41 +381,48 @@ procedure GNATCmd is "-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); + "-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 -- @@ -363,28 +452,28 @@ procedure GNATCmd is 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); + 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"; + "-gnat83"; S_GCC_Ada_95 : aliased constant S := "/95 " & - "!-gnat83"; + "!-gnat83"; S_GCC_Asm : aliased constant S := "/ASM " & - "-S,!-c"; + "-S,!-c"; S_GCC_Checks : aliased constant S := "/CHECKS=" & "FULL " & @@ -404,10 +493,13 @@ procedure GNATCmd is "-gnatp,!-gnato,!-gnatE"; S_GCC_Compres : aliased constant S := "/COMPRESS_NAMES " & - "-gnatC"; + "-gnatC"; + + S_GCC_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" & + "-gnatec>"; S_GCC_Current : aliased constant S := "/CURRENT_DIRECTORY " & - "!-I-"; + "!-I-"; S_GCC_Debug : aliased constant S := "/DEBUG=" & "SYMBOLS " & @@ -424,13 +516,13 @@ procedure GNATCmd is "-g0"; S_GCC_DebugX : aliased constant S := "/NODEBUG " & - "!-g"; + "!-g"; S_GCC_Dist : aliased constant S := "/DISTRIBUTION_STUBS=" & "RECEIVER " & "-gnatzr " & "CALLER " & - "-gnatzc"; + "-gnatzc"; S_GCC_DistX : aliased constant S := "/NODISTRIBUTION_STUBS " & "!-gnatzr,!-gnatzc"; @@ -453,6 +545,9 @@ procedure GNATCmd is 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 " & @@ -480,23 +575,37 @@ procedure GNATCmd is 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"; + "-fno-inline"; S_GCC_InlineX : aliased constant S := "/NOINLINE " & - "!-gnatn"; + "!-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"; + "-gnatl"; + + S_GCC_Noadc : aliased constant S := "/NO_GNAT_ADC " & + "-gnatA"; S_GCC_Noload : aliased constant S := "/NOLOAD " & - "-gnatc"; + "-gnatc"; S_GCC_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & - "-nostdinc"; + "-nostdinc"; S_GCC_Opt : aliased constant S := "/OPTIMIZE=" & "ALL " & @@ -515,6 +624,9 @@ procedure GNATCmd is 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 " & @@ -532,15 +644,15 @@ procedure GNATCmd is S_GCC_Repinfo : aliased constant S := "/REPRESENTATION_INFO=" & "ARRAYS " & - "-gnatR1 " & + "-gnatR1 " & "NONE " & - "-gnatR0 " & + "-gnatR0 " & "OBJECTS " & - "-gnatR2 " & + "-gnatR2 " & "SYMBOLIC " & - "-gnatR3 " & + "-gnatR3 " & "DEFAULT " & - "-gnatR"; + "-gnatR"; S_GCC_RepinfX : aliased constant S := "/NOREPRESENTATION_INFO " & "!-gnatR"; @@ -599,7 +711,7 @@ procedure GNATCmd is "!-gnatg,!-gnatr " & "PRAGMA " & "-gnatyp " & - "REFERENCES " & + "RM_COLUMN_LAYOUT " & "-gnatr " & "SPECS " & "-gnatys " & @@ -632,45 +744,45 @@ procedure GNATCmd is S_GCC_Valid : aliased constant S := "/VALIDITY_CHECKING=" & "DEFAULT " & - "-gnatVd " & + "-gnatVd " & "NODEFAULT " & - "-gnatVD " & + "-gnatVD " & "COPIES " & - "-gnatVc " & + "-gnatVc " & "NOCOPIES " & - "-gnatVC " & + "-gnatVC " & "FLOATS " & - "-gnatVf " & + "-gnatVf " & "NOFLOATS " & - "-gnatVF " & + "-gnatVF " & "IN_PARAMS " & - "-gnatVi " & + "-gnatVi " & "NOIN_PARAMS " & - "-gnatVI " & + "-gnatVI " & "MOD_PARAMS " & - "-gnatVm " & + "-gnatVm " & "NOMOD_PARAMS " & - "-gnatVM " & + "-gnatVM " & "OPERANDS " & - "-gnatVo " & + "-gnatVo " & "NOOPERANDS " & - "-gnatVO " & + "-gnatVO " & "RETURNS " & - "-gnatVr " & + "-gnatVr " & "NORETURNS " & - "-gnatVR " & + "-gnatVR " & "SUBSCRIPTS " & - "-gnatVs " & + "-gnatVs " & "NOSUBSCRIPTS " & - "-gnatVS " & + "-gnatVS " & "TESTS " & - "-gnatVt " & + "-gnatVt " & "NOTESTS " & - "-gnatVT " & + "-gnatVT " & "ALL " & - "-gnatVa " & + "-gnatVa " & "NONE " & - "-gnatVn"; + "-gnatVn"; S_GCC_Verbose : aliased constant S := "/VERBOSE " & "-v"; @@ -680,10 +792,18 @@ procedure GNATCmd is "!-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 " & @@ -698,6 +818,10 @@ procedure GNATCmd is "-gnatwi " & "NOIMPLEMENTATION " & "-gnatwI " & + "INEFFECTIVE_INLINE " & + "-gnatwp " & + "NOINEFFECTIVE_INLINE " & + "-gnatwP " & "OPTIONAL " & "-gnatwa " & "NOOPTIONAL " & @@ -714,6 +838,10 @@ procedure GNATCmd is "-gnatws " & "UNINITIALIZED " & "-Wuninitialized " & + "UNREFERENCED_FORMALS " & + "-gnatwf " & + "NOUNREFERENCED_FORMALS " & + "-gnatwF " & "UNUSED " & "-gnatwu " & "NOUNUSED " & @@ -739,66 +867,76 @@ procedure GNATCmd is "-gnatWe"; S_GCC_WideX : aliased constant S := "/NOWIDE_CHARACTER_ENCODING " & - "-gnatWn"; + "-gnatWn"; S_GCC_Xdebug : aliased constant S := "/XDEBUG " & - "-gnatD"; + "-gnatD"; S_GCC_Xref : aliased constant S := "/XREF=" & "GENERATE " & - "!-gnatx " & + "!-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); + "-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 -- @@ -807,16 +945,28 @@ procedure GNATCmd is 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_Miss 'Access, - S_Elim_Verb 'Access); + 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 -- @@ -825,6 +975,9 @@ procedure GNATCmd is 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"; @@ -834,6 +987,12 @@ procedure GNATCmd is 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*"; @@ -852,12 +1011,18 @@ procedure GNATCmd is S_Find_Source : aliased constant S := "/SOURCE_SEARCH=*" & "-aI*"; - Find_Switches : aliased constant Switches := ( - S_Find_All 'Access, + 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, @@ -865,7 +1030,8 @@ procedure GNATCmd is S_Project_Verb 'Access, S_Find_Ref 'Access, S_Find_Search 'Access, - S_Find_Source 'Access); + S_Find_Source 'Access, + S_Find_Types 'Access); ------------------------------ -- Switches for GNAT KRUNCH -- @@ -874,8 +1040,8 @@ procedure GNATCmd is S_Krunch_Count : aliased constant S := "/COUNT=#" & "`#"; - Krunch_Switches : aliased constant Switches := (1 .. 1 => - S_Krunch_Count 'Access); + Krunch_Switches : aliased constant Switches := + (1 .. 1 => S_Krunch_Count 'Access); ------------------------------- -- Switches for GNAT LIBRARY -- @@ -885,19 +1051,19 @@ procedure GNATCmd is "--config=@"; S_Lbr_Create : aliased constant S := "/CREATE=%" & - "--create=%"; + "--create=%"; S_Lbr_Delete : aliased constant S := "/DELETE=%" & - "--delete=%"; + "--delete=%"; S_Lbr_Set : aliased constant S := "/SET=%" & - "--set=%"; + "--set=%"; - Lbr_Switches : aliased constant Switches := ( - S_Lbr_Config 'Access, - S_Lbr_Create 'Access, - S_Lbr_Delete 'Access, - S_Lbr_Set 'Access); + 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 -- @@ -922,6 +1088,9 @@ procedure GNATCmd is 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=" & '"'; @@ -944,11 +1113,12 @@ procedure GNATCmd is S_Link_ZZZZZ : aliased constant S := "/<other> " & "--for-linker="; - Link_Switches : aliased constant Switches := ( - S_Link_Bind 'Access, + 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, @@ -969,9 +1139,6 @@ procedure GNATCmd is 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"; @@ -981,6 +1148,8 @@ procedure GNATCmd is S_List_Output : aliased constant S := "/OUTPUT=" & "SOURCES " & "-s " & + "DEPEND " & + "-d " & "OBJECTS " & "-o " & "UNITS " & @@ -996,18 +1165,17 @@ procedure GNATCmd is 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); + List_Switches : aliased constant Switches := + (S_List_All 'Access, + S_List_Current 'Access, + S_Ext_Ref 'Access, + S_List_Nostinc 'Access, + S_List_Object 'Access, + S_List_Output 'Access, + S_Project_File 'Access, + S_Project_Verb 'Access, + S_List_Search 'Access, + S_List_Source 'Access); ---------------------------- -- Switches for GNAT MAKE -- @@ -1015,11 +1183,11 @@ procedure GNATCmd is S_Make_Actions : aliased constant S := "/ACTIONS=" & "COMPILE " & - "-c " & + "-c " & "BIND " & - "-b " & + "-b " & "LINK " & - "-l "; + "-l "; S_Make_All : aliased constant S := "/ALL_FILES " & "-a"; @@ -1052,7 +1220,7 @@ procedure GNATCmd is "-f"; S_Make_Inplace : aliased constant S := "/IN_PLACE " & - "-i"; + "-i"; S_Make_Library : aliased constant S := "/LIBRARY_SEARCH=*" & "-L*"; @@ -1060,12 +1228,18 @@ procedure GNATCmd is 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"; + "-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"; @@ -1087,6 +1261,9 @@ procedure GNATCmd is 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*"; @@ -1096,45 +1273,89 @@ procedure GNATCmd is S_Make_Source : aliased constant S := "/SOURCE_SEARCH=*" & "-aI*"; + S_Make_Switch : aliased constant S := "/SWITCH_CHECK " & + "-s"; + + S_Make_Unique : aliased constant S := "/UNIQUE " & + "-u"; + S_Make_Verbose : aliased constant S := "/VERBOSE " & "-v"; - Make_Switches : aliased constant Switches := ( - S_Make_Actions 'Access, - S_Make_All 'Access, - S_Make_Bind 'Access, - S_Make_Comp 'Access, - S_Make_Cond 'Access, - S_Make_Cont 'Access, - S_Make_Current 'Access, - S_Make_Dep 'Access, - S_Make_Doobj 'Access, - S_Make_Execut 'Access, - S_Ext_Ref 'Access, - S_Make_Force 'Access, - S_Make_Inplace 'Access, - S_Make_Library 'Access, - S_Make_Link 'Access, - S_Make_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); + Make_Switches : aliased constant Switches := + (S_Make_Actions 'Access, + S_Make_All 'Access, + S_Make_Bind 'Access, + S_Make_Comp 'Access, + S_Make_Cond 'Access, + S_Make_Cont 'Access, + S_Make_Current 'Access, + S_Make_Dep 'Access, + S_Make_Doobj 'Access, + S_Make_Execut 'Access, + S_Ext_Ref 'Access, + S_Make_Force 'Access, + S_Make_Inplace 'Access, + S_Make_Library 'Access, + S_Make_Link 'Access, + S_Make_Mapping 'Access, + S_Make_Minimal 'Access, + S_Make_Nolink 'Access, + S_Make_Nomain 'Access, + S_Make_Nostinc 'Access, + S_Make_Nostlib 'Access, + S_Make_Object 'Access, + S_Make_Proc 'Access, + S_Project_File 'Access, + S_Project_Verb 'Access, + S_Make_Nojobs 'Access, + S_Make_Quiet 'Access, + S_Make_Reason 'Access, + S_Make_RTS 'Access, + S_Make_Search 'Access, + S_Make_Skip 'Access, + S_Make_Source 'Access, + S_Make_Switch 'Access, + S_Make_Unique 'Access, + S_Make_Verbose 'Access); + + ---------------------------- + -- Switches for GNAT Name -- + ---------------------------- + + S_Name_Conf : aliased constant S := "/CONFIG_FILE=<" & + "-c>"; + + S_Name_Dirs : aliased constant S := "/SOURCE_DIRS=*" & + "-d*"; + + S_Name_Dfile : aliased constant S := "/DIRS_FILE=<" & + "-D>"; + + S_Name_Help : aliased constant S := "/HELP" & + " -h"; + + S_Name_Proj : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + + S_Name_Verbose : aliased constant S := "/VERBOSE" & + " -v"; + + Name_Switches : aliased constant Switches := + (S_Name_Conf 'Access, + S_Name_Dirs 'Access, + S_Name_Dfile 'Access, + S_Name_Help 'Access, + S_Name_Proj 'Access, + S_Name_Verbose 'Access); ---------------------------------- -- Switches for GNAT PREPROCESS -- ---------------------------------- + S_Prep_Assoc : aliased constant S := "/ASSOCIATE=" & '"' & + "-D" & '"'; + S_Prep_Blank : aliased constant S := "/BLANK_LINES " & "-b"; @@ -1153,21 +1374,14 @@ procedure GNATCmd is 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); + Prep_Switches : aliased constant Switches := + (S_Prep_Assoc 'Access, + S_Prep_Blank 'Access, + S_Prep_Com 'Access, + S_Prep_Ref 'Access, + S_Prep_Remove 'Access, + S_Prep_Symbols 'Access, + S_Prep_Undef 'Access); ------------------------------ -- Switches for GNAT SHARED -- @@ -1202,8 +1416,8 @@ procedure GNATCmd is S_Shared_ZZZZZ : aliased constant S := "/<other> " & "--for-linker="; - Shared_Switches : aliased constant Switches := ( - S_Shared_Debug 'Access, + Shared_Switches : aliased constant Switches := + (S_Shared_Debug 'Access, S_Shared_Image 'Access, S_Shared_Ident 'Access, S_Shared_Nofiles 'Access, @@ -1256,22 +1470,16 @@ procedure GNATCmd is 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); + Stub_Switches : aliased constant Switches := + (S_Stub_Current 'Access, + S_Stub_Full 'Access, + S_Stub_Header 'Access, + S_Stub_Indent 'Access, + S_Stub_Length 'Access, + S_Stub_Quiet 'Access, + S_Stub_Search 'Access, + S_Stub_Tree 'Access, + S_Stub_Verbose 'Access); ---------------------------- -- Switches for GNAT XREF -- @@ -1280,12 +1488,21 @@ procedure GNATCmd is S_Xref_All : aliased constant S := "/ALL_FILES " & "-a"; + S_Xref_Deriv : aliased constant S := "/DERIVED_TYPES " & + "-d"; + S_Xref_Full : aliased constant S := "/FULL_PATHNAME " & "-f"; S_Xref_Global : aliased constant S := "/IGNORE_LOCALS " & "-g"; + S_Xref_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & + "-nostdinc"; + + S_Xref_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & + "-nostdlib"; + S_Xref_Object : aliased constant S := "/OBJECT_SEARCH=*" & "-aO*"; @@ -1301,18 +1518,25 @@ procedure GNATCmd is S_Xref_Output : aliased constant S := "/UNUSED " & "-u"; - Xref_Switches : aliased constant Switches := ( - S_Xref_All 'Access, + S_Xref_Tags : aliased constant S := "/TAGS " & + "-v"; + + Xref_Switches : aliased constant Switches := + (S_Xref_All 'Access, + S_Xref_Deriv 'Access, S_Ext_Ref 'Access, S_Xref_Full 'Access, S_Xref_Global 'Access, + S_Xref_Nostinc 'Access, + S_Xref_Nostlib 'Access, S_Xref_Object 'Access, S_Xref_Project 'Access, S_Project_File 'Access, S_Project_Verb 'Access, S_Xref_Search 'Access, S_Xref_Source 'Access, - S_Xref_Output 'Access); + S_Xref_Output 'Access, + S_Xref_Tags 'Access); ------------------- -- COMMAND TABLE -- @@ -1334,9 +1558,13 @@ procedure GNATCmd is -- A parameter that's passed through as is (not canonicalized) Unlimited_Files, - -- An unlimited number of writespace separate file or directory + -- An unlimited number of whitespace separate file or directory -- parameters including wildcard specifications. + Unlimited_As_Is, + -- Un unlimited number of whitespace separated paameters that are + -- passed through as is (not canonicalized). + Files_Or_Wildcard); -- A comma separated list of files and/or wildcard file specifications. -- A comma preceded by or followed by whitespace is considered as a @@ -1345,6 +1573,23 @@ procedure GNATCmd is type Parameter_Array is array (Natural range <>) of Parameter_Type; type Parameter_Ref is access all Parameter_Array; + type Command_Type is + (Bind, Chop, Compile, Elim, Find, Krunch, Library, Link, List, + Make, Name, Preprocess, Shared, Standard, Stub, Xref, Undefined); + + type Alternate_Command is (Comp, Ls, Kr, Prep, Psta); + -- Alternate command libel for non VMS system + + Corresponding_To : constant array (Alternate_Command) of Command_Type := + (Comp => Compile, + Ls => List, + Kr => Krunch, + Prep => Preprocess, + Psta => Standard); + -- Mapping of alternate commands to commands + + subtype Real_Command_Type is Command_Type range Bind .. Xref; + type Command_Entry is record Cname : String_Ptr; -- Command name for GNAT xxx command @@ -1352,9 +1597,15 @@ procedure GNATCmd is Usage : String_Ptr; -- A usage string, used for error messages - Unixcmd : String_Ptr; + Unixcmd : String_Ptr; -- Corresponding Unix command + Unixsws : Argument_List_Access; + -- Switches for the Unix command + + VMS_Only : Boolean; + -- When True, the command can only be used on VMS + Switches : Switches_Ptr; -- Pointer to array of switch strings @@ -1398,9 +1649,13 @@ procedure GNATCmd is -- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB] T_File, - -- A quailifier followed by a filename + -- A qualifier followed by a filename -- Example: GNAT LINK /EXECUTABLE=FOO.EXE + T_No_Space_File, + -- A qualifier followed by a filename + -- Example: GNAT MAKE /PROJECT_FILE=PRJ.GPR + T_Numeric, -- A qualifier followed by a numeric value. -- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39 @@ -1429,7 +1684,7 @@ procedure GNATCmd is -- 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; @@ -1441,7 +1696,9 @@ procedure GNATCmd is Next : Item_Ptr; -- Pointer to next item on list, always has the same Id value - Unix_String : String_Ptr; + Command : Command_Type := Undefined; + + Unix_String : String_Ptr := null; -- Corresponding Unix string. For a command, this is the unix command -- name and possible default switches. For a switch or option it is -- the unix switch string. @@ -1511,6 +1768,8 @@ procedure GNATCmd is Errors : Natural := 0; -- Count errors detected + Command_Arg : Positive := 1; + Command : Item_Ptr; -- Pointer to command item for current command @@ -1521,13 +1780,13 @@ procedure GNATCmd is 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"); + 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 @@ -1536,13 +1795,20 @@ procedure GNATCmd is -- Argument number Display_Command : Boolean := False; - -- Set true if /? switch causes display of generated command + -- Set true if /? switch causes display of generated command (on VMS) + + The_Command : Command_Type; + -- The command used ----------------------- -- Local Subprograms -- ----------------------- - function Init_Object_Dirs return String_Ptr; + 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 @@ -1575,6 +1841,9 @@ procedure GNATCmd is -- error message is generated in a not found situation (null is still -- returned to indicate the not-found situation). + procedure Non_VMS_Usage; + -- Display usage for platforms other than VMS + function OK_Alphanumerplus (S : String) return Boolean; -- Checks that S is a string of alphanumeric characters, -- returning True if all alphanumeric characters, @@ -1584,6 +1853,9 @@ procedure GNATCmd is -- Checks that S is a string of digits, returning True if all digits, -- False if empty or a non-digit is present. + procedure Output_Version; + -- Output the version of this program + procedure Place (C : Character); -- Place a single character in the buffer, updating Ptr @@ -1598,6 +1870,17 @@ procedure GNATCmd is -- updating Ptr appropriatelly. Note that in the case of use of ! the -- result may be to remove a previously placed switch. + procedure Set_Library_For + (Project : Project_Id; + There_Are_Libraries : in out Boolean); + -- If Project is a library project, add the correct + -- -L and -l switches to the linker invocation. + + procedure Set_Libraries is + new For_Every_Project_Imported (Boolean, Set_Library_For); + -- Add the -L and -l switches to the linker for all + -- of the library projects. + procedure Validate_Command_Or_Option (N : String_Ptr); -- Check that N is a valid command or option name, i.e. that it is of the -- form of an Ada identifier with upper case letters and underscores. @@ -1606,13 +1889,31 @@ procedure GNATCmd is -- Check that S is a valid switch string as described in the syntax for -- the switch table item UNIX_SWITCH or else begins with a backquote. + procedure VMS_Conversion (The_Command : out Command_Type); + -- Converts VMS command line to equivalent Unix command line + + ----------- + -- Index -- + ----------- + + function Index (Char : Character; Str : String) return Natural is + begin + for Index in Str'Range loop + if Str (Index) = Char then + return Index; + end if; + end loop; + + return 0; + end Index; + ---------------------- -- Init_Object_Dirs -- ---------------------- - function Init_Object_Dirs return String_Ptr is + function Init_Object_Dirs return Argument_List is Object_Dirs : Integer; - Object_Dir : array (Integer range 1 .. 256) of String_Access; + Object_Dir : Argument_List (1 .. 256); Object_Dir_Name : String_Access; begin @@ -1627,66 +1928,24 @@ procedure GNATCmd is begin exit when Dir = null; Object_Dirs := Object_Dirs + 1; - Object_Dir (Object_Dirs) - := String_Access (Normalize_Directory_Name (Dir.all)); + 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; - 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'; + Object_Dirs := Object_Dirs + 1; + Object_Dir (Object_Dirs) := new String'("-lgnat"); 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'; + Object_Dirs := Object_Dirs + 1; + Object_Dir (Object_Dirs) := new String'("-ldecgnat"); end if; - return new String'(String (Buffer.Table (1 .. Buffer.Last))); + return Object_Dir (1 .. Object_Dirs); end Init_Object_Dirs; ------------------ @@ -1781,7 +2040,7 @@ procedure GNATCmd is (S : String; Itm : Item_Ptr; Quiet : Boolean := False) - return Item_Ptr + return Item_Ptr is P1, P2 : Item_Ptr; @@ -1789,6 +2048,10 @@ procedure GNATCmd is -- Little procedure to output command/qualifier/option as appropriate -- and bump error count. + --------- + -- Err -- + --------- + procedure Err is begin if Quiet then @@ -1820,7 +2083,6 @@ procedure GNATCmd is Put (Standard_Error, ": "); Put (Standard_Error, S); - end Err; -- Start of processing for Matching_Name @@ -1937,6 +2199,17 @@ procedure GNATCmd is 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 -- ----------- @@ -1945,6 +2218,11 @@ procedure GNATCmd 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 @@ -1999,8 +2277,8 @@ procedure GNATCmd is 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 String (Buffer.Table (P3 + 1 .. P3 + Slen)) = + S (P1 .. P2) and then (P3 + Slen = Buffer.Last or else Buffer.Table (P3 + Slen + 1) = ' ') @@ -2028,6 +2306,59 @@ procedure GNATCmd is end loop; end Place_Unix_Switches; + --------------------- + -- Set_Library_For -- + --------------------- + + procedure Set_Library_For + (Project : Project_Id; + There_Are_Libraries : in out Boolean) + is + begin + -- Case of library project + + if Projects.Table (Project).Library then + There_Are_Libraries := True; + + -- Add the -L switch + + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-L" & + Get_Name_String + (Projects.Table (Project).Library_Dir)); + + -- Add the -l switch + + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-l" & + Get_Name_String + (Projects.Table (Project).Library_Name)); + + -- Add the Wl,-rpath switch if library non static + + if Projects.Table (Project).Library_Kind /= Static then + declare + Option : constant String_Access := + MLib.Tgt.Linker_Library_Path_Option + (Get_Name_String + (Projects.Table (Project).Library_Dir)); + + begin + if Option /= null then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + Option; + end if; + + end; + + end if; + + end if; + end Set_Library_For; + -------------------------------- -- Validate_Command_Or_Option -- -------------------------------- @@ -2073,720 +2404,744 @@ procedure GNATCmd is -- 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 -- -------------------------------------- + -- 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") + ); -begin - Buffer.Init; + ------------------- + -- Non_VMS_Usage -- + ------------------- - -- First we must preprocess the string form of the command and options - -- list into the internal form that we use. + procedure Non_VMS_Usage is + begin + Output_Version; + New_Line; + Put_Line ("List of available commands"); + New_Line; - for C in Command_List'Range loop + for C in Command_List'Range loop + if not Command_List (C).VMS_Only then + Put ("GNAT " & Command_List (C).Cname.all); + Set_Col (25); + Put (Command_List (C).Unixcmd.all); - declare - Command : Item_Ptr := new Command_Item; + declare + Sws : Argument_List_Access renames Command_List (C).Unixsws; + begin + if Sws /= null then + for J in Sws'Range loop + Put (' '); + Put (Sws (J).all); + end loop; + end if; + end; - Last_Switch : Item_Ptr; - -- Last switch in list + New_Line; + end if; + end loop; - begin - -- Link new command item into list of commands + New_Line; + Put_Line ("Commands FIND, LIST and XREF accept project file " & + "switches -vPx, -Pprj and -Xnam=val"); + New_Line; + end Non_VMS_Usage; - if Last_Command = null then - Commands := Command; - else - Last_Command.Next := Command; - end if; + -------------------- + -- VMS_Conversion -- + -------------------- - Last_Command := Command; + procedure VMS_Conversion (The_Command : out Command_Type) is + begin + Buffer.Init; - -- Fill in fields of new command item + -- First we must preprocess the string form of the command and options + -- list into the internal form that we use. - 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; + for C in Real_Command_Type loop - Validate_Command_Or_Option (Command.Name); + declare + Command : Item_Ptr := new Command_Item; - -- Process the switch list + Last_Switch : Item_Ptr; + -- Last switch in list - for S in Command_List (C).Switches'Range loop - declare - SS : constant String_Ptr := Command_List (C).Switches (S); + begin + -- Link new command item into list of commands - P : Natural := SS'First; - Sw : Item_Ptr := new Switch_Item; + if Last_Command = null then + Commands := Command; + else + Last_Command.Next := Command; + end if; - Last_Opt : Item_Ptr; - -- Pointer to last option + Last_Command := Command; - begin - -- Link new switch item into list of switches + -- Fill in fields of new command item - if Last_Switch = null then - Command.Switches := Sw; - else - Last_Switch.Next := Sw; - end if; + Command.Name := Command_List (C).Cname; + Command.Usage := Command_List (C).Usage; + Command.Command := C; - Last_Switch := Sw; + if Command_List (C).Unixsws = null then + Command.Unix_String := Command_List (C).Unixcmd; + else + declare + Cmd : String (1 .. 5_000); + Last : Natural := 0; + Sws : Argument_List_Access := Command_List (C).Unixsws; + + begin + Cmd (1 .. Command_List (C).Unixcmd'Length) := + Command_List (C).Unixcmd.all; + Last := Command_List (C).Unixcmd'Length; + + for J in Sws'Range loop + Last := Last + 1; + Cmd (Last) := ' '; + Cmd (Last + 1 .. Last + Sws (J)'Length) := + Sws (J).all; + Last := Last + Sws (J)'Length; + end loop; - -- Process switch string, first get name + Command.Unix_String := new String'(Cmd (1 .. Last)); + end; + end if; - while SS (P) /= ' ' and SS (P) /= '=' loop - P := P + 1; - end loop; + Command.Params := Command_List (C).Params; + Command.Defext := Command_List (C).Defext; - Sw.Name := new String'(SS (SS'First .. P - 1)); + Validate_Command_Or_Option (Command.Name); - -- Direct translation case + -- Process the switch list - if SS (P) = ' ' then - Sw.Translation := T_Direct; - Sw.Unix_String := new String'(SS (P + 1 .. SS'Last)); - Validate_Unix_Switch (Sw.Unix_String); + for S in Command_List (C).Switches'Range loop + declare + SS : constant String_Ptr := Command_List (C).Switches (S); - if SS (P - 1) = '>' then - Sw.Translation := T_Other; + P : Natural := SS'First; + Sw : Item_Ptr := new Switch_Item; - elsif SS (P + 1) = '`' then - null; + Last_Opt : Item_Ptr; + -- Pointer to last option - -- Create the inverted case (/NO ..) + begin + -- Link new switch item into list of switches - elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then - Sw := new Switch_Item; + if Last_Switch = null then + Command.Switches := Sw; + else Last_Switch.Next := Sw; - Last_Switch := Sw; + end if; - Sw.Name := - new String'("/NO" & SS (SS'First + 1 .. P - 1)); + 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 := Invert_Sense (SS (P + 1 .. SS'Last)); + Sw.Unix_String := new String'(SS (P + 1 .. SS'Last)); Validate_Unix_Switch (Sw.Unix_String); - end if; - -- Directories translation case + if SS (P - 1) = '>' then + Sw.Translation := T_Other; - 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); + elsif SS (P + 1) = '`' then + null; - -- Directory translation case + -- Create the inverted case (/NO ..) - 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); + elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then + Sw := new Switch_Item; + Last_Switch.Next := Sw; + Last_Switch := Sw; - -- File translation case + 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; - 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); + -- Directories translation case - -- Numeric 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); - 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); + -- Directory translation case - -- Alphanumerplus 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); - 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); + -- File translation case - -- String 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); - 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); + -- No space file translation case - -- Commands 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); - elsif SS (P + 1) = '?' then - Sw.Translation := T_Commands; - Sw.Unix_String := new String'(SS (P + 2 .. SS'Last)); + -- Numeric translation case - -- Options 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); - else - Sw.Translation := T_Options; - Sw.Unix_String := new String'(""); + -- Alphanumerplus translation case - P := P + 1; -- bump past = - while P <= SS'Last loop - declare - Opt : Item_Ptr := new Option_Item; - Q : Natural; + 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); - begin - -- Link new option item into options list + -- String translation case - if Last_Opt = null then - Sw.Options := Opt; - else - Last_Opt.Next := Opt; - end if; + 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); - Last_Opt := Opt; + -- Commands translation case - -- Fill in fields of new option item + elsif SS (P + 1) = '?' then + Sw.Translation := T_Commands; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last)); - Q := P; - while SS (Q) /= ' ' loop - Q := Q + 1; - end loop; + -- Options translation case - Opt.Name := new String'(SS (P .. Q - 1)); - Validate_Command_Or_Option (Opt.Name); + else + Sw.Translation := T_Options; + Sw.Unix_String := new String'(""); - P := Q + 1; - Q := P; + P := P + 1; -- bump past = + while P <= SS'Last loop + declare + Opt : Item_Ptr := new Option_Item; + Q : Natural; - while Q <= SS'Last and then SS (Q) /= ' ' loop - Q := Q + 1; - end loop; + begin + -- Link new option item into options list - 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 Last_Opt = null then + Sw.Options := Opt; + else + Last_Opt.Next := Opt; + end if; - -- If no parameters, give complete list of commands + Last_Opt := Opt; - if Argument_Count = 0 then - Put_Line ("List of available commands"); - New_Line; + -- Fill in fields of new option item - while Commands /= null loop - Put (Commands.Usage.all); - Set_Col (53); - Put_Line (Commands.Unix_String.all); - Commands := Commands.Next; - end loop; + Q := P; + while SS (Q) /= ' ' loop + Q := Q + 1; + end loop; - raise Normal_Exit; - end if; + Opt.Name := new String'(SS (P .. Q - 1)); + Validate_Command_Or_Option (Opt.Name); - Arg_Num := 1; + P := Q + 1; + Q := P; - loop - exit when Arg_Num > Argument_Count; + while Q <= SS'Last and then SS (Q) /= ' ' loop + Q := Q + 1; + end loop; - 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; + 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; - return Argv'Last; - end Get_Arg_End; + -- If no parameters, give complete list of commands - begin - Argv := new String'(Argument (Arg_Num)); - Arg_Idx := Argv'First; + if Argument_Count = 0 then + Output_Version; + New_Line; + Put_Line ("List of available commands"); + New_Line; - <<Tryagain_After_Coalesce>> - loop - declare - Next_Arg_Idx : Integer; - Arg : String_Access; + while Commands /= null loop + Put (Commands.Usage.all); + Set_Col (53); + Put_Line (Commands.Unix_String.all); + Commands := Commands.Next; + end loop; - begin - Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); - Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx)); + raise Normal_Exit; + end if; + + Arg_Num := 1; + + -- Loop through arguments - -- The first one must be a command name + while Arg_Num <= Argument_Count loop - if Arg_Num = 1 and then Arg_Idx = Argv'First then + Process_Argument : declare + Argv : String_Access; + Arg_Idx : Integer; - Command := Matching_Name (Arg.all, Commands); + 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. - if Command = null then - raise Error_Exit; + ----------------- + -- 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; - -- Give usage information if only command given + return Argv'Last; + end Get_Arg_End; - 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; + -- Start of processing for Process_Argument - Put (Command.Usage.all); - Set_Col (53); - Put_Line (Command.Unix_String.all); + begin + Argv := new String'(Argument (Arg_Num)); + Arg_Idx := Argv'First; - declare - Sw : Item_Ptr := Command.Switches; + <<Tryagain_After_Coalesce>> + loop + declare + Next_Arg_Idx : Integer; + Arg : String_Access; - 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 + Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); + Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx)); - begin - Put_Line ("=(option,option..)"); + -- 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 ..."); - while Opt /= null loop - Put (" "); - Put (Opt.Name.all); + when T_Directory => + Put ("=directory"); + Set_Col (53); + Put (Sw.Unix_String.all); - if Opt = Sw.Options then - Put (" (D)"); + 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_Line (Opt.Unix_String.all); - Opt := Opt.Next; - end loop; - end; + Put (Sw.Unix_String.all); - end case; + if Sw.Translation = T_File + and then Sw.Unix_String + (Sw.Unix_String'Last) + /= '=' + then + Put (' '); + end if; - Sw := Sw.Next; - end loop; - end; + Put_Line ("file "); - raise Normal_Exit; - end if; + when T_Numeric => + Put ("=nnn"); + Set_Col (53); - Place (Command.Unix_String.all); + 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; - -- Special handling for internal debugging switch /? + Put_Line ("nnn"); - elsif Arg.all = "/?" then - Display_Command := True; + when T_Alphanumplus => + Put ("=xyz"); + Set_Col (53); - -- Copy -switch unchanged + 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; - elsif Arg (Arg'First) = '-' then - Place (' '); - Place (Arg.all); + Put_Line ("xyz"); - -- Copy quoted switch with quotes stripped + when T_String => + Put ("="); + Put ('"'); + Put ("<string>"); + Put ('"'); + Set_Col (53); - elsif Arg (Arg'First) = '"' then - if Arg (Arg'Last) /= '"' then - Put (Standard_Error, "misquoted argument: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; + Put (Sw.Unix_String.all); - else - Put (Arg (Arg'First + 1 .. Arg'Last - 1)); - end if; + if Sw.Unix_String (Sw.Unix_String'Last) + /= '=' + then + Put (' '); + end if; - -- Parameter Argument + Put ("<string>"); + New_Line; - elsif Arg (Arg'First) /= '/' - and then Make_Commands_Active = null - then - Param_Count := Param_Count + 1; + 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"); - if Param_Count <= Command.Params'Length then + when T_Options => + declare + Opt : Item_Ptr := Sw.Options; - case Command.Params (Param_Count) is + begin + Put_Line ("=(option,option..)"); - when File | Optional_File => - declare - Normal_File : String_Access - := To_Canonical_File_Spec (Arg.all); - begin - Place (' '); - Place_Lower (Normal_File.all); + while Opt /= null loop + Put (" "); + Put (Opt.Name.all); - if Is_Extensionless (Normal_File.all) - and then Command.Defext /= " " - then - Place ('.'); - Place (Command.Defext); - end if; - end; + if Opt = Sw.Options then + Put (" (D)"); + end if; - when Unlimited_Files => - declare - Normal_File : String_Access - := To_Canonical_File_Spec (Arg.all); + Set_Col (53); + Put_Line (Opt.Unix_String.all); + Opt := Opt.Next; + end loop; + end; - 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 case; + + Sw := Sw.Next; end loop; + end; - if File_Is_Wild then - File_List := To_Canonical_File_List - (Arg.all, False); + raise Normal_Exit; + end if; - 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; + -- Place (Command.Unix_String.all); - Param_Count := Param_Count - 1; - end; + -- Special handling for internal debugging switch /? - when Other_As_Is => - Place (' '); - Place (Arg.all); + elsif Arg.all = "/?" then + Display_Command := True; - when Files_Or_Wildcard => + -- Copy -switch unchanged - -- Remove spaces from a comma separated list - -- of file names and adjust control variables - -- accordingly. + elsif Arg (Arg'First) = '-' then + Place (' '); + Place (Arg.all); - 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; + -- Copy quoted switch with quotes stripped - -- 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. + elsif Arg (Arg'First) = '"' then + if Arg (Arg'Last) /= '"' then + Put (Standard_Error, "misquoted argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; - 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; + else + Place (' '); + Place (Arg (Arg'First + 1 .. Arg'Last - 1)); + end if; - return Arg'Last; - end Get_Arg1_End; + -- Parameter Argument - begin - loop - declare - Next_Arg1_Idx : Integer - := Get_Arg1_End (Arg.all, Arg1_Idx); + elsif Arg (Arg'First) /= '/' + and then Make_Commands_Active = null + then + Param_Count := Param_Count + 1; - Arg1 : String - := Arg (Arg1_Idx .. Next_Arg1_Idx); + if Param_Count <= Command.Params'Length then - Normal_File : String_Access - := To_Canonical_File_Spec (Arg1); + 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); @@ -2797,517 +3152,1109 @@ begin Place ('.'); Place (Command.Defext); end if; - - Arg1_Idx := Next_Arg1_Idx + 1; end; - exit when Arg1_Idx > Arg'Last; + when Unlimited_Files => + declare + Normal_File : String_Access + := To_Canonical_File_Spec (Arg.all); - -- Don't allow two or more commas in a row + 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 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; + 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; - end if; - end loop; - end; - end case; - end if; + Param_Count := Param_Count - 1; + end; - -- Qualifier argument + when Other_As_Is => + Place (' '); + Place (Arg.all); - else - declare - Sw : Item_Ptr; - SwP : Natural; - P2 : Natural; - Endp : Natural := 0; -- avoid warning! - Opt : Item_Ptr; + when Unlimited_As_Is => + Place (' '); + Place (Arg.all); + Param_Count := Param_Count - 1; - begin - SwP := Arg'First; - while SwP < Arg'Last and then Arg (SwP + 1) /= '=' loop - SwP := SwP + 1; - end loop; + when Files_Or_Wildcard => - -- 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. + -- Remove spaces from a comma separated list + -- of file names and adjust control variables + -- accordingly. - -- If make commands are active, see if we have another - -- COMMANDS_TRANSLATION switch belonging to gnatmake. + 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; - if Make_Commands_Active /= null then - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Command.Switches, - Quiet => True); + -- 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. - if Sw /= null and then Sw.Translation = T_Commands then - null; + 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; - else - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Make_Commands_Active.Switches, - Quiet => False); - end if; + return Arg'Last; + end Get_Arg1_End; - -- 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); + 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; - -- For all other cases, just search the relevant command + -- Qualifier argument else - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Command.Switches, - Quiet => False); - end if; + 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; - if Sw /= null then - case Sw.Translation is + -- 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. - 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); + -- 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; - when T_Directories => - if SwP + 1 > Arg'Last then - Put (Standard_Error, - "missing directories for: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; + -- 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 Arg (SwP + 2) /= '(' then - SwP := SwP + 2; - Endp := Arg'Last; + 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; - elsif Arg (Arg'Last) /= ')' then + -- For all other cases, just search the relevant + -- command. - -- Remove spaces from a comma separated list - -- of file names and adjust control - -- variables accordingly. + 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; - 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; + when T_Directories => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing directories for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; - Put (Standard_Error, - "incorrectly parenthesized " & - "or malformed argument: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; + elsif Arg (SwP + 2) /= '(' then + SwP := SwP + 2; + Endp := Arg'Last; - else - SwP := SwP + 3; - Endp := Arg'Last - 1; - end if; + elsif Arg (Arg'Last) /= ')' then - 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; + -- Remove spaces from a comma separated + -- list of file names and adjust + -- control variables accordingly. - while P2 < Endp - and then Arg (P2 + 1) /= ',' - loop + 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; - -- A wildcard directory spec on VMS - -- will contain either * or % or ... + Put (Standard_Error, + "incorrectly parenthesized " & + "or malformed argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; - if Arg (P2) = '*' then - Dir_Is_Wild := True; + else + SwP := SwP + 3; + Endp := Arg'Last - 1; + end if; - elsif Arg (P2) = '%' then - Dir_Is_Wild := True; + 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; - elsif Dir_Maybe_Is_Wild - and then Arg (P2) = '.' - and then Arg (P2 + 1) = '.' - then - Dir_Is_Wild := True; - Dir_Maybe_Is_Wild := False; + 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); - elsif Dir_Maybe_Is_Wild then - Dir_Maybe_Is_Wild := False; + -- Some switches end in "=". No space + -- here - elsif Arg (P2) = '.' - and then Arg (P2 + 1) = '.' + if Sw.Unix_String + (Sw.Unix_String'Last) /= '=' then - Dir_Maybe_Is_Wild := True; - + Place (' '); end if; - P2 := P2 + 1; - end loop; + Place_Lower + (To_Canonical_Dir_Spec + (Arg (SwP + 2 .. Arg'Last), + False).all); + end if; - if (Dir_Is_Wild) then - Dir_List := To_Canonical_File_List - (Arg (SwP .. P2), True); + 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; - 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); + + -- 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; - SwP := P2 + 2; - end; - end loop; + when T_Numeric => + if + OK_Integer (Arg (SwP + 2 .. Arg'Last)) + then + Place_Unix_Switches (Sw.Unix_String); + Place (Arg (SwP + 2 .. Arg'Last)); - 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 + Put (Standard_Error, "argument for "); + Put (Standard_Error, Sw.Name.all); + Put_Line + (Standard_Error, " must be numeric"); + Errors := Errors + 1; + end if; - else - Place_Unix_Switches (Sw.Unix_String); + when T_Alphanumplus => + if + OK_Alphanumerplus + (Arg (SwP + 2 .. Arg'Last)) + then + Place_Unix_Switches (Sw.Unix_String); + Place (Arg (SwP + 2 .. Arg'Last)); - -- Some switches end in "=". No space here + 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 - if Sw.Unix_String - (Sw.Unix_String'Last) /= '=' - then Place (' '); - end if; + 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; - Place_Lower (To_Canonical_Dir_Spec - (Arg (SwP + 2 .. Arg'Last), False).all); - end if; + else + SwP := SwP + 3; + Endp := Arg'Last - 1; + 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; + while SwP <= Endp loop + P2 := SwP; - else - Place_Unix_Switches (Sw.Unix_String); + while P2 < Endp + and then Arg (P2 + 1) /= ',' + loop + P2 := P2 + 1; + end loop; - -- Some switches end in "=". No space here + -- Option name is in Arg (SwP .. P2) - if Sw.Unix_String - (Sw.Unix_String'Last) /= '=' - then - Place (' '); - end if; + Opt := Matching_Name (Arg (SwP .. P2), + Sw.Options); - Place_Lower (To_Canonical_File_Spec - (Arg (SwP + 2 .. Arg'Last)).all); - end if; + if Opt /= null then + Place_Unix_Switches + (Opt.Unix_String); + 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)); + SwP := P2 + 2; + end loop; - 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_Other => + Place_Unix_Switches + (new String'(Sw.Unix_String.all & + Arg.all)); - when T_Alphanumplus => - if - OK_Alphanumerplus (Arg (SwP + 2 .. Arg'Last)) - then - Place_Unix_Switches (Sw.Unix_String); - Place (Arg (SwP + 2 .. Arg'Last)); + end case; + end if; + end; + end if; - else - Put (Standard_Error, "argument for "); - Put (Standard_Error, Sw.Name.all); - Put_Line (Standard_Error, - " must be alphanumeric"); - Errors := Errors + 1; - end if; + Arg_Idx := Next_Arg_Idx + 1; + end; - 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); + exit when Arg_Idx > Argv'Last; - when T_Commands => + end loop; + end Process_Argument; - -- Output -largs/-bargs/-cargs + Arg_Num := Arg_Num + 1; + end loop; - Place (' '); - Place (Sw.Unix_String - (Sw.Unix_String'First .. - Sw.Unix_String'First + 5)); + if Display_Command then + Put (Standard_Error, "generated command -->"); + Put (Standard_Error, Command_List (The_Command).Unixcmd.all); - -- Set source of new commands, also setting this - -- non-null indicates that we are in the special - -- commands mode for processing the -xargs case. + 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; - 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; + Put (Standard_Error, " "); + Put (Standard_Error, String (Buffer.Table (1 .. Buffer.Last))); + Put (Standard_Error, "<--"); + New_Line (Standard_Error); + raise Normal_Exit; + end if; - else - SwP := SwP + 3; - Endp := Arg'Last - 1; - end if; + -- Gross error checking that the number of parameters is correct. + -- Not applicable to Unlimited_Files parameters. - while SwP <= Endp loop - P2 := SwP; + 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; - while P2 < Endp - and then Arg (P2 + 1) /= ',' - loop - P2 := P2 + 1; - end loop; + 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; - -- Option name is in Arg (SwP .. P2) + if Errors > 0 then + raise Error_Exit; + else + -- Prepare arguments for a call to spawn, filtering out + -- embedded nulls place there to delineate strings. - Opt := Matching_Name (Arg (SwP .. P2), - Sw.Options); + declare + P1, P2 : Natural; + Inside_Nul : Boolean := False; + Arg : String (1 .. 1024); + Arg_Ctr : Natural; - if Opt /= null then - Place_Unix_Switches (Opt.Unix_String); - end if; + begin + P1 := 1; - SwP := P2 + 2; - end loop; + 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 - when T_Other => - Place_Unix_Switches - (new String'(Sw.Unix_String.all & Arg.all)); + 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); - end case; + 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; + 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; - Arg_Idx := Next_Arg_Idx + 1; - end; + ------------------------------------- + -- Start of processing for GNATCmd -- + ------------------------------------- - exit when Arg_Idx > Argv'Last; +begin + -- Initializations - end loop; - end; + Namet.Initialize; + Csets.Initialize; - Arg_Num := Arg_Num + 1; - end loop; + Snames.Initialize; - 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; + Prj.Initialize; + + Last_Switches.Init; + Last_Switches.Set_Last (0); - -- Gross error checking that the number of parameters is correct. - -- Not applicable to Unlimited_Files parameters. + First_Switches.Init; + First_Switches.Set_Last (0); - if not ((Param_Count = Command.Params'Length - 1 and then - Command.Params (Param_Count + 1) = Unlimited_Files) - or else (Param_Count <= Command.Params'Length)) + -- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers, + -- filenames and pathnames to Unix style. + + if Hostparm.OpenVMS + or else To_Lower (Getenv ("EMULATE_VMS").all) = "true" then - 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; + VMS_Conversion (The_Command); + + -- If not on VMS, scan the command line directly - if Errors > 0 then - raise Error_Exit; else - -- Prepare arguments for a call to spawn, filtering out - -- embedded nulls place there to delineate strings. + if Argument_Count = 0 then + Non_VMS_Usage; + return; + else + begin + if Argument_Count > 1 and then Argument (1) = "-v" then + Opt.Verbose_Mode := True; + Command_Arg := 2; + end if; - declare - Pname_Ptr : Natural; - Args : Argument_List (1 .. 500); - Nargs : Natural; - P1, P2 : Natural; - Exec_Path : String_Access; - Inside_Nul : Boolean := False; - Arg : String (1 .. 1024); - Arg_Ctr : Natural; + The_Command := Real_Command_Type'Value (Argument (Command_Arg)); - begin - Pname_Ptr := 1; + if Command_List (The_Command).VMS_Only then + Non_VMS_Usage; + Fail ("Command """ & Command_List (The_Command).Cname.all & + """ can only be used on VMS"); + end if; + exception + when Constraint_Error => + + -- Check if it is an alternate command + declare + Alternate : Alternate_Command; + + begin + Alternate := Alternate_Command'Value + (Argument (Command_Arg)); + The_Command := Corresponding_To (Alternate); + + exception + when Constraint_Error => + Non_VMS_Usage; + Fail ("Unknown command: " & Argument (Command_Arg)); + end; + end; - while Pname_Ptr < Buffer.Last - and then Buffer.Table (Pname_Ptr + 1) /= ' ' - loop - Pname_Ptr := Pname_Ptr + 1; + for Arg in Command_Arg + 1 .. Argument_Count loop + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'(Argument (Arg)); end loop; + end if; + end if; - P1 := Pname_Ptr + 2; - Arg_Ctr := 1; - Arg (Arg_Ctr) := Buffer.Table (P1); + declare + Program : constant String := + Program_Name (Command_List (The_Command).Unixcmd.all).all; - Nargs := 0; - while P1 <= Buffer.Last loop + Exec_Path : String_Access; - if Buffer.Table (P1) = ASCII.NUL then - if Inside_Nul then - Inside_Nul := False; - else - Inside_Nul := True; - end if; - end if; + begin + -- Locate the executable for the command - if Buffer.Table (P1) = ' ' and then not Inside_Nul then - P1 := P1 + 1; - Arg_Ctr := Arg_Ctr + 1; - Arg (Arg_Ctr) := Buffer.Table (P1); + Exec_Path := Locate_Exec_On_Path (Program); - else - Nargs := Nargs + 1; - P2 := P1; + if Exec_Path = null then + Put_Line (Standard_Error, "Couldn't locate " & Program); + raise Error_Exit; + end if; + + -- If there are switches for the executable, put them as first switches + + if Command_List (The_Command).Unixsws /= null then + for J in Command_List (The_Command).Unixsws'Range loop + First_Switches.Increment_Last; + First_Switches.Table (First_Switches.Last) := + Command_List (The_Command).Unixsws (J); + end loop; + end if; + + -- For BIND, FIND, LINK, LIST and XREF, look for project file related + -- switches. + + if The_Command = Bind + or else The_Command = Find + or else The_Command = Link + or else The_Command = List + or else The_Command = Xref + then + case The_Command is + when Bind => + Tool_Package_Name := Name_Binder; + when Find => + Tool_Package_Name := Name_Finder; + when Link => + Tool_Package_Name := Name_Linker; + when List => + Tool_Package_Name := Name_Gnatls; + when Xref => + Tool_Package_Name := Name_Cross_Reference; + when others => + null; + end case; + + declare + Arg_Num : Positive := 1; + Argv : String_Access; + + procedure Remove_Switch (Num : Positive); + -- Remove a project related switch from table Last_Switches + + ------------------- + -- Remove_Switch -- + ------------------- + + procedure Remove_Switch (Num : Positive) is + begin + Last_Switches.Table (Num .. Last_Switches.Last - 1) := + Last_Switches.Table (Num + 1 .. Last_Switches.Last); + Last_Switches.Decrement_Last; + end Remove_Switch; + + -- Start of processing for ??? (need block name here) + + begin + while Arg_Num <= Last_Switches.Last loop + Argv := Last_Switches.Table (Arg_Num); + + if Argv (Argv'First) = '-' then + if Argv'Length = 1 then + Fail ("switch character cannot be followed by a blank"); + end if; + + -- The two style project files (-p and -P) cannot be used + -- together + + if (The_Command = Find or else The_Command = Xref) + and then Argv (2) = 'p' + then + Old_Project_File_Used := True; + if Project_File /= null then + Fail ("-P and -p cannot be used together"); + end if; + end if; + + -- -vPx Specify verbosity while parsing project files + + if Argv'Length = 4 + and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP" + then + case Argv (Argv'Last) is + when '0' => + Current_Verbosity := Prj.Default; + when '1' => + Current_Verbosity := Prj.Medium; + when '2' => + Current_Verbosity := Prj.High; + when others => + Fail ("Invalid switch: " & Argv.all); + end case; + + Remove_Switch (Arg_Num); + + -- -Pproject_file Specify project file to be used + + elsif Argv'Length >= 3 + and then Argv (Argv'First + 1) = 'P' + then + + -- Only one -P switch can be used + + if Project_File /= null then + Fail (Argv.all & + ": second project file forbidden (first is """ & + Project_File.all & """)"); + + -- The two style project files (-p and -P) cannot be + -- used together. + + elsif Old_Project_File_Used then + Fail ("-p and -P cannot be used together"); - 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; + Project_File := + new String'(Argv (Argv'First + 2 .. Argv'Last)); end if; + + Remove_Switch (Arg_Num); + + -- -Xexternal=value Specify an external reference to be + -- used in project files + + elsif Argv'Length >= 5 + and then Argv (Argv'First + 1) = 'X' + then + declare + Equal_Pos : constant Natural := + Index ('=', Argv (Argv'First + 2 .. Argv'Last)); + begin + if Equal_Pos >= Argv'First + 3 and then + Equal_Pos /= Argv'Last then + Add (External_Name => + Argv (Argv'First + 2 .. Equal_Pos - 1), + Value => Argv (Equal_Pos + 1 .. Argv'Last)); + else + Fail (Argv.all & + " is not a valid external assignment."); + end if; + end; + + Remove_Switch (Arg_Num); + + else + Arg_Num := Arg_Num + 1; end if; - end loop; - Args (Nargs) := new String'(String (Arg (1 .. Arg_Ctr))); - P1 := P2 + 2; - Arg_Ctr := 1; - Arg (Arg_Ctr) := Buffer.Table (P1); + else + Arg_Num := Arg_Num + 1; + end if; + end loop; + end; + end if; + + -- If there is a project file specified, parse it, get the switches + -- for the tool and setup PATH environment variables. + + if Project_File /= null then + Prj.Pars.Set_Verbosity (To => Current_Verbosity); + + Prj.Pars.Parse + (Project => Project, + Project_File_Name => Project_File.all); + + if Project = Prj.No_Project then + Fail ("""" & Project_File.all & """ processing failed"); + end if; + + -- Check if a package with the name of the tool is in the project + -- file and if there is one, get the switches, if any, and scan them. + + declare + Data : Prj.Project_Data := Prj.Projects.Table (Project); + Pkg : Prj.Package_Id := + Prj.Util.Value_Of + (Name => Tool_Package_Name, + In_Packages => Data.Decl.Packages); + + Element : Package_Element; + + Default_Switches_Array : Array_Element_Id; + + The_Switches : Prj.Variable_Value; + Current : Prj.String_List_Id; + The_String : String_Element; + + begin + if Pkg /= No_Package then + Element := Packages.Table (Pkg); + + -- Packages Gnatls has a single attribute Switches, that is + -- not an associative array. + + if The_Command = List then + The_Switches := + Prj.Util.Value_Of + (Variable_Name => Snames.Name_Switches, + In_Variables => Element.Decl.Attributes); + + -- Packages Binder (for gnatbind), Cross_Reference (for + -- gnatxref), Linker (for gnatlink) and Finder + -- (for gnatfind) have an attributed Default_Switches, + -- an associative array, indexed by the name of the + -- programming language. + else + Default_Switches_Array := + Prj.Util.Value_Of + (Name => Name_Default_Switches, + In_Arrays => Packages.Table (Pkg).Decl.Arrays); + The_Switches := Prj.Util.Value_Of + (Index => Name_Ada, + In_Array => Default_Switches_Array); + + end if; + + -- If there are switches specified in the package of the + -- project file corresponding to the tool, scan them. + + case The_Switches.Kind is + when Prj.Undefined => + null; + + when Prj.Single => + if String_Length (The_Switches.Value) > 0 then + String_To_Name_Buffer (The_Switches.Value); + First_Switches.Increment_Last; + First_Switches.Table (First_Switches.Last) := + new String'(Name_Buffer (1 .. Name_Len)); + end if; + + when Prj.List => + Current := The_Switches.Values; + while Current /= Prj.Nil_String loop + The_String := String_Elements.Table (Current); + + if String_Length (The_String.Value) > 0 then + String_To_Name_Buffer (The_String.Value); + First_Switches.Increment_Last; + First_Switches.Table (First_Switches.Last) := + new String'(Name_Buffer (1 .. Name_Len)); + end if; + + Current := The_String.Next; + end loop; + end case; end if; + end; + + -- Set up the environment variables ADA_INCLUDE_PATH and + -- ADA_OBJECTS_PATH. + + Setenv + (Name => Ada_Include_Path, + Value => Prj.Env.Ada_Include_Path (Project).all); + Setenv + (Name => Ada_Objects_Path, + Value => Prj.Env.Ada_Objects_Path + (Project, Including_Libraries => False).all); + + if The_Command = Bind or else The_Command = Link then + Change_Dir + (Get_Name_String + (Projects.Table (Project).Object_Directory)); + end if; + + if The_Command = Link then + + -- Add the default search directories, to be able to find + -- libgnat in call to MLib.Utl.Lib_Directory. + + Add_Default_Search_Dirs; + + declare + There_Are_Libraries : Boolean := False; + + begin + -- Check if there are library project files + + if MLib.Tgt.Libraries_Are_Supported then + Set_Libraries (Project, There_Are_Libraries); + end if; + + -- If there are, add the necessary additional switches + + if There_Are_Libraries then + + -- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir> + + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-L" & MLib.Utl.Lib_Directory); + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-lgnarl"); + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-lgnat"); + + declare + Option : constant String_Access := + MLib.Tgt.Linker_Library_Path_Option + (MLib.Utl.Lib_Directory); + + begin + if Option /= null then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + Option; + end if; + end; + end if; + end; + end if; + end if; + + -- Gather all the arguments and invoke the executable + + declare + The_Args : Argument_List + (1 .. First_Switches.Last + Last_Switches.Last); + Arg_Num : Natural := 0; + begin + for J in 1 .. First_Switches.Last loop + Arg_Num := Arg_Num + 1; + The_Args (Arg_Num) := First_Switches.Table (J); end loop; - Exec_Path := Locate_Exec_On_Path - (String (Buffer.Table (1 .. Pname_Ptr))); + for J in 1 .. Last_Switches.Last loop + Arg_Num := Arg_Num + 1; + The_Args (Arg_Num) := Last_Switches.Table (J); + end loop; - if Exec_Path = null then - Put_Line (Standard_Error, - "Couldn't locate " - & String (Buffer.Table (1 .. Pname_Ptr))); - raise Error_Exit; + if Opt.Verbose_Mode then + Output.Write_Str (Exec_Path.all); + + for Arg in The_Args'Range loop + Output.Write_Char (' '); + Output.Write_Str (The_Args (Arg).all); + end loop; + + Output.Write_Eol; end if; My_Exit_Status - := Exit_Status (Spawn (Exec_Path.all, Args (1 .. Nargs))); - + := Exit_Status (Spawn (Exec_Path.all, The_Args)); + raise Normal_Exit; end; - - raise Normal_Exit; - end if; + end; exception when Error_Exit => |