gcc/testsuite/ada/acats/tests/cc/cc1311b.ada

   1 -- CC1311B.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 IF PARAMETERS OF DEFAULT AND FORMAL SUBPROGRAMS HAVE
  27 --     THE SAME TYPE BUT NOT THE SAME SUBTYPE, THE PARAMETER SUBTYPES OF
  28 --     THE SUBPROGRAM DENOTED BY THE DEFAULT ARE USED INSTEAD OF
  29 --     SUBTYPES SPECIFIED IN THE FORMAL SUBPROGRAM DECLARATION.
  30
  31 -- HISTORY:
  32 --     RJW 06/11/86 CREATED ORIGINAL TEST.
  33 --     DHH 10/20/86 CORRECTED RANGE ERRORS.
  34 --     PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
  35 --     PWN 10/27/95 REMOVED CHECKS AGAINST ARRAY SLIDING RULES THAT
  36 --                  HAVE BEEN RELAXED.
  37 --     PWN 10/25/96 RESTORED CHECKS WITH NEW ADA 95 EXPECTED RESULTS.
  38
  39 WITH REPORT; USE REPORT;
  40
  41 PROCEDURE CC1311B IS
  42
  43 BEGIN
  44      TEST ("CC1311B", "CHECK THAT IF PARAMETERS OF DEFAULT AND " &
  45                       "FORMAL SUBPROGRAMS HAVE THE SAME TYPE BUT " &
  46                       "NOT THE SAME SUBTYPE, THE PARAMETER SUBTYPES " &
  47                       "OF THE SUBPROGRAM DENOTED BY THE DEFAULT ARE " &
  48                       "USED INSTEAD OF SUBTYPES SPECIFIED IN THE " &
  49                       "FORMAL SUBPROGRAM DECLARATION" );
  50
  51      DECLARE
  52           TYPE NUMBERS IS (ZERO, ONE ,TWO);
  53           SUBTYPE ZERO_TWO IS NUMBERS;
  54           SUBTYPE ZERO_ONE IS NUMBERS RANGE ZERO .. ONE;
  55
  56           FUNCTION FSUB (X : ZERO_ONE) RETURN ZERO_ONE IS
  57           BEGIN
  58                RETURN NUMBERS'VAL (IDENT_INT (NUMBERS'POS (ONE)));
  59           END FSUB;
  60
  61           GENERIC
  62                WITH FUNCTION F (X : ZERO_TWO := TWO) RETURN ZERO_TWO
  63                     IS FSUB;
  64           FUNCTION FUNC  RETURN ZERO_TWO;
  65
  66           FUNCTION FUNC RETURN ZERO_TWO IS
  67           BEGIN
  68                RETURN F;
  69           EXCEPTION
  70                WHEN CONSTRAINT_ERROR =>
  71                     RETURN ZERO;
  72                WHEN OTHERS =>
  73                     FAILED ( "WRONG EXCEPTION RAISED WITH " &
  74                              "NFUNC1" );
  75                     RETURN ZERO;
  76           END FUNC;
  77
  78           FUNCTION NFUNC1 IS NEW FUNC;
  79
  80      BEGIN
  81           IF NFUNC1 = ONE THEN
  82                FAILED ( "NO EXCEPTION RAISED WITH NFUNC1" );
  83           END IF;
  84      END;
  85
  86      DECLARE
  87           TYPE GENDER IS (MALE, FEMALE);
  88
  89           TYPE PERSON (SEX : GENDER) IS
  90                RECORD
  91                    CASE SEX IS
  92                          WHEN MALE =>
  93                               BEARDED : BOOLEAN;
  94                          WHEN FEMALE =>
  95                               CHILDREN : INTEGER;
  96                     END CASE;
  97                END RECORD;
  98
  99           SUBTYPE MAN IS PERSON (SEX => MALE);
 100           SUBTYPE TESTWRITER IS PERSON (FEMALE);
 101
 102           ROSA : TESTWRITER := (FEMALE, 4);
 103
 104           FUNCTION F (X : MAN) RETURN PERSON IS
 105                TOM : PERSON (MALE) := (MALE, FALSE);
 106           BEGIN
 107                IF EQUAL (3, 3) THEN
 108                     RETURN X;
 109                ELSE
 110                     RETURN TOM;
 111                END IF;
 112           END F;
 113
 114           GENERIC
 115                TYPE T IS PRIVATE;
 116                X1 : T;
 117                WITH FUNCTION F (X : T) RETURN T IS <> ;
 118           PACKAGE PKG IS END PKG;
 119
 120           PACKAGE BODY PKG IS
 121           BEGIN
 122                IF F(X1) = X1 THEN
 123                     FAILED ( "NO EXCEPTION RAISED WITH " &
 124                              "FUNCTION 'F' AND PACKAGE " &
 125                              "'PKG' - 1" );
 126                ELSE
 127                     FAILED ( "NO EXCEPTION RAISED WITH " &
 128                              "FUNCTION 'F' AND PACKAGE " &
 129                              "'PKG' - 2" );
 130                END IF;
 131           EXCEPTION
 132                WHEN CONSTRAINT_ERROR =>
 133                     NULL;
 134                WHEN OTHERS =>
 135                     FAILED ( "WRONG EXCEPTION RAISED WITH " &
 136                              "FUNCTION 'F' AND PACKAGE 'PKG'" );
 137           END PKG;
 138
 139           PACKAGE NPKG IS NEW PKG (TESTWRITER, ROSA);
 140
 141      BEGIN
 142           COMMENT ( "PACKAGE BODY ELABORATED - 1" );
 143      END;
 144
 145      DECLARE
 146           TYPE VECTOR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
 147           SUBTYPE SUBV1 IS VECTOR (1 .. 5);
 148           SUBTYPE SUBV2 IS VECTOR (2 .. 6);
 149
 150           V1 : SUBV1 := (1, 2, 3, 4, 5);
 151
 152           FUNCTION FSUB (Y : SUBV2) RETURN VECTOR IS
 153                Z : SUBV2;
 154           BEGIN
 155                FOR I IN Y'RANGE LOOP
 156                     Z (I) := IDENT_INT (Y (I));
 157                END LOOP;
 158                RETURN Z;
 159           END;
 160
 161           GENERIC
 162            WITH FUNCTION F (X : SUBV1 := V1) RETURN SUBV1 IS FSUB;
 163           PROCEDURE PROC;
 164
 165           PROCEDURE PROC IS
 166           BEGIN
 167                IF F = V1 THEN
 168                     COMMENT ( "NO EXCEPTION RAISED WITH " &
 169                               "FUNCTION 'F' AND PROCEDURE " &
 170                               "'PROC' - 1" );
 171                ELSE
 172                     COMMENT ( "NO EXCEPTION RAISED WITH " &
 173                               "FUNCTION 'F' AND PROCEDURE " &
 174                               "'PROC' - 2" );
 175                END IF;
 176           EXCEPTION
 177                WHEN CONSTRAINT_ERROR =>
 178                     FAILED ( "CONSTRAINT_ERROR RAISED WITH " &
 179                              "FUNCTION 'F' AND PROCEDURE " &
 180                              "'PROC'" );
 181                WHEN OTHERS =>
 182                     FAILED ( "WRONG EXCEPTION RAISED WITH " &
 183                              "FUNCTION 'F' AND PROCEDURE " &
 184                              "'PROC'" );
 185           END PROC;
 186
 187           PROCEDURE NPROC IS NEW PROC;
 188      BEGIN
 189           NPROC;
 190      END;
 191
 192      DECLARE
 193
 194           TYPE ACC IS ACCESS STRING;
 195
 196           SUBTYPE INDEX1 IS INTEGER RANGE 1 .. 5;
 197           SUBTYPE INDEX2 IS INTEGER RANGE 2 .. 6;
 198
 199           SUBTYPE ACC1 IS ACC (INDEX1);
 200           SUBTYPE ACC2 IS ACC (INDEX2);
 201
 202           AC2 : ACC2 := NEW STRING'(2 .. 6 => 'A');
 203           AC  : ACC;
 204
 205           PROCEDURE P (RESULTS : OUT ACC1; X : ACC1) IS
 206           BEGIN
 207                RESULTS := NULL;
 208           END P;
 209
 210           GENERIC
 211            WITH PROCEDURE P1 (RESULTS : OUT ACC2; X : ACC2 := AC2)
 212                     IS P;
 213           FUNCTION FUNC RETURN ACC;
 214
 215           FUNCTION FUNC RETURN ACC IS
 216                RESULTS : ACC;
 217           BEGIN
 218                P1 (RESULTS);
 219                RETURN RESULTS;
 220           EXCEPTION
 221                WHEN CONSTRAINT_ERROR =>
 222                     RETURN NEW STRING'("ABCDE");
 223                WHEN OTHERS =>
 224                     FAILED ( "WRONG EXCEPTION RAISED WITH " &
 225                              "NFUNC2" );
 226                     RETURN NULL;
 227           END FUNC;
 228
 229           FUNCTION NFUNC2 IS NEW FUNC;
 230
 231      BEGIN
 232           AC := NFUNC2;
 233           IF AC = NULL OR ELSE AC.ALL /= "ABCDE" THEN
 234             FAILED ( "NO OR WRONG EXCEPTION RAISED WITH NFUNC2" );
 235           END IF;
 236      END;
 237
 238      DECLARE
 239           SUBTYPE FLOAT1 IS FLOAT RANGE -1.0 .. 0.0;
 240           SUBTYPE FLOAT2 IS FLOAT RANGE  0.0 .. 1.0;
 241
 242           PROCEDURE PSUB (RESULTS : OUT FLOAT2; X : FLOAT2) IS
 243           BEGIN
 244                IF EQUAL (3, 3) THEN
 245                     RESULTS := X;
 246                ELSE
 247                     RESULTS := 0.0;
 248                END IF;
 249           END PSUB;
 250
 251           GENERIC
 252                WITH PROCEDURE P (RESULTS : OUT FLOAT1;
 253                                  X : FLOAT1 := -0.0625) IS PSUB;
 254           PACKAGE PKG IS END PKG;
 255
 256           PACKAGE BODY PKG IS
 257                RESULTS : FLOAT1;
 258           BEGIN
 259                P (RESULTS);
 260                IF RESULTS = 1.0 THEN
 261                     FAILED ( "NO EXCEPTION RAISED WITH " &
 262                              "PROCEDURE 'P' AND PACKAGE " &
 263                              "'PKG' - 1" );
 264                ELSE
 265                     FAILED ( "NO EXCEPTION RAISED WITH " &
 266                              "PROCEDURE 'P' AND PACKAGE " &
 267                              "'PKG' - 2" );
 268                END IF;
 269           EXCEPTION
 270                WHEN CONSTRAINT_ERROR =>
 271                     NULL;
 272                WHEN OTHERS =>
 273                     FAILED ( "WRONG EXCEPTION RAISED WITH " &
 274                              "PROCEDURE 'P' AND PACKAGE 'PKG'" );
 275           END PKG;
 276
 277           PACKAGE NPKG IS NEW PKG;
 278      BEGIN
 279           COMMENT ( "PACKAGE BODY ELABORATED - 2" );
 280      END;
 281
 282      DECLARE
 283           TYPE FIXED IS DELTA 0.125 RANGE -1.0 .. 1.0;
 284           SUBTYPE FIXED1 IS FIXED RANGE -0.5 .. 0.0;
 285           SUBTYPE FIXED2 IS FIXED RANGE  0.0 .. 0.5;
 286
 287           PROCEDURE P (RESULTS : OUT FIXED1; X : FIXED1) IS
 288           BEGIN
 289                IF EQUAL (3, 3) THEN
 290                     RESULTS := X;
 291                ELSE
 292                     RESULTS := X;
 293                END IF;
 294           END P;
 295
 296           GENERIC
 297                TYPE F IS DELTA <>;
 298                F1 : F;
 299                WITH PROCEDURE P (RESULTS : OUT F; X : F) IS <> ;
 300           PROCEDURE PROC;
 301
 302           PROCEDURE PROC IS
 303                RESULTS : F;
 304           BEGIN
 305                P (RESULTS, F1);
 306                IF RESULTS = 0.0 THEN
 307                     FAILED ( "NO EXCEPTION RAISED WITH " &
 308                              "PROCEDURE 'P' AND PROCEDURE " &
 309                              "'PROC' - 1" );
 310                ELSE
 311                     FAILED ( "NO EXCEPTION RAISED WITH " &
 312                              "PROCEDURE 'P' AND PROCEDURE " &
 313                              "'PROC' - 2" );
 314                END IF;
 315           EXCEPTION
 316                WHEN CONSTRAINT_ERROR =>
 317                     NULL;
 318                WHEN OTHERS =>
 319                     FAILED ( "WRONG EXCEPTION RAISED WITH " &
 320                              "PROCEDURE 'P' AND PROCEDURE " &
 321                              "'PROC'" );
 322           END PROC;
 323
 324           PROCEDURE NPROC IS NEW PROC (FIXED2, 0.125);
 325
 326      BEGIN
 327           NPROC;
 328      END;
 329
 330      RESULT;
 331
 332 END CC1311B;