-- C393A03.A
|
-- C393A03.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 a non-abstract primitive subprogram of an abstract
|
-- Check that a non-abstract primitive subprogram of an abstract
|
-- type can be called as a dispatching operation and that the body
|
-- type can be called as a dispatching operation and that the body
|
-- of this subprogram can make a dispatching call to an abstract
|
-- of this subprogram can make a dispatching call to an abstract
|
-- operation of the corresponding abstract type.
|
-- operation of the corresponding abstract type.
|
--
|
--
|
-- TEST DESCRIPTION:
|
-- TEST DESCRIPTION:
|
-- This test expands on the class family defined in foundation F393A00
|
-- This test expands on the class family defined in foundation F393A00
|
-- by deriving a new abstract type from the root abstract type "Object".
|
-- by deriving a new abstract type from the root abstract type "Object".
|
-- The subprograms defined for the new abstract type are then
|
-- The subprograms defined for the new abstract type are then
|
-- appropriately overridden, and the test ultimately calls various
|
-- appropriately overridden, and the test ultimately calls various
|
-- mixtures of these subprograms to check that the dispatching occurs
|
-- mixtures of these subprograms to check that the dispatching occurs
|
-- correctly.
|
-- correctly.
|
--
|
--
|
-- TEST FILES:
|
-- TEST FILES:
|
-- The following files comprise this test:
|
-- The following files comprise this test:
|
--
|
--
|
-- F393A00.A (foundation code)
|
-- F393A00.A (foundation code)
|
-- C393A03.A
|
-- C393A03.A
|
--
|
--
|
--
|
--
|
-- CHANGE HISTORY:
|
-- CHANGE HISTORY:
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 19 Dec 94 SAIC Removed ARM references from objective text.
|
-- 19 Dec 94 SAIC Removed ARM references from objective text.
|
-- 23 Oct 95 SAIC Fixed bugs for ACVC 2.0.1
|
-- 23 Oct 95 SAIC Fixed bugs for ACVC 2.0.1
|
--
|
--
|
--!
|
--!
|
|
|
------------------------------------------------------------------- C393A03_0
|
------------------------------------------------------------------- C393A03_0
|
|
|
with F393A00_1;
|
with F393A00_1;
|
package C393A03_0 is
|
package C393A03_0 is
|
|
|
type Counting_Object is abstract new F393A00_1.Object with private;
|
type Counting_Object is abstract new F393A00_1.Object with private;
|
-- inherits Initialize, Swap (abstract) and Create (abstract)
|
-- inherits Initialize, Swap (abstract) and Create (abstract)
|
|
|
procedure Bump ( A_Counter: in out Counting_Object );
|
procedure Bump ( A_Counter: in out Counting_Object );
|
procedure Clear( A_Counter: in out Counting_Object ) is abstract;
|
procedure Clear( A_Counter: in out Counting_Object ) is abstract;
|
procedure Zero ( A_Counter: in out Counting_Object );
|
procedure Zero ( A_Counter: in out Counting_Object );
|
function Value( A_Counter: Counting_Object'Class ) return Natural;
|
function Value( A_Counter: Counting_Object'Class ) return Natural;
|
|
|
private
|
private
|
|
|
type Counting_Object is abstract new F393A00_1.Object with
|
type Counting_Object is abstract new F393A00_1.Object with
|
record
|
record
|
Tally : Natural :=0;
|
Tally : Natural :=0;
|
end record;
|
end record;
|
|
|
end C393A03_0;
|
end C393A03_0;
|
|
|
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
|
|
with F393A00_0;
|
with F393A00_0;
|
package body C393A03_0 is
|
package body C393A03_0 is
|
|
|
procedure Bump ( A_Counter: in out Counting_Object ) is
|
procedure Bump ( A_Counter: in out Counting_Object ) is
|
begin
|
begin
|
F393A00_0.TC_Touch('A');
|
F393A00_0.TC_Touch('A');
|
A_Counter.Tally := A_Counter.Tally +1;
|
A_Counter.Tally := A_Counter.Tally +1;
|
end Bump;
|
end Bump;
|
|
|
procedure Zero ( A_Counter: in out Counting_Object ) is
|
procedure Zero ( A_Counter: in out Counting_Object ) is
|
begin
|
begin
|
F393A00_0.TC_Touch('B');
|
F393A00_0.TC_Touch('B');
|
|
|
-- dispatching call to abstract operation of Counting_Object
|
-- dispatching call to abstract operation of Counting_Object
|
Clear( Counting_Object'Class(A_Counter) );
|
Clear( Counting_Object'Class(A_Counter) );
|
|
|
A_Counter.Tally := 0;
|
A_Counter.Tally := 0;
|
|
|
end Zero;
|
end Zero;
|
|
|
function Value( A_Counter: Counting_Object'Class ) return Natural is
|
function Value( A_Counter: Counting_Object'Class ) return Natural is
|
begin
|
begin
|
F393A00_0.TC_Touch('C');
|
F393A00_0.TC_Touch('C');
|
return A_Counter.Tally;
|
return A_Counter.Tally;
|
end Value;
|
end Value;
|
|
|
end C393A03_0;
|
end C393A03_0;
|
|
|
------------------------------------------------------------------- C393A03_1
|
------------------------------------------------------------------- C393A03_1
|
|
|
with C393A03_0;
|
with C393A03_0;
|
package C393A03_1 is
|
package C393A03_1 is
|
|
|
type Modular_Object is new C393A03_0.Counting_Object with private;
|
type Modular_Object is new C393A03_0.Counting_Object with private;
|
-- inherits Initialize, Bump, Zero and Value,
|
-- inherits Initialize, Bump, Zero and Value,
|
-- inherits abstract Swap, Create and Clear
|
-- inherits abstract Swap, Create and Clear
|
|
|
procedure Swap( A,B: in out Modular_Object );
|
procedure Swap( A,B: in out Modular_Object );
|
procedure Clear( It: in out Modular_Object );
|
procedure Clear( It: in out Modular_Object );
|
procedure Set_Max( It : in out Modular_Object; Value : Natural );
|
procedure Set_Max( It : in out Modular_Object; Value : Natural );
|
function Create return Modular_Object;
|
function Create return Modular_Object;
|
|
|
private
|
private
|
|
|
type Modular_Object is new C393A03_0.Counting_Object with
|
type Modular_Object is new C393A03_0.Counting_Object with
|
record
|
record
|
Max_Value : Natural;
|
Max_Value : Natural;
|
end record;
|
end record;
|
|
|
end C393A03_1;
|
end C393A03_1;
|
|
|
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
|
|
with F393A00_0;
|
with F393A00_0;
|
package body C393A03_1 is
|
package body C393A03_1 is
|
|
|
procedure Swap( A,B: in out Modular_Object ) is
|
procedure Swap( A,B: in out Modular_Object ) is
|
T : constant Modular_Object := B;
|
T : constant Modular_Object := B;
|
begin
|
begin
|
F393A00_0.TC_Touch('1');
|
F393A00_0.TC_Touch('1');
|
B := A;
|
B := A;
|
A := T;
|
A := T;
|
end Swap;
|
end Swap;
|
|
|
procedure Clear( It: in out Modular_Object ) is
|
procedure Clear( It: in out Modular_Object ) is
|
begin
|
begin
|
F393A00_0.TC_Touch('2');
|
F393A00_0.TC_Touch('2');
|
null;
|
null;
|
end Clear;
|
end Clear;
|
|
|
procedure Set_Max( It : in out Modular_Object; Value : Natural ) is
|
procedure Set_Max( It : in out Modular_Object; Value : Natural ) is
|
begin
|
begin
|
F393A00_0.TC_Touch('3');
|
F393A00_0.TC_Touch('3');
|
It.Max_Value := Value;
|
It.Max_Value := Value;
|
end Set_Max;
|
end Set_Max;
|
|
|
function Create return Modular_Object is
|
function Create return Modular_Object is
|
AMO : Modular_Object;
|
AMO : Modular_Object;
|
begin
|
begin
|
F393A00_0.TC_Touch('4');
|
F393A00_0.TC_Touch('4');
|
AMO.Max_Value := Natural'Last;
|
AMO.Max_Value := Natural'Last;
|
return AMO;
|
return AMO;
|
end Create;
|
end Create;
|
|
|
end C393A03_1;
|
end C393A03_1;
|
|
|
--------------------------------------------------------------------- C393A03
|
--------------------------------------------------------------------- C393A03
|
|
|
with Report;
|
with Report;
|
with F393A00_0;
|
with F393A00_0;
|
with F393A00_1;
|
with F393A00_1;
|
with C393A03_0;
|
with C393A03_0;
|
with C393A03_1;
|
with C393A03_1;
|
procedure C393A03 is
|
procedure C393A03 is
|
|
|
A_Thing : C393A03_1.Modular_Object;
|
A_Thing : C393A03_1.Modular_Object;
|
Another_Thing : C393A03_1.Modular_Object;
|
Another_Thing : C393A03_1.Modular_Object;
|
|
|
procedure Initialize( It: in out C393A03_0.Counting_Object'Class ) is
|
procedure Initialize( It: in out C393A03_0.Counting_Object'Class ) is
|
begin
|
begin
|
C393A03_0.Initialize( It ); -- dispatch to inherited procedure
|
C393A03_0.Initialize( It ); -- dispatch to inherited procedure
|
end Initialize;
|
end Initialize;
|
|
|
procedure Bump( It: in out C393A03_0.Counting_Object'Class ) is
|
procedure Bump( It: in out C393A03_0.Counting_Object'Class ) is
|
begin
|
begin
|
C393A03_0.Bump( It ); -- dispatch to non-abstract procedure
|
C393A03_0.Bump( It ); -- dispatch to non-abstract procedure
|
end Bump;
|
end Bump;
|
|
|
procedure Set_Max( It : in out C393A03_1.Modular_Object'Class;
|
procedure Set_Max( It : in out C393A03_1.Modular_Object'Class;
|
Val : Natural) is
|
Val : Natural) is
|
begin
|
begin
|
C393A03_1.Set_Max( It, Val ); -- dispatch to non-abstract procedure
|
C393A03_1.Set_Max( It, Val ); -- dispatch to non-abstract procedure
|
end Set_Max;
|
end Set_Max;
|
|
|
procedure Swap( A, B : in out C393A03_0.Counting_Object'Class ) is
|
procedure Swap( A, B : in out C393A03_0.Counting_Object'Class ) is
|
begin
|
begin
|
C393A03_0.Swap( A, B ); -- dispatch to inherited abstract procedure
|
C393A03_0.Swap( A, B ); -- dispatch to inherited abstract procedure
|
end Swap;
|
end Swap;
|
|
|
procedure Zero( It: in out C393A03_0.Counting_Object'Class ) is
|
procedure Zero( It: in out C393A03_0.Counting_Object'Class ) is
|
begin
|
begin
|
C393A03_0.Zero( It ); -- dispatch to non-abstract procedure
|
C393A03_0.Zero( It ); -- dispatch to non-abstract procedure
|
end Zero;
|
end Zero;
|
|
|
begin -- Main test procedure.
|
begin -- Main test procedure.
|
|
|
Report.Test ("C393A03", "Check that a non-abstract primitive subprogram "
|
Report.Test ("C393A03", "Check that a non-abstract primitive subprogram "
|
& "of an abstract type can be called as a "
|
& "of an abstract type can be called as a "
|
& "dispatching operation and that the body of this "
|
& "dispatching operation and that the body of this "
|
& "subprogram can make a dispatching call to an "
|
& "subprogram can make a dispatching call to an "
|
& "abstract operation of the corresponding "
|
& "abstract operation of the corresponding "
|
& "abstract type" );
|
& "abstract type" );
|
|
|
A_Thing := C393A03_1.Create; -- Max_Value = Natural'Last
|
A_Thing := C393A03_1.Create; -- Max_Value = Natural'Last
|
F393A00_0.TC_Validate( "4", "Overridden primitive layer 2");
|
F393A00_0.TC_Validate( "4", "Overridden primitive layer 2");
|
|
|
Initialize( A_Thing );
|
Initialize( A_Thing );
|
Initialize( Another_Thing );
|
Initialize( Another_Thing );
|
F393A00_0.TC_Validate( "aa", "Non-abstract primitive layer 0");
|
F393A00_0.TC_Validate( "aa", "Non-abstract primitive layer 0");
|
|
|
Bump( A_Thing ); -- Tally = 1
|
Bump( A_Thing ); -- Tally = 1
|
F393A00_0.TC_Validate( "A", "Non-abstract primitive layer 1");
|
F393A00_0.TC_Validate( "A", "Non-abstract primitive layer 1");
|
|
|
Set_Max( A_Thing, 42 ); -- Max_Value = 42
|
Set_Max( A_Thing, 42 ); -- Max_Value = 42
|
F393A00_0.TC_Validate( "3", "Non-abstract normal layer 2");
|
F393A00_0.TC_Validate( "3", "Non-abstract normal layer 2");
|
|
|
if not F393A00_1.Initialized( A_Thing ) then
|
if not F393A00_1.Initialized( A_Thing ) then
|
Report.Failed("Initialize didn't");
|
Report.Failed("Initialize didn't");
|
end if;
|
end if;
|
F393A00_0.TC_Validate( "b", "Class-wide layer 0");
|
F393A00_0.TC_Validate( "b", "Class-wide layer 0");
|
|
|
Swap( A_Thing, Another_Thing );
|
Swap( A_Thing, Another_Thing );
|
F393A00_0.TC_Validate( "1", "Overridden abstract layer 2");
|
F393A00_0.TC_Validate( "1", "Overridden abstract layer 2");
|
|
|
Zero( A_Thing );
|
Zero( A_Thing );
|
F393A00_0.TC_Validate( "B2", "Non-abstract layer 0, calls dispatch");
|
F393A00_0.TC_Validate( "B2", "Non-abstract layer 0, calls dispatch");
|
|
|
if C393A03_0.Value( A_Thing ) /= 0 then
|
if C393A03_0.Value( A_Thing ) /= 0 then
|
Report.Failed("Zero didn't");
|
Report.Failed("Zero didn't");
|
end if;
|
end if;
|
F393A00_0.TC_Validate( "C", "Class-wide normal layer 2");
|
F393A00_0.TC_Validate( "C", "Class-wide normal layer 2");
|
|
|
Report.Result;
|
Report.Result;
|
|
|
end C393A03;
|
end C393A03;
|
|
|
