265 lines
9.8 KiB
Ada
265 lines
9.8 KiB
Ada
-- TCTouch.A
|
|
--
|
|
-- Grant of Unlimited Rights
|
|
--
|
|
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
|
|
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
|
|
-- unlimited rights in the software and documentation contained herein.
|
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
|
-- this public release, the Government intends to confer upon all
|
|
-- recipients unlimited rights equal to those held by the Government.
|
|
-- These rights include rights to use, duplicate, release or disclose the
|
|
-- released technical data and computer software in whole or in part, in
|
|
-- any manner and for any purpose whatsoever, and to have or permit others
|
|
-- to do so.
|
|
--
|
|
-- DISCLAIMER
|
|
--
|
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
|
--*
|
|
--
|
|
-- FOUNDATION DESCRIPTION:
|
|
-- The tools in this foundation are not peculiar to any particular
|
|
-- aspect of the language, but simplify the test writing and reading
|
|
-- process. Assert and Assert_Not are used to reduce the textual
|
|
-- overhead of the test-that-this-condition-is-(not)-true paradigm.
|
|
-- Touch and Validate are used to simplify tracing an expected path
|
|
-- of execution.
|
|
-- A tag comment of the form:
|
|
--
|
|
-- TCTouch.Touch( 'A' ); ----------------------------------------- A
|
|
--
|
|
-- is recommended to improve readability of this feature.
|
|
--
|
|
-- Report.Test must be called before any of the procedures in this
|
|
-- package with the exception of Touch.
|
|
-- The usage paradigm is to call Touch in locations in the test where you
|
|
-- want a trace of execution. Each call to Touch should have a unique
|
|
-- character associated with it. At each place where a check can
|
|
-- reasonably be performed to determine correct execution of a
|
|
-- sub-test, a call to Validate should be made. The first parameter
|
|
-- passed to Validate is the expected string of characters produced by
|
|
-- call(s) to Touch in the subtest just executed. The second parameter
|
|
-- is the message to pass to Report.Failed if the expected sequence was
|
|
-- not executed.
|
|
--
|
|
-- Validate should always be called after calls to Touch before a test
|
|
-- completes.
|
|
--
|
|
-- In the event that calls may have been made to Touch that are not
|
|
-- intended to be recorded, or, the failure of a previous subtest may
|
|
-- leave Touch calls "Unvalidated", the procedure Flush will reset the
|
|
-- tracker to the "empty" state. Flush does not make any calls to
|
|
-- Report.
|
|
--
|
|
-- Calls to Assert and Assert_Not are to replace the idiom:
|
|
--
|
|
-- if BadCondition then -- or if not PositiveTest then
|
|
-- Report.Failed(Message);
|
|
-- end if;
|
|
--
|
|
-- with:
|
|
--
|
|
-- Assert_Not( BadCondition, Message ); -- or
|
|
-- Assert( PositiveTest, Message );
|
|
--
|
|
-- Implementation_Check is for use with tests that cross the boundary
|
|
-- between the core and the Special Needs Annexes. There are several
|
|
-- instances where language in the core becomes enforceable only when
|
|
-- a Special Needs Annex is supported. Implementation_Check should be
|
|
-- called in place of Report.Failed in these cases; it examines the
|
|
-- constants in Impdef that indicate if the particular Special Needs
|
|
-- Annex is being validated with this validation; and acts accordingly.
|
|
--
|
|
-- The constant Foundation_ID contains the internal change version
|
|
-- for this software.
|
|
--
|
|
-- ERROR CONDITIONS:
|
|
--
|
|
-- It is an error to perform more than Max_Touch_Count (80) calls to
|
|
-- Touch without a subsequent call to Validate. To do so will cause
|
|
-- a false test failure.
|
|
--
|
|
-- CHANGE HISTORY:
|
|
-- 02 JUN 94 SAIC Initial version
|
|
-- 27 OCT 94 SAIC Revised version
|
|
-- 07 AUG 95 SAIC Added Implementation_Check
|
|
-- 07 FEB 96 SAIC Changed to match new Impdef for 2.1
|
|
-- 16 MAR 00 RLB Changed foundation id to reflect test suite version.
|
|
-- 22 MAR 01 RLB Changed foundation id to reflect test suite version.
|
|
-- 29 MAR 02 RLB Changed foundation id to reflect test suite version.
|
|
--
|
|
--!
|
|
|
|
package TCTouch is
|
|
Foundation_ID : constant String := "TCTouch ACATS 2.5";
|
|
Max_Touch_Count : constant := 80;
|
|
|
|
procedure Assert ( SB_True : Boolean; Message : String );
|
|
procedure Assert_Not( SB_False : Boolean; Message : String );
|
|
|
|
procedure Touch ( A_Tag : Character );
|
|
procedure Validate( Expected: String;
|
|
Message : String;
|
|
Order_Meaningful : Boolean := True );
|
|
|
|
procedure Flush;
|
|
|
|
type Special_Needs_Annexes is ( Annex_C, Annex_D, Annex_E,
|
|
Annex_F, Annex_G, Annex_H );
|
|
|
|
procedure Implementation_Check( Message : in String;
|
|
Annex : in Special_Needs_Annexes
|
|
:= Annex_C );
|
|
-- If Impdef.Validating_Annex_<Annex> is true, will call Report.Failed
|
|
-- otherwise will call Report.Not_Applicable. This is to allow tests
|
|
-- which are driven by wording in the core of the language, yet have
|
|
-- their functionality dictated by the Special Needs Annexes to perform
|
|
-- dual purpose.
|
|
-- The default of Annex_C for the Annex parameter is to support early
|
|
-- tests written with the assumption that Implementation_Check was
|
|
-- expressly for use with the Systems Programming Annex.
|
|
|
|
end TCTouch;
|
|
|
|
with Report;
|
|
with Impdef;
|
|
package body TCTouch is
|
|
|
|
procedure Assert( SB_True : Boolean; Message : String ) is
|
|
begin
|
|
if not SB_True then
|
|
Report.Failed( "Assertion failed: " & Message );
|
|
end if;
|
|
end Assert;
|
|
|
|
procedure Assert_Not( SB_False : Boolean; Message : String ) is
|
|
begin
|
|
if SB_False then
|
|
Report.Failed( "Assertion failed: " & Message );
|
|
end if;
|
|
end Assert_Not;
|
|
|
|
Collection : String(1..Max_Touch_Count);
|
|
Finger : Natural := 0;
|
|
|
|
procedure Touch ( A_Tag : Character ) is
|
|
begin
|
|
Finger := Finger+1;
|
|
Collection(Finger) := A_Tag;
|
|
exception
|
|
when Constraint_Error =>
|
|
Report.Failed("Trace Overflow: " & Collection);
|
|
Finger := 0;
|
|
end Touch;
|
|
|
|
procedure Sort_String( S: in out String ) is
|
|
-- algorithm from Booch Components Page 472
|
|
No_Swaps : Boolean;
|
|
procedure Swap(C1, C2: in out Character) is
|
|
T: Character := C1;
|
|
begin C1 := C2; C2 := T; end Swap;
|
|
begin
|
|
for OI in S'First+1..S'Last loop
|
|
No_Swaps := True;
|
|
for II in reverse OI..S'Last loop
|
|
if S(II) < S(II-1) then
|
|
Swap(S(II),S(II-1));
|
|
No_Swaps := False;
|
|
end if;
|
|
end loop;
|
|
exit when No_Swaps;
|
|
end loop;
|
|
end Sort_String;
|
|
|
|
procedure Validate( Expected: String;
|
|
Message : String;
|
|
Order_Meaningful : Boolean := True) is
|
|
Want : String(1..Expected'Length) := Expected;
|
|
begin
|
|
if not Order_Meaningful then
|
|
Sort_String( Want );
|
|
Sort_String( Collection(1..Finger) );
|
|
end if;
|
|
if Collection(1..Finger) /= Want then
|
|
Report.Failed( Message & " Expecting: " & Want
|
|
& " Got: " & Collection(1..Finger) );
|
|
end if;
|
|
Finger := 0;
|
|
end Validate;
|
|
|
|
procedure Flush is
|
|
begin
|
|
Finger := 0;
|
|
end Flush;
|
|
|
|
procedure Implementation_Check( Message : in String;
|
|
Annex : in Special_Needs_Annexes
|
|
:= Annex_C ) is
|
|
-- default to cover some legacy
|
|
-- USAGE DISCIPLINE:
|
|
-- Implementation_Check is designed to be used in tests that have
|
|
-- interdependency on one of the Special Needs Annexes, yet are _really_
|
|
-- tests based in the core language. There will be instances where the
|
|
-- execution of a test would be failing in the light of the requirements
|
|
-- of the annex, yet from the point of view of the core language without
|
|
-- the additional requirements of the annex, the test does not apply.
|
|
-- In these cases, rather than issuing a call to Report.Failed, calling
|
|
-- TCTouch.Implementation_Check will check that sensitivity, and if
|
|
-- the implementation is attempting to validate against the specific
|
|
-- annex, Report.Failed will be called, otherwise, Report.Not_Applicable
|
|
-- will be called.
|
|
begin
|
|
|
|
case Annex is
|
|
when Annex_C =>
|
|
if ImpDef.Validating_Annex_C then
|
|
Report.Failed( Message );
|
|
else
|
|
Report.Not_Applicable( Message & " Annex C not supported" );
|
|
end if;
|
|
|
|
when Annex_D =>
|
|
if ImpDef.Validating_Annex_D then
|
|
Report.Failed( Message );
|
|
else
|
|
Report.Not_Applicable( Message & " Annex D not supported" );
|
|
end if;
|
|
|
|
when Annex_E =>
|
|
if ImpDef.Validating_Annex_E then
|
|
Report.Failed( Message );
|
|
else
|
|
Report.Not_Applicable( Message & " Annex E not supported" );
|
|
end if;
|
|
|
|
when Annex_F =>
|
|
if ImpDef.Validating_Annex_F then
|
|
Report.Failed( Message );
|
|
else
|
|
Report.Not_Applicable( Message & " Annex F not supported" );
|
|
end if;
|
|
|
|
when Annex_G =>
|
|
if ImpDef.Validating_Annex_G then
|
|
Report.Failed( Message );
|
|
else
|
|
Report.Not_Applicable( Message & " Annex G not supported" );
|
|
end if;
|
|
|
|
when Annex_H =>
|
|
if ImpDef.Validating_Annex_H then
|
|
Report.Failed( Message );
|
|
else
|
|
Report.Not_Applicable( Message & " Annex H not supported" );
|
|
end if;
|
|
end case;
|
|
end Implementation_Check;
|
|
|
|
end TCTouch;
|