diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c48006b.ada')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c48006b.ada | 236 |
1 files changed, 236 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c48006b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c48006b.ada new file mode 100644 index 000000000..001b8897c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c48006b.ada @@ -0,0 +1,236 @@ +-- C48006B.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 AN ALLOCATOR OF THE FORM "NEW T'(X)" ALLOCATES A NEW +-- OBJECT EACH TIME IT IS EXECUTED AND THAT IF T IS A RECORD, ARRAY, OR +-- PRIVATE TYPE (CONSTRAINED OR UNCONSTRAINED), THE ALLOCATED OBJECT HAS +-- THE VALUE OF (X). + +-- RM 01/14/80 +-- RM 01/O1/82 +-- SPS 10/27/82 +-- EG 07/05/84 +-- JBG 11/08/85 AVOID CONFLICT WITH AI-7 OR AI-275 + +WITH REPORT; + +PROCEDURE C48006B IS + + USE REPORT ; + +BEGIN + + TEST("C48006B","CHECK THAT THE FORM 'NEW T'(X)' " & + "ALLOCATES A NEW OBJECT " & + "AND THAT IF T IS A RECORD, ARRAY, OR PRIVATE " & + "TYPE, THE ALLOCATED OBJECT HAS THE VALUE (X)"); + + -- RECORD OR ARRAY TYPE (CONSTRAINED OR UNCONSTRAINED) + + DECLARE + + TYPE TB0( A , B : INTEGER ) IS + RECORD + C : INTEGER := 7 ; + END RECORD; + SUBTYPE TB IS TB0( 2 , 3 ); + TYPE ATB IS ACCESS TB ; + TYPE ATB0 IS ACCESS TB0 ; + VB1 , VB2 : ATB ; + VB01 , VB02 : ATB0 ; + + TYPE ARR0 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ; + SUBTYPE ARR IS ARR0( 1..4 ); + TYPE A_ARR IS ACCESS ARR ; + TYPE A_ARR0 IS ACCESS ARR0 ; + VARR1 , VARR2 : A_ARR ; + VARR01 , VARR02 : A_ARR0 ; + + BEGIN + + VB1 := NEW TB'( 2 , 3 , 5 ); + IF ( VB1.A /=IDENT_INT( 2) OR + VB1.B /=IDENT_INT( 3) OR + VB1.C /=IDENT_INT( 5) ) + THEN FAILED( "WRONG VALUES - B1 1" ); + END IF; + + VB2 := NEW TB'( IDENT_INT(2), IDENT_INT(3), IDENT_INT(6)); + IF ( VB2.A /= 2 OR + VB2.B /= 3 OR + VB2.C /= 6 OR + VB1.A /= 2 OR + VB1.B /= 3 OR + VB1.C /= 5 ) + THEN FAILED( "WRONG VALUES - B1 2" ); + END IF; + + VB01 := NEW TB0'( 1 , 2 , 3 ); + IF ( VB01.A /=IDENT_INT( 1) OR + VB01.B /=IDENT_INT( 2) OR + VB01.C /=IDENT_INT( 3) ) + THEN FAILED( "WRONG VALUES - B2 1" ); + END IF; + + VB02 := NEW TB0'( IDENT_INT(4) , IDENT_INT(5) , + IDENT_INT(6) ); + IF ( VB02.A /=IDENT_INT( 4) OR + VB02.B /=IDENT_INT( 5) OR + VB02.C /=IDENT_INT( 6) OR + VB01.A /=IDENT_INT( 1) OR + VB01.B /=IDENT_INT( 2) OR + VB01.C /=IDENT_INT( 3) ) + THEN FAILED( "WRONG VALUES - B2 2" ); + END IF; + + VARR1 := NEW ARR'( 5 , 6 , 7 , 8 ); + IF ( VARR1(1) /=IDENT_INT( 5) OR + VARR1(2) /=IDENT_INT( 6) OR + VARR1(3) /=IDENT_INT( 7) OR + VARR1(4) /=IDENT_INT( 8) ) + THEN FAILED( "WRONG VALUES - B3 1" ); + END IF ; + + VARR2 := NEW ARR'( IDENT_INT(1) , IDENT_INT(2) , IDENT_INT(3), + IDENT_INT(4) ); + IF ( VARR2(1) /= 1 OR + VARR2(2) /= 2 OR + VARR2(3) /= 3 OR + VARR2(4) /= 4 OR + VARR1(1) /= 5 OR + VARR1(2) /= 6 OR + VARR1(3) /= 7 OR + VARR1(4) /= 8 ) + THEN FAILED( "WRONG VALUES - B3 2" ); + END IF ; + + VARR01 := NEW ARR0'( 11 , 12 , 13 ); + IF ( VARR01(INTEGER'FIRST) /= IDENT_INT(11) OR + VARR01(INTEGER'FIRST + 1) /= IDENT_INT(12) OR + VARR01(INTEGER'FIRST + 2) /= IDENT_INT(13) ) + THEN FAILED( "WRONG VALUES - B4 1" ); + END IF ; + IF ( VARR01.ALL'FIRST /= IDENT_INT( INTEGER'FIRST ) OR + VARR01.ALL'LAST /= IDENT_INT( INTEGER'FIRST + 2 ) ) + THEN FAILED( "WRONG VALUES - B4 2" ); + END IF ; + + VARR02 := NEW ARR0'( 1 => IDENT_INT(14) , 2 => IDENT_INT(15)); + IF ( VARR02(1) /= 14 OR + VARR02(2) /= 15 OR + VARR01(INTEGER'FIRST) /= 11 OR + VARR01(INTEGER'FIRST + 1) /= 12 OR + VARR01(INTEGER'FIRST + 2) /= 13 ) + THEN FAILED( "WRONG VALUES - B4 3" ); + END IF ; + + END ; + + -- PRIVATE TYPE (CONSTRAINED OR UNCONSTRAINED) + + DECLARE + + PACKAGE P IS + TYPE UP(A, B : INTEGER) IS PRIVATE; +-- SUBTYPE CP IS UP(1, 2); +-- TYPE A_CP IS ACCESS CP; + TYPE A_UP IS ACCESS UP; + CONS1_UP : CONSTANT UP; + CONS2_UP : CONSTANT UP; + CONS3_UP : CONSTANT UP; + CONS4_UP : CONSTANT UP; +-- PROCEDURE CHECK1 (X : A_CP); +-- PROCEDURE CHECK2 (X, Y : A_CP); + PROCEDURE CHECK3 (X : A_UP); + PROCEDURE CHECK4 (X, Y : A_UP); + PRIVATE + TYPE UP(A, B : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + CONS1_UP : CONSTANT UP := (1, 2, 3); + CONS2_UP : CONSTANT UP := (IDENT_INT(1), IDENT_INT(2), + IDENT_INT(4)); + CONS3_UP : CONSTANT UP := (7, 8, 9); + CONS4_UP : CONSTANT UP := (IDENT_INT(10), IDENT_INT(11), + IDENT_INT(12)); + END P; + + USE P; + +-- V_A_CP1, V_A_CP2 : A_CP; + V_A_UP1, V_A_UP2 : A_UP; + + PACKAGE BODY P IS +-- PROCEDURE CHECK1 (X : A_CP) IS +-- BEGIN +-- IF (X.A /= IDENT_INT(1) OR +-- X.B /= IDENT_INT(2) OR +-- X.C /= IDENT_INT(3)) THEN +-- FAILED ("WRONG VALUES - CP1"); +-- END IF; +-- END CHECK1; +-- PROCEDURE CHECK2 (X, Y : A_CP) IS +-- BEGIN +-- IF (X.A /= 1 OR X.B /= 2 OR X.C /= 3 OR +-- Y.A /= 1 OR Y.B /= 2 OR Y.C /= 4) THEN +-- FAILED ("WRONG VALUES - CP2"); +-- END IF; +-- END CHECK2; + PROCEDURE CHECK3 (X : A_UP) IS + BEGIN + IF (X.A /= IDENT_INT(7) OR + X.B /= IDENT_INT(8) OR + X.C /= IDENT_INT(9)) THEN + FAILED ("WRONG VALUES - UP1"); + END IF; + END CHECK3; + PROCEDURE CHECK4 (X, Y : A_UP) IS + BEGIN + IF (X.A /= 7 OR X.B /= 8 OR X.C /= 9 OR + Y.A /= 10 OR Y.B /= 11 OR Y.C /= 12) THEN + FAILED ("WRONG VALUES - UP2"); + END IF; + END CHECK4; + END P; + + BEGIN + +-- V_A_CP1 := NEW CP'(CONS1_UP); +-- CHECK1(V_A_CP1); + +-- V_A_CP2 := NEW CP'(CONS2_UP); +-- CHECK2(V_A_CP1, V_A_CP2); + + V_A_UP1 := NEW P.UP'(CONS3_UP); + CHECK3(V_A_UP1); + + V_A_UP2 := NEW P.UP'(CONS4_UP); + CHECK4(V_A_UP1, V_A_UP2); + + END; + + RESULT; + +END C48006B; |