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