ADDED tests/natools-reference_tests.adb Index: tests/natools-reference_tests.adb ================================================================== --- tests/natools-reference_tests.adb +++ tests/natools-reference_tests.adb @@ -0,0 +1,408 @@ +------------------------------------------------------------------------------ +-- 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. -- +------------------------------------------------------------------------------ + +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 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; + 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_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, 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 (Factory'Access); + 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 (Factory'Access); + 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; + + + + --------------------- + -- Test everything -- + --------------------- + + procedure All_Tests (Report : in out NT.Reporter'Class) is + begin + Test_Data_Access (Report); + Test_Double_Finalize (Report); + Test_Instance_Counts (Report); + Test_Reference_Counts (Report); + Test_Reference_Tests (Report); + end All_Tests; + +end Natools.Reference_Tests; + ADDED tests/natools-reference_tests.ads Index: tests/natools-reference_tests.ads ================================================================== --- tests/natools-reference_tests.ads +++ tests/natools-reference_tests.ads @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- 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. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.Reference_Tests is a test suite for Natools.References -- +-- reference-counted object holder. -- +------------------------------------------------------------------------------ + +with Natools.Tests; + +private with Ada.Finalization; +-- private with GNAT.Debug_Pools; +private with Natools.References; + +package Natools.Reference_Tests is + + package NT renames Natools.Tests; + + procedure All_Tests (Report : in out NT.Reporter'Class); + + procedure Test_Data_Access (Report : in out NT.Reporter'Class); + procedure Test_Double_Finalize (Report : in out NT.Reporter'Class); + procedure Test_Instance_Counts (Report : in out NT.Reporter'Class); + procedure Test_Reference_Counts (Report : in out NT.Reporter'Class); + procedure Test_Reference_Tests (Report : in out NT.Reporter'Class); + +private + + Instance_Count : Integer := 0; + + type Counter is new Ada.Finalization.Limited_Controlled with record + Instance_Number : Natural := 0; + end record; + + function Factory return Counter; + overriding procedure Finalize (Object : in out Counter); + +-- Pool : GNAT.Debug_Pools.Debug_Pool; + + package Refs is new Natools.References (Counter); +-- (Counter, System.Pool_Global.Global_Pool_Object, Pool); + +end Natools.Reference_Tests; ADDED tests/natools-references-tools.adb Index: tests/natools-references-tools.adb ================================================================== --- tests/natools-references-tools.adb +++ tests/natools-references-tools.adb @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- 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. -- +------------------------------------------------------------------------------ + +package body Natools.References.Tools is + + function Is_Consistent (Left, Right : Reference) return Boolean is + begin + return (Left.Data = Right.Data) = (Left.Count = Right.Count); + end Is_Consistent; + + + function Is_Valid (Ref : Reference) return Boolean is + begin + return (Ref.Data = null) = (Ref.Count = null); + end Is_Valid; + + + function Count (Ref : Reference) return Natural is + begin + if Ref.Count /= null then + return Natural (Ref.Count.all); + else + return 0; + end if; + end Count; + +end Natools.References.Tools; ADDED tests/natools-references-tools.ads Index: tests/natools-references-tools.ads ================================================================== --- tests/natools-references-tools.ads +++ tests/natools-references-tools.ads @@ -0,0 +1,34 @@ +------------------------------------------------------------------------------ +-- 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. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.References.Tools exposes subprograms to peek into private parts -- +-- of Natools.Reference, for debug or testing purposes. -- +------------------------------------------------------------------------------ + +generic +package Natools.References.Tools is + + function Is_Consistent (Left, Right : Reference) return Boolean; + -- Check that counter and data equality are consistent + + function Is_Valid (Ref : Reference) return Boolean; + -- Check consistency for internal state + + function Count (Ref : Reference) return Natural; + -- Return the number of references to held object + +end Natools.References.Tools; Index: tests/test_all.adb ================================================================== --- tests/test_all.adb +++ tests/test_all.adb @@ -20,10 +20,11 @@ with Ada.Command_Line; with Ada.Text_IO; with Natools.Chunked_Strings.Tests; with Natools.Getopt_Long_Tests; +with Natools.Reference_Tests; with Natools.Tests.Text_IO; procedure Test_All is package Uneven_Chunked_Strings is new Natools.Chunked_Strings (Default_Allocation_Unit => 7, @@ -58,10 +59,14 @@ Report.End_Section; Report.Section ("Getopt_Long"); Natools.Getopt_Long_Tests.All_Tests (Report); Report.End_Section; + + Report.Section ("References"); + Natools.Reference_Tests.All_Tests (Report); + Report.End_Section; Natools.Tests.Text_IO.Print_Results (Report.Total_Results); declare Results : constant Natools.Tests.Result_Summary := Report.Total_Results;