Skip to content

R
riscv-gcc-1
Commit 935a9145 by Arnaud Charlet
Options

[multiple changes] 

2014-08-01  Vincent Celier  <celier@adacore.com>

	* gnatcmd.adb: Remove the VMS specific stuff.  Integrate in
	procedure GNATCmd the relevant declarations from packages VMS_Cmds
	and VMS_Conv.
	* gnatcmd.ads: Update comments to remove any trace of VMS

2014-08-01  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb: sem_ch12.adb (Build_Wrapper): Capture entity for
	defaulted actual that is an operator, before building wrapper
	for it in GNATprove mode. Restrict construction of wrapper to
	actuals that are operators.

2014-08-01  Vincent Celier  <celier@adacore.com>

	* vms_conv.adb, vms_conv.ads, vms_data.ads, vms_cmds.ads: Remove VMS
	specific packages no longer needed.

2014-08-01  Pascal Obry  <obry@adacore.com>

	* s-os_lib.ads (System.CRTL): Move with clause to body.
	(File_Size): New type.
	(File_Length64): Use it.
	(File_Length): Restore previous spec returning a Long_Integer.
	* s-os_lib.adb (System.CRTL): Move with clause here.

2014-08-01  Vincent Celier  <celier@adacore.com>

	* mlib-prj.adb: Update comments to remove any mention of VMS.

From-SVN: r213430
parent 24228312
Showing with 281 additions and 2641 deletions
gcc/ada/ChangeLog
2014-08-01 Vincent Celier <celier@adacore.com>
* gnatcmd.adb: Remove the VMS specific stuff. Integrate in
procedure GNATCmd the relevant declarations from packages VMS_Cmds
and VMS_Conv.
* gnatcmd.ads: Update comments to remove any trace of VMS
2014-08-01 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb: sem_ch12.adb (Build_Wrapper): Capture entity for
defaulted actual that is an operator, before building wrapper
for it in GNATprove mode. Restrict construction of wrapper to
actuals that are operators.
2014-08-01 Vincent Celier <celier@adacore.com>
* vms_conv.adb, vms_conv.ads, vms_data.ads, vms_cmds.ads: Remove VMS
specific packages no longer needed.
2014-08-01 Pascal Obry <obry@adacore.com>
* s-os_lib.ads (System.CRTL): Move with clause to body.
(File_Size): New type.
(File_Length64): Use it.
(File_Length): Restore previous spec returning a Long_Integer.
* s-os_lib.adb (System.CRTL): Move with clause here.
2014-08-01 Vincent Celier <celier@adacore.com>
* mlib-prj.adb: Update comments to remove any mention of VMS.
2014-08-01 Arnaud Charlet <charlet@adacore.com>
* ug_words, xgnatugn.adb, gcc-interface/Make-lang.in: Remove
......
gcc/ada/adaint.c
......@@ -1326,6 +1326,14 @@ __gnat_file_length (int fd)
return __gnat_file_length_attr (fd, NULL, &attr);
}
long
__gnat_file_length_long (int fd)
{
struct file_attributes attr;
__gnat_reset_attributes (&attr);
return (long)__gnat_file_length_attr (fd, NULL, &attr);
}
__int64
__gnat_named_file_length (char *name)
{
......
gcc/ada/adaint.h
......@@ -160,6 +160,7 @@ extern int __gnat_create_output_file (char *);
extern int __gnat_create_output_file_new (char *);
extern int __gnat_open_append (char *, int);
extern long __gnat_file_length_long (int);
extern __int64 __gnat_file_length (int);
extern __int64 __gnat_named_file_length (char *);
extern void __gnat_tmp_name (char *);
......
gcc/ada/gnatcmd.adb
......@@ -26,6 +26,7 @@
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with Csets;
with Gnatvsn;
with Makeutl; use Makeutl;
with MLib.Tgt; use MLib.Tgt;
with MLib.Utl;
......@@ -46,11 +47,9 @@ with Snames; use Snames;
with Stringt;
with Switch; use Switch;
with Table;
with Targparm;
with Targparm; use Targparm;
with Tempdir;
with Types; use Types;
with VMS_Conv; use VMS_Conv;
with VMS_Cmds; use VMS_Cmds;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
......@@ -59,6 +58,49 @@ with Ada.Text_IO; use Ada.Text_IO;
with GNAT.OS_Lib; use GNAT.OS_Lib;
procedure GNATCmd is
Normal_Exit : exception;
-- Raise this exception for normal program termination
Error_Exit : exception;
-- Raise this exception if error detected
type Command_Type is
(Bind,
Chop,
Clean,
Compile,
Check,
Sync,
Elim,
Find,
Krunch,
Link,
List,
Make,
Metric,
Name,
Preprocess,
Pretty,
Stack,
Stub,
Test,
Xref,
Undefined);
subtype Real_Command_Type is Command_Type range Bind .. Xref;
-- All real command types (excludes only Undefined).
type Alternate_Command is (Comp, Ls, Kr, Pp, Prep);
-- Alternate command label
Corresponding_To : constant array (Alternate_Command) of Command_Type :=
(Comp => Compile,
Ls => List,
Kr => Krunch,
Prep => Preprocess,
Pp => Pretty);
-- Mapping of alternate commands to commands
Project_Node_Tree : Project_Node_Tree_Ref;
Project_File : String_Access;
Project : Prj.Project_Id;
......@@ -66,7 +108,7 @@ procedure GNATCmd is
Tool_Package_Name : Name_Id := No_Name;
B_Start : constant String := "b~";
-- Prefix of binder generated file, changed to b__ for gprbuild
-- Prefix of binder generated file
Project_Tree : constant Project_Tree_Ref :=
new Project_Tree_Data (Is_Root_Tree => True);
......@@ -119,6 +161,14 @@ procedure GNATCmd is
Table_Increment => 100,
Table_Name => "Make.Library_Path");
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");
-- Packages of project files to pass to Prj.Pars.Parse, depending on the
-- tool. We allocate objects because we cannot declare aliased objects
-- as we are in a procedure, not a library level package.
......@@ -201,6 +251,121 @@ procedure GNATCmd is
-- indicate that the underlying tool (gnatcheck, gnatpp or gnatmetric)
-- should be invoked for all sources of all projects.
type Command_Entry is record
Cname : String_Access;
-- Command name for GNAT xxx command
Unixcmd : String_Access;
-- Corresponding Unix command
Unixsws : Argument_List_Access;
-- List of switches to be used with the Unix command
end record;
Command_List : constant array (Real_Command_Type) of Command_Entry :=
(Bind =>
(Cname => new String'("BIND"),
Unixcmd => new String'("gnatbind"),
Unixsws => null),
Chop =>
(Cname => new String'("CHOP"),
Unixcmd => new String'("gnatchop"),
Unixsws => null),
Clean =>
(Cname => new String'("CLEAN"),
Unixcmd => new String'("gnatclean"),
Unixsws => null),
Compile =>
(Cname => new String'("COMPILE"),
Unixcmd => new String'("gnatmake"),
Unixsws => new Argument_List'(1 => new String'("-f"),
2 => new String'("-u"),
3 => new String'("-c"))),
Check =>
(Cname => new String'("CHECK"),
Unixcmd => new String'("gnatcheck"),
Unixsws => null),
Sync =>
(Cname => new String'("SYNC"),
Unixcmd => new String'("gnatsync"),
Unixsws => null),
Elim =>
(Cname => new String'("ELIM"),
Unixcmd => new String'("gnatelim"),
Unixsws => null),
Find =>
(Cname => new String'("FIND"),
Unixcmd => new String'("gnatfind"),
Unixsws => null),
Krunch =>
(Cname => new String'("KRUNCH"),
Unixcmd => new String'("gnatkr"),
Unixsws => null),
Link =>
(Cname => new String'("LINK"),
Unixcmd => new String'("gnatlink"),
Unixsws => null),
List =>
(Cname => new String'("LIST"),
Unixcmd => new String'("gnatls"),
Unixsws => null),
Make =>
(Cname => new String'("MAKE"),
Unixcmd => new String'("gnatmake"),
Unixsws => null),
Metric =>
(Cname => new String'("METRIC"),
Unixcmd => new String'("gnatmetric"),
Unixsws => null),
Name =>
(Cname => new String'("NAME"),
Unixcmd => new String'("gnatname"),
Unixsws => null),
Preprocess =>
(Cname => new String'("PREPROCESS"),
Unixcmd => new String'("gnatprep"),
Unixsws => null),
Pretty =>
(Cname => new String'("PRETTY"),
Unixcmd => new String'("gnatpp"),
Unixsws => null),
Stack =>
(Cname => new String'("STACK"),
Unixcmd => new String'("gnatstack"),
Unixsws => null),
Stub =>
(Cname => new String'("STUB"),
Unixcmd => new String'("gnatstub"),
Unixsws => null),
Test =>
(Cname => new String'("TEST"),
Unixcmd => new String'("gnattest"),
Unixsws => null),
Xref =>
(Cname => new String'("XREF"),
Unixcmd => new String'("gnatxref"),
Unixsws => null)
);
-----------------------
-- Local Subprograms --
-----------------------
......@@ -258,8 +423,11 @@ procedure GNATCmd is
-- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric
-- (GNAT METRIC).
procedure Non_VMS_Usage;
-- Display usage for platforms other than VMS
procedure Output_Version;
-- Output the version of this program
procedure Usage;
-- Display usage
procedure Process_Link;
-- Process GNAT LINK, when there is a project file specified
......@@ -854,8 +1022,7 @@ procedure GNATCmd is
Prj.Env.Create_Temp_File (Project_Tree.Shared, FD, Name, "files");
-- And close it, because on VMS Spawn with a file descriptor created
-- with Create_Temp_File does not redirect output.
-- And close it
Close (FD);
......@@ -982,11 +1149,29 @@ procedure GNATCmd is
return Result;
end Mapping_File;
-------------------
-- Non_VMS_Usage --
-------------------
--------------------
-- Output_Version --
--------------------
procedure Non_VMS_Usage is
procedure Output_Version is
begin
if AAMP_On_Target then
Put ("GNAAMP ");
else
Put ("GNAT ");
end if;
Put_Line (Gnatvsn.Gnat_Version_String);
Put_Line ("Copyright 1996-" &
Gnatvsn.Current_Year &
", Free Software Foundation, Inc.");
end Output_Version;
-----------
-- Usage --
-----------
procedure Usage is
begin
Output_Version;
New_Line;
......@@ -997,7 +1182,7 @@ procedure GNATCmd is
-- No usage for VMS only command or for Sync
if not Command_List (C).VMS_Only and then C /= Sync then
if C /= Sync then
if Targparm.AAMP_On_Target then
Put ("gnaampcmd ");
else
......@@ -1034,7 +1219,7 @@ procedure GNATCmd is
Put_Line ("All commands except chop, krunch and preprocess " &
"accept project file switches -vPx, -Pprj and -Xnam=val");
New_Line;
end Non_VMS_Usage;
end Usage;
------------------
-- Process_Link --
......@@ -1367,7 +1552,7 @@ procedure GNATCmd is
end Set_Library_For;
procedure Check_Version_And_Help is
new Check_Version_And_Help_G (Non_VMS_Usage);
new Check_Version_And_Help_G (Usage);
-- Start of processing for GNATCmd
......@@ -1399,8 +1584,6 @@ begin
Rules_Switches.Init;
Rules_Switches.Set_Last (0);
VMS_Conv.Initialize;
-- Add the default search directories, to be able to find system.ads in the
-- subsequent call to Targparm.Get_Target_Parameters.
......@@ -1478,20 +1661,12 @@ begin
-- If there is no command, just output the usage
if Command_Arg > Argument_Count then
Non_VMS_Usage;
Usage;
return;
end if;
The_Command := Real_Command_Type'Value (Argument (Command_Arg));
if Command_List (The_Command).VMS_Only then
Non_VMS_Usage;
Fail
("command """
& Command_List (The_Command).Cname.all
& """ can only be used on VMS");
end if;
exception
when Constraint_Error =>
......@@ -1507,7 +1682,7 @@ begin
exception
when Constraint_Error =>
Non_VMS_Usage;
Usage;
Fail ("unknown command: " & Argument (Command_Arg));
end;
end;
......@@ -2633,22 +2808,6 @@ begin
The_Args (Arg_Num) := Rules_Switches.Table (J);
end loop;
-- If Display_Command is on, only display the generated command
if Display_Command then
Put (Standard_Error, "generated command -->");
Put (Standard_Error, Exec_Path.all);
for Arg in The_Args'Range loop
Put (Standard_Error, " ");
Put (Standard_Error, The_Args (Arg).all);
end loop;
Put (Standard_Error, "<--");
New_Line (Standard_Error);
raise Normal_Exit;
end if;
if Verbose_Mode then
Output.Write_Str (Exec_Path.all);
......
gcc/ada/gnatcmd.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1996-2008, Free Software Foundation, Inc. --
-- Copyright (C) 1996-2014, 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- --
......@@ -24,35 +24,19 @@
------------------------------------------------------------------------------
-- This program provides a simple command interface for using GNAT and its
-- associated utilities. The format of switches accepted is intended to
-- be more familiar in style for VMS and DOS users than the standard Unix
-- style switches that are accepted directly.
-- associated utilities.
-- The program is typically called GNAT when it is installed and
-- the two possible styles of use are:
-- To call gcc:
-- GNAT filename switches
-- GNAT compile filename switches
-- To call the tool gnatxxx
-- GNAT xxx filename switches
-- where xxx is the command name (e.g. MAKE for gnatmake). This command name
-- can be abbreviated by giving a prefix (e.g. GNAT MAK) as long as it
-- remains unique.
-- In both cases, filename is in the format appropriate to the operating
-- system in use. The individual commands give more details. In some cases
-- a unit name may be given in place of a file name.
-- The switches start with a slash. Switch names can also be abbreviated
-- where no ambiguity arises. The switches associated with each command
-- are specified by the tables that can be found in the body.
-- Although by convention we use upper case for command names and switches
-- in the documentation, all command and switch names are case insensitive
-- and may be given in upper case or lower case or a mixture.
-- where xxx is the command name (e.g. MAKE for gnatmake).
procedure GNATCmd;
gcc/ada/mlib-prj.adb
......@@ -837,7 +837,7 @@ package body MLib.Prj is
Arguments := new String_List (1 .. Initial_Argument_Max);
end if;
-- Add "-n -o b~<lib>.adb (b__<lib>.adb on VMS) -L<lib>_"
-- Add "-n -o b~<lib>.adb -L<lib>_"
Argument_Number := 2;
Arguments (1) := No_Main;
......@@ -1726,10 +1726,8 @@ package body MLib.Prj is
Argument_Number := 0;
-- If we have a standalone library, gather all the interface ALI.
-- They are passed to Build_Dynamic_Library, where they are used by
-- some platforms (VMS, for example) to decide what symbols should be
-- exported. They are also flagged as Interface when we copy them to
-- the library directory (by Copy_ALI_Files, below).
-- They are flagged as Interface when we copy them to the library
-- directory (by Copy_ALI_Files, below).
if Standalone then
Current_Proj := For_Project;
......@@ -2400,9 +2398,8 @@ package body MLib.Prj is
-- Also ignore the shared libraries which are :
-- UNIX / Windows VMS
-- -lgnat-<version> -lgnat_<version> (7 + version'length chars)
-- -lgnarl-<version> -lgnarl_<version> (8 + version'length chars)
-- -lgnat-<version> (7 + version'length chars)
-- -lgnarl-<version> (8 + version'length chars)
if Next_Line (1 .. Nlast) /= "-static" and then
Next_Line (1 .. Nlast) /= "-shared" and then
......
gcc/ada/s-os_lib.adb
......@@ -35,6 +35,7 @@ with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with System; use System;
with System.Case_Util;
with System.CRTL;
with System.Soft_Links;
package body System.OS_Lib is
......
gcc/ada/s-os_lib.ads
......@@ -56,8 +56,6 @@ pragma Compiler_Unit_Warning;
with System;
with System.Strings;
with System.CRTL;
package System.OS_Lib is
pragma Preelaborate;
......@@ -434,8 +432,13 @@ package System.OS_Lib is
-- to the current position (origin = SEEK_CUR), end of file (origin =
-- SEEK_END), or start of file (origin = SEEK_SET).
function File_Length (FD : File_Descriptor) return CRTL.int64;
pragma Import (C, File_Length, "__gnat_file_length");
type File_Size is range -(2 ** 63) .. (2 ** 63) - 1;
function File_Length (FD : File_Descriptor) return Long_Integer;
pragma Import (C, File_Length, "__gnat_file_length_long");
function File_Length64 (FD : File_Descriptor) return File_Size;
pragma Import (C, File_Length64, "__gnat_file_length");
-- Get length of file from file descriptor FD
function File_Time_Stamp (Name : String) return OS_Time;
......
gcc/ada/sem_ch12.adb
......@@ -1137,6 +1137,15 @@ package body Sem_Ch12 is
end if;
end if;
-- Propagate visible entity to operator node, either from a
-- given actual or from a default.
if Is_Entity_Name (Actual)
and then Nkind (Expr) in N_Op
then
Set_Entity (Expr, Entity (Actual));
end if;
Decl :=
Make_Expression_Function (Loc,
Specification => Spec,
......@@ -1669,7 +1678,19 @@ package body Sem_Ch12 is
-- If actual is an entity (function or operator),
-- build wrapper for it.
if Present (Match) and then Is_Entity_Name (Match) then
if Present (Match)
and then Nkind (Match) = N_Operator_Symbol
then
-- If the name is a default, find its visible
-- entity at the point of instantiation.
if Is_Entity_Name (Match)
and then No (Entity (Match))
then
Find_Direct_Name (Match);
end if;
Append_To (Assoc,
Build_Wrapper
(Defining_Entity (Analyzed_Formal), Match));
......@@ -1679,7 +1700,6 @@ package body Sem_Ch12 is
elsif Box_Present (Formal)
and then Nkind (Defining_Entity (Analyzed_Formal))
= N_Defining_Operator_Symbol
then
Append_To (Assoc,
Build_Wrapper
......
gcc/ada/vms_cmds.ads deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- V M S _ C M D S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2010-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package is part of the GNAT driver. It contains the declaration of
-- Command_Type which list all the commands supported by the gnat driver.
package VMS_Cmds is
type Command_Type is
(Bind,
Chop,
Clean,
Compile,
Check,
Sync,
Elim,
Find,
Krunch,
Link,
List,
Make,
Metric,
Name,
Preprocess,
Pretty,
Shared,
Stack,
Stub,
Test,
Xref,
Undefined);
subtype Real_Command_Type is Command_Type range Bind .. Xref;
-- All real command types (excludes only Undefined).
end VMS_Cmds;
gcc/ada/vms_conv.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- V M S _ C O N V --
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Gnatvsn; use Gnatvsn;
with Hostparm;
with Opt;
with Osint; use Osint;
with Targparm; use Targparm;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
package body VMS_Conv is
-------------------------
-- Internal Structures --
-------------------------
-- The switches and commands are defined by strings in the previous
-- section so that they are easy to modify, but internally, they are
-- kept in a more conveniently accessible form described in this
-- section.
-- Commands, command qualifiers and options have a similar common format
-- so that searching for matching names can be done in a common manner.
type Item_Id is (Id_Command, Id_Switch, Id_Option);
type Translation_Type is
(
T_Direct,
-- A qualifier with no options.
-- Example: GNAT MAKE /VERBOSE
T_Directories,
-- A qualifier followed by a list of directories
-- Example: GNAT COMPILE /SEARCH=([], [.FOO], [.BAR])
T_Directory,
-- A qualifier followed by one directory
-- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB]
T_File,
-- A qualifier followed by a filename
-- Example: GNAT LINK /EXECUTABLE=FOO.EXE
T_No_Space_File,
-- A qualifier followed by a filename
-- Example: GNAT MAKE /PROJECT_FILE=PRJ.GPR
T_Numeric,
-- A qualifier followed by a numeric value.
-- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39
T_String,
-- A qualifier followed by a quoted string. Only used by
-- /IDENTIFICATION qualifier.
-- Example: GNAT LINK /IDENTIFICATION="3.14a1 version"
T_Options,
-- A qualifier followed by a list of options.
-- Example: GNAT COMPILE /REPRESENTATION_INFO=(ARRAYS,OBJECTS)
T_Commands,
-- A qualifier followed by a list. Only used for
-- MAKE /COMPILER_QUALIFIERS /BINDER_QUALIFIERS /LINKER_QUALIFIERS
-- (gnatmake -cargs -bargs -largs )
-- Example: GNAT MAKE ... /LINKER_QUALIFIERS /VERBOSE FOOBAR.OBJ
T_Other,
-- A qualifier passed directly to the linker. Only used
-- for LINK and SHARED if no other match is found.
-- Example: GNAT LINK FOO.ALI /SYSSHR
T_Alphanumplus
-- A qualifier followed by a legal linker symbol prefix. Only used
-- for BIND /BUILD_LIBRARY (gnatbind -Lxyz).
-- Example: GNAT BIND /BUILD_LIBRARY=foobar
);
type Item (Id : Item_Id);
type Item_Ptr is access all Item;
type Item (Id : Item_Id) is record
Name : String_Ptr;
-- Name of the command, switch (with slash) or option
Next : Item_Ptr;
-- Pointer to next item on list, always has the same Id value
Command : Command_Type := Undefined;
Unix_String : String_Ptr := null;
-- Corresponding Unix string. For a command, this is the unix command
-- name and possible default switches. For a switch or option it is
-- the unix switch string.
case Id is
when Id_Command =>
Switches : Item_Ptr;
-- Pointer to list of switch items for the command, linked
-- through the Next fields with null terminating the list.
Usage : String_Ptr;
-- Usage information, used only for errors and the default
-- list of commands output.
Params : Parameter_Ref;
-- Array of parameters
Defext : String (1 .. 3);
-- Default extension. If non-blank, then this extension is
-- supplied by default as the extension for any file parameter
-- which does not have an extension already.
when Id_Switch =>
Translation : Translation_Type;
-- Type of switch translation. For all cases, except Options,
-- this is the only field needed, since the Unix translation
-- is found in Unix_String.
Options : Item_Ptr;
-- For the Options case, this field is set to point to a list
-- of options item (for this case Unix_String is null in the
-- main switch item). The end of the list is marked by null.
when Id_Option =>
null;
-- No special fields needed, since Name and Unix_String are
-- sufficient to completely described an option.
end case;
end record;
subtype Command_Item is Item (Id_Command);
subtype Switch_Item is Item (Id_Switch);
subtype Option_Item is Item (Id_Option);
Keep_Temps_Option : constant Item_Ptr :=
new Item'
(Id => Id_Option,
Name =>
new String'("/KEEP_TEMPORARY_FILES"),
Next => null,
Command => Undefined,
Unix_String => null);
Param_Count : Natural := 0;
-- Number of parameter arguments so far
Arg_Num : Natural;
-- Argument number
Arg_File : Ada.Text_IO.File_Type;
-- A file where arguments are read from
Commands : Item_Ptr;
-- Pointer to head of list of command items, one for each command, with
-- the end of the list marked by a null pointer.
Last_Command : Item_Ptr;
-- Pointer to last item in Commands list
Command : Item_Ptr;
-- Pointer to command item for current command
Make_Commands_Active : Item_Ptr := null;
-- Set to point to Command entry for COMPILE, BIND, or LINK as appropriate
-- if a COMMANDS_TRANSLATION switch has been encountered while processing
-- a MAKE Command.
Output_File_Expected : Boolean := False;
-- True for GNAT LINK after -o switch, so that the ".ali" extension is
-- not added to the executable file name.
package Buffer is new Table.Table
(Table_Component_Type => Character,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 4096,
Table_Increment => 100,
Table_Name => "Buffer");
-- Table to store the command to be used
package Cargs_Buffer is new Table.Table
(Table_Component_Type => Character,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 4096,
Table_Increment => 100,
Table_Name => "Cargs_Buffer");
-- Table to store the compiler switches for GNAT COMPILE
Cargs : Boolean := False;
-- When True, commands should go to Cargs_Buffer instead of Buffer table
function Init_Object_Dirs return Argument_List;
-- Get the list of the object directories
function Invert_Sense (S : String) return VMS_Data.String_Ptr;
-- Given a unix switch string S, computes the inverse (adding or
-- removing ! characters as required), and returns a pointer to
-- the allocated result on the heap.
function Is_Extensionless (F : String) return Boolean;
-- Returns true if the filename has no extension
function Match (S1, S2 : String) return Boolean;
-- Determines whether S1 and S2 match (this is a case insensitive match)
function Match_Prefix (S1, S2 : String) return Boolean;
-- Determines whether S1 matches a prefix of S2. This is also a case
-- insensitive match (for example Match ("AB","abc") is True).
function Matching_Name
(S : String;
Itm : Item_Ptr;
Quiet : Boolean := False) return Item_Ptr;
-- Determines if the item list headed by Itm and threaded through the
-- Next fields (with null marking the end of the list), contains an
-- entry that uniquely matches the given string. The match is case
-- insensitive and permits unique abbreviation. If the match succeeds,
-- then a pointer to the matching item is returned. Otherwise, an
-- appropriate error message is written. Note that the discriminant
-- of Itm is used to determine the appropriate form of this message.
-- Quiet is normally False as shown, if it is set to True, then no
-- error message is generated in a not found situation (null is still
-- returned to indicate the not-found situation).
function OK_Alphanumerplus (S : String) return Boolean;
-- Checks that S is a string of alphanumeric characters,
-- returning True if all alphanumeric characters,
-- False if empty or a non-alphanumeric character is present.
function OK_Integer (S : String) return Boolean;
-- Checks that S is a string of digits, returning True if all digits,
-- False if empty or a non-digit is present.
procedure Place (C : Character);
-- Place a single character in the buffer, updating Ptr
procedure Place (S : String);
-- Place a string character in the buffer, updating Ptr
procedure Place_Lower (S : String);
-- Place string in buffer, forcing letters to lower case, updating Ptr
procedure Place_Unix_Switches (S : VMS_Data.String_Ptr);
-- Given a unix switch string, place corresponding switches in Buffer,
-- updating Ptr appropriately. Note that in the case of use of ! the
-- result may be to remove a previously placed switch.
procedure Preprocess_Command_Data;
-- Preprocess the string form of the command and options list into the
-- internal form.
procedure Process_Argument (The_Command : in out Command_Type);
-- Process one argument from the command line, or one line from
-- from a command line file. For the first call, set The_Command.
procedure Process_Buffer (S : String);
-- Process the characters in the Buffer table or the Cargs_Buffer table
-- to convert these into arguments.
procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr);
-- Check that N is a valid command or option name, i.e. that it is of the
-- form of an Ada identifier with upper case letters and underscores.
procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr);
-- Check that S is a valid switch string as described in the syntax for
-- the switch table item UNIX_SWITCH or else begins with a backquote.
----------------------
-- Init_Object_Dirs --
----------------------
function Init_Object_Dirs return Argument_List is
Object_Dirs : Integer;
Object_Dir : Argument_List (1 .. 256);
Object_Dir_Name : String_Access;
begin
Object_Dirs := 0;
Object_Dir_Name := new String'(Object_Dir_Default_Prefix);
Get_Next_Dir_In_Path_Init (Object_Dir_Name);
loop
declare
Dir : constant String_Access :=
Get_Next_Dir_In_Path (Object_Dir_Name);
begin
exit when Dir = null;
Object_Dirs := Object_Dirs + 1;
Object_Dir (Object_Dirs) :=
new String'("-L" &
To_Canonical_Dir_Spec
(To_Host_Dir_Spec
(Normalize_Directory_Name (Dir.all).all,
True).all, True).all);
end;
end loop;
Object_Dirs := Object_Dirs + 1;
Object_Dir (Object_Dirs) := new String'("-lgnat");
if OpenVMS_On_Target then
Object_Dirs := Object_Dirs + 1;
Object_Dir (Object_Dirs) := new String'("-ldecgnat");
end if;
return Object_Dir (1 .. Object_Dirs);
end Init_Object_Dirs;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
Command_List :=
(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 => Unlimited_Files),
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 => " "),
Clean =>
(Cname => new S'("CLEAN"),
Usage => new S'("GNAT CLEAN /qualifiers files"),
VMS_Only => False,
Unixcmd => new S'("gnatclean"),
Unixsws => null,
Switches => Clean_Switches'Access,
Params => new Parameter_Array'(1 => 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 => " "),
Check =>
(Cname => new S'("CHECK"),
Usage => new S'("GNAT CHECK name /qualifiers"),
VMS_Only => False,
Unixcmd => new S'("gnatcheck"),
Unixsws => null,
Switches => Check_Switches'Access,
Params => new Parameter_Array'(1 => Unlimited_Files),
Defext => " "),
Sync =>
(Cname => new S'("SYNC"),
Usage => new S'("GNAT SYNC name /qualifiers"),
VMS_Only => False,
Unixcmd => new S'("gnatsync"),
Unixsws => null,
Switches => Sync_Switches'Access,
Params => new Parameter_Array'(1 => Unlimited_Files),
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 => " "),
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 => Unlimited_Files),
Defext => "ali"),
Make =>
(Cname => new S'("MAKE"),
Usage => new S'("GNAT MAKE file(s) /qualifiers (includes "
& "COMPILE /qualifiers)"),
VMS_Only => False,
Unixcmd => new S'("gnatmake"),
Unixsws => null,
Switches => Make_Switches'Access,
Params => new Parameter_Array'(1 => Unlimited_Files),
Defext => " "),
Metric =>
(Cname => new S'("METRIC"),
Usage => new S'("GNAT METRIC /qualifiers source_file"),
VMS_Only => False,
Unixcmd => new S'("gnatmetric"),
Unixsws => null,
Switches => Metric_Switches'Access,
Params => new Parameter_Array'(1 => Unlimited_Files),
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 => " "),
Pretty =>
(Cname => new S'("PRETTY"),
Usage => new S'("GNAT PRETTY /qualifiers source_file"),
VMS_Only => False,
Unixcmd => new S'("gnatpp"),
Unixsws => null,
Switches => Pretty_Switches'Access,
Params => new Parameter_Array'(1 => Unlimited_Files),
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 => " "),
Stack =>
(Cname => new S'("STACK"),
Usage => new S'("GNAT STACK /qualifiers ci_files"),
VMS_Only => False,
Unixcmd => new S'("gnatstack"),
Unixsws => null,
Switches => Stack_Switches'Access,
Params => new Parameter_Array'(1 => Unlimited_Files),
Defext => "ci" & ASCII.NUL),
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 => " "),
Test =>
(Cname => new S'("TEST"),
Usage => new S'("GNAT TEST file(s) /qualifiers"),
VMS_Only => False,
Unixcmd => new S'("gnattest"),
Unixsws => null,
Switches => Make_Switches'Access,
Params => new Parameter_Array'(1 => Unlimited_Files),
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")
);
end Initialize;
------------------
-- Invert_Sense --
------------------
function Invert_Sense (S : String) return VMS_Data.String_Ptr is
Sinv : String (1 .. S'Length * 2);
-- Result (for sure long enough)
Sinvp : Natural := 0;
-- Pointer to output string
begin
for Sp in S'Range loop
if Sp = S'First or else S (Sp - 1) = ',' then
if S (Sp) = '!' then
null;
else
Sinv (Sinvp + 1) := '!';
Sinv (Sinvp + 2) := S (Sp);
Sinvp := Sinvp + 2;
end if;
else
Sinv (Sinvp + 1) := S (Sp);
Sinvp := Sinvp + 1;
end if;
end loop;
return new String'(Sinv (1 .. Sinvp));
end Invert_Sense;
----------------------
-- Is_Extensionless --
----------------------
function Is_Extensionless (F : String) return Boolean is
begin
for J in reverse F'Range loop
if F (J) = '.' then
return False;
elsif F (J) = '/' or else F (J) = ']' or else F (J) = ':' then
return True;
end if;
end loop;
return True;
end Is_Extensionless;
-----------
-- Match --
-----------
function Match (S1, S2 : String) return Boolean is
Dif : constant Integer := S2'First - S1'First;
begin
if S1'Length /= S2'Length then
return False;
else
for J in S1'Range loop
if To_Lower (S1 (J)) /= To_Lower (S2 (J + Dif)) then
return False;
end if;
end loop;
return True;
end if;
end Match;
------------------
-- Match_Prefix --
------------------
function Match_Prefix (S1, S2 : String) return Boolean is
begin
if S1'Length > S2'Length then
return False;
else
return Match (S1, S2 (S2'First .. S2'First + S1'Length - 1));
end if;
end Match_Prefix;
-------------------
-- Matching_Name --
-------------------
function Matching_Name
(S : String;
Itm : Item_Ptr;
Quiet : Boolean := False) return Item_Ptr
is
P1, P2 : Item_Ptr;
procedure Err;
-- Little procedure to output command/qualifier/option as appropriate
-- and bump error count.
---------
-- Err --
---------
procedure Err is
begin
if Quiet then
return;
end if;
Errors := Errors + 1;
if Itm /= null then
case Itm.Id is
when Id_Command =>
Put (Standard_Error, "command");
when Id_Switch =>
if Hostparm.OpenVMS then
Put (Standard_Error, "qualifier");
else
Put (Standard_Error, "switch");
end if;
when Id_Option =>
Put (Standard_Error, "option");
end case;
else
Put (Standard_Error, "input");
end if;
Put (Standard_Error, ": ");
Put (Standard_Error, S);
end Err;
-- Start of processing for Matching_Name
begin
-- If exact match, that's the one we want
P1 := Itm;
while P1 /= null loop
if Match (S, P1.Name.all) then
return P1;
else
P1 := P1.Next;
end if;
end loop;
-- Now check for prefix matches
P1 := Itm;
while P1 /= null loop
if P1.Name.all = "/<other>" then
return P1;
elsif not Match_Prefix (S, P1.Name.all) then
P1 := P1.Next;
else
-- Here we have found one matching prefix, so see if there is
-- another one (which is an ambiguity)
P2 := P1.Next;
while P2 /= null loop
if Match_Prefix (S, P2.Name.all) then
if not Quiet then
Put (Standard_Error, "ambiguous ");
Err;
Put (Standard_Error, " (matches ");
Put (Standard_Error, P1.Name.all);
while P2 /= null loop
if Match_Prefix (S, P2.Name.all) then
Put (Standard_Error, ',');
Put (Standard_Error, P2.Name.all);
end if;
P2 := P2.Next;
end loop;
Put_Line (Standard_Error, ")");
end if;
return null;
end if;
P2 := P2.Next;
end loop;
-- If we fall through that loop, then there was only one match
return P1;
end if;
end loop;
-- If we fall through outer loop, there was no match
if not Quiet then
Put (Standard_Error, "unrecognized ");
Err;
New_Line (Standard_Error);
end if;
return null;
end Matching_Name;
-----------------------
-- OK_Alphanumerplus --
-----------------------
function OK_Alphanumerplus (S : String) return Boolean is
begin
if S'Length = 0 then
return False;
else
for J in S'Range loop
if not (Is_Alphanumeric (S (J)) or else
S (J) = '_' or else S (J) = '$')
then
return False;
end if;
end loop;
return True;
end if;
end OK_Alphanumerplus;
----------------
-- OK_Integer --
----------------
function OK_Integer (S : String) return Boolean is
begin
if S'Length = 0 then
return False;
else
for J in S'Range loop
if not Is_Digit (S (J)) then
return False;
end if;
end loop;
return True;
end if;
end OK_Integer;
--------------------
-- Output_Version --
--------------------
procedure Output_Version is
begin
if AAMP_On_Target then
Put ("GNAAMP ");
else
Put ("GNAT ");
end if;
Put_Line (Gnatvsn.Gnat_Version_String);
Put_Line ("Copyright 1996-" &
Current_Year &
", Free Software Foundation, Inc.");
end Output_Version;
-----------
-- Place --
-----------
procedure Place (C : Character) is
begin
if Cargs then
Cargs_Buffer.Append (C);
else
Buffer.Append (C);
end if;
end Place;
procedure Place (S : String) is
begin
for J in S'Range loop
Place (S (J));
end loop;
end Place;
-----------------
-- Place_Lower --
-----------------
procedure Place_Lower (S : String) is
begin
for J in S'Range loop
Place (To_Lower (S (J)));
end loop;
end Place_Lower;
-------------------------
-- Place_Unix_Switches --
-------------------------
procedure Place_Unix_Switches (S : VMS_Data.String_Ptr) is
P1, P2, P3 : Natural;
Remove : Boolean;
Slen, Sln2 : Natural;
Wild_Card : Boolean := False;
begin
P1 := S'First;
while P1 <= S'Last loop
if S (P1) = '!' then
P1 := P1 + 1;
Remove := True;
else
Remove := False;
end if;
P2 := P1;
pragma Assert (S (P1) = '-' or else S (P1) = '`');
while P2 < S'Last and then S (P2 + 1) /= ',' loop
P2 := P2 + 1;
end loop;
-- Switch is now in S (P1 .. P2)
Slen := P2 - P1 + 1;
if Remove then
Wild_Card := S (P2) = '*';
if Wild_Card then
Slen := Slen - 1;
P2 := P2 - 1;
end if;
P3 := 1;
while P3 <= Buffer.Last - Slen loop
if Buffer.Table (P3) = ' '
and then String (Buffer.Table (P3 + 1 .. P3 + Slen)) =
S (P1 .. P2)
and then (Wild_Card
or else
P3 + Slen = Buffer.Last
or else
Buffer.Table (P3 + Slen + 1) = ' ')
then
Sln2 := Slen;
if Wild_Card then
while P3 + Sln2 /= Buffer.Last
and then Buffer.Table (P3 + Sln2 + 1) /= ' '
loop
Sln2 := Sln2 + 1;
end loop;
end if;
Buffer.Table (P3 .. Buffer.Last - Sln2 - 1) :=
Buffer.Table (P3 + Sln2 + 1 .. Buffer.Last);
Buffer.Set_Last (Buffer.Last - Sln2 - 1);
else
P3 := P3 + 1;
end if;
end loop;
if Wild_Card then
P2 := P2 + 1;
end if;
else
pragma Assert (S (P2) /= '*');
Place (' ');
if S (P1) = '`' then
P1 := P1 + 1;
end if;
Place (S (P1 .. P2));
end if;
P1 := P2 + 2;
end loop;
end Place_Unix_Switches;
-----------------------------
-- Preprocess_Command_Data --
-----------------------------
procedure Preprocess_Command_Data is
begin
for C in Real_Command_Type loop
declare
Command : constant Item_Ptr := new Command_Item;
Last_Switch : Item_Ptr;
-- Last switch in list
begin
-- Link new command item into list of commands
if Last_Command = null then
Commands := Command;
else
Last_Command.Next := Command;
end if;
Last_Command := Command;
-- Fill in fields of new command item
Command.Name := Command_List (C).Cname;
Command.Usage := Command_List (C).Usage;
Command.Command := C;
if Command_List (C).Unixsws = null then
Command.Unix_String := Command_List (C).Unixcmd;
else
declare
Cmd : String (1 .. 5_000);
Last : Natural := 0;
Sws : constant Argument_List_Access :=
Command_List (C).Unixsws;
begin
Cmd (1 .. Command_List (C).Unixcmd'Length) :=
Command_List (C).Unixcmd.all;
Last := Command_List (C).Unixcmd'Length;
for J in Sws'Range loop
Last := Last + 1;
Cmd (Last) := ' ';
Cmd (Last + 1 .. Last + Sws (J)'Length) :=
Sws (J).all;
Last := Last + Sws (J)'Length;
end loop;
Command.Unix_String := new String'(Cmd (1 .. Last));
end;
end if;
Command.Params := Command_List (C).Params;
Command.Defext := Command_List (C).Defext;
Validate_Command_Or_Option (Command.Name);
-- Process the switch list
for S in Command_List (C).Switches'Range loop
declare
SS : constant VMS_Data.String_Ptr :=
Command_List (C).Switches (S);
P : Natural := SS'First;
Sw : Item_Ptr := new Switch_Item;
Last_Opt : Item_Ptr;
-- Pointer to last option
begin
-- Link new switch item into list of switches
if Last_Switch = null then
Command.Switches := Sw;
else
Last_Switch.Next := Sw;
end if;
Last_Switch := Sw;
-- Process switch string, first get name
while SS (P) /= ' ' and then SS (P) /= '=' loop
P := P + 1;
end loop;
Sw.Name := new String'(SS (SS'First .. P - 1));
-- Direct translation case
if SS (P) = ' ' then
Sw.Translation := T_Direct;
Sw.Unix_String := new String'(SS (P + 1 .. SS'Last));
Validate_Unix_Switch (Sw.Unix_String);
if SS (P - 1) = '>' then
Sw.Translation := T_Other;
elsif SS (P + 1) = '`' then
null;
-- Create the inverted case (/NO ..)
elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then
Sw := new Switch_Item;
Last_Switch.Next := Sw;
Last_Switch := Sw;
Sw.Name :=
new String'("/NO" & SS (SS'First + 1 .. P - 1));
Sw.Translation := T_Direct;
Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last));
Validate_Unix_Switch (Sw.Unix_String);
end if;
-- Directories translation case
elsif SS (P + 1) = '*' then
pragma Assert (SS (SS'Last) = '*');
Sw.Translation := T_Directories;
Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
Validate_Unix_Switch (Sw.Unix_String);
-- Directory translation case
elsif SS (P + 1) = '%' then
pragma Assert (SS (SS'Last) = '%');
Sw.Translation := T_Directory;
Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
Validate_Unix_Switch (Sw.Unix_String);
-- File translation case
elsif SS (P + 1) = '@' then
pragma Assert (SS (SS'Last) = '@');
Sw.Translation := T_File;
Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
Validate_Unix_Switch (Sw.Unix_String);
-- No space file translation case
elsif SS (P + 1) = '<' then
pragma Assert (SS (SS'Last) = '>');
Sw.Translation := T_No_Space_File;
Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
Validate_Unix_Switch (Sw.Unix_String);
-- Numeric translation case
elsif SS (P + 1) = '#' then
pragma Assert (SS (SS'Last) = '#');
Sw.Translation := T_Numeric;
Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
Validate_Unix_Switch (Sw.Unix_String);
-- Alphanumerplus translation case
elsif SS (P + 1) = '|' then
pragma Assert (SS (SS'Last) = '|');
Sw.Translation := T_Alphanumplus;
Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
Validate_Unix_Switch (Sw.Unix_String);
-- String translation case
elsif SS (P + 1) = '"' then
pragma Assert (SS (SS'Last) = '"');
Sw.Translation := T_String;
Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
Validate_Unix_Switch (Sw.Unix_String);
-- Commands translation case
elsif SS (P + 1) = '?' then
Sw.Translation := T_Commands;
Sw.Unix_String := new String'(SS (P + 2 .. SS'Last));
-- Options translation case
else
Sw.Translation := T_Options;
Sw.Unix_String := new String'("");
P := P + 1; -- bump past =
while P <= SS'Last loop
declare
Opt : constant Item_Ptr := new Option_Item;
Q : Natural;
begin
-- Link new option item into options list
if Last_Opt = null then
Sw.Options := Opt;
else
Last_Opt.Next := Opt;
end if;
Last_Opt := Opt;
-- Fill in fields of new option item
Q := P;
while SS (Q) /= ' ' loop
Q := Q + 1;
end loop;
Opt.Name := new String'(SS (P .. Q - 1));
Validate_Command_Or_Option (Opt.Name);
P := Q + 1;
Q := P;
while Q <= SS'Last and then SS (Q) /= ' ' loop
Q := Q + 1;
end loop;
Opt.Unix_String := new String'(SS (P .. Q - 1));
Validate_Unix_Switch (Opt.Unix_String);
P := Q + 1;
end;
end loop;
end if;
end;
end loop;
end;
end loop;
end Preprocess_Command_Data;
----------------------
-- Process_Argument --
----------------------
procedure Process_Argument (The_Command : in out Command_Type) is
Argv : String_Access;
Arg_Idx : Integer;
function Get_Arg_End
(Argv : String;
Arg_Idx : Integer) return Integer;
-- Begins looking at Arg_Idx + 1 and returns the index of the
-- last character before a slash or else the index of the last
-- character in the string Argv.
-----------------
-- Get_Arg_End --
-----------------
function Get_Arg_End
(Argv : String;
Arg_Idx : Integer) return Integer
is
begin
for J in Arg_Idx + 1 .. Argv'Last loop
if Argv (J) = '/' then
return J - 1;
end if;
end loop;
return Argv'Last;
end Get_Arg_End;
-- Start of processing for Process_Argument
begin
Cargs := False;
-- If an argument file is open, read the next non empty line
if Is_Open (Arg_File) then
declare
Line : String (1 .. 256);
Last : Natural;
begin
loop
Get_Line (Arg_File, Line, Last);
exit when Last /= 0 or else End_Of_File (Arg_File);
end loop;
-- If the end of the argument file has been reached, close it
if End_Of_File (Arg_File) then
Close (Arg_File);
-- If the last line was empty, return after increasing Arg_Num
-- to go to the next argument on the comment line.
if Last = 0 then
Arg_Num := Arg_Num + 1;
return;
end if;
end if;
Argv := new String'(Line (1 .. Last));
Arg_Idx := 1;
if Argv (1) = '@' then
Put_Line (Standard_Error, "argument file cannot contain @cmd");
raise Error_Exit;
end if;
end;
else
-- No argument file is open, get the argument on the command line
Argv := new String'(Argument (Arg_Num));
Arg_Idx := Argv'First;
-- Check if this is the specification of an argument file
if Argv (Arg_Idx) = '@' then
-- The first argument on the command line cannot be an argument
-- file.
if Arg_Num = 1 then
Put_Line
(Standard_Error,
"Cannot specify argument line before command");
raise Error_Exit;
end if;
-- Open the file, after conversion of the name to canonical form.
-- Fail if file is not found.
declare
Canonical_File_Name : String_Access :=
To_Canonical_File_Spec (Argv (Arg_Idx + 1 .. Argv'Last));
begin
Open (Arg_File, In_File, Canonical_File_Name.all);
Free (Canonical_File_Name);
return;
exception
when others =>
Put (Standard_Error, "Cannot open argument file """);
Put (Standard_Error, Argv (Arg_Idx + 1 .. Argv'Last));
Put_Line (Standard_Error, """");
raise Error_Exit;
end;
end if;
end if;
<<Tryagain_After_Coalesce>>
loop
declare
Next_Arg_Idx : Integer;
Arg : String_Access;
begin
Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx);
Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx));
-- The first one must be a command name
if Arg_Num = 1 and then Arg_Idx = Argv'First then
Command := Matching_Name (Arg.all, Commands);
if Command = null then
raise Error_Exit;
end if;
The_Command := Command.Command;
Output_File_Expected := False;
-- Give usage information if only command given
if Argument_Count = 1
and then Next_Arg_Idx = Argv'Last
then
Output_Version;
New_Line;
Put_Line
("List of available qualifiers and options");
New_Line;
Put (Command.Usage.all);
Set_Col (53);
Put_Line (Command.Unix_String.all);
declare
Sw : Item_Ptr := Command.Switches;
begin
while Sw /= null loop
Put (" ");
Put (Sw.Name.all);
case Sw.Translation is
when T_Other =>
Set_Col (53);
Put_Line (Sw.Unix_String.all &
"/<other>");
when T_Direct =>
Set_Col (53);
Put_Line (Sw.Unix_String.all);
when T_Directories =>
Put ("=(direc,direc,..direc)");
Set_Col (53);
Put (Sw.Unix_String.all);
Put (" direc ");
Put (Sw.Unix_String.all);
Put_Line (" direc ...");
when T_Directory =>
Put ("=directory");
Set_Col (53);
Put (Sw.Unix_String.all);
if Sw.Unix_String (Sw.Unix_String'Last)
/= '='
then
Put (' ');
end if;
Put_Line ("directory ");
when T_File | T_No_Space_File =>
Put ("=file");
Set_Col (53);
Put (Sw.Unix_String.all);
if Sw.Translation = T_File
and then Sw.Unix_String
(Sw.Unix_String'Last) /= '='
then
Put (' ');
end if;
Put_Line ("file ");
when T_Numeric =>
Put ("=nnn");
Set_Col (53);
if Sw.Unix_String
(Sw.Unix_String'First) = '`'
then
Put (Sw.Unix_String
(Sw.Unix_String'First + 1
.. Sw.Unix_String'Last));
else
Put (Sw.Unix_String.all);
end if;
Put_Line ("nnn");
when T_Alphanumplus =>
Put ("=xyz");
Set_Col (53);
if Sw.Unix_String
(Sw.Unix_String'First) = '`'
then
Put (Sw.Unix_String
(Sw.Unix_String'First + 1
.. Sw.Unix_String'Last));
else
Put (Sw.Unix_String.all);
end if;
Put_Line ("xyz");
when T_String =>
Put ("=");
Put ('"');
Put ("<string>");
Put ('"');
Set_Col (53);
Put (Sw.Unix_String.all);
if Sw.Unix_String
(Sw.Unix_String'Last) /= '='
then
Put (' ');
end if;
Put ("<string>");
New_Line;
when T_Commands =>
Put (" (switches for ");
Put (Sw.Unix_String
(Sw.Unix_String'First + 7
.. Sw.Unix_String'Last));
Put (')');
Set_Col (53);
Put (Sw.Unix_String
(Sw.Unix_String'First
.. Sw.Unix_String'First + 5));
Put_Line (" switches");
when T_Options =>
declare
Opt : Item_Ptr := Sw.Options;
begin
Put_Line ("=(option,option..)");
while Opt /= null loop
Put (" ");
Put (Opt.Name.all);
if Opt = Sw.Options then
Put (" (D)");
end if;
Set_Col (53);
Put_Line (Opt.Unix_String.all);
Opt := Opt.Next;
end loop;
end;
end case;
Sw := Sw.Next;
end loop;
end;
raise Normal_Exit;
end if;
-- Special handling for internal debugging switch /?
elsif Arg.all = "/?" then
Display_Command := True;
Output_File_Expected := False;
-- Special handling of internal option /KEEP_TEMPORARY_FILES
elsif Arg'Length >= 7
and then Matching_Name
(Arg.all, Keep_Temps_Option, True) /= null
then
Opt.Keep_Temporary_Files := True;
-- Copy -switch unchanged, as well as +rule
elsif Arg (Arg'First) = '-' or else Arg (Arg'First) = '+' then
Place (' ');
Place (Arg.all);
-- Set Output_File_Expected for the next argument
Output_File_Expected :=
Arg.all = "-o" and then The_Command = Link;
-- Copy quoted switch with quotes stripped
elsif Arg (Arg'First) = '"' then
if Arg (Arg'Last) /= '"' then
Put (Standard_Error, "misquoted argument: ");
Put_Line (Standard_Error, Arg.all);
Errors := Errors + 1;
else
Place (' ');
Place (Arg (Arg'First + 1 .. Arg'Last - 1));
end if;
Output_File_Expected := False;
-- Parameter Argument
elsif Arg (Arg'First) /= '/'
and then Make_Commands_Active = null
then
Param_Count := Param_Count + 1;
if Param_Count <= Command.Params'Length then
case Command.Params (Param_Count) is
when File | Optional_File =>
declare
Normal_File : constant String_Access :=
To_Canonical_File_Spec
(Arg.all);
begin
Place (' ');
Place_Lower (Normal_File.all);
if Is_Extensionless (Normal_File.all)
and then Command.Defext /= " "
then
Place ('.');
Place (Command.Defext);
end if;
end;
when Unlimited_Files =>
declare
Normal_File : constant String_Access :=
To_Canonical_File_Spec
(Arg.all);
File_Is_Wild : Boolean := False;
File_List : String_Access_List_Access;
begin
for J in Arg'Range loop
if Arg (J) = '*'
or else Arg (J) = '%'
then
File_Is_Wild := True;
end if;
end loop;
if File_Is_Wild then
File_List := To_Canonical_File_List
(Arg.all, False);
for J in File_List.all'Range loop
Place (' ');
Place_Lower (File_List.all (J).all);
end loop;
else
Place (' ');
Place_Lower (Normal_File.all);
-- Add extension if not present, except after
-- switch -o.
if Is_Extensionless (Normal_File.all)
and then Command.Defext /= " "
and then not Output_File_Expected
then
Place ('.');
Place (Command.Defext);
end if;
end if;
Param_Count := Param_Count - 1;
end;
when Other_As_Is =>
Place (' ');
Place (Arg.all);
when Unlimited_As_Is =>
Place (' ');
Place (Arg.all);
Param_Count := Param_Count - 1;
when Files_Or_Wildcard =>
-- Remove spaces from a comma separated list
-- of file names and adjust control variables
-- accordingly.
while Arg_Num < Argument_Count and then
(Argv (Argv'Last) = ',' xor
Argument (Arg_Num + 1)
(Argument (Arg_Num + 1)'First) = ',')
loop
Argv := new String'
(Argv.all & Argument (Arg_Num + 1));
Arg_Num := Arg_Num + 1;
Arg_Idx := Argv'First;
Next_Arg_Idx :=
Get_Arg_End (Argv.all, Arg_Idx);
Arg := new String'
(Argv (Arg_Idx .. Next_Arg_Idx));
end loop;
-- Parse the comma separated list of VMS
-- filenames and place them on the command
-- line as space separated Unix style
-- filenames. Lower case and add default
-- extension as appropriate.
declare
Arg1_Idx : Integer := Arg'First;
function Get_Arg1_End
(Arg : String;
Arg_Idx : Integer) return Integer;
-- Begins looking at Arg_Idx + 1 and
-- returns the index of the last character
-- before a comma or else the index of the
-- last character in the string Arg.
------------------
-- Get_Arg1_End --
------------------
function Get_Arg1_End
(Arg : String;
Arg_Idx : Integer) return Integer
is
begin
for J in Arg_Idx + 1 .. Arg'Last loop
if Arg (J) = ',' then
return J - 1;
end if;
end loop;
return Arg'Last;
end Get_Arg1_End;
begin
loop
declare
Next_Arg1_Idx :
constant Integer :=
Get_Arg1_End (Arg.all, Arg1_Idx);
Arg1 :
constant String :=
Arg (Arg1_Idx .. Next_Arg1_Idx);
Normal_File :
constant 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;
-- Reset Output_File_Expected, in case it was True
Output_File_Expected := False;
-- Qualifier argument
else
Output_File_Expected := False;
Cargs := Command.Name.all = "COMPILE";
-- This code is too heavily nested, should be
-- separated out as separate subprogram ???
declare
Sw : Item_Ptr;
SwP : Natural;
P2 : Natural;
Endp : Natural := 0; -- avoid warning
Opt : Item_Ptr;
begin
SwP := Arg'First;
while SwP < Arg'Last
and then Arg (SwP + 1) /= '='
loop
SwP := SwP + 1;
end loop;
-- At this point, the switch name is in
-- Arg (Arg'First..SwP) and if that is not the
-- whole switch, then there is an equal sign at
-- Arg (SwP + 1) and the rest of Arg is what comes
-- after the equal sign.
-- If make commands are active, see if we have
-- another COMMANDS_TRANSLATION switch belonging
-- to gnatmake.
if Make_Commands_Active /= null then
Sw :=
Matching_Name
(Arg (Arg'First .. SwP),
Command.Switches,
Quiet => True);
if Sw /= null
and then Sw.Translation = T_Commands
then
null;
else
Sw :=
Matching_Name
(Arg (Arg'First .. SwP),
Make_Commands_Active.Switches,
Quiet => False);
end if;
-- For case of GNAT MAKE or CHOP, if we cannot
-- find the switch, then see if it is a
-- recognized compiler switch instead, and if
-- so process the compiler switch.
elsif Command.Name.all = "MAKE"
or else
Command.Name.all = "CHOP"
then
Sw :=
Matching_Name
(Arg (Arg'First .. SwP),
Command.Switches,
Quiet => True);
if Sw = null then
Sw :=
Matching_Name
(Arg (Arg'First .. SwP),
Matching_Name
("COMPILE", Commands).Switches,
Quiet => False);
end if;
-- For all other cases, just search the relevant
-- command.
else
Sw :=
Matching_Name
(Arg (Arg'First .. SwP),
Command.Switches,
Quiet => False);
-- Special case for GNAT COMPILE /UNCHECKED...
-- because the corresponding switch --unchecked... is
-- for gnatmake, not for the compiler.
if Cargs
and then Sw.Name.all = "/UNCHECKED_SHARED_LIB_IMPORTS"
then
Cargs := False;
end if;
end if;
if Sw /= null then
if Cargs
and then Sw.Name /= null
and then
(Sw.Name.all = "/PROJECT_FILE" or else
Sw.Name.all = "/MESSAGES_PROJECT_FILE" or else
Sw.Name.all = "/EXTERNAL_REFERENCE")
then
Cargs := False;
end if;
case Sw.Translation is
when T_Direct =>
Place_Unix_Switches (Sw.Unix_String);
if SwP < Arg'Last
and then Arg (SwP + 1) = '='
then
Put (Standard_Error,
"qualifier options ignored: ");
Put_Line (Standard_Error, Arg.all);
end if;
when T_Directories =>
if SwP + 1 > Arg'Last then
Put (Standard_Error,
"missing directories for: ");
Put_Line (Standard_Error, Arg.all);
Errors := Errors + 1;
elsif Arg (SwP + 2) /= '(' then
SwP := SwP + 2;
Endp := Arg'Last;
elsif Arg (Arg'Last) /= ')' then
-- Remove spaces from a comma separated
-- list of file names and adjust
-- control variables accordingly.
if Arg_Num < Argument_Count and then
(Argv (Argv'Last) = ',' xor
Argument (Arg_Num + 1)
(Argument (Arg_Num + 1)'First) = ',')
then
Argv :=
new String'(Argv.all
& Argument
(Arg_Num + 1));
Arg_Num := Arg_Num + 1;
Arg_Idx := Argv'First;
Next_Arg_Idx :=
Get_Arg_End (Argv.all, Arg_Idx);
Arg :=
new String'(Argv (Arg_Idx .. Next_Arg_Idx));
goto Tryagain_After_Coalesce;
end if;
Put (Standard_Error,
"incorrectly parenthesized " &
"or malformed argument: ");
Put_Line (Standard_Error, Arg.all);
Errors := Errors + 1;
else
SwP := SwP + 3;
Endp := Arg'Last - 1;
end if;
while SwP <= Endp loop
declare
Dir_Is_Wild : Boolean := False;
Dir_Maybe_Is_Wild : Boolean := False;
Dir_List : String_Access_List_Access;
begin
P2 := SwP;
while P2 < Endp
and then Arg (P2 + 1) /= ','
loop
-- A wildcard directory spec on VMS will
-- contain either * or % or ...
if Arg (P2) = '*' then
Dir_Is_Wild := True;
elsif Arg (P2) = '%' then
Dir_Is_Wild := True;
elsif Dir_Maybe_Is_Wild
and then Arg (P2) = '.'
and then Arg (P2 + 1) = '.'
then
Dir_Is_Wild := True;
Dir_Maybe_Is_Wild := False;
elsif Dir_Maybe_Is_Wild then
Dir_Maybe_Is_Wild := False;
elsif Arg (P2) = '.'
and then Arg (P2 + 1) = '.'
then
Dir_Maybe_Is_Wild := True;
end if;
P2 := P2 + 1;
end loop;
if Dir_Is_Wild then
Dir_List :=
To_Canonical_File_List
(Arg (SwP .. P2), True);
for J in Dir_List.all'Range loop
Place_Unix_Switches (Sw.Unix_String);
Place_Lower (Dir_List.all (J).all);
end loop;
else
Place_Unix_Switches (Sw.Unix_String);
Place_Lower
(To_Canonical_Dir_Spec
(Arg (SwP .. P2), False).all);
end if;
SwP := P2 + 2;
end;
end loop;
when T_Directory =>
if SwP + 1 > Arg'Last then
Put (Standard_Error,
"missing directory for: ");
Put_Line (Standard_Error, Arg.all);
Errors := Errors + 1;
else
Place_Unix_Switches (Sw.Unix_String);
-- Some switches end in "=", no space here
if Sw.Unix_String
(Sw.Unix_String'Last) /= '='
then
Place (' ');
end if;
Place_Lower
(To_Canonical_Dir_Spec
(Arg (SwP + 2 .. Arg'Last), False).all);
end if;
when T_File | T_No_Space_File =>
if SwP + 2 > Arg'Last then
Put (Standard_Error, "missing file for: ");
Put_Line (Standard_Error, Arg.all);
Errors := Errors + 1;
else
Place_Unix_Switches (Sw.Unix_String);
-- Some switches end in "=", no space here.
if Sw.Translation = T_File
and then Sw.Unix_String
(Sw.Unix_String'Last) /= '='
then
Place (' ');
end if;
Place_Lower
(To_Canonical_File_Spec
(Arg (SwP + 2 .. Arg'Last)).all);
end if;
when T_Numeric =>
if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then
Place_Unix_Switches (Sw.Unix_String);
Place (Arg (SwP + 2 .. Arg'Last));
else
Put (Standard_Error, "argument for ");
Put (Standard_Error, Sw.Name.all);
Put_Line (Standard_Error, " must be numeric");
Errors := Errors + 1;
end if;
when T_Alphanumplus =>
if OK_Alphanumerplus
(Arg (SwP + 2 .. Arg'Last))
then
Place_Unix_Switches (Sw.Unix_String);
Place (Arg (SwP + 2 .. Arg'Last));
else
Put (Standard_Error, "argument for ");
Put (Standard_Error, Sw.Name.all);
Put_Line (Standard_Error,
" must be alphanumeric");
Errors := Errors + 1;
end if;
when T_String =>
-- A String value must be extended to the end of
-- the Argv, otherwise strings like "foo/bar" get
-- split at the slash.
-- The beginning and ending of the string are
-- flagged with embedded nulls which are removed
-- when building the Spawn call. Nulls are use
-- because they won't show up in a /? output.
-- Quotes aren't used because that would make it
-- difficult to embed them.
Place_Unix_Switches (Sw.Unix_String);
if Next_Arg_Idx /= Argv'Last then
Next_Arg_Idx := Argv'Last;
Arg :=
new String'(Argv (Arg_Idx .. Next_Arg_Idx));
SwP := Arg'First;
while SwP < Arg'Last
and then Arg (SwP + 1) /= '='
loop
SwP := SwP + 1;
end loop;
end if;
Place (ASCII.NUL);
Place (Arg (SwP + 2 .. Arg'Last));
Place (ASCII.NUL);
when T_Commands =>
-- Output -largs/-bargs/-cargs
Place (' ');
Place (Sw.Unix_String
(Sw.Unix_String'First ..
Sw.Unix_String'First + 5));
if Sw.Unix_String
(Sw.Unix_String'First + 7 ..
Sw.Unix_String'Last) = "MAKE"
then
Make_Commands_Active := null;
else
-- 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);
end if;
when T_Options =>
if SwP + 1 > Arg'Last then
Place_Unix_Switches (Sw.Options.Unix_String);
SwP := Endp + 1;
elsif Arg (SwP + 2) /= '(' then
SwP := SwP + 2;
Endp := Arg'Last;
elsif Arg (Arg'Last) /= ')' then
Put (Standard_Error,
"incorrectly parenthesized argument: ");
Put_Line (Standard_Error, Arg.all);
Errors := Errors + 1;
SwP := Endp + 1;
else
SwP := SwP + 3;
Endp := Arg'Last - 1;
end if;
while SwP <= Endp loop
P2 := SwP;
while P2 < Endp
and then Arg (P2 + 1) /= ','
loop
P2 := P2 + 1;
end loop;
-- Option name is in Arg (SwP .. P2)
Opt := Matching_Name (Arg (SwP .. P2),
Sw.Options);
if Opt /= null then
Place_Unix_Switches (Opt.Unix_String);
end if;
SwP := P2 + 2;
end loop;
when T_Other =>
Place_Unix_Switches
(new String'(Sw.Unix_String.all & Arg.all));
end case;
end if;
end;
end if;
Arg_Idx := Next_Arg_Idx + 1;
end;
exit when Arg_Idx > Argv'Last;
end loop;
if not Is_Open (Arg_File) then
Arg_Num := Arg_Num + 1;
end if;
end Process_Argument;
--------------------
-- Process_Buffer --
--------------------
procedure Process_Buffer (S : String) is
P1, P2 : Natural;
Inside_Nul : Boolean := False;
Arg : String (1 .. 1024);
Arg_Ctr : Natural;
begin
P1 := 1;
while P1 <= S'Last and then S (P1) = ' ' loop
P1 := P1 + 1;
end loop;
Arg_Ctr := 1;
Arg (Arg_Ctr) := S (P1);
while P1 <= S'Last loop
if S (P1) = ASCII.NUL then
if Inside_Nul then
Inside_Nul := False;
else
Inside_Nul := True;
end if;
end if;
if S (P1) = ' ' and then not Inside_Nul then
P1 := P1 + 1;
Arg_Ctr := Arg_Ctr + 1;
Arg (Arg_Ctr) := S (P1);
else
Last_Switches.Increment_Last;
P2 := P1;
while P2 < S'Last
and then (S (P2 + 1) /= ' ' or else
Inside_Nul)
loop
P2 := P2 + 1;
Arg_Ctr := Arg_Ctr + 1;
Arg (Arg_Ctr) := S (P2);
if S (P2) = ASCII.NUL then
Arg_Ctr := Arg_Ctr - 1;
if Inside_Nul then
Inside_Nul := False;
else
Inside_Nul := True;
end if;
end if;
end loop;
Last_Switches.Table (Last_Switches.Last) :=
new String'(String (Arg (1 .. Arg_Ctr)));
P1 := P2 + 2;
exit when P1 > S'Last;
Arg_Ctr := 1;
Arg (Arg_Ctr) := S (P1);
end if;
end loop;
end Process_Buffer;
--------------------------------
-- Validate_Command_Or_Option --
--------------------------------
procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is
begin
pragma Assert (N'Length > 0);
for J in N'Range loop
if N (J) = '_' then
pragma Assert (N (J - 1) /= '_');
null;
else
pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J)));
null;
end if;
end loop;
end Validate_Command_Or_Option;
--------------------------
-- Validate_Unix_Switch --
--------------------------
procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is
begin
if S (S'First) = '`' then
return;
end if;
pragma Assert (S (S'First) = '-' or else S (S'First) = '!');
for J in S'First + 1 .. S'Last loop
pragma Assert (S (J) /= ' ');
if S (J) = '!' then
pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-');
null;
end if;
end loop;
end Validate_Unix_Switch;
--------------------
-- VMS_Conversion --
--------------------
procedure VMS_Conversion (The_Command : out Command_Type) is
Result : Command_Type := Undefined;
Result_Set : Boolean := False;
begin
Buffer.Init;
-- First we must preprocess the string form of the command and options
-- list into the internal form that we use.
Preprocess_Command_Data;
-- If no parameters, give complete list of commands
if Argument_Count = 0 then
Output_Version;
New_Line;
Put_Line ("List of available commands");
New_Line;
while Commands /= null loop
-- No usage for GNAT SYNC
if Commands.Command /= Sync then
Put (Commands.Usage.all);
Set_Col (53);
Put_Line (Commands.Unix_String.all);
end if;
Commands := Commands.Next;
end loop;
raise Normal_Exit;
end if;
-- Loop through arguments
Arg_Num := 1;
while Arg_Num <= Argument_Count loop
Process_Argument (Result);
if not Result_Set then
The_Command := Result;
Result_Set := True;
end if;
end loop;
-- Gross error checking that the number of parameters is correct.
-- Not applicable to Unlimited_Files parameters.
if (Param_Count = Command.Params'Length - 1
and then Command.Params (Param_Count + 1) = Unlimited_Files)
or else Param_Count <= Command.Params'Length
then
null;
else
Put_Line (Standard_Error,
"Parameter count of "
& Integer'Image (Param_Count)
& " not equal to expected "
& Integer'Image (Command.Params'Length));
Put (Standard_Error, "usage: ");
Put_Line (Standard_Error, Command.Usage.all);
Errors := Errors + 1;
end if;
if Errors > 0 then
raise Error_Exit;
else
-- Prepare arguments for a call to spawn, filtering out
-- embedded nulls place there to delineate strings.
Process_Buffer (String (Buffer.Table (1 .. Buffer.Last)));
if Cargs_Buffer.Last > 1 then
Last_Switches.Append (new String'("-cargs"));
Process_Buffer
(String (Cargs_Buffer.Table (1 .. Cargs_Buffer.Last)));
end if;
end if;
end VMS_Conversion;
end VMS_Conv;
gcc/ada/vms_conv.ads deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- V M S _ C O N V --
-- --
-- S p e c --
-- --
-- Copyright (C) 2003-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package is part of the GNAT driver. It contains the procedure
-- VMS_Conversion to convert a VMS command line to the equivalent command
-- line with switches for the GNAT tools that the GNAT driver will invoke.
-- The qualifier declarations are contained in package VMS_Data.
with Table;
with VMS_Data; use VMS_Data;
with VMS_Cmds; use VMS_Cmds;
with GNAT.OS_Lib; use GNAT.OS_Lib;
package VMS_Conv is
-- 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");
Normal_Exit : exception;
-- Raise this exception for normal program termination
Error_Exit : exception;
-- Raise this exception if error detected
Errors : Natural := 0;
-- Count errors detected
Display_Command : Boolean := False;
-- Set true if /? switch causes display of generated command (on VMS)
-------------------
-- Command Table --
-------------------
-- The command table contains an entry for each command recognized by
-- GNATCmd. The entries are represented by an array of records.
type Parameter_Type is
-- A parameter is defined as a whitespace bounded string, not beginning
-- with a slash. (But see note under FILES_OR_WILDCARD).
(File,
-- A required file or directory parameter
Optional_File,
-- An optional file or directory parameter
Other_As_Is,
-- A parameter that's passed through as is (not canonicalized)
Unlimited_Files,
-- An unlimited number of whitespace separate file or directory
-- parameters including wildcard specifications.
Unlimited_As_Is,
-- An unlimited number of whitespace separated parameters that are
-- passed through as is (not canonicalized).
Files_Or_Wildcard);
-- A comma separated list of files and/or wildcard file specifications.
-- A comma preceded by or followed by whitespace is considered as a
-- single comma character w/o whitespace.
type Parameter_Array is array (Natural range <>) of Parameter_Type;
type Parameter_Ref is access all Parameter_Array;
type Alternate_Command is (Comp, Ls, Kr, Pp, Prep);
-- Alternate command label for non VMS system use
Corresponding_To : constant array (Alternate_Command) of Command_Type :=
(Comp => Compile,
Ls => List,
Kr => Krunch,
Prep => Preprocess,
Pp => Pretty);
-- Mapping of alternate commands to commands
type Command_Entry is record
Cname : String_Ptr;
-- Command name for GNAT xxx command
Usage : String_Ptr;
-- A usage string, used for error messages
Unixcmd : String_Ptr;
-- Corresponding Unix command
Unixsws : Argument_List_Access;
-- Switches for the Unix command
VMS_Only : Boolean;
-- When True, the command can only be used on VMS
Switches : Switches_Ptr;
-- Pointer to array of switch strings
Params : Parameter_Ref;
-- Describes the allowable types of parameters.
-- Params (1) is the type of the first parameter, etc.
-- An empty parameter array means this command takes no parameters.
Defext : String (1 .. 3);
-- Default extension. If non-blank, then this extension is supplied by
-- default as the extension for any file parameter which does not have
-- an extension already.
end record;
-------------------
-- Switch Tables --
-------------------
-- The switch tables contain an entry for each switch recognized by the
-- command processor. It is initialized by procedure Initialize.
Command_List : array (Real_Command_Type) of Command_Entry;
----------------
-- Procedures --
----------------
procedure Initialize;
-- Initialized the switch table Command_List
procedure Output_Version;
-- Output the version of this program
procedure VMS_Conversion (The_Command : out Command_Type);
-- Converts VMS command line to equivalent Unix command line
end VMS_Conv;
gcc/ada/vms_data.ads deleted 100644 → 0
This source diff could not be displayed because it is too large. You can view the blob instead.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment