Natools

Artifact [8f83a23777]
Login

Artifact 8f83a2377706bbc26b8a3fada914c3a3167e2e8d:


------------------------------------------------------------------------------
-- Copyright (c) 2013-2014, 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.           --
------------------------------------------------------------------------------

with Ada.Calendar;
with Ada.Exceptions;

with Natools.References.Tools;

package body Natools.Reference_Tests is

   package Tools is new Refs.Tools;

   procedure Check_Ref
     (Report : in out NT.Reporter'Class;
      Name : in String;
      Ref : in Refs.Reference;
      Expected_Count : in Natural;
      Continue : in out Boolean);
      --  Check the given reference and report failure if any
      --  Do nothing if Continue is False

   procedure Check_Consistency
     (Report : in out NT.Reporter'Class;
      Name : in String;
      Left, Right : in Refs.Reference;
      Continue : in out Boolean);
      --  Check consistency between two reference and report if failed
      --  Do nothing if Continue is False

   procedure Check_Count
     (Report : in out NT.Reporter'Class;
      Name : in String;
      Expected_Count : in Integer;
      Continue : in out Boolean);
      --  Check instance count and report failure if any
      --  Do nothing if Continue is False


   --------------------
   -- Object counter --
   --------------------

   function Factory return Counter is
   begin
      Instance_Count := Instance_Count + 1;
      return Counter'(Ada.Finalization.Limited_Controlled with
         Instance_Number => Instance_Count);
   end Factory;


   overriding procedure Initialize (Object : in out Counter) is
   begin
      Instance_Count := Instance_Count + 1;
      Object.Instance_Number := Instance_Count;
   end Initialize;


   overriding procedure Finalize (Object : in out Counter) is
      pragma Unreferenced (Object);
   begin
      Instance_Count := Instance_Count - 1;
   end Finalize;



   ------------------------
   -- Helper subprograms --
   ------------------------

   procedure Check_Consistency
     (Report : in out NT.Reporter'Class;
      Name : in String;
      Left, Right : in Refs.Reference;
      Continue : in out Boolean) is
   begin
      if Continue and then not Tools.Is_Consistent (Left, Right) then
         NT.Item (Report, Name, NT.Fail);
         NT.Info (Report, "Inconsistent references found");
         Continue := False;
      end if;
   end Check_Consistency;


   procedure Check_Count
     (Report : in out NT.Reporter'Class;
      Name : in String;
      Expected_Count : in Integer;
      Continue : in out Boolean) is
   begin
      if not Continue then
         return;
      end if;

      if Instance_Count < 0 then
         NT.Item (Report, Name, NT.Fail);
         NT.Info
           (Report,
            "Invalid Instance_Count " & Integer'Image (Instance_Count));
         Continue := False;

      elsif Instance_Count /= Expected_Count then
         NT.Item (Report, Name, NT.Fail);
         NT.Info (Report, "Unexpected Instance_Count"
           & Integer'Image (Instance_Count)
           & " instead of"
           & Integer'Image (Expected_Count));
         Continue := False;
      end if;
   end Check_Count;


   procedure Check_Ref
     (Report : in out NT.Reporter'Class;
      Name : in String;
      Ref : in Refs.Reference;
      Expected_Count : in Natural;
      Continue : in out Boolean)
   is
      Actual_Count : constant Integer := Tools.Count (Ref);
   begin
      if not Continue then
         return;
      end if;

      if not Tools.Is_Valid (Ref) then
         NT.Item (Report, Name, NT.Fail);
         NT.Info (Report, "Invalid internal state for reference");
         Continue := False;

      elsif Actual_Count /= Expected_Count then
         NT.Item (Report, Name, NT.Fail);
         NT.Info (Report,
           "Unexpected reference count"
           & Natural'Image (Actual_Count)
           & " instead of"
           & Natural'Image (Expected_Count));
         Continue := False;

      elsif not Ref.Is_Empty and then Ref.Is_Last /= (Actual_Count = 1) then
         NT.Item (Report, Name, NT.Fail);
         NT.Info (Report,
           "Unexpected result of Is_Last ("
           & Boolean'Image (Ref.Is_Last)
           & ") while counter is"
           & Natural'Image (Actual_Count));
         Continue := False;
      end if;
   end Check_Ref;



   --------------------
   -- Invidual tests --
   --------------------

   procedure Test_Data_Access (Report : in out NT.Reporter'Class) is
      Argument_Count : Natural;
      Result : Boolean;

      procedure Check (Self : in Counter);
      procedure Set (Self : in out Counter);

      procedure Check (Self : in Counter) is
      begin
         Result := Argument_Count = Self.Instance_Number;
         Argument_Count := Self.Instance_Number;
      end Check;

      procedure Set (Self : in out Counter) is
      begin
         Self.Instance_Number := Argument_Count;
      end Set;

      Name : constant String := "Data access";
   begin
      declare
         Ref_1 : Refs.Reference := Refs.Create (Factory'Access);
         Ref_2 : Refs.Reference;
      begin
         Ref_2.Replace (Factory'Access);
         Argument_Count := 42;
         Ref_2.Update (Set'Access);
         Ref_1.Update.Data.Instance_Number := 18;

         Argument_Count := 18;
         Ref_1.Query (Check'Access);
         if not Result then
            NT.Item (Report, Name, NT.Fail);
            NT.Info (Report, "Stored 18, retrieved"
              & Integer'Image (Argument_Count));
            return;
         end if;

         Ref_1.Reset;

         Argument_Count := Ref_2.Query.Data.Instance_Number;
         if Argument_Count /= 42 then
            NT.Item (Report, Name, NT.Fail);
            NT.Info (Report, "Stored 42, retrieved"
              & Integer'Image (Argument_Count));
            return;
         end if;
      end;

      NT.Item (Report, Name, NT.Success);
   exception
      when Error : others => NT.Report_Exception (Report, Name, Error);
   end Test_Data_Access;


   procedure Test_Double_Finalize (Report : in out NT.Reporter'Class) is
      Name : constant String := "Double finalize";
      Initial_Count : constant Integer := Instance_Count;
      Continue : Boolean := True;
   begin
      declare
         Ref : Refs.Reference := Refs.Create (Factory'Access);
      begin
         Ref.Finalize;
      end;

      Check_Count (Report, Name, Initial_Count, Continue);

      if Continue then
         NT.Item (Report, Name, NT.Success);
      end if;
   exception
      when Error : others => NT.Report_Exception (Report, Name, Error);
   end Test_Double_Finalize;


   procedure Test_Implicit_Dereference (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Implicit dereference");
      Other_Number : constant Integer := 123;

      procedure Set_Number (Object : in out Counter);

      procedure Set_Number (Object : in out Counter) is
      begin
         Object.Instance_Number := Other_Number;
      end Set_Number;
   begin
      declare
         Ref : constant Refs.Reference := Refs.Create (Factory'Access);
         Original_Number : constant Natural := Ref.Query.Instance_Number;
      begin
         Set_Number (Ref.Update);
         Ref.Update.Instance_Number := Original_Number;
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Test_Implicit_Dereference;


   procedure Test_Instance_Counts (Report : in out NT.Reporter'Class) is
      Name : constant String := "Instance counts";
      Initial_Count : constant Integer := Instance_Count;
      Continue : Boolean := True;
   begin
      declare
         procedure Check (Count_0, Count_1, Count_2, Delta_I : in Integer);

         Ref_0 : Refs.Reference := Refs.Create (Factory'Access);
         Ref_1 : Refs.Reference := Refs.Create (Refs.Data_Access'(null));
         Ref_2 : Refs.Reference;

         procedure Check (Count_0, Count_1, Count_2, Delta_I : in Integer) is
         begin
            Check_Ref (Report, Name, Ref_0, Count_0, Continue);
            Check_Ref (Report, Name, Ref_1, Count_1, Continue);
            Check_Ref (Report, Name, Ref_2, Count_2, Continue);
            Check_Consistency (Report, Name, Ref_0, Ref_1, Continue);
            Check_Consistency (Report, Name, Ref_1, Ref_2, Continue);
            Check_Consistency (Report, Name, Ref_2, Ref_0, Continue);
            Check_Count (Report, Name, Initial_Count + Delta_I, Continue);
         end Check;
      begin
         Check (1, 0, 0, 1);

         if Continue then
            Ref_1 := Refs.Create (new Counter);
         end if;

         Check (1, 1, 0, 2);

         if Continue then
            Ref_2 := Ref_0;
         end if;

         Check (2, 1, 2, 2);

         if Continue then
            Ref_1 := Ref_0;
         end if;

         Check (3, 3, 3, 1);

         if Continue then
            Ref_2.Replace (new Counter);
         end if;

         Check (2, 2, 1, 2);

         if Continue then
            Ref_1.Reset;
            Ref_0 := Ref_1;
         end if;

         Check (0, 0, 1, 1);
      end;

      Check_Count (Report, Name, Initial_Count, Continue);

      if Continue then
         NT.Item (Report, Name, NT.Success);
      end if;
   exception
      when Error : others => NT.Report_Exception (Report, Name, Error);
   end Test_Instance_Counts;


   procedure Test_Reference_Counts (Report : in out NT.Reporter'Class) is
      Name : constant String := "Reference counts";
      Initial_Count : constant Integer := Instance_Count;
      Continue : Boolean := True;
   begin
      declare
         procedure Check (Count_0, Count_1, Count_2 : in Integer);

         Ref_0 : constant Refs.Reference := Refs.Create (Factory'Access);
         Ref_1 : Refs.Reference := Ref_0;
         Ref_2 : Refs.Reference;

         procedure Check (Count_0, Count_1, Count_2 : in Integer) is
         begin
            Check_Ref (Report, Name, Ref_0, Count_0, Continue);
            Check_Ref (Report, Name, Ref_1, Count_1, Continue);
            Check_Ref (Report, Name, Ref_2, Count_2, Continue);
            Check_Consistency (Report, Name, Ref_0, Ref_1, Continue);
            Check_Consistency (Report, Name, Ref_1, Ref_2, Continue);
            Check_Consistency (Report, Name, Ref_2, Ref_0, Continue);
         end Check;
      begin
         Check (2, 2, 0);

         if Continue then
            Ref_2 := Ref_0;
         end if;

         Check (3, 3, 3);

         if Continue then
            Refs.Reset (Ref_1);
         end if;

         Check (2, 0, 2);
      end;

      Check_Count (Report, Name, Initial_Count, Continue);

      if Continue then
         NT.Item (Report, Name, NT.Success);
      end if;
   exception
      when Error : others => NT.Report_Exception (Report, Name, Error);
   end Test_Reference_Counts;


   procedure Test_Reference_Tests (Report : in out NT.Reporter'Class) is
      Name : constant String := "Reference tests";
      Initial_Count : constant Integer := Instance_Count;
      Continue : Boolean := True;
   begin
      declare
         use type Refs.Reference;

         Ref : Refs.Reference;
         Base : constant Refs.Reference := Refs.Create (Factory'Access);
      begin
         if not Ref.Is_Empty then
            NT.Item (Report, Name, NT.Fail);
            NT.Info (Report, "Default reference is not empty");
            return;
         end if;

         if Base.Is_Empty then
            NT.Item (Report, Name, NT.Fail);
            NT.Info (Report, "Created reference is empty");
            return;
         end if;

         Ref.Replace (Factory'Access);
         if Ref.Is_Empty then
            NT.Item (Report, Name, NT.Fail);
            NT.Info (Report, "Replaced reference is empty");
            return;
         end if;

         if Ref = Base then
            NT.Item (Report, Name, NT.Fail);
            NT.Info (Report, "Unexpected equality between Ref and Base");
            return;
         end if;

         Ref := Base;
         if Ref /= Base then
            NT.Item (Report, Name, NT.Fail);
            NT.Info (Report, "Unexpected inequality between Ref and Base");
            return;
         end if;
      end;

      Check_Count (Report, Name, Initial_Count, Continue);

      if Continue then
         NT.Item (Report, Name, NT.Success);
      end if;
   exception
      when Error : others => NT.Report_Exception (Report, Name, Error);
   end Test_Reference_Tests;


   procedure Test_Task_Safety (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Task safety");
      Success : Boolean := True;

      protected Protected_Report is
         procedure Report_Exception (Ex : Ada.Exceptions.Exception_Occurrence);
      end Protected_Report;

      protected body Protected_Report is
         procedure Report_Exception
           (Ex : Ada.Exceptions.Exception_Occurrence) is
         begin
            Test.Report_Exception (Ex, NT.Fail);
         end Report_Exception;
      end Protected_Report;

      task type Checker is
         entry Start (Count : in Natural; Ref : in Refs.Immutable_Reference);
      end Checker;

      task body Checker is
         Starting_Value, Last : Natural;
         R : Refs.Immutable_Reference;
      begin
         accept Start (Count : in Natural; Ref : in Refs.Immutable_Reference)
         do
            Last := Count;
            R := Ref;
         end Start;
         Starting_Value := R.Query.Data.Instance_Number;
         for I in 1 .. Last loop
            declare
               Temp : constant Refs.Immutable_Reference := R;
            begin
               if Temp.Query.Data.Instance_Number /= Starting_Value then
                  Success := False;
               end if;
            end;
         end loop;
      exception
         when Error : others =>
            Protected_Report.Report_Exception (Error);
      end Checker;

      Start : constant Ada.Calendar.Time := Ada.Calendar.Clock;
   begin
      declare
         Base : constant Refs.Immutable_Reference
           := Refs.Create (Factory'Access);
      begin
         declare
            Checkers : array (1 .. 16) of Checker;
         begin
            for I in Checkers'Range loop
               Checkers (I).Start (10 ** 6, Base);
            end loop;
         end;

         if not Success then
            Test.Fail ("Success somehow got to False");
         end if;
      end;

      Test.Info ("Test run in "
        & Duration'Image (Ada.Calendar."-" (Ada.Calendar.Clock, Start)));
   exception
      when Error : others =>
         Test.Report_Exception (Error);
         Test.Info ("Test run in "
           & Duration'Image (Ada.Calendar."-" (Ada.Calendar.Clock, Start)));
   end Test_Task_Safety;



   ---------------------
   -- Test everything --
   ---------------------

   procedure All_Tests (Report : in out NT.Reporter'Class) is
   begin
      Test_Data_Access (Report);
      Test_Double_Finalize (Report);
      Test_Implicit_Dereference (Report);
      Test_Instance_Counts (Report);
      Test_Reference_Counts (Report);
      Test_Reference_Tests (Report);
   end All_Tests;

end Natools.Reference_Tests;