1-- C43004C.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--     CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE VALUE OF A
27--     DISCRIMINANT OF A CONSTRAINED COMPONENT OF AN AGGREGATE DOES
28--     NOT EQUAL THE CORRESPONDING DISCRIMINANT VALUE FOR THE
29--     COMPONENT'S SUBTYPE.
30
31-- HISTORY:
32--     BCB 07/19/88  CREATED ORIGINAL TEST.
33
34WITH REPORT; USE REPORT;
35
36PROCEDURE C43004C IS
37
38     ZERO : INTEGER := 0;
39
40     TYPE REC (D : INTEGER := 0) IS RECORD
41          COMP1 : INTEGER;
42     END RECORD;
43
44     TYPE DREC (DD : INTEGER := ZERO) IS RECORD
45          DCOMP1 : INTEGER;
46     END RECORD;
47
48     TYPE REC1 IS RECORD
49          A : REC(0);
50     END RECORD;
51
52     TYPE REC2 IS RECORD
53          B : DREC(ZERO);
54     END RECORD;
55
56     TYPE REC3 (D3 : INTEGER := 0) IS RECORD
57          C : REC(D3);
58     END RECORD;
59
60     V : REC1;
61     W : REC2;
62     X : REC3;
63
64     PACKAGE P IS
65          TYPE PRIV1 (D : INTEGER := 0) IS PRIVATE;
66          TYPE PRIV2 (DD : INTEGER := ZERO) IS PRIVATE;
67          FUNCTION INIT (I : INTEGER) RETURN PRIV1;
68     PRIVATE
69          TYPE PRIV1 (D : INTEGER := 0) IS RECORD
70               NULL;
71          END RECORD;
72
73          TYPE PRIV2 (DD : INTEGER := ZERO) IS RECORD
74               NULL;
75          END RECORD;
76     END P;
77
78     TYPE REC7 IS RECORD
79          H : P.PRIV1 (0);
80     END RECORD;
81
82     Y : REC7;
83
84     GENERIC
85          TYPE GP IS PRIVATE;
86     FUNCTION GEN_EQUAL (X, Y : GP) RETURN BOOLEAN;
87
88     FUNCTION GEN_EQUAL (X, Y : GP) RETURN BOOLEAN IS
89     BEGIN
90          RETURN X = Y;
91     END GEN_EQUAL;
92
93     PACKAGE BODY P IS
94          TYPE REC4 IS RECORD
95               E : PRIV1(0);
96          END RECORD;
97
98          TYPE REC5 IS RECORD
99               F : PRIV2(ZERO);
100          END RECORD;
101
102          TYPE REC6 (D6 : INTEGER := 0) IS RECORD
103               G : PRIV1(D6);
104          END RECORD;
105
106          VV : REC4;
107          WW : REC5;
108          XX : REC6;
109
110          FUNCTION REC4_EQUAL IS NEW GEN_EQUAL (REC4);
111          FUNCTION REC5_EQUAL IS NEW GEN_EQUAL (REC5);
112          FUNCTION REC6_EQUAL IS NEW GEN_EQUAL (REC6);
113
114          FUNCTION INIT (I : INTEGER) RETURN PRIV1 IS
115               VAR : PRIV1;
116          BEGIN
117               VAR := (D => I);
118               RETURN VAR;
119          END INIT;
120     BEGIN
121          TEST ("C43004C", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
122                           "IF THE VALUE OF A DISCRIMINANT OF A " &
123                           "CONSTRAINED COMPONENT OF AN AGGREGATE " &
124                           "DOES NOT EQUAL THE CORRESPONDING " &
125                            "DISCRIMINANT VALUE FOR THECOMPONENT'S " &
126                           "SUBTYPE");
127
128          BEGIN
129               VV := (E => (D => 1));
130               FAILED ("CONSTRAINT_ERROR NOT RAISED - 1");
131               IF REC4_EQUAL (VV,VV) THEN
132                    COMMENT ("DON'T OPTIMIZE VV");
133               END IF;
134          EXCEPTION
135               WHEN CONSTRAINT_ERROR =>
136                    NULL;
137               WHEN OTHERS =>
138                    FAILED ("OTHER EXCEPTION RAISED - 1");
139          END;
140
141          BEGIN
142               WW := (F => (DD => 1));
143               FAILED ("CONSTRAINT_ERROR NOT RAISED - 2");
144               IF REC5_EQUAL (WW,WW) THEN
145                    COMMENT ("DON'T OPTIMIZE WW");
146               END IF;
147          EXCEPTION
148               WHEN CONSTRAINT_ERROR =>
149                    NULL;
150               WHEN OTHERS =>
151                    FAILED ("OTHER EXCEPTION RAISED - 2");
152          END;
153
154          BEGIN
155               XX := (D6 => 1, G => (D => 5));
156               FAILED ("CONSTRAINT_ERROR NOT RAISED - 3");
157               IF REC6_EQUAL (XX,XX) THEN
158                    COMMENT ("DON'T OPTIMIZE XX");
159               END IF;
160          EXCEPTION
161               WHEN CONSTRAINT_ERROR =>
162                    NULL;
163               WHEN OTHERS =>
164                    FAILED ("OTHER EXCEPTION RAISED - 3");
165          END;
166     END P;
167
168     USE P;
169
170     FUNCTION REC1_EQUAL IS NEW GEN_EQUAL (REC1);
171     FUNCTION REC2_EQUAL IS NEW GEN_EQUAL (REC2);
172     FUNCTION REC3_EQUAL IS NEW GEN_EQUAL (REC3);
173     FUNCTION REC7_EQUAL IS NEW GEN_EQUAL (REC7);
174
175BEGIN
176
177     BEGIN
178          V := (A => (D => 1, COMP1 => 2));
179          FAILED ("CONSTRAINT_ERROR NOT RAISED - 4");
180          IF REC1_EQUAL (V,V) THEN
181               COMMENT ("DON'T OPTIMIZE V");
182          END IF;
183     EXCEPTION
184          WHEN CONSTRAINT_ERROR =>
185               NULL;
186          WHEN OTHERS =>
187               FAILED ("OTHER EXCEPTION RAISED - 4");
188     END;
189
190     BEGIN
191          W := (B => (DD => 1, DCOMP1 => 2));
192          FAILED ("CONSTRAINT_ERROR NOT RAISED - 5");
193          IF REC2_EQUAL (W,W) THEN
194               COMMENT ("DON'T OPTIMIZE W");
195          END IF;
196     EXCEPTION
197          WHEN CONSTRAINT_ERROR =>
198               NULL;
199          WHEN OTHERS =>
200               FAILED ("OTHER EXCEPTION RAISED - 5");
201     END;
202
203     BEGIN
204          X := (D3 => 1, C => (D => 5, COMP1 => 2));
205          FAILED ("CONSTRAINT_ERROR NOT RAISED - 6");
206          IF REC3_EQUAL (X,X) THEN
207               COMMENT ("DON'T OPTIMIZE X");
208          END IF;
209     EXCEPTION
210          WHEN CONSTRAINT_ERROR =>
211               NULL;
212          WHEN OTHERS =>
213               FAILED ("OTHER EXCEPTION RAISED - 6");
214     END;
215
216     BEGIN
217          Y := (H => INIT (1));
218          FAILED ("CONSTRAINT_ERROR NOT RAISED - 7");
219          IF REC7_EQUAL (Y,Y) THEN
220               COMMENT ("DON'T OPTIMIZE Y");
221          END IF;
222     EXCEPTION
223          WHEN CONSTRAINT_ERROR =>
224               NULL;
225          WHEN OTHERS =>
226               FAILED ("OTHER EXCEPTION RAISED - 7");
227     END;
228
229     RESULT;
230END C43004C;
231