URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c7/] [c730003.a] - Rev 154
Go to most recent revision | Compare with Previous | Blame | View Log
-- 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;
Go to most recent revision | Compare with Previous | Blame | View Log