c37006a.ada

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

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