1-- C37215B.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 IF
26--        A DISCRIMINANT CONSTRAINT
27-- DEPENDS ON A DISCRIMINANT, THE DISCRIMINANT VALUE IS CHECKED FOR
28-- COMPATIBILITY WHEN THE RECORD TYPE IS:
29--
30--   CASE B: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT
31--      DECLARATION.
32
33-- JBG 10/17/86
34
35WITH REPORT; USE REPORT;
36PROCEDURE C37215B IS
37
38     SUBTYPE SM IS INTEGER RANGE 1..10;
39
40     TYPE REC (D1, D2 : SM) IS
41          RECORD NULL; END RECORD;
42
43BEGIN
44     TEST ("C37215B", "CHECK COMPATIBILITY OF DISCRIMINANT EXPRESSIONS"&
45                      " WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " &
46                      "AND DISCRIMINANTS HAVE DEFAULTS");
47
48-- CASE B
49
50     DECLARE
51          TYPE CONS (D3 : INTEGER := IDENT_INT(11)) IS
52               RECORD
53                    C1 : REC(D3, 1);
54               END RECORD;
55     BEGIN
56          BEGIN
57               DECLARE
58                    X : CONS;
59               BEGIN
60                    FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 1");
61                    IF X /= (1, (1, 1)) THEN
62                         COMMENT ("SHOULDN'T GET HERE");
63                    END IF;
64               END;
65          EXCEPTION
66               WHEN CONSTRAINT_ERROR =>
67                    NULL;
68               WHEN OTHERS =>
69                    FAILED ("UNEXPECTED EXCEPTION - 1");
70          END;
71
72          BEGIN
73               DECLARE
74                    TYPE ACC_CONS IS ACCESS CONS;
75                    X : ACC_CONS;
76               BEGIN
77                    X := NEW CONS;
78                    FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 2");
79                    BEGIN
80                         IF X.ALL /= (1, (1, 1)) THEN
81                              COMMENT ("IRRELEVANT");
82                         END IF;
83                    END;
84               EXCEPTION
85                    WHEN CONSTRAINT_ERROR =>
86                         NULL;
87                    WHEN OTHERS =>
88                         FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
89               END;
90          EXCEPTION
91               WHEN OTHERS =>
92                    FAILED ("CONSTRAINT CHECKED TOO SOON - 2");
93          END;
94
95          BEGIN
96               DECLARE
97                    SUBTYPE SCONS IS CONS;
98               BEGIN
99                    DECLARE
100                         X : SCONS;
101                    BEGIN
102                         FAILED ("DISCRIMINANT CHECK NOT " &
103                                 "PERFORMED - 3");
104                         IF X /= (1, (1, 1)) THEN
105                              COMMENT ("IRRELEVANT");
106                         END IF;
107                    END;
108               EXCEPTION
109                    WHEN CONSTRAINT_ERROR =>
110                         NULL;
111                    WHEN OTHERS =>
112                         FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
113               END;
114          EXCEPTION
115               WHEN OTHERS =>
116                    FAILED ("CONSTRAINT CHECKED TOO SOON - 3");
117          END;
118
119          BEGIN
120               DECLARE
121                    TYPE ARR IS ARRAY (1..5) OF CONS;
122               BEGIN
123                    DECLARE
124                         X : ARR;
125                    BEGIN
126                         FAILED ("DISCRIMINANT CHECK NOT " &
127                                 "PERFORMED - 4");
128                         IF X /= (1..5 => (1, (1, 1))) THEN
129                              COMMENT ("IRRELEVANT");
130                         END IF;
131                    END;
132               EXCEPTION
133                    WHEN CONSTRAINT_ERROR =>
134                         NULL;
135                    WHEN OTHERS =>
136                         FAILED ("UNEXPECTED EXCEPTION RAISED - 4");
137               END;
138          EXCEPTION
139               WHEN OTHERS =>
140                    FAILED ("CONSTRAINT CHECKED TOO SOON - 4");
141          END;
142
143          BEGIN
144               DECLARE
145                    TYPE NREC IS
146                         RECORD
147                              C1 : CONS;
148                         END RECORD;
149               BEGIN
150                    DECLARE
151                         X : NREC;
152                    BEGIN
153                         FAILED ("DISCRIMINANT CHECK NOT " &
154                                 "PERFORMED - 5");
155                         IF X /= (C1 => (1, (1, 1))) THEN
156                              COMMENT ("IRRELEVANT");
157                         END IF;
158                    END;
159               EXCEPTION
160                    WHEN CONSTRAINT_ERROR =>
161                         NULL;
162                    WHEN OTHERS =>
163                         FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
164               END;
165          EXCEPTION
166               WHEN OTHERS =>
167                    FAILED ("CONSTRAINT CHECKED TOO SOON - 5");
168          END;
169
170          BEGIN
171               DECLARE
172                    TYPE DREC IS NEW CONS;
173               BEGIN
174                    DECLARE
175                         X : DREC;
176                    BEGIN
177                         FAILED ("DISCRIMINANT CHECK NOT " &
178                                 "PERFORMED - 6");
179                         IF X /= (1, (1, 1)) THEN
180                              COMMENT ("IRRELEVANT");
181                         END IF;
182                    END;
183               EXCEPTION
184                    WHEN CONSTRAINT_ERROR =>
185                         NULL;
186                    WHEN OTHERS =>
187                         FAILED ("UNEXPECTED EXCEPTION RAISED - 6");
188               END;
189          EXCEPTION
190               WHEN OTHERS =>
191                    FAILED ("CONSTRAINT CHECKED TOO SOON - 6");
192          END;
193
194     END;
195
196     RESULT;
197
198EXCEPTION
199     WHEN OTHERS =>
200          FAILED ("CONSTRAINT CHECK DONE TOO EARLY");
201          RESULT;
202
203END C37215B;
204