-- C980001.A
|
-- C980001.A
|
--
|
--
|
-- Grant of Unlimited Rights
|
-- Grant of Unlimited Rights
|
--
|
--
|
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
|
-- 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
|
-- 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 in the software and documentation contained herein.
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
-- this public release, the Government intends to confer upon all
|
-- this public release, the Government intends to confer upon all
|
-- recipients unlimited rights equal to those held by the Government.
|
-- recipients unlimited rights equal to those held by the Government.
|
-- These rights include rights to use, duplicate, release or disclose the
|
-- These rights include rights to use, duplicate, release or disclose the
|
-- released technical data and computer software in whole or in part, in
|
-- 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
|
-- any manner and for any purpose whatsoever, and to have or permit others
|
-- to do so.
|
-- to do so.
|
--
|
--
|
-- DISCLAIMER
|
-- DISCLAIMER
|
--
|
--
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
--*
|
--*
|
--
|
--
|
-- OBJECTIVE:
|
-- OBJECTIVE:
|
-- Check that when a construct is aborted the execution of an Initialize
|
-- Check that when a construct is aborted the execution of an Initialize
|
-- procedure as the last step of the default initialization of a
|
-- procedure as the last step of the default initialization of a
|
-- controlled object is abort-deferred.
|
-- controlled object is abort-deferred.
|
--
|
--
|
-- Check that when a construct is aborted the execution of a Finalize
|
-- Check that when a construct is aborted the execution of a Finalize
|
-- procedure as part of the finalization of a controlled object is
|
-- procedure as part of the finalization of a controlled object is
|
-- abort-deferred.
|
-- abort-deferred.
|
--
|
--
|
-- Check that an assignment operation to an object with a controlled
|
-- Check that an assignment operation to an object with a controlled
|
-- part is an abort-deferred operation.
|
-- part is an abort-deferred operation.
|
--
|
--
|
-- TEST DESCRIPTION:
|
-- TEST DESCRIPTION:
|
-- The controlled operations which are being tested call a subprogram
|
-- The controlled operations which are being tested call a subprogram
|
-- which guarantees that the enclosing operation becomes aborted.
|
-- which guarantees that the enclosing operation becomes aborted.
|
--
|
--
|
-- Each object is created with a unique value to prevent optimizations
|
-- Each object is created with a unique value to prevent optimizations
|
-- due to the values being the same.
|
-- due to the values being the same.
|
--
|
--
|
-- Two protected objects are utilized to warrant that the operations
|
-- Two protected objects are utilized to warrant that the operations
|
-- are delayed in their execution until such time that the abort is
|
-- are delayed in their execution until such time that the abort is
|
-- processed. The object Hold_Up is used to hold the targeted
|
-- processed. The object Hold_Up is used to hold the targeted
|
-- operation in execution, the object Progress is used to communicate
|
-- operation in execution, the object Progress is used to communicate
|
-- to the driver software that progress is indeed being made.
|
-- to the driver software that progress is indeed being made.
|
--
|
--
|
--
|
--
|
-- CHANGE HISTORY:
|
-- CHANGE HISTORY:
|
-- 01 MAY 95 SAIC Initial version
|
-- 01 MAY 95 SAIC Initial version
|
-- 01 MAY 96 SAIC Revised for 2.1
|
-- 01 MAY 96 SAIC Revised for 2.1
|
-- 11 DEC 96 SAIC Final revision for 2.1
|
-- 11 DEC 96 SAIC Final revision for 2.1
|
-- 02 DEC 97 EDS Remove 2 calls to C980001_0.Hold_Up.Lock
|
-- 02 DEC 97 EDS Remove 2 calls to C980001_0.Hold_Up.Lock
|
--!
|
--!
|
|
|
---------------------------------------------------------------- C980001_0
|
---------------------------------------------------------------- C980001_0
|
|
|
with Impdef;
|
with Impdef;
|
with Ada.Finalization;
|
with Ada.Finalization;
|
package C980001_0 is
|
package C980001_0 is
|
|
|
A_Little_While : constant Duration := Impdef.Switch_To_New_Task * 2.0;
|
A_Little_While : constant Duration := Impdef.Switch_To_New_Task * 2.0;
|
Enough_Time_For_The_Controlled_Operation_To_Happen : constant Duration
|
Enough_Time_For_The_Controlled_Operation_To_Happen : constant Duration
|
:= Impdef.Switch_To_New_Task * 4.0;
|
:= Impdef.Switch_To_New_Task * 4.0;
|
|
|
function TC_Unique return Integer;
|
function TC_Unique return Integer;
|
|
|
type Sticks_In_Initialize is new Ada.Finalization.Controlled with record
|
type Sticks_In_Initialize is new Ada.Finalization.Controlled with record
|
Item: Integer := TC_Unique;
|
Item: Integer := TC_Unique;
|
end record;
|
end record;
|
procedure Initialize( AV: in out Sticks_In_Initialize );
|
procedure Initialize( AV: in out Sticks_In_Initialize );
|
|
|
type Sticks_In_Adjust is new Ada.Finalization.Controlled with record
|
type Sticks_In_Adjust is new Ada.Finalization.Controlled with record
|
Item: Integer := TC_Unique;
|
Item: Integer := TC_Unique;
|
end record;
|
end record;
|
procedure Adjust ( AV: in out Sticks_In_Adjust );
|
procedure Adjust ( AV: in out Sticks_In_Adjust );
|
|
|
type Sticks_In_Finalize is new Ada.Finalization.Controlled with record
|
type Sticks_In_Finalize is new Ada.Finalization.Controlled with record
|
Item: Integer := TC_Unique;
|
Item: Integer := TC_Unique;
|
end record;
|
end record;
|
procedure Finalize ( AV: in out Sticks_In_Finalize );
|
procedure Finalize ( AV: in out Sticks_In_Finalize );
|
|
|
Initialize_Called : Boolean := False;
|
Initialize_Called : Boolean := False;
|
Adjust_Called : Boolean := False;
|
Adjust_Called : Boolean := False;
|
Finalize_Called : Boolean := False;
|
Finalize_Called : Boolean := False;
|
|
|
protected type Sticker is
|
protected type Sticker is
|
entry Lock;
|
entry Lock;
|
procedure Unlock;
|
procedure Unlock;
|
function Is_Locked return Boolean;
|
function Is_Locked return Boolean;
|
private
|
private
|
Locked : Boolean := False;
|
Locked : Boolean := False;
|
end Sticker;
|
end Sticker;
|
|
|
Hold_Up : Sticker;
|
Hold_Up : Sticker;
|
Progress : Sticker;
|
Progress : Sticker;
|
|
|
procedure Fail_And_Clear( Message : String );
|
procedure Fail_And_Clear( Message : String );
|
|
|
|
|
end C980001_0;
|
end C980001_0;
|
|
|
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
|
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
|
|
|
with Report;
|
with Report;
|
with TCTouch;
|
with TCTouch;
|
package body C980001_0 is
|
package body C980001_0 is
|
|
|
TC_Master_Value : Integer := 0;
|
TC_Master_Value : Integer := 0;
|
|
|
|
|
function TC_Unique return Integer is -- make all values unique.
|
function TC_Unique return Integer is -- make all values unique.
|
begin
|
begin
|
TC_Master_Value := TC_Master_Value +1;
|
TC_Master_Value := TC_Master_Value +1;
|
return TC_Master_Value;
|
return TC_Master_Value;
|
end TC_Unique;
|
end TC_Unique;
|
|
|
protected body Sticker is
|
protected body Sticker is
|
|
|
entry Lock when not Locked is
|
entry Lock when not Locked is
|
begin
|
begin
|
Locked := True;
|
Locked := True;
|
end Lock;
|
end Lock;
|
|
|
procedure Unlock is
|
procedure Unlock is
|
begin
|
begin
|
Locked := False;
|
Locked := False;
|
end Unlock;
|
end Unlock;
|
|
|
function Is_Locked return Boolean is
|
function Is_Locked return Boolean is
|
begin
|
begin
|
return Locked;
|
return Locked;
|
end Is_Locked;
|
end Is_Locked;
|
|
|
end Sticker;
|
end Sticker;
|
|
|
procedure Initialize( AV: in out Sticks_In_Initialize ) is
|
procedure Initialize( AV: in out Sticks_In_Initialize ) is
|
begin
|
begin
|
TCTouch.Touch('I'); -------------------------------------------------- I
|
TCTouch.Touch('I'); -------------------------------------------------- I
|
Hold_Up.Unlock; -- cause the select to abort
|
Hold_Up.Unlock; -- cause the select to abort
|
Initialize_Called := True;
|
Initialize_Called := True;
|
AV.Item := TC_Unique;
|
AV.Item := TC_Unique;
|
TCTouch.Touch('i'); -------------------------------------------------- i
|
TCTouch.Touch('i'); -------------------------------------------------- i
|
Progress.Unlock; -- allows Wait_Your_Turn to continue
|
Progress.Unlock; -- allows Wait_Your_Turn to continue
|
end Initialize;
|
end Initialize;
|
|
|
procedure Adjust ( AV: in out Sticks_In_Adjust ) is
|
procedure Adjust ( AV: in out Sticks_In_Adjust ) is
|
begin
|
begin
|
TCTouch.Touch('A'); -------------------------------------------------- A
|
TCTouch.Touch('A'); -------------------------------------------------- A
|
Hold_Up.Unlock; -- cause the select to abort
|
Hold_Up.Unlock; -- cause the select to abort
|
Adjust_Called := True;
|
Adjust_Called := True;
|
AV.Item := TC_Unique;
|
AV.Item := TC_Unique;
|
TCTouch.Touch('a'); -------------------------------------------------- a
|
TCTouch.Touch('a'); -------------------------------------------------- a
|
Progress.Unlock;
|
Progress.Unlock;
|
end Adjust;
|
end Adjust;
|
|
|
procedure Finalize ( AV: in out Sticks_In_Finalize ) is
|
procedure Finalize ( AV: in out Sticks_In_Finalize ) is
|
begin
|
begin
|
TCTouch.Touch('F'); -------------------------------------------------- F
|
TCTouch.Touch('F'); -------------------------------------------------- F
|
Hold_Up.Unlock; -- cause the select to abort
|
Hold_Up.Unlock; -- cause the select to abort
|
Finalize_Called := True;
|
Finalize_Called := True;
|
AV.Item := TC_Unique;
|
AV.Item := TC_Unique;
|
TCTouch.Touch('f'); -------------------------------------------------- f
|
TCTouch.Touch('f'); -------------------------------------------------- f
|
Progress.Unlock;
|
Progress.Unlock;
|
end Finalize;
|
end Finalize;
|
|
|
procedure Fail_And_Clear( Message : String ) is
|
procedure Fail_And_Clear( Message : String ) is
|
begin
|
begin
|
Report.Failed(Message);
|
Report.Failed(Message);
|
Hold_Up.Unlock;
|
Hold_Up.Unlock;
|
Progress.Unlock;
|
Progress.Unlock;
|
end Fail_And_Clear;
|
end Fail_And_Clear;
|
|
|
end C980001_0;
|
end C980001_0;
|
|
|
---------------------------------------------------------------------------
|
---------------------------------------------------------------------------
|
|
|
with Report;
|
with Report;
|
with TCTouch;
|
with TCTouch;
|
with Impdef;
|
with Impdef;
|
with C980001_0;
|
with C980001_0;
|
procedure C980001 is
|
procedure C980001 is
|
|
|
procedure Check_Initialize_Conditions is
|
procedure Check_Initialize_Conditions is
|
begin
|
begin
|
if not C980001_0.Initialize_Called then
|
if not C980001_0.Initialize_Called then
|
C980001_0.Fail_And_Clear("Initialize did not correctly complete");
|
C980001_0.Fail_And_Clear("Initialize did not correctly complete");
|
end if;
|
end if;
|
TCTouch.Validate("Ii", "Initialization Sequence");
|
TCTouch.Validate("Ii", "Initialization Sequence");
|
end Check_Initialize_Conditions;
|
end Check_Initialize_Conditions;
|
|
|
procedure Check_Adjust_Conditions is
|
procedure Check_Adjust_Conditions is
|
begin
|
begin
|
if not C980001_0.Adjust_Called then
|
if not C980001_0.Adjust_Called then
|
C980001_0.Fail_And_Clear("Adjust did not correctly complete");
|
C980001_0.Fail_And_Clear("Adjust did not correctly complete");
|
end if;
|
end if;
|
TCTouch.Validate("Aa", "Adjust Sequence");
|
TCTouch.Validate("Aa", "Adjust Sequence");
|
end Check_Adjust_Conditions;
|
end Check_Adjust_Conditions;
|
|
|
procedure Check_Finalize_Conditions is
|
procedure Check_Finalize_Conditions is
|
begin
|
begin
|
if not C980001_0.Finalize_Called then
|
if not C980001_0.Finalize_Called then
|
C980001_0.Fail_And_Clear("Finalize did not correctly complete");
|
C980001_0.Fail_And_Clear("Finalize did not correctly complete");
|
end if;
|
end if;
|
TCTouch.Validate("FfFfFf", "Finalization Sequence",
|
TCTouch.Validate("FfFfFf", "Finalization Sequence",
|
Order_Meaningful => False);
|
Order_Meaningful => False);
|
end Check_Finalize_Conditions;
|
end Check_Finalize_Conditions;
|
|
|
procedure Wait_Your_Turn is
|
procedure Wait_Your_Turn is
|
Overrun : Natural := 0;
|
Overrun : Natural := 0;
|
begin
|
begin
|
while C980001_0.Progress.Is_Locked loop -- and waits
|
while C980001_0.Progress.Is_Locked loop -- and waits
|
delay C980001_0.A_Little_While;
|
delay C980001_0.A_Little_While;
|
Overrun := Overrun +1;
|
Overrun := Overrun +1;
|
if Overrun > 10 then
|
if Overrun > 10 then
|
C980001_0.Fail_And_Clear("Overrun expired lock");
|
C980001_0.Fail_And_Clear("Overrun expired lock");
|
end if;
|
end if;
|
end loop;
|
end loop;
|
end Wait_Your_Turn;
|
end Wait_Your_Turn;
|
|
|
begin -- Main test procedure.
|
begin -- Main test procedure.
|
|
|
Report.Test ("C980001", "Check the interaction between asynchronous " &
|
Report.Test ("C980001", "Check the interaction between asynchronous " &
|
"transfer of control and controlled types" );
|
"transfer of control and controlled types" );
|
|
|
C980001_0.Progress.Lock;
|
C980001_0.Progress.Lock;
|
C980001_0.Hold_Up.Lock;
|
C980001_0.Hold_Up.Lock;
|
|
|
select
|
select
|
C980001_0.Hold_Up.Lock; -- Init will unlock
|
C980001_0.Hold_Up.Lock; -- Init will unlock
|
|
|
Wait_Your_Turn; -- abortable part is stuck in Initialize
|
Wait_Your_Turn; -- abortable part is stuck in Initialize
|
Check_Initialize_Conditions;
|
Check_Initialize_Conditions;
|
|
|
then abort
|
then abort
|
declare
|
declare
|
Object : C980001_0.Sticks_In_Initialize;
|
Object : C980001_0.Sticks_In_Initialize;
|
begin
|
begin
|
delay Impdef.Minimum_Task_Switch;
|
delay Impdef.Minimum_Task_Switch;
|
if Report.Ident_Int( Object.Item ) /= Object.Item then
|
if Report.Ident_Int( Object.Item ) /= Object.Item then
|
Report.Failed("Optimization foil caused failure");
|
Report.Failed("Optimization foil caused failure");
|
end if;
|
end if;
|
C980001_0.Fail_And_Clear(
|
C980001_0.Fail_And_Clear(
|
"Initialize test executed beyond expected region");
|
"Initialize test executed beyond expected region");
|
end;
|
end;
|
end select;
|
end select;
|
|
|
C980001_0.Progress.Lock;
|
C980001_0.Progress.Lock;
|
|
|
select
|
select
|
C980001_0.Hold_Up.Lock; -- Adjust will unlock
|
C980001_0.Hold_Up.Lock; -- Adjust will unlock
|
|
|
Wait_Your_Turn; -- abortable part is stuck in Adjust
|
Wait_Your_Turn; -- abortable part is stuck in Adjust
|
Check_Adjust_Conditions;
|
Check_Adjust_Conditions;
|
|
|
then abort
|
then abort
|
declare
|
declare
|
Object1 : C980001_0.Sticks_In_Adjust;
|
Object1 : C980001_0.Sticks_In_Adjust;
|
Object2 : C980001_0.Sticks_In_Adjust;
|
Object2 : C980001_0.Sticks_In_Adjust;
|
begin
|
begin
|
Object1 := Object2;
|
Object1 := Object2;
|
delay Impdef.Minimum_Task_Switch;
|
delay Impdef.Minimum_Task_Switch;
|
if Report.Ident_Int( Object2.Item )
|
if Report.Ident_Int( Object2.Item )
|
/= Report.Ident_Int( Object1.Item ) then
|
/= Report.Ident_Int( Object1.Item ) then
|
Report.Failed("Optimization foil 1 caused failure");
|
Report.Failed("Optimization foil 1 caused failure");
|
end if;
|
end if;
|
C980001_0.Fail_And_Clear("Adjust test executed beyond expected region");
|
C980001_0.Fail_And_Clear("Adjust test executed beyond expected region");
|
end;
|
end;
|
end select;
|
end select;
|
|
|
C980001_0.Progress.Lock;
|
C980001_0.Progress.Lock;
|
|
|
select
|
select
|
C980001_0.Hold_Up.Lock; -- Finalize will unlock
|
C980001_0.Hold_Up.Lock; -- Finalize will unlock
|
|
|
Wait_Your_Turn; -- abortable part is stuck in Finalize
|
Wait_Your_Turn; -- abortable part is stuck in Finalize
|
Check_Finalize_Conditions;
|
Check_Finalize_Conditions;
|
|
|
then abort
|
then abort
|
declare
|
declare
|
Object1 : C980001_0.Sticks_In_Finalize;
|
Object1 : C980001_0.Sticks_In_Finalize;
|
Object2 : C980001_0.Sticks_In_Finalize;
|
Object2 : C980001_0.Sticks_In_Finalize;
|
begin
|
begin
|
Object1 := Object2; -- cause a finalize call
|
Object1 := Object2; -- cause a finalize call
|
delay Impdef.Minimum_Task_Switch;
|
delay Impdef.Minimum_Task_Switch;
|
if Report.Ident_Int( Object2.Item )
|
if Report.Ident_Int( Object2.Item )
|
/= Report.Ident_Int( Object1.Item ) then
|
/= Report.Ident_Int( Object1.Item ) then
|
Report.Failed("Optimization foil 2 caused failure");
|
Report.Failed("Optimization foil 2 caused failure");
|
end if;
|
end if;
|
C980001_0.Fail_And_Clear(
|
C980001_0.Fail_And_Clear(
|
"Finalize test executed beyond expected region");
|
"Finalize test executed beyond expected region");
|
end;
|
end;
|
end select;
|
end select;
|
|
|
Report.Result;
|
Report.Result;
|
|
|
exception
|
exception
|
when others => C980001_0.Fail_And_Clear("Exception in main");
|
when others => C980001_0.Fail_And_Clear("Exception in main");
|
Report.Result;
|
Report.Result;
|
end C980001;
|
end C980001;
|
|
|
