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

   1 -- CE3806F.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 FIXED_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 FIXED_IO RAISES CONSTRAINT_ERROR WHEN THE VALUE
  30 --     OF ITEM IS OUTSIDE THE RANGE OF THE TYPE USED TO INSTANTIATE
  31 --     FIXED_IO.
  32
  33 -- HISTORY:
  34 --     JLH 09/15/87  CREATED ORIGINAL TEST.
  35 --     JRL 06/07/96  Added call to Ident_Int in expressions involving
  36 --                   Field'Last, to make the expressions non-static and
  37 --                   prevent compile-time rejection.
  38
  39 WITH REPORT; USE REPORT;
  40 WITH TEXT_IO; USE TEXT_IO;
  41
  42 PROCEDURE CE3806F IS
  43
  44 BEGIN
  45
  46      TEST ("CE3806F", "CHECK THAT PUT FOR FIXED_IO RAISES " &
  47                       "CONSTRAINT_ERROR APPROPRIATELY");
  48
  49      DECLARE
  50           TYPE FIXED IS DELTA 0.01 RANGE 1.0 .. 2.0;
  51           SUBTYPE MY_FIXED IS FIXED DELTA 0.01 RANGE 1.0 .. 1.5;
  52           PACKAGE NFX_IO IS NEW FIXED_IO (MY_FIXED);
  53           USE NFX_IO;
  54           FT : FILE_TYPE;
  55           Y : FIXED := 1.8;
  56           X : MY_FIXED := 1.3;
  57
  58      BEGIN
  59
  60           BEGIN
  61                PUT (FT, X, FORE => IDENT_INT(-6));
  62                FAILED ("CONSTRAINT_ERROR NOT RAISED - NEGATIVE FORE " &
  63                        "FIXED");
  64           EXCEPTION
  65                WHEN CONSTRAINT_ERROR =>
  66                     NULL;
  67                WHEN STATUS_ERROR =>
  68                     FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
  69                             "CONSTRAINT_ERROR - 1");
  70                WHEN USE_ERROR =>
  71                     FAILED ("USE_ERROR RAISED INSTEAD OF " &
  72                             "CONSTRAINT_ERROR - 1");
  73                WHEN OTHERS =>
  74                     FAILED ("WRONG EXCEPTION RAISED - NEGATIVE FORE " &
  75                             "FIXED");
  76           END;
  77
  78           BEGIN
  79                PUT (FT, X, AFT => IDENT_INT(-2));
  80                FAILED ("CONSTRAINT_ERROR NOT RAISED - NEGATIVE AFT " &
  81                        "FIXED");
  82           EXCEPTION
  83                WHEN CONSTRAINT_ERROR =>
  84                     NULL;
  85                WHEN STATUS_ERROR =>
  86                     FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
  87                             "CONSTRAINT_ERROR - 2");
  88                WHEN USE_ERROR =>
  89                     FAILED ("USE_ERROR RAISED INSTEAD OF " &
  90                             "CONSTRAINT_ERROR - 2");
  91                WHEN OTHERS =>
  92                     FAILED ("WRONG EXCEPTION RAISED - NEGATIVE AFT " &
  93                             "FIXED");
  94           END;
  95
  96           BEGIN
  97                PUT (FT, X, EXP => IDENT_INT(-1));
  98                FAILED ("CONSTRAINT_ERROR NOT RAISED - NEGATIVE EXP " &
  99                        "FIXED");
 100           EXCEPTION
 101                WHEN CONSTRAINT_ERROR =>
 102                     NULL;
 103                WHEN STATUS_ERROR =>
 104                     FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
 105                             "CONSTRAINT_ERROR - 3");
 106                WHEN USE_ERROR =>
 107                     FAILED ("USE_ERROR RAISED INSTEAD OF " &
 108                             "CONSTRAINT_ERROR - 3");
 109                WHEN OTHERS =>
 110                     FAILED ("WRONG EXCEPTION RAISED - NEGATIVE EXP " &
 111                             "FIXED");
 112           END;
 113
 114           IF FIELD'LAST < FIELD'BASE'LAST THEN
 115
 116                BEGIN
 117                     PUT (FT, X, FORE => IDENT_INT(FIELD'LAST+Ident_Int(1)));
 118                     FAILED ("CONSTRAINT_ERROR NOT RAISED - FORE FIXED");
 119                EXCEPTION
 120                     WHEN CONSTRAINT_ERROR =>
 121                          NULL;
 122                     WHEN STATUS_ERROR =>
 123                          FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
 124                                  "CONSTRAINT_ERROR - 4");
 125                     WHEN USE_ERROR =>
 126                          FAILED ("USE_ERROR RAISED INSTEAD OF " &
 127                                  "CONSTRAINT_ERROR - 4");
 128                     WHEN OTHERS =>
 129                          FAILED ("WRONG EXCEPTION RAISED - FORE FIXED");
 130                END;
 131
 132                BEGIN
 133                     PUT (FT, X, AFT => IDENT_INT(FIELD'LAST+Ident_Int(1)));
 134                     FAILED ("CONSTRAINT_ERROR NOT RAISED - AFT FIXED");
 135                EXCEPTION
 136                     WHEN CONSTRAINT_ERROR =>
 137                          NULL;
 138                     WHEN STATUS_ERROR =>
 139                          FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
 140                                  "CONSTRAINT_ERROR - 5");
 141                     WHEN USE_ERROR =>
 142                          FAILED ("USE_ERROR RAISED INSTEAD OF " &
 143                                  "CONSTRAINT_ERROR - 5");
 144                     WHEN OTHERS =>
 145                          FAILED ("WRONG EXCEPTION RAISED - AFT FIXED");
 146                END;
 147
 148                BEGIN
 149                     PUT (FT, X, EXP => IDENT_INT(FIELD'LAST+Ident_Int(1)));
 150                     FAILED ("CONSTRAINT_ERROR NOT RAISED - EXP FIXED");
 151                EXCEPTION
 152                     WHEN CONSTRAINT_ERROR =>
 153                          NULL;
 154                     WHEN STATUS_ERROR =>
 155                          FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
 156                                  "CONSTRAINT_ERROR - 6");
 157                     WHEN USE_ERROR =>
 158                          FAILED ("USE_ERROR RAISED INSTEAD OF " &
 159                                  "CONSTRAINT_ERROR - 6");
 160                     WHEN OTHERS =>
 161                          FAILED ("WRONG EXCEPTION RAISED - EXP FIXED");
 162                END;
 163
 164           END IF;
 165
 166           BEGIN
 167                PUT (FT, Y);
 168                FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ITEM OUTSIDE " &
 169                        "RANGE - FILE");
 170           EXCEPTION
 171                WHEN CONSTRAINT_ERROR =>
 172                     NULL;
 173                WHEN OTHERS =>
 174                     FAILED ("WRONG EXCEPTION RAISED FOR ITEM OUTSIDE " &
 175                             "RANGE - FILE");
 176           END;
 177
 178           BEGIN
 179                PUT (Y);
 180                FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ITEM OUTSIDE " &
 181                        "RANGE - DEFAULT");
 182           EXCEPTION
 183                WHEN CONSTRAINT_ERROR =>
 184                     NULL;
 185                WHEN OTHERS =>
 186                     FAILED ("WRONG EXCEPTION RAISED FOR ITEM OUTSIDE " &
 187                             "RANGE - DEFAULT");
 188           END;
 189
 190      END;
 191
 192      RESULT;
 193
 194 END CE3806F;