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
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
|
-- C730003.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
-- F08630-91-C-0015, 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 WHATSOVER, 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 the characteristics of a type derived from a private
-- extension (outside the scope of the full view) are those defined by
-- the partial view of the private extension.
-- In particular, check that a component of the derived type may be
-- explicitly declared with the same name as a component declared for
-- the full view of the private extension.
-- Check that a component defined in the private extension of a type
-- may be updated through a view conversion of a type derived from
-- the type.
--
-- TEST DESCRIPTION:
-- Consider:
--
-- package Parent is
-- type T is tagged record
-- ...
-- end record;
--
-- type DT is new T with private;
-- procedure Op1 (P: in out DT);
--
-- private
-- type DT is new T with record
-- Y: ...; -- (A)
-- end record;
-- end Parent;
--
-- package body Parent is
-- function Op1 (P: in DT) return ... is
-- begin
-- return P.Y;
-- end Op1;
-- end Parent;
--
-- package Unrelated is
-- type Intermediate is new DT with record
-- Y: ...; -- Note: same name as component of -- (B)
-- -- parent's full view.
-- end record;
-- end Unrelated;
--
-- package Parent.Child is
-- type DDT is new Intermediate with null record;
-- -- Implicit declared Op1 (P.DDT); -- (C)
--
-- procedure Op2 (P: in out DDT);
-- end Parent.Child;
--
-- package body Parent.Child is
-- procedure Op2 (P: in out DDT) is
-- Obj : DT renames DT(P);
-- begin
-- ...
-- P.Y := ...; -- Updates DDT's Y. -- (D)
-- DT(P).Y := ...; -- Updates DT's Y. -- (E)
-- Obj.Y := ...; -- Updates DT's Y. -- (F)
-- end Op2;
-- end Parent.Child;
--
-- Types DT and DDT both declare a component Y at (A) and (B),
-- respectively. The component Y of the full view of DT is not visible
-- at the place where DDT is declared. Therefore, it is invisible for
-- all views of DDT (although it still exists for objects of DDT), and
-- it is legal to declare another component for DDT with the same name.
--
-- DDT inherits the primitive subprogram Op1 from DT at (C). Op1 returns
-- the component Y; for calls with an operand of type DDT, Op1 returns
-- the Y inherited from DT, not the new Y explicitly declared for DDT,
-- even though the inherited Y is not visible for any view of DDT.
--
-- Within the body of Op2, the assignment statement at (D) updates the
-- Y explicitly declared for DDT. At (E) and (F), however, a view
-- conversion denotes a new view of P as an object of type DT, which
-- enables access to the Y from the full view of DT. Thus, the
-- assignment statements at (E) and (F) update the (invisible) Y from DT.
--
-- Note that the above analysis would be wrong if the new component Y
-- were declared directly in Child. In that case, the two same-named
-- components would be illegal -- see AI-150.
--
--
-- CHANGE HISTORY:
-- 06 Dec 1994 SAIC ACVC 2.0
-- 29 JUN 1999 RAD Declare same-named component in an
-- unrelated package -- see AI-150.
--
--!
package C730003_0 is
type Suit_Kind is (Clubs, Diamonds, Hearts, Spades);
type Face_Kind is (Up, Down);
type Playing_Card is tagged record
Face: Face_Kind;
Suit: Suit_Kind;
end record;
procedure Turn_Over_Card (Card : in out Playing_Card);
type Disp_Card is new Playing_Card with private;
subtype ASCII_Representation is Natural range 1..14;
function Get_Private_View (A_Card : Disp_Card) return ASCII_Representation;
private
type Disp_Card is new Playing_Card with record
View: ASCII_Representation; -- (A)
end record;
end C730003_0;
--==================================================================--
package body C730003_0 is
procedure Turn_Over_Card (Card: in out Playing_Card) is
begin
Card.Face := Up;
end Turn_Over_Card;
function Get_Private_View (A_Card : Disp_Card)
return ASCII_Representation is
begin
return A_Card.View;
end Get_Private_View;
end C730003_0;
--==================================================================--
with C730003_0; use C730003_0;
package C730003_1 is
subtype Graphic_Representation is String (1 .. 2);
type Graphic_Card is new Disp_Card with record
View : Graphic_Representation; -- (B)
-- "Duplicate" component field name.
end record;
end C730003_1;
--==================================================================--
with C730003_1; use C730003_1;
package C730003_0.C730003_2 is
Queen_Of_Spades : constant C730003_0.ASCII_Representation := 12;
Ace_Of_Hearts : constant String := "AH";
Close_To_The_Vest : constant C730003_0.ASCII_Representation := 14;
Read_Em_And_Weep : constant String := "AA";
type Graphic_Card is new C730003_1.Graphic_Card with null record;
-- Implicit function Get_Private_View -- (C)
-- (A_Card : Graphic_Card) return C730003_0.ASCII_Representation;
function Get_View (Card : Graphic_Card) return String;
procedure Update_View (Card : in out Graphic_Card);
procedure Hide_From_View (Card : in out Graphic_Card);
end C730003_0.C730003_2;
--==================================================================--
package body C730003_0.C730003_2 is
function Get_View (Card : Graphic_Card) return String is
begin
return Card.View;
end Get_View;
procedure Update_View (Card : in out Graphic_Card) is
ASCII_View : Disp_Card renames Disp_Card(Card); -- View conversion.
begin
ASCII_View.View := Queen_Of_Spades; -- (F)
-- Assignment to "hidden" field.
Card.View := Ace_Of_Hearts; -- (D)
-- Assignment to Graphic_Card declared field.
end Update_View;
procedure Hide_From_View (Card : in out Graphic_Card) is
begin
-- Update both of Card's View components.
Disp_Card(Card).View := Close_To_The_Vest; -- (E)
-- Assignment to "hidden" field.
Card.View := Read_Em_And_Weep; -- (D)
-- Assignment to Graphic_Card declared field.
end Hide_From_View;
end C730003_0.C730003_2;
--==================================================================--
with C730003_0;
with C730003_0.C730003_2;
with Report;
procedure C730003 is
begin
Report.Test ("C730003", "Check that the characteristics of a type " &
"derived from a private extension (outside " &
"the scope of the full view) are those " &
"defined by the partial view of the private " &
"extension");
Check_Your_Cards:
declare
use C730003_0;
use C730003_0.C730003_2;
Top_Card_On_The_Deck : Graphic_Card;
begin
-- Update value in the components of the card. There are two
-- component fields named View, although one is not visible for
-- any view of a Graphic_Card.
Update_View(Top_Card_On_The_Deck);
-- Verify that both "View" components of the card have been updated.
if Get_View(Top_Card_On_The_Deck) /= Ace_Of_Hearts then
Report.Failed ("Incorrect value in visible component - 1");
end if;
if Get_Private_View(Top_Card_On_The_Deck) /= Queen_Of_Spades
then
Report.Failed ("Incorrect value in non-visible component - 1");
end if;
-- Again, update the components of the card (to blank values).
Hide_From_View(Top_Card_On_The_Deck);
-- Verify that both components have been updated.
if Get_View(Top_Card_On_The_Deck) /= Read_Em_And_Weep then
Report.Failed ("Incorrect value in visible component - 2");
end if;
if Get_Private_View(Top_Card_On_The_Deck) /= Close_To_The_Vest
then
Report.Failed ("Incorrect value in non-visible component - 2");
end if;
exception
when others => Report.Failed("Exception raised in test block");
end Check_Your_Cards;
Report.Result;
end C730003;
|
