old-autovect-branch/gcc/testsuite/ada/acats/tests/c6/c64103b.ada

   1 -- C64103B.ADA
   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 -- OBJECTIVE:
  26 --     CHECK THAT, FOR IN-OUT PARAMETERS OF A SCALAR TYPE,
  27 --     CONSTRAINT_ERROR IS RAISED:
  28 --          BEFORE A SUBPROGRAM CALL WHEN THE CONVERTED ACTUAL
  29 --          PARAMETER IS OUTSIDE THE RANGE OF THE FORMAL PARAMETER'S
  30 --          SUBTYPE;
  31 --          AFTER A SUBPROGRAM CALL WHEN THE CONVERTED FORMAL PARAMETER
  32 --          IS OUTSIDE THE RANGE OF THE ACTUAL PARAMETER'S SUBTYPE.
  33
  34 -- HISTORY:
  35 --     CPP  07/18/84  CREATED ORIGINAL TEST.
  36 --     VCL  10/27/87  MODIFIED THIS HEADER; ADDED STATEMENTS WHICH
  37 --                    REFERENCED THE ACTUAL PARAMETERS IN THE SECOND
  38 --                    SUBTEST.
  39
  40 WITH REPORT;  USE REPORT;
  41 PROCEDURE C64103B IS
  42 BEGIN
  43      TEST ("C64103B", "FOR IN-OUT PARAMETERS OF A SCALAR TYPE, " &
  44                       "CONSTRAINT_ERROR IS RAISED:  BEFORE A " &
  45                       "SUBPROGRAM CALL WHEN THE CONVERTED ACTUAL " &
  46                       "PARAMETER IS OUTSIDE THE RANGE OF THE FORMAL " &
  47                       "PARAMETER'S SUBTYPE;  AFTER A SUBPROGRAM " &
  48                       "CALL WHEN THE CONVERTED FORMAL PARAMETER IS " &
  49                       "OUTSIDE THE RANGE OF THE ACTUAL PARAMETER'S " &
  50                       "SUBTYPE");
  51
  52
  53      DECLARE
  54           A0 : INTEGER := -9;
  55           A1 : INTEGER := IDENT_INT(-1);
  56           TYPE SUBINT IS RANGE -8 .. -2;
  57
  58           TYPE FLOAT_TYPE IS DIGITS 3 RANGE 0.0 .. 3.0;
  59           A2 : FLOAT_TYPE := 0.12;
  60           A3 : FLOAT_TYPE := 2.5;
  61           TYPE NEW_FLOAT IS DIGITS 3 RANGE 1.0 .. 2.0;
  62
  63           TYPE FIXED_TYPE IS DELTA 1.0 RANGE -2.0 .. 5.0;
  64           A4 : FIXED_TYPE := -2.0;
  65           A5 : FIXED_TYPE := 4.0;
  66           TYPE NEW_FIXED IS DELTA 1.0 RANGE -1.0 .. 3.0;
  67
  68           A6 : CHARACTER := 'A';
  69           SUBTYPE SUPER_CHAR IS CHARACTER RANGE 'B'..'Q';
  70
  71           TYPE COLOR IS (RED, BURGUNDY, LILAC, MAROON, MAGENTA);
  72           SUBTYPE A_COLOR IS COLOR RANGE RED..LILAC;
  73           SUBTYPE B_COLOR IS COLOR RANGE MAROON..MAGENTA;
  74           A7 : B_COLOR := MAROON;
  75
  76           PROCEDURE P1 (X : IN OUT SUBINT;
  77                         S :        STRING) IS
  78           BEGIN
  79                FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (A" &
  80                        S & ")");
  81           END P1;
  82
  83           PROCEDURE P2 (X : IN OUT NEW_FLOAT;
  84                         S :        STRING)     IS
  85           BEGIN
  86                FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P2 (A" &
  87                        S & ")");
  88           END P2;
  89
  90           PROCEDURE P3 (X : IN OUT NEW_FIXED;
  91                         S :        STRING)     IS
  92           BEGIN
  93                FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P3 (A" &
  94                        S & ")");
  95           END P3;
  96
  97           PROCEDURE P4 (X : IN OUT SUPER_CHAR;
  98                         S :        STRING)     IS
  99           BEGIN
 100                FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P4 (A" &
 101                         S & ")");
 102           END P4;
 103
 104           PROCEDURE P5 (X : IN OUT A_COLOR;
 105                         S :        STRING) IS
 106           BEGIN
 107                FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P5 (A" &
 108                        S & ")");
 109           END P5;
 110      BEGIN
 111           BEGIN
 112                P1 (SUBINT (A0), "1");
 113           EXCEPTION
 114                WHEN CONSTRAINT_ERROR =>
 115                     NULL;
 116                WHEN OTHERS =>
 117                     FAILED ("WRONG EXCEPTION RAISED -P1 (A1)");
 118           END;
 119
 120           BEGIN
 121                P1 (SUBINT (A1), "2");
 122           EXCEPTION
 123                WHEN CONSTRAINT_ERROR =>
 124                     NULL;
 125                WHEN OTHERS =>
 126                     FAILED ("WRONG EXCEPTION RAISED -P1 (A2)");
 127           END;
 128
 129           BEGIN
 130                P2 (NEW_FLOAT (A2), "1");
 131           EXCEPTION
 132                WHEN CONSTRAINT_ERROR =>
 133                     NULL;
 134                WHEN OTHERS =>
 135                     FAILED ("WRONG EXCEPTION RAISED -P2 (A1)");
 136           END;
 137
 138           BEGIN
 139                P2 (NEW_FLOAT (A3), "2");
 140           EXCEPTION
 141                WHEN CONSTRAINT_ERROR =>
 142                     NULL;
 143                WHEN OTHERS =>
 144                     FAILED ("WRONG EXCEPTION RAISED -P2 (A2)");
 145           END;
 146
 147           BEGIN
 148                P3 (NEW_FIXED (A4), "1");
 149           EXCEPTION
 150                WHEN CONSTRAINT_ERROR =>
 151                     NULL;
 152                WHEN OTHERS =>
 153                     FAILED ("WRONG EXCEPTION RAISED -P3 (A1)");
 154           END;
 155
 156           BEGIN
 157                P3 (NEW_FIXED (A5), "2");
 158           EXCEPTION
 159                WHEN CONSTRAINT_ERROR =>
 160                     NULL;
 161                WHEN OTHERS =>
 162                     FAILED ("WRONG EXCEPTION RAISED -P3 (A2)");
 163           END;
 164
 165           BEGIN
 166                P4 (SUPER_CHAR (A6),"1");
 167           EXCEPTION
 168                WHEN CONSTRAINT_ERROR =>
 169                     NULL;
 170                WHEN OTHERS =>
 171                     FAILED ("WRONG EXCEPTION RAISED -P4 (A1)");
 172           END;
 173
 174           BEGIN
 175                P5 (A_COLOR (A7), "1");
 176           EXCEPTION
 177                WHEN CONSTRAINT_ERROR =>
 178                     NULL;
 179                WHEN OTHERS =>
 180                     FAILED ("WRONG EXCEPTION RAISED -P5 (A1)");
 181           END;
 182      END;
 183
 184
 185      DECLARE
 186           CALLED : BOOLEAN;
 187           TYPE SUBINT IS RANGE -8 .. -2;
 188           A0 : SUBINT := -3;
 189           A1 : INTEGER := -9;
 190           A2 : INTEGER := -1;
 191
 192           TYPE FLOAT IS DIGITS 3 RANGE -1.0 .. 2.0;
 193           TYPE A_FLOAT IS DIGITS 3 RANGE 0.0 .. 1.0;
 194           A3 : A_FLOAT := 1.0;
 195           A4 : FLOAT := -0.5;
 196           A5 : FLOAT := 1.5;
 197
 198           TYPE NEW_FIXED IS DELTA 1.0 RANGE -1.0 .. 3.0;
 199           A6 : NEW_FIXED := 0.0;
 200           TYPE FIXED_TYPE IS DELTA 1.0 RANGE -2.0 .. 5.0;
 201           A7 : FIXED_TYPE := -2.0;
 202           A8 : FIXED_TYPE := 4.0;
 203
 204           SUBTYPE SUPER_CHAR IS CHARACTER RANGE 'B'..'Q';
 205           A9  : SUPER_CHAR := 'C';
 206           A10 : CHARACTER := 'A';
 207           A11 : CHARACTER := 'R';
 208
 209           PROCEDURE P1 (X : IN OUT INTEGER; Y : INTEGER) IS
 210           BEGIN
 211                CALLED := TRUE;
 212                X := IDENT_INT (Y);
 213           END P1;
 214
 215           PROCEDURE P2 (X : IN OUT FLOAT; Y : FLOAT) IS
 216           BEGIN
 217                CALLED := TRUE;
 218                X := Y;
 219           END P2;
 220
 221           PROCEDURE P3 ( X : IN OUT FIXED_TYPE; Y : FIXED_TYPE) IS
 222           BEGIN
 223                CALLED := TRUE;
 224                X := Y;
 225           END P3;
 226
 227           PROCEDURE P4 (X : IN OUT CHARACTER; Y : CHARACTER) IS
 228           BEGIN
 229                CALLED := TRUE;
 230                X := IDENT_CHAR(Y);
 231           END P4;
 232      BEGIN
 233           BEGIN
 234                CALLED := FALSE;
 235                P1 (INTEGER(A0), A1);
 236                IF A0 = -3 THEN
 237                     FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B1)");
 238                ELSE
 239                     FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B2)");
 240                END IF;
 241           EXCEPTION
 242                WHEN CONSTRAINT_ERROR =>
 243                     IF NOT CALLED THEN
 244                          FAILED ("EXCEPTION RAISED BEFORE CALL " &
 245                                  "-P1 (B1)");
 246                     END IF;
 247                WHEN OTHERS =>
 248                     FAILED ("WRONG EXCEPTION RAISED -P1 (B1)");
 249           END;
 250
 251           BEGIN
 252                CALLED := FALSE;
 253                P1 (INTEGER(A0), A2);
 254                IF A0 = -3 THEN
 255                     FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B3)");
 256                ELSE
 257                     FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B4)");
 258                END IF;
 259           EXCEPTION
 260                WHEN CONSTRAINT_ERROR =>
 261                     IF NOT CALLED THEN
 262                          FAILED ("EXCEPTION RAISED BEFORE CALL " &
 263                                  "-P1 (B2)");
 264                     END IF;
 265                WHEN OTHERS =>
 266                     FAILED ("WRONG EXCEPTION RAISED -P1 (B2)");
 267           END;
 268
 269           BEGIN
 270                CALLED := FALSE;
 271                P2 (FLOAT (A3), A4);
 272                IF A3 = 1.0 THEN
 273                     FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (B1)");
 274                ELSE
 275                     FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (B2)");
 276                END IF;
 277           EXCEPTION
 278                WHEN CONSTRAINT_ERROR =>
 279                     IF NOT CALLED THEN
 280                          FAILED ("EXCEPTION RAISED BEFORE CALL " &
 281                                  "-P2 (B1)");
 282                     END IF;
 283                WHEN OTHERS =>
 284                     FAILED ("WRONG EXCEPTION RAISED -P2 (B1)");
 285           END;
 286
 287           BEGIN
 288                CALLED := FALSE;
 289                P2 (FLOAT (A3), A5);
 290                IF A3 = 1.0 THEN
 291                     FAILED ("EXCEPTION NOT RAISED -P2 (B3)");
 292                ELSE
 293                     FAILED ("EXCEPTION NOT RAISED -P2 (B4)");
 294                END IF;
 295           EXCEPTION
 296                WHEN CONSTRAINT_ERROR =>
 297                     IF NOT CALLED THEN
 298                          FAILED ("EXCEPTION RAISED BEFORE CALL " &
 299                                  "-P2 (B2)");
 300                     END IF;
 301                WHEN OTHERS =>
 302                     FAILED ("WRONG EXCEPTION RAISED -P2 (B2)");
 303           END;
 304
 305           BEGIN
 306                CALLED := FALSE;
 307                P3 (FIXED_TYPE (A6), A7);
 308                IF A6 = 0.0 THEN
 309                     FAILED ("EXCEPTION NOT RAISED -P3 (B1)");
 310                ELSE
 311                     FAILED ("EXCEPTION NOT RAISED -P3 (B2)");
 312                END IF;
 313           EXCEPTION
 314                WHEN CONSTRAINT_ERROR =>
 315                     IF NOT CALLED THEN
 316                          FAILED ("EXCEPTION RAISED BEFORE CALL " &
 317                                  "-P3 (B1)");
 318                     END IF;
 319                WHEN OTHERS =>
 320                     FAILED ("WRONG EXCEPTION RAISED -P3 (B1)");
 321           END;
 322
 323           BEGIN
 324                CALLED := FALSE;
 325                P3 (FIXED_TYPE (A6), A8);
 326                IF A6 = 0.0 THEN
 327                     FAILED ("EXCEPTION NOT RAISED -P3 (B3)");
 328                ELSE
 329                     FAILED ("EXCEPTION NOT RAISED -P3 (B4)");
 330                END IF;
 331           EXCEPTION
 332                WHEN CONSTRAINT_ERROR =>
 333                     IF NOT CALLED THEN
 334                          FAILED ("EXCEPTION RAISED BEFORE CALL " &
 335                                  "-P3 (B2)");
 336                     END IF;
 337                WHEN OTHERS =>
 338                     FAILED ("WRONG EXCEPTION RAISED -P3 (B2)");
 339           END;
 340
 341           BEGIN
 342                CALLED := FALSE;
 343                P4 (CHARACTER (A9), A10);
 344                IF A9 = 'C' THEN
 345                     FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B1)");
 346                ELSE
 347                     FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B2)");
 348                END IF;
 349           EXCEPTION
 350                WHEN CONSTRAINT_ERROR =>
 351                     IF NOT CALLED THEN
 352                          FAILED ("EXCEPTION RAISED BEFORE CALL " &
 353                                  "-P4 (B1)");
 354                     END IF;
 355                WHEN OTHERS =>
 356                     FAILED ("WRONG EXCEPTION RAISED -P4 (B1)");
 357           END;
 358
 359           BEGIN
 360                CALLED := FALSE;
 361                P4 (CHARACTER (A9), A11);
 362                IF A9 = 'C' THEN
 363                     FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B3)");
 364                ELSE
 365                     FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B4)");
 366                END IF;
 367           EXCEPTION
 368                WHEN CONSTRAINT_ERROR =>
 369                     IF NOT CALLED THEN
 370                          FAILED ("EXCEPTION RAISED BEFORE CALL " &
 371                                  "-P4 (B2)");
 372                     END IF;
 373                WHEN OTHERS =>
 374                     FAILED ("WRONG EXCEPTION RAISED -P4 (B2)");
 375           END;
 376      END;
 377
 378      RESULT;
 379 END C64103B;