|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: B T
Length: 30728 (0x7808)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦49e7f20b9⟧
└─⟦this⟧
with Test_Io;
with Xlbt_Arithmetic;
with Xlbt_String;
--
with Xlbmt_Network_Types;
package body Cvt_Test_Utilities is
------------------------------------------------------------------------------
-- Cvt_Test_Utilities - test generics and support routines useful for
-- testing data conversions.
------------------------------------------------------------------------------
-- 09/05/90 DRK | Created.
------------------------------------------------------------------------------
generic
type Original is private;
Original_Name : String;
type Converted_Element is (<>);
type Converted_Index is range <>;
type Converted is array (Converted_Index range <>) of Converted_Element;
with procedure To_Conv (Conv : out Converted; Orig : Original);
with procedure From_Conv (Orig : out Original; Conv : Converted);
procedure Base_Tester (Image : String; Orig : Original; Conv : Converted);
procedure Base_Tester (Image : String; Orig : Original; Conv : Converted) is
------------------------------------------------------------------
-- Image - Specifies a text representation for Orig.
-- Orig - Specifies the original value to be converted.
-- Conv - Specifies the equivalent converted value.
--
-- Called to exercise various conversions of private values.
------------------------------------------------------------------
Normal_Data : Converted (1 .. Conv'Length) := Conv;
Zero_Index_Data : Converted (0 .. Conv'Length - 1) := Conv;
Two_Index_Data : Converted (2 .. Conv'Length + 1) := Conv;
Oversized_Data : Converted (1 .. Conv'Length + 1) :=
Conv & (1 => Converted_Element'Val (0));
Undersized_Data : Converted (1 .. Conv'Length - 1) :=
Conv (Conv'First .. Conv'Last - 1);
--
-- Constants used in various test cases.
type Anomalies is (None, Zero_Index, Two_Index, Oversized, Undersized);
--
-- The type of problem we expect to encounter in a test.
-- None - no problems should be detected.
-- Zero_Index - the Conv array has starting index = 0.
-- Two_Index - the Conv array has starting index = 2.
-- Oversized - the Conv array is too large.
-- Undersized - the Conv array is too small.
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
Failed : Boolean := False;
--
-- Has this test failed?
procedure Check (Condition : Boolean;
Failure_Message : String;
Success_Message : String := ".") is
-- Do a simple check for a test.
begin
if not Condition then
Test_Io.Put_Line (Failure_Message);
Failed := True;
else
Test_Io.Put (Success_Message);
end if;
end Check;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
procedure Test_To_Conv (Value : Original;
Expected : Converted;
Anomaly : Anomalies := None) is
--------------------------------------------------------------
-- Value - Specifies the value to be converted.
-- Expected - Specifies the expected result value (and
-- the bounds of the result array being used).
-- Anomaly - Specifies the expected final result.
--
-- Try a single To_Conv conversion and verify its result.
--------------------------------------------------------------
Conv : Converted (Expected'Range);
Bool : Boolean;
begin
-- Try the conversion.
To_Conv (Conv, Value);
-- Check our results.
case Anomaly is
when None =>
Bool := Conv = Expected;
Check (Bool, "<To_Conv failed>");
when Zero_Index =>
Bool := Conv = Expected;
Check (Bool, "<To_Conv failed on a 0-based slice>");
when Two_Index =>
Bool := Conv = Expected;
Check (Bool, "<To_Conv failed on a 2-based slice>");
when Oversized =>
Check (False, "<To_Conv accepted an oversized array>");
when Undersized =>
Check (False, "<To_Conv accepted an undersized array>");
end case;
exception
when Constraint_Error =>
-- Oversized and Undersized anomalies should get here.
case Anomaly is
when None =>
Check (False, "<To_Conv raised Constraint_Error>");
when Zero_Index =>
Check (False,
"<To_Conv couldn't handle a 0-based slice>");
when Two_Index =>
Check (False,
"<To_Conv couldn't handle a 2-based slice>");
when Oversized | Undersized =>
Check (True, ".");
end case;
when Dummy_Converters.Unimplemented =>
-- Ignore this test.
null;
when others =>
-- Nobody should get here.
Check (False, "<To_Conv croaked: expected " &
Anomalies'Image (Anomaly) & ">");
end Test_To_Conv;
procedure Test_From_Conv (Value : Converted;
Expected : Original;
Anomaly : Anomalies := None) is
--------------------------------------------------------------
-- Value - Specifies the value to be converted.
-- Expected - Specifies the expected result value.
-- Anomaly - Specifies the expected final result.
--
-- Try a single From_Conv conversion and verify its result.
--------------------------------------------------------------
Conv : Original;
Bool : Boolean;
begin
-- Try the conversion.
From_Conv (Conv, Value);
-- Check our results.
case Anomaly is
when None =>
Bool := Conv = Expected;
Check (Bool, "<From_Conv failed>");
when Zero_Index =>
Bool := Conv = Expected;
Check (Bool, "<From_Conv failed on a 0-based slice>");
when Two_Index =>
Bool := Conv = Expected;
Check (Bool, "<From_Conv failed on a 2-based slice>");
when Oversized =>
Check (False, "<From_Conv accepted an oversized array>");
when Undersized =>
Check (False, "<From_Conv accepted an undersized array>");
end case;
exception
when Constraint_Error =>
-- Oversized and Undersized anomalies should get here.
case Anomaly is
when None =>
Check (False, "<From_Conv raised Constraint_Error>");
when Zero_Index =>
Check (False,
"<From_Conv couldn't handle a 0-based slice>");
when Two_Index =>
Check (False,
"<From_Conv couldn't handle a 2-based slice>");
when Oversized | Undersized =>
Check (True, ".");
end case;
when Dummy_Converters.Unimplemented =>
-- Ignore this test.
null;
when others =>
-- Nobody should get here.
Check (False, "<From_Conv croaked: expected " &
Anomalies'Image (Anomaly) & ">");
end Test_From_Conv;
begin
-- Start a test.
Test_Io.Put (Original_Name & "'(" & Image & ") ");
-- Try the normal conversions.
Test_To_Conv (Orig, Normal_Data);
Test_From_Conv (Normal_Data, Orig);
-- Try some conversions with non-standard array bounds.
Test_To_Conv (Orig, Zero_Index_Data, Zero_Index);
Test_From_Conv (Zero_Index_Data, Orig, Zero_Index);
Test_To_Conv (Orig, Two_Index_Data, Two_Index);
Test_From_Conv (Two_Index_Data, Orig, Two_Index);
-- Try some conversions with oversized arrays.
Test_To_Conv (Orig, Oversized_Data, Oversized);
Test_From_Conv (Oversized_Data, Orig, Oversized);
-- Try some conversions with undersized arrays.
if Conv'Length > 0 then
Test_To_Conv (Orig, Undersized_Data, Undersized);
Test_From_Conv (Undersized_Data, Orig, Undersized);
end if;
-- All done.
Test_Io.Put_Line (" done.");
if Failed then
Test_Io.Put_Error ("Converter tests for " &
Original_Name & " failed.");
end if;
exception
when others =>
Check (False, "<unexpected exception>");
Test_Io.Put_Line (" aborted.");
Test_Io.Put_Exception ("Converter tests for " & Original_Name &
" raised an unexpected exception.");
end Base_Tester;
----------------------------------------------------------------------
----------------------------------------------------------------------
package body Raw_Data_Tests is
------------------------------------------------------------------
-- The test generics in this section will perform a series of
-- standard tests with a given pair of converter subprograms. The
-- test generics below require both To_Raw and From_Raw converters.
-- If a particular conversion is not used by the protocol, the
-- standard converter packages will not supply a converter
-- subprogram. Instantiate an appropriate Dummy_Generic_Converter
-- to handle these cases. The test generics below all accept and
-- handle the Dummy_Generic_Converters.Unimplemented exception.
--
-- Logging information is produced via Test_Io calls.
------------------------------------------------------------------
-- generic
-- type Original is private;
-- Original_Name : String;
-- with procedure To_Raw (Raw : out X_Raw_Data_Array;
-- Orig : Original);
-- with procedure From_Raw (Orig : out Original;
-- Raw : X_Raw_Data_Array);
procedure Tester (Image : String;
Orig : Original;
Raw : Xlbmt_Network_Types.X_Raw_Data_Array) is
--------------------------------------------------------------
-- Image - Specifies a text representation for Orig.
-- Orig - Specifies the original value to be converted.
-- Raw - Specifies the equivalent raw value.
--
-- Called to exercise various conversions of private values.
--------------------------------------------------------------
procedure Test is new Base_Tester
(Original, Original_Name,
Xlbmt_Network_Types.X_Raw_Data,
Xlbmt_Network_Types.X_Raw_Data_Index,
Xlbmt_Network_Types.X_Raw_Data_Array,
To_Raw, From_Raw);
begin
Test (Image, Orig, Raw);
end Tester;
------------------------------------------------------------------
-- generic
-- type Original is private;
-- type Index is (<>);
-- type Original_Array is array (Index range <>) of Original;
-- Original_Name : String;
-- with procedure To_Raw (Raw : out X_Raw_Data_Array;
-- Orig : Original_Array);
-- with procedure From_Raw (Orig : out Original_Array;
-- Raw : X_Raw_Data_Array);
procedure Tester_1d (Image : String;
Orig : Original_Array;
Raw : Xlbmt_Network_Types.X_Raw_Data_Array) is
--------------------------------------------------------------
-- Image - Specifies a text representation for Orig.
-- Orig - Specifies the original value to be converted.
-- Raw - Specifies the equivalent raw value.
--
-- Called to exercise various conversions of array values.
--------------------------------------------------------------
subtype Constrained_Array is Original_Array (Orig'Range);
procedure Constrained_Test is
new Cvt_Test_Utilities.Raw_Data_Tests.Tester
(Constrained_Array, Original_Name, To_Raw, From_Raw);
begin
Constrained_Test (Image, Orig, Raw);
end Tester_1d;
------------------------------------------------------------------
-- generic
-- type Original is private;
-- type Index1 is (<>);
-- type Index2 is (<>);
-- type Original_Array is array (Index1 range <>,
-- Index2 range <>) of Original;
-- Original_Name : String;
-- with procedure To_Raw (Raw : out X_Raw_Data_Array;
-- Orig : Original_Array);
-- with procedure From_Raw (Orig : out Original_Array;
-- Raw : X_Raw_Data_Array);
procedure Tester_2d (Image : String;
Orig : Original_Array;
Raw : Xlbmt_Network_Types.X_Raw_Data_Array) is
--------------------------------------------------------------
-- Image - Specifies a text representation for Orig.
-- Orig - Specifies the original value to be converted.
-- Raw - Specifies the equivalent raw value.
--
-- Called to exercise various conversions of 2d array values.
--------------------------------------------------------------
subtype Constrained_Array is Original_Array
(Orig'Range (1), Orig'Range (2));
procedure Constrained_Test is
new Cvt_Test_Utilities.Raw_Data_Tests.Tester
(Constrained_Array, Original_Name, To_Raw, From_Raw);
begin
Constrained_Test (Image, Orig, Raw);
end Tester_2d;
end Raw_Data_Tests;
----------------------------------------------------------------------
----------------------------------------------------------------------
package body U_Char_Tests is
------------------------------------------------------------------
-- The test generics in this section will perform a series of
-- standard tests with a given pair of converter subprograms. The
-- test generics below require both To_Uca and From_Uca converters.
-- If a particular conversion is not used by the protocol, the
-- standard converter packages will not supply a converter
-- subprogram. Instantiate an appropriate Dummy_Generic_Converter
-- to handle these cases. The test generics below all accept and
-- handle the Dummy_Generic_Converters.Unimplemented exception.
--
-- Logging information is produced via Test_Io calls.
------------------------------------------------------------------
-- generic
-- type Original is private;
-- Original_Name : String;
-- with procedure To_Uca (Uca : out U_Char_Array;
-- Orig : Original);
-- with procedure From_Uca (Orig : out Original;
-- Uca : U_Char_Array);
procedure Tester (Image : String;
Orig : Original;
Uca : Xlbt_Arithmetic.U_Char_Array) is
--------------------------------------------------------------
-- Image - Specifies a text representation for Orig.
-- Orig - Specifies the original value to be converted.
-- Uca - Specifies the equivalent converted value.
--
-- Called to exercise various conversions of private values.
--------------------------------------------------------------
procedure Test is new Base_Tester (Original, Original_Name,
Xlbt_Arithmetic.U_Char,
Xlbt_Arithmetic.S_Natural,
Xlbt_Arithmetic.U_Char_Array,
To_Uca, From_Uca);
begin
Test (Image, Orig, Uca);
end Tester;
------------------------------------------------------------------
-- generic
-- type Original is private;
-- type Index is (<>);
-- type Original_Array is array (Index range <>) of Original;
-- Original_Name : String;
-- with procedure To_Uca (Uca : out U_Char_Array;
-- Orig : Original_Array);
-- with procedure From_Uca (Orig : out Original_Array;
-- Uca : U_Char_Array);
procedure Tester_1d (Image : String;
Orig : Original_Array;
Uca : Xlbt_Arithmetic.U_Char_Array) is
--------------------------------------------------------------
-- Image - Specifies a text representation for Orig.
-- Orig - Specifies the original value to be converted.
-- Uca - Specifies the equivalent converted value.
--
-- Called to exercise various conversions of array values.
--------------------------------------------------------------
subtype Constrained_Array is Original_Array (Orig'Range);
procedure Constrained_Test is
new Cvt_Test_Utilities.U_Char_Tests.Tester
(Constrained_Array, Original_Name, To_Uca, From_Uca);
begin
Constrained_Test (Image, Orig, Uca);
end Tester_1d;
------------------------------------------------------------------
-- generic
-- type Original is private;
-- type Index1 is (<>);
-- type Index2 is (<>);
-- type Original_Array is array (Index1 range <>,
-- Index2 range <>) of Original;
-- Original_Name : String;
-- with procedure To_Uca (Uca : out U_Char_Array;
-- Orig : Original_Array);
-- with procedure From_Uca (Orig : out Original_Array;
-- Uca : U_Char_Array);
procedure Tester_2d (Image : String;
Orig : Original_Array;
Uca : Xlbt_Arithmetic.U_Char_Array) is
--------------------------------------------------------------
-- Image - Specifies a text representation for Orig.
-- Orig - Specifies the original value to be converted.
-- Uca - Specifies the equivalent converted value.
--
-- Called to exercise various conversions of 2d array values.
--------------------------------------------------------------
subtype Constrained_Array is Original_Array
(Orig'Range (1), Orig'Range (2));
procedure Constrained_Test is
new Cvt_Test_Utilities.U_Char_Tests.Tester
(Constrained_Array, Original_Name, To_Uca, From_Uca);
begin
Constrained_Test (Image, Orig, Uca);
end Tester_2d;
end U_Char_Tests;
----------------------------------------------------------------------
----------------------------------------------------------------------
package body X_String_Tests is
------------------------------------------------------------------
-- The test generics in this section will perform a series of
-- standard tests with a given pair of converter subprograms. The
-- test generics below require both To_Raw and From_Raw converters.
-- If a particular conversion is not used by the protocol, the
-- standard converter packages will not supply a converter
-- subprogram. Instantiate an appropriate Dummy_Generic_Converter
-- to handle these cases. The test generics below all accept and
-- handle the Dummy_Generic_Converters.Unimplemented exception.
--
-- Logging information is produced via Test_Io calls.
------------------------------------------------------------------
-- generic
-- type Original is private;
-- Original_Name : String;
-- with procedure To_Str8 (Str8 : out X_String;
-- Orig : Original);
-- with procedure From_Str8 (Orig : out Original;
-- Str8 : X_String);
procedure Tester (Image : String;
Orig : Original;
Str8 : Xlbt_String.X_String) is
--------------------------------------------------------------
-- Image - Specifies a text representation for Orig.
-- Orig - Specifies the original value to be converted.
-- Str8 - Specifies the equivalent Str8 value.
--
-- Called to exercise various conversions of private values.
--------------------------------------------------------------
procedure Test is new Base_Tester
(Original, Original_Name,
Xlbt_String.X_Character,
Xlbt_Arithmetic.S_Natural,
Xlbt_String.X_String, To_Str8, From_Str8);
begin
Test (Image, Orig, Str8);
end Tester;
------------------------------------------------------------------
-- generic
-- type Original is private;
-- type Index is (<>);
-- type Original_Array is array (Index range <>) of Original;
-- Original_Name : String;
-- with procedure To_Str8 (Str8 : out X_String;
-- Orig : Original_Array);
-- with procedure From_Str8 (Orig : out Original_Array;
-- Str8 : X_String);
procedure Tester_1d (Image : String;
Orig : Original_Array;
Str8 : Xlbt_String.X_String) is
--------------------------------------------------------------
-- Image - Specifies a text representation for Orig.
-- Orig - Specifies the original value to be converted.
-- Str8 - Specifies the equivalent raw value.
--
-- Called to exercise various conversions of array values.
--------------------------------------------------------------
subtype Constrained_Array is Original_Array (Orig'Range);
procedure Constrained_Test is
new Cvt_Test_Utilities.X_String_Tests.Tester
(Constrained_Array, Original_Name, To_Str8, From_Str8);
begin
Constrained_Test (Image, Orig, Str8);
end Tester_1d;
------------------------------------------------------------------
-- generic
-- type Original is private;
-- type Index1 is (<>);
-- type Index2 is (<>);
-- type Original_Array is array (Index1 range <>,
-- Index2 range <>) of Original;
-- Original_Name : String;
-- with procedure To_Str8 (Str8 : out X_String;
-- Orig : Original_Array);
-- with procedure From_Str8 (Orig : out Original_Array;
-- Str8 : X_String);
procedure Tester_2d (Image : String;
Orig : Original_Array;
Str8 : Xlbt_String.X_String) is
--------------------------------------------------------------
-- Image - Specifies a text representation for Orig.
-- Orig - Specifies the original value to be converted.
-- Str8 - Specifies the equivalent raw value.
--
-- Called to exercise various conversions of 2d array values.
--------------------------------------------------------------
subtype Constrained_Array is Original_Array
(Orig'Range (1), Orig'Range (2));
procedure Constrained_Test is
new Cvt_Test_Utilities.X_String_Tests.Tester
(Constrained_Array, Original_Name, To_Str8, From_Str8);
begin
Constrained_Test (Image, Orig, Str8);
end Tester_2d;
end X_String_Tests;
----------------------------------------------------------------------
----------------------------------------------------------------------
package body Dummy_Converters is
------------------------------------------------------------------
-- This package is a dummy version of Xlbmp_Generic_Converters
-- and Xlbp_U_Char_Generics. It is used by tests that want to
-- use converters which aren't normally required by the
-- protocol, and thus aren't provided by any of the standard
-- converter packages. The conversion generics here perform no
-- actual work - they just raise Unimplemented so that the test
-- generics will know to ignore this test.
------------------------------------------------------------------
-- generic
-- type Original is (<>);
-- type Converted is private;
procedure Convert_From_Discrete (Conv : out Converted;
Orig : Original) is
begin
raise Unimplemented;
end Convert_From_Discrete;
-- generic
-- type Original is private;
-- type Converted is private;
procedure Convert_From_Private (Conv : out Converted;
Orig : Original) is
begin
raise Unimplemented;
end Convert_From_Private;
-- generic
-- type Original is private;
-- type Index is (<>);
-- type Original_Array is array (Index range <>) of Original;
-- type Converted is private;
procedure Convert_From_Array (Conv : out Converted;
Orig : Original_Array) is
begin
raise Unimplemented;
end Convert_From_Array;
-- generic
-- type Original is private;
-- type Index1 is (<>);
-- type Index2 is (<>);
-- type Original_Array is array (Index1 range <>,
-- Index2 range <>) of Original;
-- type Converted is private;
procedure Convert_From_2d_Array (Conv : out Converted;
Orig : Original_Array) is
begin
raise Unimplemented;
end Convert_From_2d_Array;
-- generic
-- type Original is (<>);
-- type Converted is private;
procedure Convert_To_Discrete (Orig : out Original;
Conv : Converted) is
begin
raise Unimplemented;
end Convert_To_Discrete;
-- generic
-- type Original is private;
-- type Converted is private;
procedure Convert_To_Private (Orig : out Original;
Conv : Converted) is
begin
raise Unimplemented;
end Convert_To_Private;
-- generic
-- type Original is private;
-- type Index is (<>);
-- type Original_Array is array (Index range <>) of Original;
-- type Converted is private;
procedure Convert_To_Array (Orig : out Original_Array;
Conv : Converted) is
begin
raise Unimplemented;
end Convert_To_Array;
-- generic
-- type Original is private;
-- type Index1 is (<>);
-- type Index2 is (<>);
-- type Original_Array is array (Index1 range <>,
-- Index2 range <>) of Original;
-- type Converted is private;
procedure Convert_To_2d_Array (Orig : out Original_Array;
Conv : Converted) is
begin
raise Unimplemented;
end Convert_To_2d_Array;
end Dummy_Converters;
--\f
end Cvt_Test_Utilities;