1-- C95086B.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--   BEFORE AN ENTRY CALL, WHEN AN IN OR IN OUT ACTUAL ACCESS
27--   PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS DIFFERENT
28--   FROM THE FORMAL PARAMETER.
29--
30--   SUBTESTS ARE:
31--       (A) IN MODE, STATIC ONE DIMENSIONAL BOUNDS.
32--       (B) IN OUT MODE, DYNAMIC RECORD DISCRIMINANTS.
33--       (C) CASE (A), BUT ACTUAL PARAMETER IS A TYPE CONVERSION.
34--       (D) CASE (B), BUT ACTUAL PARAMETER IS A TYPE CONVERSION.
35
36-- RJW 1/27/86
37
38WITH REPORT; USE REPORT;
39PROCEDURE C95086B IS
40
41BEGIN
42     TEST ( "C95086B", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
43            "BEFORE AN ENTRY CALL, WHEN AN IN OR IN OUT ACTUAL " &
44            "ACCESS PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS " &
45            "DIFFERENT FROM THE FORMAL PARAMETER" );
46
47     --------------------------------------------------
48
49     DECLARE -- (A)
50
51          TYPE E IS (E1, E2, E3, E4);
52          TYPE T IS ARRAY (E RANGE <>) OF INTEGER;
53
54          TYPE A IS ACCESS T;
55          SUBTYPE SA IS A (E2..E4);
56          V : A (E1..E2) := NULL;
57
58          TASK T1 IS
59               ENTRY P (X : SA);
60          END T1;
61
62          TASK BODY T1 IS
63          BEGIN
64               ACCEPT P (X : SA);
65          EXCEPTION
66               WHEN OTHERS =>
67                    FAILED ( "EXCEPTION RAISED IN TASK - (A)" );
68          END T1;
69
70     BEGIN -- (A)
71
72          T1.P (V);
73
74     EXCEPTION
75          WHEN OTHERS =>
76               FAILED ( "EXCEPTION RAISED - (A)" );
77     END; -- (A)
78
79     --------------------------------------------------
80
81     DECLARE -- (B)
82
83          TYPE ARR IS ARRAY (CHARACTER RANGE <>) OF INTEGER;
84
85          TYPE T (B : BOOLEAN := FALSE; C : CHARACTER := 'A') IS
86               RECORD
87                    I : INTEGER;
88                    CASE B IS
89                         WHEN FALSE =>
90                              J : INTEGER;
91                         WHEN TRUE =>
92                              A : ARR ('A' .. C);
93                    END CASE;
94               END RECORD;
95
96          TYPE A IS ACCESS T;
97          SUBTYPE SA IS A (TRUE, 'C');
98          V : A (IDENT_BOOL(FALSE), IDENT_CHAR('B')) := NULL;
99
100          TASK T1 IS
101               ENTRY P (X : IN OUT SA);
102          END T1;
103
104          TASK BODY T1 IS
105          BEGIN
106               ACCEPT P (X : IN OUT SA) DO
107                    NULL;
108               END P;
109          EXCEPTION
110               WHEN OTHERS =>
111                    FAILED ( "EXCEPTION RAISED IN TASK - (B)" );
112          END T1;
113
114     BEGIN -- (B)
115
116          T1.P (V);
117
118     EXCEPTION
119          WHEN OTHERS =>
120               FAILED ( "EXCEPTION RAISED - (B)" );
121     END; -- (B)
122
123     --------------------------------------------------
124
125     DECLARE -- (C)
126
127          TYPE E IS (E1, E2, E3, E4);
128          TYPE T IS ARRAY (E RANGE <>) OF INTEGER;
129
130          TYPE A IS ACCESS T;
131          SUBTYPE SA IS A (E2..E4);
132          V : A (E1..E2) := NULL;
133
134          TASK T1 IS
135               ENTRY P (X : SA);
136          END T1;
137
138          TASK BODY T1 IS
139          BEGIN
140               ACCEPT P (X : SA) DO
141                    NULL;
142               END P;
143          EXCEPTION
144               WHEN OTHERS =>
145                    FAILED ( "EXCEPTION RAISED IN TASK - (C)" );
146          END T1;
147
148     BEGIN -- (C)
149
150          T1.P (SA(V));
151
152     EXCEPTION
153          WHEN OTHERS =>
154               FAILED ( "EXCEPTION RAISED - (C)" );
155     END; -- (C)
156
157     --------------------------------------------------
158
159     DECLARE -- (D)
160
161          TYPE ARR IS ARRAY (CHARACTER RANGE <>) OF INTEGER;
162
163          TYPE T (B : BOOLEAN := FALSE; C : CHARACTER := 'A') IS
164               RECORD
165                    I : INTEGER;
166                    CASE B IS
167                         WHEN FALSE =>
168                              J : INTEGER;
169                         WHEN TRUE =>
170                              A : ARR ('A' .. C);
171                    END CASE;
172               END RECORD;
173
174          TYPE A IS ACCESS T;
175          SUBTYPE SA IS A (TRUE, 'C');
176          V : A (IDENT_BOOL(FALSE), IDENT_CHAR('B')) := NULL;
177
178          TASK T1 IS
179               ENTRY P (X : IN OUT SA);
180          END T1;
181
182          TASK BODY T1 IS
183          BEGIN
184               ACCEPT P (X : IN OUT SA);
185          EXCEPTION
186               WHEN OTHERS =>
187                    FAILED ( "EXCEPTION RAISED IN TASK - (D)" );
188          END T1;
189
190     BEGIN -- (D)
191
192          T1.P (SA(V));
193
194     EXCEPTION
195          WHEN OTHERS =>
196               FAILED ( "EXCEPTION RAISED - (D)" );
197     END; -- (D)
198
199     --------------------------------------------------
200
201     RESULT;
202END C95086B;
203