|
111
|
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
|
|
|
36 WITH REPORT;
|
|
|
37
|
|
|
38 PROCEDURE C48006B IS
|
|
|
39
|
|
|
40 USE REPORT ;
|
|
|
41
|
|
|
42 BEGIN
|
|
|
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
|
|
|
236 END C48006B;
|
