-- C37213J.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, FOR A GENERIC FORMAL TYPE - WHERE A DISCRIMINANT OR AN -- INDEX CONSTRAINT DEPENDS ON A RECORD DISCRIMINANT AND THE -- RECORD TYPE IS CONSTRAINED BY DEFAULT - USED TO DECLARE AN -- OBJECT OR A SUBTYPE, THAT THE NON-DISCRIMINANT EXPRESSIONS -- OF THE CONSTRAINT ARE CHECKED FOR COMPATIBILITY: -- 1) ONLY IN AN OBJECT DECLARATION, AND -- 2) ONLY IF THE DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT -- IN THE SUBTYPE. -- HISTORY: -- JBG 10/17/86 CREATED ORIGINAL TEST. -- VCL 10/23/87 MODIFIED THIS HEADER; SEPARATED THIS TEST INTO -- 3 NEW TESTS (J,K,L); CHANGED THE AGGREGATE FOR -- THE PARAMETER 'VALUE' IN THE CALL OF PROCEDURE -- 'SUBTYPE_CHK1'; MOVED THE CALL TO REPORT.TEST -- SO THAT IT COMES BEFORE ANY DECLARATIONS; ADDED -- A SEQUENCE COUNTER TO IDENTIFY WHICH SUBTEST -- DECLARATION PART RAISES CONSTRAINT_ERROR. -- VCL 03/28/88 MODIFIED THE TEST DISCRIPTION TO MORE ACCURATELY -- DESCRIBE THE OBJECTIVE; CHANGED THE FORMAL -- PARAMETERS TO THE GENERIC UNITS AND THE -- CORRESPONDING ACTUAL PARAMETERS; REORGANIZED THE -- TEST SO THAT ALL OPERATIONS ON A SPECIFIC TYPE -- ARE TOGETHER. WITH REPORT; USE REPORT; PROCEDURE C37213J IS BEGIN TEST ("C37213J", "THE NON-DISCRIMINANT VALUES OF A DISCRIMINANT " & "OR AN INDEX CONSTRAINT THAT DEPEND ON A " & "DISCRIMINANT ARE PROPERLY CHECKED WHEN THE " & "RECORD TYPE IS CONSTRAINED BY DEFAULT AND " & "USED AS THE ACTUAL PARAMETER TO A GENERIC " & "FORMAL TYPE USED TO DECLARE AN OBJECT OR A " & "SUBTYPE"); DECLARE SUBTYPE SM IS INTEGER RANGE 1..10; TYPE REC (D1, D2 : SM) IS RECORD NULL; END RECORD; TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; SEQUENCE_NUMBER : INTEGER; GENERIC TYPE CONS IS PRIVATE; OBJ_XCP : BOOLEAN; TAG : STRING; PACKAGE OBJ_CHK IS END OBJ_CHK; GENERIC TYPE CONS IS PRIVATE; PROCEDURE SUBTYP_CHK (OBJ_XCP : BOOLEAN; TAG : STRING); PACKAGE BODY OBJ_CHK IS BEGIN -- DECLARE AN OBJECT OF THE FORMAL TYPE. DECLARE X : CONS; FUNCTION VALUE RETURN CONS IS BEGIN IF EQUAL (3,3) THEN RETURN X; ELSE RETURN X; END IF; END VALUE; BEGIN IF OBJ_XCP THEN FAILED ("NO CHECK DURING DECLARATION " & "OF OBJECT OF TYPE CONS - " & TAG); ELSIF X /= VALUE THEN FAILED ("INCORRECT VALUE FOR OBJECT OF " & "TYPE CONS - " & TAG); END IF; END; EXCEPTION WHEN CONSTRAINT_ERROR => IF NOT OBJ_XCP THEN FAILED ("IMPROPER CONSTRAINT CHECKED " & "DURING DECLARATION OF OBJECT " & "OF TYPE CONS - " & TAG); END IF; END OBJ_CHK; PROCEDURE SUBTYP_CHK (OBJ_XCP : BOOLEAN; TAG : STRING) IS BEGIN -- DECLARE A SUBTYPE OF THE FORMAL TYPE. DECLARE SUBTYPE SCONS IS CONS; BEGIN DECLARE X : SCONS; FUNCTION VALUE RETURN SCONS IS BEGIN IF EQUAL (5, 5) THEN RETURN X; ELSE RETURN X; END IF; END VALUE; BEGIN IF OBJ_XCP THEN FAILED ("NO CHECK DURING DECLARATION " & "OF OBJECT OF SUBTYPE SCONS - " & TAG); ELSIF X /= VALUE THEN FAILED ("INCORRECT VALUE FOR OBJECT " & "OF SUBTYPE SCONS - " & TAG); END IF; END; EXCEPTION WHEN CONSTRAINT_ERROR => IF NOT OBJ_XCP THEN FAILED ("IMPROPER CONSTRAINT CHECKED " & "DURING DECLARATION OF OBJECT " & "OF SUBTYPE SCONS - " & TAG); END IF; END; EXCEPTION WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT IMPROPERLY CHECKED " & "DURING SUBTYPE DECLARATION - " & TAG); END SUBTYP_CHK; BEGIN SEQUENCE_NUMBER := 1; DECLARE TYPE REC_DEF (D3 : INTEGER := 1) IS RECORD C1 : REC (D3, 0); END RECORD; PACKAGE PACK1 IS NEW OBJ_CHK (REC_DEF, OBJ_XCP => TRUE, TAG => "PACK1"); PROCEDURE PROC1 IS NEW SUBTYP_CHK (REC_DEF); BEGIN PROC1 (OBJ_XCP => TRUE, TAG => "PROC1"); END; SEQUENCE_NUMBER := 2; DECLARE TYPE ARR_DEF (D3 : INTEGER := IDENT_INT(1)) IS RECORD C1 : MY_ARR (0..D3); END RECORD; PACKAGE PACK2 IS NEW OBJ_CHK (ARR_DEF, OBJ_XCP => TRUE, TAG => "PACK2"); PROCEDURE PROC2 IS NEW SUBTYP_CHK (ARR_DEF); BEGIN PROC2 (OBJ_XCP => TRUE, TAG => "PROC2"); END; SEQUENCE_NUMBER := 3; DECLARE TYPE VAR_REC_DEF1 (D3 : INTEGER := 1) IS RECORD CASE D3 IS WHEN -5..10 => C1 : REC (D3, IDENT_INT(11)); WHEN OTHERS => C2 : INTEGER := IDENT_INT(5); END CASE; END RECORD; PACKAGE PACK3 IS NEW OBJ_CHK (VAR_REC_DEF1, OBJ_XCP => TRUE, TAG => "PACK3"); PROCEDURE PROC3 IS NEW SUBTYP_CHK (VAR_REC_DEF1); BEGIN PROC3 (OBJ_XCP => TRUE, TAG => "PROC3"); END; SEQUENCE_NUMBER := 4; DECLARE TYPE VAR_REC_DEF6 (D3 : INTEGER := IDENT_INT(-6)) IS RECORD CASE D3 IS WHEN -5..10 => C1 : REC (D3, IDENT_INT(11)); WHEN OTHERS => C2 : INTEGER := IDENT_INT(5); END CASE; END RECORD; PACKAGE PACK4 IS NEW OBJ_CHK (VAR_REC_DEF6, OBJ_XCP => FALSE, TAG => "PACK4"); PROCEDURE PROC4 IS NEW SUBTYP_CHK (VAR_REC_DEF6); BEGIN PROC4 (OBJ_XCP => FALSE,TAG => "PROC4"); END; SEQUENCE_NUMBER := 5; DECLARE TYPE VAR_REC_DEF11 (D3 : INTEGER := 11) IS RECORD CASE D3 IS WHEN -5..10 => C1 : REC (D3, IDENT_INT(11)); WHEN OTHERS => C2 : INTEGER := IDENT_INT(5); END CASE; END RECORD; PACKAGE PACK5 IS NEW OBJ_CHK (VAR_REC_DEF11, OBJ_XCP => FALSE, TAG => "PACK5"); PROCEDURE PROC5 IS NEW SUBTYP_CHK (VAR_REC_DEF11); BEGIN PROC5 (OBJ_XCP => FALSE, TAG => "PROC5"); END; SEQUENCE_NUMBER := 6; DECLARE TYPE VAR_ARR_DEF1 (D3 : INTEGER := IDENT_INT(1)) IS RECORD CASE D3 IS WHEN -5..10 => C1 : MY_ARR(D3..IDENT_INT(11)); WHEN OTHERS => C2 : INTEGER := IDENT_INT(5); END CASE; END RECORD; PACKAGE PACK6 IS NEW OBJ_CHK (VAR_ARR_DEF1, OBJ_XCP => TRUE, TAG => "PACK6"); PROCEDURE PROC6 IS NEW SUBTYP_CHK (VAR_ARR_DEF1); BEGIN PROC6 (OBJ_XCP => TRUE, TAG => "PROC6"); END; SEQUENCE_NUMBER := 7; DECLARE TYPE VAR_ARR_DEF6 (D3 : INTEGER := -6) IS RECORD CASE D3 IS WHEN -5..10 => C1 : MY_ARR(D3..IDENT_INT(11)); WHEN OTHERS => C2 : INTEGER := IDENT_INT(5); END CASE; END RECORD; PACKAGE PACK7 IS NEW OBJ_CHK (VAR_ARR_DEF6, OBJ_XCP => FALSE, TAG => "PACK7"); PROCEDURE PROC7 IS NEW SUBTYP_CHK (VAR_ARR_DEF6); BEGIN PROC7 (OBJ_XCP => FALSE, TAG => "PROC7"); END; SEQUENCE_NUMBER := 8; DECLARE TYPE VAR_ARR_DEF11 (D3 : INTEGER := IDENT_INT(11)) IS RECORD CASE D3 IS WHEN -5..10 => C1 : MY_ARR(D3..IDENT_INT(11)); WHEN OTHERS => C2 : INTEGER := IDENT_INT(5); END CASE; END RECORD; PACKAGE PACK8 IS NEW OBJ_CHK (VAR_ARR_DEF11, OBJ_XCP => FALSE, TAG => "PACK8"); PROCEDURE PROC8 IS NEW SUBTYP_CHK (VAR_ARR_DEF11); BEGIN PROC8 (OBJ_XCP => FALSE, TAG => "PROC8"); END; EXCEPTION WHEN OTHERS => FAILED ("EXCEPTION RAISED DURING DECLARATION / " & "INSTANTIATION ELABORATION - " & INTEGER'IMAGE(SEQUENCE_NUMBER)); END; RESULT; END C37213J;