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

   1 -- CE3806C.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 PUT FOR FLOAT_IO RAISES CONSTRAINT_ERROR WHEN THE
  27 --     VALUES SUPPLIED BY FORE, AFT, OR EXP ARE NEGATIVE OR GREATER
  28 --     THAN FIELD'LAST WHEN FIELD'LAST < FIELD'BASE'LAST.  ALSO CHECK
  29 --     THAT PUT FOR FLOAT_IO RAISES CONSTRAINT_ERROR WHEN THE VALUE OF
  30 --     ITEM IS OUTSIDE THE RANGE OF THE TYPE USED TO INSTANTIATE
  31 --     FLOAT_IO.
  32
  33 -- HISTORY:
  34 --     SPS 09/10/82
  35 --     JBG 08/30/83
  36 --     JLH 09/14/87  ADDED CASES FOR COMPLETE OBJECTIVE.
  37 --     KAS 11/24/95  DELETED DIGITS CONSTRAINT FROM SUBTYPE
  38 --                   CHANGED STATIC EXPRESSIONS INVOLVING 'LAST
  39
  40 WITH REPORT;
  41 USE REPORT;
  42 WITH TEXT_IO;
  43 USE TEXT_IO;
  44
  45 PROCEDURE CE3806C IS
  46
  47      FIELD_LAST : TEXT_IO.FIELD := TEXT_IO.FIELD'LAST;
  48
  49 BEGIN
  50
  51      TEST ("CE3806C", "CHECK THAT PUT FOR FLOAT_IO RAISES " &
  52                       "CONSTRAINT_ERROR APPROPRIATELY");
  53
  54      DECLARE
  55           TYPE FLOAT IS DIGITS 5 RANGE 0.0 .. 2.0;
  56           SUBTYPE MY_FLOAT IS FLOAT RANGE 0.0 .. 1.0;
  57           PACKAGE NFL_IO IS NEW FLOAT_IO (MY_FLOAT);
  58           USE NFL_IO;
  59           FT : FILE_TYPE;
  60           Y : FLOAT := 1.8;
  61           X : MY_FLOAT := 26.3 / 26.792;
  62
  63      BEGIN
  64           BEGIN
  65                PUT (FT, X, FORE => IDENT_INT(-6));
  66                FAILED ("CONSTRAINT_ERROR NOT RAISED - NEGATIVE FORE " &
  67                        "FLOAT");
  68           EXCEPTION
  69                WHEN CONSTRAINT_ERROR =>
  70                     NULL;
  71                WHEN STATUS_ERROR =>
  72                     FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
  73                             "CONSTRAINT_ERROR - 1");
  74                WHEN USE_ERROR =>
  75                     FAILED ("USE_ERROR RAISED INSTEAD OF " &
  76                             "CONSTRAINT_ERROR - 1");
  77                WHEN OTHERS =>
  78                     FAILED ("WRONG EXCEPTION RAISED - NEGATIVE FORE " &
  79                             "FLOAT");
  80           END;
  81
  82           BEGIN
  83                PUT (FT, X, AFT => IDENT_INT(-2));
  84                FAILED ("CONSTRAINT_ERROR NOT RAISED - NEGATIVE AFT " &
  85                        "FLOAT");
  86           EXCEPTION
  87                WHEN CONSTRAINT_ERROR =>
  88                     NULL;
  89                WHEN STATUS_ERROR =>
  90                     FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
  91                             "CONSTRAINT_ERROR - 2");
  92                WHEN USE_ERROR =>
  93                     FAILED ("USE_ERROR RAISED INSTEAD OF " &
  94                             "CONSTRAINT_ERROR - 2");
  95                WHEN OTHERS =>
  96                     FAILED ("WRONG EXCEPTION RAISED - NEGATIVE AFT " &
  97                             "FLOAT");
  98           END;
  99
 100           BEGIN
 101                PUT (FT, X, EXP => IDENT_INT(-1));
 102                FAILED ("CONSTRAINT_ERROR NOT RAISED - NEGATIVE EXP " &
 103                        "FLOAT");
 104           EXCEPTION
 105                WHEN CONSTRAINT_ERROR =>
 106                     NULL;
 107                WHEN STATUS_ERROR =>
 108                     FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
 109                             "CONSTRAINT_ERROR - 3");
 110                WHEN USE_ERROR =>
 111                     FAILED ("USE_ERROR RAISED INSTEAD OF " &
 112                             "CONSTRAINT_ERROR - 3");
 113                WHEN OTHERS =>
 114                     FAILED ("WRONG EXCEPTION RAISED - NEGATIVE EXP " &
 115                             "FLOAT");
 116           END;
 117
 118           IF FIELD_LAST < FIELD'BASE'LAST THEN
 119
 120                BEGIN
 121                     PUT (FT, X, FORE => IDENT_INT(FIELD_LAST+1));
 122                     FAILED ("CONSTRAINT_ERROR NOT RAISED - FORE FLOAT");
 123                EXCEPTION
 124                     WHEN CONSTRAINT_ERROR =>
 125                          NULL;
 126                     WHEN STATUS_ERROR =>
 127                          FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
 128                                  "CONSTRAINT_ERROR - 4");
 129                     WHEN USE_ERROR =>
 130                          FAILED ("USE_ERROR RAISED INSTEAD OF " &
 131                                  "CONSTRAINT_ERROR - 4");
 132                     WHEN OTHERS =>
 133                          FAILED ("WRONG EXCEPTION RAISED - FORE FLOAT");
 134                END;
 135
 136                BEGIN
 137                     PUT (FT, X, AFT => IDENT_INT(FIELD_LAST+1));
 138                     FAILED ("CONSTRAINT_ERROR NOT RAISED - AFT FLOAT");
 139                EXCEPTION
 140                     WHEN CONSTRAINT_ERROR =>
 141                          NULL;
 142                     WHEN STATUS_ERROR =>
 143                          FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
 144                                  "CONSTRAINT_ERROR - 5");
 145                     WHEN USE_ERROR =>
 146                          FAILED ("USE_ERROR RAISED INSTEAD OF " &
 147                                  "CONSTRAINT_ERROR - 5");
 148                     WHEN OTHERS =>
 149                          FAILED ("WRONG EXCEPTION RAISED - AFT FLOAT");
 150                END;
 151
 152                BEGIN
 153                     PUT (FT, X, EXP => IDENT_INT(FIELD_LAST+1));
 154                     FAILED ("CONSTRAINT_ERROR NOT RAISED - EXP FLOAT");
 155                EXCEPTION
 156                     WHEN CONSTRAINT_ERROR =>
 157                          NULL;
 158                     WHEN STATUS_ERROR =>
 159                          FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
 160                                  "CONSTRAINT_ERROR - 6");
 161                     WHEN USE_ERROR =>
 162                          FAILED ("USE_ERROR RAISED INSTEAD OF " &
 163                                  "CONSTRAINT_ERROR - 6");
 164                     WHEN OTHERS =>
 165                          FAILED ("WRONG EXCEPTION RAISED - EXP FLOAT");
 166                END;
 167            END IF;
 168
 169            BEGIN
 170                PUT (FT, Y);
 171                FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ITEM OUTSIDE " &
 172                        "RANGE - FILE");
 173            EXCEPTION
 174                WHEN CONSTRAINT_ERROR =>
 175                     NULL;
 176                WHEN OTHERS =>
 177                     FAILED ("WRONG EXCEPTION RAISED FOR ITEM OUTSIDE " &
 178                             "RANGE - FILE");
 179           END;
 180
 181           BEGIN
 182                PUT (Y);
 183                FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ITEM OUTSIDE " &
 184                        "RANGE - DEFAULT");
 185           EXCEPTION
 186                WHEN CONSTRAINT_ERROR =>
 187                     NULL;
 188                WHEN OTHERS =>
 189                     FAILED ("WRONG EXCEPTION RAISED FOR ITEM OUTSIDE " &
 190                             "RANGE - DEFAULT");
 191           END;
 192
 193      END;
 194
 195      RESULT;
 196
 197 END CE3806C;