1-- C48006B.ADA 2 3-- Grant of Unlimited Rights 4-- 5-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, 6-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 7-- unlimited rights in the software and documentation contained herein. 8-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making 9-- this public release, the Government intends to confer upon all 10-- recipients unlimited rights equal to those held by the Government. 11-- These rights include rights to use, duplicate, release or disclose the 12-- released technical data and computer software in whole or in part, in 13-- any manner and for any purpose whatsoever, and to have or permit others 14-- to do so. 15-- 16-- DISCLAIMER 17-- 18-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR 19-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 20-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE 21-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 22-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A 23-- PARTICULAR PURPOSE OF SAID MATERIAL. 24--* 25-- CHECK THAT AN ALLOCATOR OF THE FORM "NEW T'(X)" ALLOCATES A NEW 26-- OBJECT EACH TIME IT IS EXECUTED AND THAT IF T IS A RECORD, ARRAY, OR 27-- PRIVATE TYPE (CONSTRAINED OR UNCONSTRAINED), THE ALLOCATED OBJECT HAS 28-- THE VALUE OF (X). 29 30-- RM 01/14/80 31-- RM 01/O1/82 32-- SPS 10/27/82 33-- EG 07/05/84 34-- JBG 11/08/85 AVOID CONFLICT WITH AI-7 OR AI-275 35 36WITH REPORT; 37 38PROCEDURE C48006B IS 39 40 USE REPORT ; 41 42BEGIN 43 44 TEST("C48006B","CHECK THAT THE FORM 'NEW T'(X)' " & 45 "ALLOCATES A NEW OBJECT " & 46 "AND THAT IF T IS A RECORD, ARRAY, OR PRIVATE " & 47 "TYPE, THE ALLOCATED OBJECT HAS THE VALUE (X)"); 48 49 -- RECORD OR ARRAY TYPE (CONSTRAINED OR UNCONSTRAINED) 50 51 DECLARE 52 53 TYPE TB0( A , B : INTEGER ) IS 54 RECORD 55 C : INTEGER := 7 ; 56 END RECORD; 57 SUBTYPE TB IS TB0( 2 , 3 ); 58 TYPE ATB IS ACCESS TB ; 59 TYPE ATB0 IS ACCESS TB0 ; 60 VB1 , VB2 : ATB ; 61 VB01 , VB02 : ATB0 ; 62 63 TYPE ARR0 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ; 64 SUBTYPE ARR IS ARR0( 1..4 ); 65 TYPE A_ARR IS ACCESS ARR ; 66 TYPE A_ARR0 IS ACCESS ARR0 ; 67 VARR1 , VARR2 : A_ARR ; 68 VARR01 , VARR02 : A_ARR0 ; 69 70 BEGIN 71 72 VB1 := NEW TB'( 2 , 3 , 5 ); 73 IF ( VB1.A /=IDENT_INT( 2) OR 74 VB1.B /=IDENT_INT( 3) OR 75 VB1.C /=IDENT_INT( 5) ) 76 THEN FAILED( "WRONG VALUES - B1 1" ); 77 END IF; 78 79 VB2 := NEW TB'( IDENT_INT(2), IDENT_INT(3), IDENT_INT(6)); 80 IF ( VB2.A /= 2 OR 81 VB2.B /= 3 OR 82 VB2.C /= 6 OR 83 VB1.A /= 2 OR 84 VB1.B /= 3 OR 85 VB1.C /= 5 ) 86 THEN FAILED( "WRONG VALUES - B1 2" ); 87 END IF; 88 89 VB01 := NEW TB0'( 1 , 2 , 3 ); 90 IF ( VB01.A /=IDENT_INT( 1) OR 91 VB01.B /=IDENT_INT( 2) OR 92 VB01.C /=IDENT_INT( 3) ) 93 THEN FAILED( "WRONG VALUES - B2 1" ); 94 END IF; 95 96 VB02 := NEW TB0'( IDENT_INT(4) , IDENT_INT(5) , 97 IDENT_INT(6) ); 98 IF ( VB02.A /=IDENT_INT( 4) OR 99 VB02.B /=IDENT_INT( 5) OR 100 VB02.C /=IDENT_INT( 6) OR 101 VB01.A /=IDENT_INT( 1) OR 102 VB01.B /=IDENT_INT( 2) OR 103 VB01.C /=IDENT_INT( 3) ) 104 THEN FAILED( "WRONG VALUES - B2 2" ); 105 END IF; 106 107 VARR1 := NEW ARR'( 5 , 6 , 7 , 8 ); 108 IF ( VARR1(1) /=IDENT_INT( 5) OR 109 VARR1(2) /=IDENT_INT( 6) OR 110 VARR1(3) /=IDENT_INT( 7) OR 111 VARR1(4) /=IDENT_INT( 8) ) 112 THEN FAILED( "WRONG VALUES - B3 1" ); 113 END IF ; 114 115 VARR2 := NEW ARR'( IDENT_INT(1) , IDENT_INT(2) , IDENT_INT(3), 116 IDENT_INT(4) ); 117 IF ( VARR2(1) /= 1 OR 118 VARR2(2) /= 2 OR 119 VARR2(3) /= 3 OR 120 VARR2(4) /= 4 OR 121 VARR1(1) /= 5 OR 122 VARR1(2) /= 6 OR 123 VARR1(3) /= 7 OR 124 VARR1(4) /= 8 ) 125 THEN FAILED( "WRONG VALUES - B3 2" ); 126 END IF ; 127 128 VARR01 := NEW ARR0'( 11 , 12 , 13 ); 129 IF ( VARR01(INTEGER'FIRST) /= IDENT_INT(11) OR 130 VARR01(INTEGER'FIRST + 1) /= IDENT_INT(12) OR 131 VARR01(INTEGER'FIRST + 2) /= IDENT_INT(13) ) 132 THEN FAILED( "WRONG VALUES - B4 1" ); 133 END IF ; 134 IF ( VARR01.ALL'FIRST /= IDENT_INT( INTEGER'FIRST ) OR 135 VARR01.ALL'LAST /= IDENT_INT( INTEGER'FIRST + 2 ) ) 136 THEN FAILED( "WRONG VALUES - B4 2" ); 137 END IF ; 138 139 VARR02 := NEW ARR0'( 1 => IDENT_INT(14) , 2 => IDENT_INT(15)); 140 IF ( VARR02(1) /= 14 OR 141 VARR02(2) /= 15 OR 142 VARR01(INTEGER'FIRST) /= 11 OR 143 VARR01(INTEGER'FIRST + 1) /= 12 OR 144 VARR01(INTEGER'FIRST + 2) /= 13 ) 145 THEN FAILED( "WRONG VALUES - B4 3" ); 146 END IF ; 147 148 END ; 149 150 -- PRIVATE TYPE (CONSTRAINED OR UNCONSTRAINED) 151 152 DECLARE 153 154 PACKAGE P IS 155 TYPE UP(A, B : INTEGER) IS PRIVATE; 156-- SUBTYPE CP IS UP(1, 2); 157-- TYPE A_CP IS ACCESS CP; 158 TYPE A_UP IS ACCESS UP; 159 CONS1_UP : CONSTANT UP; 160 CONS2_UP : CONSTANT UP; 161 CONS3_UP : CONSTANT UP; 162 CONS4_UP : CONSTANT UP; 163-- PROCEDURE CHECK1 (X : A_CP); 164-- PROCEDURE CHECK2 (X, Y : A_CP); 165 PROCEDURE CHECK3 (X : A_UP); 166 PROCEDURE CHECK4 (X, Y : A_UP); 167 PRIVATE 168 TYPE UP(A, B : INTEGER) IS 169 RECORD 170 C : INTEGER; 171 END RECORD; 172 CONS1_UP : CONSTANT UP := (1, 2, 3); 173 CONS2_UP : CONSTANT UP := (IDENT_INT(1), IDENT_INT(2), 174 IDENT_INT(4)); 175 CONS3_UP : CONSTANT UP := (7, 8, 9); 176 CONS4_UP : CONSTANT UP := (IDENT_INT(10), IDENT_INT(11), 177 IDENT_INT(12)); 178 END P; 179 180 USE P; 181 182-- V_A_CP1, V_A_CP2 : A_CP; 183 V_A_UP1, V_A_UP2 : A_UP; 184 185 PACKAGE BODY P IS 186-- PROCEDURE CHECK1 (X : A_CP) IS 187-- BEGIN 188-- IF (X.A /= IDENT_INT(1) OR 189-- X.B /= IDENT_INT(2) OR 190-- X.C /= IDENT_INT(3)) THEN 191-- FAILED ("WRONG VALUES - CP1"); 192-- END IF; 193-- END CHECK1; 194-- PROCEDURE CHECK2 (X, Y : A_CP) IS 195-- BEGIN 196-- IF (X.A /= 1 OR X.B /= 2 OR X.C /= 3 OR 197-- Y.A /= 1 OR Y.B /= 2 OR Y.C /= 4) THEN 198-- FAILED ("WRONG VALUES - CP2"); 199-- END IF; 200-- END CHECK2; 201 PROCEDURE CHECK3 (X : A_UP) IS 202 BEGIN 203 IF (X.A /= IDENT_INT(7) OR 204 X.B /= IDENT_INT(8) OR 205 X.C /= IDENT_INT(9)) THEN 206 FAILED ("WRONG VALUES - UP1"); 207 END IF; 208 END CHECK3; 209 PROCEDURE CHECK4 (X, Y : A_UP) IS 210 BEGIN 211 IF (X.A /= 7 OR X.B /= 8 OR X.C /= 9 OR 212 Y.A /= 10 OR Y.B /= 11 OR Y.C /= 12) THEN 213 FAILED ("WRONG VALUES - UP2"); 214 END IF; 215 END CHECK4; 216 END P; 217 218 BEGIN 219 220-- V_A_CP1 := NEW CP'(CONS1_UP); 221-- CHECK1(V_A_CP1); 222 223-- V_A_CP2 := NEW CP'(CONS2_UP); 224-- CHECK2(V_A_CP1, V_A_CP2); 225 226 V_A_UP1 := NEW P.UP'(CONS3_UP); 227 CHECK3(V_A_UP1); 228 229 V_A_UP2 := NEW P.UP'(CONS4_UP); 230 CHECK4(V_A_UP1, V_A_UP2); 231 232 END; 233 234 RESULT; 235 236END C48006B; 237