c45282b.ada

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

-- C45282B.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 IN AND NOT IN ARE EVALUATED CORRECTLY FOR :
--     D) ACCESS TO RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH
--        DISCRIMINANTS (WITH AND WITHOUT DEFAULT VALUES), WHERE THE 
--        TYPE MARK DENOTES A CONSTRAINED AND UNCONSTRAINED TYPE;
--     E) ACCESS TO TASK TYPES.

-- TBN  8/8/86

WITH REPORT; USE REPORT;
PROCEDURE C45282B IS

     SUBTYPE INT IS INTEGER RANGE 1 .. 5;

     PACKAGE P IS
          TYPE PRI_REC1 (D : INT) IS PRIVATE;
          TYPE PRI_REC2 (D : INT := 2) IS PRIVATE;
          FUNCTION INIT_PREC1 (A : INT; B : STRING) RETURN PRI_REC1;
          FUNCTION INIT_PREC2 (A : INT; B : STRING) RETURN PRI_REC2;
          TYPE LIM_REC1 (D : INT) IS LIMITED PRIVATE;
          TYPE ACC_LIM1 IS ACCESS LIM_REC1;
          SUBTYPE ACC_SUB_LIM1 IS ACC_LIM1 (2);
          PROCEDURE ASSIGN_LIM1 (A : ACC_LIM1; B : INT; C : STRING);
          TYPE LIM_REC2 (D : INT := 2) IS LIMITED PRIVATE;
          TYPE ACC_LIM2 IS ACCESS LIM_REC2;
          SUBTYPE ACC_SUB_LIM2 IS ACC_LIM2 (2);
          PROCEDURE ASSIGN_LIM2 (A : ACC_LIM2; B : INT; C : STRING);
     PRIVATE
          TYPE PRI_REC1 (D : INT) IS
               RECORD
                    STR : STRING (1 .. D);
               END RECORD;
          TYPE PRI_REC2 (D : INT := 2) IS
               RECORD
                    STR : STRING (1 .. D);
               END RECORD;
          TYPE LIM_REC1 (D : INT) IS
               RECORD
                    STR : STRING (1 .. D);
               END RECORD;
          TYPE LIM_REC2 (D : INT := 2) IS
               RECORD
                    STR : STRING (1 .. D);
               END RECORD;
     END P;

     USE P;

     TYPE DIS_REC1 (D : INT) IS
          RECORD
               STR : STRING (1 .. D);
          END RECORD;
     TYPE DIS_REC2 (D : INT := 5) IS
          RECORD
               STR : STRING (D .. 8);
          END RECORD;

     TYPE ACC1_REC1 IS ACCESS DIS_REC1;
     SUBTYPE ACC2_REC1 IS ACC1_REC1 (2);
     TYPE ACC1_REC2 IS ACCESS DIS_REC2;
     SUBTYPE ACC2_REC2 IS ACC1_REC2 (2);
     REC1 : ACC1_REC1;
     REC2 : ACC2_REC1;
     REC3 : ACC1_REC2;
     REC4 : ACC2_REC2;
     TYPE ACC_PREC1 IS ACCESS PRI_REC1;
     SUBTYPE ACC_SREC1 IS ACC_PREC1 (2);
     REC5 : ACC_PREC1;
     REC6 : ACC_SREC1;
     TYPE ACC_PREC2 IS ACCESS PRI_REC2;
     SUBTYPE ACC_SREC2 IS ACC_PREC2 (2);
     REC7 : ACC_PREC2;
     REC8 : ACC_SREC2;
     REC9 : ACC_LIM1;
     REC10 : ACC_SUB_LIM1;
     REC11 : ACC_LIM2;
     REC12 : ACC_SUB_LIM2;

     TASK TYPE T IS
          ENTRY E (X : INTEGER);
     END T;

     TASK BODY T IS
     BEGIN
          ACCEPT E (X : INTEGER) DO
               IF X /= IDENT_INT(1) THEN
                    FAILED ("INCORRECT VALUE PASSED TO TASK");
               END IF;
          END E;
     END T;

     PACKAGE BODY P IS
          FUNCTION INIT_PREC1 (A : INT; B : STRING) RETURN PRI_REC1 IS
               REC : PRI_REC1 (A);
          BEGIN
               REC := (A, B);
               RETURN (REC);
          END INIT_PREC1;

          FUNCTION INIT_PREC2 (A : INT; B : STRING) RETURN PRI_REC2 IS
               REC : PRI_REC2;
          BEGIN
               REC := (A, B);
               RETURN (REC);
          END INIT_PREC2;

          PROCEDURE ASSIGN_LIM1 (A : ACC_LIM1; B : INT; C : STRING) IS
          BEGIN
               A.ALL := (B, C);
          END ASSIGN_LIM1;

          PROCEDURE ASSIGN_LIM2 (A : ACC_LIM2; B : INT; C : STRING) IS
          BEGIN
               A.ALL := (B, C);
          END ASSIGN_LIM2;
     END P;

BEGIN

     TEST ("C45282B", "CHECK THAT IN AND NOT IN ARE EVALUATED FOR " &
                      "ACCESS TYPES TO RECORD TYPES, PRIVATE TYPES, " &
                      "LIMITED PRIVATE TYPES WITH DISCRIMINANTS, AND " &
                      "TASK TYPES");

-- CASE D
------------------------------------------------------------------------
     IF REC1 NOT IN ACC1_REC1 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 1");
     END IF;
     IF REC1 IN ACC2_REC1 THEN
          NULL;
     ELSE
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 2");
     END IF;
     IF REC2 NOT IN ACC1_REC1 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 3");
     END IF;
     REC1 := NEW DIS_REC1'(5, "12345");
     IF REC1 IN ACC1_REC1 THEN
          NULL;
     ELSE
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 4");
     END IF;
     IF REC1 IN ACC2_REC1 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 5");
     END IF;
     REC2 := NEW DIS_REC1'(2, "HI");
     IF REC2 IN ACC1_REC1 THEN
          NULL;
     ELSE
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 6");
     END IF;

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

     IF REC3 IN ACC1_REC2 THEN
          NULL;
     ELSE
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 7");
     END IF;
     IF REC3 NOT IN ACC2_REC2 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 8");
     END IF;
     IF REC4 IN ACC1_REC2 THEN
          NULL;
     ELSE
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 9");
     END IF;
     REC3 := NEW DIS_REC2'(5, "5678");
     IF REC3 IN ACC1_REC2 THEN
          NULL;
     ELSE
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 10");
     END IF;
     IF REC3 IN ACC2_REC2 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 11");
     END IF;
     REC4 := NEW DIS_REC2'(2, "2345678");
     IF REC4 IN ACC1_REC2 THEN
          NULL;
     ELSE
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 12");
     END IF;
     IF REC4 NOT IN ACC2_REC2 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 13");
     END IF;

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

     IF REC5 NOT IN ACC_PREC1 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 14");
     END IF;
     IF REC5 NOT IN ACC_SREC1 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 15");
     END IF;
     IF REC6 NOT IN ACC_PREC1 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 16");
     END IF;
     REC5 := NEW PRI_REC1'(INIT_PREC1 (5, "12345"));
     IF REC5 IN ACC_PREC1 THEN
          NULL;
     ELSE
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 17");
     END IF;
     IF REC5 IN ACC_SREC1 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 18");
     END IF;
     REC6 := NEW PRI_REC1'(INIT_PREC1 (2, "HI"));
     IF REC6 IN ACC_PREC1 THEN
          NULL;
     ELSE
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 19");
     END IF;

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

     IF REC7 NOT IN ACC_PREC2 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 20");
     END IF;
     IF REC7 NOT IN ACC_SREC2 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 21");
     END IF;
     IF REC8 NOT IN ACC_PREC2 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 22");
     END IF;
     REC7 := NEW PRI_REC2'(INIT_PREC2 (5, "12345"));
     IF REC7 IN ACC_PREC2 THEN
          NULL;
     ELSE
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 23");
     END IF;
     IF REC7 IN ACC_SREC2 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 24");
     END IF;
     REC8 := NEW PRI_REC2'(INIT_PREC2 (2, "HI"));
     IF REC8 IN ACC_PREC2 THEN
          NULL;
     ELSE
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 25");
     END IF;

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

     IF REC9 NOT IN ACC_LIM1 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 26");
     END IF;
     IF REC9 NOT IN ACC_SUB_LIM1 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 27");
     END IF;
     IF REC10 NOT IN ACC_LIM1 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 28");
     END IF;
     REC9 := NEW LIM_REC1 (5);
     ASSIGN_LIM1 (REC9, 5, "12345");
     IF REC9 IN ACC_LIM1 THEN
          NULL;
     ELSE
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 29");
     END IF;
     IF REC9 IN ACC_SUB_LIM1 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 30");
     END IF;
     REC10 := NEW LIM_REC1 (2);
     ASSIGN_LIM1 (REC10, 2, "12");
     IF REC10 IN ACC_LIM1 THEN
          NULL;
     ELSE
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 31");
     END IF;

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

     IF REC11 NOT IN ACC_LIM2 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 32");
     END IF;
     IF REC11 NOT IN ACC_SUB_LIM2 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 33");
     END IF;
     IF REC12 NOT IN ACC_LIM2 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 34");
     END IF;
     REC11 := NEW LIM_REC2;
     IF REC11 NOT IN ACC_SUB_LIM2 THEN
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 35");
     END IF;
     ASSIGN_LIM2 (REC11, 2, "12");
     IF REC11 IN ACC_LIM2 THEN
          NULL;
     ELSE
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 36");
     END IF;
     IF REC11 IN ACC_SUB_LIM2 THEN
          NULL;
     ELSE
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 37");
     END IF;
     REC12 := NEW LIM_REC2;
     ASSIGN_LIM2 (REC12, 2, "12");
     IF REC12 IN ACC_LIM2 THEN
          NULL;
     ELSE
          FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 38");
     END IF;

-- CASE E
------------------------------------------------------------------------
     DECLARE
          TYPE ACC_TASK IS ACCESS T;
          T1 : ACC_TASK;
     BEGIN
          IF T1 NOT IN ACC_TASK THEN
               FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 39");
          END IF;
          T1 := NEW T;
          IF T1 IN ACC_TASK THEN
               NULL;
          ELSE
               FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 38");
          END IF;
          T1.E (1);
     END;

     RESULT;
END C45282B;