1-- C37207A.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
27--     FOR A TYPE WITH OR WITHOUT DEFAULT DISCRIMINANT VALUES, CHECK
28--     THAT A DISCRIMINANT CONSTRAINT CAN BE SUPPLIED IN THE FOLLOWING
29--     CONTEXTS AND HAS THE PROPER EFFECT:
30
31--     IN A 1) OBJECT_DECLARATION, 2) COMPONENT_DECLARATION OR
32--     3) SUBTYPE INDICATION OF AN ARRAY_TYPE_DEFINITION, AND HENCE,
33--     ASSIGNMENTS CANNOT ATTEMPT TO CHANGE THE SPECIFIED DISCRIMINANT
34--     VALUES WITHOUT RAISING CONSTRAINT_ERROR
35
36--     4) IN AN ACCESS_TYPE_DEFINITION, AND HENCE, ACCESS VALUES
37--     OF THIS ACCESS TYPE CANNOT BE ASSIGNED NON-NULL VALUES
38--     DESIGNATING OBJECTS WITH DIFFERENT DISCRIMINANT VALUES.
39
40--     5) IN AN ALLOCATOR, AND THE ALLOCATED OBJECT HAS THE SPECIFIED
41--     DISCRIMINANT VALUES.
42
43--     6) IN A FORMAL PARAMETER DECLARATION OF A SUBPROGRAM, AND
44--     HENCE, ASSIGNMENTS TO THE FORMAL PARAMETER CANNOT ATTEMPT TO
45--     CHANGE THE DISCRIMINANT VALUES WITHOUT RAISING CONSTRAINT_ERROR,
46--     CONSTRAINED IS TRUE, AND IF ACTUAL PARAMETERS HAVE DISCRIMINANT
47--     VALUES DIFFERENT FROM THE SPECIFIED ONES, CONSTRAINT_ERROR IS
48--     RAISED.
49
50-- HISTORY:
51
52--     ASL 07/24/81
53--     RJW 08/28/86  CORRECTED SYNTAX ERRORS.
54--     JLH 08/07/87  ADDED CODE TO PREVENT DEAD VARIABLE OPTIMIZATION.
55--     EDS 07/16/98  AVOID OPTIMIZATION
56
57WITH REPORT; USE REPORT;
58PROCEDURE C37207A IS
59
60BEGIN
61     TEST ("C37207A","DISCRIMINANT CONSTRAINT CAN BE SUPPLIED TO " &
62          "DECLARATIONS AND DEFINITIONS USING TYPES WITH OR WITHOUT " &
63          "DEFAULT DISCRIMINANT VALUES");
64
65     DECLARE
66          TYPE REC1 (DISC : INTEGER := 5) IS
67               RECORD
68                    NULL;
69               END RECORD;
70
71          TYPE REC2 (DISC : INTEGER) IS
72               RECORD
73                    NULL;
74                END RECORD;
75
76          OBJ1 : REC1(6);                     -- 1.
77          OBJ2 : REC2(6);                     -- 1.
78          BADOBJ1 : REC1(7);                  -- 1.
79          BADOBJ2 : REC2(7);                  -- 1.
80
81          TYPE REC3 IS
82               RECORD
83                    COMP1 : REC1(6);          -- 2.
84                    COMP2 : REC2(6);          -- 2.
85               END RECORD;
86
87          OBJ3 : REC3;
88
89          TYPE ARR1 IS ARRAY (1..10) OF REC1(6);  -- 3.
90          TYPE ARR2 IS ARRAY (1..10) OF REC2(6);  -- 3.
91
92          A1 : ARR1;
93          A2 : ARR2;
94
95          TYPE REC1_NAME IS ACCESS REC1(6);   -- 4.
96          TYPE REC2_NAME IS ACCESS REC2(6);   -- 4.
97
98          ACC1 : REC1_NAME;
99          ACC2 : REC2_NAME;
100
101          SUBTYPE REC16 IS REC1(6);
102          SUBTYPE REC26 IS REC2(6);
103
104          PROCEDURE PROC (P1 : IN OUT REC16;     -- 6.
105                         P2 : IN OUT REC26) IS  -- 6.
106          BEGIN
107               IF NOT (P1'CONSTRAINED AND P2'CONSTRAINED) THEN  -- 6.
108                    FAILED ("'CONSTRAINED ATTRIBUTE INCORRECT FOR " &
109                            "CONSTRAINED FORMAL PARAMETERS");
110               END IF;
111               BEGIN
112                    P1 := (DISC => 7);         -- 6.
113                    FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
114                            "ATTEMPT TO CHANGE DISCRIMINANT OF " &
115                            "CONSTRAINED FORMAL PARAMETER " &
116                            INTEGER'IMAGE(P1.DISC));
117               EXCEPTION
118                    WHEN CONSTRAINT_ERROR => NULL;
119                    WHEN OTHERS => FAILED ("WRONG EXCEPTION     (1)");
120               END;
121               BEGIN
122                    P2 := (DISC => 7);         -- 6.
123                    FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
124                            "ATTEMPT TO CHANGE DISCRIMINANT OF " &
125                            "CONSTRAINED FORMAL PARAMETER " &
126                            INTEGER'IMAGE(P2.DISC));
127               EXCEPTION
128                    WHEN CONSTRAINT_ERROR => NULL;
129                    WHEN OTHERS => FAILED ("WRONG EXCEPTION     (2)");
130               END;
131          END PROC;
132     BEGIN
133---------------------------------------------------------------
134
135          BEGIN
136               OBJ1 := (DISC => IDENT_INT(7));           -- 1.
137               FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
138                       "ATTEMPT TO CHANGE DISCRIMINANT OF " &
139                       "CONSTRAINED OBJECT");
140               IF OBJ1 = (DISC => 7) THEN
141                    COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
142               END IF;
143          EXCEPTION
144               WHEN CONSTRAINT_ERROR => NULL;
145               WHEN OTHERS => FAILED ("WRONG EXCEPTION     (3)");
146          END;
147
148---------------------------------------------------------------
149
150          BEGIN
151               OBJ3 := ((DISC => IDENT_INT(7)),      -- 2.
152                        (DISC => IDENT_INT(7)));     -- 2.
153               FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
154                       "ATTEMPT TO CHANGE DISCRIMINANT OF " &
155                       "CONSTRAINED RECORD COMPONENT");
156               IF OBJ3 = ((DISC => 7), (DISC => 7)) THEN
157                    COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
158               END IF;
159          EXCEPTION
160               WHEN CONSTRAINT_ERROR => NULL;
161               WHEN OTHERS => FAILED ("WRONG EXCEPTION     (4)");
162          END;
163
164--------------------------------------------------------------
165
166          BEGIN
167               A2(2) := (DISC => IDENT_INT(7));          -- 3.
168               FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
169                       "ATTEMPT TO CHANGE DISCRIMINANT OF " &
170                       "CONSTRAINED ARRAY COMPONENT");
171               IF A2(2) = (DISC => 7) THEN
172                    COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
173               END IF;
174          EXCEPTION
175               WHEN CONSTRAINT_ERROR => NULL;
176               WHEN OTHERS => FAILED ("WRONG EXCEPTION     (5)");
177          END;
178
179--------------------------------------------------------------
180
181          BEGIN
182               ACC1 := NEW REC1(DISC => IDENT_INT(7));   -- 4.
183               FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
184                       "ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " &
185                       "TO ACCESS VARIABLE");
186               IF ACC1 =  NEW REC1(DISC => 7) THEN
187                    COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
188               END IF;
189         EXCEPTION
190               WHEN CONSTRAINT_ERROR => NULL;
191               WHEN OTHERS => FAILED ("WRONG EXCEPTION     (6)");
192          END;
193
194----------------------------------------------------------------
195
196               ACC1 := NEW REC1(DISC => IDENT_INT(6));  -- OK.
197
198          BEGIN
199               ACC1.ALL := BADOBJ1;           -- 5.
200               FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
201                       "ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " &
202                       "TO ACCESSED OBJECT");
203               IF ACC1.ALL = BADOBJ1 THEN
204                    COMMENT ("PREVENT DEAD VARIABLE OPTIMIZATION");
205               END IF;
206          EXCEPTION
207               WHEN CONSTRAINT_ERROR => NULL;
208               WHEN OTHERS => FAILED ("WRONG EXCEPTION     (7)");
209          END;
210
211-----------------------------------------------------------------
212
213               PROC (OBJ1,OBJ2);              -- OK.
214
215          BEGIN
216               PROC (BADOBJ1,BADOBJ2);        -- 6.
217               FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
218                       "PASSING OF CONSTRAINED ACTUAL " &
219                       "PARAMETERS TO DIFFERENTLY CONSTRAINED " &
220                       "FORMAL PARAMETERS");
221          EXCEPTION
222               WHEN CONSTRAINT_ERROR => NULL;
223               WHEN OTHERS => FAILED ("WRONG EXCEPTION     (8)");
224          END;
225
226---------------------------------------------------------------
227     END;
228
229     RESULT;
230END C37207A;
231