1-- C37209B.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 WHEN THE SUBTYPE
27--     INDICATION IN A CONSTANT OBJECT DECLARATION SPECIFIES A
28--     CONSTRAINED SUBTYPE WITH DISCRIMINANTS AND THE INITIALIZATION
29--     VALUE DOES NOT BELONG TO THE SUBTYPE (I. E., THE DISCRIMINANT
30--     VALUE DOES NOT MATCH THOSE SPECIFIED BY THE CONSTRAINT).
31
32-- HISTORY:
33--     RJW 08/25/86  CREATED ORIGINAL TEST
34--     VCL 08/19/87  CHANGED THE RETURN TYPE OF FUNTION 'INIT' IN
35--                   PACKAGE 'PRIV2' SO THAT 'INIT' IS UNCONSTRAINED,
36--                   THUS NOT RAISING A CONSTRAINT ERROR ON RETURN FROM
37--                   'INIT'.
38
39WITH REPORT; USE REPORT;
40PROCEDURE C37209B IS
41
42BEGIN
43     TEST ( "C37209B", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
44                       "THE SUBTYPE INDICATION IN A CONSTANT " &
45                       "OBJECT DECLARATION SPECIFIES A CONSTRAINED " &
46                       "SUBTYPE WITH DISCRIMINANTS AND THE " &
47                       "INITIALIZATION VALUE DOES NOT BELONG TO " &
48                       "THE SUBTYPE (I. E., THE DISCRIMINANT VALUE " &
49                       "DOES NOT MATCH THOSE SPECIFIED BY THE " &
50                       "CONSTRAINT)" );
51     DECLARE
52
53          TYPE REC (D : INTEGER) IS
54               RECORD
55                    NULL;
56               END RECORD;
57
58          SUBTYPE REC1 IS REC (IDENT_INT (5));
59     BEGIN
60          DECLARE
61               R1 : CONSTANT REC1 := (D => IDENT_INT (10));
62               I  : INTEGER := IDENT_INT (R1.D);
63          BEGIN
64               FAILED ( "NO EXCEPTION RAISED FOR DECLARATION OF " &
65                        "R1" );
66          EXCEPTION
67               WHEN OTHERS =>
68                    FAILED ( "EXCEPTION FOR R1 RAISED INSIDE BLOCK" );
69          END;
70
71     EXCEPTION
72          WHEN CONSTRAINT_ERROR =>
73               NULL;
74          WHEN OTHERS =>
75               FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION OF " &
76                        "R1" );
77     END;
78
79
80     BEGIN
81          DECLARE
82               PACKAGE PRIV1 IS
83                    TYPE REC (D : INTEGER) IS PRIVATE;
84                    SUBTYPE REC2 IS REC (IDENT_INT (5));
85                    R2 : CONSTANT REC2;
86
87               PRIVATE
88                    TYPE REC (D : INTEGER) IS
89                         RECORD
90                              NULL;
91                         END RECORD;
92
93                    R2 : CONSTANT REC2 := (D => IDENT_INT (10));
94               END PRIV1;
95
96               USE PRIV1;
97
98          BEGIN
99               DECLARE
100                    I : INTEGER := IDENT_INT (R2.D);
101               BEGIN
102                    FAILED ( "NO EXCEPTION RAISED AT DECLARATION " &
103                             "OF R2" );
104              END;
105          END;
106
107     EXCEPTION
108          WHEN CONSTRAINT_ERROR =>
109               NULL;
110          WHEN OTHERS =>
111               FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " &
112                        "OF R2" );
113     END;
114
115     BEGIN
116          DECLARE
117               PACKAGE PRIV2 IS
118                    TYPE REC (D : INTEGER) IS PRIVATE;
119                    SUBTYPE REC3 IS REC (IDENT_INT (5));
120
121                    FUNCTION INIT (D : INTEGER) RETURN REC;
122               PRIVATE
123                    TYPE REC (D : INTEGER) IS
124                         RECORD
125                              NULL;
126                         END RECORD;
127
128               END PRIV2;
129
130               PACKAGE BODY PRIV2 IS
131                    FUNCTION INIT (D : INTEGER) RETURN REC IS
132                    BEGIN
133                         RETURN (D => IDENT_INT (D));
134                    END INIT;
135               END PRIV2;
136
137               USE PRIV2;
138
139          BEGIN
140               DECLARE
141                    R3 : CONSTANT REC3 := INIT (10);
142                    I  : INTEGER := IDENT_INT (R3.D);
143               BEGIN
144                    FAILED ( "NO EXCEPTION RAISED AT DECLARATION " &
145                             "OF R3" );
146              END;
147          END;
148
149     EXCEPTION
150          WHEN CONSTRAINT_ERROR =>
151               NULL;
152          WHEN OTHERS =>
153               FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " &
154                        "OF R3" );
155     END;
156
157     BEGIN
158          DECLARE
159               PACKAGE LPRIV IS
160                    TYPE REC  (D : INTEGER) IS
161                         LIMITED PRIVATE;
162                    SUBTYPE REC4 IS REC (IDENT_INT (5));
163
164                    R4 : CONSTANT REC4;
165
166               PRIVATE
167                    TYPE REC (D : INTEGER) IS
168                         RECORD
169                              NULL;
170                         END RECORD;
171
172                    R4 : CONSTANT REC4 := (D => IDENT_INT (10));
173               END LPRIV;
174
175               USE LPRIV;
176
177          BEGIN
178               DECLARE
179                    I : INTEGER := IDENT_INT (R4.D);
180               BEGIN
181                    FAILED ( "NO EXCEPTION RAISED AT DECLARATION " &
182                             "OF R4" );
183              END;
184          END;
185     EXCEPTION
186          WHEN CONSTRAINT_ERROR =>
187               NULL;
188          WHEN OTHERS =>
189               FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " &
190                        "OF R4" );
191     END;
192
193     RESULT;
194END C37209B;
195