1-- C64105C.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-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS
26--   IN THE FOLLOWING CIRCUMSTANCES:
27--       (1)
28--       (2) AFTER THE CALL, WHEN AN IN OUT OR OUT FORMAL
29--           ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS
30--           DIFFERENT CONSTRAINTS.
31--       (3)
32--   SUBTESTS ARE:
33--       (C) CASE 2, IN OUT MODE, STATIC PRIVATE DISCRIMINANT.
34--       (D) CASE 2, OUT MODE, DYNAMIC TWO DIMENSIONAL BOUNDS.
35--       (E) SAME AS (C), WITH TYPE CONVERSION.
36--       (F) SAME AS (D), WITH TYPE CONVERSION.
37
38-- JRK 3/20/81
39-- SPS 10/26/82
40-- CPP 8/8/84
41
42WITH REPORT;
43PROCEDURE C64105C IS
44
45     USE REPORT;
46
47BEGIN
48     TEST ("C64105C", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
49           "AFTER THE CALL, WHEN AN IN OUT OR OUT FORMAL " &
50           "ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS " &
51           "DIFFERENT CONSTRAINTS" );
52
53     --------------------------------------------------
54
55     DECLARE -- (C)
56
57          PACKAGE PKG IS
58               TYPE E IS (E1, E2);
59               TYPE T (D : E := E1) IS PRIVATE;
60          PRIVATE
61               TYPE T (D : E := E1) IS
62                    RECORD
63                         I : INTEGER;
64                         CASE D IS
65                              WHEN E1 =>
66                                   B : BOOLEAN;
67                              WHEN E2 =>
68                                   C : CHARACTER;
69                         END CASE;
70                    END RECORD;
71          END PKG;
72          USE PKG;
73
74          TYPE A IS ACCESS T;
75          SUBTYPE SA IS A(E2);
76          V : A (E1) := NULL;
77          ENTERED : BOOLEAN := FALSE;
78
79          PROCEDURE P (X : IN OUT SA) IS
80          BEGIN
81               ENTERED := TRUE;
82               X := NULL;
83          EXCEPTION
84               WHEN OTHERS =>
85                    FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)");
86          END P;
87
88     BEGIN -- (C)
89
90          P (V);
91
92     EXCEPTION
93          WHEN CONSTRAINT_ERROR =>
94               IF NOT ENTERED THEN
95                    FAILED ("EXCEPTION RAISED BEFORE CALL - (C)");
96               ELSE
97                    FAILED ("EXCEPTION RAISED ON RETURN - (C)");
98               END IF;
99          WHEN OTHERS =>
100               FAILED ("EXCEPTION RAISED - (C)");
101     END; -- (C)
102
103     --------------------------------------------------
104
105     DECLARE -- (D)
106
107          TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF
108                    INTEGER;
109
110          TYPE A IS ACCESS T;
111          SUBTYPE SA IS A ('D'..'F', FALSE..FALSE);
112          V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'),
113                 IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL;
114          ENTERED : BOOLEAN := FALSE;
115
116          PROCEDURE P (X : OUT SA) IS
117          BEGIN
118               ENTERED := TRUE;
119               X := NULL;
120          EXCEPTION
121               WHEN OTHERS =>
122                    FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)");
123          END P;
124
125     BEGIN -- (D)
126
127          P (V);
128
129     EXCEPTION
130          WHEN CONSTRAINT_ERROR =>
131               IF NOT ENTERED THEN
132                    FAILED ("EXCEPTION RAISED BEFORE CALL - (D)");
133               ELSE
134                    FAILED ("EXCEPTION RAISED ON RETURN - (D)");
135               END IF;
136          WHEN OTHERS =>
137               FAILED ("EXCEPTION RAISED - (D)");
138     END; -- (D)
139
140     --------------------------------------------------
141
142     DECLARE -- (E)
143
144          PACKAGE PKG IS
145               TYPE E IS (E1, E2);
146               TYPE T (D : E := E1) IS PRIVATE;
147          PRIVATE
148               TYPE T (D : E := E1) IS
149                    RECORD
150                         I : INTEGER;
151                         CASE D IS
152                              WHEN E1 =>
153                                   B : BOOLEAN;
154                              WHEN E2 =>
155                                   C : CHARACTER;
156                         END CASE;
157                    END RECORD;
158          END PKG;
159          USE PKG;
160
161          TYPE A IS ACCESS T;
162          SUBTYPE SA IS A(E2);
163          V : A (E1) := NULL;
164          ENTERED : BOOLEAN := FALSE;
165
166          PROCEDURE P (X : IN OUT SA) IS
167          BEGIN
168               ENTERED := TRUE;
169               X := NULL;
170          EXCEPTION
171               WHEN OTHERS =>
172                    FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)");
173          END P;
174
175     BEGIN -- (E)
176
177          P (SA(V));
178
179     EXCEPTION
180          WHEN CONSTRAINT_ERROR =>
181               IF NOT ENTERED THEN
182                    FAILED ("EXCEPTION RAISED BEFORE CALL - (E)");
183               ELSE
184                    FAILED ("EXCEPTION RAISED ON RETURN - (E)");
185               END IF;
186          WHEN OTHERS =>
187               FAILED ("EXCEPTION RAISED - (E)");
188     END; -- (E)
189
190     --------------------------------------------------
191
192     DECLARE -- (F)
193
194          TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF
195                    INTEGER;
196
197          TYPE A IS ACCESS T;
198          SUBTYPE SA IS A ('D'..'F', FALSE..FALSE);
199          V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'),
200                 IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL;
201          ENTERED : BOOLEAN := FALSE;
202
203          PROCEDURE P (X : OUT SA) IS
204          BEGIN
205               ENTERED := TRUE;
206               X := NULL;
207          EXCEPTION
208               WHEN OTHERS =>
209                    FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)");
210          END P;
211
212     BEGIN -- (D)
213
214          P (SA(V));
215
216     EXCEPTION
217          WHEN CONSTRAINT_ERROR =>
218               IF NOT ENTERED THEN
219                    FAILED ("EXCEPTION RAISED BEFORE CALL - (F)");
220               ELSE
221                    FAILED ("EXCEPTION RAISED ON RETURN - (F)");
222               END IF;
223          WHEN OTHERS =>
224               FAILED ("EXCEPTION RAISED - (F)");
225     END; -- (F)
226
227     --------------------------------------------------
228
229     RESULT;
230END C64105C;
231