Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c34008a.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 -- C34008A.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 -- OBJECTIVE:
26 -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED
27 -- (IMPLICITLY) FOR DERIVED TASK TYPES.
28
29 -- HISTORY:
30 -- JRK 08/27/87 CREATED ORIGINAL TEST.
31 -- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
32 -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
33 -- DTN 11/30/95 REMOVED ATTIBUTES OF NON-OBJECTS.
34
35 WITH SYSTEM; USE SYSTEM;
36 WITH REPORT; USE REPORT;
37
38 PROCEDURE C34008A IS
39
40 PACKAGE PKG IS
41
42 TASK TYPE PARENT IS
43 ENTRY E (I : IN OUT INTEGER);
44 ENTRY F (1 .. 3) (I : INTEGER; J : OUT INTEGER);
45 ENTRY G;
46 ENTRY H (1 .. 3);
47 ENTRY R (I : OUT INTEGER);
48 ENTRY W (I : INTEGER);
49 END PARENT;
50
51 FUNCTION ID (X : PARENT) RETURN INTEGER;
52
53 END PKG;
54
55 USE PKG;
56
57 TYPE T IS NEW PARENT;
58
59 TASK TYPE AUX;
60
61 X : T;
62 W : PARENT;
63 B : BOOLEAN := FALSE;
64 I : INTEGER := 0;
65 J : INTEGER := 0;
66 A1, A2 : AUX;
67
68 PROCEDURE A (X : ADDRESS) IS
69 BEGIN
70 B := IDENT_BOOL (TRUE);
71 END A;
72
73 FUNCTION V RETURN T IS
74 BEGIN
75 RETURN X;
76 END V;
77
78 PACKAGE BODY PKG IS
79
80 TASK BODY PARENT IS
81 N : INTEGER := 1;
82 BEGIN
83 LOOP
84 SELECT
85 ACCEPT E (I : IN OUT INTEGER) DO
86 I := I + N;
87 END E;
88 OR
89 ACCEPT F (2) (I : INTEGER; J : OUT INTEGER) DO
90 J := I + N;
91 END F;
92 OR
93 ACCEPT G DO
94 WHILE H(2)'COUNT < 2 LOOP
95 DELAY 5.0;
96 END LOOP;
97 ACCEPT H (2) DO
98 IF E'COUNT /= 0 OR
99 F(1)'COUNT /= 0 OR
100 F(2)'COUNT /= 0 OR
101 F(3)'COUNT /= 0 OR
102 G'COUNT /= 0 OR
103 H(1)'COUNT /= 0 OR
104 H(2)'COUNT /= 1 OR
105 H(3)'COUNT /= 0 OR
106 R'COUNT /= 0 OR
107 W'COUNT /= 0 THEN
108 FAILED ("INCORRECT 'COUNT");
109 END IF;
110 END H;
111 ACCEPT H (2);
112 END G;
113 OR
114 ACCEPT R (I : OUT INTEGER) DO
115 I := N;
116 END R;
117 OR
118 ACCEPT W (I : INTEGER) DO
119 N := I;
120 END W;
121 OR
122 TERMINATE;
123 END SELECT;
124 END LOOP;
125 END PARENT;
126
127 FUNCTION ID (X : PARENT) RETURN INTEGER IS
128 I : INTEGER;
129 BEGIN
130 X.R (I);
131 RETURN I;
132 END ID;
133
134 END PKG;
135
136 TASK BODY AUX IS
137 BEGIN
138 X.H (2);
139 END AUX;
140
141 BEGIN
142 TEST ("C34008A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
143 "ARE DECLARED (IMPLICITLY) FOR DERIVED TASK " &
144 "TYPES");
145
146 X.W (IDENT_INT (2));
147 IF ID (X) /= 2 THEN
148 FAILED ("INCORRECT INITIALIZATION");
149 END IF;
150
151 IF ID (T'(X)) /= 2 THEN
152 FAILED ("INCORRECT QUALIFICATION");
153 END IF;
154
155 IF ID (T (X)) /= 2 THEN
156 FAILED ("INCORRECT SELF CONVERSION");
157 END IF;
158
159 W.W (IDENT_INT (3));
160 IF ID (T (W)) /= 3 THEN
161 FAILED ("INCORRECT CONVERSION FROM PARENT");
162 END IF;
163
164 IF ID (PARENT (X)) /= 2 THEN
165 FAILED ("INCORRECT CONVERSION TO PARENT");
166 END IF;
167
168 I := 5;
169 X.E (I);
170 IF I /= 7 THEN
171 FAILED ("INCORRECT SELECTION (ENTRY)");
172 END IF;
173
174 I := 5;
175 X.F (IDENT_INT (2)) (I, J);
176 IF J /= 7 THEN
177 FAILED ("INCORRECT SELECTION (FAMILY)");
178 END IF;
179
180 IF NOT (X IN T) THEN
181 FAILED ("INCORRECT ""IN""");
182 END IF;
183
184 IF X NOT IN T THEN
185 FAILED ("INCORRECT ""NOT IN""");
186 END IF;
187
188
189 B := FALSE;
190 A (X'ADDRESS);
191 IF NOT B THEN
192 FAILED ("INCORRECT OBJECT'ADDRESS");
193 END IF;
194
195 IF NOT X'CALLABLE THEN
196 FAILED ("INCORRECT OBJECT'CALLABLE");
197 END IF;
198
199 IF NOT V'CALLABLE THEN
200 FAILED ("INCORRECT VALUE'CALLABLE");
201 END IF;
202
203 X.G;
204
205 IF X'SIZE < T'SIZE THEN
206 FAILED ("INCORRECT OBJECT'SIZE");
207 END IF;
208
209 IF T'STORAGE_SIZE < 0 THEN
210 FAILED ("INCORRECT TYPE'STORAGE_SIZE");
211 END IF;
212
213 IF X'STORAGE_SIZE < 0 THEN
214 FAILED ("INCORRECT OBJECT'STORAGE_SIZE");
215 END IF;
216
217 IF X'TERMINATED THEN
218 FAILED ("INCORRECT OBJECT'TERMINATED");
219 END IF;
220
221 IF V'TERMINATED THEN
222 FAILED ("INCORRECT VALUE'TERMINATED");
223 END IF;
224
225 RESULT;
226 END C34008A;