Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c6/c64105c.ada @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 -- C64105C.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 -- IN THE FOLLOWING CIRCUMSTANCES:
27 -- (1)
28 -- (2) AFTER THE CALL, WHEN AN IN OUT OR OUT FORMAL
29 -- ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS
30 -- DIFFERENT CONSTRAINTS.
31 -- (3)
32 -- SUBTESTS ARE:
33 -- (C) CASE 2, IN OUT MODE, STATIC PRIVATE DISCRIMINANT.
34 -- (D) CASE 2, OUT MODE, DYNAMIC TWO DIMENSIONAL BOUNDS.
35 -- (E) SAME AS (C), WITH TYPE CONVERSION.
36 -- (F) SAME AS (D), WITH TYPE CONVERSION.
37
38 -- JRK 3/20/81
39 -- SPS 10/26/82
40 -- CPP 8/8/84
41
42 WITH REPORT;
43 PROCEDURE C64105C IS
44
45 USE REPORT;
46
47 BEGIN
48 TEST ("C64105C", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
49 "AFTER THE CALL, WHEN AN IN OUT OR OUT FORMAL " &
50 "ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS " &
51 "DIFFERENT CONSTRAINTS" );
52
53 --------------------------------------------------
54
55 DECLARE -- (C)
56
57 PACKAGE PKG IS
58 TYPE E IS (E1, E2);
59 TYPE T (D : E := E1) IS PRIVATE;
60 PRIVATE
61 TYPE T (D : E := E1) IS
62 RECORD
63 I : INTEGER;
64 CASE D IS
65 WHEN E1 =>
66 B : BOOLEAN;
67 WHEN E2 =>
68 C : CHARACTER;
69 END CASE;
70 END RECORD;
71 END PKG;
72 USE PKG;
73
74 TYPE A IS ACCESS T;
75 SUBTYPE SA IS A(E2);
76 V : A (E1) := NULL;
77 ENTERED : BOOLEAN := FALSE;
78
79 PROCEDURE P (X : IN OUT SA) IS
80 BEGIN
81 ENTERED := TRUE;
82 X := NULL;
83 EXCEPTION
84 WHEN OTHERS =>
85 FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)");
86 END P;
87
88 BEGIN -- (C)
89
90 P (V);
91
92 EXCEPTION
93 WHEN CONSTRAINT_ERROR =>
94 IF NOT ENTERED THEN
95 FAILED ("EXCEPTION RAISED BEFORE CALL - (C)");
96 ELSE
97 FAILED ("EXCEPTION RAISED ON RETURN - (C)");
98 END IF;
99 WHEN OTHERS =>
100 FAILED ("EXCEPTION RAISED - (C)");
101 END; -- (C)
102
103 --------------------------------------------------
104
105 DECLARE -- (D)
106
107 TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF
108 INTEGER;
109
110 TYPE A IS ACCESS T;
111 SUBTYPE SA IS A ('D'..'F', FALSE..FALSE);
112 V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'),
113 IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL;
114 ENTERED : BOOLEAN := FALSE;
115
116 PROCEDURE P (X : OUT SA) IS
117 BEGIN
118 ENTERED := TRUE;
119 X := NULL;
120 EXCEPTION
121 WHEN OTHERS =>
122 FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)");
123 END P;
124
125 BEGIN -- (D)
126
127 P (V);
128
129 EXCEPTION
130 WHEN CONSTRAINT_ERROR =>
131 IF NOT ENTERED THEN
132 FAILED ("EXCEPTION RAISED BEFORE CALL - (D)");
133 ELSE
134 FAILED ("EXCEPTION RAISED ON RETURN - (D)");
135 END IF;
136 WHEN OTHERS =>
137 FAILED ("EXCEPTION RAISED - (D)");
138 END; -- (D)
139
140 --------------------------------------------------
141
142 DECLARE -- (E)
143
144 PACKAGE PKG IS
145 TYPE E IS (E1, E2);
146 TYPE T (D : E := E1) IS PRIVATE;
147 PRIVATE
148 TYPE T (D : E := E1) IS
149 RECORD
150 I : INTEGER;
151 CASE D IS
152 WHEN E1 =>
153 B : BOOLEAN;
154 WHEN E2 =>
155 C : CHARACTER;
156 END CASE;
157 END RECORD;
158 END PKG;
159 USE PKG;
160
161 TYPE A IS ACCESS T;
162 SUBTYPE SA IS A(E2);
163 V : A (E1) := NULL;
164 ENTERED : BOOLEAN := FALSE;
165
166 PROCEDURE P (X : IN OUT SA) IS
167 BEGIN
168 ENTERED := TRUE;
169 X := NULL;
170 EXCEPTION
171 WHEN OTHERS =>
172 FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)");
173 END P;
174
175 BEGIN -- (E)
176
177 P (SA(V));
178
179 EXCEPTION
180 WHEN CONSTRAINT_ERROR =>
181 IF NOT ENTERED THEN
182 FAILED ("EXCEPTION RAISED BEFORE CALL - (E)");
183 ELSE
184 FAILED ("EXCEPTION RAISED ON RETURN - (E)");
185 END IF;
186 WHEN OTHERS =>
187 FAILED ("EXCEPTION RAISED - (E)");
188 END; -- (E)
189
190 --------------------------------------------------
191
192 DECLARE -- (F)
193
194 TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF
195 INTEGER;
196
197 TYPE A IS ACCESS T;
198 SUBTYPE SA IS A ('D'..'F', FALSE..FALSE);
199 V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'),
200 IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL;
201 ENTERED : BOOLEAN := FALSE;
202
203 PROCEDURE P (X : OUT SA) IS
204 BEGIN
205 ENTERED := TRUE;
206 X := NULL;
207 EXCEPTION
208 WHEN OTHERS =>
209 FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)");
210 END P;
211
212 BEGIN -- (D)
213
214 P (SA(V));
215
216 EXCEPTION
217 WHEN CONSTRAINT_ERROR =>
218 IF NOT ENTERED THEN
219 FAILED ("EXCEPTION RAISED BEFORE CALL - (F)");
220 ELSE
221 FAILED ("EXCEPTION RAISED ON RETURN - (F)");
222 END IF;
223 WHEN OTHERS =>
224 FAILED ("EXCEPTION RAISED - (F)");
225 END; -- (F)
226
227 --------------------------------------------------
228
229 RESULT;
230 END C64105C;