gcc/testsuite/ada/acats/tests/c9/c93004f.ada

   1 -- C93004F.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 DURING THE ACTIVATION OF A
  26 -- TASK, OTHER TASKS ARE UNAFFECTED.
  27
  28 -- THE ENCLOSING BLOCK RECEIVES TASKING_ERROR.
  29
  30 -- THIS TESTS CHECKS THE CASE IN WHICH THE TASKS ARE CREATED BY THE
  31 -- ALLOCATION OF A RECORD OF TASKS OR AN ARRAY OF TASKS.
  32
  33 -- R. WILLIAMS 8/7/86
  34
  35 WITH REPORT; USE REPORT;
  36
  37 PROCEDURE C93004F IS
  38
  39 BEGIN
  40      TEST ( "C93004F", "CHECK THAT WHEN AN EXCEPTION IS RAISED " &
  41                        "DURING THE ACTIVATION OF A TASK, OTHER " &
  42                        "TASKS ARE UNAFFECTED. IN THIS TEST, THE " &
  43                        "TASKS ARE CREATED BY THE ALLOCATION OF A " &
  44                        "RECORD OR AN ARRAY OF TASKS" );
  45
  46      DECLARE
  47
  48           TASK TYPE T IS
  49                ENTRY E;
  50           END T;
  51
  52           TASK TYPE TT;
  53
  54           TASK TYPE TX IS
  55                ENTRY E;
  56           END TX;
  57
  58           TYPE REC IS
  59                RECORD
  60                     TR : T;
  61                END RECORD;
  62
  63           TYPE ARR IS ARRAY (IDENT_INT (1) .. IDENT_INT (1)) OF T;
  64
  65           TYPE RECX IS
  66                RECORD
  67                     TTX1 : TX;
  68                     TTT  : TT;
  69                     TTX2 : TX;
  70                END RECORD;
  71
  72           TYPE ACCR IS ACCESS REC;
  73           AR : ACCR;
  74
  75           TYPE ACCA IS ACCESS ARR;
  76           AA : ACCA;
  77
  78           TYPE ACCX IS ACCESS RECX;
  79           AX : ACCX;
  80
  81           TASK BODY T IS
  82           BEGIN
  83                ACCEPT E;
  84           END T;
  85
  86           TASK BODY TT IS
  87           BEGIN
  88                AR.TR.E;
  89           EXCEPTION
  90                WHEN OTHERS =>
  91                     FAILED ( "TASK AR.TR NOT ACTIVE" );
  92           END TT;
  93
  94           TASK BODY TX IS
  95                I : POSITIVE := IDENT_INT (0); -- RAISE
  96                                               -- CONSTRAINT_ERROR.
  97           BEGIN
  98                IF I /= IDENT_INT (2) OR I = IDENT_INT (1) + 1 THEN
  99                     FAILED ( "TX ACTIVATED OK" );
 100                END IF;
 101           END TX;
 102
 103      BEGIN
 104           AR := NEW REC;
 105           AA := NEW ARR;
 106           AX := NEW RECX;
 107
 108           FAILED ( "TASKING_ERROR NOT RAISED IN MAIN" );
 109
 110           AA.ALL (1).E;        -- CLEAN UP.
 111
 112      EXCEPTION
 113           WHEN TASKING_ERROR =>
 114
 115                BEGIN
 116                     AA.ALL (1).E;
 117                EXCEPTION
 118                     WHEN TASKING_ERROR =>
 119                          FAILED ( "AA.ALL (1) NOT ACTIVATED" );
 120                END;
 121
 122           WHEN CONSTRAINT_ERROR =>
 123                FAILED ( "CONSTRAINT_ERROR RAISED IN MAIN" );
 124           WHEN OTHERS =>
 125                FAILED ( "ABNORMAL EXCEPTION IN MAIN" );
 126      END;
 127
 128      RESULT;
 129
 130 END C93004F;