1-- C47007A.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-- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A CONSTRAINED
26-- ARRAY TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE BOUNDS
27-- OF THE OPERAND ARE NOT THE SAME AS THE BOUNDS OF THE TYPE MARK.
28
29-- RJW 7/23/86
30
31WITH REPORT; USE REPORT;
32PROCEDURE C47007A IS
33
34     TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER;
35
36     TYPE TARR IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>)
37          OF INTEGER;
38
39     TYPE NARR IS NEW ARR;
40
41     TYPE NTARR IS NEW TARR;
42
43BEGIN
44
45     TEST( "C47007A", "WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION " &
46                      "DENOTES A CONSTRAINED ARRAY TYPE, CHECK THAT " &
47                      "CONSTRAINT_ERROR IS RAISED WHEN THE BOUNDS " &
48                      "OF THE OPERAND ARE NOT THE SAME AS THE " &
49                      "BOUNDS OF THE TYPE MARK" );
50
51     DECLARE
52
53          SUBTYPE SARR IS ARR (IDENT_INT (1) .. IDENT_INT (1));
54          A : ARR (IDENT_INT (2) .. IDENT_INT (2));
55     BEGIN
56          A := SARR'(A'RANGE => 0);
57          FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " &
58                   "THOSE OF SUBTYPE SARR" );
59     EXCEPTION
60          WHEN CONSTRAINT_ERROR =>
61               NULL;
62          WHEN OTHERS =>
63               FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " &
64                        "THE SAME AS THOSE OF SUBTYPE SARR" );
65     END;
66
67     DECLARE
68
69          SUBTYPE NULLA IS ARR (IDENT_INT (1) .. IDENT_INT (0));
70          A : ARR (IDENT_INT (2) .. IDENT_INT (1));
71
72     BEGIN
73          A := NULLA'(A'FIRST .. A'LAST => 0);
74          FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " &
75                   "THOSE OF SUBTYPE NULLA" );
76     EXCEPTION
77          WHEN CONSTRAINT_ERROR =>
78               NULL;
79          WHEN OTHERS =>
80               FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " &
81                        "THE SAME AS THOSE OF SUBTYPE NULLA" );
82     END;
83
84     DECLARE
85
86          SUBTYPE STARR IS TARR (IDENT_INT (1) .. IDENT_INT (1),
87                                 IDENT_INT (1) .. IDENT_INT (5));
88          A : TARR (IDENT_INT (2) .. IDENT_INT (6),
89                    IDENT_INT (1) .. IDENT_INT (1));
90     BEGIN
91          A := STARR'(A'RANGE => (A'RANGE (2) => 0));
92          FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " &
93                   "THOSE OF SUBTYPE STARR" );
94     EXCEPTION
95          WHEN CONSTRAINT_ERROR =>
96               NULL;
97          WHEN OTHERS =>
98               FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " &
99                        "THE SAME AS THOSE OF SUBTYPE STARR" );
100     END;
101
102     DECLARE
103
104          SUBTYPE NULLT IS TARR (IDENT_INT (1) .. IDENT_INT (5),
105                                 IDENT_INT (1) .. IDENT_INT (0));
106
107          A : TARR (IDENT_INT (1) .. IDENT_INT (5),
108                    IDENT_INT (2) .. IDENT_INT (1));
109     BEGIN
110          A := NULLT'(A'FIRST .. A'LAST  =>
111                     (A'FIRST (2) .. A'LAST (2) => 0));
112          FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " &
113                   "THOSE OF SUBTYPE NULLT" );
114     EXCEPTION
115          WHEN CONSTRAINT_ERROR =>
116               NULL;
117          WHEN OTHERS =>
118               FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " &
119                        "THE SAME AS THOSE OF SUBTYPE NULLT" );
120     END;
121
122     DECLARE
123
124          SUBTYPE SNARR IS NARR (IDENT_INT (1) .. IDENT_INT (1));
125          A : NARR (IDENT_INT (2) .. IDENT_INT (2));
126
127     BEGIN
128          A := SNARR'(A'RANGE => 0);
129          FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " &
130                   "THOSE OF SUBTYPE SNARR" );
131     EXCEPTION
132          WHEN CONSTRAINT_ERROR =>
133               NULL;
134          WHEN OTHERS =>
135               FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " &
136                        "THE SAME AS THOSE OF SUBTYPE SNARR" );
137     END;
138
139     DECLARE
140
141          SUBTYPE NULLNA IS NARR (IDENT_INT (1) .. IDENT_INT (0));
142          A : NARR (IDENT_INT (2) .. IDENT_INT (1));
143
144     BEGIN
145          A := NULLNA'(A'RANGE => 0);
146          FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " &
147                   "THOSE OF SUBTYPE NULLNA" );
148     EXCEPTION
149          WHEN CONSTRAINT_ERROR =>
150               NULL;
151          WHEN OTHERS =>
152               FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " &
153                        "THE SAME AS THOSE OF SUBTYPE NULLNA" );
154     END;
155
156     DECLARE
157
158          SUBTYPE SNTARR IS NTARR (IDENT_INT (1) .. IDENT_INT (1),
159                                   IDENT_INT (1) .. IDENT_INT (5));
160
161          A : NTARR (IDENT_INT (2) .. IDENT_INT (2),
162                     IDENT_INT (1) .. IDENT_INT (5));
163     BEGIN
164          A := SNTARR'(A'RANGE => (A'RANGE (2) => 0));
165          FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " &
166                   "THOSE OF SUBTYPE SNTARR" );
167     EXCEPTION
168          WHEN CONSTRAINT_ERROR =>
169               NULL;
170          WHEN OTHERS =>
171               FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " &
172                        "THE SAME AS THOSE OF SUBTYPE SNTARR" );
173     END;
174
175     DECLARE
176
177          SUBTYPE NULLNT IS NTARR (IDENT_INT (1) .. IDENT_INT (5),
178                                   IDENT_INT (1) .. IDENT_INT (0));
179
180          A : NTARR (IDENT_INT (1) .. IDENT_INT (5),
181                    IDENT_INT (1) .. IDENT_INT (1));
182     BEGIN
183          A := NULLNT'(A'RANGE => (A'RANGE (2) => 0));
184          FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " &
185                   "THOSE OF SUBTYPE NULLNT" );
186     EXCEPTION
187          WHEN CONSTRAINT_ERROR =>
188               NULL;
189          WHEN OTHERS =>
190               FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " &
191                        "THE SAME AS THOSE OF SUBTYPE NULLNT" );
192     END;
193
194     RESULT;
195END C47007A;
196