-----------------------------------------------------------------------
--  util-texts-builders -- Text builder
--  Copyright (C) 2013, 2016, 2017, 2021, 2022 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;

package body Util.Texts.Builders is

   --  ------------------------------
   --  Get the length of the item builder.
   --  ------------------------------
   function Length (Source : in Builder) return Natural is
   begin
      return Source.Length;
   end Length;

   --  ------------------------------
   --  Get the capacity of the builder.
   --  ------------------------------
   function Capacity (Source : in Builder) return Natural is
      B : constant Block_Access := Source.Current;
   begin
      return Source.Length + B.Len - B.Last;
   end Capacity;

   --  ------------------------------
   --  Get the builder block size.
   --  ------------------------------
   function Block_Size (Source : in Builder) return Positive is
   begin
      return Source.Block_Size;
   end Block_Size;

   --  ------------------------------
   --  Set the block size for the allocation of next chunks.
   --  ------------------------------
   procedure Set_Block_Size (Source : in out Builder;
                             Size   : in Positive) is
   begin
      Source.Block_Size := Size;
   end Set_Block_Size;

   --  ------------------------------
   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   --  ------------------------------
   procedure Append (Source   : in out Builder;
                     New_Item : in Input) is
      B     : Block_Access := Source.Current;
      Start : Natural := New_Item'First;
      Last  : constant Natural := New_Item'Last;
   begin
      while Start <= Last loop
         declare
            Space : Natural := B.Len - B.Last;
            Size  : constant Natural := Last - Start + 1;
         begin
            if Space > Size then
               Space := Size;
            elsif Space = 0 then
               if Size > Source.Block_Size then
                  B.Next_Block := new Block (Size);
               else
                  B.Next_Block := new Block (Source.Block_Size);
               end if;
               B := B.Next_Block;
               Source.Current := B;
               if B.Len > Size then
                  Space := Size;
               else
                  Space  := B.Len;
               end if;
            end if;
            B.Content (B.Last + 1 .. B.Last + Space) := New_Item (Start .. Start + Space - 1);
            Source.Length := Source.Length + Space;
            B.Last := B.Last + Space;
            Start  := Start + Space;
         end;
      end loop;
   end Append;

   --  ------------------------------
   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   --  ------------------------------
   procedure Append (Source   : in out Builder;
                     New_Item : in Element_Type) is
      B     : Block_Access := Source.Current;
   begin
      if B.Len = B.Last then
         B.Next_Block := new Block (Source.Block_Size);
         B := B.Next_Block;
         Source.Current := B;
      end if;
      Source.Length := Source.Length + 1;
      B.Last := B.Last + 1;
      B.Content (B.Last) := New_Item;
   end Append;

   procedure Inline_Append (Source   : in out Builder) is
      B     : Block_Access := Source.Current;
      Last  : Natural;
   begin
      loop
         if B.Len = B.Last then
            B.Next_Block := new Block (Source.Block_Size);
            B := B.Next_Block;
            Source.Current := B;
         end if;
         Process (B.Content (B.Last + 1 .. B.Len), Last);
         exit when Last > B.Len or Last <= B.Last;
         Source.Length := Source.Length + Last - B.Last;
         B.Last := Last;
         exit when Last < B.Len;
      end loop;
   end Inline_Append;

   --  ------------------------------
   --  Clear the source freeing any storage allocated for the buffer.
   --  ------------------------------
   procedure Clear (Source : in out Builder) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Block, Name => Block_Access);
      Current, Next : Block_Access;
   begin
      Next := Source.First.Next_Block;
      while Next /= null loop
         Current := Next;
         Next    := Current.Next_Block;
         Free (Current);
      end loop;
      Source.First.Next_Block := null;
      Source.First.Last       := 0;
      Source.Current          := Source.First'Unchecked_Access;
      Source.Length           := 0;
   end Clear;

   --  ------------------------------
   --  Iterate over the buffer content calling the <tt>Process</tt> procedure with each
   --  chunk.
   --  ------------------------------
   procedure Iterate (Source  : in Builder;
                      Process : not null access procedure (Chunk : in Input)) is
   begin
      if Source.First.Last > 0 then
         Process (Source.First.Content (1 .. Source.First.Last));
         declare
            B : Block_Access := Source.First.Next_Block;
         begin
            while B /= null loop
               Process (B.Content (1 .. B.Last));
               B := B.Next_Block;
            end loop;
         end;
      end if;
   end Iterate;

   procedure Inline_Iterate (Source  : in Builder) is
   begin
      if Source.First.Last > 0 then
         Process (Source.First.Content (1 .. Source.First.Last));
         declare
            B : Block_Access := Source.First.Next_Block;
         begin
            while B /= null loop
               Process (B.Content (1 .. B.Last));
               B := B.Next_Block;
            end loop;
         end;
      end if;
   end Inline_Iterate;

   --  ------------------------------
   --  Return the content starting from the tail and up to <tt>Length</tt> items.
   --  ------------------------------
   function Tail (Source : in Builder;
                  Length : in Natural) return Input is
      Last : constant Natural := Source.Current.Last;
   begin
      if Last >= Length then
         return Source.Current.Content (Last - Length + 1 .. Last);
      elsif Length >= Source.Length then
         return To_Array (Source);
      else
         declare
            Result  : Input (1 .. Length);
            Offset  : Natural := Source.Length - Length;
            B       : access constant Block := Source.First'Access;
            Src_Pos : Positive := 1;
            Dst_Pos : Positive := 1;
            Len     : Natural;
         begin
            --  Skip the data moving to next blocks as needed.
            while Offset /= 0 loop
               if Offset < B.Last then
                  Src_Pos := Offset + 1;
                  Offset := 0;
               else
                  Offset := Offset - B.Last + 1;
                  B := B.Next_Block;
               end if;
            end loop;

            --  Copy what remains until we reach the length.
            while Dst_Pos <= Length loop
               Len := B.Last - Src_Pos + 1;
               Result (Dst_Pos .. Dst_Pos + Len - 1) := B.Content (Src_Pos .. B.Last);
               Src_Pos := 1;
               Dst_Pos := Dst_Pos + Len;
               B := B.Next_Block;
            end loop;
            return Result;
         end;
      end if;
   end Tail;

   --  ------------------------------
   --  Get the buffer content as an array.
   --  ------------------------------
   function To_Array (Source : in Builder) return Input is
      Result : Input (1 .. Source.Length);
   begin
      if Source.First.Last > 0 then
         declare
            Pos : Positive := Source.First.Last;
            B   : Block_Access := Source.First.Next_Block;
         begin
            Result (1 .. Pos) := Source.First.Content (1 .. Pos);
            while B /= null loop
               Result (Pos + 1 .. Pos + B.Last) := B.Content (1 .. B.Last);
               Pos := Pos + B.Last;
               B   := B.Next_Block;
            end loop;
         end;
      end if;
      return Result;
   end To_Array;

   --  ------------------------------
   --  Call the <tt>Process</tt> procedure with the full buffer content, trying to avoid
   --  secondary stack copies as much as possible.
   --  ------------------------------
   procedure Get (Source : in Builder) is
   begin
      if Source.Length < Source.First.Len then
         Process (Source.First.Content (1 .. Source.Length));
      else
         declare
            Content : constant Input := To_Array (Source);
         begin
            Process (Content);
         end;
      end if;
   end Get;

   --  ------------------------------
   --  Format the message and replace occurrences of argument patterns by
   --  their associated value.
   --  Returns the formatted message in the stream
   --  ------------------------------
   procedure Format (Into      : in out Builder;
                     Message   : in Input;
                     Arguments : in Value_List) is
      C       : Element_Type;
      Old_Pos : Natural;
      N       : Natural := 0;
      Pos     : Natural := Message'First;
      First   : Natural := Pos;
   begin
      --  Replace {N} with arg1, arg2, arg3 or ?
      while Pos <= Message'Last loop
         C := Message (Pos);
         if Element_Type'Pos (C) = Character'Pos ('{') and then Pos + 1 <= Message'Last then
            if First /= Pos then
               Append (Into, Message (First .. Pos - 1));
            end if;
            N := 0;
            Pos := Pos + 1;
            C := Message (Pos);

            --  Handle {} replacement to emit the current argument and advance argument position.
            if Element_Type'Pos (C) = Character'Pos ('}') then
               Pos := Pos + 1;
               if N >= Arguments'Length then
                  First := Pos - 2;
               else
                  Append (Into, Arguments (N + Arguments'First));
                  First := Pos;
               end if;
               N := N + 1;
            else
               N := 0;
               Old_Pos := Pos - 1;
               loop
                  if Element_Type'Pos (C) >= Character'Pos ('0')
                    and Element_Type'Pos (C) <= Character'Pos ('9')
                  then
                     N := N * 10 + Natural (Element_Type'Pos (C) - Character'Pos ('0'));
                     Pos := Pos + 1;
                     if Pos > Message'Last then
                        First := Old_Pos;
                        exit;
                     end if;
                  elsif Element_Type'Pos (C) = Character'Pos ('}') then
                     Pos := Pos + 1;
                     if N >= Arguments'Length then
                        First := Old_Pos;
                     else
                        Append (Into, Arguments (N + Arguments'First));
                        First := Pos;
                     end if;
                     exit;
                  else
                     First := Old_Pos;
                     exit;
                  end if;
                  C := Message (Pos);
               end loop;
            end if;
         else
            Pos := Pos + 1;
         end if;
      end loop;
      if First /= Pos then
         Append (Into, Message (First .. Pos - 1));
      end if;
   end Format;

   --  ------------------------------
   --  Setup the builder.
   --  ------------------------------
   overriding
   procedure Initialize (Source : in out Builder) is
   begin
      Source.Current := Source.First'Unchecked_Access;
   end Initialize;

   --  ------------------------------
   --  Finalize the builder releasing the storage.
   --  ------------------------------
   overriding
   procedure Finalize (Source : in out Builder) is
   begin
      Clear (Source);
   end Finalize;

end Util.Texts.Builders;

-----------------------------------------------------------------------
--  util-texts-builders -- Text builder
--  Copyright (C) 2013, 2016, 2017, 2021, 2022 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;

package body Util.Texts.Builders is

   --  ------------------------------
   --  Get the length of the item builder.
   --  ------------------------------
   function Length (Source : in Builder) return Natural is
   begin
      return Source.Length;
   end Length;

   --  ------------------------------
   --  Get the capacity of the builder.
   --  ------------------------------
   function Capacity (Source : in Builder) return Natural is
      B : constant Block_Access := Source.Current;
   begin
      return Source.Length + B.Len - B.Last;
   end Capacity;

   --  ------------------------------
   --  Get the builder block size.
   --  ------------------------------
   function Block_Size (Source : in Builder) return Positive is
   begin
      return Source.Block_Size;
   end Block_Size;

   --  ------------------------------
   --  Set the block size for the allocation of next chunks.
   --  ------------------------------
   procedure Set_Block_Size (Source : in out Builder;
                             Size   : in Positive) is
   begin
      Source.Block_Size := Size;
   end Set_Block_Size;

   --  ------------------------------
   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   --  ------------------------------
   procedure Append (Source   : in out Builder;
                     New_Item : in Input) is
      B     : Block_Access := Source.Current;
      Start : Natural := New_Item'First;
      Last  : constant Natural := New_Item'Last;
   begin
      while Start <= Last loop
         declare
            Space : Natural := B.Len - B.Last;
            Size  : constant Natural := Last - Start + 1;
         begin
            if Space > Size then
               Space := Size;
            elsif Space = 0 then
               if Size > Source.Block_Size then
                  B.Next_Block := new Block (Size);
               else
                  B.Next_Block := new Block (Source.Block_Size);
               end if;
               B := B.Next_Block;
               Source.Current := B;
               if B.Len > Size then
                  Space := Size;
               else
                  Space  := B.Len;
               end if;
            end if;
            B.Content (B.Last + 1 .. B.Last + Space) := New_Item (Start .. Start + Space - 1);
            Source.Length := Source.Length + Space;
            B.Last := B.Last + Space;
            Start  := Start + Space;
         end;
      end loop;
   end Append;

   --  ------------------------------
   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   --  ------------------------------
   procedure Append (Source   : in out Builder;
                     New_Item : in Element_Type) is
      B     : Block_Access := Source.Current;
   begin
      if B.Len = B.Last then
         B.Next_Block := new Block (Source.Block_Size);
         B := B.Next_Block;
         Source.Current := B;
      end if;
      Source.Length := Source.Length + 1;
      B.Last := B.Last + 1;
      B.Content (B.Last) := New_Item;
   end Append;

   procedure Inline_Append (Source   : in out Builder) is
      B     : Block_Access := Source.Current;
      Last  : Natural;
   begin
      loop
         if B.Len = B.Last then
            B.Next_Block := new Block (Source.Block_Size);
            B := B.Next_Block;
            Source.Current := B;
         end if;
         Process (B.Content (B.Last + 1 .. B.Len), Last);
         exit when Last > B.Len or Last <= B.Last;
         Source.Length := Source.Length + Last - B.Last;
         B.Last := Last;
         exit when Last < B.Len;
      end loop;
   end Inline_Append;

   --  ------------------------------
   --  Clear the source freeing any storage allocated for the buffer.
   --  ------------------------------
   procedure Clear (Source : in out Builder) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Block, Name => Block_Access);
      Current, Next : Block_Access;
   begin
      Next := Source.First.Next_Block;
      while Next /= null loop
         Current := Next;
         Next    := Current.Next_Block;
         Free (Current);
      end loop;
      Source.First.Next_Block := null;
      Source.First.Last       := 0;
      Source.Current          := Source.First'Unchecked_Access;
      Source.Length           := 0;
   end Clear;

   --  ------------------------------
   --  Iterate over the buffer content calling the <tt>Process</tt> procedure with each
   --  chunk.
   --  ------------------------------
   procedure Iterate (Source  : in Builder;
                      Process : not null access procedure (Chunk : in Input)) is
   begin
      if Source.First.Last > 0 then
         Process (Source.First.Content (1 .. Source.First.Last));
         declare
            B : Block_Access := Source.First.Next_Block;
         begin
            while B /= null loop
               Process (B.Content (1 .. B.Last));
               B := B.Next_Block;
            end loop;
         end;
      end if;
   end Iterate;

   procedure Inline_Iterate (Source  : in Builder) is
   begin
      if Source.First.Last > 0 then
         Process (Source.First.Content (1 .. Source.First.Last));
         declare
            B : Block_Access := Source.First.Next_Block;
         begin
            while B /= null loop
               Process (B.Content (1 .. B.Last));
               B := B.Next_Block;
            end loop;
         end;
      end if;
   end Inline_Iterate;

   --  ------------------------------
   --  Return the content starting from the tail and up to <tt>Length</tt> items.
   --  ------------------------------
   function Tail (Source : in Builder;
                  Length : in Natural) return Input is
      Last : constant Natural := Source.Current.Last;
   begin
      if Last >= Length then
         return Source.Current.Content (Last - Length + 1 .. Last);
      elsif Length >= Source.Length then
         return To_Array (Source);
      else
         declare
            Result  : Input (1 .. Length);
            Offset  : Natural := Source.Length - Length;
            B       : access constant Block := Source.First'Access;
            Src_Pos : Positive := 1;
            Dst_Pos : Positive := 1;
            Len     : Natural;
         begin
            --  Skip the data moving to next blocks as needed.
            while Offset /= 0 loop
               if Offset < B.Last then
                  Src_Pos := Offset + 1;
                  Offset := 0;
               else
                  Offset := Offset - B.Last + 1;
                  B := B.Next_Block;
               end if;
            end loop;

            --  Copy what remains until we reach the length.
            while Dst_Pos <= Length loop
               Len := B.Last - Src_Pos + 1;
               Result (Dst_Pos .. Dst_Pos + Len - 1) := B.Content (Src_Pos .. B.Last);
               Src_Pos := 1;
               Dst_Pos := Dst_Pos + Len;
               B := B.Next_Block;
            end loop;
            return Result;
         end;
      end if;
   end Tail;

   --  ------------------------------
   --  Get the buffer content as an array.
   --  ------------------------------
   function To_Array (Source : in Builder) return Input is
      Result : Input (1 .. Source.Length);
   begin
      if Source.First.Last > 0 then
         declare
            Pos : Positive := Source.First.Last;
            B   : Block_Access := Source.First.Next_Block;
         begin
            Result (1 .. Pos) := Source.First.Content (1 .. Pos);
            while B /= null loop
               Result (Pos + 1 .. Pos + B.Last) := B.Content (1 .. B.Last);
               Pos := Pos + B.Last;
               B   := B.Next_Block;
            end loop;
         end;
      end if;
      return Result;
   end To_Array;

   --  ------------------------------
   --  Get the element at the given position.
   --  ------------------------------
   function Element (Source   : in Builder;
                     Position : in Positive) return Element_Type is
   begin
      if Position <= Source.First.Last then
         return Source.First.Content (Position);
      else
         declare
            Pos : Positive := Position - Source.First.Last;
            B   : Block_Access := Source.First.Next_Block;
         begin
            loop
               if Pos <= B.Last then
                  return B.Content (Pos);
               end if;
               Pos := Pos - B.Last;
               B := B.Next_Block;
            end loop;
         end;
      end if;
   end Element;

   --  ------------------------------
   --  Call the <tt>Process</tt> procedure with the full buffer content, trying to avoid
   --  secondary stack copies as much as possible.
   --  ------------------------------
   procedure Get (Source : in Builder) is
   begin
      if Source.Length < Source.First.Len then
         Process (Source.First.Content (1 .. Source.Length));
      else
         declare
            Content : constant Input := To_Array (Source);
         begin
            Process (Content);
         end;
      end if;
   end Get;

   --  ------------------------------
   --  Format the message and replace occurrences of argument patterns by
   --  their associated value.
   --  Returns the formatted message in the stream
   --  ------------------------------
   procedure Format (Into      : in out Builder;
                     Message   : in Input;
                     Arguments : in Value_List) is
      C       : Element_Type;
      Old_Pos : Natural;
      N       : Natural := 0;
      Pos     : Natural := Message'First;
      First   : Natural := Pos;
   begin
      --  Replace {N} with arg1, arg2, arg3 or ?
      while Pos <= Message'Last loop
         C := Message (Pos);
         if Element_Type'Pos (C) = Character'Pos ('{') and then Pos + 1 <= Message'Last then
            if First /= Pos then
               Append (Into, Message (First .. Pos - 1));
            end if;
            N := 0;
            Pos := Pos + 1;
            C := Message (Pos);

            --  Handle {} replacement to emit the current argument and advance argument position.
            if Element_Type'Pos (C) = Character'Pos ('}') then
               Pos := Pos + 1;
               if N >= Arguments'Length then
                  First := Pos - 2;
               else
                  Append (Into, Arguments (N + Arguments'First));
                  First := Pos;
               end if;
               N := N + 1;
            else
               N := 0;
               Old_Pos := Pos - 1;
               loop
                  if Element_Type'Pos (C) >= Character'Pos ('0')
                    and Element_Type'Pos (C) <= Character'Pos ('9')
                  then
                     N := N * 10 + Natural (Element_Type'Pos (C) - Character'Pos ('0'));
                     Pos := Pos + 1;
                     if Pos > Message'Last then
                        First := Old_Pos;
                        exit;
                     end if;
                  elsif Element_Type'Pos (C) = Character'Pos ('}') then
                     Pos := Pos + 1;
                     if N >= Arguments'Length then
                        First := Old_Pos;
                     else
                        Append (Into, Arguments (N + Arguments'First));
                        First := Pos;
                     end if;
                     exit;
                  else
                     First := Old_Pos;
                     exit;
                  end if;
                  C := Message (Pos);
               end loop;
            end if;
         else
            Pos := Pos + 1;
         end if;
      end loop;
      if First /= Pos then
         Append (Into, Message (First .. Pos - 1));
      end if;
   end Format;

   --  ------------------------------
   --  Setup the builder.
   --  ------------------------------
   overriding
   procedure Initialize (Source : in out Builder) is
   begin
      Source.Current := Source.First'Unchecked_Access;
   end Initialize;

   --  ------------------------------
   --  Finalize the builder releasing the storage.
   --  ------------------------------
   overriding
   procedure Finalize (Source : in out Builder) is
   begin
      Clear (Source);
   end Finalize;

end Util.Texts.Builders;

Implement the Element function

Implement the Element function


-----------------------------------------------------------------------
--  mat-events-tools - Profiler Events Description
--  Copyright (C) 2014, 2015 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 Ada.Containers.Vectors;
package MAT.Events.Tools is

   Not_Found : exception;

   package Target_Event_Vectors is
     new Ada.Containers.Vectors (Positive, Target_Event_Type);

   subtype Target_Event_Vector is Target_Event_Vectors.Vector;
   subtype Target_Event_Cursor is Target_Event_Vectors.Cursor;

   --  Find in the list the first event with the given type.
   --  Raise <tt>Not_Found</tt> if the list does not contain such event.
   function Find (List : in Target_Event_Vector;
                  Kind : in Probe_Index_Type) return Target_Event_Type;

   type Event_Info_Type is record
      First_Event    : Target_Event_Type;
      Last_Event     : Target_Event_Type;
      Frame_Addr     : MAT.Types.Target_Addr;
      Count          : Natural;
      Malloc_Count   : Natural := 0;
      Realloc_Count  : Natural := 0;
      Free_Count     : Natural := 0;
      Alloc_Size     : MAT.Types.Target_Size := 0;
      Free_Size      : MAT.Types.Target_Size := 0;
   end record;

   --  Collect statistics information about events.
   procedure Collect_Info (Into  : in out Event_Info_Type;
                           Event : in MAT.Events.Target_Event_Type);

   package Size_Event_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Size,
                                      Element_Type => Event_Info_Type);
   subtype Size_Event_Info_Map is Size_Event_Info_Maps.Map;
   subtype Size_Event_Info_Cursor is Size_Event_Info_Maps.Cursor;

   --  The frame key is composed of the frame address and the frame level.
   type Frame_Key_Type is record
      Addr  : MAT.Types.Target_Addr;
      Level : Natural;
   end record;
   function "<" (Left, Right : in Frame_Key_Type) return Boolean;

   --  Ordered map to collect event info statistics by <frame, level> pair.
   package Frame_Event_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => Frame_Key_Type,
                                      Element_Type => Event_Info_Type);
   subtype Frame_Event_Info_Map is Frame_Event_Info_Maps.Map;
   subtype Frame_Event_Info_Cursor is Frame_Event_Info_Maps.Cursor;

   package Event_Info_Vectors is
     new Ada.Containers.Vectors (Index_Type   => Positive,
                                 Element_Type => Event_Info_Type);
   subtype Event_Info_Vector is Event_Info_Vectors.Vector;
   subtype Event_Info_Cursor is Event_Info_Vectors.Cursor;

   --  Extract from the frame info map, the list of event info sorted on the count.
   procedure Build_Event_Info (Map : in Frame_Event_Info_Map;
                               List : in out Event_Info_Vector);

   type Frame_Info_Type is record
      Key  : Frame_Key_Type;
      Info : Event_Info_Type;
   end record;

   package Frame_Info_Vectors is
     new Ada.Containers.Vectors (Index_Type   => Positive,
                                 Element_Type => Frame_Info_Type);
   subtype Frame_Info_Vector is Frame_Info_Vectors.Vector;
   subtype Frame_Info_Cursor is Frame_Info_Vectors.Cursor;

   --  Extract from the frame info map, the list of frame event info sorted
   --  on the frame level and slot size.
   procedure Build_Frame_Info (Map  : in Frame_Event_Info_Map;
                               List : in out Frame_Info_Vector);

end MAT.Events.Tools;

-----------------------------------------------------------------------
--  mat-events-tools - Profiler Events Description
--  Copyright (C) 2014, 2015 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 Ada.Containers.Vectors;
package MAT.Events.Tools is

   Not_Found : exception;

   package Target_Event_Vectors is
     new Ada.Containers.Vectors (Positive, Target_Event_Type);

   subtype Target_Event_Vector is Target_Event_Vectors.Vector;
   subtype Target_Event_Cursor is Target_Event_Vectors.Cursor;

   --  Find in the list the first event with the given type.
   --  Raise <tt>Not_Found</tt> if the list does not contain such event.
   function Find (List : in Target_Event_Vector;
                  Kind : in Probe_Index_Type) return Target_Event_Type;

   type Event_Info_Type is record
      First_Event    : Target_Event_Type;
      Last_Event     : Target_Event_Type;
      Count          : Natural := 0;
      Malloc_Count   : Natural := 0;
      Realloc_Count  : Natural := 0;
      Free_Count     : Natural := 0;
      Alloc_Size     : MAT.Types.Target_Size := 0;
      Free_Size      : MAT.Types.Target_Size := 0;
   end record;

   --  Collect statistics information about events.
   procedure Collect_Info (Into  : in out Event_Info_Type;
                           Event : in MAT.Events.Target_Event_Type);

   package Size_Event_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Size,
                                      Element_Type => Event_Info_Type);
   subtype Size_Event_Info_Map is Size_Event_Info_Maps.Map;
   subtype Size_Event_Info_Cursor is Size_Event_Info_Maps.Cursor;

   --  The frame key is composed of the frame address and the frame level.
   type Frame_Key_Type is record
      Addr  : MAT.Types.Target_Addr;
      Level : Natural;
   end record;
   function "<" (Left, Right : in Frame_Key_Type) return Boolean;

   --  Ordered map to collect event info statistics by <frame, level> pair.
   package Frame_Event_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => Frame_Key_Type,
                                      Element_Type => Event_Info_Type);
   subtype Frame_Event_Info_Map is Frame_Event_Info_Maps.Map;
   subtype Frame_Event_Info_Cursor is Frame_Event_Info_Maps.Cursor;

   package Event_Info_Vectors is
     new Ada.Containers.Vectors (Index_Type   => Positive,
                                 Element_Type => Event_Info_Type);
   subtype Event_Info_Vector is Event_Info_Vectors.Vector;
   subtype Event_Info_Cursor is Event_Info_Vectors.Cursor;

   --  Extract from the frame info map, the list of event info sorted on the count.
   procedure Build_Event_Info (Map : in Frame_Event_Info_Map;
                               List : in out Event_Info_Vector);

   type Frame_Info_Type is record
      Key  : Frame_Key_Type;
      Info : Event_Info_Type;
   end record;

   package Frame_Info_Vectors is
     new Ada.Containers.Vectors (Index_Type   => Positive,
                                 Element_Type => Frame_Info_Type);
   subtype Frame_Info_Vector is Frame_Info_Vectors.Vector;
   subtype Frame_Info_Cursor is Frame_Info_Vectors.Cursor;

   --  Extract from the frame info map, the list of frame event info sorted
   --  on the frame level and slot size.
   procedure Build_Frame_Info (Map  : in Frame_Event_Info_Map;
                               List : in out Frame_Info_Vector);

end MAT.Events.Tools;

Remove the Frame_Addr from the Event_Info_Type and setup the Count to 0


-----------------------------------------------------------------------
--  xmi -- XMI parser example
--  Copyright (C) 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.Text_IO;
with Ada.Command_Line;

with Util.Log.Loggers;
with Util.Beans;
with Util.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Serialize.IO.XML;

--  This sample reads an UML 1.4 model saved in XMI 1.2 format.  It uses the serialization
--  framework to indicate what XML nodes and attributes must be reported.
procedure XMI is

   use type Ada.Text_IO.Count;

   Reader : Util.Serialize.IO.XML.Parser;

   Count  : constant Natural := Ada.Command_Line.Argument_Count;

   type XMI_Fields is (FIELD_CLASS_NAME, FIELD_CLASS_ID, FIELD_STEREOTYPE,
                       FIELD_ATTRIBUTE_NAME,
                       FIELD_PACKAGE_NAME,
                       FIELD_PACKAGE_END,
                       FIELD_VISIBILITY,
                       FIELD_DATA_TYPE,
                       FIELD_ENUM_DATA_TYPE,
                       FIELD_ENUM_NAME,
                       FIELD_ENUM_END,
                       FIELD_ENUM_LITERAL,
                       FIELD_ENUM_LITERAL_END,
                       FIELD_CLASS_END,
                       FIELD_MULTIPLICITY_LOWER,
                       FIELD_MULTIPLICITY_UPPER,
                       FIELD_ASSOCIATION_AGGREGATION,
                       FIELD_ASSOCIATION_NAME,
                       FIELD_ASSOCIATION_VISIBILITY,
                       FIELD_ASSOCIATION_END_ID,
                       FIELD_ASSOCIATION_END,
                       FIELD_TAG_DEFINITION_ID,
                       FIELD_TAG_DEFINITION_NAME,
                       FIELD_OPERATION_NAME,
                       FIELD_COMMENT_NAME,
                       FIELD_COMMENT_BODY,
                       FIELD_COMMENT_CLASS_ID,
                       FIELD_TAGGED_VALUE_TYPE,
                       FIELD_TAGGED_VALUE_VALUE);

   type XMI_Info is record
      Indent : Ada.Text_IO.Count := 1;
   end record;
   type XMI_Access is access all XMI_Info;

   procedure Set_Member (P     : in out XMI_Info;
                         Field : in XMI_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Print (Col  : in Ada.Text_IO.Count;
                    Line : in String) is
   begin
      Ada.Text_IO.Set_Col (Col);
      Ada.Text_IO.Put_Line (Line);
   end Print;

   procedure Set_Member (P     : in out XMI_Info;
                         Field : in XMI_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
      when FIELD_CLASS_NAME =>
         Print (P.Indent, "Class " & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_VISIBILITY =>
         Print (P.Indent, "visibility: " & Util.Beans.Objects.To_String (Value));

      when FIELD_CLASS_ID =>
         Print (P.Indent, "id: " & Util.Beans.Objects.To_String (Value));

      when FIELD_ATTRIBUTE_NAME =>
         Ada.Text_IO.Set_Col (P.Indent);
         Ada.Text_IO.Put ("attr: " & Util.Beans.Objects.To_String (Value));

      when FIELD_MULTIPLICITY_LOWER =>
         Ada.Text_IO.Set_Col (P.Indent);
         Ada.Text_IO.Put ("  multiplicity: " & Util.Beans.Objects.To_String (Value));

      when FIELD_MULTIPLICITY_UPPER =>
         Ada.Text_IO.Put_Line (".." & Util.Beans.Objects.To_String (Value));

      when FIELD_STEREOTYPE =>
         Print (P.Indent, "<<" & Util.Beans.Objects.To_String (Value) & ">>");

      when FIELD_DATA_TYPE =>
         Print (P.Indent, "  data-type:" & Util.Beans.Objects.To_String (Value));

      when FIELD_ENUM_DATA_TYPE =>
         Print (P.Indent, "  enum-type:" & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_ENUM_NAME =>
         Print (P.Indent, "  enum " & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_ENUM_LITERAL =>
         Print (P.Indent, "  enum:" & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_OPERATION_NAME =>
         Print (P.Indent, "operation:" & Util.Beans.Objects.To_String (Value));

      when FIELD_ASSOCIATION_NAME =>
         Print (P.Indent, "association " & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_ASSOCIATION_VISIBILITY =>
         Print (P.Indent, "visibility: " & Util.Beans.Objects.To_String (Value));

      when FIELD_ASSOCIATION_AGGREGATION =>
         Print (P.Indent, "   aggregate: " & Util.Beans.Objects.To_String (Value));

      when FIELD_ASSOCIATION_END_ID =>
         Print (P.Indent, "   end-id: " & Util.Beans.Objects.To_String (Value));

      when FIELD_PACKAGE_NAME =>
         Print (P.Indent, "package " & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_TAGGED_VALUE_VALUE =>
         Print (P.Indent, "-- " & Util.Beans.Objects.To_String (Value));

      when FIELD_TAGGED_VALUE_TYPE =>
         Print (P.Indent, "tag-type: " & Util.Beans.Objects.To_String (Value));

      when FIELD_TAG_DEFINITION_NAME =>
         Print (P.Indent, "Tag: " & Util.Beans.Objects.To_String (Value));

      when FIELD_TAG_DEFINITION_ID =>
         Print (P.Indent, "  tag-id: " & Util.Beans.Objects.To_String (Value));

      when FIELD_COMMENT_NAME =>
         Print (P.Indent, "Comment: " & Util.Beans.Objects.To_String (Value));

      when FIELD_COMMENT_BODY =>
         Print (P.Indent, "   text: " & Util.Beans.Objects.To_String (Value));

      when FIELD_COMMENT_CLASS_ID =>
         Print (P.Indent, "   for-id: " & Util.Beans.Objects.To_String (Value));

      when FIELD_PACKAGE_END | FIELD_CLASS_END | FIELD_ENUM_END | FIELD_ENUM_LITERAL_END |
           FIELD_ASSOCIATION_END =>
         P.Indent := P.Indent - 2;

      end case;
   end Set_Member;

   package XMI_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => XMI_Info,
                                               Element_Type_Access => XMI_Access,
                                               Fields              => XMI_Fields,
                                               Set_Member          => Set_Member);

   XMI_Mapping        : aliased XMI_Mapper.Mapper;
   Mapper             : Util.Serialize.Mappers.Processing;

begin
--        Util.Log.Loggers.Initialize ("samples/log4j.properties");

   if Count = 0 then
      Ada.Text_IO.Put_Line ("Usage: xmi file...");
      Ada.Text_IO.Put_Line ("Example xmi samples/demo-atlas.xmi");
      return;
   end if;

   --  Define the XMI mapping.
   XMI_Mapping.Add_Mapping ("**/Package/@name", FIELD_PACKAGE_NAME);
   XMI_Mapping.Add_Mapping ("**/Package/@visibility", FIELD_VISIBILITY);
   XMI_Mapping.Add_Mapping ("**/Package", FIELD_PACKAGE_END);

   XMI_Mapping.Add_Mapping ("**/Class/@name", FIELD_CLASS_NAME);
   XMI_Mapping.Add_Mapping ("**/Class/@xmi.idref", FIELD_CLASS_NAME);
   XMI_Mapping.Add_Mapping ("**/Class/@xmi.id", FIELD_CLASS_ID);
   XMI_Mapping.Add_Mapping ("**/Class/@visibility", FIELD_VISIBILITY);
   XMI_Mapping.Add_Mapping ("**/Class", FIELD_CLASS_END);

   XMI_Mapping.Add_Mapping ("**/Stereotype/@href", FIELD_STEREOTYPE);
   XMI_Mapping.Add_Mapping ("**/Stereotype/@name", FIELD_STEREOTYPE);

   XMI_Mapping.Add_Mapping ("**/Attribute/@name", FIELD_ATTRIBUTE_NAME);
   XMI_Mapping.Add_Mapping ("**/Attribute/@visibility", FIELD_VISIBILITY);

   XMI_Mapping.Add_Mapping ("**/TaggedValue.dataValue", FIELD_TAGGED_VALUE_VALUE);

   XMI_Mapping.Add_Mapping ("**/DataType/@href", FIELD_DATA_TYPE);

   XMI_Mapping.Add_Mapping ("**/Enumeration/@href", FIELD_ENUM_NAME);
   XMI_Mapping.Add_Mapping ("**/Enumeration/@name", FIELD_ENUM_NAME);
   XMI_Mapping.Add_Mapping ("**/Enumeration", FIELD_ENUM_END);

   XMI_Mapping.Add_Mapping ("**/EnumerationLiteral/@name", FIELD_ENUM_LITERAL);
   XMI_Mapping.Add_Mapping ("**/EnumerationLiteral", FIELD_ENUM_LITERAL_END);

   XMI_Mapping.Add_Mapping ("**/MultiplicityRange/@lower", FIELD_MULTIPLICITY_LOWER);
   XMI_Mapping.Add_Mapping ("**/MultiplicityRange/@upper", FIELD_MULTIPLICITY_UPPER);

   XMI_Mapping.Add_Mapping ("**/Operation/@name", FIELD_OPERATION_NAME);
   XMI_Mapping.Add_Mapping ("**/Operation/@visibility", FIELD_VISIBILITY);

   XMI_Mapping.Add_Mapping ("**/Association/@name", FIELD_ASSOCIATION_NAME);
   XMI_Mapping.Add_Mapping ("**/Association/@visibility", FIELD_ASSOCIATION_VISIBILITY);
   XMI_Mapping.Add_Mapping ("**/Association/@aggregation", FIELD_ASSOCIATION_AGGREGATION);
   XMI_Mapping.Add_Mapping ("**/AssociationEnd.participant/Class/@xmi.idref",
                            FIELD_ASSOCIATION_END_ID);
   XMI_Mapping.Add_Mapping ("**/Association", FIELD_ASSOCIATION_END);

   XMI_Mapping.Add_Mapping ("**/TagDefinition/@name", FIELD_TAG_DEFINITION_NAME);
   XMI_Mapping.Add_Mapping ("**/TagDefinition/@xm.id", FIELD_TAG_DEFINITION_ID);

   XMI_Mapping.Add_Mapping ("**/Comment/@name", FIELD_COMMENT_NAME);
   XMI_Mapping.Add_Mapping ("**/Comment/@body", FIELD_COMMENT_BODY);
   XMI_Mapping.Add_Mapping ("**/Comment/Comment.annotatedElement/Class/@xmi.idref",
                            FIELD_COMMENT_CLASS_ID);

   Mapper.Add_Mapping ("XMI", XMI_Mapping'Unchecked_Access);

   for I in 1 .. Count loop
      declare
         S    : constant String := Ada.Command_Line.Argument (I);
         Data : aliased XMI_Info;
      begin
         XMI_Mapper.Set_Context (Mapper, Data'Unchecked_Access);
         Reader.Parse (S, Mapper);
      end;
   end loop;
end XMI;

-----------------------------------------------------------------------
--  xmi -- XMI parser example
--  Copyright (C) 2012, 2022 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.Text_IO;
with Ada.Command_Line;

with Util.Beans;
with Util.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Serialize.IO.XML;

--  This sample reads an UML 1.4 model saved in XMI 1.2 format.  It uses the serialization
--  framework to indicate what XML nodes and attributes must be reported.
procedure XMI is

   use type Ada.Text_IO.Count;

   Reader : Util.Serialize.IO.XML.Parser;

   Count  : constant Natural := Ada.Command_Line.Argument_Count;

   type XMI_Fields is (FIELD_CLASS_NAME, FIELD_CLASS_ID, FIELD_STEREOTYPE,
                       FIELD_ATTRIBUTE_NAME,
                       FIELD_PACKAGE_NAME,
                       FIELD_PACKAGE_END,
                       FIELD_VISIBILITY,
                       FIELD_DATA_TYPE,
                       FIELD_ENUM_DATA_TYPE,
                       FIELD_ENUM_NAME,
                       FIELD_ENUM_END,
                       FIELD_ENUM_LITERAL,
                       FIELD_ENUM_LITERAL_END,
                       FIELD_CLASS_END,
                       FIELD_MULTIPLICITY_LOWER,
                       FIELD_MULTIPLICITY_UPPER,
                       FIELD_ASSOCIATION_AGGREGATION,
                       FIELD_ASSOCIATION_NAME,
                       FIELD_ASSOCIATION_VISIBILITY,
                       FIELD_ASSOCIATION_END_ID,
                       FIELD_ASSOCIATION_END,
                       FIELD_TAG_DEFINITION_ID,
                       FIELD_TAG_DEFINITION_NAME,
                       FIELD_OPERATION_NAME,
                       FIELD_COMMENT_NAME,
                       FIELD_COMMENT_BODY,
                       FIELD_COMMENT_CLASS_ID,
                       FIELD_TAGGED_VALUE_TYPE,
                       FIELD_TAGGED_VALUE_VALUE);

   type XMI_Info is record
      Indent : Ada.Text_IO.Count := 1;
   end record;
   type XMI_Access is access all XMI_Info;

   procedure Set_Member (P     : in out XMI_Info;
                         Field : in XMI_Fields;
                         Value : in Util.Beans.Objects.Object);
   procedure Print (Col  : in Ada.Text_IO.Count;
                    Line : in String);

   procedure Print (Col  : in Ada.Text_IO.Count;
                    Line : in String) is
   begin
      Ada.Text_IO.Set_Col (Col);
      Ada.Text_IO.Put_Line (Line);
   end Print;

   procedure Set_Member (P     : in out XMI_Info;
                         Field : in XMI_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
      when FIELD_CLASS_NAME =>
         Print (P.Indent, "Class " & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_VISIBILITY =>
         Print (P.Indent, "visibility: " & Util.Beans.Objects.To_String (Value));

      when FIELD_CLASS_ID =>
         Print (P.Indent, "id: " & Util.Beans.Objects.To_String (Value));

      when FIELD_ATTRIBUTE_NAME =>
         Ada.Text_IO.Set_Col (P.Indent);
         Ada.Text_IO.Put ("attr: " & Util.Beans.Objects.To_String (Value));

      when FIELD_MULTIPLICITY_LOWER =>
         Ada.Text_IO.Set_Col (P.Indent);
         Ada.Text_IO.Put ("  multiplicity: " & Util.Beans.Objects.To_String (Value));

      when FIELD_MULTIPLICITY_UPPER =>
         Ada.Text_IO.Put_Line (".." & Util.Beans.Objects.To_String (Value));

      when FIELD_STEREOTYPE =>
         Print (P.Indent, "<<" & Util.Beans.Objects.To_String (Value) & ">>");

      when FIELD_DATA_TYPE =>
         Print (P.Indent, "  data-type:" & Util.Beans.Objects.To_String (Value));

      when FIELD_ENUM_DATA_TYPE =>
         Print (P.Indent, "  enum-type:" & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_ENUM_NAME =>
         Print (P.Indent, "  enum " & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_ENUM_LITERAL =>
         Print (P.Indent, "  enum:" & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_OPERATION_NAME =>
         Print (P.Indent, "operation:" & Util.Beans.Objects.To_String (Value));

      when FIELD_ASSOCIATION_NAME =>
         Print (P.Indent, "association " & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_ASSOCIATION_VISIBILITY =>
         Print (P.Indent, "visibility: " & Util.Beans.Objects.To_String (Value));

      when FIELD_ASSOCIATION_AGGREGATION =>
         Print (P.Indent, "   aggregate: " & Util.Beans.Objects.To_String (Value));

      when FIELD_ASSOCIATION_END_ID =>
         Print (P.Indent, "   end-id: " & Util.Beans.Objects.To_String (Value));

      when FIELD_PACKAGE_NAME =>
         Print (P.Indent, "package " & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_TAGGED_VALUE_VALUE =>
         Print (P.Indent, "-- " & Util.Beans.Objects.To_String (Value));

      when FIELD_TAGGED_VALUE_TYPE =>
         Print (P.Indent, "tag-type: " & Util.Beans.Objects.To_String (Value));

      when FIELD_TAG_DEFINITION_NAME =>
         Print (P.Indent, "Tag: " & Util.Beans.Objects.To_String (Value));

      when FIELD_TAG_DEFINITION_ID =>
         Print (P.Indent, "  tag-id: " & Util.Beans.Objects.To_String (Value));

      when FIELD_COMMENT_NAME =>
         Print (P.Indent, "Comment: " & Util.Beans.Objects.To_String (Value));

      when FIELD_COMMENT_BODY =>
         Print (P.Indent, "   text: " & Util.Beans.Objects.To_String (Value));

      when FIELD_COMMENT_CLASS_ID =>
         Print (P.Indent, "   for-id: " & Util.Beans.Objects.To_String (Value));

      when FIELD_PACKAGE_END | FIELD_CLASS_END | FIELD_ENUM_END | FIELD_ENUM_LITERAL_END |
           FIELD_ASSOCIATION_END =>
         P.Indent := P.Indent - 2;

      end case;
   end Set_Member;

   package XMI_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => XMI_Info,
                                               Element_Type_Access => XMI_Access,
                                               Fields              => XMI_Fields,
                                               Set_Member          => Set_Member);

   XMI_Mapping        : aliased XMI_Mapper.Mapper;
   Mapper             : Util.Serialize.Mappers.Processing;

begin
--        Util.Log.Loggers.Initialize ("samples/log4j.properties");

   if Count = 0 then
      Ada.Text_IO.Put_Line ("Usage: xmi file...");
      Ada.Text_IO.Put_Line ("Example xmi samples/demo-atlas.xmi");
      return;
   end if;

   --  Define the XMI mapping.
   XMI_Mapping.Add_Mapping ("**/Package/@name", FIELD_PACKAGE_NAME);
   XMI_Mapping.Add_Mapping ("**/Package/@visibility", FIELD_VISIBILITY);
   XMI_Mapping.Add_Mapping ("**/Package", FIELD_PACKAGE_END);

   XMI_Mapping.Add_Mapping ("**/Class/@name", FIELD_CLASS_NAME);
   XMI_Mapping.Add_Mapping ("**/Class/@xmi.idref", FIELD_CLASS_NAME);
   XMI_Mapping.Add_Mapping ("**/Class/@xmi.id", FIELD_CLASS_ID);
   XMI_Mapping.Add_Mapping ("**/Class/@visibility", FIELD_VISIBILITY);
   XMI_Mapping.Add_Mapping ("**/Class", FIELD_CLASS_END);

   XMI_Mapping.Add_Mapping ("**/Stereotype/@href", FIELD_STEREOTYPE);
   XMI_Mapping.Add_Mapping ("**/Stereotype/@name", FIELD_STEREOTYPE);

   XMI_Mapping.Add_Mapping ("**/Attribute/@name", FIELD_ATTRIBUTE_NAME);
   XMI_Mapping.Add_Mapping ("**/Attribute/@visibility", FIELD_VISIBILITY);

   XMI_Mapping.Add_Mapping ("**/TaggedValue.dataValue", FIELD_TAGGED_VALUE_VALUE);

   XMI_Mapping.Add_Mapping ("**/DataType/@href", FIELD_DATA_TYPE);

   XMI_Mapping.Add_Mapping ("**/Enumeration/@href", FIELD_ENUM_NAME);
   XMI_Mapping.Add_Mapping ("**/Enumeration/@name", FIELD_ENUM_NAME);
   XMI_Mapping.Add_Mapping ("**/Enumeration", FIELD_ENUM_END);

   XMI_Mapping.Add_Mapping ("**/EnumerationLiteral/@name", FIELD_ENUM_LITERAL);
   XMI_Mapping.Add_Mapping ("**/EnumerationLiteral", FIELD_ENUM_LITERAL_END);

   XMI_Mapping.Add_Mapping ("**/MultiplicityRange/@lower", FIELD_MULTIPLICITY_LOWER);
   XMI_Mapping.Add_Mapping ("**/MultiplicityRange/@upper", FIELD_MULTIPLICITY_UPPER);

   XMI_Mapping.Add_Mapping ("**/Operation/@name", FIELD_OPERATION_NAME);
   XMI_Mapping.Add_Mapping ("**/Operation/@visibility", FIELD_VISIBILITY);

   XMI_Mapping.Add_Mapping ("**/Association/@name", FIELD_ASSOCIATION_NAME);
   XMI_Mapping.Add_Mapping ("**/Association/@visibility", FIELD_ASSOCIATION_VISIBILITY);
   XMI_Mapping.Add_Mapping ("**/Association/@aggregation", FIELD_ASSOCIATION_AGGREGATION);
   XMI_Mapping.Add_Mapping ("**/AssociationEnd.participant/Class/@xmi.idref",
                            FIELD_ASSOCIATION_END_ID);
   XMI_Mapping.Add_Mapping ("**/Association", FIELD_ASSOCIATION_END);

   XMI_Mapping.Add_Mapping ("**/TagDefinition/@name", FIELD_TAG_DEFINITION_NAME);
   XMI_Mapping.Add_Mapping ("**/TagDefinition/@xm.id", FIELD_TAG_DEFINITION_ID);

   XMI_Mapping.Add_Mapping ("**/Comment/@name", FIELD_COMMENT_NAME);
   XMI_Mapping.Add_Mapping ("**/Comment/@body", FIELD_COMMENT_BODY);
   XMI_Mapping.Add_Mapping ("**/Comment/Comment.annotatedElement/Class/@xmi.idref",
                            FIELD_COMMENT_CLASS_ID);

   Mapper.Add_Mapping ("XMI", XMI_Mapping'Unchecked_Access);

   for I in 1 .. Count loop
      declare
         S    : constant String := Ada.Command_Line.Argument (I);
         Data : aliased XMI_Info;
      begin
         XMI_Mapper.Set_Context (Mapper, Data'Unchecked_Access);
         Reader.Parse (S, Mapper);
      end;
   end loop;
end XMI;

Fix compilation warning

Fix compilation warning


-----------------------------------------------------------------------
--  date -- Print the date
--  Copyright (C) 2011, 2021 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.Text_IO;
with Ada.Calendar;
with Ada.Strings.Unbounded;
with GNAT.Command_Line;

with Util.Log.Loggers;
with Util.Dates.Formats;
with Util.Properties.Bundles;
procedure Date is

   use type Ada.Calendar.Time;
   use Util.Log.Loggers;
   use Ada.Strings.Unbounded;
   use Util.Properties.Bundles;
   use GNAT.Command_Line;

   Log         : constant Logger := Create ("log");

   Factory     : Util.Properties.Bundles.Loader;
   Bundle      : Util.Properties.Bundles.Manager;
   Locale      : Unbounded_String := To_Unbounded_String ("en");
   Date        : constant Ada.Calendar.Time := Ada.Calendar.Clock;
   Use_Default : Boolean := True;
begin
   Util.Log.Loggers.Initialize ("samples/log4j.properties");

   --  Load the bundles from the current directory
   Initialize (Factory, "samples/;bundles");

   loop
      case Getopt ("h l: locale: help") is
         when ASCII.NUL =>
            exit;

         when 'l' =>
            Locale := To_Unbounded_String (Parameter);

         when others =>
            raise GNAT.Command_Line.Invalid_Switch;
      end case;
   end loop;
   begin
      Load_Bundle (Factory, "dates", To_String (Locale), Bundle);

   exception
      when NO_BUNDLE =>
         Log.Error ("There is no bundle: {0}", "dates");
   end;
   loop
      declare
         Pattern : constant String := Get_Argument;
      begin
         exit when Pattern = "";

         Use_Default := False;
         Ada.Text_IO.Put_Line (Util.Dates.Formats.Format (Pattern => Pattern,
                                                          Date    => Date,
                                                          Bundle  => Bundle));
      end;
   end loop;
   if Use_Default then
      Ada.Text_IO.Put_Line (Util.Dates.Formats.Format (Pattern => "%a %b %_d %T %Y",
                                                       Date    => Date,
                                                       Bundle  => Bundle));
   end if;

exception
   when GNAT.Command_Line.Invalid_Switch =>
      Log.Error ("Usage: date -l locale format");
end Date;

-----------------------------------------------------------------------
--  date -- Print the date
--  Copyright (C) 2011, 2021, 2022 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.Text_IO;
with Ada.Calendar;
with Ada.Strings.Unbounded;
with GNAT.Command_Line;

with Util.Log.Loggers;
with Util.Dates.Formats;
with Util.Properties.Bundles;
procedure Date is

   use Util.Log.Loggers;
   use Ada.Strings.Unbounded;
   use Util.Properties.Bundles;
   use GNAT.Command_Line;

   Log         : constant Logger := Create ("log");

   Factory     : Util.Properties.Bundles.Loader;
   Bundle      : Util.Properties.Bundles.Manager;
   Locale      : Unbounded_String := To_Unbounded_String ("en");
   Date        : constant Ada.Calendar.Time := Ada.Calendar.Clock;
   Use_Default : Boolean := True;
begin
   Util.Log.Loggers.Initialize ("samples/log4j.properties");

   --  Load the bundles from the current directory
   Initialize (Factory, "samples/;bundles");

   loop
      case Getopt ("h l: locale: help") is
         when ASCII.NUL =>
            exit;

         when 'l' =>
            Locale := To_Unbounded_String (Parameter);

         when others =>
            raise GNAT.Command_Line.Invalid_Switch;
      end case;
   end loop;
   begin
      Load_Bundle (Factory, "dates", To_String (Locale), Bundle);

   exception
      when NO_BUNDLE =>
         Log.Error ("There is no bundle: {0}", "dates");
   end;
   loop
      declare
         Pattern : constant String := Get_Argument;
      begin
         exit when Pattern = "";

         Use_Default := False;
         Ada.Text_IO.Put_Line (Util.Dates.Formats.Format (Pattern => Pattern,
                                                          Date    => Date,
                                                          Bundle  => Bundle));
      end;
   end loop;
   if Use_Default then
      Ada.Text_IO.Put_Line (Util.Dates.Formats.Format (Pattern => "%a %b %_d %T %Y",
                                                       Date    => Date,
                                                       Bundle  => Bundle));
   end if;

exception
   when GNAT.Command_Line.Invalid_Switch =>
      Log.Error ("Usage: date -l locale format");
end Date;

Fix compilation warning

Fix compilation warning


-----------------------------------------------------------------------
--  ado-schemas-tests -- Test loading of database schema
--  Copyright (C) 2009 - 2020 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.Directories;

with Util.Test_Caller;
with Util.Strings.Vectors;
with Util.Strings.Transforms;

with ADO.Parameters;
with ADO.Schemas.Databases;
with ADO.Sessions.Sources;
with ADO.Sessions.Entities;
with ADO.Schemas.Entities;

with Regtests;
with Regtests.Audits.Model;
with Regtests.Simple.Model;
package body ADO.Schemas.Tests is

   use Util.Tests;

   function To_Lower_Case (S : in String) return String
     renames Util.Strings.Transforms.To_Lower_Case;

   package Caller is new Util.Test_Caller (Test, "ADO.Schemas");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type",
                       Test_Find_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type (error)",
                       Test_Find_Entity_Type_Error'Access);
      Caller.Add_Test (Suite, "Test ADO.Sessions.Load_Schema",
                       Test_Load_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table",
                       Test_Table_Iterator'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table (Empty schema)",
                       Test_Empty_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Databases.Create_Database",
                       Test_Create_Schema'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the entity cache and the Find_Entity_Type operation
   --  ------------------------------
   procedure Test_Find_Entity_Type (T : in out Test) is
      S   : ADO.Sessions.Session := Regtests.Get_Database;
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      ADO.Schemas.Entities.Initialize (Cache   => C,
                                       Session => S);

      declare
         T4 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.ALLOCATE_TABLE);
         T5 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T1 : constant ADO.Entity_Type
           := Sessions.Entities.Find_Entity_Type (Session => S,
                                                  Table   => Regtests.Audits.Model.AUDIT_TABLE);
         T2 : constant ADO.Entity_Type
           := Sessions.Entities.Find_Entity_Type (Session => S,
                                                  Table   => Regtests.Audits.Model.EMAIL_TABLE);
         T3 : constant ADO.Entity_Type
           := Sessions.Entities.Find_Entity_Type (Session => S,
                                                  Name    => "audit_property");
      begin
         T.Assert (T1 > 0, "T1 must be positive");
         T.Assert (T2 > 0, "T2 must be positive");
         T.Assert (T3 > 0, "T3 must be positive");
         T.Assert (T4 > 0, "T4 must be positive");
         T.Assert (T5 > 0, "T5 must be positive");

         T.Assert (T1 /= T2, "Two distinct tables have different entity types (T1, T2)");
         T.Assert (T2 /= T3, "Two distinct tables have different entity types (T2, T3)");
         T.Assert (T3 /= T4, "Two distinct tables have different entity types (T3, T4)");
         T.Assert (T4 /= T5, "Two distinct tables have different entity types (T4, T5)");
         T.Assert (T5 /= T1, "Two distinct tables have different entity types (T5, T1)");
      end;
   end Test_Find_Entity_Type;

   --  ------------------------------
   --  Test calling Find_Entity_Type with an invalid table.
   --  ------------------------------
   procedure Test_Find_Entity_Type_Error (T : in out Test) is
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      declare
         R : ADO.Entity_Type;
         pragma Unreferenced (R);
      begin
         R := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T.Assert (False, "Find_Entity_Type did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;

      declare
         P : ADO.Parameters.Parameter
           := ADO.Parameters.Parameter'(T => ADO.Parameters.T_INTEGER, Num => 0,
                                        Len => 0, Value_Len => 0, Position => 0, Name => "");
      begin
         P := C.Expand ("something");
         T.Assert (False, "Expand did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;
   end Test_Find_Entity_Type_Error;

   --  ------------------------------
   --  Test the Load_Schema operation and check the result schema.
   --  ------------------------------
   procedure Test_Load_Schema (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
   begin
      S.Load_Schema (Schema);

      Table := ADO.Schemas.Find_Table (Schema, "allocate");
      T.Assert (Table /= null, "Table schema for test_allocate not found");

      Assert_Equals (T, "allocate", Get_Name (Table));

      declare
         C : Column_Cursor := Get_Columns (Table);
         Nb_Columns : Integer := 0;
      begin
         while Has_Element (C) loop
            Nb_Columns := Nb_Columns + 1;
            Next (C);
         end loop;
         Assert_Equals (T, 3, Nb_Columns, "Invalid number of columns");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "ID");
      begin
         T.Assert (C /= null, "Cannot find column 'id' in table schema");
         Assert_Equals (T, "id", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_LONG_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
         T.Assert (Is_Primary (C), "Column must be a primary key");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "NAME");
      begin
         T.Assert (C /= null, "Cannot find column 'NAME' in table schema");
         Assert_Equals (T, "name", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_VARCHAR, "Invalid column type");
         T.Assert (Is_Null (C), "Column is null");
         T.Assert (not Is_Primary (C), "Column must not be a primary key");
         Assert_Equals (T, 255, Get_Size (C), "Column has invalid size");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "version");
      begin
         T.Assert (C /= null, "Cannot find column 'version' in table schema");
         Assert_Equals (T, "version", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "this_column_does_not_exist");
      begin
         T.Assert (C = null, "Find_Column must return null for an unknown column");
      end;
   end Test_Load_Schema;

   --  ------------------------------
   --  Test the Table_Cursor operations and check the result schema.
   --  ------------------------------
   procedure Test_Table_Iterator (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
      Driver : constant String := S.Get_Driver.Get_Driver_Name;
   begin
      S.Load_Schema (Schema);

      declare
         Iter  : Table_Cursor := Schema.Get_Tables;
         Count : Natural := 0;
      begin
         T.Assert (Has_Element (Iter), "The Get_Tables returns an empty iterator");
         while Has_Element (Iter) loop
            Table := Element (Iter);
            T.Assert (Table /= null, "Element function must not return null");
            declare
               Col_Iter : Column_Cursor := Get_Columns (Table);
            begin
               --  T.Assert (Has_Element (Col_Iter), "Table has a column");
               while Has_Element (Col_Iter) loop
                  T.Assert (Element (Col_Iter) /= null, "Element function must not return null");
                  Next (Col_Iter);
               end loop;
            end;
            Count := Count + 1;
            Next (Iter);
         end loop;
         if Driver = "sqlite" then
            Util.Tests.Assert_Equals (T, 11, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "mysql" then
            Util.Tests.Assert_Equals (T, 11, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "postgresql" then
            Util.Tests.Assert_Equals (T, 11, Count,
                                      "Invalid number of tables found in the schema");
         end if;
      end;
   end Test_Table_Iterator;

   --  ------------------------------
   --  Test the Table_Cursor operations on an empty schema.
   --  ------------------------------
   procedure Test_Empty_Schema (T : in out Test) is
      Schema : Schema_Definition;
      Iter   : constant Table_Cursor := Schema.Get_Tables;
   begin
      T.Assert (not Has_Element (Iter), "The Get_Tables must return an empty iterator");
      T.Assert (Schema.Find_Table ("test") = null, "The Find_Table must return null");
   end Test_Empty_Schema;

   --  ------------------------------
   --  Test the creation of database.
   --  ------------------------------
   procedure Test_Create_Schema (T : in out Test) is
      use ADO.Sessions.Sources;

      Msg      : Util.Strings.Vectors.Vector;
      Cfg      : Data_Source := Data_Source (Regtests.Get_Controller);
      Driver   : constant String := Cfg.Get_Driver;
      Database : constant String := Cfg.Get_Database;
      Path     : constant String :=
        "db/regtests/" & Cfg.Get_Driver & "/create-ado-" & Driver & ".sql";

      pragma Unreferenced (Msg);
   begin
      if Driver = "sqlite" then
         if Ada.Directories.Exists (Database & ".test") then
            Ada.Directories.Delete_File (Database & ".test");
         end if;
         Cfg.Set_Database (Database & ".test");
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
         T.Assert (Ada.Directories.Exists (Database & ".test"),
                   "The sqlite database was not created");
      else
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
      end if;
   end Test_Create_Schema;

end ADO.Schemas.Tests;

-----------------------------------------------------------------------
--  ado-schemas-tests -- Test loading of database schema
--  Copyright (C) 2009 - 2020 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.Directories;

with Util.Test_Caller;
with Util.Strings.Vectors;
with Util.Strings.Transforms;

with ADO.Parameters;
with ADO.Schemas.Databases;
with ADO.Sessions.Sources;
with ADO.Sessions.Entities;
with ADO.Schemas.Entities;

with Regtests;
with Regtests.Audits.Model;
with Regtests.Simple.Model;
package body ADO.Schemas.Tests is

   use Util.Tests;

   function To_Lower_Case (S : in String) return String
     renames Util.Strings.Transforms.To_Lower_Case;

   package Caller is new Util.Test_Caller (Test, "ADO.Schemas");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type",
                       Test_Find_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type (error)",
                       Test_Find_Entity_Type_Error'Access);
      Caller.Add_Test (Suite, "Test ADO.Sessions.Load_Schema",
                       Test_Load_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table",
                       Test_Table_Iterator'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table (Empty schema)",
                       Test_Empty_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Databases.Create_Database",
                       Test_Create_Schema'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the entity cache and the Find_Entity_Type operation
   --  ------------------------------
   procedure Test_Find_Entity_Type (T : in out Test) is
      S   : ADO.Sessions.Session := Regtests.Get_Database;
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      ADO.Schemas.Entities.Initialize (Cache   => C,
                                       Session => S);

      declare
         T4 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.ALLOCATE_TABLE);
         T5 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T1 : constant ADO.Entity_Type
           := Sessions.Entities.Find_Entity_Type (Session => S,
                                                  Table   => Regtests.Audits.Model.AUDIT_TABLE);
         T2 : constant ADO.Entity_Type
           := Sessions.Entities.Find_Entity_Type (Session => S,
                                                  Table   => Regtests.Audits.Model.EMAIL_TABLE);
         T3 : constant ADO.Entity_Type
           := Sessions.Entities.Find_Entity_Type (Session => S,
                                                  Name    => "audit_property");
      begin
         T.Assert (T1 > 0, "T1 must be positive");
         T.Assert (T2 > 0, "T2 must be positive");
         T.Assert (T3 > 0, "T3 must be positive");
         T.Assert (T4 > 0, "T4 must be positive");
         T.Assert (T5 > 0, "T5 must be positive");

         T.Assert (T1 /= T2, "Two distinct tables have different entity types (T1, T2)");
         T.Assert (T2 /= T3, "Two distinct tables have different entity types (T2, T3)");
         T.Assert (T3 /= T4, "Two distinct tables have different entity types (T3, T4)");
         T.Assert (T4 /= T5, "Two distinct tables have different entity types (T4, T5)");
         T.Assert (T5 /= T1, "Two distinct tables have different entity types (T5, T1)");
      end;
   end Test_Find_Entity_Type;

   --  ------------------------------
   --  Test calling Find_Entity_Type with an invalid table.
   --  ------------------------------
   procedure Test_Find_Entity_Type_Error (T : in out Test) is
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      declare
         R : ADO.Entity_Type;
         pragma Unreferenced (R);
      begin
         R := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T.Assert (False, "Find_Entity_Type did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;

      declare
         P : ADO.Parameters.Parameter
           := ADO.Parameters.Parameter'(T => ADO.Parameters.T_INTEGER, Num => 0,
                                        Len => 0, Value_Len => 0, Position => 0, Name => "");
      begin
         P := C.Expand ("something");
         T.Assert (False, "Expand did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;
   end Test_Find_Entity_Type_Error;

   --  ------------------------------
   --  Test the Load_Schema operation and check the result schema.
   --  ------------------------------
   procedure Test_Load_Schema (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
   begin
      S.Load_Schema (Schema);

      Table := ADO.Schemas.Find_Table (Schema, "allocate");
      T.Assert (Table /= null, "Table schema for test_allocate not found");

      Assert_Equals (T, "allocate", Get_Name (Table));

      declare
         C : Column_Cursor := Get_Columns (Table);
         Nb_Columns : Integer := 0;
      begin
         while Has_Element (C) loop
            Nb_Columns := Nb_Columns + 1;
            Next (C);
         end loop;
         Assert_Equals (T, 3, Nb_Columns, "Invalid number of columns");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "ID");
      begin
         T.Assert (C /= null, "Cannot find column 'id' in table schema");
         Assert_Equals (T, "id", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_LONG_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
         T.Assert (Is_Primary (C), "Column must be a primary key");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "NAME");
      begin
         T.Assert (C /= null, "Cannot find column 'NAME' in table schema");
         Assert_Equals (T, "name", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_VARCHAR, "Invalid column type");
         T.Assert (Is_Null (C), "Column is null");
         T.Assert (not Is_Primary (C), "Column must not be a primary key");
         Assert_Equals (T, 255, Get_Size (C), "Column has invalid size");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "version");
      begin
         T.Assert (C /= null, "Cannot find column 'version' in table schema");
         Assert_Equals (T, "version", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
         Assert_Equals (T, "", Get_Default (C), "Column has a default value");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "this_column_does_not_exist");
      begin
         T.Assert (C = null, "Find_Column must return null for an unknown column");
      end;

      Table := ADO.Schemas.Find_Table (Schema, "audit_property");
      T.Assert (Table /= null, "Table schema for audit_property not found");

      Assert_Equals (T, "audit_property", Get_Name (Table));
      declare
         C : Column_Cursor := Get_Columns (Table);
         Nb_Columns : Integer := 0;
      begin
         while Has_Element (C) loop
            Nb_Columns := Nb_Columns + 1;
            Next (C);
         end loop;
         Assert_Equals (T, 7, Nb_Columns, "Invalid number of columns");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "float_value");
      begin
         T.Assert (C /= null, "Cannot find column 'float_value' in table schema");
         Assert_Equals (T, "float_value", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_FLOAT, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
         T.Assert (not Is_Binary (C), "Column is binary");
         T.Assert (not Is_Primary (C), "Column must be not be a primary key");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "double_value");
      begin
         T.Assert (C /= null, "Cannot find column 'double_value' in table schema");
         Assert_Equals (T, "double_value", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_DOUBLE, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
         T.Assert (not Is_Binary (C), "Column is binary");
         T.Assert (not Is_Primary (C), "Column must be not be a primary key");
      end;

   end Test_Load_Schema;

   --  ------------------------------
   --  Test the Table_Cursor operations and check the result schema.
   --  ------------------------------
   procedure Test_Table_Iterator (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
      Driver : constant String := S.Get_Driver.Get_Driver_Name;
   begin
      S.Load_Schema (Schema);

      declare
         Iter  : Table_Cursor := Schema.Get_Tables;
         Count : Natural := 0;
      begin
         T.Assert (Has_Element (Iter), "The Get_Tables returns an empty iterator");
         while Has_Element (Iter) loop
            Table := Element (Iter);
            T.Assert (Table /= null, "Element function must not return null");
            declare
               Col_Iter : Column_Cursor := Get_Columns (Table);
            begin
               --  T.Assert (Has_Element (Col_Iter), "Table has a column");
               while Has_Element (Col_Iter) loop
                  T.Assert (Element (Col_Iter) /= null, "Element function must not return null");
                  Next (Col_Iter);
               end loop;
            end;
            Count := Count + 1;
            Next (Iter);
         end loop;
         if Driver = "sqlite" then
            Util.Tests.Assert_Equals (T, 11, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "mysql" then
            Util.Tests.Assert_Equals (T, 11, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "postgresql" then
            Util.Tests.Assert_Equals (T, 11, Count,
                                      "Invalid number of tables found in the schema");
         end if;
      end;
   end Test_Table_Iterator;

   --  ------------------------------
   --  Test the Table_Cursor operations on an empty schema.
   --  ------------------------------
   procedure Test_Empty_Schema (T : in out Test) is
      Schema : Schema_Definition;
      Iter   : constant Table_Cursor := Schema.Get_Tables;
   begin
      T.Assert (not Has_Element (Iter), "The Get_Tables must return an empty iterator");
      T.Assert (Schema.Find_Table ("test") = null, "The Find_Table must return null");
   end Test_Empty_Schema;

   --  ------------------------------
   --  Test the creation of database.
   --  ------------------------------
   procedure Test_Create_Schema (T : in out Test) is
      use ADO.Sessions.Sources;

      Msg      : Util.Strings.Vectors.Vector;
      Cfg      : Data_Source := Data_Source (Regtests.Get_Controller);
      Driver   : constant String := Cfg.Get_Driver;
      Database : constant String := Cfg.Get_Database;
      Path     : constant String :=
        "db/regtests/" & Cfg.Get_Driver & "/create-ado-" & Driver & ".sql";

      pragma Unreferenced (Msg);
   begin
      if Driver = "sqlite" then
         if Ada.Directories.Exists (Database & ".test") then
            Ada.Directories.Delete_File (Database & ".test");
         end if;
         Cfg.Set_Database (Database & ".test");
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
         T.Assert (Ada.Directories.Exists (Database & ".test"),
                   "The sqlite database was not created");
      else
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
      end if;
   end Test_Create_Schema;

end ADO.Schemas.Tests;

Add more schema checks with float columns