diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c7/c730003.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c7/c730003.a | 283 |
1 files changed, 283 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c7/c730003.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c7/c730003.a new file mode 100644 index 000000000..47002f3aa --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c7/c730003.a @@ -0,0 +1,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; |