1-- C730003.A 2-- 3-- Grant of Unlimited Rights 4-- 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. 14-- 15-- DISCLAIMER 16-- 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. 23--* 24-- 25-- OBJECTIVE: 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 34-- the type. 35-- 36-- TEST DESCRIPTION: 37-- Consider: 38-- 39-- package Parent is 40-- type T is tagged record 41-- ... 42-- end record; 43-- 44-- type DT is new T with private; 45-- procedure Op1 (P: in out DT); 46-- 47-- private 48-- type DT is new T with record 49-- Y: ...; -- (A) 50-- end record; 51-- end Parent; 52-- 53-- package body Parent is 54-- function Op1 (P: in DT) return ... is 55-- begin 56-- return P.Y; 57-- end Op1; 58-- end Parent; 59-- 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. 64-- end record; 65-- end Unrelated; 66-- 67-- package Parent.Child is 68-- type DDT is new Intermediate with null record; 69-- -- Implicit declared Op1 (P.DDT); -- (C) 70-- 71-- procedure Op2 (P: in out DDT); 72-- end Parent.Child; 73-- 74-- package body Parent.Child is 75-- procedure Op2 (P: in out DDT) is 76-- Obj : DT renames DT(P); 77-- begin 78-- ... 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) 82-- end Op2; 83-- end Parent.Child; 84-- 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. 90-- 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. 95-- 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. 101-- 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. 105-- 106-- 107-- CHANGE HISTORY: 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. 111-- 112--! 113 114package C730003_0 is 115 116 type Suit_Kind is (Clubs, Diamonds, Hearts, Spades); 117 type Face_Kind is (Up, Down); 118 119 type Playing_Card is tagged record 120 Face: Face_Kind; 121 Suit: Suit_Kind; 122 end record; 123 124 procedure Turn_Over_Card (Card : in out Playing_Card); 125 126 type Disp_Card is new Playing_Card with private; 127 128 subtype ASCII_Representation is Natural range 1..14; 129 130 function Get_Private_View (A_Card : Disp_Card) return ASCII_Representation; 131 132private 133 134 type Disp_Card is new Playing_Card with record 135 View: ASCII_Representation; -- (A) 136 end record; 137 138end C730003_0; 139 140--==================================================================-- 141 142package body C730003_0 is 143 144 procedure Turn_Over_Card (Card: in out Playing_Card) is 145 begin 146 Card.Face := Up; 147 end Turn_Over_Card; 148 149 function Get_Private_View (A_Card : Disp_Card) 150 return ASCII_Representation is 151 begin 152 return A_Card.View; 153 end Get_Private_View; 154 155end C730003_0; 156 157--==================================================================-- 158 159with C730003_0; use C730003_0; 160package C730003_1 is 161 162 subtype Graphic_Representation is String (1 .. 2); 163 164 type Graphic_Card is new Disp_Card with record 165 View : Graphic_Representation; -- (B) 166 -- "Duplicate" component field name. 167 end record; 168 169end C730003_1; 170 171--==================================================================-- 172 173with C730003_1; use C730003_1; 174package C730003_0.C730003_2 is 175 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"; 180 181 type Graphic_Card is new C730003_1.Graphic_Card with null record; 182 183 -- Implicit function Get_Private_View -- (C) 184 -- (A_Card : Graphic_Card) return C730003_0.ASCII_Representation; 185 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); 189 190end C730003_0.C730003_2; 191 192--==================================================================-- 193 194package body C730003_0.C730003_2 is 195 196 function Get_View (Card : Graphic_Card) return String is 197 begin 198 return Card.View; 199 end Get_View; 200 201 procedure Update_View (Card : in out Graphic_Card) is 202 ASCII_View : Disp_Card renames Disp_Card(Card); -- View conversion. 203 begin 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. 208 end Update_View; 209 210 procedure Hide_From_View (Card : in out Graphic_Card) is 211 begin 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. 217 end Hide_From_View; 218 219end C730003_0.C730003_2; 220 221--==================================================================-- 222 223with C730003_0; 224with C730003_0.C730003_2; 225with Report; 226 227procedure C730003 is 228begin 229 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 " & 234 "extension"); 235 236 Check_Your_Cards: 237 declare 238 use C730003_0; 239 use C730003_0.C730003_2; 240 241 Top_Card_On_The_Deck : Graphic_Card; 242 243 begin 244 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. 248 249 Update_View(Top_Card_On_The_Deck); 250 251 -- Verify that both "View" components of the card have been updated. 252 253 if Get_View(Top_Card_On_The_Deck) /= Ace_Of_Hearts then 254 Report.Failed ("Incorrect value in visible component - 1"); 255 end if; 256 257 if Get_Private_View(Top_Card_On_The_Deck) /= Queen_Of_Spades 258 then 259 Report.Failed ("Incorrect value in non-visible component - 1"); 260 end if; 261 262 -- Again, update the components of the card (to blank values). 263 264 Hide_From_View(Top_Card_On_The_Deck); 265 266 -- Verify that both components have been updated. 267 268 if Get_View(Top_Card_On_The_Deck) /= Read_Em_And_Weep then 269 Report.Failed ("Incorrect value in visible component - 2"); 270 end if; 271 272 if Get_Private_View(Top_Card_On_The_Deck) /= Close_To_The_Vest 273 then 274 Report.Failed ("Incorrect value in non-visible component - 2"); 275 end if; 276 277 exception 278 when others => Report.Failed("Exception raised in test block"); 279 end Check_Your_Cards; 280 281 Report.Result; 282 283end C730003; 284