Subversion Repositories openrisc_2011-10-31

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                            V M S _ C O N V                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1996-2009, 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 :=

                    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   => "   "),

         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 --