gcc/testsuite/ada/acats/tests/c3/c393008.a

   1 -- C393008.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 -- TEST OBJECTIVE:
  27 --      Check that an extended type can be derived from an abstract type.
  28 --
  29 -- TEST DESCRIPTION:
  30 --      Declare a tagged record; declare an abstract
  31 --      primitive operation and a non-abstract primitive operation of the
  32 --      type.  Derive an extended type from it, including a new component.
  33 --      Use the derived type, the overriding operation and the inherited
  34 --      operation to instantiate a generic package.  The overriding operation
  35 --      calls a new primitive operation and an inherited operation [so the
  36 --      instantiation must get this sorted out correctly].
  37 --
  38 --
  39 -- CHANGE HISTORY:
  40 --      06 Dec 94   SAIC    ACVC 2.0
  41 --
  42 --!
  43
  44 with Report;
  45 with TCTouch;
  46 procedure C393008 is
  47
  48 package C393008_0 is
  49
  50   type Status_Enum is (No_Status, Handled, Unhandled, Pending);
  51
  52   type Alert_Type is abstract tagged record
  53       Status : Status_Enum;
  54       Reply  : Boolean;
  55       Urgent : Boolean;
  56   end record;
  57
  58   subtype Serial_Number is Integer range 0..Integer'last;
  59   Serial_Num : Serial_Number := 0;
  60
  61   procedure Handle   (A : in out Alert_Type) is abstract;
  62                                         -- abstract primitive operation
  63
  64   -- the procedure Init would be _nice_ have this procedure be non_abstract
  65   -- and create a "base" object with a "null" constraint.  The language
  66   -- will not allow this due to the restriction that an object of an
  67   -- abstract type cannot be created.  Hence Init must be abstract,
  68   -- requiring any type derived directly from Alert_Type to declare
  69   -- an Init.
  70   --
  71   -- In light of this, I have changed init to a function to more closely
  72   -- model the typical usage of OO features...
  73
  74   function  Init return Alert_Type is abstract;
  75
  76   procedure No_Reply (A : in out Alert_Type);
  77
  78 end C393008_0;
  79
  80 --=======================================================================--
  81
  82 package body C393008_0 is
  83
  84   procedure No_Reply (A : in out Alert_Type) is
  85     begin                              -- primitive operation, not abstract
  86       TCTouch.Touch('A');  ------------------------------------------------- A
  87       if A.Status = Handled then
  88         A.Reply  := False;
  89       end if;
  90     end No_Reply;
  91
  92 end C393008_0;
  93
  94 --=======================================================================--
  95
  96   generic
  97                         -- pass in the Alert_Type object, including its
  98                         -- operations
  99     type Data_Type is new C393008_0.Alert_Type with private;
 100                         -- note that Alert_Type is abstract, so it may not be
 101                         -- used as an actual parameter
 102     with procedure Update     (P : in out Data_Type) is <>;  -- generic formal
 103     with function  Initialize return Data_Type is <>;        -- generic formal
 104
 105   package C393008_1 is
 106        -- Utilities
 107
 108     procedure Modify (Item : in out Data_Type);
 109
 110   end C393008_1;
 111    -- Utilities
 112
 113 --=======================================================================--
 114
 115   package body C393008_1 is
 116             -- Utilities
 117
 118       procedure Modify (Item : in out Data_Type) is
 119         begin
 120           TCTouch.Touch('B');  --------------------------------------------- B
 121           Item := Initialize;
 122           Update (Item);
 123         end Modify;
 124
 125   end C393008_1;
 126
 127 --=======================================================================--
 128
 129   package C393008_2 is
 130
 131     type Low_Alert_Type is new C393008_0.Alert_Type with record
 132       Serial : C393008_0.Serial_Number;
 133     end record;
 134
 135     procedure Serialize (LA : in out Low_Alert_Type);
 136
 137     -- inherit No_Reply
 138
 139     procedure Handle (LA : in out Low_Alert_Type);
 140
 141     function Init return Low_Alert_Type;
 142   end C393008_2;
 143
 144   package body C393008_2 is
 145     procedure Serialize (LA : in out Low_Alert_Type) is
 146     begin                          -- new primitive operation
 147       TCTouch.Touch('C');  ------------------------------------------------- C
 148       C393008_0.Serial_Num := C393008_0.Serial_Num + 1;
 149       LA.Serial := C393008_0.Serial_Num;
 150     end Serialize;
 151
 152   -- inherit No_Reply
 153
 154     function Init return Low_Alert_Type is
 155       TA: Low_Alert_Type;
 156     begin
 157       TCTouch.Touch('D');  ------------------------------------------------- D
 158       Serialize( TA );
 159       TA.Status := C393008_0.No_Status;
 160       return TA;
 161     end Init;
 162
 163     procedure Handle (LA : in out Low_Alert_Type) is
 164     begin                          -- overrides abstract inherited Handle
 165       TCTouch.Touch('E');  ------------------------------------------------- E
 166       Serialize (LA);
 167       LA.Reply := False;
 168       LA.Status := C393008_0.Handled;
 169       No_Reply (LA);
 170     end Handle;
 171
 172   end C393008_2;
 173
 174   use C393008_2;
 175
 176   package Alert_Utilities is new
 177     C393008_1 (Data_Type   => Low_Alert_Type,
 178                Update      => Handle,   -- Low_Alert's Handle
 179                Initialize  => Init);    -- inherited from Alert
 180
 181   Item : Low_Alert_Type;
 182
 183   use type C393008_0.Status_Enum;
 184
 185 begin
 186
 187   Report.Test ("C393008", "Check that an extended type can be derived "&
 188                           "from an abstract type");
 189
 190   Item := Init;
 191   if (Item.Status /= C393008_0.No_Status) or (Item.Serial /=1)  then
 192     Report.Failed ("Wrong initialization");
 193   end if;
 194   TCTouch.Validate("DC", "Initialization Call");
 195
 196   Alert_Utilities.Modify (Item);
 197   if (Item.Status /= C393008_0.Handled) or (Item.Serial /= 3) then
 198     Report.Failed ("Wrong results from Modify");
 199   end if;
 200   TCTouch.Validate("BDCECA", "Generic Instance Call");
 201
 202   Report.Result;
 203
 204 end C393008;