1-- C41304B.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 L.R RAISES CONSTRAINT_ERROR WHEN:
27--        L DENOTES A RECORD OBJECT SUCH THAT, FOR THE EXISTING
28--           DISCRIMINANT VALUES, THE COMPONENT DENOTED BY R DOES
29--           NOT EXIST.
30--        L IS A FUNCTION CALL DELIVERING A RECORD VALUE SUCH THAT,
31--           FOR THE EXISTING DISCRIMINANT VALUES, THE COMPONENT
32--           DENOTED BY R DOES NOT EXIST.
33--        L IS AN ACCESS OBJECT AND THE OBJECT DESIGNATED BY THE ACCESS
34--           VALUE IS SUCH THAT COMPONENT R DOES NOT EXIST FOR THE
35--           OBJECT'S CURRENT DISCRIMINANT VALUES.
36--        L IS A FUNCTION CALL RETURNING AN ACCESS VALUE AND THE OBJECT
37--           DESIGNATED BY THE ACCESS VALUE IS SUCH THAT COMPONENT R
38--           DOES NOT EXIST FOR THE OBJECT'S CURRENT DISCRIMINANT
39--           VALUES.
40
41-- HISTORY:
42--     TBN 05/23/86  CREATED ORIGINAL TEST.
43--     JET 01/08/88  MODIFIED HEADER FORMAT AND ADDED CODE TO
44--                   PREVENT OPTIMIZATION.
45
46WITH REPORT; USE REPORT;
47PROCEDURE C41304B IS
48
49     TYPE V (DISC : INTEGER := 0) IS
50          RECORD
51               CASE DISC IS
52                    WHEN 1 =>
53                         X : INTEGER;
54                    WHEN OTHERS =>
55                         Y : INTEGER;
56               END CASE;
57          END RECORD;
58
59     TYPE T IS ACCESS V;
60
61BEGIN
62     TEST ("C41304B", "CHECK THAT L.R RAISES CONSTRAINT_ERROR WHEN " &
63                      "THE COMPONENT DENOTED BY R DOES NOT EXIST");
64
65     DECLARE
66
67          VR : V := (DISC => 0, Y => 4);
68          J : INTEGER;
69
70     BEGIN
71
72          IF EQUAL (4, 4) THEN
73               VR := (DISC => 1, X => 3);
74          END IF;
75
76          J := VR.Y;
77          FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A RECORD OBJECT");
78
79          -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J.
80
81          IF EQUAL (J,3) THEN
82               FAILED ("CONSTRAINT_ERROR NOT RAISED - 1");
83          END IF;
84
85     EXCEPTION
86
87          WHEN CONSTRAINT_ERROR =>
88               NULL;
89          WHEN OTHERS =>
90               FAILED ("WRONG EXCEPTION RAISED FOR A RECORD OBJECT");
91
92     END;
93
94     --------------------------------------------------
95
96     DECLARE
97
98          J : INTEGER;
99
100          FUNCTION F RETURN V IS
101          BEGIN
102               IF EQUAL (4, 4) THEN
103                    RETURN (DISC => 2, Y => 3);
104               END IF;
105               RETURN (DISC => 1, X => 4);
106          END F;
107
108     BEGIN
109
110          J := F.X;
111          FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A FUNCTION CALL " &
112                  "DELIVERING A RECORD VALUE");
113
114          -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J.
115
116          IF EQUAL (J,3) THEN
117               FAILED ("CONSTRAINT_ERROR NOT RAISED - 2");
118          END IF;
119
120     EXCEPTION
121
122          WHEN CONSTRAINT_ERROR =>
123               NULL;
124          WHEN OTHERS =>
125               FAILED ("WRONG EXCEPTION RAISED FOR A FUNCTION CALL " &
126                       "DELIVERING A RECORD VALUE");
127
128     END;
129
130     --------------------------------------------------
131
132     DECLARE
133
134          A : T := NEW V' (DISC => 0, Y => 4);
135          J : INTEGER;
136
137     BEGIN
138
139          IF EQUAL (4, 4) THEN
140               A := NEW V' (DISC => 1, X => 3);
141          END IF;
142
143          J := A.Y;
144          FAILED ("CONSTRAINT_ERROR NOT RAISED FOR AN ACCESS OBJECT");
145
146          -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J.
147
148          IF EQUAL (J,3) THEN
149               FAILED ("CONSTRAINT_ERROR NOT RAISED - 3");
150          END IF;
151
152     EXCEPTION
153
154          WHEN CONSTRAINT_ERROR =>
155               NULL;
156          WHEN OTHERS =>
157               FAILED ("WRONG EXCEPTION RAISED FOR AN ACCESS OBJECT");
158
159     END;
160
161     --------------------------------------------------
162
163     DECLARE
164
165          J : INTEGER;
166
167          FUNCTION F RETURN T IS
168          BEGIN
169               IF EQUAL (4, 4) THEN
170                    RETURN NEW V' (DISC => 2, Y => 3);
171               END IF;
172               RETURN NEW V' (DISC => 1, X => 4);
173          END F;
174
175     BEGIN
176
177          J := F.X;
178          FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A FUNCTION CALL " &
179                  "DELIVERING AN ACCESS VALUE");
180
181          -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J.
182
183          IF EQUAL (J,3) THEN
184               FAILED ("CONSTRAINT_ERROR NOT RAISED - 4");
185          END IF;
186
187     EXCEPTION
188
189          WHEN CONSTRAINT_ERROR =>
190               NULL;
191          WHEN OTHERS =>
192               FAILED ("WRONG EXCEPTION RAISED FOR A FUNCTION CALL " &
193                       "DELIVERING AN ACCESS VALUE");
194
195     END;
196
197     RESULT;
198END C41304B;
199