-- C392D03.A
|
-- C392D03.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, for an inherited dispatching operation that is overridden,
|
-- Check that, for an inherited dispatching operation that is overridden,
|
-- the body executed is the body of the overriding subprogram, even if
|
-- the body executed is the body of the overriding subprogram, even if
|
-- the overriding occurs in a private part.
|
-- the overriding occurs in a private part.
|
--
|
--
|
-- Check for the case where the overriding operation is declared in a
|
-- Check for the case where the overriding operation is declared in a
|
-- separate (non-child) package from that declaring the parent type, and
|
-- separate (non-child) package from that declaring the parent type, and
|
-- the descendant type is a record extension.
|
-- the descendant type is a record extension.
|
--
|
--
|
-- Check for both dispatching and nondispatching calls.
|
-- Check for both dispatching and nondispatching calls.
|
--
|
--
|
-- TEST DESCRIPTION:
|
-- TEST DESCRIPTION:
|
-- Consider:
|
-- Consider:
|
--
|
--
|
-- package P is
|
-- package P is
|
-- type Root is tagged ...
|
-- type Root is tagged ...
|
-- procedure Op (A: Root);
|
-- procedure Op (A: Root);
|
-- end P;
|
-- end P;
|
--
|
--
|
-- with P;
|
-- with P;
|
-- package Q is
|
-- package Q is
|
-- type Derived1 is new P.Root with record...
|
-- type Derived1 is new P.Root with record...
|
-- -- Implicit procedure Op (A: Derived1) declared here.
|
-- -- Implicit procedure Op (A: Derived1) declared here.
|
-- type Derived2 is new P.Root with private...
|
-- type Derived2 is new P.Root with private...
|
-- -- Implicit procedure Op (A: Derived2) declared here.
|
-- -- Implicit procedure Op (A: Derived2) declared here.
|
-- type New_Derived is new Derived1 with private...
|
-- type New_Derived is new Derived1 with private...
|
-- -- Implicit procedure Op (A: New_Derived) declared here.
|
-- -- Implicit procedure Op (A: New_Derived) declared here.
|
-- private
|
-- private
|
-- procedure Op (A: Derived1); -- Overrides parent's Op.
|
-- procedure Op (A: Derived1); -- Overrides parent's Op.
|
-- type Derived2 is new P.Root with record...
|
-- type Derived2 is new P.Root with record...
|
-- procedure Op (A: Derived2); -- Overrides parent's Op.
|
-- procedure Op (A: Derived2); -- Overrides parent's Op.
|
-- type New_Derived is new Derived1 with record...
|
-- type New_Derived is new Derived1 with record...
|
-- ...
|
-- ...
|
-- end Q;
|
-- end Q;
|
--
|
--
|
-- Both type Derived1 and Derived2 inherit Op from the parent type Root.
|
-- Both type Derived1 and Derived2 inherit Op from the parent type Root.
|
-- Type New_Derived inherits (inherited) Op from Derived1. The inherited
|
-- Type New_Derived inherits (inherited) Op from Derived1. The inherited
|
-- operation is implicitly declared immediately after the type extension.
|
-- operation is implicitly declared immediately after the type extension.
|
-- The inherited operation is overridden by an explicit declaration in
|
-- The inherited operation is overridden by an explicit declaration in
|
-- the private part. Even though the overriding operation is private,
|
-- the private part. Even though the overriding operation is private,
|
-- calls to Op with an operand of tag Derived1, Derived2, or New_Derived
|
-- calls to Op with an operand of tag Derived1, Derived2, or New_Derived
|
-- will execute the body of the overriding operation.
|
-- will execute the body of the overriding operation.
|
--
|
--
|
-- TEST FILES:
|
-- TEST FILES:
|
-- The following files comprise this test:
|
-- The following files comprise this test:
|
--
|
--
|
-- F392D00.A
|
-- F392D00.A
|
-- C392D03.A
|
-- C392D03.A
|
--
|
--
|
--
|
--
|
-- CHANGE HISTORY:
|
-- CHANGE HISTORY:
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 06 Dec 94 SAIC ACVC 2.0
|
--
|
--
|
--!
|
--!
|
|
|
with F392D00;
|
with F392D00;
|
package C392D03_0 is
|
package C392D03_0 is
|
|
|
type Aperture is (Eight, Sixteen);
|
type Aperture is (Eight, Sixteen);
|
|
|
type Auto_Focus is new F392D00.Remote_Camera with record
|
type Auto_Focus is new F392D00.Remote_Camera with record
|
-- ...
|
-- ...
|
FStop : Aperture;
|
FStop : Aperture;
|
end record;
|
end record;
|
|
|
-- Implicit procedure Focus (C : in out Auto_Focus;
|
-- Implicit procedure Focus (C : in out Auto_Focus;
|
-- Depth : in Depth_Of_Field) declared here.
|
-- Depth : in Depth_Of_Field) declared here.
|
|
|
type Auto_Flashing is new F392D00.Remote_Camera with private;
|
type Auto_Flashing is new F392D00.Remote_Camera with private;
|
|
|
-- Implicit procedure Focus (C : in out Auto_Flashing;
|
-- Implicit procedure Focus (C : in out Auto_Flashing;
|
-- Depth : in Depth_Of_Field) declared here.
|
-- Depth : in Depth_Of_Field) declared here.
|
|
|
type Special_Focus is new Auto_Focus with private;
|
type Special_Focus is new Auto_Focus with private;
|
|
|
-- Implicit procedure Focus (C : in out Special_Focus;
|
-- Implicit procedure Focus (C : in out Special_Focus;
|
-- Depth : in Depth_Of_Field) declared here.
|
-- Depth : in Depth_Of_Field) declared here.
|
|
|
-- ...Other operations.
|
-- ...Other operations.
|
|
|
private
|
private
|
|
|
procedure Focus (C : in out Auto_Focus; -- Overrides
|
procedure Focus (C : in out Auto_Focus; -- Overrides
|
Depth : in F392D00.Depth_Of_Field); -- parent's op.
|
Depth : in F392D00.Depth_Of_Field); -- parent's op.
|
|
|
-- For the improved remote camera, focus is set automatically, so it is
|
-- For the improved remote camera, focus is set automatically, so it is
|
-- declared as a private operation.
|
-- declared as a private operation.
|
|
|
type Auto_Flashing is new F392D00.Remote_Camera with null record;
|
type Auto_Flashing is new F392D00.Remote_Camera with null record;
|
|
|
procedure Focus (C : in out Auto_Flashing; -- Overrides
|
procedure Focus (C : in out Auto_Flashing; -- Overrides
|
Depth : in F392D00.Depth_Of_Field); -- parent's op.
|
Depth : in F392D00.Depth_Of_Field); -- parent's op.
|
|
|
type Special_Focus is new Auto_Focus with null record;
|
type Special_Focus is new Auto_Focus with null record;
|
|
|
end C392D03_0;
|
end C392D03_0;
|
|
|
|
|
--==================================================================--
|
--==================================================================--
|
|
|
|
|
package body C392D03_0 is
|
package body C392D03_0 is
|
|
|
procedure Focus (C : in out Auto_Focus;
|
procedure Focus (C : in out Auto_Focus;
|
Depth : in F392D00.Depth_Of_Field) is
|
Depth : in F392D00.Depth_Of_Field) is
|
begin
|
begin
|
-- Artificial for testing purposes.
|
-- Artificial for testing purposes.
|
C.DOF := 52;
|
C.DOF := 52;
|
end Focus;
|
end Focus;
|
|
|
-----------------------------------------------------------
|
-----------------------------------------------------------
|
procedure Focus (C : in out Auto_Flashing;
|
procedure Focus (C : in out Auto_Flashing;
|
Depth : in F392D00.Depth_Of_Field) is
|
Depth : in F392D00.Depth_Of_Field) is
|
begin
|
begin
|
-- Artificial for testing purposes.
|
-- Artificial for testing purposes.
|
C.DOF := 91;
|
C.DOF := 91;
|
end Focus;
|
end Focus;
|
|
|
end C392D03_0;
|
end C392D03_0;
|
|
|
|
|
--==================================================================--
|
--==================================================================--
|
|
|
|
|
with F392D00;
|
with F392D00;
|
with C392D03_0;
|
with C392D03_0;
|
|
|
with Report;
|
with Report;
|
|
|
procedure C392D03 is
|
procedure C392D03 is
|
|
|
type Focus_Ptr is access procedure
|
type Focus_Ptr is access procedure
|
(P1 : in out C392D03_0.Auto_Focus;
|
(P1 : in out C392D03_0.Auto_Focus;
|
P2 : in F392D00.Depth_Of_Field);
|
P2 : in F392D00.Depth_Of_Field);
|
|
|
Basic_Camera : F392D00.Remote_Camera;
|
Basic_Camera : F392D00.Remote_Camera;
|
Auto_Camera1 : C392D03_0.Auto_Focus;
|
Auto_Camera1 : C392D03_0.Auto_Focus;
|
Auto_Camera2 : C392D03_0.Auto_Focus;
|
Auto_Camera2 : C392D03_0.Auto_Focus;
|
Flash_Camera1 : C392D03_0.Auto_Flashing;
|
Flash_Camera1 : C392D03_0.Auto_Flashing;
|
Flash_Camera2 : C392D03_0.Auto_Flashing;
|
Flash_Camera2 : C392D03_0.Auto_Flashing;
|
Special_Camera : C392D03_0.Special_Focus;
|
Special_Camera : C392D03_0.Special_Focus;
|
Auto_Depth : F392D00.Depth_Of_Field := 78;
|
Auto_Depth : F392D00.Depth_Of_Field := 78;
|
|
|
TC_Expected_Basic_Depth : constant F392D00.Depth_Of_Field := 46;
|
TC_Expected_Basic_Depth : constant F392D00.Depth_Of_Field := 46;
|
TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 52;
|
TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 52;
|
TC_Expected_Depth : constant F392D00.Depth_Of_Field := 91;
|
TC_Expected_Depth : constant F392D00.Depth_Of_Field := 91;
|
|
|
FP : Focus_Ptr := C392D03_0.Focus'Access;
|
FP : Focus_Ptr := C392D03_0.Focus'Access;
|
|
|
use type F392D00.Depth_Of_Field;
|
use type F392D00.Depth_Of_Field;
|
|
|
begin
|
begin
|
Report.Test ("C392D03", "Dispatching for overridden primitive " &
|
Report.Test ("C392D03", "Dispatching for overridden primitive " &
|
"subprograms: record extension declared in non-child " &
|
"subprograms: record extension declared in non-child " &
|
"package, parent is tagged record");
|
"package, parent is tagged record");
|
|
|
|
|
-- Call the class-wide operation for Remote_Camera'Class, which itself makes
|
-- Call the class-wide operation for Remote_Camera'Class, which itself makes
|
-- a dispatching call to Focus:
|
-- a dispatching call to Focus:
|
|
|
-- For an object of type Remote_Camera, the dispatching call should
|
-- For an object of type Remote_Camera, the dispatching call should
|
-- dispatch to the body declared for the root type:
|
-- dispatch to the body declared for the root type:
|
|
|
F392D00.Self_Test(Basic_Camera);
|
F392D00.Self_Test(Basic_Camera);
|
|
|
if Basic_Camera.DOF /= TC_Expected_Basic_Depth then
|
if Basic_Camera.DOF /= TC_Expected_Basic_Depth then
|
Report.Failed ("Call dispatched incorrectly for root type");
|
Report.Failed ("Call dispatched incorrectly for root type");
|
end if;
|
end if;
|
|
|
|
|
-- For an object of type Auto_Focus, the dispatching call should
|
-- For an object of type Auto_Focus, the dispatching call should
|
-- dispatch to the body declared for the derived type:
|
-- dispatch to the body declared for the derived type:
|
|
|
F392D00.Self_Test(Auto_Camera1);
|
F392D00.Self_Test(Auto_Camera1);
|
|
|
if Auto_Camera1.DOF /= TC_Expected_Auto_Depth then
|
if Auto_Camera1.DOF /= TC_Expected_Auto_Depth then
|
Report.Failed ("Call dispatched incorrectly for Auto_Focus type");
|
Report.Failed ("Call dispatched incorrectly for Auto_Focus type");
|
end if;
|
end if;
|
|
|
|
|
-- For an object of type Auto_Flash, the dispatching call should
|
-- For an object of type Auto_Flash, the dispatching call should
|
-- also dispatch to the body declared for the derived type:
|
-- also dispatch to the body declared for the derived type:
|
|
|
F392D00.Self_Test(Flash_Camera1);
|
F392D00.Self_Test(Flash_Camera1);
|
|
|
if Flash_Camera1.DOF /= TC_Expected_Depth then
|
if Flash_Camera1.DOF /= TC_Expected_Depth then
|
Report.Failed ("Call dispatched incorrectly for Auto_Flash type");
|
Report.Failed ("Call dispatched incorrectly for Auto_Flash type");
|
end if;
|
end if;
|
|
|
-- For an object of Auto_Flash type, a non-dispatching call to Focus should
|
-- For an object of Auto_Flash type, a non-dispatching call to Focus should
|
-- execute the body declared for the derived type (even through it is
|
-- execute the body declared for the derived type (even through it is
|
-- declared in the private part).
|
-- declared in the private part).
|
|
|
C392D03_0.Focus (Flash_Camera2, Auto_Depth);
|
C392D03_0.Focus (Flash_Camera2, Auto_Depth);
|
|
|
if Flash_Camera2.DOF /= TC_Expected_Depth then
|
if Flash_Camera2.DOF /= TC_Expected_Depth then
|
Report.Failed ("Non-dispatching call to privately overriding " &
|
Report.Failed ("Non-dispatching call to privately overriding " &
|
"subprogram executed the wrong body");
|
"subprogram executed the wrong body");
|
end if;
|
end if;
|
|
|
-- For an object of Auto_Focus type, a non-dispatching call to Focus should
|
-- For an object of Auto_Focus type, a non-dispatching call to Focus should
|
-- execute the body declared for the derived type (even through it is
|
-- execute the body declared for the derived type (even through it is
|
-- declared in the private part).
|
-- declared in the private part).
|
|
|
FP.all (Auto_Camera2, Auto_Depth);
|
FP.all (Auto_Camera2, Auto_Depth);
|
|
|
if Auto_Camera2.DOF /= TC_Expected_Auto_Depth then
|
if Auto_Camera2.DOF /= TC_Expected_Auto_Depth then
|
Report.Failed ("Non-dispatching call by using access to overriding " &
|
Report.Failed ("Non-dispatching call by using access to overriding " &
|
"subprogram executed the wrong body");
|
"subprogram executed the wrong body");
|
end if;
|
end if;
|
|
|
-- For an object of type Special_Camera, the dispatching call should
|
-- For an object of type Special_Camera, the dispatching call should
|
-- also dispatch to the body declared for the derived type:
|
-- also dispatch to the body declared for the derived type:
|
|
|
F392D00.Self_Test(Special_Camera);
|
F392D00.Self_Test(Special_Camera);
|
|
|
if Special_Camera.DOF /= TC_Expected_Auto_Depth then
|
if Special_Camera.DOF /= TC_Expected_Auto_Depth then
|
Report.Failed ("Call dispatched incorrectly for Special_Camera type");
|
Report.Failed ("Call dispatched incorrectly for Special_Camera type");
|
end if;
|
end if;
|
|
|
Report.Result;
|
Report.Result;
|
|
|
end C392D03;
|
end C392D03;
|
|
|
