1-- C48009G.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-- OBJECTIVE:
26--     FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT
27--     CONSTRAINT_ERROR IS RAISED IF T IS A CONSTRAINED ACCESS
28--     TYPE AND THE OBJECT DESIGNATED BY X DOES NOT HAVE DISCRIMINANTS
29--     OR INDEX BOUNDS THAT EQUAL THE CORRESPONDING VALUES FOR T.
30
31-- HISTORY:
32--     EG  08/30/84  CREATED ORIGINAL TEST.
33--     JET 01/05/87  UPDATED HEADER FORMAT AND ADDED CODE TO PREVENT
34--                   OPTIMIZATION.
35
36WITH REPORT;
37
38PROCEDURE C48009G IS
39
40     USE REPORT;
41
42     GENERIC
43          TYPE G_TYPE IS PRIVATE;
44     FUNCTION EQUAL_G (X : G_TYPE; Y : G_TYPE) RETURN BOOLEAN;
45
46     FUNCTION EQUAL_G (X : G_TYPE; Y : G_TYPE) RETURN BOOLEAN IS
47     BEGIN
48          IF (IDENT_INT(3) = 3) AND (X = Y) THEN
49               RETURN TRUE;
50          ELSE
51               RETURN FALSE;
52          END IF;
53     END EQUAL_G;
54
55BEGIN
56
57     TEST("C48009G","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " &
58                    "THAT CONSTRAINT_ERROR IS RAISED WHEN " &
59                    "APPROPRIATE - CONSTRAINED ACCESS TYPE");
60
61     DECLARE
62
63          TYPE INT IS RANGE 1 .. 5;
64
65          TYPE UR(A : INT) IS
66               RECORD
67                    B : INTEGER;
68               END RECORD;
69          TYPE UA IS ARRAY(INT RANGE <>) OF INTEGER;
70
71          PACKAGE P IS
72               TYPE UP(A, B : INT) IS PRIVATE;
73               TYPE UL(A, B : INT) IS LIMITED PRIVATE;
74               CONS_UP : CONSTANT UP;
75          PRIVATE
76               TYPE UP(A, B : INT) IS
77                    RECORD
78                         C : INTEGER;
79                    END RECORD;
80               TYPE UL(A, B : INT) IS
81                    RECORD
82                         C : INTEGER;
83                    END RECORD;
84               CONS_UP : CONSTANT UP := (2, 2, (IDENT_INT(3)));
85          END P;
86
87          TYPE A_UR IS ACCESS UR;
88          TYPE A_UA IS ACCESS UA;
89          TYPE A_UP IS ACCESS P.UP;
90          TYPE A_UL IS ACCESS P.UL;
91
92          SUBTYPE CA_UR IS A_UR(2);
93          SUBTYPE CA_UA IS A_UA(2 .. 3);
94          SUBTYPE CA_UP IS A_UP(3, 2);
95          SUBTYPE CA_UL IS A_UL(2, 4);
96
97          TYPE A_CA_UR IS ACCESS CA_UR;
98          TYPE A_CA_UA IS ACCESS CA_UA;
99          TYPE A_CA_UP IS ACCESS CA_UP;
100          TYPE A_CA_UL IS ACCESS CA_UL;
101
102          V_A_CA_UR : A_CA_UR;
103          V_A_CA_UA : A_CA_UA;
104          V_A_CA_UP : A_CA_UP;
105          V_A_CA_UL : A_CA_UL;
106
107          FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UR);
108          FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UA);
109          FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UP);
110          FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UL);
111
112     BEGIN
113
114          BEGIN
115               V_A_CA_UR := NEW CA_UR'(NEW UR'(1,(IDENT_INT(2))));
116
117               IF EQUAL (V_A_CA_UR, V_A_CA_UR) THEN
118                    FAILED ("NO EXCEPTION RAISED - UR");
119               END IF;
120
121          EXCEPTION
122               WHEN CONSTRAINT_ERROR =>
123                    NULL;
124               WHEN OTHERS =>
125                    FAILED ("WRONG EXCEPTION RAISED - UR");
126          END;
127
128          BEGIN
129               V_A_CA_UA := NEW CA_UA'(NEW UA'(1 => 2,
130                                               2 => IDENT_INT(3)));
131
132               IF EQUAL (V_A_CA_UA, V_A_CA_UA) THEN
133                    FAILED ("NO EXCEPTION RAISED - UA");
134               END IF;
135
136          EXCEPTION
137               WHEN CONSTRAINT_ERROR =>
138                    NULL;
139               WHEN OTHERS =>
140                    FAILED ("WRONG EXCEPTION RAISED - UA");
141          END;
142
143          BEGIN
144               V_A_CA_UP := NEW CA_UP'(NEW P.UP'(P.CONS_UP));
145
146               IF EQUAL (V_A_CA_UP, V_A_CA_UP) THEN
147                    FAILED ("NO EXCEPTION RAISED - UP");
148               END IF;
149
150          EXCEPTION
151               WHEN CONSTRAINT_ERROR =>
152                    NULL;
153               WHEN OTHERS =>
154                    FAILED ("WRONG EXCEPTION RAISED - UP");
155          END;
156
157          BEGIN
158               V_A_CA_UR := NEW CA_UR'(NULL);
159
160               IF NOT EQUAL (V_A_CA_UR, V_A_CA_UR) THEN
161                    COMMENT ("NO EXCEPTION RAISED - UR");
162               END IF;
163
164          EXCEPTION
165               WHEN OTHERS =>
166                    FAILED ("EXCEPTION RAISED - UR");
167          END;
168
169          BEGIN
170               V_A_CA_UA := NEW CA_UA'(NULL);
171
172               IF NOT EQUAL (V_A_CA_UA, V_A_CA_UA) THEN
173                    COMMENT ("NO EXCEPTION RAISED - UA");
174               END IF;
175
176          EXCEPTION
177               WHEN OTHERS =>
178                    FAILED ("EXCEPTION RAISED - UA");
179          END;
180
181          BEGIN
182               V_A_CA_UP := NEW CA_UP'(NULL);
183
184               IF NOT EQUAL (V_A_CA_UP, V_A_CA_UP) THEN
185                    COMMENT ("NO EXCEPTION RAISED - UP");
186               END IF;
187
188          EXCEPTION
189               WHEN OTHERS =>
190                    FAILED ("EXCEPTION RAISED - UP");
191          END;
192
193          BEGIN
194               V_A_CA_UL := NEW CA_UL'(NULL);
195
196               IF NOT EQUAL (V_A_CA_UL, V_A_CA_UL) THEN
197                    COMMENT ("NO EXCEPTION RAISED - UL");
198               END IF;
199
200          EXCEPTION
201               WHEN OTHERS =>
202                    FAILED ("EXCEPTION RAISED - UL");
203          END;
204
205     END;
206
207     RESULT;
208
209END C48009G;
210