gomp-20050608-branch/gcc/testsuite/ada/acats/tests/c7/c731001.a

   1 -- C731001.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
   6 --     F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
   7 --     software and documentation contained herein.  Unlimited rights are
   8 --     defined in DFAR 252.227-7013(a)(19).  By making this public release,
   9 --     the Government intends to confer upon all recipients unlimited rights
  10 --     equal to those held by the Government.  These rights include rights to
  11 --     use, duplicate, release or disclose the released technical data and
  12 --     computer software in whole or in part, in any manner and for any purpose
  13 --     whatsoever, and to have or permit others to do so.
  14 --
  15 --                                    DISCLAIMER
  16 --
  17 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  18 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  19 --     WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE
  20 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  21 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  22 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  23 --*
  24 --
  25 -- OBJECTIVE
  26 --     Check that inherited operations can be overridden, even when they are
  27 --     inherited in a body.
  28 --     The test cases here are inspired by the AARM examples given in
  29 --     the discussion of AARM-7.3.1(7.a-7.v).
  30 --     This discussion was confirmed by AI95-00035.
  31 --
  32 -- TEST DESCRIPTION
  33 --     See AARM-7.3.1.
  34 --
  35 -- CHANGE HISTORY:
  36 --      29 JUN 1999   RAD   Initial Version
  37 --      23 SEP 1999   RLB   Improved comments, renamed, issued.
  38 --      20 AUG 2001   RLB   Corrected 'verbose' flag.
  39 --
  40 --!
  41
  42 with Report; use Report; pragma Elaborate_All(Report);
  43 package C731001_1 is
  44     pragma Elaborate_Body;
  45 private
  46     procedure Check_String(X, Y: String);
  47     function Check_String(X, Y: String) return String;
  48         -- This one is a function, so we can call it in package specs.
  49 end C731001_1;
  50
  51 package body C731001_1 is
  52
  53     Verbose: Boolean := False;
  54
  55     procedure Check_String(X, Y: String) is
  56     begin
  57         if Verbose then
  58             Comment("""" & X & """ = """ & Y & """?");
  59         end if;
  60         if X /= Y then
  61             Failed("""" & X & """ should be """ & Y & """");
  62         end if;
  63     end Check_String;
  64
  65     function Check_String(X, Y: String) return String is
  66     begin
  67         Check_String(X, Y);
  68         return X;
  69     end Check_String;
  70
  71 end C731001_1;
  72
  73 private package C731001_1.Parent is
  74
  75     procedure Call_Main;
  76
  77     type Root is tagged null record;
  78     subtype Renames_Root is Root;
  79     subtype Root_Class is Renames_Root'Class;
  80     function Make return Root;
  81     function Op1(X: Root) return String;
  82     function Call_Op2(X: Root'Class) return String;
  83 private
  84     function Op2(X: Root) return String;
  85 end C731001_1.Parent;
  86
  87 procedure C731001_1.Parent.Main;
  88
  89 with C731001_1.Parent.Main;
  90 package body C731001_1.Parent is
  91
  92     procedure Call_Main is
  93     begin
  94         Main;
  95     end Call_Main;
  96
  97     function Make return Root is
  98         Result: Root;
  99     begin
 100         return Result;
 101     end Make;
 102
 103     function Op1(X: Root) return String is
 104     begin
 105         return "Parent.Op1 body";
 106     end Op1;
 107
 108     function Op2(X: Root) return String is
 109     begin
 110         return "Parent.Op2 body";
 111     end Op2;
 112
 113     function Call_Op2(X: Root'Class) return String is
 114     begin
 115         return Op2(X);
 116     end Call_Op2;
 117
 118 begin
 119
 120     Check_String(Op1(Root'(Make)), "Parent.Op1 body");
 121     Check_String(Op1(Root_Class(Root'(Make))), "Parent.Op1 body");
 122
 123     Check_String(Op2(Root'(Make)), "Parent.Op2 body");
 124     Check_String(Op2(Root_Class(Root'(Make))), "Parent.Op2 body");
 125
 126 end C731001_1.Parent;
 127
 128 with C731001_1.Parent; use C731001_1.Parent;
 129 private package C731001_1.Unrelated is
 130
 131     type T2 is new Root with null record;
 132     subtype T2_Class is T2'Class;
 133     function Make return T2;
 134     function Op2(X: T2) return String;
 135 end C731001_1.Unrelated;
 136
 137 with C731001_1.Parent; use C731001_1.Parent;
 138     pragma Elaborate(C731001_1.Parent);
 139 package body C731001_1.Unrelated is
 140
 141     function Make return T2 is
 142         Result: T2;
 143     begin
 144         return Result;
 145     end Make;
 146
 147     function Op2(X: T2) return String is
 148     begin
 149         return "Unrelated.Op2 body";
 150     end Op2;
 151 begin
 152
 153     Check_String(Op1(T2'(Make)), "Parent.Op1 body");
 154     Check_String(Op1(T2_Class(T2'(Make))), "Parent.Op1 body");
 155     Check_String(Op1(Root_Class(T2'(Make))), "Parent.Op1 body");
 156
 157     Check_String(Op2(T2'(Make)), "Unrelated.Op2 body");
 158     Check_String(Op2(T2_Class(T2'(Make))), "Unrelated.Op2 body");
 159     Check_String(Call_Op2(T2'(Make)), "Parent.Op2 body");
 160     Check_String(Call_Op2(T2_Class(T2'(Make))), "Parent.Op2 body");
 161     Check_String(Call_Op2(Root_Class(T2'(Make))), "Parent.Op2 body");
 162
 163 end C731001_1.Unrelated;
 164
 165 package C731001_1.Parent.Child is
 166     pragma Elaborate_Body;
 167
 168     type T3 is new Root with null record;
 169     subtype T3_Class is T3'Class;
 170     function Make return T3;
 171
 172     T3_Obj: T3;
 173     T3_Class_Obj: T3_Class := T3_Obj;
 174     T3_Root_Class_Obj: Root_Class := T3_Obj;
 175
 176     X3: constant String :=
 177       Check_String(Op1(T3_Obj), "Parent.Op1 body") &
 178       Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
 179       Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
 180
 181       Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
 182       Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
 183       Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body");
 184
 185     package Nested is
 186         type T4 is new Root with null record;
 187         subtype T4_Class is T4'Class;
 188         function Make return T4;
 189
 190         T4_Obj: T4;
 191         T4_Class_Obj: T4_Class := T4_Obj;
 192         T4_Root_Class_Obj: Root_Class := T4_Obj;
 193
 194         X4: constant String :=
 195           Check_String(Op1(T4_Obj), "Parent.Op1 body") &
 196           Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
 197           Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
 198
 199           Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
 200           Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
 201           Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
 202
 203     private
 204
 205         XX4: constant String :=
 206           Check_String(Op1(T4_Obj), "Parent.Op1 body") &
 207           Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
 208           Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
 209
 210           Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
 211           Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
 212           Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
 213
 214     end Nested;
 215
 216     use Nested;
 217
 218     XXX4: constant String :=
 219       Check_String(Op1(T4_Obj), "Parent.Op1 body") &
 220       Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
 221       Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
 222
 223       Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
 224       Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
 225       Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
 226
 227 private
 228
 229     XX3: constant String :=
 230       Check_String(Op1(T3_Obj), "Parent.Op1 body") &
 231       Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
 232       Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
 233
 234       Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
 235       Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
 236       Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") &
 237
 238       Check_String(Op2(T3_Obj), "Parent.Op2 body") &
 239       Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") &
 240       Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body");
 241
 242     XXXX4: constant String :=
 243       Check_String(Op1(T4_Obj), "Parent.Op1 body") &
 244       Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
 245       Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
 246
 247       Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
 248       Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
 249       Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
 250
 251       Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
 252
 253 end C731001_1.Parent.Child;
 254
 255 with C731001_1.Unrelated; use C731001_1.Unrelated;
 256     pragma Elaborate(C731001_1.Unrelated);
 257 package body C731001_1.Parent.Child is
 258
 259     XXX3: constant String :=
 260       Check_String(Op1(T3_Obj), "Parent.Op1 body") &
 261       Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
 262       Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
 263
 264       Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
 265       Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
 266       Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") &
 267
 268       Check_String(Op2(T3_Obj), "Parent.Op2 body") &
 269       Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") &
 270       Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body");
 271
 272     XXXXX4: constant String :=
 273       Check_String(Op1(T4_Obj), "Parent.Op1 body") &
 274       Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
 275       Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
 276
 277       Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
 278       Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
 279       Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
 280
 281       Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
 282
 283     function Make return T3 is
 284         Result: T3;
 285     begin
 286         return Result;
 287     end Make;
 288
 289     package body Nested is
 290         function Make return T4 is
 291             Result: T4;
 292         begin
 293             return Result;
 294         end Make;
 295
 296         XXXXXX4: constant String :=
 297           Check_String(Op1(T4_Obj), "Parent.Op1 body") &
 298           Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
 299           Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
 300
 301           Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
 302           Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
 303           Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
 304
 305           Check_String(Op2(T4_Obj), "Parent.Op2 body") &
 306           Check_String(Op2(T4_Class_Obj), "Parent.Op2 body") &
 307           Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
 308
 309     end Nested;
 310
 311     type T5 is new T2 with null record;
 312     subtype T5_Class is T5'Class;
 313     function Make return T5;
 314
 315     function Make return T5 is
 316         Result: T5;
 317     begin
 318         return Result;
 319     end Make;
 320
 321     XXXXXXX4: constant String :=
 322       Check_String(Op1(T4_Obj), "Parent.Op1 body") &
 323       Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
 324       Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
 325
 326       Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
 327       Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
 328       Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
 329
 330       Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
 331
 332 end C731001_1.Parent.Child;
 333
 334 procedure C731001_1.Main;
 335
 336 with C731001_1.Parent;
 337 procedure C731001_1.Main is
 338 begin
 339     C731001_1.Parent.Call_Main;
 340 end C731001_1.Main;
 341
 342 with C731001_1.Parent.Child;
 343     use C731001_1.Parent;
 344     use C731001_1.Parent.Child;
 345     use C731001_1.Parent.Child.Nested;
 346 with C731001_1.Unrelated; use C731001_1.Unrelated;
 347 procedure C731001_1.Parent.Main is
 348
 349     Root_Obj: Root := Make;
 350     Root_Class_Obj: Root_Class := Root'(Make);
 351
 352     T2_Obj: T2 := Make;
 353     T2_Class_Obj: T2_Class := T2_Obj;
 354     T2_Root_Class_Obj: Root_Class := T2_Class_Obj;
 355
 356     T3_Obj: T3 := Make;
 357     T3_Class_Obj: T3_Class := T3_Obj;
 358     T3_Root_Class_Obj: Root_Class := T3_Obj;
 359
 360     T4_Obj: T4 := Make;
 361     T4_Class_Obj: T4_Class := T4_Obj;
 362     T4_Root_Class_Obj: Root_Class := T4_Obj;
 363
 364 begin
 365     Test("C731001_1", "Check that inherited operations can be overridden, even"
 366                     & " when they are inherited in a body");
 367
 368     Check_String(Op1(Root_Obj), "Parent.Op1 body");
 369     Check_String(Op1(Root_Class_Obj), "Parent.Op1 body");
 370
 371     Check_String(Call_Op2(Root_Obj), "Parent.Op2 body");
 372     Check_String(Call_Op2(Root_Class_Obj), "Parent.Op2 body");
 373
 374     Check_String(Op1(T2_Obj), "Parent.Op1 body");
 375     Check_String(Op1(T2_Class_Obj), "Parent.Op1 body");
 376     Check_String(Op1(T2_Root_Class_Obj), "Parent.Op1 body");
 377
 378     Check_String(Op2(T2_Obj), "Unrelated.Op2 body");
 379     Check_String(Op2(T2_Class_Obj), "Unrelated.Op2 body");
 380     Check_String(Call_Op2(T2_Obj), "Parent.Op2 body");
 381     Check_String(Call_Op2(T2_Class_Obj), "Parent.Op2 body");
 382     Check_String(Call_Op2(T2_Root_Class_Obj), "Parent.Op2 body");
 383
 384     Check_String(Op1(T3_Obj), "Parent.Op1 body");
 385     Check_String(Op1(T3_Class_Obj), "Parent.Op1 body");
 386     Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body");
 387
 388     Check_String(Call_Op2(T3_Obj), "Parent.Op2 body");
 389     Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body");
 390     Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body");
 391
 392     Check_String(Op1(T4_Obj), "Parent.Op1 body");
 393     Check_String(Op1(T4_Class_Obj), "Parent.Op1 body");
 394     Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body");
 395
 396     Check_String(Call_Op2(T4_Obj), "Parent.Op2 body");
 397     Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body");
 398     Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
 399
 400     Result;
 401 end C731001_1.Parent.Main;
 402
 403 with C731001_1.Main;
 404 procedure C731001 is
 405 begin
 406     C731001_1.Main;
 407 end C731001;