OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

Compare Revisions

  • This comparison shows the changes necessary to convert path 
    /openrisc/tags/gnu-src/gcc-4.5.1/gcc-4.5.1-or32-1.0rc1/gcc/testsuite/ada/acats/tests/cb
    from Rev 294 to Rev 338
    ↔ Reverse comparison
  •

Rev 294 → Rev 338

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.