1-- CE3906D.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 CONSTRAINT_ERROR IS RAISED BY PUT FOR ENUMERATION
27--     TYPES WHEN THE VALUE OF WIDTH IS NEGATIVE, WHEN WIDTH IS
28--     GREATER THAN FIELD'LAST, OR WHEN THE VALUE OF ITEM IS OUTSIDE
29--     THE RANGE OF THE SUBTYPE USED TO INSTANTIATE ENUMERATION_IO.
30
31-- HISTORY:
32--     SPS 10/08/82
33--     DWC 09/17/87  ADDED CASES FOR CONSTRAINT_ERROR.
34--     JRL 06/07/96  Added call to Ident_Int in expressions involving
35--                   Field'Last, to make the expressions non-static and
36--                   prevent compile-time rejection.
37
38WITH REPORT;
39USE REPORT;
40WITH TEXT_IO;
41USE TEXT_IO;
42
43PROCEDURE CE3906D IS
44BEGIN
45
46     TEST ("CE3906D", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY PUT " &
47                      "FOR ENUMERATION TYPES WHEN THE VALUE OF " &
48                      "WIDTH IS NEGATIVE, WHEN WIDTH IS GREATER " &
49                      "THAN FIELD'LAST, OR WHEN THE VALUE OF ITEM " &
50                      "IS OUTSIDE THE RANGE OF THE SUBTYPE USED TO " &
51                      "INSTANTIATE ENUMERATION_IO");
52
53     DECLARE
54          FT : FILE_TYPE;
55          TYPE DAY IS (SUNDAY, MONDAY, TUESDAY, WEDNESDAY,
56                       THURSDAY, FRIDAY, SATURDAY);
57          TODAY : DAY := FRIDAY;
58          SUBTYPE WEEKDAY IS DAY RANGE MONDAY .. FRIDAY;
59          PACKAGE DAY_IO IS NEW ENUMERATION_IO (WEEKDAY);
60          USE DAY_IO;
61     BEGIN
62
63          BEGIN
64               PUT (FT, TODAY, -1);
65               FAILED ("CONSTRAINT_ERROR NOT RAISED; NEGATIVE " &
66                       "WIDTH - FILE");
67          EXCEPTION
68               WHEN CONSTRAINT_ERROR =>
69                    NULL;
70               WHEN STATUS_ERROR =>
71                    FAILED ("RAISED STATUS_ERROR");
72               WHEN OTHERS =>
73                    FAILED ("WRONG EXCEPTION RAISED; NEGATIVE " &
74                            "WIDTH - FILE");
75          END;
76
77          IF FIELD'LAST < INTEGER'LAST THEN
78               BEGIN
79                    PUT (FT, TODAY, FIELD'LAST + Ident_Int(1));
80                    FAILED ("CONSTRAINT_ERROR NOT RAISED; WIDTH " &
81                            "GREATER THAN FIELD'LAST + 1- FILE");
82               EXCEPTION
83                    WHEN CONSTRAINT_ERROR =>
84                         NULL;
85                    WHEN OTHERS =>
86                         FAILED ("WRONG EXCEPTION RAISED; WIDTH " &
87                                 "GREATER THAN FIELD'LAST + 1 - FILE");
88               END;
89
90               BEGIN
91                    PUT (TODAY, FIELD'LAST + Ident_Int(1));
92                    FAILED ("CONSTRAINT_ERROR NOT RAISED; WIDTH " &
93                            "GREATER THAN FIELD'LAST + 1 - DEFAULT");
94               EXCEPTION
95                    WHEN CONSTRAINT_ERROR =>
96                         NULL;
97                    WHEN OTHERS =>
98                         FAILED ("WRONG EXCEPTION RAISED; WIDTH " &
99                                 "GREATER THAN FIELD'LAST + 1 " &
100                                 "- DEFAULT");
101          END;
102
103          END IF;
104
105          TODAY := SATURDAY;
106
107          BEGIN
108               PUT (FT, TODAY);
109               FAILED ("CONSTRAINT_ERROR NOT RAISED; ITEM VALUE " &
110                       "OUT OF RANGE - FILE");
111          EXCEPTION
112               WHEN CONSTRAINT_ERROR =>
113                    NULL;
114               WHEN OTHERS =>
115                    FAILED ("WRONG EXCEPTION RAISED; ITEM VALUE " &
116                            "OUT OF RANGE - FILE");
117          END;
118
119          TODAY := FRIDAY;
120
121          BEGIN
122               PUT (TODAY, -3);
123               FAILED ("CONSTRAINT_ERROR NOT RAISED; NEGATIVE " &
124                       "WIDTH - DEFAULT");
125          EXCEPTION
126               WHEN CONSTRAINT_ERROR =>
127                    NULL;
128               WHEN STATUS_ERROR =>
129                    FAILED ("RAISED STATUS_ERROR");
130               WHEN OTHERS =>
131                    FAILED ("WRONG EXCEPTION RAISED; NEGATIVE " &
132                            "WIDTH - DEFAULT");
133          END;
134
135          TODAY := SATURDAY;
136
137          BEGIN
138               PUT (TODAY);
139               FAILED ("CONSTRAINT_ERROR NOT RAISED; ITEM VALUE " &
140                       "OUT OF RANGE - DEFAULT");
141          EXCEPTION
142               WHEN CONSTRAINT_ERROR =>
143                    NULL;
144               WHEN OTHERS =>
145                    FAILED ("WRONG EXCEPTION RAISED; ITEM VALUE " &
146                            "OUT OF RANGE - DEFAULT");
147          END;
148     END;
149
150     RESULT;
151
152END CE3906D;
153