gcc/testsuite/ada/acats/tests/c3/c380004.a

   1 -- C380004.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 entry
  28 --    families and protected components.  (Defect Report 8652/0002,
  29 --    as reflected in Technical Corrigendum 1, RM95 3.6(22/1), 3.8(18/1), and
  30 --    9.5.2(22/1)).
  31 --
  32 -- CHANGE HISTORY:
  33 --     9 FEB 2001   PHL   Initial version.
  34 --    29 JUN 2002   RLB   Readied for release.
  35 --
  36 --!
  37 with Report;
  38 use Report;
  39 procedure C380004 is
  40
  41     type Rec (D1, D2 : Positive) is
  42         record
  43             null;
  44         end record;
  45
  46     F1_Poe : Integer;
  47
  48     function Chk (Poe : Integer; Value : Integer; Message : String)
  49                  return Boolean is
  50     begin
  51         if Poe /= Value then
  52             Failed (Message & ": Poe is " & Integer'Image (Poe));
  53         end if;
  54         return True;
  55     end Chk;
  56
  57     function F1 return Integer is
  58     begin
  59         F1_Poe := F1_Poe - Ident_Int (1);
  60         return F1_Poe;
  61     end F1;
  62
  63     generic
  64         type T is limited private;
  65         with function Is_Ok (X : T;
  66                              Param1 : Integer;
  67                              Param2 : Integer;
  68                              Param3 : Integer) return Boolean;
  69     procedure Check;
  70
  71     procedure Check is
  72     begin
  73
  74         declare
  75             type Poe is new T;
  76             Chk1 : Boolean := Chk (F1_Poe, 17, "F1 evaluated");
  77             X : Poe;             -- F1 evaluated
  78             Y : Poe;             -- F1 evaluated
  79             Chk2 : Boolean := Chk (F1_Poe, 15, "F1 not evaluated");
  80         begin
  81             if not Is_Ok (T (X), 16, 16, 17) or
  82                not Is_Ok (T (Y), 15, 15, 17) then
  83                 Failed ("Discriminant values not correct - 0");
  84             end if;
  85         end;
  86
  87         declare
  88             type Poe is new T;
  89         begin
  90             begin
  91                 declare
  92                     X : Poe;
  93                 begin
  94                     if not Is_Ok (T (X), 14, 14, 17) then
  95                         Failed ("Discriminant values not correct - 1");
  96                     end if;
  97                 end;
  98             exception
  99                 when others =>
 100                     Failed ("Unexpected exception - 1");
 101             end;
 102
 103             declare
 104                 type Acc_Poe is access Poe;
 105                 X : Acc_Poe;
 106             begin
 107                 X := new Poe;
 108                 begin
 109                     if not Is_Ok (T (X.all), 13, 13, 17) then
 110                         Failed ("Discriminant values not correct - 2");
 111                     end if;
 112                 end;
 113             exception
 114                 when others =>
 115                     Failed ("Unexpected exception raised - 2");
 116             end;
 117
 118             declare
 119                 subtype Spoe is Poe;
 120                 X : Spoe;
 121             begin
 122                 if not Is_Ok (T (X), 12, 12, 17) then
 123                     Failed ("Discriminant values not correct - 3");
 124                 end if;
 125             exception
 126                 when others =>
 127                     Failed ("Unexpected exception raised - 3");
 128             end;
 129
 130             declare
 131                 type Arr is array (1 .. 2) of Poe;
 132                 X : Arr;
 133             begin
 134                 if Is_Ok (T (X (1)), 11, 11, 17) and then
 135                    Is_Ok (T (X (2)), 10, 10, 17) then
 136                     null;
 137                 elsif Is_Ok (T (X (2)), 11, 11, 17) and then
 138                       Is_Ok (T (X (1)), 10, 10, 17) then
 139                     null;
 140                 else
 141                     Failed ("Discriminant values not correct - 4");
 142                 end if;
 143             exception
 144                 when others =>
 145                     Failed ("Unexpected exception raised - 4");
 146             end;
 147
 148             declare
 149                 type Nrec is
 150                     record
 151                         C1, C2 : Poe;
 152                     end record;
 153                 X : Nrec;
 154             begin
 155                 if Is_Ok (T (X.C1), 8, 8, 17) and then
 156                    Is_Ok (T (X.C2), 9, 9, 17) then
 157                     null;
 158                 elsif Is_Ok (T (X.C2), 8, 8, 17) and then
 159                       Is_Ok (T (X.C1), 9, 9, 17) then
 160                     null;
 161                 else
 162                     Failed ("Discriminant values not correct - 5");
 163                 end if;
 164             exception
 165                 when others =>
 166                     Failed ("Unexpected exception raised - 5");
 167             end;
 168
 169             declare
 170                 type Drec is new Poe;
 171                 X : Drec;
 172             begin
 173                 if not Is_Ok (T (X), 7, 7, 17) then
 174                     Failed ("Discriminant values not correct - 6");
 175                 end if;
 176             exception
 177                 when others =>
 178                     Failed ("Unexpected exception raised - 6");
 179             end;
 180         end;
 181     end Check;
 182
 183
 184 begin
 185     Test ("C380004",
 186           "Check evaluation of discriminant expressions " &
 187              "when the constraint depends on a discriminant, " &
 188              "and the discriminants have defaults - discriminant-dependent" &
 189              "entry families and protected components");
 190
 191
 192     Comment ("Discriminant-dependent entry families for task types");
 193
 194     F1_Poe := 18;
 195
 196     declare
 197         task type Poe (D3 : Positive := F1) is
 198             entry E (D3 .. F1);    -- F1 evaluated
 199             entry Is_Ok (D3 : Integer;
 200                          E_First : Integer;
 201                          E_Last : Integer;
 202                          Ok : out Boolean);
 203         end Poe;
 204         task body Poe is
 205         begin
 206             loop
 207                 select
 208                     accept Is_Ok (D3 : Integer;
 209                                   E_First : Integer;
 210                                   E_Last : Integer;
 211                                   Ok : out Boolean) do
 212                         declare
 213                             Cnt : Natural;
 214                         begin
 215                             if Poe.D3 = D3 then
 216                                 -- Can't think of a better way to check the
 217                                 -- bounds of the entry family.
 218                                 begin
 219                                     Cnt := E (E_First)'Count;
 220                                     Cnt := E (E_Last)'Count;
 221                                 exception
 222                                     when Constraint_Error =>
 223                                         Ok := False;
 224                                         return;
 225                                 end;
 226                                 begin
 227                                     Cnt := E (E_First - 1)'Count;
 228                                     Ok := False;
 229                                     return;
 230                                 exception
 231                                     when Constraint_Error =>
 232                                         null;
 233                                     when others =>
 234                                         Ok := False;
 235                                         return;
 236                                 end;
 237                                 begin
 238                                     Cnt := E (E_Last + 1)'Count;
 239                                     Ok := False;
 240                                     return;
 241                                 exception
 242                                     when Constraint_Error =>
 243                                         null;
 244                                     when others =>
 245                                         Ok := False;
 246                                         return;
 247                                 end;
 248                                 Ok := True;
 249                             else
 250                                 Ok := False;
 251                                 return;
 252                             end if;
 253                         end;
 254                     end Is_Ok;
 255                 or
 256                     terminate;
 257                 end select;
 258             end loop;
 259         end Poe;
 260
 261         function Is_Ok
 262                     (C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer)
 263                     return Boolean is
 264             Ok : Boolean;
 265         begin
 266             C.Is_Ok (D3, E_First, E_Last, Ok);
 267             return Ok;
 268         end Is_Ok;
 269
 270         procedure Chk is new Check (Poe, Is_Ok);
 271
 272     begin
 273         Chk;
 274     end;
 275
 276
 277     Comment ("Discriminant-dependent entry families for protected types");
 278
 279     F1_Poe := 18;
 280
 281     declare
 282         protected type Poe (D3 : Integer := F1) is
 283             entry E (D3 .. F1);    -- F1 evaluated
 284             function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer)
 285                            return Boolean;
 286         end Poe;
 287         protected body Poe is
 288             entry E (for I in D3 .. F1) when True is
 289             begin
 290                 null;
 291             end E;
 292             function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer)
 293                            return Boolean is
 294                 Cnt : Natural;
 295             begin
 296                 if Poe.D3 = D3 then
 297                     -- Can't think of a better way to check the
 298                     -- bounds of the entry family.
 299                     begin
 300                         Cnt := E (E_First)'Count;
 301                         Cnt := E (E_Last)'Count;
 302                     exception
 303                         when Constraint_Error =>
 304                             return False;
 305                     end;
 306                     begin
 307                         Cnt := E (E_First - 1)'Count;
 308                         return False;
 309                     exception
 310                         when Constraint_Error =>
 311                             null;
 312                         when others =>
 313                             return False;
 314                     end;
 315                     begin
 316                         Cnt := E (E_Last + 1)'Count;
 317                         return False;
 318                     exception
 319                         when Constraint_Error =>
 320                             null;
 321                         when others =>
 322                             return False;
 323                     end;
 324                     return True;
 325                 else
 326                     return False;
 327                 end if;
 328             end Is_Ok;
 329         end Poe;
 330
 331         function Is_Ok
 332                     (C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer)
 333                     return Boolean is
 334         begin
 335             return C.Is_Ok (D3, E_First, E_Last);
 336         end Is_Ok;
 337
 338         procedure Chk is new Check (Poe, Is_Ok);
 339
 340     begin
 341         Chk;
 342     end;
 343
 344     Comment ("Protected components");
 345
 346     F1_Poe := 18;
 347
 348     declare
 349         protected type Poe (D3 : Integer := F1) is
 350             function C1_D1 return Integer;
 351             function C1_D2 return Integer;
 352         private
 353             C1 : Rec (D3, F1);    -- F1 evaluated
 354         end Poe;
 355         protected body Poe is
 356             function C1_D1 return Integer is
 357             begin
 358                 return C1.D1;
 359             end C1_D1;
 360             function C1_D2 return Integer is
 361             begin
 362                 return C1.D2;
 363             end C1_D2;
 364         end Poe;
 365
 366         function Is_Ok (C : Poe; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer)
 367                        return Boolean is
 368         begin
 369             return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2;
 370         end Is_Ok;
 371
 372         procedure Chk is new Check (Poe, Is_Ok);
 373
 374     begin
 375         Chk;
 376     end;
 377
 378     Result;
 379
 380 exception
 381     when others =>
 382         Failed ("Unexpected exception");
 383         Result;
 384
 385 end C380004;