c37213l.ada

来自「用于进行gcc测试」· ADA 代码 · 共 330 行

-- C37213L.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 A
--     DERIVED OR AN ACCESS TYPE, THAT THE NON-DISCRIMINANT EXPRESSIONS
--     OF THE CONSTRAINT ARE CHECKED FOR COMPATIBILITY:
--          1) ONLY IN AN OBJECT DECLARATION OR ALLOCATOR, AND
--          2) ONLY IF THE DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT
--             IN THE SUBTYPE.

-- HISTORY:
--     VCL  10/23/88  CREATED ORIGINAL TEST BY SPLITTING FROM C37213J.
--     VCL  03/30/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;  REWROTE ONE OF THE GENERIC
--                    PACKAGES AS A GENERIC PROCEDURE TO BROADEN
--                    COVERAGE OF TEST.

WITH REPORT; USE REPORT;
PROCEDURE C37213L IS
BEGIN
     TEST ("C37213L", "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 A DERIVED OR AN " &
                      "ACCESS TYPE");

     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 DER_CHK IS  END DER_CHK;

          PACKAGE BODY DER_CHK IS
          BEGIN
               DECLARE
                    TYPE DREC IS NEW CONS;
               BEGIN
                    DECLARE
                         X : DREC;

                         FUNCTION VALUE RETURN DREC 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 DREC - " &
                                      TAG);
                         ELSIF X /= VALUE THEN
                              FAILED ("INCORRECT VALUE FOR OBJECT OF " &
                                      "TYPE DREC - " & TAG);
                         END IF;
                    END;
               EXCEPTION
                    WHEN CONSTRAINT_ERROR =>
                         IF NOT OBJ_XCP THEN
                              FAILED ("IMPROPER CONSTRAINT CHECKED " &
                                      "DURING DECLARATION OF OBJECT " &
                                      "OF TYPE DREC - " & TAG);
                         END IF;
               END;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    FAILED ("CONSTRAINT IMPROPERLY CHECKED " &
                            "DURING DECLARATION OF DREC - " & TAG);
          END;

          GENERIC
               TYPE CONS IS PRIVATE;
          PROCEDURE ACC_CHK (OBJ_XCP : BOOLEAN;
                             TAG     : STRING);

          PROCEDURE ACC_CHK (OBJ_XCP : BOOLEAN;
                             TAG     : STRING)  IS
          BEGIN
               DECLARE
                    TYPE ACC_CONS IS ACCESS CONS;
               BEGIN
                    DECLARE
                         X : ACC_CONS;

                         FUNCTION VALUE RETURN CONS IS
                         BEGIN
                              IF EQUAL (5, 5) THEN
                                   RETURN X.ALL;
                              ELSE
                                   RETURN X.ALL;
                              END IF;
                         END VALUE;
                    BEGIN
                         X := NEW CONS;

                         IF OBJ_XCP THEN
                              FAILED ("NO CHECK DURING ALLOCATION " &
                                      "OF OBJECT OF TYPE CONS - " &
                                      TAG);
                         ELSIF X.ALL /= VALUE THEN
                              FAILED ("INCORRECT VALUE FOR OBJECT " &
                                      "OF TYPE CONS - " & TAG);
                         END IF;
                    EXCEPTION
                         WHEN CONSTRAINT_ERROR =>
                              IF NOT OBJ_XCP THEN
                                   FAILED ("IMPROPER CONSTRAINT " &
                                           "CHECKED DURING " &
                                           "ALLOCATION OF OBJECT " &
                                           "OF TYPE CONS - " & TAG);
                              END IF;
                    END;
               EXCEPTION
                    WHEN CONSTRAINT_ERROR =>
                         FAILED ("CONSTRAINT IMPROPERLY CHECKED " &
                                 "DURING DECLARATION OF X - " & TAG);
               END;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    FAILED ("CONSTRAINT IMPROPERLY CHECKED " &
                            "DURING DECLARATION OF ACC_CONS - " & TAG);
          END ACC_CHK;
     BEGIN
          SEQUENCE_NUMBER := 1;
          DECLARE
               TYPE REC_DEF (D3 : INTEGER := 1) IS
                    RECORD
                         C1 : REC (D3, 0);
                    END RECORD;

               PACKAGE PACK1 IS NEW DER_CHK (REC_DEF,
                                  OBJ_XCP => TRUE,
                                  TAG     => "PACK1");

               PROCEDURE PROC1 IS NEW ACC_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 DER_CHK (ARR_DEF,
                                  OBJ_XCP => TRUE,
                                  TAG     => "PACK2");

               PROCEDURE PROC2 IS NEW ACC_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 DER_CHK (VAR_REC_DEF1,
                                  OBJ_XCP => TRUE,
                                  TAG     => "PACK3");

               PROCEDURE PROC3 IS NEW ACC_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 DER_CHK (VAR_REC_DEF6,
                                  OBJ_XCP => FALSE,
                                  TAG     => "PACK4");

               PROCEDURE PROC4 IS NEW ACC_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 DER_CHK (VAR_REC_DEF11,
                                  OBJ_XCP => FALSE,
                                  TAG     => "PACK5");

               PROCEDURE PROC5 IS NEW ACC_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 DER_CHK (VAR_ARR_DEF1,
                                  OBJ_XCP => TRUE,
                                  TAG     => "PACK6");

               PROCEDURE PROC6 IS NEW ACC_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 DER_CHK (VAR_ARR_DEF6,
                                  OBJ_XCP => FALSE,
                                  TAG     => "PACK7");

               PROCEDURE PROC7 IS NEW ACC_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 DER_CHK (VAR_ARR_DEF11,
                                  OBJ_XCP => FALSE,
                                  TAG     => "PACK8");

               PROCEDURE PROC8 IS NEW ACC_CHK (VAR_ARR_DEF11);
          BEGIN
               PROC8 (OBJ_XCP => FALSE, TAG => "PROC8");
          END;
     EXCEPTION
          WHEN OTHERS =>
               FAILED ("UNEXPECTED EXCEPTION RAISED DURING " &
                       "DECLARATION / INSTANTIATION ELABORATION - " &
                       INTEGER'IMAGE (SEQUENCE_NUMBER));
     END;

     RESULT;
END C37213L;