|
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: 30822 (0x7866)
Types: TextFile
Names: »B«
└─⟦180fe333a⟧ Bits:30000405 8mm tape, Rational 1000, SW CATALOG, 10_20_0
└─⟦180fe333a⟧ Bits:30000537 8mm tape, Rational 1000, SW Catalog 10_20_0
└─⟦5cb1d1d7f⟧ »DATA«
└─⟦3b1ee7bd8⟧
└─⟦this⟧
--+ TITLE: TEST PROCEDURE FOR PACKAGE STACK_OF_DYNAMIC_ITEMS_G
--+ SUPPORT: Andre Volckov DMA-EPFL CH-1015 Lausanne
--+ REVISION 2: Jean-Jos# de Rus.
--+ CREATION: 20-JUL-1987 by Andre Volckov
with Text_Io;
use Text_Io;
with Integer_Text_Io;
with Stack_Of_Dynamic_Items_G;
with Generator_Of_Dynamic_Items;
use Generator_Of_Dynamic_Items;
procedure Stack_Of_Dynamic_Items_Test is
------------------------------
--+ OVERVIEW: This procedure tests behaviour of the package
--+ STACK_OF_DYNAMIC_ITEMS_G. It tests all primitives exported by this
--+ package in each particular and critical situation.
--+ Reference table in package GENERATOR_OF_DYNAMIC_ITEMS is used to
--+ initialize and compare elements of stacks involved in these tests.
-------------------------------------------------------------------------------
package Stack is new Stack_Of_Dynamic_Items_G
(Item_Type, Assign, Destroy, Equals);
use Stack;
Vector_Size : constant Positive := 100;
Vector : Vector_Type (1 .. Vector_Size);
Step : Integer;
-- Step indicator for error location.
Actual_Max_Free_List_Size : Natural := 0;
-- Actual maximum free list size positioned with SET_MAX_FREE_LIST_SIZE;
Item : Item_Type;
Error : Boolean := False;
Test_Error : exception;
-- Raised on unsuccesful test.
--/ GENERAL PURPOSE PROCEDURES:
-------------------------------------------------------------------------------
procedure Display_Error_Location (Step : in Integer; Number : in Integer) is
-- Displays error location and assigns value "TRUE" to ERROR
-- which stops program execution at the end of a STEP.
begin
Error := True;
Put ("*** ERROR: ");
Integer_Text_Io.Put (Number);
Put (" AT STEP");
Integer_Text_Io.Put (Step);
Put (" FOR MAX_FREE_LIST_SIZE =");
Integer_Text_Io.Put (Actual_Max_Free_List_Size);
New_Line;
end Display_Error_Location;
-------------------------------------------------------------------------------
procedure Null_Act_On_Item (Item : in Item_Type;
Order_Number : in Positive;
Continue : in out Boolean) is
-- Used in tests of traversals.
begin
null;
end Null_Act_On_Item;
-------------------------------------------------------------------------------
procedure Act_On_Item (Item : in Item_Type;
Order_Number : in Positive;
Continue : in out Boolean) is
-- Used in tests of traversals.
Temp : Item_Type;
begin
Assign (Temp, Item);
end Act_On_Item;
-------------------------------------------------------------------------------
procedure Traverse_Without_Action is new Traverse_G (Null_Act_On_Item);
-------------------------------------------------------------------------------
procedure Traverse_With_Action is new Traverse_G (Act_On_Item);
-------------------------------------------------------------------------------
procedure Initialize (Stack : in out Stack_Type;
Number_Of_Elements : in Positive) is
-- Initializes a stack with first NUMBER_OF_ELEMENTS
-- elements of the reference table.
begin
Destroy (Stack);
for I in 1 .. Number_Of_Elements loop
Push (Stack, Vector (I));
end loop;
end Initialize;
-------------------------------------------------------------------------------
procedure Check_Empty_Structure (Structure : in out Stack_Type) is
-- Tests behaviour of the exported procedures while
-- the STRUCTURE is empty.
-- Tests the exception EMPTY_STRUCTURE_ERROR.
begin
if Size (Structure) /= 0 then
Display_Error_Location (Step, 5);
end if;
if not Is_Empty (Structure) then
Display_Error_Location (Step, 10);
end if;
begin
Pop (Structure);
Display_Error_Location (Step, 15);
exception
when Empty_Structure_Error =>
null;
end;
begin
Pop (Structure, Item);
Display_Error_Location (Step, 20);
exception
when Empty_Structure_Error =>
null;
end;
begin
Get_Top_Value (Structure, Item);
Display_Error_Location (Step, 25);
exception
when Empty_Structure_Error =>
null;
end;
begin
Assign (Item, Top_Value (Structure));
Display_Error_Location (Step, 26);
exception
when Empty_Structure_Error =>
null;
end;
if Structure /= Structure then
Display_Error_Location (Step, 30);
end if;
begin
Traverse_Without_Action (Structure);
exception
when others =>
Display_Error_Location (Step, 35);
end;
begin
Traverse_With_Action (Structure);
exception
when others =>
Display_Error_Location (Step, 40);
end;
begin
Destroy (Structure);
exception
when others =>
Display_Error_Location (Step, 45);
end;
begin
Assign (Structure, Structure);
exception
when others =>
Display_Error_Location (Step, 50);
end;
if Structure /= Structure then
Display_Error_Location (Step, 55);
end if;
exception
when others =>
Display_Error_Location (Step, 60);
-- Presence of an undefined error!
end Check_Empty_Structure;
-------------------------------------------------------------------------------
procedure Check_Between_Two_Empty_Structures
(Dest, Source : in out Stack_Type) is
-- Check relations and assignment between two empty stacks.
begin
if Dest /= Source then
Display_Error_Location (Step, 5);
end if;
begin
Assign (Dest, Source);
exception
when others =>
Display_Error_Location (Step, 10);
end;
end Check_Between_Two_Empty_Structures;
-------------------------------------------------------------------------------
procedure Check_Unary_Operations (Number : in Positive;
Top_Val : in Item_Type;
Structure : in out Stack_Type) is
-- Check unary operations on stack.
Item : Item_Type;
begin
if Size (Structure) /= Number then
Display_Error_Location (Step, 5);
end if;
if Is_Empty (Structure) then
Display_Error_Location (Step, 10);
end if;
Assign (Item, Top_Value (Structure));
if not Equals (Item, Top_Val) then
Display_Error_Location (Step, 15);
end if;
Get_Top_Value (Structure, Item);
if not Equals (Item, Top_Val) then
Display_Error_Location (Step, 16);
end if;
Pop (Structure);
if Size (Structure) /= Number - 1 then
Display_Error_Location (Step, 20);
end if;
Push (Structure, Top_Val);
if Size (Structure) /= Number then
Display_Error_Location (Step, 25);
end if;
Pop (Structure, Item);
if Size (Structure) /= Number - 1 then
Display_Error_Location (Step, 30);
end if;
if not Equals (Item, Top_Val) then
Display_Error_Location (Step, 35);
end if;
Push (Structure, Item);
if Structure /= Structure then
Display_Error_Location (Step, 40);
end if;
begin
Traverse_Without_Action (Structure);
exception
when others =>
Display_Error_Location (Step, 45);
end;
declare
Dest : Stack_Type;
begin
Assign (Dest, Structure);
if Dest /= Structure then
Display_Error_Location (Step, 50);
end if;
Assign (Structure, Structure);
if Dest /= Structure then
Display_Error_Location (Step, 55);
end if;
end;
Destroy (Structure);
if not Is_Empty (Structure) then
Display_Error_Location (Step, 60);
end if;
exception
when others =>
Display_Error_Location (Step, 65);
-- Presence of an undefined error!
end Check_Unary_Operations;
-------------------------------------------------------------------------------
procedure Check_Equal_Structures (Left, Right : in out Stack_Type) is
-- Check relations and assignment between two equal structures.
begin
if Left /= Right then
Display_Error_Location (Step, 5);
end if;
begin
Assign (Left, Right);
exception
when others =>
Display_Error_Location (Step, 10);
end;
begin
Destroy (Left);
Assign (Left, Right);
exception
when others =>
Display_Error_Location (Step, 15);
end;
begin
Destroy (Right);
Assign (Left, Right);
exception
when others =>
Display_Error_Location (Step, 20);
end;
if Left /= Right then
Display_Error_Location (Step, 25);
end if;
exception
when others =>
Display_Error_Location (Step, 30);
-- Presence of an undefined error!
end Check_Equal_Structures;
-------------------------------------------------------------------------------
procedure Check_Not_Equal_Structures (Left, Right : in out Stack_Type) is
-- Check relations and assignment between two different structures.
begin
if Left = Right then
Display_Error_Location (Step, 5);
end if;
if Right = Left then
Display_Error_Location (Step, 10);
end if;
begin
Assign (Left, Right);
exception
when others =>
Display_Error_Location (Step, 15);
end;
if Left /= Right then
Display_Error_Location (Step, 20);
end if;
exception
when others =>
Display_Error_Location (Step, 25);
-- Presence of an undefined error!
end Check_Not_Equal_Structures;
-------------------------------------------------------------------------------
procedure Check_Traversal (Stack : in Stack_Type;
Last : in Natural;
Vector : in Vector_Type) is
-- Check TRAVERSE_G procedure.
Number : Natural;
Order_Number_Error, Value_Error, Stop_Error : exception;
procedure Compare (Item : in Item_Type;
Order_Number : in Positive;
Continue : in out Boolean) is
begin
Number := Number + 1;
if Number /= Order_Number then
raise Order_Number_Error;
end if;
if not Equals (Item, Vector (Last + 1 - Number)) then
raise Value_Error;
end if;
end Compare;
procedure Stop_At_Number (Item : in Item_Type;
Order_Number : in Positive;
Continue : in out Boolean) is
begin
if Order_Number = Number then
Continue := False;
elsif Order_Number > Number then
raise Stop_Error;
end if;
end Stop_At_Number;
begin
declare
procedure Traverse is new Traverse_G (Compare);
begin
Number := 0;
Traverse (Stack);
exception
when Order_Number_Error =>
Display_Error_Location (Step, 4);
when Value_Error =>
Display_Error_Location (Step, 10);
end;
declare
procedure Traverse is new Traverse_G (Stop_At_Number);
begin
Number := 1;
Traverse (Stack);
Number := (Last + 1) / 2;
Traverse (Stack);
Number := Last - 1;
if Number > 0 then
Traverse (Stack);
end if;
Number := Last;
Traverse (Stack);
exception
when Stop_Error =>
Display_Error_Location (Step, 15);
end;
exception
when others =>
Display_Error_Location (Step, 20);
-- Presence of an undefined error!
end Check_Traversal;
-------------------------------------------------------------------------------
procedure Preliminary_Tests is
-- Preliminary verification of each exported procedure.
Source, Dest, Structure : Stack_Type;
begin
--/ SIZE test
for I in Vector'Range loop
Push (Structure, Vector (I));
if Size (Structure) /= I then
Display_Error_Location (Step, 5);
exit;
end if;
end loop;
for I in Vector'Range loop
Pop (Structure);
if Size (Structure) /= Vector_Size - I then
Display_Error_Location (Step, 10);
exit;
end if;
end loop;
--/ DESTROY test
Initialize (Structure, Vector_Size);
Destroy (Structure);
if Size (Structure) /= 0 then
Display_Error_Location (Step, 15);
end if;
--/ PUSH/POP(...ITEM) and stack content test
Initialize (Structure, Vector_Size);
for I in 1 .. Vector_Size loop
Pop (Structure, Item);
if not Equals (Item, Vector (Vector_Size + 1 - I)) then
Display_Error_Location (Step, 20);
exit;
end if;
end loop;
--/ POP test
Initialize (Structure, Vector_Size);
for I in Vector'Range loop
Pop (Structure);
if Size (Structure) /= Vector_Size - I then
Display_Error_Location (Step, 25);
exit;
end if;
end loop;
--/ ASSIGN TEST
Initialize (Source, Vector_Size);
Assign (Dest, Source);
if Dest /= Source then
Display_Error_Location (Step, 30);
end if;
--/ GET_TOP_VALUE test
Push (Structure, Vector (Vector_Size / 2));
Assign (Item, Top_Value (Structure));
if not Equals (Item, Vector (Vector_Size / 2)) then
Display_Error_Location (Step, 35);
end if;
Get_Top_Value (Structure, Item);
if not Equals (Item, Vector (Vector_Size / 2)) then
Display_Error_Location (Step, 36);
end if;
--/ "=" test
Initialize (Source, Vector_Size);
Initialize (Dest, Vector_Size);
if Source /= Dest then
Display_Error_Location (Step, 40);
end if;
--/ TRAVERSE_G test
declare
Item : Item_Type;
Compare_Error : exception;
procedure Compare_Each (Item : in Item_Type;
Order_Number : in Positive;
Continue : in out Boolean) is
-- Compares the current element of the stack with corresponding
-- element of the VECTOR.
begin
if not Equals (Item, Vector
(Vector_Size + 1 - Order_Number)) then
raise Compare_Error;
end if;
end Compare_Each;
procedure Traverse_G_Test is new Traverse_G (Compare_Each);
begin
Initialize (Structure, Vector_Size);
Traverse_G_Test (Structure);
exception
when Compare_Error =>
Display_Error_Location (Step, 45);
end;
exception
when others =>
Display_Error_Location (Step, 50);
-- Presence of an undefined error!
end Preliminary_Tests;
-------------------------------------------------------------------------------
procedure Check_Exceptions is
Structure : Stack_Type;
begin
Initialize (Structure, Vector_Size);
Destroy (Structure);
begin
Pop (Structure);
Display_Error_Location (Step, 5); -- exception not raised
exception
when Empty_Structure_Error =>
null;
end;
declare
Item : Item_Type;
begin
Pop (Structure, Item);
Display_Error_Location (Step, 10); -- exception not raised
exception
when Empty_Structure_Error =>
null;
end;
declare
Item : Item_Type;
begin
Assign (Item, Top_Value (Structure));
Display_Error_Location (Step, 15); -- exception not raised
exception
when Empty_Structure_Error =>
null;
end;
begin
Get_Top_Value (Structure, Item);
Display_Error_Location (Step, 16); -- exception not raised
exception
when Empty_Structure_Error =>
null;
end;
Push (Structure, Vector (1));
Pop (Structure);
begin
Pop (Structure);
Display_Error_Location (Step, 20); -- exception not raised
exception
when Empty_Structure_Error =>
null;
end;
declare
Item : Item_Type;
begin
Pop (Structure, Item);
Display_Error_Location (Step, 25); -- exception not raised
exception
when Empty_Structure_Error =>
null;
end;
declare
Item : Item_Type;
begin
begin
Assign (Item, Top_Value (Structure));
Display_Error_Location (Step, 30); -- exception not raised
exception
when Empty_Structure_Error =>
null;
end;
begin
Get_Top_Value (Structure, Item);
Display_Error_Location (Step, 35); -- exception not raised
exception
when Empty_Structure_Error =>
null;
end;
end;
exception
when others =>
Display_Error_Location (Step, 40); -- presence of an undefined error
end Check_Exceptions;
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
--/ MAIN TEST PROCEDURE:
begin
Put ("Tests for STACK_OF_DYNAMIC_ITEMS_G...");
New_Line;
Generate (Vector);
for Pass in 1 .. 3 loop
-- Repeat tests for different values of MAX_FREE_LIST_SIZE.
-- If PASS = 1 then MAX_FREE_LIST_SIZE = 0 by default.
if Pass = 2 then
Release_Free_List;
Set_Max_Free_List_Size (Vector_Size / 2);
Actual_Max_Free_List_Size := Vector_Size / 2;
elsif Pass = 3 then
Release_Free_List;
Set_Max_Free_List_Size (Vector_Size);
Actual_Max_Free_List_Size := Vector_Size;
end if;
declare
Structure, Source, Dest : Stack_Type;
-- Stacks involved in tests.
begin
--/ TESTS FOR EXCEPTIONS, CONSTRUCTORS, QUERIES AND ITERATORS:
--/ A declared object must be empty:
Step := 1;
Check_Empty_Structure (Structure);
if Error then
raise Test_Error;
end if;
--/ Check between two declared objects who must be empty:
Step := 2;
Check_Between_Two_Empty_Structures (Dest, Source);
if Error then
raise Test_Error;
end if;
--/ Basic tests of operations
Step := 3;
Preliminary_Tests;
if Error then
raise Test_Error;
end if;
--/ Basic test of exceptions
Step := 4;
Check_Exceptions;
if Error then
raise Test_Error;
end if;
--/ Particular situations tests:
--/ Check unary operations on the stack of size 1:
Step := 5;
Push (Structure, Vector (1));
Check_Unary_Operations (1, Vector (1), Structure);
if Error then
raise Test_Error;
end if;
--/Check unary operations on the stack of size VECTOR_SIZE:
Step := 6;
Initialize (Structure, Vector_Size);
Check_Unary_Operations (Vector_Size,
Vector (Vector_Size), Structure);
if Error then
raise Test_Error;
end if;
--/ A stack must be empty: check of an empty structure:
Step := 7;
Check_Empty_Structure (Structure);
if Error then
raise Test_Error;
end if;
--/ Successives PUSHs and POPs must leave the stack empty:
Step := 8;
Initialize (Structure, Vector_Size); -- PUSH(STRUCTURE...);
for I in 1 .. Vector_Size loop
Pop (Structure);
end loop;
Check_Empty_Structure (Structure);
if Error then
raise Test_Error;
end if;
--/ Destroy must leave the stack empty:
Step := 9;
Initialize (Structure, Vector_Size);
Destroy (Structure);
Check_Empty_Structure (Structure);
if Error then
raise Test_Error;
end if;
--/ Check of equal structures:
Step := 10;
Initialize (Source, Vector_Size);
Initialize (Dest, Vector_Size);
Pop (Source, Item);
Push (Source, Item);
Check_Equal_Structures (Dest, Source);
if Error then
raise Test_Error;
end if;
--/ Check of two empty structures:
Step := 11;
Destroy (Source);
Destroy (Dest);
Check_Between_Two_Empty_Structures (Dest, Source);
if Error then
raise Test_Error;
end if;
--/ Check of not equal structures:
--/ different number of elements.
Step := 12;
Initialize (Source, Vector_Size);
Initialize (Dest, Vector_Size);
Push (Dest, Vector (Vector_Size));
Check_Not_Equal_Structures (Dest, Source);
if Error then
raise Test_Error;
end if;
--/ Check of not equal structures:
--/ same number of elements; top element is different.
Step := 13;
Initialize (Source, Vector_Size);
Initialize (Dest, Vector_Size);
Push (Source, Vector (Vector_Size - 1));
Push (Dest, Vector (Vector_Size));
Check_Not_Equal_Structures (Dest, Source);
if Error then
raise Test_Error;
end if;
--/ Check of not equal structures:
--/ same number of elements; intermediate element is different.
Step := 14;
Destroy (Source);
Destroy (Dest);
for I in 1 .. Vector_Size / 2 loop
Push (Source, Vector (I));
Push (Dest, Vector (I));
end loop;
Push (Source, Vector (1));
Push (Dest, Vector (2));
for I in Vector_Size / 2 + 1 .. Vector_Size loop
Push (Source, Vector (I));
Push (Dest, Vector (I));
end loop;
Check_Not_Equal_Structures (Dest, Source);
if Error then
raise Test_Error;
end if;
--/ Check of not equal structures;
--/ same number of elements; bottom element is different.
Step := 15;
Destroy (Source);
Destroy (Dest);
Push (Source, Vector (1));
Push (Dest, Vector (2));
for I in 2 .. Vector_Size loop
Push (Source, Vector (I));
Push (Dest, Vector (I));
end loop;
Check_Not_Equal_Structures (Dest, Source);
if Error then
raise Test_Error;
end if;
--/ Check of not equal structures;
--/ DEST is empty;
Step := 16;
Initialize (Source, Vector_Size);
Initialize (Dest, Vector_Size);
Destroy (Dest);
Check_Not_Equal_Structures (Dest, Source);
if Error then
raise Test_Error;
end if;
--/ Check of not equal structures;
--/ SOURCE is empty;
Step := 17;
Initialize (Source, Vector_Size);
Initialize (Dest, Vector_Size);
Destroy (Source);
Check_Not_Equal_Structures (Dest, Source);
if Error then
raise Test_Error;
end if;
--/ Check traversal; 1 element in the stack.
Step := 18;
Push (Structure, Vector (1));
Check_Traversal (Structure, 1, Vector);
if Error then
raise Test_Error;
end if;
--/ Check traversal; All elements in the stack.
Step := 19;
Initialize (Structure, Vector_Size);
Check_Traversal (Structure, Vector_Size, Vector);
if Error then
raise Test_Error;
end if;
Destroy (Structure);
Destroy (Source);
Destroy (Dest);
end;
end loop;
declare
Structure, Source, Dest : Stack_Type;
-- Stacks involved in tests.
begin
--/ HEAP MANAGEMENT TESTS:
Initialize (Structure, Vector_Size);
Release_Free_List;
Set_Max_Free_List_Size (Vector_Size);
Actual_Max_Free_List_Size := Vector_Size;
--/ Free list management tests on PUSH/POP:
Step := 20;
declare
Free_List_Size_Error : exception;
begin
for I in 1 .. Vector_Size loop
Pop (Structure);
if Free_List_Size /= I then
raise Free_List_Size_Error;
end if;
end loop;
exception
when Free_List_Size_Error =>
Display_Error_Location (Step, 801);
end;
declare
Free_List_Size_Error : exception;
begin
for I in 1 .. Vector_Size loop
Push (Structure, Vector (I));
if Free_List_Size /= Vector_Size - I then
raise Free_List_Size_Error;
end if;
end loop;
exception
when Free_List_Size_Error =>
Display_Error_Location (Step, 802);
end;
if Error then
raise Test_Error;
end if;
--/ SET_MAX_FREE_LIST test:
Step := 21;
Set_Max_Free_List_Size (Vector_Size / 2);
Actual_Max_Free_List_Size := Vector_Size / 2;
declare
Free_List_Size_Error : exception;
begin
for I in 1 .. Vector_Size / 2 loop
Pop (Structure);
if Free_List_Size /= I then
raise Free_List_Size_Error;
end if;
end loop;
exception
when Free_List_Size_Error =>
Display_Error_Location (Step, 901);
end;
declare
Free_List_Size_Error : exception;
begin
while Size (Structure) /= 0 loop
Pop (Structure);
if Free_List_Size /= Vector_Size / 2 then
raise Free_List_Size_Error;
end if;
end loop;
exception
when Free_List_Size_Error =>
Display_Error_Location (Step, 902);
end;
Push (Structure, Vector (1));
if Free_List_Size /= Vector_Size / 2 - 1 then
Display_Error_Location (Step, 903);
end if;
if Error then
raise Test_Error;
end if;
--/ RELEASE_FREE_LIST test:
Step := 22;
Set_Max_Free_List_Size (Vector_Size);
Actual_Max_Free_List_Size := Vector_Size;
Initialize (Structure, Vector_Size);
for I in 1 .. Vector_Size loop
Pop (Structure);
end loop;
if Free_List_Size /= Vector_Size then
Display_Error_Location (Step, 1001);
end if;
Release_Free_List;
if Free_List_Size /= 0 then
Display_Error_Location (Step, 1002);
end if;
if Error then
raise Test_Error;
end if;
--/ Free list management test on DESTROY:
Step := 23;
Initialize (Structure, Vector_Size);
Destroy (Structure);
if Free_List_Size /= Vector_Size then
Display_Error_Location (Step, 1101);
end if;
if Error then
raise Test_Error;
end if;
--/ Free list management test on ASSIGN:
Step := 24;
Release_Free_List;
Initialize (Source, Vector_Size - 10);
Initialize (Dest, Vector_Size);
Destroy (Dest);
-- Free list contains VECTOR_SIZE elements.
Assign (Dest, Source);
-- DEST contains VECTOR_SIZE-10 elements
-- Free list must contain 10 elements
if Free_List_Size /= 10 then
Display_Error_Location (Step, 1201);
end if;
Destroy (Source);
-- Free list contains VECTOR_SIZE elements.
Assign (Dest, Source);
-- Free list must contain VECTOR_SIZE elements
if Free_List_Size /= Vector_Size then
Display_Error_Location (Step, 1202);
end if;
if Error then
raise Test_Error;
end if;
end;
Put_Line ("successfuly completed.");
exception
when Test_Error =>
Put_Line ("Test procedure cannot continue.");
end Stack_Of_Dynamic_Items_Test;