------------------------------------------------------------------------------
--                         G N A T S Y M B O L I Z E                        --
--                                                                          --
--                        Copyright (C) 2017, AdaCore                       --
--                                                                          --
-- This 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.  This software is distributed in the hope  that it will be useful, --
-- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
-- TABILITY 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  this  software;   see  file --
-- COPYING3.  If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license.                                                          --
------------------------------------------------------------------------------

with Ada.Text_IO;       use Ada.Text_IO;
with Ada.Command_Line;  use Ada.Command_Line;
with System; use System;
with System.Storage_Elements; use System.Storage_Elements;

with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;

pragma Warnings (Off);
with System.Dwarf_Lines; use System.Dwarf_Lines;
with System.Bounded_Strings; use System.Bounded_Strings;
pragma Warnings (On);

with GNAT.OS_Lib;               use GNAT.OS_Lib;

procedure GNATsymbolize is

   -----------------------
   -- Local subprograms --
   -----------------------

   procedure Error (Msg : String);
   pragma No_Return (Error);
   --  Prints the message and then terminates the program

   procedure Usage;
   --  Displays the short help message and then terminates the program

   function Get_Value_From_Hex_Arg (Arg : Natural) return Address;
   --  Threats the argument number Arg as a C-style hexadecimal literal
   --  and returns its integer value

   --  Separate functions that provide build-time customization:

   -----------
   -- Error --
   -----------

   procedure Error (Msg : String) is
   begin
      Put_Line (Msg);
      OS_Exit (1);
      raise Program_Error;
   end Error;

   ----------------------------
   -- Get_Value_From_Hex_Arg --
   ----------------------------

   function Get_Value_From_Hex_Arg (Arg : Natural) return Address is
      Cur_Arg : constant String := Argument (Arg);
      Offset  : Natural;

   begin
      --  Skip "0x" prefix if present

      if Cur_Arg'Length > 2 and then Cur_Arg (1 .. 2) = "0x" then
         Offset := 3;
      else
         Offset := 1;
      end if;

      --  Convert to value

      return To_Address (Integer_Address'Value
        ("16#" & Cur_Arg (Offset .. Cur_Arg'Last) & "#"));

   exception
      when Constraint_Error =>

         Error ("Can't parse backtrace address '" & Cur_Arg & "'");
         raise;
   end Get_Value_From_Hex_Arg;

   -----------
   -- Usage --
   -----------

   procedure Usage is
   begin
      Put_Line ("Usage : " & Command_Name
                & " [--cache] [--count=N] <executable> <addr>...");

      OS_Exit (1);
   end Usage;

   Argc : constant Natural := Argument_Count;
   P : Natural;
   Count : Natural := 1;
   Flag_Cache : Boolean := False;
   Flag_Dump : Boolean := False;
begin

   P := 1;
   while P < Argc loop
      declare
         Arg : constant String := Argument (P);
      begin
         if Arg = "--cache" then
            Flag_Cache := True;
         elsif Arg = "--dump" then
            Flag_Dump := True;
         elsif Arg'Length > 8
           and then Arg (Arg'First .. Arg'First + 7) = "--count="
         then
            Count := Natural'Value (Arg (Arg'First + 8 .. Arg'Last));
         elsif Arg = "-h" or else Arg = "--help" then
            Usage;
         else
            exit;
         end if;
      end;
      P := P + 1;
   end loop;

   --  The image argument is required
   if P > Argc then
      Usage;
   end if;

   declare
      Filename : constant String := Argument (P);
      Addrs : Tracebacks_Array (P + 1 .. Argc);
      C : Dwarf_Context;
      Success : Boolean;
      Res : Bounded_String (Argument_Count * 100);
   begin
      --  The first argument specifies the image file. Check if it exists
      if not Is_Regular_File (Filename) then
         Error ("Couldn't find the executable " & Filename);
      end if;

      for I in Addrs'Range loop
         Addrs (I) := Get_Value_From_Hex_Arg (I);
      end loop;

      Open (Filename, C, Success);

      if not Success then
         Error ("cannot open " & Filename);
      end if;

      if Flag_Cache then
         Enable_Cache (C);
         if Flag_Dump then
            Dump_Cache (C);
         end if;
         null;
      end if;

      for I in 1 .. Count loop
         Symbolic_Traceback (C, Addrs, False, Success, Res);
         if not Success then
            Put_Line (Standard_Error, "cannot symbolize");
         else
            Put (To_String (Res));
         end if;
      end loop;

      Close (C);
   end;
exception
   when others =>

      --  Mask all exceptions

      return;
end GNATsymbolize;
