cc1311b.ada

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

-- CC1311B.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 IF PARAMETERS OF DEFAULT AND FORMAL SUBPROGRAMS HAVE
--     THE SAME TYPE BUT NOT THE SAME SUBTYPE, THE PARAMETER SUBTYPES OF
--     THE SUBPROGRAM DENOTED BY THE DEFAULT ARE USED INSTEAD OF
--     SUBTYPES SPECIFIED IN THE FORMAL SUBPROGRAM DECLARATION.

-- HISTORY:
--     RJW 06/11/86 CREATED ORIGINAL TEST.
--     DHH 10/20/86 CORRECTED RANGE ERRORS.
--     PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
--     PWN 10/27/95 REMOVED CHECKS AGAINST ARRAY SLIDING RULES THAT
--                  HAVE BEEN RELAXED.
--     PWN 10/25/96 RESTORED CHECKS WITH NEW ADA 95 EXPECTED RESULTS.

WITH REPORT; USE REPORT;

PROCEDURE CC1311B IS

BEGIN
     TEST ("CC1311B", "CHECK THAT IF PARAMETERS OF DEFAULT AND " &
                      "FORMAL SUBPROGRAMS HAVE THE SAME TYPE BUT " &
                      "NOT THE SAME SUBTYPE, THE PARAMETER SUBTYPES " &
                      "OF THE SUBPROGRAM DENOTED BY THE DEFAULT ARE " &
                      "USED INSTEAD OF SUBTYPES SPECIFIED IN THE " &
                      "FORMAL SUBPROGRAM DECLARATION" );

     DECLARE
          TYPE NUMBERS IS (ZERO, ONE ,TWO);
          SUBTYPE ZERO_TWO IS NUMBERS;
          SUBTYPE ZERO_ONE IS NUMBERS RANGE ZERO .. ONE;

          FUNCTION FSUB (X : ZERO_ONE) RETURN ZERO_ONE IS
          BEGIN
               RETURN NUMBERS'VAL (IDENT_INT (NUMBERS'POS (ONE)));
          END FSUB;

          GENERIC
               WITH FUNCTION F (X : ZERO_TWO := TWO) RETURN ZERO_TWO
                    IS FSUB;
          FUNCTION FUNC  RETURN ZERO_TWO;

          FUNCTION FUNC RETURN ZERO_TWO IS
          BEGIN
               RETURN F;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    RETURN ZERO;
               WHEN OTHERS =>
                    FAILED ( "WRONG EXCEPTION RAISED WITH " &
                             "NFUNC1" );
                    RETURN ZERO;
          END FUNC;

          FUNCTION NFUNC1 IS NEW FUNC;

     BEGIN
          IF NFUNC1 = ONE THEN
               FAILED ( "NO EXCEPTION RAISED WITH NFUNC1" );
          END IF;
     END;

     DECLARE
          TYPE GENDER IS (MALE, FEMALE);

          TYPE PERSON (SEX : GENDER) IS
               RECORD
                   CASE SEX IS
                         WHEN MALE =>
                              BEARDED : BOOLEAN;
                         WHEN FEMALE =>
                              CHILDREN : INTEGER;
                    END CASE;
               END RECORD;

          SUBTYPE MAN IS PERSON (SEX => MALE);
          SUBTYPE TESTWRITER IS PERSON (FEMALE);

          ROSA : TESTWRITER := (FEMALE, 4);

          FUNCTION F (X : MAN) RETURN PERSON IS
               TOM : PERSON (MALE) := (MALE, FALSE);
          BEGIN
               IF EQUAL (3, 3) THEN
                    RETURN X;
               ELSE
                    RETURN TOM;
               END IF;
          END F;

          GENERIC
               TYPE T IS PRIVATE;
               X1 : T;
               WITH FUNCTION F (X : T) RETURN T IS <> ;
          PACKAGE PKG IS END PKG;

          PACKAGE BODY PKG IS
          BEGIN
               IF F(X1) = X1 THEN
                    FAILED ( "NO EXCEPTION RAISED WITH " &
                             "FUNCTION 'F' AND PACKAGE " &
                             "'PKG' - 1" );
               ELSE
                    FAILED ( "NO EXCEPTION RAISED WITH " &
                             "FUNCTION 'F' AND PACKAGE " &
                             "'PKG' - 2" );
               END IF;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    FAILED ( "WRONG EXCEPTION RAISED WITH " &
                             "FUNCTION 'F' AND PACKAGE 'PKG'" );
          END PKG;

          PACKAGE NPKG IS NEW PKG (TESTWRITER, ROSA);

     BEGIN
          COMMENT ( "PACKAGE BODY ELABORATED - 1" );
     END;

     DECLARE
          TYPE VECTOR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
          SUBTYPE SUBV1 IS VECTOR (1 .. 5);
          SUBTYPE SUBV2 IS VECTOR (2 .. 6);

          V1 : SUBV1 := (1, 2, 3, 4, 5);

          FUNCTION FSUB (Y : SUBV2) RETURN VECTOR IS
               Z : SUBV2;
          BEGIN
               FOR I IN Y'RANGE LOOP
                    Z (I) := IDENT_INT (Y (I));
               END LOOP;
               RETURN Z;
          END;

          GENERIC
           WITH FUNCTION F (X : SUBV1 := V1) RETURN SUBV1 IS FSUB;
          PROCEDURE PROC;

          PROCEDURE PROC IS
          BEGIN
               IF F = V1 THEN
                    COMMENT ( "NO EXCEPTION RAISED WITH " &
                              "FUNCTION 'F' AND PROCEDURE " &
                              "'PROC' - 1" );
               ELSE
                    COMMENT ( "NO EXCEPTION RAISED WITH " &
                              "FUNCTION 'F' AND PROCEDURE " &
                              "'PROC' - 2" );
               END IF;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    FAILED ( "CONSTRAINT_ERROR RAISED WITH " &
                             "FUNCTION 'F' AND PROCEDURE " &
                             "'PROC'" );
               WHEN OTHERS =>
                    FAILED ( "WRONG EXCEPTION RAISED WITH " &
                             "FUNCTION 'F' AND PROCEDURE " &
                             "'PROC'" );
          END PROC;

          PROCEDURE NPROC IS NEW PROC;
     BEGIN
          NPROC;
     END;

     DECLARE

          TYPE ACC IS ACCESS STRING;

          SUBTYPE INDEX1 IS INTEGER RANGE 1 .. 5;
          SUBTYPE INDEX2 IS INTEGER RANGE 2 .. 6;

          SUBTYPE ACC1 IS ACC (INDEX1);
          SUBTYPE ACC2 IS ACC (INDEX2);

          AC2 : ACC2 := NEW STRING'(2 .. 6 => 'A');
          AC  : ACC;

          PROCEDURE P (RESULTS : OUT ACC1; X : ACC1) IS
          BEGIN
               RESULTS := NULL;
          END P;

          GENERIC
           WITH PROCEDURE P1 (RESULTS : OUT ACC2; X : ACC2 := AC2)
                    IS P;
          FUNCTION FUNC RETURN ACC;

          FUNCTION FUNC RETURN ACC IS
               RESULTS : ACC;
          BEGIN
               P1 (RESULTS);
               RETURN RESULTS;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    RETURN NEW STRING'("ABCDE");
               WHEN OTHERS =>
                    FAILED ( "WRONG EXCEPTION RAISED WITH " &
                             "NFUNC2" );
                    RETURN NULL;
          END FUNC;

          FUNCTION NFUNC2 IS NEW FUNC;

     BEGIN
          AC := NFUNC2;
          IF AC = NULL OR ELSE AC.ALL /= "ABCDE" THEN
            FAILED ( "NO OR WRONG EXCEPTION RAISED WITH NFUNC2" );
          END IF;
     END;

     DECLARE
          SUBTYPE FLOAT1 IS FLOAT RANGE -1.0 .. 0.0;
          SUBTYPE FLOAT2 IS FLOAT RANGE  0.0 .. 1.0;

          PROCEDURE PSUB (RESULTS : OUT FLOAT2; X : FLOAT2) IS
          BEGIN
               IF EQUAL (3, 3) THEN
                    RESULTS := X;
               ELSE
                    RESULTS := 0.0;
               END IF;
          END PSUB;

          GENERIC
               WITH PROCEDURE P (RESULTS : OUT FLOAT1;
                                 X : FLOAT1 := -0.0625) IS PSUB;
          PACKAGE PKG IS END PKG;

          PACKAGE BODY PKG IS
               RESULTS : FLOAT1;
          BEGIN
               P (RESULTS);
               IF RESULTS = 1.0 THEN
                    FAILED ( "NO EXCEPTION RAISED WITH " &
                             "PROCEDURE 'P' AND PACKAGE " &
                             "'PKG' - 1" );
               ELSE
                    FAILED ( "NO EXCEPTION RAISED WITH " &
                             "PROCEDURE 'P' AND PACKAGE " &
                             "'PKG' - 2" );
               END IF;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    FAILED ( "WRONG EXCEPTION RAISED WITH " &
                             "PROCEDURE 'P' AND PACKAGE 'PKG'" );
          END PKG;

          PACKAGE NPKG IS NEW PKG;
     BEGIN
          COMMENT ( "PACKAGE BODY ELABORATED - 2" );
     END;

     DECLARE
          TYPE FIXED IS DELTA 0.125 RANGE -1.0 .. 1.0;
          SUBTYPE FIXED1 IS FIXED RANGE -0.5 .. 0.0;
          SUBTYPE FIXED2 IS FIXED RANGE  0.0 .. 0.5;

          PROCEDURE P (RESULTS : OUT FIXED1; X : FIXED1) IS
          BEGIN
               IF EQUAL (3, 3) THEN
                    RESULTS := X;
               ELSE
                    RESULTS := X;
               END IF;
          END P;

          GENERIC
               TYPE F IS DELTA <>;
               F1 : F;
               WITH PROCEDURE P (RESULTS : OUT F; X : F) IS <> ;
          PROCEDURE PROC;

          PROCEDURE PROC IS
               RESULTS : F;
          BEGIN
               P (RESULTS, F1);
               IF RESULTS = 0.0 THEN
                    FAILED ( "NO EXCEPTION RAISED WITH " &
                             "PROCEDURE 'P' AND PROCEDURE " &
                             "'PROC' - 1" );
               ELSE
                    FAILED ( "NO EXCEPTION RAISED WITH " &
                             "PROCEDURE 'P' AND PROCEDURE " &
                             "'PROC' - 2" );
               END IF;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    FAILED ( "WRONG EXCEPTION RAISED WITH " &
                             "PROCEDURE 'P' AND PROCEDURE " &
                             "'PROC'" );
          END PROC;

          PROCEDURE NPROC IS NEW PROC (FIXED2, 0.125);

     BEGIN
          NPROC;
     END;

     RESULT;

END CC1311B;