-------------------------------------------------------------- {{{1 ---------- --: Copyright © 2007 … 2024 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.Wide_Wide_Characters.Handling; with Ada.Containers.Hashed_Maps; with Ada.Environment_Variables; with Ada.Characters.Conversions; with Ada.Strings.Wide_Wide_Fixed; with Ada.Strings.Wide_Wide_Maps; with Ada.Task_Identification; with Ada.Wide_Wide_Text_IO; with AdaCL.Command_Line.GetOpt; with AdaCL.Wide_Wide_Strings.Hex; with AdaCL.Strings; with AdaCL.Wide_Wide_Strings; with AdaCL.To_Wide_Wide_String; with AdaCL.To_UTF_String; -- -- @summary -- Ada Class Library -- Trace -- -- @description -- package body AdaCL.Trace is --------------------------------------------------------------------------- use type Ada.Strings.Unbounded.Unbounded_String; --------------------------------------------------------------------------- package Text_IO renames Ada.Wide_Wide_Text_IO; package Unbounded renames Ada.Strings.Unbounded; package W_Unbounded renames Ada.Strings.Wide_Unbounded; package WW_Unbounded renames Ada.Strings.Wide_Wide_Unbounded; package Conversions renames Ada.Characters.Conversions; package Env renames Ada.Environment_Variables; --------------------------------------------------------------------------- function Address_Image is new AdaCL.Wide_Wide_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 with Inline; --- -- Get Trace line counter -- function Get_Sequence return Natural with Inline; procedure Set_Filename (New_Filename : in String) with Inline; --- -- 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 with Inline; --- -- Trace is On -- procedure Set_On (On : Boolean) with Inline; --- -- Trace is On -- function Get_Verbose return Boolean with Inline; --- -- 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) with Inline; --- -- Trace with line numbers. -- function Get_Write_Line_Number return Boolean with Inline; --- -- Trace with line numbers. -- procedure Set_Write_Line_Number (Write_Line_Number : Boolean) with Inline; --- -- Trace with thread profex and optional line numbers. -- function Get_Write_Prefix return Boolean with Inline; --- -- Trace with thread profex and optional line numbers. -- procedure Set_Write_Prefix (Write_Prefix : Boolean) with Inline; --- -- Trace Destination -- function Get_Trace_Location return Destination with Inline; --- -- Trace Destination -- procedure Set_Trace_Location (Location : in Destination) with Inline; --- -- Write Formated Text -- --: @param Text Text to be written --: @param Marker Marker to be used procedure Write_Formatted_String (Text : in Wide_Wide_String; Marker : in Wide_Wide_Character); --- -- Write Text -- --: @param Text Text to be written procedure Write_String (Text : in Wide_Wide_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 Wide_Wide_String := "verbose"; Trace_Opt : constant Wide_Wide_String := "TRACE"; Trace_Opt_File : constant Wide_Wide_String := "TRACEFILE"; Trace_Opt_NoPrefix : constant Wide_Wide_String := "NOPREFIX"; Trace_Opt_On : constant Wide_Wide_String := "ON"; Trace_Opt_To : constant Wide_Wide_String := "TRACETO"; Trace_Opt_To_Err1 : constant Wide_Wide_String := "STDERR"; Trace_Opt_To_Err2 : constant Wide_Wide_String := "ERR"; Trace_Opt_To_File : constant Wide_Wide_String := "FILE"; Trace_Opt_To_Queue1 : constant Wide_Wide_String := "QUEUE"; Trace_Opt_To_Queue2 : constant Wide_Wide_String := "PMPRINTF"; Trace_Opt_To_Std1 : constant Wide_Wide_String := "STDOUT"; Trace_Opt_To_Std2 : constant Wide_Wide_String := "OUT"; Trace_Env_Prefix : constant String := "ADACL_"; Trace_Env : constant String := Trace_Env_Prefix & "TRACE"; Trace_Env_File : constant String := Trace_Env_Prefix & "TRACEFILE"; Trace_Env_To : constant String := Trace_Env_Prefix & "TRACETO"; Marker_Std : constant Wide_Wide_Character := '>'; Marker_Special : constant Wide_Wide_Character := '!'; Marker_Outdent : constant Wide_Wide_Character := '-'; Marker_Indent : constant Wide_Wide_Character := '+'; --------------------------------------------------------------------------- -- -- 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 : " & To_Wide_Wide_String (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; procedure Set_Trace (Argument : in Wide_Wide_String) is begin 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; end Set_Trace; procedure Set_Trace_To (Argument : in Wide_Wide_String) is begin 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; end Set_Trace_To; procedure Set_Trace_File (Argument : in String) is begin if Argument'Length > 0 then Set_Filename (Argument); end if; end Set_Trace_File; Options : AdaCL.Command_Line.GetOpt.Object; Found : FoundFlag; begin if Env.Exists (Trace_Env) then Set_Trace (To_Wide_Wide_String (Env.Value (Trace_Env))); end if; if Env.Exists (Trace_Env_To) then Set_Trace_To (To_Wide_Wide_String (Env.Value (Trace_Env_To))); end if; if Env.Exists (Trace_Env_File) then Set_Trace_File (Env.Value (Trace_Env_File)); end if; Options.Set_Pattern (":" & Trace_Verbose (1)); Options.Set_ExceptionOnError (False); Options.Set_ExtractGNU (True); ParseCL : loop Options.Next (Found); exit ParseCL when Found = EndOfOptions; if Found = GNU_Style then Analyze_GNU : declare Option : constant Wide_Wide_String := Options.Get_GNUOption; Argument : constant Wide_Wide_String := Options.Get_Argument; begin if Option = Trace_Opt then Set_Trace (Argument); elsif Option = Trace_Opt_To then Set_Trace_To (Argument); elsif Option = Trace_Opt_File then Set_Trace_File (AdaCL.To_UTF_String (Argument)); elsif Option = Trace_Verbose then Verbose := True; end if; end Analyze_GNU; elsif Found = WithoutArgument then Analyze_Without : declare Option : constant Wide_Wide_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 Wide_Wide_String; Marker : in Wide_Wide_Character) is use Ada.Strings.Wide_Wide_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_Wide_Wide_String := To_Unbounded_Wide_Wide_String (Marker & ' ' & Text); StrPrefix : Unbounded_Wide_Wide_String := Thread.Indent * ' '; StrLF : constant Wide_Wide_String := [1 => Wide_Wide_Character'Val (10)]; begin if Write_Prefix then Prefix : declare use Ada.Strings.Wide_Wide_Fixed; StrThread_ID : constant Wide_Wide_String := Head (Thread.Thread_No'Wide_Wide_Image, 5); StrLineNo : constant Wide_Wide_String := Head (Get_Sequence'Wide_Wide_Image, 5); begin StrPrefix := StrLineNo & ":" & StrThread_ID & ":" & StrPrefix; end Prefix; end if; AdaCL.Wide_Wide_Strings.Append_All (Source => StrOut, Search => StrLF, New_Item => To_Wide_Wide_String (StrPrefix), Mapping => Ada.Strings.Wide_Wide_Maps.Identity); StrOut := StrPrefix & StrOut; Write_String (To_Wide_Wide_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 Wide_Wide_String) is use Ada.Wide_Wide_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 => To_Wide_Wide_String (This.Trace_Name), Marker => Marker_Indent); end if; end if; end Adjust; procedure Initialize is begin Cl.Initialize; end Initialize; --- -- 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_With_Entity (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_With_File (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 => To_Wide_Wide_String (This.Trace_Name), Marker => Marker_Outdent); end if; end if; end Finalize; 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 => To_Wide_Wide_String (Retval.Trace_Name), Marker => Marker_Indent); Cl.Reset_Last_Function (Name); end if; return Retval; end Function_Trace; procedure Entering (Name : in String) is begin if Is_Trace_Enabled then Cl.Write_Formatted_String (Text => To_Wide_Wide_String (Name), Marker => Marker_Indent); end if; return; end Entering; procedure Entering (Entity : in String := GNAT.Source_Info.Enclosing_Entity; Source : in String := GNAT.Source_Info.Source_Location) is begin Entering (Name => Entity & ':' & Source); end Entering; procedure Entering (In_Parameter : in String; Entity : in String := GNAT.Source_Info.Enclosing_Entity; Source : in String := GNAT.Source_Info.Source_Location) is begin Entering (Name => Entity & ':' & Source & '[' & In_Parameter & ']'); end Entering; procedure Entering (In_Parameters : in Parameter_Vectors.Vector; Entity : in String := GNAT.Source_Info.Enclosing_Entity; Source : in String := GNAT.Source_Info.Source_Location) is begin Entering (Name => Entity & ':' & Source & In_Parameters'Image); end Entering; procedure Exiting (Name : in String) is begin if Is_Trace_Enabled then Cl.Write_Formatted_String (Text => To_Wide_Wide_String (Name), Marker => Marker_Outdent); end if; return; end Exiting; procedure Exiting (Entity : in String := GNAT.Source_Info.Enclosing_Entity; Source : in String := GNAT.Source_Info.Source_Location) is begin Exiting (Name => Entity & ':' & Source); end Exiting; procedure Exiting (Out_Parameter : in String; Entity : in String := GNAT.Source_Info.Enclosing_Entity; Source : in String := GNAT.Source_Info.Source_Location) is begin Exiting (Name => Entity & ':' & Source & " (" & Out_Parameter & ')'); end Exiting; procedure Exiting (Out_Parameters : in Parameter_Vectors.Vector; Entity : in String := GNAT.Source_Info.Enclosing_Entity; Source : in String := GNAT.Source_Info.Source_Location) is begin Exiting (Name => Entity & ':' & Source & Out_Parameters'Image); end Exiting; --- -- 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_With_Entity (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_With_Entity; --- -- 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_With_File (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_With_File; --- -- 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_With_Entity (Raising : in Ada.Exceptions.Exception_Id := Ada.Assertions.Assertion_Error'Identity; Message : in Wide_Wide_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_Wide_Wide (" with Message " & Message); Write (" for Entity " & Entity); Write (" in Source " & Source); Raise_Exception (E => Raising, Message => To_UTF_String (Message) & " Entity :" & Entity & "." & " Source :" & Source & "."); end Raise_Exception_With_Entity; --- -- 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_With_File (Raising : in Ada.Exceptions.Exception_Id := Ada.Assertions.Assertion_Error'Identity; Message : in Wide_Wide_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_Wide_Wide (" with Message " & Message); Write (" in File " & Source); Write (" in Line " & Line'Image); Raise_Exception (E => Raising, Message => To_UTF_String (Message) & "." & " Source :" & Source & " Line :" & Line'Image & "."); end Raise_Exception_With_File; --- -- Check the Trace Destination -- function Trace_Destination return Destination is (Cl.Get_Trace_Location); procedure Write (Text : in String) is begin if Is_Trace_Enabled then Cl.Write_Formatted_String (Text => Conversions.To_Wide_Wide_String (Text), Marker => Marker_Std); end if; end Write; --- -- 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 => Conversions.To_Wide_Wide_String (Text), Marker => Marker_Std); end if; end Write_Wide; --- -- Write an string using Write_Formatted_String after adding the appropriate padding for indentation. -- --: @param Text String to be written procedure Write_Wide_Wide (Text : in Wide_Wide_String) is begin if Is_Trace_Enabled then Cl.Write_Formatted_String (Text => Text, Marker => Marker_Std); end if; end Write_Wide_Wide; --- -- 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 Wide_Wide_String := Address_Image (System.Storage_Elements.To_Integer (An_Address)); begin Cl.Write_Formatted_String (Text => To_Wide_Wide_String (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_Wide_Wide_String (To_String (Text)), Marker => Marker_Std); 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 W_Unbounded.Unbounded_Wide_String) is begin if Is_Trace_Enabled then Cl.Write_Formatted_String (Text => Conversions.To_Wide_Wide_String (W_Unbounded.To_Wide_String (Text)), Marker => Marker_Std); 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 WW_Unbounded.Unbounded_Wide_Wide_String) is begin if Is_Trace_Enabled then Cl.Write_Formatted_String (Text => WW_Unbounded.To_Wide_Wide_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 => To_Wide_Wide_String (Exception_Information (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 => Conversions.To_Wide_Wide_String (Exception_Information (An_Exception)), Marker => Marker_Special); Cl.Write_Formatted_String (Text => "Function: " & Conversions.To_Wide_Wide_String (Entity), Marker => Marker_Special); Cl.Write_Formatted_String (Text => "Source: " & Conversions.To_Wide_Wide_String (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."); Put_Help_Line (Evironment_Variable => Trace_Env); 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."); Put_Help_Line (Evironment_Variable => Trace_Env_To); Text_IO.New_Line; Put_Help_Line (Trace_Opt_File, "Filename", "trace file."); Put_Help_Line (Evironment_Variable => Trace_Env_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 ("Length : " & Size_In_Byte'Image); if Is_Trace_Enabled then Dump : declare function Element_Image is new AdaCL.Wide_Wide_Strings.Hex.Generic_Image (System.Storage_Elements.Storage_Element); use Ada.Strings.Wide_Wide_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 : Wide_Wide_String (1 .. Text_Len); Line : Storage_Offset := Data'First; Col : Storage_Offset := Data'First; Char : Wide_Wide_Character; Byte_Col : Integer; begin Dump_Line : while Line <= Data'Last loop declare Address_Text : constant Wide_Wide_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 Wide_Wide_String := Element_Image (Data (Line + Col)); begin Text (Byte_Col .. Byte_Col + 1) := Byte_Text; end; Char := Wide_Wide_Character'Val (Data (Line + Col)); if Ada.Wide_Wide_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_Len + 1); end loop Dump_Column; Cl.Write_Formatted_String (Text => Text, Marker => Marker_Std); 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 := @ + 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, To_Wide_Wide_String (Text)); end if; if Is_Trace_Enabled then Cl.Write_Formatted_String (Text => Conversions.To_Wide_Wide_String (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 Wide_String) is begin if not Is_Trace_Enabled or else Trace_Destination /= Standard_Error then Text_IO.Put_Line (Text_IO.Standard_Error, Conversions.To_Wide_Wide_String (Text)); end if; if Is_Trace_Enabled then Cl.Write_Formatted_String (Text => Conversions.To_Wide_Wide_String (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 Wide_Wide_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 WW_Unbounded.Unbounded_Wide_Wide_String) is begin if not Is_Trace_Enabled or else Trace_Destination /= Standard_Error then Text_IO.Put_Line (Text_IO.Standard_Error, WW_Unbounded.To_Wide_Wide_String (Text)); end if; if Is_Trace_Enabled then Cl.Write_Formatted_String (Text => WW_Unbounded.To_Wide_Wide_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, Conversions.To_Wide_Wide_String (Exception_Information (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, Conversions.To_Wide_Wide_String (Exception_Information (An_Exception))); Text_IO.Put_Line (Text_IO.Standard_Error, "Function: " & Conversions.To_Wide_Wide_String (Entity)); Text_IO.Put_Line (Text_IO.Standard_Error, "Source: " & Conversions.To_Wide_Wide_String (Source)); 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, Conversions.To_Wide_Wide_String (Text)); end if; if Is_Trace_Enabled then Cl.Write_Formatted_String (Text => Conversions.To_Wide_Wide_String (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, Conversions.To_Wide_Wide_Character (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, Conversions.To_Wide_Wide_String (To_String (Text))); end if; if Is_Trace_Enabled then Cl.Write_Formatted_String (Text => Conversions.To_Wide_Wide_String (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; 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