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

   1 -- CC50001.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, in an instance, each implicit declaration of a predefined
  28 --      operator of a formal tagged private type declares a view of the
  29 --      corresponding predefined operator of the actual type (even if the
  30 --      operator has been overridden for the actual type). Check that the
  31 --      body executed is determined by the type and tag of the operands.
  32 --
  33 -- TEST DESCRIPTION:
  34 --      The formal tagged private type has an unknown discriminant part, and
  35 --      is thus indefinite. This allows both definite and indefinite types
  36 --      to be passed as actuals. For tagged types, definite implies
  37 --      nondiscriminated, and indefinite implies discriminated (with known
  38 --      or unknown discriminants).
  39 --
  40 --      Only nonlimited tagged types are tested, since equality operators
  41 --      are not predefined for limited types.
  42 --
  43 --      A tagged type is passed as an actual to a generic formal tagged
  44 --      private type. The tagged type overrides the predefined equality
  45 --      operator. A subprogram within the generic calls the equality operator
  46 --      of the formal type. In an instance, the equality operator denotes
  47 --      a view of the predefined operator of the actual type, but the
  48 --      call dispatches to the body of the overriding operator.
  49 --
  50 --
  51 -- CHANGE HISTORY:
  52 --      06 Dec 94   SAIC    ACVC 2.0
  53 --      21 Nov 95   SAIC    ACVC 2.0.1 fixes: Corrected expected result on
  54 --                          calls to "=" within the instance. Modified
  55 --                          commentary.
  56 --
  57 --!
  58
  59 package CC50001_0 is
  60
  61    type Count_Type is tagged record                     -- Nondiscriminated
  62       Count : Integer := 0;                             -- tagged type.
  63    end record;
  64
  65    function "="(Left, Right : Count_Type)               -- User-defined
  66      return Boolean;                                    -- equality operator.
  67
  68
  69    subtype Str_Len is Natural range 0 .. 100;
  70    subtype Stu_ID  is String (1 .. 5);
  71    subtype Dept_ID is String (1 .. 4);
  72    subtype Emp_ID  is String (1 .. 9);
  73    type    Status   is (Student, Faculty, Staff);
  74
  75    type Person_Type (Stat : Status;                     -- Discriminated
  76                      NameLen, AddrLen : Str_Len) is     -- tagged type.
  77      tagged record
  78       Name    : String (1 .. NameLen);
  79       Address : String (1 .. AddrLen);
  80       case Stat is
  81          when Student =>
  82             Student_ID  : Stu_ID;
  83          when Faculty =>
  84             Department  : Dept_ID;
  85          when Staff   =>
  86             Employee_ID : Emp_ID;
  87       end case;
  88    end record;
  89
  90    function "="(Left, Right : Person_Type)              -- User-defined
  91      return Boolean;                                    -- equality operator.
  92
  93
  94    -- Testing entities: ------------------------------------------------
  95
  96    TC_Count_Item     : constant Count_Type  := (Count => 111);
  97
  98    TC_Person_Item    : constant Person_Type :=
  99      (Faculty, 18, 17, "Eccles, John Scott", "Popham House, Lee", "0931");
 100
 101    ---------------------------------------------------------------------
 102
 103
 104 end CC50001_0;
 105
 106
 107      --===================================================================--
 108
 109
 110 package body CC50001_0 is
 111
 112    function "="(Left, Right : Count_Type) return Boolean is
 113    begin
 114       return False;   -- Return FALSE even if Left = Right.
 115    end "=";
 116
 117
 118    function "="(Left, Right : Person_Type) return Boolean is
 119    begin
 120       return False;   -- Return FALSE even if Left = Right.
 121    end "=";
 122
 123 end CC50001_0;
 124
 125
 126      --===================================================================--
 127
 128
 129 with CC50001_0;  -- Tagged (actual) type declarations.
 130 generic        -- Generic stack abstraction.
 131
 132    type Item (<>) is tagged private;            -- Formal tagged private type.
 133
 134 package CC50001_1 is
 135
 136    -- Simulate a generic stack abstraction. In a real application, the
 137    -- second operand of Push might be of type Stack, and type Stack
 138    -- would have at least one component (pointing to the top stack item).
 139
 140    type Stack is private;
 141
 142    procedure Push (I : in Item; TC_Check : out Boolean);
 143
 144    -- ... Other stack operations.
 145
 146 private
 147
 148    -- ... Stack and ancillary type declarations.
 149
 150    type Stack is record                       -- Artificial.
 151       null;
 152    end record;
 153
 154 end CC50001_1;
 155
 156
 157      --===================================================================--
 158
 159
 160 package body CC50001_1 is
 161
 162    -- For the sake of brevity, the implementation of Push is completely
 163    -- artificial; the goal is to model a call of the equality operator within
 164    -- the generic.
 165    --
 166    -- A real application might implement Push such that it does not add new
 167    -- items to the stack if they are identical to the top item; in that
 168    -- case, the equality operator would be called as part of an "if"
 169    -- condition.
 170
 171    procedure Push (I : in Item; TC_Check : out Boolean) is
 172    begin
 173       TC_Check := not (I = I);              -- Call user-defined "="; should
 174                                             -- return FALSE. Negation of
 175                                             -- result makes TC_Check TRUE.
 176    end Push;
 177
 178 end CC50001_1;
 179
 180
 181      --==================================================================--
 182
 183
 184 with CC50001_0;  -- Tagged (actual) type declarations.
 185 with CC50001_1;  -- Generic stack abstraction.
 186
 187 use  CC50001_0;  -- Overloaded "=" directly visible.
 188
 189 with Report;
 190 procedure CC50001 is
 191
 192    package Count_Stacks  is new CC50001_1 (CC50001_0.Count_Type);
 193    package Person_Stacks is new CC50001_1 (CC50001_0.Person_Type);
 194
 195    User_Defined_Op_Called : Boolean;
 196
 197 begin
 198    Report.Test ("CC50001", "Check that, in an instance, each implicit "     &
 199                 "declaration of a primitive subprogram of a formal tagged " &
 200                 "private type declares a view of the corresponding "        &
 201                 "predefined operator of the actual type (even if the "      &
 202                 "operator has been overridden or hidden for the actual type)");
 203
 204 --
 205 -- Test which "=" is called inside generic:
 206 --
 207
 208    User_Defined_Op_Called := False;
 209
 210    Count_Stacks.Push (CC50001_0.TC_Count_Item,
 211                       User_Defined_Op_Called);
 212
 213
 214    if not User_Defined_Op_Called then
 215       Report.Failed ("User-defined ""="" not called inside generic for Count");
 216    end if;
 217
 218
 219    User_Defined_Op_Called := False;
 220
 221    Person_Stacks.Push (CC50001_0.TC_Person_Item,
 222                        User_Defined_Op_Called);
 223
 224    if not User_Defined_Op_Called then
 225       Report.Failed ("User-defined ""="" not called inside generic " &
 226                      "for Person");
 227    end if;
 228
 229
 230 --
 231 -- Test which "=" is called outside generic:
 232 --
 233
 234    User_Defined_Op_Called := False;
 235
 236    User_Defined_Op_Called :=
 237      not (CC50001_0.TC_Count_Item = CC50001_0.TC_Count_Item);
 238
 239    if not User_Defined_Op_Called then
 240       Report.Failed ("User-defined ""="" not called outside generic "&
 241                      "for Count");
 242    end if;
 243
 244
 245    User_Defined_Op_Called := False;
 246
 247    User_Defined_Op_Called :=
 248      not (CC50001_0.TC_Person_Item = CC50001_0.TC_Person_Item);
 249
 250    if not User_Defined_Op_Called then
 251       Report.Failed ("User-defined ""="" not called outside generic "&
 252                      "for Person");
 253    end if;
 254
 255
 256    Report.Result;
 257 end CC50001;