gcc/testsuite/ada/acats/tests/cc/cc51007.a

   1 -- CC51007.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 generic formal derived tagged type is a private extension.
  28 --      Specifically, check that, for a generic formal derived type whose
  29 --      ancestor type has abstract primitive subprograms, neither the formal
  30 --      derived type nor its descendants need be abstract. Check that objects
  31 --      and components of the formal derived type and its nonabstract
  32 --      descendants may be declared and allocated, as may nonabstract
  33 --      functions returning these types, and that aggregates of nonabstract
  34 --      descendants of the formal derived type are legal. Check that calls to
  35 --      the abstract primitive subprograms of the ancestor dispatch to the
  36 --      bodies corresponding to the tag of the actual parameters.
  37 --
  38 -- TEST DESCRIPTION:
  39 --      Although the ancestor type is abstract and has abstract primitive
  40 --      subprograms, these subprograms, when inherited by a formal nonabstract
  41 --      derived type, are not abstract, since the formal derived type is a
  42 --      nonabstract private extension.
  43 --
  44 --      Thus, derivatives of the formal derived type need not be abstract,
  45 --      and both the formal derived type and its derivatives are considered
  46 --      nonabstract types.
  47 --
  48 --      This test verifies that the restrictions placed on abstract types do
  49 --      not apply to the formal derived type or its derivatives. Specifically,
  50 --      objects of, components of, allocators of, and nonabstract functions
  51 --      returning the formal derived type or its derivatives are legal. In
  52 --      addition, the test verifies that a call within the instance to a
  53 --      primitive subprogram of the (abstract) ancestor type dispatches to
  54 --      the body corresponding to the tag of the actual parameter.
  55 --
  56 --
  57 -- CHANGE HISTORY:
  58 --      06 Dec 94   SAIC    ACVC 2.0
  59 --      23 Dec 94   SAIC    Deleted illegal extension aggregate.  Corrected
  60 --                          dispatching call. Editorial changes to commentary.
  61 --      05 Nov 95   SAIC    ACVC 2.0.1 fixes: Moved instantiation of CC51007_3
  62 --                          to library level.
  63 --      11 Aug 96   SAIC    ACVC 2.1: Added pragma Elaborate to context
  64 --                          clauses of CC51007_1 and CC51007_4.
  65 --
  66 --!
  67
  68 package CC51007_0 is
  69
  70    Max_Length : constant := 10;
  71    type Text is new String(1 .. Max_Length);
  72
  73    type Alert is abstract tagged record              -- Root type of class
  74       Message : Text := (others => '*');             -- (abstract).
  75    end record;
  76
  77    procedure Handle (A: in out Alert) is abstract;   -- Abstract dispatching
  78                                                      -- operation.
  79
  80 end CC51007_0;
  81
  82 -- No body for CC51007_0;
  83
  84
  85      --===================================================================--
  86
  87
  88 with CC51007_0;
  89
  90 with Ada.Calendar;
  91 pragma Elaborate (Ada.Calendar);
  92
  93 package CC51007_1 is
  94
  95    type Low_Alert is new CC51007_0.Alert with record
  96       Time_Of_Arrival : Ada.Calendar.Time := Ada.Calendar.Time_Of (1901, 8, 1);
  97    end record;
  98
  99    procedure Handle (A: in out Low_Alert);           -- Overrides parent's
 100                                                      -- implementation.
 101    Low : Low_Alert;
 102
 103 end CC51007_1;
 104
 105
 106      --===================================================================--
 107
 108
 109 package body CC51007_1 is
 110
 111    procedure Handle (A: in out Low_Alert) is         -- Artificial for
 112    begin                                             -- testing.
 113       A.Time_Of_Arrival := Ada.Calendar.Time_Of (1984, 1, 1);
 114       A.Message := "Low Alert!";
 115    end Handle;
 116
 117 end CC51007_1;
 118
 119
 120      --===================================================================--
 121
 122
 123 with CC51007_1;
 124 package CC51007_2 is
 125
 126    type Person is (OOD, CO, CinC);
 127
 128    type Medium_Alert is new CC51007_1.Low_Alert with record
 129       Action_Officer : Person := OOD;
 130    end record;
 131
 132    procedure Handle (A: in out Medium_Alert);        -- Overrides parent's
 133                                                      -- implementation.
 134    Med : Medium_Alert;
 135
 136 end CC51007_2;
 137
 138
 139      --===================================================================--
 140
 141
 142 with Ada.Calendar;
 143 package body CC51007_2 is
 144
 145    procedure Handle (A: in out Medium_Alert) is      -- Artificial for
 146    begin                                             -- testing.
 147       A.Action_Officer := CO;
 148       A.Time_Of_Arrival := Ada.Calendar.Time_Of (2001, 1, 1);
 149       A.Message := "Med Alert!";
 150    end Handle;
 151
 152 end CC51007_2;
 153
 154
 155      --===================================================================--
 156
 157
 158 with CC51007_0;
 159 generic
 160    type Alert_Type is new CC51007_0.Alert with private;
 161    Initial_State : in Alert_Type;
 162 package CC51007_3 is
 163
 164    function Clear_Message (A: Alert_Type)                -- Function returning
 165      return Alert_Type;                                  -- formal type.
 166
 167
 168    Max_Note : Natural := 10;
 169    type Note is new String (1 .. Max_Note);
 170
 171    type Extended_Alert is new Alert_Type with record
 172       Addendum : Note := (others => '*');
 173    end record;
 174
 175    -- In instance, inherits version of Handle from
 176    -- actual corresponding to formal type.
 177
 178    function Annotate_Alert (A: in Alert_Type'Class)      -- Function returning
 179      return Extended_Alert;                              -- derived type.
 180
 181
 182    Init_Ext_Alert : constant Extended_Alert     :=       -- Object declaration.
 183      (Initial_State with Addendum => "----------");      -- Aggregate.
 184
 185
 186    type Alert_Type_Ptr is access constant Alert_Type;
 187    type Ext_Alert_Ptr  is access          Extended_Alert;
 188
 189    Init_Alert_Ptr     : Alert_Type_Ptr :=
 190      new Alert_Type'(Initial_State);                        -- Allocator.
 191
 192    Init_Ext_Alert_Ptr : Ext_Alert_Ptr  :=
 193      new Extended_Alert'(Init_Ext_Alert);                -- Allocator.
 194
 195
 196    type Alert_Pair is record
 197       A  : Alert_Type;                                   -- Component.
 198       EA : Extended_Alert;                               -- Component.
 199    end record;
 200
 201 end CC51007_3;
 202
 203
 204      --===================================================================--
 205
 206
 207 package body CC51007_3 is
 208
 209    function Clear_Message (A: Alert_Type) return Alert_Type is
 210       Temp : Alert_Type := A;                       -- Object declaration.
 211    begin
 212       Temp.Message := (others => '-');
 213       return Temp;
 214    end Clear_Message;
 215
 216    function Annotate_Alert (A: in Alert_Type'Class) return Extended_Alert is
 217       Temp : Alert_Type'Class := A;
 218    begin
 219       Handle (Temp);                                -- Dispatching call to
 220                                                     -- operation of ancestor.
 221       return (Alert_Type(Temp) with Addendum => "No comment");
 222    end Annotate_Alert;
 223
 224 end CC51007_3;
 225
 226
 227      --===================================================================--
 228
 229
 230 with CC51007_1;
 231
 232 with CC51007_3;
 233 pragma Elaborate (CC51007_3);
 234
 235 package CC51007_4 is new CC51007_3 (CC51007_1.Low_Alert, CC51007_1.Low);
 236
 237
 238      --===================================================================--
 239
 240
 241 with CC51007_1;
 242 with CC51007_2;
 243 with CC51007_3;
 244 with CC51007_4;
 245
 246 with Ada.Calendar;
 247 with Report;
 248 procedure CC51007 is
 249
 250    package Alert_Support renames CC51007_4;
 251
 252    Ext : Alert_Support.Extended_Alert;
 253
 254    TC_Result       : Alert_Support.Extended_Alert;
 255
 256    TC_Low_Expected : constant Alert_Support.Extended_Alert :=
 257                        (Time_Of_Arrival => Ada.Calendar.Time_Of (1984, 1, 1),
 258                         Message         => "Low Alert!",
 259                         Addendum        => "No comment");
 260
 261    TC_Med_Expected : constant Alert_Support.Extended_Alert :=
 262                        (Time_Of_Arrival => Ada.Calendar.Time_Of (2001, 1, 1),
 263                         Message         => "Med Alert!",
 264                         Addendum        => "No comment");
 265
 266    TC_Ext_Expected : constant Alert_Support.Extended_Alert := TC_Low_Expected;
 267
 268
 269    use type Alert_Support.Extended_Alert;
 270
 271 begin
 272    Report.Test ("CC51007", "Check that, for a generic formal derived type "  &
 273                 "whose ancestor type has abstract primitive subprograms, "   &
 274                 "neither the formal derived type nor its descendants need "  &
 275                 "be abstract, and that objects of, components of, "          &
 276                 "allocators of, aggregates of, and nonabstract functions "   &
 277                 "returning these types are legal. Check that calls to the "  &
 278                 "abstract primitive subprograms of the ancestor dispatch "   &
 279                 "to the bodies corresponding to the tag of the actual "      &
 280                 "parameters");
 281
 282
 283    TC_Result := Alert_Support.Annotate_Alert (CC51007_1.Low);  -- Dispatching
 284                                                                -- call.
 285    if TC_Result /= TC_Low_Expected then
 286       Report.Failed ("Wrong results from dispatching call (Low_Alert)");
 287    end if;
 288
 289
 290    TC_Result := Alert_Support.Annotate_Alert (CC51007_2.Med);  -- Dispatching
 291                                                                -- call.
 292    if TC_Result /= TC_Med_Expected then
 293       Report.Failed ("Wrong results from dispatching call (Medium_Alert)");
 294    end if;
 295
 296
 297    TC_Result := Alert_Support.Annotate_Alert (Ext);   -- Results in dispatching
 298                                                       -- call.
 299    if TC_Result /= TC_Ext_Expected then
 300       Report.Failed ("Wrong results from dispatching call (Extended_Alert)");
 301    end if;
 302
 303
 304    Report.Result;
 305 end CC51007;