c37213h.ada

来自「用于进行gcc测试」· ADA 代码 · 共 458 行 · 第 1/2 页

-- C37213H.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, WHERE AN INDEX CONSTRAINT DEPENDS ON A RECORD
--     DISCRIMINANT WITH A DEFAULT VALUE AND THE RECORD TYPE IS NOT
--     EXPLICITLY CONSTRAINED, THAT THE NON-DISCRIMINANT EXPRESSIONS
--     IN THE INDEX CONSTRAINT ARE:
--          1) EVALUATED WHEN THE RECORD COMPONENT SUBTYPE DEFINITION
--             IS ELABORATED,
--          2) PROPERLY CHECKED FOR COMPATIBILITY ONLY IN AN ALLOCATION
--             OR OBJECT DECLARATION AND 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; MODIFIED THE CHECK OF
--                    SUBTYPE 'SCONS', IN BOTH SUBPARTS OF THE TEST,
--                    TO INDICATE FAILURE IF CONSTRAINT_ERROR IS RAISED
--                    FOR THE SUBTYPE DECLARATION AND FAILURE IF
--                    CONSTRAINT_ERROR IS NOT RAISED FOR AN OBJECT
--                    DECLARATION OF THIS SUBTYPE; RELOCATED THE CALL TO
--                    REPORT.TEST SO THAT IT COMES BEFORE ANY
--                    DECLARATIONS;  ADDED 'SEQUENCE_NUMBER' TO IDENTIFY
--                    THE CURRENT SUBTEST (FOR EXCEPTIONS); CHANGE THE
--                    TYPE OF THE DISCRIMINANT IN THE RECORD 'CONS'
--                    TO AN INTEGER SUBTYPE.
--     VCL  03/30/88  MODIFIED HEADER AND MESSAGES OUTPUT BY REPORT
--                    PACKAGE.

WITH REPORT; USE REPORT;
PROCEDURE C37213H IS
BEGIN
     TEST ("C37213H", "THE NON-DISCRIMINANT EXPRESSIONS OF AN " &
                      "INDEX CONSTRAINT THAT DEPEND ON A " &
                      "DISCRIMINANT WITH A DEFAULT VALUE ARE " &
                      "PROPERLY EVALUATED AND CHECKED WHEN THE " &
                      "RECORD TYPE IS NOT EXPLICITLY CONSTRAINED AND " &
                      "THE COMPONENT IS AND IS NOT PRESENT IN THE " &
                      "SUBTYPE");

     DECLARE
          SEQUENCE_NUMBER : INTEGER;

          SUBTYPE DISCR IS INTEGER RANGE -50..50;
          SUBTYPE SM IS INTEGER RANGE 1..10;
          TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER;

          F1_CONS : INTEGER := 2;

          FUNCTION CHK (
               CONS    : INTEGER;
               VALUE   : INTEGER;
               MESSAGE : STRING) RETURN BOOLEAN IS
          BEGIN
               IF CONS /= VALUE THEN
                    FAILED (MESSAGE & ": F1_CONS IS " &
                            INTEGER'IMAGE(F1_CONS));
               END IF;
               RETURN TRUE;
          END CHK;

          FUNCTION F1 RETURN INTEGER IS
          BEGIN
               F1_CONS := F1_CONS - IDENT_INT(1);
               RETURN F1_CONS;
          END F1;
     BEGIN


-- CASE 1: DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT.

          SEQUENCE_NUMBER :=1;
          DECLARE
               TYPE CONS (D3 : DISCR := IDENT_INT(1)) IS
                    RECORD
                         CASE D3 IS
                              WHEN -5..10 =>
                                   C1 : MY_ARR(F1..D3); -- F1 EVALUATED.
                              WHEN OTHERS =>
                                   C2 : INTEGER := IDENT_INT(0);
                         END CASE;
                    END RECORD;

               CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED");

               X : CONS;                     -- F1 NOT EVALUATED AGAIN.
               Y : CONS;                     -- F1 NOT EVALUATED AGAIN.

               CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED");
          BEGIN
               IF X.C1'FIRST /= 1 OR Y.C1'LAST /= 1 THEN
                    FAILED ("VALUES NOT CORRECT");
               END IF;
          END;


          F1_CONS := 12;

          SEQUENCE_NUMBER := 2;
          DECLARE
               TYPE CONS (D3 : DISCR := IDENT_INT(1)) IS
                    RECORD
                         CASE D3 IS
                              WHEN -5..10 =>
                                   C1 : MY_ARR(D3..F1);
                              WHEN OTHERS =>
                                   C2 : INTEGER := IDENT_INT(0);
                         END CASE;
                    END RECORD;
          BEGIN
               BEGIN
                    DECLARE
                         X : CONS;
                    BEGIN
                         FAILED ("INDEX CHECK NOT PERFORMED - 1");
                         IF X /= (1, (1, 1)) THEN
                              COMMENT ("INCORRECT VALUES FOR X - 1");
                         END IF;
                    END;
               EXCEPTION
                    WHEN CONSTRAINT_ERROR =>
                         NULL;
                    WHEN OTHERS =>
                         FAILED ("UNEXPECTED EXCEPTION RAISED - 1");
               END;

               BEGIN
                    DECLARE
                         SUBTYPE SCONS IS CONS;
                    BEGIN
                         DECLARE
                              X : SCONS;
                         BEGIN
                              FAILED ("INDEX CHECK NOT PERFORMED - 2");
                              IF X /= (1, (1, 1)) THEN
                                   COMMENT ("INCORRECT VALUES FOR X " &
                                            "- 2");
                              END IF;
                         END;
                    EXCEPTION
                         WHEN CONSTRAINT_ERROR =>
                              NULL;
                         WHEN OTHERS =>
                              FAILED ("UNEXPECTED EXCEPTION RAISED " &
                                      "- 2A");
                    END;
               EXCEPTION
                    WHEN OTHERS =>
                         FAILED ("UNEXPECTED EXCEPTION RAISED - 2B");
               END;

               BEGIN
                    DECLARE
                         TYPE ARR IS ARRAY (1..5) OF CONS;
                    BEGIN
                         DECLARE
                              X : ARR;
                         BEGIN
                              FAILED ("INDEX CHECK NOT PERFORMED - 3");
                              IF X /= (1..5 => (1, (1, 1))) THEN
                                   COMMENT ("INCORRECT VALUES FOR X " &
                                            "- 3");
                              END IF;
                         END;
                    EXCEPTION
                         WHEN CONSTRAINT_ERROR =>
                              NULL;
                         WHEN OTHERS =>
                              FAILED ("UNEXPECTED EXCEPTION RAISED " &
                                      "- 3A");
                    END;
               EXCEPTION
                    WHEN OTHERS =>
                         FAILED ("UNEXPECTED EXCEPTION RAISED - 3B");
               END;

               BEGIN
                    DECLARE
                         TYPE NREC IS
                              RECORD
                                   C1 : CONS;
                              END RECORD;
                    BEGIN
                         DECLARE
                              X : NREC;
                         BEGIN
                              FAILED ("INDEX CHECK NOT PERFORMED - 4");
                              IF X /= (C1 => (1, (1, 1))) THEN
                                   COMMENT ("INCORRECT VALUES FOR X " &
                                            "- 4");
                              END IF;
                         END;
                    EXCEPTION
                         WHEN CONSTRAINT_ERROR =>
                              NULL;
                         WHEN OTHERS =>
                              FAILED ("UNEXPECTED EXCEPTION RAISED " &
                                      "- 4A");
                    END;
               EXCEPTION
                    WHEN OTHERS =>
                         FAILED ("UNEXPECTED EXCEPTION RAISED - 4B");
               END;

               BEGIN
                    DECLARE
                         TYPE NREC IS NEW CONS;