c48009e.ada

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

-- C48009E.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.
--*
-- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR
-- IS RAISED IF T IS A CONSTRAINED ARRAY TYPE AND:
--   1) A NAMED NULL OR NON-NULL BOUND FOR X DOES NOT EQUAL THE
--      CORRESPONDING BOUND FOR T;
--   2) A BOUND OF T DOES NOT EQUAL THE CORRESPONDING VALUE SPECIFIED IN
--      THE DECLARATION OF THE ALLOCATOR'S BASE TYPE; 
--   3) A POSITIONAL AGGREGATE DOES NOT HAVE THE NUMBER OF COMPONENTS
--      REQUIRED BY T OR BY THE ALLOCATOR'S BASE TYPE. 
 
 -- RM  01/08/80
 -- NL  10/13/81
 -- SPS 10/26/82
 -- JBG 03/03/83
 -- EG  07/05/84
 -- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X.
 -- KAS 11/14/95 CHANGED FAILURE AT SLIDING ASSIGNMENT TO COMMENT ON LANGUAGE
 -- KAS 11/30/95 REINSTRUMENTED CASES TO SELECT LANGUAGE SEMANTICS
 -- PWN 05/03/96 Enforced Ada 95 sliding rules
 -- PWN 10/24/96 Adjusted expected results for Ada 95.
 -- TMB 11/19/96 BACKED OUT CHANGE FOR SLIDING WITH ACCESS TYPES
 -- MRM 12/16/96 Removed problem code from withdrawn version of test, and
 --              implemented a dereference-index check to ensure Ada95
 --              required behavior.
 -- PWB.CTA 03/07/97 Restored checks from 1.11 in 2 cases where sliding does
 --                  not occur 
 WITH REPORT;
 
 PROCEDURE  C48009E  IS
 
      USE REPORT ;
 
 BEGIN
 
      TEST("C48009E","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " &
                     "THAT CONSTRAINT_ERROR IS RAISED WHEN "          &
                     "APPROPRIATE - CONSTRAINED ARRAY TYPES");
      DECLARE
 
           TYPE UA IS ARRAY(INTEGER RANGE <>) OF INTEGER;
           TYPE CA3_2 IS ARRAY(3 .. 2) OF INTEGER;
           TYPE SA1_3 IS ARRAY(1 .. 3) OF INTEGER;
           TYPE NA1_3 IS ARRAY(1 .. IDENT_INT(3)) OF INTEGER;
           SUBTYPE CA2_6 IS UA(2 .. 6);
           SUBTYPE CA1_4 IS UA(1 .. 4);
           SUBTYPE CA1_6 IS UA(1 .. 6);
           SUBTYPE CA4_1 IS UA(4 .. 1);
           SUBTYPE CA4_2 IS UA(4 .. 2);
 
           TYPE A_CA3_2 IS ACCESS CA3_2;
           TYPE A_SA1_3 IS ACCESS SA1_3;
           TYPE A_NA1_3 IS ACCESS NA1_3;
           TYPE A_CA1_5 IS ACCESS UA(1 .. 5);
           TYPE A_CA4_2 IS ACCESS CA4_2;
 
           V_A_CA3_2 : A_CA3_2;
           V_A_SA1_3 : A_SA1_3;
           V_A_NA1_3 : A_NA1_3;
           V_A_CA1_5 : A_CA1_5;
 
           FUNCTION ALLOC1(X : CA2_6) RETURN A_CA1_5 IS
           BEGIN
                IF EQUAL(1, 1) THEN
                     RETURN NEW CA2_6'(X);
                ELSE
                     RETURN NULL;
                END IF;
           END ALLOC1;
           FUNCTION ALLOC2(X : CA4_1) RETURN A_CA4_2 IS
           BEGIN
                IF EQUAL(1, 1) THEN
                     RETURN NEW CA4_1'(X);
                ELSE
                     RETURN NULL;
                END IF;
           END ALLOC2;
 
      BEGIN
 
          BEGIN
               V_A_CA3_2 := NEW CA3_2'(IDENT_INT(4) .. IDENT_INT(2)
                                       => 5);
               FAILED ("NO EXCEPTION RAISED - CASE 1A");
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    FAILED ("WRONG EXCEPTION RAISED - CASE 1A");
          END;
 
           BEGIN
                V_A_NA1_3 := NEW NA1_3'(1 .. IDENT_INT(2) => 4);
                FAILED ("NO EXCEPTION RAISED - CASE 1B");
           EXCEPTION
                WHEN CONSTRAINT_ERROR =>
                     NULL;
                WHEN OTHERS =>
                     FAILED ("WRONG EXCEPTION RAISED - CASE 1B");
           END;
 
           BEGIN
                -- note that ALLOC1 returns A_CA1_5, so both
                -- (1) and (5) are valid index references!
                IF ALLOC1((2 .. 6 => 2))(5) /= 2 THEN
                     FAILED ("Wrong Value Returned - CASE 2A");
                ELSIF ALLOC1((2 .. 6 => 3))(1) /= 3 THEN
                     FAILED ("Unlikely Index Case - CASE 2A");
                END IF;
           EXCEPTION
                WHEN OTHERS =>
                     FAILED ("EXCEPTION RAISED - CASE 2A");
           END;
 
           BEGIN
                IF ALLOC2((4 .. 1 => 3)) = NULL THEN
                     FAILED ("IMPOSSIBLE - CASE 2B");
                END IF;
                COMMENT ("ADA 95 SLIDING ASSIGNMENT");
           EXCEPTION
                WHEN CONSTRAINT_ERROR =>
                     FAILED ("ADA 83 NON-SLIDING ASSIGNMENT");
                WHEN OTHERS =>
                     FAILED ("WRONG EXCEPTION RAISED - CASE 2B");
           END;
 
           BEGIN
                V_A_SA1_3 := NEW SA1_3'(1, 2);
                FAILED ("NO EXCEPTION RAISED - CASE 3A");
           EXCEPTION
                WHEN CONSTRAINT_ERROR =>  
                     NULL;
                WHEN OTHERS =>  
                     FAILED ("WRONG EXCEPTION RAISED - CASE 3A");
           END;
 
           BEGIN
                V_A_SA1_3 := NEW SA1_3'(3, 4, 5, 6);
                FAILED ("NO EXCEPTION RAISED - CASE 3B");
           EXCEPTION
                WHEN CONSTRAINT_ERROR =>  
                     NULL;
                WHEN OTHERS =>  
                     FAILED ("WRONG EXCEPTION RAISED - CASE 3B");
           END;
 
           BEGIN
                V_A_NA1_3 := NEW NA1_3'(1, 2);
                FAILED ("NO EXCEPTION RAISED - CASE 3C");
           EXCEPTION
                WHEN CONSTRAINT_ERROR =>  
                     NULL;
                WHEN OTHERS =>  
                     FAILED ("WRONG EXCEPTION RAISED - CASE 3C");
           END;
 
           BEGIN -- SATISFIES T BUT NOT BASE TYPE.
                V_A_CA1_5 := NEW CA1_4'(1, 2, 3, 4);
                FAILED ("NO EXCEPTION RAISED - CASE 3D");
           EXCEPTION
                WHEN CONSTRAINT_ERROR =>  
                     NULL;
                WHEN OTHERS =>  
                     FAILED ("WRONG EXCEPTION RAISED - CASE 3D");
           END;
 
           BEGIN -- SATISFIES T BUT NOT BASE TYPE.
                V_A_CA1_5 := NEW CA1_6'(1, 2, 3, 4, 5, 6);
                FAILED ("NO EXCEPTION RAISED - CASE 3E");
           EXCEPTION
                WHEN CONSTRAINT_ERROR =>
                     NULL;
                WHEN OTHERS =>
                     FAILED ("WRONG EXCEPTION RAISED - CASE 3E");
           END;
 
           BEGIN -- SATISFIES BASE TYPE BUT NOT T.
                V_A_CA1_5 := NEW CA1_4'(1, 2, 3, 4, 5);
                FAILED ("NO EXCEPTION RAISED - CASE 3F");
           EXCEPTION
                WHEN CONSTRAINT_ERROR =>
                     NULL;
                WHEN OTHERS =>
                     FAILED ("WRONG EXCEPTION RAISED - CASE 3F");
           END;
 
          BEGIN -- SATISFIES BASE TYPE BUT NOT T.
               V_A_CA1_5 := NEW CA1_6'(1, 2, 3, 4, 5);
               FAILED ("NO EXCEPTION RAISED - CASE 3G");
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    FAILED ("WRONG EXCEPTION RAISED - CASE 3G");
          END;
 
      END ;
 
      RESULT ;
 
 END C48009E ;