cc3120a.ada

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

-- CC3120A.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 GENERIC IN PARAMETERS ARE ALWAYS COPIED, AND THAT
-- GENERIC IN OUT PARAMETERS ARE ALWAYS RENAMED.

-- DAT 8/10/81
-- SPS 10/21/82

WITH REPORT; USE REPORT;

PROCEDURE CC3120A IS
BEGIN
     TEST ("CC3120A", "GENERIC IN PARMS ARE COPIED, GENERIC IN OUT"
          & " PARMS ARE RENAMED");

     DECLARE
          S1, S2 : INTEGER;
          A1, A2, A3 : STRING (1 .. IDENT_INT (3));

          TYPE REC IS RECORD
               C1, C2 : INTEGER := 1;
          END RECORD;

          R1, R2 : REC;

          PACKAGE P IS
               TYPE PRIV IS PRIVATE;
               PROCEDURE SET_PRIV (P : IN OUT PRIV);
          PRIVATE
               TYPE PRIV IS NEW REC;
          END P;
          USE P;

          P1, P2 : PRIV;
          EX : EXCEPTION;

          GENERIC
               TYPE T IS PRIVATE;
               P1 : IN OUT T;
               P2 : IN T;
          PROCEDURE GP;

          B_ARR : ARRAY (1..10) OF BOOLEAN;

          PACKAGE BODY P IS
               PROCEDURE SET_PRIV (P : IN OUT PRIV) IS
               BEGIN
                    P.C1 := 3;
               END SET_PRIV;
          END P;

          PROCEDURE GP IS
          BEGIN
               IF P1 = P2 THEN
                    FAILED ("PARAMETER SCREW_UP SOMEWHERE");
               END IF;
               P1 := P2;
               IF P1 /= P2 THEN
                    FAILED ("ASSIGNMENT SCREW_UP SOMEWHERE");
               END IF;
               RAISE EX;
               FAILED ("RAISE STATEMENT DOESN'T WORK");
          END GP;
     BEGIN
          S1 := 4;
          S2 := 5;
          A1 := "XYZ";
          A2 := "ABC";
          A3 := "DEF";
          R1.C1 := 4;
          R2.C1 := 5;
          B_ARR := (1|3|5|7|9 => TRUE, 2|4|6|8|10 => FALSE);
          SET_PRIV (P2);

          IF S1 = S2
          OR A1 = A3
          OR R1 = R2
          OR P1 = P2 THEN
               FAILED ("WRONG ASSIGNMENT");
          END IF;
          BEGIN
               DECLARE
                    PROCEDURE PR IS NEW GP (INTEGER, S1, S2);
               BEGIN
                    S2 := S1;
                    PR;       -- OLD S2 ASSIGNED TO S1, SO S1 /= S2 NOW
                    FAILED ("EX NOT RAISED 1");
               EXCEPTION
                    WHEN EX => NULL;
               END;

               DECLARE
                    SUBTYPE STR_1_3 IS STRING (IDENT_INT (1)..3);
                    PROCEDURE PR IS NEW GP (STR_1_3, A1, A3);
               BEGIN
                    A3 := A1;
                    PR;
                    FAILED ("EX NOT RAISED 2");
               EXCEPTION
                    WHEN EX => NULL;
               END;

               DECLARE
                    PROCEDURE PR IS NEW GP (REC, R1, R2);
               BEGIN
                    R2 := R1;
                    PR;
                    FAILED ("EX NOT RAISED 3");
               EXCEPTION
                    WHEN EX => NULL;
               END;

               DECLARE
                    PROCEDURE PR IS NEW GP (PRIV, P1, P2);
               BEGIN
                    P2 := P1;
                    PR;
                    FAILED ("EX NOT RAISED 4");
               EXCEPTION
                    WHEN EX => NULL;
               END;
               DECLARE
                    PROCEDURE PR IS NEW GP (CHARACTER,
                                            A3(IDENT_INT(2)),
                                            A3(IDENT_INT(3)));
               BEGIN
                    A3(3) := A3(2);
                    PR;
                    FAILED ("EX NOT RAISED 5");
               EXCEPTION
                    WHEN EX => NULL;
               END;

               DECLARE
                    PROCEDURE PR IS NEW GP (BOOLEAN,
                                            B_ARR(IDENT_INT(2)),
                                            B_ARR(IDENT_INT(3)));
               BEGIN
                    B_ARR(3) := B_ARR(2);
                    PR;
                    FAILED ("EX NOT RAISED 6");
               EXCEPTION
                    WHEN EX => NULL;
               END;
          END;

          IF S1 = S2
          OR A1 = A2
          OR R1 = R2
          OR P1 = P2
          OR A3(2) = A3(3) 
          OR B_ARR(2) = B_ARR(3) THEN
               FAILED ("ASSIGNMENT FAILED 2");
          END IF;
     END;

     RESULT;
END CC3120A;