gomp-20050608-branch/gcc/testsuite/ada/acats/tests/c3/c392014.a

   1 -- C392014.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     The Ada Conformity Assessment Authority (ACAA) holds unlimited
   6 --     rights in the software and documentation contained herein. Unlimited
   7 --     rights are the same as those granted by the U.S. Government for older
   8 --     parts of the Ada Conformity Assessment Test Suite, and are defined
   9 --     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
  10 --     intends to confer upon all recipients unlimited rights equal to those
  11 --     held by the ACAA. These rights include rights to use, duplicate,
  12 --     release or disclose the released technical data and computer software
  13 --     in whole or in part, in any manner and for any purpose whatsoever, and
  14 --     to have or permit others 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 objects designated by X'Access (where X is of a class-wide
  28 --    type) and new T'Class'(...) are dynamically tagged and can be used in
  29 --    dispatching calls.  (Defect Report 8652/0010).
  30 --
  31 -- CHANGE HISTORY:
  32 --    18 JAN 2001   PHL   Initial version
  33 --    15 MAR 2001   RLB   Readied for release.
  34 --    03 JUN 2004   RLB   Removed constraint for S0, as the subtype has
  35 --                        unknown discriminants.
  36
  37 --!
  38 package C392014_0 is
  39
  40     type T (D : Integer) is abstract tagged private;
  41
  42     procedure P (X : access T) is abstract;
  43     function Create (X : Integer) return T'Class;
  44
  45     Result : Natural := 0;
  46
  47 private
  48     type T (D : Integer) is abstract tagged null record;
  49 end C392014_0;
  50
  51 with C392014_0;
  52 package C392014_1 is
  53     type T is new C392014_0.T with private;
  54     function Create (X : Integer) return T'Class;
  55 private
  56     type T is new C392014_0.T with
  57         record
  58             C1 : Integer;
  59         end record;
  60     procedure P (X : access T);
  61 end C392014_1;
  62
  63 package C392014_1.Child is
  64     type T is new C392014_1.T with private;
  65     procedure P (X : access T);
  66     function Create (X : Integer) return T'Class;
  67 private
  68     type T is new C392014_1.T with
  69         record
  70             C1C : Integer;
  71         end record;
  72 end C392014_1.Child;
  73
  74 with Report;
  75 use Report;
  76 with C392014_1.Child;
  77 package body C392014_1 is
  78
  79     procedure P (X : access T) is
  80     begin
  81         C392014_0.Result := C392014_0.Result + X.D + X.C1;
  82     end P;
  83
  84     function Create (X : Integer) return T'Class is
  85     begin
  86         case X mod Ident_Int (2) is
  87             when 0 =>
  88                 return C392014_1.Child.Create (X / Ident_Int (2));
  89             when 1 =>
  90                 declare
  91                     Y : T (D => (X / Ident_Int (2)) mod Ident_Int (20));
  92                 begin
  93                     Y.C1 := X / Ident_Int (40);
  94                     return T'Class (Y);
  95                 end;
  96             when others =>
  97                 null;
  98         end case;
  99     end Create;
 100
 101 end C392014_1;
 102
 103 with C392014_0;
 104 with C392014_1;
 105 package C392014_2 is
 106     type T is new C392014_0.T with private;
 107     function Create (X : Integer) return T'Class;
 108 private
 109     type T is new C392014_1.T with
 110         record
 111             C2 : Integer;
 112         end record;
 113     procedure P (X : access T);
 114 end C392014_2;
 115
 116 with Report;
 117 use Report;
 118 with C392014_1.Child;
 119 with C392014_2;
 120 package body C392014_0 is
 121
 122     function Create (X : Integer) return T'Class is
 123     begin
 124         case X mod 3 is
 125             when 0 =>
 126                 return C392014_1.Create (X / Ident_Int (3));
 127             when 1 =>
 128                 return C392014_1.Child.Create (X / Ident_Int (3));
 129             when 2 =>
 130                 return C392014_2.Create (X / Ident_Int (3));
 131             when others =>
 132                 null;
 133         end case;
 134     end Create;
 135
 136 end C392014_0;
 137
 138 with Report;
 139 use Report;
 140 with C392014_0;
 141 package body C392014_1.Child is
 142
 143     procedure P (X : access T) is
 144     begin
 145         C392014_0.Result := C392014_0.Result + X.D + X.C1 + X.C1C;
 146     end P;
 147
 148     function Create (X : Integer) return T'Class is
 149         Y : T (D => X mod Ident_Int (20));
 150     begin
 151         Y.C1 := (X / Ident_Int (20)) mod Ident_Int (20);
 152         Y.C1C := X / Ident_Int (400);
 153         return T'Class (Y);
 154     end Create;
 155
 156 end C392014_1.Child;
 157
 158 with Report;
 159 use Report;
 160 package body C392014_2 is
 161
 162     procedure P (X : access T) is
 163     begin
 164         C392014_0.Result := C392014_0.Result + X.D + X.C2;
 165     end P;
 166
 167     function Create (X : Integer) return T'Class is
 168         Y : T (D => X mod Ident_Int (20));
 169     begin
 170         Y.C2 := X / Ident_Int (600);
 171         return T'Class (Y);
 172     end Create;
 173
 174 end C392014_2;
 175
 176 with Report;
 177 use Report;
 178 with C392014_0;
 179 with C392014_1.Child;
 180 with C392014_2;
 181 procedure C392014 is
 182
 183     subtype S0 is C392014_0.T'Class;
 184     subtype S1 is C392014_1.T'Class;
 185
 186     X0 : aliased C392014_0.T'Class := C392014_0.Create (Ident_Int (5218));
 187     X1 : aliased C392014_1.T'Class := C392014_1.Create (Ident_Int (8253));
 188
 189     Y0 : aliased S0 := C392014_0.Create (Ident_Int (2693));
 190     Y1 : aliased S1 := C392014_1.Create (Ident_Int (5622));
 191
 192     procedure TC_Check (Subtest : String; Expected : Integer) is
 193     begin
 194         if C392014_0.Result = Expected then
 195             Comment ("Subtest " & Subtest & " Passed");
 196         else
 197             Failed ("Subtest " & Subtest & " Failed");
 198         end if;
 199         C392014_0.Result := Ident_Int (0);
 200     end TC_Check;
 201
 202 begin
 203     Test ("C392014",
 204           "Check that objects designated by X'Access " &
 205              "(where X is of a class-wide type) and New T'Class'(...) " &
 206              "are dynamically tagged and can be used in dispatching " &
 207              "calls");
 208
 209     C392014_0.P (X0'Access);
 210     TC_Check ("X0'Access", Ident_Int (29));
 211     C392014_0.P (new C392014_0.T'Class'(C392014_0.Create (Ident_Int (12850))));
 212     TC_Check ("New C392014_0.T'Class", Ident_Int (27));
 213     C392014_1.P (X1'Access);
 214     TC_Check ("X1'Access", Ident_Int (212));
 215     C392014_1.P (new C392014_1.T'Class'(C392014_1.Create (Ident_Int (2031))));
 216     TC_Check ("New C392014_1.T'Class", Ident_Int (65));
 217     C392014_0.P (Y0'Access);
 218     TC_Check ("Y0'Access", Ident_Int (18));
 219     C392014_0.P (new S0'(C392014_0.Create (Ident_Int (6893))));
 220     TC_Check ("New S0", Ident_Int (20));
 221     C392014_1.P (Y1'Access);
 222     TC_Check ("Y1'Access", Ident_Int (18));
 223     C392014_1.P (new S1'(C392014_1.Create (Ident_Int (1861))));
 224     TC_Check ("New S1", Ident_Int (56));
 225
 226     Result;
 227 end C392014;