old-autovect-branch/gcc/testsuite/ada/acats/tests/c3/c35507k.ada

   1 -- C35507K.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 THE ATTRIBUTES 'POS' AND 'VAL' YIELD THE CORRECT
  27 --     RESULTS WHEN THE PREFIX IS A CHARACTER TYPE.
  28
  29 -- HISTORY:
  30 --     RJW 06/03/86
  31 --     JLH 07/28/87  MODIFIED FUNCTION IDENT.
  32 -- PWN 11/30/94 REMOVED PART OF TEST INVALID FOR ADA 9X.
  33
  34 WITH REPORT; USE REPORT;
  35
  36 PROCEDURE  C35507K  IS
  37
  38      TYPE CHAR IS ('A', B);
  39
  40      TYPE NEWCHAR IS NEW CHAR;
  41
  42      SUBTYPE SCHAR IS CHARACTER
  43              RANGE CHARACTER'VAL (127) .. CHARACTER'VAL (127);
  44
  45      BLANK : CONSTANT CHARACTER := ' ';
  46
  47      POSITION : INTEGER;
  48
  49      NONGRAPH : ARRAY (0 .. 31) OF CHARACTER :=
  50           (ASCII.NUL, ASCII.SOH, ASCII.STX, ASCII.ETX,
  51            ASCII.EOT, ASCII.ENQ, ASCII.ACK, ASCII.BEL,
  52            ASCII.BS,  ASCII.HT,  ASCII.LF,  ASCII.VT,
  53            ASCII.FF,  ASCII.CR,  ASCII.SO,  ASCII.SI,
  54            ASCII.DLE, ASCII.DC1, ASCII.DC2, ASCII.DC3,
  55            ASCII.DC4, ASCII.NAK, ASCII.SYN, ASCII.ETB,
  56            ASCII.CAN, ASCII.EM,  ASCII.SUB, ASCII.ESC,
  57            ASCII.FS,  ASCII.GS,  ASCII.RS,  ASCII.US);
  58
  59      FUNCTION IDENT (CH : CHAR) RETURN CHAR IS
  60      BEGIN
  61           IF EQUAL (CHAR'POS (CH), CHAR'POS (CH)) THEN
  62                RETURN CH;
  63           END IF;
  64           RETURN CHAR'FIRST;
  65      END IDENT;
  66
  67      FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS
  68      BEGIN
  69           IF EQUAL (NEWCHAR'POS (CH), NEWCHAR'POS (CH)) THEN
  70                RETURN CH;
  71           END IF;
  72           RETURN NEWCHAR'FIRST;
  73      END IDENT;
  74
  75 BEGIN
  76
  77      TEST( "C35507K" , "CHECK THAT THE ATTRIBUTES 'POS' AND " &
  78                        "'VAL' YIELD THE CORRECT RESULTS WHEN THE " &
  79                        "PREFIX IS A CHARACTER TYPE" );
  80
  81      BEGIN
  82           IF CHAR'POS ('A') /= 0 THEN
  83                FAILED ( "INCORRECT VALUE FOR CHAR'POS('A') - 1" );
  84           END IF;
  85
  86           IF CHAR'POS (B) /= 1 THEN
  87                FAILED ( "INCORRECT VALUE FOR CHAR'POS(B) - 1" );
  88           END IF;
  89
  90           IF CHAR'VAL (0) /= 'A' THEN
  91                FAILED ( "INCORRECT VALUE FOR CHAR'VAL(0)" );
  92           END IF;
  93
  94           IF CHAR'VAL (1) /= B THEN
  95                FAILED ( "INCORRECT VALUE FOR CHAR'VAL(1)" );
  96           END IF;
  97
  98           IF CHAR'POS (IDENT ('A')) /= 0 THEN
  99                FAILED ( "INCORRECT VALUE " &
 100                         "FOR CHAR'POS (IDENT ('A')) - 2" );
 101           END IF;
 102
 103           IF CHAR'POS (IDENT (B)) /= 1 THEN
 104                FAILED ( "INCORRECT VALUE " &
 105                         "FOR CHAR'POS (IDENT (B)) - 2" );
 106           END IF;
 107
 108      END;
 109
 110      BEGIN
 111           IF NEWCHAR'POS ('A') /= 0 THEN
 112                FAILED ( "INCORRECT VALUE FOR NEWCHAR'POS('A')" );
 113           END IF;
 114
 115           IF NEWCHAR'POS (B) /= 1 THEN
 116                FAILED ( "INCORRECT VALUE FOR NEWCHAR'POS(B) - 1" );
 117           END IF;
 118
 119           IF NEWCHAR'VAL (0) /= 'A' THEN
 120                FAILED ( "INCORRECT VALUE FOR NEWCHAR'VAL(0) - 1" );
 121           END IF;
 122
 123           IF NEWCHAR'VAL (1) /= B THEN
 124                FAILED ( "INCORRECT VALUE FOR NEWCHAR'VAL(1)" );
 125           END IF;
 126
 127           IF NEWCHAR'VAL (IDENT_INT (1)) /= B THEN
 128                FAILED ( "INCORRECT VALUE " &
 129                         "FOR NEWCHAR'POS (IDENT (B)) - 2" );
 130           END IF;
 131
 132           IF (NEWCHAR'VAL (IDENT_INT(0))) /= 'A' THEN
 133                FAILED ( "INCORRECT VALUE " &
 134                         "FOR IDENT (NEWCHAR'VAL (0)) - 2" );
 135           END IF;
 136
 137      END;
 138
 139      BEGIN
 140           IF CHAR'VAL (IDENT_INT (2)) = B THEN
 141                FAILED ( "NO EXCEPTION RAISED " &
 142                         "FOR CHAR'VAL (IDENT_INT (2)) - 1" );
 143           ELSE
 144                FAILED ( "NO EXCEPTION RAISED " &
 145                         "FOR CHAR'VAL (IDENT_INT (2)) - 2" );
 146           END IF;
 147      EXCEPTION
 148           WHEN CONSTRAINT_ERROR =>
 149                NULL;
 150           WHEN OTHERS =>
 151                FAILED ( "WRONG EXCEPTION RAISED " &
 152                          "FOR CHAR'VAL (IDENT_INT (2))" );
 153      END;
 154
 155      BEGIN
 156           IF NEWCHAR'VAL (IDENT_INT (-1)) = 'A' THEN
 157                FAILED ( "NO EXCEPTION RAISED " &
 158                         "FOR NEWCHAR'VAL (IDENT_INT (-1)) - 1" );
 159           ELSE
 160                FAILED ( "NO EXCEPTION RAISED " &
 161                         "FOR NEWCHAR'VAL (IDENT_INT (-1)) - 2" );
 162           END IF;
 163      EXCEPTION
 164           WHEN CONSTRAINT_ERROR =>
 165                NULL;
 166           WHEN OTHERS =>
 167                FAILED ( "WRONG EXCEPTION RAISED " &
 168                         "FOR NEWCHAR'VAL (IDENT_INT (-1))" );
 169      END;
 170
 171      POSITION := 0;
 172
 173      FOR CH IN CHARACTER LOOP
 174           IF SCHAR'POS (CH) /= POSITION THEN
 175                FAILED ( "INCORRECT VALUE FOR SCHAR'POS OF " &
 176                          CHARACTER'IMAGE (CH) );
 177           END IF;
 178
 179           POSITION := POSITION + 1;
 180      END LOOP;
 181
 182      FOR POSITION IN 0 .. 31 LOOP
 183           IF CHARACTER'VAL (POSITION) /= NONGRAPH (POSITION) THEN
 184                FAILED ( "INCORRECT VALUE FOR CHARACTER'VAL OF " &
 185                         "NONGRAPHIC CHARACTER IN POSITION - " &
 186                          INTEGER'IMAGE (POSITION) );
 187           END IF;
 188      END LOOP;
 189
 190      POSITION := 32;
 191
 192      FOR CH IN BLANK .. ASCII.TILDE LOOP
 193           IF SCHAR'VAL (POSITION) /= CH THEN
 194                FAILED ( "INCORRECT VALUE FOR SCHAR'VAL OF " &
 195                         "GRAPHIC CHARACTER IN POSITION - " &
 196                          INTEGER'IMAGE (POSITION) );
 197           END IF;
 198
 199           POSITION := POSITION + 1;
 200      END LOOP;
 201
 202      IF CHARACTER'VAL (127) /= ASCII.DEL THEN
 203           FAILED ( "INCORRECT VALUE FOR CHARACTER'VAL OF " &
 204                     "NONGRAPHIC CHARACTER IN POSITION - 127" );
 205      END IF;
 206
 207      BEGIN
 208           IF CHARACTER'VAL (IDENT_INT (-1)) = ASCII.NUL THEN
 209                FAILED ( "NO EXCEPTION RAISED " &
 210                         "FOR CHARACTER'VAL (IDENT_INT (-1)) - 1" );
 211           ELSE
 212                FAILED ( "NO EXCEPTION RAISED " &
 213                         "FOR CHARACTER'VAL (IDENT_INT (-1)) - 2" );
 214           END IF;
 215      EXCEPTION
 216           WHEN CONSTRAINT_ERROR =>
 217                NULL;
 218           WHEN OTHERS =>
 219                FAILED ( "WRONG EXCEPTION RAISED " &
 220                         "FOR CHARACTER'VAL (IDENT_INT (-1))" );
 221      END;
 222
 223      RESULT;
 224 END C35507K;