1-- C93005B.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 WHEN AN EXCEPTION IS RAISED IN A DECLARATIVE PART, A TASK
26-- DECLARED IN THE SAME DECLARATIVE PART BECOMES TERMINATED.
27
28-- CHECK THAT A TASK WAITING ON ENTRIES OF SUCH A
29-- TERMINATED-BEFORE-ACTIVATION TASK RECEIVES TASKING_ERROR.
30
31-- THIS TEST CHECKS THE CASE IN WHICH SEVERAL TASKS ARE WAITING FOR
32-- ACTIVATION WHEN THE EXCEPTION OCCURS.
33
34-- R. WILLIAMS 8/7/86
35-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
36
37WITH SYSTEM; USE SYSTEM;
38WITH REPORT; USE REPORT;
39
40PROCEDURE C93005B IS
41
42
43BEGIN
44     TEST ( "C93005B", "CHECK THAT WHEN AN EXCEPTION IS RAISED IN A " &
45                       "DECLARATIVE PART, A TASK DECLARED IN THE " &
46                       "SAME DECLARATIVE PART BECOMES TERMINATED. " &
47                       "IN THIS CASE, SEVERAL TASKS ARE WAITING FOR " &
48                       "ACTIVATION WHEN THE EXCEPTION OCCURS" );
49
50     BEGIN
51
52          DECLARE
53               TASK TYPE TA IS      -- CHECKS THAT TX TERMINATES.
54               END TA;
55
56               TYPE ATA IS ACCESS TA;
57
58               TASK TYPE TB IS      -- CHECKS THAT TY TERMINATES.
59               END TB;
60
61               TYPE TBREC IS
62                    RECORD
63                         TTB: TB;
64                    END RECORD;
65
66               TASK TX IS          -- WILL NEVER BE ACTIVATED.
67                    ENTRY E;
68               END TX;
69
70               TASK BODY TA IS
71               BEGIN
72                    DECLARE  -- THIS BLOCK TO CHECK THAT TAB
73                             -- TERMINATES.
74                         TASK TAB IS
75                         END TAB;
76
77                         TASK BODY TAB IS
78                         BEGIN
79                              TX.E;
80                              FAILED ( "RENDEZVOUS COMPLETED " &
81                                       "WITHOUT ERROR - TAB" );
82                         EXCEPTION
83                              WHEN TASKING_ERROR =>
84                                   NULL;
85                              WHEN OTHERS =>
86                                   FAILED ( "ABNORMAL EXCEPTION " &
87                                            "- TAB" );
88                         END TAB;
89                    BEGIN
90                         NULL;
91                    END;
92
93                    TX.E;    --TX IS NOW TERMINATED.
94
95                    FAILED ( "RENDEZVOUS COMPLETED WITHOUT ERROR " &
96                             "- TA" );
97
98               EXCEPTION
99                    WHEN TASKING_ERROR =>
100                         NULL;
101                    WHEN OTHERS =>
102                         FAILED ( "ABNORMAL EXCEPTION - TA" );
103               END TA;
104
105               PACKAGE RAISE_IT IS
106                    TASK TY IS             -- WILL NEVER BE ACTIVATED.
107                         ENTRY E;
108                    END TY;
109               END RAISE_IT;
110
111               TASK BODY TB IS
112               BEGIN
113                    DECLARE  -- THIS BLOCK TO CHECK THAT TBB
114                             -- TERMINATES.
115                         TASK TBB IS
116                         END TBB;
117
118                         TASK BODY TBB IS
119                         BEGIN
120                              RAISE_IT.TY.E;
121                              FAILED ( "RENDEZVOUS COMPLETED " &
122                                       "WITHOUT ERROR - TBB" );
123                         EXCEPTION
124                              WHEN TASKING_ERROR =>
125                                   NULL;
126                              WHEN OTHERS =>
127                                   FAILED ( "ABNORMAL EXCEPTION " &
128                                            "- TBB" );
129                         END TBB;
130                    BEGIN
131                         NULL;
132                    END;
133
134                    RAISE_IT.TY.E;    -- TY IS NOW TERMINATED.
135
136                    FAILED ( "RENDEZVOUS COMPLETED WITHOUT ERROR " &
137                             "- TB" );
138
139               EXCEPTION
140                    WHEN TASKING_ERROR =>
141                         NULL;
142                    WHEN OTHERS =>
143                         FAILED ( "ABNORMAL EXCEPTION - TB" );
144               END TB;
145
146               PACKAGE START_TC IS END START_TC;
147
148               TASK BODY TX IS
149               BEGIN
150                    FAILED ( "TX ACTIVATED" );
151                    -- IN CASE OF FAILURE.
152                    LOOP
153                         SELECT
154                              ACCEPT E;
155                         OR
156                              TERMINATE;
157                         END SELECT;
158                    END LOOP;
159               END TX;
160
161               PACKAGE START_TZ IS
162                    TASK TZ IS             -- WILL NEVER BE ACTIVATED.
163                         ENTRY E;
164                    END TZ;
165               END START_TZ;
166
167               PACKAGE BODY START_TC IS
168                    TBREC1 : TBREC;     -- CHECKS THAT TY TERMINATES.
169
170                    TASK TC IS -- CHECKS THAT TZ TERMINATES.
171                    END TC;
172
173                    TASK BODY TC IS
174                    BEGIN
175                         DECLARE  -- THIS BLOCK TO CHECK THAT TCB
176                                  -- TERMINATES.
177
178                              TASK TCB IS
179                              END TCB;
180
181                              TASK BODY TCB IS
182                              BEGIN
183                                   START_TZ.TZ.E;
184                                   FAILED ( "RENDEZVOUS COMPLETED " &
185                                            "WITHOUT " &
186                                            "ERROR - TCB" );
187                              EXCEPTION
188                                   WHEN TASKING_ERROR =>
189                                        NULL;
190                                   WHEN OTHERS =>
191                                        FAILED ( "ABNORMAL " &
192                                                 "EXCEPTION - TCB" );
193                              END TCB;
194                         BEGIN
195                              NULL;
196                         END;
197
198                         START_TZ.TZ.E;    -- TZ IS NOW TERMINATED.
199
200                         FAILED ( "RENDEZVOUS COMPLETED WITHOUT " &
201                                  "ERROR - TC" );
202
203                    EXCEPTION
204                         WHEN TASKING_ERROR =>
205                              NULL;
206                         WHEN OTHERS =>
207                              FAILED ( "ABNORMAL EXCEPTION - TC" );
208                    END TC;
209               END START_TC;     -- TBREC1 AND TC ACTIVATED HERE.
210
211               PACKAGE BODY RAISE_IT IS
212                    NTA : ATA := NEW TA;  -- NTA.ALL ACTIVATED HERE.
213
214                    TASK BODY TY IS
215                    BEGIN
216                         FAILED ( "TY ACTIVATED" );
217                         -- IN CASE OF FAILURE.
218                         LOOP
219                              SELECT
220                                   ACCEPT E;
221                              OR
222                                   TERMINATE;
223                              END SELECT;
224                         END LOOP;
225                    END TY;
226
227                    PACKAGE XCEPTION IS
228                         I : POSITIVE := IDENT_INT (0); -- RAISE
229                                                   -- CONSTRAINT_ERROR.
230                    END XCEPTION;
231
232                    USE XCEPTION;
233
234               BEGIN   -- TY WOULD BE ACTIVATED HERE.
235
236                    IF I /= IDENT_INT (2) OR I = IDENT_INT (1) + 1 THEN
237                         FAILED ( "PACKAGE DIDN'T RAISE EXCEPTION" );
238                    END IF;
239               END RAISE_IT;
240
241               PACKAGE BODY START_TZ IS
242                    TASK BODY TZ IS
243                    BEGIN
244                         FAILED ( "TZ ACTIVATED" );
245                         -- IN CASE OF FAILURE.
246                         LOOP
247                              SELECT
248                                   ACCEPT E;
249                              OR
250                                   TERMINATE;
251                              END SELECT;
252                         END LOOP;
253                    END TZ;
254               END START_TZ;    -- TZ WOULD BE ACTIVATED HERE.
255
256          BEGIN     -- TX WOULD BE ACTIVATED HERE.
257                    -- CAN'T LEAVE BLOCK UNTIL TA, TB, AND TC ARE TERM.
258
259               FAILED ( "EXCEPTION NOT RAISED" );
260          END;
261
262     EXCEPTION
263          WHEN CONSTRAINT_ERROR =>
264               NULL;
265          WHEN TASKING_ERROR =>
266               FAILED ( "TASKING_ERROR IN MAIN PROGRAM" );
267          WHEN OTHERS =>
268               FAILED ( "ABNORMAL EXCEPTION IN MAIN" );
269     END;
270
271     RESULT;
272
273END C93005B;
274