gcc/testsuite/ada/acats/tests/c3/c3900011.am

   1 -- C3900011.AM
   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 record extension can be declared in the same package
  28 --      as its parent, and that this parent may be a tagged record or a
  29 --      record extension. Check that each derivative inherits all user-
  30 --      defined primitive subprograms of its parent (including those that
  31 --      its parent inherited), and that it may declare its own primitive
  32 --      subprograms.
  33 --
  34 --      Check that predefined equality operators are defined for the root
  35 --      tagged type.
  36 --
  37 --      Check that type conversion is defined from a type extension to its
  38 --      parent, and that this parent itself may be a type extension.
  39 --
  40 -- TEST DESCRIPTION:
  41 --      Declare a root tagged type in a package specification. Declare two
  42 --      primitive subprograms for the type.
  43 --
  44 --      Extend the root type with a record extension in the same package
  45 --      specification. Declare a new primitive subprogram for the extension
  46 --      (in addition to its two inherited subprograms).
  47 --
  48 --      Extend the extension with a record extension in the same package
  49 --      specification. Declare a new primitive subprogram for this second
  50 --      extension (in addition to its three inherited subprograms).
  51 --
  52 --      In the main program, declare operations for the root tagged type which
  53 --      utilize aggregates and equality operators to verify the correctness
  54 --      of the components. Overload these operations for the two type
  55 --      extensions. Within each of these overloading operations, utilize type
  56 --      conversion to call the parent's implementation of the same operation.
  57 --
  58 -- TEST FILES:
  59 --      The following files comprise this test:
  60 --
  61 --         C3900010.A
  62 --      => C3900011.AM
  63 --
  64 --
  65 -- CHANGE HISTORY:
  66 --      06 Dec 94   SAIC    ACVC 2.0
  67 --
  68 --!
  69
  70 with C3900010;
  71 with Report;
  72 procedure C3900011 is
  73
  74
  75    package Check_Alert_Values is
  76
  77       -- Declare functions to verify correctness of tagged record components
  78       -- before and after calls to their primitive subprograms.
  79
  80
  81       -- Alert_Type:
  82
  83       function Initial_Values_Okay (A : in C3900010.Alert_Type)
  84         return Boolean;
  85
  86       function Bad_Final_Values (A : in C3900010.Alert_Type)
  87         return Boolean;
  88
  89
  90       -- Low_Alert_Type:
  91
  92       function Initial_Values_Okay (LA : in C3900010.Low_Alert_Type)
  93         return Boolean;
  94
  95       function Bad_Final_Values (LA : in C3900010.Low_Alert_Type)
  96         return Boolean;
  97
  98
  99       -- Medium_Alert_Type:
 100
 101       function Initial_Values_Okay (MA : in C3900010.Medium_Alert_Type)
 102         return Boolean;
 103
 104       function Bad_Final_Values (MA : in C3900010.Medium_Alert_Type)
 105         return Boolean;
 106
 107
 108    end Check_Alert_Values;
 109
 110
 111         --==========================================================--
 112
 113
 114    package body Check_Alert_Values is
 115
 116
 117       function Initial_Values_Okay (A : in C3900010.Alert_Type)
 118         return Boolean is
 119          use type C3900010.Alert_Type;
 120       begin                                      -- "=" operator availability.
 121          return (A = (Arrival_Time => C3900010.Default_Time,
 122                       Display_On   => C3900010.Null_Device));
 123       end Initial_Values_Okay;
 124
 125
 126       function Initial_Values_Okay (LA : in C3900010.Low_Alert_Type)
 127         return Boolean is
 128       begin                                      -- Type conversion.
 129          return (Initial_Values_Okay (C3900010.Alert_Type (LA)) and
 130                  LA.Level = 0);
 131       end Initial_Values_Okay;
 132
 133
 134       function Initial_Values_Okay (MA : in C3900010.Medium_Alert_Type)
 135         return Boolean is
 136          use type C3900010.Person_Enum;
 137       begin                                      -- Type conversion.
 138          return (Initial_Values_Okay (C3900010.Low_Alert_Type (MA)) and
 139                  MA.Action_Officer = C3900010.Nobody);
 140       end Initial_Values_Okay;
 141
 142
 143       function Bad_Final_Values (A : in C3900010.Alert_Type)
 144         return Boolean is
 145          use type C3900010.Alert_Type;
 146       begin                                      -- "/=" operator availability.
 147          return (A /= (Arrival_Time => C3900010.Alert_Time,
 148                        Display_On   => C3900010.Null_Device));
 149       end Bad_Final_Values;
 150
 151
 152       function Bad_Final_Values (LA : in C3900010.Low_Alert_Type)
 153         return Boolean is
 154          use type C3900010.Low_Alert_Type;
 155       begin                                      -- "=" operator availability.
 156          return not ( LA = (Arrival_Time => C3900010.Alert_Time,
 157                             Display_On   => C3900010.Teletype,
 158                             Level        => 1) );
 159       end Bad_Final_Values;
 160
 161
 162       function Bad_Final_Values (MA : in C3900010.Medium_Alert_Type)
 163         return Boolean is
 164          use type C3900010.Medium_Alert_Type;
 165       begin                                      -- "/=" operator availability.
 166          return ( MA /= (C3900010.Alert_Time,
 167                          C3900010.Console,
 168                          1,
 169                          C3900010.Duty_Officer) );
 170       end Bad_Final_Values;
 171
 172
 173    end Check_Alert_Values;
 174
 175
 176         --==========================================================--
 177
 178
 179    use Check_Alert_Values;
 180    use C3900010;
 181
 182    Root_Alarm   : C3900010.Alert_Type;
 183    Low_Alarm    : C3900010.Low_Alert_Type;
 184    Medium_Alarm : C3900010.Medium_Alert_Type;
 185
 186 begin
 187
 188    Report.Test ("C390001", "Primitive operation inheritance by type " &
 189                 "extensions: all extensions declared in same package " &
 190                 "as parent");
 191
 192
 193 -- Check root tagged type:
 194
 195    if Initial_Values_Okay (Root_Alarm) then
 196       Handle  (Root_Alarm);                          -- Explicitly declared.
 197       Display (Root_Alarm);                          -- Explicitly declared.
 198
 199       if Bad_Final_Values (Root_Alarm) then
 200          Report.Failed ("Wrong results after Alert_Type calls");
 201       end if;
 202    else
 203       Report.Failed ("Wrong initial values for Alert_Type");
 204    end if;
 205
 206
 207 -- Check record extension of root tagged type:
 208
 209    if Initial_Values_Okay (Low_Alarm) then
 210       Handle (Low_Alarm);                            -- Inherited.
 211       Low_Alarm.Display_On := Teletype;
 212       Display (Low_Alarm);                           -- Inherited.
 213       Low_Alarm.Level := Level_Of (Low_Alarm);       -- Explicitly declared.
 214
 215       if Bad_Final_Values (Low_Alarm) then
 216          Report.Failed ("Wrong results after Low_Alert_Type calls");
 217       end if;
 218    else
 219       Report.Failed ("Wrong initial values for Low_Alert_Type");
 220    end if;
 221
 222
 223 -- Check record extension of record extension:
 224
 225    if Initial_Values_Okay (Medium_Alarm) then
 226       Handle (Medium_Alarm);                         -- Inherited twice.
 227       Medium_Alarm.Display_On := Console;
 228       Display (Medium_Alarm);                        -- Inherited twice.
 229       Medium_Alarm.Level := Level_Of (Medium_Alarm); -- Inherited.
 230       Assign_Officer (Medium_Alarm, Duty_Officer);   -- Explicitly declared.
 231
 232       if Bad_Final_Values (Medium_Alarm) then
 233          Report.Failed ("Wrong results after Medium_Alert_Type calls");
 234       end if;
 235    else
 236       Report.Failed ("Wrong initial values for Medium_Alert_Type");
 237    end if;
 238
 239
 240 -- Check final display counts:
 241
 242    if C3900010.Display_Count_For /= (Null_Device => 1,
 243                                      Teletype    => 1,
 244                                      Console     => 1,
 245                                      Big_Screen  => 0)
 246    then
 247       Report.Failed ("Wrong final values for display counts");
 248    end if;
 249
 250
 251    Report.Result;
 252
 253 end C3900011;