Index: tests/natools-reference_tests.adb ================================================================== --- tests/natools-reference_tests.adb +++ tests/natools-reference_tests.adb @@ -1,7 +1,7 @@ ------------------------------------------------------------------------------ --- Copyright (c) 2013, Natacha Porté -- +-- 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. -- -- -- @@ -12,10 +12,13 @@ -- 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; @@ -396,10 +399,83 @@ 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 -- --------------------- @@ -411,6 +487,5 @@ Test_Reference_Counts (Report); Test_Reference_Tests (Report); end All_Tests; end Natools.Reference_Tests; - Index: tests/natools-reference_tests.ads ================================================================== --- tests/natools-reference_tests.ads +++ tests/natools-reference_tests.ads @@ -1,7 +1,7 @@ ------------------------------------------------------------------------------ --- Copyright (c) 2013, Natacha Porté -- +-- 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. -- -- -- @@ -15,10 +15,13 @@ ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- Natools.Reference_Tests is a test suite for Natools.References -- -- reference-counted object holder. -- +-- Note that the task-safety test is quite long and often reports success -- +-- on task-unsafe code when run on a single core. For these reasons, it is -- +-- not used by All_Tests. -- ------------------------------------------------------------------------------ with Natools.Tests; private with Ada.Finalization; @@ -29,16 +32,19 @@ package Natools.Reference_Tests is package NT renames Natools.Tests; procedure All_Tests (Report : in out NT.Reporter'Class); + -- All tests except Test_Task_Safety (see the Note above) 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); + + procedure Test_Task_Safety (Report : in out NT.Reporter'Class); private Instance_Count : Integer := 0; Index: tests/test_all.adb ================================================================== --- tests/test_all.adb +++ tests/test_all.adb @@ -86,10 +86,11 @@ Natools.HMAC_Tests.All_Tests (Report); Report.End_Section; Report.Section ("References"); Natools.Reference_Tests.All_Tests (Report); + Natools.Reference_Tests.Test_Task_Safety (Report); Report.End_Section; Report.Section ("S_Expressions.Atom_Buffers"); Natools.S_Expressions.Atom_Buffers.Tests.All_Tests (Report); Report.End_Section;