aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/testsuite/ada/acats/tests/c9/c93005b.ada
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c9/c93005b.ada')
-rw-r--r--gcc-4.9/gcc/testsuite/ada/acats/tests/c9/c93005b.ada273
1 files changed, 273 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c9/c93005b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c9/c93005b.ada
new file mode 100644
index 000000000..1b621c0de
--- /dev/null
+++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c9/c93005b.ada
@@ -0,0 +1,273 @@
+-- C93005B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT WHEN AN EXCEPTION IS RAISED IN A DECLARATIVE PART, A TASK
+-- DECLARED IN THE SAME DECLARATIVE PART BECOMES TERMINATED.
+
+-- CHECK THAT A TASK WAITING ON ENTRIES OF SUCH A
+-- TERMINATED-BEFORE-ACTIVATION TASK RECEIVES TASKING_ERROR.
+
+-- THIS TEST CHECKS THE CASE IN WHICH SEVERAL TASKS ARE WAITING FOR
+-- ACTIVATION WHEN THE EXCEPTION OCCURS.
+
+-- R. WILLIAMS 8/7/86
+-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
+
+WITH SYSTEM; USE SYSTEM;
+WITH REPORT; USE REPORT;
+
+PROCEDURE C93005B IS
+
+
+BEGIN
+ TEST ( "C93005B", "CHECK THAT WHEN AN EXCEPTION IS RAISED IN A " &
+ "DECLARATIVE PART, A TASK DECLARED IN THE " &
+ "SAME DECLARATIVE PART BECOMES TERMINATED. " &
+ "IN THIS CASE, SEVERAL TASKS ARE WAITING FOR " &
+ "ACTIVATION WHEN THE EXCEPTION OCCURS" );
+
+ BEGIN
+
+ DECLARE
+ TASK TYPE TA IS -- CHECKS THAT TX TERMINATES.
+ END TA;
+
+ TYPE ATA IS ACCESS TA;
+
+ TASK TYPE TB IS -- CHECKS THAT TY TERMINATES.
+ END TB;
+
+ TYPE TBREC IS
+ RECORD
+ TTB: TB;
+ END RECORD;
+
+ TASK TX IS -- WILL NEVER BE ACTIVATED.
+ ENTRY E;
+ END TX;
+
+ TASK BODY TA IS
+ BEGIN
+ DECLARE -- THIS BLOCK TO CHECK THAT TAB
+ -- TERMINATES.
+ TASK TAB IS
+ END TAB;
+
+ TASK BODY TAB IS
+ BEGIN
+ TX.E;
+ FAILED ( "RENDEZVOUS COMPLETED " &
+ "WITHOUT ERROR - TAB" );
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ( "ABNORMAL EXCEPTION " &
+ "- TAB" );
+ END TAB;
+ BEGIN
+ NULL;
+ END;
+
+ TX.E; --TX IS NOW TERMINATED.
+
+ FAILED ( "RENDEZVOUS COMPLETED WITHOUT ERROR " &
+ "- TA" );
+
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ( "ABNORMAL EXCEPTION - TA" );
+ END TA;
+
+ PACKAGE RAISE_IT IS
+ TASK TY IS -- WILL NEVER BE ACTIVATED.
+ ENTRY E;
+ END TY;
+ END RAISE_IT;
+
+ TASK BODY TB IS
+ BEGIN
+ DECLARE -- THIS BLOCK TO CHECK THAT TBB
+ -- TERMINATES.
+ TASK TBB IS
+ END TBB;
+
+ TASK BODY TBB IS
+ BEGIN
+ RAISE_IT.TY.E;
+ FAILED ( "RENDEZVOUS COMPLETED " &
+ "WITHOUT ERROR - TBB" );
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ( "ABNORMAL EXCEPTION " &
+ "- TBB" );
+ END TBB;
+ BEGIN
+ NULL;
+ END;
+
+ RAISE_IT.TY.E; -- TY IS NOW TERMINATED.
+
+ FAILED ( "RENDEZVOUS COMPLETED WITHOUT ERROR " &
+ "- TB" );
+
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ( "ABNORMAL EXCEPTION - TB" );
+ END TB;
+
+ PACKAGE START_TC IS END START_TC;
+
+ TASK BODY TX IS
+ BEGIN
+ FAILED ( "TX ACTIVATED" );
+ -- IN CASE OF FAILURE.
+ LOOP
+ SELECT
+ ACCEPT E;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END TX;
+
+ PACKAGE START_TZ IS
+ TASK TZ IS -- WILL NEVER BE ACTIVATED.
+ ENTRY E;
+ END TZ;
+ END START_TZ;
+
+ PACKAGE BODY START_TC IS
+ TBREC1 : TBREC; -- CHECKS THAT TY TERMINATES.
+
+ TASK TC IS -- CHECKS THAT TZ TERMINATES.
+ END TC;
+
+ TASK BODY TC IS
+ BEGIN
+ DECLARE -- THIS BLOCK TO CHECK THAT TCB
+ -- TERMINATES.
+
+ TASK TCB IS
+ END TCB;
+
+ TASK BODY TCB IS
+ BEGIN
+ START_TZ.TZ.E;
+ FAILED ( "RENDEZVOUS COMPLETED " &
+ "WITHOUT " &
+ "ERROR - TCB" );
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ( "ABNORMAL " &
+ "EXCEPTION - TCB" );
+ END TCB;
+ BEGIN
+ NULL;
+ END;
+
+ START_TZ.TZ.E; -- TZ IS NOW TERMINATED.
+
+ FAILED ( "RENDEZVOUS COMPLETED WITHOUT " &
+ "ERROR - TC" );
+
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ( "ABNORMAL EXCEPTION - TC" );
+ END TC;
+ END START_TC; -- TBREC1 AND TC ACTIVATED HERE.
+
+ PACKAGE BODY RAISE_IT IS
+ NTA : ATA := NEW TA; -- NTA.ALL ACTIVATED HERE.
+
+ TASK BODY TY IS
+ BEGIN
+ FAILED ( "TY ACTIVATED" );
+ -- IN CASE OF FAILURE.
+ LOOP
+ SELECT
+ ACCEPT E;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END TY;
+
+ PACKAGE XCEPTION IS
+ I : POSITIVE := IDENT_INT (0); -- RAISE
+ -- CONSTRAINT_ERROR.
+ END XCEPTION;
+
+ USE XCEPTION;
+
+ BEGIN -- TY WOULD BE ACTIVATED HERE.
+
+ IF I /= IDENT_INT (2) OR I = IDENT_INT (1) + 1 THEN
+ FAILED ( "PACKAGE DIDN'T RAISE EXCEPTION" );
+ END IF;
+ END RAISE_IT;
+
+ PACKAGE BODY START_TZ IS
+ TASK BODY TZ IS
+ BEGIN
+ FAILED ( "TZ ACTIVATED" );
+ -- IN CASE OF FAILURE.
+ LOOP
+ SELECT
+ ACCEPT E;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END TZ;
+ END START_TZ; -- TZ WOULD BE ACTIVATED HERE.
+
+ BEGIN -- TX WOULD BE ACTIVATED HERE.
+ -- CAN'T LEAVE BLOCK UNTIL TA, TB, AND TC ARE TERM.
+
+ FAILED ( "EXCEPTION NOT RAISED" );
+ END;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN TASKING_ERROR =>
+ FAILED ( "TASKING_ERROR IN MAIN PROGRAM" );
+ WHEN OTHERS =>
+ FAILED ( "ABNORMAL EXCEPTION IN MAIN" );
+ END;
+
+ RESULT;
+
+END C93005B;