Natools

File tests/natools-chunked_strings-tests-memory.adb from the latest check-in

------------------------------------------------------------------------------
-- Copyright (c) 2013, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

procedure Natools.Chunked_Strings.Tests.Memory
  (Report : in out Natools.Tests.Reporter'Class)
is
   function Allocated_Size (Source : in Chunked_String) return Natural;
      --  Return the number of allocated characters in Source


   function Allocated_Size (Source : in Chunked_String) return Natural is
   begin
      if Source.Data = null or else Source.Data'Last < 1 then
         return 0;
      end if;

      return (Source.Data'Last - 1) * Source.Chunk_Size
        + Source.Data (Source.Data'Last)'Last;
   end Allocated_Size;

   package NT renames Natools.Tests;
begin
   NT.Section (Report, "Extra tests for memory usage");

   declare
      Name : constant String := "Procedure Preallocate";
      CS : Chunked_String;
      Memory_Ref : Natural;
      Repeats : constant Positive := 50;
   begin
      Preallocate (CS, Repeats * Name'Length);
      Memory_Ref := Allocated_Size (CS);

      for I in 1 .. Repeats loop
         Append (CS, Name);
      end loop;

      if Memory_Ref /= Allocated_Size (CS) then
         NT.Item (Report, Name, NT.Fail);
         NT.Info (Report, "Memory after preallocation:"
           & Natural'Image (Memory_Ref));
         NT.Info (Report, "Memory after insertions:"
           & Natural'Image (Allocated_Size (CS)));
      else
         NT.Item (Report, Name, NT.Success);
      end if;
   exception
      when Error : others => NT.Report_Exception (Report, Name, Error);
   end;

   declare
      Name : constant String := "Procedure Free_Extra_Memory";
      CS : Chunked_String;
      Memory_Ref : Natural;
      Repeats : constant Positive := 50;
   begin
      Preallocate (CS, Repeats * Name'Length);
      Append (CS, Name);
      Memory_Ref := Allocated_Size (CS);
      Free_Extra_Memory (CS);

      if Memory_Ref <= Allocated_Size (CS) then
         NT.Item (Report, Name, NT.Fail);
         NT.Info (Report, "Memory before:"
           & Natural'Image (Memory_Ref));
         NT.Info (Report, "Memory after:"
           &  Natural'Image (Allocated_Size (CS)));
      else
         NT.Item (Report, Name, NT.Success);
      end if;
   exception
      when Error : others => NT.Report_Exception (Report, Name, Error);
   end;

   declare
      Name : constant String := "Procedure Free_Extra_Memory (empty)";
      CS : Chunked_String;
      Memory_Ref : Natural;
      Repeats : constant Positive := 50;
   begin
      Preallocate (CS, Repeats * Name'Length);
      Memory_Ref := Allocated_Size (CS);
      Free_Extra_Memory (CS);

      if Memory_Ref <= Allocated_Size (CS) then
         NT.Item (Report, Name, NT.Fail);
         NT.Info (Report, "Memory before:"
           & Natural'Image (Memory_Ref));
         NT.Info (Report, "Memory after:"
           &  Natural'Image (Allocated_Size (CS)));
      else
         NT.Item (Report, Name, NT.Success);
      end if;
   exception
      when Error : others => NT.Report_Exception (Report, Name, Error);
   end;

   Natools.Tests.End_Section (Report);
end Natools.Chunked_Strings.Tests.Memory;