1-- C95086D.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 OR AFTER THE ENTRY CALL, WHEN AN UNCONSTRAINED ACTUAL
27--    OUT ACCESS PARAMETER DESIGNATES AN OBJECT (PRIOR TO THE
28--    ENTRY CALL) WITH CONSTRAINTS DIFFERENT FROM THE FORMAL
29--    PARAMETER.
30--
31--   SUBTESTS ARE:
32--       (A) STATIC LIMITED PRIVATE DISCRIMINANT.
33--       (B) DYNAMIC ONE DIMENSIONAL BOUNDS.
34
35-- RJW 2/3/86
36
37WITH REPORT; USE REPORT;
38PROCEDURE C95086D IS
39
40BEGIN
41     TEST ("C95086D", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
42           "BEFORE AND AFTER THE ENTRY CALL, WHEN AN UNCONSTRAINED " &
43           "ACTUAL OUT ACCESS PARAMETER DESIGNATES AN OBJECT (PRIOR " &
44           "TO THE ENTRY CALL) WITH CONSTRAINTS DIFFERENT FROM THE " &
45           "FORMAL PARAMETER");
46
47     --------------------------------------------------
48
49     DECLARE -- (A)
50
51          PACKAGE PKG IS
52               SUBTYPE INT IS INTEGER RANGE 0..5;
53               TYPE T (I : INT := 0) IS LIMITED PRIVATE;
54          PRIVATE
55               TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
56               TYPE T (I : INT := 0) IS
57                    RECORD
58                         J : INTEGER;
59                         A : ARR (1..I);
60                    END RECORD;
61          END PKG;
62
63          USE PKG;
64
65          TYPE A IS ACCESS T;
66          SUBTYPE SA IS A (3);
67          V : A := NEW T (2);
68          CALLED : BOOLEAN := FALSE;
69
70          TASK T1 IS
71               ENTRY P (X : OUT SA);
72          END T1;
73
74          TASK BODY T1 IS
75          BEGIN
76               ACCEPT P (X : OUT SA) DO
77                    CALLED := TRUE;
78                    X := NEW T (3);
79               END P;
80          EXCEPTION
81               WHEN OTHERS =>
82                    FAILED ("EXCEPTION RAISED IN TASK - (A)");
83          END T1;
84
85     BEGIN -- (A)
86
87          T1.P (V);
88
89     EXCEPTION
90          WHEN CONSTRAINT_ERROR =>
91               IF NOT CALLED THEN
92                    FAILED ("EXCEPTION RAISED BEFORE ENTRY CALL - (A)");
93               ELSE
94                    FAILED ("EXCEPTION RAISED ON RETURN - (A)");
95               END IF;
96          WHEN OTHERS =>
97               FAILED ("EXCEPTION RAISED - (A)");
98     END; -- (A)
99
100     --------------------------------------------------
101
102     DECLARE -- (B)
103
104          TYPE A IS ACCESS STRING;
105          SUBTYPE SA IS A (1..2);
106          V : A := NEW STRING (IDENT_INT(5) .. IDENT_INT(7));
107          CALLED : BOOLEAN := FALSE;
108
109          TASK T1 IS
110               ENTRY P (X : OUT SA);
111          END T1;
112
113          TASK BODY T1 IS
114          BEGIN
115               ACCEPT P (X : OUT SA) DO
116                    CALLED := TRUE;
117                    X := NEW STRING (IDENT_INT(1) .. IDENT_INT(2));
118               END P;
119          EXCEPTION
120               WHEN OTHERS =>
121                    FAILED ("EXCEPTION RAISED IN TASK - (B)");
122          END T1;
123
124     BEGIN -- (B)
125
126          T1.P (V);
127
128     EXCEPTION
129          WHEN CONSTRAINT_ERROR =>
130               IF NOT CALLED THEN
131                    FAILED ("EXCEPTION RAISED BEFORE ENTRY CALL - (B)");
132               ELSE
133                    FAILED ("EXCEPTION RAISED ON RETURN - (B)");
134               END IF;
135          WHEN OTHERS =>
136               FAILED ("EXCEPTION RAISED - (B)");
137     END; -- (B)
138
139     --------------------------------------------------
140
141     RESULT;
142END C95086D;
143