-- 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;