c37405a.ada

来自「linux下编程用 编译软件」· ADA 代码 · 共 162 行

-- C37405A.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 WHEN ASSIGNING TO A CONSTRAINED OR UNCONSTRAINED
-- OBJECT OR FORMAL PARAMETER OF A TYPE DECLARED WITH DEFAULT
-- DISCRIMINANTS, THE ASSIGNMENT DOES NOT CHANGE THE 'CONSTRAINED
-- ATTRIBUTE VALUE ASSOCIATED WITH THE OBJECT OR PARAMETER.
 
-- ASL 7/21/81
-- TBN 1/20/86     RENAMED FROM C37209A.ADA AND REVISED THE ASSIGNMENTS 
--                 OF CONSTRAINED AND UNCONSTRAINED OBJECTS TO ARRAY AND
--                 RECORD COMPONENTS.

WITH REPORT; USE REPORT;
PROCEDURE C37405A IS
 
     TYPE REC(DISC : INTEGER := 25) IS
          RECORD
               COMP : INTEGER;
          END RECORD;
 
     SUBTYPE CONSTR IS REC(10);
     SUBTYPE UNCONSTR IS REC;

     TYPE REC_C IS 
          RECORD
               COMP: CONSTR;
          END RECORD;

     TYPE REC_U IS
          RECORD
               COMP: UNCONSTR;
          END RECORD;
 
     C1,C2 : CONSTR;
     U1,U2 : UNCONSTR;
-- C2 AND U2 ARE NOT PASSED TO EITHER PROC1 OR PROC2.

     ARR_C : ARRAY (1..5) OF CONSTR;
     ARR_U : ARRAY (1..5) OF UNCONSTR;

     REC_COMP_C : REC_C;
     REC_COMP_U : REC_U;
 
     PROCEDURE PROC11(PARM : IN OUT UNCONSTR; B : IN BOOLEAN) IS
     BEGIN
          PARM := C2;
          IF IDENT_BOOL(B) /= PARM'CONSTRAINED THEN
               FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " &
                       "ASSIGNMENT - 1");
          END IF;
     END PROC11;

     PROCEDURE PROC12(PARM : IN OUT UNCONSTR; B : IN BOOLEAN) IS
     BEGIN
          PARM := U2;
          IF B /= PARM'CONSTRAINED THEN
               FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " &
                       "ASSIGNMENT - 2");
          END IF;
     END PROC12;

     PROCEDURE PROC1(PARM : IN OUT UNCONSTR; B : IN BOOLEAN) IS
     BEGIN
          IF B /= PARM'CONSTRAINED THEN
               FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " &
                       "PASSING PARAMETER");
          END IF;
 
          PROC11(PARM, B);
 
          PROC12(PARM, B);

     END PROC1;
 
     PROCEDURE PROC2(PARM : IN OUT CONSTR) IS
     BEGIN
          COMMENT ("CALLING PROC1 FROM PROC2");   -- IN CASE TEST FAILS.
          PROC1(PARM,TRUE);
          PARM := U2;
          IF NOT PARM'CONSTRAINED THEN
               FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " &
                       "ASSIGNMENT - 3");
          END IF;
     END PROC2;
BEGIN
     TEST("C37405A", "'CONSTRAINED ATTRIBUTE OF OBJECTS, FORMAL " &
                     "PARAMETERS CANNOT BE CHANGED BY ASSIGNMENT");
 
     C2 := (DISC => IDENT_INT(10), COMP => 3);
     U2 := (DISC => IDENT_INT(10), COMP => 4);

     ARR_C := (1..5 => U2);
     ARR_U := (1..5 => C2);

     REC_COMP_C := (COMP => U2);
     REC_COMP_U := (COMP => C2);
 
     C1 := U2;
     U1 := C2;
 
     IF U1'CONSTRAINED OR NOT C1'CONSTRAINED THEN
          FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY ASSIGNMENT - 4");
     END IF;

     IF ARR_U(3)'CONSTRAINED OR NOT ARR_C(4)'CONSTRAINED THEN
          FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY ASSIGNMENT - 5");
     END IF;

     IF REC_COMP_U.COMP'CONSTRAINED
         OR NOT REC_COMP_C.COMP'CONSTRAINED THEN
          FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY ASSIGNMENT - 6");
     END IF;
 
     COMMENT("CALLING PROC1 DIRECTLY");
     PROC1(C1,TRUE);
     PROC2(C1);

     COMMENT("CALLING PROC1 DIRECTLY");
     PROC1(U1,FALSE);
     PROC2(U1);

     COMMENT("CALLING PROC1 DIRECTLY");
     PROC1(ARR_C(4), TRUE);
     PROC2(ARR_C(5));

     COMMENT("CALLING PROC1 DIRECTLY");
     PROC1(ARR_U(2), FALSE);
     PROC2(ARR_U(3));

     COMMENT("CALLING PROC1 DIRECTLY");
     PROC1(REC_COMP_C.COMP, TRUE);
     PROC2(REC_COMP_C.COMP);

     COMMENT("CALLING PROC1 DIRECTLY");
     PROC1(REC_COMP_U.COMP, FALSE);
     PROC2(REC_COMP_U.COMP);
 
     RESULT;
END C37405A;