1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
|
-- CC51006.A
--
-- Grant of Unlimited Rights
--
-- 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
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- 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
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that, in an instance, each implicit declaration of a primitive
-- subprogram of a formal (nontagged) derived type declares a view of
-- the corresponding primitive subprogram of the ancestor type, even if
-- the subprogram has been overridden for the actual type. Check that for
-- a formal derived type with no discriminant part, if the ancestor
-- subtype is an unconstrained scalar subtype then the actual may be
-- either constrained or unconstrained.
--
-- TEST DESCRIPTION:
-- The formal derived type has no discriminant part, but the ancestor
-- subtype is unconstrained, making the formal type unconstrained. Since
-- the ancestor subtype is a scalar subtype (not an access or composite
-- subtype), the actual may be either constrained or unconstrained.
--
-- Declare a root type of a class as an unconstrained scalar (use floating
-- point). Declare a primitive subprogram of the root type. Declare a
-- generic package which has a formal derived type with the scalar root
-- type as ancestor. Inside the generic, declare an operation which calls
-- the ancestor type's primitive subprogram. Derive both constrained and
-- unconstrained types from the root type and override the primitive
-- subprogram for each. Declare a constrained subtype of the unconstrained
-- derivative. Instantiate the generic package for the derived types and
-- the subtype and call the "generic" operation for each one. Confirm that
-- in all cases the root type's implementation of the primitive
-- subprogram is called.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
package CC51006_0 is -- Weight class.
type Weight_Type is digits 3; -- Root type of class (unconstrained).
function Weight_To_String (Wt : Weight_Type) return String;
-- ... Other operations.
end CC51006_0;
--==================================================================--
package body CC51006_0 is
-- The implementations of the operations below are purely artificial; the
-- validity of their implementations in the context of the abstraction is
-- irrelevant to the feature being tested.
function Weight_To_String (Wt : Weight_Type) return String is
begin
if Wt > 0.0 then -- Always true for this test.
return ("Root type's implementation called");
else
return ("Unexpected result ");
end if;
end Weight_To_String;
end CC51006_0;
--==================================================================--
with CC51006_0; -- Weight class.
generic -- Generic weight operations.
type Weight is new CC51006_0.Weight_Type;
package CC51006_1 is
procedure Output_Weight (Wt : in Weight; TC_Return : out String);
-- ... Other operations.
end CC51006_1;
--==================================================================--
package body CC51006_1 is
-- The implementation of this procedure is purely artificial, and contains
-- an artificial parameter for testing purposes: the procedure returns the
-- weight string to the caller.
procedure Output_Weight (Wt : in Weight; TC_Return : out String) is
begin
TC_Return := Weight_To_String (Wt); -- Should always call root type's
end Output_Weight; -- implementation.
end CC51006_1;
--==================================================================--
with CC51006_0; -- Weight class.
use CC51006_0;
package CC51006_2 is -- Extensions to weight class.
type Grams is new Weight_Type; -- Unconstrained
-- derivative.
function Weight_To_String (Wt : Grams) return String; -- Overrides root
-- type's operation.
subtype Milligrams is Grams -- Constrained
range 0.0 .. 0.999; -- subtype (of der.).
type Pounds is new Weight_Type -- Constrained
range 0.0 .. 500.0; -- derivative.
function Weight_To_String (Wt : Pounds) return String; -- Overrides root
-- type's operation.
end CC51006_2;
--==================================================================--
package body CC51006_2 is
-- The implementations of the operations below are purely artificial; the
-- validity of their implementations in the context of the abstraction is
-- irrelevant to the feature being tested.
function Weight_To_String (Wt : Grams) return String is
begin
return ("GRAMS: Should never be called ");
end Weight_To_String;
function Weight_To_String (Wt : Pounds) return String is
begin
return ("POUNDS: Should never be called ");
end Weight_To_String;
end CC51006_2;
--==================================================================--
with CC51006_1; -- Generic weight operations.
with CC51006_2; -- Extensions to weight class.
with Report;
procedure CC51006 is
package Metric_Wts_G is new CC51006_1 (CC51006_2.Grams); -- Unconstr.
package Metric_Wts_MG is new CC51006_1 (CC51006_2.Milligrams); -- Constr.
package US_Wts is new CC51006_1 (CC51006_2.Pounds); -- Constr.
Gms : CC51006_2.Grams := 113.451;
Mgm : CC51006_2.Milligrams := 0.549;
Lbs : CC51006_2.Pounds := 24.52;
subtype TC_Buffers is String (1 .. 33);
TC_Expected : constant TC_Buffers := "Root type's implementation called";
TC_Buffer : TC_Buffers;
begin
Report.Test ("CC51006", "Check that, in an instance, each implicit " &
"declaration of a primitive subprogram of a formal " &
"(nontagged) type declares a view of the corresponding " &
"primitive subprogram of the ancestor type");
Metric_Wts_G.Output_Weight (Gms, TC_Buffer);
if TC_Buffer /= TC_Expected then
Report.Failed ("Root operation not called for unconstrained derivative");
end if;
Metric_Wts_MG.Output_Weight (Mgm, TC_Buffer);
if TC_Buffer /= TC_Expected then
Report.Failed ("Root operation not called for constrained subtype");
end if;
US_Wts.Output_Weight (Lbs, TC_Buffer);
if TC_Buffer /= TC_Expected then
Report.Failed ("Root operation not called for constrained derivative");
end if;
Report.Result;
end CC51006;
|
