adacl_5.15.1_e7c1515b/src/adacl-trace.adb

-------------------------------------------------------------- {{{1 ----------
--: Copyright © 2007 … 2023 Martin Krischik «krischik@users.sourceforge.net»
-------------------------------------------------------------------------------
--: This library is free software; you can redistribute it and/or modify it
--: under the terms of the GNU Library General Public License as published by
--: the Free Software Foundation; either version 2 of the License, or (at your
--: option) any later version.
--:
--: This library is distributed in the hope that it will be useful, but
--: WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
--: or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
--: License for more details.
--:
--: You should have received a copy of the GNU Library General Public License
--: along with this library; if not, write to the Free Software Foundation,
--: Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
--------------------------------------------------------------- }}}1 ----------

pragma License (Modified_Gpl);
pragma Ada_2022;

with Ada.Characters.Conversions;
with Ada.Characters.Handling;
with Ada.Characters.Latin_1;
with Ada.Containers.Hashed_Maps;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;
with Ada.Task_Identification;
with Ada.Text_IO;
with AdaCL.Command_Line.GetOpt;
with AdaCL.Strings;
with AdaCL.Strings.Hex;

--
--  @summary
--  Ada Class Library
--  Trace
--
--  @description
--
package body AdaCL.Trace is

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

   use type Ada.Strings.Unbounded.Unbounded_String;

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

   package Unbounded renames Ada.Strings.Unbounded;
   package Latin_1 renames Ada.Characters.Latin_1;
   package Text_IO renames Ada.Text_IO;

   ---------------------------------------------------------------------------
   function Address_Image is new AdaCL.Strings.Hex.Generic_Image (System.Storage_Elements.Integer_Address);

   ---
   --  Remembers thread ids.
   --
   --: @field Thread_No  Each Thread has a number. A number is shorter then string.
   --: @field Indent     Function indeting is counded separate for every thread
   type Thread_ID is record
      Thread_No : Natural := Natural'First;
      Indent    : Natural := Natural'First;
   end record;

   ---
   --  The controlled object used in Function_Trace is adjusted multiple times. To get a better output two adjustments
   --  and two finals are ignored.
   --
   type Repeat_Count is range 0 .. 4;

   ---
   --  Some Container for Thread_IDs
   --
   package Thread_ID_Map is new Ada.Containers.Hashed_Maps
      (Key_Type        => Unbounded.Unbounded_String,
       Element_Type    => Thread_ID,
       Hash            => AdaCL.Strings.Hash,
       Equivalent_Keys => "=",
       "="             => "=");

   ---
   --  Protect all global data.
   --
   protected Cl is
      ---
      --  Initialize Trace.
      --
      procedure Initialize;

      ---
      --  Icrement Trace line counter by one
      --
      procedure Inc_Sequence;
      pragma Inline (Inc_Sequence);

      ---
      --  Get Trace line counter
      --
      function Get_Sequence return Natural;
      pragma Inline (Get_Sequence);

      procedure Set_Filename (New_Filename : in String);
      pragma Inline (Set_Filename);

      ---
      --  Determine the threadId of the current thread
      --
      procedure Get_Thread_ID (Retval : out Thread_ID);

      ---
      --  Determine the threadId of the current thread
      --
      procedure Set_Thread_ID (Element : in Thread_ID);

      ---
      --  Trace is On
      --
      function Get_On return Boolean;
      pragma Inline (Get_On);

      ---
      --  Trace is On
      --
      procedure Set_On (On : Boolean);
      pragma Inline (Set_On);

      ---
      --  Trace is On
      --
      function Get_Verbose return Boolean;
      pragma Inline (Get_Verbose);

      ---
      --  The controlled object used in Function_Trace is adjusted multiple times. To get a better output two
      --  adjustments are ignored.
      --
      --  reset the last function counter and function name.
      --
      procedure Reset_Last_Function (Function_Name : String);

      ---
      --  The controlled object used in Function_Trace is adjusted multiple times. To get a better output two
      --  adjustments are ignored.
      --
      --  Check if counter is greater 0
      --
      function Ignore_Function (Function_Name : String) return Boolean;

      ---
      --  The controlled object used in Function_Trace is adjusted multiple times. To get a better output two
      --  adjustments are ignored.
      --
      --  Decrement counter until it reaches 0
      --
      procedure Decrement_Last_Function;

      ---
      --  Trace is On
      --
      procedure Set_Verbose (Verbose : Boolean);
      pragma Inline (Set_Verbose);

      ---
      --  Trace with line numbers.
      --
      function Get_Write_Line_Number return Boolean;
      pragma Inline (Get_Write_Line_Number);

      ---
      --  Trace with line numbers.
      --
      procedure Set_Write_Line_Number (Write_Line_Number : Boolean);
      pragma Inline (Set_Write_Line_Number);

      ---
      --  Trace with thread profex and optional line numbers.
      --
      function Get_Write_Prefix return Boolean;
      pragma Inline (Get_Write_Prefix);

      ---
      --  Trace with thread profex and optional line numbers.
      --
      procedure Set_Write_Prefix (Write_Prefix : Boolean);
      pragma Inline (Set_Write_Prefix);

      ---
      --  Trace Destination
      --
      function Get_Trace_Location return Destination;
      pragma Inline (Get_Trace_Location);

      ---
      --  Trace Destination
      --
      procedure Set_Trace_Location (Location : in Destination);
      pragma Inline (Set_Trace_Location);

      ---
      --  Write Formated Text
      --
      --: @param Text    Text to be written
      --: @param Marker  Marker to be used
      procedure Write_Formatted_String (Text : in String; Marker : in Character);

      ---
      --  Write Text
      --
      --: @param Text  Text to be written
      procedure Write_String (Text : in String);

   private

      ---
      --  Trace line counter
      --
      Sequence : Natural := Natural'First;

      ---
      --  Filename of Trace if Destination ist File
      --
      Filename : Unbounded.Unbounded_String := Unbounded.To_Unbounded_String ("AdaCL-Trace.log");

      ---
      --  The original IBM design opened and closed the File all the time. However, Ada.Text_IO won't allow that and of
      --  course, it is slow.
      --
      Filehandle : Text_IO.File_Type;

      ---
      --  Last Thread ID used
      --
      Thread_No : Natural := Natural'First;

      ---
      --  Current Indenting Level for each thread
      --
      Threads : Thread_ID_Map.Map;

      ---
      --  Trace Destination
      --
      Location : Destination := Standard_Error;

      ---
      --  Trace is On
      --
      On : Boolean := False;

      ---
      --  Trace with line numbers.
      --
      Write_Line_Number : Boolean := True;

      ---
      --  Trace with thread profex and optional line numbers.
      Write_Prefix : Boolean := True;

      ---
      --   Verbose operation.
      Verbose : Boolean := False;

      ---
      --  The controlled object used in Function_Trace is adjusted multiple times. To get a better output two
      --  adjustments are ignored.
      --
      --  Counter to count how often Adjust was called.
      --
      Repeat_Counter : Repeat_Count := 0;

      ---
      --  The controlled object used in Function_Trace is adjusted multiple times. To get a better output two
      --  adjustments are ignored.
      --
      --  remembers the last function name traced
      --
      Last_Function : Unbounded.Unbounded_String := Unbounded.Null_Unbounded_String;

   end Cl;

   ---------------------------------------------------------------------------
   --
   --  Indent Level
   --
   Indent_Level : constant Natural := 2;
   --
   --  Commandline options
   --
   Trace_Verbose : constant String := "verbose";

   Trace_Opt          : constant String := "TRACE";
   Trace_Opt_On       : constant String := "ON";
   Trace_Opt_NoPrefix : constant String := "NOPREFIX";

   Trace_Opt_To        : constant String := "TRACETO";
   Trace_Opt_To_Err1   : constant String := "STDERR";
   Trace_Opt_To_Err2   : constant String := "ERR";
   Trace_Opt_To_Std1   : constant String := "STDOUT";
   Trace_Opt_To_Std2   : constant String := "OUT";
   Trace_Opt_To_File   : constant String := "FILE";
   Trace_Opt_To_Queue1 : constant String := "QUEUE";
   Trace_Opt_To_Queue2 : constant String := "PMPRINTF";

   Trace_Opt_File : constant String := "TRACEFILE";

   Marker_Std     : constant Character := Latin_1.Greater_Than_Sign;
   Marker_Special : constant Character := Latin_1.Exclamation;
   Marker_Outdent : constant Character := Latin_1.Minus_Sign;
   Marker_Indent  : constant Character := Latin_1.Plus_Sign;

   ---------------------------------------------------------------------------
   --
   --  Protect all global data.
   --
   protected body Cl is

      ---
      --  Get Trace line counter
      --
      function Get_Sequence return Natural is (Sequence);

      ---
      --  Trace is On
      --
      function Get_On return Boolean is (On);

      ---
      --
      --  Determine the threadId of the current thread
      --
      procedure Get_Thread_ID (Retval : out Thread_ID) is
         use Ada.Strings.Unbounded;
         use Thread_ID_Map;
         use Ada.Task_Identification;

         FixThread_ID : constant String           := Image (Current_Task);
         StrThread_ID : constant Unbounded_String := To_Unbounded_String (FixThread_ID);
      begin
         if Contains (Container => Threads, Key => StrThread_ID) then
            Retval := Element (Container => Threads, Key => StrThread_ID);
         else
            Retval :=
               Thread_ID'
                  (Thread_No => Thread_No,
                   Indent    => 0);
            Insert
               (Container => Threads,
                Key       => StrThread_ID,
                New_Item  => Retval);

            Thread_No := Natural'Succ (Thread_No);

            if On then
               Write_Formatted_String (Text => "New Thread : " & FixThread_ID, Marker => Marker_Special);
            end if;
         end if;
      end Get_Thread_ID;

      ---
      --  Trace Destination
      --
      function Get_Trace_Location return Destination is (Location);

      ---
      --  Trace with line numbers.
      --
      function Get_Write_Line_Number return Boolean is (Write_Line_Number);

      ---
      --  Trace with thread profex and optional line numbers.
      --
      function Get_Write_Prefix return Boolean is (Write_Prefix);

      ---
      --  Trace is On
      --
      function Get_Verbose return Boolean is (Verbose);

      ---
      --
      --  Icrement Sequence by one
      --
      procedure Inc_Sequence is
      begin
         Sequence := Natural'Succ (Sequence);
      end Inc_Sequence;

      ---
      --
      --  Initialize Trace.
      --
      procedure Initialize is
         use AdaCL.Command_Line.GetOpt;

         Options : AdaCL.Command_Line.GetOpt.Object;
         Found   : FoundFlag;
      begin
         Options.Set_Pattern (":" & Trace_Verbose (1));
         Options.Set_ExceptionOnError (False);
         Options.Set_ExtractGNU (True);

         ParseCL :
         loop
            Options.Next (Found);

            --  To trace the trace ;-)
            --
            --: Text_IO.Put_Line (Text_IO.Standard_Error, Options'Image);
            --: Text_IO.Put_Line (Text_IO.Standard_Error, Found'Image);

            exit ParseCL when Found = EndOfOptions;

            if Found = GNU_Style then
               Analyze_GNU :
               declare
                  Option   : constant String := Options.Get_GNUOption;
                  Argument : constant String := Options.Get_Argument;
               begin
                  if Option = Trace_Opt then
                     if Argument = Trace_Opt_On then
                        On := True;
                     elsif Argument = Trace_Opt_NoPrefix then
                        On                := True;
                        Write_Prefix      := False;
                        Write_Line_Number := False;
                     end if;
                  elsif Option = Trace_Opt_To then
                     if Argument = Trace_Opt_To_Err1 or else Argument = Trace_Opt_To_Err2 then
                        Location := Standard_Error;
                     elsif Argument = Trace_Opt_To_Std1 or else Argument = Trace_Opt_To_Std2 then
                        Location := Standard_Output;
                     elsif Argument = Trace_Opt_To_File then
                        Location := File;
                     elsif Argument = Trace_Opt_To_Queue1 or else Argument = Trace_Opt_To_Queue2 then
                        Location := Queue;
                     end if;
                  elsif Option = Trace_Opt_File then
                     if Argument'Length > 0 then
                        Set_Filename (Argument);
                     end if;
                  elsif Option = Trace_Verbose then
                     Verbose := True;
                  end if;
               end Analyze_GNU;
            elsif Found = WithoutArgument then
               Analyze_Without :
               declare
                  Option : constant Character := Options.Get_Option;
               begin
                  if Option = Trace_Verbose (1) then
                     Verbose := True;
                  end if;
               end Analyze_Without;
            end if;
         end loop ParseCL;
      end Initialize;

      ---
      --  The controlled object used in Function_Trace is adjusted multiple times. To get a better output two
      --  adjustments are ignored.
      --
      --  reset the last function counter and function name.
      --
      procedure Reset_Last_Function (Function_Name : String) is
      begin
         Repeat_Counter := Repeat_Count'Last;
         Last_Function  := Unbounded.To_Unbounded_String (Function_Name);
      end Reset_Last_Function;

      ---
      --  The controlled object used in Function_Trace is adjusted multiple times. To get a better output two
      --  adjustments are ignored.
      --
      --  Check if counter is greater 0
      --
      function Ignore_Function (Function_Name : String) return Boolean is
         (Repeat_Counter > 0 and then Last_Function = Function_Name);

      ---
      --  The controlled object used in Function_Trace is adjusted multiple times. To get a better output two
      --  adjustments are ignored.
      --
      --  Decrement counter until it reaches 0
      --
      procedure Decrement_Last_Function is
      begin
         if Repeat_Counter > 0 then
            Repeat_Counter := @ - 1;
         end if;

         if Repeat_Counter = 0 then
            Last_Function := Unbounded.Null_Unbounded_String;
         end if;
      end Decrement_Last_Function;

      ---
      --  Set Filename for Trace File
      --
      procedure Set_Filename (New_Filename : in String) is
      begin
         if Text_IO.Is_Open (Filehandle) then
            Text_IO.Close (Filehandle);
         end if;

         Filename := Unbounded.To_Unbounded_String (New_Filename);
      end Set_Filename;

      ---
      --  Trace is On
      --
      procedure Set_On (On : Boolean) is
      begin
         Cl.On := On;
      end Set_On;

      ---
      --  Determine the threadId of the current thread
      --
      procedure Set_Thread_ID (Element : in Thread_ID) is
         use Ada.Strings.Unbounded;
         use Thread_ID_Map;
         use Ada.Task_Identification;

         FixThread_ID : constant String           := Image (Current_Task);
         StrThread_ID : constant Unbounded_String := To_Unbounded_String (FixThread_ID);
      begin
         if Contains (Container => Threads, Key => StrThread_ID) then
            Replace
               (Container => Threads,
                Key       => StrThread_ID,
                New_Item  => Element);
         else
            Insert
               (Container => Threads,
                Key       => StrThread_ID,
                New_Item  => Element);
         end if;
      end Set_Thread_ID;

      ---
      --  Trace Destination
      --
      procedure Set_Trace_Location (Location : in Destination) is
      begin
         Cl.Location := Location;
      end Set_Trace_Location;

      ---
      --  Trace is On
      --
      procedure Set_Verbose (Verbose : Boolean) is
      begin
         Cl.Verbose := Verbose;
      end Set_Verbose;

      ---
      --  Trace with line numbers.
      --
      procedure Set_Write_Line_Number (Write_Line_Number : Boolean) is
      begin
         Cl.Write_Line_Number := Write_Line_Number;
      end Set_Write_Line_Number;

      ---
      --  Trace with thread profex and optional line numbers.
      --
      procedure Set_Write_Prefix (Write_Prefix : Boolean) is
      begin
         Cl.Write_Prefix := Write_Prefix;
      end Set_Write_Prefix;

      ---
      --  Write Formated Text
      --
      --: @param Text    Text to be written
      --: @param Marker  Marker to be used
      procedure Write_Formatted_String (Text : in String; Marker : in Character) is
         use Ada.Strings.Unbounded;

         Thread : Thread_ID;
      begin
         Get_Thread_ID (Thread);

         if Marker = Marker_Outdent and then Thread.Indent >= Indent_Level then
            Thread.Indent := Thread.Indent - Indent_Level;
         end if;

         Format :
         declare
            StrOut    : Unbounded_String := To_Unbounded_String (Marker & ' ' & Text);
            StrPrefix : Unbounded_String := Thread.Indent * ' ';
            StrLF     : constant String  := [1 => Latin_1.LF];
         begin
            if Write_Prefix then
               Prefix :
               declare
                  use Ada.Strings.Fixed;

                  StrThread_ID : constant String := Head (Thread.Thread_No'Image, 5);
                  StrLineNo    : constant String := Head (Get_Sequence'Image, 5);
               begin
                  StrPrefix := StrLineNo & ":" & StrThread_ID & ":" & StrPrefix;
               end Prefix;
            end if;

            AdaCL.Strings.Append_All
               (Source   => StrOut,
                Search   => StrLF,
                New_Item => To_String (StrPrefix),
                Mapping  => Ada.Strings.Maps.Identity);
            StrOut := StrPrefix & StrOut;

            Write_String (To_String (StrOut));
         end Format;

         Inc_Sequence;

         if Marker = Marker_Indent then
            Thread.Indent := Thread.Indent + Indent_Level;
         end if;

         Set_Thread_ID (Thread);

      end Write_Formatted_String;

      ---
      --  Write Text
      --
      --: @param Text to be written
      procedure Write_String (Text : in String) is
         use Ada.Text_IO;
      begin
         case Location is
            when Queue =>
               null;
            when Standard_Error =>
               Put_Line (Standard_Error, Text);
            when Standard_Output =>
               Put_Line (Standard_Output, Text);
            when File =>
               if not Is_Open (Filehandle) then
                  Create
                     (File => Filehandle,
                      Mode => Out_File,
                      Name => Unbounded.To_String (Filename),
                      Form => "shared=yes");
               end if;

               Put_Line (Filehandle, Text);
               Flush (Filehandle);
         end case;
      end Write_String;
   end Cl;

   ---
   --  Copy Instanz.
   --
   --: @param This   Object itself.
   overriding procedure Adjust (This : in out Object) is
   begin
      if Is_Trace_Enabled then
         if Cl.Ignore_Function (This.Trace_Name) then
            Cl.Decrement_Last_Function;
         else
            Cl.Write_Formatted_String (Text => This.Trace_Name, Marker => Marker_Indent);
         end if;
      end if;
   end Adjust;

   ---
   --  Report_Assertion a Condition. If the condition is not true create a trace entry describing the assertion and
   --  then raise an exception.
   --
   --: @param Condition  Condition which should be true
   --: @param Raising    Exeption which is raised
   --: @param Message    Free form Message
   --: @param Entity     Location destriptor.
   --: @param Source     Location destriptor.
   procedure Report_Assertion
      (Condition : in Boolean;
       Raising   : in Ada.Exceptions.Exception_Id := Ada.Assertions.Assertion_Error'Identity;
       Message   : in String                      := "No Message given.";
       Entity    : in String                      := GNAT.Source_Info.Enclosing_Entity;
       Source    : in String                      := GNAT.Source_Info.Source_Location)
   is
   begin
      if not Condition then
         Raise_Exception
            (Raising => Raising,
             Message => Message,
             Entity  => Entity,
             Source  => Source);
      end if;
   end Report_Assertion;

   ---
   --  Report_Assertion a Condition. If the condition is not true create a trace entry describing the assertion and
   --  then raise an exception.
   --
   --: @param Condition  Condition which should be true
   --: @param Message    Free form Message
   --: @param Source     Filename.
   --: @param Line       Line number.
   procedure Report_Assertion
      (Condition : Boolean;
       Message   : String;
       Source    : String  := GNAT.Source_Info.File;
       Line      : Natural := GNAT.Source_Info.Line)
   is
   begin
      if not Condition then
         Raise_Exception
            (Raising => Ada.Assertions.Assertion_Error'Identity,
             Message => Message,
             Source  => Source,
             Line    => Line);
      end if;
   end Report_Assertion;

   ---
   --  Enable Trace
   --
   procedure Disable_Trace is
   begin
      Cl.Set_On (False);
   end Disable_Trace;

   ---
   --  Enable Trace
   --
   procedure Disable_Verbose is
   begin
      Cl.Set_Verbose (False);
   end Disable_Verbose;

   ---
   --  Don't Write Line numbers
   --
   procedure Disable_Write_Line_Number is
   begin
      Cl.Set_Write_Line_Number (False);
   end Disable_Write_Line_Number;

   ---
   --  Disable the Write prefix
   --
   procedure Disable_Write_Prefix is
   begin
      Cl.Set_Write_Prefix (False);
   end Disable_Write_Prefix;

   ---
   --  Enable Trace
   --
   procedure Enable_Trace is
   begin
      Cl.Set_On (True);
   end Enable_Trace;

   ---
   --  Enable Trace
   --
   procedure Enable_Verbose is
   begin
      Cl.Set_Verbose (True);
   end Enable_Verbose;

   ---
   --  Write Line numbers
   --
   procedure Enable_Write_Line_Number is
   begin
      Cl.Set_Write_Line_Number (True);
   end Enable_Write_Line_Number;

   ---
   --  Enable the Write prefix
   --
   procedure Enable_Write_Prefix is
   begin
      Cl.Set_Write_Prefix (True);
   end Enable_Write_Prefix;

   ---
   --  Trace end of function
   --
   --: @param This  Object itself.
   overriding procedure Finalize (This : in out Object) is
   begin
      if Is_Trace_Enabled then
         if Cl.Ignore_Function (This.Trace_Name) then
            Cl.Decrement_Last_Function;
         else
            Cl.Write_Formatted_String (Text => This.Trace_Name, Marker => Marker_Outdent);
         end if;
      end if;
   end Finalize;

   ---
   --  Functrace is not quite as usefull as the C++ version. The reason are the missing constructors and destructors in
   --  Ada. With Controlled types you can't limit to just one call to Initialize and one to Finalize There are allways
   --  some extra Adjust with matching. Finalize.
   --
   --: @param Name  Name of the function calls to be traced.
   function Function_Trace (Name : String) return Object is
      Retval : constant Object (Name'Length) :=
         (Base.Object with Name_Length => Name'Length,
          Trace_Name                   => Name);
   begin
      --
      --  The Initialize method is not realy a replacement for a proper contructor.
      --
      if Is_Trace_Enabled then
         Cl.Write_Formatted_String (Text => Retval.Trace_Name, Marker => Marker_Indent);
         Cl.Reset_Last_Function (Name);
      end if;

      return Retval;
   end Function_Trace;

   ---
   --  check is trace is Enabled
   --
   function Is_Trace_Enabled return Boolean is (Cl.Get_On);

   ---
   --  check is trace is Enabled
   --
   function Is_Verbose_Enabled return Boolean is (Cl.Get_Verbose);

   ---
   --  check if Line numbers are written
   --
   function Is_Write_Line_Number_Enabled return Boolean is (Cl.Get_Write_Line_Number);

   ---
   --  Check the Write prefix flag
   --
   function Is_Write_Prefix_Enabled return Boolean is (Cl.Get_Write_Prefix);

   ---
   --  Trace the given exception details and then raise the exception.
   --
   --: @param Raising  Exception which is raised
   --: @param Message  Free form Message
   --: @param Entity   Location descriptor. Suggested content: AdaCL.Trace.Entity
   --: @param Source   Location descriptor. Suggested content: AdaCL.Trace.Source
   procedure Raise_Exception
      (Raising : in Ada.Exceptions.Exception_Id := Ada.Assertions.Assertion_Error'Identity;
       Message : in String                      := "No Message given";
       Entity  : in String                      := GNAT.Source_Info.Enclosing_Entity;
       Source  : in String                      := GNAT.Source_Info.Source_Location)
   is
      use Ada.Exceptions;
   begin
      Write ("Raise Exception " & Exception_Name (Raising));
      Write ("   with Message " & Message);
      Write ("   for Entity   " & Entity);
      Write ("   in Source    " & Source);

      Raise_Exception (E => Raising, Message => Message & " Entity :" & Entity & "." & " Source :" & Source & ".");
   end Raise_Exception;

   ---
   --  Trace the given exception details and then raise the exception.
   --
   --: @param Raising  Exception which is raised Message : Free form Message
   --: @param Message  Message to print to trace
   --: @param Source   Filename.
   --: @param Line     Line number.
   procedure Raise_Exception
      (Raising : in Ada.Exceptions.Exception_Id := Ada.Assertions.Assertion_Error'Identity;
       Message : in String                      := "No Message given";
       Source  : in String                      := GNAT.Source_Info.File;
       Line    : in Natural                     := GNAT.Source_Info.Line)
   is
      use Ada.Exceptions;
   begin
      Write ("Raise Exception " & Exception_Name (Raising));
      Write ("   with Message " & Message);
      Write ("   in File      " & Source);
      Write ("   in Line      " & Line'Image);

      Raise_Exception (E => Raising, Message => Message & "." & " Source :" & Source & " Line :" & Line'Image & ".");
   end Raise_Exception;

   ---
   --  Check the Trace Destination
   --
   function Trace_Destination return Destination is (Cl.Get_Trace_Location);

   ---
   --  Write an IString using Write_Formatted_String after adding the appropriate padding for indentation.
   --
   --: @param Text  String to be written
   procedure Write (Text : in String) is
   begin
      if Is_Trace_Enabled then
         Cl.Write_Formatted_String (Text => Text, Marker => Marker_Std);
      end if;
   end Write;

   ---
   --  Write an Address.
   --
   --: @param Text  String to be written
   procedure Write (Text : in String; An_Address : in System.Address) is
   begin
      if Is_Trace_Enabled then
         Write_Address :
         declare
            Address_Text : constant String := Address_Image (System.Storage_Elements.To_Integer (An_Address));
         begin
            Cl.Write_Formatted_String (Text => Text & ' ' & Address_Text, Marker => Marker_Std);
         end Write_Address;
      end if;
   end Write;

   ---
   --  Write an IString using Write_Formatted_String after adding the appropriate padding for indentation.
   --
   --: @param Text  String to be written
   procedure Write (Text : in Unbounded.Unbounded_String) is
      use Ada.Strings.Unbounded;
   begin
      if Is_Trace_Enabled then
         Cl.Write_Formatted_String (Text => To_String (Text), Marker => Marker_Std);
      end if;
   end Write;

   ---
   --  Write an Exception to the Trace
   --
   --: @param An_Exception  String to be written
   procedure Write (An_Exception : in Ada.Exceptions.Exception_Occurrence) is
      use Ada.Exceptions;
   begin
      if Is_Trace_Enabled then
         Cl.Write_Formatted_String (Text => Exception_Information (An_Exception), Marker => Marker_Special);
         --              Cl.Write_Formatted_String (Text   =>
         --  G_TB.Symbolic_Traceback (An_Exception),
         --                                         Marker => Marker_Special);
      end if;
   end Write;

   ---
   --  Write an Exception to the Trace
   --
   --: @param An_Exception  String to be written
   --: @param Entity     Procedure in which the exception was caught
   --: @param Source      Source File in which Entity is located.
   procedure Write
      (An_Exception : in Ada.Exceptions.Exception_Occurrence;
       Entity       : in String;
       Source       : in String)
   is
      use Ada.Exceptions;
   begin
      if Is_Trace_Enabled then
         Cl.Write_Formatted_String (Text => Exception_Information (An_Exception), Marker => Marker_Special);
         Cl.Write_Formatted_String (Text => "Function: " & Entity, Marker => Marker_Special);
         Cl.Write_Formatted_String (Text => "Source: " & Source, Marker => Marker_Special);
         --       Cl.Write_Formatted_String (
         --          Text   => G_TB.Symbolic_Traceback (An_Exception),
         --          Marker => Marker_Special);
      end if;
   end Write;

   ---
   --  Write Help for Commandline Options parsed from Trace
   --
   procedure Write_Commandline_Help is
      use AdaCL.Command_Line.GetOpt;
   begin
      Text_IO.New_Line;
      Text_IO.Put_Line ("Trace options:");
      Text_IO.New_Line;
      Put_Help_Line (Trace_Verbose (1), Trace_Verbose, "verbose operation.");
      Put_Help_Line (Trace_Opt, Trace_Opt_On, "activate trace.");
      Put_Help_Line (Trace_Opt, Trace_Opt_NoPrefix, "activate trace without prefix.");
      Text_IO.New_Line;
      Put_Help_Line (Trace_Opt_To, Trace_Opt_To_Err1, "trace in stderr.");
      Put_Help_Line (Trace_Opt_To, Trace_Opt_To_Std1, "trace in stdout.");
      Put_Help_Line (Trace_Opt_To, Trace_Opt_To_File, "trace to file.");
      Text_IO.New_Line;
      Put_Help_Line (Trace_Opt_File, "Filename", "trace file.");
      Text_IO.New_Line;
   end Write_Commandline_Help;

   ---
   --  Create a memory dump
   --
   --  String to be written
   procedure Write_Dump (An_Address : in System.Address; Size_In_Byte : in System.Storage_Elements.Storage_Count) is
      use System.Storage_Elements;
   begin
      Write ("Address: ", An_Address);
      Write ("Lenght : " & Size_In_Byte'Image);

      if Is_Trace_Enabled then
         Dump :
         declare
            function Element_Image is new AdaCL.Strings.Hex.Generic_Image (System.Storage_Elements.Storage_Element);

            use Ada.Strings.Fixed;

            Data : Storage_Array (0 .. Size_In_Byte - 1);
            for Data'Address use An_Address;
            pragma Import (Ada, Data);

            Line_Len     : constant := 16;
            Byte_Len     : constant := 2;
            Address_Len  : constant := 16;
            Byte_Offset  : constant := 10 + Address_Len + 5;   --  «Dump   : [00007FF7B3740130] : »
            ASCII_Offset : constant := Byte_Offset + Line_Len * (Byte_Len + 1) + 1;
            Text_Len     : constant := ASCII_Offset + Line_Len;

            Text     : String (1 .. Text_Len);
            Line     : Storage_Offset := Data'First;
            Col      : Storage_Offset := Data'First;
            Char     : Character;
            Byte_Col : Integer;
         begin
            Dump_Line :
            while Line <= Data'Last loop
               declare
                  Address_Text : constant String := Address_Image (To_Integer (An_Address + Line));
               begin
                  Move (Source => "Dump   : [" & Address_Text & "] : ", Target => Text);
               end;

               Col      := 0;
               Byte_Col := Byte_Offset;

               Dump_Column :
               while Col < Line_Len and then Col + Line < Size_In_Byte loop
                  declare
                     Byte_Text : constant String := Element_Image (Data (Line + Col));
                  begin
                     Text (Byte_Col .. Byte_Col + 1) := Byte_Text;
                  end;

                  Char := Character'Val (Data (Line + Col));

                  if Ada.Characters.Handling.Is_Graphic (Char) then
                     Text (Natural (ASCII_Offset + Col)) := Char;
                  else
                     Text (Natural (ASCII_Offset + Col)) := '.';
                  end if;

                  Col      := Col + 1;
                  Byte_Col := Byte_Col + (Byte_Len + 1);
               end loop Dump_Column;

               Cl.Write_Formatted_String (Text => Text, Marker => Marker_Std);
               Line := Line + Line_Len;
            end loop Dump_Line;
         end Dump;
      end if;
   end Write_Dump;

   ---
   --  Create a memory dump. This Dump takes size in bits.
   --
   --: @param An_Address   String to be written
   --: @param Size_In_Bits Size in Storage_Elements.
   procedure Write_Dump (An_Address : in System.Address; Size_In_Bits : in Integer) is
      use System.Storage_Elements;

      Size : Storage_Count := Storage_Count (Size_In_Bits / System.Storage_Unit);
   begin
      if (Size_In_Bits mod System.Storage_Unit) /= 0 then
         Size := Size + 1;
      end if;

      Write_Dump (An_Address, Size);
   end Write_Dump;

   ---
   --  Write an IString using Write_Formatted_String after adding the appropriate padding for indentation.
   --
   --: @param Text  String to be written
   procedure Write_Error (Text : in String) is
   begin
      if not Is_Trace_Enabled or else Trace_Destination /= Standard_Error then
         Text_IO.Put_Line (Text_IO.Standard_Error, Text);
      end if;

      if Is_Trace_Enabled then
         Cl.Write_Formatted_String (Text => Text, Marker => Marker_Std);
      end if;
   end Write_Error;

   ---
   --  Write an IString using Write_Formatted_String after adding the appropriate padding for indentation.
   --
   --: @param Text  String to be written
   procedure Write_Error (Text : in Unbounded.Unbounded_String) is
      use Ada.Strings.Unbounded;
   begin
      if not Is_Trace_Enabled or else Trace_Destination /= Standard_Error then
         Text_IO.Put_Line (Text_IO.Standard_Error, To_String (Text));
      end if;

      if Is_Trace_Enabled then
         Cl.Write_Formatted_String (Text => To_String (Text), Marker => Marker_Std);
      end if;
   end Write_Error;

   ---
   --  Write an Exception to the Trace
   --
   --: @param An_Exception   String to be written
   procedure Write_Error (An_Exception : in Ada.Exceptions.Exception_Occurrence) is
      use Ada.Exceptions;
   begin
      if not Is_Trace_Enabled or else Trace_Destination /= Standard_Error then
         Text_IO.Put_Line (Text_IO.Standard_Error, Exception_Information (An_Exception));
         --              Text_IO.Put_Line (Text_IO.Standard_Error,
         --  G_TB.Symbolic_Traceback (An_Exception));
      end if;

      Write (An_Exception);
   end Write_Error;

   ---
   --  Write an Exception to the Trace
   --
   --: @param An_Exception String to be written
   --: @param Entity       Procedure in which the exception was caught
   --: @param Source       Source File in which Entity is located.
   procedure Write_Error
      (An_Exception : in Ada.Exceptions.Exception_Occurrence;
       Entity       : in String;
       Source       : in String)
   is
      use Ada.Exceptions;
   begin
      if not Is_Trace_Enabled or else Trace_Destination /= Standard_Error then
         Text_IO.New_Line (Text_IO.Standard_Error);
         Text_IO.Put (Text_IO.Standard_Error, Exception_Information (An_Exception));
         Text_IO.Put_Line (Text_IO.Standard_Error, "Function: " & Entity);
         Text_IO.Put_Line (Text_IO.Standard_Error, "Source: " & Source);
         --              Text_IO.Put_Line (Text_IO.Standard_Error,
         --  G_TB.Symbolic_Traceback (An_Exception));
      end if;

      Write
         (An_Exception => An_Exception,
          Entity       => Entity,
          Source       => Source);
   end Write_Error;

   ---
   --  When verbose is aktivated then an empty line is written to Standart_Output
   --
   procedure Write_Info is
   begin
      if Is_Verbose_Enabled then
         Text_IO.New_Line (Text_IO.Standard_Output);
      end if;
   end Write_Info;

   ---
   --  Write an IString using writeFormattedString after adding the appropriate padding for indentation.
   --
   --  When verbose is aktivated then the string is written to Standart_Output as well.
   --
   --: @param Text  String to be written
   procedure Write_Info (Text : in String) is
   begin
      if Is_Verbose_Enabled and then (not Is_Trace_Enabled or else Trace_Destination /= Standard_Output) then
         Text_IO.Put_Line (Text_IO.Standard_Output, Text);
      end if;

      if Is_Trace_Enabled then
         Cl.Write_Formatted_String (Text => Text, Marker => Marker_Std);
      end if;
   end Write_Info;

   ---
   --  When verbose is aktivated then the character is written to Standart_Output.
   --
   --: @param Text  character to be written
   procedure Write_Info (Text : in Character) is
   begin
      if Is_Verbose_Enabled then
         Text_IO.Put (Text_IO.Standard_Output, Text);
      end if;
   end Write_Info;

   ---
   --  Write an IString using writeFormattedString after adding the appropriate padding for indentation.
   --
   --  When verbose is aktivated then the string is written to Standart_Output as well.
   --
   --: @param Text  String to be written
   procedure Write_Info (Text : in Unbounded.Unbounded_String) is
      use Ada.Strings.Unbounded;
   begin
      if Is_Verbose_Enabled and then (not Is_Trace_Enabled or else Trace_Destination /= Standard_Output) then
         Text_IO.Put_Line (Text_IO.Standard_Output, To_String (Text));
      end if;

      if Is_Trace_Enabled then
         Cl.Write_Formatted_String (Text => To_String (Text), Marker => Marker_Std);
      end if;
   end Write_Info;

   ---
   --  Write to queue - not supported yet.
   --
   procedure Write_To_File is
   begin
      Cl.Set_Trace_Location (File);
   end Write_To_File;

   ---
   --  Set Filename for Trace File
   --
   procedure Write_To_File (New_Filename : in String) is
   begin
      Cl.Set_Filename (New_Filename);
      Cl.Set_Trace_Location (File);
   end Write_To_File;

   ---
   --  Write to queue - not supported yet.
   --
   procedure Write_To_Queue is
   begin
      Cl.Set_Trace_Location (Queue);
   end Write_To_Queue;

   ---
   --  Write to Standart Error
   --
   procedure Write_To_Standard_Error is
   begin
      Cl.Set_Trace_Location (Standard_Error);
   end Write_To_Standard_Error;

   ---
   --  Write to Standart Error
   --
   procedure Write_To_Standard_Output is
   begin
      Cl.Set_Trace_Location (Standard_Output);
   end Write_To_Standard_Output;

   ---
   --  Write an string using Write_Formatted_String after adding the appropriate padding for indentation.
   --
   --: @param Text  String to be written
   procedure Write_Wide (Text : in Wide_String) is
   begin
      if Is_Trace_Enabled then
         Cl.Write_Formatted_String (Text => Ada.Characters.Conversions.To_String (Text), Marker => Marker_Std);
      end if;
   end Write_Wide;

begin
   Cl.Initialize;
   pragma Debug (Enable_Trace);
   pragma Debug (Write_To_File);
end AdaCL.Trace;

---------------------------------------------------------------- {{{ ----------
--: vim: set textwidth=0 nowrap tabstop=8 shiftwidth=3 softtabstop=3 expandtab :
--: vim: set filetype=ada fileencoding=utf-8 fileformat=unix foldmethod=expr :
--: vim: set spell spelllang=en_gb