-- CC3128A.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 A CONSTRAINED IN FORMAL PARAMETER HAVING AN ACCESS TYPE,
--     CONSTRAINT_ERROR IS RAISED IF AND ONLY IF THE ACTUAL PARAMETER IS NOT
--     NULL AND THE OBJECT DESIGNATED BY THE ACTUAL PARAMETER DOES NOT SATISFY
--     THE FORMAL PARAMETER'S CONSTRAINTS.

-- HISTORY:
--     RJW 10/28/88  CREATED ORIGINAL TEST.
--     JRL 02/28/96  Removed cases where the designated subtypes of the formal
--                   and actual do not statically match. Corrected commentary.

WITH REPORT; USE REPORT;
PROCEDURE CC3128A IS

BEGIN
     TEST ("CC3128A", "FOR A CONSTRAINED IN FORMAL PARAMETER HAVING " &
                      "AN ACCESS TYPE, CONSTRAINT_ERROR IS RAISED " &
                      "IF AND ONLY IF THE ACTUAL PARAMETER IS NOT " &
                      "NULL AND THE OBJECT DESIGNATED BY THE ACTUAL " &
                      "PARAMETER DOES NOT SATISFY FORMAL PARAMETER'S " &
                      "CONSTRAINTS");

     DECLARE
          TYPE REC (D : INTEGER := 10) IS
               RECORD
                    NULL;
               END RECORD;

          TYPE ACCREC IS ACCESS REC;

          SUBTYPE LINK IS ACCREC (5);

          GENERIC
               LINK1 : LINK;
          FUNCTION F (I : INTEGER) RETURN INTEGER;

          FUNCTION F (I : INTEGER) RETURN INTEGER IS
          BEGIN
               IF I /= 5 THEN
                    FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " &
                            "TO CALL TO FUNCTION F - 1");
               END IF;
               IF NOT EQUAL (I, 5) AND THEN
                  NOT EQUAL (LINK1.D, LINK1.D) THEN
                    COMMENT ("DISREGARD");
               END IF;
               RETURN I + 1;
          EXCEPTION
               WHEN OTHERS =>
                    FAILED ("EXCEPTION RAISED WITHIN FUNCTION F - 1");
               RETURN I + 1;
          END F;

          GENERIC
               TYPE PRIV (D : INTEGER) IS PRIVATE;
               PRIV1 : PRIV;
          PACKAGE GEN IS
               TYPE ACCPRIV IS ACCESS PRIV;
               SUBTYPE LINK IS ACCPRIV (5);
               GENERIC
                    LINK1 : LINK;
                    I : IN OUT INTEGER;
               PACKAGE P IS END P;
          END GEN;

          PACKAGE BODY GEN IS
               PACKAGE BODY P IS
               BEGIN
                    IF I /= 5 THEN
                         FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " &
                                 "TO PACKAGE BODY P - 1");
                    END IF;
                    IF NOT EQUAL (I, 5) AND THEN
                       NOT EQUAL (LINK1.D, LINK1.D) THEN
                         COMMENT ("DISREGARD");
                    END IF;
                    I := I + 1;
               EXCEPTION
                    WHEN OTHERS =>
                         FAILED ("EXCEPTION RAISED WITHIN " &
                                 "PACKAGE P - 1");
                    I := I + 1;
               END P;

          BEGIN
               BEGIN
                    DECLARE
                         AR10 : ACCPRIV;
                         I : INTEGER := IDENT_INT (5);
                         PACKAGE P1 IS NEW P (AR10, I);
                    BEGIN
                         IF I /= 6 THEN
                              FAILED ("INCORRECT RESULT - " &
                                      "PACKAGE P1");
                         END IF;
                    EXCEPTION
                         WHEN OTHERS =>
                              FAILED ("EXCEPTION RAISED TOO LATE - " &
                                      "PACKAGE P1 - 1");
                    END;
               EXCEPTION
                    WHEN OTHERS =>
                         FAILED ("EXCEPTION RAISED AT INSTANTIATION " &
                                 "OF PACKAGE P1 WITH NULL ACCESS " &
                                 "VALUE");
               END;

               BEGIN
                    DECLARE
                         AR10 : ACCPRIV := NEW PRIV'(PRIV1);
                         I : INTEGER := IDENT_INT (0);
                         PACKAGE P1 IS NEW P (AR10, I);
                    BEGIN
                         FAILED ("NO EXCEPTION RAISED BY " &
                                 "INSTANTIATION OF PACKAGE P1");
                    EXCEPTION
                         WHEN OTHERS =>
                              FAILED ("EXCEPTION RAISED TOO LATE - " &
                                      "PACKAGE P1 - 2");
                    END;
               EXCEPTION
                    WHEN CONSTRAINT_ERROR =>
                         NULL;
                    WHEN OTHERS =>
                         FAILED ("WRONG EXCEPTION RAISED AT " &
                                 "INSTANTIATION OF PACKAGE P1");
               END;
          END GEN;

          PACKAGE NEWGEN IS NEW GEN (REC, (D => 10));

     BEGIN
          BEGIN
               DECLARE
                    I : INTEGER := IDENT_INT (5);
                    AR10 : ACCREC;
                    FUNCTION F1 IS NEW F (AR10);
               BEGIN
                    I := F1 (I);
                    IF I /= 6 THEN
                         FAILED ("INCORRECT RESULT RETURNED BY " &
                                 "FUNCTION F1");
                    END IF;
               EXCEPTION
                    WHEN OTHERS =>
                         FAILED ("EXCEPTION RAISED AT CALL TO " &
                                 "FUNCTION F1 - 1");
               END;
          EXCEPTION
               WHEN OTHERS =>
                    FAILED ("EXCEPTION RAISED AT INSTANTIATION OF " &
                            "FUNCTION F1 WITH NULL ACCESS VALUE");
          END;

          BEGIN
               DECLARE
                    I : INTEGER := IDENT_INT (0);
                    AR10 : ACCREC := NEW REC'(D => 10);
                    FUNCTION F1 IS NEW F (AR10);
               BEGIN
                    FAILED ("NO EXCEPTION RAISED BY INSTANTIATION " &
                            "OF FUNCTION F1");
                    I := F1 (I);
               EXCEPTION
                    WHEN OTHERS =>
                         FAILED ("EXCEPTION RAISED AT CALL TO " &
                                 "FUNCTION F1 - 2");
               END;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    FAILED ("WRONG EXCEPTION RAISED AT " &
                            "INSTANTIATION OF FUNCTION F1");
          END;
     END;

     DECLARE
          TYPE ARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;

          TYPE ACCARR IS ACCESS ARR;

          SUBTYPE LINK IS ACCARR (1 .. 5);

          GENERIC
               LINK1 : LINK;
          FUNCTION F (I : INTEGER) RETURN INTEGER;

          FUNCTION F (I : INTEGER) RETURN INTEGER IS
          BEGIN
               IF I /= 5 THEN
                    FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " &
                            "TO CALL TO FUNCTION F - 2");
               END IF;
               IF NOT EQUAL (I, 5) AND THEN
                  NOT EQUAL (LINK1(IDENT_INT (3)),LINK1(IDENT_INT (3)))
                  THEN
                    COMMENT ("DISREGARD");
               END IF;
               RETURN I + 1;
          EXCEPTION
               WHEN OTHERS =>
                    FAILED ("EXCEPTION RAISED WITHIN FUNCTION F - 2");
               RETURN I + 1;
          END F;

          GENERIC
               TYPE GENARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
          PACKAGE GEN IS
               TYPE ACCGENARR IS ACCESS GENARR;
               SUBTYPE LINK IS ACCGENARR (1 .. 5);
               GENERIC
                    LINK1 : LINK;
                    I : IN OUT INTEGER;
               PACKAGE P IS END P;
          END GEN;

          PACKAGE BODY GEN IS
               PACKAGE BODY P IS
               BEGIN
                    IF I /= 5 THEN
                         FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " &
                                 "TO PACKAGE BODY P - 2");
                    END IF;
                    IF NOT EQUAL (I, 5) AND THEN
                       NOT
                       EQUAL(LINK1(IDENT_INT (3)),LINK1(IDENT_INT (3)))
                       THEN
                         COMMENT ("DISREGARD");
                    END IF;
                    I := I + 1;
               EXCEPTION
                    WHEN OTHERS =>
                         FAILED ("EXCEPTION RAISED WITHIN " &
                                 "PACKAGE P - 2");
                    I := I + 1;
               END P;

          BEGIN
               BEGIN
                    DECLARE
                         AR26 : ACCGENARR (2 .. 6);
                         I : INTEGER := IDENT_INT (5);
                         PACKAGE P2 IS NEW P (AR26, I);
                    BEGIN
                         IF I /= 6 THEN
                              FAILED ("INCORRECT RESULT - " &
                                      "PACKAGE P2");
                         END IF;
                    EXCEPTION
                         WHEN OTHERS =>
                              FAILED ("EXCEPTION RAISED TOO LATE - " &
                                      "PACKAGE P2 - 1");
                    END;
               EXCEPTION
                    WHEN OTHERS =>
                         FAILED ("EXCEPTION RAISED AT INSTANTIATION " &
                                 "OF PACKAGE P2 WITH NULL ACCESS " &
                                 "VALUE");
               END;

               BEGIN
                    DECLARE
                         AR26 : ACCGENARR
                                (IDENT_INT (2) .. IDENT_INT (6)) :=
                                NEW GENARR'(1,2,3,4,5);
                         I : INTEGER := IDENT_INT (0);
                         PACKAGE P2 IS NEW P (AR26, I);
                    BEGIN
                         FAILED ("NO EXCEPTION RAISED BY " &
                                 "INSTANTIATION OF PACKAGE P2");
                    EXCEPTION
                         WHEN OTHERS =>
                              FAILED ("EXCEPTION RAISED TOO LATE - " &
                                      "PACKAGE P2 - 2");
                    END;
               EXCEPTION
                    WHEN CONSTRAINT_ERROR =>
                         NULL;
                    WHEN OTHERS =>
                         FAILED ("WRONG EXCEPTION RAISED AT " &
                                 "INSTANTIATION OF PACKAGE P2");
               END;
          END GEN;

          PACKAGE NEWGEN IS NEW GEN (ARR);

     BEGIN
          BEGIN
               DECLARE
                    I : INTEGER := IDENT_INT (5);
                    AR26 : ACCARR (IDENT_INT (2) .. IDENT_INT (6));
                    FUNCTION F2 IS NEW F (AR26);
               BEGIN
                    I := F2 (I);
                    IF I /= 6 THEN
                         FAILED ("INCORRECT RESULT RETURNED BY " &
                                 "FUNCTION F2");
                    END IF;
               EXCEPTION
                    WHEN OTHERS =>
                         FAILED ("EXCEPTION RAISED AT CALL TO " &
                                 "FUNCTION F2 - 1");
               END;
          EXCEPTION
               WHEN OTHERS =>
                    FAILED ("EXCEPTION RAISED AT INSTANTIATION OF " &
                            "FUNCTION F2 WITH NULL ACCESS VALUE");
          END;

          BEGIN
               DECLARE
                    I : INTEGER := IDENT_INT (0);
                    AR26 : ACCARR (2 .. 6) := NEW ARR'(1,2,3,4,5);
                    FUNCTION F2 IS NEW F (AR26);
               BEGIN
                    FAILED ("NO EXCEPTION RAISED BY INSTANTIATION " &
                            "OF FUNCTION F2");
                    I := F2 (I);
               EXCEPTION
                    WHEN OTHERS =>
                         FAILED ("EXCEPTION RAISED AT CALL TO " &
                                 "FUNCTION F2 - 2");
               END;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    FAILED ("WRONG EXCEPTION RAISED AT " &
                            "INSTANTIATION OF FUNCTION F2");
          END;
     END;
     RESULT;
END CC3128A;