c64106a.ada

用于进行gcc测试

-- C64106A.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 UNCONSTRAINED RECORD, PRIVATE, LIMITED PRIVATE, AND ARRAY
--   FORMAL PARAMETERS USE THE CONSTRAINTS OF ACTUAL PARAMETERS.
--   SUBTESTS ARE:
--        (A) RECORD TYPE, UNCONSTRAINED ACTUALS, DEFAULTS.
--        (B) PRIVATE TYPE, CONSTRAINED ACTUALS, NO DEFAULTS.
--        (C) LIMITED PRIVATE TYPE, UNCONSTRAINED ACTUALS, NO DEFAULTS.
--        (D) ARRAY TYPE, CONSTRAINED ACTUALS, DEFAULTS.

-- DAS  1/15/81
-- JBG  5/16/83
-- CPP  5/22/84

WITH REPORT;
PROCEDURE C64106A IS

     USE REPORT;

BEGIN
     TEST ("C64106A", "CHECK USE OF ACTUAL CONSTRAINTS BY " &
                      "UNCONSTRAINED FORMAL PARAMETERS");

     DECLARE  -- (A)

          PACKAGE PKG IS

              SUBTYPE INT IS INTEGER RANGE 0..100;

              TYPE RECTYPE (CONSTRAINT : INT := 80) IS
                    RECORD
                         INTFIELD  : INTEGER;
                         STRFIELD  : STRING (1..CONSTRAINT);
                    END RECORD;

               REC1  : RECTYPE   := (10,10,"0123456789");
               REC2  : RECTYPE   := (17,7,"C64106A..........");
               REC3  : RECTYPE   := (1,1,"A");
               REC4  : RECTYPE;  -- 80

               PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE := (2,0,"AB");
                                       REC2 : OUT RECTYPE;
                                       REC3 : IN OUT RECTYPE);

               PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE);
          END PKG;

          PACKAGE BODY PKG IS

               PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE := (2,0,"AB");
                                       REC2 : OUT RECTYPE;
                                       REC3 : IN OUT RECTYPE) IS
               BEGIN
                    IF (REC1.CONSTRAINT /= IDENT_INT(10)) THEN
                         FAILED ("RECORD TYPE IN PARAMETER DID " &
                                 "NOT USE CONSTRAINT OF ACTUAL");
                    END IF;
                    IF (REC2.CONSTRAINT /= IDENT_INT(17)) THEN
                         FAILED ("RECORD TYPE OUT PARAMETER DID " &
                                 "NOT USE CONSTRAINT OF ACTUAL");
                    END IF;
                    IF (REC3.CONSTRAINT /= IDENT_INT(1)) THEN
                         FAILED ("RECORD TYPE IN OUT PARAMETER DID " &
                                 "NOT USE CONSTRAINT OF ACTUAL");
                    END IF;
                    REC2 := PKG.REC2;
               END CHK_RECTYPE1;

               PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS
               BEGIN
                    IF (REC.CONSTRAINT /= IDENT_INT(80)) THEN
                         FAILED ("RECORD TYPE OUT PARAMETER DID " &
                                 "NOT USE CONSTRAINT OF " &
                                 "UNINITIALIZED ACTUAL");
                    END IF;
                    REC := (10,10,"9876543210");
               END CHK_RECTYPE2;
          END PKG;

     BEGIN  -- (A)

          PKG.CHK_RECTYPE1 (PKG.REC1, PKG.REC2, PKG.REC3);
          PKG.CHK_RECTYPE2 (PKG.REC4);

     END;   -- (A)

     ---------------------------------------------

B :  DECLARE  -- (B)

          PACKAGE PKG IS

               SUBTYPE INT IS INTEGER RANGE 0..100;

               TYPE RECTYPE (CONSTRAINT : INT := 80) IS PRIVATE;


               PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
                                       REC2 : OUT RECTYPE;
                                       REC3 : IN OUT RECTYPE);

               PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE);

          PRIVATE
               TYPE RECTYPE (CONSTRAINT : INT := 80) IS
                    RECORD
                         INTFIELD  : INTEGER;
                         STRFIELD  : STRING (1..CONSTRAINT);
                    END RECORD;
          END PKG;

          REC1  : PKG.RECTYPE(10);
          REC2  : PKG.RECTYPE(17);   
          REC3  : PKG.RECTYPE(1);    
          REC4  : PKG.RECTYPE(10);

          PACKAGE BODY PKG IS

               PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
                                       REC2 : OUT RECTYPE;
                                       REC3 : IN OUT RECTYPE) IS
               BEGIN
                    IF (REC1.CONSTRAINT /= IDENT_INT(10)) THEN
                         FAILED ("PRIVATE TYPE IN PARAMETER DID " &
                                 "NOT USE CONSTRAINT OF ACTUAL");
                    END IF;
                    IF (REC2.CONSTRAINT /= IDENT_INT(17)) THEN
                         FAILED ("PRIVATE TYPE OUT PARAMETER DID " &
                                 "NOT USE CONSTRAINT OF ACTUAL");
                    END IF;
                    IF (REC3.CONSTRAINT /= IDENT_INT(1)) THEN
                         FAILED ("PRIVATE TYPE IN OUT PARAMETER DID " &
                                 "NOT USE CONSTRAINT OF ACTUAL");
                    END IF;
                    REC2 := B.REC2;
               END CHK_RECTYPE1;

               PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS
               BEGIN
                    IF (REC.CONSTRAINT /= IDENT_INT(10)) THEN
                         FAILED ("PRIVATE TYPE OUT PARAMETER DID " &
                                 "NOT USE CONSTRAINT OF " &
                                 "UNINITIALIZED ACTUAL");
                    END IF;
                    REC := (10,10,"9876543210");
               END CHK_RECTYPE2;

          BEGIN
               REC1 := (10,10,"0123456789");
               REC2 := (17,7,"C64106A..........");
               REC3 := (1,1,"A");

          END PKG;

     BEGIN  -- (B)

          PKG.CHK_RECTYPE1 (REC1, REC2, REC3);
          PKG.CHK_RECTYPE2 (REC4);

     END B;  -- (B)

     ---------------------------------------------

C :  DECLARE  -- (C)

          PACKAGE PKG IS

               SUBTYPE INT IS INTEGER RANGE 0..100;

               TYPE RECTYPE (CONSTRAINT : INT := 80) IS
                    LIMITED PRIVATE;

               PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
                                       REC2 : OUT RECTYPE;
                                       REC3 : IN OUT RECTYPE);

               PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE);

          PRIVATE
               TYPE RECTYPE (CONSTRAINT : INT := 80) IS
                    RECORD
                         INTFIELD  : INTEGER;
                         STRFIELD  : STRING (1..CONSTRAINT);
                    END RECORD;
          END PKG;

          REC1  : PKG.RECTYPE;     -- 10   
          REC2  : PKG.RECTYPE;     -- 17
          REC3  : PKG.RECTYPE;     --  1
          REC4  : PKG.RECTYPE;     -- 80

          PACKAGE BODY PKG IS

               PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
                                       REC2 : OUT RECTYPE;
                                       REC3 : IN OUT RECTYPE) IS
               BEGIN
                    IF (REC1.CONSTRAINT /= IDENT_INT(10)) THEN
                         FAILED ("LIMITED PRIVATE TYPE IN PARAMETER " &
                                 "DID NOT USE CONSTRAINT OF " &
                                 "ACTUAL");
                    END IF;
                    IF (REC2.CONSTRAINT /= IDENT_INT(17)) THEN
                         FAILED ("LIMITED PRIVATE TYPE OUT PARAMETER " &
                                 "DID NOT USE CONSTRAINT OF " &
                                 "ACTUAL");
                    END IF;
                    IF (REC3.CONSTRAINT /= IDENT_INT(1)) THEN
                         FAILED ("LIMITED PRIVATE TYPE IN OUT " &
                                 "PARAMETER DID NOT USE " &
                                 "CONSTRAINT OF ACTUAL");
                    END IF;
                    REC2 := C.REC2;
               END CHK_RECTYPE1;

               PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS
               BEGIN
                    IF (REC.CONSTRAINT /= IDENT_INT(80)) THEN
                         FAILED ("LIMITED PRIVATE TYPE OUT " &
                                 "PARAMETER DID NOT USE " &
                                 "CONSTRAINT OF UNINITIALIZED ACTUAL");
                    END IF;
                    REC := (10,10,"9876543210");
               END CHK_RECTYPE2;

          BEGIN
               REC1 := (10,10,"0123456789");
               REC2 := (17,7,"C64106A..........");
               REC3 := (1,1,"A");
          END PKG;

     BEGIN  -- (C)

          PKG.CHK_RECTYPE1 (REC1, REC2, REC3);
          PKG.CHK_RECTYPE2 (REC4);

     END C;   -- (C)

     ---------------------------------------------

D :  DECLARE  -- (D)

          TYPE ATYPE IS ARRAY (INTEGER RANGE <>, POSITIVE RANGE <>) OF
               CHARACTER;

          A1, A2, A3  : ATYPE(-1..1, 4..5)  := (('A','B'),
                                                ('C','D'),
                                                ('E','F'));

          A4  : ATYPE(-1..1, 4..5);

          CA1 : CONSTANT ATYPE(8..9, -7..INTEGER'FIRST) := 
                              (8..9 => (-7..INTEGER'FIRST => 'A'));

          S1  : STRING(1..INTEGER'FIRST) := "";
          S2  : STRING(-5..-7) := "";
          S3  : STRING(1..0) := "";

          PROCEDURE CHK_ARRAY1 (A1 : IN ATYPE := CA1;  A2 : OUT ATYPE;
                                A3 : IN OUT ATYPE) IS
          BEGIN
               IF ((A1'FIRST(1) /= IDENT_INT(-1)) OR
                   (A1'LAST(1)  /= IDENT_INT(1)) OR
                   (A1'FIRST(2) /= IDENT_INT(4)) OR
                   (A1'LAST(2)  /= IDENT_INT(5))) THEN
                    FAILED ("ARRAY TYPE IN PARAMETER DID NOT " &
                            "USE CONSTRAINTS OF ACTUAL");
               END IF;
               IF ((A2'FIRST(1) /= IDENT_INT(-1)) OR
                   (A2'LAST(1)  /= IDENT_INT(1)) OR
                   (A2'FIRST(2) /= IDENT_INT(4)) OR
                   (A2'LAST(2)  /= IDENT_INT(5))) THEN
                    FAILED ("ARRAY TYPE OUT PARAMETER DID NOT USE" &
                            "CONSTRAINTS OF ACTUAL");
               END IF;
               IF ((A3'FIRST(1) /= IDENT_INT(-1)) OR
                   (A3'LAST(1)  /= IDENT_INT(1)) OR
                   (A3'FIRST(2) /= IDENT_INT(4)) OR
                   (A3'LAST(2)  /= IDENT_INT(5))) THEN
                    FAILED ("ARRAY TYPE IN OUT PARAMETER DID NOT " &
                            "USE CONSTRAINTS OF ACTUAL");
               END IF;
               A2 := D.A2;
          END CHK_ARRAY1;

          PROCEDURE CHK_ARRAY2 (A4 : OUT ATYPE) IS
          BEGIN
               IF ((A4'FIRST(1) /= IDENT_INT(-1)) OR
                   (A4'LAST(1)  /= IDENT_INT(1)) OR
                   (A4'FIRST(2) /= IDENT_INT(4)) OR
                   (A4'LAST(2)  /= IDENT_INT(5))) THEN
                    FAILED ("ARRAY TYPE OUT PARAMETER DID NOT " &
                            "USE CONSTRAINTS OF UNINITIALIZED " &
                            "ACTUAL");
               END IF;
               A4 := A2;
          END CHK_ARRAY2;

          PROCEDURE CHK_STRING (S1 : IN STRING;
                                S2 : IN OUT STRING;
                                S3 : OUT STRING) IS
          BEGIN
               IF ((S1'FIRST /= IDENT_INT(1)) OR
                   (S1'LAST  /= IDENT_INT(INTEGER'FIRST))) THEN
                    FAILED ("STRING TYPE IN PARAMETER DID NOT " &
                            "USE CONSTRAINTS OF ACTUAL NULL " &
                            "STRING");
               END IF;
               IF ((S2'FIRST /= IDENT_INT(-5)) OR
                   (S2'LAST  /= IDENT_INT(-7))) THEN 
                    FAILED ("STRING TYPE IN OUT PARAMETER DID NOT " &
                            "USE CONSTRAINTS OF ACTUAL NULL STRING");
               END IF;
               IF ((S3'FIRST /= IDENT_INT(1)) OR
                   (S3'LAST  /= IDENT_INT(0))) THEN
                    FAILED ("STRING TYPE OUT PARAMETER DID NOT " &
                            "USE CONSTRAINTS OF ACTUAL NULL STRING");
               END IF;
               S3 := "";
          END CHK_STRING;

     BEGIN  -- (D)
          CHK_ARRAY1 (A1, A2, A3);
          CHK_ARRAY2 (A4);
          CHK_STRING (S1, S2, S3);
     END D;  -- (D)

     RESULT;
END C64106A;