c61010a.ada

用于进行gcc测试

-- C61010A.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.
--*
-- CHECK THAT AN IN OR IN OUT FORMAL PARAMETER CAN BE DECLARED WITH A
-- LIMITED PRIVATE TYPE OR A LIMITED COMPOSITE TYPE.

-- DAS  1/22/81
-- JRK  1/20/84  TOTALLY REVISED.

WITH REPORT; USE REPORT;
PROCEDURE C61010A IS

     PACKAGE PKG IS

          TYPE ITYPE IS LIMITED PRIVATE;

          PROCEDURE LOOK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING);

          PROCEDURE LOOK_INOUT_I (X : IN OUT ITYPE; V : INTEGER;
                                  M : STRING);

          PROCEDURE SET_I (X : IN OUT ITYPE; V : INTEGER);

          SUBTYPE INT_0_20 IS INTEGER RANGE 0 .. 20;
          TYPE VRTYPE (C : INT_0_20 := 20) IS LIMITED PRIVATE;

          PROCEDURE LOOK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER;
                                S : STRING; M : STRING);

          PROCEDURE LOOK_INOUT_VR (X : IN OUT VRTYPE; C : INTEGER;
                                   I : INTEGER; S : STRING;
                                   M : STRING);

          PROCEDURE SET_VR (X : IN OUT VRTYPE; C : INTEGER; I : INTEGER;
                            S : STRING);

     PRIVATE

          TYPE ITYPE IS NEW INTEGER RANGE 0 .. 99;

          TYPE VRTYPE (C : INT_0_20 := 20) IS
               RECORD
                    I : INTEGER;
                    S : STRING (1 .. C);
               END RECORD;

     END PKG;

     USE PKG;

     I1 : ITYPE;

     TYPE ATYPE IS ARRAY (1 .. 3) OF ITYPE;

     A1 : ATYPE;

     VR1 : VRTYPE;

     D : CONSTANT INT_0_20 := 10;

     TYPE RTYPE IS
          RECORD
               J : ITYPE;
               R : VRTYPE (D);
          END RECORD;

     R1 : RTYPE;

     PACKAGE BODY PKG IS

          PROCEDURE LOOK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING) IS
          BEGIN
               IF INTEGER (X) /= V THEN
                    FAILED ("WRONG SCALAR VALUE - " & M);
               END IF;
          END LOOK_IN_I;

          PROCEDURE LOOK_INOUT_I (X : IN OUT ITYPE; V : INTEGER;
                                  M : STRING) IS
          BEGIN
               IF INTEGER (X) /= V THEN
                    FAILED ("WRONG SCALAR VALUE - " & M);
               END IF;
          END LOOK_INOUT_I;

          PROCEDURE SET_I (X : IN OUT ITYPE; V : INTEGER) IS
          BEGIN
               X := ITYPE (IDENT_INT (V));
          END SET_I;

          PROCEDURE LOOK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER;
                                S : STRING; M : STRING) IS
          BEGIN
               IF (X.C /= C OR X.I /= I) OR ELSE X.S /= S THEN
                    FAILED ("WRONG COMPOSITE VALUE - " & M);
               END IF;
          END LOOK_IN_VR;

          PROCEDURE LOOK_INOUT_VR (X : IN OUT VRTYPE; C : INTEGER;
                                   I : INTEGER; S : STRING;
                                   M : STRING) IS
          BEGIN
               IF (X.C /= C OR X.I /= I) OR ELSE X.S /= S THEN
                    FAILED ("WRONG COMPOSITE VALUE - " & M);
               END IF;
          END LOOK_INOUT_VR;

          PROCEDURE SET_VR (X : IN OUT VRTYPE; C : INTEGER; I : INTEGER;
                            S : STRING) IS
          BEGIN
               X := (IDENT_INT(C), IDENT_INT(I), IDENT_STR(S));
          END SET_VR;

     BEGIN
          I1 := ITYPE (IDENT_INT(2));

          FOR I IN A1'RANGE LOOP
               A1 (I) := ITYPE (3 + IDENT_INT(I));
          END LOOP;

          VR1 := (IDENT_INT(5), IDENT_INT(4), IDENT_STR("01234"));

          R1.J := ITYPE (IDENT_INT(6));
          R1.R := (IDENT_INT(D), IDENT_INT(19),
                   IDENT_STR("ABCDEFGHIJ"));
     END PKG;

     PROCEDURE CHECK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING) IS
     BEGIN
          LOOK_IN_I (X, V, M);
     END CHECK_IN_I;

     PROCEDURE CHECK_INOUT_I (X : IN OUT ITYPE; OV : INTEGER;
                              NV : INTEGER; M : STRING) IS
     BEGIN
          LOOK_INOUT_I (X, OV, M & " - A");
          SET_I (X, NV);
          LOOK_INOUT_I (X, NV, M & " - B");
          LOOK_IN_I (X, NV, M & " - C");
     END CHECK_INOUT_I;

     PROCEDURE CHECK_IN_A (X : IN ATYPE; V : INTEGER; M : STRING) IS
     BEGIN
          FOR I IN X'RANGE LOOP
               LOOK_IN_I (X(I), V+I, M & " -" & INTEGER'IMAGE (I));
          END LOOP;
     END CHECK_IN_A;

     PROCEDURE CHECK_INOUT_A (X : IN OUT ATYPE; OV : INTEGER;
                              NV : INTEGER; M : STRING) IS
     BEGIN
          FOR I IN X'RANGE LOOP
               LOOK_INOUT_I (X(I), OV+I, M & " - A" &
                                         INTEGER'IMAGE (I));
               SET_I (X(I), NV+I);
               LOOK_INOUT_I (X(I), NV+I, M & " - B" &
                                         INTEGER'IMAGE (I));
               LOOK_IN_I (X(I), NV+I, M & " - C" & INTEGER'IMAGE (I));
          END LOOP;
     END CHECK_INOUT_A;

     PROCEDURE CHECK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER;
                            S : STRING; M : STRING) IS
     BEGIN
          LOOK_IN_VR (X, C, I, S, M);
     END CHECK_IN_VR;

     PROCEDURE CHECK_INOUT_VR (X : IN OUT VRTYPE;
                               OC : INTEGER; OI : INTEGER; OS : STRING;
                               NC : INTEGER; NI : INTEGER; NS : STRING;
                               M : STRING) IS
     BEGIN
          LOOK_INOUT_VR (X, OC, OI, OS, M & " - A");
          SET_VR (X, NC, NI, NS);
          LOOK_INOUT_VR (X, NC, NI, NS, M & " - B");
          LOOK_IN_VR (X, NC, NI, NS, M & " - C");
     END CHECK_INOUT_VR;

     PROCEDURE CHECK_IN_R (X : IN RTYPE; J : INTEGER; C : INTEGER;
                           I : INTEGER; S : STRING; M : STRING) IS
     BEGIN
          LOOK_IN_I (X.J, J, M & " - A");
          LOOK_IN_VR (X.R, C, I, S, M & " - B");
     END CHECK_IN_R;

     PROCEDURE CHECK_INOUT_R (X : IN OUT RTYPE; OJ : INTEGER;
                              OC : INTEGER; OI : INTEGER; OS : STRING;
                              NJ : INTEGER;
                              NC : INTEGER; NI : INTEGER; NS : STRING;
                              M : STRING) IS
     BEGIN
          LOOK_INOUT_I (X.J, OJ, M & " - A");
          LOOK_INOUT_VR (X.R, OC, OI, OS, M & " - B");
          SET_I (X.J, NJ);
          SET_VR (X.R, NC, NI, NS);
          LOOK_INOUT_I (X.J, NJ, M & " - C");
          LOOK_INOUT_VR (X.R, NC, NI, NS, M & " - D");
          LOOK_IN_I (X.J, NJ, M & " - E");
          LOOK_IN_VR (X.R, NC, NI, NS, M & " - F");
     END CHECK_INOUT_R;

BEGIN
     TEST ("C61010A", "CHECK THAT LIMITED PRIVATE/COMPOSITE TYPES " &
                      "CAN BE USED AS IN OR IN OUT FORMAL PARAMETERS");

     CHECK_IN_I (I1, 2, "IN I");

     CHECK_INOUT_I (I1, 2, 5, "INOUT I");

     CHECK_IN_A (A1, 3, "IN A");

     CHECK_INOUT_A (A1, 3, 17, "INOUT A");

     CHECK_IN_VR (VR1, 5, 4, "01234", "IN VR");

     CHECK_INOUT_VR (VR1, 5, 4, "01234", 10, 11, "9876543210",
                     "INOUT VR");

     CHECK_IN_R (R1, 6, D, 19, "ABCDEFGHIJ", "IN R");

     CHECK_INOUT_R (R1, 6, D, 19, "ABCDEFGHIJ", 13, D, 5, "ZYXWVUTSRQ",
                    "INOUT R");

     RESULT;
END C61010A;