-- C37207A.ADA
|
-- C37207A.ADA
|
|
|
-- Grant of Unlimited Rights
|
-- Grant of Unlimited Rights
|
--
|
--
|
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
|
-- 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
|
-- 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 in the software and documentation contained herein.
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
-- this public release, the Government intends to confer upon all
|
-- this public release, the Government intends to confer upon all
|
-- recipients unlimited rights equal to those held by the Government.
|
-- recipients unlimited rights equal to those held by the Government.
|
-- These rights include rights to use, duplicate, release or disclose the
|
-- These rights include rights to use, duplicate, release or disclose the
|
-- released technical data and computer software in whole or in part, in
|
-- 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
|
-- any manner and for any purpose whatsoever, and to have or permit others
|
-- to do so.
|
-- to do so.
|
--
|
--
|
-- DISCLAIMER
|
-- DISCLAIMER
|
--
|
--
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
--*
|
--*
|
-- OBJECTIVE:
|
-- OBJECTIVE:
|
|
|
-- FOR A TYPE WITH OR WITHOUT DEFAULT DISCRIMINANT VALUES, CHECK
|
-- FOR A TYPE WITH OR WITHOUT DEFAULT DISCRIMINANT VALUES, CHECK
|
-- THAT A DISCRIMINANT CONSTRAINT CAN BE SUPPLIED IN THE FOLLOWING
|
-- THAT A DISCRIMINANT CONSTRAINT CAN BE SUPPLIED IN THE FOLLOWING
|
-- CONTEXTS AND HAS THE PROPER EFFECT:
|
-- CONTEXTS AND HAS THE PROPER EFFECT:
|
|
|
-- IN A 1) OBJECT_DECLARATION, 2) COMPONENT_DECLARATION OR
|
-- IN A 1) OBJECT_DECLARATION, 2) COMPONENT_DECLARATION OR
|
-- 3) SUBTYPE INDICATION OF AN ARRAY_TYPE_DEFINITION, AND HENCE,
|
-- 3) SUBTYPE INDICATION OF AN ARRAY_TYPE_DEFINITION, AND HENCE,
|
-- ASSIGNMENTS CANNOT ATTEMPT TO CHANGE THE SPECIFIED DISCRIMINANT
|
-- ASSIGNMENTS CANNOT ATTEMPT TO CHANGE THE SPECIFIED DISCRIMINANT
|
-- VALUES WITHOUT RAISING CONSTRAINT_ERROR
|
-- VALUES WITHOUT RAISING CONSTRAINT_ERROR
|
|
|
-- 4) IN AN ACCESS_TYPE_DEFINITION, AND HENCE, ACCESS VALUES
|
-- 4) IN AN ACCESS_TYPE_DEFINITION, AND HENCE, ACCESS VALUES
|
-- OF THIS ACCESS TYPE CANNOT BE ASSIGNED NON-NULL VALUES
|
-- OF THIS ACCESS TYPE CANNOT BE ASSIGNED NON-NULL VALUES
|
-- DESIGNATING OBJECTS WITH DIFFERENT DISCRIMINANT VALUES.
|
-- DESIGNATING OBJECTS WITH DIFFERENT DISCRIMINANT VALUES.
|
|
|
-- 5) IN AN ALLOCATOR, AND THE ALLOCATED OBJECT HAS THE SPECIFIED
|
-- 5) IN AN ALLOCATOR, AND THE ALLOCATED OBJECT HAS THE SPECIFIED
|
-- DISCRIMINANT VALUES.
|
-- DISCRIMINANT VALUES.
|
|
|
-- 6) IN A FORMAL PARAMETER DECLARATION OF A SUBPROGRAM, AND
|
-- 6) IN A FORMAL PARAMETER DECLARATION OF A SUBPROGRAM, AND
|
-- HENCE, ASSIGNMENTS TO THE FORMAL PARAMETER CANNOT ATTEMPT TO
|
-- HENCE, ASSIGNMENTS TO THE FORMAL PARAMETER CANNOT ATTEMPT TO
|
-- CHANGE THE DISCRIMINANT VALUES WITHOUT RAISING CONSTRAINT_ERROR,
|
-- CHANGE THE DISCRIMINANT VALUES WITHOUT RAISING CONSTRAINT_ERROR,
|
-- CONSTRAINED IS TRUE, AND IF ACTUAL PARAMETERS HAVE DISCRIMINANT
|
-- CONSTRAINED IS TRUE, AND IF ACTUAL PARAMETERS HAVE DISCRIMINANT
|
-- VALUES DIFFERENT FROM THE SPECIFIED ONES, CONSTRAINT_ERROR IS
|
-- VALUES DIFFERENT FROM THE SPECIFIED ONES, CONSTRAINT_ERROR IS
|
-- RAISED.
|
-- RAISED.
|
|
|
-- HISTORY:
|
-- HISTORY:
|
|
|
-- ASL 07/24/81
|
-- ASL 07/24/81
|
-- RJW 08/28/86 CORRECTED SYNTAX ERRORS.
|
-- RJW 08/28/86 CORRECTED SYNTAX ERRORS.
|
-- JLH 08/07/87 ADDED CODE TO PREVENT DEAD VARIABLE OPTIMIZATION.
|
-- JLH 08/07/87 ADDED CODE TO PREVENT DEAD VARIABLE OPTIMIZATION.
|
-- EDS 07/16/98 AVOID OPTIMIZATION
|
-- EDS 07/16/98 AVOID OPTIMIZATION
|
|
|
WITH REPORT; USE REPORT;
|
WITH REPORT; USE REPORT;
|
PROCEDURE C37207A IS
|
PROCEDURE C37207A IS
|
|
|
BEGIN
|
BEGIN
|
TEST ("C37207A","DISCRIMINANT CONSTRAINT CAN BE SUPPLIED TO " &
|
TEST ("C37207A","DISCRIMINANT CONSTRAINT CAN BE SUPPLIED TO " &
|
"DECLARATIONS AND DEFINITIONS USING TYPES WITH OR WITHOUT " &
|
"DECLARATIONS AND DEFINITIONS USING TYPES WITH OR WITHOUT " &
|
"DEFAULT DISCRIMINANT VALUES");
|
"DEFAULT DISCRIMINANT VALUES");
|
|
|
DECLARE
|
DECLARE
|
TYPE REC1 (DISC : INTEGER := 5) IS
|
TYPE REC1 (DISC : INTEGER := 5) IS
|
RECORD
|
RECORD
|
NULL;
|
NULL;
|
END RECORD;
|
END RECORD;
|
|
|
TYPE REC2 (DISC : INTEGER) IS
|
TYPE REC2 (DISC : INTEGER) IS
|
RECORD
|
RECORD
|
NULL;
|
NULL;
|
END RECORD;
|
END RECORD;
|
|
|
OBJ1 : REC1(6); -- 1.
|
OBJ1 : REC1(6); -- 1.
|
OBJ2 : REC2(6); -- 1.
|
OBJ2 : REC2(6); -- 1.
|
BADOBJ1 : REC1(7); -- 1.
|
BADOBJ1 : REC1(7); -- 1.
|
BADOBJ2 : REC2(7); -- 1.
|
BADOBJ2 : REC2(7); -- 1.
|
|
|
TYPE REC3 IS
|
TYPE REC3 IS
|
RECORD
|
RECORD
|
COMP1 : REC1(6); -- 2.
|
COMP1 : REC1(6); -- 2.
|
COMP2 : REC2(6); -- 2.
|
COMP2 : REC2(6); -- 2.
|
END RECORD;
|
END RECORD;
|
|
|
OBJ3 : REC3;
|
OBJ3 : REC3;
|
|
|
TYPE ARR1 IS ARRAY (1..10) OF REC1(6); -- 3.
|
TYPE ARR1 IS ARRAY (1..10) OF REC1(6); -- 3.
|
TYPE ARR2 IS ARRAY (1..10) OF REC2(6); -- 3.
|
TYPE ARR2 IS ARRAY (1..10) OF REC2(6); -- 3.
|
|
|
A1 : ARR1;
|
A1 : ARR1;
|
A2 : ARR2;
|
A2 : ARR2;
|
|
|
TYPE REC1_NAME IS ACCESS REC1(6); -- 4.
|
TYPE REC1_NAME IS ACCESS REC1(6); -- 4.
|
TYPE REC2_NAME IS ACCESS REC2(6); -- 4.
|
TYPE REC2_NAME IS ACCESS REC2(6); -- 4.
|
|
|
ACC1 : REC1_NAME;
|
ACC1 : REC1_NAME;
|
ACC2 : REC2_NAME;
|
ACC2 : REC2_NAME;
|
|
|
SUBTYPE REC16 IS REC1(6);
|
SUBTYPE REC16 IS REC1(6);
|
SUBTYPE REC26 IS REC2(6);
|
SUBTYPE REC26 IS REC2(6);
|
|
|
PROCEDURE PROC (P1 : IN OUT REC16; -- 6.
|
PROCEDURE PROC (P1 : IN OUT REC16; -- 6.
|
P2 : IN OUT REC26) IS -- 6.
|
P2 : IN OUT REC26) IS -- 6.
|
BEGIN
|
BEGIN
|
IF NOT (P1'CONSTRAINED AND P2'CONSTRAINED) THEN -- 6.
|
IF NOT (P1'CONSTRAINED AND P2'CONSTRAINED) THEN -- 6.
|
FAILED ("'CONSTRAINED ATTRIBUTE INCORRECT FOR " &
|
FAILED ("'CONSTRAINED ATTRIBUTE INCORRECT FOR " &
|
"CONSTRAINED FORMAL PARAMETERS");
|
"CONSTRAINED FORMAL PARAMETERS");
|
END IF;
|
END IF;
|
BEGIN
|
BEGIN
|
P1 := (DISC => 7); -- 6.
|
P1 := (DISC => 7); -- 6.
|
FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
|
FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
|
"ATTEMPT TO CHANGE DISCRIMINANT OF " &
|
"ATTEMPT TO CHANGE DISCRIMINANT OF " &
|
"CONSTRAINED FORMAL PARAMETER " &
|
"CONSTRAINED FORMAL PARAMETER " &
|
INTEGER'IMAGE(P1.DISC));
|
INTEGER'IMAGE(P1.DISC));
|
EXCEPTION
|
EXCEPTION
|
WHEN CONSTRAINT_ERROR => NULL;
|
WHEN CONSTRAINT_ERROR => NULL;
|
WHEN OTHERS => FAILED ("WRONG EXCEPTION (1)");
|
WHEN OTHERS => FAILED ("WRONG EXCEPTION (1)");
|
END;
|
END;
|
BEGIN
|
BEGIN
|
P2 := (DISC => 7); -- 6.
|
P2 := (DISC => 7); -- 6.
|
FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
|
FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
|
"ATTEMPT TO CHANGE DISCRIMINANT OF " &
|
"ATTEMPT TO CHANGE DISCRIMINANT OF " &
|
"CONSTRAINED FORMAL PARAMETER " &
|
"CONSTRAINED FORMAL PARAMETER " &
|
INTEGER'IMAGE(P2.DISC));
|
INTEGER'IMAGE(P2.DISC));
|
EXCEPTION
|
EXCEPTION
|
WHEN CONSTRAINT_ERROR => NULL;
|
WHEN CONSTRAINT_ERROR => NULL;
|
WHEN OTHERS => FAILED ("WRONG EXCEPTION (2)");
|
WHEN OTHERS => FAILED ("WRONG EXCEPTION (2)");
|
END;
|
END;
|
END PROC;
|
END PROC;
|
BEGIN
|
BEGIN
|
---------------------------------------------------------------
|
---------------------------------------------------------------
|
|
|
BEGIN
|
BEGIN
|
OBJ1 := (DISC => IDENT_INT(7)); -- 1.
|
OBJ1 := (DISC => IDENT_INT(7)); -- 1.
|
FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
|
FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
|
"ATTEMPT TO CHANGE DISCRIMINANT OF " &
|
"ATTEMPT TO CHANGE DISCRIMINANT OF " &
|
"CONSTRAINED OBJECT");
|
"CONSTRAINED OBJECT");
|
IF OBJ1 = (DISC => 7) THEN
|
IF OBJ1 = (DISC => 7) THEN
|
COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
|
COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
|
END IF;
|
END IF;
|
EXCEPTION
|
EXCEPTION
|
WHEN CONSTRAINT_ERROR => NULL;
|
WHEN CONSTRAINT_ERROR => NULL;
|
WHEN OTHERS => FAILED ("WRONG EXCEPTION (3)");
|
WHEN OTHERS => FAILED ("WRONG EXCEPTION (3)");
|
END;
|
END;
|
|
|
---------------------------------------------------------------
|
---------------------------------------------------------------
|
|
|
BEGIN
|
BEGIN
|
OBJ3 := ((DISC => IDENT_INT(7)), -- 2.
|
OBJ3 := ((DISC => IDENT_INT(7)), -- 2.
|
(DISC => IDENT_INT(7))); -- 2.
|
(DISC => IDENT_INT(7))); -- 2.
|
FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
|
FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
|
"ATTEMPT TO CHANGE DISCRIMINANT OF " &
|
"ATTEMPT TO CHANGE DISCRIMINANT OF " &
|
"CONSTRAINED RECORD COMPONENT");
|
"CONSTRAINED RECORD COMPONENT");
|
IF OBJ3 = ((DISC => 7), (DISC => 7)) THEN
|
IF OBJ3 = ((DISC => 7), (DISC => 7)) THEN
|
COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
|
COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
|
END IF;
|
END IF;
|
EXCEPTION
|
EXCEPTION
|
WHEN CONSTRAINT_ERROR => NULL;
|
WHEN CONSTRAINT_ERROR => NULL;
|
WHEN OTHERS => FAILED ("WRONG EXCEPTION (4)");
|
WHEN OTHERS => FAILED ("WRONG EXCEPTION (4)");
|
END;
|
END;
|
|
|
--------------------------------------------------------------
|
--------------------------------------------------------------
|
|
|
BEGIN
|
BEGIN
|
A2(2) := (DISC => IDENT_INT(7)); -- 3.
|
A2(2) := (DISC => IDENT_INT(7)); -- 3.
|
FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
|
FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
|
"ATTEMPT TO CHANGE DISCRIMINANT OF " &
|
"ATTEMPT TO CHANGE DISCRIMINANT OF " &
|
"CONSTRAINED ARRAY COMPONENT");
|
"CONSTRAINED ARRAY COMPONENT");
|
IF A2(2) = (DISC => 7) THEN
|
IF A2(2) = (DISC => 7) THEN
|
COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
|
COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
|
END IF;
|
END IF;
|
EXCEPTION
|
EXCEPTION
|
WHEN CONSTRAINT_ERROR => NULL;
|
WHEN CONSTRAINT_ERROR => NULL;
|
WHEN OTHERS => FAILED ("WRONG EXCEPTION (5)");
|
WHEN OTHERS => FAILED ("WRONG EXCEPTION (5)");
|
END;
|
END;
|
|
|
--------------------------------------------------------------
|
--------------------------------------------------------------
|
|
|
BEGIN
|
BEGIN
|
ACC1 := NEW REC1(DISC => IDENT_INT(7)); -- 4.
|
ACC1 := NEW REC1(DISC => IDENT_INT(7)); -- 4.
|
FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
|
FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
|
"ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " &
|
"ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " &
|
"TO ACCESS VARIABLE");
|
"TO ACCESS VARIABLE");
|
IF ACC1 = NEW REC1(DISC => 7) THEN
|
IF ACC1 = NEW REC1(DISC => 7) THEN
|
COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
|
COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
|
END IF;
|
END IF;
|
EXCEPTION
|
EXCEPTION
|
WHEN CONSTRAINT_ERROR => NULL;
|
WHEN CONSTRAINT_ERROR => NULL;
|
WHEN OTHERS => FAILED ("WRONG EXCEPTION (6)");
|
WHEN OTHERS => FAILED ("WRONG EXCEPTION (6)");
|
END;
|
END;
|
|
|
----------------------------------------------------------------
|
----------------------------------------------------------------
|
|
|
ACC1 := NEW REC1(DISC => IDENT_INT(6)); -- OK.
|
ACC1 := NEW REC1(DISC => IDENT_INT(6)); -- OK.
|
|
|
BEGIN
|
BEGIN
|
ACC1.ALL := BADOBJ1; -- 5.
|
ACC1.ALL := BADOBJ1; -- 5.
|
FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
|
FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
|
"ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " &
|
"ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " &
|
"TO ACCESSED OBJECT");
|
"TO ACCESSED OBJECT");
|
IF ACC1.ALL = BADOBJ1 THEN
|
IF ACC1.ALL = BADOBJ1 THEN
|
COMMENT ("PREVENT DEAD VARIABLE OPTIMIZATION");
|
COMMENT ("PREVENT DEAD VARIABLE OPTIMIZATION");
|
END IF;
|
END IF;
|
EXCEPTION
|
EXCEPTION
|
WHEN CONSTRAINT_ERROR => NULL;
|
WHEN CONSTRAINT_ERROR => NULL;
|
WHEN OTHERS => FAILED ("WRONG EXCEPTION (7)");
|
WHEN OTHERS => FAILED ("WRONG EXCEPTION (7)");
|
END;
|
END;
|
|
|
-----------------------------------------------------------------
|
-----------------------------------------------------------------
|
|
|
PROC (OBJ1,OBJ2); -- OK.
|
PROC (OBJ1,OBJ2); -- OK.
|
|
|
BEGIN
|
BEGIN
|
PROC (BADOBJ1,BADOBJ2); -- 6.
|
PROC (BADOBJ1,BADOBJ2); -- 6.
|
FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
|
FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
|
"PASSING OF CONSTRAINED ACTUAL " &
|
"PASSING OF CONSTRAINED ACTUAL " &
|
"PARAMETERS TO DIFFERENTLY CONSTRAINED " &
|
"PARAMETERS TO DIFFERENTLY CONSTRAINED " &
|
"FORMAL PARAMETERS");
|
"FORMAL PARAMETERS");
|
EXCEPTION
|
EXCEPTION
|
WHEN CONSTRAINT_ERROR => NULL;
|
WHEN CONSTRAINT_ERROR => NULL;
|
WHEN OTHERS => FAILED ("WRONG EXCEPTION (8)");
|
WHEN OTHERS => FAILED ("WRONG EXCEPTION (8)");
|
END;
|
END;
|
|
|
---------------------------------------------------------------
|
---------------------------------------------------------------
|
END;
|
END;
|
|
|
RESULT;
|
RESULT;
|
END C37207A;
|
END C37207A;
|
|
|