1-- C37108B.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 RAISED IN AN OBJECT DECLARATION IF
26-- A DEFAULT INITIAL VALUE HAS BEEN SPECIFIED WHICH VIOLATES THE
27-- CONSTRAINTS OF A RECORD OR AN ARRAY TYPE WHOSE CONSTRAINT
28-- DEPENDS ON A DISCRIMINANT, AND NO EXPLICIT INITIALIZATION IS
29-- PROVIDED FOR THE OBJECT.
30
31-- R.WILLIAMS 8/25/86
32-- EDS        7/16/98    AVOID OPTIMIZATION
33
34WITH REPORT; USE REPORT;
35PROCEDURE C37108B IS
36
37     TYPE ARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
38
39     TYPE R (P : POSITIVE) IS
40          RECORD
41               NULL;
42          END RECORD;
43
44BEGIN
45     TEST ( "C37108B", "CHECK THAT CONSTRAINT_ERROR IS RAISED IN " &
46                       "AN OBJECT DECLARATION IF A DEFAULT INITIAL " &
47                       "VALUE HAS BEEN SPECIFIED WHICH VIOLATES THE " &
48                       "CONSTRAINTS OF A RECORD OR AN ARRAY TYPE " &
49                       "WHOSE CONSTRAINT DEPENDS ON A DISCRIMINANT, " &
50                       "AND NO EXPLICIT INITIALIZATION IS PROVIDED " &
51                       "FOR THE OBJECT" );
52
53
54     BEGIN
55          DECLARE
56               TYPE REC1 (D : NATURAL := IDENT_INT (0)) IS
57                    RECORD
58                         A : ARR (D .. 5);
59                    END RECORD;
60
61          BEGIN
62               DECLARE
63                    R1 : REC1;
64
65               BEGIN
66                    R1.A (1) := IDENT_INT (2);
67                    FAILED ( "NO EXCEPTION RAISED AT DECLARATION OF " &
68                             "R1" & INTEGER'IMAGE(R1.A(5)));  --USE R2
69               EXCEPTION
70                    WHEN OTHERS =>
71                         FAILED ( "EXCEPTION FOR R1 RAISED INSIDE " &
72                                  "BLOCK" );
73               END;
74
75          EXCEPTION
76               WHEN CONSTRAINT_ERROR =>
77                    NULL;
78               WHEN OTHERS =>
79                    FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
80                             "OF R1" );
81          END;
82
83     EXCEPTION
84          WHEN CONSTRAINT_ERROR =>
85               FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " &
86                        "DECLARATION OF REC1" );
87          WHEN OTHERS =>
88               FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " &
89                        "DECLARATION OF REC1" );
90     END;
91
92     BEGIN
93          DECLARE
94               TYPE REC2 (D : INTEGER := IDENT_INT (-1)) IS
95                    RECORD
96                         A : R (P => D);
97                    END RECORD;
98
99          BEGIN
100               DECLARE
101                    R2 : REC2;
102
103               BEGIN
104                    R2.A := R'(P => IDENT_INT (1));
105                    FAILED ( "NO EXCEPTION RAISED AT DECLARATION OF " &
106                             "R2" & INTEGER'IMAGE(R2.A.P));  --USE R2
107               EXCEPTION
108                    WHEN OTHERS =>
109                         FAILED ( "EXCEPTION FOR R2 RAISED INSIDE " &
110                                  "BLOCK" );
111               END;
112
113          EXCEPTION
114               WHEN CONSTRAINT_ERROR =>
115                    NULL;
116               WHEN OTHERS =>
117                    FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
118                             "OF R2" );
119          END;
120
121     EXCEPTION
122          WHEN CONSTRAINT_ERROR =>
123               FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " &
124                        "DECLARATION OF REC2" );
125          WHEN OTHERS =>
126               FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " &
127                        "DECLARATION OF REC2" );
128     END;
129
130     BEGIN
131          DECLARE
132               PACKAGE PRIV IS
133                    TYPE REC3 (D : INTEGER := IDENT_INT (-1)) IS
134                         PRIVATE;
135                    PROCEDURE PROC (R :REC3);
136
137               PRIVATE
138                    TYPE REC3 (D : INTEGER := IDENT_INT (-1)) IS
139                         RECORD
140                              A : R (P => D);
141                         END RECORD;
142               END PRIV;
143
144               PACKAGE BODY PRIV IS
145                    PROCEDURE PROC (R : REC3) IS
146                         I : INTEGER;
147                    BEGIN
148                         I := IDENT_INT (R.A.P);
149                         IF EQUAL(2, IDENT_INT(1)) THEN
150                              FAILED("IMPOSSIBLE " & INTEGER'IMAGE(I));  --USE I
151                         END IF;
152                    END PROC;
153               END PRIV;
154
155               USE PRIV;
156
157          BEGIN
158               DECLARE
159                    R3 : REC3;
160
161               BEGIN
162                    PROC (R3);
163                    FAILED ( "NO EXCEPTION RAISED AT " &
164                              "DECLARATION OF R3" );
165               EXCEPTION
166                    WHEN OTHERS =>
167                         FAILED ( "EXCEPTION FOR R3 RAISED INSIDE " &
168                                  "BLOCK" );
169               END;
170
171          EXCEPTION
172               WHEN CONSTRAINT_ERROR =>
173                    NULL;
174               WHEN OTHERS =>
175                    FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
176                             "OF R3" );
177          END;
178
179     EXCEPTION
180          WHEN CONSTRAINT_ERROR =>
181               FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " &
182                        "DECLARATION OF REC3" );
183          WHEN OTHERS =>
184               FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " &
185                        "DECLARATION OF REC3" );
186     END;
187
188     BEGIN
189          DECLARE
190               PACKAGE LPRIV IS
191                    TYPE REC4 (D : NATURAL := IDENT_INT (0))
192                         IS LIMITED PRIVATE;
193                    PROCEDURE PROC (R :REC4);
194
195               PRIVATE
196                    TYPE REC4 (D : NATURAL := IDENT_INT (0)) IS
197                         RECORD
198                              A : ARR (D .. 5);
199                         END RECORD;
200               END LPRIV;
201
202               PACKAGE BODY LPRIV IS
203                    PROCEDURE PROC (R : REC4) IS
204                         I : INTEGER;
205                    BEGIN
206                         I := IDENT_INT (R.A'FIRST);
207                         IF EQUAL(2, IDENT_INT(1)) THEN
208                              FAILED("IMPOSSIBLE " & INTEGER'IMAGE(I));  --USE I
209                         END IF;
210                    END PROC;
211               END LPRIV;
212
213               USE LPRIV;
214
215          BEGIN
216               DECLARE
217                    R4 : REC4;
218
219               BEGIN
220                    PROC (R4);
221                    FAILED ( "NO EXCEPTION RAISED AT " &
222                             "DECLARATION OF R4" );
223               EXCEPTION
224                    WHEN OTHERS =>
225                         FAILED ( "EXCEPTION FOR R4 RAISED INSIDE " &
226                                  "BLOCK" );
227               END;
228
229          EXCEPTION
230               WHEN CONSTRAINT_ERROR =>
231                    NULL;
232               WHEN OTHERS =>
233                    FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
234                             "OF R4" );
235          END;
236
237     EXCEPTION
238          WHEN CONSTRAINT_ERROR =>
239               FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " &
240                        "DECLARATION OF REC4" );
241          WHEN OTHERS =>
242               FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " &
243                        "DECLARATION OF REC4" );
244     END;
245
246     RESULT;
247END C37108B;
248