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 a type that inherits abstract operations but
28 -- overrides each of these operations is not required to be
29 -- abstract, and that objects of the type and its class-wide type
30 -- may be declared and passed in calls to the overriding
34 -- This test derives a type from the root abstract type available
35 -- in foundation F393A00. It declares subprograms as required by
36 -- the language to override the abstract subprograms, allowing the
37 -- derived type itself to be not abstract. It also declares
38 -- operations on the new type, as well as on the associated class-
39 -- wide type. The main program then uses two objects of the type
40 -- and two objects of the class-wide type as parameters for each of
41 -- the subprograms. Correct execution is determined by path
42 -- analysis and value checking.
45 -- The following files comprise this test:
47 -- F393A00.A (foundation code)
52 -- 06 Dec 94 SAIC ACVC 2.0
53 -- 19 Dec 94 SAIC Removed RM references from objective text.
59 type Organism
is new F393A00_1
.Object
with private;
60 type Kingdoms
is ( Animal
, Vegetable
, Unspecified
);
62 procedure Swap
( A
,B
: in out Organism
);
63 function Create
return Organism
;
65 procedure Initialize
( The_Entity
: in out Organism
;
66 In_The_Kingdom
: Kingdoms
);
67 function Kingdom
( Of_The_Entity
: Organism
) return Kingdoms
;
69 procedure TC_Check
( An_Entity
: Organism
'Class;
70 In_Kingdom
: Kingdoms
;
71 Initialized
: Boolean );
73 Incompatible
: exception;
76 type Organism
is new F393A00_1
.Object
with
78 In_Kingdom
: Kingdoms
;
83 package body C393A06_0
is
85 procedure Swap
( A
,B
: in out Organism
) is
87 F393A00_0
.TC_Touch
( 'A' ); ------------------------------------------- A
88 if A
.In_Kingdom
/= B
.In_Kingdom
then
89 F393A00_0
.TC_Touch
( 'X' );
93 T
: constant Organism
:= A
;
101 function Create
return Organism
is
104 F393A00_0
.TC_Touch
( 'B' ); ------------------------------------------- B
105 Initialize
( Widget
);
106 Widget
.In_Kingdom
:= Unspecified
;
110 procedure Initialize
( The_Entity
: in out Organism
;
111 In_The_Kingdom
: Kingdoms
) is
113 F393A00_0
.TC_Touch
( 'C' ); ------------------------------------------- C
114 F393A00_1
.Initialize
( F393A00_1
.Object
( The_Entity
) );
115 The_Entity
.In_Kingdom
:= In_The_Kingdom
;
118 function Kingdom
( Of_The_Entity
: Organism
) return Kingdoms
is
120 F393A00_0
.TC_Touch
( 'D' ); ------------------------------------------- D
121 return Of_The_Entity
.In_Kingdom
;
124 procedure TC_Check
( An_Entity
: Organism
'Class;
125 In_Kingdom
: Kingdoms
;
126 Initialized
: Boolean ) is
128 if F393A00_1
.Initialized
( An_Entity
) /= Initialized
then
129 F393A00_0
.TC_Touch
( '-' ); ------------------------------------------- -
130 elsif An_Entity
.In_Kingdom
/= In_Kingdom
then
131 F393A00_0
.TC_Touch
( '!' ); ------------------------------------------- !
133 F393A00_0
.TC_Touch
( '+' ); ------------------------------------------- +
146 package Darwin
renames C393A06_0
;
147 package Tagger
renames F393A00_0
;
148 package Objects
renames F393A00_1
;
150 Lion
: Darwin
.Organism
;
151 Tigerlily
: Darwin
.Organism
;
152 Bear
: Darwin
.Organism
'Class := Darwin
.Create
;
153 Sunflower
: Darwin
.Organism
'Class := Darwin
.Create
;
155 use type Darwin
.Kingdoms
;
157 begin -- Main test procedure.
159 Report
.Test
("C393A06", "Check that a type that inherits abstract "
160 & "operations but overrides each of these "
161 & "operations is not required to be abstract. "
162 & "Check that objects of the type and its "
163 & "class-wide type may be declared and passed "
164 & "in calls to the overriding subprograms" );
166 Tagger
.TC_Validate
( "BaBa", "Declaration Initializations" );
168 Darwin
.Initialize
( Lion
, Darwin
.Animal
);
169 Darwin
.Initialize
( Tigerlily
, Darwin
.Vegetable
);
170 Darwin
.Initialize
( Bear
, Darwin
.Animal
);
171 Darwin
.Initialize
( Sunflower
, Darwin
.Vegetable
);
173 Tagger
.TC_Validate
( "CaCaCaCa", "Initialization sequence" );
176 Darwin
.Swap
( Lion
, Darwin
.Organism
( Bear
) );
177 Darwin
.Swap
( Lion
, Tigerlily
);
178 Report
.Failed
("Exception not raised");
180 when Darwin
.Incompatible
=> null;
183 Tagger
.TC_Validate
( "AAX", "Swap sequence" );
185 if Darwin
.Kingdom
( Darwin
.Create
) = Darwin
.Unspecified
then
186 Darwin
.Swap
( Sunflower
, Darwin
.Organism
'Class( Tigerlily
) );
189 Tagger
.TC_Validate
( "BaDA", "Vegetable swap sequence" );
191 Darwin
.TC_Check
( Lion
, Darwin
.Animal
, True );
192 Darwin
.TC_Check
( Tigerlily
, Darwin
.Vegetable
, True );
193 Darwin
.TC_Check
( Bear
, Darwin
.Animal
, True );
194 Darwin
.TC_Check
( Sunflower
, Darwin
.Vegetable
, True );
196 Tagger
.TC_Validate
( "b+b+b+b+", "Final sequence" );