1-- C47009B.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--     WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES AN ACCESS
27--     TYPE, CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN THE VALUE
28--     OF THE OPERAND IS NULL.
29
30-- HISTORY:
31--     RJW 07/23/86  CREATED ORIGINAL TEST.
32--     BCB 08/18/87  CHANGED HEADER TO STANDARD HEADER FORMAT.  CHANGED
33--                   CONSTRAINTS OF B SUBTYPES TO VALUES WHICH ARE
34--                   CLOSER TO THE VALUES OF THE A SUBTYPES.  INDENTED
35--                   THE EXCEPTION STATEMENTS IN SUBTEST 11.
36
37WITH REPORT; USE REPORT;
38PROCEDURE C47009B IS
39
40BEGIN
41
42     TEST( "C47009B", "WHEN THE TYPE MARK IN A QUALIFIED " &
43                      "EXPRESSION DENOTES AN ACCESS TYPE, " &
44                      "CHECK THAT CONSTRAINT_ERROR IS NOT " &
45                      "RAISED WHEN THE VALUE OF THE OPERAND IS NULL" );
46
47     DECLARE
48
49          TYPE ACC1 IS ACCESS BOOLEAN;
50          A : ACC1;
51
52     BEGIN
53          A := ACC1'(NULL);
54     EXCEPTION
55          WHEN CONSTRAINT_ERROR =>
56               FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC1" );
57          WHEN OTHERS =>
58               FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC1" );
59     END;
60
61     DECLARE
62
63          TYPE ACC2 IS ACCESS INTEGER;
64          A : ACC2;
65
66     BEGIN
67          A := ACC2'(NULL);
68     EXCEPTION
69          WHEN CONSTRAINT_ERROR =>
70               FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC2" );
71          WHEN OTHERS =>
72               FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC2" );
73     END;
74
75     DECLARE
76
77          TYPE CHAR IS ('A', 'B');
78          TYPE ACC3 IS ACCESS CHAR;
79          A : ACC3;
80
81     BEGIN
82          A := ACC3'(NULL);
83     EXCEPTION
84          WHEN CONSTRAINT_ERROR =>
85               FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC3" );
86          WHEN OTHERS =>
87               FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC3" );
88     END;
89
90     DECLARE
91
92          TYPE FLOAT1 IS DIGITS 5 RANGE -1.0 .. 1.0;
93          TYPE ACC4 IS ACCESS FLOAT1;
94          A : ACC4;
95
96     BEGIN
97          A := ACC4'(NULL);
98     EXCEPTION
99          WHEN CONSTRAINT_ERROR =>
100               FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC4" );
101          WHEN OTHERS =>
102               FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC4" );
103     END;
104
105     DECLARE
106
107          TYPE FIXED IS DELTA 0.5 RANGE -1.0 .. 1.0;
108          TYPE ACC5 IS ACCESS FIXED;
109          A : ACC5;
110
111     BEGIN
112          A := ACC5'(NULL);
113     EXCEPTION
114          WHEN CONSTRAINT_ERROR =>
115               FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC5" );
116          WHEN OTHERS =>
117               FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC5" );
118     END;
119
120     DECLARE
121
122          TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER;
123          TYPE ACC6 IS ACCESS ARR;
124          SUBTYPE ACC6A IS ACC6 (IDENT_INT (1) .. IDENT_INT (5));
125          SUBTYPE ACC6B IS ACC6 (IDENT_INT (2) .. IDENT_INT (10));
126          A : ACC6A;
127          B : ACC6B;
128
129     BEGIN
130          A := ACC6A'(B);
131     EXCEPTION
132          WHEN CONSTRAINT_ERROR =>
133               FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " &
134                        "TYPE ACC6" );
135          WHEN OTHERS =>
136               FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " &
137                        "TYPE ACC6" );
138     END;
139
140     DECLARE
141
142          TYPE ARR IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>)
143               OF INTEGER;
144          TYPE ACC7 IS ACCESS ARR;
145          SUBTYPE ACC7A IS ACC7 (IDENT_INT (1) .. IDENT_INT (5),
146                                 IDENT_INT (1) .. IDENT_INT (1));
147          SUBTYPE ACC7B IS ACC7 (IDENT_INT (1) .. IDENT_INT (15),
148                                 IDENT_INT (1) .. IDENT_INT (10));
149          A : ACC7A;
150          B : ACC7B;
151
152     BEGIN
153          A := ACC7A'(B);
154     EXCEPTION
155          WHEN CONSTRAINT_ERROR =>
156               FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " &
157                        "TYPE ACC7" );
158          WHEN OTHERS =>
159               FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " &
160                        "TYPE ACC7" );
161     END;
162
163     DECLARE
164
165          TYPE REC (D : INTEGER) IS
166               RECORD
167                    NULL;
168               END RECORD;
169
170          TYPE ACC8 IS ACCESS REC;
171          SUBTYPE ACC8A IS ACC8 (IDENT_INT (5));
172          SUBTYPE ACC8B IS ACC8 (IDENT_INT (6));
173          A : ACC8A;
174          B : ACC8B;
175
176     BEGIN
177          A := ACC8A'(B);
178     EXCEPTION
179          WHEN CONSTRAINT_ERROR =>
180               FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " &
181                        "TYPE ACC8" );
182          WHEN OTHERS =>
183               FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " &
184                        "TYPE ACC8" );
185     END;
186
187     DECLARE
188
189          TYPE REC (D1,D2 : INTEGER) IS
190               RECORD
191                    NULL;
192               END RECORD;
193
194          TYPE ACC9 IS ACCESS REC;
195          SUBTYPE ACC9A IS ACC9 (IDENT_INT (4), IDENT_INT (5));
196          SUBTYPE ACC9B IS ACC9 (IDENT_INT (5), IDENT_INT (4));
197          A : ACC9A;
198          B : ACC9B;
199
200     BEGIN
201          A := ACC9A'(B);
202     EXCEPTION
203          WHEN CONSTRAINT_ERROR =>
204               FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " &
205                        "TYPE ACC9" );
206          WHEN OTHERS =>
207               FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " &
208                        "TYPE ACC9" );
209     END;
210
211     DECLARE
212
213          PACKAGE PKG IS
214               TYPE REC (D : INTEGER) IS PRIVATE;
215
216          PRIVATE
217               TYPE REC (D : INTEGER) IS
218                    RECORD
219                         NULL;
220                    END RECORD;
221
222          END PKG;
223
224          USE PKG;
225
226          TYPE ACC10 IS ACCESS REC;
227          SUBTYPE ACC10A IS ACC10 (IDENT_INT (10));
228          SUBTYPE ACC10B IS ACC10 (IDENT_INT (9));
229          A : ACC10A;
230          B : ACC10B;
231
232     BEGIN
233          A := ACC10A'(B);
234     EXCEPTION
235          WHEN CONSTRAINT_ERROR =>
236               FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " &
237                        "TYPE ACC10" );
238          WHEN OTHERS =>
239               FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " &
240                        "TYPE ACC10" );
241     END;
242
243     DECLARE
244
245          PACKAGE PKG1 IS
246               TYPE REC (D : INTEGER) IS LIMITED PRIVATE;
247
248          PRIVATE
249               TYPE REC (D : INTEGER) IS
250                    RECORD
251                         NULL;
252                    END RECORD;
253          END PKG1;
254
255          PACKAGE PKG2 IS END PKG2;
256
257          PACKAGE BODY PKG2 IS
258               USE PKG1;
259
260               TYPE ACC11 IS ACCESS REC;
261               SUBTYPE ACC11A IS ACC11 (IDENT_INT (11));
262               SUBTYPE ACC11B IS ACC11 (IDENT_INT (12));
263               A : ACC11A;
264               B : ACC11B;
265
266          BEGIN
267               A := ACC11A'(B);
268          EXCEPTION
269               WHEN CONSTRAINT_ERROR =>
270                    FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF" &
271                             " TYPE ACC11" );
272               WHEN OTHERS =>
273                    FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " &
274                             "TYPE ACC11" );
275          END PKG2;
276
277     BEGIN
278          NULL;
279     END;
280
281     RESULT;
282END C47009B;
283