------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--             G N A T . T R A C E B A C K . S Y M B O L I C                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--         Copyright (C) 2005-2010, 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.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  Run-time symbolic traceback support for IA64/VMS

with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
with System;
with System.Aux_DEC;
with System.Soft_Links;
with System.Traceback_Entries;

package body GNAT.Traceback.Symbolic is

   use System;
   use System.Aux_DEC;
   use System.Traceback_Entries;

   subtype Var_String_Buf is String (1 .. 254);

   type Var_String is record
      Curlen : Unsigned_Word := 0;
      Buf    : Var_String_Buf;
   end record;
   pragma Convention (C, Var_String);
   for Var_String'Size use 8 * 256;

   type Descriptor64 is record
      Mbo       : Unsigned_Word;
      Dtype     : Unsigned_Byte;
      Class     : Unsigned_Byte;
      Mbmo      : Unsigned_Longword;
      Maxstrlen : Integer_64;
      Pointer   : Address;
   end record;
   pragma Convention (C, Descriptor64);

   subtype Cond_Value_Type is Unsigned_Longword;

   --  TBK_API_PARAM as defined in TBKDEF

   type Tbk_Api_Param is record
      Length              : Unsigned_Word;
      T_Type              : Unsigned_Byte;
      Version             : Unsigned_Byte;
      Reserveda           : Unsigned_Longword;
      Faulting_Pc         : Address;
      Faulting_Fp         : Address;
      Filename_Desc       : Address;
      Library_Module_Desc : Address;
      Record_Number       : Address;
      Image_Desc          : Address;
      Module_Desc         : Address;
      Routine_Desc        : Address;
      Listing_Lineno      : Address;
      Rel_Pc              : Address;
      Image_Base_Addr     : Address;
      Module_Base_Addr    : Address;
      Malloc_Rtn          : Address;
      Free_Rtn            : Address;
      Symbolize_Flags     : Address;
      Reserved0           : Unsigned_Quadword;
      Reserved1           : Unsigned_Quadword;
      Reserved2           : Unsigned_Quadword;
   end record;
   pragma Convention (C, Tbk_Api_Param);

   K_Version : constant Unsigned_Byte := 1;
   --  Current API version

   K_Length : constant Unsigned_Word := 152;
   --  Length of the parameter

   pragma Compile_Time_Error (Tbk_Api_Param'Size = K_Length * 8,
                              "Bad length for tbk_api_param");
   --  Sanity check

   function Symbolize (Param : Address) return Cond_Value_Type;
   pragma Import (C, Symbolize, "TBK$I64_SYMBOLIZE");

   function Decode_Ada_Name (Encoded_Name : String) return String;
   --  Decodes an Ada identifier name. Removes leading "_ada_" and trailing
   --  __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.'

   procedure Setup_Descriptor64_Vs (Desc : out Descriptor64; Var : Address);
   --  Setup descriptor Desc for address Var

   ---------------------
   -- Decode_Ada_Name --
   ---------------------

   function Decode_Ada_Name (Encoded_Name : String) return String is
      Decoded_Name : String (1 .. Encoded_Name'Length);
      Pos          : Integer := Encoded_Name'First;
      Last         : Integer := Encoded_Name'Last;
      DPos         : Integer := 1;

   begin
      if Pos > Last then
         return "";
      end if;

      --  Skip leading _ada_

      if Encoded_Name'Length > 4
        and then Encoded_Name (Pos .. Pos + 4) = "_ada_"
      then
         Pos := Pos + 5;
      end if;

      --  Skip trailing __{DIGIT}+ or ${DIGIT}+

      if Encoded_Name (Last) in '0' .. '9' then
         for J in reverse Pos + 2 .. Last - 1 loop
            case Encoded_Name (J) is
               when '0' .. '9' =>
                  null;

               when '$' =>
                  Last := J - 1;
                  exit;

               when '_' =>
                  if Encoded_Name (J - 1) = '_' then
                     Last := J - 2;
                  end if;
                  exit;

               when others =>
                  exit;
            end case;
         end loop;
      end if;

      --  Now just copy encoded name to decoded name, converting "__" to '.'

      while Pos <= Last loop
         if Encoded_Name (Pos) = '_' and then Encoded_Name (Pos + 1) = '_'
           and then Pos /= Encoded_Name'First
         then
            Decoded_Name (DPos) := '.';
            Pos := Pos + 2;
         else
            Decoded_Name (DPos) := Encoded_Name (Pos);
            Pos := Pos + 1;
         end if;

         DPos := DPos + 1;
      end loop;

      return Decoded_Name (1 .. DPos - 1);
   end Decode_Ada_Name;

   ---------------------------
   -- Setup_Descriptor64_Vs --
   ---------------------------

   procedure Setup_Descriptor64_Vs (Desc : out Descriptor64; Var : Address) is
      K_Dtype_Vt : constant Unsigned_Byte := 37;
      K_Class_Vs : constant Unsigned_Byte := 11;
   begin
      Desc.Mbo := 1;
      Desc.Dtype := K_Dtype_Vt;
      Desc.Class := K_Class_Vs;
      Desc.Mbmo := -1;
      Desc.Maxstrlen := Integer_64 (Var_String_Buf'Length);
      Desc.Pointer := Var;
   end Setup_Descriptor64_Vs;

   ------------------------
   -- Symbolic_Traceback --
   ------------------------

   function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is
      Param         : Tbk_Api_Param;
      Status        : Cond_Value_Type;
      Record_Number : Unsigned_Longword;
      Image_Name    : Var_String;
      Image_Dsc     : Descriptor64;
      Module_Name   : Var_String;
      Module_Dsc    : Descriptor64;
      Routine_Name  : Var_String;
      Routine_Dsc   : Descriptor64;
      Line_Number   : Unsigned_Longword;
      Res           : String (1 .. 256 * Traceback'Length);
      Len           : Integer;

   begin
      if Traceback'Length = 0 then
         return "";
      end if;

      Len := 0;

      --  Since image computation is not thread-safe we need task lockout

      System.Soft_Links.Lock_Task.all;

      --  Initialize descriptors

      Setup_Descriptor64_Vs (Image_Dsc, Image_Name'Address);
      Setup_Descriptor64_Vs (Module_Dsc, Module_Name'Address);
      Setup_Descriptor64_Vs (Routine_Dsc, Routine_Name'Address);

      for J in Traceback'Range loop
         --  Initialize fields in case they are not written

         Record_Number := 0;
         Line_Number := 0;
         Image_Name.Curlen := 0;
         Module_Name.Curlen := 0;
         Routine_Name.Curlen := 0;

         --  Symbolize

         Param := (Length              => K_Length,
                   T_Type              => 0,
                   Version             => K_Version,
                   Reserveda           => 0,
                   Faulting_Pc         => PC_For (Traceback (J)),
                   Faulting_Fp         => 0,
                   Filename_Desc       => Null_Address,
                   Library_Module_Desc => Null_Address,
                   Record_Number       => Record_Number'Address,
                   Image_Desc          => Image_Dsc'Address,
                   Module_Desc         => Module_Dsc'Address,
                   Routine_Desc        => Routine_Dsc'Address,
                   Listing_Lineno      => Line_Number'Address,
                   Rel_Pc              => Null_Address,
                   Image_Base_Addr     => Null_Address,
                   Module_Base_Addr    => Null_Address,
                   Malloc_Rtn          => Null_Address,
                   Free_Rtn            => Null_Address,
                   Symbolize_Flags     => Null_Address,
                   Reserved0           => (0, 0),
                   Reserved1           => (0, 0),
                   Reserved2           => (0, 0));

         Status := Symbolize (Param'Address);

         --  Check for success (marked by bit 0)

         if (Status rem 2) = 1 then

            --  Success

            if Line_Number = 0 then

               --  As GCC doesn't emit source file correlation, use record
               --  number of line number is not set

               Line_Number := Record_Number;
            end if;

            declare
               First : constant Integer := Len + 1;
               Last  : Integer := First + 80 - 1;
               Pos   : Integer;

               Routine_Name_D : constant String :=
                                  Decode_Ada_Name
                                    (Routine_Name.Buf
                                      (1 .. Natural (Routine_Name.Curlen)));

               Lineno : constant String :=
                          Unsigned_Longword'Image (Line_Number);

            begin
               Res (First .. Last) := (others => ' ');

               Res (First .. First + Natural (Image_Name.Curlen) - 1) :=
                 Image_Name.Buf (1 .. Natural (Image_Name.Curlen));

               Res (First + 10 ..
                      First + 10 + Natural (Module_Name.Curlen) - 1) :=
                 Module_Name.Buf (1 .. Natural (Module_Name.Curlen));

               Res (First + 30 ..
                      First + 30 + Routine_Name_D'Length - 1) :=
                 Routine_Name_D;

               --  If routine name doesn't fit 20 characters, output the line
               --  number on next line at 50th position.

               if Routine_Name_D'Length > 20 then
                  Pos := First + 30 + Routine_Name_D'Length;
                  Res (Pos) := ASCII.LF;
                  Last := Pos + 80;
                  Res (Pos + 1 .. Last) := (others => ' ');
                  Pos := Pos + 51;
               else
                  Pos := First + 50;
               end if;

               Res (Pos .. Pos + Lineno'Length - 1) := Lineno;

               Res (Last) := ASCII.LF;
               Len := Last;
            end;

         --  Failure (bit 0 clear)

         else
            Res (Len + 1 .. Len + 6) := "ERROR" & ASCII.LF;
            Len := Len + 6;
         end if;
      end loop;

      System.Soft_Links.Unlock_Task.all;
      return Res (1 .. Len);
   end Symbolic_Traceback;

   function Symbolic_Traceback (E : Exception_Occurrence) return String is
   begin
      return Symbolic_Traceback (Tracebacks (E));
   end Symbolic_Traceback;

end GNAT.Traceback.Symbolic;