3 -- Grant of Unlimited Rights
5 -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
6 -- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
7 -- software and documentation contained herein. Unlimited rights are
8 -- defined in DFAR 252.227-7013(a)(19). By making this public release,
9 -- the Government intends to confer upon all recipients unlimited rights
10 -- equal to those held by the Government. These rights include rights to
11 -- use, duplicate, release or disclose the released technical data and
12 -- computer software in whole or in part, in any manner and for any purpose
13 -- whatsoever, and to have or permit others to do so.
17 -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
18 -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
19 -- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE
20 -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
21 -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
22 -- PARTICULAR PURPOSE OF SAID MATERIAL.
26 -- Check that the characteristics of a type derived from a private
27 -- extension (outside the scope of the full view) are those defined by
28 -- the partial view of the private extension.
29 -- In particular, check that a component of the derived type may be
30 -- explicitly declared with the same name as a component declared for
31 -- the full view of the private extension.
32 -- Check that a component defined in the private extension of a type
33 -- may be updated through a view conversion of a type derived from
40 -- type T is tagged record
44 -- type DT is new T with private;
45 -- procedure Op1 (P: in out DT);
48 -- type DT is new T with record
53 -- package body Parent is
54 -- function Op1 (P: in DT) return ... is
60 -- package Unrelated is
61 -- type Intermediate is new DT with record
62 -- Y: ...; -- Note: same name as component of -- (B)
63 -- -- parent's full view.
67 -- package Parent.Child is
68 -- type DDT is new Intermediate with null record;
69 -- -- Implicit declared Op1 (P.DDT); -- (C)
71 -- procedure Op2 (P: in out DDT);
74 -- package body Parent.Child is
75 -- procedure Op2 (P: in out DDT) is
76 -- Obj : DT renames DT(P);
79 -- P.Y := ...; -- Updates DDT's Y. -- (D)
80 -- DT(P).Y := ...; -- Updates DT's Y. -- (E)
81 -- Obj.Y := ...; -- Updates DT's Y. -- (F)
85 -- Types DT and DDT both declare a component Y at (A) and (B),
86 -- respectively. The component Y of the full view of DT is not visible
87 -- at the place where DDT is declared. Therefore, it is invisible for
88 -- all views of DDT (although it still exists for objects of DDT), and
89 -- it is legal to declare another component for DDT with the same name.
91 -- DDT inherits the primitive subprogram Op1 from DT at (C). Op1 returns
92 -- the component Y; for calls with an operand of type DDT, Op1 returns
93 -- the Y inherited from DT, not the new Y explicitly declared for DDT,
94 -- even though the inherited Y is not visible for any view of DDT.
96 -- Within the body of Op2, the assignment statement at (D) updates the
97 -- Y explicitly declared for DDT. At (E) and (F), however, a view
98 -- conversion denotes a new view of P as an object of type DT, which
99 -- enables access to the Y from the full view of DT. Thus, the
100 -- assignment statements at (E) and (F) update the (invisible) Y from DT.
102 -- Note that the above analysis would be wrong if the new component Y
103 -- were declared directly in Child. In that case, the two same-named
104 -- components would be illegal -- see AI-150.
108 -- 06 Dec 1994 SAIC ACVC 2.0
109 -- 29 JUN 1999 RAD Declare same-named component in an
110 -- unrelated package -- see AI-150.
116 type Suit_Kind
is (Clubs
, Diamonds
, Hearts
, Spades
);
117 type Face_Kind
is (Up
, Down
);
119 type Playing_Card
is tagged record
124 procedure Turn_Over_Card
(Card
: in out Playing_Card
);
126 type Disp_Card
is new Playing_Card
with private;
128 subtype ASCII_Representation
is Natural range 1..14;
130 function Get_Private_View
(A_Card
: Disp_Card
) return ASCII_Representation
;
134 type Disp_Card
is new Playing_Card
with record
135 View
: ASCII_Representation
; -- (A)
140 --==================================================================--
142 package body C730003_0
is
144 procedure Turn_Over_Card
(Card
: in out Playing_Card
) is
149 function Get_Private_View
(A_Card
: Disp_Card
)
150 return ASCII_Representation
is
153 end Get_Private_View
;
157 --==================================================================--
159 with C730003_0
; use C730003_0
;
162 subtype Graphic_Representation
is String (1 .. 2);
164 type Graphic_Card
is new Disp_Card
with record
165 View
: Graphic_Representation
; -- (B)
166 -- "Duplicate" component field name.
171 --==================================================================--
173 with C730003_1
; use C730003_1
;
174 package C730003_0
.C730003_2
is
176 Queen_Of_Spades
: constant C730003_0
.ASCII_Representation
:= 12;
177 Ace_Of_Hearts
: constant String := "AH";
178 Close_To_The_Vest
: constant C730003_0
.ASCII_Representation
:= 14;
179 Read_Em_And_Weep
: constant String := "AA";
181 type Graphic_Card
is new C730003_1
.Graphic_Card
with null record;
183 -- Implicit function Get_Private_View -- (C)
184 -- (A_Card : Graphic_Card) return C730003_0.ASCII_Representation;
186 function Get_View
(Card
: Graphic_Card
) return String;
187 procedure Update_View
(Card
: in out Graphic_Card
);
188 procedure Hide_From_View
(Card
: in out Graphic_Card
);
190 end C730003_0
.C730003_2
;
192 --==================================================================--
194 package body C730003_0
.C730003_2
is
196 function Get_View
(Card
: Graphic_Card
) return String is
201 procedure Update_View
(Card
: in out Graphic_Card
) is
202 ASCII_View
: Disp_Card
renames Disp_Card
(Card
); -- View conversion.
204 ASCII_View
.View
:= Queen_Of_Spades
; -- (F)
205 -- Assignment to "hidden" field.
206 Card
.View
:= Ace_Of_Hearts
; -- (D)
207 -- Assignment to Graphic_Card declared field.
210 procedure Hide_From_View
(Card
: in out Graphic_Card
) is
212 -- Update both of Card's View components.
213 Disp_Card
(Card
).View
:= Close_To_The_Vest
; -- (E)
214 -- Assignment to "hidden" field.
215 Card
.View
:= Read_Em_And_Weep
; -- (D)
216 -- Assignment to Graphic_Card declared field.
219 end C730003_0
.C730003_2
;
221 --==================================================================--
224 with C730003_0
.C730003_2
;
230 Report
.Test
("C730003", "Check that the characteristics of a type " &
231 "derived from a private extension (outside " &
232 "the scope of the full view) are those " &
233 "defined by the partial view of the private " &
239 use C730003_0
.C730003_2
;
241 Top_Card_On_The_Deck
: Graphic_Card
;
245 -- Update value in the components of the card. There are two
246 -- component fields named View, although one is not visible for
247 -- any view of a Graphic_Card.
249 Update_View
(Top_Card_On_The_Deck
);
251 -- Verify that both "View" components of the card have been updated.
253 if Get_View
(Top_Card_On_The_Deck
) /= Ace_Of_Hearts
then
254 Report
.Failed
("Incorrect value in visible component - 1");
257 if Get_Private_View
(Top_Card_On_The_Deck
) /= Queen_Of_Spades
259 Report
.Failed
("Incorrect value in non-visible component - 1");
262 -- Again, update the components of the card (to blank values).
264 Hide_From_View
(Top_Card_On_The_Deck
);
266 -- Verify that both components have been updated.
268 if Get_View
(Top_Card_On_The_Deck
) /= Read_Em_And_Weep
then
269 Report
.Failed
("Incorrect value in visible component - 2");
272 if Get_Private_View
(Top_Card_On_The_Deck
) /= Close_To_The_Vest
274 Report
.Failed
("Incorrect value in non-visible component - 2");
278 when others => Report
.Failed
("Exception raised in test block");
279 end Check_Your_Cards
;