gomp-20050608-branch/gcc/testsuite/ada/acats/tests/ca/ca11a02.a

   1 -- CA11A02.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --
  26 -- OBJECTIVE:
  27 --      Check that a type extended in a client of a public child inherits
  28 --      primitive operations from parent.
  29 --
  30 -- TEST DESCRIPTION:
  31 --      Declare a root tagged type in a package specification. Declare two
  32 --      primitive subprograms for the type (foundation code).
  33 --
  34 --      Add a public child to the above package.  Extend the root type with
  35 --      a record extension in the specification.  Declare a new primitive
  36 --      subprogram to write to the child extension.
  37 --
  38 --      In the main program, "with" the child.  Declare an extension of
  39 --      the child extension.  Access the primitive operations from both
  40 --      parent and child packages.
  41 --
  42 -- TEST FILES:
  43 --      This test depends on the following foundation code:
  44 --
  45 --         FA11A00.A
  46 --
  47 --
  48 -- CHANGE HISTORY:
  49 --      06 Dec 94   SAIC    ACVC 2.0
  50 --      20 Dec 94   SAIC    Moved declaration of Label_Widget to library level
  51 --
  52 --!
  53
  54 package FA11A00.CA11A02_0 is     -- Color_Widget_Pkg
  55 -- This public child declares an extension from its parent.  It
  56 -- represents processing of widgets in a window system.
  57
  58    type Widget_Color_Enum is (Black, Green, White);
  59
  60    type Color_Widget is new Widget with           -- Record extension of
  61       record                                      -- parent tagged type.
  62          Color : Widget_Color_Enum;
  63       end record;
  64
  65    -- Inherits procedure Set_Width from parent.
  66    -- Inherits procedure Set_Height from parent.
  67
  68    -- To be inherited by its derivatives.
  69    procedure Set_Color (The_Widget : in out Color_Widget;
  70                         C          : in     Widget_Color_Enum);
  71
  72 end FA11A00.CA11A02_0;     -- Color_Widget_Pkg
  73
  74 --=======================================================================--
  75
  76 package body FA11A00.CA11A02_0 is     -- Color_Widget_Pkg
  77
  78    procedure Set_Color (The_Widget : in out Color_Widget;
  79                         C          : in     Widget_Color_Enum) is
  80    begin
  81       The_Widget.Color := C;
  82    end Set_Color;
  83
  84 end FA11A00.CA11A02_0;     -- Color_Widget_Pkg
  85
  86 --=======================================================================--
  87
  88 with FA11A00.CA11A02_0;               -- Color_Widget_Pkg.
  89
  90 package CA11A02_1 is
  91
  92    type Label_Widget (Str_Disc : Integer) is new
  93      FA11A00.CA11A02_0.Color_Widget with
  94        record
  95          Label : String (1 .. Str_Disc);
  96        end record;
  97
  98    -- Inherits (inherited) procedure Set_Width from Color_Widget.
  99    -- Inherits (inherited) procedure Set_Height from Color_Widget.
 100    -- Inherits procedure Set_Color from Color_Widget.
 101
 102 end CA11A02_1;
 103
 104 --=======================================================================--
 105
 106 with FA11A00.CA11A02_0;               -- Color_Widget_Pkg,
 107                                       -- implicitly with Widget_Pkg
 108 with CA11A02_1;
 109
 110 with Report;
 111
 112 procedure CA11A02 is
 113
 114    package Widget_Pkg renames FA11A00;
 115    package Color_Widget_Pkg renames FA11A00.CA11A02_0;
 116
 117    use Widget_Pkg;              -- All user-defined operators directly visible.
 118
 119    procedure Set_Label (The_Widget : in out CA11A02_1.Label_Widget;
 120                         L          : in     String) is
 121    begin
 122       The_Widget.Label := L;
 123    end Set_Label;
 124    ---------------------------------------------------------
 125    procedure Set_Widget (The_Widget : in out CA11A02_1.Label_Widget;
 126                          The_Width  : in     Widget_Length;
 127                          The_Height : in     Widget_Length;
 128                          The_Color  : in
 129                                           Color_Widget_Pkg.Widget_Color_Enum;
 130                          The_Label  : in     String) is
 131    begin
 132       CA11A02_1.Set_Width  (The_Widget, The_Width);    -- Twice inherited.
 133       CA11A02_1.Set_Height (The_Widget, The_Height);   -- Twice inherited.
 134       CA11A02_1.Set_Color (The_Widget, The_Color);     -- Inherited.
 135       Set_Label  (The_Widget, The_Label);              -- Explicitly declared.
 136    end Set_Widget;
 137
 138    White_Widget : CA11A02_1.Label_Widget (11);
 139
 140 begin
 141
 142    Report.Test ("CA11A02", "Check that a type extended in a client of " &
 143                 "a public child inherits primitive operations from parent");
 144
 145    Set_Widget (White_Widget, 15, 21, Color_Widget_Pkg.White, "Alarm_Clock");
 146
 147    If White_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or
 148      White_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or
 149        Color_Widget_Pkg."/=" (White_Widget.Color, Color_Widget_Pkg.White) or
 150          White_Widget.Label /= "Alarm_Clock" then
 151             Report.Failed ("Incorrect result for White_Widget");
 152    end if;
 153
 154    Report.Result;
 155
 156 end CA11A02;