1-- C37006A.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-- FOR A COMPONENT OF A RECORD, ACCESS, OR PRIVATE TYPE, OR FOR A
26-- LIMITED PRIVATE COMPONENT, CHECK THAT A NON-STATIC EXPRESSION CAN
27-- BE USED IN A DISCRIMINANT CONSTRAINT OR (EXCEPTING LIMITED PRIVATE
28-- COMPONENTS) IN SPECIFYING A DEFAULT INITIAL VALUE.
29
30-- R.WILLIAMS 8/28/86
31
32WITH REPORT; USE REPORT;
33PROCEDURE C37006A IS
34
35     SUBTYPE INT IS INTEGER RANGE 0 .. 100;
36
37     TYPE ARR IS ARRAY (INT RANGE <>) OF INTEGER;
38
39     TYPE REC1 (D1, D2 : INT) IS
40          RECORD
41               A : ARR (D1 .. D2);
42          END RECORD;
43
44     TYPE REC1_NAME IS ACCESS REC1;
45
46     PROCEDURE CHECK (AR : ARR; STR : STRING) IS
47     BEGIN
48          IF AR'FIRST /= 1 OR AR'LAST /= 2 THEN
49               FAILED ( "INCORRECT BOUNDS FOR R.COMP.A IN COMPONENT " &
50                        "OF " & STR & " TYPE");
51          ELSIF AR /= (3, 4) THEN
52               FAILED ( "INITIALIZATION OF R.COMP.A IN COMPONENT OF " &
53                         STR & " TYPE FAILED" );
54          END IF;
55     END CHECK;
56
57     PACKAGE PACK IS
58          TYPE PRIV (D1, D2 : INT) IS PRIVATE;
59          TYPE LIM (D1, D2 : INT) IS LIMITED PRIVATE;
60          FUNCTION PRIV_FUN (PARM1, PARM2 : INTEGER) RETURN PRIV;
61          PROCEDURE PRIV_CHECK (R : PRIV);
62          PROCEDURE LIM_CHECK (R : LIM);
63
64     PRIVATE
65          TYPE PRIV (D1, D2 : INT) IS
66               RECORD
67                    A : ARR (D1 .. D2);
68               END RECORD;
69
70          TYPE LIM (D1, D2 : INT) IS
71               RECORD
72                    A : ARR (D1 .. D2);
73               END RECORD;
74     END PACK;
75
76     PACKAGE BODY PACK IS
77
78          FUNCTION PRIV_FUN (PARM1, PARM2 : INTEGER) RETURN PRIV IS
79          BEGIN
80               RETURN (IDENT_INT (1), IDENT_INT (2),
81                       ARR'(1 => 3, 2 => 4));
82          END PRIV_FUN;
83
84          PROCEDURE PRIV_CHECK (R : PRIV) IS
85          BEGIN
86               CHECK (R.A, "PRIVATE TYPE" );
87          END PRIV_CHECK;
88
89          PROCEDURE LIM_CHECK (R : LIM) IS
90          BEGIN
91               IF R.A'FIRST /= 1 OR R.A'LAST /= 2 THEN
92                    FAILED ( "INCORRECT BOUNDS FOR R.COMP.A IN " &
93                             "COMPONENT OF LIMITED PRIVATE TYPE");
94               END IF;
95          END LIM_CHECK;
96     END PACK;
97
98     USE PACK;
99
100BEGIN
101
102     TEST ( "C37006A", "FOR A COMPONENT OF A RECORD, ACCESS, " &
103                       "OR PRIVATE TYPE, OR FOR A LIMITED PRIVATE " &
104                       "COMPONENT, CHECK THAT A NON-STATIC " &
105                       "EXPRESSION CAN BE USED IN A DISCRIMINANT " &
106                       "CONSTRAINT OR (EXCEPTING LIMITED PRIVATE " &
107                       "COMPONENTS) IN SPECIFYING A DEFAULT " &
108                       "INITIAL VALUE" );
109
110     BEGIN
111          DECLARE
112
113               TYPE REC2 IS
114                    RECORD
115                         COMP : REC1 (IDENT_INT (1), IDENT_INT (2)) :=
116                                (IDENT_INT (1), IDENT_INT (2),
117                                 ARR'(1 => 3, 2 => 4));
118                    END RECORD;
119
120          R : REC2;
121
122          BEGIN
123               IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN
124                    CHECK (R.COMP.A, "RECORD");
125               ELSE
126                    FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " &
127                             "OF RECORD TYPE COMPONENT" );
128               END IF;
129
130          EXCEPTION
131               WHEN CONSTRAINT_ERROR =>
132                    FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " &
133                             "SEQUENCE FOLLOWING DECLARATION OF " &
134                             "RECORD TYPE COMPONENT" );
135               WHEN OTHERS =>
136                    FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " &
137                             "SEQUENCE FOLLOWING DECLARATION OF " &
138                             "RECORD TYPE COMPONENT" );
139          END;
140
141     EXCEPTION
142          WHEN CONSTRAINT_ERROR =>
143               FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " &
144                        "OF RECORD TYPE COMPONENT" );
145          WHEN OTHERS =>
146               FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " &
147                        "OF RECORD TYPE COMPONENT" );
148     END;
149
150     BEGIN
151          DECLARE
152
153               TYPE REC2 IS
154                    RECORD
155                         COMP : REC1_NAME (IDENT_INT (1),
156                                           IDENT_INT (2)) :=
157                                NEW REC1'(IDENT_INT (1),
158                                          IDENT_INT (2),
159                                          ARR'(1 => 3, 2 => 4));
160                    END RECORD;
161
162          R : REC2;
163
164          BEGIN
165               IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN
166                    CHECK (R.COMP.A, "ACCESS");
167               ELSE
168                    FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " &
169                             "OF ACCESS TYPE COMPONENT" );
170               END IF;
171
172          EXCEPTION
173               WHEN CONSTRAINT_ERROR =>
174                    FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " &
175                             "SEQUENCE FOLLOWING DECLARATION OF " &
176                             "ACCESS TYPE COMPONENT" );
177               WHEN OTHERS =>
178                    FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " &
179                             "SEQUENCE FOLLOWING DECLARATION OF " &
180                             "ACCESS TYPE COMPONENT" );
181          END;
182
183     EXCEPTION
184          WHEN CONSTRAINT_ERROR =>
185               FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " &
186                        "OF ACCESS TYPE COMPONENT" );
187          WHEN OTHERS =>
188               FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " &
189                        "OF ACCESS TYPE COMPONENT" );
190     END;
191
192     BEGIN
193          DECLARE
194
195               TYPE REC2 IS
196                    RECORD
197                         COMP : PRIV (IDENT_INT (1), IDENT_INT (2)) :=
198                                PRIV_FUN (IDENT_INT (1),
199                                          IDENT_INT (2));
200                    END RECORD;
201
202          R : REC2;
203
204          BEGIN
205               IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN
206                    PRIV_CHECK (R.COMP);
207               ELSE
208                    FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " &
209                             "OF PRIVATE TYPE COMPONENT" );
210               END IF;
211
212          EXCEPTION
213               WHEN CONSTRAINT_ERROR =>
214                    FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " &
215                             "SEQUENCE FOLLOWING DECLARATION OF " &
216                             "PRIVATE TYPE COMPONENT" );
217               WHEN OTHERS =>
218                    FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " &
219                             "SEQUENCE FOLLOWING DECLARATION OF " &
220                             "PRIVATE TYPE COMPONENT" );
221          END;
222
223     EXCEPTION
224          WHEN CONSTRAINT_ERROR =>
225               FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " &
226                        "OF PRIVATE TYPE COMPONENT" );
227          WHEN OTHERS =>
228               FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " &
229                        "OF PRIVATE TYPE COMPONENT" );
230     END;
231
232     BEGIN
233          DECLARE
234
235               TYPE REC2 IS
236                    RECORD
237                         COMP : LIM (IDENT_INT (1), IDENT_INT (2));
238                    END RECORD;
239
240          R : REC2;
241
242          BEGIN
243               IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN
244                    LIM_CHECK (R.COMP);
245               ELSE
246                    FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " &
247                             "OF LIM PRIV TYPE COMPONENT" );
248               END IF;
249
250          EXCEPTION
251               WHEN CONSTRAINT_ERROR =>
252                    FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " &
253                             "SEQUENCE FOLLOWING DECLARATION OF " &
254                             " LIM PRIV TYPE COMPONENT" );
255               WHEN OTHERS =>
256                    FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " &
257                             "SEQUENCE FOLLOWING DECLARATION OF " &
258                             " LIM PRIV TYPE COMPONENT" );
259          END;
260
261     EXCEPTION
262          WHEN CONSTRAINT_ERROR =>
263               FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " &
264                        "OF  LIM PRIV TYPE COMPONENT" );
265          WHEN OTHERS =>
266               FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " &
267                        "OF  LIM PRIV TYPE COMPONENT" );
268     END;
269
270     RESULT;
271
272END C37006A;
273