gcc/testsuite/ada/acats/tests/ce/ce2401h.ada

   1 -- CE2401H.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 READ, WRITE, SET_INDEX, INDEX, SIZE, AND
  27 --     END_OF_FILE ARE SUPPORTED FOR DIRECT FILES WITH
  28 --     ELEMENT_TYPE UNCONSTRAINED RECORDS WITH DEFAULT DISCRIMINANTS.
  29
  30 --     THIS INSTANTIATION IS ALWAYS LEGAL BY AI-00037.
  31
  32 -- APPLICABILITY CRITERIA:
  33 --     THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
  34 --     CREATE WITH INOUT_FILE MODE AND OPENING WITH IN_FILE MODE FOR
  35 --     DIRECT FILES.
  36
  37 -- HISTORY:
  38 --     TBN 05/15/86
  39 --     TBN 11/04/86  REVISED TEST TO OUTPUT A NON_APPLICABLE
  40 --                   RESULT WHEN FILES ARE NOT SUPPORTED.
  41 --     DWC 08/10/87  ISOLATED EXCEPTIONS.
  42
  43 WITH REPORT;
  44 USE REPORT;
  45 WITH DIRECT_IO;
  46
  47 PROCEDURE CE2401H IS
  48
  49      END_SUBTEST : EXCEPTION;
  50
  51 BEGIN
  52
  53      TEST ("CE2401H", "CHECK THAT READ, WRITE, SET_INDEX, INDEX, " &
  54                        "SIZE, AND END_OF_FILE ARE SUPPORTED FOR " &
  55                        "DIRECT FILES WITH ELEMENT_TYPE UNCONSTRAINED " &
  56                        "RECORDS WITH DEFAULT DISCRIMINANTS");
  57
  58      DECLARE
  59           TYPE REC_DEF (DISCR : INTEGER := 1) IS
  60                RECORD
  61                     ONE : INTEGER := DISCR;
  62                     TWO : INTEGER := 3;
  63                     THREE : INTEGER := 5;
  64                     FOUR : INTEGER := 7;
  65                END RECORD;
  66           PACKAGE DIR_REC_DEF IS NEW DIRECT_IO (REC_DEF);
  67           USE DIR_REC_DEF;
  68           FILE1 : FILE_TYPE;
  69           REC : REC_DEF;
  70           ITEM : REC_DEF;
  71           ONE : POSITIVE_COUNT := 1;
  72           TWO : POSITIVE_COUNT := 2;
  73
  74      BEGIN
  75           BEGIN
  76                CREATE (FILE1, INOUT_FILE, LEGAL_FILE_NAME);
  77           EXCEPTION
  78                WHEN USE_ERROR | NAME_ERROR  =>
  79                     NOT_APPLICABLE ("CREATE WITH INOUT_FILE MODE " &
  80                                     "NOT SUPPORTED FOR " &
  81                                     "UNCONSTRAINED RECORDS WITH " &
  82                                     "DEFAULT DISCRIMINATES");
  83                     RAISE END_SUBTEST;
  84                WHEN OTHERS =>
  85                     FAILED ("UNEXPECTED EXCEPTION RAISED ON DIRECT " &
  86                             "CREATE");
  87                     RAISE END_SUBTEST;
  88           END;
  89
  90           BEGIN
  91                WRITE (FILE1, REC);
  92           EXCEPTION
  93                WHEN OTHERS =>
  94                     FAILED ("EXCEPTION RAISED ON WRITE FOR " &
  95                             "RECORD WITH DEFAULT - 1");
  96           END;
  97
  98           BEGIN
  99                WRITE (FILE1, REC, TWO);
 100           EXCEPTION
 101                WHEN OTHERS =>
 102                     FAILED ("EXCEPTION RAISED ON WRITE FOR " &
 103                             "RECORD WITH DEFAULT - 2");
 104           END;
 105
 106           BEGIN
 107                IF SIZE (FILE1) /= TWO THEN
 108                     FAILED ("SIZE FOR RECORD WITH DEFAULT");
 109                END IF;
 110                IF NOT END_OF_FILE (FILE1) THEN
 111                     FAILED ("WRONG END_OF_FILE VALUE FOR TYPE " &
 112                             "RECORD WITH DEFAULT");
 113                END IF;
 114                SET_INDEX (FILE1, ONE);
 115                IF INDEX (FILE1) /= ONE THEN
 116                     FAILED ("WRONG INDEX VALUE FOR RECORD" &
 117                             "WITH DEFAULT");
 118                END IF;
 119           END;
 120
 121           CLOSE (FILE1);
 122
 123           BEGIN
 124                OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
 125           EXCEPTION
 126                WHEN USE_ERROR =>
 127                     NOT_APPLICABLE ("OPEN FOR IN_FILE NOT SUPPORTED");
 128                     RAISE END_SUBTEST;
 129           END;
 130
 131           BEGIN
 132                READ (FILE1, ITEM);
 133                IF ITEM /= (1,1,3,5,7) THEN
 134                     FAILED ("WRONG VALUE READ");
 135                END IF;
 136           EXCEPTION
 137                WHEN OTHERS =>
 138                     FAILED ("READ WITHOUT FROM FOR " &
 139                             "TYPE RECORD WITH DEFAULT");
 140           END;
 141
 142           BEGIN
 143                ITEM := (OTHERS => 0);
 144                READ (FILE1, ITEM, ONE);
 145                IF ITEM /= (1,1,3,5,7) THEN
 146                     FAILED ("WRONG VALUE READ");
 147                END IF;
 148           EXCEPTION
 149                WHEN OTHERS =>
 150                     FAILED ("READ WITH FROM FOR " &
 151                             "TYPE RECORD WITH DEFAULT");
 152           END;
 153
 154           BEGIN
 155                DELETE (FILE1);
 156           EXCEPTION
 157                WHEN USE_ERROR =>
 158                     NULL;
 159           END;
 160
 161      EXCEPTION
 162           WHEN END_SUBTEST =>
 163                NULL;
 164      END;
 165
 166      RESULT;
 167
 168 END CE2401H;