diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/cb')
45 files changed, 6850 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb10002.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb10002.a new file mode 100644 index 000000000..f3099d4a2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb10002.a @@ -0,0 +1,128 @@ +-- CB10002.A + +-- 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. +--* +-- +-- OBJECTIVE: +-- Check that Storage_Error is raised when storage for allocated objects +-- is exceeded. +-- +-- TEST DESCRIPTION: +-- This test allocates a very large data structure. +-- +-- In order to avoid running forever on virtual memory targets, the +-- data structure is bounded in size, and elements are larger the longer +-- the program runs. +-- +-- The program attempts to allocate about 8,600,000 integers, or about +-- 32 Megabytes on a typical 32-bit machine. +-- +-- If Storage_Error is raised, the data structure is deallocated. +-- (Otherwise, Report.Result may fail as memory is exhausted). + +-- CHANGE HISTORY: +-- 30 Aug 85 JRK Ada 83 test created. +-- 14 Sep 99 RLB Created Ada 95 test. + + +with Report; +with Ada.Unchecked_Deallocation; +procedure CB10002 is + + type Data_Space is array (Positive range <>) of Integer; + + type Element (Size : Positive); + + type Link is access Element; + + type Element (Size : Positive) is + record + Parent : Link; + Child : Link; + Sibling: Link; + Data : Data_Space (1 .. Size); + end record; + + procedure Free is new Ada.Unchecked_Deallocation (Element, Link); + + Holder : array (1 .. 430) of Link; + Last_Allocated : Natural := 0; + + procedure Allocator (Count : in Positive) is + begin + -- Allocate various sized objects similar to what a real application + -- would do. + if Count in 1 .. 20 then + Holder(Count) := new Element (Report.Ident_Int(10)); + elsif Count in 21 .. 40 then + Holder(Count) := new Element (Report.Ident_Int(79)); + elsif Count in 41 .. 60 then + Holder(Count) := new Element (Report.Ident_Int(250)); + elsif Count in 61 .. 80 then + Holder(Count) := new Element (Report.Ident_Int(520)); + elsif Count in 81 .. 100 then + Holder(Count) := new Element (Report.Ident_Int(1000)); + elsif Count in 101 .. 120 then + Holder(Count) := new Element (Report.Ident_Int(2048)); + elsif Count in 121 .. 140 then + Holder(Count) := new Element (Report.Ident_Int(4200)); + elsif Count in 141 .. 160 then + Holder(Count) := new Element (Report.Ident_Int(7999)); + elsif Count in 161 .. 180 then + Holder(Count) := new Element (Report.Ident_Int(15000)); + else -- 181..430 + Holder(Count) := new Element (Report.Ident_Int(32000)); + end if; + Last_Allocated := Count; + end Allocator; + + +begin + Report.Test ("CB10002", "Check that Storage_Error is raised when " & + "storage for allocated objects is exceeded"); + + begin + for I in Holder'range loop + Allocator (I); + end loop; + Report.Not_Applicable ("Unable to exhaust memory"); + for I in 1 .. Last_Allocated loop + Free (Holder(I)); + end loop; + exception + when Storage_Error => + if Last_Allocated = 0 then + Report.Failed ("Unable to allocate anything"); + else -- Clean up, so we have enough memory to report on the result. + for I in 1 .. Last_Allocated loop + Free (Holder(I)); + end loop; + Report.Comment (Natural'Image(Last_Allocated) & " items allocated"); + end if; + when others => + Report.Failed ("Wrong exception raised by heap overflow"); + end; + + Report.Result; + +end CB10002; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb1001a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb1001a.ada new file mode 100644 index 000000000..5cd5391e5 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb1001a.ada @@ -0,0 +1,102 @@ +-- CB1001A.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 ALL PREDEFINED EXCEPTIONS MAY BE RAISED EXPLICITLY +-- AND MAY HAVE HANDLERS WRITTEN FOR THEM. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- DCB 03/25/80 +-- JRK 11/17/80 +-- SPS 11/2/82 +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; +PROCEDURE CB1001A IS + + USE REPORT; + + FLOW_COUNT : INTEGER := 0; + +BEGIN + TEST("CB1001A", "CHECK THAT ALL PREDEFINED EXCEPTIONS MAY BE " & + "RAISED EXPLICITLY AND MAY HAVE HANDLERS WRITTEN FOR THEM"); + + BEGIN + RAISE CONSTRAINT_ERROR; + FAILED("NO EXCEPTION RAISED WHEN CONSTRAINT_ERROR EXPECTED"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED WHEN CONSTRAINT_ERROR " & + "EXPECTED"); + END; + + + BEGIN + RAISE PROGRAM_ERROR; + FAILED("NO EXCEPTION RAISED WHEN PROGRAM_ERROR EXPECTED"); + EXCEPTION + WHEN PROGRAM_ERROR => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED WHEN PROGRAM_ERROR " & + "EXPECTED"); + END; + + BEGIN + RAISE STORAGE_ERROR; + FAILED("NO EXCEPTION RAISED WHEN STORAGE_ERROR EXPECTED"); + + EXCEPTION + WHEN STORAGE_ERROR => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED WHEN STORAGE_ERROR " & + "EXPECTED"); + END; + + BEGIN + RAISE TASKING_ERROR; + FAILED("NO EXCEPTION RAISED WHEN TASKING_ERROR EXPECTED"); + + EXCEPTION + WHEN TASKING_ERROR => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED WHEN TASKING_ERROR " & + "EXPECTED"); + END; + + IF FLOW_COUNT /= 4 THEN + FAILED("WRONG FLOW_COUNT VALUE"); + END IF; + + RESULT; +END CB1001A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb1004a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb1004a.ada new file mode 100644 index 000000000..d137d0e32 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb1004a.ada @@ -0,0 +1,85 @@ +-- CB1004A.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 EXCEPTIONS DECLARED IN RECURSIVE PROCEDURES ARE NOT +-- REPLICATED ANEW FOR EACH RECURSIVE ACTIVATION OF THE PROCEDURE. + +-- DCB 03/30/80 +-- JRK 11/17/80 +-- SPS 3/23/83 + +WITH REPORT; +PROCEDURE CB1004A IS + + USE REPORT; + + FLOW_COUNT : INTEGER := 0; + + PROCEDURE P1(SWITCH1 : IN INTEGER) IS + + E1 : EXCEPTION; + + PROCEDURE P2 IS + + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; -- 3 + P1(2); + FAILED("EXCEPTION NOT PROPAGATED"); + + EXCEPTION + WHEN E1 => + FLOW_COUNT := FLOW_COUNT + 1; -- 6 + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED"); + END P2; + + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; -- 2 -- 4 + IF SWITCH1 = 1 THEN + P2; + ELSIF SWITCH1 = 2 THEN + FLOW_COUNT := FLOW_COUNT + 1; -- 5 + RAISE E1; + FAILED("EXCEPTION NOT RAISED"); + END IF; + END P1; + +BEGIN + TEST("CB1004A","CHECK THAT EXCEPTIONS ARE NOT RECURSIVELY " & + "REPLICATED"); + + FLOW_COUNT := FLOW_COUNT + 1; -- 1 + P1(1); + + IF FLOW_COUNT /= 6 THEN + FAILED("INCORRECT FLOW_COUNT VALUE"); + END IF; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION HANDLED IN WRONG SCOPE"); + RESULT; +END CB1004A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb1005a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb1005a.ada new file mode 100644 index 000000000..94e5383b3 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb1005a.ada @@ -0,0 +1,164 @@ +-- CB1005A.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 EXCEPTIONS DECLARED IN GENERIC PACKAGES AND PROCEDURES ARE +-- CONSIDERED DISTINCT FOR EACH INSTANTIATION. + +-- CHECK THAT AN EXCEPTION NAME DECLARED IN A GENERIC PACKAGE +-- INSTANTIATION IN A RECURSIVE PROCEDURE DENOTES THE SAME ENTITY +-- EVEN WHEN THE INSTANTIATION IS ELABORATED MORE THAN ONCE BECAUSE +-- OF RECURSIVE CALLS. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- TBN 9/23/86 +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; USE REPORT; +PROCEDURE CB1005A IS + + PROCEDURE PROP; + + GENERIC + PACKAGE PAC IS + EXC : EXCEPTION; + END PAC; + + GENERIC + PROCEDURE PROC (INST_AGAIN : BOOLEAN); + + PROCEDURE PROC (INST_AGAIN : BOOLEAN) IS + EXC : EXCEPTION; + BEGIN + IF INST_AGAIN THEN + BEGIN + PROP; + FAILED ("EXCEPTION WAS NOT PROPAGATED - 9"); + EXCEPTION + WHEN EXC => + FAILED ("EXCEPTION NOT DISTINCT - 10"); + WHEN PROGRAM_ERROR | STORAGE_ERROR | + TASKING_ERROR | CONSTRAINT_ERROR => + FAILED ("WRONG EXCEPTION PROPAGATED - 11"); + WHEN OTHERS => + NULL; + END; + ELSE + RAISE EXC; + END IF; + END PROC; + + PROCEDURE RAISE_EXC (CALL_AGAIN : BOOLEAN) IS + PACKAGE PAC3 IS NEW PAC; + BEGIN + IF CALL_AGAIN THEN + BEGIN + RAISE_EXC (FALSE); + FAILED ("EXCEPTION WAS NOT PROPAGATED - 12"); + EXCEPTION + WHEN PAC3.EXC => + NULL; + END; + ELSE + RAISE PAC3.EXC; + END IF; + END RAISE_EXC; + + PROCEDURE PROP IS + PROCEDURE PROC2 IS NEW PROC; + BEGIN + PROC2 (FALSE); + END PROP; + +BEGIN + TEST ("CB1005A", "CHECK THAT EXCEPTIONS DECLARED IN GENERIC " & + "PACKAGES AND PROCEDURES ARE CONSIDERED " & + "DISTINCT FOR EACH INSTANTIATION"); + + ------------------------------------------------------------------- + DECLARE + PACKAGE PAC1 IS NEW PAC; + PACKAGE PAC2 IS NEW PAC; + PAC1_EXC_FOUND : BOOLEAN := FALSE; + BEGIN + BEGIN + IF EQUAL (3, 3) THEN + RAISE PAC2.EXC; + END IF; + FAILED ("EXCEPTION WAS NOT RAISED - 1"); + + EXCEPTION + WHEN PAC1.EXC => + FAILED ("PACKAGE EXCEPTIONS NOT DISTINCT - 2"); + PAC1_EXC_FOUND := TRUE; + END; + IF NOT PAC1_EXC_FOUND THEN + FAILED ("EXCEPTION WAS NOT PROPAGATED - 3"); + END IF; + + EXCEPTION + WHEN PAC1.EXC => + FAILED ("PACKAGE EXCEPTIONS NOT DISTINCT - 4"); + WHEN PAC2.EXC => + BEGIN + IF EQUAL (3, 3) THEN + RAISE PAC1.EXC; + END IF; + FAILED ("EXCEPTION WAS NOT RAISED - 5"); + + EXCEPTION + WHEN PAC2.EXC => + FAILED ("PACKAGE EXCEPTIONS NOT DISTINCT - 6"); + WHEN PAC1.EXC => + NULL; + WHEN OTHERS => + FAILED ("UNKNOWN EXCEPTION RAISED - 7"); + END; + WHEN OTHERS => + FAILED ("UNKNOWN EXCEPTION RAISED - 8"); + END; + + ------------------------------------------------------------------- + DECLARE + PROCEDURE PROC1 IS NEW PROC; + BEGIN + PROC1 (TRUE); + END; + + ------------------------------------------------------------------- + BEGIN + RAISE_EXC (TRUE); + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTIONS ARE DISTINCT FOR RECURSION - 13"); + END; + + ------------------------------------------------------------------- + + RESULT; +END CB1005A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb1010a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb1010a.ada new file mode 100644 index 000000000..ac0a7793a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb1010a.ada @@ -0,0 +1,179 @@ +-- CB1010A.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 STORAGE_ERROR IS RAISED WHEN STORAGE ALLOCATED TO A TASK +-- IS EXCEEDED. + +-- PNH 8/26/85 +-- JRK 8/30/85 + +WITH REPORT; USE REPORT; + +PROCEDURE CB1010A IS + + N : INTEGER := IDENT_INT (1); + M : INTEGER := IDENT_INT (0); + + PROCEDURE OVERFLOW_STACK IS + A : ARRAY (1 .. 1000) OF INTEGER; + BEGIN + N := N + M; + A (N) := M; + IF N > M THEN -- ALWAYS TRUE. + OVERFLOW_STACK; + END IF; + M := A (N); -- TO PREVENT TAIL RECURSION OPTIMIZATION. + END OVERFLOW_STACK; + +BEGIN + TEST ("CB1010A", "CHECK THAT STORAGE_ERROR IS RAISED WHEN " & + "STORAGE ALLOCATED TO A TASK IS EXCEEDED"); + + -------------------------------------------------- + + COMMENT ("CHECK TASKS THAT DO NOT HANDLE STORAGE_ERROR " & + "PRIOR TO RENDEZVOUS"); + + DECLARE + + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + BEGIN + OVERFLOW_STACK; + FAILED ("TASK T1 NOT TERMINATED BY STACK OVERFLOW"); + END T1; + + BEGIN + + T1.E1; + FAILED ("NO EXCEPTION RAISED BY ENTRY CALL T1.E1"); + + EXCEPTION + WHEN TASKING_ERROR => + IF N /= 1 OR M /= 0 THEN + FAILED ("VALUES OF VARIABLES N OR M ALTERED - 1"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY CALL OF ENTRY E1 " & + "OF TERMINATED TASK T1"); + END; + + -------------------------------------------------- + + COMMENT ("CHECK TASKS THAT DO HANDLE STORAGE_ERROR PRIOR TO " & + "RENDEZVOUS"); + + N := IDENT_INT (1); + M := IDENT_INT (0); + + DECLARE + + TASK T2 IS + ENTRY E2; + END T2; + + TASK BODY T2 IS + BEGIN + OVERFLOW_STACK; + FAILED ("EXCEPTION NOT RAISED BY STACK OVERFLOW IN " & + "TASK T2"); + EXCEPTION + WHEN STORAGE_ERROR => + ACCEPT E2; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN TASK T2 BY " & + "STACK OVERFLOW"); + END T2; + + BEGIN + + T2.E2; + IF N /= 1 OR M /= 0 THEN + FAILED ("VALUES OF VARIABLES N OR M ALTERED - 2"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY ENTRY CALL T2.E2"); + ABORT T2; + END; + + -------------------------------------------------- + + COMMENT ("CHECK TASKS THAT DO NOT HANDLE STORAGE_ERROR " & + "DURING RENDEZVOUS"); + + N := IDENT_INT (1); + M := IDENT_INT (0); + + DECLARE + + TASK T3 IS + ENTRY E3A; + ENTRY E3B; + END T3; + + TASK BODY T3 IS + BEGIN + ACCEPT E3A DO + OVERFLOW_STACK; + FAILED ("EXCEPTION NOT RAISED IN ACCEPT E3A BY " & + "STACK OVERFLOW"); + END E3A; + FAILED ("EXCEPTION NOT PROPOGATED CORRECTLY IN TASK T3"); + EXCEPTION + WHEN STORAGE_ERROR => + ACCEPT E3B; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN TASK T3 BY " & + "STACK OVERFLOW"); + END T3; + + BEGIN + + T3.E3A; + FAILED ("NO EXCEPTION RAISED BY ENTRY CALL T3.E3A"); + + EXCEPTION + WHEN STORAGE_ERROR => + T3.E3B; + IF N /= 1 OR M /= 0 THEN + FAILED ("VALUES OF VARIABLES N OR M ALTERED - 3"); + END IF; + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED BY ENTRY CALL T3.E3A " & + "INSTEAD OF STORAGE_ERROR"); + ABORT T3; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY ENTRY CALL T3.E3A"); + ABORT T3; + END; + + -------------------------------------------------- + + RESULT; +END CB1010A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb1010c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb1010c.ada new file mode 100644 index 000000000..bcd95041a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb1010c.ada @@ -0,0 +1,70 @@ +-- CB1010C.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 STORAGE_ERROR IS RAISED WHEN STORAGE FOR A DECLARATIVE +-- ITEM IS INSUFFICIENT. + +-- JRK 8/30/85 + +WITH REPORT; USE REPORT; + +PROCEDURE CB1010C IS + + N : INTEGER := IDENT_INT (1000); + M : INTEGER := IDENT_INT (0); + + PROCEDURE OVERFLOW_STACK IS + BEGIN + N := N + M; + DECLARE + A : ARRAY (1 .. N) OF INTEGER; + BEGIN + A (N) := M; + IF N > M THEN -- ALWAYS TRUE. + OVERFLOW_STACK; + END IF; + M := A (N); -- TO PREVENT TAIL RECURSION OPTIMIZATION. + END; + END OVERFLOW_STACK; + +BEGIN + TEST ("CB1010C", "CHECK THAT STORAGE_ERROR IS RAISED WHEN " & + "STORAGE FOR A DECLARATIVE ITEM IS INSUFFICIENT"); + + BEGIN + + OVERFLOW_STACK; + FAILED ("EXCEPTION NOT RAISED BY STACK OVERFLOW"); + + EXCEPTION + WHEN STORAGE_ERROR => + IF N /= 1000 OR M /= 0 THEN + FAILED ("VALUES OF VARIABLES N OR M WERE ALTERED"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY STACK OVERFLOW"); + END; + + RESULT; +END CB1010C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb1010d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb1010d.ada new file mode 100644 index 000000000..e58046c85 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb1010d.ada @@ -0,0 +1,92 @@ +-- CB1010D.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 STORAGE_ERROR IS RAISED WHEN STORAGE FOR THE EXECUTION OF +-- A SUBPROGRAM IS INSUFFICIENT. + +-- PNH 8/26/85 +-- JRK 8/30/85 + +WITH REPORT; USE REPORT; + +PROCEDURE CB1010D IS + + N : INTEGER := IDENT_INT (1); + M : INTEGER := IDENT_INT (0); + + PROCEDURE OVERFLOW_STACK IS + BEGIN + N := N + M; + IF N > M THEN -- ALWAYS TRUE. + OVERFLOW_STACK; + END IF; + N := N - M; -- TO PREVENT TAIL RECURSION OPTIMIZATION. + END OVERFLOW_STACK; + +BEGIN + TEST ("CB1010D", "CHECK THAT STORAGE_ERROR IS RAISED WHEN " & + "STORAGE FOR THE EXECUTION OF A SUBPROGRAM " & + "IS INSUFFICIENT"); + + -- CHECK HANDLING OF STORAGE_ERROR IN MAIN PROGRAM. + + BEGIN + OVERFLOW_STACK; + FAILED ("EXCEPTION NOT RAISED BY STACK OVERFLOW - 1"); + EXCEPTION + WHEN STORAGE_ERROR => + IF N /= 1 THEN + FAILED ("VALUE OF VARIABLE N ALTERED - 1"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY STACK OVERFLOW - 1"); + END; + + -- CHECK HANDLING OF STORAGE_ERROR IN SUBPROGRAM. + + DECLARE + + PROCEDURE P IS + BEGIN + OVERFLOW_STACK; + FAILED ("EXCEPTION NOT RAISED BY STACK OVERFLOW - 2"); + EXCEPTION + WHEN STORAGE_ERROR => + IF N /= 1 THEN + FAILED ("VALUE OF VARIABLE N ALTERED - 2"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY STACK " & + "OVERFLOW - 2"); + END P; + + BEGIN + + N := IDENT_INT (1); + P; + + END; + + RESULT; +END CB1010D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20001.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20001.a new file mode 100644 index 000000000..ccfad52e4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20001.a @@ -0,0 +1,228 @@ +-- CB20001.A +-- +-- 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. +--* +-- +-- OBJECTIVE: +-- Check that exceptions can be handled in accept bodies, and that a +-- task object that has an exception handled in an accept body is still +-- viable for future use. +-- +-- TEST DESCRIPTION: +-- Declare a task that has exception handlers within an accept +-- statement in the task body. Declare a task object, and make entry +-- calls with data that will cause various exceptions to be raised +-- by the accept statement. Ensure that the exceptions are: +-- 1) raised and handled locally in the accept body +-- 2) raised in the accept body and handled/reraised to be handled +-- by the task body +-- 3) raised in the accept body and propagated to the calling +-- procedure. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; + +package CB20001_0 is + + Incorrect_Data, + Location_Error, + Off_Screen_Data : exception; + + TC_Handled_In_Accept, + TC_Reraised_In_Accept, + TC_Handled_In_Task_Block, + TC_Handled_In_Caller : boolean := False; + + type Location_Type is range 0 .. 2000; + + task type Submarine_Type is + entry Contact (Location : in Location_Type); + end Submarine_Type; + + Current_Position : Location_Type := 0; + +end CB20001_0; + + + --=================================================================-- + + +package body CB20001_0 is + + + task body Submarine_Type is + begin + loop + + Task_Block: + begin + select + accept Contact (Location : in Location_Type) do + if Location > 1000 then + raise Off_Screen_Data; + elsif (Location > 500) and (Location <= 1000) then + raise Location_Error; + elsif (Location > 100) and (Location <= 500) then + raise Incorrect_Data; + else + Current_Position := Location; + end if; + exception + when Off_Screen_Data => + TC_Handled_In_Accept := True; + when Location_Error => + TC_Reraised_In_Accept := True; + raise; -- Reraise the Location_Error exception + -- in the task block. + end Contact; + or + terminate; + end select; + + exception + + when Off_Screen_Data => + TC_Handled_In_Accept := False; + Report.Failed ("Off_Screen_Data exception " & + "improperly handled in task block"); + + when Location_Error => + TC_Handled_In_Task_Block := True; + end Task_Block; + + end loop; + + exception + + when Location_Error | Off_Screen_Data => + TC_Handled_In_Accept := False; + TC_Handled_In_Task_Block := False; + Report.Failed ("Exception improperly propagated out to task body"); + when others => + null; + end Submarine_Type; + +end CB20001_0; + + + --=================================================================-- + + +with CB20001_0; +with Report; +with ImpDef; + +procedure CB20001 is + + package Submarine_Tracking renames CB20001_0; + + Trident : Submarine_Tracking.Submarine_Type; -- Declare task + Sonar_Contact : Submarine_Tracking.Location_Type; + + TC_LEB_Error, + TC_Main_Handler_Used : Boolean := False; + +begin + + Report.Test ("CB20001", "Check that exceptions can be handled " & + "in accept bodies"); + + + Off_Screen_Block: + begin + Sonar_Contact := 1500; + Trident.Contact (Sonar_Contact); -- Cause Off_Screen_Data exception + -- to be raised and handled in a task + -- accept body. + exception + when Submarine_Tracking.Off_Screen_Data => + TC_Main_Handler_Used := True; + Report.Failed ("Off_Screen_Data exception improperly handled " & + "in calling procedure"); + when others => + Report.Failed ("Exception handled unexpectedly in " & + "Off_Screen_Block"); + end Off_Screen_Block; + + + Location_Error_Block: + begin + Sonar_Contact := 700; + Trident.Contact (Sonar_Contact); -- Cause Location_Error exception + -- to be raised in task accept body, + -- propogated to a task block, and + -- handled there. Corresponding + -- exception propagated here also. + Report.Failed ("Expected exception not raised"); + exception + when Submarine_Tracking.Location_Error => + TC_LEB_Error := True; + when others => + Report.Failed ("Exception handled unexpectedly in " & + "Location_Error_Block"); + end Location_Error_Block; + + + Incorrect_Data_Block: + begin + Sonar_Contact := 200; + Trident.Contact (Sonar_Contact); -- Cause Incorrect_Data exception + -- to be raised in task accept body, + -- propogated to calling procedure. + Report.Failed ("Expected exception not raised"); + exception + when Submarine_Tracking.Incorrect_Data => + Submarine_Tracking.TC_Handled_In_Caller := True; + when others => + Report.Failed ("Exception handled unexpectedly in " & + "Incorrect_Data_Block"); + end Incorrect_Data_Block; + + + if TC_Main_Handler_Used or + not (Submarine_Tracking.TC_Handled_In_Caller and -- Check to see that + Submarine_Tracking.TC_Handled_In_Task_Block and -- all exceptions + Submarine_Tracking.TC_Handled_In_Accept and -- were handled in + Submarine_Tracking.TC_Reraised_In_Accept and -- proper locations. + TC_LEB_Error) + then + Report.Failed ("Exceptions handled in incorrect locations"); + end if; + + if Integer(Submarine_Tracking.Current_Position) /= 0 then + Report.Failed ("Variable incorrectly written in task processing"); + end if; + + delay ImpDef.Minimum_Task_Switch; + if Trident'Callable then + Report.Failed ("Task didn't terminate with exception propagation"); + end if; + + Report.Result; + +end CB20001; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20003.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20003.a new file mode 100644 index 000000000..daaf9ffe5 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20003.a @@ -0,0 +1,286 @@ +-- CB20003.A +-- +-- 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. +--* +-- +-- OBJECTIVE: +-- Check that exceptions can be raised, reraised, and handled in an +-- accessed subprogram. +-- +-- +-- TEST DESCRIPTION: +-- Declare a record type, with one component being an access to +-- subprogram type. Various subprograms are defined to fit the profile +-- of this access type, such that the record component can refer to +-- any of the subprograms. +-- +-- Each of the subprograms raises a different exception, based on the +-- value of an input parameter. Exceptions are 1) raised, handled with +-- an others handler, reraised and propagated to main to be handled in +-- a specific handler; 2) raised, handled in a specific handler, reraised +-- and propagated to the main to be handled in an others handler there, +-- and 3) raised and propagated directly to the caller by the subprogram. +-- +-- Boolean variables are set throughout the test to ensure that correct +-- exception processing has occurred, and these variables are verified at +-- the conclusion of the test. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package CB20003_0 is -- package Push_Buttons + + + Non_Default_Priority, + Non_Alert_Priority, + Non_Emergency_Priority : exception; + + Handled_With_Others, + Reraised_In_Subprogram, + Handled_In_Caller : Boolean := False; + + subtype Priority_Type is Integer range 1 .. 10; + + Default_Priority : Priority_Type := 1; + Alert_Priority : Priority_Type := 3; + Emergency_Priority : Priority_Type := 5; + + + type Button is tagged private; -- Private tagged type. + + type Button_Response_Ptr is access procedure (P : in Priority_Type; + B : in out Button); + + + -- Procedures accessible with Button_Response_Ptr type. + + procedure Default_Response (P : in Priority_Type; + B : in out Button); + + procedure Alert_Response (P : in Priority_Type; + B : in out Button); + + procedure Emergency_Response (P : in Priority_Type; + B : in out Button); + + + + procedure Push (B : in out Button; + P : in Priority_Type); + + procedure Set_Response (B : in out Button; + R : in Button_Response_Ptr); + +private + + type Button is tagged + record + Priority : Priority_Type := Default_Priority; + Response : Button_Response_Ptr := Default_Response'Access; + end record; + + +end CB20003_0; -- package Push_Buttons + + + --=================================================================-- + + +with Report; + +package body CB20003_0 is -- package Push_Buttons + + + procedure Push (B : in out Button; + P : in Priority_Type) is + begin -- Invoking subprogram designated + B.Response (P, B); -- by access value. + end Push; + + + procedure Set_Response (B : in out Button; + R : in Button_Response_Ptr) is + begin + B.Response := R; -- Set procedure value in record + end Set_Response; + + + procedure Default_Response (P : in Priority_Type; + B : in out Button) is + begin + if (P > Default_Priority) then + raise Non_Default_Priority; + Report.Failed ("Exception not raised in procedure body"); + else + B.Priority := P; + end if; + exception + when others => -- Catch exception with others handler + Handled_With_Others := True; -- Successfully caught with "others" + raise; + Report.Failed ("Exception not reraised in handler"); + end Default_Response; + + + + procedure Alert_Response (P : in Priority_Type; + B : in out Button) is + begin + if (P > Alert_Priority) then + raise Non_Alert_Priority; + Report.Failed ("Exception not raised in procedure body"); + else + B.Priority := P; + end if; + exception + when Non_Alert_Priority => + Reraised_In_Subprogram := True; + raise; -- Propagate to caller. + Report.Failed ("Exception not reraised in procedure excpt handler"); + when others => + Report.Failed ("Incorrect exception raised/handled"); + end Alert_Response; + + + + procedure Emergency_Response (P : in Priority_type; + B : in out Button) is + begin + if (P > Emergency_Priority) then + raise Non_Emergency_Priority; + Report.Failed ("Exception not raised in procedure body"); + else + B.Priority := P; + end if; + -- No exception handler here, exception will be propagated to caller. + end Emergency_Response; + + +end CB20003_0; -- package Push_Buttons + + + --=================================================================-- + + +with Report; +with CB20003_0; -- package Push_Buttons + +procedure CB20003 is + + package Push_Buttons renames CB20003_0; + + Console_Button : Push_Buttons.Button; + +begin + + Report.Test ("CB20003", "Check that exceptions can be raised, " & + "reraised, and handled in a subprogram " & + "referenced by an access to subprogram value"); + + + Default_Response_Processing: -- The exception + -- Handled_With_Others is to + -- be caught with an others + -- handler in Default_Resp., + -- reraised, and handled with + -- a specific handler here. + begin + + Push_Buttons.Push (Console_Button, -- Raise exception that will + Report.Ident_Int(2)); -- be handled in procedure. + exception + when Push_Buttons.Non_Default_Priority => + if not Push_Buttons.Handled_With_Others then -- Not reraised in + -- procedure. + Report.Failed + ("Exception not handled/reraised in procedure"); + end if; + when others => + Report.Failed ("Exception handled in " & + " Default_Response_Processing block"); + end Default_Response_Processing; + + + + Alert_Response_Processing: + begin + + Push_Buttons.Set_Response (Console_Button, + Push_Buttons.Alert_Response'access); + + Push_Buttons.Push (Console_Button, -- Raise exception that will + Report.Ident_Int(4)); -- be handled in procedure, + -- reraised, and propagated + -- to caller. + Report.Failed ("Exception not propagated to caller " & + "in Alert_Response_Processing block"); + + exception + when Push_Buttons.Non_Alert_Priority => + if not Push_Buttons.Reraised_In_Subprogram then -- Not reraised in + -- procedure. + Report.Failed ("Exception not reraised in procedure"); + end if; + when others => + Report.Failed ("Exception handled in " & + " Alert_Response_Processing block"); + end Alert_Response_Processing; + + + + Emergency_Response_Processing: + begin + + Push_Buttons.Set_Response (Console_Button, + Push_Buttons.Emergency_Response'access); + + Push_Buttons.Push (Console_Button, -- Raise exception that will + Report.Ident_Int(6)); -- be propagated directly to + -- caller. + Report.Failed ("Exception not propagated to caller " & + "in Emergency_Response_Processing block"); + + exception + when Push_Buttons.Non_Emergency_Priority => + Push_Buttons.Handled_In_Caller := True; + when others => + Report.Failed ("Exception handled in " & + " Emergency_Response_Processing block"); + end Emergency_Response_Processing; + + + + if not (Push_Buttons.Handled_With_Others and + Push_Buttons.Reraised_In_Subprogram and + Push_Buttons.Handled_In_Caller ) + then + Report.Failed ("Incorrect exception handling in referenced subprograms"); + end if; + + + Report.Result; + +end CB20003; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20004.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20004.a new file mode 100644 index 000000000..42c0d7672 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20004.a @@ -0,0 +1,203 @@ +-- CB20004.A +-- +-- 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. +--* +-- +-- OBJECTIVE: +-- Check that exceptions propagate correctly from objects of +-- protected types. Check propagation from protected entry bodies. +-- +-- TEST DESCRIPTION: +-- Declare a package with a protected type, including entries and private +-- data, simulating a bounded buffer abstraction. In the main procedure, +-- perform entry calls on an object of the protected type that raises +-- exceptions. +-- Ensure that the exceptions are: +-- 1) raised and handled locally in the entry body +-- 2) raised in the entry body and handled/reraised to be handled +-- by the caller. +-- 3) raised in the entry body and propagated directly to the calling +-- procedure. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package CB20004_0 is -- Package Buffer. + + Max_Buffer_Size : constant := 2; + + Handled_In_Body, + Propagated_To_Caller, + Handled_In_Caller : Boolean := False; + + Data_Over_5, + Data_Degradation : exception; + + type Data_Item is range 0 .. 100; + + type Item_Array_Type is array (1 .. Max_Buffer_Size) of Data_Item; + + protected type Bounded_Buffer is + entry Put (Item : in Data_Item); + entry Get (Item : out Data_Item); + private + Item_Array : Item_Array_Type; + I, J : Integer range 1 .. Max_Buffer_Size := 1; + Count : Integer range 0 .. Max_Buffer_Size := 0; + end Bounded_Buffer; + +end CB20004_0; + + --=================================================================-- + +with Report; + +package body CB20004_0 is -- Package Buffer. + + protected body Bounded_Buffer is + + entry Put (Item : in Data_Item) when Count < Max_Buffer_Size is + begin + if Item > 10 then + Item_Array (I) := Item * 8; -- Constraint_Error will be raised + elsif Item > 5 then -- and handled in entry body. + raise Data_Over_5; -- Exception handled/reraised in + else -- entry body, propagated to caller. + Item_Array (I) := Item; -- Store data item in buffer. + I := (I mod Max_Buffer_Size) + 1; + Count := Count + 1; + end if; + exception + when Constraint_Error => + Handled_In_Body := True; + when Data_Over_5 => + Propagated_To_Caller := True; + raise; -- Propagate the exception to the caller. + end Put; + + + entry Get (Item : out Data_Item) when Count > 0 is + begin + Item := Item_Array(J); + J := (J mod Max_Buffer_Size) + 1; + Count := Count - 1; + if Count = 0 then + raise Data_Degradation; -- Exception to propagate to caller. + end if; + end Get; + + end Bounded_Buffer; + +end CB20004_0; + + + --=================================================================-- + + +with CB20004_0; -- Package Buffer. +with Report; + +procedure CB20004 is + + package Buffer renames CB20004_0; + + Data : Buffer.Data_Item := Buffer.Data_Item'First; + Data_Buffer : Buffer.Bounded_Buffer; -- an object of protected type. + + Handled_In_Caller : Boolean := False; -- same name as boolean declared + -- in package Buffer. +begin + + Report.Test ("CB20004", "Check that exceptions propagate correctly " & + "from objects of protected types" ); + + Initial_Data_Block: + begin -- Data causes Constraint_Error. + Data_Buffer.Put (CB20004_0.Data_Item(Report.Ident_Int(51))); + + exception + when Constraint_Error => + Buffer.Handled_In_Body := False; -- Improper exception handling + -- in entry body. + Report.Failed ("Exception propagated to caller " & + " from Initial_Data_Block"); + when others => + Report.Failed ("Exception raised in processing and " & + "propagated to caller from Initial_Data_Block"); + end Initial_Data_Block; + + + Data_Entry_Block: + begin + -- Valid data. No exception. + Data_Buffer.Put (CB20004_0.Data_Item(Report.Ident_Int(3))); + + -- Data will cause exception. + Data_Buffer.Put (7); -- Call protected object entry, + -- exception to be handled/ + -- reraised in entry body. + Report.Failed ("Data_Over_5 Exception not raised in processing"); + exception + when Buffer.Data_Over_5 => + if Buffer.Propagated_To_Caller then -- Reraised in entry body? + Buffer.Handled_In_Caller := True; + else + Report.Failed ("Exception not reraised in entry body"); + end if; + when others => + Report.Failed ("Exception raised in processing and propagated " & + "to caller from Data_Entry_Block"); + end Data_Entry_Block; + + + Data_Retrieval_Block: + begin + + Data_Buffer.Get (Data); -- Retrieval of buffer data, buffer now empty. + -- Exception will be raised in entry body, with + -- propagation to caller. + Report.Failed ("Data_Degradation Exception not raised in processing"); + exception + when Buffer.Data_Degradation => + Handled_In_Caller := True; -- Local Boolean used here. + when others => + Report.Failed ("Exception raised in processing and propagated " & + "to caller from Data_Retrieval_Block"); + end Data_Retrieval_Block; + + + if not (Buffer.Handled_In_Body and -- Validate proper exception + Buffer.Propagated_To_Caller and -- handling in entry bodies. + Buffer.Handled_In_Caller and + Handled_In_Caller) + then + Report.Failed ("Improper exception handling by entry bodies"); + end if; + + + Report.Result; + +end CB20004; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20005.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20005.a new file mode 100644 index 000000000..898d2a2c6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20005.a @@ -0,0 +1,210 @@ +-- CB20005.A +-- +-- 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. +--* +-- +-- OBJECTIVE: +-- Check that exceptions are raised and properly handled locally in +-- protected operations. +-- +-- TEST DESCRIPTION: +-- Declare a package with a protected type, including protected operation +-- declarations and private data, simulating a counting semaphore. +-- In the main procedure, perform calls on protected operations +-- of the protected object designed to induce the raising of exceptions. +-- +-- Ensure that the exceptions are raised and handled locally in a +-- protected procedures and functions, and that in this case the +-- exceptions will not propagate to the calling unit. Use specific +-- exception handlers in the protected functions. +-- +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package CB20005_0 is -- Package Semaphore. + + Handled_In_Function, + Handled_In_Procedure : Boolean := False; + + Resource_Overflow, + Resource_Underflow : exception; + + protected type Counting_Semaphore (Max_Resources : Integer) is + procedure Secure; + function Resource_Limit_Exceeded return Boolean; + procedure Release; + private + Count : Integer := Max_Resources; + end Counting_Semaphore; + +end CB20005_0; + + --=================================================================-- + +with Report; + +package body CB20005_0 is -- Package Semaphore. + + protected body Counting_Semaphore is + + procedure Secure is + begin + if (Count = 0) then -- No resources left to secure. + raise Resource_Underflow; + Report.Failed + ("Program control not transferred by raise in Secure"); + else + Count := Count - 1; -- Avail resources decremented. + end if; + exception + when Resource_Underflow => -- Exception handled locally in + Handled_In_Procedure := True; -- this protected operation. + when others => + Report.Failed ("Unexpected exception raised in Secure"); + end Secure; + + + function Resource_Limit_Exceeded return Boolean is + begin + if (Count > Max_Resources) then + raise Resource_Overflow; -- Exception used as control flow + -- mechanism. + Report.Failed + ("Program control not transferred by raise in " & + "Resource_Limit_Exceeded"); + else + return (False); + end if; + exception + when Resource_Overflow => -- Handle its own raised + Handled_In_Function := True; -- exception. + return (True); + when others => + Report.Failed + ("Unexpected exception raised in Resource_Limit_Exceeded"); + end Resource_Limit_Exceeded; + + + procedure Release is + begin + Count := Count + 1; -- Count of resources available + -- incremented. + if Resource_Limit_Exceeded then -- Call to protected operation + Count := Count - 1; -- function that raises/handles + end if; -- an exception. + exception + when Resource_Overflow => + Handled_In_Function := False; + Report.Failed ("Exception propagated to Function Release"); + when others => + Report.Failed ("Unexpected exception raised in Function Release"); + end Release; + + + end Counting_Semaphore; + +end CB20005_0; + + + --=================================================================-- + + +with CB20005_0; -- Package Semaphore. +with Report; + +procedure CB20005 is +begin + + Report.Test ("CB20005", "Check that exceptions are raised and handled " & + "correctly in protected operations" ); + + Test_Block: + declare + + package Semaphore renames CB20005_0; + + Total_Resources_Available : constant := 1; + + Resources : Semaphore.Counting_Semaphore(Total_Resources_Available); + -- An object of protected type. + + begin + + Allocate_Resources: + declare + Loop_Count : Integer := Total_Resources_Available + 1; + begin + for I in 1..Loop_Count loop -- Force exception. + Resources.Secure; + end loop; + exception + when Semaphore.Resource_Underflow => + Semaphore.Handled_In_Procedure := False; -- Excptn not handled + Report.Failed -- in prot. operation. + ("Resource_Underflow exception not handled " & + "in Allocate_Resources"); + when others => + Report.Failed + ("Exception unexpectedly raised during resource allocation"); + end Allocate_Resources; + + + Deallocate_Resources: + declare + Loop_Count : Integer := Total_Resources_Available + 1; + begin + for I in 1..Loop_Count loop -- Force excptn. + Resources.Release; + end loop; + exception + when Semaphore.Resource_Overflow => + Semaphore.Handled_In_Function := False; -- Exception not handled + Report.Failed -- in prot. operation. + ("Resource overflow not handled by function"); + when others => + Report.Failed + ("Exception raised during resource deallocation"); + end Deallocate_Resources; + + + if not (Semaphore.Handled_In_Procedure and -- Incorrect excpt. handling + Semaphore.Handled_In_Function) -- in protected operations. + then + Report.Failed + ("Improper exception handling by protected operations"); + end if; + + + exception + when others => + Report.Failed ("Exception raised and propagated in test"); + + end Test_Block; + + Report.Result; + +end CB20005; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20006.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20006.a new file mode 100644 index 000000000..f2b3c70a9 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20006.a @@ -0,0 +1,217 @@ +-- CB20006.A +-- +-- 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. +--* +-- +-- OBJECTIVE: +-- Check that exceptions are raised and properly handled (including +-- propagation by reraise) in protected operations. +-- +-- TEST DESCRIPTION: +-- Declare a package with a protected type, including protected operation +-- declarations and private data, simulating a counting semaphore. +-- In the main procedure, perform calls on protected operations +-- of the protected object designed to induce the raising of exceptions. +-- +-- The exceptions raised are to be initially handled in the protected +-- operations, but this handling involves the reraise of the exception +-- and the propagation of the exception to the caller. +-- +-- Ensure that the exceptions are raised, handled / reraised successfully +-- in protected procedures and functions. Use "others" handlers in the +-- protected operations. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package CB20006_0 is -- Package Semaphore. + + Reraised_In_Function, + Reraised_In_Procedure, + Handled_In_Function_Caller, + Handled_In_Procedure_Caller : Boolean := False; + + Resource_Overflow, + Resource_Underflow : exception; + + protected type Counting_Semaphore (Max_Resources : Integer) is + procedure Secure; + function Resource_Limit_Exceeded return Boolean; + procedure Release; + private + Count : Integer := Max_Resources; + end Counting_Semaphore; + +end CB20006_0; + + --=================================================================-- + +with Report; + +package body CB20006_0 is -- Package Semaphore. + + protected body Counting_Semaphore is + + procedure Secure is + begin + if (Count = 0) then -- No resources left to secure. + raise Resource_Underflow; + Report.Failed + ("Program control not transferred by raise in Procedure Secure"); + else + Count := Count - 1; -- Available resources decremented. + end if; + exception + when Resource_Underflow => + Reraised_In_Procedure := True; + raise; -- Exception propagated to caller. + Report.Failed ("Exception not propagated to caller from Secure"); + when others => + Report.Failed ("Unexpected exception raised in Secure"); + end Secure; + + + function Resource_Limit_Exceeded return Boolean is + begin + if (Count > Max_Resources) then + raise Resource_Overflow; -- Exception used as control flow + -- mechanism. + Report.Failed + ("Specific raise did not alter program control" & + " from Resource_Limit_Exceeded"); + else + return (False); + end if; + exception + when others => + Reraised_In_Function := True; + raise; -- Exception propagated to caller. + Report.Failed ("Exception not propagated to caller" & + " from Resource_Limit_Exceeded"); + end Resource_Limit_Exceeded; + + + procedure Release is + begin + Count := Count + 1; -- Count of resources available + -- incremented. + if Resource_Limit_Exceeded then -- Call to protected operation + Count := Count - 1; -- function that raises/reraises + -- an exception. + Report.Failed("Resource limit exceeded"); + end if; + + exception + when others => + raise; -- Reraised and propagated again. + Report.Failed ("Exception not reraised by procedure Release"); + end Release; + + + end Counting_Semaphore; + +end CB20006_0; + + + --=================================================================-- + + +with CB20006_0; -- Package Semaphore. +with Report; + +procedure CB20006 is +begin + + Report.Test ("CB20006", "Check that exceptions are raised and " & + "handled / reraised and propagated " & + "correctly by protected operations" ); + + Test_Block: + declare + + package Semaphore renames CB20006_0; + + Total_Resources_Available : constant := 1; + + Resources : Semaphore.Counting_Semaphore (Total_Resources_Available); + -- An object of protected type. + + begin + + Allocate_Resources: + declare + Loop_Count : Integer := Total_Resources_Available + 1; + begin + for I in 1..Loop_Count loop -- Force exception + Resources.Secure; + end loop; + Report.Failed + ("Exception not propagated from protected operation Secure"); + exception + when Semaphore.Resource_Underflow => -- Exception propagated + Semaphore.Handled_In_Procedure_Caller := True; -- from protected + when others => -- procedure. + Semaphore.Handled_In_Procedure_Caller := False; + end Allocate_Resources; + + + Deallocate_Resources: + declare + Loop_Count : Integer := Total_Resources_Available + 1; + begin + for I in 1..Loop_Count loop -- Force exception + Resources.Release; + end loop; + Report.Failed + ("Exception not propagated from protected operation Release"); + exception + when Semaphore.Resource_Overflow => -- Exception propagated + Semaphore.Handled_In_Function_Caller := True; -- from protected + when others => -- function. + Semaphore.Handled_In_Function_Caller := False; + end Deallocate_Resources; + + + if not (Semaphore.Reraised_In_Procedure and + Semaphore.Reraised_In_Function and + Semaphore.Handled_In_Procedure_Caller and + Semaphore.Handled_In_Function_Caller) + then -- Incorrect excpt. handling + Report.Failed -- in protected operations. + ("Improper exception handling/reraising by protected operations"); + end if; + + exception + + when others => + Report.Failed ("Unexpected exception " & + " raised and propagated in test"); + end Test_Block; + + Report.Result; + + +end CB20006; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20007.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20007.a new file mode 100644 index 000000000..6d052517e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20007.a @@ -0,0 +1,196 @@ +-- CB20007.A +-- +-- 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. +--* +-- +-- OBJECTIVE: +-- Check that exceptions are raised and can be directly propagated to +-- the calling unit by protected operations. +-- +-- TEST DESCRIPTION: +-- Declare a package with a protected type, including protected operation +-- declarations and private data, simulating a counting semaphore. +-- In the main procedure, perform calls on protected operations +-- of the protected object designed to induce the raising of exceptions. +-- +-- The exceptions raised are to be propagated directly from the protected +-- operations to the calling unit. +-- +-- Ensure that the exceptions are raised and correctly propagated directly +-- to the calling unit from protected procedures and functions. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package CB20007_0 is -- Package Semaphore. + + Handled_In_Function_Caller, + Handled_In_Procedure_Caller : Boolean := False; + + Resource_Overflow, + Resource_Underflow : exception; + + protected type Counting_Semaphore (Max_Resources : Integer) is + procedure Secure; + function Resource_Limit_Exceeded return Boolean; + procedure Release; + private + Count : Integer := Max_Resources; + end Counting_Semaphore; + +end CB20007_0; + + --=================================================================-- + +with Report; + +package body CB20007_0 is -- Package Semaphore. + + protected body Counting_Semaphore is + + procedure Secure is + begin + if (Count = 0) then -- No resources left to secure. + raise Resource_Underflow; + Report.Failed ("Program control not transferred by raise"); + else + Count := Count - 1; -- Available resources decremented. + end if; + -- No exception handlers here, direct propagation to calling unit. + end Secure; + + + function Resource_Limit_Exceeded return Boolean is + begin + if (Count > Max_Resources) then + raise Resource_Overflow; -- Exception used as control flow + -- mechanism. + Report.Failed ("Program control not transferred by raise"); + else + return (False); + end if; + -- No exception handlers here, direct propagation to calling unit. + end Resource_Limit_Exceeded; + + + procedure Release is + begin + Count := Count + 1; -- Count of resources available + -- incremented. + if Resource_Limit_Exceeded then -- Call to protected operation + Count := Count - 1; -- function that raises an + -- exception. + Report.Failed("Resource limit exceeded"); + end if; + -- No exception handler here for exception raised in function. + -- Exception will propagate directly to calling unit. + end Release; + + + end Counting_Semaphore; + +end CB20007_0; + + + --=================================================================-- + + +with CB20007_0; -- Package Semaphore. +with Report; + +procedure CB20007 is +begin + + Test_Block: + declare + + package Semaphore renames CB20007_0; + + Total_Resources_Available : constant := 1; + + Resources : Semaphore.Counting_Semaphore (Total_Resources_Available); + -- An object of protected type. + + begin + + Report.Test ("CB20007", "Check that exceptions are raised and can " & + "be directly propagated to the calling unit " & + "by protected operations" ); + + Allocate_Resources: + declare + Loop_Count : Integer := Total_Resources_Available + 1; + begin -- Force exception. + for I in 1..Loop_Count loop + Resources.Secure; + end loop; + Report.Failed ("Exception not propagated from protected " & + " operation in Allocate_Resources"); + exception + when Semaphore.Resource_Underflow => -- Exception prop. + Semaphore.Handled_In_Procedure_Caller := True; -- from protected + -- procedure. + when others => + Report.Failed ("Unknown exception during resource allocation"); + end Allocate_Resources; + + + Deallocate_Resources: + declare + Loop_Count : Integer := Total_Resources_Available + 1; + begin -- Force exception. + for I in 1..Loop_Count loop + Resources.Release; + end loop; + Report.Failed ("Exception not propagated from protected " & + "operation in Deallocate_Resources"); + exception + when Semaphore.Resource_Overflow => -- Exception prop + Semaphore.Handled_In_Function_Caller := True; -- from protected + -- function. + when others => + Report.Failed ("Exception raised during resource deallocation"); + end Deallocate_Resources; + + + if not (Semaphore.Handled_In_Procedure_Caller and -- Incorrect exception + Semaphore.Handled_In_Function_Caller) -- handling in + then -- protected ops. + Report.Failed + ("Improper exception propagation by protected operations"); + end if; + + exception + + when others => + Report.Failed ("Unexpected exception " & + " raised and propagated in test"); + end Test_Block; + + + Report.Result; + +end CB20007; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb2004a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb2004a.ada new file mode 100644 index 000000000..e16aeb5d0 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb2004a.ada @@ -0,0 +1,245 @@ +-- CB2004A.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 A PREDEFINED OR A PROGRAMMER DEFINED EXCEPTION +-- RAISED SEVERAL LEVELS INSIDE A HIERARCHY OF NESTED BLOCKS +-- CAN BE SUCCESSFULLY HANDLED IN AN OUTER BLOCK. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- DCB 5/12/80 +-- JRK 11/17/80 +-- SPS 11/2/82 +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; +PROCEDURE CB2004A IS + + USE REPORT; + + FLOW_COUNT : INTEGER := 0; + + E1, E2, E3 : EXCEPTION; + +BEGIN + TEST("CB2004A","CHECK THAT EXCEPTIONS RAISED INSIDE NESTED " & + "BLOCKS CAN BE HANDLED IN OUTER BLOCKS"); + + BEGIN + + -- PROGRAMMER-DEFINED EXCEPTION, SINGLE EXCEPTON_CHOICE. + + BEGIN + BEGIN + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE E1; + FAILED("PROGRAMMER-DEFINED EXCEPTION " & + "NOT RAISED #1"); + + EXCEPTION + WHEN E2 | E3 => + FAILED("WRONG PROGRAMMER-" & + "DEFINED EXCEPTION HANDLED #1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR | + PROGRAM_ERROR | STORAGE_ERROR | + TASKING_ERROR | E2 | E3 => + FAILED("WRONG " & + "EXCEPTION HANDLED #1"); + END; + + EXCEPTION + WHEN E1 => + FLOW_COUNT := FLOW_COUNT + 1; + END; + + -- PROGRAMMER-DEFINED EXCEPTION, MULTIPLE EXCEPTION_CHOICES. + + BEGIN + BEGIN + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE E2; + FAILED("PROGRAMMER-DEFINED EXCEPTION " & + "NOT RAISED #2"); + + EXCEPTION + WHEN E1 | E3 => + FAILED("WRONG PROGRAMMER-" & + "DEFINED EXCEPTION HANDLED #2"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR | + PROGRAM_ERROR | STORAGE_ERROR | + TASKING_ERROR | E1 | E3 => + FAILED("WRONG " & + "EXCEPTION HANDLED #2"); + END; + + EXCEPTION + WHEN E3 => + FAILED("WRONG EXCEPTION HANDLED #2A"); + WHEN E1 | E2 | CONSTRAINT_ERROR => + FLOW_COUNT := FLOW_COUNT + 1; + END; + + -- PROGRAMMER-DEFINED EXCEPTION, 'OTHERS' CHOICE. + + BEGIN + BEGIN + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE E1; + FAILED("PROGRAMMER-DEFINED EXCEPTION " & + "NOT RAISED #3"); + + EXCEPTION + WHEN E2 | E3 => + FAILED("WRONG PROGRAMMER-" & + "DEFINED EXCEPTION HANDLED #3"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR | + PROGRAM_ERROR | STORAGE_ERROR | + TASKING_ERROR | E2 | E3 => + FAILED("WRONG " & + "EXCEPTION HANDLED #3"); + END; + + EXCEPTION + WHEN E2 | CONSTRAINT_ERROR => + FAILED("WRONG EXCEPTION HANDLED #3A"); + WHEN OTHERS => + FLOW_COUNT := FLOW_COUNT + 1; + END; + + -- PREDEFINED EXCEPTION, SINGLE EXCEPTION_CHOICE. + + BEGIN + BEGIN + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE CONSTRAINT_ERROR; + FAILED("PREDEFINED EXCEPTION NOT RAISED #4"); + + EXCEPTION + WHEN E1 | E2 | E3 => + FAILED("WRONG " & + "EXCEPTION HANDLED #4"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR | STORAGE_ERROR | + TASKING_ERROR => + FAILED("WRONG PREDEFINED " & + "EXCEPTION HANDLED #4"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FLOW_COUNT := FLOW_COUNT + 1; + END; + + -- PREDEFINED EXCEPTION, MULTIPLE EXCEPTION_CHOICES. + + BEGIN + BEGIN + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE CONSTRAINT_ERROR; + FAILED("PREDEFINED EXCEPTION NOT RAISED #5"); + + EXCEPTION + WHEN E1 | E2 | E3 => + FAILED("WRONG " & + "EXCEPTION HANDLED #5"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR | + STORAGE_ERROR | TASKING_ERROR => + FAILED("WRONG PREDEFINED " & + "EXCEPTION HANDLED #5"); + END; + + EXCEPTION + WHEN E1 | E2 => + FAILED("WRONG EXCEPTION HANDLED #5A"); + WHEN CONSTRAINT_ERROR | E3 => + FLOW_COUNT := FLOW_COUNT + 1; + END; + + -- PREDEFINED EXCEPTION, 'OTHERS' CHOICE. + + BEGIN + BEGIN + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE CONSTRAINT_ERROR; + FAILED("PREDEFINED EXCEPTION NOT RAISED #6"); + + EXCEPTION + WHEN E1 | E2 | E3 => + FAILED("WRONG " & + " EXCEPTION HANDLED #6"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR | STORAGE_ERROR | + TASKING_ERROR => + FAILED("WRONG PREDEFINED " & + "EXCEPTION HANDLED #6"); + END; + + EXCEPTION + WHEN E1 => + FAILED("WRONG EXCEPTION HANDLED #6A"); + WHEN OTHERS => + FLOW_COUNT := FLOW_COUNT + 1; + END; + + EXCEPTION + WHEN E1 | E2 | E3 => + FAILED("PROGRAMMER-DEFINED EXCEPTION HANDLED IN" & + "WRONG SCOPE"); + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR HANDLED IN WRONG SCOPE"); + WHEN OTHERS => + FAILED("OTHER EXCEPTIONS HANDLED IN WRONG SCOPE"); + END; + + IF FLOW_COUNT /= 12 THEN + FAILED("INCORRECT FLOW_COUNT VALUE"); + END IF; + + RESULT; +END CB2004A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb2005a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb2005a.ada new file mode 100644 index 000000000..64ac5a786 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb2005a.ada @@ -0,0 +1,77 @@ +-- CB2005A.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 A RETURN STATEMENT CAN APPEAR IN AN EXCEPTION HANDLER +-- AND IT CAUSES CONTROL TO LEAVE THE SUBPROGRAM, FOR BOTH +-- FUNCTIONS AND PROCEDURES. + +-- DAT 4/13/81 +-- JRK 4/24/81 +-- SPS 10/26/82 + +WITH REPORT; USE REPORT; + +PROCEDURE CB2005A IS + + I : INTEGER RANGE 0 .. 1; + + FUNCTION SETI RETURN INTEGER IS + BEGIN + I := I + 1; + FAILED ("CONSTRAINT_ERROR NOT RAISED 1"); + RETURN 0; + EXCEPTION + WHEN OTHERS => + RETURN I; + FAILED ("FUNCTION RETURN STMT DID NOT RETURN"); + RETURN 0; + END SETI; + + PROCEDURE ISET IS + BEGIN + I := 2; + FAILED ("CONSTRAINT_ERROR NOT RAISED 2"); + I := 0; + EXCEPTION + WHEN OTHERS => + RETURN; + FAILED ("PROCEDURE RETURN STMT DID NOT RETURN"); + END ISET; + +BEGIN + TEST ("CB2005A", "RETURN IN EXCEPTION HANDLERS"); + + I := 1; + IF SETI /= 1 THEN + FAILED ("WRONG VALUE RETURNED 1"); + END IF; + + I := 1; + ISET; + IF I /= 1 THEN + FAILED ("WRONG VALUE RETURNED 2"); + END IF; + + RESULT; +END CB2005A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb2006a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb2006a.ada new file mode 100644 index 000000000..b4da0e2cc --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb2006a.ada @@ -0,0 +1,70 @@ +-- CB2006A.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 LOCAL VARIABLES AND PARAMETERS OF A SUBPROGRAM, +-- OR PACKAGE ARE ACCESSIBLE WITHIN A HANDLER. + +-- DAT 4/13/81 +-- SPS 3/23/83 + +WITH REPORT; USE REPORT; + +PROCEDURE CB2006A IS + + I : INTEGER RANGE 0 .. 1; + + PACKAGE P IS + V2 : INTEGER := 2; + END P; + + PROCEDURE PR (J : IN OUT INTEGER) IS + K : INTEGER := J; + BEGIN + I := K; + FAILED ("CONSTRAINT_ERROR NOT RAISED 1"); + EXCEPTION + WHEN OTHERS => + J := K + 1; + END PR; + + PACKAGE BODY P IS + L : INTEGER := 2; + BEGIN + TEST ("CB2006A", "LOCAL VARIABLES ARE ACCESSIBLE IN" + & " HANDLERS"); + + I := 1; + I := I + 1; + FAILED ("CONSTRAINT_ERROR NOT RAISED 2"); + EXCEPTION + WHEN OTHERS => + PR (L); + IF L /= V2 + 1 THEN + FAILED ("WRONG VALUE IN LOCAL VARIABLE"); + END IF; + END P; +BEGIN + + RESULT; +END CB2006A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb2007a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb2007a.ada new file mode 100644 index 000000000..01e12d834 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb2007a.ada @@ -0,0 +1,104 @@ +-- CB2007A.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 AN EXIT STATEMENT IN A HANDLER CAN TRANSFER CONTROL +-- OUT OF A LOOP. + +-- DAT 4/13/81 +-- RM 4/30/81 +-- SPS 3/23/83 + +WITH REPORT; USE REPORT; + +PROCEDURE CB2007A IS +BEGIN + TEST ("CB2007A", "EXIT STATEMENTS IN EXCEPTION HANDLERS"); + + DECLARE + FLOW_INDEX : INTEGER := 0 ; + BEGIN + + FOR I IN 1 .. 10 LOOP + BEGIN + IF I = 1 THEN + RAISE CONSTRAINT_ERROR; + END IF; + FAILED ("WRONG CONTROL FLOW 1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => EXIT; + END; + FAILED ("WRONG CONTROL FLOW 2"); + EXIT; + END LOOP; + + FOR AAA IN 1..1 LOOP + FOR BBB IN 1..1 LOOP + FOR I IN 1 .. 10 LOOP + BEGIN + IF I = 1 THEN + RAISE CONSTRAINT_ERROR; + END IF; + FAILED ("WRONG CONTROL FLOW A1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => EXIT; + END; + FAILED ("WRONG CONTROL FLOW A2"); + EXIT; + END LOOP; + + FLOW_INDEX := FLOW_INDEX + 1 ; + END LOOP; + END LOOP; + + LOOP1 : + FOR AAA IN 1..1 LOOP + LOOP2 : + FOR BBB IN 1..1 LOOP + LOOP3 : + FOR I IN 1 .. 10 LOOP + BEGIN + IF I = 1 THEN + RAISE CONSTRAINT_ERROR; + END IF; + FAILED ("WRONG CONTROL FLOW B1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => EXIT LOOP2 ; + END; + FAILED ("WRONG CONTROL FLOW B2"); + EXIT LOOP2 ; + END LOOP LOOP3 ; + + FAILED ("WRONG CONTROL FLOW B3"); + END LOOP LOOP2 ; + + FLOW_INDEX := FLOW_INDEX + 1 ; + END LOOP LOOP1 ; + + IF FLOW_INDEX /= 2 THEN FAILED( "WRONG FLOW OF CONTROL" ); + END IF; + + END ; + + RESULT; +END CB2007A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20a02.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20a02.a new file mode 100644 index 000000000..4c8537086 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb20a02.a @@ -0,0 +1,155 @@ +-- CB20A02.A +-- +-- 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. +--* +-- +-- OBJECTIVE: +-- Check that the name and pertinent information about a user defined +-- exception are available to an enclosing program unit even when the +-- enclosing unit has no visibility into the scope where the exception +-- is declared and raised. +-- +-- TEST DESCRIPTION: +-- Declare a subprogram nested within the test subprogram. The enclosing +-- subprogram does not have visibility into the nested subprogram. +-- Declare and raise an exception in the nested subprogram, and allow +-- the exception to propagate to the enclosing scope. Use the function +-- Exception_Name in the enclosing subprogram to produce exception +-- specific information when the exception is handled in an others +-- handler. +-- +-- TEST FILES: +-- +-- This test depends on the following foundation code file: +-- FB20A00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with FB20A00; -- Package containing Function Find +with Ada.Exceptions; +with Report; + +procedure CB20A02 is + + Seed_Number : Integer; + Random_Number : Integer := 0; + + --=================================================================-- + + function Random_Number_Generator (Seed : Integer) return Integer is + + Result : Integer := 0; + + HighSeedError, + Mid_Seed_Error, + L_o_w_S_e_e_d_E_r_r_o_r : exception; + + begin -- Random_Number_Generator + + + if (Report.Ident_Int (Seed) > 1000) then + raise HighSeedError; + elsif (Report.Ident_Int (Seed) > 100) then + raise Mid_Seed_Error; + elsif (Report.Ident_Int (Seed) > 10) then + raise L_o_w_S_e_e_d_E_r_r_o_r; + else + Seed_Number := ((Seed_Number * 417) + 231) mod 53; + Result := Seed_Number / 52; + end if; + + return Result; + + end Random_Number_Generator; + + --=================================================================-- + +begin + + Report.Test ("CB20A02", "Check that the name " & + "of a user defined exception is available " & + "to an enclosing program unit even when the " & + "enclosing unit has no visibility into the " & + "scope where the exception is declared and " & + "raised" ); + + High_Seed: + begin + -- This seed value will result in the raising of a HighSeedError + -- exception. + Seed_Number := 1001; + Random_Number := Random_Number_Generator (Seed_Number); + Report.Failed ("Exception not raised in High_Seed block"); + exception + when Error : others => + if not FB20A00.Find (Ada.Exceptions.Exception_Name (Error), + "HighSeedError") + then + Report.Failed ("Expected HighSeedError, but found " & + Ada.Exceptions.Exception_Name (Error)); + end if; + end High_Seed; + + + Mid_Seed: + begin + -- This seed value will generate a Mid_Seed_Error exception. + Seed_Number := 101; + Random_Number := Random_Number_Generator (Seed_Number); + Report.Failed ("Exception not raised in Mid_Seed block"); + exception + when Error : others => + if not FB20A00.Find (Ada.Exceptions.Exception_Name (Error), + "Mid_Seed_Error") + then + Report.Failed ("Expected Mid_Seed_Error, but found " & + Ada.Exceptions.Exception_Name (Error)); + end if; + end Mid_Seed; + + + Low_Seed: + begin + -- This seed value will result in the raising of a + -- L_o_w_S_e_e_d_E_r_r_o_r exception. + Seed_Number := 11; + Random_Number := Random_Number_Generator (Seed_Number); + Report.Failed ("Exception not raised in Low_Seed block"); + exception + when Error : others => + if not FB20A00.Find (Ada.Exceptions.Exception_Name (Error), + "L_o_w_S_e_e_d_E_r_r_o_r") + then + Report.Failed ("Expected L_o_w_S_e_e_d_E_r_r_o_r but found " & + Ada.Exceptions.Exception_Name (Error)); + end if; + end Low_Seed; + + + Report.Result; + +end CB20A02; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb3003a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb3003a.ada new file mode 100644 index 000000000..3acdd2eda --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb3003a.ada @@ -0,0 +1,164 @@ +-- CB3003A.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 THE NON-SPECIFIC RAISE STATEMENT PROPAGATES THE EXCEPTION +-- FOR FURTHER PROCESSING(HANDLING) IN ANOTHER HANDLER. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- DCB 04/01/80 +-- JRK 11/19/80 +-- SPS 11/2/82 +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; +PROCEDURE CB3003A IS + + USE REPORT; + + FLOW_COUNT : INTEGER := 0; + E1,E2 : EXCEPTION; + +BEGIN + TEST("CB3003A","CHECK THAT THE NON-SPECIFIC RAISE STATEMENT" & + " PROPAGATES THE ERROR FOR FURTHER HANDLING IN ANOTHER" & + " HANDLER"); + + ------------------------------------------------------- + + BEGIN + BEGIN + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE E1; + FAILED("EXCEPTION NOT RAISED (CASE 1)"); + EXCEPTION + WHEN OTHERS => + FLOW_COUNT := FLOW_COUNT + 1; + RAISE; + FAILED("EXCEPTION NOT RERAISED (CASE 1; " & + "INNER)"); + END; + + EXCEPTION + -- A HANDLER SPECIFIC TO THE RAISED EXCEPTION (E1). + WHEN E1 => + FLOW_COUNT := FLOW_COUNT + 1; + RAISE; + FAILED("EXCEPTION NOT RERAISED (CASE 1; OUTER)"); + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED (CASE 1)"); + END; + + EXCEPTION + WHEN E1 => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("WRONG EXCEPTION PASSED (CASE 1)"); + END; + + ------------------------------------------------------- + + BEGIN + BEGIN + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE E1; + FAILED("EXCEPTION NOT RAISED (CASE 2)"); + EXCEPTION + WHEN OTHERS => + FLOW_COUNT := FLOW_COUNT + 1; + RAISE; + FAILED("EXCEPTION NOT RERAISED (CASE 2; " & + "INNER)"); + END; + + EXCEPTION + -- A HANDLER FOR SEVERAL EXCEPTIONS INCLUDING THE ONE RAISED. + WHEN CONSTRAINT_ERROR => + FAILED("WRONG EXCEPTION RAISED (CONSTRAINT_ERROR)"); + WHEN E2 => + FAILED("WRONG EXCEPTION RAISED (E2)"); + WHEN PROGRAM_ERROR | E1 | TASKING_ERROR => + FLOW_COUNT := FLOW_COUNT + 1; + RAISE; + FAILED("EXCEPTION NOT RERAISED (CASE 2; OUTER)"); + WHEN STORAGE_ERROR => + FAILED("WRONG EXCEPTION RAISED (STORAGE_ERROR)"); + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED (OTHERS)"); + END; + + EXCEPTION + WHEN E1 => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("WRONG EXCEPTION PASSED (CASE 2)"); + END; + + ------------------------------------------------------- + + BEGIN + BEGIN + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE E1; + FAILED("EXCEPTION NOT RAISED (CASE 3)"); + EXCEPTION + WHEN OTHERS => + FLOW_COUNT := FLOW_COUNT + 1; + RAISE; + FAILED("EXCEPTION NOT RERAISED (CASE 3; " & + "INNER)"); + END; + + EXCEPTION + -- A NON-SPECIFIC HANDLER. + WHEN CONSTRAINT_ERROR | E2 => + FAILED("WRONG EXCEPTION RAISED " & + "(CONSTRAINT_ERROR | E2)"); + WHEN OTHERS => + FLOW_COUNT := FLOW_COUNT + 1; + RAISE; + FAILED("EXCEPTION NOT RERAISED (CASE 3; OUTER)"); + END; + + EXCEPTION + WHEN E1 => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("WRONG EXCEPTION PASSED (CASE 3)"); + END; + + ------------------------------------------------------- + + IF FLOW_COUNT /= 12 THEN + FAILED("INCORRECT FLOW_COUNT VALUE"); + END IF; + + RESULT; +END CB3003A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb3003b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb3003b.ada new file mode 100644 index 000000000..460670f03 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb3003b.ada @@ -0,0 +1,135 @@ +-- CB3003B.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 A NON-EXPLICIT RAISE STATEMENT MAY APPEAR IN A BLOCK +-- STATEMENT WITHIN AN EXCEPTION HANDLER; IF THE BLOCK STATEMENT +-- INCLUDES A HANDLER FOR THE CURRENT EXCEPTION, THEN THE INNER +-- HANDLER RECEIVES CONTROL. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- L.BROWN 10/08/86 +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; USE REPORT; + +PROCEDURE CB3003B IS + + MY_ERROR : EXCEPTION; + +BEGIN + TEST("CB3003B","A NON-EXPLICIT RAISE STATEMENT MAY APPEAR IN A "& + "BLOCK STATEMENT WITHIN AN EXCEPTION HANDLER"); + + BEGIN + BEGIN + IF EQUAL(3,3) THEN + RAISE MY_ERROR; + END IF; + FAILED("MY_ERROR WAS NOT RAISED 1"); + EXCEPTION + WHEN MY_ERROR => + BEGIN + IF EQUAL(3,3) THEN + RAISE; + END IF; + FAILED("MY_ERROR WAS NOT RAISED 2"); + EXCEPTION + WHEN MY_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED 1"); + END; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED 2"); + END; + EXCEPTION + WHEN MY_ERROR => + FAILED("CONTROL PASSED TO OUTER HANDLER 1"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED 1"); + END; + + BEGIN + BEGIN + IF EQUAL(3,3) THEN + RAISE MY_ERROR; + END IF; + FAILED("MY_ERROR WAS NOT RAISED 3"); + EXCEPTION + WHEN CONSTRAINT_ERROR | MY_ERROR | TASKING_ERROR => + BEGIN + IF EQUAL(3,3) THEN + RAISE; + END IF; + FAILED("MY_ERROR WAS NOT RAISED 4"); + EXCEPTION + WHEN MY_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED 3"); + END; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED 4"); + END; + EXCEPTION + WHEN MY_ERROR => + FAILED("CONTROL PASSED TO OUTER HANDLER 2"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED 2"); + END; + + BEGIN + BEGIN + IF EQUAL(3,3) THEN + RAISE MY_ERROR; + END IF; + FAILED("MY_ERROR WAS NOT RAISED 5"); + EXCEPTION + WHEN OTHERS => + BEGIN + IF EQUAL(3,3) THEN + RAISE; + END IF; + FAILED("MY_ERROR WAS NOT RAISED 6"); + EXCEPTION + WHEN MY_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED 5"); + END; + END; + EXCEPTION + WHEN MY_ERROR => + FAILED("CONTROL PASSED TO OUTER HANDLER 3"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED 3"); + END; + + RESULT; + +END CB3003B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb3004a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb3004a.ada new file mode 100644 index 000000000..b089bc255 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb3004a.ada @@ -0,0 +1,145 @@ +-- CB3004A.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 INNER UNIT REDECLARES AN EXCEPTION NAME +-- THE HIDDEN DEFINITION IS STILL AVAILABLE FOR USE. + +-- NOTE : WE ASSUME FUNCTIONS ACT LIKE PROCEDURES AND +-- THAT UNITS, BLOCKS, AND PROCEDURES ACT THE SAME +-- IN OTHER CONTEXTS (E.G. TASKS AND PACKAGES). + +-- DCB 6/2/80 +-- JRK 11/19/80 +-- SPS 3/24/83 + +WITH REPORT; +PROCEDURE CB3004A IS + + USE REPORT; + + E1 : EXCEPTION; + FLOW_COUNT : INTEGER := 0; + + PROCEDURE P1 IS + E1, E2 : EXCEPTION; + + PROCEDURE P2 IS + E1 : EXCEPTION; + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE E1; + FAILED("E1 EXCEPTION NOT RAISED"); + EXCEPTION + WHEN P1.E1 => + FAILED("P1.E1 EXCEPTION RAISED WHEN " & + "(P2)E1 EXPECTED"); + WHEN E1 => + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE P1.E1; + FAILED("P1.E1 EXCEPTION NOT RAISED"); + EXCEPTION + WHEN E1 => + FAILED("(P2)E1 EXCEPTION RAISED WHEN" & + " P1.E1 EXPECTED"); + WHEN P1.E1 => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("OTHERS RAISED WHEN P1.E1 " & + "EXPECTED"); + END; + WHEN OTHERS => + FAILED("OTHERS RAISED WHEN (P2)E1 EXPECTED"); + END P2; + + PROCEDURE P3 IS + CONSTRAINT_ERROR : EXCEPTION; + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE CONSTRAINT_ERROR; + FAILED("CONSTRAINT_ERROR EXCEPTION NOT RAISED"); + EXCEPTION + WHEN STANDARD.CONSTRAINT_ERROR => + FAILED("STANDARD.CONSTRAINT_ERROR EXCEPTION " & + "RAISED WHEN " & + "(P3)CONSTRAINT_ERROR EXPECTED"); + WHEN CONSTRAINT_ERROR => + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE STANDARD.CONSTRAINT_ERROR; + FAILED("STANDARD.CONSTRAINT_ERROR " & + "EXCEPTION NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("(P3)CONSTRAINT_ERROR " & + "EXCEPTION RAISED WHEN " & + "STANDARD.CONSTRAINT_ERROR " & + "EXPECTED"); + WHEN STANDARD.CONSTRAINT_ERROR => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("OTHERS RAISED WHEN " & + "STANDARD.CONSTRAINT_ERROR " & + "EXPECTED"); + END; + WHEN OTHERS => + FAILED("OTHERS RAISED WHEN " & + "(P3)CONSTRAINT_ERROR EXPECTED"); + END P3; + + PROCEDURE P4 IS + E2 : EXCEPTION; + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE P1.E2; + FAILED("P1.E2 EXCEPTION NOT RAISED"); + EXCEPTION + WHEN E2 => + FAILED("(P4).E2 RAISED WHEN P1.E2 EXPECTED"); + END P4; + + BEGIN -- P1 + P2; + P3; + P4; + FAILED("P1.E2 EXCEPTION NOT PROPAGATED FROM P4"); + EXCEPTION + WHEN E2 => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("EXCEPTION RAISED WHERE NONE EXPECTED"); + END P1; + +BEGIN + TEST("CB3004A","CHECK THAT WHEN EXCEPTION NAMES" & + " ARE REDECLARED THE HIDDEN DEFINITION IS STILL AVAILABLE"); + + P1; + + IF FLOW_COUNT /= 8 THEN + FAILED("INCORRECT FLOW_COUNT VALUE"); + END IF; + + RESULT; +END CB3004A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40005.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40005.a new file mode 100644 index 000000000..681ec18ff --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40005.a @@ -0,0 +1,339 @@ +-- CB40005.A +-- +-- 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. +--* +-- +-- OBJECTIVE: +-- Check that exceptions raised in non-generic code can be handled by +-- a procedure in a generic package. Check that the exception identity +-- can be properly retrieved from the generic code and used by the +-- non-generic code. +-- +-- TEST DESCRIPTION: +-- This test models a possible usage paradigm for the type: +-- Ada.Exceptions.Exception_Occurrence. +-- +-- A generic package takes access to procedure types (allowing it to +-- be used at any accessibility level) and defines a "fail soft" +-- procedure that takes designators to a procedure to call, a +-- procedure to call in the event that it fails, and a function to +-- call to determine the next action. +-- +-- In the event an exception occurs on the call to the first procedure, +-- the exception is stored in a stack; along with the designator to the +-- procedure that caused it; allowing the procedure to be called again, +-- or the exception to be re-raised. +-- +-- A full implementation of such a tool would use a more robust storage +-- mechanism, and would provide a more flexible interface. +-- +-- +-- CHANGE HISTORY: +-- 29 MAR 96 SAIC Initial version +-- 12 NOV 96 SAIC Revised for 2.1 release +-- +--! + +----------------------------------------------------------------- CB40005_0 + +with Ada.Exceptions; +generic + type Proc_Pointer is access procedure; + type Func_Pointer is access function return Proc_Pointer; +package CB40005_0 is -- Fail_Soft + + + procedure Fail_Soft_Call( Proc_To_Call : Proc_Pointer; + Proc_To_Call_On_Exception : Proc_Pointer := null; + Retry_Routine : Func_Pointer := null ); + + function Top_Event_Exception return Ada.Exceptions.Exception_Occurrence; + + function Top_Event_Procedure return Proc_Pointer; + + procedure Pop_Event; + + function Event_Stack_Size return Natural; + +end CB40005_0; -- Fail_Soft + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- CB40005_0 + +with Report; +package body CB40005_0 is + + type History_Event is record + Exception_Event : Ada.Exceptions.Exception_Occurrence_Access; + Procedure_Called : Proc_Pointer; + end record; + + procedure Store_Event( Proc_Called : Proc_Pointer; + Error : Ada.Exceptions.Exception_Occurrence ); + + procedure Fail_Soft_Call( Proc_To_Call : Proc_Pointer; + Proc_To_Call_On_Exception : Proc_Pointer := null; + Retry_Routine : Func_Pointer := null ) is + + Current_Proc_To_Call : Proc_Pointer := Proc_To_Call; + + begin + while Current_Proc_To_Call /= null loop + begin + Current_Proc_To_Call.all; -- call procedure through pointer + Current_Proc_To_Call := null; + exception + when Capture: others => + Store_Event( Current_Proc_To_Call, Capture ); + if Proc_To_Call_On_Exception /= null then + Proc_To_Call_On_Exception.all; + end if; + if Retry_Routine /= null then + Current_Proc_To_Call := Retry_Routine.all; + else + Current_Proc_To_Call := null; + end if; + end; + end loop; + end Fail_Soft_Call; + + Stack : array(1..10) of History_Event; -- minimal, sufficient for testing + + Stack_Top : Natural := 0; + + procedure Store_Event( Proc_Called : Proc_Pointer; + Error : Ada.Exceptions.Exception_Occurrence ) + is + begin + Stack_Top := Stack_Top +1; + Stack(Stack_Top) := ( Ada.Exceptions.Save_Occurrence(Error), + Proc_Called ); + end Store_Event; + + function Top_Event_Exception return Ada.Exceptions.Exception_Occurrence is + begin + if Stack_Top > 0 then + return Stack(Stack_Top).Exception_Event.all; + else + return Ada.Exceptions.Null_Occurrence; + end if; + end Top_Event_Exception; + + function Top_Event_Procedure return Proc_Pointer is + begin + if Stack_Top > 0 then + return Stack(Stack_Top).Procedure_Called; + else + return null; + end if; + end Top_Event_Procedure; + + procedure Pop_Event is + begin + if Stack_Top > 0 then + Stack_Top := Stack_Top -1; + else + Report.Failed("Stack Error"); + end if; + end Pop_Event; + + function Event_Stack_Size return Natural is + begin + return Stack_Top; + end Event_Stack_Size; + +end CB40005_0; + +------------------------------------------------------------------- CB40005 + +with Report; +with TCTouch; +with CB40005_0; +with Ada.Exceptions; +procedure CB40005 is + + type Proc_Pointer is access procedure; + type Func_Pointer is access function return Proc_Pointer; + + package Fail_Soft is new CB40005_0(Proc_Pointer, Func_Pointer); + + procedure Cause_Standard_Exception; + + procedure Cause_Visible_Exception; + + procedure Cause_Invisible_Exception; + + Exception_Procedure_Pointer : Proc_Pointer; + + Visible_Exception : exception; + + procedure Action_On_Exception; + + function Retry_Procedure return Proc_Pointer; + + Raise_Error : Boolean; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + procedure Cause_Standard_Exception is + begin + TCTouch.Touch('S'); --------------------------------------------------- S + if Raise_Error then + raise Constraint_Error; + end if; + end Cause_Standard_Exception; + + procedure Cause_Visible_Exception is + begin + TCTouch.Touch('V'); --------------------------------------------------- V + if Raise_Error then + raise Visible_Exception; + end if; + end Cause_Visible_Exception; + + procedure Cause_Invisible_Exception is + Invisible_Exception : exception; + begin + TCTouch.Touch('I'); --------------------------------------------------- I + if Raise_Error then + raise Invisible_Exception; + end if; + end Cause_Invisible_Exception; + + procedure Action_On_Exception is + begin + TCTouch.Touch('A'); --------------------------------------------------- A + end Action_On_Exception; + + function Retry_Procedure return Proc_Pointer is + begin + TCTouch.Touch('R'); --------------------------------------------------- R + return Action_On_Exception'Access; + end Retry_Procedure; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +begin -- Main test procedure. + + Report.Test ("CB40005", "Check that exceptions raised in non-generic " & + "code can be handled by a procedure in a generic " & + "package. Check that the exception identity can " & + "be properly retrieved from the generic code and " & + "used by the non-generic code" ); + + -- first, check that the no exception cases cause no action on the stack + Raise_Error := False; + + Fail_Soft.Fail_Soft_Call( Cause_Standard_Exception'Access ); -- S + + Fail_Soft.Fail_Soft_Call( Cause_Visible_Exception'Access, -- V + Action_On_Exception'Access, + Retry_Procedure'Access ); + + Fail_Soft.Fail_Soft_Call( Cause_Invisible_Exception'Access, -- I + null, + Retry_Procedure'Access ); + + TCTouch.Assert( Fail_Soft.Event_Stack_Size = 0, "Empty stack"); + + TCTouch.Validate( "SVI", "Non error case check" ); + + -- second, check that error cases add to the stack + Raise_Error := True; + + Fail_Soft.Fail_Soft_Call( Cause_Standard_Exception'Access ); -- S + + Fail_Soft.Fail_Soft_Call( Cause_Visible_Exception'Access, -- V + Action_On_Exception'Access, -- A + Retry_Procedure'Access ); -- RA + + Fail_Soft.Fail_Soft_Call( Cause_Invisible_Exception'Access, -- I + null, + Retry_Procedure'Access ); -- RA + + TCTouch.Assert( Fail_Soft.Event_Stack_Size = 3, "Stack = 3"); + + TCTouch.Validate( "SVARAIRA", "Error case check" ); + + -- check that the exceptions and procedure were stored correctly + -- on the stack + Raise_Error := False; + + -- return procedure pointer from top of stack and call the procedure + -- through that pointer: + + Fail_Soft.Top_Event_Procedure.all; + + TCTouch.Validate( "I", "Invisible case unwind" ); + + begin + Ada.Exceptions.Raise_Exception( + Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) ); + Report.Failed("1: Exception not raised"); + exception + when Constraint_Error => Report.Failed("1: Raised Constraint_Error"); + when Visible_Exception => Report.Failed("1: Raised Visible_Exception"); + when others => null; -- expected case + end; + + Fail_Soft.Pop_Event; + + -- return procedure pointer from top of stack and call the procedure + -- through that pointer: + + Fail_Soft.Top_Event_Procedure.all; + + TCTouch.Validate( "V", "Visible case unwind" ); + + begin + Ada.Exceptions.Raise_Exception( + Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) ); + Report.Failed("2: Exception not raised"); + exception + when Constraint_Error => Report.Failed("2: Raised Constraint_Error"); + when Visible_Exception => null; -- expected case + when others => Report.Failed("2: Raised Invisible_Exception"); + end; + + Fail_Soft.Pop_Event; + + Fail_Soft.Top_Event_Procedure.all; + + TCTouch.Validate( "S", "Standard case unwind" ); + + begin + Ada.Exceptions.Raise_Exception( + Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) ); + Report.Failed("3: Exception not raised"); + exception + when Constraint_Error => null; -- expected case + when Visible_Exception => Report.Failed("3: Raised Visible_Exception"); + when others => Report.Failed("3: Raised Invisible_Exception"); + end; + + Fail_Soft.Pop_Event; + + TCTouch.Assert( Fail_Soft.Event_Stack_Size = 0, "Stack empty after pops"); + + Report.Result; + +end CB40005; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4001a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4001a.ada new file mode 100644 index 000000000..010add15c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4001a.ada @@ -0,0 +1,151 @@ +-- CB4001A.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 ANY EXCEPTION RAISED IN THE STATEMENT SEQUENCE OF A +-- SUBPROGRAM IS PROPAGATED TO THE CALLER OF THE SUBPROGRAM, NOT TO THE +-- STATICALLY ENCLOSING LEXICAL ENVIRONMENT. + +-- RM 05/30/80 +-- JRK 11/19/80 +-- SPS 03/28/83 +-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. + +WITH REPORT; +PROCEDURE CB4001A IS + + USE REPORT; + + E1 : EXCEPTION; + I9 : INTEGER RANGE 1..10 ; + FLOW_COUNT : INTEGER := 0 ; + +BEGIN + TEST("CB4001A","CHECK THAT ANY EXCEPTION RAISED IN THE " & + "STATEMENT SEQUENCE OF A SUBPROGRAM IS " & + "PROPAGATED TO THE CALLER, NOT TO THE STATICALLY ENCLOSING" & + " LEXICAL ENVIRONMENT"); + + BEGIN -- BLOCK WITH HANDLERS; LEX. ENVIRONMT FOR ALL PROC.DEFS + + DECLARE -- BLOCK WITH PROCEDURE DEFINITIONS + + PROCEDURE CALLEE1 ; + PROCEDURE CALLEE2 ; + PROCEDURE CALLEE3 ; + PROCEDURE R ; + PROCEDURE S ; + + PROCEDURE CALLER1 IS + BEGIN + FLOW_COUNT := FLOW_COUNT + 1 ; + CALLEE1 ; + FAILED("EXCEPTION NOT RAISED (CALLER1)"); + EXCEPTION + WHEN E1 => + FLOW_COUNT := FLOW_COUNT + 1 ; + END ; + + PROCEDURE CALLER2 IS + BEGIN + FLOW_COUNT := FLOW_COUNT + 1 ; + CALLEE2 ; + FAILED("EXCEPTION NOT RAISED (CALLER2)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FLOW_COUNT := FLOW_COUNT + 1 ; + END ; + + PROCEDURE CALLER3 IS + BEGIN + FLOW_COUNT := FLOW_COUNT + 1 ; + CALLEE3 ; + FAILED("EXCEPTION NOT RAISED (CALLER3)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FLOW_COUNT := FLOW_COUNT + 1 ; + END ; + + PROCEDURE CALLEE1 IS + BEGIN + FLOW_COUNT := FLOW_COUNT + 1 ; + R ; + FAILED("EXCEPTION NOT RAISED (CALLEE1)"); + END ; + + PROCEDURE CALLEE2 IS + BEGIN + FLOW_COUNT := FLOW_COUNT + 1 ; + RAISE CONSTRAINT_ERROR ; + FAILED("EXCEPTION NOT RAISED (CALLEE2)"); + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED("WRONG EXCEPTION RAISED (CALLEE2)"); + END ; + + PROCEDURE CALLEE3 IS + BEGIN + FLOW_COUNT := FLOW_COUNT + 1 ; + I9 := IDENT_INT(20) ; + FAILED("EXCEPTION NOT RAISED (CALLEE3)"); + END ; + + PROCEDURE R IS + E2 : EXCEPTION; + BEGIN + FLOW_COUNT := FLOW_COUNT + 10 ; + S ; + FAILED("EXCEPTION E1 NOT RAISED (PROC R)"); + EXCEPTION + WHEN E2 => + FAILED("WRONG EXCEPTION RAISED (PROC R)"); + END ; + + PROCEDURE S IS + BEGIN + FLOW_COUNT := FLOW_COUNT + 10 ; + RAISE E1 ; + FAILED("EXCEPTION E1 NOT RAISED (PROC S)"); + END ; + + BEGIN -- (THE BLOCK WITH PROC. DEFS) + + CALLER1; + CALLER2; + CALLER3; + + END ; -- (THE BLOCK WITH PROC. DEFS) + + EXCEPTION + + WHEN OTHERS => + FAILED("EXCEPTION PROPAGATED STATICALLY"); + + END ; + + IF FLOW_COUNT /= 29 THEN + FAILED("INCORRECT FLOW_COUNT VALUE"); + END IF; + + RESULT; +END CB4001A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4002a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4002a.ada new file mode 100644 index 000000000..e37525769 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4002a.ada @@ -0,0 +1,127 @@ +-- CB4002A.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 EXCEPTIONS RAISED DURING ELABORATION OF THE +-- DECLARATIVE PART OF A SUBPROGRAM ARE PROPAGATED TO THE +-- CALLER, FOR CONSTRAINT_ERROR CAUSED BY INITIALIZATION, +-- AND CONSTRAINT ELABORATION, AND FOR FUNCTION EVALUATIONS +-- RAISING CONSTRAINT_ERROR AND A PROGRAMMER-DEFINED EXCEPTION. + +-- DAT 4/13/81 +-- SPS 3/28/83 + +WITH REPORT; USE REPORT; + +PROCEDURE CB4002A IS +BEGIN + TEST("CB4002A", "EXCEPTIONS IN SUBPROGRAM DECLARATIVE_PARTS" + & " ARE PROPAGATED TO CALLER"); + + DECLARE + SUBTYPE I5 IS INTEGER RANGE -5 .. 5; + + E : EXCEPTION; + + FUNCTION RAISE_IT (I : I5) RETURN INTEGER IS + J : INTEGER RANGE 0 .. 1 := I; + BEGIN + IF I = 0 THEN + RAISE CONSTRAINT_ERROR; + ELSIF I = 1 THEN + RAISE E; + END IF; + FAILED ("EXCEPTION NOT RAISED 0"); + RETURN J; + EXCEPTION + WHEN OTHERS => + IF I NOT IN 0 .. 1 THEN + FAILED ("WRONG HANDLER 0"); + RETURN 0; + ELSE + RAISE; + END IF; + END RAISE_IT; + + PROCEDURE P1 (P : INTEGER) IS + Q : INTEGER := RAISE_IT (P); + BEGIN + FAILED ("EXCEPTION NOT RAISED 1"); + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER 1"); + END P1; + + PROCEDURE P2 (P : INTEGER) IS + Q : I5 RANGE 0 .. P := 1; + BEGIN + IF P = 0 OR P > 5 THEN + FAILED ("EXCEPTION NOT RAISED 2"); + END IF; + END P2; + + BEGIN + + BEGIN + P1(-1); + FAILED ("EXCEPTION NOT RAISED 2A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + END; + + BEGIN + P1(0); + FAILED ("EXCEPTION NOT RAISED 3"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + END; + + BEGIN + P1(1); + FAILED ("EXCEPTION NOT RAISED 4"); + EXCEPTION + WHEN E => NULL; + END; + + BEGIN + P2(0); + FAILED ("EXCEPTION NOT RAISED 5"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + END; + + BEGIN + P2(6); + FAILED ("EXCEPTION NOT RAISED 6"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + END; + + EXCEPTION + WHEN OTHERS => FAILED ("WRONG EXCEPTION OR HANDLER"); + END; + + RESULT; +EXCEPTION + WHEN OTHERS => FAILED ("WRONG HANDLER FOR SURE"); RESULT; +END CB4002A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4003a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4003a.ada new file mode 100644 index 000000000..7f1aaf5e2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4003a.ada @@ -0,0 +1,119 @@ +-- CB4003A.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. +--* +-- OBJECTIVE: +-- CHECK THAT EXCEPTIONS RAISED DURING ELABORATION OF PACKAGE +-- SPECIFICATIONS, OR DECLARATIVE_PARTS OF BLOCKS AND PACKAGE +-- BODIES, ARE PROPAGATED TO THE STATIC ENVIRONMENT. EXCEPTIONS +-- ARE CAUSED BY INITIALIZATIONS AND FUNCTION CALLS. + +-- HISTORY: +-- DAT 04/14/81 CREATED ORIGINAL TEST. +-- JET 01/06/88 UPDATED HEADER FORMAT AND ADDED CODE TO +-- PREVENT OPTIMIZATION. + +WITH REPORT; USE REPORT; + +PROCEDURE CB4003A IS + + E : EXCEPTION; + + FUNCTION F (B : BOOLEAN) RETURN INTEGER IS + BEGIN + IF B THEN + RAISE E; + ELSE + RETURN 1; + END IF; + END F; + +BEGIN + TEST ("CB4003A", "CHECK THAT EXCEPTIONS DURING ELABORATION" + & " OF DECLARATIVE PARTS" + & " IN BLOCKS, PACKAGE SPECS, AND PACKAGE BODIES ARE" + & " PROPAGATED TO STATIC ENCLOSING ENVIRONMENT"); + + BEGIN + DECLARE + PACKAGE P1 IS + I : INTEGER RANGE 1 .. 1 := 2; + END P1; + BEGIN + FAILED ("EXCEPTION NOT RAISED 1"); + IF NOT EQUAL(P1.I,P1.I) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("WRONG HANDLER 1"); + END; + FAILED ("EXCEPTION NOT RAISED 1A"); + EXCEPTION + WHEN CONSTRAINT_ERROR =>NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION 1"); + END; + + FOR L IN IDENT_INT(1) .. IDENT_INT(4) LOOP + BEGIN + DECLARE + PACKAGE P2 IS + PRIVATE + J : INTEGER RANGE 2 .. 4 := L; + END P2; + + Q : INTEGER := F(L = 3); + + PACKAGE BODY P2 IS + K : INTEGER := F(L = 2); + + BEGIN + IF NOT (EQUAL(J,J) OR EQUAL(K,K)) THEN + COMMENT("CAN'T OPTIMIZE THIS"); + END IF; + END P2; + BEGIN + IF L /= 4 THEN + FAILED ("EXCEPTION NOT RAISED 2"); + END IF; + + IF NOT EQUAL(Q,Q) THEN + COMMENT("CAN'T OPTIMIZE THIS"); + END IF; + + EXIT; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG EXCEPTION HANDLER 2"); + EXIT; + END; + FAILED ("EXCEPTION NOT RAISED 2A"); + EXCEPTION + WHEN E | CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 2"); + END; + END LOOP; + + RESULT; + +END CB4003A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4004a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4004a.ada new file mode 100644 index 000000000..228d0a4ee --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4004a.ada @@ -0,0 +1,77 @@ +-- CB4004A.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 VARIOUS EXCEPTIONS IN THE BODY OF A SUBPROGRAM WITH +-- AN APPLICABLE HANDLER ARE HANDLED LOCALLY. + +-- DAT 04/15/81 +-- JRK 04/24/81 +-- SPS 11/02/82 +-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE CB4004A IS + + E, F : EXCEPTION; + STORAGE_ERROR: EXCEPTION; + + I1 : INTEGER RANGE 1 .. 1; + + FUNCTION F1 (I : INTEGER) RETURN BOOLEAN IS + BEGIN + CASE I IS + WHEN 1 => RAISE E; + WHEN 2 => RAISE STORAGE_ERROR; + WHEN 3 => I1 := 4; + WHEN 4 => RAISE TASKING_ERROR; + WHEN OTHERS => NULL; + END CASE; + RETURN FALSE; + EXCEPTION + WHEN E | F => RETURN I = 1; + WHEN STORAGE_ERROR => RETURN I = 2; + WHEN PROGRAM_ERROR | CONSTRAINT_ERROR => + RETURN I = 3; + WHEN OTHERS => RETURN I = 4; + END F1; + +BEGIN + TEST ("CB4004A", "EXCEPTIONS WITH LOCAL HANDLERS ARE HANDLED" + & " THERE"); + + BEGIN + FOR L IN 1 .. 4 LOOP + IF F1(L) /= TRUE THEN + FAILED ("LOCAL EXCEPTIONS DON'T WORK"); + EXIT; + END IF; + END LOOP; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER"); + END; + + RESULT; +END CB4004A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4005a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4005a.ada new file mode 100644 index 000000000..5b68ac39b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4005a.ada @@ -0,0 +1,66 @@ +-- CB4005A.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 EXCEPTIONS PROPAGATED OUT OF A HANDLER ARE PROPAGATED +-- OUTSIDE THE ENCLOSING UNIT. + +-- DAT 4/15/81 +-- SPS 3/28/83 + +WITH REPORT; USE REPORT; + +PROCEDURE CB4005A IS + + E , F : EXCEPTION; + + B : BOOLEAN := FALSE; + + PROCEDURE P IS + BEGIN + RAISE E; + EXCEPTION + WHEN F => FAILED ("WRONG HANDLER 1"); + WHEN E => + IF B THEN + FAILED ("WRONG HANDLER 2"); + ELSE + B := TRUE; + RAISE F; + END IF; + END P; + +BEGIN + TEST ("CB4005A", "EXCEPTIONS FROM HANDLERS ARE PROPAGATED " & + "OUTSIDE"); + + BEGIN + P; + FAILED ("EXCEPTION NOT PROPAGATED 1"); + EXCEPTION + WHEN F => NULL; + WHEN OTHERS => FAILED ("WRONG HANDLER 3"); + END; + + RESULT; +END CB4005A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4006a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4006a.ada new file mode 100644 index 000000000..b0ddfc57a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4006a.ada @@ -0,0 +1,97 @@ +-- CB4006A.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. +--* +-- OBJECTIVE: +-- CHECK THAT EXCEPTIONS IN A BLOCK IN A HANDLER +-- ARE HANDLED CORRECTLY. + +-- HISTORY: +-- DAT 04/15/81 +-- SPS 11/02/82 +-- JET 01/06/88 UPDATED HEADER FORMAT AND ADDED CODE TO +-- PREVENT OPTIMIZATION. +-- JRL 05/28/92 CHANGED CODE IN PROGRAM_ERROR BLOCK TO +-- PREVENT OPTIMIZATION. + +WITH REPORT; +USE REPORT; + +PROCEDURE CB4006A IS + + I1 : INTEGER RANGE 1 .. 2 := 1; + + PROCEDURE P IS + BEGIN + IF EQUAL(3,3) THEN + RAISE PROGRAM_ERROR; + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + DECLARE + I : INTEGER RANGE 1 .. 1 := I1; + BEGIN + IF EQUAL(I,I) THEN + I := I1 + 1; + END IF ; + FAILED ("EXCEPTION NOT RAISED 1"); + + IF NOT EQUAL(I,I) THEN + COMMENT ("CAN'T OPTIMIZE THIS"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF I1 /= 1 THEN + FAILED ("WRONG HANDLER 1"); + ELSE + I1 := I1 + 1; + END IF; + END; + WHEN CONSTRAINT_ERROR => + FAILED ("WRONG HANDLER 3"); + END P; + +BEGIN + TEST ("CB4006A", "CHECK THAT EXCEPTIONS IN BLOCKS IN " & + "HANDLERS WORK"); + + P; + IF IDENT_INT(I1) /= 2 THEN + FAILED ("EXCEPTION NOT HANDLED CORRECTLY"); + ELSE + BEGIN + P; + FAILED ("EXCEPTION NOT RAISED CORRECTLY 2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + END; + END IF; + + RESULT; + +EXCEPTION + WHEN OTHERS => FAILED ("WRONG HANDLER 2"); + RESULT; + +END CB4006A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4007a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4007a.ada new file mode 100644 index 000000000..789d1b330 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4007a.ada @@ -0,0 +1,115 @@ +-- CB4007A.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. +--* +-- OBJECTIVE: +-- CHECK THAT THE STATEMENT PART OF A PACKAGE CAN RAISE, PROPAGATE, +-- AND HANDLE EXCEPTIONS. IF THE BODY'S HANDLERS HANDLE ALL +-- EXCEPTIONS RAISED AND DO NOT RAISE ANY UNHANDLED EXCEPTIONS, +-- NO EXCEPTION IS PROPAGATED. + +-- HISTORY: +-- DHH 03/28/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE CB4007A IS +BEGIN + + TEST("CB4007A", "CHECK THAT THE STATEMENT PART OF A PACKAGE " & + "CAN RAISE, PROPAGATE, AND HANDLE EXCEPTIONS. " & + "IF THE BODY'S HANDLERS HANDLE ALL EXCEPTIONS " & + "RAISED AND DO NOT RAISE ANY UNHANDLED " & + "EXCEPTIONS, NO EXCEPTION IS PROPAGATED"); + DECLARE + + PACKAGE OUTSIDE IS + END OUTSIDE; + + PACKAGE BODY OUTSIDE IS + + BEGIN + DECLARE + PACKAGE HANDLER IS + END HANDLER; + + PACKAGE BODY HANDLER IS + BEGIN + DECLARE + PACKAGE PROPAGATE IS + END PROPAGATE; + + PACKAGE BODY PROPAGATE IS + BEGIN + DECLARE + PACKAGE RISE IS + END RISE; + + PACKAGE BODY RISE IS + BEGIN + RAISE CONSTRAINT_ERROR; + FAILED("EXCEPTION " & + "NOT RAISED"); + END RISE; + + BEGIN + NULL; + END; -- PACKAGE PROPAGATE DECLARE. + EXCEPTION + WHEN CONSTRAINT_ERROR => + RAISE CONSTRAINT_ERROR; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION " & + "RAISED IN PROPAGATE " & + "PACKAGE"); + END PROPAGATE; + + BEGIN + NULL; + END; -- PACKAGE HANDLER DECLARE. + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "HANDLER PACKAGE"); + END HANDLER; + + BEGIN + NULL; + END; -- PACKAGE OUTSIDE DECLARE. + EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN OUTSIDE " & + "PACKAGE"); + END OUTSIDE; + BEGIN + NULL; + END; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED"); + RESULT; +END CB4007A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4008a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4008a.ada new file mode 100644 index 000000000..741a7a8f0 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4008a.ada @@ -0,0 +1,137 @@ +-- CB4008A.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 NESTED LAST WISHES EXCEPTION HANDLERS WORK +-- (FOR PROCEDURES). + +-- DAT 4/15/81 +-- SPS 3/28/83 + +WITH REPORT; USE REPORT; + +PROCEDURE CB4008A IS + + C : INTEGER := 0; + + E : EXCEPTION; + + DEPTH : CONSTANT := 99; + + PROCEDURE F; + + PROCEDURE I IS + BEGIN + C := C + 1; + IF C >= DEPTH THEN + RAISE E; + END IF; + END I; + + PROCEDURE O IS + BEGIN + C := C - 1; + END O; + + PROCEDURE X IS + PROCEDURE X1 IS + PROCEDURE X2 IS + BEGIN + F; + END X2; + + PROCEDURE X3 IS + BEGIN + I; + X2; + EXCEPTION + WHEN E => O; RAISE; + END X3; + BEGIN + I; + X3; + EXCEPTION + WHEN E => O; RAISE; + END X1; + + PROCEDURE X1A IS + BEGIN + I; + X1; + FAILED ("INCORRECT EXECUTION SEQUENCE"); + EXCEPTION + WHEN E => O; RAISE; + END X1A; + BEGIN + I; + X1A; + EXCEPTION + WHEN E => O; RAISE; + END X; + + PROCEDURE Y IS + BEGIN + I; + X; + EXCEPTION WHEN E => O; RAISE; + END Y; + + PROCEDURE F IS + PROCEDURE F2; + + PROCEDURE F1 IS + BEGIN + I; + F2; + EXCEPTION WHEN E => O; RAISE; + END F1; + + PROCEDURE F2 IS + BEGIN + I; + Y; + EXCEPTION WHEN E => O; RAISE; + END F2; + BEGIN + I; + F1; + EXCEPTION WHEN E => O; RAISE; + END F; + +BEGIN + TEST ("CB4008A", "(PROCEDURE) LAST WISHES UNWIND PROPERLY"); + + BEGIN + I; + Y; + FAILED ("INCORRECT EXECUTION SEQUENCE 2"); + EXCEPTION + WHEN E => + O; + IF C /= 0 THEN + FAILED ("EXCEPTION HANDLER MISSED SOMEWHERE"); + END IF; + END; + + RESULT; +END CB4008A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4009a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4009a.ada new file mode 100644 index 000000000..98f009e4b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4009a.ada @@ -0,0 +1,114 @@ +-- CB4009A.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 A PROGRAMMER DEFINED EXCEPTION AND A REDECLARED +-- PREDEFINED EXCEPTION MAY BE PROPAGATED OUT OF SCOPE AND BACK IN, +-- WITH OUT-OF-SCOPE 'OTHERS' HANDLERS HANDLING THE EXCEPTION +-- INSTEAD OF OTHER HANDLERS. SEPARATELY COMPILED UNITS ARE NOT TESTED. + +-- DAT 4/15/81 +-- SPS 1/14/82 + +WITH REPORT; USE REPORT; + +PROCEDURE CB4009A IS + + E : EXCEPTION; + + I : INTEGER := 0; + + PROCEDURE P1 (C : INTEGER); + PROCEDURE P2 (C : INTEGER); + PROCEDURE P3 (C : INTEGER); + + F : BOOLEAN := FALSE; + T : CONSTANT BOOLEAN := TRUE; + + PROCEDURE P1 (C : INTEGER) IS + BEGIN + P3(C); + EXCEPTION + WHEN E => F := T; + WHEN CONSTRAINT_ERROR => F := T; + WHEN OTHERS => I := I + 1; RAISE; + END P1; + + PROCEDURE P2 (C : INTEGER) IS + E : EXCEPTION; + CONSTRAINT_ERROR : EXCEPTION; + BEGIN + CASE C IS + WHEN 0 => FAILED ("WRONG CASE"); + WHEN 1 => RAISE E; + WHEN -1 => RAISE CONSTRAINT_ERROR; + WHEN OTHERS => P1 (C - C/ABS(C)); + END CASE; + EXCEPTION + WHEN E => + I := I + 100; RAISE; + WHEN CONSTRAINT_ERROR => + I := I + 101; RAISE; + WHEN OTHERS => + F := T; + END P2; + + PROCEDURE P3 (C : INTEGER) IS + BEGIN + P2(C); + EXCEPTION + WHEN E => F := T; + WHEN CONSTRAINT_ERROR => F := T; + END P3; + +BEGIN + TEST ("CB4009A", "EXCEPTIONS PROPAGATED OUT OF SCOPE"); + + I := 0; + BEGIN + P3 (-2); + FAILED ("EXCEPTION NOT RAISED 1"); + EXCEPTION + WHEN OTHERS => NULL; + END; + IF I /= 203 THEN + FAILED ("INCORRECT HANDLER SOMEWHERE 1"); + END IF; + + I := 0; + BEGIN + P3(3); + FAILED ("EXCEPTION NOT RAISED 2"); + EXCEPTION + WHEN OTHERS => NULL; + END; + IF I /= 302 THEN + FAILED ("INCORRECT HANDLER SOMEWHERE 2"); + END IF; + + IF F = T THEN + FAILED ("WRONG HANDLER SOMEWHERE"); + END IF; + + RESULT; +END CB4009A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4013a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4013a.ada new file mode 100644 index 000000000..655b80035 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb4013a.ada @@ -0,0 +1,80 @@ +-- CB4013A.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. +--* +-- OBJECTIVE: +-- CHECK THAT AN UNHANDLED EXCEPTION RAISED IN A TASK BODY, BUT +-- OUTSIDE AN ACCEPT STATEMENT, RAISES NO EXCEPTION OUTSIDE THE +-- TASK. + +-- HISTORY: +-- DHH 03/29/88 CREATED ORIGINAL TEST. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE CB4013A IS + + TASK TYPE CHOICE IS + ENTRY E1; + ENTRY STOP; + END CHOICE; + + T : CHOICE; + + TASK BODY CHOICE IS + BEGIN + ACCEPT E1; + IF EQUAL(3,3) THEN + RAISE CONSTRAINT_ERROR; + END IF; + ACCEPT STOP; + END CHOICE; + +BEGIN + + TEST("CB4013A", "CHECK THAT AN UNHANDLED EXCEPTION RAISED IN " & + "A TASK BODY, BUT OUTSIDE AN ACCEPT STATEMENT, " & + "RAISES NO EXCEPTION OUTSIDE THE TASK"); + + T.E1; + DELAY 1.0; + IF T'CALLABLE THEN + FAILED("TASK NOT COMPLETED ON RAISING CONSTRAINT_ERROR"); + T.STOP; + END IF; + + RESULT; + +EXCEPTION + WHEN TASKING_ERROR => + FAILED("TASKING_ERROR RAISED OUTSIDE TASK"); + RESULT; + + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR PROPAGATED OUTSIDE TASK"); + RESULT; + + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED"); + RESULT; +END CB4013A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40a01.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40a01.a new file mode 100644 index 000000000..1c569119a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40a01.a @@ -0,0 +1,135 @@ +-- CB40A01.A +-- +-- 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. +--* +-- +-- OBJECTIVE: +-- Check that a user defined exception is correctly propagated out of +-- a public child package. +-- +-- TEST DESCRIPTION: +-- Declare a public child package containing a procedure used to +-- analyze the alphanumeric content of a particular text string. +-- The procedure contains a processing loop that continues until the +-- range of the text string is exceeded, at which time a user defined +-- exception is raised. This exception propagates out of the procedure +-- through the parent package, to the main test program. +-- +-- Exception Type Raised: +-- * User Defined +-- Predefined +-- +-- Hierarchical Structure Employed For This Test: +-- * Parent Package +-- * Public Child Package +-- Private Child Package +-- Public Child Subprogram +-- Private Child Subprogram +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- FB40A00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +package FB40A00.CB40A01_0 is -- package Text_Parser.Processing + + procedure Process_Text (Text : in String_Pointer_Type); + +end FB40A00.CB40A01_0; + + + --=================================================================-- + + +with Report; + +package body FB40A00.CB40A01_0 is + + procedure Process_Text (Text : in String_Pointer_Type) is + Pos : Natural := Text'First - 1; + begin + loop -- Process string, raise exception upon completion. + Pos := Pos + 1; + if Pos > Text.all'Last then + raise Completed_Text_Processing; + elsif (Text.all (Pos) in 'A' .. 'Z') or + (Text.all (Pos) in 'a' .. 'z') or + (Text.all (Pos) in '0' .. '9') then + Increment_AlphaNumeric_Count; + else + Increment_Non_AlphaNumeric_Count; + end if; + end loop; + -- No exception handler here, exception propagates. + Report.Failed ("No exception raised in child package subprogram"); + end Process_Text; + +end FB40A00.CB40A01_0; + + + --=================================================================-- + + +with FB40A00.CB40A01_0; +with Report; + +procedure CB40A01 is + + String_Pointer : FB40A00.String_Pointer_Type := + new String'("'Twas the night before Christmas, " & + "and all through the house..."); + +begin + + Process_Block: + begin + + Report.Test ("CB40A01", "Check that a user defined exception " & + "is correctly propagated out of a " & + "public child package"); + + FB40A00.CB40A01_0.Process_Text (String_Pointer); + + Report.Failed ("Exception should have been handled"); + + exception + + when FB40A00.Completed_Text_Processing => -- Correct exception + if FB40A00.AlphaNumeric_Count /= 48 then -- propagation. + Report.Failed ("Incorrect string processing"); + end if; + + when others => + Report.Failed ("Exception handled in an others handler"); + + end Process_Block; + + Report.Result; + +end CB40A01; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40a020.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40a020.a new file mode 100644 index 000000000..09830b87f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40a020.a @@ -0,0 +1,95 @@ +-- CB40A020.A +-- +-- 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. +--* +-- +-- OBJECTIVE: +-- See CB40A021.AM. +-- +-- TEST DESCRIPTION: +-- See CB40A021.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- FB40A00.A +-- => CB40A020.A +-- CB40A021.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 02 Nov 96 SAIC ACVC 2.1: Modified prologue. +-- +--! + + +package FB40A00.CB40A020_0 is -- package Text_Parser.Processing + + function Count_AlphaNumerics (Text : in String) return Natural; + +end FB40A00.CB40A020_0; + + + --=================================================================-- + + +-- Text_Parser.Processing.Process_Text +with Report; +private procedure FB40A00.CB40A020_0.CB40A020_1 (Text : in String); + +procedure FB40A00.CB40A020_0.CB40A020_1 (Text : in String) is + Pos : Natural := Text'First - 1; +begin + loop -- Process string, raise exception upon completion. + Pos := Pos + 1; + if Pos > Text'Last then + raise Completed_Text_Processing; + elsif (Text (Pos) in 'A' .. 'Z') or + (Text (Pos) in 'a' .. 'z') or + (Text (Pos) in '0' .. '9') then + Increment_AlphaNumeric_Count; + else + Increment_Non_AlphaNumeric_Count; + end if; + end loop; + -- No exception handler here, exception propagates. + Report.Failed ("No exception raised in child package subprogram"); +end FB40A00.CB40A020_0.CB40A020_1; + + + --=================================================================-- + + +with FB40A00.CB40A020_0.CB40A020_1; -- "with" of private child subprogram + -- Text_Parser.Processing.Process_Text +package body FB40A00.CB40A020_0 is + + function Count_AlphaNumerics (Text : in String) return Natural is + begin + FB40A00.CB40A020_0.CB40A020_1 (Text); -- Call prvt child proc. + return (AlphaNumeric_Count); -- Global maintained in parent. + -- No exception handler here, exception propagates. + end Count_AlphaNumerics; + +end FB40A00.CB40A020_0; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40a021.am b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40a021.am new file mode 100644 index 000000000..027b7da9d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40a021.am @@ -0,0 +1,103 @@ +-- CB40A021.AM +-- +-- 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. +--* +-- +-- OBJECTIVE: +-- Check that a user defined exception is correctly propagated from a +-- private child subprogram to its parent and then to a client of the +-- parent. +-- +-- TEST DESCRIPTION: +-- Declare a child package containing a function. The body of the +-- function contains a call to a private child subprogram (child of +-- the child). The private child subprogram raises an exception +-- defined in the root ancestor package, and it is propagated to the +-- test program. +-- +-- Exception Type Raised: +-- * User Defined +-- Predefined +-- +-- Hierarchical Structure Employed For This Test: +-- * Parent Package +-- * Visible Child Package +-- Private Child Package +-- Visible Child Subprogram +-- * Private Child Subprogram +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- FB40A00.A +-- CB40A020.A +-- => CB40A021.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 02 Nov 96 SAIC ACVC 2.1: Modified prologue. +-- +--! + + +with Report; +with FB40A00.CB40A020_0; -- Explicit "with" of Text_Parser.Processing + -- Implicit "with" of Text_Parser (FB40A00) + +procedure CB40A021 is + + String_Constant : constant String := + "ACVC Version 2.0 will incorporate Ada 9X feature tests."; + + Number_Of_AlphaNumeric_Characters : Natural := 0; + +begin + + Process_Block: + begin + + Report.Test ("CB40A021", "Check that a user defined exception " & + "is correctly propagated across " & + "package and subprogram boundaries"); + + Number_Of_AlphaNumeric_Characters := + FB40A00.CB40A020_0.Count_AlphaNumerics (String_Constant); + + Report.Failed ("Exception should have been handled"); + + exception + + when FB40A00.Completed_Text_Processing => -- Correct exception + if FB40A00.AlphaNumeric_Count /= 45 then -- propagation. + Report.Failed ("Incorrect string processing"); + end if; + + when others => + Report.Failed ("Exception handled in an others handler"); + + end Process_Block; + + Report.Result; + +end CB40A021; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40a030.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40a030.a new file mode 100644 index 000000000..8b053e2f0 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40a030.a @@ -0,0 +1,105 @@ +-- CB40A030.A +-- +-- 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. +--* +-- +-- OBJECTIVE: +-- See CB40A031.AM. +-- +-- TEST DESCRIPTION: +-- See CB40A031.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- FB40A00.A +-- => CB40A030.A +-- CB40A031.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 02 Nov 96 SAIC ACVC 2.1: Modified prologue. +-- +--! + + +package FB40A00.CB40A030_0 is -- package Text_Parser.Character_Counting + + function Count_AlphaNumerics (Text : in String) return Natural; + +end FB40A00.CB40A030_0; + + + --=================================================================-- + + +private package FB40A00.CB40A030_1 is -- package Text_Parser.Processing + + procedure Process_Text (Text : in String); + +end FB40A00.CB40A030_1; + + + --=================================================================-- + + +package body FB40A00.CB40A030_1 is + + procedure Process_Text (Text : in String) is + Loop_Count : Integer := Text'Length + 1; + begin + for Pos in 1..Loop_Count loop -- Process string, force the + -- raise of Constraint_Error. + if (Text (Pos) in 'a'..'z') or + (Text (Pos) in 'A'..'Z') or + (Text (Pos) in '0'..'9') then + Increment_AlphaNumeric_Count; + else + Increment_Non_AlphaNumeric_Count; + end if; + + end loop; + -- No exception handler here, exception propagates. + end Process_Text; + +end FB40A00.CB40A030_1; + + + --=================================================================-- + + +with FB40A00.CB40A030_1; -- private sibling package Text_Parser.Processing; + +package body FB40A00.CB40A030_0 is + + function Count_AlphaNumerics (Text : in String) return Natural is + begin + FB40A00.CB40A030_1.Process_Text (Text); -- Call proc in prvt child + -- package that is a + -- sibling of this package. + return (AlphaNumeric_Count); + -- No exception handler here, exception propagates. + end Count_AlphaNumerics; + +end FB40A00.CB40A030_0; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40a031.am b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40a031.am new file mode 100644 index 000000000..6f2f2aa99 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40a031.am @@ -0,0 +1,102 @@ +-- CB40A031.AM +-- +-- 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. +--* +-- +-- OBJECTIVE: +-- Check that a predefined exception is correctly propagated from +-- a private child package through a visible child package to a client. +-- +-- TEST DESCRIPTION: +-- Declare two child packages from a root package, one visible, one +-- private. The visible child package contains a function, whose +-- body makes a call to a procedure contained in the private sibling +-- package. A predefined exception occurring in the subprogram within the +-- private package is propagated through the visible sibling and ancestor +-- to the test program. +-- +-- Exception Type Raised: +-- User Defined +-- * Predefined +-- +-- Hierarchical Structure Employed For This Test: +-- * Parent Package +-- * Visible Child Package +-- * Private Child Package +-- Visible Child Subprogram +-- Private Child Subprogram +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- FB40A00.A +-- CB40A030.A +-- => CB40A031.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 02 Nov 96 SAIC ACVC 2.1: Modified prologue. +-- +--! + +with Report; +with FB40A00.CB40A030_0; -- Explicit "with" of Text_Parser.Character_Counting + -- Implicit "with" of Text_Parser + +procedure CB40A031 is + + String_Constant : constant String := + "The San Diego Padres will win the World Series in 1999."; + + Number_Of_AlphaNumeric_Characters : Natural := 0; + +begin + + Process_Block: + begin + + Report.Test ("CB40A031", "Check that a predefined exception " & + "is correctly propagated across " & + "package boundaries"); + + Number_Of_AlphaNumeric_Characters := + FB40A00.CB40A030_0.Count_AlphaNumerics (String_Constant); + + Report.Failed ("Exception should have been handled"); + + exception + + when Constraint_Error => -- Correct exception + if FB40A00.AlphaNumeric_Count /= 44 then -- propagation. + Report.Failed ("Incorrect string processing"); + end if; + + when others => + Report.Failed ("Exception handled in an others handler"); + + end Process_Block; + + Report.Result; + +end CB40A031; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40a04.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40a04.a new file mode 100644 index 000000000..45209b9be --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb40a04.a @@ -0,0 +1,119 @@ +-- CB40A04.A +-- +-- 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. +--* +-- +-- OBJECTIVE: +-- Check that a predefined exception is correctly propagated out of a +-- public child function to a client. +-- +-- TEST DESCRIPTION: +-- Declare a public child subprogram. Define the processing loop +-- inside the subprogram to expect a string with index starting at 1. +-- From the test procedure, call the child subprogram with a slice +-- from the middle of a string variable. This will cause an exception +-- to be raised in the child and propagated to the caller. +-- +-- Exception Type Raised: +-- User Defined +-- * Predefined +-- +-- Hierarchical Structure Employed For This Test: +-- * Parent Package +-- Public Child Package +-- Private Child Package +-- * Public Child Subprogram +-- Private Child Subprogram +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- FB40A00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +-- Child subprogram Text_Parser.Count_AlphaNumerics + +function FB40A00.CB40A04_0 (Text : string) return Natural is +begin + + for I in 1 .. Text'Last loop -- Raise immediate Constraint_Error + if (Text (I) in 'a'..'z') or -- with String slice passed from + (Text (I) in 'A'..'Z') or -- caller. (Slice'first /= 1) + (Text (I) in '0'..'9') then + Increment_AlphaNumeric_Count; + else + Increment_Non_AlphaNumeric_Count; + end if; + end loop; + + return (AlphaNumeric_Count); -- Global in parent package. + + -- No exception handler here, exception propagates. + +end FB40A00.CB40A04_0; + + + --=================================================================-- + + +with FB40A00.CB40A04_0; -- Explicit "with" of Text_Parser.Count_AlphaNumerics +with Report; -- Implicit "with" of Text_Parser. + +procedure CB40A04 is + + String_Var : String (1..19) := "The quick brown fox"; + + Number_Of_AlphaNumeric_Characters : Natural := 0; + +begin + + Report.Test ("CB40A04", "Check that a predefined exception is " & + "correctly propagated out of a public " & + "child function to a client"); + + Process_Block: + begin + + Number_Of_AlphaNumeric_Characters := -- Provide slice of string + FB40A00.CB40A04_0 (String_Var (5..10)); -- to subprogram. + + Report.Failed ("Exception should have been handled"); + + exception + + when Constraint_Error => -- Correct exception + null; -- propagation. + + when others => + Report.Failed ("Exception handled in an others handler"); + + end Process_Block; + + Report.Result; + +end CB40A04; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb41001.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb41001.a new file mode 100644 index 000000000..95ad868fe --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb41001.a @@ -0,0 +1,213 @@ +-- CB41001.A +-- +-- 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. +--* +-- +-- OBJECTIVE: +-- Check that the 'Identity attribute returns the unique identity of an +-- exception. Check that the Raise_Exception procedure can raise an +-- exception that is specified through the use of the 'Identity attribute, +-- and that Reraise_Occurrence can re-raise an exception occurrence +-- using an exception choice parameter. +-- +-- TEST DESCRIPTION: +-- This test uses the capability of the 'Identity attribute, which +-- returns the unique identity of an exception, as an Exception_Id +-- result. This result is used as an input parameter to the procedure +-- Raise_Exception. The exception that results is handled, propagated +-- using the Reraise_Occurrence procedure, and handled again. +-- The above actions are performed for both a user-defined and a +-- predefined exception. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 11 Nov 96 SAIC ACVC 2.1: Modified Propagate_User_Exception. +-- +--! + +with Report; +with Ada.Exceptions; + +procedure CB41001 is + +begin + + Report.Test ("CB41001", "Check that the 'Identity attribute returns " & + "the unique identity of an exception. Check " & + "that the 'Identity attribute is of type " & + "Exception_Id. Check that the " & + "Raise_Exception procedure can raise an " & + "exception that is specified through the " & + "use of the 'Identity attribute"); + Test_Block: + declare + + Check_Points : constant := 5; + + type Check_Point_Array_Type is array (1..Check_Points) of Boolean; + + -- Global array used to track the processing path through the test. + TC_Check_Points : Check_Point_Array_Type := (others => False); + + A_User_Defined_Exception : Exception; + An_Exception_ID : Ada.Exceptions.Exception_Id := + Ada.Exceptions.Null_Id; + + procedure Propagate_User_Exception is + Hidden_Exception : Exception; + begin + -- Use the 'Identity function to store the unique identity of a + -- user defined exception into a variable of type Exception_Id. + + An_Exception_ID := A_User_Defined_Exception'Identity; + + -- Raise this user defined exception using the result of the + -- 'Identity attribute. + + Ada.Exceptions.Raise_Exception(E => An_Exception_Id); + + Report.Failed("User defined exception not raised by " & + "procedure Propagate_User_Exception"); + + exception + when Proc_Excpt : A_User_Defined_Exception => -- Expected exception. + begin + + -- By raising a different exception at this point, the + -- information associated with A_User_Defined_Exception must + -- be correctly stacked internally. + + Ada.Exceptions.Raise_Exception(Hidden_Exception'Identity); + Report.Failed("Hidden_Exception not raised by " & + "procedure Propagate_User_Exception"); + exception + when others => + TC_Check_Points(1) := True; + + -- Reraise the original exception, which will be propagated + -- outside the scope of this procedure. + + Ada.Exceptions.Reraise_Occurrence(Proc_Excpt); + Report.Failed("User defined exception not reraised"); + + end; + + when others => + Report.Failed("Unexpected exception raised by " & + "Procedure Propagate_User_Exception"); + end Propagate_User_Exception; + + begin + + User_Exception_Block: + begin + -- Call procedure to raise, handle, and reraise a user defined + -- exception. + Propagate_User_Exception; + + Report.Failed("User defined exception not propagated from " & + "procedure Propagate_User_Exception"); + + exception + when A_User_Defined_Exception => -- Expected exception. + TC_Check_Points(2) := True; + when others => + Report.Failed + ("Unexpected exception handled in User_Exception_Block"); + end User_Exception_Block; + + + Predefined_Exception_Block: + begin + + Inner_Block: + begin + + begin + -- Use the 'Identity attribute as an input parameter to the + -- Raise_Exception procedure. + + Ada.Exceptions.Raise_Exception(Constraint_Error'Identity); + Report.Failed("Constraint_Error not raised in Inner_Block"); + + exception + when Excpt : Constraint_Error => -- Expected exception. + TC_Check_Points(3) := True; + + -- Reraise the exception. + Ada.Exceptions.Reraise_Occurrence(X => Excpt); + Report.Failed("Predefined exception not raised from " & + "within the exception handler - 1"); + when others => + Report.Failed("Incorrect result from attempt to raise " & + "Constraint_Error using the 'Identity " & + "attribute - 1"); + end; + + Report.Failed("Constraint_Error not reraised in Inner_Block"); + + exception + when Block_Excpt : Constraint_Error => -- Expected exception. + TC_Check_Points(4) := True; + + -- Reraise the exception in a scope where the exception + -- was not originally raised. + + Ada.Exceptions.Reraise_Occurrence(X => Block_Excpt); + Report.Failed("Predefined exception not raised from " & + "within the exception handler - 2"); + + when others => + Report.Failed("Incorrect result from attempt to raise " & + "Constraint_Error using the 'Identity " & + "attribute - 2"); + end Inner_Block; + + Report.Failed("Exception not propagated from Inner_Block"); + + exception + when Constraint_Error => -- Expected exception. + TC_Check_Points(5) := True; + when others => + Report.Failed("Unexpected exception handled after second " & + "reraise of Constraint_Error"); + end Predefined_Exception_Block; + + + -- Verify the processing path taken through the test. + + for i in 1..Check_Points loop + if not TC_Check_Points(i) then + Report.Failed("Incorrect processing path taken through test, " & + "didn't pass check point #" & Integer'Image(i)); + end if; + end loop; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CB41001; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb41002.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb41002.a new file mode 100644 index 000000000..1b3898154 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb41002.a @@ -0,0 +1,283 @@ +-- CB41002.A +-- +-- 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. +--* +-- +-- OBJECTIVE: +-- Check that the message string input parameter in a call to the +-- Raise_Exception procedure is associated with the raised exception +-- occurrence, and that the message string can be obtained using the +-- Exception_Message function with the associated Exception_Occurrence +-- object. Check that Function Exception_Information is available +-- to provide implementation-defined information about the exception +-- occurrence. +-- +-- TEST DESCRIPTION: +-- This test checks that a message associated with a raised exception +-- is propagated with the exception, and can be retrieved using the +-- Exception_Message function. The exception will be raised using the +-- 'Identity attribute as a parameter to the Raise_Exception procedure, +-- and an associated message string will be provided. The exception +-- will be handled, and the message associated with the occurrence will +-- be compared to the original source message (non-default). +-- +-- The test also includes a simulated logging procedure +-- (Check_Exception_Information) that checks that Exception_Information +-- can be called. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 22 Jun 00 RLB Added a check at Exception_Information can be +-- called. +-- +--! + +with Report; +with Ada.Exceptions; + +procedure CB41002 is +begin + + Report.Test ("CB41002", "Check that the message string input parameter " & + "in a call to the Raise_Exception procedure is " & + "associated with the raised exception " & + "occurrence, and that the message string can " & + "be obtained using the Exception_Message " & + "function with the associated " & + "Exception_Occurrence object. Also check that " & + "the Exception_Information function can be called"); + + Test_Block: + declare + + Number_Of_Exceptions : constant := 3; + + User_Exception_1, + User_Exception_2, + User_Exception_3 : exception; + + type String_Ptr is access String; + + User_Messages : constant array (1..Number_Of_Exceptions) + of String_Ptr := + (new String'("Msg"), + new String'("This message will override the default " & + "message provided by the implementation"), + new String'("The message can be captured by procedure" & -- 200 chars + " Exception_Message. It is designed to b" & + "e exactly 200 characters in length, sinc" & + "e there is a permission concerning the " & + "truncation of a message over 200 chars. ")); + + procedure Check_Exception_Information ( + Occur : in Ada.Exceptions.Exception_Occurrence) is + -- Simulates an error logging routine. + Info : constant String := + Ada.Exceptions.Exception_Information (Occur); + function Is_Substring_of (Target, Search : in String) return Boolean is + -- Returns True if Search is a substring of Target, and False + -- otherwise. + begin + for I in Report.Ident_Int(Target'First) .. + Target'Last - Search'Length + 1 loop + if Target(I .. I+Search'Length-1) = Search then + return True; + end if; + end loop; + return False; + end Is_Substring_of; + begin + -- We can't display Info, as it often contains line breaks + -- (confusing Report), and might look much like the failure of a test + -- with an unhandled exception (thus confusing grading tools). + -- + -- We don't particular care if the implementation advice is followed, + -- but we make these checks to insure that a compiler cannot optimize + -- away Info or the rest of this routine. + if not Is_Substring_of (Info, + Ada.Exceptions.Exception_Name (Occur)) then + Report.Comment ("Exception_Information does not contain " & + "Exception_Name - see 11.4.1(19)"); + elsif not Is_Substring_of (Info, + Ada.Exceptions.Exception_Message (Occur)) then + Report.Comment ("Exception_Information does not contain " & + "Exception_Message - see 11.4.1(19)"); + end if; + end Check_Exception_Information; + + begin + + for i in 1..Number_Of_Exceptions loop + begin + + -- Raise a user-defined exception with a specific message string. + case i is + when 1 => + Ada.Exceptions.Raise_Exception(User_Exception_1'Identity, + User_Messages(i).all); + when 2 => + Ada.Exceptions.Raise_Exception(User_Exception_2'Identity, + User_Messages(i).all); + when 3 => + Ada.Exceptions.Raise_Exception(User_Exception_3'Identity, + User_Messages(i).all); + when others => + Report.Failed("Incorrect result from Case statement"); + end case; + + Report.Failed + ("Exception not raised by procedure Exception_With_Message " & + "for User_Exception #" & Integer'Image(i)); + + exception + when Excptn : others => + + begin + -- The message that is associated with the raising of each + -- exception is captured here using the Exception_Message + -- function. + + if User_Messages(i).all /= + Ada.Exceptions.Exception_Message(Excptn) + then + Report.Failed + ("Message captured from exception is not the " & + "message provided when the exception was raised, " & + "User_Exception #" & Integer'Image(i)); + end if; + + Check_Exception_Information(Excptn); + end; + end; + end loop; + + + + -- Verify that the exception specific message is carried across + -- various boundaries: + + begin + + begin + Ada.Exceptions.Raise_Exception(User_Exception_1'Identity, + User_Messages(1).all); + Report.Failed("User_Exception_1 not raised"); + end; + Report.Failed("User_Exception_1 not propagated"); + exception + when Excptn : User_Exception_1 => + + if User_Messages(1).all /= + Ada.Exceptions.Exception_Message(Excptn) + then + Report.Failed("User_Message_1 not found"); + end if; + Check_Exception_Information(Excptn); + + when others => Report.Failed("Unexpected exception handled - 1"); + end; + + + + begin + + begin + Ada.Exceptions.Raise_Exception(User_Exception_2'Identity, + User_Messages(2).all); + Report.Failed("User_Exception_2 not raised"); + exception + when Exc : User_Exception_2 => + + -- The exception is reraised here; message should propagate + -- with exception occurrence. + + Ada.Exceptions.Reraise_Occurrence(Exc); + when others => Report.Failed("User_Exception_2 not handled"); + end; + Report.Failed("User_Exception_2 not propagated"); + exception + when Excptn : User_Exception_2 => + + if User_Messages(2).all /= + Ada.Exceptions.Exception_Message(Excptn) + then + Report.Failed("User_Message_2 not found"); + end if; + Check_Exception_Information(Excptn); + + when others => Report.Failed("Unexpected exception handled - 2"); + end; + + + -- Check exception and message propagation across task boundaries. + + declare + + task Raise_An_Exception is -- single task + entry Raise_It; + end Raise_An_Exception; + + task body Raise_An_Exception is + begin + accept Raise_It do + Ada.Exceptions.Raise_Exception(User_Exception_3'Identity, + User_Messages(3).all); + end Raise_It; + Report.Failed("User_Exception_3 not raised"); + exception + when Excptn : User_Exception_3 => + if User_Messages(3).all /= + Ada.Exceptions.Exception_Message(Excptn) + then + Report.Failed + ("User_Message_3 not returned inside task body"); + end if; + Check_Exception_Information(Excptn); + when others => + Report.Failed("Incorrect exception raised in task body"); + end Raise_An_Exception; + + begin + Raise_An_Exception.Raise_It; -- Exception will be propagated here. + Report.Failed("User_Exception_3 not propagated to caller"); + exception + when Excptn : User_Exception_3 => + if User_Messages(3).all /= + Ada.Exceptions.Exception_Message(Excptn) + then + Report.Failed("User_Message_3 not returned to caller of task"); + end if; + Check_Exception_Information(Excptn); + when others => + Report.Failed("Incorrect exception raised by task"); + end; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CB41002; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb41003.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb41003.a new file mode 100644 index 000000000..aee0b094c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb41003.a @@ -0,0 +1,358 @@ +-- CB41003.A +-- +-- 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. +--* +-- +-- OBJECTIVE: +-- Check that an exception occurrence can be saved into an object of +-- type Exception_Occurrence using the procedure Save_Occurrence. +-- Check that a saved exception occurrence can be used to reraise +-- another occurrence of the same exception using the procedure +-- Reraise_Occurrence. Check that the function Save_Occurrence will +-- allocate a new object of type Exception_Occurrence_Access, and saves +-- the source exception to the new object which is returned as the +-- function result. +-- +-- TEST DESCRIPTION: +-- This test verifies that an occurrence of an exception can be saved, +-- using either of two overloaded versions of Save_Occurrence. The +-- procedure version of Save_Occurrence is used to save an occurrence +-- of a user defined exception into an object of type +-- Exception_Occurrence. This object is then used as an input +-- parameter to procedure Reraise_Occurrence, the expected exception is +-- handled, and the exception id of the handled exception is compared +-- to the id of the originally raised exception. +-- The function version of Save_Occurrence returns a result of +-- Exception_Occurrence_Access, and is used to store the value of another +-- occurrence of the user defined exception. The resulting access value +-- is dereferenced and used as an input to Reraise_Occurrence. The +-- resulting exception is handled, and the exception id of the handled +-- exception is compared to the id of the originally raised exception. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +with Ada.Exceptions; + +procedure CB41003 is + +begin + + Report.Test ("CB41003", "Check that an exception occurrence can " & + "be saved into an object of type " & + "Exception_Occurrence using the procedure " & + "Save_Occurrence"); + + Test_Block: + declare + + use Ada.Exceptions; + + User_Exception_1, + User_Exception_2 : Exception; + + Saved_Occurrence : Exception_Occurrence; + Occurrence_Ptr : Exception_Occurrence_Access; + + User_Message : constant String := -- 200 character string. + "The string returned by Exception_Message may be tr" & + "uncated (to no less then 200 characters) by the Sa" & + "ve_Occurrence procedure (not the function), the Re" & + "raise_Occurrence proc, and the re-raise statement."; + + begin + + Raise_And_Save_Block_1 : + begin + + -- This nested exception structure is designed to ensure that the + -- appropriate exception occurrence is saved using the + -- Save_Occurrence procedure. + + raise Program_Error; + Report.Failed("Program_Error not raised"); + + exception + when Program_Error => + + begin + -- Use the procedure Raise_Exception, along with the 'Identity + -- attribute to raise the first user defined exception. Note + -- that a 200 character message is included in the call. + + Raise_Exception(User_Exception_1'Identity, User_Message); + Report.Failed("User_Exception_1 not raised"); + + exception + when Exc : User_Exception_1 => + + -- This exception occurrence is saved into a variable using + -- procedure Save_Occurrence. This saved occurrence should + -- not be confused with the raised occurrence of + -- Program_Error above. + + Save_Occurrence(Target => Saved_Occurrence, Source => Exc); + + when others => + Report.Failed("Unexpected exception handled, expecting " & + "User_Exception_1"); + end; + + when others => + Report.Failed("Incorrect exception generated by raise statement"); + + end Raise_And_Save_Block_1; + + + Reraise_And_Handle_Saved_Exception_1 : + begin + -- Reraise the exception that was saved in the previous block. + + Reraise_Occurrence(X => Saved_Occurrence); + + exception + when Exc : User_Exception_1 => -- Expected exception. + -- Check the exception id of the handled id by using the + -- Exception_Identity function, and compare with the id of the + -- originally raised exception. + + if User_Exception_1'Identity /= Exception_Identity(Exc) then + Report.Failed("Exception_Ids do not match - 1"); + end if; + + -- Check that the message associated with this exception occurrence + -- has not been truncated (it was originally 200 characters). + + if User_Message /= Exception_Message(Exc) then + Report.Failed("Exception messages do not match - 1"); + end if; + + when others => + Report.Failed + ("Incorrect exception raised by Reraise_Occurrence - 1"); + end Reraise_And_Handle_Saved_Exception_1; + + + Raise_And_Save_Block_2 : + begin + + Raise_Exception(User_Exception_2'Identity, User_Message); + Report.Failed("User_Exception_2 not raised"); + + exception + when Exc : User_Exception_2 => + + -- This exception occurrence is saved into an access object + -- using function Save_Occurrence. + + Occurrence_Ptr := Save_Occurrence(Source => Exc); + + when others => + Report.Failed("Unexpected exception handled, expecting " & + "User_Exception_2"); + end Raise_And_Save_Block_2; + + + Reraise_And_Handle_Saved_Exception_2 : + begin + -- Reraise the exception that was saved in the previous block. + -- Dereference the access object for use as input parameter. + + Reraise_Occurrence(X => Occurrence_Ptr.all); + + exception + when Exc : User_Exception_2 => -- Expected exception. + -- Check the exception id of the handled id by using the + -- Exception_Identity function, and compare with the id of the + -- originally raised exception. + + if User_Exception_2'Identity /= Exception_Identity(Exc) then + Report.Failed("Exception_Ids do not match - 2"); + end if; + + -- Check that the message associated with this exception occurrence + -- has not been truncated (it was originally 200 characters). + + if User_Message /= Exception_Message(Exc) then + Report.Failed("Exception messages do not match - 2"); + end if; + + when others => + Report.Failed + ("Incorrect exception raised by Reraise_Occurrence - 2"); + end Reraise_And_Handle_Saved_Exception_2; + + + -- Another example of the use of saving an exception occurrence + -- is demonstrated in the following block, where the ability to + -- save an occurrence into a data structure, for later processing, + -- is modeled. + + Store_And_Handle_Block: + declare + + Exc_Number : constant := 3; + Exception_1, + Exception_2, + Exception_3 : exception; + + Exception_Storage : array (1..Exc_Number) of Exception_Occurrence; + Messages : array (1..Exc_Number) of String(1..9) := + ("Message 1", "Message 2", "Message 3"); + + begin + + Outer_Block: + begin + + Inner_Block: + begin + + for i in 1..Exc_Number loop + begin + + begin + -- Exceptions all raised in a deep scope. + if i = 1 then + Raise_Exception(Exception_1'Identity, Messages(i)); + elsif i = 2 then + Raise_Exception(Exception_2'Identity, Messages(i)); + elsif i = 3 then + Raise_Exception(Exception_3'Identity, Messages(i)); + end if; + Report.Failed("Exception not raised on loop #" & + Integer'Image(i)); + end; + Report.Failed("Exception not propagated on loop #" & + Integer'Image(i)); + exception + when Exc : others => + + -- Save each occurrence into a storage array for + -- later processing. + + Save_Occurrence(Exception_Storage(i), Exc); + end; + end loop; + + end Inner_Block; + end Outer_Block; + + -- Raise the exceptions from the stored occurrences, and handle. + + for i in 1..Exc_Number loop + begin + Reraise_Occurrence(Exception_Storage(i)); + Report.Failed("No exception reraised for " & + "exception #" & Integer'Image(i)); + exception + when Exc : others => + -- The following sequence of checks ensures that the + -- correct occurrence was stored, and the associated + -- exception was raised and handled in the proper order. + if i = 1 then + if Exception_1'Identity /= Exception_Identity(Exc) then + Report.Failed("Exception_1 not raised"); + end if; + elsif i = 2 then + if Exception_2'Identity /= Exception_Identity(Exc) then + Report.Failed("Exception_2 not raised"); + end if; + elsif i = 3 then + if Exception_3'Identity /= Exception_Identity(Exc) then + Report.Failed("Exception_3 not raised"); + end if; + end if; + + if Exception_Message(Exc) /= Messages(i) then + Report.Failed("Incorrect message associated with " & + "exception #" & Integer'Image(i)); + end if; + end; + end loop; + exception + when others => + Report.Failed("Unexpected exception in Store_And_Handle_Block"); + end Store_And_Handle_Block; + + + Reraise_Out_Of_Scope: + declare + + TC_Value : constant := 5; + The_Exception : exception; + Saved_Exc_Occ : Exception_Occurrence; + + procedure Handle_It (Exc_Occ : in Exception_Occurrence) is + Must_Be_Raised : exception; + begin + if Exception_Identity(Exc_Occ) = The_Exception'Identity then + raise Must_Be_Raised; + Report.Failed("Exception Must_Be_Raised was not raised"); + else + Report.Failed("Incorrect exception handled in " & + "Procedure Handle_It"); + end if; + end Handle_It; + + begin + + if Report.Ident_Int(5) = TC_Value then + raise The_Exception; + end if; + + exception + when Exc : others => + Save_Occurrence (Saved_Exc_Occ, Exc); + begin + Handle_It(Saved_Exc_Occ); -- Raise another exception, in a + exception -- different scope. + when others => -- Handle this new exception. + begin + Reraise_Occurrence (Saved_Exc_Occ); -- Reraise the + -- original excptn. + Report.Failed("Saved Exception was not raised"); + exception + when Exc_2 : others => + if Exception_Identity (Exc_2) /= + The_Exception'Identity + then + Report.Failed + ("Incorrect exception occurrence reraised"); + end if; + end; + end; + end Reraise_Out_Of_Scope; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CB41003; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb41004.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb41004.a new file mode 100644 index 000000000..5a7b70494 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb41004.a @@ -0,0 +1,299 @@ +-- CB41004.A +-- +-- 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. +--* +-- +-- OBJECTIVE: +-- Check that Raise_Exception and Reraise_Occurrence have no effect in +-- the case of Null_Id or Null_Occurrence. Check that Exception_Message, +-- Exception_Identity, Exception_Name, and Exception_Information raise +-- Constraint_Error for a Null_Occurrence input parameter. +-- Check that calling the Save_Occurrence subprograms with the +-- Null_Occurrence input parameter saves the Null_Occurrence to the +-- appropriate target object, and does not raise Constraint_Error. +-- Check that Null_Id is the default initial value of type Exception_Id. +-- +-- TEST DESCRIPTION: +-- This test performs a series of calls to many of the subprograms +-- defined in package Ada.Exceptions, using either Null_Id or +-- Null_Occurrence (based on their parameter profile). In the cases of +-- Raise_Exception and Reraise_Occurrence, these null input values +-- should result in no exceptions being raised, and Constraint_Error +-- should not be raised in response to these calls. Test failure will +-- result if any exception is raised in these cases. +-- For the Save_Occurrence subprograms, calling them with the +-- Null_Occurrence input parameter does not raise Constraint_Error, but +-- simply results in the Null_Occurrence being saved into the appropriate +-- target (either a Exception_Occurrence out parameter, or as an +-- Exception_Occurrence_Access value). +-- In the cases of the other mentioned subprograms, calls performed with +-- a Null_Occurrence input parameter must result in Constraint_Error +-- being raised. This exception will be handled, with test failure the +-- result if the exception is not raised. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 08 Dec 00 RLB Removed Exception_Identity subtest, pending +-- resolution of AI95-00241. +-- Notes for future: Replace Exception_Identity +-- subtest with whatever the resolution is. +-- Add a subtest for Exception_Name(Null_Id), which +-- is missing from this test. +--! + +with Report; +with Ada.Exceptions; + +procedure CB41004 is +begin + + Report.Test ("CB41004", "Check that Null_Id and Null_Occurrence input " & + "parameters have the appropriate effect when " & + "used in calls of the subprograms found in " & + "package Ada.Exceptions"); + + Test_Block: + declare + + use Ada.Exceptions; + + -- No initial values given for these two declarations; they default + -- to Null_Id and Null_Occurrence respectively. + A_Null_Exception_Id : Ada.Exceptions.Exception_Id; + A_Null_Exception_Occurrence : Ada.Exceptions.Exception_Occurrence; + + TC_Flag : Boolean := False; + + begin + + -- Verify that Null_Id is the default initial value of type + -- Exception_Id. + + if not (A_Null_Exception_Id = Ada.Exceptions.Null_Id) then + Report.Failed("The default initial value of an object of type " & + "Exception_Id was not Null_Id"); + end if; + + + -- Verify that Reraise_Occurrence has no effect in the case of + -- Null_Occurrence. + begin + Ada.Exceptions.Reraise_Occurrence(A_Null_Exception_Occurrence); + TC_Flag := True; + exception + when others => + Report.Failed + ("Exception raised by procedure Reraise_Occurrence " & + "when called with a Null_Occurrence input parameter"); + end; + + if not TC_Flag then + Report.Failed("Incorrect processing following the call to " & + "Reraise_Occurrence with a Null_Occurrence " & + "input parameter"); + end if; + + + -- Verify that function Exception_Message raises Constraint_Error for + -- a Null_Occurrence input parameter. + begin + declare + Msg : constant String := + Ada.Exceptions.Exception_Message(A_Null_Exception_Occurrence); + begin + Report.Failed + ("Constraint_Error not raised by Function Exception_Message " & + "when called with a Null_Occurrence input parameter"); + end; + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Unexpected exception raised by Function Exception_Message " & + "when called with a Null_Occurrence input parameter"); + end; + + +-- -- Verify that function Exception_Identity raises Constraint_Error for +-- -- a Null_Occurrence input parameter. +-- -- Note: (RLB, 2000/12/08) This behavior may be modified by AI-00241. +-- -- As such, this test case has been removed pending a resolution. +-- begin +-- declare +-- Id : Ada.Exceptions.Exception_Id := +-- Ada.Exceptions.Exception_Identity(A_Null_Exception_Occurrence); +-- begin +-- Report.Failed +-- ("Constraint_Error not raised by Function Exception_Identity " & +-- "when called with a Null_Occurrence input parameter"); +-- end; +-- exception +-- when Constraint_Error => null; -- OK, expected exception. +-- when others => +-- Report.Failed +-- ("Unexpected exception raised by Function Exception_Identity " & +-- "when called with a Null_Occurrence input parameter"); +-- end; + + + -- Verify that function Exception_Name raises Constraint_Error for + -- a Null_Occurrence input parameter. + begin + declare + Name : constant String := + Ada.Exceptions.Exception_Name(A_Null_Exception_Occurrence); + begin + Report.Failed + ("Constraint_Error not raised by Function Exception_Name " & + "when called with a Null_Occurrence input parameter"); + end; + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Unexpected exception raised by Function Exception_Null " & + "when called with a Null_Occurrence input parameter"); + end; + + + -- Verify that function Exception_Information raises Constraint_Error + -- for a Null_Occurrence input parameter. + begin + declare + Info : constant String := + Ada.Exceptions.Exception_Information + (A_Null_Exception_Occurrence); + begin + Report.Failed + ("Constraint_Error not raised by Function " & + "Exception_Information when called with a " & + "Null_Occurrence input parameter"); + end; + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Unexpected exception raised by Function Exception_Null " & + "when called with a Null_Occurrence input parameter"); + end; + + + -- Verify that calling the Save_Occurrence procedure with a + -- Null_Occurrence input parameter saves the Null_Occurrence to the + -- target object, and does not raise Constraint_Error. + declare + use Ada.Exceptions; + Saved_Occurrence : Exception_Occurrence; + begin + + -- Initialize the Saved_Occurrence variable with a value other than + -- Null_Occurrence (default). + begin + raise Program_Error; + exception + when Exc : others => Save_Occurrence(Saved_Occurrence, Exc); + end; + + -- Save a Null_Occurrence input parameter. + begin + Save_Occurrence(Target => Saved_Occurrence, + Source => Ada.Exceptions.Null_Occurrence); + exception + when others => + Report.Failed + ("Unexpected exception raised by procedure " & + "Save_Occurrence when called with a Null_Occurrence " & + "input parameter"); + end; + + -- Verify that the occurrence that was saved above is a + -- Null_Occurrence value. + + begin + Reraise_Occurrence(Saved_Occurrence); + exception + when others => + Report.Failed("Value saved from Procedure Save_Occurrence " & + "resulted in an exception, i.e., was not a " & + "value of Null_Occurrence"); + end; + + exception + when others => + Report.Failed("Unexpected exception raised during evaluation " & + "of Procedure Save_Occurrence"); + end; + + + -- Verify that calling the Save_Occurrence function with a + -- Null_Occurrence input parameter returns the Null_Occurrence as the + -- function result, and does not raise Constraint_Error. + declare + Occurrence_Ptr : Ada.Exceptions.Exception_Occurrence_Access; + begin + -- Save a Null_Occurrence input parameter. + begin + Occurrence_Ptr := + Ada.Exceptions.Save_Occurrence(Ada.Exceptions.Null_Occurrence); + exception + when others => + Report.Failed + ("Unexpected exception raised by function " & + "Save_Occurrence when called with a Null_Occurrence " & + "input parameter"); + end; + + -- Verify that the occurrence that was saved above is a + -- Null_Occurrence value. + + begin + -- Dereferenced value of type Exception_Occurrence_Access + -- should be a Null_Occurrence value, based on the action + -- of Function Save_Occurrence above. Providing this as an + -- input parameter to Reraise_Exception should not result in + -- any exception being raised. + + Ada.Exceptions.Reraise_Occurrence(Occurrence_Ptr.all); + + exception + when others => + Report.Failed("Value saved from Function Save_Occurrence " & + "resulted in an exception, i.e., was not a " & + "value of Null_Occurrence"); + end; + exception + when others => + Report.Failed("Unexpected exception raised during evaluation " & + "of Function Save_Occurrence"); + end; + + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CB41004; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb5001a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb5001a.ada new file mode 100644 index 000000000..5cf563fdc --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb5001a.ada @@ -0,0 +1,87 @@ +-- CB5001A.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 AN EXCEPTION RAISED IN A RENDEVOUS IS PROPAGATED BOTH TO +-- THE CALLER AND TO THE CALLED TASK. + +-- THIS VERSION CHECKS THAT THE EXCEPTION IS PROPAGATED THROUGH ONE +-- LEVEL OF RENDEVOUS. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- JEAN-PIERRE ROSEN 09 MARCH 1984 +-- JBG 6/1/84 +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE CB5001A IS + +BEGIN + + TEST("CB5001A", "CHECK THAT AN EXCEPTION IN A RENDEVOUS IS " & + "PROPAGATED TO CALLER AND CALLED TASKS -- ONE " & + "LEVEL"); + + DECLARE + TASK T2 IS + ENTRY E2; + END T2; + + TASK BODY T2 IS + MY_EXCEPTION: EXCEPTION; + BEGIN + ACCEPT E2 DO + IF EQUAL (1,1) THEN + RAISE MY_EXCEPTION; + END IF; + END E2; + FAILED ("T2: EXCEPTION NOT RAISED"); + EXCEPTION + WHEN MY_EXCEPTION => + NULL; + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED IN T2"); + WHEN OTHERS => + FAILED ("T2 RECEIVED ABNORMAL EXCEPTION"); + END T2; + + BEGIN + T2.E2; + FAILED ("MAIN: EXCEPTION NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR | PROGRAM_ERROR | STORAGE_ERROR => + FAILED ("PREDEFINED ERROR RAISED IN MAIN"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED IN MAIN"); + WHEN OTHERS => + NULL; + END; + + RESULT; + +END CB5001A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb5001b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb5001b.ada new file mode 100644 index 000000000..35dff52f7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb5001b.ada @@ -0,0 +1,106 @@ +-- CB5001B.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 AN EXCEPTION RAISED IN A RENDEVOUS IS PROPAGATED BOTH TO +-- THE CALLER AND TO THE CALLED TASK. + +-- THIS VERSION CHECKS THAT THE EXCEPTION IS PROPAGATED THROUGH TWO +-- LEVELS OF RENDEVOUS. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- JEAN-PIERRE ROSEN 09 MARCH 1984 +-- JBG 6/1/84 +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE CB5001B IS + +BEGIN + + TEST("CB5001B", "CHECK THAT AN EXCEPTION IN A RENDEVOUS IS " & + "PROPAGATED TO CALLER AND CALLED TASKS -- TWO " & + "LEVELS"); + + DECLARE + TASK T1 IS + ENTRY E1; + END T1; + + TASK T2 IS + ENTRY E2; + END T2; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 DO + T2.E2; + END E1; + FAILED ("T1: EXCEPTION NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR | PROGRAM_ERROR => + FAILED ("PREDEFINED EXCEPTION RAISED IN T1"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED IN T1"); + WHEN OTHERS => + NULL; + END T1; + + TASK BODY T2 IS + MY_EXCEPTION: EXCEPTION; + BEGIN + ACCEPT E2 DO + IF EQUAL (1,1) THEN + RAISE MY_EXCEPTION; + END IF; + END E2; + FAILED ("T2: EXCEPTION NOT RAISED"); + EXCEPTION + WHEN MY_EXCEPTION => + NULL; + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED IN T2"); + WHEN OTHERS => + FAILED ("T2 RECEIVED ABNORMAL EXCEPTION"); + END T2; + + BEGIN + T1.E1; + FAILED ("MAIN: EXCEPTION NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR | PROGRAM_ERROR => + FAILED ("PREDEFINED ERROR RAISED IN MAIN"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED IN MAIN"); + WHEN OTHERS => + NULL; + END; + + RESULT; + +END CB5001B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb5002a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb5002a.ada new file mode 100644 index 000000000..f4484bcc4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb5002a.ada @@ -0,0 +1,168 @@ +-- CB5002A.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. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN "TASKING_ERROR" IS RAISED EXPLICITLY OR BY +-- PROPAGATION WITHIN AN ACCEPT STATEMENT, THEN "TASKING_ERROR" +-- IS RAISED IN BOTH THE CALLING AND THE CALLED TASK. + +-- HISTORY: +-- DHH 03/31/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE CB5002A IS + +BEGIN + TEST("CB5002A", "CHECK THAT WHEN ""TASKING_ERROR"" IS RAISED " & + "EXPLICITLY OR BY PROPAGATION WITHIN AN ACCEPT " & + "STATEMENT, THEN ""TASKING_ERROR"" IS RAISED " & + "IN BOTH THE CALLING AND THE CALLED TASK"); + + DECLARE + TASK CALLING_EXP IS + ENTRY A; + END CALLING_EXP; + + TASK CALLED_EXP IS + ENTRY B; + ENTRY STOP; + END CALLED_EXP; + + TASK CALLING_PROP IS + ENTRY C; + END CALLING_PROP; + + TASK CALLED_PROP IS + ENTRY D; + ENTRY STOP; + END CALLED_PROP; + + TASK PROP IS + ENTRY E; + ENTRY STOP; + END PROP; +----------------------------------------------------------------------- + TASK BODY CALLING_EXP IS + BEGIN + ACCEPT A DO + BEGIN + CALLED_EXP.B; + FAILED("EXCEPTION NOT RAISED IN CALLING " & + "TASK - EXPLICIT RAISE"); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED IN " & + "CALLING TASK - EXPLICIT RAISE"); + END; -- EXCEPTION + END A; + END CALLING_EXP; + + TASK BODY CALLED_EXP IS + BEGIN + BEGIN + ACCEPT B DO + RAISE TASKING_ERROR; + FAILED("EXCEPTION NOT RAISED IN CALLED " & + "TASK - EXPLICIT RAISE"); + END B; + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED IN CALLED " & + "TASK - EXPLICIT RAISE"); + END; -- EXCEPTION BLOCK + + ACCEPT STOP; + END CALLED_EXP; + +----------------------------------------------------------------------- + TASK BODY CALLING_PROP IS + BEGIN + ACCEPT C DO + BEGIN + CALLED_PROP.D; + FAILED("EXCEPTION NOT RAISED IN CALLING " & + "TASK - PROPAGATED RAISE"); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED IN " & + "CALLING TASK - PROPAGATED RAISE"); + END; -- EXCEPTION + END C; + END CALLING_PROP; + + TASK BODY CALLED_PROP IS + BEGIN + BEGIN + ACCEPT D DO + PROP.E; + FAILED("EXCEPTION NOT RAISED IN CALLED " & + "TASK - PROPAGATED RAISE"); + END D; + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED IN CALLED " & + "TASK - PROPAGATED RAISE"); + END; -- EXCEPTION BLOCK; + + ACCEPT STOP; + END CALLED_PROP; + + TASK BODY PROP IS + BEGIN + BEGIN + ACCEPT E DO + RAISE TASKING_ERROR; + FAILED("EXCEPTION NOT RAISED IN PROPAGATE " & + "TASK - ACCEPT E"); + END E; + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED IN PROP. TASK"); + END; -- EXCEPTION BLOCK + + ACCEPT STOP; + + END PROP; +----------------------------------------------------------------------- + BEGIN + CALLING_EXP.A; + CALLING_PROP.C; + CALLED_EXP.STOP; + CALLED_PROP.STOP; + PROP.STOP; + + END; -- DECLARE + + RESULT; +END CB5002A; |