Subversion Repositories scarts

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              S Y M B O L S                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 2003-2005 Free Software Foundation, Inc.          --

--                                                                          --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 2,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --

-- for  more details.  You should have  received  a copy of the GNU General --

-- Public License  distributed with GNAT;  see file COPYING.  If not, write --

-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --

-- Boston, MA 02110-1301, USA.                                              --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

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

--  This is the VMS version of this package

with Ada.Exceptions;    use Ada.Exceptions;

with Ada.Sequential_IO;

with Ada.Text_IO;       use Ada.Text_IO;

package body Symbols is

   Case_Sensitive  : constant String := "case_sensitive=";

   Symbol_Vector   : constant String := "SYMBOL_VECTOR=(";

   Equal_Data      : constant String := "=DATA)";

   Equal_Procedure : constant String := "=PROCEDURE)";

   Gsmatch         : constant String := "gsmatch=";

   Gsmatch_Lequal  : constant String := "gsmatch=lequal,";

   Symbol_File_Name : String_Access := null;

   --  Name of the symbol file

   Sym_Policy : Policy := Autonomous;

   --  The symbol policy. Set by Initialize

   Major_ID : Integer := 1;

   --  The Major ID. May be modified by Initialize if Library_Version is

   --  specified or if it is read from the reference symbol file.

   Soft_Major_ID : Boolean := True;

   --  False if library version is specified in procedure Initialize.

   --  When True, Major_ID may be modified if found in the reference symbol

   --  file.

   Minor_ID : Natural := 0;

   --  The Minor ID. May be modified if read from the reference symbol file

   Soft_Minor_ID : Boolean := True;

   --  False if symbol policy is Autonomous, if library version is specified

   --  in procedure Initialize and is not the same as the major ID read from

   --  the reference symbol file. When True, Minor_ID may be increased in

   --  Compliant symbol policy.

   subtype Byte is Character;

   --  Object files are stream of bytes, but some of these bytes, those for

   --  the names of the symbols, are ASCII characters.

   package Byte_IO is new Ada.Sequential_IO (Byte);

   use Byte_IO;

   File : Byte_IO.File_Type;

   --  Each object file is read as a stream of bytes (characters)

   function Equal (Left, Right : Symbol_Data) return Boolean;

   --  Test for equality of symbols

   function Image (N : Integer) return String;

   --  Returns the image of N, without the initial space

   -----------

   -- Equal --

   -----------

   function Equal (Left, Right : Symbol_Data) return Boolean is

   begin

      return Left.Name /= null and then

             Right.Name /= null and then

             Left.Name.all = Right.Name.all and then

             Left.Kind = Right.Kind and then

             Left.Present = Right.Present;

   end Equal;

   -----------

   -- Image --

   -----------

   function Image (N : Integer) return String is

      Result : constant String := N'Img;

   begin

      if Result (Result'First) = ' ' then

         return Result (Result'First + 1 .. Result'Last);

      else

         return Result;

      end if;

   end Image;

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

   -- Initialize --

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

   procedure Initialize

     (Symbol_File   : String;

      Reference     : String;

      Symbol_Policy : Policy;

      Quiet         : Boolean;

      Version       : String;

      Success       : out Boolean)

   is

      File : Ada.Text_IO.File_Type;

      Line : String (1 .. 1_000);

      Last : Natural;

   begin

      --  Record the symbol file name

      Symbol_File_Name := new String'(Symbol_File);

      --  Record the policy

      Sym_Policy := Symbol_Policy;

      --  Record the version (Major ID)

      if Version = "" then

         Major_ID := 1;

         Soft_Major_ID := True;

      else

         begin

            Major_ID := Integer'Value (Version);

            Soft_Major_ID := False;

            if Major_ID <= 0 then

               raise Constraint_Error;

            end if;

         exception

            when Constraint_Error =>

               if not Quiet then

                  Put_Line ("Version """ & Version & """ is illegal.");

                  Put_Line ("On VMS, version must be a positive number");

               end if;

               Success := False;

               return;

         end;

      end if;

      Minor_ID := 0;

      Soft_Minor_ID := Sym_Policy /= Autonomous;

      --  Empty the symbol tables

      Symbol_Table.Set_Last (Original_Symbols, 0);

      Symbol_Table.Set_Last (Complete_Symbols, 0);

      --  Assume that everything will be fine

      Success := True;

      --  If policy is Compliant or Controlled, attempt to read the reference

      --  file. If policy is Restricted, attempt to read the symbol file.

      if Sym_Policy /= Autonomous then

         case Sym_Policy is

            when Autonomous =>

               null;

            when Compliant | Controlled =>

               begin

                  Open (File, In_File, Reference);

               exception

                  when Ada.Text_IO.Name_Error =>

                     Success := False;

                     return;

                  when X : others =>

                     if not Quiet then

                        Put_Line ("could not open """ & Reference & """");

                        Put_Line (Exception_Message (X));

                     end if;

                     Success := False;

                     return;

               end;

            when Restricted =>

               begin

                  Open (File, In_File, Symbol_File);

               exception

                  when Ada.Text_IO.Name_Error =>

                     Success := False;

                     return;

                  when X : others =>

                     if not Quiet then

                        Put_Line ("could not open """ & Symbol_File & """");

                        Put_Line (Exception_Message (X));

                     end if;

                     Success := False;

                     return;

               end;

         end case;

         --  Read line by line

         while not End_Of_File (File) loop

            Get_Line (File, Line, Last);

            --  Ignore empty lines

            if Last = 0 then

               null;

            --  Ignore lines starting with "case_sensitive="

            elsif Last > Case_Sensitive'Length

              and then Line (1 .. Case_Sensitive'Length) = Case_Sensitive

            then

               null;

            --  Line starting with "SYMBOL_VECTOR=("

            elsif Last > Symbol_Vector'Length

              and then Line (1 .. Symbol_Vector'Length) = Symbol_Vector

            then

               --  SYMBOL_VECTOR=(<symbol>=DATA)

               if Last > Symbol_Vector'Length + Equal_Data'Length and then

                 Line (Last - Equal_Data'Length + 1 .. Last) = Equal_Data

               then

                  Symbol_Table.Increment_Last (Original_Symbols);

                  Original_Symbols.Table

                    (Symbol_Table.Last (Original_Symbols)) :=

                      (Name =>

                         new String'(Line (Symbol_Vector'Length + 1 ..

                                           Last - Equal_Data'Length)),

                       Kind => Data,

                       Present => True);

               --  SYMBOL_VECTOR=(<symbol>=PROCEDURE)

               elsif Last > Symbol_Vector'Length + Equal_Procedure'Length

                 and then

                  Line (Last - Equal_Procedure'Length + 1 .. Last) =

                                                              Equal_Procedure

               then

                  Symbol_Table.Increment_Last (Original_Symbols);

                  Original_Symbols.Table

                    (Symbol_Table.Last (Original_Symbols)) :=

                    (Name =>

                       new String'(Line (Symbol_Vector'Length + 1 ..

                                         Last - Equal_Procedure'Length)),

                     Kind => Proc,

                     Present => True);

               --  Anything else is incorrectly formatted

               else

                  if not Quiet then

                     Put_Line ("symbol file """ & Reference &

                               """ is incorrectly formatted:");

                     Put_Line ("""" & Line (1 .. Last) & """");

                  end if;

                  Close (File);

                  Success := False;

                  return;

               end if;

            --  Lines with "gsmatch=lequal," or "gsmatch=equal,"

            elsif Last > Gsmatch'Length

              and then Line (1 .. Gsmatch'Length) = Gsmatch

            then

               declare

                  Start  : Positive := Gsmatch'Length + 1;

                  Finish : Positive := Start;

                  OK     : Boolean  := True;

                  ID     : Integer;

               begin

                  --  First, look for the first coma

                  loop

                     if Start >= Last - 1 then

                        OK := False;

                        exit;

                     elsif Line (Start) = ',' then

                        Start := Start + 1;

                        exit;

                     else

                        Start := Start + 1;

                     end if;

                  end loop;

                  Finish := Start;

                  --  If the comma is found, get the Major and the Minor IDs

                  if OK then

                     loop

                        if Line (Finish) not in '0' .. '9'

                          or else Finish >= Last - 1

                        then

                           OK := False;

                           exit;

                        end if;

                        exit when Line (Finish + 1) = ',';

                        Finish := Finish + 1;

                     end loop;

                  end if;

                  if OK then

                     ID := Integer'Value (Line (Start .. Finish));

                     OK := ID /= 0;

                     --  If Soft_Major_ID is True, it means that

                     --  Library_Version was not specified.

                     if Soft_Major_ID then

                        Major_ID := ID;

                     --  If the Major ID in the reference file is different

                     --  from the Library_Version, then the Minor ID will be 0

                     --  because there is no point in taking the Minor ID in

                     --  the reference file, or incrementing it. So, we set

                     --  Soft_Minor_ID to False, so that we don't modify

                     --  the Minor_ID later.

                     elsif Major_ID /= ID then

                        Soft_Minor_ID := False;

                     end if;

                     Start := Finish + 2;

                     Finish := Start;

                     loop

                        if Line (Finish) not in '0' .. '9' then

                           OK := False;

                           exit;

                        end if;

                        exit when Finish = Last;

                        Finish := Finish + 1;

                     end loop;

                     --  Only set Minor_ID if Soft_Minor_ID is True (see above)

                     if OK and then Soft_Minor_ID then

                        Minor_ID := Integer'Value (Line (Start .. Finish));

                     end if;

                  end if;

                  --  If OK is not True, that means the line is not correctly

                  --  formatted.

                  if not OK then

                     if not Quiet then

                        Put_Line ("symbol file """ & Reference &

                                  """ is incorrectly formatted");

                        Put_Line ("""" & Line (1 .. Last) & """");

                     end if;

                     Close (File);

                     Success := False;

                     return;

                  end if;

               end;

            --  Anything else is incorrectly formatted

            else

               if not Quiet then

                  Put_Line ("unexpected line in symbol file """ &

                            Reference & """");

                  Put_Line ("""" & Line (1 .. Last) & """");

               end if;

               Close (File);

               Success := False;

               return;

            end if;

         end loop;

         Close (File);

      end if;

   end Initialize;

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

   -- Processing --

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

   package body Processing is separate;

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

   -- Finalize --

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

   procedure Finalize

     (Quiet   : Boolean;

      Success : out Boolean)

   is

      File   : Ada.Text_IO.File_Type;

      --  The symbol file

      S_Data : Symbol_Data;

      --  A symbol

      Cur    : Positive := 1;

      --  Most probable index in the Complete_Symbols of the current symbol

      --  in Original_Symbol.

      Found  : Boolean;

   begin

      --  Nothing to be done if Initialize has never been called

      if Symbol_File_Name = null then

         Success := False;

      else

         --  First find if the symbols in the reference symbol file are also

         --  in the object files. Note that this is not done if the policy is

         --  Autonomous, because no reference symbol file has been read.

         --  Expect the first symbol in the symbol file to also be the first

         --  in Complete_Symbols.

         Cur := 1;

         for Index_1 in 1 .. Symbol_Table.Last (Original_Symbols) loop

            S_Data := Original_Symbols.Table (Index_1);

            Found := False;

            First_Object_Loop :

            for Index_2 in Cur .. Symbol_Table.Last (Complete_Symbols) loop

               if Equal (S_Data, Complete_Symbols.Table (Index_2)) then

                  Cur := Index_2 + 1;

                  Complete_Symbols.Table (Index_2).Present := False;

                  Found := True;

                  exit First_Object_Loop;

               end if;

            end loop First_Object_Loop;

            --  If the symbol could not be found between Cur and Last, try

            --  before Cur.

            if not Found then

               Second_Object_Loop :

               for Index_2 in 1 .. Cur - 1 loop

                  if Equal (S_Data, Complete_Symbols.Table (Index_2)) then

                     Cur := Index_2 + 1;

                     Complete_Symbols.Table (Index_2).Present := False;

                     Found := True;

                     exit Second_Object_Loop;

                  end if;

               end loop Second_Object_Loop;

            end if;

            --  If the symbol is not found, mark it as such in the table

            if not Found then

               if (not Quiet) or else Sym_Policy = Controlled then

                  Put_Line ("symbol """ & S_Data.Name.all &

                            """ is no longer present in the object files");

               end if;

               if Sym_Policy = Controlled or else Sym_Policy = Restricted then

                  Success := False;

                  return;

               --  Any symbol that is undefined in the reference symbol file

               --  triggers an increase of the Major ID, because the new

               --  version of the library is no longer compatible with

               --  existing executables.

               elsif Soft_Major_ID then

                  Major_ID := Major_ID + 1;

                  Minor_ID := 0;

                  Soft_Major_ID := False;

                  Soft_Minor_ID := False;

               end if;

               Original_Symbols.Table (Index_1).Present := False;

               Free (Original_Symbols.Table (Index_1).Name);

               if Soft_Minor_ID then

                  Minor_ID := Minor_ID + 1;

                  Soft_Minor_ID := False;

               end if;

            end if;

         end loop;

         if Sym_Policy /= Restricted then

            --  Append additional symbols, if any, to the Original_Symbols

            --  table.

            for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop

               S_Data := Complete_Symbols.Table (Index);

               if S_Data.Present then

                  if Sym_Policy = Controlled then

                     Put_Line ("symbol """ & S_Data.Name.all &

                               """ is not in the reference symbol file");

                     Success := False;

                     return;

                  elsif Soft_Minor_ID then

                     Minor_ID := Minor_ID + 1;

                     Soft_Minor_ID := False;

                  end if;

                  Symbol_Table.Increment_Last (Original_Symbols);

                  Original_Symbols.Table

                    (Symbol_Table.Last (Original_Symbols)) := S_Data;

                  Complete_Symbols.Table (Index).Present := False;

               end if;

            end loop;

            --  Create the symbol file

            Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all);

            Put (File, Case_Sensitive);

            Put_Line (File, "yes");

            --  Put a line in the symbol file for each symbol in symbol table

            for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop

               if Original_Symbols.Table (Index).Present then

                  Put (File, Symbol_Vector);

                  Put (File, Original_Symbols.Table (Index).Name.all);

                  if Original_Symbols.Table (Index).Kind = Data then

                     Put_Line (File, Equal_Data);

                  else

                     Put_Line (File, Equal_Procedure);

                  end if;

                  Free (Original_Symbols.Table (Index).Name);

               end if;

            end loop;

            Put (File, Case_Sensitive);

            Put_Line (File, "NO");

            --  Put the version IDs

            Put (File, Gsmatch_Lequal);

            Put (File, Image (Major_ID));

            Put (File, ',');

            Put_Line  (File, Image (Minor_ID));

            --  And we are done

            Close (File);

            --  Reset both tables

            Symbol_Table.Set_Last (Original_Symbols, 0);

            Symbol_Table.Set_Last (Complete_Symbols, 0);

            --  Clear the symbol file name

            Free (Symbol_File_Name);

         end if;

         Success := True;

      end if;

   exception

      when X : others =>

         Put_Line ("unexpected exception raised while finalizing """

                   & Symbol_File_Name.all & """");

         Put_Line (Exception_Information (X));

         Success := False;

   end Finalize;

end Symbols;