1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
|
-
+
+
+
+
|
------------------------------------------------------------------------------
-- 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. --
-- --
-- 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
|
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
|
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
|
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_Instance_Counts (Report);
Test_Reference_Counts (Report);
Test_Reference_Tests (Report);
end All_Tests;
end Natools.Reference_Tests;
|