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