------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                    S Y M B O L S . P R O C E S S I N G                   --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2004-2007, 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 is the VMS/IA64 version of this package

with Ada.IO_Exceptions;

with Ada.Unchecked_Deallocation;

separate (Symbols)
package body Processing is

   type String_Array is array (Positive range <>) of String_Access;
   type Strings_Ptr is access String_Array;

   procedure Free is
     new Ada.Unchecked_Deallocation (String_Array, Strings_Ptr);

   type Section_Header is record
      Shname   : Integer;
      Shtype   : Integer;
      Shoffset : Integer;
      Shsize   : Integer;
      Shlink   : Integer;
   end record;

   type Section_Header_Array is array (Natural range <>) of Section_Header;
   type Section_Header_Ptr is access Section_Header_Array;

   procedure Free is
     new Ada.Unchecked_Deallocation (Section_Header_Array, Section_Header_Ptr);

   -------------
   -- Process --
   -------------

   procedure Process
     (Object_File : String;
      Success     : out Boolean)
   is
      B : Byte;
      W : Integer;

      Str : String (1 .. 1000) := (others => ' ');
      Str_Last : Natural;

      Strings : Strings_Ptr;

      Shoff : Integer;
      Shnum : Integer;
      Shentsize : Integer;

      Shname   : Integer;
      Shtype   : Integer;
      Shoffset : Integer;
      Shsize   : Integer;
      Shlink   : Integer;

      Symtab_Index       : Natural := 0;
      String_Table_Index : Natural := 0;

      End_Symtab : Integer;

      Stname  : Integer;
      Stinfo  : Character;
      Sttype  : Integer;
      Stbind  : Integer;
      Stshndx : Integer;

      Section_Headers : Section_Header_Ptr;

      Offset : Natural := 0;
      OK     : Boolean := True;

      procedure Get_Byte (B : out Byte);
      --  Read one byte from the object file

      procedure Get_Half (H : out Integer);
      --  Read one half work from the object file

      procedure Get_Word (W : out Integer);
      --  Read one full word from the object file

      procedure Reset;
      --  Restart reading the object file

      procedure Skip_Half;
      --  Read and disregard one half word from the object file

      --------------
      -- Get_Byte --
      --------------

      procedure Get_Byte (B : out Byte) is
      begin
         Byte_IO.Read (File, B);
         Offset := Offset + 1;
      end Get_Byte;

      --------------
      -- Get_Half --
      --------------

      procedure Get_Half (H : out Integer) is
         C1, C2 : Character;
      begin
         Get_Byte (C1); Get_Byte (C2);
         H :=
           Integer'(Character'Pos (C2)) * 256 + Integer'(Character'Pos (C1));
      end Get_Half;

      --------------
      -- Get_Word --
      --------------

      procedure Get_Word (W : out Integer) is
         H1, H2 : Integer;
      begin
         Get_Half (H1); Get_Half (H2);
         W := H2 * 256 * 256 + H1;
      end Get_Word;

      -----------
      -- Reset --
      -----------

      procedure Reset is
      begin
         Offset := 0;
         Byte_IO.Reset (File);
      end Reset;

      ---------------
      -- Skip_Half --
      ---------------

      procedure Skip_Half is
         B : Byte;
         pragma Unreferenced (B);
      begin
         Byte_IO.Read (File, B);
         Byte_IO.Read (File, B);
         Offset := Offset + 2;
      end Skip_Half;

   --  Start of processing for Process

   begin
      --  Open the object file with Byte_IO. Return with Success = False if
      --  this fails.

      begin
         Open (File, In_File, Object_File);
      exception
         when others =>
            Put_Line
              ("*** Unable to open object file """ & Object_File & """");
            Success := False;
            return;
      end;

      --  Assume that the object file has a correct format

      Success := True;

      --  Skip ELF identification

      while Offset < 16 loop
         Get_Byte (B);
      end loop;

      --  Skip e_type

      Skip_Half;

      --  Skip e_machine

      Skip_Half;

      --  Skip e_version

      Get_Word (W);

      --  Skip e_entry

      for J in 1 .. 8 loop
         Get_Byte (B);
      end loop;

      --  Skip e_phoff

      for J in 1 .. 8 loop
         Get_Byte (B);
      end loop;

      Get_Word (Shoff);

      --  Skip upper half of Shoff

      for J in 1 .. 4 loop
         Get_Byte (B);
      end loop;

      --  Skip e_flags

      Get_Word (W);

      --  Skip e_ehsize

      Skip_Half;

      --  Skip e_phentsize

      Skip_Half;

      --  Skip e_phnum

      Skip_Half;

      Get_Half (Shentsize);

      Get_Half (Shnum);

      Section_Headers := new Section_Header_Array (0 .. Shnum - 1);

      --  Go to Section Headers

      while Offset < Shoff loop
         Get_Byte (B);
      end loop;

      --  Reset Symtab_Index

      Symtab_Index := 0;

      for J in Section_Headers'Range loop

         --  Get the data for each Section Header

         Get_Word (Shname);
         Get_Word (Shtype);

         for K in 1 .. 16 loop
            Get_Byte (B);
         end loop;

         Get_Word (Shoffset);
         Get_Word (W);

         Get_Word (Shsize);
         Get_Word (W);

         Get_Word (Shlink);

         while (Offset - Shoff) mod Shentsize /= 0 loop
            Get_Byte (B);
         end loop;

         --  If this is the Symbol Table Section Header, record its index

         if Shtype = 2 then
            Symtab_Index := J;
         end if;

         Section_Headers (J) := (Shname, Shtype, Shoffset, Shsize, Shlink);
      end loop;

      if Symtab_Index = 0 then
         Success := False;
         return;
      end if;

      End_Symtab :=
        Section_Headers (Symtab_Index).Shoffset +
        Section_Headers (Symtab_Index).Shsize;

      String_Table_Index := Section_Headers (Symtab_Index).Shlink;
      Strings :=
        new String_Array (1 .. Section_Headers (String_Table_Index).Shsize);

      --  Go get the String Table section for the Symbol Table

      Reset;

      while Offset < Section_Headers (String_Table_Index).Shoffset loop
         Get_Byte (B);
      end loop;

      Offset := 0;

      Get_Byte (B);  --  zero

      while Offset < Section_Headers (String_Table_Index).Shsize loop
         Str_Last := 0;

         loop
            Get_Byte (B);
            if B /= ASCII.NUL then
               Str_Last := Str_Last + 1;
               Str (Str_Last) := B;

            else
               Strings (Offset - Str_Last - 1) :=
                 new String'(Str (1 .. Str_Last));
               exit;
            end if;
         end loop;
      end loop;

      --  Go get the Symbol Table

      Reset;

      while Offset < Section_Headers (Symtab_Index).Shoffset loop
         Get_Byte (B);
      end loop;

      while Offset < End_Symtab loop
         Get_Word (Stname);
         Get_Byte (Stinfo);
         Get_Byte (B);
         Get_Half (Stshndx);
         for J in 1 .. 4 loop
            Get_Word (W);
         end loop;

         Sttype := Integer'(Character'Pos (Stinfo)) mod 16;
         Stbind := Integer'(Character'Pos (Stinfo)) / 16;

         if (Sttype = 1 or else Sttype = 2)
              and then Stbind /= 0
              and then Stshndx /= 0
         then
            --  Check if this is a symbol from a generic body

            OK := True;

            for J in Strings (Stname)'First .. Strings (Stname)'Last - 2 loop
               if Strings (Stname) (J) = 'G'
                 and then Strings (Stname) (J + 1) = 'P'
                 and then Strings (Stname) (J + 2) in '0' .. '9'
               then
                  OK := False;
                  exit;
               end if;
            end loop;

            if OK then
               declare
                  S_Data : Symbol_Data;
               begin
                  S_Data.Name := new String'(Strings (Stname).all);

                  if Sttype = 1 then
                     S_Data.Kind := Data;

                  else
                     S_Data.Kind := Proc;
                  end if;

                  --  Put the new symbol in the table

                  Symbol_Table.Append (Complete_Symbols, S_Data);
               end;
            end if;
         end if;
      end loop;

      --  The object file has been processed, close it

      Close (File);

      --  Free the allocated memory

      Free (Section_Headers);

      for J in Strings'Range loop
         if Strings (J) /= null then
            Free (Strings (J));
         end if;
      end loop;

      Free (Strings);

   exception
      --  For any exception, output an error message, close the object file
      --  and return with Success = False.

      when Ada.IO_Exceptions.End_Error =>
         Close (File);

      when X : others =>
         Put_Line ("unexpected exception raised while processing """
                   & Object_File & """");
         Put_Line (Exception_Information (X));
         Close (File);
         Success := False;
   end Process;

end Processing;