| -- 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; |
