-- C37006A.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. --* -- FOR A COMPONENT OF A RECORD, ACCESS, OR PRIVATE TYPE, OR FOR A -- LIMITED PRIVATE COMPONENT, CHECK THAT A NON-STATIC EXPRESSION CAN -- BE USED IN A DISCRIMINANT CONSTRAINT OR (EXCEPTING LIMITED PRIVATE -- COMPONENTS) IN SPECIFYING A DEFAULT INITIAL VALUE. -- R.WILLIAMS 8/28/86 WITH REPORT; USE REPORT; PROCEDURE C37006A IS SUBTYPE INT IS INTEGER RANGE 0 .. 100; TYPE ARR IS ARRAY (INT RANGE <>) OF INTEGER; TYPE REC1 (D1, D2 : INT) IS RECORD A : ARR (D1 .. D2); END RECORD; TYPE REC1_NAME IS ACCESS REC1; PROCEDURE CHECK (AR : ARR; STR : STRING) IS BEGIN IF AR'FIRST /= 1 OR AR'LAST /= 2 THEN FAILED ( "INCORRECT BOUNDS FOR R.COMP.A IN COMPONENT " & "OF " & STR & " TYPE"); ELSIF AR /= (3, 4) THEN FAILED ( "INITIALIZATION OF R.COMP.A IN COMPONENT OF " & STR & " TYPE FAILED" ); END IF; END CHECK; PACKAGE PACK IS TYPE PRIV (D1, D2 : INT) IS PRIVATE; TYPE LIM (D1, D2 : INT) IS LIMITED PRIVATE; FUNCTION PRIV_FUN (PARM1, PARM2 : INTEGER) RETURN PRIV; PROCEDURE PRIV_CHECK (R : PRIV); PROCEDURE LIM_CHECK (R : LIM); PRIVATE TYPE PRIV (D1, D2 : INT) IS RECORD A : ARR (D1 .. D2); END RECORD; TYPE LIM (D1, D2 : INT) IS RECORD A : ARR (D1 .. D2); END RECORD; END PACK; PACKAGE BODY PACK IS FUNCTION PRIV_FUN (PARM1, PARM2 : INTEGER) RETURN PRIV IS BEGIN RETURN (IDENT_INT (1), IDENT_INT (2), ARR'(1 => 3, 2 => 4)); END PRIV_FUN; PROCEDURE PRIV_CHECK (R : PRIV) IS BEGIN CHECK (R.A, "PRIVATE TYPE" ); END PRIV_CHECK; PROCEDURE LIM_CHECK (R : LIM) IS BEGIN IF R.A'FIRST /= 1 OR R.A'LAST /= 2 THEN FAILED ( "INCORRECT BOUNDS FOR R.COMP.A IN " & "COMPONENT OF LIMITED PRIVATE TYPE"); END IF; END LIM_CHECK; END PACK; USE PACK; BEGIN TEST ( "C37006A", "FOR A COMPONENT OF A RECORD, ACCESS, " & "OR PRIVATE TYPE, OR FOR A LIMITED PRIVATE " & "COMPONENT, CHECK THAT A NON-STATIC " & "EXPRESSION CAN BE USED IN A DISCRIMINANT " & "CONSTRAINT OR (EXCEPTING LIMITED PRIVATE " & "COMPONENTS) IN SPECIFYING A DEFAULT " & "INITIAL VALUE" ); BEGIN DECLARE TYPE REC2 IS RECORD COMP : REC1 (IDENT_INT (1), IDENT_INT (2)) := (IDENT_INT (1), IDENT_INT (2), ARR'(1 => 3, 2 => 4)); END RECORD; R : REC2; BEGIN IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN CHECK (R.COMP.A, "RECORD"); ELSE FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " & "OF RECORD TYPE COMPONENT" ); END IF; EXCEPTION WHEN CONSTRAINT_ERROR => FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " & "SEQUENCE FOLLOWING DECLARATION OF " & "RECORD TYPE COMPONENT" ); WHEN OTHERS => FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " & "SEQUENCE FOLLOWING DECLARATION OF " & "RECORD TYPE COMPONENT" ); END; EXCEPTION WHEN CONSTRAINT_ERROR => FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " & "OF RECORD TYPE COMPONENT" ); WHEN OTHERS => FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " & "OF RECORD TYPE COMPONENT" ); END; BEGIN DECLARE TYPE REC2 IS RECORD COMP : REC1_NAME (IDENT_INT (1), IDENT_INT (2)) := NEW REC1'(IDENT_INT (1), IDENT_INT (2), ARR'(1 => 3, 2 => 4)); END RECORD; R : REC2; BEGIN IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN CHECK (R.COMP.A, "ACCESS"); ELSE FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " & "OF ACCESS TYPE COMPONENT" ); END IF; EXCEPTION WHEN CONSTRAINT_ERROR => FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " & "SEQUENCE FOLLOWING DECLARATION OF " & "ACCESS TYPE COMPONENT" ); WHEN OTHERS => FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " & "SEQUENCE FOLLOWING DECLARATION OF " & "ACCESS TYPE COMPONENT" ); END; EXCEPTION WHEN CONSTRAINT_ERROR => FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " & "OF ACCESS TYPE COMPONENT" ); WHEN OTHERS => FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " & "OF ACCESS TYPE COMPONENT" ); END; BEGIN DECLARE TYPE REC2 IS RECORD COMP : PRIV (IDENT_INT (1), IDENT_INT (2)) := PRIV_FUN (IDENT_INT (1), IDENT_INT (2)); END RECORD; R : REC2; BEGIN IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN PRIV_CHECK (R.COMP); ELSE FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " & "OF PRIVATE TYPE COMPONENT" ); END IF; EXCEPTION WHEN CONSTRAINT_ERROR => FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " & "SEQUENCE FOLLOWING DECLARATION OF " & "PRIVATE TYPE COMPONENT" ); WHEN OTHERS => FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " & "SEQUENCE FOLLOWING DECLARATION OF " & "PRIVATE TYPE COMPONENT" ); END; EXCEPTION WHEN CONSTRAINT_ERROR => FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " & "OF PRIVATE TYPE COMPONENT" ); WHEN OTHERS => FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " & "OF PRIVATE TYPE COMPONENT" ); END; BEGIN DECLARE TYPE REC2 IS RECORD COMP : LIM (IDENT_INT (1), IDENT_INT (2)); END RECORD; R : REC2; BEGIN IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN LIM_CHECK (R.COMP); ELSE FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " & "OF LIM PRIV TYPE COMPONENT" ); END IF; EXCEPTION WHEN CONSTRAINT_ERROR => FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " & "SEQUENCE FOLLOWING DECLARATION OF " & " LIM PRIV TYPE COMPONENT" ); WHEN OTHERS => FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " & "SEQUENCE FOLLOWING DECLARATION OF " & " LIM PRIV TYPE COMPONENT" ); END; EXCEPTION WHEN CONSTRAINT_ERROR => FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " & "OF LIM PRIV TYPE COMPONENT" ); WHEN OTHERS => FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " & "OF LIM PRIV TYPE COMPONENT" ); END; RESULT; END C37006A;