c93005b.ada

来自「用于进行gcc测试」· ADA 代码 · 共 274 行

-- 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;