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

   1 -- C380003.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 ACAA 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 per-object expressions are evaluated as specified for
  28 --    protected components.  (Defect Report 8652/0002, as reflected in
  29 --    Technical Corrigendum 1, RM95 3.6(22/1) and 3.8(18/1)).
  30 --
  31 -- CHANGE HISTORY:
  32 --     9 FEB 2001   PHL   Initial version.
  33 --    29 JUN 2002   RLB   Readied for release.
  34 --
  35 --!
  36 with Report;
  37 use Report;
  38 procedure C380003 is
  39
  40     subtype Sm is Integer range 1 .. 10;
  41
  42     type Rec (D1, D2 : Sm) is
  43         record
  44             null;
  45         end record;
  46
  47 begin
  48     Test ("C380003",
  49           "Check compatibility of discriminant expressions" &
  50              " when the constraint depends on discriminants, " &
  51              "and the discriminants have defaults - protected components");
  52
  53     declare
  54         protected type Cons (D3 : Integer := Ident_Int (11)) is
  55             function C1_D1 return Integer;
  56             function C1_D2 return Integer;
  57         private
  58             C1 : Rec (D3, 1);
  59         end Cons;
  60         protected body Cons is
  61             function C1_D1 return Integer is
  62             begin
  63                 return C1.D1;
  64             end C1_D1;
  65             function C1_D2 return Integer is
  66             begin
  67                 return C1.D2;
  68             end C1_D2;
  69         end Cons;
  70
  71         function Is_Ok
  72                     (C : Cons; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer)
  73                     return Boolean is
  74         begin
  75             return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2;
  76         end Is_Ok;
  77
  78     begin
  79         begin
  80             declare
  81                 X : Cons;
  82             begin
  83                 Failed ("Discriminant check not performed - 1");
  84                 if not Is_Ok (X, 1, 1, 1) then
  85                     Comment ("Shouldn't get here");
  86                 end if;
  87             end;
  88         exception
  89             when Constraint_Error =>
  90                 null;
  91             when others =>
  92                 Failed ("Unexpected exception - 1");
  93         end;
  94
  95         begin
  96             declare
  97                 type Acc_Cons is access Cons;
  98                 X : Acc_Cons;
  99             begin
 100                 X := new Cons;
 101                 Failed ("Discriminant check not performed - 2");
 102                 begin
 103                     if not Is_Ok (X.all, 1, 1, 1) then
 104                         Comment ("Irrelevant");
 105                     end if;
 106                 end;
 107             exception
 108                 when Constraint_Error =>
 109                     null;
 110                 when others =>
 111                     Failed ("Unexpected exception raised - 2");
 112             end;
 113         exception
 114             when others =>
 115                 Failed ("Constraint checked too soon - 2");
 116         end;
 117
 118         begin
 119             declare
 120                 subtype Scons is Cons;
 121             begin
 122                 declare
 123                     X : Scons;
 124                 begin
 125                     Failed ("Discriminant check not performed - 3");
 126                     if not Is_Ok (X, 1, 1, 1) then
 127                         Comment ("Irrelevant");
 128                     end if;
 129                 end;
 130             exception
 131                 when Constraint_Error =>
 132                     null;
 133                 when others =>
 134                     Failed ("Unexpected exception raised - 3");
 135             end;
 136         exception
 137             when others =>
 138                 Failed ("Constraint checked too soon - 3");
 139         end;
 140
 141         begin
 142             declare
 143                 type Arr is array (1 .. 5) of Cons;
 144             begin
 145                 declare
 146                     X : Arr;
 147                 begin
 148                     Failed ("Discriminant check not performed - 4");
 149                     for I in Arr'Range loop
 150                         if not Is_Ok (X (I), 1, 1, 1) then
 151                             Comment ("Irrelevant");
 152                         end if;
 153                     end loop;
 154                 end;
 155             exception
 156                 when Constraint_Error =>
 157                     null;
 158                 when others =>
 159                     Failed ("Unexpected exception raised - 4");
 160             end;
 161         exception
 162             when others =>
 163                 Failed ("Constraint checked too soon - 4");
 164         end;
 165
 166         begin
 167             declare
 168                 type Nrec is
 169                     record
 170                         C1 : Cons;
 171                     end record;
 172             begin
 173                 declare
 174                     X : Nrec;
 175                 begin
 176                     Failed ("Discriminant check not performed - 5");
 177                     if not Is_Ok (X.C1, 1, 1, 1) then
 178                         Comment ("Irrelevant");
 179                     end if;
 180                 end;
 181             exception
 182                 when Constraint_Error =>
 183                     null;
 184                 when others =>
 185                     Failed ("Unexpected exception raised - 5");
 186             end;
 187         exception
 188             when others =>
 189                 Failed ("Constraint checked too soon - 5");
 190         end;
 191
 192         begin
 193             declare
 194                 type Drec is new Cons;
 195             begin
 196                 declare
 197                     X : Drec;
 198                 begin
 199                     Failed ("Discriminant check not performed - 6");
 200                     if not Is_Ok (Cons (X), 1, 1, 1) then
 201                         Comment ("Irrelevant");
 202                     end if;
 203                 end;
 204             exception
 205                 when Constraint_Error =>
 206                     null;
 207                 when others =>
 208                     Failed ("Unexpected exception raised - 6");
 209             end;
 210         exception
 211             when others =>
 212                 Failed ("Constraint checked too soon - 6");
 213         end;
 214
 215     end;
 216
 217     Result;
 218
 219 exception
 220     when others =>
 221         Failed ("Constraint check done too early");
 222         Result;
 223 end C380003;