3 -- Grant of Unlimited Rights
5 -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
6 -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
7 -- unlimited rights in the software and documentation contained herein.
8 -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
9 -- this public release, the Government intends to confer upon all
10 -- recipients unlimited rights equal to those held by the Government.
11 -- These rights include rights to use, duplicate, release or disclose the
12 -- released technical data and computer software in whole or in part, in
13 -- any manner and for any purpose whatsoever, and to have or permit others
18 -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19 -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
20 -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
21 -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
22 -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
23 -- PARTICULAR PURPOSE OF SAID MATERIAL.
27 -- Check that primitive operations declared in a child package
28 -- override operations declared in ancestor packages, and that
29 -- operations on class-wide types defined in the ancestor packages
30 -- dispatch as appropriate to these overriding implementations.
34 -- This test builds on the foundation code file (FA11C00) that contains
35 -- a parent package, child package, and grandchild package. The parent
36 -- package declares a tagged type and primitive operation. The child
37 -- package extends the type, and overrides the primitive operation. The
38 -- grandchild package does the same.
40 -- The test procedure "withs" the grandchild package, and receives
41 -- visibility to all of its ancestor packages, types and operations.
42 -- A procedure with a formal class-wide parameter is defined that will
43 -- allow for dispatching calls to the overridden primitive operations,
44 -- based on the specific type of the actual parameter. The primitive
45 -- operations provide a string value to update a global string array
46 -- variable. Calls to the local procedure are made, with objects of each
47 -- of the tagged types as parameters, and the global variable is finally
48 -- examined to ensure that the correct version of primitive operation was
49 -- dispatched correctly.
52 -- This test depends on the following foundation code:
58 -- 06 Dec 94 SAIC ACVC 2.0
62 with FA11C00_0
.FA11C00_1
.FA11C00_2
; -- Package Animal.Mammal.Primate
67 package Animal_Package
renames FA11C00_0
;
68 package Mammal_Package
renames FA11C00_0
.FA11C00_1
;
69 package Primate_Package
renames FA11C00_0
.FA11C00_1
.FA11C00_2
;
71 Max_Animals
: constant := 3;
73 type Data_Base_Type
is array (1 .. Max_Animals
) of String (1 .. 37);
75 Zoo_Data_Base
: Data_Base_Type
:= (others => (others => ' '));
78 Macaw
: Animal_Package
.Animal
:= (Common_Name
=> "Scarlet Macaw ",
81 Manatee
: Mammal_Package
.Mammal
:= (Common_Name
=> "Southern Manatee ",
83 Hair_Color
=> Mammal_Package
.Brown
);
85 Lemur
: Primate_Package
.Primate
:=
86 (Common_Name
=> "Ring-Tailed Lemur ",
88 Hair_Color
=> Mammal_Package
.Black
,
89 Habitat
=> Primate_Package
.Arboreal
);
92 Report
.Test
("CA11C02", "Check that primitive operations declared " &
93 "in a child package override operations declared " &
94 "in ancestor packages, and that operations " &
95 "on class-wide types defined in the ancestor " &
96 "packages dispatch as appropriate to these " &
97 "overriding implementations");
101 use Animal_Package
, Mammal_Package
, Primate_Package
;
103 -- The following procedure updates the global variable Zoo_Data_Base.
105 procedure Enter_Data
(A
: Animal
'Class; I
: Integer) is
107 Zoo_Data_Base
(I
) := Image
(A
);
112 -- Verify initial test conditions.
114 if not (Zoo_Data_Base
(1)(1..6) = " ")
116 (Zoo_Data_Base
(2)(1..6) = " ")
118 (Zoo_Data_Base
(3)(1..6) = " ")
120 Report
.Failed
("Initial condition failure");
124 -- Enter data from all three animals into the zoo database.
126 Enter_Data
(Macaw
, 1); -- First entry in database.
127 Enter_Data
(A
=> Manatee
, I
=> 2); -- Second entry.
128 Enter_Data
(Lemur
, I
=> 3); -- Third entry.
130 -- Verify the correct version of the overridden function Image was used
131 -- for entering the specific data.
133 if not (Zoo_Data_Base
(1)(1 .. 6) = "Animal")
135 (Zoo_Data_Base
(1)(26 .. 30) = "Macaw")
137 Report
.Failed
("Incorrect version of Image for parent type");
140 if not (Zoo_Data_Base
(2)(1 .. 6) = "Mammal"
142 Zoo_Data_Base
(2)(27 .. 33) = "Manatee")
144 Report
.Failed
("Incorrect version of Image for child type");
147 if not ((Zoo_Data_Base
(3)(1 .. 7) = "Primate")
149 (Zoo_Data_Base
(3)(30 .. 34) = "Lemur"))
151 Report
.Failed
("Incorrect version of Image for grandchild type");