gomp-20050608-branch/gcc/testsuite/ada/acats/tests/ce/ce2401c.ada

   1 -- CE2401C.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 READ (WITH AND WITHOUT PARAMETER FROM), WRITE (WITH
  27 --     AND WITHOUT PARAMETER TO), SET_INDEX, INDEX, SIZE, AND
  28 --     END_OF_FILE ARE IMPLEMENTED FOR DIRECT FILES WITH
  29 --     ELEMENT_TYPE CONSTRAINED ARRAY, AND RECORD WITHOUT DISCRIMINANTS.
  30
  31 -- APPLICABILITY CRITERIA:
  32 --     THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
  33 --     DIRECT FILES.
  34
  35 -- HISTORY:
  36 --     ABW 08/18/82
  37 --     SPS 09/20/82
  38 --     SPS 11/09/82
  39 --     JBG 05/02/83
  40 --     JRK 03/26/84
  41 --     EG  05/16/85
  42 --     TBN 11/04/86  REVISED TEST TO OUTPUT A NON_APPLICABLE
  43 --                   RESULT WHEN FILES ARE NOT SUPPORTED.
  44 --     DWC 08/10/87  ISOLATED EXCEPTIONS.
  45
  46 WITH REPORT; USE REPORT;
  47 WITH DIRECT_IO;
  48
  49 PROCEDURE CE2401C IS
  50      END_SUBTEST: EXCEPTION;
  51 BEGIN
  52
  53      TEST ("CE2401C" , "CHECK READ, WRITE, SET_INDEX " &
  54                        "INDEX, SIZE, AND END_OF_FILE FOR " &
  55                        "DIRECT FILES FOR CONSTRAINED ARRAY TYPES, " &
  56                        "AND RECORD TYPES WITHOUT DISCRIMINANTS");
  57
  58      DECLARE
  59           TYPE ARR_CN IS ARRAY (1..5) OF BOOLEAN;
  60           PACKAGE DIR_ARR_CN IS NEW DIRECT_IO (ARR_CN);
  61           USE DIR_ARR_CN;
  62           FILE : FILE_TYPE;
  63      BEGIN
  64           BEGIN
  65                CREATE (FILE, INOUT_FILE, LEGAL_FILE_NAME);
  66           EXCEPTION
  67                WHEN USE_ERROR | NAME_ERROR =>
  68                     NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " &
  69                                     "ON CREATE - CONSTRAINED ARRAY");
  70                     RAISE END_SUBTEST;
  71                WHEN OTHERS =>
  72                     FAILED ("UNEXPECTED ERROR RAISED ON " &
  73                             "CREATE - CONSTRAINED ARRAY");
  74                     RAISE END_SUBTEST;
  75           END;
  76
  77           DECLARE
  78                ARR : ARR_CN := (TRUE,TRUE,FALSE,TRUE,TRUE);
  79                ITEM : ARR_CN;
  80                ONE : POSITIVE_COUNT := 1;
  81                TWO : POSITIVE_COUNT := 2;
  82           BEGIN
  83                BEGIN
  84                     WRITE (FILE,ARR);
  85                EXCEPTION
  86                     WHEN OTHERS =>
  87                          FAILED ("EXCEPTION RAISED ON WRITE FOR " &
  88                                  "CONTRAINED ARRAY - 1");
  89                END;
  90
  91                BEGIN
  92                     WRITE (FILE,ARR,TWO);
  93                EXCEPTION
  94                     WHEN OTHERS =>
  95                          FAILED ("EXCEPTION RAISED ON WRITE FOR " &
  96                                  "CONSTRAINED ARRAY - 2");
  97                END;
  98
  99                BEGIN
 100                     IF SIZE (FILE) /= TWO THEN
 101                          FAILED ("SIZE FOR TYPE CONSTRAINED ARRAY");
 102                     END IF;
 103                     IF NOT END_OF_FILE (FILE) THEN
 104                          FAILED ("WRONG END_OF_FILE VALUE FOR TYPE " &
 105                                  "CONSTRAINED ARRAY");
 106                     END IF;
 107                     SET_INDEX (FILE,ONE);
 108                     IF INDEX (FILE) /= ONE THEN
 109                          FAILED ("WRONG INDEX VALUE FOR TYPE " &
 110                                  "CONSTRAINED ARRAY");
 111                     END IF;
 112                END;
 113
 114                CLOSE (FILE);
 115
 116                BEGIN
 117                     OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
 118                EXCEPTION
 119                     WHEN USE_ERROR =>
 120                          NOT_APPLICABLE ("OPEN FOR IN_FILE MODE " &
 121                                          "NOT SUPPORTED - 1");
 122                          RAISE END_SUBTEST;
 123                END;
 124
 125                BEGIN
 126                     READ (FILE,ITEM);
 127                     IF ITEM /= ARR THEN
 128                          FAILED ("INCORRECT ARRAY VALUES READ " &
 129                                  "- 1");
 130                     END IF;
 131                EXCEPTION
 132                     WHEN OTHERS =>
 133                          FAILED ("READ WITHOUT FROM FOR " &
 134                                  "TYPE CONSTRAINED ARRAY");
 135                END;
 136
 137                BEGIN
 138                     READ (FILE,ITEM,ONE);
 139                     IF ITEM /= ARR THEN
 140                          FAILED ("INCORRECT ARRAY VALUES READ " &
 141                                  "- 2");
 142                     END IF;
 143                EXCEPTION
 144                     WHEN OTHERS =>
 145                          FAILED ("READ WITH FROM FOR " &
 146                                  "TYPE CONSTRAINED ARRAY");
 147                END;
 148           END;
 149
 150           BEGIN
 151                DELETE (FILE);
 152           EXCEPTION
 153                WHEN USE_ERROR =>
 154                     NULL;
 155           END;
 156
 157      EXCEPTION
 158           WHEN END_SUBTEST =>
 159                NULL;
 160      END;
 161
 162      DECLARE
 163           TYPE REC IS
 164                RECORD
 165                     ONE : INTEGER;
 166                     TWO : INTEGER;
 167           END RECORD;
 168           PACKAGE DIR_REC IS NEW DIRECT_IO (REC);
 169           USE DIR_REC;
 170           FILE : FILE_TYPE;
 171      BEGIN
 172           BEGIN
 173                CREATE (FILE, INOUT_FILE, LEGAL_FILE_NAME(2));
 174           EXCEPTION
 175                WHEN USE_ERROR | NAME_ERROR =>
 176                     NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " &
 177                                     "ON CREATE - RECORD");
 178                     RAISE END_SUBTEST;
 179                WHEN OTHERS =>
 180                     FAILED ("UNEXPECTED ERROR RAISED ON CREATE - " &
 181                             "RECORD");
 182           END;
 183
 184           DECLARE
 185                REC1 : REC := REC'(ONE=>18,TWO=>36);
 186                ITEM : REC;
 187                ONE : POSITIVE_COUNT := 1;
 188                TWO : POSITIVE_COUNT := 2;
 189           BEGIN
 190                BEGIN
 191                     WRITE (FILE,REC1);
 192                EXCEPTION
 193                     WHEN OTHERS =>
 194                          FAILED ("EXCEPTION RAISED ON WRITE FOR - " &
 195                                  "RECORD - 1");
 196                END;
 197
 198                BEGIN
 199                     WRITE (FILE,REC1,TWO);
 200                EXCEPTION
 201                     WHEN OTHERS =>
 202                          FAILED ("EXCEPTION RAISED ON WRITE FOR - " &
 203                                  "RECORD - 2");
 204                END;
 205
 206                BEGIN
 207                     IF SIZE (FILE) /= TWO THEN
 208                          FAILED ("SIZE FOR TYPE RECORD");
 209                     END IF;
 210                     IF NOT END_OF_FILE (FILE) THEN
 211                          FAILED ("WRONG END_OF_FILE VALUE FOR RECORD");
 212                     END IF;
 213                     SET_INDEX (FILE,ONE);
 214                     IF INDEX (FILE) /= ONE THEN
 215                          FAILED ("WRONG INDEX VALUE FOR TYPE RECORD");
 216                     END IF;
 217                END;
 218
 219                CLOSE (FILE);
 220
 221                BEGIN
 222                     OPEN (FILE, IN_FILE, LEGAL_FILE_NAME(2));
 223                EXCEPTION
 224                     WHEN USE_ERROR =>
 225                          NOT_APPLICABLE ("OPEN FOR IN_FILE MODE " &
 226                                          "NOT SUPPORTED - 2");
 227                          RAISE END_SUBTEST;
 228                END;
 229
 230                BEGIN
 231                     READ (FILE,ITEM);
 232                     IF ITEM /= REC1 THEN
 233                          FAILED ("INCORRECT RECORD VALUES READ " &
 234                                  "- 1");
 235                     END IF;
 236                EXCEPTION
 237                     WHEN OTHERS =>
 238                          FAILED ("READ WITHOUT FROM FOR RECORD");
 239                END;
 240
 241                BEGIN
 242                     READ (FILE,ITEM,ONE);
 243                     IF ITEM /= REC1 THEN
 244                          FAILED ("INCORRECT RECORD VALUES READ " &
 245                                  "- 2");
 246                     END IF;
 247                EXCEPTION
 248                     WHEN OTHERS =>
 249                          FAILED ("READ WITH FROM FOR " &
 250                                  "TYPE RECORD");
 251                END;
 252           END;
 253
 254           BEGIN
 255                DELETE (FILE);
 256           EXCEPTION
 257                WHEN USE_ERROR =>
 258                     NULL;
 259           END;
 260
 261      EXCEPTION
 262           WHEN END_SUBTEST =>
 263                NULL;
 264      END;
 265
 266      RESULT;
 267
 268 END CE2401C;