old-autovect-branch/gcc/testsuite/ada/acats/tests/ca/ca11a01.a

   1 -- CA11A01.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 type extended in a public child inherits primitive
  28 --      operations from its ancestor.
  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 --      Add a public grandchild to the above package.  Extend the extension of
  39 --      the parent type with a record extension in the private part of the
  40 --      specification.  Declare a new primitive subprogram for this grandchild
  41 --      extension.
  42 --
  43 --      In the main program, "with" the grandchild.  Access the primitive
  44 --      operations from grandparent and parent package.
  45 --
  46 -- TEST FILES:
  47 --      This test depends on the following foundation code:
  48 --
  49 --         FA11A00.A
  50 --
  51 --
  52 -- CHANGE HISTORY:
  53 --      06 Dec 94   SAIC    ACVC 2.0
  54 --
  55 --!
  56
  57 package FA11A00.CA11A01_0 is     -- Color_Widget_Pkg
  58 -- This public child declares an extension from its parent.  It
  59 -- represents processing of widgets in a window system.
  60
  61    type Widget_Color_Enum is (Black, Green, White);
  62
  63    type Color_Widget is new Widget with           -- Record extension of
  64       record                                      -- parent tagged type.
  65          Color : Widget_Color_Enum;
  66       end record;
  67
  68    -- Inherits procedure Set_Width from Widget.
  69    -- Inherits procedure Set_Height from Widget.
  70
  71    -- To be inherited by its derivatives.
  72    procedure Set_Color (The_Widget : in out Color_Widget;
  73                         C          : in     Widget_Color_Enum);
  74
  75    procedure Set_Color_Widget (The_Widget : in out Color_Widget;
  76                                The_Width  : in     Widget_Length;
  77                                The_Height : in     Widget_Length;
  78                                The_Color  : in     Widget_Color_Enum);
  79
  80 end FA11A00.CA11A01_0;     -- Color_Widget_Pkg
  81
  82 --=======================================================================--
  83
  84 package body FA11A00.CA11A01_0 is     -- Color_Widget_Pkg
  85
  86    procedure Set_Color (The_Widget : in out Color_Widget;
  87                         C          : in     Widget_Color_Enum) is
  88    begin
  89       The_Widget.Color := C;
  90    end Set_Color;
  91    ---------------------------------------------------------------
  92    procedure Set_Color_Widget (The_Widget : in out Color_Widget;
  93                                The_Width  : in     Widget_Length;
  94                                The_Height : in     Widget_Length;
  95                                The_Color  : in     Widget_Color_Enum) is
  96    begin
  97       Set_Width  (The_Widget, The_Width);   -- Inherited from parent.
  98       Set_Height (The_Widget, The_Height);  -- Inherited from parent.
  99       Set_Color  (The_Widget, The_Color);
 100    end Set_Color_Widget;
 101
 102 end FA11A00.CA11A01_0;     -- Color_Widget_Pkg
 103
 104 --=======================================================================--
 105
 106 package FA11A00.CA11A01_0.CA11A01_1 is     -- Label_Widget_Pkg
 107 -- This public grandchild extends the extension from its parent.  It
 108 -- represents processing of widgets in a window system.
 109
 110    -- Declaration used by private extension component.
 111    subtype Widget_Label_Str is string (1 .. 10);
 112
 113    type Label_Widget is new Color_Widget with private;
 114                             -- Record extension of parent tagged type.
 115
 116    -- Inherits (inherited) procedure Set_Width from Color_Widget.
 117    -- Inherits (inherited) procedure Set_Height from Color_Widget.
 118    -- Inherits procedure Set_Color from Color_Widget.
 119    -- Inherits procedure Set_Color_Widget from Color_Widget.
 120
 121    procedure Set_Label_Widget (The_Widget : in out Label_Widget;
 122                                The_Width  : in     Widget_Length;
 123                                The_Height : in     Widget_Length;
 124                                The_Color  : in     Widget_Color_Enum;
 125                                The_Label  : in     Widget_Label_Str);
 126
 127    -- The following function is needed to verify the value of the
 128    -- extension's private component.
 129
 130    function Verify_Label (The_Widget : in Label_Widget;
 131                           The_Label  : in Widget_Label_Str) return Boolean;
 132
 133 private
 134    type Label_Widget is new Color_Widget with
 135       record
 136          Label : Widget_Label_Str;
 137       end record;
 138
 139 end FA11A00.CA11A01_0.CA11A01_1;     -- Label_Widget_Pkg
 140
 141 --=======================================================================--
 142
 143 package body FA11A00.CA11A01_0.CA11A01_1 is     -- Label_Widget_Pkg
 144
 145    procedure Set_Label (The_Widget : in out Label_Widget;
 146                         L          : in     Widget_Label_Str) is
 147    begin
 148       The_Widget.Label := L;
 149    end Set_Label;
 150    --------------------------------------------------------------
 151    procedure Set_Label_Widget (The_Widget : in out Label_Widget;
 152                                The_Width  : in     Widget_Length;
 153                                The_Height : in     Widget_Length;
 154                                The_Color  : in     Widget_Color_Enum;
 155                                The_Label  : in     Widget_Label_Str) is
 156    begin
 157       Set_Width  (The_Widget, The_Width);   -- Twice inherited.
 158       Set_Height (The_Widget, The_Height);  -- Twice inherited.
 159       Set_Color  (The_Widget, The_Color);   -- Inherited from parent.
 160       Set_Label  (The_Widget, The_Label);
 161    end Set_Label_Widget;
 162    --------------------------------------------------------------
 163    function Verify_Label (The_Widget : in Label_Widget;
 164                           The_Label  : in Widget_Label_Str) return Boolean is
 165    begin
 166       return (The_Widget.Label = The_Label);
 167    end Verify_Label;
 168
 169 end FA11A00.CA11A01_0.CA11A01_1;     -- Label_Widget_Pkg
 170
 171 --=======================================================================--
 172
 173 with FA11A00.CA11A01_0.CA11A01_1;     -- Label_Widget_Pkg,
 174                                       -- implicitly with Widget_Pkg,
 175                                       -- implicitly with Color_Widget_Pkg
 176 with Report;
 177
 178 procedure CA11A01 is
 179
 180    package Widget_Pkg renames FA11A00;
 181    package Color_Widget_Pkg renames FA11A00.CA11A01_0;
 182    package Label_Widget_Pkg renames FA11A00.CA11A01_0.CA11A01_1;
 183
 184    use Widget_Pkg;              -- All user-defined operators directly visible.
 185
 186    Mail_Label     : Label_Widget_Pkg.Widget_Label_Str := "Quick_Mail";
 187
 188    Default_Widget : Widget;
 189    Black_Widget   : Color_Widget_Pkg.Color_Widget;
 190    Mail_Widget    : Label_Widget_Pkg.Label_Widget;
 191
 192 begin
 193
 194    Report.Test ("CA11A01", "Check that type extended in a public " &
 195                 "child inherits primitive operations from its " &
 196                 "ancestor");
 197
 198    Set_Width (Default_Widget, 9);             -- Call from parent.
 199    Set_Height (Default_Widget, 10);           -- Call from parent.
 200
 201    If Default_Widget.Width /= Widget_Length (Report.Ident_Int (9)) or
 202      Default_Widget.Height /= Widget_Length (Report.Ident_Int (10)) then
 203         Report.Failed ("Incorrect result for Default_Widget");
 204    end if;
 205
 206    Color_Widget_Pkg.Set_Color_Widget
 207      (Black_Widget, 17, 18, Color_Widget_Pkg.Black);   -- Explicitly declared.
 208
 209    If Black_Widget.Width /= Widget_Length (Report.Ident_Int (17)) or
 210      Black_Widget.Height /= Widget_Length (Report.Ident_Int (18)) or
 211        Color_Widget_Pkg."/=" (Black_Widget.Color, Color_Widget_Pkg.Black) then
 212           Report.Failed ("Incorrect result for Black_Widget");
 213    end if;
 214
 215    Label_Widget_Pkg.Set_Label_Widget
 216      (Mail_Widget, 15, 21, Color_Widget_Pkg.White,
 217        "Quick_Mail");                                  -- Explicitly declared.
 218
 219    If Mail_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or
 220      Mail_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or
 221        Color_Widget_Pkg."/=" (Mail_Widget.Color, Color_Widget_Pkg.White) or
 222          not Label_Widget_Pkg.Verify_Label (Mail_Widget, Mail_Label) then
 223             Report.Failed ("Incorrect result for Mail_Widget");
 224    end if;
 225
 226    Report.Result;
 227
 228 end CA11A01;