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/c6
    from Rev 294 to Rev 338
    ↔ Reverse comparison
  •

Rev 294 → Rev 338

/c64104j.ada
0,0 → 1,88
-- C64104J.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 CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
 
-- (G) AFTER RETURN, OUT MODE, UNCONSTRAINED FORMAL, STATIC ONE
-- DIMENSIONAL BOUNDS.
 
-- HISTORY:
-- JRK 03/18/81 CREATED ORIGINAL TEST.
-- NL 10/13/81
-- BCB 11/12/87 CHANGED HEADING TO STANDARD FORMAT. ADDED CODE TO
-- ENSURE THAT SUBPROGRAMS ARE ACTUALLY CALLED.
 
WITH REPORT;
PROCEDURE C64104J IS
 
USE REPORT;
 
BEGIN
TEST ("C64104J", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
"APPROPRIATELY FOR ACCESS PARAMETERS");
 
--------------------------------------------------
 
DECLARE
 
TYPE A IS ACCESS STRING;
 
CALLED : BOOLEAN := FALSE;
 
V : A (1..3) := NEW STRING (1..3);
 
PROCEDURE P (X : OUT A) IS
BEGIN
CALLED := TRUE;
X := NEW STRING (2..3);
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE");
END P;
 
BEGIN
 
P (V);
FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("SUBPROGRAM P WAS NOT CALLED");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED");
END;
 
--------------------------------------------------
 
RESULT;
 
END C64104J;
/c64104k.ada
0,0 → 1,95
-- C64104K.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 CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
 
-- (H) AFTER RETURN, OUT MODE, UNCONSTRAINED FORMAL, DYNAMIC
-- RECORD DISCRIMINANT.
 
-- HISTORY:
-- JRK 03/18/81 CREATED ORIGINAL TEST.
-- NL 10/13/81
-- SPS 10/26/82
-- BCB 11/12/87 CHANGED HEADING TO STANDARD FORMAT. ADDED CODE TO
-- ENSURE THAT SUBPROGRAMS ARE ACTUALLY CALLED.
 
WITH REPORT;
PROCEDURE C64104K IS
 
USE REPORT;
 
BEGIN
TEST ("C64104K", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
"APPROPRIATELY FOR ACCESS PARAMETERS");
 
--------------------------------------------------
 
DECLARE
TYPE ARR IS ARRAY (BOOLEAN RANGE <>) OF INTEGER;
TYPE T (B : BOOLEAN := FALSE) IS
RECORD
I : INTEGER;
A : ARR (FALSE..B);
END RECORD;
 
TYPE A IS ACCESS T;
 
CALLED : BOOLEAN := FALSE;
 
V : A (IDENT_BOOL(FALSE)) := NEW T (IDENT_BOOL(FALSE));
 
PROCEDURE P (X : OUT A) IS
BEGIN
CALLED := TRUE;
X := NEW T (TRUE);
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE");
END P;
 
BEGIN
 
P (V);
FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("SUBPROGRAM P WAS NOT CALLED");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED");
END;
 
--------------------------------------------------
 
RESULT;
 
END C64104K;
/c64104l.ada
0,0 → 1,109
-- C64104L.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 CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
 
-- (I) AFTER RETURN, OUT MODE, CONSTRAINED FORMAL, STATIC
-- PRIVATE DISCRIMINANTS.
 
-- JRK 3/18/81
-- NL 10/13/81
-- SPS 10/26/82
 
WITH REPORT;
PROCEDURE C64104L IS
 
USE REPORT;
 
BEGIN
TEST ("C64104L", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
"APPROPRIATELY FOR ACCESS PARAMETERS");
 
--------------------------------------------------
 
DECLARE
 
PACKAGE PKG IS
TYPE E IS (E1, E2, E3);
TYPE T (D : E := E1; B : BOOLEAN := FALSE) IS
PRIVATE;
PRIVATE
TYPE ARR IS ARRAY (E RANGE <>) OF INTEGER;
TYPE T (D : E := E1; B : BOOLEAN := FALSE) IS
RECORD
I : INTEGER;
CASE B IS
WHEN FALSE =>
J : INTEGER;
WHEN TRUE =>
A : ARR (E1 .. D);
END CASE;
END RECORD;
END PKG;
USE PKG;
 
TYPE A IS ACCESS T;
SUBTYPE SA IS A(E2, TRUE);
V : A (E2, FALSE) := NEW T (E2, FALSE);
 
ENTERED : BOOLEAN := FALSE;
 
PROCEDURE P (X : OUT SA ) IS
BEGIN
ENTERED := TRUE;
X := NEW T (E2, TRUE);
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE");
END P;
 
BEGIN
 
P (V);
FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT ENTERED THEN
FAILED ("CONSTRAINT_ERROR RAISED BEFORE " &
"CALL");
END IF;
WHEN OTHERS =>
IF NOT ENTERED THEN
FAILED ("OTHER EXCEPTION RAISED BEFORE CALL");
ELSE FAILED ("WRONG EXCEPTION RAISED AFTER " &
"RETURN");
END IF;
END;
 
------------------------------------------------
 
RESULT;
 
END C64104L;
/c64104m.ada
0,0 → 1,95
-- C64104M.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 CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
 
-- (J) AFTER RETURN, OUT MODE, CONSTRAINED FORMAL, DYNAMIC TWO
-- DIMENSIONAL BOUNDS.
 
-- JRK 3/18/81
-- NL 10/13/81
-- SPS 10/26/82
 
WITH REPORT;
PROCEDURE C64104M IS
 
USE REPORT;
 
BEGIN
TEST ("C64104M", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
"APPROPRIATELY FOR ACCESS PARAMETERS");
 
--------------------------------------------------
 
DECLARE
 
TYPE T IS ARRAY (INTEGER RANGE <>,
CHARACTER RANGE <>
) OF INTEGER;
 
TYPE A IS ACCESS T;
 
V : A (1..10, 'A'..'Z') := NEW T (1..10, 'A'..'Z');
 
ENTERED : BOOLEAN := FALSE;
Y : CONSTANT CHARACTER := IDENT_CHAR('Y');
SUBTYPE SA IS A(1..10, 'A'..Y);
PROCEDURE P (X : OUT SA ) IS
BEGIN
ENTERED := TRUE;
X := NEW T (1..10, 'A'..IDENT_CHAR('Y'));
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE");
END P;
 
BEGIN
 
P (V);
FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT ENTERED THEN
FAILED ("CONSTRAINT_ERROR RAISED BEFORE " &
"CALL");
END IF;
WHEN OTHERS =>
IF NOT ENTERED THEN
FAILED ("OTHER EXCEPTION RAISED BEFORE CALL");
ELSE FAILED ("WRONG EXCEPTION RAISED AFTER " &
"RETURN");
END IF;
END;
 
--------------------------------------------------
 
RESULT;
 
END C64104M;
/c64104n.ada
0,0 → 1,116
-- C64104N.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 CONSTRAINT_ERROR IS RAISED AT THE PLACE OF THE CALL
-- FOR THE CASE OF A PRIVATE TYPE IMPLEMENTED AS A SCALAR TYPE
-- WHERE THE VALUE OF THE FORMAL PARAMETER DOES NOT BELONG TO THE
-- SUBTYPE OF THE ACTUAL PARAMETER.
 
-- HISTORY:
-- DAVID A. TAFFS
-- CPP 07/23/84
-- RDH 04/18/90 REVISED TO CHECK THAT SUBPROGRAM IS ACTUALLY
-- CALLED.
-- THS 09/21/90 REWORDED COMMENT STATING THAT THE TEST DOES NOT
-- ACCEPT THE LITERAL INTERPRETATION OF 6.4.1(9).
 
WITH REPORT; USE REPORT;
PROCEDURE C64104N IS
 
BEGIN
TEST ("C64104N", "CHECK THAT PRIVATE TYPE (SCALAR) RAISES " &
"CONSTRAINT_ERROR WHEN ACTUAL AND FORMAL PARAMETER " &
"BOUNDS DIFFER");
 
DECLARE
 
CALLED : BOOLEAN := FALSE;
 
PACKAGE P IS
TYPE T IS PRIVATE;
DC : CONSTANT T;
 
GENERIC PACKAGE PP IS
END PP;
PRIVATE
TYPE T IS NEW INTEGER;
DC : CONSTANT T := -1;
END P;
 
PROCEDURE Q (X : IN OUT P.T) IS
BEGIN
CALLED := TRUE;
X := P.DC;
IF P. "=" (X, P.DC) THEN
COMMENT("PROCEDURE Q WAS CALLED");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED("EXCEPTION RAISED INSIDE SUBPROGRAM");
END Q;
 
GENERIC
Y : IN OUT P.T;
PACKAGE CALL IS
END CALL;
 
PACKAGE BODY CALL IS
BEGIN
Q (Y);
END CALL;
 
-- NOTE CALL HAS VARIABLE OF A PRIVATE TYPE AS AN OUT PARAMETER.
-- THIS TEST DOES NOT ACCEPT THE LITERAL INTERPRETATION OF 6.4.1(9).
-- REFER TO ADA IMPLEMENTOR'S GUIDE 6.4.1 SEMANTIC RAMIFICATION 19
-- AND AI-00025 FOR CLARIFICATION AS TO WHY THE LITERAL
-- INTERPRETATION IS REJECTED.
 
PACKAGE BODY P IS
Z : T RANGE 0..1 := 0;
PACKAGE BODY PP IS
PACKAGE CALL_Q IS NEW CALL(Z);
END PP;
END P;
 
BEGIN
BEGIN
DECLARE
PACKAGE CALL_Q_NOW IS NEW P.PP; -- EXCEPTION
BEGIN
FAILED ("NO EXCEPTION RAISED");
END;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED("SUBPROGRAM Q WAS NOT CALLED");
END IF;
WHEN OTHERS =>
FAILED("WRONG EXCEPTION RAISED");
END;
 
RESULT;
 
END;
END C64104N;
/c64104o.ada
0,0 → 1,112
-- C64104O.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 CONSTRAINT_ERROR IS RAISED AT THE PLACE OF THE CALL
-- FOR THE CASE OF A PRIVATE TYPE IMPLEMENTED AS AN ACCESS TYPE WHERE
-- THE ACTUAL BOUNDS OR DISCRIMINANTS OF THE DESIGNATED OBJECT DIFFER
-- FROM THOSE OF THE FORMAL.
 
-- HISTORY
-- CPP 7/23/84 CREATED ORIGINAL TEST.
-- DHH 8/31/87 ADDED COMMENT IN PROCEDURE Q SO THAT CODE WILL NOT BE
-- OPTIMIZED OUT OF EXISTENCE.
 
 
WITH REPORT; USE REPORT;
PROCEDURE C64104O IS
 
BEGIN
 
TEST ("C64104O", "CHECK THAT PRIVATE TYPE (ACCESS) RAISES " &
"CONSTRAINT_ERROR WHEN ACTUAL AND FORMAL PARAMETER BOUNDS " &
"DIFFER");
 
DECLARE
 
 
CALLED : BOOLEAN := FALSE;
 
PACKAGE P IS
TYPE T IS PRIVATE;
DC : CONSTANT T;
GENERIC PACKAGE PP IS
END PP;
PRIVATE
TYPE T IS ACCESS STRING;
DC : CONSTANT T := NEW STRING'("AAA");
END P;
 
PROCEDURE Q (X : IN OUT P.T) IS
 
BEGIN
 
CALLED := TRUE;
X := P.DC;
IF P. "=" (X, P.DC) THEN
COMMENT("PROCEDURE Q WAS CALLED");
END IF;
 
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED INSIDE SUBPROGRAM");
END Q;
 
GENERIC
Y : IN OUT P.T;
PACKAGE CALL IS
END CALL;
 
PACKAGE BODY CALL IS
BEGIN
Q(Y);
END CALL;
 
PACKAGE BODY P IS
Z : T(1..5) := NEW STRING'("CCCCC");
PACKAGE BODY PP IS
PACKAGE CALL_Q IS NEW CALL(Z);
END PP;
END P;
 
BEGIN
BEGIN
DECLARE
PACKAGE CALL_Q_NOW IS NEW P.PP;
BEGIN
FAILED ("NO EXCEPTION RAISED");
END;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("SUBPROGRAM Q WAS NOT CALLED");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED");
END;
 
RESULT;
END;
 
END C64104O;
/c62004a.ada
0,0 → 1,64
-- C62004A.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 ALIASING IS PERMITTED FOR PARAMETERS OF COMPOSITE TYPES,
-- E.G., THAT A MATRIX ADDITION PROCEDURE CAN BE CALLED WITH THREE
-- IDENTICAL ARGUMENTS. (NOTE: ALIASING MAY NOT WORK FOR ARGUMENTS
-- TO ALL SUBROUTINES SINCE PARAMETER PASSING IS IMPLEMENTATION
-- DEPENDENT. HOWEVER, THIS TEST IS NOT ERRONEOUS.)
 
-- DAS 1/26/81
 
WITH REPORT;
PROCEDURE C62004A IS
 
USE REPORT;
 
TYPE MATRIX IS ARRAY (1..3,1..3) OF INTEGER;
 
A : MATRIX := ((1,2,3),(4,5,6),(7,8,9));
 
PROCEDURE MAT_ADD (X,Y : IN MATRIX; SUM : OUT MATRIX) IS
BEGIN
FOR I IN 1..3 LOOP
FOR J IN 1..3 LOOP
SUM(I,J) := X(I,J) + Y(I,J);
END LOOP;
END LOOP;
END MAT_ADD;
 
BEGIN
 
TEST ("C62004A", "CHECK THAT ALIASING IS PERMITTED FOR" &
" PARAMETERS OF COMPOSITE TYPES");
 
MAT_ADD (A, A, A);
 
IF (A /= ((2,4,6),(8,10,12),(14,16,18))) THEN
FAILED ("THE RESULT OF THE MATRIX ADDITION IS INCORRECT");
END IF;
 
RESULT;
 
END C62004A;
/c64202a.ada
0,0 → 1,72
-- C64202A.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 DEFAULT EXPRESSIONS OF FORMAL PARAMETERS ARE EVALUATED
-- EACH TIME THEY ARE NEEDED.
 
-- SPS 2/22/84
 
WITH REPORT; USE REPORT;
PROCEDURE C64202A IS
BEGIN
 
TEST ("C64202A", "CHECK THAT THE DEFAULT EXPRESSION IS EVALUATED" &
" EACH TIME IT IS NEEDED");
 
DECLARE
X : INTEGER := 1;
FUNCTION F RETURN INTEGER IS
BEGIN
X := X + 1;
RETURN X;
END F;
 
PROCEDURE P (CALL : POSITIVE; X, Y : INTEGER := F) IS
BEGIN
IF CALL = 1 THEN
IF X = Y OR Y /= 2 THEN
FAILED ("DEFAULT NOT EVALUATED CORRECTLY - 1" &
" X =" & INTEGER'IMAGE(X) & " Y =" &
INTEGER'IMAGE(Y));
END IF;
ELSIF CALL = 2 THEN
IF X = Y OR
NOT ((X = 3 AND Y = 4) OR (X = 4 AND Y = 3)) THEN
FAILED ("DEFAULT NOT EVALUATED CORRECTLY - 2" &
" X =" & INTEGER'IMAGE(X) & " Y =" &
INTEGER'IMAGE(Y));
END IF;
END IF;
END P;
 
BEGIN
COMMENT ("FIRST CALL");
P (1, 3);
COMMENT ("SECOND CALL");
P(2);
END;
 
RESULT;
 
END C64202A;
/c61008a.ada
0,0 → 1,266
-- C61008A.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 CONSTRAINT_ERROR IS NOT RAISED IF THE DEFAULT VALUE
-- FOR A FORMAL PARAMETER DOES NOT SATISFY THE CONSTRAINTS OF THE
-- SUBTYPE_INDICATION WHEN THE DECLARATION IS ELABORATED, ONLY WHEN
-- THE DEFAULT IS USED.
 
-- SUBTESTS ARE:
-- (A) ARRAY PARAMETERS CONSTRAINED WITH NONSTATIC BOUNDS AND
-- INITIALIZED WITH A STATIC AGGREGATE.
-- (B) A SCALAR PARAMETER WITH NON-STATIC RANGE CONSTRAINTS
-- INITIALIZED WITH A STATIC VALUE.
-- (C) A RECORD PARAMETER WHOSE COMPONENTS HAVE NON-STATIC
-- CONSTRAINTS INITIALIZED WITH A STATIC AGGREGATE.
-- (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON SUB-
-- SCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED
-- WITH A STATIC AGGREGATE.
-- (E) A RECORD PARAMETER WITH A NON-STATIC CONSTRAINT
-- INITIALIZED WITH A STATIC AGGREGATE.
 
-- DAS 1/20/81
-- SPS 10/26/82
-- VKG 1/13/83
-- SPS 2/9/83
-- BHS 7/9/84
 
WITH REPORT;
PROCEDURE C61008A IS
 
USE REPORT;
 
BEGIN
 
TEST ("C61008A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " &
"AN INITIALIZATION VALUE DOES NOT SATISFY " &
"CONSTRAINTS ON A FORMAL PARAMETER");
 
--------------------------------------------------
 
DECLARE -- (A)
 
PROCEDURE PA (I1, I2 : INTEGER) IS
 
TYPE A1 IS ARRAY (1..I1,1..I2) OF INTEGER;
 
PROCEDURE PA1 (A : A1 := ((1,0),(0,1))) IS
BEGIN
FAILED ("BODY OF PA1 EXECUTED");
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PA1");
END PA1;
 
BEGIN
PA1;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - PA1");
END PA;
 
BEGIN -- (A)
PA (IDENT_INT(1), IDENT_INT(10));
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN CALL TO PA");
END; -- (A)
 
--------------------------------------------------
 
DECLARE -- (B)
 
PROCEDURE PB (I1, I2 : INTEGER) IS
 
SUBTYPE INT IS INTEGER RANGE I1..I2;
 
PROCEDURE PB1 (I : INT := -1) IS
BEGIN
FAILED ("BODY OF PB1 EXECUTED");
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PB1");
END PB1;
 
BEGIN
PB1;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - PB1");
END PB;
 
BEGIN -- (B)
PB (IDENT_INT(0), IDENT_INT(63));
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN CALL TO PB");
END; -- (B)
 
--------------------------------------------------
 
DECLARE -- (C)
 
PROCEDURE PC (I1, I2 : INTEGER) IS
TYPE AR1 IS ARRAY (1..3) OF INTEGER RANGE I1..I2;
TYPE REC IS
RECORD
I : INTEGER RANGE I1..I2;
A : AR1 ;
END RECORD;
 
PROCEDURE PC1 (R : REC := (-3,(0,2,3))) IS
BEGIN
FAILED ("BODY OF PC1 EXECUTED");
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PC1");
END PC1;
 
BEGIN
PC1;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - PC1");
END PC;
 
BEGIN -- (C)
PC (IDENT_INT(1), IDENT_INT(3));
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN CALL TO PC");
END; -- (C)
 
--------------------------------------------------
 
DECLARE -- (D1)
 
PROCEDURE P1D (I1, I2 : INTEGER) IS
 
TYPE A1 IS ARRAY (1..2,1..2) OF INTEGER RANGE I1..I2;
 
PROCEDURE P1D1 (A : A1 := ((1,-1),(1,2))) IS
BEGIN
FAILED ("BODY OF P1D1 EXECUTED");
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN P1D1");
END P1D1;
 
BEGIN
P1D1;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - P1D1");
END P1D;
 
BEGIN -- (D1)
P1D (IDENT_INT(1), IDENT_INT(2));
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN CALL TO P1D");
END; -- (D1)
 
--------------------------------------------------
 
DECLARE -- (D2)
 
PROCEDURE P2D (I1, I2 : INTEGER) IS
TYPE A1 IS ARRAY (1..2,1..2) OF INTEGER RANGE I1..I2;
 
PROCEDURE P2D1 (A : A1 := (3..4 => (1,2))) IS
BEGIN
FAILED ("BODY OF P2D1 EXECUTED");
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN P2D1");
END P2D1;
 
BEGIN
P2D1;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - P2D1");
END P2D;
 
BEGIN -- (D2)
P2D (IDENT_INT(1), IDENT_INT(2));
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN CALL TO P2D");
END; -- (D2)
 
--------------------------------------------------
 
DECLARE -- (E)
 
PROCEDURE PE (I1, I2 : INTEGER) IS
SUBTYPE INT IS INTEGER RANGE 0..10;
TYPE ARR IS ARRAY (1..3) OF INT;
TYPE REC (I : INT) IS
RECORD
A : ARR;
END RECORD;
 
SUBTYPE REC4 IS REC(I1);
 
PROCEDURE PE1 (R : REC4 := (3,(1,2,3))) IS
BEGIN
FAILED ("BODY OF PE1 EXECUTED");
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PE1");
END PE1;
 
BEGIN
PE1;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - PE1");
END PE;
 
BEGIN -- (E)
PE (IDENT_INT(4), IDENT_INT(10));
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN CALL TO PE");
END; -- (E)
 
--------------------------------------------------
 
RESULT;
 
END C61008A;
/c64105a.ada
0,0 → 1,84
-- C64105A.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 CONSTRAINT_ERROR IS NOT RAISED AT THE TIME OF CALL WHEN
-- THE VALUE OF AN ACTUAL OUT SCALAR PARAMETER DOES NOT SATISFY THE
-- RANGE CONSTRAINTS OF THE FORMAL PARAMETER.
 
-- DAS 1/29/81
-- CPP 8/6/84
 
WITH REPORT;
PROCEDURE C64105A IS
 
USE REPORT;
 
SUBTYPE SUBINT1 IS INTEGER RANGE -10..10;
SUBTYPE SUBINT2 IS INTEGER RANGE -20..20;
 
I10 : SUBINT1 := 10;
I20 : SUBINT2 := 20;
 
PROCEDURE P1 (I : OUT SUBINT1) IS
BEGIN
I := SUBINT1'FIRST;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
END P1;
 
BEGIN
 
TEST ("C64105A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED" &
" AT THE TIME OF CALL WHEN THE VALUE OF AN" &
" ACTUAL OUT SCALAR PARAMETER DOES NOT" &
" SATISFY THE RANGE CONSTRAINTS OF THE FORMAL" &
" PARAMETER");
 
DECLARE
BEGIN
P1 (SUBINT1(I20));
IF I20 /= IDENT_INT(-10) THEN
FAILED ("OUT PARAM DID NOT GET CORRECT VALUE - 1");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED ON CALL TO P1 - 1");
END;
 
DECLARE
BEGIN
I20 := IDENT_INT(20);
P1 (I20);
IF I20 /= IDENT_INT(-10) THEN
FAILED ("OUT PARAM DID NOT GET CORRECT VALUE - 2");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED ON CALL TO P1 - 2");
END;
 
RESULT;
 
END C64105A;
/c64105b.ada
0,0 → 1,184
-- C64105B.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 CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS
-- IN THE FOLLOWING CIRCUMSTANCES:
-- (1) BEFORE THE CALL, WHEN AN IN OR IN OUT ACTUAL ACCESS
-- PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS DIFFERENT
-- FROM THE FORMAL PARAMETER.
-- (2)
-- (3)
-- SUBTESTS ARE:
-- (A) CASE 1, IN MODE, STATIC ONE DIMENSIONAL BOUNDS.
-- (B) CASE 1, IN OUT MODE, DYNAMIC RECORD DISCRIMINANTS.
-- (C) CASE (A), BUT ACTUAL PARAMETER IS A TYPE CONVERSION.
-- (D) CASE (B), BUT ACTUAL PARAMETER IS A TYPE CONVERSION.
 
-- JRK 3/20/81
-- SPS 10/26/82
-- CPP 8/6/84
 
WITH REPORT;
PROCEDURE C64105B IS
 
USE REPORT;
 
BEGIN
TEST ("C64105B", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
"BEFORE THE CALL, WHEN AN IN OR IN OUT ACTUAL ACCESS " &
"PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS DIFFERENT " &
"FROM THE FORMAL PARAMETER" );
 
--------------------------------------------------
 
DECLARE -- (A)
 
TYPE E IS (E1, E2, E3, E4);
TYPE T IS ARRAY (E RANGE <>) OF INTEGER;
 
TYPE A IS ACCESS T;
SUBTYPE SA IS A(E2..E4);
V : A (E1..E2) := NULL;
 
PROCEDURE P (X : SA ) IS
BEGIN
NULL;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE - (A)");
END P;
BEGIN -- (A)
 
P (V);
 
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED - (A)");
END; -- (A)
 
--------------------------------------------------
 
DECLARE -- (B)
TYPE ARR IS ARRAY (CHARACTER RANGE <>) OF INTEGER;
TYPE T (B : BOOLEAN := FALSE; C : CHARACTER := 'A') IS
RECORD
I : INTEGER;
CASE B IS
WHEN FALSE =>
J : INTEGER;
WHEN TRUE =>
A : ARR ('A' .. C);
END CASE;
END RECORD;
 
TYPE A IS ACCESS T;
SUBTYPE SA IS A(TRUE, 'C');
V : A (IDENT_BOOL(FALSE), IDENT_CHAR('B')) := NULL;
 
PROCEDURE P (X : IN OUT SA ) IS
BEGIN
NULL;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE - (B)");
END P;
 
BEGIN -- (B)
 
P (V);
 
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED - (B)");
END; -- (B)
 
--------------------------------------------------
 
DECLARE -- (C)
 
TYPE E IS (E1, E2, E3, E4);
TYPE T IS ARRAY (E RANGE <>) OF INTEGER;
 
TYPE A IS ACCESS T;
SUBTYPE SA IS A(E2..E4);
V : A (E1..E2) := NULL;
 
PROCEDURE P (X : SA ) IS
BEGIN
NULL;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)");
END P;
BEGIN -- (C)
 
P (SA(V));
 
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED - (C)");
END; -- (C)
 
--------------------------------------------------
 
DECLARE -- (D)
TYPE ARR IS ARRAY (CHARACTER RANGE <>) OF INTEGER;
TYPE T (B : BOOLEAN := FALSE; C : CHARACTER := 'A') IS
RECORD
I : INTEGER;
CASE B IS
WHEN FALSE =>
J : INTEGER;
WHEN TRUE =>
A : ARR ('A' .. C);
END CASE;
END RECORD;
 
TYPE A IS ACCESS T;
SUBTYPE SA IS A(TRUE, 'C');
V : A (IDENT_BOOL(FALSE), IDENT_CHAR('B')) := NULL;
 
PROCEDURE P (X : IN OUT SA ) IS
BEGIN
NULL;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)");
END P;
 
BEGIN -- (D)
 
P (SA(V));
 
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED - (D)");
END; -- (D)
 
--------------------------------------------------
 
RESULT;
END C64105B;
/c64105c.ada
0,0 → 1,230
-- C64105C.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 CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS
-- IN THE FOLLOWING CIRCUMSTANCES:
-- (1)
-- (2) AFTER THE CALL, WHEN AN IN OUT OR OUT FORMAL
-- ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS
-- DIFFERENT CONSTRAINTS.
-- (3)
-- SUBTESTS ARE:
-- (C) CASE 2, IN OUT MODE, STATIC PRIVATE DISCRIMINANT.
-- (D) CASE 2, OUT MODE, DYNAMIC TWO DIMENSIONAL BOUNDS.
-- (E) SAME AS (C), WITH TYPE CONVERSION.
-- (F) SAME AS (D), WITH TYPE CONVERSION.
 
-- JRK 3/20/81
-- SPS 10/26/82
-- CPP 8/8/84
 
WITH REPORT;
PROCEDURE C64105C IS
 
USE REPORT;
 
BEGIN
TEST ("C64105C", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
"AFTER THE CALL, WHEN AN IN OUT OR OUT FORMAL " &
"ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS " &
"DIFFERENT CONSTRAINTS" );
 
--------------------------------------------------
 
DECLARE -- (C)
 
PACKAGE PKG IS
TYPE E IS (E1, E2);
TYPE T (D : E := E1) IS PRIVATE;
PRIVATE
TYPE T (D : E := E1) IS
RECORD
I : INTEGER;
CASE D IS
WHEN E1 =>
B : BOOLEAN;
WHEN E2 =>
C : CHARACTER;
END CASE;
END RECORD;
END PKG;
USE PKG;
 
TYPE A IS ACCESS T;
SUBTYPE SA IS A(E2);
V : A (E1) := NULL;
ENTERED : BOOLEAN := FALSE;
 
PROCEDURE P (X : IN OUT SA) IS
BEGIN
ENTERED := TRUE;
X := NULL;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)");
END P;
 
BEGIN -- (C)
 
P (V);
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT ENTERED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL - (C)");
ELSE
FAILED ("EXCEPTION RAISED ON RETURN - (C)");
END IF;
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED - (C)");
END; -- (C)
 
--------------------------------------------------
 
DECLARE -- (D)
 
TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF
INTEGER;
 
TYPE A IS ACCESS T;
SUBTYPE SA IS A ('D'..'F', FALSE..FALSE);
V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'),
IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL;
ENTERED : BOOLEAN := FALSE;
 
PROCEDURE P (X : OUT SA) IS
BEGIN
ENTERED := TRUE;
X := NULL;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)");
END P;
 
BEGIN -- (D)
 
P (V);
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT ENTERED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL - (D)");
ELSE
FAILED ("EXCEPTION RAISED ON RETURN - (D)");
END IF;
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED - (D)");
END; -- (D)
 
--------------------------------------------------
 
DECLARE -- (E)
 
PACKAGE PKG IS
TYPE E IS (E1, E2);
TYPE T (D : E := E1) IS PRIVATE;
PRIVATE
TYPE T (D : E := E1) IS
RECORD
I : INTEGER;
CASE D IS
WHEN E1 =>
B : BOOLEAN;
WHEN E2 =>
C : CHARACTER;
END CASE;
END RECORD;
END PKG;
USE PKG;
 
TYPE A IS ACCESS T;
SUBTYPE SA IS A(E2);
V : A (E1) := NULL;
ENTERED : BOOLEAN := FALSE;
 
PROCEDURE P (X : IN OUT SA) IS
BEGIN
ENTERED := TRUE;
X := NULL;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)");
END P;
 
BEGIN -- (E)
 
P (SA(V));
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT ENTERED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL - (E)");
ELSE
FAILED ("EXCEPTION RAISED ON RETURN - (E)");
END IF;
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED - (E)");
END; -- (E)
 
--------------------------------------------------
 
DECLARE -- (F)
 
TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF
INTEGER;
 
TYPE A IS ACCESS T;
SUBTYPE SA IS A ('D'..'F', FALSE..FALSE);
V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'),
IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL;
ENTERED : BOOLEAN := FALSE;
 
PROCEDURE P (X : OUT SA) IS
BEGIN
ENTERED := TRUE;
X := NULL;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)");
END P;
 
BEGIN -- (D)
 
P (SA(V));
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT ENTERED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL - (F)");
ELSE
FAILED ("EXCEPTION RAISED ON RETURN - (F)");
END IF;
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED - (F)");
END; -- (F)
 
--------------------------------------------------
 
RESULT;
END C64105C;
/c64105d.ada
0,0 → 1,134
-- C64105D.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 CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS
-- IN THE FOLLOWING CIRCUMSTANCES:
-- (1)
-- (2)
-- (3) BEFORE OR AFTER THE CALL, WHEN AN UNCONSTRAINED ACTUAL
-- OUT ACCESS PARAMETER DESIGNATES AN OBJECT (PRIOR TO THE
-- CALL) WITH CONSTRAINTS DIFFERENT FROM THE FORMAL
-- PARAMETER.
-- SUBTESTS ARE:
-- (G) CASE 3, STATIC LIMITED PRIVATE DISCRIMINANT.
-- (H) CASE 3, DYNAMIC ONE DIMENSIONAL BOUNDS.
 
-- JRK 3/20/81
-- SPS 10/26/82
 
WITH REPORT;
PROCEDURE C64105D IS
 
USE REPORT;
 
BEGIN
TEST ("C64105D", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
"BEFORE AND AFTER THE CALL, WHEN AN UNCONSTRAINED ACTUAL " &
"OUT ACCESS PARAMETER DESIGNATES AN OBJECT (PRIOR TO THE " &
"CALL) WITH CONSTRAINTS DIFFERENT FROM THE FORMAL " &
"PARAMETER" );
 
--------------------------------------------------
 
DECLARE -- (G)
 
PACKAGE PKG IS
SUBTYPE INT IS INTEGER RANGE 0..5;
TYPE T (I : INT := 0) IS LIMITED PRIVATE;
PRIVATE
TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
TYPE T (I : INT := 0) IS
RECORD
J : INTEGER;
A : ARR (1..I);
END RECORD;
END PKG;
USE PKG;
 
TYPE A IS ACCESS T;
SUBTYPE SA IS A(3);
V : A := NEW T (2);
CALLED : BOOLEAN := FALSE;
 
PROCEDURE P (X : OUT SA) IS
BEGIN
CALLED := TRUE;
X := NEW T (3);
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE - (G)");
END P;
 
BEGIN -- (G)
P (V);
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL - (G)");
ELSE
FAILED ("EXCEPTION RAISED ON RETURN - (G)");
END IF;
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED - (G)");
END; -- (G)
 
--------------------------------------------------
 
DECLARE -- (H)
 
TYPE A IS ACCESS STRING;
SUBTYPE SA IS A (1..2);
V : A := NEW STRING (IDENT_INT(5) .. IDENT_INT(7));
CALLED : BOOLEAN := FALSE;
 
PROCEDURE P (X : OUT SA) IS
BEGIN
CALLED := TRUE;
X := NEW STRING (IDENT_INT(1) .. IDENT_INT(2));
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE - (H)");
END P;
 
BEGIN -- (H)
 
P (V);
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL - (H)");
ELSE
FAILED ("EXCEPTION RAISED ON RETURN - (H)");
END IF;
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED - (H)");
END; -- (H)
 
--------------------------------------------------
 
RESULT;
END C64105D;
/c64004g.ada
0,0 → 1,102
-- C64004G.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 FOR CALLS TO SUBPROGRAMS HAVING AT LEAST ONE DEFAULT
-- PARAMETER, THE CORRECT ASSOCIATION IS MADE BETWEEN ACTUAL AND
-- FORMAL PARAMETERS.
 
-- DAS 1/27/81
 
 
WITH REPORT;
PROCEDURE C64004G IS
 
USE REPORT;
 
Y1,Y2,Y3 : INTEGER := 0;
O1,O2 : INTEGER := 0;
 
PROCEDURE P (I1: INTEGER; I2: INTEGER := 2; I3: INTEGER := 3;
O1,O2,O3: OUT INTEGER) IS
BEGIN
O1 := I1;
O2 := I2;
O3 := I3;
END P;
 
FUNCTION F (I1: INTEGER := 1; I2: INTEGER) RETURN INTEGER IS
BEGIN
C64004G.O1 := I1;
C64004G.O2 := I2;
RETURN 1;
END F;
 
BEGIN
 
TEST ("C64004G", "CHECK ASSOCIATIONS BETWEEN ACTUAL AND FORMAL" &
" PARAMETERS (HAVING DEFAULT VALUES)");
 
P (I1=>11, I2=>12, I3=>13, O1=>Y1, O2=>Y2, O3=>Y3);
IF (Y1 /= 11) OR (Y2 /= 12) OR (Y3 /= 13) THEN
FAILED ("INCORRECT PARAMETER ASSOCIATION - 1");
END IF;
 
P (I1=>21, O1=>Y1, O2=>Y2, O3=>Y3);
IF (Y1 /= 21) OR (Y2 /= 2) OR (Y3 /= 3) THEN
FAILED ("INCORRECT PARAMETER ASSOCIATION - 2");
END IF;
 
P (O1=>Y1, O3=>Y3, I1=>31, I3=>33, O2=>Y2);
IF (Y1 /= 31) OR (Y2 /= 2) OR (Y3 /= 33) THEN
FAILED ("INCORRECT PARAMETER ASSOCIATION - 3");
END IF;
 
P (41, 42, O1=>Y1, O2=>Y2, O3=>Y3);
IF (Y1 /= 41) OR (Y2 /= 42) OR (Y3 /= 3) THEN
FAILED ("INCORRECT PARANETER ASSOCIATION - 4");
END IF;
 
P (51, O3=>Y3, O1=>Y1, O2=>Y2, I3=>53);
IF (Y1 /= 51) OR (Y2 /= 2) OR (Y3 /= 53) THEN
FAILED ("INCORRECT PARAMETER ASSOCIATION - 5");
END IF;
 
Y1 := F (I1=>61, I2=>62);
IF (O1 /= 61) OR (O2 /= 62) THEN
FAILED ("INCORRECT PARAMETER ASSOCIATION - 6");
END IF;
 
Y2 := F (I2=>72, I1=>71);
IF (O1 /= 71) OR (O2 /= 72) THEN
FAILED ("INCORRECT PARAMETER ASSOCIATION - 7");
END IF;
 
Y3 := F (I2=>82);
IF (O1 /= 1) OR (O2 /= 82) THEN
FAILED ("INCORRECT PARAMETER ASSOCIATION - 8");
END IF;
 
RESULT;
 
END C64004G;
/c64109a.ada
0,0 → 1,128
-- C64109A.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 ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY
-- TO SUBPROGRAMS. SPECIFICALLY,
-- (A) CHECK ALL PARAMETER MODES.
 
-- CPP 8/20/84
 
WITH REPORT; USE REPORT;
PROCEDURE C64109A IS
 
BEGIN
TEST ("C64109A", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
"RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS");
 
--------------------------------------------
 
DECLARE -- (A)
 
TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE(1..IDENT_INT(5));
TYPE RECORD_TYPE IS
RECORD
I : INTEGER;
A : ARRAY_SUBTYPE;
END RECORD;
REC : RECORD_TYPE := (I => 23,
A => (1..3 => IDENT_INT(7), 4..5 => 9));
BOOL : BOOLEAN;
 
PROCEDURE P1 (ARR : ARRAY_TYPE) IS
BEGIN
IF ARR /= (7, 7, 7, 9, 9) THEN
FAILED ("IN PARAMETER NOT PASSED CORRECTLY");
END IF;
 
IF ARR'FIRST /= IDENT_INT(1) OR
ARR'LAST /= IDENT_INT(5) THEN
FAILED ("WRONG BOUNDS FOR IN PARAMETER");
END IF;
END P1;
 
FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
BEGIN
IF ARR /= (7, 7, 7, 9, 9) THEN
FAILED ("IN PARAMETER NOT PASSED CORRECTLY TO FN");
END IF;
IF ARR'FIRST /= IDENT_INT(1) OR
ARR'LAST /= IDENT_INT(5) THEN
FAILED ("WRONG BOUNDS FOR IN PARAMETER FOR FN");
END IF;
 
RETURN TRUE;
END F1;
 
PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS
BEGIN
IF ARR /= (7, 7, 7, 9, 9) THEN
FAILED ("IN OUT PARAMETER NOT PASSED " &
"CORRECTLY");
END IF;
IF ARR'FIRST /= IDENT_INT(1) OR
ARR'LAST /= IDENT_INT(5) THEN
FAILED ("WRONG BOUNDS FOR IN OUT PARAMETER");
END IF;
ARR := (ARR'RANGE => 5);
END P2;
 
PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
BEGIN
IF ARR'FIRST /= IDENT_INT(1) OR
ARR'LAST /= IDENT_INT(5) THEN
FAILED ("WRONG BOUNDS FOR OUT PARAMETER");
END IF;
 
ARR := (ARR'RANGE => 3);
END P3;
 
BEGIN -- (A)
 
P1 (REC.A);
IF REC.A /= (7, 7, 7, 9, 9) THEN
FAILED ("IN PARAM CHANGED BY PROCEDURE");
END IF;
 
BOOL := F1 (REC.A);
IF REC.A /= (7, 7, 7, 9, 9) THEN
FAILED ("IN PARAM CHANGED BY FUNCTION");
END IF;
 
P2 (REC.A);
IF REC.A /= (5, 5, 5, 5, 5) THEN
FAILED ("IN OUT PARAM RETURNED INCORRECTLY");
END IF;
 
P3 (REC.A);
IF REC.A /= (3, 3, 3, 3, 3) THEN
FAILED ("OUT PARAM RETURNED INCORRECTLY");
END IF;
 
END; -- (A)
 
--------------------------------------------
 
RESULT;
END C64109A;
/c64109b.ada
0,0 → 1,155
-- C64109B.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 ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY
-- TO SUBPROGRAMS. SPECIFICALLY,
-- (B) CHECK MULTIDIMENSIONAL ARRAYS.
 
-- CPP 8/20/84
 
WITH REPORT; USE REPORT;
PROCEDURE C64109B IS
 
BEGIN
TEST ("C64109B", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
"RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " &
"MULTIDIMENSIONAL ARRAYS");
 
DECLARE -- (B)
 
TYPE MULTI_TYPE IS ARRAY (POSITIVE RANGE <>,
POSITIVE RANGE <>) OF BOOLEAN;
SUBTYPE MULTI_SUBTYPE IS MULTI_TYPE (1..2, 1..3);
TYPE RECORD_TYPE IS
RECORD
I : BOOLEAN;
A : MULTI_SUBTYPE;
END RECORD;
REC : RECORD_TYPE :=
(I => FALSE,
A => (1..2 => (1..3 => IDENT_BOOL(TRUE))));
BOOL : BOOLEAN;
 
PROCEDURE P1 (ARR : MULTI_TYPE) IS
BEGIN
IF ARR /= (1..2 => (1..3 => TRUE)) THEN
FAILED ("IN PARAM NOT PASSED CORRECTLY");
END IF;
 
IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(2) THEN
FAILED ("FIRST DIM NOT CORRECT - IN PARAMETER");
ELSIF ARR'FIRST(2) /= IDENT_INT(1) OR ARR'LAST(2) /= 3
THEN
FAILED ("2ND DIM NOT CORRECT - IN PARAMETER");
END IF;
END P1;
 
FUNCTION F1 (ARR : MULTI_TYPE) RETURN BOOLEAN IS
BEGIN
IF ARR /= (1..2 => (1..3 => TRUE)) THEN
FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
END IF;
 
IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(2) THEN
FAILED ("FIRST DIM NOT CORRECT - IN PARAMETER FN");
ELSIF ARR'FIRST(2) /= IDENT_INT(1) OR ARR'LAST(2) /= 3
THEN
FAILED ("2ND DIM NOT CORRECT - IN PARAMETER FN");
END IF;
RETURN TRUE;
END F1;
 
PROCEDURE P2 (ARR : IN OUT MULTI_TYPE) IS
BEGIN
IF ARR /= (1..2 => (1..3 => TRUE)) THEN
FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
END IF;
 
IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(2) THEN
FAILED ("FIRST DIM NOT CORRECT - IN OUT PARAMETER");
ELSIF ARR'FIRST(2) /= IDENT_INT(1) OR ARR'LAST(2) /= 3
THEN
FAILED ("2ND DIM NOT CORRECT - IN OUT PARAMETER");
END IF;
ARR := (ARR'RANGE(1) => (ARR'RANGE(2) => FALSE));
END P2;
 
PROCEDURE P3 (ARR : OUT MULTI_TYPE) IS
BEGIN
FOR I IN 1 .. 2 LOOP
FOR J IN 1 .. 3 LOOP
IF (J MOD 2) = 0 THEN
ARR(I, J) := TRUE;
ELSE
ARR(I, J) := FALSE;
END IF;
END LOOP;
END LOOP;
 
IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(2) THEN
FAILED ("FIRST DIM NOT CORRECT - OUT PARAMETER");
ELSIF ARR'FIRST(2) /= IDENT_INT(1) OR ARR'LAST(2) /= 3
THEN
FAILED ("2ND DIM NOT CORRECT - OUT PARAMETER");
END IF;
END P3;
 
BEGIN -- (B)
 
P1 (REC.A);
IF REC.A /= (1..2 => (1..3 => TRUE)) THEN
FAILED ("IN PARAM CHANGED BY PROCEDURE");
END IF;
 
BOOL := F1 (REC.A);
IF REC.A /= (1..2 => (1..3 => TRUE)) THEN
FAILED ("IN PARAM CHANGED BY FUNCTION");
END IF;
 
P2 (REC.A);
IF REC.A /= (1..2 => (1..3 => FALSE)) THEN
FAILED ("IN OUT PARAM CHANGED BY PROCEDURE");
END IF;
 
P3 (REC.A);
FOR I IN 1 .. 2 LOOP
FOR J IN 1 .. 3 LOOP
IF (J MOD 2) = 0 THEN
IF REC.A(I, J) /= TRUE THEN
FAILED ("OUT PARAM RETURNED " &
"INCORRECTLY - (B)");
END IF;
ELSE
IF REC.A(I, J) /= FALSE THEN
FAILED ("OUT PARAM RETURNED " &
"INCORRECTLY - (B)2");
END IF;
END IF;
END LOOP;
END LOOP;
 
END; -- (B)
 
RESULT;
END C64109B;
/c64109c.ada
0,0 → 1,127
-- C64109C.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 ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY
-- TO SUBPROGRAMS. SPECIFICALLY,
-- (C) CHECK RECORDS HAVING A DISCRIMINANT, WITH MORE THAN ONE ARRAY
-- COMPONENT, WHERE THE BOUNDS OF THE ARRAY DEPEND ON THE
-- DISCRIMINANT.
 
-- CPP 8/20/84
 
WITH REPORT; USE REPORT;
PROCEDURE C64109C IS
 
BEGIN
TEST ("C64109C", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
"RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " &
"RECORDS WITH DISCRIMINANTS");
 
DECLARE -- (C)
 
SUBTYPE SUBINT IS INTEGER RANGE 1..6;
TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF INTEGER;
TYPE RECORD_TYPE (BOUND : INTEGER) IS
RECORD
B : BOOLEAN;
A : ARRAY_TYPE (1..BOUND);
AA : ARRAY_TYPE (BOUND..6);
END RECORD;
REC : RECORD_TYPE (BOUND => IDENT_INT(4)) :=
(BOUND => 4,
B => TRUE,
A => (1..IDENT_INT(4) => 6),
AA => (4..6 => 8));
BOOL : BOOLEAN;
 
PROCEDURE P1 (ARR : ARRAY_TYPE) IS
BEGIN
IF ARR /= (6, 6, 6, 6) THEN
FAILED ("IN PARAM NOT PASSED CORRECTLY");
END IF;
 
IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(4) THEN
FAILED ("WRONG BOUNDS - IN PARAMETER");
END IF;
END P1;
 
FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
BEGIN
IF ARR /= (6, 6, 6, 6) THEN
FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
END IF;
 
IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(4) THEN
FAILED ("WRONG BOUNDS - IN PARAMETER FOR FN");
END IF;
RETURN TRUE;
END F1;
 
PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS
BEGIN
IF ARR /= (8, 8, 8) THEN
FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
END IF;
 
IF ARR'FIRST /= 4 OR ARR'LAST /= IDENT_INT(6) THEN
FAILED ("WRONG BOUNDS - IN OUT PARAMETER");
END IF;
 
ARR := (ARR'RANGE => 10);
END P2;
 
PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
BEGIN
IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(4) THEN
FAILED ("WRONG BOUNDS - OUT PARAMETER");
END IF;
ARR := (ARR'RANGE => 4);
END P3;
 
BEGIN -- (C)
 
P1 (REC.A);
IF REC.A /= (6, 6, 6, 6) THEN
FAILED ("IN PARAM CHANGED BY PROCEDURE");
END IF;
 
BOOL := F1 (REC.A);
IF REC.A /= (6, 6, 6, 6) THEN
FAILED ("IN PARAM CHANGED BY FUNCTION");
END IF;
 
P2 (REC.AA);
IF REC.AA /= (10, 10, 10) THEN
FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
END IF;
 
P3 (REC.A);
IF REC.A /= (4, 4, 4, 4) THEN
FAILED ("OUT PARAM NOT RETURNED CORRECTLY");
END IF;
 
END; -- (C)
 
RESULT;
END C64109C;
/c650001.a
0,0 → 1,412
-- C650001.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, for a function result type that is a return-by-reference
-- type, Program_Error is raised if the return expression is a name that
-- denotes an object view whose accessibility level is deeper than that
-- of the master that elaborated the function body.
--
-- Check for cases where the result type is:
-- (a) A tagged limited type.
-- (b) A task type.
-- (c) A protected type.
-- (d) A composite type with a subcomponent of a
-- return-by-reference type (task type).
--
-- TEST DESCRIPTION:
-- The accessibility level of the master that elaborates the body of a
-- return-by-reference function will always be less deep than that of
-- the function (which is itself a master).
--
-- Thus, the return object may not be any of the following, since each
-- has an accessibility level at least as deep as that of the function:
--
-- (1) An object declared local to the function.
-- (2) The result of a local function.
-- (3) A parameter of the function.
--
-- Verify that Program_Error is raised within the return-by-reference
-- function if the return object is any of (1)-(3) above, for various
-- subsets of the return types (a)-(d) above. Include cases where (1)-(3)
-- are operands of parenthesized expressions.
--
-- Verify that no exception is raised if the return object is any of the
-- following:
--
-- (4) An object declared at a less deep level than that of the
-- master that elaborated the function body.
-- (5) The result of a function declared at the same level as the
-- original function (assuming the new function is also legal).
-- (6) A parameter of the master that elaborated the function body.
--
-- For (5), pass the new function as an actual via an access-to-
-- subprogram parameter of the original function. Check for cases where
-- the new function does and does not raise an exception.
--
-- Since the functions to be tested cannot be part of an assignment
-- statement (since they return values of a limited type), pass each
-- function result as an actual parameter to a dummy procedure, e.g.,
--
-- Dummy_Proc ( Function_Call );
--
--
-- CHANGE HISTORY:
-- 03 May 95 SAIC Initial prerelease version.
-- 08 Feb 99 RLB Removed subcase with two errors.
--
--!
 
package C650001_0 is
 
type Tagged_Limited is tagged limited record
C: String (1 .. 10);
end record;
 
task type Task_Type;
 
protected type Protected_Type is
procedure Op;
end Protected_Type;
 
type Task_Array is array (1 .. 10) of Task_Type;
 
type Variant_Record (Toggle: Boolean) is record
case Toggle is
when True =>
T: Task_Type; -- Return-by-reference component.
when False =>
I: Integer; -- Non-return-by-reference component.
end case;
end record;
 
-- Limited type even though variant contains no limited components:
type Non_Task_Variant is new Variant_Record (Toggle => False);
 
end C650001_0;
 
 
--==================================================================--
 
 
package body C650001_0 is
 
task body Task_Type is
begin
null;
end Task_Type;
 
protected body Protected_Type is
procedure Op is
begin
null;
end Op;
end Protected_Type;
 
end C650001_0;
 
 
--==================================================================--
 
 
with C650001_0;
package C650001_1 is
 
type TC_Result_Kind is (OK, P_E, O_E);
 
procedure TC_Display_Results (Actual : in TC_Result_Kind;
Expected: in TC_Result_Kind;
Message : in String);
 
-- Dummy procedures:
 
procedure Check_Tagged (P: C650001_0.Tagged_Limited);
procedure Check_Task (P: C650001_0.Task_Type);
procedure Check_Protected (P: C650001_0.Protected_Type);
procedure Check_Composite (P: C650001_0.Non_Task_Variant);
 
end C650001_1;
 
 
--==================================================================--
 
 
with Report;
package body C650001_1 is
 
procedure TC_Display_Results (Actual : in TC_Result_Kind;
Expected: in TC_Result_Kind;
Message : in String) is
begin
if Actual /= Expected then
case Actual is
when OK =>
Report.Failed ("No exception raised: " & Message);
when P_E =>
Report.Failed ("Program_Error raised: " & Message);
when O_E =>
Report.Failed ("Unexpected exception raised: " & Message);
end case;
end if;
end TC_Display_Results;
 
 
procedure Check_Tagged (P: C650001_0.Tagged_Limited) is
begin
null;
end;
 
procedure Check_Task (P: C650001_0.Task_Type) is
begin
null;
end;
 
procedure Check_Protected (P: C650001_0.Protected_Type) is
begin
null;
end;
 
procedure Check_Composite (P: C650001_0.Non_Task_Variant) is
begin
null;
end;
 
end C650001_1;
 
 
 
--==================================================================--
 
 
with C650001_0;
with C650001_1;
 
with Report;
procedure C650001 is
begin
 
Report.Test ("C650001", "Check that, for a function result type that " &
"is a return-by-reference type, Program_Error is raised " &
"if the return expression is a name that denotes an " &
"object view whose accessibility level is deeper than " &
"that of the master that elaborated the function body");
 
 
 
SUBTEST1:
declare
 
Result: C650001_1.TC_Result_Kind;
PO : C650001_0.Protected_Type;
 
function Return_Prot (P: C650001_0.Protected_Type)
return C650001_0.Protected_Type is
begin
Result := C650001_1.OK;
return P; -- Formal parameter (3).
exception
when Program_Error =>
Result := C650001_1.P_E; -- Expected result.
return PO;
when others =>
Result := C650001_1.O_E;
return PO;
end Return_Prot;
 
begin -- SUBTEST1.
C650001_1.Check_Protected ( Return_Prot(PO) );
C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #1");
exception
when others =>
Report.Failed ("SUBTEST #1: Unexpected exception in outer block");
end SUBTEST1;
 
 
 
SUBTEST2:
declare
 
Result: C650001_1.TC_Result_Kind;
Comp : C650001_0.Non_Task_Variant;
 
function Return_Composite return C650001_0.Non_Task_Variant is
Local: C650001_0.Non_Task_Variant;
begin
Result := C650001_1.OK;
return (Local); -- Parenthesized local object (1).
exception
when Program_Error =>
Result := C650001_1.P_E; -- Expected result.
return Comp;
when others =>
Result := C650001_1.O_E;
return Comp;
end Return_Composite;
 
begin -- SUBTEST2.
C650001_1.Check_Composite ( Return_Composite );
C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #2");
exception
when others =>
Report.Failed ("SUBTEST #2: Unexpected exception in outer block");
end SUBTEST2;
 
 
 
SUBTEST3:
declare
 
Result: C650001_1.TC_Result_Kind;
Tsk : C650001_0.Task_Type;
TskArr: C650001_0.Task_Array;
 
function Return_Task (P: C650001_0.Task_Array)
return C650001_0.Task_Type is
 
function Inner return C650001_0.Task_Type is
begin
return P(P'First); -- OK: should not raise exception (6).
exception
when Program_Error =>
Report.Failed ("SUBTEST #3: Program_Error incorrectly " &
"raised within function Inner");
return Tsk;
when others =>
Report.Failed ("SUBTEST #3: Unexpected exception " &
"raised within function Inner");
return Tsk;
end Inner;
 
begin -- Return_Task.
Result := C650001_1.OK;
return Inner; -- Call to local function (2).
exception
when Program_Error =>
Result := C650001_1.P_E; -- Expected result.
return Tsk;
when others =>
Result := C650001_1.O_E;
return Tsk;
end Return_Task;
 
begin -- SUBTEST3.
C650001_1.Check_Task ( Return_Task(TskArr) );
C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #3");
exception
when others =>
Report.Failed ("SUBTEST #3: Unexpected exception in outer block");
end SUBTEST3;
 
 
 
SUBTEST4:
declare
 
Result: C650001_1.TC_Result_Kind;
TagLim: C650001_0.Tagged_Limited;
 
function Return_TagLim (P: C650001_0.Tagged_Limited'Class)
return C650001_0.Tagged_Limited is
begin
Result := C650001_1.OK;
return C650001_0.Tagged_Limited(P); -- Conversion of formal param (3).
exception
when Program_Error =>
Result := C650001_1.P_E; -- Expected result.
return TagLim;
when others =>
Result := C650001_1.O_E;
return TagLim;
end Return_TagLim;
 
begin -- SUBTEST4.
C650001_1.Check_Tagged ( Return_TagLim(TagLim) );
C650001_1.TC_Display_Results (Result, C650001_1.P_E,
"SUBTEST #4 (root type)");
exception
when others =>
Report.Failed ("SUBTEST #4: Unexpected exception in outer block");
end SUBTEST4;
 
 
 
SUBTEST5:
declare
Tsk : C650001_0.Task_Type;
begin -- SUBTEST5.
 
declare
Result: C650001_1.TC_Result_Kind;
 
type AccToFunc is access function return C650001_0.Task_Type;
 
function Return_Global return C650001_0.Task_Type is
begin
return Tsk; -- OK: should not raise exception (4).
end Return_Global;
 
function Return_Local return C650001_0.Task_Type is
Local : C650001_0.Task_Type;
begin
return Local; -- Propagate Program_Error.
end Return_Local;
 
 
function Return_Func (P: AccToFunc) return C650001_0.Task_Type is
begin
Result := C650001_1.OK;
return P.all; -- Function call (5).
exception
when Program_Error =>
Result := C650001_1.P_E;
return Tsk;
when others =>
Result := C650001_1.O_E;
return Tsk;
end Return_Func;
 
RG : AccToFunc := Return_Global'Access;
RL : AccToFunc := Return_Local'Access;
 
begin
C650001_1.Check_Task ( Return_Func(RG) );
C650001_1.TC_Display_Results (Result, C650001_1.OK,
"SUBTEST #5 (global task)");
 
C650001_1.Check_Task ( Return_Func(RL) );
C650001_1.TC_Display_Results (Result, C650001_1.P_E,
"SUBTEST #5 (local task)");
exception
when others =>
Report.Failed ("SUBTEST #5: Unexpected exception in outer block");
end;
 
end SUBTEST5;
 
 
 
Report.Result;
 
end C650001;
/c64109d.ada
0,0 → 1,128
-- C64109D.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 ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY
-- TO SUBPROGRAMS. SPECIFICALLY,
-- (D) CHECK OBJECTS DESIGNATED BY ACCESS TYPES.
 
-- CPP 8/20/84
 
WITH REPORT; USE REPORT;
PROCEDURE C64109D IS
 
BEGIN
TEST ("C64109D", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
"RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " &
"OBJECTS DESIGNATED BY ACCESS TYPES");
 
DECLARE -- (D)
 
SUBTYPE INDEX IS INTEGER RANGE 1..3;
TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>) OF INTEGER;
SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE(1..IDENT_INT(3));
TYPE NODE_TYPE;
TYPE ACCESS_TYPE IS ACCESS NODE_TYPE;
TYPE NODE_TYPE IS
RECORD
A : ARRAY_SUBTYPE;
NEXT : ACCESS_TYPE;
END RECORD;
PTR : ACCESS_TYPE := NEW NODE_TYPE'
(A => (IDENT_INT(1)..3 => IDENT_INT(5)),
NEXT => NULL);
BOOL : BOOLEAN;
 
PROCEDURE P1 (ARR : ARRAY_TYPE) IS
BEGIN
IF ARR /= (5, 5, 5) THEN
FAILED ("IN PARAM NOT PASSED CORRECTLY");
END IF;
 
IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
FAILED ("WRONG BOUNDS - IN PARAMETER");
END IF;
END P1;
 
FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
BEGIN
IF ARR /= (5, 5, 5) THEN
FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
END IF;
 
IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
FAILED ("WRONG BOUNDS - IN PARAMETER FOR FN");
END IF;
 
RETURN TRUE;
END F1;
 
PROCEDURE P2 (ARR : IN OUT ARRAY_SUBTYPE) IS
BEGIN
IF ARR /= (5, 5, 5) THEN
FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
END IF;
 
IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
FAILED ("WRONG BOUNDS - IN OUT PARAMETER");
END IF;
 
ARR := (OTHERS => 6);
END P2;
 
PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
BEGIN
 
IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
FAILED ("WRONG BOUNDS - OUT PARAMETER");
END IF;
 
ARR := (ARR'RANGE => 7);
END P3;
 
BEGIN -- (D)
 
P1 (PTR.A);
IF PTR.A /= (5, 5, 5) THEN
FAILED ("IN PARAM CHANGED BY PROCEDURE");
END IF;
 
BOOL := F1 (PTR.A);
IF PTR.A /= (5, 5, 5) THEN
FAILED ("IN PARAM CHANGED BY FUNCTION");
END IF;
 
P2 (PTR.A);
IF PTR.A /= (6, 6, 6) THEN
FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
END IF;
 
P3 (PTR.A);
IF PTR.A /= (7, 7, 7) THEN
FAILED ("OUT PARAM NOT RETURNED CORRECTLY");
END IF;
 
END; -- (D)
 
RESULT;
END C64109D;
/c64109e.ada
0,0 → 1,156
-- C64109E.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 ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY
-- TO SUBPROGRAMS. SPECIFICALLY,
-- (E) CHECK THE CASE WHERE THE FORMAL IS UNCONSTRAINED, AND ARRAYS
-- WITH DIFFERENT BOUNDS ARE PASSED AS ACTUALS.
 
-- CPP 8/20/84
 
WITH REPORT; USE REPORT;
PROCEDURE C64109E IS
 
BEGIN
TEST ("C64109E", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
"RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " &
"ARRAYS WITH DIFFERENT BOUNDS PASSED TO UNCONSTRAINED " &
"FORMAL");
 
DECLARE -- (E)
 
SUBTYPE SUBINT IS INTEGER RANGE 0..5;
TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
TYPE RECORD_TYPE IS
RECORD
A : ARRAY_TYPE (IDENT_INT(0)..IDENT_INT(2));
B : ARRAY_TYPE (1..3);
END RECORD;
REC : RECORD_TYPE := (A => (0..2 => IDENT_BOOL(TRUE)),
B => (1..3 => IDENT_BOOL(FALSE)));
BOOL : BOOLEAN;
 
PROCEDURE P1 (ARR : ARRAY_TYPE; ARR2 : ARRAY_TYPE) IS
BEGIN
IF ARR /= (TRUE, TRUE, TRUE) THEN
FAILED ("IN PARAM NOT PASSED CORRECTLY");
END IF;
IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
FAILED ("WRONG IN PARAMETER BOUNDS - 1");
END IF;
IF ARR2 /= (FALSE, FALSE, FALSE) THEN
FAILED ("IN PARAM NOT PASSED CORRECTLY - 2");
END IF;
IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
FAILED ("WRONG IN PARAMETER BOUNDS - 2");
END IF;
END P1;
 
FUNCTION F1 ( ARR : ARRAY_TYPE; ARR2 : ARRAY_TYPE)
RETURN BOOLEAN IS
BEGIN
IF ARR /= (TRUE, TRUE, TRUE) THEN
FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
END IF;
IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
FAILED ("WRONG IN PARAMETER BOUNDS FOR FN - 1");
END IF;
IF ARR2 /= (FALSE, FALSE, FALSE) THEN
FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
END IF;
IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
FAILED ("WRONG IN PARAMETER BOUNDS FOR FN - 2");
END IF;
RETURN TRUE;
END F1;
 
PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE;
ARR2 : IN OUT ARRAY_TYPE) IS
BEGIN
IF ARR /= (TRUE, TRUE, TRUE) THEN
FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
END IF;
IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
FAILED ("WRONG IN OUT PARAMETER BOUNDS - 1");
END IF;
IF ARR2 /= (FALSE, FALSE, FALSE) THEN
FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
END IF;
IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
FAILED ("WRONG IN OUT PARAMETER BOUNDS - 2");
END IF;
ARR := (ARR'RANGE => FALSE);
ARR2 := (ARR2'RANGE => TRUE);
END P2;
 
PROCEDURE P3 (ARR : OUT ARRAY_TYPE; ARR2 : OUT ARRAY_TYPE) IS
BEGIN
IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
FAILED ("WRONG OUT PARAMETER BOUNDS - 1");
END IF;
IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
FAILED ("WRONG OUT PARAMETER BOUNDS - 2");
END IF;
ARR := (ARR'RANGE => FALSE);
ARR2 := (ARR2'RANGE => TRUE);
END P3;
 
BEGIN -- (E)
 
P1 (REC.A, REC.B);
IF REC.A /= (TRUE, TRUE, TRUE) THEN
FAILED ("IN PARAM CHANGED BY PROCEDURE");
END IF;
IF REC.B /= (FALSE, FALSE, FALSE) THEN
FAILED ("IN PARAM CHANGED BY PROCEDURE - 2");
END IF;
 
BOOL := F1 (REC.A, REC.B);
IF REC.A /= (TRUE, TRUE, TRUE) THEN
FAILED ("IN PARAM CHANGED BY FUNCTION");
END IF;
IF REC.B /= (FALSE, FALSE, FALSE) THEN
FAILED ("IN PARAM CHANGED BY FUNCTION - 2");
END IF;
 
P2 (REC.A, REC.B);
IF REC.A /= (FALSE, FALSE, FALSE) THEN
FAILED ("IN OUT PARAM RETURNED INCORRECTLY");
END IF;
IF REC.B /= (TRUE, TRUE, TRUE) THEN
FAILED ("IN OUT PARAM RETURNED INCORRECTLY - 2");
END IF;
 
P3 (REC.A, REC.B);
IF REC.A /= (FALSE, FALSE, FALSE) THEN
FAILED ("OUT PARAM RETURNED INCORRECTLY");
END IF;
IF REC.B /= (TRUE, TRUE, TRUE) THEN
FAILED ("OUT PARAM RETURNED INCORRECTLY - 2");
END IF;
 
END; -- (E)
 
RESULT;
END C64109E;
/c64109f.ada
0,0 → 1,126
-- C64109F.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 ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY
-- TO SUBPROGRAMS. SPECIFICALLY,
-- (F) CHECK THAT A FORMAL PARAMETER CAN BE USED AS AN ACTUAL IN
-- ANOTHER CALL.
 
-- CPP 8/20/84
 
WITH REPORT; USE REPORT;
PROCEDURE C64109F IS
 
BEGIN
TEST ("C64109F", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
"RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " &
"FORMAL AS AN ACTUAL");
 
DECLARE -- (F)
 
TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
SUBTYPE ARRAY_SUBTYPE IS
ARRAY_TYPE (IDENT_INT(1)..IDENT_INT(5));
TYPE RECORD_TYPE IS
RECORD
I : INTEGER;
A : ARRAY_SUBTYPE;
END RECORD;
REC : RECORD_TYPE := (I => 23,
A => (1..3 => 7, 4..5 => 9));
BOOL : BOOLEAN;
 
PROCEDURE P_CALLED (A : IN OUT ARRAY_TYPE) IS
BEGIN
IF A /= (7, 7, 7, 9, 9) THEN
FAILED ("IN OUT PARAM NOT RECEIVED CORRECTLY");
END IF;
IF A'FIRST /= 1 OR A'LAST /= 5 THEN
FAILED ("BOUNDS WRONG - IN OUT");
END IF;
A := (6, 6, 6, 6, 6);
END P_CALLED;
 
PROCEDURE P (A : IN OUT ARRAY_TYPE) IS
BEGIN
P_CALLED (A);
END P;
 
FUNCTION F_CALLED (A : ARRAY_SUBTYPE) RETURN BOOLEAN IS
GOOD : BOOLEAN;
BEGIN
GOOD := (A = (7, 7, 7, 9, 9));
IF NOT GOOD THEN
FAILED ("IN PARAMETER NOT RECEIVED CORRECTLY");
END IF;
IF A'FIRST /= 1 OR A'LAST /= IDENT_INT(5) THEN
FAILED ("BOUNDS WRONG - FUNCTION");
END IF;
RETURN GOOD;
END F_CALLED;
 
FUNCTION F (A : ARRAY_TYPE) RETURN BOOLEAN IS
BEGIN
RETURN (F_CALLED (A));
END F;
 
PROCEDURE P_OUT_CALLED (A : OUT ARRAY_TYPE) IS
BEGIN
IF A'FIRST /= 1 OR A'LAST /= 5 THEN
FAILED ("BOUNDS WRONG - OUT");
END IF;
A := (8, 8, 8, 8, 8);
END P_OUT_CALLED;
 
PROCEDURE P_OUT (A : OUT ARRAY_TYPE) IS
BEGIN
P_OUT_CALLED (A);
A := (9, 9, 9, 9, 9);
END P_OUT;
 
BEGIN -- (F)
 
P (REC.A);
IF REC.A /= (6, 6, 6, 6, 6) THEN
FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
END IF;
 
REC.A := (7, 7, 7, 9, 9);
BOOL := F (REC.A);
IF NOT BOOL THEN
FAILED ("IN PARAM NOT RETURNED CORRECTLY");
END IF;
 
REC.A := (7, 7, 7, 9, 9);
P_OUT (REC.A);
IF REC.A /= (9, 9, 9, 9, 9) THEN
FAILED ("OUT PARAM NOT RETURNED CORRECTLY - 2");
END IF;
 
END; -- (F)
 
--------------------------------------------
 
RESULT;
END C64109F;
/c64109g.ada
0,0 → 1,125
-- C64109G.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 SLICES OF ARRAYS ARE PASSED CORRECTLY TO SUBPROGRAMS.
-- SPECIFICALLY,
-- (A) CHECK ALL PARAMETER MODES.
 
-- CPP 8/28/84
-- PWN 05/31/96 Corrected spelling problem.
 
WITH REPORT; USE REPORT;
PROCEDURE C64109G IS
 
BEGIN
TEST ("C64109G", "CHECK THAT SLICES OF ARRAYS ARE PASSED " &
"CORRECTLY TO SUBPROGRAMS");
 
--------------------------------------------
 
DECLARE -- (A)
 
SUBTYPE SUBINT IS INTEGER RANGE 1..5;
TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF INTEGER;
ARR : ARRAY_TYPE (1..5) := (1..3 => 7, 4..5 => 9);
BOOL : BOOLEAN;
 
PROCEDURE P1 (S : ARRAY_TYPE) IS
BEGIN
IF S(IDENT_INT(3)) /= 7 THEN
FAILED ("IN PARAMETER NOT PASSED CORRECTLY - (A)");
END IF;
IF S(4) /= 9 THEN
FAILED ("IN PARAMETER NOT PASSED CORRECTLY - (A)2");
END IF;
END P1;
 
FUNCTION F1 (S : ARRAY_TYPE) RETURN BOOLEAN IS
BEGIN
IF S(3) /= 7 THEN
FAILED ("IN PARAMETER NOT PASSED CORRECTLY - (A)");
END IF;
IF S(IDENT_INT(4)) /= 9 THEN
FAILED ("IN PARAMETER NOT PASSED CORRECTLY - (A)2");
END IF;
RETURN TRUE;
END F1;
 
PROCEDURE P2 (S : IN OUT ARRAY_TYPE) IS
BEGIN
IF S(3) /= 7 THEN
FAILED ("IN OUT PARAM NOT PASSED CORRECTLY - (A)");
END IF;
IF S(4) /= 9 THEN
FAILED ("IN OUT PARAM NOT PASSED CORRECTLY - (A)2");
END IF;
FOR I IN 3 .. 4 LOOP
S(I) := 5;
END LOOP;
END P2;
 
PROCEDURE P3 (S : OUT ARRAY_TYPE) IS
BEGIN
FOR I IN 3 .. 4 LOOP
S(I) := 3;
END LOOP;
END P3;
 
BEGIN -- (A)
 
P1 (ARR(3..4));
IF ARR(3) /= 7 THEN
FAILED ("IN PARAM CHANGED BY PROCEDURE - (A)");
END IF;
IF ARR(4) /= 9 THEN
FAILED ("IN PARAM CHANGED BY PROCEDURE - (A)2");
END IF;
 
BOOL := F1 (ARR(IDENT_INT(3)..IDENT_INT(4)));
IF ARR(3) /= 7 THEN
FAILED ("IN PARAM CHANGED BY FUNCTION - (A)");
END IF;
IF ARR(4) /= 9 THEN
FAILED ("IN PARAM CHANGED BY FUNCTION - (A)2");
END IF;
 
P2 (ARR(3..4));
FOR I IN 3 .. 4 LOOP
IF ARR(I) /= 5 THEN
FAILED ("IN OUT PARAM RETURNED INCORRECTLY - (A)");
END IF;
END LOOP;
 
P3 (ARR(IDENT_INT(3)..4));
FOR I IN 3 .. 4 LOOP
IF ARR(I) /= 3 THEN
FAILED ("OUT PARAM RETURNED INCORRECTLY - (A)");
END IF;
END LOOP;
 
END;
 
RESULT;
 
END C64109G;
/c64109h.ada
0,0 → 1,160
-- C64109H.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 SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE
-- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY,
-- (A) CHECK ALL PARAMETER MODES.
 
-- HISTORY:
-- TBN 07/11/86 CREATED ORIGINAL TEST.
-- JET 08/04/87 MODIFIED REC.A REFERENCES.
 
WITH REPORT; USE REPORT;
PROCEDURE C64109H IS
 
BEGIN
TEST ("C64109H", "CHECK THAT SLICES OF ARRAYS WHICH ARE " &
"COMPONENTS OF RECORDS ARE PASSED CORRECTLY " &
"TO SUBPROGRAMS");
 
DECLARE -- (A)
 
TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE(1..IDENT_INT(5));
TYPE RECORD_TYPE IS
RECORD
I : INTEGER;
A : ARRAY_SUBTYPE;
END RECORD;
REC : RECORD_TYPE := (I => 23,
A => (1..3 => IDENT_INT(7), 4..5 => 9));
BOOL : BOOLEAN;
 
PROCEDURE P1 (ARR : ARRAY_TYPE) IS
BEGIN
IF ARR /= (7, 9, 9) THEN
FAILED ("IN PARAMETER NOT PASSED CORRECTLY");
END IF;
 
IF ARR'FIRST /= IDENT_INT(3) OR
ARR'LAST /= IDENT_INT(5) THEN
FAILED ("WRONG BOUNDS FOR IN PARAMETER");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
END P1;
 
FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
BEGIN
IF ARR /= (7, 7, 9) THEN
FAILED ("IN PARAMETER NOT PASSED CORRECTLY TO FN");
END IF;
IF ARR'FIRST /= IDENT_INT(2) OR
ARR'LAST /= IDENT_INT(4) THEN
FAILED ("WRONG BOUNDS FOR IN PARAMETER FOR FN");
END IF;
 
RETURN TRUE;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN FUNCTION F1");
END F1;
 
PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS
BEGIN
IF ARR /= (7, 7, 7, 9) THEN
FAILED ("IN OUT PARAMETER NOT PASSED " &
"CORRECTLY");
END IF;
IF ARR'FIRST /= IDENT_INT(1) OR
ARR'LAST /= IDENT_INT(4) THEN
FAILED ("WRONG BOUNDS FOR IN OUT PARAMETER");
END IF;
ARR := (ARR'RANGE => 5);
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P2");
END P2;
 
PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
BEGIN
IF ARR'FIRST /= IDENT_INT(3) OR
ARR'LAST /= IDENT_INT(4) THEN
FAILED ("WRONG BOUNDS FOR OUT PARAMETER");
END IF;
 
ARR := (ARR'RANGE => 3);
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P3");
END P3;
 
BEGIN -- (A)
 
BEGIN -- (B)
P1 (REC.A (3..5));
IF REC.A /= (7, 7, 7, 9, 9) THEN
FAILED ("IN PARAM CHANGED BY PROCEDURE");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF P1");
END; -- (B)
 
BEGIN -- (C)
BOOL := F1 (REC.A (2..4));
IF REC.A /= (7, 7, 7, 9, 9) THEN
FAILED ("IN PARAM CHANGED BY FUNCTION");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF F1");
END; -- (C)
 
BEGIN -- (D)
P2 (REC.A (1..4));
IF REC.A /= (5, 5, 5, 5, 9) THEN
FAILED ("IN OUT PARAM RETURNED INCORRECTLY");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF P2");
END; -- (D)
 
BEGIN -- (E)
P3 (REC.A (3..4));
IF REC.A /= (5, 5, 3, 3, 9) THEN
FAILED ("OUT PARAM RETURNED INCORRECTLY");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF P3");
END; -- (E)
 
END; -- (A)
 
RESULT;
END C64109H;
/c64109i.ada
0,0 → 1,163
-- C64109I.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 SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE
-- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY,
-- (C) CHECK RECORDS HAVING A DISCRIMINANT, WITH MORE THAN ONE ARRAY
-- COMPONENT, WHERE THE BOUNDS OF THE ARRAY DEPEND ON THE
-- DISCRIMINANT.
 
-- HISTORY:
-- TBN 07/10/86 CREATED ORIGINAL TEST.
-- JET 08/04/87 REMOVED PARTIAL ARRAY REFERENCES IN
-- RECORD FIELDS.
 
WITH REPORT; USE REPORT;
PROCEDURE C64109I IS
 
BEGIN
TEST ("C64109I", "CHECK THAT SLICES OF ARRAYS WHICH ARE " &
"COMPONENTS OF RECORDS ARE PASSED CORRECTLY " &
"TO SUBPROGRAMS - RECORDS WITH DISCRIMINANTS");
 
DECLARE -- (C)
 
SUBTYPE SUBINT IS INTEGER RANGE 1..6;
TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF INTEGER;
TYPE RECORD_TYPE (BOUND : INTEGER) IS
RECORD
B : BOOLEAN;
A : ARRAY_TYPE (1..BOUND);
AA : ARRAY_TYPE (BOUND..6);
END RECORD;
REC : RECORD_TYPE (BOUND => IDENT_INT(4)) :=
(BOUND => 4,
B => TRUE,
A => (1..IDENT_INT(4) => 6),
AA => (4..6 => 8));
BOOL : BOOLEAN;
 
PROCEDURE P1 (ARR : ARRAY_TYPE) IS
BEGIN
IF ARR /= (6, 6, 6) THEN
FAILED ("IN PARAM NOT PASSED CORRECTLY");
END IF;
 
IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(3) THEN
FAILED ("WRONG BOUNDS - IN PARAMETER");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
END P1;
 
FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
BEGIN
IF ARR /= (6, 6, 6) THEN
FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
END IF;
 
IF ARR'FIRST /= 2 OR ARR'LAST /= IDENT_INT(4) THEN
FAILED ("WRONG BOUNDS - IN PARAMETER FOR FN");
END IF;
RETURN TRUE;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN FUNCTION F1");
END F1;
 
PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS
BEGIN
IF ARR /= (8, 8) THEN
FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
END IF;
 
IF ARR'FIRST /= 4 OR ARR'LAST /= IDENT_INT(5) THEN
FAILED ("WRONG BOUNDS - IN OUT PARAMETER");
END IF;
 
ARR := (ARR'RANGE => 10);
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P2");
END P2;
 
PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
BEGIN
IF ARR'FIRST /= 2 OR ARR'LAST /= IDENT_INT(3) THEN
FAILED ("WRONG BOUNDS - OUT PARAMETER");
END IF;
ARR := (ARR'RANGE => 4);
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P3");
END P3;
 
BEGIN -- (C)
 
BEGIN -- (D)
P1 (REC.A (1..3));
IF REC.A /= (6, 6, 6, 6) THEN
FAILED ("IN PARAM CHANGED BY PROCEDURE");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF P1");
END; -- (D)
 
BEGIN -- (E)
BOOL := F1 (REC.A (2..4));
IF REC.A /= (6, 6, 6, 6) THEN
FAILED ("IN PARAM CHANGED BY FUNCTION");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF F1");
END; -- (E)
 
BEGIN -- (F)
P2 (REC.AA (4..5));
IF REC.AA /= (10, 10, 8) THEN
FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF P2");
END; -- (F)
 
BEGIN -- (G)
P3 (REC.A (2..3));
IF REC.A /= (6, 4, 4, 6) THEN
FAILED ("OUT PARAM NOT RETURNED CORRECTLY");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF P3");
END; -- (G)
 
END; -- (C)
 
RESULT;
END C64109I;
/c64109j.ada
0,0 → 1,164
-- C64109J.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 SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE
-- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY,
-- (D) CHECK OBJECTS DESIGNATED BY ACCESS TYPES.
 
-- HISTORY:
-- TBN 07/10/86 CREATED ORIGINAL TEST.
-- JET 08/04/87 MODIFIED PTR.A REFERENCES.
 
WITH REPORT; USE REPORT;
PROCEDURE C64109J IS
 
BEGIN
TEST ("C64109J", "CHECK THAT SLICES OF ARRAYS WHICH ARE " &
"COMPONENTS OF RECORDS ARE PASSED CORRECTLY " &
"TO SUBPROGRAMS - OBJECTS DESIGNATED BY ACCESS " &
"TYPES");
 
DECLARE -- (D)
 
SUBTYPE INDEX IS INTEGER RANGE 1..5;
TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>) OF INTEGER;
SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE(1..IDENT_INT(5));
TYPE NODE_TYPE;
TYPE ACCESS_TYPE IS ACCESS NODE_TYPE;
TYPE NODE_TYPE IS
RECORD
A : ARRAY_SUBTYPE;
NEXT : ACCESS_TYPE;
END RECORD;
PTR : ACCESS_TYPE := NEW NODE_TYPE'
(A => (IDENT_INT(1)..5 => IDENT_INT(5)),
NEXT => NULL);
BOOL : BOOLEAN;
 
PROCEDURE P1 (ARR : ARRAY_TYPE) IS
BEGIN
IF ARR /= (5, 5, 5) THEN
FAILED ("IN PARAM NOT PASSED CORRECTLY");
END IF;
 
IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
FAILED ("WRONG BOUNDS - IN PARAMETER");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
END P1;
 
FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
BEGIN
IF ARR /= (5, 5, 5) THEN
FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
END IF;
 
IF ARR'FIRST /= IDENT_INT(2) OR ARR'LAST /= 4 THEN
FAILED ("WRONG BOUNDS - IN PARAMETER FOR FN");
END IF;
 
RETURN TRUE;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN FUNCTION F1");
END F1;
 
PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS
BEGIN
IF ARR /= (5, 5, 5) THEN
FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
END IF;
 
IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
FAILED ("WRONG BOUNDS - IN OUT PARAMETER");
END IF;
 
ARR := (ARR'RANGE => 6);
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P2");
END P2;
 
PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
BEGIN
 
IF ARR'FIRST /= IDENT_INT(3) OR ARR'LAST /= 5 THEN
FAILED ("WRONG BOUNDS - OUT PARAMETER");
END IF;
 
ARR := (ARR'RANGE => 7);
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P3");
END P3;
 
BEGIN -- (D)
 
BEGIN -- (E)
P1 (PTR.A (1..3));
IF PTR.A /= (5, 5, 5, 5, 5) THEN
FAILED ("IN PARAM CHANGED BY PROCEDURE");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF P1");
END; -- (E)
 
BEGIN -- (F)
BOOL := F1 (PTR.A (2..4));
IF PTR.A /= (5, 5, 5, 5, 5) THEN
FAILED ("IN PARAM CHANGED BY FUNCTION");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF F1");
END; -- (F)
 
BEGIN -- (G)
P2 (PTR.A (1..3));
IF PTR.A /= (6, 6, 6, 5, 5) THEN
FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF P2");
END; -- (G)
 
BEGIN -- (H)
P3 (PTR.A (3..5));
IF PTR.A /= (6, 6, 7, 7, 7) THEN
FAILED ("OUT PARAM NOT RETURNED CORRECTLY");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF P3");
END; -- (H)
 
END; -- (D)
 
RESULT;
END C64109J;
/c64109k.ada
0,0 → 1,191
-- C64109K.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 SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE
-- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY,
-- (E) CHECK THE CASE WHERE THE FORMAL IS UNCONSTRAINED, AND ARRAYS
-- WITH DIFFERENT BOUNDS ARE PASSED AS ACTUALS.
 
-- HISTORY:
-- TBN 07/11/86 CREATED ORIGINAL TEST.
-- JET 08/04/87 MODIFIED REC.A REFERENCES.
 
WITH REPORT; USE REPORT;
PROCEDURE C64109K IS
 
BEGIN
TEST ("C64109K", "CHECK THAT SLICES OF ARRAYS WHICH ARE " &
"COMPONENTS OF RECORDS ARE PASSED CORRECTLY " &
"TO SUBPROGRAMS - ARRAYS WITH DIFFERENT BOUNDS " &
"PASSED TO UNCONSTRAINED FORMAL");
 
DECLARE -- (E)
 
SUBTYPE SUBINT IS INTEGER RANGE 0..5;
TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
TYPE RECORD_TYPE IS
RECORD
A : ARRAY_TYPE (IDENT_INT(0)..IDENT_INT(4));
B : ARRAY_TYPE (1..5);
END RECORD;
REC : RECORD_TYPE := (A => (0..4 => IDENT_BOOL(TRUE)),
B => (1..5 => IDENT_BOOL(FALSE)));
BOOL : BOOLEAN;
 
PROCEDURE P1 (ARR : ARRAY_TYPE; ARR2 : ARRAY_TYPE) IS
BEGIN
IF ARR /= (TRUE, TRUE, TRUE) THEN
FAILED ("IN PARAM NOT PASSED CORRECTLY");
END IF;
IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
FAILED ("WRONG IN PARAMETER BOUNDS - 1");
END IF;
IF ARR2 /= (FALSE, FALSE, FALSE) THEN
FAILED ("IN PARAM NOT PASSED CORRECTLY - 2");
END IF;
IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
FAILED ("WRONG IN PARAMETER BOUNDS - 2");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
END P1;
 
FUNCTION F1 ( ARR : ARRAY_TYPE; ARR2 : ARRAY_TYPE)
RETURN BOOLEAN IS
BEGIN
IF ARR /= (TRUE, TRUE, TRUE) THEN
FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
END IF;
IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
FAILED ("WRONG IN PARAMETER BOUNDS FOR FN - 1");
END IF;
IF ARR2 /= (FALSE, FALSE, FALSE) THEN
FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
END IF;
IF ARR2'FIRST /= 3 OR ARR2'LAST /= IDENT_INT(5) THEN
FAILED ("WRONG IN PARAMETER BOUNDS FOR FN - 2");
END IF;
RETURN TRUE;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN FUNCTION F1");
END F1;
 
PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE;
ARR2 : IN OUT ARRAY_TYPE) IS
BEGIN
IF ARR /= (TRUE, TRUE, TRUE) THEN
FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
END IF;
IF ARR'FIRST /= IDENT_INT(2) OR ARR'LAST /= 4 THEN
FAILED ("WRONG IN OUT PARAMETER BOUNDS - 1");
END IF;
IF ARR2 /= (FALSE, FALSE, FALSE) THEN
FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
END IF;
IF ARR2'FIRST /= 2 OR ARR2'LAST /= IDENT_INT(4) THEN
FAILED ("WRONG IN OUT PARAMETER BOUNDS - 2");
END IF;
ARR := (ARR'RANGE => FALSE);
ARR2 := (ARR2'RANGE => TRUE);
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P2");
END P2;
 
PROCEDURE P3 (ARR : OUT ARRAY_TYPE; ARR2 : OUT ARRAY_TYPE) IS
BEGIN
IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
FAILED ("WRONG OUT PARAMETER BOUNDS - 1");
END IF;
IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
FAILED ("WRONG OUT PARAMETER BOUNDS - 2");
END IF;
ARR := (ARR'RANGE => FALSE);
ARR2 := (ARR2'RANGE => TRUE);
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P3");
END P3;
 
BEGIN -- (E)
 
BEGIN -- (F)
P1 (REC.A (0..2), REC.B (1..3));
IF REC.A /= (TRUE, TRUE, TRUE, TRUE, TRUE) THEN
FAILED ("IN PARAM CHANGED BY PROCEDURE");
END IF;
IF REC.B /= (FALSE, FALSE, FALSE, FALSE, FALSE) THEN
FAILED ("IN PARAM CHANGED BY PROCEDURE - 2");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF P1");
END; -- (F)
 
BEGIN -- (G)
BOOL := F1 (REC.A (1..3), REC.B (3..5));
IF REC.A /= (TRUE, TRUE, TRUE, TRUE, TRUE) THEN
FAILED ("IN PARAM CHANGED BY FUNCTION");
END IF;
IF REC.B /= (FALSE, FALSE, FALSE, FALSE, FALSE) THEN
FAILED ("IN PARAM CHANGED BY FUNCTION - 2");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF F1");
END; -- (G)
 
BEGIN -- (H)
P2 (REC.A (2..4), REC.B (2..4));
IF REC.A /= (TRUE, TRUE, FALSE, FALSE, FALSE) THEN
FAILED ("IN OUT PARAM RETURNED INCORRECTLY");
END IF;
IF REC.B /= (FALSE, TRUE, TRUE, TRUE, FALSE) THEN
FAILED ("IN OUT PARAM RETURNED INCORRECTLY - 2");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF P2");
END; -- (H)
 
BEGIN -- (I)
P3 (REC.A (0..2), REC.B (1..3));
IF REC.A /= (FALSE, FALSE, FALSE, FALSE, FALSE) THEN
FAILED ("OUT PARAM RETURNED INCORRECTLY");
END IF;
IF REC.B /= (TRUE, TRUE, TRUE, TRUE, FALSE) THEN
FAILED ("OUT PARAM RETURNED INCORRECTLY - 2");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF P3");
END; -- (I)
 
END; -- (E)
 
RESULT;
END C64109K;
/c64109l.ada
0,0 → 1,158
-- C64109L.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 SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE
-- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY,
-- (F) CHECK THAT A FORMAL PARAMETER CAN BE USED AS AN ACTUAL IN
-- ANOTHER SUBPROGRAM CALL.
 
-- HISTORY:
-- TBN 07/11/86 CREATED ORIGINAL TEST.
-- JET 08/04/87 MODIFIED REC.A REFERENCES.
 
WITH REPORT; USE REPORT;
PROCEDURE C64109L IS
 
BEGIN
TEST ("C64109L", "CHECK THAT SLICES OF ARRAYS WHICH ARE " &
"COMPONENTS OF RECORDS ARE PASSED CORRECTLY " &
"TO SUBPROGRAMS - FORMAL AS AN ACTUAL");
 
DECLARE -- (F)
 
TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
SUBTYPE ARRAY_SUBTYPE IS
ARRAY_TYPE (IDENT_INT(1)..IDENT_INT(5));
TYPE RECORD_TYPE IS
RECORD
I : INTEGER;
A : ARRAY_SUBTYPE;
END RECORD;
REC : RECORD_TYPE := (I => 23,
A => (1..3 => 7, 4..5 => 9));
BOOL : BOOLEAN;
 
PROCEDURE P_CALLED (A : IN OUT ARRAY_TYPE) IS
BEGIN
IF A /= (7, 7, 7) THEN
FAILED ("IN OUT PARAM NOT RECEIVED CORRECTLY");
END IF;
IF A'FIRST /= 1 OR A'LAST /= IDENT_INT(3) THEN
FAILED ("BOUNDS WRONG - IN OUT");
END IF;
A := (A'RANGE => 6);
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P_CALLED");
END P_CALLED;
 
PROCEDURE P (A : IN OUT ARRAY_TYPE) IS
BEGIN
P_CALLED (A);
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P");
END P;
 
FUNCTION F_CALLED (A : ARRAY_TYPE) RETURN BOOLEAN IS
GOOD : BOOLEAN;
BEGIN
GOOD := (A = (6, 9, 9));
IF NOT GOOD THEN
FAILED ("IN PARAMETER NOT RECEIVED CORRECTLY");
END IF;
IF A'FIRST /= 3 OR A'LAST /= IDENT_INT(5) THEN
FAILED ("BOUNDS WRONG - FUNCTION");
END IF;
RETURN GOOD;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN FUNCTION F_CALLED");
END F_CALLED;
 
FUNCTION F (A : ARRAY_TYPE) RETURN BOOLEAN IS
BEGIN
RETURN (F_CALLED (A));
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN FUNCTION F");
END F;
 
PROCEDURE P_OUT_CALLED (A : OUT ARRAY_TYPE) IS
BEGIN
IF A'FIRST /= IDENT_INT(2) OR A'LAST /= 4 THEN
FAILED ("BOUNDS WRONG - OUT");
END IF;
A := (8, 8, 8);
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE " &
"P_OUT_CALLED");
END P_OUT_CALLED;
 
PROCEDURE P_OUT (A : OUT ARRAY_TYPE) IS
BEGIN
P_OUT_CALLED (A);
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P_OUT");
END P_OUT;
 
BEGIN -- (F)
 
BEGIN -- (G)
P (REC.A (1..3));
IF REC.A /= (6, 6, 6, 9, 9) THEN
FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF P");
END; -- (G)
 
BEGIN -- (H)
BOOL := F (REC.A (3..5));
IF NOT BOOL THEN
FAILED ("IN PARAM NOT RETURNED CORRECTLY");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF F");
END; -- (H)
 
BEGIN -- (I)
P_OUT (REC.A (2..4));
IF REC.A /= (6, 8, 8, 8, 9) THEN
FAILED ("OUT PARAM NOT RETURNED CORRECTLY - 2");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED DURING CALL OF P_OUT");
END; -- (I)
 
END; -- (F)
 
RESULT;
END C64109L;
/c64005d0.ada
0,0 → 1,219
-- C64005D0M.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 SUBPROGRAMS CAN BE CALLED RECURSIVELY AND THAT
-- NON-LOCAL VARIABLES AND FORMAL PARAMETERS ARE PROPERLY ACCESSED FROM
-- WITHIN RECURSIVE INVOCATIONS. THIS TEST CHECKS THAT EVERY DISPLAY OR
-- STATIC CHAIN LEVEL CAN BE ACCESSED.
 
-- THIS TEST USES 3 LEVELS OF NESTED RECURSIVE PROCEDURES (SEPARATELY
-- COMPILED AS SUBUNITS).
 
-- SEPARATE FILES ARE:
-- C64005D0M THE MAIN PROCEDURE.
-- C64005DA A RECURSIVE PROCEDURE SUBUNIT OF C64005D0M.
-- C64005DB A RECURSIVE PROCEDURE SUBUNIT OF C64005DA.
-- C64005DC A RECURSIVE PROCEDURE SUBUNIT OF C64005DB.
 
-- JRK 7/30/84
 
WITH REPORT; USE REPORT;
 
PROCEDURE C64005D0M IS
 
SUBTYPE LEVEL IS CHARACTER RANGE 'A' .. 'C';
SUBTYPE CALL IS CHARACTER RANGE '1' .. '3';
 
MAX_LEV : CONSTANT := LEVEL'POS (LEVEL'LAST) -
LEVEL'POS (LEVEL'FIRST) + 1;
T_LEN : CONSTANT := 2 * (1 + 3 * (MAX_LEV +
MAX_LEV*(MAX_LEV+1)/2*2)) + 1;
G_LEN : CONSTANT := 2 + 4 * MAX_LEV;
 
TYPE TRACE IS
RECORD
E : NATURAL := 0;
S : STRING (1 .. T_LEN);
END RECORD;
 
V : CHARACTER := IDENT_CHAR ('<');
L : CHARACTER := IDENT_CHAR ('>');
T : TRACE;
G : STRING (1 .. G_LEN);
 
PROCEDURE C64005DA (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
SEPARATE;
 
BEGIN
TEST ("C64005D", "CHECK THAT NON-LOCAL VARIABLES AND FORMAL " &
"PARAMETERS AT ALL LEVELS OF NESTED " &
"RECURSIVE PROCEDURES ARE ACCESSIBLE (FOR " &
"3 LEVELS OF SEPARATELY COMPILED SUBUNITS)");
 
-- APPEND V TO T.
T.S (T.E+1) := V;
T.E := T.E + 1;
 
C64005DA (IDENT_CHAR(LEVEL'FIRST), IDENT_CHAR('1'), T);
 
-- APPEND L TO T.
T.S (T.E+1) := L;
T.E := T.E + 1;
 
COMMENT ("FINAL CALL TRACE LENGTH IS: " & INTEGER'IMAGE(T.E));
COMMENT ("FINAL CALL TRACE IS: " & T.S(1..T.E));
COMMENT ("GLOBAL SNAPSHOT IS: " & G);
 
-- CHECK THAT T AND G ARE CORRECT BY COMPUTING THEM ITERATIVELY.
 
DECLARE
SUBTYPE LC_LEVEL IS CHARACTER RANGE ASCII.LC_A ..
CHARACTER'VAL (CHARACTER'POS(ASCII.LC_A) + MAX_LEV - 1);
 
CT : TRACE;
CG : STRING (1 .. G_LEN);
BEGIN
COMMENT ("CORRECT FINAL CALL TRACE LENGTH IS: " &
INTEGER'IMAGE(T_LEN));
 
IF T.E /= IDENT_INT (T_LEN) THEN
FAILED ("WRONG FINAL CALL TRACE LENGTH");
 
ELSE CT.S (CT.E+1) := '<';
CT.E := CT.E + 1;
 
FOR I IN LC_LEVEL LOOP
CT.S (CT.E+1) := '<';
CT.E := CT.E + 1;
 
FOR J IN LC_LEVEL'FIRST .. I LOOP
CT.S (CT.E+1) := J;
CT.S (CT.E+2) := '1';
CT.E := CT.E + 2;
END LOOP;
END LOOP;
 
FOR I IN LC_LEVEL LOOP
CT.S (CT.E+1) := '<';
CT.E := CT.E + 1;
 
FOR J IN LC_LEVEL'FIRST .. LC_LEVEL'PRED(I) LOOP
CT.S (CT.E+1) := J;
CT.S (CT.E+2) := '3';
CT.E := CT.E + 2;
END LOOP;
 
CT.S (CT.E+1) := I;
CT.S (CT.E+2) := '2';
CT.E := CT.E + 2;
 
CT.S (CT.E+1) := '<';
CT.E := CT.E + 1;
 
FOR J IN LC_LEVEL'FIRST .. I LOOP
CT.S (CT.E+1) := J;
CT.S (CT.E+2) := '3';
CT.E := CT.E + 2;
END LOOP;
END LOOP;
 
CT.S (CT.E+1) := '=';
CT.E := CT.E + 1;
 
FOR I IN REVERSE LEVEL LOOP
FOR J IN REVERSE LEVEL'FIRST .. I LOOP
CT.S (CT.E+1) := J;
CT.S (CT.E+2) := '3';
CT.E := CT.E + 2;
END LOOP;
 
CT.S (CT.E+1) := '>';
CT.E := CT.E + 1;
 
CT.S (CT.E+1) := I;
CT.S (CT.E+2) := '2';
CT.E := CT.E + 2;
 
FOR J IN REVERSE LEVEL'FIRST .. LEVEL'PRED(I) LOOP
CT.S (CT.E+1) := J;
CT.S (CT.E+2) := '3';
CT.E := CT.E + 2;
END LOOP;
 
CT.S (CT.E+1) := '>';
CT.E := CT.E + 1;
END LOOP;
 
FOR I IN REVERSE LEVEL LOOP
FOR J IN REVERSE LEVEL'FIRST .. I LOOP
CT.S (CT.E+1) := J;
CT.S (CT.E+2) := '1';
CT.E := CT.E + 2;
END LOOP;
 
CT.S (CT.E+1) := '>';
CT.E := CT.E + 1;
END LOOP;
 
CT.S (CT.E+1) := '>';
CT.E := CT.E + 1;
 
IF CT.E /= IDENT_INT (T_LEN) THEN
FAILED ("WRONG ITERATIVE TRACE LENGTH");
 
ELSE COMMENT ("CORRECT FINAL CALL TRACE IS: " & CT.S);
 
IF T.S /= CT.S THEN
FAILED ("WRONG FINAL CALL TRACE");
END IF;
END IF;
END IF;
 
DECLARE
E : NATURAL := 0;
BEGIN
CG (1..2) := "<>";
E := E + 2;
 
FOR I IN LEVEL LOOP
CG (E+1) := LC_LEVEL'VAL (LEVEL'POS(I) -
LEVEL'POS(LEVEL'FIRST) +
LC_LEVEL'POS
(LC_LEVEL'FIRST));
CG (E+2) := '3';
CG (E+3) := I;
CG (E+4) := '3';
E := E + 4;
END LOOP;
 
COMMENT ("CORRECT GLOBAL SNAPSHOT IS: " & CG);
 
IF G /= CG THEN
FAILED ("WRONG GLOBAL SNAPSHOT");
END IF;
END;
END;
 
RESULT;
END C64005D0M;
/c64005a.ada
0,0 → 1,64
-- C64005A.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 SUBPROGRAM CAN BE CALLED
-- RECURSIVELY AND THAT NON-LOCAL VARIABLES AND
-- CONSTANTS ARE PROPERLY ACCESSED FROM WITHIN
-- RECURSIVE INVOCATIONS.
 
-- CVP 5/1/81
 
WITH REPORT;
PROCEDURE C64005A IS
 
USE REPORT;
 
TWENTY : CONSTANT INTEGER := 20;
C1 : CONSTANT INTEGER := 1;
I1, I2 : INTEGER := 0;
 
PROCEDURE RECURSE (I1A : INTEGER; I2 : IN OUT INTEGER) IS
C1 : CONSTANT INTEGER := 5;
BEGIN
IF I1A < TWENTY THEN
RECURSE (I1A+C1, I2);
I1 := I1 + C64005A.C1;
I2 := I2 + I1A;
END IF;
END RECURSE;
 
BEGIN
TEST ("C64005A", "RECURSIVE SUBPROGRAMS WITH " &
"NON-LOCAL DATA ACCESS");
 
RECURSE (0, I2);
 
IF I1 /= 4 OR I2 /= 30 THEN
FAILED ("RECURSIVE PROCEDURE INVOCATIONS " &
"WITH GLOBAL DATA ACCESS NOT PERFORMED " &
"CORRECTLY");
END IF;
 
RESULT;
END C64005A;
/c64005b.ada
0,0 → 1,109
-- C64005B.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 SUBPROGRAM CAN BE CALLED RECURSIVELY AND THAT NON-LOCAL
-- VARIABLES AND CONSTANTS ARE PROPERLY ACCESSED FROM WITHIN RECURSIVE
-- INVOCATIONS.
 
-- CPP 7/2/84
 
WITH REPORT; USE REPORT;
PROCEDURE C64005B IS
 
COUNT : INTEGER := 0;
TWENTY : CONSTANT INTEGER := 20;
C1 : CONSTANT INTEGER := 1;
G1, G2, G3 : INTEGER := 0;
G4, G5 : INTEGER := 0;
 
PROCEDURE R (A1 : INTEGER; A2 : IN OUT INTEGER; A3 : OUT INTEGER)
IS
C1 : CONSTANT INTEGER := 5;
TEN : CONSTANT INTEGER := 10;
J1, J2 : INTEGER := 1;
J3 : INTEGER := 0;
 
PROCEDURE RECURSE (P1 : INTEGER; P2 : IN OUT INTEGER) IS
C1 : INTEGER := 2;
BEGIN -- RECURSE
C1 := IDENT_INT (10);
IF P1 < TWENTY THEN
RECURSE (P1 + C1, G2);
G1 := G1 + C64005B.C1;
G3 := G3 + P1;
P2 := P2 + IDENT_INT(2);
A2 := A2 + IDENT_INT(1);
J2 := J2 + R.C1;
END IF;
END RECURSE;
 
BEGIN -- R
IF A2 < TEN THEN
A2 := A2 + C1;
RECURSE (0, J1);
J3 := J3 + TEN;
COUNT := COUNT + 1;
COMMENT ("ON PASS # " & INTEGER'IMAGE(COUNT));
COMMENT ("VALUE OF A2 IS " & INTEGER'IMAGE(A2));
COMMENT ("VALUE OF J3 IS " & INTEGER'IMAGE(J3));
R (0, A2, J3);
J3 := J3 + A2;
END IF;
A3 := J1 + J3;
END R;
 
BEGIN
TEST("C64005B", "RECURSIVE SUBPROGRAMS WITH ALL KINDS " &
"OF DATA ACCESS");
 
R (0, G4, G5);
 
IF (COUNT /= 2) OR (G1 /= 4) OR
(G2 /= 4) OR (G3 /= 20) OR
(G4 /= 14) OR (G5 /= 35) THEN
FAILED ("RECURSIVE INVOCATIONS' DATA ACCESS IS NOT" &
" WORKING CORRECTLY");
END IF;
 
COMMENT ("VALUE OF COUNT IS " & INTEGER'IMAGE(COUNT));
COMMENT ("VALUE OF G1 IS " & INTEGER'IMAGE(G1));
COMMENT ("VALUE OF G2 IS " & INTEGER'IMAGE(G2));
COMMENT ("VALUE OF G3 IS " & INTEGER'IMAGE(G3));
COMMENT ("VALUE OF G4 IS " & INTEGER'IMAGE(G4));
COMMENT ("VALUE OF G5 IS " & INTEGER'IMAGE(G5));
 
RESULT;
 
EXCEPTION
WHEN PROGRAM_ERROR =>
FAILED ("PROGRAM_ERROR RAISED");
COMMENT ("VALUE OF COUNT IS " & INTEGER'IMAGE(COUNT));
COMMENT ("VALUE OF G1 IS " & INTEGER'IMAGE(G1));
COMMENT ("VALUE OF G2 IS " & INTEGER'IMAGE(G2));
COMMENT ("VALUE OF G3 IS " & INTEGER'IMAGE(G3));
COMMENT ("VALUE OF G4 IS " & INTEGER'IMAGE(G4));
COMMENT ("VALUE OF G5 IS " & INTEGER'IMAGE(G5));
RESULT;
 
END C64005B;
/c61009a.ada
0,0 → 1,160
-- C61009A.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 STATIC EXPRESSION, CONSTANT NAME, ATTRIBUTE NAME,
-- VARIABLE, DEREFERENCED ACCESS, USER-DEFINED OPERATOR, USER-
-- DEFINED FUNCTION, OR ALLOCATOR CAN BE USED IN THE INITIALIZATION
-- EXPRESSION OF A FORMAL PARAMETER, AND THAT THE APPROPRIATE
-- VALUE IS USED AS A DEFAULT PARAMETER VALUE WHEN THE SUBPROGRAM
-- IS CALLED.
 
-- DAS 1/21/81
-- ABW 7/20/82
-- SPS 12/10/82
 
WITH REPORT;
PROCEDURE C61009A IS
 
USE REPORT;
 
TYPE INT IS RANGE 1 .. 10;
 
TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
 
TYPE RECTYPE (CONSTRAINT : INTEGER) IS
RECORD
A : ARR (0..CONSTRAINT);
END RECORD;
 
C7 : CONSTANT INTEGER := 7;
V7 : INTEGER := 7;
TYPE A_INT IS ACCESS INTEGER;
C_A : CONSTANT A_INT := NEW INTEGER'(7);
 
SUBTYPE RECTYPE1 IS RECTYPE (2 + 5);
SUBTYPE RECTYPE2 IS RECTYPE (C7);
SUBTYPE RECTYPE3 IS RECTYPE (V7);
 
FUNCTION "&" (X,Y : INTEGER) RETURN INTEGER IS
BEGIN
RETURN 10;
END "&";
 
FUNCTION FUNC (X : INTEGER) RETURN INTEGER IS
BEGIN
RETURN X;
END FUNC;
 
-- STATIC EXPRESSION
 
PROCEDURE PROC1 (REC : RECTYPE1 := (3+4,(0,1,2,3,4,5,6,7))) IS
BEGIN
IF (REC /= (7,(0,1,2,3,4,5,6,7))) THEN
FAILED ("INCORRECT DEFAULT VALUE FOR PROC1 PARAMETER");
END IF;
END PROC1;
 
-- CONSTANT NAME
 
PROCEDURE PROC2 (REC : RECTYPE2 := (C7,(0,1,2,3,4,5,6,7))) IS
BEGIN
IF (REC /= (C7,(0,1,2,3,4,5,6,7))) THEN
FAILED ("INCORRECT DEFAULT VALUE FOR PROC2 PARAMETER");
END IF;
END PROC2;
 
-- ATTRIBUTE NAME
 
PROCEDURE PROC3 (P1 : INT := INT'LAST) IS
BEGIN
IF (P1 /= INT (10)) THEN
FAILED ("INCORRECT DEFAULT VALUE FOR PROC3 PARAMETER");
END IF;
END PROC3;
 
-- VARIABLE
 
PROCEDURE PROC4 (P4 : RECTYPE3 := (V7,(0,1,2,3,4,5,6,7))) IS
BEGIN
IF (P4 /= (V7,(0,1,2,3,4,5,6,7))) THEN
FAILED ("INCORRECT DEFAULT VALUE FOR PROC4 PARAMETER");
END IF;
END PROC4;
 
--DEREFERENCED ACCESS
 
PROCEDURE PROC5 (P5 : INTEGER := C_A.ALL) IS
BEGIN
IF(P5 /= C_A.ALL) THEN
FAILED ("INCORRECT DEFAULT VALUE FOR PROC5 PARAMETER");
END IF;
END PROC5;
 
--USER-DEFINED OPERATOR
 
PROCEDURE PROC6 (P6 : INTEGER := 6&4) IS
BEGIN
IF (P6 /= IDENT_INT(10)) THEN
FAILED ("INCORRECT DEFAULT VALUE FOR PROC6 PARAMETER");
END IF;
END PROC6;
 
--USER-DEFINED FUNCTION
 
PROCEDURE PROC7 (P7 : INTEGER := FUNC(10)) IS
BEGIN
IF (P7 /= IDENT_INT(10)) THEN
FAILED ("INCORRECT DEFAULT VALUE FOR PROC7 PARAMETER");
END IF;
END PROC7;
 
-- ALLOCATOR
 
PROCEDURE PROC8 (P8 : A_INT := NEW INTEGER'(7)) IS
BEGIN
IF (P8.ALL /= IDENT_INT(7)) THEN
FAILED ("INCORRECT DEFAULT VALUE FOR PROC8 PARAMETER");
END IF;
END PROC8;
 
BEGIN
TEST ("C61009A", "CHECK USE OF STATIC EXPRESSIONS, CONSTANT " &
"NAMES, ATTRIBUTE NAMES, VARIABLES, USER- " &
"DEFINED OPERATORS, USER-DEFINED FUNCTIONS " &
"DEREFERENCED ACCESSES, AND ALLOCATORS IN " &
"THE FORMAL PART OF A SUBPROGRAM SPECIFICATION");
 
PROC1;
PROC2;
PROC3;
PROC4;
PROC5;
PROC6;
PROC7;
PROC8;
 
RESULT;
 
END C61009A;
/c64005c.ada
0,0 → 1,330
-- C64005C.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 SUBPROGRAMS CAN BE CALLED RECURSIVELY AND THAT
-- NON-LOCAL VARIABLES AND FORMAL PARAMETERS ARE PROPERLY ACCESSED FROM
-- WITHIN RECURSIVE INVOCATIONS. THIS TEST CHECKS THAT EVERY DISPLAY OR
-- STATIC CHAIN LEVEL CAN BE ACCESSED.
 
-- THIS TEST USES 3 LEVELS OF NESTED RECURSIVE PROCEDURES.
 
-- JRK 7/26/84
 
WITH REPORT; USE REPORT;
 
PROCEDURE C64005C IS
 
SUBTYPE LEVEL IS CHARACTER RANGE 'A' .. 'C';
SUBTYPE CALL IS CHARACTER RANGE '1' .. '3';
 
MAX_LEV : CONSTANT := LEVEL'POS (LEVEL'LAST) -
LEVEL'POS (LEVEL'FIRST) + 1;
T_LEN : CONSTANT := 2 * (1 + 3 * (MAX_LEV +
MAX_LEV*(MAX_LEV+1)/2*2)) + 1;
G_LEN : CONSTANT := 2 + 4 * MAX_LEV;
 
TYPE TRACE IS
RECORD
E : NATURAL := 0;
S : STRING (1 .. T_LEN);
END RECORD;
 
V : CHARACTER := IDENT_CHAR ('<');
L : CHARACTER := IDENT_CHAR ('>');
T : TRACE;
G : STRING (1 .. G_LEN);
 
PROCEDURE C64005CA (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
 
V : STRING (1..2);
 
M : CONSTANT NATURAL := LEVEL'POS (L) -
LEVEL'POS (LEVEL'FIRST) + 1;
N : CONSTANT NATURAL := 2 * M + 1;
 
PROCEDURE C64005CB (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
 
V : STRING (1..2);
 
M : CONSTANT NATURAL := LEVEL'POS (L) -
LEVEL'POS (LEVEL'FIRST) + 1;
N : CONSTANT NATURAL := 2 * M + 1;
 
PROCEDURE C64005CC (L : LEVEL; C : CALL;
T : IN OUT TRACE) IS
 
V : STRING (1..2);
 
M : CONSTANT NATURAL := LEVEL'POS (L) -
LEVEL'POS (LEVEL'FIRST) + 1;
N : CONSTANT NATURAL := 2 * M + 1;
 
BEGIN
 
V (1) := IDENT_CHAR (ASCII.LC_C);
V (2) := C;
 
-- APPEND ALL V TO T.
T.S (T.E+1 .. T.E+N) := C64005C.V & C64005CA.V &
C64005CB.V & C64005CC.V;
T.E := T.E + N;
 
CASE C IS
 
WHEN '1' =>
C64005CA (IDENT_CHAR(LEVEL'FIRST),
IDENT_CHAR('2'), T);
 
WHEN '2' =>
C64005CC (L, IDENT_CHAR('3'), T);
 
WHEN '3' =>
-- APPEND MID-POINT SYMBOL TO T.
T.S (T.E+1) := IDENT_CHAR ('=');
T.E := T.E + 1;
 
-- G := CATENATE ALL V, L, C;
G := C64005C.V & C64005C.L &
C64005CA.V & C64005CA.L & C64005CA.C &
C64005CB.V & C64005CB.L & C64005CB.C &
C64005CC.V & C64005CC.L & C64005CC.C;
END CASE;
 
-- APPEND ALL L AND C TO T IN REVERSE ORDER.
T.S (T.E+1 .. T.E+N) := C64005CC.L & C64005CC.C &
C64005CB.L & C64005CB.C &
C64005CA.L & C64005CA.C &
C64005C.L;
T.E := T.E + N;
 
END C64005CC;
 
BEGIN
 
V (1) := IDENT_CHAR (ASCII.LC_B);
V (2) := C;
 
-- APPEND ALL V TO T.
T.S (T.E+1 .. T.E+N) := C64005C.V & C64005CA.V &
C64005CB.V;
T.E := T.E + N;
 
CASE C IS
 
WHEN '1' =>
C64005CC (LEVEL'SUCC(L), IDENT_CHAR('1'), T);
 
WHEN '2' =>
C64005CB (L, IDENT_CHAR('3'), T);
 
WHEN '3' =>
C64005CC (LEVEL'SUCC(L), IDENT_CHAR('2'), T);
END CASE;
 
-- APPEND ALL L AND C TO T IN REVERSE ORDER.
T.S (T.E+1 .. T.E+N) := C64005CB.L & C64005CB.C &
C64005CA.L & C64005CA.C &
C64005C.L;
T.E := T.E + N;
 
END C64005CB;
 
BEGIN
 
V (1) := IDENT_CHAR (ASCII.LC_A);
V (2) := C;
 
-- APPEND ALL V TO T.
T.S (T.E+1 .. T.E+N) := C64005C.V & C64005CA.V;
T.E := T.E + N;
 
CASE C IS
 
WHEN '1' =>
C64005CB (LEVEL'SUCC(L), IDENT_CHAR('1'), T);
 
WHEN '2' =>
C64005CA (L, IDENT_CHAR('3'), T);
 
WHEN '3' =>
C64005CB (LEVEL'SUCC(L), IDENT_CHAR('2'), T);
END CASE;
 
-- APPEND ALL L AND C TO T IN REVERSE ORDER.
T.S (T.E+1 .. T.E+N) := C64005CA.L & C64005CA.C & C64005C.L;
T.E := T.E + N;
 
END C64005CA;
 
BEGIN
TEST ("C64005C", "CHECK THAT NON-LOCAL VARIABLES AND FORMAL " &
"PARAMETERS AT ALL LEVELS OF NESTED " &
"RECURSIVE PROCEDURES ARE ACCESSIBLE");
 
-- APPEND V TO T.
T.S (T.E+1) := V;
T.E := T.E + 1;
 
C64005CA (IDENT_CHAR(LEVEL'FIRST), IDENT_CHAR('1'), T);
 
-- APPEND L TO T.
T.S (T.E+1) := L;
T.E := T.E + 1;
 
COMMENT ("FINAL CALL TRACE LENGTH IS: " & INTEGER'IMAGE(T.E));
COMMENT ("FINAL CALL TRACE IS: " & T.S(1..T.E));
COMMENT ("GLOBAL SNAPSHOT IS: " & G);
 
-- CHECK THAT T AND G ARE CORRECT BY COMPUTING THEM ITERATIVELY.
 
DECLARE
SUBTYPE LC_LEVEL IS CHARACTER RANGE ASCII.LC_A ..
CHARACTER'VAL (CHARACTER'POS(ASCII.LC_A) + MAX_LEV - 1);
 
CT : TRACE;
CG : STRING (1 .. G_LEN);
BEGIN
COMMENT ("CORRECT FINAL CALL TRACE LENGTH IS: " &
INTEGER'IMAGE(T_LEN));
 
IF T.E /= IDENT_INT (T_LEN) THEN
FAILED ("WRONG FINAL CALL TRACE LENGTH");
 
ELSE CT.S (CT.E+1) := '<';
CT.E := CT.E + 1;
 
FOR I IN LC_LEVEL LOOP
CT.S (CT.E+1) := '<';
CT.E := CT.E + 1;
 
FOR J IN LC_LEVEL'FIRST .. I LOOP
CT.S (CT.E+1) := J;
CT.S (CT.E+2) := '1';
CT.E := CT.E + 2;
END LOOP;
END LOOP;
 
FOR I IN LC_LEVEL LOOP
CT.S (CT.E+1) := '<';
CT.E := CT.E + 1;
 
FOR J IN LC_LEVEL'FIRST .. LC_LEVEL'PRED(I) LOOP
CT.S (CT.E+1) := J;
CT.S (CT.E+2) := '3';
CT.E := CT.E + 2;
END LOOP;
 
CT.S (CT.E+1) := I;
CT.S (CT.E+2) := '2';
CT.E := CT.E + 2;
 
CT.S (CT.E+1) := '<';
CT.E := CT.E + 1;
 
FOR J IN LC_LEVEL'FIRST .. I LOOP
CT.S (CT.E+1) := J;
CT.S (CT.E+2) := '3';
CT.E := CT.E + 2;
END LOOP;
END LOOP;
 
CT.S (CT.E+1) := '=';
CT.E := CT.E + 1;
 
FOR I IN REVERSE LEVEL LOOP
FOR J IN REVERSE LEVEL'FIRST .. I LOOP
CT.S (CT.E+1) := J;
CT.S (CT.E+2) := '3';
CT.E := CT.E + 2;
END LOOP;
 
CT.S (CT.E+1) := '>';
CT.E := CT.E + 1;
 
CT.S (CT.E+1) := I;
CT.S (CT.E+2) := '2';
CT.E := CT.E + 2;
 
FOR J IN REVERSE LEVEL'FIRST .. LEVEL'PRED(I) LOOP
CT.S (CT.E+1) := J;
CT.S (CT.E+2) := '3';
CT.E := CT.E + 2;
END LOOP;
 
CT.S (CT.E+1) := '>';
CT.E := CT.E + 1;
END LOOP;
 
FOR I IN REVERSE LEVEL LOOP
FOR J IN REVERSE LEVEL'FIRST .. I LOOP
CT.S (CT.E+1) := J;
CT.S (CT.E+2) := '1';
CT.E := CT.E + 2;
END LOOP;
 
CT.S (CT.E+1) := '>';
CT.E := CT.E + 1;
END LOOP;
 
CT.S (CT.E+1) := '>';
CT.E := CT.E + 1;
 
IF CT.E /= IDENT_INT (T_LEN) THEN
FAILED ("WRONG ITERATIVE TRACE LENGTH");
 
ELSE COMMENT ("CORRECT FINAL CALL TRACE IS: " & CT.S);
 
IF T.S /= CT.S THEN
FAILED ("WRONG FINAL CALL TRACE");
END IF;
END IF;
END IF;
 
DECLARE
E : NATURAL := 0;
BEGIN
CG (1..2) := "<>";
E := E + 2;
 
FOR I IN LEVEL LOOP
CG (E+1) := LC_LEVEL'VAL (LEVEL'POS(I) -
LEVEL'POS(LEVEL'FIRST) +
LC_LEVEL'POS
(LC_LEVEL'FIRST));
CG (E+2) := '3';
CG (E+3) := I;
CG (E+4) := '3';
E := E + 4;
END LOOP;
 
COMMENT ("CORRECT GLOBAL SNAPSHOT IS: " & CG);
 
IF G /= CG THEN
FAILED ("WRONG GLOBAL SNAPSHOT");
END IF;
END;
END;
 
RESULT;
END C64005C;
/c64106a.ada
0,0 → 1,351
-- C64106A.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 UNCONSTRAINED RECORD, PRIVATE, LIMITED PRIVATE, AND ARRAY
-- FORMAL PARAMETERS USE THE CONSTRAINTS OF ACTUAL PARAMETERS.
-- SUBTESTS ARE:
-- (A) RECORD TYPE, UNCONSTRAINED ACTUALS, DEFAULTS.
-- (B) PRIVATE TYPE, CONSTRAINED ACTUALS, NO DEFAULTS.
-- (C) LIMITED PRIVATE TYPE, UNCONSTRAINED ACTUALS, NO DEFAULTS.
-- (D) ARRAY TYPE, CONSTRAINED ACTUALS, DEFAULTS.
 
-- DAS 1/15/81
-- JBG 5/16/83
-- CPP 5/22/84
 
WITH REPORT;
PROCEDURE C64106A IS
 
USE REPORT;
 
BEGIN
TEST ("C64106A", "CHECK USE OF ACTUAL CONSTRAINTS BY " &
"UNCONSTRAINED FORMAL PARAMETERS");
 
DECLARE -- (A)
 
PACKAGE PKG IS
 
SUBTYPE INT IS INTEGER RANGE 0..100;
 
TYPE RECTYPE (CONSTRAINT : INT := 80) IS
RECORD
INTFIELD : INTEGER;
STRFIELD : STRING (1..CONSTRAINT);
END RECORD;
 
REC1 : RECTYPE := (10,10,"0123456789");
REC2 : RECTYPE := (17,7,"C64106A..........");
REC3 : RECTYPE := (1,1,"A");
REC4 : RECTYPE; -- 80
 
PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE := (2,0,"AB");
REC2 : OUT RECTYPE;
REC3 : IN OUT RECTYPE);
 
PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE);
END PKG;
 
PACKAGE BODY PKG IS
 
PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE := (2,0,"AB");
REC2 : OUT RECTYPE;
REC3 : IN OUT RECTYPE) IS
BEGIN
IF (REC1.CONSTRAINT /= IDENT_INT(10)) THEN
FAILED ("RECORD TYPE IN PARAMETER DID " &
"NOT USE CONSTRAINT OF ACTUAL");
END IF;
IF (REC2.CONSTRAINT /= IDENT_INT(17)) THEN
FAILED ("RECORD TYPE OUT PARAMETER DID " &
"NOT USE CONSTRAINT OF ACTUAL");
END IF;
IF (REC3.CONSTRAINT /= IDENT_INT(1)) THEN
FAILED ("RECORD TYPE IN OUT PARAMETER DID " &
"NOT USE CONSTRAINT OF ACTUAL");
END IF;
REC2 := PKG.REC2;
END CHK_RECTYPE1;
 
PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS
BEGIN
IF (REC.CONSTRAINT /= IDENT_INT(80)) THEN
FAILED ("RECORD TYPE OUT PARAMETER DID " &
"NOT USE CONSTRAINT OF " &
"UNINITIALIZED ACTUAL");
END IF;
REC := (10,10,"9876543210");
END CHK_RECTYPE2;
END PKG;
 
BEGIN -- (A)
 
PKG.CHK_RECTYPE1 (PKG.REC1, PKG.REC2, PKG.REC3);
PKG.CHK_RECTYPE2 (PKG.REC4);
 
END; -- (A)
 
---------------------------------------------
 
B : DECLARE -- (B)
 
PACKAGE PKG IS
 
SUBTYPE INT IS INTEGER RANGE 0..100;
 
TYPE RECTYPE (CONSTRAINT : INT := 80) IS PRIVATE;
 
 
PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
REC2 : OUT RECTYPE;
REC3 : IN OUT RECTYPE);
 
PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE);
 
PRIVATE
TYPE RECTYPE (CONSTRAINT : INT := 80) IS
RECORD
INTFIELD : INTEGER;
STRFIELD : STRING (1..CONSTRAINT);
END RECORD;
END PKG;
 
REC1 : PKG.RECTYPE(10);
REC2 : PKG.RECTYPE(17);
REC3 : PKG.RECTYPE(1);
REC4 : PKG.RECTYPE(10);
 
PACKAGE BODY PKG IS
 
PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
REC2 : OUT RECTYPE;
REC3 : IN OUT RECTYPE) IS
BEGIN
IF (REC1.CONSTRAINT /= IDENT_INT(10)) THEN
FAILED ("PRIVATE TYPE IN PARAMETER DID " &
"NOT USE CONSTRAINT OF ACTUAL");
END IF;
IF (REC2.CONSTRAINT /= IDENT_INT(17)) THEN
FAILED ("PRIVATE TYPE OUT PARAMETER DID " &
"NOT USE CONSTRAINT OF ACTUAL");
END IF;
IF (REC3.CONSTRAINT /= IDENT_INT(1)) THEN
FAILED ("PRIVATE TYPE IN OUT PARAMETER DID " &
"NOT USE CONSTRAINT OF ACTUAL");
END IF;
REC2 := B.REC2;
END CHK_RECTYPE1;
 
PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS
BEGIN
IF (REC.CONSTRAINT /= IDENT_INT(10)) THEN
FAILED ("PRIVATE TYPE OUT PARAMETER DID " &
"NOT USE CONSTRAINT OF " &
"UNINITIALIZED ACTUAL");
END IF;
REC := (10,10,"9876543210");
END CHK_RECTYPE2;
 
BEGIN
REC1 := (10,10,"0123456789");
REC2 := (17,7,"C64106A..........");
REC3 := (1,1,"A");
 
END PKG;
 
BEGIN -- (B)
 
PKG.CHK_RECTYPE1 (REC1, REC2, REC3);
PKG.CHK_RECTYPE2 (REC4);
 
END B; -- (B)
 
---------------------------------------------
 
C : DECLARE -- (C)
 
PACKAGE PKG IS
 
SUBTYPE INT IS INTEGER RANGE 0..100;
 
TYPE RECTYPE (CONSTRAINT : INT := 80) IS
LIMITED PRIVATE;
 
PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
REC2 : OUT RECTYPE;
REC3 : IN OUT RECTYPE);
 
PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE);
 
PRIVATE
TYPE RECTYPE (CONSTRAINT : INT := 80) IS
RECORD
INTFIELD : INTEGER;
STRFIELD : STRING (1..CONSTRAINT);
END RECORD;
END PKG;
 
REC1 : PKG.RECTYPE; -- 10
REC2 : PKG.RECTYPE; -- 17
REC3 : PKG.RECTYPE; -- 1
REC4 : PKG.RECTYPE; -- 80
 
PACKAGE BODY PKG IS
 
PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
REC2 : OUT RECTYPE;
REC3 : IN OUT RECTYPE) IS
BEGIN
IF (REC1.CONSTRAINT /= IDENT_INT(10)) THEN
FAILED ("LIMITED PRIVATE TYPE IN PARAMETER " &
"DID NOT USE CONSTRAINT OF " &
"ACTUAL");
END IF;
IF (REC2.CONSTRAINT /= IDENT_INT(17)) THEN
FAILED ("LIMITED PRIVATE TYPE OUT PARAMETER " &
"DID NOT USE CONSTRAINT OF " &
"ACTUAL");
END IF;
IF (REC3.CONSTRAINT /= IDENT_INT(1)) THEN
FAILED ("LIMITED PRIVATE TYPE IN OUT " &
"PARAMETER DID NOT USE " &
"CONSTRAINT OF ACTUAL");
END IF;
REC2 := C.REC2;
END CHK_RECTYPE1;
 
PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS
BEGIN
IF (REC.CONSTRAINT /= IDENT_INT(80)) THEN
FAILED ("LIMITED PRIVATE TYPE OUT " &
"PARAMETER DID NOT USE " &
"CONSTRAINT OF UNINITIALIZED ACTUAL");
END IF;
REC := (10,10,"9876543210");
END CHK_RECTYPE2;
 
BEGIN
REC1 := (10,10,"0123456789");
REC2 := (17,7,"C64106A..........");
REC3 := (1,1,"A");
END PKG;
 
BEGIN -- (C)
 
PKG.CHK_RECTYPE1 (REC1, REC2, REC3);
PKG.CHK_RECTYPE2 (REC4);
 
END C; -- (C)
 
---------------------------------------------
 
D : DECLARE -- (D)
 
TYPE ATYPE IS ARRAY (INTEGER RANGE <>, POSITIVE RANGE <>) OF
CHARACTER;
 
A1, A2, A3 : ATYPE(-1..1, 4..5) := (('A','B'),
('C','D'),
('E','F'));
 
A4 : ATYPE(-1..1, 4..5);
 
CA1 : CONSTANT ATYPE(8..9, -7..INTEGER'FIRST) :=
(8..9 => (-7..INTEGER'FIRST => 'A'));
 
S1 : STRING(1..INTEGER'FIRST) := "";
S2 : STRING(-5..-7) := "";
S3 : STRING(1..0) := "";
 
PROCEDURE CHK_ARRAY1 (A1 : IN ATYPE := CA1; A2 : OUT ATYPE;
A3 : IN OUT ATYPE) IS
BEGIN
IF ((A1'FIRST(1) /= IDENT_INT(-1)) OR
(A1'LAST(1) /= IDENT_INT(1)) OR
(A1'FIRST(2) /= IDENT_INT(4)) OR
(A1'LAST(2) /= IDENT_INT(5))) THEN
FAILED ("ARRAY TYPE IN PARAMETER DID NOT " &
"USE CONSTRAINTS OF ACTUAL");
END IF;
IF ((A2'FIRST(1) /= IDENT_INT(-1)) OR
(A2'LAST(1) /= IDENT_INT(1)) OR
(A2'FIRST(2) /= IDENT_INT(4)) OR
(A2'LAST(2) /= IDENT_INT(5))) THEN
FAILED ("ARRAY TYPE OUT PARAMETER DID NOT USE" &
"CONSTRAINTS OF ACTUAL");
END IF;
IF ((A3'FIRST(1) /= IDENT_INT(-1)) OR
(A3'LAST(1) /= IDENT_INT(1)) OR
(A3'FIRST(2) /= IDENT_INT(4)) OR
(A3'LAST(2) /= IDENT_INT(5))) THEN
FAILED ("ARRAY TYPE IN OUT PARAMETER DID NOT " &
"USE CONSTRAINTS OF ACTUAL");
END IF;
A2 := D.A2;
END CHK_ARRAY1;
 
PROCEDURE CHK_ARRAY2 (A4 : OUT ATYPE) IS
BEGIN
IF ((A4'FIRST(1) /= IDENT_INT(-1)) OR
(A4'LAST(1) /= IDENT_INT(1)) OR
(A4'FIRST(2) /= IDENT_INT(4)) OR
(A4'LAST(2) /= IDENT_INT(5))) THEN
FAILED ("ARRAY TYPE OUT PARAMETER DID NOT " &
"USE CONSTRAINTS OF UNINITIALIZED " &
"ACTUAL");
END IF;
A4 := A2;
END CHK_ARRAY2;
 
PROCEDURE CHK_STRING (S1 : IN STRING;
S2 : IN OUT STRING;
S3 : OUT STRING) IS
BEGIN
IF ((S1'FIRST /= IDENT_INT(1)) OR
(S1'LAST /= IDENT_INT(INTEGER'FIRST))) THEN
FAILED ("STRING TYPE IN PARAMETER DID NOT " &
"USE CONSTRAINTS OF ACTUAL NULL " &
"STRING");
END IF;
IF ((S2'FIRST /= IDENT_INT(-5)) OR
(S2'LAST /= IDENT_INT(-7))) THEN
FAILED ("STRING TYPE IN OUT PARAMETER DID NOT " &
"USE CONSTRAINTS OF ACTUAL NULL STRING");
END IF;
IF ((S3'FIRST /= IDENT_INT(1)) OR
(S3'LAST /= IDENT_INT(0))) THEN
FAILED ("STRING TYPE OUT PARAMETER DID NOT " &
"USE CONSTRAINTS OF ACTUAL NULL STRING");
END IF;
S3 := "";
END CHK_STRING;
 
BEGIN -- (D)
CHK_ARRAY1 (A1, A2, A3);
CHK_ARRAY2 (A4);
CHK_STRING (S1, S2, S3);
END D; -- (D)
 
RESULT;
END C64106A;
/c67005a.ada
0,0 → 1,96
-- C67005A.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 IF A RENAMING DECLARATION DECLARES AN EQUALITY OPERATOR, THE
-- TYPES OF THE PARAMETERS NEED NOT BE LIMITED TYPES.
 
-- JBG 9/28/83
 
WITH REPORT; USE REPORT;
PROCEDURE C67005A IS
BEGIN
TEST ("C67005A", "CHECK THAT AN EQUALITY OPERATOR DECLARED BY " &
"A RENAMING DECLARATION NEED NOT HAVE " &
"PARAMETERS OF A LIMITED TYPE");
DECLARE
GENERIC
TYPE LP IS LIMITED PRIVATE;
WITH FUNCTION EQUAL (L, R : LP) RETURN BOOLEAN;
PACKAGE EQUALITY_OPERATOR IS
FUNCTION "=" (L, R : LP) RETURN BOOLEAN;
END EQUALITY_OPERATOR;
 
PACKAGE BODY EQUALITY_OPERATOR IS
FUNCTION "=" (L, R : LP) RETURN BOOLEAN IS
BEGIN
RETURN EQUAL(L, R);
END "=";
END EQUALITY_OPERATOR;
 
PACKAGE POLAR_COORDINATES IS
TYPE POLAR_COORD IS
RECORD
R : INTEGER;
THETA : INTEGER;
END RECORD;
FUNCTION EQUAL (L, R : POLAR_COORD) RETURN BOOLEAN;
PACKAGE POLAR_EQUAL IS NEW EQUALITY_OPERATOR
(POLAR_COORD, EQUAL);
FUNCTION "=" (L, R : POLAR_COORD) RETURN BOOLEAN
RENAMES POLAR_EQUAL."=";
END POLAR_COORDINATES;
 
PACKAGE BODY POLAR_COORDINATES IS
FUNCTION EQUAL (L, R : POLAR_COORD) RETURN BOOLEAN IS
BEGIN
RETURN (L.THETA MOD 360) = (R.THETA MOD 360) AND
L.R = R.R;
END EQUAL;
END POLAR_COORDINATES;
 
USE POLAR_COORDINATES;
 
PACKAGE VARIABLES IS
P270 : POLAR_COORD := (R => 3, THETA => 270);
P360 : POLAR_COORD := (R => 3, THETA => IDENT_INT(360));
END VARIABLES;
 
USE VARIABLES;
 
BEGIN
 
IF P270 /= (3, -90) THEN
FAILED ("INCORRECT INEQUALITY OPERATOR");
END IF;
 
IF P360 = (3, 0) THEN
NULL;
ELSE
FAILED ("INCORRECT EQUALITY OPERATOR");
END IF;
 
RESULT;
 
END;
END C67005A;
/c64106b.ada
0,0 → 1,237
-- C64106B.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 ASSIGNMENTS TO FORMAL PARAMETERS OF UNCONSTRAINED RECORD,
-- PRIVATE, AND LIMITED PRIVATE TYPES WITHOUT DEFAULT CONSTRAINTS
-- RAISE CONSTRAINT_ERROR IF AN ATTEMPT IS MADE TO CHANGE THE
-- CONSTRAINT OF THE ACTUAL PARAMETER.
-- SUBTESTS ARE:
-- (A) RECORD TYPE.
-- (B) PRIVATE TYPE.
-- (C) LIMITED PRIVATE TYPE.
 
-- DAS 1/15/81
-- CPP 8/9/84
 
WITH REPORT;
PROCEDURE C64106B IS
 
USE REPORT;
 
BEGIN
 
TEST ("C64106B", "CHECK ASSIGNMENT TO FORMAL PARAMETERS OF " &
"UNCONSTRAINED TYPE (WITH NO DEFAULT)");
 
--------------------------------------------------
 
DECLARE -- (A)
 
PACKAGE PKG IS
 
TYPE RECTYPE (CONSTRAINT : INTEGER) IS
RECORD
INTFIELD : INTEGER;
STRFIELD : STRING (1..CONSTRAINT);
END RECORD;
 
PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE;
REC6 : IN OUT RECTYPE);
END PKG;
 
REC9 : PKG.RECTYPE(IDENT_INT(9)) :=
(IDENT_INT(9), 9, "123456789");
REC6 : PKG.RECTYPE(IDENT_INT(6)) :=
(IDENT_INT(6), 5, "AEIOUY");
 
PACKAGE BODY PKG IS
 
PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE;
REC6 : IN OUT RECTYPE) IS
 
REC4 : CONSTANT RECTYPE(IDENT_INT(4)) :=
(IDENT_INT(4), 4, "OOPS");
 
BEGIN
BEGIN -- (A.1)
REC9 := REC6;
FAILED ("CONSTRAINT_ERROR NOT RAISED - A.1");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - A.1");
END; -- (A.1)
 
BEGIN -- (A.2)
REC6 := REC4;
FAILED ("CONSTRAINT_ERROR NOT RAISED - A.2");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - A.2");
END; -- (A.2)
 
REC9 := (IDENT_INT(9), 9, "987654321");
 
END CHK_RECTYPE;
END PKG;
 
BEGIN -- (A)
 
PKG.CHK_RECTYPE (REC9, REC6);
IF REC9.STRFIELD /= IDENT_STR("987654321") THEN
FAILED ("ASSIGNMENT TO REC9 FAILED - (A)");
END IF;
 
END; -- (A)
 
--------------------------------------------------
 
DECLARE -- (B)
 
PACKAGE PKG IS
 
TYPE RECTYPE (CONSTRAINT : INTEGER) IS PRIVATE;
 
PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE;
REC6 : IN OUT RECTYPE);
PRIVATE
TYPE RECTYPE (CONSTRAINT : INTEGER) IS
RECORD
INTFIELD : INTEGER;
STRFIELD : STRING (1..CONSTRAINT);
END RECORD;
END PKG;
 
REC9 : PKG.RECTYPE(9);
REC6 : PKG.RECTYPE(6);
 
PACKAGE BODY PKG IS
 
PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE;
REC6 : IN OUT RECTYPE) IS
 
REC4 : CONSTANT RECTYPE(4) := (4, 4, "OOPS");
 
BEGIN
BEGIN -- (B.1)
REC9 := REC6;
FAILED ("CONSTRAINT_ERROR NOT RAISED - B.1");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - B.1");
END; -- (B.1)
 
BEGIN -- (B.2)
REC6 := REC4;
FAILED ("CONSTRAINT_ERROR NOT RAISED - B.2");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - B.2");
END; -- (B.2)
END CHK_RECTYPE;
 
BEGIN
REC9 := (9, 9, "123456789");
REC6 := (6, 5, "AEIOUY");
END PKG;
 
BEGIN -- (B)
 
PKG.CHK_RECTYPE (REC9, REC6);
 
END; -- (B)
 
--------------------------------------------------
 
DECLARE -- (C)
 
PACKAGE PKG IS
 
TYPE RECTYPE (CONSTRAINT : INTEGER) IS LIMITED PRIVATE;
 
PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE;
REC6 : IN OUT RECTYPE);
PRIVATE
TYPE RECTYPE (CONSTRAINT : INTEGER) IS
RECORD
INTFIELD : INTEGER;
STRFIELD : STRING (1..CONSTRAINT);
END RECORD;
END PKG;
 
REC6 : PKG.RECTYPE(IDENT_INT(6));
REC9 : PKG.RECTYPE(IDENT_INT(9));
 
PACKAGE BODY PKG IS
 
PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE;
REC6 : IN OUT RECTYPE) IS
 
REC4 : CONSTANT RECTYPE(4) := (4, 4, "OOPS");
 
BEGIN
BEGIN -- (C.1)
REC9 := REC6;
FAILED ("CONSTRAINT_ERROR NOT RAISED - C.1");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - C.1");
END; -- (C.1)
 
BEGIN -- (C.2)
REC6 := REC4;
FAILED ("CONSTRAINT_ERROR NOT RAISED - C.2");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - C.2");
END; -- (C.2)
END CHK_RECTYPE;
 
BEGIN
REC6 := (6, 5, "AEIOUY");
REC9 := (9, 9, "123456789");
END PKG;
 
BEGIN -- (C)
 
PKG.CHK_RECTYPE (REC9, REC6);
 
END; -- (C)
 
--------------------------------------------------
 
RESULT;
 
END C64106B;
/c67005b.ada
0,0 → 1,124
-- C67005B.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 IF EQUALITY IS REDEFINED FOR A SCALAR TYPE, CASE
-- STATEMENTS STILL USE THE PREDEFINED EQUALITY OPERATION.
 
-- JBG 9/28/83
 
WITH REPORT; USE REPORT;
PROCEDURE C67005B IS
 
GENERIC
TYPE LP IS LIMITED PRIVATE;
WITH FUNCTION EQUAL (L, R : LP) RETURN BOOLEAN;
PACKAGE EQUALITY_OPERATOR IS
FUNCTION "=" (L, R : LP) RETURN BOOLEAN;
END EQUALITY_OPERATOR;
PACKAGE BODY EQUALITY_OPERATOR IS
FUNCTION "=" (L, R : LP) RETURN BOOLEAN IS
BEGIN
RETURN EQUAL(L, R);
END "=";
END EQUALITY_OPERATOR;
 
BEGIN
TEST ("C67005B", "CHECK THAT REDEFINING EQUALITY FOR A " &
"SCALAR TYPE DOES NOT AFFECT CASE STATEMENTS");
 
DECLARE
TYPE MY IS NEW INTEGER;
CHECK : MY;
 
VAR : INTEGER RANGE 1..3 := 3;
 
PACKAGE INTEGER_EQUALS IS
FUNCTION EQUAL (L, R : INTEGER) RETURN BOOLEAN;
PACKAGE INTEGER_EQUAL IS NEW EQUALITY_OPERATOR
(INTEGER, EQUAL);
END INTEGER_EQUALS;
 
FUNCTION "=" (L, R : INTEGER) RETURN BOOLEAN RENAMES
INTEGER_EQUALS.INTEGER_EQUAL."=";
 
PACKAGE BODY INTEGER_EQUALS IS
FUNCTION EQUAL (L, R : INTEGER) RETURN BOOLEAN IS
BEGIN
RETURN FALSE;
END EQUAL;
END INTEGER_EQUALS;
 
BEGIN
 
IF VAR = 3 THEN
FAILED ("DID NOT USE REDEFINED '=' - 1");
END IF;
 
IF VAR /= 3 THEN
NULL;
ELSE
FAILED ("DID NOT USE REDEFINED '/=' - 1");
END IF;
 
IF VAR = IDENT_INT(3) THEN
FAILED ("DID NOT USE REDEFINED '=' - 2");
END IF;
 
IF VAR /= IDENT_INT(3) THEN
NULL;
ELSE
FAILED ("DID NOT USE REDEFINED '/=' - 2");
END IF;
 
CHECK := MY(IDENT_INT(0));
IF CHECK /= 0 THEN
FAILED ("USING WRONG EQUALITY FOR DERIVED TYPE");
END IF;
 
CASE VAR IS
WHEN 1..3 => CHECK := MY(IDENT_INT(1));
WHEN OTHERS => NULL;
END CASE;
 
IF CHECK /= 1 THEN
FAILED ("DID NOT USE PREDEFINED EQUALS IN CASE - 1");
END IF;
 
CASE IDENT_INT(VAR) IS
WHEN 1 => CHECK := 4;
WHEN 2 => CHECK := 5;
WHEN 3 => CHECK := 6;
WHEN OTHERS => CHECK := 7;
END CASE;
 
IF CHECK /= 6 THEN
FAILED ("DID NOT USE PREDEFINED EQUALS IN CASE - 2");
END IF;
 
END;
 
RESULT;
 
END C67005B;
/c64106c.ada
0,0 → 1,309
-- C64106C.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 ASSIGNMENTS TO FORMAL PARAMETERS OF UNCONSTRAINED
-- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH DEFAULT
-- CONSTRAINTS RAISE CONSTRAINT_ERROR IF THE ACTUAL PARAMETER IS
-- CONSTRAINED AND THE CONSTRAINT VALUES OF THE OBJECT BEING
-- ASSIGNED TO DO NOT SATISFY THOSE OF THE ACTUAL PARAMETER.
 
-- SUBTESTS ARE:
-- (A) CONSTRAINED ACTUAL PARAMETERS OF RECORD TYPE.
-- (B) CONSTRAINED ACTUAL PARAMETERS OF PRIVATE TYPE.
-- (C) CONSTRAINED ACTUAL PARAMETERS OF LIMITED PRIVATE TYPE.
 
-- DAS 1/16/81
-- VKG 1/7/83
-- CPP 8/9/84
 
WITH REPORT;
PROCEDURE C64106C IS
 
USE REPORT;
 
BEGIN
 
TEST ("C64106C", "CHECK ASSIGNMENTS TO FORMAL PARAMETERS OF " &
"UNCONSTRAINED TYPES (WITH DEFAULTS)");
 
--------------------------------------------------
 
DECLARE -- (A)
 
PACKAGE PKG IS
 
SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
 
TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
RECORD
INTFLD : INTRANGE;
STRFLD : STRING(1..CONSTRAINT);
END RECORD;
 
REC91,REC92,REC93 : RECTYPE(9);
REC_OOPS : RECTYPE(4);
 
PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
REC3 : OUT RECTYPE);
END PKG;
 
PACKAGE BODY PKG IS
 
PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
REC3 : OUT RECTYPE) IS
 
PROCEDURE P1 (REC11 : IN RECTYPE;
REC12 : IN OUT RECTYPE;
REC13 : OUT RECTYPE) IS
BEGIN
IF (NOT REC11'CONSTRAINED) OR
(REC11.CONSTRAINT /= IDENT_INT(9)) THEN
FAILED ("CONSTRAINT ON RECORD " &
"TYPE IN PARAMETER " &
"NOT RECOGNIZED");
END IF;
 
BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
REC12 := REC_OOPS;
FAILED ("CONSTRAINT ERROR NOT RAISED - " &
"A.1");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - " &
"A.1");
END;
 
BEGIN -- ASSIGNMENT TO OUT PARAMETER
REC13 := REC_OOPS;
FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
"A.2");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - " &
"A.2");
END;
END P1;
 
BEGIN
P1 (REC1, REC2, REC3);
END P;
 
BEGIN
 
REC91 := (9, 9, "123456789");
REC92 := REC91;
REC93 := REC91;
 
REC_OOPS := (4, 4, "OOPS");
 
END PKG;
 
BEGIN -- (A)
 
PKG.P (PKG.REC91, PKG.REC92, PKG.REC93);
 
END; -- (A)
 
--------------------------------------------------
 
DECLARE -- (B)
 
PACKAGE PKG IS
 
SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
 
TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS PRIVATE;
 
PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
REC3 : OUT RECTYPE);
 
PRIVATE
 
TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
RECORD
INTFLD : INTRANGE;
STRFLD : STRING(1..CONSTRAINT);
END RECORD;
END PKG;
 
REC91, REC92, REC93 : PKG.RECTYPE(9);
REC_OOPS : PKG.RECTYPE(4);
 
PACKAGE BODY PKG IS
 
PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
REC3 : OUT RECTYPE) IS
 
PROCEDURE P1 (REC11 : IN RECTYPE;
REC12 : IN OUT RECTYPE;
REC13 : OUT RECTYPE) IS
BEGIN
IF (NOT REC11'CONSTRAINED) OR
(REC11.CONSTRAINT /= IDENT_INT(9)) THEN
FAILED ("CONSTRAINT ON PRIVATE " &
"TYPE IN PARAMETER " &
"NOT RECOGNIZED");
END IF;
 
BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
REC12 := REC_OOPS;
FAILED ("CONSTRAINT ERROR NOT RAISED - " &
"B.1");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - " &
"B.1");
END;
 
BEGIN -- ASSIGNMENT TO OUT PARAMETER
REC13 := REC_OOPS;
FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
"B.2");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - " &
"B.2");
END;
END P1;
 
BEGIN
P1 (REC1, REC2, REC3);
END P;
 
BEGIN
 
REC91 := (9, 9, "123456789");
REC92 := REC91;
REC93 := REC91;
 
REC_OOPS := (4, 4, "OOPS");
 
END PKG;
 
BEGIN -- (B)
 
PKG.P (REC91, REC92, REC93);
 
END; -- (B)
 
--------------------------------------------------
 
DECLARE -- (C)
 
PACKAGE PKG IS
 
SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
 
TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
LIMITED PRIVATE;
 
PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
REC3 : OUT RECTYPE);
 
PRIVATE
 
TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
RECORD
INTFLD : INTRANGE;
STRFLD : STRING(1..CONSTRAINT);
END RECORD;
END PKG;
 
REC91,REC92,REC93 : PKG.RECTYPE(9);
REC_OOPS : PKG.RECTYPE(4);
 
PACKAGE BODY PKG IS
 
PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
REC3 : OUT RECTYPE) IS
 
PROCEDURE P1 (REC11 : IN RECTYPE;
REC12 : IN OUT RECTYPE;
REC13 : OUT RECTYPE) IS
BEGIN
IF (NOT REC11'CONSTRAINED) OR
(REC11.CONSTRAINT /= 9) THEN
FAILED ("CONSTRAINT ON LIMITED PRIVATE " &
"TYPE IN PARAMETER " &
"NOT RECOGNIZED");
END IF;
 
BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
REC12 := REC_OOPS;
FAILED ("CONSTRAINT ERROR NOT RAISED - " &
"C.1");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - " &
"C.1");
END;
 
BEGIN -- ASSIGNMENT TO OUT PARAMETER
REC13 := REC_OOPS;
FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
"C.2");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - " &
"C.2");
END;
END P1;
 
BEGIN
P1 (REC1, REC2, REC3);
END P;
 
BEGIN
 
REC91 := (9, 9, "123456789");
REC92 := REC91;
REC93 := REC91;
 
REC_OOPS := (4, 4, "OOPS");
 
END PKG;
 
BEGIN -- (C)
 
PKG.P (REC91, REC92, REC93);
 
END; -- (C)
 
--------------------------------------------------
 
RESULT;
 
END C64106C;
/c67005c.ada
0,0 → 1,109
-- C67005C.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 DECLARATION OF "=" NEED NOT HAVE PARAMETERS
-- OF A LIMITED TYPE IN A RENAMING DECLARATION. THIS TEST CHECKS
-- ACCESS TYPES.
 
-- BRYCE BARDIN (HUGHES AIRCRAFT) 7/2/84
-- CPP 7/12/84
 
WITH REPORT; USE REPORT;
PROCEDURE C67005C IS
 
GENERIC
TYPE T IS LIMITED PRIVATE;
WITH FUNCTION EQUAL (LEFT, RIGHT : T) RETURN BOOLEAN IS <>;
PACKAGE EQUALITY IS
FUNCTION "=" (LEFT, RIGHT : T) RETURN BOOLEAN;
-- PRAGMA INLINE ("=");
END EQUALITY;
 
PACKAGE BODY EQUALITY IS
FUNCTION "=" (LEFT, RIGHT : T) RETURN BOOLEAN IS
BEGIN
RETURN EQUAL (LEFT, RIGHT);
END "=";
END EQUALITY;
 
PACKAGE STARTER IS
TYPE INT IS PRIVATE;
FUNCTION VALUE_OF (I : INTEGER) RETURN INT;
FUNCTION EQUAL (LEFT, RIGHT : INT) RETURN BOOLEAN;
PRIVATE
TYPE INT IS ACCESS INTEGER;
END STARTER;
 
PACKAGE BODY STARTER IS
FUNCTION VALUE_OF (I : INTEGER) RETURN INT IS
BEGIN
RETURN NEW INTEGER'(I);
END VALUE_OF;
 
FUNCTION EQUAL (LEFT, RIGHT : INT) RETURN BOOLEAN IS
BEGIN
RETURN LEFT.ALL = RIGHT.ALL;
END EQUAL;
END STARTER;
 
PACKAGE ABSTRACTION IS
TYPE INT IS NEW STARTER.INT;
PACKAGE INT_EQUALITY IS NEW EQUALITY (INT, EQUAL);
FUNCTION "=" (LEFT, RIGHT : INT) RETURN BOOLEAN
RENAMES INT_EQUALITY."=";
END ABSTRACTION;
USE ABSTRACTION;
 
BEGIN
 
TEST ("C67005C", "RENAMING OF EQUALITY OPERATOR WITH " &
"NON-LIMITED PARAMETERS");
 
DECLARE
 
I : INT := VALUE_OF(1);
J : INT := VALUE_OF(0);
 
PROCEDURE CHECK (B : BOOLEAN) IS
BEGIN
IF I = J AND B THEN
COMMENT ("I = J");
ELSIF I /= J AND NOT B THEN
COMMENT ("I /= J");
ELSE
FAILED ("WRONG ""="" OPERATOR");
END IF;
END CHECK;
 
BEGIN
 
CHECK(FALSE);
I := VALUE_OF(0);
CHECK(TRUE);
RESULT;
 
END;
 
END C67005C;
/c64106d.ada
0,0 → 1,280
-- C64106D.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 ASSIGNMENTS TO FORMAL PARAMETERS OF UNCONSTRAINED
-- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH DEFAULT
-- CONSTRAINTS DO NOT RAISE CONSTRAINT_ERROR IF THE ACTUAL PARAMETER
-- IS UNCONSTRAINED, EVEN IF THE CONSTRAINT VALUES OF THE OBJECT
-- BEING ASSIGNED ARE DIFFERENT THAN THOSE OF THE ACTUAL PARAMETER.
 
-- SUBTESTS ARE:
-- (A) UNCONSTRAINED ACTUAL PARAMETERS OF RECORD TYPE.
-- (B) UNCONSTRAINED ACTUAL PARAMETERS OF PRIVATE TYPE.
-- (C) UNCONSTRAINED ACTUAL PARAMETERS OF LIMITED PRIVATE TYPE.
 
-- JRK 4/16/81
-- CPP 8/9/84
-- JRK 11/28/84
 
WITH REPORT;
PROCEDURE C64106D IS
 
USE REPORT;
 
BEGIN
 
TEST ("C64106D", "CHECK ASSIGNMENTS TO FORMAL PARAMETERS OF " &
"UNCONSTRAINED TYPES WITH UNCONSTRAINED " &
"ACTUAL PARAMETERS");
 
--------------------------------------------------
 
DECLARE -- (A)
 
PACKAGE PKG IS
 
SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
 
TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
RECORD
INTFLD : INTRANGE;
STRFLD : STRING(1..CONSTRAINT);
END RECORD;
 
PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
REC3 : OUT RECTYPE);
END PKG;
 
REC91, REC92, REC93 : PKG.RECTYPE :=
(IDENT_INT(5), 5, IDENT_STR("12345"));
REC_OOPS : PKG.RECTYPE;
 
PACKAGE BODY PKG IS
 
PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
REC3 : OUT RECTYPE) IS
 
PROCEDURE P1 (REC11 : IN RECTYPE;
REC12 : IN OUT RECTYPE;
REC13 : OUT RECTYPE) IS
BEGIN
 
IF NOT REC11'CONSTRAINED THEN
FAILED ("REC11 IS NOT CONSTRAINED - A.1");
END IF;
IF REC11.CONSTRAINT /= IDENT_INT(9) THEN
FAILED ("REC11 CONSTRAINT IS NOT 9 " &
"- A.1");
END IF;
 
BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
REC12 := REC_OOPS;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED - A.1");
END;
 
BEGIN -- ASSIGNMENT TO OUT PARAMETER
REC13 := REC_OOPS;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED - A.2");
END;
END P1;
 
BEGIN
P1 (REC1, REC2, REC3);
END P;
 
BEGIN
 
REC91 := (9, 9, "123456789");
REC92 := REC91;
REC93 := REC91;
 
REC_OOPS := (4, 4, "OOPS");
 
END PKG;
 
USE PKG;
 
BEGIN -- (A)
 
PKG.P (REC91, REC92, REC93);
IF (REC92 /= REC_OOPS) OR (REC93 /= REC_OOPS) THEN
FAILED ("RESULTANT VALUE OF REC92 OR REC93 INCORRECT");
END IF;
 
END; -- (A)
 
--------------------------------------------------
 
DECLARE -- (B)
 
PACKAGE PKG IS
 
SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
 
TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS PRIVATE;
 
PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
REC3 : OUT RECTYPE);
 
PRIVATE
 
TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
RECORD
INTFLD : INTRANGE;
STRFLD : STRING(1..CONSTRAINT);
END RECORD;
END PKG;
 
REC91, REC92, REC93 : PKG.RECTYPE;
REC_OOPS : PKG.RECTYPE;
 
PACKAGE BODY PKG IS
 
PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
REC3 : OUT RECTYPE) IS
 
PROCEDURE P1 (REC11 : IN RECTYPE;
REC12 : IN OUT RECTYPE;
REC13 : OUT RECTYPE) IS
BEGIN
 
IF REC3'CONSTRAINED THEN
FAILED ("REC3 IS CONSTRAINED - B.1");
END IF;
 
BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
REC12 := REC_OOPS;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED - B.1");
END;
 
BEGIN -- ASSIGNMENT TO OUT PARAMETER
REC13 := REC_OOPS;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED - B.2");
END;
END P1;
 
BEGIN
P1 (REC1, REC2, REC3);
END P;
 
BEGIN
 
REC91 := (9, 9, "123456789");
REC92 := REC91;
REC93 := REC91;
 
REC_OOPS := (4, 4, "OOPS");
 
END PKG;
 
BEGIN -- (B)
 
PKG.P (REC91, REC92, REC93);
 
END; -- (B)
 
--------------------------------------------------
 
DECLARE -- (C)
 
PACKAGE PKG IS
 
SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
 
TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
LIMITED PRIVATE;
 
PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
REC3 : OUT RECTYPE);
 
PRIVATE
 
TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
RECORD
INTFLD : INTRANGE;
STRFLD : STRING(1..CONSTRAINT);
END RECORD;
END PKG;
 
REC91, REC92, REC93 : PKG.RECTYPE;
REC_OOPS : PKG.RECTYPE;
 
PACKAGE BODY PKG IS
 
PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
REC3 : OUT RECTYPE) IS
 
PROCEDURE P1 (REC11 : IN RECTYPE;
REC12 : IN OUT RECTYPE;
REC13 : OUT RECTYPE) IS
BEGIN
 
BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
REC12 := REC_OOPS;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED - C.1");
END;
 
BEGIN -- ASSIGNMENT TO OUT PARAMETER
REC13 := REC_OOPS;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED - C.2");
END;
END P1;
 
BEGIN
P1 (REC1, REC2, REC3);
END P;
 
BEGIN
 
REC91 := (9, 9, "123456789");
REC92 := REC91;
REC93 := REC91;
 
REC_OOPS := (4, 4, "OOPS");
 
END PKG;
 
BEGIN -- (C)
 
PKG.P (REC91, REC92, REC93);
 
END; -- (C)
 
--------------------------------------------------
 
RESULT;
 
END C64106D;
/c67005d.ada
0,0 → 1,78
-- C67005D.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 EQUALITY CAN BE REDEFINED FOR AN ARBITRARY TYPE BY USING A
-- SEQUENCE OF RENAMING DECLARATIONS.
 
-- JBG 9/11/84
 
WITH REPORT; USE REPORT;
PROCEDURE C67005D IS
 
FUNCTION MY_EQUALS (L, R : INTEGER) RETURN BOOLEAN IS
BEGIN
RETURN FALSE;
END MY_EQUALS;
 
GENERIC
TYPE LP IS LIMITED PRIVATE;
WITH FUNCTION "=" (L, R : LP) RETURN BOOLEAN;
PACKAGE EQUALITY_OPERATOR IS
PACKAGE INNER IS
FUNCTION "=" (L, R : LP) RETURN BOOLEAN RENAMES
EQUALITY_OPERATOR."=";
END INNER;
END EQUALITY_OPERATOR;
 
BEGIN
TEST ("C67005D", "CHECK REDEFINITION OF ""="" BY RENAMING");
 
DECLARE
 
CHK1 : BOOLEAN := 3 = IDENT_INT(3); -- PREDEFINED "="
 
-- REDEFINE INTEGER "=".
 
PACKAGE INT_EQUALITY IS NEW
EQUALITY_OPERATOR (INTEGER, MY_EQUALS);
FUNCTION "=" (L, R : INTEGER) RETURN BOOLEAN RENAMES
INT_EQUALITY.INNER."=";
 
CHK2 : BOOLEAN := 3 = IDENT_INT(3); -- REDEFINED "=".
 
BEGIN
 
IF NOT CHK1 THEN
FAILED ("PREDEFINED ""="" NOT USED");
END IF;
 
IF CHK2 THEN
FAILED ("REDEFINED ""="" NOT USED");
END IF;
 
END;
 
RESULT;
 
END C67005D;
/c631001.a
0,0 → 1,134
-- C631001.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 if different forms of a name are used in the default
-- expression of a discriminant part, the selector may be an operator
-- symbol or a character literal.
--
-- TEST DESCRIPTION:
-- This transition test defines private types where their selectors in
-- the default expression of the discriminant parts at the full type
-- declarations are an operator and a literal, respectively.
-- The test also declares procedures that use an operator and a literal
-- as selectors in the formal parts.
--
-- Inspired by B63102A.ADA.
--
--
-- CHANGE HISTORY:
-- 25 Mar 96 SAIC Initial version for ACVC 2.1.
-- 26 Feb 97 PWB.CTA Removed use of function called before elaboration
--!
 
with Report;
 
procedure C631001 is
 
package C631001_0 is
 
type Int_Type is range 1 .. 100;
type Enu_Type is ('A', 'B', 'C', 'D');
 
type Private_Enu (D : Enu_Type := 'B') is private;
 
function "+" (X, Y : Int_Type) return Int_Type;
 
procedure Int_Proc (P1 : in Int_Type := "+" (10, 15);
P2 : out Int_Type);
procedure Enu_Proc (P1 : in Enu_Type := 'C';
P2 : out Enu_Type);
 
private
 
type Private_Enu (D : Enu_Type := C631001_0.'B') is -- OK.
record
C2 : Enu_Type := D;
end record;
 
-----------------------------------------------------------------
PE_Obj : C631001_0.Private_Enu;
 
end C631001_0;
 
--==================================================================--
 
package body C631001_0 is
 
function "+" (X, Y : Int_Type) return Int_Type is
begin
return 10;
end "+";
 
-----------------------------------------------------------------
procedure Int_Proc (P1 : in Int_Type := C631001_0."+" (10, 15); -- OK.
P2 : out Int_Type) is
begin
P2 := P1;
end Int_Proc;
 
-----------------------------------------------------------------
procedure Enu_Proc (P1 : in Enu_Type := C631001_0.'C'; -- OK.
P2 : out Enu_Type) is
begin
P2 := P1;
end Enu_Proc;
 
-----------------------------------------------------------------
 
end C631001_0;
 
---------------------------------------------------------------------------
Int_Obj : C631001_0.Int_Type := 50;
Enu_Obj : C631001_0.Enu_Type := C631001_0.'D';
 
-- Direct visibility to operator symbols
use type C631001_0.Int_Type;
use type C631001_0.Enu_Type;
 
begin -- main
 
Report.Test ("C631001", "Check that if different forms of a name are " &
"used in the default expression of a discriminant part, " &
"the selector may be an operator symbol or a character " &
"literal");
 
C631001_0.Int_Proc (P2 => Int_Obj);
 
if Int_Obj /= 10 then
Report.Failed ("Wrong result for Int_Obj");
end if;
 
C631001_0.Enu_Proc (P2 => Enu_Obj);
 
if Enu_Obj /= 'C' then
Report.Failed ("Wrong result for Enu_Obj");
end if;
 
Report.Result;
 
end C631001;
/c61010a.ada
0,0 → 1,246
-- C61010A.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 IN OR IN OUT FORMAL PARAMETER CAN BE DECLARED WITH A
-- LIMITED PRIVATE TYPE OR A LIMITED COMPOSITE TYPE.
 
-- DAS 1/22/81
-- JRK 1/20/84 TOTALLY REVISED.
 
WITH REPORT; USE REPORT;
PROCEDURE C61010A IS
 
PACKAGE PKG IS
 
TYPE ITYPE IS LIMITED PRIVATE;
 
PROCEDURE LOOK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING);
 
PROCEDURE LOOK_INOUT_I (X : IN OUT ITYPE; V : INTEGER;
M : STRING);
 
PROCEDURE SET_I (X : IN OUT ITYPE; V : INTEGER);
 
SUBTYPE INT_0_20 IS INTEGER RANGE 0 .. 20;
TYPE VRTYPE (C : INT_0_20 := 20) IS LIMITED PRIVATE;
 
PROCEDURE LOOK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER;
S : STRING; M : STRING);
 
PROCEDURE LOOK_INOUT_VR (X : IN OUT VRTYPE; C : INTEGER;
I : INTEGER; S : STRING;
M : STRING);
 
PROCEDURE SET_VR (X : IN OUT VRTYPE; C : INTEGER; I : INTEGER;
S : STRING);
 
PRIVATE
 
TYPE ITYPE IS NEW INTEGER RANGE 0 .. 99;
 
TYPE VRTYPE (C : INT_0_20 := 20) IS
RECORD
I : INTEGER;
S : STRING (1 .. C);
END RECORD;
 
END PKG;
 
USE PKG;
 
I1 : ITYPE;
 
TYPE ATYPE IS ARRAY (1 .. 3) OF ITYPE;
 
A1 : ATYPE;
 
VR1 : VRTYPE;
 
D : CONSTANT INT_0_20 := 10;
 
TYPE RTYPE IS
RECORD
J : ITYPE;
R : VRTYPE (D);
END RECORD;
 
R1 : RTYPE;
 
PACKAGE BODY PKG IS
 
PROCEDURE LOOK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING) IS
BEGIN
IF INTEGER (X) /= V THEN
FAILED ("WRONG SCALAR VALUE - " & M);
END IF;
END LOOK_IN_I;
 
PROCEDURE LOOK_INOUT_I (X : IN OUT ITYPE; V : INTEGER;
M : STRING) IS
BEGIN
IF INTEGER (X) /= V THEN
FAILED ("WRONG SCALAR VALUE - " & M);
END IF;
END LOOK_INOUT_I;
 
PROCEDURE SET_I (X : IN OUT ITYPE; V : INTEGER) IS
BEGIN
X := ITYPE (IDENT_INT (V));
END SET_I;
 
PROCEDURE LOOK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER;
S : STRING; M : STRING) IS
BEGIN
IF (X.C /= C OR X.I /= I) OR ELSE X.S /= S THEN
FAILED ("WRONG COMPOSITE VALUE - " & M);
END IF;
END LOOK_IN_VR;
 
PROCEDURE LOOK_INOUT_VR (X : IN OUT VRTYPE; C : INTEGER;
I : INTEGER; S : STRING;
M : STRING) IS
BEGIN
IF (X.C /= C OR X.I /= I) OR ELSE X.S /= S THEN
FAILED ("WRONG COMPOSITE VALUE - " & M);
END IF;
END LOOK_INOUT_VR;
 
PROCEDURE SET_VR (X : IN OUT VRTYPE; C : INTEGER; I : INTEGER;
S : STRING) IS
BEGIN
X := (IDENT_INT(C), IDENT_INT(I), IDENT_STR(S));
END SET_VR;
 
BEGIN
I1 := ITYPE (IDENT_INT(2));
 
FOR I IN A1'RANGE LOOP
A1 (I) := ITYPE (3 + IDENT_INT(I));
END LOOP;
 
VR1 := (IDENT_INT(5), IDENT_INT(4), IDENT_STR("01234"));
 
R1.J := ITYPE (IDENT_INT(6));
R1.R := (IDENT_INT(D), IDENT_INT(19),
IDENT_STR("ABCDEFGHIJ"));
END PKG;
 
PROCEDURE CHECK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING) IS
BEGIN
LOOK_IN_I (X, V, M);
END CHECK_IN_I;
 
PROCEDURE CHECK_INOUT_I (X : IN OUT ITYPE; OV : INTEGER;
NV : INTEGER; M : STRING) IS
BEGIN
LOOK_INOUT_I (X, OV, M & " - A");
SET_I (X, NV);
LOOK_INOUT_I (X, NV, M & " - B");
LOOK_IN_I (X, NV, M & " - C");
END CHECK_INOUT_I;
 
PROCEDURE CHECK_IN_A (X : IN ATYPE; V : INTEGER; M : STRING) IS
BEGIN
FOR I IN X'RANGE LOOP
LOOK_IN_I (X(I), V+I, M & " -" & INTEGER'IMAGE (I));
END LOOP;
END CHECK_IN_A;
 
PROCEDURE CHECK_INOUT_A (X : IN OUT ATYPE; OV : INTEGER;
NV : INTEGER; M : STRING) IS
BEGIN
FOR I IN X'RANGE LOOP
LOOK_INOUT_I (X(I), OV+I, M & " - A" &
INTEGER'IMAGE (I));
SET_I (X(I), NV+I);
LOOK_INOUT_I (X(I), NV+I, M & " - B" &
INTEGER'IMAGE (I));
LOOK_IN_I (X(I), NV+I, M & " - C" & INTEGER'IMAGE (I));
END LOOP;
END CHECK_INOUT_A;
 
PROCEDURE CHECK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER;
S : STRING; M : STRING) IS
BEGIN
LOOK_IN_VR (X, C, I, S, M);
END CHECK_IN_VR;
 
PROCEDURE CHECK_INOUT_VR (X : IN OUT VRTYPE;
OC : INTEGER; OI : INTEGER; OS : STRING;
NC : INTEGER; NI : INTEGER; NS : STRING;
M : STRING) IS
BEGIN
LOOK_INOUT_VR (X, OC, OI, OS, M & " - A");
SET_VR (X, NC, NI, NS);
LOOK_INOUT_VR (X, NC, NI, NS, M & " - B");
LOOK_IN_VR (X, NC, NI, NS, M & " - C");
END CHECK_INOUT_VR;
 
PROCEDURE CHECK_IN_R (X : IN RTYPE; J : INTEGER; C : INTEGER;
I : INTEGER; S : STRING; M : STRING) IS
BEGIN
LOOK_IN_I (X.J, J, M & " - A");
LOOK_IN_VR (X.R, C, I, S, M & " - B");
END CHECK_IN_R;
 
PROCEDURE CHECK_INOUT_R (X : IN OUT RTYPE; OJ : INTEGER;
OC : INTEGER; OI : INTEGER; OS : STRING;
NJ : INTEGER;
NC : INTEGER; NI : INTEGER; NS : STRING;
M : STRING) IS
BEGIN
LOOK_INOUT_I (X.J, OJ, M & " - A");
LOOK_INOUT_VR (X.R, OC, OI, OS, M & " - B");
SET_I (X.J, NJ);
SET_VR (X.R, NC, NI, NS);
LOOK_INOUT_I (X.J, NJ, M & " - C");
LOOK_INOUT_VR (X.R, NC, NI, NS, M & " - D");
LOOK_IN_I (X.J, NJ, M & " - E");
LOOK_IN_VR (X.R, NC, NI, NS, M & " - F");
END CHECK_INOUT_R;
 
BEGIN
TEST ("C61010A", "CHECK THAT LIMITED PRIVATE/COMPOSITE TYPES " &
"CAN BE USED AS IN OR IN OUT FORMAL PARAMETERS");
 
CHECK_IN_I (I1, 2, "IN I");
 
CHECK_INOUT_I (I1, 2, 5, "INOUT I");
 
CHECK_IN_A (A1, 3, "IN A");
 
CHECK_INOUT_A (A1, 3, 17, "INOUT A");
 
CHECK_IN_VR (VR1, 5, 4, "01234", "IN VR");
 
CHECK_INOUT_VR (VR1, 5, 4, "01234", 10, 11, "9876543210",
"INOUT VR");
 
CHECK_IN_R (R1, 6, D, 19, "ABCDEFGHIJ", "IN R");
 
CHECK_INOUT_R (R1, 6, D, 19, "ABCDEFGHIJ", 13, D, 5, "ZYXWVUTSRQ",
"INOUT R");
 
RESULT;
END C61010A;
/c62002a.ada
0,0 → 1,190
-- C62002A.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 COMPONENTS OF ACCESS IN PARAMETERS CAN BE USED AS THE
-- TARGET OF AN ASSIGNMENT STATEMENT OR AS AN ACTUAL PARAMETER OF
-- ANY MODE. SUBTESTS ARE:
-- (A) INTEGER ACCESS TYPE.
-- (B) ARRAY ACCESS TYPE.
-- (C) RECORD ACCESS TYPE.
 
-- DAS 1/23/81
-- SPS 10/26/82
 
WITH REPORT;
PROCEDURE C62002A IS
 
USE REPORT;
 
BEGIN
 
TEST ("C62002A", "CHECK THAT COMPONENTS OF ACCESS IN PARAMETERS" &
" MAY BE USED IN ASSIGNMENT CONTEXTS");
 
--------------------------------------------------
 
DECLARE -- (A)
 
TYPE PTRINT IS ACCESS INTEGER;
PI : PTRINT;
 
PROCEDURE PROCA (PI : IN PTRINT) IS
 
PROCEDURE PROCA1 (I : OUT INTEGER) IS
BEGIN
I := 7;
END PROCA1;
 
PROCEDURE PROCA2 (I : IN OUT INTEGER) IS
BEGIN
I := I + 1;
END PROCA2;
BEGIN
 
PROCA1 (PI.ALL);
PROCA2 (PI.ALL);
PI.ALL := PI.ALL + 1;
IF (PI.ALL /= 9) THEN
FAILED ("ASSIGNMENT TO COMPONENT OF INTEGER" &
" ACCESS PARAMETER FAILED");
END IF;
END PROCA;
 
BEGIN -- (A)
 
PI := NEW INTEGER '(0);
PROCA (PI);
 
END; -- (A)
 
---------------------------------------------
 
DECLARE -- (B)
 
TYPE TBL IS ARRAY (1..3) OF INTEGER;
TYPE PTRTBL IS ACCESS TBL;
PT : PTRTBL;
 
PROCEDURE PROCB (PT : IN PTRTBL) IS
 
PROCEDURE PROCB1 (I : OUT INTEGER) IS
BEGIN
I := 7;
END PROCB1;
 
PROCEDURE PROCB2 (I : IN OUT INTEGER) IS
BEGIN
I := I + 1;
END PROCB2;
 
PROCEDURE PROCB3 (T : OUT TBL) IS
BEGIN
T := (1,2,3);
END PROCB3;
 
PROCEDURE PROCB4 (T : IN OUT TBL) IS
BEGIN
T(3) := T(3) - 1;
END PROCB4;
 
BEGIN
 
PROCB3 (PT.ALL); -- (1,2,3)
PROCB4 (PT.ALL); -- (1,2,2)
PROCB1 (PT(2)); -- (1,7,2)
PROCB2 (PT(1)); -- (2,7,2)
PT(3) := PT(3) + 7; -- (2,7,9)
IF (PT.ALL /= (2,7,9)) THEN
FAILED ("ASSIGNMENT TO COMPONENT OF ARRAY" &
" ACCESS PARAMETER FAILED");
END IF;
END PROCB;
 
BEGIN -- (B)
 
PT := NEW TBL '(0,0,0);
PROCB (PT);
 
END; -- (B)
 
---------------------------------------------
 
DECLARE -- (C)
 
TYPE REC IS
RECORD
I1 : INTEGER;
I2 : INTEGER;
I3 : INTEGER;
END RECORD;
TYPE PTRREC IS ACCESS REC;
PR : PTRREC;
 
PROCEDURE PROCC (PR : IN PTRREC) IS
 
PROCEDURE PROCC1 (I : OUT INTEGER) IS
BEGIN
I := 7;
END PROCC1;
 
PROCEDURE PROCC2 (I : IN OUT INTEGER) IS
BEGIN
I := I + 1;
END PROCC2;
 
PROCEDURE PROCC3 (R : OUT REC) IS
BEGIN
R := (1,2,3);
END PROCC3;
 
PROCEDURE PROCC4 (R : IN OUT REC) IS
BEGIN
R.I3 := R.I3 - 1;
END PROCC4;
 
BEGIN
 
PROCC3 (PR.ALL); -- (1,2,3)
PROCC4 (PR.ALL); -- (1,2,2)
PROCC1 (PR.I2); -- (1,7,2)
PROCC2 (PR.I1); -- (2,7,2)
PR.I3 := PR.I3 + 7; -- (2,7,9)
IF (PR.ALL /= (2,7,9)) THEN
FAILED ("ASSIGNMENT TO COMPONENT OF RECORD" &
" ACCESS PARAMETER FAILED");
END IF;
END PROCC;
 
BEGIN -- (C)
 
PR := NEW REC '(0,0,0);
PROCC (PR);
 
END; -- (C)
 
---------------------------------------------
 
RESULT;
 
END C62002A;
/c64002b.ada
0,0 → 1,65
-- C64002B.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 PARAMETERLESS SUBPROGRAMS CAN BE CALLED WITH APPROPRIATE
-- NOTATION.
 
-- DAS 1/27/81
-- SPS 10/26/82
 
WITH REPORT;
PROCEDURE C64002B IS
 
USE REPORT;
 
I : INTEGER := 1;
 
FUNCTION F0 RETURN INTEGER IS
BEGIN
RETURN 7;
END F0;
 
PROCEDURE P0 IS
BEGIN
I := 15;
END P0;
 
BEGIN
 
TEST ("C64002B", "CHECK THAT PARAMETERLESS SUBPROGRAMS CAN BE" &
" CALLED");
 
IF (F0 /= 7) THEN
FAILED ("PARAMETERLESS FUNCTION CALL RETURNS BAD VALUE");
END IF;
 
P0;
IF (I /= 15) THEN
FAILED ("PARAMETERLESS PROCEDURE CALL YIELDS INCORRECT" &
" RESULT");
END IF;
 
RESULT;
 
END C64002B;
/c66002a.ada
0,0 → 1,104
-- C66002A.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 OVERLOADED SUBPROGRAM DECLARATIONS
-- ARE PERMITTED IN WHICH THERE IS A MINIMAL
-- DIFFERENCE BETWEEN THE DECLARATIONS.
 
-- (A) ONE SUBPROGRAM IS A FUNCTION; THE OTHER IS A PROCEDURE.
 
-- CVP 5/4/81
-- JRK 5/8/81
-- NL 10/13/81
-- SPS 11/2/82
 
WITH REPORT;
PROCEDURE C66002A IS
 
USE REPORT;
 
BEGIN
TEST ("C66002A", "SUBPROGRAM OVERLOADING WITH " &
"MINIMAL DIFFERENCES ALLOWED");
 
--------------------------------------------------
 
-- ONE SUBPROGRAM IS A PROCEDURE; THE OTHER IS
-- A FUNCTION. BOTH PARAMETERIZED AND PARAMETERLESS
-- SUBPROGRAMS ARE TESTED.
 
DECLARE
I, J, K : INTEGER := 0;
S : STRING (1..2) := "12";
 
PROCEDURE P1 (I1, I2 : INTEGER) IS
BEGIN
S(1) := 'A';
END P1;
 
FUNCTION P1 (I1, I2 : INTEGER) RETURN INTEGER IS
BEGIN
S(2) := 'B';
RETURN I1; -- RETURNED VALUE IS IRRELEVENT.
END P1;
 
PROCEDURE P2 IS
BEGIN
S(1) := 'C';
END P2;
 
FUNCTION P2 RETURN INTEGER IS
BEGIN
S(2) := 'D';
RETURN I; -- RETURNED VALUE IS IRRELEVENT.
END P2;
 
BEGIN
P1 (I, J);
K := P1 (I, J);
 
IF S /= "AB" THEN
FAILED ("PARAMETERIZED OVERLOADED " &
"SUBPROGRAMS, ONE A PROCEDURE AND " &
"THE OTHER A FUNCTION, CAUSED " &
"CONFUSION");
END IF;
 
S := "12";
P2;
K := P2 ;
 
IF S /= "CD" THEN
FAILED ("PARAMETERLESS OVERLOADED " &
"SUBPROGRAMS, ONE A PROCEDURE AND " &
"THE OTHER A FUNCTION, CAUSED " &
"CONFUSION");
END IF;
END;
 
--------------------------------------------------
 
RESULT;
 
END C66002A;
/c62006a.ada
0,0 → 1,70
-- C62006A.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 DISCRIMINANTS OF AN OUT FORMAL PARAMETER, AS WELL AS
-- THE DISCRIMINANTS OF THE SUBCOMPONENTS OF AN OUT FORMAL PARAMETER,
-- MAY BE READ INSIDE THE PROCEDURE.
 
-- SPS 2/17/84
 
WITH REPORT; USE REPORT;
PROCEDURE C62006A IS
BEGIN
 
TEST ("C62006A", "CHECK THAT THE DISCRIMINANTS OF AN OUT FORMAL " &
"PARAMETER CAN BE READ INSIDE THE PROCEDURE");
 
DECLARE
 
TYPE R1 (D1 : INTEGER) IS RECORD
NULL;
END RECORD;
 
TYPE R2 (D2 : POSITIVE) IS RECORD
C : R1 (2);
END RECORD;
 
R : R2 (5);
 
PROCEDURE P (REC : OUT R2) IS
BEGIN
 
IF REC.D2 /= 5 THEN
FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT OF" &
" OUT PARAMETER");
END IF;
 
IF REC.C.D1 /= 2 THEN
FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " &
" OF THE SUBCOMPONENT OF AN OUT PARAMETER");
END IF;
END P;
 
BEGIN
P (R);
END;
 
RESULT;
 
END C62006A;
/c67002a.ada
0,0 → 1,426
-- C67002A.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 OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED)
-- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS.
-- SUBTESTS ARE:
-- (A) THROUGH (P): "=", "AND", "OR", "XOR", "<", "<=",
-- ">", ">=", "&", "*", "/", "MOD", "REM", "**", "+", "-",
-- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS.
-- (Q), (R), (S), AND (T): "+", "-", "NOT", "ABS", RESPECTIVELY,
-- WITH ONE PARAMETER.
 
-- CVP 5/7/81
-- JRK 6/1/81
-- CPP 6/25/84
 
WITH REPORT;
PROCEDURE C67002A IS
 
USE REPORT;
 
BEGIN
TEST ("C67002A", "USE OF OPERATOR SYMBOLS IN " &
"(OVERLOADED) FUNCTION SPECIFICATIONS");
 
-------------------------------------------------
 
DECLARE -- (A)
PACKAGE EQU IS
TYPE LP IS LIMITED PRIVATE;
FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN;
PRIVATE
TYPE LP IS NEW INTEGER;
END EQU;
USE EQU;
 
LP1, LP2 : LP;
 
PACKAGE BODY EQU IS
FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN IS
BEGIN
RETURN LPA > LPB;
END "=";
BEGIN
LP1 := LP (IDENT_INT (7));
LP2 := LP (IDENT_INT (8));
END EQU;
 
BEGIN -- (A)
IF (LP1 = LP2) OR NOT (LP2 = LP1) OR
(LP1 = LP1) OR (LP2 /= LP1) THEN
FAILED ("OVERLOADING OF ""="" OPERATOR DEFECTIVE");
END IF;
END; -- (A)
 
-------------------------------------------------
 
DECLARE -- (B)
FUNCTION "AND" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END "AND";
 
BEGIN -- (B)
IF (IDENT_INT (10) AND 1) /= 'G' OR
(5 AND 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""AND"" OPERATOR DEFECTIVE");
END IF;
END; -- (B)
 
-------------------------------------------------
 
DECLARE -- (C)
FUNCTION "OR" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END "OR";
 
BEGIN -- (C)
IF (IDENT_INT (10) OR 1) /= 'G' OR
(5 OR 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""OR"" OPERATOR DEFECTIVE");
END IF;
END; -- (C)
 
-------------------------------------------------
 
DECLARE -- (D)
FUNCTION "XOR" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END "XOR";
 
BEGIN -- (D)
IF (IDENT_INT (10) XOR 1) /= 'G' OR
(5 XOR 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""XOR"" OPERATOR DEFECTIVE");
END IF;
END; -- (D)
 
-------------------------------------------------
 
DECLARE -- (E)
FUNCTION "<" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END "<";
 
BEGIN -- (E)
IF (IDENT_INT (10) < 1) /= 'G' OR
(5 < 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""<"" OPERATOR DEFECTIVE");
END IF;
END; -- (E)
 
-------------------------------------------------
 
DECLARE -- (F)
FUNCTION "<=" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END "<=";
 
BEGIN -- (F)
IF (IDENT_INT (10) <= 1) /= 'G' OR
(5 <= 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""<="" OPERATOR DEFECTIVE");
END IF;
END; -- (F)
 
-------------------------------------------------
 
DECLARE -- (G)
FUNCTION ">" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END ">";
 
BEGIN -- (G)
IF (IDENT_INT (10) > 1) /= 'G' OR
(5 > 10) /= 'L' THEN
FAILED ("OVERLOADING OF "">"" OPERATOR DEFECTIVE");
END IF;
END; -- (G)
 
-------------------------------------------------
 
DECLARE -- (H)
FUNCTION ">=" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END ">=";
 
BEGIN -- (H)
IF (IDENT_INT (10) >= 1) /= 'G' OR
(5 >= 10) /= 'L' THEN
FAILED ("OVERLOADING OF "">="" OPERATOR DEFECTIVE");
END IF;
END; -- (H)
 
-------------------------------------------------
 
DECLARE -- (I)
FUNCTION "&" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END "&";
 
BEGIN -- (I)
IF (IDENT_INT (10) & 1) /= 'G' OR
(5 & 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""&"" OPERATOR DEFECTIVE");
END IF;
END; -- (I)
 
-------------------------------------------------
 
DECLARE -- (J)
FUNCTION "*" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END "*";
 
BEGIN -- (J)
IF (IDENT_INT (10) * 1) /= 'G' OR
(5 * 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""*"" OPERATOR DEFECTIVE");
END IF;
END; -- (J)
 
-------------------------------------------------
 
DECLARE -- (K)
FUNCTION "/" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END "/";
 
BEGIN -- (K)
IF (IDENT_INT (10) / 1) /= 'G' OR
(5 / 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""/"" OPERATOR DEFECTIVE");
END IF;
END; -- (K)
 
-------------------------------------------------
 
DECLARE -- (L)
FUNCTION "MOD" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END "MOD";
 
BEGIN -- (L)
IF (IDENT_INT (10) MOD 1) /= 'G' OR
(5 MOD 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""MOD"" OPERATOR DEFECTIVE");
END IF;
END; -- (L)
 
-------------------------------------------------
 
DECLARE -- (M)
FUNCTION "REM" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END "REM";
 
BEGIN -- (M)
IF (IDENT_INT (10) REM 1) /= 'G' OR
(5 REM 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE");
END IF;
END; -- (M)
 
-------------------------------------------------
 
DECLARE -- (N)
FUNCTION "**" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END "**";
 
BEGIN -- (N)
IF (IDENT_INT (10) ** 1) /= 'G' OR
(5 ** 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""**"" OPERATOR DEFECTIVE");
END IF;
END; -- (N)
 
-------------------------------------------------
 
DECLARE -- (O)
FUNCTION "+" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END "+";
 
BEGIN -- (O)
IF (IDENT_INT (10) + 1) /= 'G' OR
(5 + 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""+"" OPERATOR DEFECTIVE");
END IF;
END; -- (O)
 
-------------------------------------------------
 
DECLARE -- (P)
FUNCTION "-" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END "-";
 
BEGIN -- (P)
IF (IDENT_INT (10) - 1) /= 'G' OR
(5 - 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""-"" OPERATOR DEFECTIVE");
END IF;
END; -- (P)
 
-------------------------------------------------
 
DECLARE -- (Q)
FUNCTION "+" (I1 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 < IDENT_INT (0) THEN
RETURN 'N';
ELSE RETURN 'P';
END IF;
END "+";
 
BEGIN -- (Q)
IF (+ IDENT_INT(25) /= 'P') OR
(+ (0-25) /= 'N') THEN
FAILED ("OVERLOADING OF ""+"" " &
"OPERATOR (ONE OPERAND) DEFECTIVE");
END IF;
END; -- (Q)
 
-------------------------------------------------
 
DECLARE -- (R)
FUNCTION "-" (I1 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 < IDENT_INT (0) THEN
RETURN 'N';
ELSE RETURN 'P';
END IF;
END "-";
 
BEGIN -- (R)
IF (- IDENT_INT(25) /= 'P') OR
(- (0-25) /= 'N') THEN
FAILED ("OVERLOADING OF ""-"" " &
"OPERATOR (ONE OPERAND) DEFECTIVE");
END IF;
END; -- (R)
 
-------------------------------------------------
 
DECLARE -- (S)
FUNCTION "NOT" (I1 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 < IDENT_INT (0) THEN
RETURN 'N';
ELSE RETURN 'P';
END IF;
END "NOT";
 
BEGIN -- (S)
IF (NOT IDENT_INT(25) /= 'P') OR
(NOT (0-25) /= 'N') THEN
FAILED ("OVERLOADING OF ""NOT"" " &
"OPERATOR (ONE OPERAND) DEFECTIVE");
END IF;
END; -- (S)
 
-------------------------------------------------
 
DECLARE -- (T)
FUNCTION "ABS" (I1 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 < IDENT_INT (0) THEN
RETURN 'N';
ELSE RETURN 'P';
END IF;
END "ABS";
 
BEGIN -- (T)
IF (ABS IDENT_INT(25) /= 'P') OR
(ABS (0-25) /= 'N') THEN
FAILED ("OVERLOADING OF ""ABS"" " &
"OPERATOR (ONE OPERAND) DEFECTIVE");
END IF;
END; -- (T)
 
-------------------------------------------------
 
RESULT;
END C67002A;
/c64103b.ada
0,0 → 1,379
-- C64103B.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, FOR IN-OUT PARAMETERS OF A SCALAR TYPE,
-- CONSTRAINT_ERROR IS RAISED:
-- BEFORE A SUBPROGRAM CALL WHEN THE CONVERTED ACTUAL
-- PARAMETER IS OUTSIDE THE RANGE OF THE FORMAL PARAMETER'S
-- SUBTYPE;
-- AFTER A SUBPROGRAM CALL WHEN THE CONVERTED FORMAL PARAMETER
-- IS OUTSIDE THE RANGE OF THE ACTUAL PARAMETER'S SUBTYPE.
 
-- HISTORY:
-- CPP 07/18/84 CREATED ORIGINAL TEST.
-- VCL 10/27/87 MODIFIED THIS HEADER; ADDED STATEMENTS WHICH
-- REFERENCED THE ACTUAL PARAMETERS IN THE SECOND
-- SUBTEST.
 
WITH REPORT; USE REPORT;
PROCEDURE C64103B IS
BEGIN
TEST ("C64103B", "FOR IN-OUT PARAMETERS OF A SCALAR TYPE, " &
"CONSTRAINT_ERROR IS RAISED: BEFORE A " &
"SUBPROGRAM CALL WHEN THE CONVERTED ACTUAL " &
"PARAMETER IS OUTSIDE THE RANGE OF THE FORMAL " &
"PARAMETER'S SUBTYPE; AFTER A SUBPROGRAM " &
"CALL WHEN THE CONVERTED FORMAL PARAMETER IS " &
"OUTSIDE THE RANGE OF THE ACTUAL PARAMETER'S " &
"SUBTYPE");
 
 
DECLARE
A0 : INTEGER := -9;
A1 : INTEGER := IDENT_INT(-1);
TYPE SUBINT IS RANGE -8 .. -2;
 
TYPE FLOAT_TYPE IS DIGITS 3 RANGE 0.0 .. 3.0;
A2 : FLOAT_TYPE := 0.12;
A3 : FLOAT_TYPE := 2.5;
TYPE NEW_FLOAT IS DIGITS 3 RANGE 1.0 .. 2.0;
 
TYPE FIXED_TYPE IS DELTA 1.0 RANGE -2.0 .. 5.0;
A4 : FIXED_TYPE := -2.0;
A5 : FIXED_TYPE := 4.0;
TYPE NEW_FIXED IS DELTA 1.0 RANGE -1.0 .. 3.0;
 
A6 : CHARACTER := 'A';
SUBTYPE SUPER_CHAR IS CHARACTER RANGE 'B'..'Q';
 
TYPE COLOR IS (RED, BURGUNDY, LILAC, MAROON, MAGENTA);
SUBTYPE A_COLOR IS COLOR RANGE RED..LILAC;
SUBTYPE B_COLOR IS COLOR RANGE MAROON..MAGENTA;
A7 : B_COLOR := MAROON;
 
PROCEDURE P1 (X : IN OUT SUBINT;
S : STRING) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (A" &
S & ")");
END P1;
 
PROCEDURE P2 (X : IN OUT NEW_FLOAT;
S : STRING) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P2 (A" &
S & ")");
END P2;
 
PROCEDURE P3 (X : IN OUT NEW_FIXED;
S : STRING) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P3 (A" &
S & ")");
END P3;
 
PROCEDURE P4 (X : IN OUT SUPER_CHAR;
S : STRING) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P4 (A" &
S & ")");
END P4;
 
PROCEDURE P5 (X : IN OUT A_COLOR;
S : STRING) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P5 (A" &
S & ")");
END P5;
BEGIN
BEGIN
P1 (SUBINT (A0), "1");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P1 (A1)");
END;
 
BEGIN
P1 (SUBINT (A1), "2");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P1 (A2)");
END;
 
BEGIN
P2 (NEW_FLOAT (A2), "1");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P2 (A1)");
END;
 
BEGIN
P2 (NEW_FLOAT (A3), "2");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P2 (A2)");
END;
 
BEGIN
P3 (NEW_FIXED (A4), "1");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P3 (A1)");
END;
 
BEGIN
P3 (NEW_FIXED (A5), "2");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P3 (A2)");
END;
 
BEGIN
P4 (SUPER_CHAR (A6),"1");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P4 (A1)");
END;
 
BEGIN
P5 (A_COLOR (A7), "1");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P5 (A1)");
END;
END;
 
 
DECLARE
CALLED : BOOLEAN;
TYPE SUBINT IS RANGE -8 .. -2;
A0 : SUBINT := -3;
A1 : INTEGER := -9;
A2 : INTEGER := -1;
 
TYPE FLOAT IS DIGITS 3 RANGE -1.0 .. 2.0;
TYPE A_FLOAT IS DIGITS 3 RANGE 0.0 .. 1.0;
A3 : A_FLOAT := 1.0;
A4 : FLOAT := -0.5;
A5 : FLOAT := 1.5;
 
TYPE NEW_FIXED IS DELTA 1.0 RANGE -1.0 .. 3.0;
A6 : NEW_FIXED := 0.0;
TYPE FIXED_TYPE IS DELTA 1.0 RANGE -2.0 .. 5.0;
A7 : FIXED_TYPE := -2.0;
A8 : FIXED_TYPE := 4.0;
 
SUBTYPE SUPER_CHAR IS CHARACTER RANGE 'B'..'Q';
A9 : SUPER_CHAR := 'C';
A10 : CHARACTER := 'A';
A11 : CHARACTER := 'R';
 
PROCEDURE P1 (X : IN OUT INTEGER; Y : INTEGER) IS
BEGIN
CALLED := TRUE;
X := IDENT_INT (Y);
END P1;
 
PROCEDURE P2 (X : IN OUT FLOAT; Y : FLOAT) IS
BEGIN
CALLED := TRUE;
X := Y;
END P2;
 
PROCEDURE P3 ( X : IN OUT FIXED_TYPE; Y : FIXED_TYPE) IS
BEGIN
CALLED := TRUE;
X := Y;
END P3;
 
PROCEDURE P4 (X : IN OUT CHARACTER; Y : CHARACTER) IS
BEGIN
CALLED := TRUE;
X := IDENT_CHAR(Y);
END P4;
BEGIN
BEGIN
CALLED := FALSE;
P1 (INTEGER(A0), A1);
IF A0 = -3 THEN
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B1)");
ELSE
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B2)");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL " &
"-P1 (B1)");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P1 (B1)");
END;
 
BEGIN
CALLED := FALSE;
P1 (INTEGER(A0), A2);
IF A0 = -3 THEN
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B3)");
ELSE
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B4)");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL " &
"-P1 (B2)");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P1 (B2)");
END;
 
BEGIN
CALLED := FALSE;
P2 (FLOAT (A3), A4);
IF A3 = 1.0 THEN
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (B1)");
ELSE
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (B2)");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL " &
"-P2 (B1)");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P2 (B1)");
END;
 
BEGIN
CALLED := FALSE;
P2 (FLOAT (A3), A5);
IF A3 = 1.0 THEN
FAILED ("EXCEPTION NOT RAISED -P2 (B3)");
ELSE
FAILED ("EXCEPTION NOT RAISED -P2 (B4)");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL " &
"-P2 (B2)");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P2 (B2)");
END;
 
BEGIN
CALLED := FALSE;
P3 (FIXED_TYPE (A6), A7);
IF A6 = 0.0 THEN
FAILED ("EXCEPTION NOT RAISED -P3 (B1)");
ELSE
FAILED ("EXCEPTION NOT RAISED -P3 (B2)");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL " &
"-P3 (B1)");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P3 (B1)");
END;
 
BEGIN
CALLED := FALSE;
P3 (FIXED_TYPE (A6), A8);
IF A6 = 0.0 THEN
FAILED ("EXCEPTION NOT RAISED -P3 (B3)");
ELSE
FAILED ("EXCEPTION NOT RAISED -P3 (B4)");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL " &
"-P3 (B2)");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P3 (B2)");
END;
 
BEGIN
CALLED := FALSE;
P4 (CHARACTER (A9), A10);
IF A9 = 'C' THEN
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B1)");
ELSE
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B2)");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL " &
"-P4 (B1)");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P4 (B1)");
END;
 
BEGIN
CALLED := FALSE;
P4 (CHARACTER (A9), A11);
IF A9 = 'C' THEN
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B3)");
ELSE
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B4)");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL " &
"-P4 (B2)");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P4 (B2)");
END;
END;
 
RESULT;
END C64103B;
/c67002b.ada
0,0 → 1,176
-- C67002B.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 OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED)
-- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS.
-- THIS TEST CHECKS THE CASE OF CERTAIN OPERATOR SYMBOLS.
-- SUBTESTS ARE:
-- (A) THROUGH (E): "AND", "OR", "XOR", "MOD", "REM"
-- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS.
-- (F) AND (G): "NOT" AND "ABS", RESPECTIVELY,
-- WITH ONE PARAMETER.
 
-- CPP 6/26/84
 
WITH REPORT;
PROCEDURE C67002B IS
 
USE REPORT;
 
BEGIN
TEST ("C67002B", "USE OF OPERATOR SYMBOLS IN " &
"(OVERLOADED) FUNCTION SPECIFICATIONS");
 
-------------------------------------------------
 
DECLARE -- (A)
FUNCTION "And" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END "And";
 
BEGIN -- (A)
IF (IDENT_INT (10) AND 1) /= 'G' OR
(5 AnD 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""And"" OPERATOR DEFECTIVE");
END IF;
END; -- (A)
 
-------------------------------------------------
 
DECLARE -- (B)
FUNCTION "or" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END "or";
 
BEGIN -- (B)
IF (IDENT_INT (10) Or 1) /= 'G' OR
(5 OR 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""or"" OPERATOR DEFECTIVE");
END IF;
END; -- (B)
 
-------------------------------------------------
 
DECLARE -- (C)
FUNCTION "xOR" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END "xOR";
 
BEGIN -- (C)
IF (IDENT_INT (10) XoR 1) /= 'G' OR
(5 xOR 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""xOR"" OPERATOR DEFECTIVE");
END IF;
END; -- (C)
 
-------------------------------------------------
 
DECLARE -- (D)
FUNCTION "mOd" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END "mOd";
 
BEGIN -- (D)
IF (IDENT_INT (10) MoD 1) /= 'G' OR
(5 moD 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""mOd"" OPERATOR DEFECTIVE");
END IF;
END; -- (D)
 
-------------------------------------------------
 
DECLARE -- (E)
FUNCTION "REM" (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END "REM";
 
BEGIN -- (E)
IF (IDENT_INT (10) rem 1) /= 'G' OR
(5 Rem 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE");
END IF;
END; -- (E)
 
-------------------------------------------------
 
DECLARE -- (F)
FUNCTION "NOT" (I1 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 < IDENT_INT (0) THEN
RETURN 'N';
ELSE RETURN 'P';
END IF;
END "NOT";
 
BEGIN -- (F)
IF (Not IDENT_INT(25) /= 'P') OR
(noT (0-25) /= 'N') THEN
FAILED ("OVERLOADING OF ""NOT"" " &
"OPERATOR (ONE OPERAND) DEFECTIVE");
END IF;
END; -- (F)
 
-------------------------------------------------
 
DECLARE -- (G)
FUNCTION "ABS" (I1 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 < IDENT_INT (0) THEN
RETURN 'N';
ELSE RETURN 'P';
END IF;
END "ABS";
 
BEGIN -- (G)
IF (abs IDENT_INT(25) /= 'P') OR
(Abs (0-25) /= 'N') THEN
FAILED ("OVERLOADING OF ""ABS"" " &
"OPERATOR (ONE OPERAND) DEFECTIVE");
END IF;
END; -- (T)
 
-------------------------------------------------
 
RESULT;
END C67002B;
/c66002c.ada
0,0 → 1,102
-- C66002C.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 OVERLOADED SUBPROGRAM DECLARATIONS
-- ARE PERMITTED IN WHICH THERE IS A MINIMAL
-- DIFFERENCE BETWEEN THE DECLARATIONS.
 
-- (C) ONE SUBPROGRAM HAS ONE LESS PARAMETER THAN THE OTHER.
 
-- CVP 5/4/81
-- JRK 5/8/81
-- NL 10/13/81
 
WITH REPORT;
PROCEDURE C66002C IS
 
USE REPORT;
 
BEGIN
TEST ("C66002C", "SUBPROGRAM OVERLOADING WITH " &
"MINIMAL DIFFERENCES ALLOWED");
 
--------------------------------------------------
 
-- ONE PROCEDURE HAS ONE MORE PARAMETER
-- THAN THE OTHER. THIS IS TESTED IN THE
-- CASE IN WHICH THAT PARAMETER HAS A DEFAULT
-- VALUE, AND THE CASE IN WHICH IT DOES NOT.
 
DECLARE
I, J : INTEGER := 0;
B : BOOLEAN := TRUE;
S : STRING (1..2) := "12";
 
PROCEDURE P1 (I1, I2 : INTEGER; B1 : IN OUT BOOLEAN) IS
BEGIN
S(1) := 'A';
END P1;
 
PROCEDURE P1 (I1, I2 : INTEGER) IS
BEGIN
S(2) := 'B';
END P1;
 
PROCEDURE P2 (B1 : IN OUT BOOLEAN; I1 : INTEGER := 0) IS
BEGIN
S(1) := 'C';
END P2;
 
PROCEDURE P2 (B1 : IN OUT BOOLEAN) IS
BEGIN
S(2) := 'D';
END P2;
 
BEGIN
P1 (I, J, B);
P1 (I, J);
 
IF S /= "AB" THEN
FAILED ("PROCEDURES DIFFERING ONLY IN " &
"NUMBER OF PARAMETERS (NO DEFAULTS) " &
"CAUSED CONFUSION");
END IF;
 
S := "12";
P2 (B, I);
-- NOTE THAT A CALL TO P2 WITH ONLY
-- ONE PARAMETER IS AMBIGUOUS.
 
IF S /= "C2" THEN
FAILED ("PROCEDURES DIFFERING ONLY IN " &
"EXISTENCE OF ONE PARAMETER (WITH " &
"DEFAULT) CAUSED CONFUSION");
END IF;
END;
 
--------------------------------------------------
 
RESULT;
 
END C66002C;
/c64103c.ada
0,0 → 1,230
-- C64103C.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 APPROPRIATE EXCEPTION IS RAISED FOR TYPE CONVERSIONS
-- ON IN OUT ARRAY PARAMETERS. IN PARTICULAR:
-- (A) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN THE ACTUAL
-- COMPONENT'S CONSTRAINTS DIFFER FROM THE FORMAL COMPONENT'S
-- CONSTRAINTS.
-- (B) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO
-- AN UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE
-- OUTSIDE OF A FORMAL INDEX SUBTYPE FOR A NON-NULL DIMENSION (SEE
-- AI-00313 FOR MULTIDIMENSIONAL CASE)
-- (C) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL FOR CONVERSION TO A
-- CONSTRAINED ARRAY TYPE WHEN THE NUMBER OF COMPONENTS PER
-- DIMENSION OF THE ACTUAL DIFFERS FROM THAT OF THE FORMAL.
-- (D) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO AN
-- UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE
-- OUTSIDE OF THE BASE INDEX TYPE OF THE FORMAL.
 
-- *** 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
 
-- CPP 07/19/84
-- JBG 06/05/85
-- EG 10/29/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO
-- AI-00387.
-- MRM 03/30/93 REMOVE NUMERIC_ERROR FOR 9X COMPATIBILITY
-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
 
WITH SYSTEM;
WITH REPORT; USE REPORT;
PROCEDURE C64103C IS
 
BEGIN
TEST ("C64103C", "CHECK THAT APPROPRIATE EXCEPTION IS RAISED ON " &
"TYPE CONVERSIONS OF IN OUT ARRAY PARAMETERS");
 
-----------------------------------------------
 
DECLARE -- (A)
BEGIN -- (A)
 
DECLARE
TYPE SUBINT IS RANGE 0..8;
TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
A0 : ARRAY_TYPE (0..3) := (0..3 => TRUE);
 
PROCEDURE P2 (X : IN OUT ARRAY_TYPE) IS
BEGIN
NULL;
END P2;
BEGIN
P2 (ARRAY_TYPE (A0)); -- OK.
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED -P2 (A)");
END;
 
END; -- (A)
 
-----------------------------------------------
 
DECLARE -- (B1) NON-NULL ACTUAL PARAMETER
 
TYPE SUBINT IS RANGE 0..8;
TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
TYPE AR1 IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
A1 : AR1 (-1..7) := (-1..7 => TRUE);
A2 : AR1 (1..9) := (1..9 => TRUE);
 
PROCEDURE P1 (X : IN OUT ARRAY_TYPE) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (B)");
END P1;
 
BEGIN -- (B1)
 
BEGIN
COMMENT ("CALL TO P1 (B1) ON A1");
P1 (ARRAY_TYPE (A1));
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P1 (B1)");
END;
 
BEGIN
COMMENT ("CALL TO P1 (B1) ON A2");
P1 (ARRAY_TYPE (A2));
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P1 (B1)");
END;
 
END; -- (B1)
 
DECLARE -- (B2) NULL ACTUAL PARAMETER; MULTIDIMENSIONAL
 
TYPE SUBINT IS RANGE 0..8;
TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>,
SUBINT RANGE <>) OF BOOLEAN;
TYPE AR1 IS ARRAY (INTEGER RANGE <>,
INTEGER RANGE <>)OF BOOLEAN;
A1 : AR1 (IDENT_INT(-1)..7, 5..4) :=
(OTHERS => (OTHERS => TRUE));
A2 : AR1 (5..4, 1..IDENT_INT(9)) :=
(OTHERS => (OTHERS => TRUE));
PROCEDURE P1 (X : IN OUT ARRAY_TYPE) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (B)");
END P1;
 
BEGIN -- (B2)
 
BEGIN
COMMENT ("CALL TO P1 (B2) ON A1");
P1 (ARRAY_TYPE (A1));
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P1 (B2)");
END;
 
BEGIN
COMMENT ("CALL TO P1 (B2) ON A2");
P1 (ARRAY_TYPE (A2));
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P1 (B2)");
END;
 
END; -- (B2)
 
-----------------------------------------------
 
BEGIN -- (C)
 
DECLARE
TYPE INDEX1 IS RANGE 1..3;
TYPE INDEX2 IS RANGE 1..4;
TYPE AR_TYPE IS ARRAY (INDEX1, INDEX2) OF BOOLEAN;
A0 : AR_TYPE := (1..3 => (1..4 => FALSE));
 
TYPE I1 IS RANGE 1..4;
TYPE I2 IS RANGE 1..3;
TYPE ARRAY_TYPE IS ARRAY (I1, I2) OF BOOLEAN;
 
PROCEDURE P1 (X : IN OUT ARRAY_TYPE) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (C)");
END P1;
BEGIN
P1 (ARRAY_TYPE (A0));
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P1 (C)");
END;
 
END; -- (C)
 
-----------------------------------------------
 
DECLARE -- (D)
BEGIN -- (D)
 
DECLARE
TYPE SM_INT IS RANGE 0..2;
TYPE LG IS RANGE 0 .. SYSTEM.MAX_INT;
SUBTYPE LG_INT IS LG RANGE SYSTEM.MAX_INT - 3 ..
SYSTEM.MAX_INT;
TYPE AR_SMALL IS ARRAY (SM_INT RANGE <>) OF BOOLEAN;
TYPE AR_LARGE IS ARRAY (LG_INT RANGE <>) OF BOOLEAN;
A0 : AR_LARGE (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT) :=
(SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT => TRUE);
 
PROCEDURE P1 (X : IN OUT AR_SMALL) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (D)");
END P1;
BEGIN
IF LG (SM_INT'BASE'LAST) < LG_INT'BASE'LAST THEN
P1 (AR_SMALL (A0));
ELSE
COMMENT ("NOT APPLICABLE -P1 (D)");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
COMMENT ("CONSTRAINT_ERROR RAISED - P1 (D)");
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - P1 (D)");
END;
 
END; -- (D)
 
-----------------------------------------------
 
RESULT;
 
END C64103C;
/c67002c.ada
0,0 → 1,548
-- C67002C.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 OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED)
-- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS.
-- THIS TEST CHECKS FORMAL SUBPROGRAM PARAMETERS.
-- SUBTESTS ARE:
-- (A) THROUGH (P): "=", "AND", "OR", "XOR", "<", "<=",
-- ">", ">=", "&", "*", "/", "MOD", "REM", "**", "+", "-",
-- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS.
-- (Q), (R), (S), AND (T): "+", "-", "NOT", "ABS", RESPECTIVELY,
-- WITH ONE PARAMETER.
 
-- CPP 6/26/84
 
WITH REPORT; USE REPORT;
PROCEDURE C67002C IS
 
FUNCTION TWO_PARAMS (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END TWO_PARAMS;
 
FUNCTION ONE_PARAM (I1 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 < IDENT_INT(0) THEN
RETURN 'N';
ELSE RETURN 'P';
END IF;
END ONE_PARAM;
 
BEGIN
TEST ("C67002C", "USE OF OPERATOR SYMBOLS IN " &
"(OVERLOADED) FUNCTION SPECIFICATIONS");
 
-------------------------------------------------
 
DECLARE -- (A)
 
PACKAGE EQU IS
TYPE LP IS LIMITED PRIVATE;
FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN;
PRIVATE
TYPE LP IS NEW INTEGER;
END EQU;
USE EQU;
 
LP1, LP2 : LP;
 
PACKAGE BODY EQU IS
FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN IS
BEGIN
RETURN LPA > LPB;
END "=";
BEGIN
LP1 := LP (IDENT_INT (7));
LP2 := LP (IDENT_INT (8));
END EQU;
 
GENERIC
WITH FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (LP1 = LP2) OR NOT (LP2 = LP1) OR
(LP1 = LP1) OR (LP2 /= LP1) THEN
FAILED ("OVERLOADING OF ""="" OPERATOR DEFECTIVE");
END IF;
END PKG;
 
PACKAGE EQUAL IS NEW PKG ("=" => EQU."=");
 
BEGIN -- (A)
NULL;
END; -- (A)
 
-------------------------------------------------
 
DECLARE -- (B)
 
GENERIC
WITH FUNCTION "AND" (I1, I2 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (IDENT_INT (10) AND 1) /= 'G' OR
(5 AND 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""AND"" OPERATOR DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG ("AND" => TWO_PARAMS);
 
BEGIN -- (B)
NULL;
END; -- (B)
 
-------------------------------------------------
 
DECLARE -- (C)
 
GENERIC
WITH FUNCTION "OR" (I1, I2 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (IDENT_INT (10) OR 1) /= 'G' OR
(5 OR 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""OR"" OPERATOR DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG ("OR" => TWO_PARAMS);
 
BEGIN -- (C)
NULL;
END; -- (C)
 
-------------------------------------------------
 
DECLARE -- (D)
 
GENERIC
WITH FUNCTION "XOR" (I1, I2 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (IDENT_INT (10) XOR 1) /= 'G' OR
(5 XOR 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""XOR"" OPERATOR DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG ("XOR" => TWO_PARAMS);
 
BEGIN -- (D)
NULL;
END; -- (D)
 
-------------------------------------------------
 
DECLARE -- (E)
 
GENERIC
WITH FUNCTION "<" (I1, I2 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (IDENT_INT (10) < 1) /= 'G' OR
(5 < 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""<"" OPERATOR DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG ("<" => TWO_PARAMS);
 
BEGIN -- (E)
NULL;
END; -- (E)
 
-------------------------------------------------
 
DECLARE -- (F)
 
GENERIC
WITH FUNCTION "<=" (I1, I2 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (IDENT_INT (10) <= 1) /= 'G' OR
(5 <= 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""<="" OPERATOR DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG ("<=" => TWO_PARAMS);
 
BEGIN -- (F)
NULL;
END; -- (F)
 
-------------------------------------------------
 
DECLARE -- (G)
 
GENERIC
WITH FUNCTION ">" (I1, I2 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (IDENT_INT (10) > 1) /= 'G' OR
(5 > 10) /= 'L' THEN
FAILED ("OVERLOADING OF "">"" OPERATOR DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG (">" => TWO_PARAMS);
 
BEGIN -- (G)
NULL;
END; -- (G)
 
-------------------------------------------------
 
DECLARE -- (H)
 
GENERIC
WITH FUNCTION ">=" (I1, I2 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (IDENT_INT (10) >= 1) /= 'G' OR
(5 >= 10) /= 'L' THEN
FAILED ("OVERLOADING OF "">="" OPERATOR DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG (">=" => TWO_PARAMS);
 
BEGIN -- (H)
NULL;
END; -- (H)
 
-------------------------------------------------
 
DECLARE -- (I)
 
GENERIC
WITH FUNCTION "&" (I1, I2 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (IDENT_INT (10) & 1) /= 'G' OR
(5 & 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""&"" OPERATOR DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG ("&" => TWO_PARAMS);
 
BEGIN -- (I)
NULL;
END; -- (I)
 
-------------------------------------------------
 
DECLARE -- (J)
 
GENERIC
WITH FUNCTION "*" (I1, I2 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (IDENT_INT (10) * 1) /= 'G' OR
(5 * 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""*"" OPERATOR DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG ("*" => TWO_PARAMS);
 
BEGIN -- (J)
NULL;
END; -- (J)
 
-------------------------------------------------
 
DECLARE -- (K)
 
GENERIC
WITH FUNCTION "/" (I1, I2 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (IDENT_INT (10) / 1) /= 'G' OR
(5 / 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""/"" OPERATOR DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG ("/" => TWO_PARAMS);
 
BEGIN -- (K)
NULL;
END; -- (K)
 
-------------------------------------------------
 
DECLARE -- (L)
 
GENERIC
WITH FUNCTION "MOD" (I1, I2 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (IDENT_INT (10) MOD 1) /= 'G' OR
(5 MOD 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""MOD"" OPERATOR DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG ("MOD" => TWO_PARAMS);
 
BEGIN -- (L)
NULL;
END; -- (L)
 
-------------------------------------------------
 
DECLARE -- (M)
 
GENERIC
WITH FUNCTION "REM" (I1, I2 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (IDENT_INT (10) REM 1) /= 'G' OR
(5 REM 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG ("REM" => TWO_PARAMS);
 
BEGIN -- (M)
NULL;
END; -- (M)
 
-------------------------------------------------
 
DECLARE -- (N)
 
GENERIC
WITH FUNCTION "**" (I1, I2 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (IDENT_INT (10) ** 1) /= 'G' OR
(5 ** 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""**"" OPERATOR DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG ("**" => TWO_PARAMS);
 
BEGIN -- (N)
NULL;
END; -- (N)
 
-------------------------------------------------
 
DECLARE -- (O)
 
GENERIC
WITH FUNCTION "+" (I1, I2 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (IDENT_INT (10) + 1) /= 'G' OR
(5 + 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""+"" OPERATOR DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG ("+" => TWO_PARAMS);
 
BEGIN -- (O)
NULL;
END; -- (O)
 
-------------------------------------------------
 
DECLARE -- (P)
 
GENERIC
WITH FUNCTION "-" (I1, I2 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (IDENT_INT (10) - 1) /= 'G' OR
(5 - 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""-"" OPERATOR DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG ("-" => TWO_PARAMS);
 
BEGIN -- (P)
NULL;
END; -- (P)
 
-------------------------------------------------
 
DECLARE -- (Q)
 
GENERIC
WITH FUNCTION "+" (I1 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (+ IDENT_INT(25) /= 'P') OR
(+ (0-25) /= 'N') THEN
FAILED ("OVERLOADING OF ""+"" " &
"OPERATOR (ONE OPERAND) DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG ("+" => ONE_PARAM);
 
BEGIN -- (Q)
NULL;
END; -- (Q)
 
-------------------------------------------------
 
DECLARE -- (R)
 
GENERIC
WITH FUNCTION "-" (I1 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (- IDENT_INT(25) /= 'P') OR
(- (0-25) /= 'N') THEN
FAILED ("OVERLOADING OF ""-"" " &
"OPERATOR (ONE OPERAND) DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG ("-" => ONE_PARAM);
 
BEGIN -- (R)
NULL;
END; -- (R)
 
-------------------------------------------------
 
DECLARE -- (S)
 
GENERIC
WITH FUNCTION "NOT" (I1 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (NOT IDENT_INT(25) /= 'P') OR
(NOT (0-25) /= 'N') THEN
FAILED ("OVERLOADING OF ""NOT"" " &
"OPERATOR (ONE OPERAND) DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG ("NOT" => ONE_PARAM);
 
BEGIN -- (S)
NULL;
END; -- (S)
 
-------------------------------------------------
 
DECLARE -- (T)
 
GENERIC
WITH FUNCTION "ABS" (I1 : INTEGER) RETURN CHARACTER;
PACKAGE PKG IS
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF (ABS IDENT_INT(25) /= 'P') OR
(ABS (0-25) /= 'N') THEN
FAILED ("OVERLOADING OF ""ABS"" " &
"OPERATOR (ONE OPERAND) DEFECTIVE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG ("ABS" => ONE_PARAM);
 
BEGIN -- (T)
NULL;
END; -- (T)
 
-------------------------------------------------
 
RESULT;
END C67002C;
/c66002d.ada
0,0 → 1,85
-- C66002D.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 OVERLOADED SUBPROGRAM DECLARATIONS
-- ARE PERMITTED IN WHICH THERE IS A MINIMAL
-- DIFFERENCE BETWEEN THE DECLARATIONS.
 
-- (D) THE BASE TYPE OF A PARAMETER IS DIFFERENT FROM THAT
-- OF THE CORRESPONDING ONE.
 
-- CVP 5/4/81
-- JRK 5/8/81
-- NL 10/13/81
 
WITH REPORT;
PROCEDURE C66002D IS
 
USE REPORT;
 
BEGIN
TEST ("C66002D", "SUBPROGRAM OVERLOADING WITH " &
"MINIMAL DIFFERENCES ALLOWED");
 
--------------------------------------------------
 
-- THE BASE TYPE OF ONE PARAMETER IS
-- DIFFERENT FROM THAT OF THE CORRESPONDING
-- ONE.
 
DECLARE
I, J, K : INTEGER := 0;
B : BOOLEAN;
S : STRING (1..2) := "12";
 
PROCEDURE P (I1 : INTEGER; BI : OUT BOOLEAN;
I2 : IN OUT INTEGER) IS
BEGIN
S(1) := 'A';
BI := TRUE; -- THIS VALUE IS IRRELEVENT.
END P;
 
PROCEDURE P (I1 : INTEGER; BI : OUT INTEGER;
I2 : IN OUT INTEGER) IS
BEGIN
S(2) := 'B';
BI := 0; -- THIS VALUE IS IRRELEVENT.
END P;
 
BEGIN
P (I, B, K);
P (I, J, K);
 
IF S /= "AB" THEN
FAILED ("PROCEDURES DIFFERING ONLY BY " &
"THE BASE TYPE OF A PARAMETER " &
"CAUSED CONFUSION");
END IF;
END;
 
--------------------------------------------------
 
RESULT;
 
END C66002D;
/c64103d.ada
0,0 → 1,187
-- C64103D.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 APPROPRIATE EXCEPTION IS RAISED FOR TYPE CONVERSIONS
-- ON OUT ARRAY PARAMETERS. IN PARTICULAR:
-- (A) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN THE ACTUAL
-- COMPONENT'S CONSTRAINTS DIFFER FROM THE FORMAL COMPONENT'S
-- CONSTRAINTS.
-- (B) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO
-- AN UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE
-- OUTSIDE OF A FORMAL INDEX SUBTYPE.
-- (C) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL FOR CONVERSION TO A
-- CONSTRAINED ARRAY TYPE WHEN THE NUMBER OF COMPONENTS PER
-- DIMENSION OF THE ACTUAL DIFFERS FROM THAT OF THE FORMAL.
-- (D) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO AN
-- UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE
-- OUTSIDE OF THE BASE INDEX TYPE OF THE FORMAL.
 
-- *** 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
 
-- CPP 07/19/84
-- EG 10/29/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO
-- AI-00387.
-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
 
WITH SYSTEM;
WITH REPORT; USE REPORT;
PROCEDURE C64103D IS
 
BEGIN
TEST ("C64103D", "CHECK THAT APPROPRIATE EXCEPTION IS RAISED ON " &
"TYPE CONVERSIONS OF OUT ARRAY PARAMETERS");
 
-----------------------------------------------
 
DECLARE -- (A)
BEGIN -- (A)
 
DECLARE
TYPE SUBINT IS RANGE 0..8;
TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
A0 : ARRAY_TYPE (0..3) := (0..3 => TRUE);
 
PROCEDURE P2 (X : OUT ARRAY_TYPE) IS
BEGIN
NULL;
END P2;
BEGIN
P2 (ARRAY_TYPE (A0)); -- OK.
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED -P2 (A)");
END;
 
END; -- (A)
 
-----------------------------------------------
 
DECLARE -- (B)
 
TYPE SUBINT IS RANGE 0..8;
TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
TYPE AR1 IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
A1 : AR1 (-1..7) := (-1..7 => TRUE);
A2 : AR1 (1..9) := (1..9 => TRUE);
 
PROCEDURE P1 (X : OUT ARRAY_TYPE) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (B)");
END P1;
 
BEGIN -- (B)
 
BEGIN
COMMENT ("CALL TO P1 (B) ON A1");
P1 (ARRAY_TYPE (A1));
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P1 (B)");
END;
 
BEGIN
COMMENT ("CALL TO P1 (B) ON A2");
P1 (ARRAY_TYPE (A2));
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P1 (B)");
END;
 
END; -- (B)
 
-----------------------------------------------
 
DECLARE -- (C)
BEGIN -- (C)
 
DECLARE
TYPE INDEX1 IS RANGE 1..3;
TYPE INDEX2 IS RANGE 1..4;
TYPE AR_TYPE IS ARRAY (INDEX1, INDEX2) OF BOOLEAN;
A0 : AR_TYPE := (1..3 => (1..4 => FALSE));
 
TYPE I1 IS RANGE 1..4;
TYPE I2 IS RANGE 1..3;
TYPE ARRAY_TYPE IS ARRAY (I1, I2) OF BOOLEAN;
 
PROCEDURE P1 (X : OUT ARRAY_TYPE) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (C)");
END P1;
BEGIN
P1 (ARRAY_TYPE (A0));
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P1 (C)");
END;
 
END; -- (C)
 
-----------------------------------------------
 
DECLARE -- (D)
BEGIN -- (D)
 
DECLARE
TYPE SM_INT IS RANGE 0..2;
TYPE LG_INT IS RANGE SYSTEM.MIN_INT..SYSTEM.MAX_INT;
TYPE AR_SMALL IS ARRAY (SM_INT RANGE <>) OF BOOLEAN;
TYPE AR_LARGE IS ARRAY (LG_INT RANGE <>) OF BOOLEAN;
A0 : AR_LARGE (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT) :=
(SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT => TRUE);
 
PROCEDURE P1 (X : OUT AR_SMALL) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (D)");
END P1;
BEGIN
IF LG_INT (SM_INT'BASE'LAST) < LG_INT'BASE'LAST THEN
P1 (AR_SMALL (A0));
ELSE
COMMENT ("NOT APPLICABLE -P1 (D)");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
COMMENT ("CONSTRAINT_ERROR RAISED - P1 (D)");
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - P1 (D)");
END;
 
END; -- (D)
 
-----------------------------------------------
 
RESULT;
 
END C64103D;
/c67002d.ada
0,0 → 1,354
-- C67002D.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 OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED)
-- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS.
-- THIS TEST CHECKS GENERIC INSTANTIATIONS FOR THESE FUNCTIONS.
-- SUBTESTS ARE:
-- (A) THROUGH (P): "=", "AND", "OR", "XOR", "<", "<=",
-- ">", ">=", "&", "*", "/", "MOD", "REM", "**", "+", "-",
-- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS.
-- (Q), (R), (S), AND (T): "+", "-", "NOT", "ABS", RESPECTIVELY,
-- WITH ONE PARAMETER.
 
-- CPP 6/25/84
 
WITH REPORT; USE REPORT;
PROCEDURE C67002D IS
 
GENERIC
TYPE ELEMENT IS (<>);
FUNCTION TWO_PARAMS (I1, I2 : ELEMENT) RETURN CHARACTER;
FUNCTION TWO_PARAMS (I1, I2 : ELEMENT) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END TWO_PARAMS;
 
GENERIC
TYPE ELEMENT IS (<>);
FUNCTION ONE_PARAM (I1 : ELEMENT) RETURN CHARACTER;
FUNCTION ONE_PARAM (I1 : ELEMENT) RETURN CHARACTER IS
BEGIN
IF I1 < ELEMENT'VAL(IDENT_INT(0)) THEN
RETURN 'N';
ELSE RETURN 'P';
END IF;
END ONE_PARAM;
BEGIN
TEST ("C67002D", "USE OF OPERATOR SYMBOLS IN " &
"(OVERLOADED) FUNCTION SPECIFICATIONS");
 
-------------------------------------------------
 
DECLARE -- (A)
GENERIC
TYPE LP IS LIMITED PRIVATE;
WITH FUNCTION ">" (L, R : LP) RETURN BOOLEAN IS <>;
PACKAGE PKG IS
LP1, LP2 : LP;
FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN;
END PKG;
 
PACKAGE BODY PKG IS
FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN IS
BEGIN
RETURN LPA > LPB;
END "=";
END PKG;
 
BEGIN -- (A)
DECLARE
PACKAGE PACK IS NEW PKG (LP => INTEGER);
USE PACK;
FUNCTION "=" (L, R : INTEGER) RETURN BOOLEAN
RENAMES PACK."=";
BEGIN
LP1 := IDENT_INT(7);
LP2 := IDENT_INT(8);
IF (LP1 = LP2) OR NOT (LP2 = LP1) OR
(LP1 = LP1) OR (LP2 /= LP1) THEN
FAILED ("OVERLOADING OF ""="" OPERATOR DEFECTIVE");
END IF;
END;
END; -- (A)
 
-------------------------------------------------
 
DECLARE -- (B)
FUNCTION "AND" IS NEW TWO_PARAMS
(ELEMENT => INTEGER);
 
BEGIN -- (B)
IF (IDENT_INT (10) AND 1) /= 'G' OR
(5 AND 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""AND"" OPERATOR DEFECTIVE");
END IF;
END; -- (B)
 
-------------------------------------------------
 
DECLARE -- (C)
FUNCTION "OR" IS NEW TWO_PARAMS
(ELEMENT => INTEGER);
 
BEGIN -- (C)
IF (IDENT_INT (10) OR 1) /= 'G' OR
(5 OR 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""OR"" OPERATOR DEFECTIVE");
END IF;
END; -- (C)
 
-------------------------------------------------
 
DECLARE -- (D)
FUNCTION "XOR" IS NEW TWO_PARAMS
(ELEMENT => INTEGER);
 
BEGIN -- (D)
IF (IDENT_INT (10) XOR 1) /= 'G' OR
(5 XOR 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""XOR"" OPERATOR DEFECTIVE");
END IF;
END; -- (D)
 
-------------------------------------------------
 
DECLARE -- (E)
FUNCTION "<" IS NEW TWO_PARAMS
(ELEMENT => INTEGER);
 
BEGIN -- (E)
IF (IDENT_INT (10) < 1) /= 'G' OR
(5 < 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""<"" OPERATOR DEFECTIVE");
END IF;
END; -- (E)
 
-------------------------------------------------
 
DECLARE -- (F)
FUNCTION "<=" IS NEW TWO_PARAMS
(ELEMENT => INTEGER);
 
BEGIN -- (F)
IF (IDENT_INT (10) <= 1) /= 'G' OR
(5 <= 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""<="" OPERATOR DEFECTIVE");
END IF;
END; -- (F)
 
-------------------------------------------------
 
DECLARE -- (G)
FUNCTION ">" IS NEW TWO_PARAMS
(ELEMENT => INTEGER);
 
BEGIN -- (G)
IF (IDENT_INT (10) > 1) /= 'G' OR
(5 > 10) /= 'L' THEN
FAILED ("OVERLOADING OF "">"" OPERATOR DEFECTIVE");
END IF;
END; -- (G)
 
-------------------------------------------------
 
DECLARE -- (H)
FUNCTION ">=" IS NEW TWO_PARAMS
(ELEMENT => INTEGER);
 
BEGIN -- (H)
IF (IDENT_INT (10) >= 1) /= 'G' OR
(5 >= 10) /= 'L' THEN
FAILED ("OVERLOADING OF "">="" OPERATOR DEFECTIVE");
END IF;
END; -- (H)
 
-------------------------------------------------
 
DECLARE -- (I)
FUNCTION "&" IS NEW TWO_PARAMS
(ELEMENT => INTEGER);
 
BEGIN -- (I)
IF (IDENT_INT (10) & 1) /= 'G' OR
(5 & 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""&"" OPERATOR DEFECTIVE");
END IF;
END; -- (I)
 
-------------------------------------------------
 
DECLARE -- (J)
FUNCTION "*" IS NEW TWO_PARAMS
(ELEMENT => INTEGER);
 
BEGIN -- (J)
IF (IDENT_INT (10) * 1) /= 'G' OR
(5 * 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""*"" OPERATOR DEFECTIVE");
END IF;
END; -- (J)
 
-------------------------------------------------
 
DECLARE -- (K)
FUNCTION "/" IS NEW TWO_PARAMS
(ELEMENT => INTEGER);
 
BEGIN -- (K)
IF (IDENT_INT (10) / 1) /= 'G' OR
(5 / 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""/"" OPERATOR DEFECTIVE");
END IF;
END; -- (K)
 
-------------------------------------------------
 
DECLARE -- (L)
FUNCTION "MOD" IS NEW TWO_PARAMS
(ELEMENT => INTEGER);
 
BEGIN -- (L)
IF (IDENT_INT (10) MOD 1) /= 'G' OR
(5 MOD 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""MOD"" OPERATOR DEFECTIVE");
END IF;
END; -- (L)
 
-------------------------------------------------
 
DECLARE -- (M)
FUNCTION "REM" IS NEW TWO_PARAMS
(ELEMENT => INTEGER);
 
BEGIN -- (M)
IF (IDENT_INT (10) REM 1) /= 'G' OR
(5 REM 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE");
END IF;
END; -- (M)
 
-------------------------------------------------
 
DECLARE -- (N)
FUNCTION "**" IS NEW TWO_PARAMS
(ELEMENT => INTEGER);
 
BEGIN -- (N)
IF (IDENT_INT (10) ** 1) /= 'G' OR
(5 ** 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""**"" OPERATOR DEFECTIVE");
END IF;
END; -- (N)
 
-------------------------------------------------
 
DECLARE -- (O)
FUNCTION "+" IS NEW TWO_PARAMS
(ELEMENT => INTEGER);
 
BEGIN -- (O)
IF (IDENT_INT (10) + 1) /= 'G' OR
(5 + 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""+"" OPERATOR DEFECTIVE");
END IF;
END; -- (O)
 
-------------------------------------------------
 
DECLARE -- (P)
FUNCTION "-" IS NEW TWO_PARAMS
(ELEMENT => INTEGER);
 
BEGIN -- (P)
IF (IDENT_INT (10) - 1) /= 'G' OR
(5 - 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""-"" OPERATOR DEFECTIVE");
END IF;
END; -- (P)
 
-------------------------------------------------
 
DECLARE -- (Q)
FUNCTION "+" IS NEW ONE_PARAM
(ELEMENT => INTEGER);
 
BEGIN -- (Q)
IF (+ IDENT_INT(25) /= 'P') OR
(+ (0-25) /= 'N') THEN
FAILED ("OVERLOADING OF ""+"" " &
"OPERATOR (ONE OPERAND) DEFECTIVE");
END IF;
END; -- (Q)
 
-------------------------------------------------
 
DECLARE -- (R)
FUNCTION "-" IS NEW ONE_PARAM
(ELEMENT => INTEGER);
 
BEGIN -- (R)
IF (- IDENT_INT(25) /= 'P') OR
(- (0-25) /= 'N') THEN
FAILED ("OVERLOADING OF ""-"" " &
"OPERATOR (ONE OPERAND) DEFECTIVE");
END IF;
END; -- (R)
 
-------------------------------------------------
 
DECLARE -- (S)
FUNCTION "NOT" IS NEW ONE_PARAM
(ELEMENT => INTEGER);
 
BEGIN -- (S)
IF (NOT IDENT_INT(25) /= 'P') OR
(NOT (0-25) /= 'N') THEN
FAILED ("OVERLOADING OF ""NOT"" " &
"OPERATOR (ONE OPERAND) DEFECTIVE");
END IF;
END; -- (S)
 
-------------------------------------------------
 
DECLARE -- (T)
FUNCTION "ABS" IS NEW ONE_PARAM
(ELEMENT => INTEGER);
 
BEGIN -- (T)
IF (ABS IDENT_INT(25) /= 'P') OR
(ABS (0-25) /= 'N') THEN
FAILED ("OVERLOADING OF ""ABS"" " &
"OPERATOR (ONE OPERAND) DEFECTIVE");
END IF;
END; -- (T)
 
-------------------------------------------------
 
RESULT;
END C67002D;
/c66002e.ada
0,0 → 1,91
-- C66002E.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 OVERLOADED SUBPROGRAM DECLARATIONS
-- ARE PERMITTED IN WHICH THERE IS A MINIMAL
-- DIFFERENCE BETWEEN THE DECLARATIONS.
 
-- (E) ONE SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE
-- PART, THE OTHER IN AN INNER PART, AND THE PARAMETERS ARE
-- ORDERED DIFFERENTLY.
 
-- CVP 5/4/81
-- JRK 5/8/81
-- NL 10/13/81
 
WITH REPORT;
PROCEDURE C66002E IS
 
USE REPORT;
 
BEGIN
TEST ("C66002E", "SUBPROGRAM OVERLOADING WITH " &
"MINIMAL DIFFERENCES ALLOWED");
 
--------------------------------------------------
 
-- ONE SUBPROGRAM IS DECLARED IN AN OUTER
-- DECLARATIVE PART, THE OTHER IN AN INNER
-- PART, AND THE PARAMETERS ARE ORDERED
-- DIFFERENTLY.
 
DECLARE
S : STRING (1..2) := "12";
 
PROCEDURE P (I1 : INTEGER; I2 : IN OUT INTEGER;
B1 : BOOLEAN) IS
BEGIN
S(1) := 'A';
END P;
 
BEGIN
DECLARE
I : INTEGER := 0;
 
PROCEDURE P (B1 : BOOLEAN; I1 : INTEGER;
I2 : IN OUT INTEGER) IS
BEGIN
S(2) := 'B';
END P;
 
BEGIN
P (5, I, TRUE);
P (TRUE, 5, I);
-- NOTE THAT A CALL IN WHICH ALL ACTUAL PARAMETERS
-- ARE NAMED_ASSOCIATIONS IS AMBIGUOUS.
 
IF S /= "AB" THEN
FAILED ("PROCEDURES IN " &
"ENCLOSING-ENCLOSED SCOPES " &
"DIFFERING ONLY IN PARAMETER " &
"TYPE ORDER CAUSED CONFUSION");
END IF;
END;
END;
 
--------------------------------------------------
 
RESULT;
 
END C66002E;
/c64103e.ada
0,0 → 1,219
-- C64103E.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, FOR IN-OUT PARAMETERS OF AN ACCESS TYPE,
-- CONSTRAINT_ERROR IS RAISED:
-- BEFORE A SUBPROGRAM CALL WHEN THE BOUNDS OR DISCRIMINANTS
-- OF THE ACTUAL DESIGNATED PARAMETER ARE DIFFERENT FROM
-- THOSE OF THE FORMAL DESIGNATED PARAMETER;
-- AFTER A SUBPROGRAM CALL WHEN THE BOUNDS OR DISCRIMINANTS
-- OF THE FORMAL DESIGNATED PARAMETER ARE DIFFERENT FROM
-- THOSE OF THE ACTUAL DESIGNATED PARAMETER.
 
-- HISTORY:
-- CPP 07/23/84 CREATED ORIGINAL TEST.
-- VCL 10/27/87 MODIFIED THIS HEADER; ADDED STATEMENTS WHICH
-- REFERENCED THE ACTUAL PARAMETERS IN THE SECOND
-- SUBTEST.
 
WITH REPORT; USE REPORT;
PROCEDURE C64103E IS
BEGIN
TEST ("C64103E", "FOR IN-OUT PARAMETERS OF AN ACCESS TYPE, " &
"CONSTRAINT_ERROR IS RAISED: BEFORE A " &
"SUBPROGRAM CALL WHEN THE BOUNDS OR " &
"DISCRIMINANTS OF THE ACTUAL DESIGNATED " &
"PARAMETER ARE DIFFERENT FROM THOSE OF THE " &
"FORMAL DESIGNATED PARAMETER; AFTER A " &
"SUBPROGRAM CALL WHEN THE BOUNDS OR " &
"DISCRIMINANTS OF THE FORMAL DESIGNATED " &
"PARAMETER ARE DIFFERENT FROM THOSE OF THE " &
"ACTUAL DESIGNATED PARAMETER");
 
 
BEGIN
DECLARE
TYPE AST IS ACCESS STRING;
SUBTYPE AST_3 IS AST(1..3);
SUBTYPE AST_5 IS AST(3..5);
X_3 : AST_3 := NEW STRING(1..IDENT_INT(3));
 
PROCEDURE P1 (X : IN OUT AST_5) IS
BEGIN
FAILED("EXCEPTION NOT RAISED BEFORE CALL -P1 (A)");
END P1;
BEGIN
P1 (AST_5 (X_3));
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P1 (A)");
END;
 
DECLARE
TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
TYPE A_ARRAY IS ACCESS ARRAY_TYPE;
SUBTYPE A1_ARRAY IS A_ARRAY (1..IDENT_INT(3));
TYPE A2_ARRAY IS NEW A_ARRAY (2..4);
A0 : A1_ARRAY := NEW ARRAY_TYPE (1..3);
 
PROCEDURE P2 (X : IN OUT A2_ARRAY) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P2 (A)");
END P2;
BEGIN
P2 (A2_ARRAY (A0));
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P2 (A)");
END;
 
DECLARE
TYPE SUBINT IS RANGE 0..8;
TYPE REC1 (DISC : SUBINT := 8) IS
RECORD
FIELD : SUBINT := DISC;
END RECORD;
TYPE A1_REC IS ACCESS REC1;
TYPE A2_REC IS NEW A1_REC(3);
A0 : A1_REC := NEW REC1(4);
 
PROCEDURE P3 (X : IN OUT A2_REC) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED BEFORE CALL " &
"-P3 (A)");
END P3;
 
BEGIN
P3 (A2_REC (A0));
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P3 (A)");
END;
 
END;
 
 
BEGIN
DECLARE
TYPE AST IS ACCESS STRING;
SUBTYPE AST_3 IS AST(IDENT_INT(1)..IDENT_INT(3));
X_3 : AST_3 := NEW STRING'(1..IDENT_INT(3) => 'A');
CALLED : BOOLEAN := FALSE;
 
PROCEDURE P1 (X : IN OUT AST) IS
BEGIN
CALLED := TRUE;
X := NEW STRING'(3..5 => 'C');
END P1;
BEGIN
P1 (AST (X_3));
IF X_3.ALL = STRING'(1 .. 3 => 'A') THEN
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B1)");
ELSE
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B2)");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL" &
"-P1 (B)");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P1 (B)");
END;
 
DECLARE
TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
TYPE A_ARRAY IS ACCESS ARRAY_TYPE;
SUBTYPE A1_ARRAY IS A_ARRAY (1..IDENT_INT(3));
A0 : A1_ARRAY := NEW ARRAY_TYPE'(1..3 => TRUE);
CALLED : BOOLEAN := FALSE;
 
PROCEDURE P2 (X : IN OUT A_ARRAY) IS
BEGIN
CALLED := TRUE;
X := NEW ARRAY_TYPE'(2..4 => FALSE);
END P2;
BEGIN
P2 (A_ARRAY (A0));
IF A0.ALL = ARRAY_TYPE'(1 .. 3 => TRUE) THEN
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (B1)");
ELSE
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (B2)");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL" &
"-P1 (B)");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P2 (B)");
END;
 
DECLARE
TYPE SUBINT IS RANGE 0..8;
TYPE REC1 (DISC : SUBINT := 8) IS
RECORD
FIELD : SUBINT := DISC;
END RECORD;
TYPE A1_REC IS ACCESS REC1;
TYPE A2_REC IS NEW A1_REC;
A0 : A1_REC(4) := NEW REC1(4);
CALLED : BOOLEAN := FALSE;
 
PROCEDURE P3 (X : IN OUT A2_REC) IS
BEGIN
CALLED := TRUE;
X := NEW REC1;
END P3;
 
BEGIN
P3 (A2_REC (A0));
IF A0.ALL = REC1'(4,4) THEN
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P3 (B1)");
ELSE
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P3 (B2)");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL" &
"-P1 (B)");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P3 (B)");
END;
 
END;
 
RESULT;
END C64103E;
/c64107a.ada
0,0 → 1,73
-- C64107A.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 ACTUAL PARAMETERS ARE EVALUATED AND IDENTIFIED AT THE
-- TIME OF CALL.
 
-- DAS 1/29/81
-- SPS 12/13/82
 
WITH REPORT;
PROCEDURE C64107A IS
 
USE REPORT;
 
TYPE VECTOR IS ARRAY (1..10) OF INTEGER;
TYPE PTRINT IS ACCESS INTEGER;
 
I : INTEGER := 1;
A : VECTOR := (1,2,3,4,5,6,7,8,9,10);
P1 : PTRINT := NEW INTEGER'(2);
P2 : PTRINT := P1;
 
PROCEDURE PROC1 (I : OUT INTEGER; J : OUT INTEGER) IS
BEGIN
I := 10;
J := -1;
END PROC1;
 
PROCEDURE PROC2 (P : OUT PTRINT; I : OUT INTEGER) IS
BEGIN
P := NEW INTEGER'(3);
I := 5;
END PROC2;
 
BEGIN
 
TEST ("C64107A", "CHECK THAT ACTUAL PARAMETERS ARE EVALUATED" &
" AND IDENTIFIED AT THE TIME OF CALL");
 
PROC1 (I, A(I));
IF (A /= (-1,2,3,4,5,6,7,8,9,10)) THEN
FAILED ("A(I) EVALUATED UPON RETURN");
END IF;
 
PROC2 (P1, P1.ALL);
IF (P2.ALL /= 5) THEN
FAILED ("P1.ALL EVALUATED UPON RETURN");
END IF;
 
RESULT;
 
END C64107A;
/c67002e.ada
0,0 → 1,348
-- C67002E.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 OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED)
-- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS.
-- THIS TEST CHECKS RENAMING DECLARATIONS FOR THESE FUNCTIONS.
-- SUBTESTS ARE:
-- (A) THROUGH (P): "=", "AND", "OR", "XOR", "<", "<=",
-- ">", ">=", "&", "*", "/", "MOD", "REM", "**", "+", "-",
-- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS.
-- (Q), (R), (S), AND (T): "+", "-", "NOT", "ABS", RESPECTIVELY,
-- WITH ONE PARAMETER.
 
-- CPP 6/26/84
 
WITH REPORT; USE REPORT;
PROCEDURE C67002E IS
 
FUNCTION TWO_PARAMS (I1, I2 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 > I2 THEN
RETURN 'G';
ELSE RETURN 'L';
END IF;
END TWO_PARAMS;
 
FUNCTION ONE_PARAM (I1 : INTEGER) RETURN CHARACTER IS
BEGIN
IF I1 < IDENT_INT(0) THEN
RETURN 'N';
ELSE RETURN 'P';
END IF;
END ONE_PARAM;
 
BEGIN
TEST ("C67002E", "USE OF OPERATOR SYMBOLS IN " &
"(OVERLOADED) FUNCTION SPECIFICATIONS");
 
-------------------------------------------------
 
DECLARE -- (A)
 
PACKAGE PKG IS
TYPE LP IS LIMITED PRIVATE;
FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN;
PRIVATE
TYPE LP IS NEW INTEGER;
END PKG;
USE PKG;
 
LP1, LP2 : LP;
 
FUNCTION "=" (LPA, LPB : LP)
RETURN BOOLEAN RENAMES PKG."=";
 
PACKAGE BODY PKG IS
FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN IS
BEGIN
RETURN LPA > LPB;
END "=";
BEGIN
LP1 := LP (IDENT_INT (7));
LP2 := LP (IDENT_INT (8));
END PKG;
 
BEGIN -- (A)
IF (LP1 = LP2) OR NOT (LP2 = LP1) OR
(LP1 = LP1) OR (LP2 /= LP1) THEN
FAILED ("OVERLOADING OF ""="" OPERATOR DEFECTIVE");
END IF;
END; -- (A)
 
-------------------------------------------------
 
DECLARE -- (B)
FUNCTION "AND" (I1, I2 : INTEGER)
RETURN CHARACTER RENAMES TWO_PARAMS;
 
BEGIN -- (B)
IF (IDENT_INT (10) AND 1) /= 'G' OR
(5 AND 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""AND"" OPERATOR DEFECTIVE");
END IF;
END; -- (B)
 
-------------------------------------------------
 
DECLARE -- (C)
FUNCTION "OR" (I1, I2 : INTEGER)
RETURN CHARACTER RENAMES TWO_PARAMS;
 
BEGIN -- (C)
IF (IDENT_INT (10) OR 1) /= 'G' OR
(5 OR 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""OR"" OPERATOR DEFECTIVE");
END IF;
END; -- (C)
 
-------------------------------------------------
 
DECLARE -- (D)
FUNCTION "XOR" (I1, I2 : INTEGER)
RETURN CHARACTER RENAMES TWO_PARAMS;
 
BEGIN -- (D)
IF (IDENT_INT (10) XOR 1) /= 'G' OR
(5 XOR 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""XOR"" OPERATOR DEFECTIVE");
END IF;
END; -- (D)
 
-------------------------------------------------
 
DECLARE -- (E)
FUNCTION "<" (I1, I2 : INTEGER)
RETURN CHARACTER RENAMES TWO_PARAMS;
 
BEGIN -- (E)
IF (IDENT_INT (10) < 1) /= 'G' OR
(5 < 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""<"" OPERATOR DEFECTIVE");
END IF;
END; -- (E)
 
-------------------------------------------------
 
DECLARE -- (F)
FUNCTION "<=" (I1, I2 : INTEGER)
RETURN CHARACTER RENAMES TWO_PARAMS;
 
BEGIN -- (F)
IF (IDENT_INT (10) <= 1) /= 'G' OR
(5 <= 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""<="" OPERATOR DEFECTIVE");
END IF;
END; -- (F)
 
-------------------------------------------------
 
DECLARE -- (G)
FUNCTION ">" (I1, I2 : INTEGER)
RETURN CHARACTER RENAMES TWO_PARAMS;
 
BEGIN -- (G)
IF (IDENT_INT (10) > 1) /= 'G' OR
(5 > 10) /= 'L' THEN
FAILED ("OVERLOADING OF "">"" OPERATOR DEFECTIVE");
END IF;
END; -- (G)
 
-------------------------------------------------
 
DECLARE -- (H)
FUNCTION ">=" (I1, I2 : INTEGER)
RETURN CHARACTER RENAMES TWO_PARAMS;
 
BEGIN -- (H)
IF (IDENT_INT (10) >= 1) /= 'G' OR
(5 >= 10) /= 'L' THEN
FAILED ("OVERLOADING OF "">="" OPERATOR DEFECTIVE");
END IF;
END; -- (H)
 
-------------------------------------------------
 
DECLARE -- (I)
FUNCTION "&" (I1, I2 : INTEGER)
RETURN CHARACTER RENAMES TWO_PARAMS;
 
BEGIN -- (I)
IF (IDENT_INT (10) & 1) /= 'G' OR
(5 & 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""&"" OPERATOR DEFECTIVE");
END IF;
END; -- (I)
 
-------------------------------------------------
 
DECLARE -- (J)
FUNCTION "*" (I1, I2 : INTEGER)
RETURN CHARACTER RENAMES TWO_PARAMS;
 
BEGIN -- (J)
IF (IDENT_INT (10) * 1) /= 'G' OR
(5 * 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""*"" OPERATOR DEFECTIVE");
END IF;
END; -- (J)
 
-------------------------------------------------
 
DECLARE -- (K)
FUNCTION "/" (I1, I2 : INTEGER)
RETURN CHARACTER RENAMES TWO_PARAMS;
 
BEGIN -- (K)
IF (IDENT_INT (10) / 1) /= 'G' OR
(5 / 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""/"" OPERATOR DEFECTIVE");
END IF;
END; -- (K)
 
-------------------------------------------------
 
DECLARE -- (L)
FUNCTION "MOD" (I1, I2 : INTEGER)
RETURN CHARACTER RENAMES TWO_PARAMS;
 
BEGIN -- (L)
IF (IDENT_INT (10) MOD 1) /= 'G' OR
(5 MOD 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""MOD"" OPERATOR DEFECTIVE");
END IF;
END; -- (L)
 
-------------------------------------------------
 
DECLARE -- (M)
FUNCTION "REM" (I1, I2 : INTEGER)
RETURN CHARACTER RENAMES TWO_PARAMS;
 
BEGIN -- (M)
IF (IDENT_INT (10) REM 1) /= 'G' OR
(5 REM 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE");
END IF;
END; -- (M)
 
-------------------------------------------------
 
DECLARE -- (N)
FUNCTION "**" (I1, I2 : INTEGER)
RETURN CHARACTER RENAMES TWO_PARAMS;
 
BEGIN -- (N)
IF (IDENT_INT (10) ** 1) /= 'G' OR
(5 ** 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""**"" OPERATOR DEFECTIVE");
END IF;
END; -- (N)
 
-------------------------------------------------
 
DECLARE -- (O)
FUNCTION "+" (I1, I2 : INTEGER)
RETURN CHARACTER RENAMES TWO_PARAMS;
 
BEGIN -- (O)
IF (IDENT_INT (10) + 1) /= 'G' OR
(5 + 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""+"" OPERATOR DEFECTIVE");
END IF;
END; -- (O)
 
-------------------------------------------------
 
DECLARE -- (P)
FUNCTION "-" (I1, I2 : INTEGER)
RETURN CHARACTER RENAMES TWO_PARAMS;
 
BEGIN -- (P)
IF (IDENT_INT (10) - 1) /= 'G' OR
(5 - 10) /= 'L' THEN
FAILED ("OVERLOADING OF ""-"" OPERATOR DEFECTIVE");
END IF;
END; -- (P)
 
-------------------------------------------------
 
DECLARE -- (Q)
FUNCTION "+" (I1 : INTEGER)
RETURN CHARACTER RENAMES ONE_PARAM;
 
BEGIN -- (Q)
IF (+ IDENT_INT(25) /= 'P') OR
(+ (0-25) /= 'N') THEN
FAILED ("OVERLOADING OF ""+"" " &
"OPERATOR (ONE OPERAND) DEFECTIVE");
END IF;
END; -- (Q)
 
-------------------------------------------------
 
DECLARE -- (R)
FUNCTION "-" (I1 : INTEGER)
RETURN CHARACTER RENAMES ONE_PARAM;
 
BEGIN -- (R)
IF (- IDENT_INT(25) /= 'P') OR
(- (0-25) /= 'N') THEN
FAILED ("OVERLOADING OF ""-"" " &
"OPERATOR (ONE OPERAND) DEFECTIVE");
END IF;
END; -- (R)
 
-------------------------------------------------
 
DECLARE -- (S)
FUNCTION "NOT" (I1 : INTEGER)
RETURN CHARACTER RENAMES ONE_PARAM;
 
BEGIN -- (S)
IF (NOT IDENT_INT(25) /= 'P') OR
(NOT (0-25) /= 'N') THEN
FAILED ("OVERLOADING OF ""NOT"" " &
"OPERATOR (ONE OPERAND) DEFECTIVE");
END IF;
END; -- (S)
 
-------------------------------------------------
 
DECLARE -- (T)
FUNCTION "ABS" (I1 : INTEGER)
RETURN CHARACTER RENAMES ONE_PARAM;
 
BEGIN -- (T)
IF (ABS IDENT_INT(25) /= 'P') OR
(ABS (0-25) /= 'N') THEN
FAILED ("OVERLOADING OF ""ABS"" " &
"OPERATOR (ONE OPERAND) DEFECTIVE");
END IF;
END; -- (T)
 
-------------------------------------------------
 
RESULT;
END C67002E;
/c66002f.ada
0,0 → 1,92
-- C66002F.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 OVERLOADED SUBPROGRAM DECLARATIONS
-- ARE PERMITTED IN WHICH THERE IS A MINIMAL
-- DIFFERENCE BETWEEN THE DECLARATIONS.
 
-- (F) ONE SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE PART,
-- THE OTHER IN AN INNER PART, AND ONE HAS ONE MORE PARAMETER
-- THAN THE OTHER; THE OMITTED PARAMETER HAS A DEFAULT VALUE.
 
-- CVP 5/4/81
-- JRK 5/8/81
-- NL 10/13/81
 
WITH REPORT;
PROCEDURE C66002F IS
 
USE REPORT;
 
BEGIN
TEST ("C66002F", "SUBPROGRAM OVERLOADING WITH " &
"MINIMAL DIFFERENCES ALLOWED");
 
--------------------------------------------------
 
-- ONE SUBPROGRAM IS IN AN OUTER DECLARATIVE
-- PART, THE OTHER IN AN INNER PART, AND ONE
-- HAS ONE MORE PARAMETER (WITH A DEFAULT
-- VALUE) THAN THE OTHER.
 
BF :
DECLARE
S : STRING (1..3) := "123";
 
PROCEDURE P (I1, I2, I3 : INTEGER := 1) IS
C : CONSTANT STRING := "CXA";
BEGIN
S(I3) := C(I3);
END P;
 
PROCEDURE ENCLOSE IS
PROCEDURE P (I1, I2 : INTEGER := 1) IS
BEGIN
S(2) := 'B';
END P;
 
BEGIN -- ENCLOSE
P (1, 2, 3);
ENCLOSE.P (1, 2); -- NOTE THAT THESE CALLS
BF.P (1, 2); -- MUST BE DISAMBIGUATED.
 
IF S /= "CBA" THEN
FAILED ("PROCEDURES IN ENCLOSING-" &
"ENCLOSED SCOPES DIFFERING " &
"ONLY IN EXISTENCE OF ONE " &
"DEFAULT-VALUED PARAMETER CAUSED " &
"CONFUSION");
END IF;
END ENCLOSE;
 
BEGIN
ENCLOSE;
END BF;
 
--------------------------------------------------
 
RESULT;
 
END C66002F;
/c64103f.ada
0,0 → 1,144
-- C64103F.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, FOR OUT PARAMETERS OF AN ACCESS TYPE,
-- CONSTRAINT_ERROR IS RAISED:
-- AFTER A SUBPROGRAM CALL WHEN THE BOUNDS OR DISCRIMINANTS
-- OF THE FORMAL DESIGNATED PARAMETER ARE DIFFERENT FROM
-- THOSE OF THE ACTUAL DESIGNATED PARAMETER.
 
-- HISTORY:
-- CPP 07/23/84 CREATED ORIGINAL TEST.
-- VCL 10/27/87 MODIFIED THIS HEADER; ADDED STATEMENTS WHICH
-- REFERENCE THE ACTUAL PARAMETERS.
 
WITH REPORT; USE REPORT;
PROCEDURE C64103F IS
BEGIN
TEST ("C64103F", "FOR OUT PARAMETERS OF AN ACCESS TYPE, " &
"CONSTRAINT_ERROR IS RAISED: AFTER A " &
"SUBPROGRAM CALL WHEN THE BOUNDS OR " &
"DISCRIMINANTS OF THE FORMAL DESIGNATED " &
"PARAMETER ARE DIFFERENT FROM THOSE OF THE " &
"ACTUAL DESIGNATED PARAMETER");
 
 
BEGIN
DECLARE
TYPE AST IS ACCESS STRING;
SUBTYPE AST_3 IS AST(IDENT_INT(1)..IDENT_INT(3));
SUBTYPE AST_5 IS AST(3..5);
X_3 : AST_3 := NEW STRING'(1..IDENT_INT(3) => 'A');
CALLED : BOOLEAN := FALSE;
 
PROCEDURE P1 (X : OUT AST_5) IS
BEGIN
CALLED := TRUE;
X := NEW STRING'(3..5 => 'C');
END P1;
BEGIN
P1 (AST_5 (X_3));
IF X_3.ALL = STRING'(1 .. 3 => 'A') THEN
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (A1)");
ELSE
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (A2)");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL " &
"-P1 (A)");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P1 (A)");
END;
 
DECLARE
TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
TYPE A_ARRAY IS ACCESS ARRAY_TYPE;
SUBTYPE A1_ARRAY IS A_ARRAY (1..IDENT_INT(3));
TYPE A2_ARRAY IS NEW A_ARRAY (2..4);
A0 : A1_ARRAY := NEW ARRAY_TYPE'(1..3 => TRUE);
CALLED : BOOLEAN := FALSE;
 
PROCEDURE P2 (X : OUT A2_ARRAY) IS
BEGIN
CALLED := TRUE;
X := NEW ARRAY_TYPE'(2..4 => FALSE);
END P2;
BEGIN
P2 (A2_ARRAY (A0));
IF A0.ALL = ARRAY_TYPE'(1 .. 3 => TRUE) THEN
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (A1)");
ELSE
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (A2)");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL " &
"-P1 (A)");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P2 (A)");
END;
 
DECLARE
TYPE SUBINT IS RANGE 0..8;
TYPE REC1 (DISC : SUBINT := 8) IS
RECORD
FIELD : SUBINT := DISC;
END RECORD;
TYPE A1_REC IS ACCESS REC1;
TYPE A2_REC IS NEW A1_REC (3);
A0 : A1_REC(4) := NEW REC1(4);
CALLED : BOOLEAN := FALSE;
 
PROCEDURE P3 (X : OUT A2_REC) IS
BEGIN
CALLED := TRUE;
X := NEW REC1(3);
END P3;
 
BEGIN
P3 (A2_REC (A0));
IF A0.ALL = REC1'(4,4) THEN
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P3 (A1)");
ELSE
FAILED ("EXCEPTION NOT RAISED AFTER CALL -P3 (A2)");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("EXCEPTION RAISED BEFORE CALL " &
"-P1 (A)");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -P3 (A)");
END;
END;
 
RESULT;
END C64103F;
/c64005da.ada
0,0 → 1,65
-- C64005DA.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.
--*
-- JRK 7/30/84
 
SEPARATE (C64005D0M)
 
PROCEDURE C64005DA (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
 
V : STRING (1..2);
 
M : CONSTANT NATURAL := LEVEL'POS (L) -
LEVEL'POS (LEVEL'FIRST) + 1;
N : CONSTANT NATURAL := 2 * M + 1;
 
PROCEDURE C64005DB (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
SEPARATE;
 
BEGIN
 
V (1) := IDENT_CHAR (ASCII.LC_A);
V (2) := C;
 
-- APPEND ALL V TO T.
T.S (T.E+1 .. T.E+N) := C64005D0M.V & C64005DA.V;
T.E := T.E + N;
 
CASE C IS
 
WHEN '1' =>
C64005DB (LEVEL'SUCC(L), IDENT_CHAR('1'), T);
 
WHEN '2' =>
C64005DA (L, IDENT_CHAR('3'), T);
 
WHEN '3' =>
C64005DB (LEVEL'SUCC(L), IDENT_CHAR('2'), T);
END CASE;
 
-- APPEND ALL L AND C TO T IN REVERSE ORDER.
T.S (T.E+1 .. T.E+N) := C64005DA.L & C64005DA.C & C64005D0M.L;
T.E := T.E + N;
 
END C64005DA;
/c66002g.ada
0,0 → 1,82
-- C66002G.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 OVERLOADED SUBPROGRAM DECLARATIONS
-- ARE PERMITTED IN WHICH THERE IS A MINIMAL
-- DIFFERENCE BETWEEN THE DECLARATIONS.
 
-- (G) THE RESULT TYPE OF TWO FUNCTION DECLARATIONS IS DIFFERENT.
 
-- CVP 5/4/81
-- JRK 5/8/81
-- NL 10/13/81
-- SPS 10/26/82
 
WITH REPORT;
PROCEDURE C66002G IS
 
USE REPORT;
 
BEGIN
TEST ("C66002G", "SUBPROGRAM OVERLOADING WITH " &
"MINIMAL DIFFERENCES ALLOWED");
 
--------------------------------------------------
 
-- THE RESULT TYPES OF TWO FUNCTION
-- DECLARATIONS ARE DIFFERENT.
 
DECLARE
I : INTEGER;
B : BOOLEAN;
S : STRING (1..2) := "12";
 
FUNCTION F RETURN INTEGER IS
BEGIN
S(1) := 'A';
RETURN IDENT_INT (0); -- THIS VALUE IS IRRELEVENT.
END F;
 
FUNCTION F RETURN BOOLEAN IS
BEGIN
S(2) := 'B';
RETURN IDENT_BOOL (TRUE); -- THIS VALUE IS IRRELEVANT.
END F;
 
BEGIN
I := F;
B := F;
 
IF S /= "AB" THEN
FAILED ("FUNCTIONS DIFFERING ONLY IN " &
"BASE TYPE OF RETURNED VALUE " &
"CAUSED CONFUSION");
END IF;
END;
 
--------------------------------------------------
 
RESULT;
 
END C66002G;
/c64005db.ada
0,0 → 1,67
-- C64005DB.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.
--*
-- JRK 7/30/84
 
SEPARATE (C64005D0M.C64005DA)
 
PROCEDURE C64005DB (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
 
V : STRING (1..2);
 
M : CONSTANT NATURAL := LEVEL'POS (L) -
LEVEL'POS (LEVEL'FIRST) + 1;
N : CONSTANT NATURAL := 2 * M + 1;
 
PROCEDURE C64005DC (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
SEPARATE;
 
BEGIN
 
V (1) := IDENT_CHAR (ASCII.LC_B);
V (2) := C;
 
-- APPEND ALL V TO T.
T.S (T.E+1 .. T.E+N) := C64005D0M.V & C64005DA.V & C64005DB.V;
T.E := T.E + N;
 
CASE C IS
 
WHEN '1' =>
C64005DC (LEVEL'SUCC(L), IDENT_CHAR('1'), T);
 
WHEN '2' =>
C64005DB (L, IDENT_CHAR('3'), T);
 
WHEN '3' =>
C64005DC (LEVEL'SUCC(L), IDENT_CHAR('2'), T);
END CASE;
 
-- APPEND ALL L AND C TO T IN REVERSE ORDER.
T.S (T.E+1 .. T.E+N) := C64005DB.L & C64005DB.C &
C64005DA.L & C64005DA.C &
C64005D0M.L;
T.E := T.E + N;
 
END C64005DB;
/c640001.a
0,0 → 1,334
-- C640001.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 prefix of a subprogram call with an actual parameter
-- part may be an implicit dereference of an access-to-subprogram value.
-- Check that, for an access-to-subprogram type whose designated profile
-- contains parameters of a tagged generic formal type, an access-to-
-- subprogram value may designate dispatching and non-dispatching
-- operations, and that dereferences of such a value call the appropriate
-- subprogram.
--
-- TEST DESCRIPTION:
-- The test declares a tagged type (Table) with a dispatching operation
-- (Clear), as well as a derivative (Table2) which overrides that
-- operation. A subprogram with the same name and profile as Clear is
-- declared in a separate package -- it is therefore not a dispatching
-- operation of Table. For the purposes of the test, each version of Clear
-- modifies the components of its parameter in a unique way.
--
-- Additionally, an operation (Reset) of type Table is declared which
-- makes a re-dispatching call to Clear, i.e.,
--
-- procedure Reset (A: in out Table) is
-- begin
-- ...
-- Clear (Table'Class(A)); -- Re-dispatch based on tag of actual.
-- ...
-- end Reset;
--
-- An access-to-subprogram type is declared within a generic package,
-- with a designated profile which declares a parameter of a generic
-- formal tagged private type.
--
-- The generic is instantiated with type Table. The instance defines an
-- array of access-to-subprogram values (which represents a table of
-- operations to be performed sequentially on a single operand).
-- Access values designating the dispatching version of Clear, the
-- non-dispatching version of Clear, and Reset (which re-dispatches to
-- Clear) are placed in this array.
--
-- In the instance, each subprogram in the array is called by implicitly
-- dereferencing the corresponding access value. For the dispatching and
-- non-dispatching versions of Clear, the actual parameter passed is of
-- type Table. For Reset, the actual parameter passed is a view conversion
-- of an object of type Table2 to type Table, i.e., Table(Table2_Obj).
-- Since the tag of the operand never changes, the call to Clear within
-- Reset should execute Table2's version of Clear.
--
-- The main program verifies that the appropriate version of Clear is
-- called in each case, by checking that the components of the actual are
-- updated as expected.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
package C640001_0 is
 
-- Data type artificial for testing purposes.
 
Row_Len : constant := 10;
 
T : constant Boolean := True;
F : constant Boolean := False;
 
type Row_Type is array (1 .. Row_Len) of Boolean;
 
function Is_True (A : in Row_Type) return Boolean;
function Is_False (A : in Row_Type) return Boolean;
 
 
Init : constant Row_Type := (T, F, T, F, T, F, T, F, T, F);
 
type Table is tagged record -- Tagged type.
Row1 : Row_Type := Init;
Row2 : Row_Type := Init;
end record;
 
procedure Clear (A : in out Table); -- Dispatching operation.
 
procedure Reset (A : in out Table); -- Re-dispatching operation.
 
-- ...Other operations.
 
 
type Table2 is new Table with null record; -- Extension of Table (but
-- structurally identical).
 
procedure Clear (A : in out Table2); -- Overrides parent's op.
 
-- ...Other operations.
 
 
end C640001_0;
 
 
--===================================================================--
 
 
package body C640001_0 is
 
function Is_True (A : in Row_Type) return Boolean is
begin
for I in A'Range loop
if A(I) /= True then -- Return true if all elements
return False; -- of A are True.
end if;
end loop;
return True;
end Is_True;
 
 
function Is_False (A : in Row_Type) return Boolean is
begin
return A = Row_Type'(others => False); -- Return true if all elements
end Is_False; -- of A are False.
 
 
procedure Clear (A : in out Table) is
begin
for I in Row_Type'Range loop -- This version of Clear sets
A.Row1(I) := False; -- the elements of Row1 only
end loop; -- to False.
end Clear;
 
 
procedure Reset (A : in out Table) is
begin
Clear (Table'Class(A)); -- Redispatch to appropriate
-- ... Other "reset" activities. -- version of Clear.
end Reset;
 
 
procedure Clear (A : in out Table2) is
begin
for I in Row_Type'Range loop -- This version of Clear sets
A.Row1(I) := True; -- the elements of Row1 only
end loop; -- to True.
end Clear;
 
 
end C640001_0;
 
 
--===================================================================--
 
 
with C640001_0;
package C640001_1 is
 
procedure Clear (T : in out C640001_0.Table); -- Non-dispatching operation.
 
end C640001_1;
 
 
--===================================================================--
 
 
package body C640001_1 is
 
procedure Clear (T : in out C640001_0.Table) is
begin
for I in C640001_0.Row_Type'Range loop -- This version of Clear sets
T.Row2(I) := True; -- the elements of Row2 only
end loop; -- to True.
end Clear;
 
end C640001_1;
 
 
--===================================================================--
 
 
-- This unit represents a support package for table-driven processing of
-- data objects. Process_Operand performs a set of operations are performed
-- sequentially on a single operand. Note that parameters are provided to
-- specify which subset of operations in the operations table are to be
-- performed (ordinarily these might be omitted, but the test requires that
-- each operation be called individually for a single operand).
 
generic
type Tag is tagged private;
package C640001_2 is
 
type Proc_Ptr is access procedure (P: in out Tag);
 
type Op_List is private;
 
procedure Add_Op (Op : in Proc_Ptr; -- Add operation to
List : in out Op_List); -- to list of ops.
 
procedure Process_Operand (Operand : in out Tag; -- Execute a subset
List : in Op_List; -- of a list of
First_Op : in Positive; -- operations using
Last_Op : in Positive); -- a given operand.
 
-- ...Other operations.
 
private
type Op_Array is array (1 .. 3) of Proc_Ptr;
 
type Op_List is record
Top : Natural := 0;
Ops : Op_Array;
end record;
end C640001_2;
 
 
--===================================================================--
 
 
package body C640001_2 is
 
procedure Add_Op (Op : in Proc_Ptr;
List : in out Op_List) is
begin
List.Top := List.Top + 1; -- Artificial; no Constraint_Error protection.
List.Ops(List.Top) := Op;
end Add_Op;
 
 
procedure Process_Operand (Operand : in out Tag;
List : in Op_List;
First_Op : in Positive;
Last_Op : in Positive) is
begin
for I in First_Op .. Last_Op loop
List.Ops(I)(Operand); -- Implicit dereference of an
end loop; -- access-to-subprogram value.
end Process_Operand;
 
end C640001_2;
 
 
--===================================================================--
 
 
with C640001_0;
with C640001_1;
with C640001_2;
 
with Report;
procedure C640001 is
 
package Table_Support is new C640001_2 (C640001_0.Table);
 
Sub_Ptr : Table_Support.Proc_Ptr;
My_List : Table_Support.Op_List;
My_Table1 : C640001_0.Table; -- Initial values of both Row1 &
-- Row2 are (T,F,T,F,T,F,T,F,T,F).
My_Table2 : C640001_0.Table2; -- Initial values of both Row1 &
-- Row2 are (T,F,T,F,T,F,T,F,T,F).
begin
Report.Test ("C640001", "Check that, for an access-to-subprogram type " &
"whose designated profile contains parameters " &
"of a tagged generic formal type, an access-" &
"to-subprogram value may designate dispatching " &
"and non-dispatching operations");
 
--
-- Add subprogram access values to list:
--
 
Sub_Ptr := C640001_0.Clear'Access; -- Designates dispatching op.
Table_Support.Add_Op (Sub_Ptr, My_List); -- (1st operation on My_List).
 
Sub_Ptr := C640001_1.Clear'Access; -- Designates non-dispatching op.
Table_Support.Add_Op (Sub_Ptr, My_List); -- (2nd operation on My_List).
 
Sub_Ptr := C640001_0.Reset'Access; -- Designates re-dispatching op.
Table_Support.Add_Op (Sub_Ptr, My_List); -- (3rd operation on My_List).
 
 
--
-- Call dispatching operation:
--
 
Table_Support.Process_Operand (My_Table1, My_List, 1, 1); -- Call 1st op.
if not C640001_0.Is_False (My_Table1.Row1) then
Report.Failed ("Wrong result after calling dispatching operation");
end if;
 
 
--
-- Call non-dispatching operation:
--
 
Table_Support.Process_Operand (My_Table1, My_List, 2, 2); -- Call 2nd op.
if not C640001_0.Is_True (My_Table1.Row2) then
Report.Failed ("Wrong result after calling non-dispatching operation");
end if;
 
 
--
-- Call re-dispatching operation:
--
 
Table_Support.Process_Operand (C640001_0.Table(My_Table2), -- View conv.
My_List, 3, 3); -- Call 3rd op.
if not C640001_0.Is_True (My_Table2.Row1) then
Report.Failed ("Wrong result after calling re-dispatching operation");
end if;
 
 
Report.Result;
end C640001;
/c64005dc.ada
0,0 → 1,74
-- C64005DC.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.
--*
-- JRK 7/30/84
 
SEPARATE (C64005D0M.C64005DA.C64005DB)
 
PROCEDURE C64005DC (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
 
V : STRING (1..2);
 
M : CONSTANT NATURAL := LEVEL'POS (L) -
LEVEL'POS (LEVEL'FIRST) + 1;
N : CONSTANT NATURAL := 2 * M + 1;
 
BEGIN
 
V (1) := IDENT_CHAR (ASCII.LC_C);
V (2) := C;
 
-- APPEND ALL V TO T.
T.S (T.E+1 .. T.E+N) := C64005D0M.V & C64005DA.V & C64005DB.V &
C64005DC.V;
T.E := T.E + N;
 
CASE C IS
 
WHEN '1' =>
C64005DA (IDENT_CHAR(LEVEL'FIRST), IDENT_CHAR('2'), T);
 
WHEN '2' =>
C64005DC (L, IDENT_CHAR('3'), T);
 
WHEN '3' =>
-- APPEND MID-POINT SYMBOL TO T.
T.S (T.E+1) := IDENT_CHAR ('=');
T.E := T.E + 1;
 
-- G := CATENATE ALL V, L, C;
G := C64005D0M.V & C64005D0M.L &
C64005DA.V & C64005DA.L & C64005DA.C &
C64005DB.V & C64005DB.L & C64005DB.C &
C64005DC.V & C64005DC.L & C64005DC.C;
END CASE;
 
-- APPEND ALL L AND C TO T IN REVERSE ORDER.
T.S (T.E+1 .. T.E+N) := C64005DC.L & C64005DC.C &
C64005DB.L & C64005DB.C &
C64005DA.L & C64005DA.C &
C64005D0M.L;
T.E := T.E + N;
 
END C64005DC;
/c62003a.ada
0,0 → 1,234
-- C62003A.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 SCALAR AND ACCESS PARAMETERS ARE COPIED.
-- SUBTESTS ARE:
-- (A) SCALAR PARAMETERS TO PROCEDURES.
-- (B) SCALAR PARAMETERS TO FUNCTIONS.
-- (C) ACCESS PARAMETERS TO PROCEDURES.
-- (D) ACCESS PARAMETERS TO FUNCTIONS.
 
-- DAS 01/14/80
-- SPS 10/26/82
-- CPP 05/25/84
-- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
 
WITH REPORT;
PROCEDURE C62003A IS
 
USE REPORT;
 
BEGIN
TEST ("C62003A", "CHECK THAT SCALAR AND ACCESS PARAMETERS ARE " &
"COPIED");
 
--------------------------------------------------
 
DECLARE -- (A)
 
I : INTEGER;
E : EXCEPTION;
 
PROCEDURE P (PI : IN INTEGER; PO : OUT INTEGER;
PIO : IN OUT INTEGER) IS
 
TMP : INTEGER;
 
BEGIN
 
TMP := PI; -- SAVE VALUE OF PI AT PROC ENTRY.
 
PO := 10;
IF (PI /= TMP) THEN
FAILED ("ASSIGNMENT TO SCALAR OUT " &
"PARAMETER CHANGES THE VALUE OF " &
"INPUT PARAMETER");
TMP := PI; -- RESET TMP FOR NEXT CASE.
END IF;
 
PIO := PIO + 100;
IF (PI /= TMP) THEN
FAILED ("ASSIGNMENT TO SCALAR IN OUT " &
"PARAMETER CHANGES THE VALUE OF " &
"INPUT PARAMETER");
TMP := PI; -- RESET TMP FOR NEXT CASE.
END IF;
 
I := I + 1;
IF (PI /= TMP) THEN
FAILED ("ASSIGNMENT TO SCALAR ACTUAL " &
"PARAMETER CHANGES THE VALUE OF " &
"INPUT PARAMETER");
END IF;
 
RAISE E; -- CHECK EXCEPTION HANDLING.
END P;
 
BEGIN -- (A)
I := 0; -- INITIALIZE I SO VARIOUS CASES CAN BE DETECTED.
P (I, I, I);
FAILED ("EXCEPTION NOT RAISED - A");
EXCEPTION
WHEN E =>
IF (I /= 1) THEN
CASE I IS
WHEN 11 =>
FAILED ("OUT ACTUAL SCALAR PARAMETER " &
"CHANGED GLOBAL VALUE");
WHEN 101 =>
FAILED ("IN OUT ACTUAL SCALAR " &
"PARAMETER CHANGED GLOBAL VALUE");
WHEN 111 =>
FAILED ("OUT AND IN OUT ACTUAL SCALAR " &
"PARAMETERS CHANGED GLOBAL " &
"VALUE");
WHEN OTHERS =>
FAILED ("UNDETERMINED CHANGE TO GLOBAL " &
"VALUE");
END CASE;
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - A");
END; -- (A)
 
--------------------------------------------------
 
DECLARE -- (B)
 
I,J : INTEGER;
 
FUNCTION F (FI : IN INTEGER) RETURN INTEGER IS
 
TMP : INTEGER := FI;
 
BEGIN
 
I := I + 1;
IF (FI /= TMP) THEN
FAILED ("ASSIGNMENT TO SCALAR ACTUAL FUNCTION " &
"PARAMETER CHANGES THE VALUE OF " &
"INPUT PARAMETER");
END IF;
 
RETURN (100);
END F;
 
BEGIN -- (B)
I := 100;
J := F(I);
END; -- (B)
 
--------------------------------------------------
 
DECLARE -- (C)
 
TYPE ACCTYPE IS ACCESS INTEGER;
 
I : ACCTYPE;
E : EXCEPTION;
 
PROCEDURE P (PI : IN ACCTYPE; PO : OUT ACCTYPE;
PIO : IN OUT ACCTYPE) IS
 
TMP : ACCTYPE;
 
BEGIN
 
TMP := PI; -- SAVE VALUE OF PI AT PROC ENTRY.
 
I := NEW INTEGER'(101);
IF (PI /= TMP) THEN
FAILED ("ASSIGNMENT TO ACCESS ACTUAL " &
"PARAMETER CHANGES THE VALUE OF " &
"INPUT PARAMETER");
TMP := PI; -- RESET TMP FOR NEXT CASE.
END IF;
 
PO := NEW INTEGER'(1);
IF (PI /= TMP) THEN
FAILED ("ASSIGNMENT TO ACCESS OUT " &
"PARAMETER CHANGES THE VALUE OF " &
"INPUT PARAMETER");
TMP := PI; -- RESET TMP FOR NEXT CASE.
END IF;
 
PIO := NEW INTEGER'(10);
IF (PI /= TMP) THEN
FAILED ("ASSIGNMENT TO ACCESS IN OUT " &
"PARAMETER CHANGES THE VALUE OF " &
"INPUT PARAMETER");
END IF;
 
RAISE E; -- CHECK EXCEPTION HANDLING.
END P;
 
BEGIN -- (C)
I := NEW INTEGER'(100);
P (I, I, I);
FAILED ("EXCEPTION NOT RAISED - C");
EXCEPTION
WHEN E =>
IF (I.ALL /= 101) THEN
FAILED ("OUT OR IN OUT ACTUAL PROCEDURE " &
"PARAMETER VALUE CHANGED DESPITE " &
"RAISED EXCEPTION");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - C");
END; -- (C)
 
--------------------------------------------------
 
DECLARE -- (D)
 
TYPE ACCTYPE IS ACCESS INTEGER;
 
I,J : ACCTYPE;
 
FUNCTION F (FI : IN ACCTYPE) RETURN ACCTYPE IS
 
TMP : ACCTYPE := FI;
 
BEGIN
 
I := NEW INTEGER;
IF (FI /= TMP) THEN
FAILED ("ASSIGNMENT TO ACCESS ACTUAL FUNCTION " &
"PARAMETER CHANGES THE VALUE OF " &
"INPUT PARAMETER");
END IF;
 
RETURN (NULL);
END F;
 
BEGIN -- (D)
I := NULL;
J := F(I);
END; -- (D)
 
--------------------------------------------------
 
RESULT;
 
END C62003A;
/c62003b.ada
0,0 → 1,301
-- C62003B.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 PRIVATE TYPES IMPLEMENTED AS SCALAR OR ACCESS TYPES ARE
-- PASSED BY COPY.
-- SUBTESTS ARE:
-- (A) PRIVATE SCALAR PARAMETERS TO PROCEDURES.
-- (B) PRIVATE SCALAR PARAMETERS TO FUNCTIONS.
-- (C) PRIVATE ACCESS PARAMETERS TO PROCEDURES.
-- (D) PRIVATE ACCESS PARAMETERS TO FUNCTIONS.
 
-- CPP 05/25/84
-- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
 
WITH REPORT; USE REPORT;
PROCEDURE C62003B IS
 
BEGIN
TEST("C62003B", "CHECK THAT PRIVATE SCALAR AND ACCESS " &
"PARAMETERS ARE COPIED");
 
---------------------------------------------------
 
A_B: DECLARE
 
PACKAGE SCALAR_PKG IS
 
TYPE T IS PRIVATE;
C0 : CONSTANT T;
C1 : CONSTANT T;
C10 : CONSTANT T;
C100 : CONSTANT T;
 
FUNCTION "+" (OLD : IN T; INCREMENT : IN T) RETURN T;
FUNCTION CONVERT (OLD_PRIVATE : IN T) RETURN INTEGER;
 
PRIVATE
TYPE T IS NEW INTEGER;
C0 : CONSTANT T := 0;
C1 : CONSTANT T := 1;
C10 : CONSTANT T := 10;
C100 : CONSTANT T := 100;
 
END SCALAR_PKG;
 
 
PACKAGE BODY SCALAR_PKG IS
 
FUNCTION "+" (OLD : IN T; INCREMENT : IN T) RETURN T IS
BEGIN -- "+"
RETURN T(INTEGER(OLD) + INTEGER(INCREMENT));
END "+";
 
FUNCTION CONVERT (OLD_PRIVATE : IN T) RETURN INTEGER IS
BEGIN -- CONVERT
RETURN INTEGER(OLD_PRIVATE);
END CONVERT;
 
END SCALAR_PKG;
 
USE SCALAR_PKG;
 
---------------------------------------------------
 
BEGIN -- A_B
 
A : DECLARE
 
I : T;
E : EXCEPTION;
 
PROCEDURE P (PI : IN T; PO : OUT T; PIO : IN OUT T) IS
 
TEMP : T;
 
BEGIN -- P
 
TEMP := PI; -- SAVE VALUE OF PI AT PROC ENTRY.
 
PO := C10;
IF (PI /= TEMP) THEN
FAILED ("ASSIGNMENT TO PRIVATE (SCALAR) OUT " &
"PARAMETER CHANGES THE VALUE OF " &
"INPUT PARAMETER");
TEMP := PI; -- RESET TEMP FOR NEXT CASE.
END IF;
 
PIO := PIO + C100;
IF (PI /= TEMP) THEN
FAILED ("ASSIGNMENT TO PRIVATE (SCALAR) IN " &
"OUT PARAMETER CHANGES THE VALUE OF " &
"INPUT PARAMETER");
TEMP := PI; -- RESET TEMP FOR NEXT CASE.
END IF;
 
I := I + C1;
IF (PI /= TEMP) THEN
FAILED ("ASSIGNMENT TO PRIVATE (SCALAR) " &
"ACTUAL PARAMETER CHANGES THE " &
"VALUE OF INPUT PARAMETER");
END IF;
 
RAISE E; -- CHECK EXCEPTION HANDLING.
END P;
 
BEGIN -- A
I := C0; -- INITIALIZE I SO VARIOUS CASES CAN BE
-- DETECTED.
P (I, I, I);
FAILED ("EXCEPTION NOT RAISED - A");
EXCEPTION
WHEN E =>
IF (I /= C1) THEN
CASE CONVERT(I) IS
WHEN 11 =>
FAILED ("OUT ACTUAL PRIVATE " &
"(SCALAR) PARAMETER " &
"CHANGED GLOBAL VALUE");
WHEN 101 =>
FAILED ("IN OUT ACTUAL PRIVATE " &
"(SCALAR) PARAMETER " &
"CHANGED GLOBAL VALUE");
WHEN 111 =>
FAILED ("OUT AND IN OUT ACTUAL " &
"PRIVATE (SCALAR) " &
"PARAMETER CHANGED " &
"GLOBAL VALUE");
WHEN OTHERS =>
FAILED ("UNDETERMINED CHANGE TO " &
"GLOBAL VALUE");
END CASE;
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - A");
END A;
 
---------------------------------------------------
 
B : DECLARE
 
I, J : T;
 
FUNCTION F (FI : IN T) RETURN T IS
 
TEMP : T := FI; -- SAVE VALUE OF FI AT FN ENTRY.
 
BEGIN -- F
 
I := I + C1;
IF (FI /= TEMP) THEN
FAILED ("ASSIGNMENT TO PRIVATE (SCALAR) " &
"ACTUAL FUNCTION PARAMETER CHANGES " &
"THE VALUE OF INPUT PARAMETER ");
END IF;
 
RETURN C0;
END F;
 
BEGIN -- B
I := C0;
J := F(I);
END B;
 
END A_B;
 
---------------------------------------------------
 
C_D: DECLARE
 
PACKAGE ACCESS_PKG IS
 
TYPE T IS PRIVATE;
C_NULL : CONSTANT T;
C1 : CONSTANT T;
C10 : CONSTANT T;
C100 : CONSTANT T;
C101 : CONSTANT T;
 
PRIVATE
TYPE T IS ACCESS INTEGER;
C_NULL : CONSTANT T := NULL;
C1 : CONSTANT T := NEW INTEGER'(1);
C10 : CONSTANT T := NEW INTEGER'(10);
C100 : CONSTANT T := NEW INTEGER'(100);
C101 : CONSTANT T := NEW INTEGER'(101);
 
END ACCESS_PKG;
 
USE ACCESS_PKG;
 
---------------------------------------------------
 
BEGIN -- C_D;
 
C : DECLARE
 
I : T;
E : EXCEPTION;
PROCEDURE P (PI : IN T; PO : OUT T; PIO : IN OUT T) IS
 
TEMP : T;
 
BEGIN -- P
 
TEMP := PI; -- SAVE VALUE OF PI AT PROC ENTRY.
 
I := C101;
IF (PI /= TEMP) THEN
FAILED ("ASSIGNMENT TO PRIVATE (ACCESS) " &
"ACTUAL VARIABLE CHANGES THE VALUE " &
"OF INPUT PARAMETER");
TEMP := PI; -- RESET TEMP FOR NEXT CASE.
END IF;
 
PO := C1;
IF (PI /= TEMP) THEN
FAILED ("ASSIGNMENT TO PRIVATE (ACCESS) OUT " &
"PARAMETER CHANGES THE VALUE OF " &
"INPUT PARAMETER");
TEMP := PI; -- RESET TEMP FOR NEXT CASE.
END IF;
 
PIO := C10;
IF (PI /= TEMP) THEN
FAILED ("ASSIGNMENT TO PRIVATE (ACCESS) IN " &
"OUT PARAMETER CHANGES THE VALUE " &
"OF INPUT PARAMETER");
END IF;
 
RAISE E; -- CHECK EXCEPTION HANDLING.
END P;
 
BEGIN -- C
I := C100;
P (I, I, I);
FAILED ("EXCEPTION NOT RAISED - C");
EXCEPTION
WHEN E =>
IF (I /= C101) THEN
FAILED ("OUT OR IN OUT ACTUAL PROCEDURE " &
"PARAMETER VALUE CHANGED DESPITE " &
"RAISED EXCEPTION");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - C");
END C;
 
---------------------------------------------------
 
D : DECLARE
 
I, J : T;
 
FUNCTION F (FI : IN T) RETURN T IS
 
TEMP : T := FI; -- SAVE VALUE OF FI AT FN ENTRY.
 
BEGIN -- F
I := C100;
IF (FI /= TEMP) THEN
FAILED ("ASSIGNMENT TO PRIVATE " &
"(ACCESS) ACTUAL FUNCTION " &
"PARAMETER CHANGES THE VALUE " &
"OF INPUT PARAMETER");
END IF;
RETURN C_NULL;
END F;
 
BEGIN -- D
I := C_NULL;
J := F(I);
END D;
 
END C_D;
 
---------------------------------------------------
 
RESULT;
 
END C62003B;
/c64201b.ada
0,0 → 1,101
-- C64201B.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 INITALIZATION OF IN PARAMETERS OF A TASK
-- TYPE IS PERMITTED.
-- (SEE ALSO 7.4.4/T2 FOR TESTS OF LIMITED PRIVATE TYPES.)
 
-- CVP 5/14/81
-- ABW 7/1/82
-- BHS 7/9/84
 
WITH REPORT;
PROCEDURE C64201B IS
 
USE REPORT;
 
BEGIN
 
TEST( "C64201B" , "CHECK THAT INITIALIZATION OF IN PARAMETERS " &
"OF A TASK TYPE IS PERMITTED" );
 
DECLARE
 
GLOBAL : INTEGER := 10;
 
TASK TYPE T_TYPE IS
ENTRY E (X : IN OUT INTEGER);
END;
 
TSK1, TSK2 : T_TYPE;
 
TASK BODY T_TYPE IS
BEGIN
ACCEPT E (X : IN OUT INTEGER) DO
X := X - 1;
END E;
ACCEPT E (X : IN OUT INTEGER) DO
X := X + 1;
END E;
END T_TYPE;
 
 
PROCEDURE PROC1 (T : T_TYPE := TSK1) IS
BEGIN
T.E (X => GLOBAL);
END PROC1;
 
PROCEDURE PROC2 (T : T_TYPE := TSK1) IS
BEGIN
T.E (X => GLOBAL);
IF (GLOBAL /= IDENT_INT(8)) THEN
FAILED( "TASK NOT PASSED IN PROC1, " &
"DEFAULT TSK1 EMPLOYED" );
END IF;
END PROC2;
 
PROCEDURE TERM (T : T_TYPE; NUM : CHARACTER) IS
BEGIN
IF NOT T'TERMINATED THEN
ABORT T;
COMMENT ("ABORTING TASK " & NUM);
END IF;
END TERM;
 
BEGIN
 
PROC1(TSK2);
IF GLOBAL /= 9 THEN
FAILED ("INCORRECT GLOBAL VALUE AFTER PROC1");
ELSE
PROC2;
END IF;
 
TERM(TSK1, '1');
TERM(TSK2, '2');
END;
 
RESULT;
 
END C64201B;
/c65003a.ada
0,0 → 1,100
-- C65003A.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 IF NO RETURN STATEMENT IS EXECUTED, A FUNCTION RAISES
-- PROGRAM_ERROR. DETERMINE WHERE THE EXCEPTION IS RAISED.
 
-- THIS LACK OF AN EXECUTABLE RETURN IS DETECTABLE AT COMPILE TIME IN
-- THIS TEST.
 
-- JBG 10/14/83
-- SPS 2/22/84
 
WITH REPORT; USE REPORT;
PROCEDURE C65003A IS
 
EXCEPTION_RAISED : BOOLEAN := FALSE;
FUNCTION RETURN_IN_EXCEPTION RETURN INTEGER IS
BEGIN
IF FALSE THEN
RETURN 5;
END IF;
EXCEPTION
WHEN PROGRAM_ERROR =>
COMMENT ("PROGRAM_ERROR RAISED IN FUNCTION BODY - " &
"RETURN_IN_EXCEPTION");
EXCEPTION_RAISED := TRUE;
RETURN 5;
END RETURN_IN_EXCEPTION;
 
FUNCTION NO_RETURN RETURN INTEGER IS
NO_RETURN_EXCEPTION : EXCEPTION;
BEGIN
RAISE NO_RETURN_EXCEPTION;
RETURN 5;
EXCEPTION
WHEN NO_RETURN_EXCEPTION =>
NULL;
END NO_RETURN;
 
BEGIN
 
TEST ("C65003A", "CHECK THAT PROGRAM_ERROR IS RAISED IF A " &
"FUNCTION RETURNS WITHOUT EXECUTING A RETURN " &
"STATEMENT");
 
BEGIN
 
IF RETURN_IN_EXCEPTION = RETURN_IN_EXCEPTION THEN
IF NOT EXCEPTION_RAISED THEN
FAILED ("PROGRAM_ERROR NOT RAISED - " &
"RETURN_IN_EXCEPTION");
END IF;
END IF;
 
EXCEPTION
WHEN PROGRAM_ERROR =>
COMMENT ("PROGRAM_ERROR RAISED AT POINT OF CALL " &
"- RETURN_IN_EXCEPTION");
 
END;
 
 
BEGIN
 
IF NO_RETURN = NO_RETURN THEN
FAILED ("PROGRAM_ERROR NOT RAISED - NO_RETURN");
END IF;
 
EXCEPTION
WHEN PROGRAM_ERROR =>
COMMENT ("PROGRAM_ERROR RAISED WHEN NO RETURN IN " &
"EXCEPTION HANDLER");
END;
 
RESULT;
 
END C65003A;
/c64201c.ada
0,0 → 1,196
-- C64201C.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 INITIALIZATION OF IN PARAMETERS OF A COMPOSITE
-- TYPE HAVING AT LEAST ONE COMPONENT (INCLUDING COMPONENTS
-- OF COMPONENTS) OF A TASK TYPE IS PERMITTED.
-- (SEE ALSO 7.4.4/T2 FOR TESTS OF LIMITED PRIVATE TYPES.)
 
-- CVP 5/14/81
-- ABW 7/1/82
-- BHS 7/9/84
 
WITH REPORT;
USE REPORT;
PROCEDURE C64201C IS
 
 
GLOBAL : INTEGER := 10;
 
 
TASK TYPE T IS
ENTRY E (X : IN OUT INTEGER);
END;
 
TYPE REC_T IS
RECORD
TT : T;
BB : BOOLEAN := TRUE;
END RECORD;
 
TYPE REC_REC_T IS
RECORD
RR : REC_T;
END RECORD;
 
TYPE ARR_T IS ARRAY (1 .. 2) OF T;
 
TYPE ARR_REC_T IS ARRAY (1 .. 2) OF REC_T;
 
RT1, RT2 : REC_T;
RRT1, RRT2 : REC_REC_T;
AT1, AT2 : ARR_T;
ART1, ART2 : ARR_REC_T;
 
TASK BODY T IS
BEGIN
ACCEPT E (X : IN OUT INTEGER) DO
X := X - 1;
END E;
ACCEPT E (X : IN OUT INTEGER) DO
X := X + 1;
END E;
END T;
 
 
PROCEDURE PROC1A (P1X : REC_T := RT1) IS
BEGIN
IF P1X.BB THEN -- EXPECT RT2 PASSED.
FAILED( "RECORD OF TASK NOT PASSED, DEFAULT EMPLOYED" );
END IF;
END PROC1A;
 
PROCEDURE PROC1B (P1X : REC_T := RT1) IS
BEGIN
IF NOT P1X.BB THEN -- EXPECT DEFAULT USED.
FAILED( "DEFAULT RECORD OF TASK NOT EMPLOYED" );
END IF;
END PROC1B;
 
 
PROCEDURE PROC2A (P2X : REC_REC_T := RRT1) IS
BEGIN
IF P2X.RR.BB THEN -- EXPECT RRT2 PASSED.
FAILED( "RECORD OF RECORD OF TASK NOT PASSED, " &
"DEFAULT EMPLOYED" );
END IF;
END PROC2A;
 
PROCEDURE PROC2B (P2X : REC_REC_T := RRT1) IS
BEGIN
IF NOT P2X.RR.BB THEN -- EXPECT DEFAULT USED.
FAILED( "DEFAULT RECORD OF RECORD OF TASK " &
"NOT EMPLOYED" );
END IF;
END PROC2B;
 
 
PROCEDURE PROC3 (P3X : ARR_T := AT1) IS
BEGIN
P3X(1).E (X => GLOBAL); -- CALL TO AT2(1).E,
-- GLOBAL => GLOBAL - 1.
END PROC3;
 
PROCEDURE PROC4 (P4X : ARR_T := AT1) IS
BEGIN
P4X(1).E (X => GLOBAL); -- CALL TO DEFAULT AT1(1).E,
-- GLOBAL => GLOBAL - 1.
IF GLOBAL /= IDENT_INT(8) THEN
FAILED( "ARRAY OF TASKS NOT PASSED " &
"CORRECTLY IN PROC3" );
END IF;
END PROC4;
 
PROCEDURE PROC5 (P5X : ARR_REC_T := ART1) IS
BEGIN
P5X(1).TT.E (X => GLOBAL); -- CALL TO ART2(1).TT.E,
-- GLOBAL => GLOBAL - 1.
END PROC5;
 
PROCEDURE PROC6 (P6X : ARR_REC_T := ART1) IS
BEGIN
P6X(1).TT.E (X => GLOBAL); -- CALL DEFAULT ART1(1).TT.E,
-- GLOBAL => GLOBAL - 1.
IF GLOBAL /= IDENT_INT(8) THEN
FAILED( "ARRAY OF RECORDS OF TASKS NOT " &
"PASSED IN PROC5" );
END IF;
END PROC6;
 
PROCEDURE TERM (TSK : T; NUM : CHARACTER) IS
BEGIN
IF NOT TSK'TERMINATED THEN
ABORT TSK;
COMMENT ("ABORTING TASK " & NUM);
END IF;
END TERM;
 
 
BEGIN
 
TEST( "C64201C" , "CHECK THAT INITIALIZATION OF IN " &
"PARAMETERS OF A COMPOSITE TYPE " &
"IS PERMITTED" );
 
RT2.BB := FALSE;
RRT2.RR.BB := FALSE;
 
PROC1A(RT2); -- NO ENTRY CALL
PROC1B; -- NO ENTRY CALL
PROC2A(RRT2); -- NO ENTRY CALL
PROC2B; -- NO ENTRY CALL
 
PROC3(AT2); -- CALL AT2(1).E
IF GLOBAL /= 9 THEN
FAILED ("INCORRECT GLOBAL VALUE AFTER PROC3");
ELSE
PROC4; -- CALL AT1(1).E
END IF;
 
GLOBAL := 10;
PROC5(ART2); -- CALL ART2(1).TT.E
IF GLOBAL /= 9 THEN
FAILED ("INCORRECT GLOBAL VALUE AFTER PROC5");
ELSE
PROC6; -- CALL ART1(1).TT.E
END IF;
 
-- MAKE SURE ALL TASKS TERMINATED
TERM (RT1.TT, '1');
TERM (RT2.TT, '2');
TERM (RRT1.RR.TT, '3');
TERM (RRT2.RR.TT, '4');
TERM (AT1(1), '5');
TERM (AT2(1), '6');
TERM (AT1(2), '7');
TERM (AT2(2), '8');
TERM (ART1(1).TT, '9');
TERM (ART2(1).TT, 'A');
TERM (ART1(2).TT, 'B');
TERM (ART2(2).TT, 'C');
 
RESULT;
 
END C64201C;
/c64104a.ada
0,0 → 1,215
-- C64104A.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 CONSTRAINT_ERROR IS RAISED FOR OUT OF RANGE SCALAR
-- ARGUMENTS. SUBTESTS ARE:
-- (A) STATIC IN ARGUMENT.
-- (B) DYNAMIC IN ARGUMENT.
-- (C) IN OUT, OUT OF RANGE ON CALL.
-- (D) OUT, OUT OF RANGE ON RETURN.
-- (E) IN OUT, OUT OF RANGE ON RETURN.
 
-- HISTORY:
-- DAS 01/14/81
-- CPP 07/03/84
-- LB 11/20/86 ADDED CODE TO ENSURE IN SUBTESTS WHICH CHECK
-- RETURNED VALUES, THAT SUBPROGRAMS ARE ACTUALLY
-- CALLED.
-- JET 08/04/87 FIXED HEADER FOR STANDARD FORMAT.
 
WITH REPORT; USE REPORT;
PROCEDURE C64104A IS
 
SUBTYPE DIGIT IS INTEGER RANGE 0..9;
 
CALLED : BOOLEAN;
D : DIGIT;
I : INTEGER;
M1 : CONSTANT INTEGER := IDENT_INT(-1);
COUNT : INTEGER := 0;
SUBTYPE SI IS INTEGER RANGE M1 .. 10;
 
PROCEDURE P1 (PIN : IN DIGIT; WHO : STRING) IS -- (A), (B)
BEGIN
FAILED ("EXCEPTION NOT RAISED BEFORE CALL - P1 " & WHO);
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN P1 FOR " & WHO);
END P1;
 
PROCEDURE P2 (PINOUT : IN OUT DIGIT; WHO : STRING) IS -- (C)
BEGIN
FAILED ("EXCEPTION NOT RAISED BEFORE CALL - P2 " & WHO);
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN P2 FOR " & WHO);
END P2;
 
PROCEDURE P3 (POUT : OUT SI; WHO : STRING) IS -- (D)
BEGIN
IF WHO = "10" THEN
POUT := IDENT_INT(10); -- (10 IS NOT A DIGIT)
ELSE
POUT := -1;
END IF;
CALLED := TRUE;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN P3 FOR " & WHO);
END P3;
 
PROCEDURE P4 (PINOUT : IN OUT INTEGER; WHO : STRING) IS -- (E)
BEGIN
IF WHO = "10" THEN
PINOUT := 10; -- (10 IS NOT A DIGIT)
ELSE
PINOUT := IDENT_INT(-1);
END IF;
CALLED := TRUE;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN P4 FOR" & WHO);
END P4;
 
BEGIN
 
TEST ("C64104A", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
"FOR OUT OF RANGE SCALAR ARGUMENTS");
 
BEGIN -- (A)
P1 (10, "10");
FAILED ("CONSTRAINT_ERROR NOT RAISED FOR P1 (10)");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
COUNT := COUNT + 1;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED FOR P1 (10)");
END; -- (A)
 
BEGIN -- (B)
P1 (IDENT_INT (-1), "-1");
FAILED ("CONSTRAINT_ERROR NOT RAISED FOR P1 (" &
"IDENT_INT (-1))");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
COUNT := COUNT + 1;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED FOR P1 (" &
"IDENT_INT (-1))");
END; --(B)
 
BEGIN -- (C)
I := IDENT_INT (10);
P2 (I, "10");
FAILED ("CONSTRAINT_ERROR NOT RAISED FOR P2 (10)");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
COUNT := COUNT + 1;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED FOR P2 (10)");
END; -- (C)
 
BEGIN -- (C1)
I := IDENT_INT (-1);
P2 (I, "-1");
FAILED ("CONSTRAINT_ERROR NOT RAISED FOR P2 (-1)");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
COUNT := COUNT + 1;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED FOR P2 (-1)");
END; -- (C1)
 
BEGIN -- (D)
CALLED := FALSE;
D := IDENT_INT (1);
P3 (D, "10");
FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM" &
" P3 (10)");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
COUNT := COUNT + 1;
IF NOT CALLED THEN
FAILED ("SUBPROGRAM P3 WAS NOT CALLED");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED FOR P3 (10)");
END; -- (D)
 
BEGIN -- (D1)
CALLED := FALSE;
D := IDENT_INT (1);
P3 (D, "-1");
FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM" &
" P3 (-1)");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
COUNT := COUNT + 1;
IF NOT CALLED THEN
FAILED ("SUBPROGRAM P3 WAS NOT CALLED");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED FOR P3 (-1)");
END; -- (D1)
 
BEGIN -- (E)
CALLED := FALSE;
D := 9;
P4 (D, "10");
FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM" &
" P4 (10)");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
COUNT := COUNT + 1;
IF NOT CALLED THEN
FAILED ("SUBPROGRAM P4 WAS NOT CALLED");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED FOR P4 (10)");
END; -- (E)
 
BEGIN -- (E1)
CALLED := FALSE;
D := 0;
P4 (D, "-1");
FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM" &
" P4 (-1)");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
COUNT := COUNT + 1;
IF NOT CALLED THEN
FAILED ("SUBPROGRAM P4 WAS NOT CALLED");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED FOR P4 (-1)");
END; -- (E1)
 
IF (COUNT /= 8) THEN
FAILED ("INCORRECT NUMBER OF CONSTRAINT_ERRORS RAISED");
END IF;
 
RESULT;
 
END C64104A;
/c65003b.ada
0,0 → 1,73
-- C65003B.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 IF NO RETURN STATEMENT IS EXECUTED, A FUNCTION RAISES
-- PROGRAM_ERROR. DETERMINE WHERE THE EXCEPTION IS RAISED.
 
-- THIS LACK OF AN EXECUTABLE RETURN IS NOT DETECTABLE AT COMPILE TIME.
 
-- JBG 10/14/83
-- SPS 2/22/84
 
WITH REPORT; USE REPORT;
PROCEDURE C65003B IS
 
EXCEPTION_RAISED : BOOLEAN := FALSE;
 
FUNCTION RETURN_IN_EXCEPTION RETURN INTEGER IS
BEGIN
WHILE NOT EQUAL (1, 1) LOOP
RETURN 5;
END LOOP;
EXCEPTION
WHEN PROGRAM_ERROR =>
COMMENT ("PROGRAM_ERROR RAISED IN FUNCTION BODY");
EXCEPTION_RAISED := TRUE;
RETURN 5;
END RETURN_IN_EXCEPTION;
 
BEGIN
 
TEST ("C65003B", "CHECK THAT PROGRAM_ERROR IS RAISED IF A " &
"FUNCTION RETURNS WITHOUT EXECUTING A RETURN " &
"STATEMENT");
 
BEGIN
 
IF RETURN_IN_EXCEPTION = RETURN_IN_EXCEPTION THEN
IF NOT EXCEPTION_RAISED THEN
FAILED ("PROGRAM_ERROR NOT RAISED");
END IF;
END IF;
 
EXCEPTION
WHEN PROGRAM_ERROR =>
COMMENT ("PROGRAM_ERROR RAISED AT POINT OF CALL");
 
END;
 
RESULT;
 
END C65003B;
/c64104b.ada
0,0 → 1,136
-- C64104B.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 CONSTRAINT_ERROR IS RAISED UNDER APPROPRIATE CIRCUMSTANCES
-- WITH RESPECT TO PARAMETERS OF RECORD TYPES. SUBTESTS INVOLVE
-- ACTUAL RECORD PARAMETERS WHOSE CONSTRAINT VALUES ARE NOT EQUAL
-- TO THE CONSTRAINTS ON THEIR CORRESPONDING FORMAL PARAMETERS:
-- (A) IN PARAMETER, STATIC AGGREGATE.
-- (B) IN PARAMETER, DYNAMIC AGGREGATE.
-- (C) IN PARAMETER, VARIABLE.
-- (D) IN OUT PARAMETER, EXCEPTION RAISED ON CALL.
-- (E) OUT PARAMETER, EXCEPTION RAISED ON CALL.
 
-- DAS 2/11/81
-- SPS 10/26/82
 
WITH REPORT;
PROCEDURE C64104B IS
 
USE REPORT;
SUBTYPE INT IS INTEGER RANGE 0..10;
TYPE REC (N : INT := 0) IS
RECORD
A : STRING (1..N);
END RECORD;
SUBTYPE SREC IS REC(N=>3);
PROCEDURE P1 (R : IN SREC) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED ON CALL TO P1");
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
END P1;
 
PROCEDURE P2 (R : IN OUT SREC) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED ON CALL TO P2");
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P2");
END P2;
 
PROCEDURE P3 (R : OUT SREC) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED ON CALL TO P3");
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE P3");
END P3;
 
BEGIN
 
TEST ("C64104B", "CHECK RAISING OF CONSTRAINT_ERROR FOR " &
"PARAMETERS OF RECORD TYPES");
 
BEGIN -- (A)
P1 ((2,"AA"));
FAILED ("EXCEPTION NOT RAISED IN SUBTEST (A)");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (A)");
END; -- (A)
 
BEGIN -- (B)
P1 ((IDENT_INT(2), "AA"));
FAILED ("EXCEPTION NOT RAISED IN SUBTEST (B)");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (B)");
END; -- (B)
 
DECLARE -- (C)
R : REC := (IDENT_INT(2), "AA");
BEGIN -- (C)
P1 (R);
FAILED ("EXCEPTION NOT RAISED IN SUBTEST (C)");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (C)");
END; -- (C)
 
DECLARE -- (D)
R : REC := (IDENT_INT(2), "AA");
BEGIN -- (D)
P2 (R);
FAILED ("EXCEPTION NOT RAISED IN SUBTEST (D)");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (D)");
END; -- (D)
 
 
DECLARE -- (E)
R : REC;
BEGIN -- (E)
P3 (R);
FAILED ("EXCEPTION NOT RAISED IN SUBTEST (E)");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (E)");
END; -- (E)
 
RESULT;
 
END C64104B;
/c64104c.ada
0,0 → 1,200
-- C64104C.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 CONSTRAINT_ERROR IS RAISED UNDER THE
-- APPROPRIATE CIRCUMSTANCES FOR ARRAY PARAMETERS, NAMELY
-- WHEN THE ACTUAL BOUNDS DON'T MATCH THE FORMAL BOUNDS
-- (BEFORE THE CALL FOR ALL MODES).
-- SUBTESTS ARE:
-- (A) IN MODE, ONE DIMENSION, STATIC AGGREGATE.
-- (B) IN MODE, TWO DIMENSIONS, DYNAMIC AGGREGATE.
-- (C) IN MODE, TWO DIMENSIONS, DYNAMIC VARIABLE.
-- (D) IN OUT MODE, THREE DIMENSIONS, STATIC VARIABLE.
-- (E) OUT MODE, ONE DIMENSION, DYNAMIC VARIABLE.
-- (F) IN OUT MODE, NULL STRING AGGREGATE.
-- (G) IN OUT MODE, TWO DIMENSIONS, NULL AGGREGATE (OK CASE).
-- IN OUT MODE, TWO DIMENSIONS, NULL AGGREGATE.
 
-- JRK 3/17/81
-- SPS 10/26/82
-- CPP 8/6/84
-- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X.
 
WITH REPORT;
PROCEDURE C64104C IS
 
USE REPORT;
 
BEGIN
TEST ("C64104C", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
"ACTUAL ARRAY BOUNDS DON'T MATCH FORMAL BOUNDS");
 
--------------------------------------------------
 
DECLARE -- (A)
SUBTYPE ST IS STRING (1..3);
 
PROCEDURE P (A : ST) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED ON CALL - (A)");
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE - (A)");
END P;
 
BEGIN -- (A)
 
P ("AB");
FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (A)");
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - (A)");
END; -- (A)
 
--------------------------------------------------
 
DECLARE -- (B)
 
SUBTYPE S IS INTEGER RANGE 1..3;
TYPE T IS ARRAY (S,S) OF INTEGER;
 
PROCEDURE P (A : T) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED ON CALL - (B)");
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE - (B)");
END P;
 
BEGIN -- (B)
 
P ((1..3 => (1..IDENT_INT(2) => 0)));
FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (B)");
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - (B)");
END; -- (B)
 
--------------------------------------------------
 
DECLARE -- (C)
 
SUBTYPE S IS INTEGER RANGE 1..5;
TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF INTEGER;
SUBTYPE ST IS T (1..3,1..3);
V : T (1..IDENT_INT(2), 1..3) :=
(1..IDENT_INT(2) => (1..3 => 0));
 
PROCEDURE P (A :ST) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED ON CALL - (C)");
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)");
END P;
 
BEGIN -- (C)
 
P (V);
FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (C)");
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - (C)");
END; -- (C)
 
--------------------------------------------------
 
DECLARE -- (D)
 
SUBTYPE S IS INTEGER RANGE 1..5;
TYPE T IS ARRAY (S RANGE <>, S RANGE <>, S RANGE <>) OF
INTEGER;
SUBTYPE ST IS T (1..3, 1..3, 1..3);
V : T (1..3, 1..2, 1..3) :=
(1..3 => (1..2 => (1..3 => 0)));
 
PROCEDURE P (A : IN OUT ST) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED ON CALLL - (D)");
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)");
END P;
 
BEGIN -- (D)
 
P (V);
FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (D)");
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - (D)");
END; -- (D)
 
--------------------------------------------------
 
 
DECLARE -- (G)
 
SUBTYPE S IS INTEGER RANGE 1..5;
TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF CHARACTER;
SUBTYPE ST IS T (2..1, 2..1);
V : T (2..1, 2..1) := (2..1 => (2..1 => ' '));
 
PROCEDURE P (A : IN OUT ST) IS
BEGIN
COMMENT ("OK CASE CALLED CORRECTLY");
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE - (G)");
END P;
 
BEGIN -- (G)
 
P (V);
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
FAILED ("CONSTRAINT_ERROR RAISED ON OK CASE - (G)");
WHEN OTHERS =>
FAILED ("OTHER EXCEPTION RAISED ON OK CASE - (G)");
END; -- (G)
 
--------------------------------------------------
 
--------------------------------------------------
 
RESULT;
END C64104C;
/c64104d.ada
0,0 → 1,93
-- C64104D.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 CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
 
-- (A) BEFORE CALL, IN MODE, STATIC PRIVATE DISCRIMINANT.
 
-- JRK 3/18/81
-- NL 10/13/81
-- ABW 6/11/82
-- SPS 10/26/82
 
WITH REPORT;
PROCEDURE C64104D IS
 
USE REPORT;
 
BEGIN
TEST ("C64104D", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
"APPROPRIATELY FOR ACCESS PARAMETERS");
 
--------------------------------------------------
 
DECLARE
 
PACKAGE PKG IS
TYPE E IS (E1, E2, E3);
TYPE T (D : E := E1) IS PRIVATE;
TYPE AR IS ARRAY (E1 .. E3) OF INTEGER;
PRIVATE
TYPE T (D : E := E1) IS
RECORD
I : INTEGER;
A : AR;
END RECORD;
END PKG;
USE PKG;
 
TYPE A IS ACCESS T;
SUBTYPE A1 IS A(E3);
V : A (E2) := NEW T (E2);
 
PROCEDURE P (X : A1) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED ON CALL");
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE");
END P;
 
BEGIN
 
P (V);
FAILED ("EXCEPTION NOT RAISED BEFORE CALL");
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED");
END;
 
------------------------------------------------
 
RESULT;
 
END C64104D;
/c64108a.ada
0,0 → 1,148
-- C64108A.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 PERMITTED FORMS OF VARIABLE NAMES ARE PERMITTED
-- AS ACTUAL PARAMETERS.
 
-- DAS 2/10/81
-- SPS 10/26/82
-- SPS 11/5/82
 
WITH REPORT;
PROCEDURE C64108A IS
 
USE REPORT;
SUBTYPE INT IS INTEGER RANGE 1..3;
TYPE REC (N : INT) IS
RECORD
S : STRING (1..N);
END RECORD;
TYPE PTRSTR IS ACCESS STRING;
 
R1,R2,R3 : REC(3);
S1,S2,S3 : STRING (1..3);
PTRTBL : ARRAY (1..3) OF PTRSTR;
 
PROCEDURE P1 (S1 : IN STRING; S2: IN OUT STRING;
S3 : OUT STRING) IS
BEGIN
S3 := S2;
S2 := S1;
END P1;
 
PROCEDURE P2 (C1 : IN CHARACTER; C2 : IN OUT CHARACTER;
C3 : OUT CHARACTER) IS
BEGIN
C3 := C2;
C2 := C1;
END P2;
 
FUNCTION F1 (X : INT) RETURN PTRSTR IS
BEGIN
RETURN PTRTBL(X);
END F1;
 
FUNCTION "+" (S1,S2 : STRING) RETURN PTRSTR IS
BEGIN
RETURN PTRTBL(CHARACTER'POS(S1(1))-CHARACTER'POS('A')+1);
END "+";
 
BEGIN
 
TEST ("C64108A", "CHECK THAT ALL PERMITTED FORMS OF VARIABLE" &
" NAMES ARE PERMITTED AS ACTUAL PARAMETERS");
 
S1 := "AAA";
S2 := "BBB";
P1 (S1, S2, S3);
IF (S2 /= "AAA") OR (S3 /= "BBB") THEN
FAILED ("SIMPLE VARIABLE AS AN ACTUAL PARAMETER NOT WORKING");
END IF;
 
S1 := "AAA";
S2 := "BBB";
S3 := IDENT_STR("CCC");
P2 (S1(1), S2(IDENT_INT(1)), S3(1));
IF (S2 /= "ABB") OR (S3 /= "BCC") THEN
FAILED ("INDEXED COMPONENT AS AN ACTUAL PARAMETER NOT " &
"WORKING");
END IF;
 
R1.S := "AAA";
R2.S := "BBB";
P1 (R1.S, R2.S, R3.S);
IF (R2.S /= "AAA") OR (R3.S /= "BBB") THEN
FAILED ("SELECTED COMPONENT AS AN ACTUAL PARAMETER" &
" NOT WORKING");
END IF;
 
S1 := "AAA";
S2 := "BBB";
P1 (S1(1..IDENT_INT(2)), S2(1..2), S3(IDENT_INT(1)..IDENT_INT(2)));
IF (S2 /= "AAB") OR (S3 /= "BBC") THEN
FAILED ("SLICE AS AN ACTUAL PARAMETER NOT WORKING");
END IF;
 
PTRTBL(1) := NEW STRING'("AAA");
PTRTBL(2) := NEW STRING'("BBB");
PTRTBL(3) := NEW STRING'("CCC");
P1 (F1(1).ALL, F1(2).ALL, F1(IDENT_INT(3)).ALL);
IF (PTRTBL(2).ALL /= "AAA") OR (PTRTBL(3).ALL /= "BBB") THEN
FAILED ("SELECTED COMPONENT OF FUNCTION VALUE AS AN ACTUAL" &
" PARAMETER NOT WORKING");
END IF;
 
PTRTBL(1) := NEW STRING'("AAA");
PTRTBL(2) := NEW STRING'("BBB");
PTRTBL(3) := NEW STRING'("CCC");
S1 := IDENT_STR("AAA");
S2 := IDENT_STR("BBB");
S3 := IDENT_STR("CCC");
P1 ("+"(S1,S1).ALL, "+"(S2,S2).ALL, "+"(S3,S3).ALL);
IF (PTRTBL(2).ALL /= "AAA") OR (PTRTBL(3).ALL /= "BBB") THEN
FAILED ("SELECTED COMPONENT OF OVERLOADED OPERATOR FUNCTION" &
" VALUE AS AN ACTUAL PARAMETER NOT WORKING");
END IF;
 
PTRTBL(1) := NEW STRING'("AAA");
PTRTBL(2) := NEW STRING'("BBB");
PTRTBL(3) := NEW STRING'("CCC");
P2 (F1(1)(1), F1(IDENT_INT(2))(1), F1(3)(IDENT_INT(1)));
IF (PTRTBL(2).ALL /= "ABB") OR (PTRTBL(3).ALL /= "BCC") THEN
FAILED ("INDEXED COMPONENT OF FUNCTION VALUE AS AN ACTUAL" &
" PARAMETER NOT WORKING");
END IF;
 
PTRTBL(1) := NEW STRING'("AAA");
PTRTBL(2) := NEW STRING'("BBB");
PTRTBL(3) := NEW STRING'("CCC");
P1 (F1(1)(2..3), F1(2)(IDENT_INT(2)..3), F1(3)(2..IDENT_INT(3)));
IF (PTRTBL(2).ALL /= "BAA") OR (PTRTBL(3).ALL /= "CBB") THEN
FAILED ("SLICE OF FUNCTION VALUE AS AN ACTUAL PARAMETER" &
" NOT WORKING");
END IF;
 
RESULT;
 
END C64108A;
/c64104e.ada
0,0 → 1,82
-- C64104E.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 CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
 
-- (B) BEFORE CALL, IN MODE, DYNAMIC TWO DIMENSIONAL BOUNDS.
 
-- JRK 3/18/81
-- NL 10/13/81
-- SPS 10/26/82
 
WITH REPORT;
PROCEDURE C64104E IS
 
USE REPORT;
 
BEGIN
TEST ("C64104E", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
"APPROPRIATELY FOR ACCESS PARAMETERS");
 
--------------------------------------------------
 
DECLARE
 
TYPE T IS ARRAY (BOOLEAN RANGE <>, CHARACTER RANGE <>) OF
INTEGER;
 
TYPE A IS ACCESS T;
SUBTYPE A1 IS A(BOOLEAN, 'A'..'C');
V : A := NEW T (BOOLEAN, 'A'..IDENT_CHAR('B'));
 
PROCEDURE P (X : A1) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED ON CALL");
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE");
END P;
 
BEGIN
 
P (V);
FAILED ("EXCEPTION NOT RAISED BEFORE CALL");
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED");
END;
 
--------------------------------------------------
 
RESULT;
 
END C64104E;
/c64104f.ada
0,0 → 1,79
-- C64104F.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 CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
 
-- (C) BEFORE CALL, IN OUT MODE, STATIC ONE DIMENSIONAL BOUNDS.
 
-- JRK 3/18/81
-- NL 10/13/81
-- SPS 10/26/82
 
WITH REPORT;
PROCEDURE C64104F IS
 
USE REPORT;
 
BEGIN
TEST ("C64104F", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
"APPROPRIATELY FOR ACCESS PARAMETERS");
 
--------------------------------------------------
 
DECLARE
 
TYPE A IS ACCESS STRING;
SUBTYPE A1 IS A(1..3);
V : A (2..4) := NEW STRING (2..4);
 
PROCEDURE P (X : IN OUT A1) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED ON CALL");
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE");
END P;
 
BEGIN
 
P (V);
FAILED ("EXCEPTION NOT RAISED BEFORE CALL");
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED");
END;
 
--------------------------------------------------
 
RESULT;
 
END C64104F;
/c64104g.ada
0,0 → 1,93
-- C64104G.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 CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
 
-- (D) BEFORE CALL, IN OUT MODE, DYNAMIC RECORD DISCRIMINANTS.
 
-- JRK 3/18/81
-- NL 10/13/81
-- SPS 10/26/82
 
WITH REPORT;
PROCEDURE C64104G IS
 
USE REPORT;
 
BEGIN
TEST ("C64104G", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
"APPROPRIATELY FOR ACCESS PARAMETERS");
 
--------------------------------------------------
 
DECLARE
SUBTYPE INT IS INTEGER RANGE 0..10;
TYPE T (C : CHARACTER := 'A';
B : BOOLEAN := FALSE;
I : INT := 0
) IS
RECORD
J : INTEGER;
CASE B IS
WHEN FALSE =>
K : INTEGER;
WHEN TRUE =>
S : STRING (1 .. I);
END CASE;
END RECORD;
 
TYPE A IS ACCESS T;
SUBTYPE SA IS A ('Z', TRUE, 5);
V : A := NEW T ('Z', IDENT_BOOL(FALSE), 5);
 
PROCEDURE P (X : IN OUT SA ) IS
BEGIN
FAILED ("EXCEPTION NOT RAISED ON CALL");
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE");
END P;
 
BEGIN
 
P (V);
FAILED ("EXCEPTION NOT RAISED BEFORE CALL");
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED");
END;
 
--------------------------------------------------
 
RESULT;
 
END C64104G;
/c67003f.ada
0,0 → 1,319
-- C67003F.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 PREDEFINED OPERATORS FOR THE PREDEFINED TYPES CAN BE
-- REDEFINED.
-- CHECK THAT THE REDEFINED OPERATOR IS INVOKED WHEN INFIX OR PREFIX
-- NOTATION IS USED.
 
-- HISTORY:
-- WMC 03/21/92 TEST CREATED FROM CONSOLIDATION OF C67003[A-E].ADA
 
 
WITH REPORT;
 
PROCEDURE C67003F IS
 
USE REPORT;
 
BEGIN
 
TEST ("C67003F", "CHECK THAT REDEFINITION OF " &
"OPERATORS FOR PREDEFINED TYPES WORKS");
 
DECLARE -- INTEGER OPERATORS.
 
-- INTEGER INFIX OPERATORS.
 
FUNCTION "*" (X, Y : INTEGER) RETURN INTEGER IS
BEGIN
IF X /= Y THEN
RETURN 1;
ELSE RETURN 0;
END IF;
END "*";
 
FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER IS
BEGIN
IF X /= Y THEN
RETURN 2;
ELSE RETURN 0;
END IF;
END "+";
FUNCTION "REM" (X, Y : INTEGER) RETURN INTEGER IS
BEGIN
IF X /= Y THEN
RETURN 3;
ELSE RETURN 0;
END IF;
END "REM";
-- INTEGER PREFIX OPERATORS.
 
FUNCTION "+" (X : INTEGER) RETURN INTEGER IS
BEGIN
IF X /= 0 THEN
RETURN 4;
ELSE RETURN 0;
END IF;
END "+";
 
FUNCTION "ABS" (X : INTEGER) RETURN INTEGER IS
BEGIN
IF X /= 0 THEN
RETURN 5;
ELSE RETURN 0;
END IF;
END "ABS";
 
-- INTEGER RELATIONAL OPERATOR.
 
FUNCTION "<" (X, Y : INTEGER) RETURN BOOLEAN IS
BEGIN
RETURN X = Y;
END "<";
 
BEGIN
 
IF IDENT_INT (3) * IDENT_INT (5) /= 1 THEN
FAILED ("REDEFINITION OF INTEGER ""*"" IS DEFECTIVE");
END IF;
 
IF IDENT_INT (1) + IDENT_INT (30) /= 2 THEN
FAILED ("REDEFINITION OF INTEGER ""+"" IS DEFECTIVE");
END IF;
 
IF IDENT_INT (7) REM IDENT_INT (8) /= 3 THEN
FAILED ("REDEFINITION OF ""REM"" IS DEFECTIVE");
END IF;
 
IF + (IDENT_INT (10)) /= 4 THEN
FAILED ("REDEFINITION OF INTEGER UNARY ""+"" IS DEFECTIVE");
END IF;
 
IF ABS (IDENT_INT (2)) /= 5 THEN
FAILED ("REDEFINITION OF INTEGER ""ABS"" IS DEFECTIVE");
END IF;
 
IF IDENT_INT (7) < IDENT_INT (8) THEN
FAILED ("REDEFINITION OF INTEGER ""<"" IS DEFECTIVE");
END IF;
 
END;
 
DECLARE -- FLOAT OPERATORS.
 
-- NOTE THAT ALL LITERAL VALUES USED SHOULD BE
-- REPRESENTABLE EXACTLY.
 
FUNCTION IDENT_FLOAT (X : FLOAT) RETURN FLOAT IS
I : INTEGER := INTEGER (X);
BEGIN
IF EQUAL (I, I) THEN -- ALWAYS EQUAL.
RETURN X;
END IF;
RETURN 0.0;
END IDENT_FLOAT;
 
-- FLOAT INFIX OPERATORS.
 
FUNCTION "-" (X, Y : FLOAT) RETURN FLOAT IS
BEGIN
IF X /= Y THEN
RETURN 1.0;
ELSE RETURN 0.0;
END IF;
END "-";
 
FUNCTION "/" (X, Y : FLOAT) RETURN FLOAT IS
BEGIN
IF X /= Y THEN
RETURN 2.0;
ELSE RETURN 0.0;
END IF;
END "/";
 
FUNCTION "**" (X : FLOAT; Y : INTEGER) RETURN FLOAT IS
BEGIN
IF INTEGER (X) /= Y THEN
RETURN 3.0;
ELSE RETURN 0.0;
END IF;
END "**";
 
-- FLOAT PREFIX OPERATOR.
 
FUNCTION "-" (X : FLOAT) RETURN FLOAT IS
BEGIN
IF X /= 0.0 THEN
RETURN 4.0;
ELSE RETURN 0.0;
END IF;
END "-";
 
-- FLOAT RELATIONAL OPERATOR.
 
FUNCTION "<=" (X, Y : FLOAT) RETURN BOOLEAN IS
BEGIN
RETURN X = Y;
END "<=";
 
BEGIN
 
IF IDENT_FLOAT (50.0) - IDENT_FLOAT (100.0) /= 1.0 THEN
FAILED ("REDEFINITION OF FLOAT ""-"" IS DEFECTIVE");
END IF;
 
IF IDENT_FLOAT (5.0) / IDENT_FLOAT (1.0) /= 2.0 THEN
FAILED ("REDEFINITION OF FLOAT ""/"" IS DEFECTIVE");
END IF;
 
IF IDENT_FLOAT (3.0) ** IDENT_INT (2) /= 3.0 THEN
FAILED ("REDEFINITION OF FLOAT ""**"" IS DEFECTIVE");
END IF;
 
IF -(IDENT_FLOAT (5.0)) /= 4.0 THEN
FAILED ("REDEFINITION OF FLOAT UNARY ""-"" IS DEFECTIVE");
END IF;
 
IF IDENT_FLOAT (1.0) <= IDENT_FLOAT (5.0) THEN
FAILED ("REDEFINITION OF FLOAT ""<="" IS DEFECTIVE");
END IF;
 
END;
 
DECLARE -- BOOLEAN OPERATORS.
 
-- BOOLEAN LOGICAL OPERATORS.
 
FUNCTION "AND" (X, Y : BOOLEAN) RETURN BOOLEAN IS
BEGIN
IF X AND THEN Y THEN
RETURN FALSE;
ELSE RETURN TRUE;
END IF;
END "AND";
 
FUNCTION "XOR" (X, Y : BOOLEAN) RETURN BOOLEAN IS
BEGIN
RETURN X = Y;
END "XOR";
 
-- BOOLEAN RELATIONAL OPERATOR.
 
FUNCTION ">" (X, Y : BOOLEAN) RETURN BOOLEAN IS
BEGIN
RETURN X = Y;
END ">";
 
BEGIN
 
IF IDENT_BOOL (TRUE) AND IDENT_BOOL (TRUE) THEN
FAILED ("REDEFINITION OF ""AND"" IS DEFECTIVE");
END IF;
 
IF IDENT_BOOL (TRUE) XOR IDENT_BOOL (FALSE) THEN
FAILED ("REDEFINITION OF ""XOR"" IS DEFECTIVE");
END IF;
 
IF IDENT_BOOL (TRUE) > IDENT_BOOL (FALSE) THEN
FAILED ("REDEFINITION OF BOOLEAN "">"" IS DEFECTIVE");
END IF;
 
END;
DECLARE -- STRING OPERATORS.
 
S1 : STRING (1..2) := "A" & IDENT_CHAR ('B');
S2 : STRING (1..2) := "C" & IDENT_CHAR ('D');
 
FUNCTION "&" (X, Y : STRING) RETURN STRING IS
Z : STRING (1 .. X'LENGTH + Y'LENGTH);
BEGIN
Z (1 .. Y'LENGTH) := Y;
Z (Y'LENGTH + 1 .. Z'LAST) := X;
RETURN Z;
END "&";
 
FUNCTION "&" (X : CHARACTER; Y : STRING) RETURN STRING IS
Z : STRING (1 .. Y'LENGTH + 1);
BEGIN
Z (1 .. Y'LENGTH) := Y;
Z (Z'LAST) := X;
RETURN Z;
END "&";
 
-- STRING RELATIONAL OPERATOR.
 
FUNCTION ">=" (X, Y : STRING) RETURN BOOLEAN IS
BEGIN
RETURN X = Y;
END ">=";
 
BEGIN
 
IF S1 & S2 /= "CDAB" THEN
FAILED ("BAD REDEFINITION OF ""&"" (S,S)");
END IF;
 
IF IDENT_CHAR ('C') & S1 /= "ABC" THEN
FAILED ("BAD REDEFINITION OF ""&"" (C,S)");
END IF;
 
IF S2 >= S1 THEN
FAILED ("BAD REDEFINITION OF STRING "">=""");
END IF;
 
END;
 
DECLARE -- CHARACTER OPERATORS.
 
-- CHARACTER RELATIONAL OPERATORS.
 
FUNCTION ">" (X, Y : CHARACTER) RETURN BOOLEAN IS
BEGIN
RETURN X = Y;
END ">";
 
FUNCTION "<=" (X, Y : CHARACTER) RETURN BOOLEAN IS
BEGIN
RETURN X = Y;
END "<=";
 
BEGIN
 
IF IDENT_CHAR ('C') > IDENT_CHAR ('B') THEN
FAILED ("REDEFINITION OF CHARACTER "">"" IS DEFECTIVE");
END IF;
 
IF IDENT_CHAR ('A') <= IDENT_CHAR ('E') THEN
FAILED ("REDEFINITION OF CHARACTER ""<="" IS DEFECTIVE");
END IF;
 
END;
 
RESULT;
 
END C67003F;
/c64104h.ada
0,0 → 1,111
-- C64104H.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 CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
 
-- (E) AFTER RETURN, IN OUT MODE, STATIC LIMITED PRIVATE
-- DISCRIMINANTS.
 
-- HISTORY:
-- JRK 03/18/81 CREATED ORIGINAL TEST.
-- NL 10/13/81
-- LB 11/25/86 ADDED CODE TO ENSURE THAT SUBPROGRAMS ARE
-- ACTUALLY BEING CALLED.
-- BCB 11/12/87 CHANGED HEADER TO STANDARD FORMAT.
 
 
WITH REPORT;
PROCEDURE C64104H IS
 
USE REPORT;
 
BEGIN
TEST ("C64104H", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
"APPROPRIATELY FOR ACCESS PARAMETERS");
 
--------------------------------------------------
 
DECLARE
 
PACKAGE PKG IS
SUBTYPE INT IS INTEGER RANGE 0..10;
SUBTYPE CHAR IS CHARACTER RANGE 'A' .. 'C';
TYPE T (I : INT := 0; C : CHAR := 'A') IS
LIMITED PRIVATE;
PRIVATE
TYPE T (I : INT := 0; C : CHAR := 'A') IS
RECORD
J : INTEGER;
CASE C IS
WHEN 'A' =>
K : INTEGER;
WHEN 'B' =>
S : STRING (1..I);
WHEN OTHERS =>
NULL;
END CASE;
END RECORD;
END PKG;
USE PKG;
 
CALLED : BOOLEAN;
TYPE A IS ACCESS T;
 
V : A (2,'B') := NEW T (2,'B');
 
PROCEDURE P (X : IN OUT A) IS
BEGIN
CALLED := TRUE;
X := NEW T (2,'A');
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE");
END P;
 
BEGIN
 
CALLED := FALSE;
P (V);
FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("SUBPROGRAM P WAS NOT CALLED");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED");
END;
 
--------------------------------------------------
 
RESULT;
 
END C64104H;
/c641001.a
0,0 → 1,281
-- C641001.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 actual parameters passed by reference are view converted
-- to the nominal subtype of the formal parameter.
--
-- TEST DESCRIPTION:
-- Check that sliding is allowed for formal parameters, especially
-- check cases that would have caused errors in Ada'83.
-- Check that length check for a formal parameter (esp out mode)
-- is performed before the call, not after.
--
-- notes: 6.2; by reference ::= tagged, task, protected,
-- limited (nonprivate), or composite containing such
-- 4.6; view conversion
--
--
-- CHANGE HISTORY:
-- 26 JAN 96 SAIC Initial version
-- 04 NOV 96 SAIC Commentary revision for release 2.1
-- 27 FEB 97 PWB.CTA Corrected reference to the wrong string
--!
 
----------------------------------------------------------------- C641001_0
 
package C641001_0 is
 
subtype String_10 is String(1..10);
 
procedure Check_String_10( S : out String_10; Start, Stop: Natural );
 
procedure Check_Illegal_Slice_Reference( Slice_Passed : in out String;
Index: Natural );
 
type Tagged_Data(Bound: Natural) is tagged record
Data_Item : String(1..Bound) := (others => '*');
end record;
 
type Tag_List is array(Natural range <>) of Tagged_Data(5);
 
subtype Tag_List_10 is Tag_List(1..10);
 
procedure Check_Tag_Slice( TL : in out Tag_List_10 );
 
procedure Check_Out_Tagged_Data( Formal : out Tagged_Data );
 
end C641001_0;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with Report;
with TCTouch;
package body C641001_0 is
 
String_Data : constant String := "1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ";
 
procedure Check_String_10( S : out String_10; Start, Stop: Natural ) is
begin
if S'Length /= 10 then
Report.Failed("Length check not performed prior to execution");
end if;
S := String_Data(Start..Stop);
exception
when others => Report.Failed("Exception encountered in Check_String_10");
end Check_String_10;
 
procedure Check_Illegal_Slice_Reference( Slice_Passed : in out String;
Index: Natural ) is
begin
-- essentially "do-nothing" for optimization foilage...
if Slice_Passed(Index) in Character then
-- Intent is ^^^^^ should raise Constraint_Error
Report.Failed("Illegal Slice provided legal character");
else
Report.Failed("Illegal Slice provided illegal character");
end if;
exception
when Constraint_Error =>
null; -- expected case
when others =>
Report.Failed("Wrong exception in Check_Illegal_Slice_Reference");
end Check_Illegal_Slice_Reference;
 
procedure Check_Tag_Slice( TL : in out Tag_List_10 ) is
-- if the view conversion is not performed, one of the following checks
-- will fail (given data passed as 0..9 and then 2..11)
begin
Check_Under_Index: -- index 0 should raise C_E
begin
TCTouch.Assert( TL(Report.Ident_Int(0)).Data_Item = "*****",
"Index 0 (illegal); bad data" );
Report.Failed("Index 0 did not raise Constraint_Error");
exception
when Constraint_Error =>
null; -- expected case
when others =>
Report.Failed("Wrong exception in Check_Under_Index ");
end Check_Under_Index;
 
Check_Over_Index: -- index 11 should raise C_E
begin
TCTouch.Assert( TL(Report.Ident_Int(11)).Data_Item = "*****",
"Index 11 (illegal); bad data" );
Report.Failed("Index 11 did not raise Constraint_Error");
exception
when Constraint_Error =>
null; -- expected case
when others =>
Report.Failed("Wrong exception in Check_Over_Index ");
end Check_Over_Index;
 
end Check_Tag_Slice;
 
procedure Check_Out_Tagged_Data( Formal : out Tagged_Data ) is
begin
TCTouch.Assert( Formal.Data_Item = "*****", "out formal data bad" );
Formal.Data_Item(1) := '!';
end Check_Out_Tagged_Data;
 
end C641001_0;
 
------------------------------------------------------------------- C641001
 
with Report;
with TCTouch;
with C641001_0;
procedure C641001 is
 
function II( I: Integer ) return Integer renames Report.Ident_Int;
-- ^^ name chosen to allow embedding in calls
 
A_String_10 : C641001_0.String_10;
Slicable : String(1..40);
Tag_Slices : C641001_0.Tag_List(0..11);
 
Global_Data : String(1..26) := "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
 
procedure Check_Out_Sliding( Lo1, Hi1, Lo2, Hi2 : Natural ) is
 
subtype One_Constrained_String is String(Lo1..Hi1); -- 1 5
subtype Two_Constrained_String is String(Lo2..Hi2); -- 6 10
 
procedure Out_Param( Param : out One_Constrained_String ) is
begin
Param := Report.Ident_Str( Global_Data(Lo2..Hi2) );
end Out_Param;
Object : Two_Constrained_String;
begin
Out_Param( Object );
if Object /= Report.Ident_Str( Global_Data(Lo2..Hi2) ) then
Report.Failed("Bad result in Check_Out_Sliding");
end if;
exception
when others => Report.Failed("Exception in Check_Out_Sliding");
end Check_Out_Sliding;
 
procedure Check_Dynamic_Subtype_Cases(F_Lower,F_Upper: Natural;
A_Lower,A_Upper: Natural) is
 
subtype Dyn_String is String(F_Lower..F_Upper);
 
procedure Check_Dyn_Subtype_Formal_Out( Param : out Dyn_String ) is
begin
Param := Global_Data(11..20);
end Check_Dyn_Subtype_Formal_Out;
 
procedure Check_Dyn_Subtype_Formal_In( Param : in Dyn_String ) is
begin
if Param /= Global_Data(11..20) then
Report.Failed("Dynamic case, data mismatch");
end if;
end Check_Dyn_Subtype_Formal_In;
 
Stuff: String(A_Lower..A_Upper);
 
begin
Check_Dyn_Subtype_Formal_Out( Stuff );
Check_Dyn_Subtype_Formal_In( Stuff );
end Check_Dynamic_Subtype_Cases;
 
begin -- Main test procedure.
 
Report.Test ("C641001", "Check that actual parameters passed by " &
"reference are view converted to the nominal " &
"subtype of the formal parameter" );
 
-- non error cases for string slices
 
C641001_0.Check_String_10( A_String_10, 1, 10 );
TCTouch.Assert( A_String_10 = "1234567890", "Nominal case" );
 
C641001_0.Check_String_10( A_String_10, 11, 20 );
TCTouch.Assert( A_String_10 = "ABCDEFGHIJ", "Sliding to subtype" );
 
C641001_0.Check_String_10( Slicable(1..10), 1, 10 );
TCTouch.Assert( Slicable(1..10) = "1234567890", "Slice, no sliding" );
 
C641001_0.Check_String_10( Slicable(1..10), 21, 30 );
TCTouch.Assert( Slicable(1..10) = "KLMNOPQRST", "Sliding to slice" );
 
C641001_0.Check_String_10( Slicable(11..20), 11, 20 );
TCTouch.Assert( Slicable(11..20) = "ABCDEFGHIJ", "Sliding to same" );
 
C641001_0.Check_String_10( Slicable(21..30), 11, 20 );
TCTouch.Assert( Slicable(21..30) = "ABCDEFGHIJ", "Sliding up" );
 
-- error cases for string slices
 
C641001_0.Check_Illegal_Slice_Reference( Slicable(21..30), 20 );
 
C641001_0.Check_Illegal_Slice_Reference( Slicable(1..15), Slicable'Last );
 
-- checks for view converting actuals to formals
 
-- catch low bound fault
C641001_0.Check_Tag_Slice( Tag_Slices(II(0)..9) ); -- II ::= Ident_Int
TCTouch.Assert( Tag_Slices'First = 0, "Tag_Slices'First = 0" );
TCTouch.Assert( Tag_Slices'Last = 11, "Tag_Slices'Last = 11" );
 
-- catch high bound fault
C641001_0.Check_Tag_Slice( Tag_Slices(2..II(11)) );
TCTouch.Assert( Tag_Slices'First = 0, "Tag_Slices'First = 0" );
TCTouch.Assert( Tag_Slices'Last = 11, "Tag_Slices'Last = 11" );
 
Check_Formal_Association_Check:
begin
C641001_0.Check_String_10( Slicable, 1, 10 ); -- catch length fault
Report.Failed("Exception not raised at Check_Formal_Association_Check");
exception
when Constraint_Error =>
null; -- expected case
when others =>
Report.Failed("Wrong exception at Check_Formal_Association_Check");
end Check_Formal_Association_Check;
 
-- check for constrained actual, unconstrained formal
C641001_0.Check_Out_Tagged_Data( Tag_Slices(5) );
TCTouch.Assert( Tag_Slices(5).Data_Item = "!****",
"formal out returned bad result" );
 
-- additional checks for out mode formal parameters, dynamic subtypes
 
Check_Out_Sliding( II(1),II(5), II(6),II(10) );
 
Check_Out_Sliding( 21,25, 6,10 );
 
Check_Dynamic_Subtype_Cases(F_Lower => II(1), F_Upper => II(10),
A_Lower => II(1), A_Upper => II(10));
 
Check_Dynamic_Subtype_Cases(F_Lower => II(21), F_Upper => II(30),
A_Lower => II( 1), A_Upper => II(10));
 
Check_Dynamic_Subtype_Cases(F_Lower => II( 1), F_Upper => II(10),
A_Lower => II(21), A_Upper => II(30));
 
Report.Result;
 
end C641001;
/c64104i.ada
0,0 → 1,101
-- C64104I.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 CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
 
-- (F) AFTER RETURN, IN OUT MODE, DYNAMIC THREE DIMENSIONAL
-- BOUNDS.
 
-- HISTORY:
-- JRK 03/18/81 CREATED ORIGINAL TEST.
-- NL 10/13/81
-- LB 11/25/86 ADDED CODE TO ENSURE THAT SUBPROGRAMS ARE
-- ACTUALLY BEING CALLED.
-- BCB 11/12/87 CHANGED HEADER TO STANDARD FORMAT.
 
 
WITH REPORT;
PROCEDURE C64104I IS
 
USE REPORT;
 
BEGIN
TEST ("C64104I", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
"APPROPRIATELY FOR ACCESS PARAMETERS");
 
--------------------------------------------------
 
DECLARE
 
CALLED : BOOLEAN;
 
TYPE E IS (E1, E2, E3);
 
TYPE T IS ARRAY (CHARACTER RANGE <>,
E RANGE <>,
BOOLEAN RANGE <>
) OF INTEGER;
 
TYPE A IS ACCESS T;
 
V : A ('A'..'Z', E1..E2, BOOLEAN) :=
NEW T ('A'..'Z', E1..E2, BOOLEAN);
 
PROCEDURE P (X : IN OUT A) IS
BEGIN
CALLED := TRUE;
IF EQUAL (3,3) THEN
X := NEW T ('A'..'Z', E2..E3, BOOLEAN);
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED IN PROCEDURE");
END P;
 
BEGIN
 
CALLED := FALSE;
P (V);
FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
 
EXCEPTION
WHEN CONSTRAINT_ERROR =>
IF NOT CALLED THEN
FAILED ("SUBPROGRAM P WAS NOT CALLED");
END IF;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED");
END;
 
--------------------------------------------------
 
RESULT;
 
END C64104I;

powered by: WebSVN 2.1.0

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