-----------------------------------------------------------------------
--  security-contexts -- Context to provide security information and verify permissions
--  Copyright (C) 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Finalization;

with Security.Permissions;
with Security.Policies;

--  == Security Context ==
--  The security context provides contextual information for a security controller to
--  verify that a permission is granted.
--  This security context is used as follows:
--
--    * An instance of the security context is declared within a function/procedure as
--      a local variable
--
--    * This instance will be associated with the current thread through a task attribute
--
--    * The security context is populated with information to identify the current user,
--      his roles, permissions and other information that could be used by security controllers
--
--    * To verify a permission, the current security context is retrieved and the
--      Has_Permission operation is called,
--
--    * The Has_Permission will first look in a small cache stored in the security context.
--
--    * When not present in the cache, it will use the security manager to find the
--      security controller associated with the permission to verify
--
--    * The security controller will be called with the security context to check the permission.
--      The whole job of checking the permission is done by the security controller.
--      The security controller retrieves information from the security context to decide
--      whether the permission is granted or not.
--
--    * The result produced by the security controller is then saved in the local cache.
--
package Security.Contexts is

   Invalid_Context : exception;
   Invalid_Policy  : exception;

   type Security_Context is new Ada.Finalization.Limited_Controlled with private;
   type Security_Context_Access is access all Security_Context'Class;

   --  Get the application associated with the current service operation.
   function Get_User_Principal (Context : in Security_Context'Class)
                                return Security.Principal_Access;
   pragma Inline_Always (Get_User_Principal);

   --  Get the permission manager.
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Policies.Policy_Manager_Access;
   pragma Inline_Always (Get_Permission_Manager);

   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   function Get_Policy (Context : in Security_Context'Class;
                        Name    : in String) return Security.Policies.Policy_Access;

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission'Class;
                             Result     : out Boolean);

   --  Initializes the service context.  By creating the Security_Context variable,
   --  the instance will be associated with the current task attribute.  If the current task
   --  already has a security context, the new security context is installed, the old one
   --  being kept.
   overriding
   procedure Initialize (Context : in out Security_Context);

   --  Finalize the security context releases any object.  The previous security context is
   --  restored to the current task attribute.
   overriding
   procedure Finalize (Context : in out Security_Context);

   --  Set the current application and user context.
   procedure Set_Context (Context   : in out Security_Context;
                          Manager   : in Security.Policies.Policy_Manager_Access;
                          Principal : in Security.Principal_Access);

   --  Set a policy context information represented by Value and associated with
   --  the Policy.
   procedure Set_Policy_Context (Context   : in out Security_Context;
                                 Policy    : in Security.Policies.Policy_Access;
                                 Value     : in Security.Policies.Policy_Context_Access);

   --  Get the policy context information registered for the given security policy in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   --  Raises Invalid_Policy if the policy was not set.
   function Get_Policy_Context (Context  : in Security_Context;
                                Policy   : in Security.Policies.Policy_Access)
                                return Security.Policies.Policy_Context_Access;

   --  Returns True if a context information was registered for the security policy.
   function Has_Policy_Context (Context : in Security_Context;
                                Policy  : in Security.Policies.Policy_Access) return Boolean;

   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   function Current return Security_Context_Access;
   pragma Inline_Always (Current);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   function Has_Permission (Permission : in Security.Permissions.Permission_Index) return Boolean;

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   function Has_Permission (Permission : in String) return Boolean;

private

--     type Permission_Cache is record
--        Perm   : Security.Permissions.Permission_Type;
--        Result : Boolean;
--     end record;

   type Security_Context is new Ada.Finalization.Limited_Controlled with record
      Previous    : Security_Context_Access := null;
      Manager     : Security.Policies.Policy_Manager_Access := null;
      Principal   : Security.Principal_Access := null;
      Contexts    : Security.Policies.Policy_Context_Array_Access := null;
   end record;

end Security.Contexts;

-----------------------------------------------------------------------
--  security-contexts -- Context to provide security information and verify permissions
--  Copyright (C) 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Finalization;

with Security.Permissions;
with Security.Policies;

--  == Security Context ==
--  The security context provides contextual information for a security controller to
--  verify that a permission is granted.
--  This security context is used as follows:
--
--    * An instance of the security context is declared within a function/procedure as
--      a local variable.
--    * This instance will be associated with the current thread through a task attribute
--    * The security context is populated with information to identify the current user,
--      his roles, permissions and other information that could be used by security controllers
--    * To verify a permission, the current security context is retrieved and the
--      Has_Permission operation is called,
--    * The Has_Permission will first look in a small cache stored in the security context.
--    * When not present in the cache, it will use the security manager to find the
--      security controller associated with the permission to verify
--    * The security controller will be called with the security context to check the permission.
--      The whole job of checking the permission is done by the security controller.
--      The security controller retrieves information from the security context to decide
--      whether the permission is granted or not.
--    * The result produced by the security controller is then saved in the local cache.
--
--  For example the security context is declared as follows:
--
--    Context : Security.Contexts.Security_Context;
--
--  A security policy and a principal must be set in the security context.  The security policy
--  defines the rules that govern the security and the principal identifies the current user.
--
--    Context.Set_Context (Policy_Manager, User);
--
--  A permission is checked by using the <tt>Has_Permission</tt> operation:
--
--    if Security.Contexts.Has_Permission (Perm_Create_Workspace.Permission);
--
package Security.Contexts is

   Invalid_Context : exception;
   Invalid_Policy  : exception;

   type Security_Context is new Ada.Finalization.Limited_Controlled with private;
   type Security_Context_Access is access all Security_Context'Class;

   --  Get the application associated with the current service operation.
   function Get_User_Principal (Context : in Security_Context'Class)
                                return Security.Principal_Access;
   pragma Inline_Always (Get_User_Principal);

   --  Get the permission manager.
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Policies.Policy_Manager_Access;
   pragma Inline_Always (Get_Permission_Manager);

   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   function Get_Policy (Context : in Security_Context'Class;
                        Name    : in String) return Security.Policies.Policy_Access;

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission'Class;
                             Result     : out Boolean);

   --  Initializes the service context.  By creating the Security_Context variable,
   --  the instance will be associated with the current task attribute.  If the current task
   --  already has a security context, the new security context is installed, the old one
   --  being kept.
   overriding
   procedure Initialize (Context : in out Security_Context);

   --  Finalize the security context releases any object.  The previous security context is
   --  restored to the current task attribute.
   overriding
   procedure Finalize (Context : in out Security_Context);

   --  Set the current application and user context.
   procedure Set_Context (Context   : in out Security_Context;
                          Manager   : in Security.Policies.Policy_Manager_Access;
                          Principal : in Security.Principal_Access);

   --  Set a policy context information represented by Value and associated with
   --  the Policy.
   procedure Set_Policy_Context (Context   : in out Security_Context;
                                 Policy    : in Security.Policies.Policy_Access;
                                 Value     : in Security.Policies.Policy_Context_Access);

   --  Get the policy context information registered for the given security policy in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   --  Raises Invalid_Policy if the policy was not set.
   function Get_Policy_Context (Context  : in Security_Context;
                                Policy   : in Security.Policies.Policy_Access)
                                return Security.Policies.Policy_Context_Access;

   --  Returns True if a context information was registered for the security policy.
   function Has_Policy_Context (Context : in Security_Context;
                                Policy  : in Security.Policies.Policy_Access) return Boolean;

   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   function Current return Security_Context_Access;
   pragma Inline_Always (Current);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   function Has_Permission (Permission : in Security.Permissions.Permission_Index) return Boolean;

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   function Has_Permission (Permission : in String) return Boolean;

private

--     type Permission_Cache is record
--        Perm   : Security.Permissions.Permission_Type;
--        Result : Boolean;
--     end record;

   type Security_Context is new Ada.Finalization.Limited_Controlled with record
      Previous    : Security_Context_Access := null;
      Manager     : Security.Policies.Policy_Manager_Access := null;
      Principal   : Security.Principal_Access := null;
      Contexts    : Security.Policies.Policy_Context_Array_Access := null;
   end record;

end Security.Contexts;

Update the documentation

Update the documentation


-----------------------------------------------------------------------
--  ADO Drivers -- Database Drivers
--  Copyright (C) 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Properties;

--  The <b>ADO.Drivers</b> package represents the database driver that will create
--  database connections and provide the database specific implementation.
package ADO.Drivers is

   use Ada.Strings.Unbounded;

   --  Raised when the connection URI is invalid.
   Connection_Error : exception;

   --  Raised for all errors reported by the database
   DB_Error : exception;

   type Driver_Index is new Natural range 0 .. 4;

   --  Initialize the drivers and the library by reading the property file
   --  and configure the runtime with it.
   procedure Initialize (Config : in String);

   --  Initialize the drivers and the library and configure the runtime with the given properties.
   procedure Initialize (Config : in Util.Properties.Manager'Class);

   --  Initialize the drivers which are available.
   procedure Initialize;

   --  Get the global configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   function Get_Config (Name    : in String;
                        Default : in String := "") return String;

end ADO.Drivers;

-----------------------------------------------------------------------
--  ADO Drivers -- Database Drivers
--  Copyright (C) 2010, 2011, 2012, 2013 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Properties;

--  The <b>ADO.Drivers</b> package represents the database driver that will create
--  database connections and provide the database specific implementation.
package ADO.Drivers is

   use Ada.Strings.Unbounded;

   --  Raised when the connection URI is invalid.
   Connection_Error : exception;

   --  Raised for all errors reported by the database
   DB_Error : exception;

   type Driver_Index is new Natural range 0 .. 4;

   --  Initialize the drivers and the library by reading the property file
   --  and configure the runtime with it.
   procedure Initialize (Config : in String);

   --  Initialize the drivers and the library and configure the runtime with the given properties.
   procedure Initialize (Config : in Util.Properties.Manager'Class);

   --  Get the global configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   function Get_Config (Name    : in String;
                        Default : in String := "") return String;

end ADO.Drivers;

Move the Initialize operation in a separate library


-----------------------------------------------------------------------
--  mat-frames - Representation of stack frames
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with Interfaces; use Interfaces;
with MAT.Types; use MAT.Types;
package body MAT.Frames is

   procedure Free is
      new Ada.Unchecked_Deallocation (Frame, Frame_Type);

   --  ------------------------------
   --  Return the parent frame.
   --  ------------------------------
   function Parent (Frame : in Frame_Type) return Frame_Type is
   begin
      if Frame = null then
         return null;
      else
         return Frame.Parent;
      end if;
   end Parent;

   --  ------------------------------
   --  Returns the backtrace of the current frame (up to the root).
   --  ------------------------------
   function Backtrace (Frame :  in Frame_Type) return Frame_Table is
      Pc      : Frame_Table (1 .. Frame.Depth);
      Current : Frame_Type := Frame;
      Pos     : Natural   := Current.Depth;
      New_Pos : Natural;
   begin
      while Current /= null and Pos /= 0 loop
         New_Pos := Pos - Current.Local_Depth + 1;
         Pc (New_Pos .. Pos) := Current.Calls (1 .. Current.Local_Depth);
         Pos     := New_Pos - 1;
         Current := Current.Parent;
      end loop;
      return Pc;
   end Backtrace;

   --  ------------------------------
   --  Returns the number of children in the frame.
   --  When recursive is true, compute in the sub-tree.
   --  ------------------------------
   function Count_Children (Frame     : in Frame_Type;
                            Recursive : in Boolean := False) return Natural is
      Count : Natural := 0;
      Child : Frame_Type;
   begin
      if Frame /= null then
         Child := Frame.Children;
         while Child /= null loop
            Count := Count + 1;
            if Recursive then
               declare
                  N : Natural := Count_Children (Child, True);
               begin
                  if N > 0 then
                     N := N - 1;
                  end if;
                  Count := Count + N;
               end;
            end if;
            Child := Child.Next;
         end loop;
      end if;
      return Count;
   end Count_Children;

   --  ------------------------------
   --  Returns all the direct calls made by the current frame.
   --  ------------------------------
   function Calls (Frame : in Frame_Type) return Frame_Table is
      Nb_Calls : Natural   := Count_Children (Frame);
      Pc       : Frame_Table (1 .. Nb_Calls);
   begin
      if Frame /= null then
         declare
            Child : Frame_Type := Frame.Children;
            Pos   : Natural   := 1;
         begin
            while Child /= null loop
               Pc (Pos) := Child.Calls (1);
               Pos   := Pos + 1;
               Child := Child.Next;
            end loop;
         end;
      end if;
      return Pc;
   end Calls;

   --  ------------------------------
   --  Returns the current stack depth (# of calls from the root
   --  to reach the frame).
   --  ------------------------------
   function Current_Depth (Frame : in Frame_Type) return Natural is
   begin
      if Frame = null then
         return 0;
      else
         return Frame.Depth;
      end if;
   end Current_Depth;

   --  ------------------------------
   --  Create a root for stack frame representation.
   --  ------------------------------
   function Create_Root return Frame_Type is
   begin
      return new Frame;
   end Create_Root;

   --  ------------------------------
   --  Destroy the frame tree recursively.
   --  ------------------------------
   procedure Destroy (Frame : in out Frame_Type) is
      F : Frame_Type;
   begin
      if Frame = null then
         return;
      end if;
      --  Destroy its children recursively.
      while Frame.Children /= null loop
         F := Frame.Children;
         Destroy (F);
      end loop;

      --  Unlink from parent list.
      if Frame.Parent /= null then
         F := Frame.Parent.Children;
         if F = Frame then
            Frame.Parent.Children := Frame.Next;
         else
            while F /= null and F.Next /= Frame loop
               F := F.Next;
            end loop;
            if F = null then
               raise Program_Error;
            end if;
            F.Next := Frame.Next;
         end if;
      end if;
      Free (Frame);
   end Destroy;

   --  Release the frame when its reference is no longer necessary.
   procedure Release (F : in Frame_Ptr) is
      Current : Frame_Ptr := F;
   begin
      --  Scan the fram until the root is reached
      --  and decrement the used counter.  Free the frames
      --  when the used counter reaches 0.
      while Current /= null loop
         if Current.Used <= 1 then
            declare
               Tree : Frame_Ptr := Current;
            begin
               Current := Current.Parent;
               Destroy (Tree);
            end;
         else
            Current.Used := Current.Used - 1;
            Current := Current.Parent;
         end if;
      end loop;
   end Release;

   --  Split the node pointed to by `F' at the position `Pos'
   --  in the caller chain.  A new parent is created for the node
   --  and the brothers of the node become the brothers of the
   --  new parent.
   --
   --  Returns in `F' the new parent node.
   procedure Split (F : in out Frame_Ptr; Pos : in Positive) is

      --  Before:                       After:
      --
      --    +-------+             +-------+
      --  /-|  P    |           /-|  P    |
      --  | +-------+           | +-------+
      --  |       ^             |       ^
      --  |   +-------+         |    +-------+
      --  ...>| node  |...      ....>|  new  |...        (0..N brothers)
      --      +-------+              +-------+
      --       |     ^              |      ^
      --       | +-------+          | +-------+
      --       ->|  c    |          ->| node  |-->0      (0 brother)
      --         +-------+            +-------+
      --                                    |
      --                                +-------+
      --                                |   c   |
      --                                +-------+
      --
      New_Parent : Frame_Ptr := new Frame '(Parent      => F.Parent,
                                            Next        => F.Next,
                                            Children    => F,
                                            Used        => F.Used,
                                            Depth       => F.Depth,
                                            Local_Depth => Pos,
                                            Calls       => (others => 0));
      Child : Frame_Ptr := F.Parent.Children;
   begin
      --  Move the PC values in the new parent.
      New_Parent.Calls (1 .. Pos) := F.Calls (1 .. Pos);
      F.Calls (1 .. F.Local_Depth - Pos) := F.Calls (Pos + 1 .. F.Local_Depth);
      F.Parent         := New_Parent;
      F.Next           := null;
      New_Parent.Depth := F.Depth - F.Local_Depth + Pos;
      F.Local_Depth    := F.Local_Depth - Pos;

      --  Remove F from its parent children list and replace if with New_Parent.
      if Child = F then
         New_Parent.Parent.Children := New_Parent;
      else
         while Child.Next /= F loop
            Child := Child.Next;
         end loop;
         Child.Next := New_Parent;
      end if;
      F := New_Parent;
   end Split;

   procedure Add_Frame (F  : in Frame_Ptr;
                        Pc : in Pc_Table;
                        Result : out Frame_Ptr) is
      Child         : Frame_Ptr := F;
      Pos           : Positive  := Pc'First;
      Current_Depth : Natural   := F.Depth;
      Cnt           : Local_Depth_Type;
   begin
      while Pos <= Pc'Last loop
         Cnt := Frame_Group_Size;
         if Pos + Cnt > Pc'Last then
            Cnt := Pc'Last - Pos + 1;
         end if;
         Current_Depth := Current_Depth + Cnt;
         Child := new Frame '(Parent      => Child,
                              Next        => Child.Children,
                              Children    => null,
                              Used        => 1,
                              Depth       => Current_Depth,
                              Local_Depth => Cnt,
                              Calls       => (others => 0));
         Child.Calls (1 .. Cnt) := Pc (Pos .. Pos + Cnt - 1);
         Pos := Pos + Cnt;
         Child.Parent.Children := Child;
      end loop;
      Result := Child;
   end Add_Frame;

   procedure Insert (F : in Frame_Ptr;
                     Pc : in Pc_Table;
                     Result : out Frame_Ptr) is
      Current : Frame_Ptr := F;
      Child   : Frame_Ptr;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive  := 1;
      Addr    : Target_Addr;
   begin
      while Pos <= Pc'Last loop
         Addr := Pc (Pos);
         if Lpos <= Current.Local_Depth then
            if Addr = Current.Calls (Lpos) then
               Lpos := Lpos + 1;
               Pos  := Pos + 1;

               --  Split this node
            else
               if Lpos > 1 then
                  Split (Current, Lpos - 1);
               end if;
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
         else
            --  Find the first child which has the address.
            Child := Current.Children;
            while Child /= null loop
               exit when Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;
            if Child = null then
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
            Current := Child;
            Lpos    := 2;
            Pos     := Pos + 1;
            Current.Used := Current.Used + 1;
         end if;
      end loop;
      if Lpos <= Current.Local_Depth then
         Split (Current, Lpos - 1);
      end if;
      Result := Current;
   end Insert;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   function Find (F : in Frame_Ptr; Pc : in Target_Addr) return Frame_Ptr is
      Child : Frame_Ptr := F.Children;
   begin
      while Child /= null loop
         if Child.Local_Depth >= 1 and then Child.Calls (1) = Pc then
            return Child;
         end if;
         Child := Child.Next;
      end loop;
      raise Not_Found;
   end Find;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   function Find (F : in Frame_Ptr; Pc : in PC_Table) return Frame_Ptr is
      Child : Frame_Ptr := F;
      Pos   : Positive  := Pc'First;
      Lpos  : Positive;
   begin
      while Pos <= Pc'Last loop
         Child := Find (Child, Pc (Pos));
         Pos  := Pos + 1;
         Lpos := 2;
         --  All the PC of the child frame must match.
         while Pos <= Pc'Last and Lpos <= Child.Local_Depth loop
            if Child.Calls (Lpos) /= Pc (Pos) then
               raise Not_Found;
            end if;
            Lpos := Lpos + 1;
            Pos  := Pos + 1;
         end loop;
      end loop;
      return Child;
   end Find;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   procedure Find (F       : in Frame_Ptr;
                   Pc      : in PC_Table;
                   Result  : out Frame_Ptr;
                   Last_Pc : out Natural) is
      Current : Frame_Ptr := F;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive;
   begin
      Main_Search:
      while Pos <= Pc'Last loop
         declare
            Addr  : Target_Addr := Pc (Pos);
            Child : Frame_Ptr   := Current.Children;
         begin
            --  Find the child which has the corresponding PC.
            loop
               exit Main_Search when Child = null;
               exit when Child.Local_Depth >= 1 and Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;

            Current := Child;
            Pos  := Pos + 1;
            Lpos := 2;
            --  All the PC of the child frame must match.
            while Pos <= Pc'Last and Lpos <= Current.Local_Depth loop
               exit Main_Search when Current.Calls (Lpos) /= Pc (Pos);
               Lpos := Lpos + 1;
               Pos  := Pos + 1;
            end loop;
         end;
      end loop Main_Search;
      Result := Current;
      if Pos > Pc'Last then
         Last_Pc := 0;
      else
         Last_Pc := Pos;
      end if;
   end Find;

end MAT.Frames;

-----------------------------------------------------------------------
--  mat-frames - Representation of stack frames
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with Interfaces; use Interfaces;
with MAT.Types; use MAT.Types;
package body MAT.Frames is

   procedure Free is
      new Ada.Unchecked_Deallocation (Frame, Frame_Type);

   --  ------------------------------
   --  Return the parent frame.
   --  ------------------------------
   function Parent (Frame : in Frame_Type) return Frame_Type is
   begin
      if Frame = null then
         return null;
      else
         return Frame.Parent;
      end if;
   end Parent;

   --  ------------------------------
   --  Returns the backtrace of the current frame (up to the root).
   --  ------------------------------
   function Backtrace (Frame :  in Frame_Type) return Frame_Table is
      Pc      : Frame_Table (1 .. Frame.Depth);
      Current : Frame_Type := Frame;
      Pos     : Natural   := Current.Depth;
      New_Pos : Natural;
   begin
      while Current /= null and Pos /= 0 loop
         New_Pos := Pos - Current.Local_Depth + 1;
         Pc (New_Pos .. Pos) := Current.Calls (1 .. Current.Local_Depth);
         Pos     := New_Pos - 1;
         Current := Current.Parent;
      end loop;
      return Pc;
   end Backtrace;

   --  ------------------------------
   --  Returns the number of children in the frame.
   --  When recursive is true, compute in the sub-tree.
   --  ------------------------------
   function Count_Children (Frame     : in Frame_Type;
                            Recursive : in Boolean := False) return Natural is
      Count : Natural := 0;
      Child : Frame_Type;
   begin
      if Frame /= null then
         Child := Frame.Children;
         while Child /= null loop
            Count := Count + 1;
            if Recursive then
               declare
                  N : Natural := Count_Children (Child, True);
               begin
                  if N > 0 then
                     N := N - 1;
                  end if;
                  Count := Count + N;
               end;
            end if;
            Child := Child.Next;
         end loop;
      end if;
      return Count;
   end Count_Children;

   --  ------------------------------
   --  Returns all the direct calls made by the current frame.
   --  ------------------------------
   function Calls (Frame : in Frame_Type) return Frame_Table is
      Nb_Calls : Natural   := Count_Children (Frame);
      Pc       : Frame_Table (1 .. Nb_Calls);
   begin
      if Frame /= null then
         declare
            Child : Frame_Type := Frame.Children;
            Pos   : Natural   := 1;
         begin
            while Child /= null loop
               Pc (Pos) := Child.Calls (1);
               Pos   := Pos + 1;
               Child := Child.Next;
            end loop;
         end;
      end if;
      return Pc;
   end Calls;

   --  ------------------------------
   --  Returns the current stack depth (# of calls from the root
   --  to reach the frame).
   --  ------------------------------
   function Current_Depth (Frame : in Frame_Type) return Natural is
   begin
      if Frame = null then
         return 0;
      else
         return Frame.Depth;
      end if;
   end Current_Depth;

   --  ------------------------------
   --  Create a root for stack frame representation.
   --  ------------------------------
   function Create_Root return Frame_Type is
   begin
      return new Frame;
   end Create_Root;

   --  ------------------------------
   --  Destroy the frame tree recursively.
   --  ------------------------------
   procedure Destroy (Frame : in out Frame_Type) is
      F : Frame_Type;
   begin
      if Frame = null then
         return;
      end if;
      --  Destroy its children recursively.
      while Frame.Children /= null loop
         F := Frame.Children;
         Destroy (F);
      end loop;

      --  Unlink from parent list.
      if Frame.Parent /= null then
         F := Frame.Parent.Children;
         if F = Frame then
            Frame.Parent.Children := Frame.Next;
         else
            while F /= null and F.Next /= Frame loop
               F := F.Next;
            end loop;
            if F = null then
               raise Program_Error;
            end if;
            F.Next := Frame.Next;
         end if;
      end if;
      Free (Frame);
   end Destroy;

   --  ------------------------------
   --  Release the frame when its reference is no longer necessary.
   --  ------------------------------
   procedure Release (Frame : in Frame_Type) is
      Current : Frame_Type := Frame;
   begin
      --  Scan the frame until the root is reached
      --  and decrement the used counter.  Free the frames
      --  when the used counter reaches 0.
      while Current /= null loop
         if Current.Used <= 1 then
            declare
               Tree : Frame_Type := Current;
            begin
               Current := Current.Parent;
               Destroy (Tree);
            end;
         else
            Current.Used := Current.Used - 1;
            Current := Current.Parent;
         end if;
      end loop;
   end Release;

   --  Split the node pointed to by `F' at the position `Pos'
   --  in the caller chain.  A new parent is created for the node
   --  and the brothers of the node become the brothers of the
   --  new parent.
   --
   --  Returns in `F' the new parent node.
   procedure Split (F : in out Frame_Ptr; Pos : in Positive) is

      --  Before:                       After:
      --
      --    +-------+             +-------+
      --  /-|  P    |           /-|  P    |
      --  | +-------+           | +-------+
      --  |       ^             |       ^
      --  |   +-------+         |    +-------+
      --  ...>| node  |...      ....>|  new  |...        (0..N brothers)
      --      +-------+              +-------+
      --       |     ^              |      ^
      --       | +-------+          | +-------+
      --       ->|  c    |          ->| node  |-->0      (0 brother)
      --         +-------+            +-------+
      --                                    |
      --                                +-------+
      --                                |   c   |
      --                                +-------+
      --
      New_Parent : Frame_Ptr := new Frame '(Parent      => F.Parent,
                                            Next        => F.Next,
                                            Children    => F,
                                            Used        => F.Used,
                                            Depth       => F.Depth,
                                            Local_Depth => Pos,
                                            Calls       => (others => 0));
      Child : Frame_Ptr := F.Parent.Children;
   begin
      --  Move the PC values in the new parent.
      New_Parent.Calls (1 .. Pos) := F.Calls (1 .. Pos);
      F.Calls (1 .. F.Local_Depth - Pos) := F.Calls (Pos + 1 .. F.Local_Depth);
      F.Parent         := New_Parent;
      F.Next           := null;
      New_Parent.Depth := F.Depth - F.Local_Depth + Pos;
      F.Local_Depth    := F.Local_Depth - Pos;

      --  Remove F from its parent children list and replace if with New_Parent.
      if Child = F then
         New_Parent.Parent.Children := New_Parent;
      else
         while Child.Next /= F loop
            Child := Child.Next;
         end loop;
         Child.Next := New_Parent;
      end if;
      F := New_Parent;
   end Split;

   procedure Add_Frame (F  : in Frame_Ptr;
                        Pc : in Pc_Table;
                        Result : out Frame_Ptr) is
      Child         : Frame_Ptr := F;
      Pos           : Positive  := Pc'First;
      Current_Depth : Natural   := F.Depth;
      Cnt           : Local_Depth_Type;
   begin
      while Pos <= Pc'Last loop
         Cnt := Frame_Group_Size;
         if Pos + Cnt > Pc'Last then
            Cnt := Pc'Last - Pos + 1;
         end if;
         Current_Depth := Current_Depth + Cnt;
         Child := new Frame '(Parent      => Child,
                              Next        => Child.Children,
                              Children    => null,
                              Used        => 1,
                              Depth       => Current_Depth,
                              Local_Depth => Cnt,
                              Calls       => (others => 0));
         Child.Calls (1 .. Cnt) := Pc (Pos .. Pos + Cnt - 1);
         Pos := Pos + Cnt;
         Child.Parent.Children := Child;
      end loop;
      Result := Child;
   end Add_Frame;

   procedure Insert (F : in Frame_Ptr;
                     Pc : in Pc_Table;
                     Result : out Frame_Ptr) is
      Current : Frame_Ptr := F;
      Child   : Frame_Ptr;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive  := 1;
      Addr    : Target_Addr;
   begin
      while Pos <= Pc'Last loop
         Addr := Pc (Pos);
         if Lpos <= Current.Local_Depth then
            if Addr = Current.Calls (Lpos) then
               Lpos := Lpos + 1;
               Pos  := Pos + 1;

               --  Split this node
            else
               if Lpos > 1 then
                  Split (Current, Lpos - 1);
               end if;
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
         else
            --  Find the first child which has the address.
            Child := Current.Children;
            while Child /= null loop
               exit when Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;
            if Child = null then
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
            Current := Child;
            Lpos    := 2;
            Pos     := Pos + 1;
            Current.Used := Current.Used + 1;
         end if;
      end loop;
      if Lpos <= Current.Local_Depth then
         Split (Current, Lpos - 1);
      end if;
      Result := Current;
   end Insert;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   function Find (F : in Frame_Ptr; Pc : in Target_Addr) return Frame_Ptr is
      Child : Frame_Ptr := F.Children;
   begin
      while Child /= null loop
         if Child.Local_Depth >= 1 and then Child.Calls (1) = Pc then
            return Child;
         end if;
         Child := Child.Next;
      end loop;
      raise Not_Found;
   end Find;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   function Find (F : in Frame_Ptr; Pc : in PC_Table) return Frame_Ptr is
      Child : Frame_Ptr := F;
      Pos   : Positive  := Pc'First;
      Lpos  : Positive;
   begin
      while Pos <= Pc'Last loop
         Child := Find (Child, Pc (Pos));
         Pos  := Pos + 1;
         Lpos := 2;
         --  All the PC of the child frame must match.
         while Pos <= Pc'Last and Lpos <= Child.Local_Depth loop
            if Child.Calls (Lpos) /= Pc (Pos) then
               raise Not_Found;
            end if;
            Lpos := Lpos + 1;
            Pos  := Pos + 1;
         end loop;
      end loop;
      return Child;
   end Find;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   procedure Find (F       : in Frame_Ptr;
                   Pc      : in PC_Table;
                   Result  : out Frame_Ptr;
                   Last_Pc : out Natural) is
      Current : Frame_Ptr := F;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive;
   begin
      Main_Search:
      while Pos <= Pc'Last loop
         declare
            Addr  : Target_Addr := Pc (Pos);
            Child : Frame_Ptr   := Current.Children;
         begin
            --  Find the child which has the corresponding PC.
            loop
               exit Main_Search when Child = null;
               exit when Child.Local_Depth >= 1 and Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;

            Current := Child;
            Pos  := Pos + 1;
            Lpos := 2;
            --  All the PC of the child frame must match.
            while Pos <= Pc'Last and Lpos <= Current.Local_Depth loop
               exit Main_Search when Current.Calls (Lpos) /= Pc (Pos);
               Lpos := Lpos + 1;
               Pos  := Pos + 1;
            end loop;
         end;
      end loop Main_Search;
      Result := Current;
      if Pos > Pc'Last then
         Last_Pc := 0;
      else
         Last_Pc := Pos;
      end if;
   end Find;

end MAT.Frames;

Refactor the Release operation

Refactor the Release operation


-----------------------------------------------------------------------
--  Memory - Memory slot
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Containers.Ordered_Maps;

with MAT.Types;
with MAT.Frames;

with Interfaces;
package MAT.Memory is

   type Allocation is record
      Size   : MAT.Types.Target_Size;
      Frame  : Frames.Frame_Type;
      Time   : MAT.Types.Target_Tick_Ref;
      Thread : MAT.Types.Target_Thread_Ref;
   end record;

   use type MAT.Types.Target_Addr;
   package Allocation_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Addr,
                                      Element_Type => Allocation);

   subtype Allocation_Map is Allocation_Maps.Map;
   subtype Allocation_Cursor is Allocation_Maps.Cursor;

private

end MAT.Memory;

-----------------------------------------------------------------------
--  Memory - Memory slot
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Containers.Ordered_Maps;

with MAT.Types;
with MAT.Frames;

with Interfaces;
package MAT.Memory is

   type Allocation is record
      Size   : MAT.Types.Target_Size;
      Frame  : Frames.Frame_Type;
      Time   : MAT.Types.Target_Tick_Ref;
      Thread : MAT.Types.Target_Thread_Ref;
   end record;

   --  Statistics about memory allocation.
   type Memory_Info is record
      Total_Size    : MAT.Types.Target_Size := 0;
      Alloc_Count   : Natural := 0;
      Min_Slot_Size : MAT.Types.Target_Size := 0;
      Max_Slot_Size : MAT.Types.Target_Size := 0;
   end record;

   use type MAT.Types.Target_Addr;
   package Allocation_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Addr,
                                      Element_Type => Allocation);

   subtype Allocation_Map is Allocation_Maps.Map;
   subtype Allocation_Cursor is Allocation_Maps.Cursor;

private

end MAT.Memory;

Declare the Memory_Info type

Declare the Memory_Info type


-----------------------------------------------------------------------
--  util-streams-buffered-lzma -- LZMA streams
--  Copyright (C) 2018, 2019 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Lzma.Check;
with Lzma.Container;
with Interfaces.C;
with Ada.IO_Exceptions;
package body Util.Streams.Buffered.Lzma is

   use type Interfaces.C.size_t;
   use type Base.lzma_ret;

   subtype size_t is Interfaces.C.size_t;
   subtype Offset is Ada.Streams.Stream_Element_Offset;

   --  -----------------------
   --  Initialize the stream to write on the given stream.
   --  An internal buffer is allocated for writing the stream.
   --  -----------------------
   overriding
   procedure Initialize (Stream  : in out Compress_Stream;
                         Output  : access Output_Stream'Class;
                         Size    : in Positive) is
      Result : Base.lzma_ret;
   begin
      Output_Buffer_Stream (Stream).Initialize (Output, Size);

      Stream.Stream.next_out := Stream.Buffer (Stream.Buffer'First)'Unchecked_Access;
      Stream.Stream.avail_out := Stream.Buffer'Length;
      Result := Container.lzma_easy_encoder (Stream.Stream'Unchecked_Access, 6,
                                             Check.LZMA_CHECK_CRC64);
      if Result /= Base.LZMA_OK then
         raise Ada.IO_Exceptions.Device_Error with "Cannot initialize compressor";
      end if;
   end Initialize;

   --  -----------------------
   --  Close the sink.
   --  -----------------------
   overriding
   procedure Close (Stream : in out Compress_Stream) is
   begin
      Stream.Flush;
      Output_Buffer_Stream (Stream).Close;
   end Close;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   overriding
   procedure Write (Stream : in out Compress_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
      Last_Pos  : Ada.Streams.Stream_Element_Offset;
      Encoded   : Boolean := False;
      Result    : Base.lzma_ret;
   begin
      loop
         if Stream.Stream.avail_in = 0 then
            Stream.Stream.next_in := Buffer (Buffer'First)'Unrestricted_Access;
            Stream.Stream.avail_in := size_t (Buffer'Length);
            Encoded := True;
         end if;

         Result := Base.lzma_code (Stream.Stream'Unchecked_Access, Base.LZMA_RUN);

         --  Write the output data when the buffer is full or we reached the end of stream.
         if Stream.Stream.avail_out = 0 or Result = Base.LZMA_STREAM_END then
            Last_Pos := Stream.Buffer'First + Stream.Buffer'Length
              - Offset (Stream.Stream.avail_out) - 1;
            Stream.Output.Write (Stream.Buffer (Stream.Buffer'First .. Last_Pos));
            Stream.Stream.next_out := Stream.Buffer (Stream.Buffer'First)'Unchecked_Access;
            Stream.Stream.avail_out := Stream.Buffer'Length;
         end if;
         exit when Result /= Base.LZMA_OK or (Stream.Stream.avail_in = 0 and Encoded);
      end loop;
   end Write;

   --  -----------------------
   --  Flush the buffer by writing on the output stream.
   --  Raises Data_Error if there is no output stream.
   --  -----------------------
   overriding
   procedure Flush (Stream : in out Compress_Stream) is
      Last_Pos : Ada.Streams.Stream_Element_Offset;
      Result : Base.lzma_ret;
   begin
      Stream.Stream.next_in := null;
      Stream.Stream.avail_in := 0;
      loop
         Result := Base.lzma_code (Stream.Stream'Unchecked_Access, Base.LZMA_FINISH);

         if Stream.Stream.avail_out = 0 or Result = Base.LZMA_STREAM_END then
            Last_Pos := Stream.Buffer'First + Stream.Buffer'Length
              - Offset (Stream.Stream.avail_out) - 1;
            Stream.Output.Write (Stream.Buffer (Stream.Buffer'First .. Last_Pos));
            Stream.Stream.next_out := Stream.Buffer (Stream.Buffer'First)'Unchecked_Access;
            Stream.Stream.avail_out := Stream.Buffer'Length;
         end if;
         exit when Result /= Base.LZMA_OK;
      end loop;
   end Flush;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   overriding
   procedure Finalize (Object : in out Compress_Stream) is
   begin
      Base.lzma_end (Object.Stream'Unchecked_Access);
      Output_Buffer_Stream (Object).Finalize;
   end Finalize;

   --  -----------------------
   --  Initialize the stream to write on the given stream.
   --  An internal buffer is allocated for writing the stream.
   --  -----------------------
   overriding
   procedure Initialize (Stream  : in out Decompress_Stream;
                         Input   : access Input_Stream'Class;
                         Size    : in Positive) is
      Result : Base.lzma_ret;
   begin
      Input_Buffer_Stream (Stream).Initialize (Input, Size);

      Stream.Stream.next_in := Stream.Buffer (Stream.Buffer'First)'Unchecked_Access;
      Stream.Stream.avail_in := 0;
      Result := Container.lzma_stream_decoder (Stream.Stream'Unchecked_Access,
                                               Long_Long_Integer'Last,
                                               Container.LZMA_CONCATENATED);
      if Result /= Base.LZMA_OK then
         raise Ada.IO_Exceptions.Device_Error with "Cannot initialize decompressor";
      end if;
   end Initialize;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   overriding
   procedure Read (Stream : in out Decompress_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
      use type Base.lzma_action;

      Result : Base.lzma_ret;
   begin
      Stream.Stream.next_out  := Into (Into'First)'Unrestricted_Access;
      Stream.Stream.avail_out := Into'Length;
      loop
         if Stream.Stream.avail_in = 0 and not Stream.Is_Eof
           and Stream.Action = Base.LZMA_RUN
         then
            Stream.Fill;
            if Stream.Write_Pos >= Stream.Read_Pos then
               Stream.Stream.avail_in := size_t (Stream.Write_Pos - Stream.Read_Pos);
               Stream.Stream.next_in := Stream.Buffer (Stream.Buffer'First)'Unchecked_Access;
            else
               Stream.Stream.avail_in := 0;
               Stream.Stream.next_in := null;
               Stream.Action := Base.LZMA_FINISH;
            end if;
         end if;
         Result := Base.lzma_code (Stream.Stream'Unchecked_Access, Stream.Action);

         if Stream.Stream.avail_out = 0 or Result = Base.LZMA_STREAM_END then
            Last := Into'First + Into'Length
              - Offset (Stream.Stream.avail_out) - 1;
            return;
         end if;
         if Result /= Base.LZMA_OK then
            raise Ada.IO_Exceptions.Data_Error with "Decompression error";
         end if;
      end loop;
   end Read;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   overriding
   procedure Finalize (Object : in out Decompress_Stream) is
   begin
      Base.lzma_end (Object.Stream'Unchecked_Access);
      Input_Buffer_Stream (Object).Finalize;
   end Finalize;

end Util.Streams.Buffered.Lzma;

-----------------------------------------------------------------------
--  util-streams-buffered-lzma -- LZMA streams
--  Copyright (C) 2018, 2019 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Lzma.Check;
with Lzma.Container;
with Interfaces.C;
with Ada.IO_Exceptions;
package body Util.Streams.Buffered.Lzma is

   use type Interfaces.C.size_t;
   use type Base.lzma_ret;

   subtype size_t is Interfaces.C.size_t;
   subtype Offset is Ada.Streams.Stream_Element_Offset;

   --  -----------------------
   --  Initialize the stream to write on the given stream.
   --  An internal buffer is allocated for writing the stream.
   --  -----------------------
   overriding
   procedure Initialize (Stream  : in out Compress_Stream;
                         Output  : access Output_Stream'Class;
                         Size    : in Positive) is
      Result : Base.lzma_ret;
   begin
      Output_Buffer_Stream (Stream).Initialize (Output, Size);

      Stream.Stream.next_out := Stream.Buffer (Stream.Buffer'First)'Unchecked_Access;
      Stream.Stream.avail_out := Stream.Buffer'Length;
      Result := Container.lzma_easy_encoder (Stream.Stream'Unchecked_Access, 6,
                                             Check.LZMA_CHECK_CRC64);
      if Result /= Base.LZMA_OK then
         raise Ada.IO_Exceptions.Device_Error with "Cannot initialize compressor";
      end if;
   end Initialize;

   --  -----------------------
   --  Close the sink.
   --  -----------------------
   overriding
   procedure Close (Stream : in out Compress_Stream) is
   begin
      Stream.Flush;
      Output_Buffer_Stream (Stream).Close;
   end Close;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   overriding
   procedure Write (Stream : in out Compress_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
      Last_Pos  : Ada.Streams.Stream_Element_Offset;
      Encoded   : Boolean := False;
      Result    : Base.lzma_ret;
   begin
      loop
         if Stream.Stream.avail_in = 0 then
            Stream.Stream.next_in := Buffer (Buffer'First)'Unrestricted_Access;
            Stream.Stream.avail_in := size_t (Buffer'Length);
            Encoded := True;
         end if;

         Result := Base.lzma_code (Stream.Stream'Unchecked_Access, Base.LZMA_RUN);

         --  Write the output data when the buffer is full or we reached the end of stream.
         if Stream.Stream.avail_out = 0 or Result = Base.LZMA_STREAM_END then
            Last_Pos := Stream.Buffer'First + Stream.Buffer'Length
              - Offset (Stream.Stream.avail_out) - 1;
            Stream.Output.Write (Stream.Buffer (Stream.Buffer'First .. Last_Pos));
            Stream.Stream.next_out := Stream.Buffer (Stream.Buffer'First)'Unchecked_Access;
            Stream.Stream.avail_out := Stream.Buffer'Length;
         end if;
         exit when Result /= Base.LZMA_OK or (Stream.Stream.avail_in = 0 and Encoded);
      end loop;
   end Write;

   --  -----------------------
   --  Flush the buffer by writing on the output stream.
   --  Raises Data_Error if there is no output stream.
   --  -----------------------
   overriding
   procedure Flush (Stream : in out Compress_Stream) is
      Last_Pos : Ada.Streams.Stream_Element_Offset;
      Result : Base.lzma_ret;
   begin
      Stream.Stream.next_in := null;
      Stream.Stream.avail_in := 0;
      loop
         Result := Base.lzma_code (Stream.Stream'Unchecked_Access, Base.LZMA_FINISH);

         if Stream.Stream.avail_out = 0 or Result = Base.LZMA_STREAM_END then
            Last_Pos := Stream.Buffer'First + Stream.Buffer'Length
              - Offset (Stream.Stream.avail_out) - 1;
            Stream.Output.Write (Stream.Buffer (Stream.Buffer'First .. Last_Pos));
            Stream.Stream.next_out := Stream.Buffer (Stream.Buffer'First)'Unchecked_Access;
            Stream.Stream.avail_out := Stream.Buffer'Length;
         end if;
         exit when Result /= Base.LZMA_OK;
      end loop;
   end Flush;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   overriding
   procedure Finalize (Object : in out Compress_Stream) is
   begin
      Object.Flush;
      Output_Buffer_Stream (Object).Finalize;
      Base.lzma_end (Object.Stream'Unchecked_Access);
   end Finalize;

   --  -----------------------
   --  Initialize the stream to write on the given stream.
   --  An internal buffer is allocated for writing the stream.
   --  -----------------------
   overriding
   procedure Initialize (Stream  : in out Decompress_Stream;
                         Input   : access Input_Stream'Class;
                         Size    : in Positive) is
      Result : Base.lzma_ret;
   begin
      Input_Buffer_Stream (Stream).Initialize (Input, Size);

      Stream.Stream.next_in := Stream.Buffer (Stream.Buffer'First)'Unchecked_Access;
      Stream.Stream.avail_in := 0;
      Result := Container.lzma_stream_decoder (Stream.Stream'Unchecked_Access,
                                               Long_Long_Integer'Last,
                                               Container.LZMA_CONCATENATED);
      if Result /= Base.LZMA_OK then
         raise Ada.IO_Exceptions.Device_Error with "Cannot initialize decompressor";
      end if;
   end Initialize;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   overriding
   procedure Read (Stream : in out Decompress_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
      use type Base.lzma_action;

      Result : Base.lzma_ret;
   begin
      Stream.Stream.next_out  := Into (Into'First)'Unrestricted_Access;
      Stream.Stream.avail_out := Into'Length;
      loop
         if Stream.Stream.avail_in = 0 and not Stream.Is_Eof
           and Stream.Action = Base.LZMA_RUN
         then
            Stream.Fill;
            if Stream.Write_Pos >= Stream.Read_Pos then
               Stream.Stream.avail_in := size_t (Stream.Write_Pos - Stream.Read_Pos);
               Stream.Stream.next_in := Stream.Buffer (Stream.Buffer'First)'Unchecked_Access;
            else
               Stream.Stream.avail_in := 0;
               Stream.Stream.next_in := null;
               Stream.Action := Base.LZMA_FINISH;
            end if;
         end if;
         Result := Base.lzma_code (Stream.Stream'Unchecked_Access, Stream.Action);

         if Stream.Stream.avail_out = 0 or Result = Base.LZMA_STREAM_END then
            Last := Into'First + Into'Length
              - Offset (Stream.Stream.avail_out) - 1;
            return;
         end if;
         if Result /= Base.LZMA_OK then
            raise Ada.IO_Exceptions.Data_Error with "Decompression error";
         end if;
      end loop;
   end Read;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   overriding
   procedure Finalize (Object : in out Decompress_Stream) is
   begin
      Base.lzma_end (Object.Stream'Unchecked_Access);
      Input_Buffer_Stream (Object).Finalize;
   end Finalize;

end Util.Streams.Buffered.Lzma;

Fix Finalize to flush the LZMA before deleting the object


-----------------------------------------------------------------------
--  ADO Mysql Database -- MySQL Database connections
--  Copyright (C) 2009, 2010 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Mysql.Mysql; use Mysql.Mysql;

package ADO.Drivers.Connections.Mysql is

   type Mysql_Driver is limited private;

   --  Initialize the Mysql driver.
   procedure Initialize;

private

   --  Create a new MySQL connection using the configuration parameters.
   procedure Create_Connection (D      : in out Mysql_Driver;
                                Config : in Configuration'Class;
                                Result : out Database_Connection_Access);

   type Mysql_Driver is new ADO.Drivers.Connections.Driver with record
      Id : Natural := 0;
   end record;

   --  Deletes the Mysql driver.
   overriding
   procedure Finalize (D : in out Mysql_Driver);

   --  Database connection implementation
   type Database_Connection is new ADO.Drivers.Connections.Database_Connection with record
      Name        : Unbounded_String := Null_Unbounded_String;
      Server_Name : Unbounded_String := Null_Unbounded_String;
      Login_Name  : Unbounded_String := Null_Unbounded_String;
      Password    : Unbounded_String := Null_Unbounded_String;

      Server      : Mysql_Access := null;

      Connected   : Boolean      := False;

      --  MySQL autocommit flag
      Autocommit  : Boolean := True;
   end record;

   type Database_Connection_Access is access all Database_Connection'Class;

   --  Get the database driver which manages this connection.
   overriding
   function Get_Driver (Database : in Database_Connection)
                        return Driver_Access;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement_Access;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Query    : in String)
                              return Query_Statement_Access;

   --  Create a delete statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement_Access;

   --  Create an insert statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement_Access;

   --  Create an update statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement_Access;

   --  Start a transaction.
   overriding
   procedure Begin_Transaction (Database : in out Database_Connection);

   --  Commit the current transaction.
   overriding
   procedure Commit (Database : in out Database_Connection);

   --  Rollback the current transaction.
   overriding
   procedure Rollback (Database : in out Database_Connection);

   procedure Execute (Database : in out Database_Connection;
                      SQL      : in Query_String);

   --  Closes the database connection
   overriding
   procedure Close (Database : in out Database_Connection);

   overriding
   procedure Finalize (Database : in out Database_Connection);

   --  Load the database schema definition for the current database.
   overriding
   procedure Load_Schema (Database : in Database_Connection;
                          Schema   : out ADO.Schemas.Schema_Definition);

end ADO.Drivers.Connections.Mysql;

-----------------------------------------------------------------------
--  ADO Mysql Database -- MySQL Database connections
--  Copyright (C) 2009, 2010, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Mysql.Mysql; use Mysql.Mysql;

package ADO.Drivers.Connections.Mysql is

   type Mysql_Driver is limited private;

   --  Initialize the Mysql driver.
   procedure Initialize;

private

   --  Create a new MySQL connection using the configuration parameters.
   procedure Create_Connection (D      : in out Mysql_Driver;
                                Config : in Configuration'Class;
                                Result : in out Ref.Ref'Class);

   type Mysql_Driver is new ADO.Drivers.Connections.Driver with record
      Id : Natural := 0;
   end record;

   --  Deletes the Mysql driver.
   overriding
   procedure Finalize (D : in out Mysql_Driver);

   --  Database connection implementation
   type Database_Connection is new ADO.Drivers.Connections.Database_Connection with record
      Name        : Unbounded_String := Null_Unbounded_String;
      Server_Name : Unbounded_String := Null_Unbounded_String;
      Login_Name  : Unbounded_String := Null_Unbounded_String;
      Password    : Unbounded_String := Null_Unbounded_String;

      Server      : Mysql_Access := null;

      Connected   : Boolean      := False;

      --  MySQL autocommit flag
      Autocommit  : Boolean := True;
   end record;

   type Database_Connection_Access is access all Database_Connection'Class;

   --  Get the database driver which manages this connection.
   overriding
   function Get_Driver (Database : in Database_Connection)
                        return Driver_Access;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement_Access;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Query    : in String)
                              return Query_Statement_Access;

   --  Create a delete statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement_Access;

   --  Create an insert statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement_Access;

   --  Create an update statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement_Access;

   --  Start a transaction.
   overriding
   procedure Begin_Transaction (Database : in out Database_Connection);

   --  Commit the current transaction.
   overriding
   procedure Commit (Database : in out Database_Connection);

   --  Rollback the current transaction.
   overriding
   procedure Rollback (Database : in out Database_Connection);

   procedure Execute (Database : in out Database_Connection;
                      SQL      : in Query_String);

   --  Closes the database connection
   overriding
   procedure Close (Database : in out Database_Connection);

   overriding
   procedure Finalize (Database : in out Database_Connection);

   --  Load the database schema definition for the current database.
   overriding
   procedure Load_Schema (Database : in Database_Connection;
                          Schema   : out ADO.Schemas.Schema_Definition);

end ADO.Drivers.Connections.Mysql;

Update the Create_Connection procedure

Update the Create_Connection procedure


-----------------------------------------------------------------------
--  mat-events-targets - Events received and collected from a target
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

package body MAT.Events.Targets is

   --  ------------------------------
   --  Add the event in the list of events and increment the event counter.
   --  ------------------------------
   procedure Insert (Target : in out Target_Events;
                     Event  : in MAT.Types.Uint16;
                     Frame  : in MAT.Events.Frame_Info) is
   begin
      Target.Events.Insert (Event, Frame);
      Util.Concurrent.Counters.Increment (Target.Event_Count);
   end Insert;

   --  ------------------------------
   --  Get the current event counter.
   --  ------------------------------
   function Get_Event_Counter (Target : in Target_Events) return Integer is
   begin
      return Util.Concurrent.Counters.Value (Target.Event_Count);
   end Get_EVent_Counter;

   protected body Event_Collector is

      --  ------------------------------
      --  Add the event in the list of events.
      --  ------------------------------
      procedure Insert (Event  : in MAT.Types.Uint16;
                        Frame  : in MAT.Events.Frame_Info) is
      begin
         null;
      end Insert;

   end Event_Collector;

end MAT.Events.Targets;

-----------------------------------------------------------------------
--  mat-events-targets - Events received and collected from a target
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

package body MAT.Events.Targets is

   --  ------------------------------
   --  Add the event in the list of events and increment the event counter.
   --  ------------------------------
   procedure Insert (Target : in out Target_Events;
                     Event  : in MAT.Types.Uint16;
                     Frame  : in MAT.Events.Frame_Info) is
   begin
      Target.Events.Insert (Event, Frame);
      Util.Concurrent.Counters.Increment (Target.Event_Count);
   end Insert;

   procedure Get_Events (Target : in out Target_Events;
                         Start  : in MAT.Types.Target_Time;
                         Finish : in MAT.Types.Target_Time;
                         Into   : in out Target_Event_Vector) is
   begin
      Target.Events.Get_Events (Start, Finish, Into);
   end Get_Events;

   --  ------------------------------
   --  Get the current event counter.
   --  ------------------------------
   function Get_Event_Counter (Target : in Target_Events) return Integer is
   begin
      return Util.Concurrent.Counters.Value (Target.Event_Count);
   end Get_EVent_Counter;

   protected body Event_Collector is

      --  ------------------------------
      --  Add the event in the list of events.
      --  ------------------------------
      procedure Insert (Event  : in MAT.Types.Uint16;
                        Frame  : in MAT.Events.Frame_Info) is
         Info : Target_Event;
      begin
         Info.Event  := Event;
         Info.Time   := Frame.Time;
         Info.Thread := Frame.Thread;
         Events.Insert (Frame.Time, Info);
      end Insert;

      procedure Get_Events (Start  : in MAT.Types.Target_Time;
                            Finish : in MAT.Types.Target_Time;
                            Into   : in out Target_Event_Vector) is
         Iter : Event_Cursor := Events.First;
      begin
         while Event_Maps.Has_Element (Iter) loop
            Into.Append (Event_Maps.Element (Iter));
            Event_Maps.Next (Iter);
         end loop;
      end Get_Events;

   end Event_Collector;

end MAT.Events.Targets;

Implement the Get_Events procedure

Implement the Get_Events procedure