1-- C64106C.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 ASSIGNMENTS TO FORMAL PARAMETERS OF UNCONSTRAINED
26--    RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH DEFAULT
27--    CONSTRAINTS RAISE CONSTRAINT_ERROR IF THE ACTUAL PARAMETER IS
28--    CONSTRAINED AND THE CONSTRAINT VALUES OF THE OBJECT BEING
29--    ASSIGNED TO DO NOT SATISFY THOSE OF THE ACTUAL PARAMETER.
30
31--    SUBTESTS ARE:
32--        (A) CONSTRAINED ACTUAL PARAMETERS OF RECORD TYPE.
33--        (B) CONSTRAINED ACTUAL PARAMETERS OF PRIVATE TYPE.
34--        (C) CONSTRAINED ACTUAL PARAMETERS OF LIMITED PRIVATE TYPE.
35
36-- DAS  1/16/81
37-- VKG  1/7/83
38-- CPP  8/9/84
39
40WITH REPORT;
41PROCEDURE C64106C IS
42
43     USE REPORT;
44
45BEGIN
46
47     TEST ("C64106C", "CHECK ASSIGNMENTS TO FORMAL PARAMETERS OF " &
48                      "UNCONSTRAINED TYPES (WITH DEFAULTS)");
49
50     --------------------------------------------------
51
52     DECLARE  -- (A)
53
54          PACKAGE PKG IS
55
56               SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
57
58               TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
59                    RECORD
60                         INTFLD   : INTRANGE;
61                         STRFLD   : STRING(1..CONSTRAINT);
62                    END RECORD;
63
64               REC91,REC92,REC93  : RECTYPE(9);
65               REC_OOPS           : RECTYPE(4);
66
67               PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
68                            REC3 : OUT RECTYPE);
69          END PKG;
70
71          PACKAGE BODY PKG IS
72
73               PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
74                            REC3 : OUT RECTYPE) IS
75
76                    PROCEDURE P1 (REC11 : IN RECTYPE;
77                                  REC12 : IN OUT RECTYPE;
78                                  REC13 : OUT RECTYPE) IS
79                    BEGIN
80                         IF (NOT REC11'CONSTRAINED) OR
81                            (REC11.CONSTRAINT /= IDENT_INT(9)) THEN
82                              FAILED ("CONSTRAINT ON RECORD " &
83                                      "TYPE IN PARAMETER " &
84                                      "NOT RECOGNIZED");
85                         END IF;
86
87                         BEGIN  -- ASSIGNMENT TO IN OUT PARAMETER
88                              REC12 := REC_OOPS;
89                              FAILED ("CONSTRAINT ERROR NOT RAISED - " &
90                                      "A.1");
91                         EXCEPTION
92                              WHEN CONSTRAINT_ERROR =>
93                                   NULL;
94                              WHEN OTHERS =>
95                                   FAILED ("WRONG EXCEPTION RAISED - " &
96                                           "A.1");
97                         END;
98
99                         BEGIN  -- ASSIGNMENT TO OUT PARAMETER
100                              REC13 := REC_OOPS;
101                              FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
102                                      "A.2");
103                         EXCEPTION
104                              WHEN CONSTRAINT_ERROR =>
105                                   NULL;
106                              WHEN OTHERS =>
107                                   FAILED ("WRONG EXCEPTION RAISED - " &
108                                           "A.2");
109                         END;
110                    END P1;
111
112               BEGIN
113                    P1 (REC1, REC2, REC3);
114               END P;
115
116          BEGIN
117
118               REC91 := (9, 9, "123456789");
119               REC92 := REC91;
120               REC93 := REC91;
121
122               REC_OOPS := (4, 4, "OOPS");
123
124          END PKG;
125
126     BEGIN  -- (A)
127
128          PKG.P (PKG.REC91, PKG.REC92, PKG.REC93);
129
130     END;   -- (A)
131
132     --------------------------------------------------
133
134     DECLARE  -- (B)
135
136          PACKAGE PKG IS
137
138               SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
139
140               TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS PRIVATE;
141
142               PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
143                            REC3 : OUT RECTYPE);
144
145          PRIVATE
146
147               TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
148                    RECORD
149                         INTFLD   : INTRANGE;
150                         STRFLD   : STRING(1..CONSTRAINT);
151                    END RECORD;
152          END PKG;
153
154          REC91, REC92, REC93  : PKG.RECTYPE(9);
155          REC_OOPS             : PKG.RECTYPE(4);
156
157          PACKAGE BODY PKG IS
158
159               PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
160                            REC3 : OUT RECTYPE) IS
161
162                    PROCEDURE P1 (REC11 : IN RECTYPE;
163                                  REC12 : IN OUT RECTYPE;
164                                  REC13 : OUT RECTYPE) IS
165                    BEGIN
166                         IF (NOT REC11'CONSTRAINED) OR
167                            (REC11.CONSTRAINT /= IDENT_INT(9)) THEN
168                              FAILED ("CONSTRAINT ON PRIVATE " &
169                                      "TYPE IN PARAMETER " &
170                                      "NOT RECOGNIZED");
171                         END IF;
172
173                         BEGIN  -- ASSIGNMENT TO IN OUT PARAMETER
174                              REC12 := REC_OOPS;
175                              FAILED ("CONSTRAINT ERROR NOT RAISED - " &
176                                      "B.1");
177                         EXCEPTION
178                              WHEN CONSTRAINT_ERROR =>
179                                   NULL;
180                              WHEN OTHERS =>
181                                   FAILED ("WRONG EXCEPTION RAISED - " &
182                                           "B.1");
183                         END;
184
185                         BEGIN  -- ASSIGNMENT TO OUT PARAMETER
186                              REC13 := REC_OOPS;
187                              FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
188                                      "B.2");
189                         EXCEPTION
190                              WHEN CONSTRAINT_ERROR =>
191                                   NULL;
192                              WHEN OTHERS =>
193                                   FAILED ("WRONG EXCEPTION RAISED - " &
194                                           "B.2");
195                         END;
196                    END P1;
197
198               BEGIN
199                    P1 (REC1, REC2, REC3);
200               END P;
201
202          BEGIN
203
204               REC91 := (9, 9, "123456789");
205               REC92 := REC91;
206               REC93 := REC91;
207
208               REC_OOPS := (4, 4, "OOPS");
209
210          END PKG;
211
212     BEGIN  -- (B)
213
214          PKG.P (REC91, REC92, REC93);
215
216     END;   -- (B)
217
218     --------------------------------------------------
219
220     DECLARE  -- (C)
221
222          PACKAGE PKG IS
223
224               SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
225
226               TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
227                    LIMITED PRIVATE;
228
229               PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
230                            REC3 : OUT RECTYPE);
231
232          PRIVATE
233
234               TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
235                    RECORD
236                         INTFLD   : INTRANGE;
237                         STRFLD   : STRING(1..CONSTRAINT);
238                    END RECORD;
239          END PKG;
240
241          REC91,REC92,REC93  : PKG.RECTYPE(9);
242          REC_OOPS           : PKG.RECTYPE(4);
243
244          PACKAGE BODY PKG IS
245
246               PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
247                            REC3 : OUT RECTYPE) IS
248
249                    PROCEDURE P1 (REC11 : IN RECTYPE;
250                                  REC12 : IN OUT RECTYPE;
251                                  REC13 : OUT RECTYPE) IS
252                    BEGIN
253                         IF (NOT REC11'CONSTRAINED) OR
254                            (REC11.CONSTRAINT /= 9) THEN
255                              FAILED ("CONSTRAINT ON LIMITED PRIVATE " &
256                                      "TYPE IN PARAMETER " &
257                                      "NOT RECOGNIZED");
258                         END IF;
259
260                         BEGIN  -- ASSIGNMENT TO IN OUT PARAMETER
261                              REC12 := REC_OOPS;
262                              FAILED ("CONSTRAINT ERROR NOT RAISED - " &
263                                      "C.1");
264                         EXCEPTION
265                              WHEN CONSTRAINT_ERROR =>
266                                   NULL;
267                              WHEN OTHERS =>
268                                   FAILED ("WRONG EXCEPTION RAISED - " &
269                                           "C.1");
270                         END;
271
272                         BEGIN  -- ASSIGNMENT TO OUT PARAMETER
273                              REC13 := REC_OOPS;
274                              FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
275                                      "C.2");
276                         EXCEPTION
277                              WHEN CONSTRAINT_ERROR =>
278                                   NULL;
279                              WHEN OTHERS =>
280                                   FAILED ("WRONG EXCEPTION RAISED - " &
281                                           "C.2");
282                         END;
283                    END P1;
284
285               BEGIN
286                    P1 (REC1, REC2, REC3);
287               END P;
288
289          BEGIN
290
291               REC91 := (9, 9, "123456789");
292               REC92 := REC91;
293               REC93 := REC91;
294
295               REC_OOPS := (4, 4, "OOPS");
296
297          END PKG;
298
299     BEGIN  -- (C)
300
301          PKG.P (REC91, REC92, REC93);
302
303     END;   -- (C)
304
305     --------------------------------------------------
306
307     RESULT;
308
309END C64106C;
310