c730003.a

来自「linux下编程用 编译软件」· A 代码 · 共 284 行

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