1-- C34006F.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--     FOR DERIVED RECORD TYPES WITH DISCRIMINANTS AND WITH NON-LIMITED
27--     COMPONENT TYPES:
28--     CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR
29--     THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
30--     CONSTRAINED.
31--     CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
32--     IMPOSED ON THE DERIVED SUBTYPE.
33
34-- HISTORY:
35--     JRK 9/22/86  CREATED ORIGINAL TEST.
36
37WITH REPORT; USE REPORT;
38
39PROCEDURE C34006F IS
40
41     SUBTYPE COMPONENT IS INTEGER;
42
43     PACKAGE PKG IS
44
45          MAX_LEN : CONSTANT := 10;
46
47          SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
48
49          TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS
50               RECORD
51                    I : INTEGER;
52                    CASE B IS
53                         WHEN TRUE =>
54                              S : STRING (1 .. L);
55                              C : COMPONENT;
56                         WHEN FALSE =>
57                              F : FLOAT := 5.0;
58                    END CASE;
59               END RECORD;
60
61          FUNCTION CREATE ( B : BOOLEAN;
62                            L : LENGTH;
63                            I : INTEGER;
64                            S : STRING;
65                            C : COMPONENT;
66                            F : FLOAT;
67                            X : PARENT  -- TO RESOLVE OVERLOADING.
68                          ) RETURN PARENT;
69
70     END PKG;
71
72     USE PKG;
73
74     TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
75
76     SUBTYPE SUBPARENT IS PARENT (TRUE, 3);
77
78     TYPE S IS NEW SUBPARENT;
79
80     X : T := (TRUE, 3, 2, "AAA", 2);
81     Y : S := (TRUE, 3, 2, "AAA", 2);
82
83     PACKAGE BODY PKG IS
84
85          FUNCTION CREATE
86             ( B : BOOLEAN;
87               L : LENGTH;
88               I : INTEGER;
89               S : STRING;
90               C : COMPONENT;
91               F : FLOAT;
92               X : PARENT
93             ) RETURN PARENT
94          IS
95          BEGIN
96               CASE B IS
97                    WHEN TRUE =>
98                         RETURN (TRUE, L, I, S, C);
99                    WHEN FALSE =>
100                         RETURN (FALSE, L, I, F);
101               END CASE;
102          END CREATE;
103
104     END PKG;
105
106BEGIN
107     TEST ("C34006F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
108                      "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
109                      "WHEN THE DERIVED TYPE DEFINITION IS " &
110                      "CONSTRAINED.  ALSO CHECK THAT ANY CONSTRAINT " &
111                      "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
112                      "ON THE DERIVED SUBTYPE.  CHECK FOR DERIVED " &
113                      "RECORD TYPES WITH DISCRIMINANTS AND WITH " &
114                      "NON-LIMITED COMPONENT TYPES");
115
116     -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
117
118     BEGIN
119          IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) /=
120             (FALSE, 2, 3, 6.0) OR
121             CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) /=
122             (FALSE, 2, 3, 6.0) THEN
123               FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " &
124                       "SUBTYPE");
125          END IF;
126     EXCEPTION
127          WHEN CONSTRAINT_ERROR =>
128               FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1");
129          WHEN OTHERS =>
130               FAILED ("CALL TO CREATE RAISED EXCEPTION - 1");
131     END;
132
133     BEGIN
134          IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR
135             CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN
136               FAILED ("INCORRECT ""IN""");
137          END IF;
138     EXCEPTION
139          WHEN CONSTRAINT_ERROR =>
140               FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2");
141          WHEN OTHERS =>
142               FAILED ("CALL TO CREATE RAISED EXCEPTION - 2");
143     END;
144
145     -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
146
147     IF X.B /= TRUE OR X.L /= 3 OR
148        Y.B /= TRUE OR Y.L /= 3 THEN
149          FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES");
150     END IF;
151
152     IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN
153          FAILED ("INCORRECT 'CONSTRAINED");
154     END IF;
155
156     BEGIN
157          X := (TRUE, 3, 1, "ABC", 4);
158          Y := (TRUE, 3, 1, "ABC", 4);
159          IF PARENT (X) /= PARENT (Y) THEN  -- USE X AND Y.
160               FAILED ("INCORRECT CONVERSION TO PARENT");
161          END IF;
162     EXCEPTION
163          WHEN OTHERS =>
164               FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
165     END;
166
167     BEGIN
168          X := (FALSE, 3, 2, 6.0);
169          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
170                  "X := (FALSE, 3, 2, 6.0)");
171          IF X = (FALSE, 3, 2, 6.0) THEN  -- USE X.
172               COMMENT ("X ALTERED -- X := (FALSE, 3, 2, 6.0)");
173          END IF;
174     EXCEPTION
175          WHEN CONSTRAINT_ERROR =>
176               NULL;
177          WHEN OTHERS =>
178               FAILED ("WRONG EXCEPTION RAISED -- " &
179                       "X := (FALSE, 3, 2, 6.0)");
180     END;
181
182     BEGIN
183          X := (TRUE, 4, 2, "ZZZZ", 6);
184          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
185                  "X := (TRUE, 4, 2, ""ZZZZ"", 6)");
186          IF X = (TRUE, 4, 2, "ZZZZ", 6) THEN  -- USE X.
187               COMMENT ("X ALTERED -- X := (TRUE, 4, 2, ""ZZZZ"", 6)");
188          END IF;
189     EXCEPTION
190          WHEN CONSTRAINT_ERROR =>
191               NULL;
192          WHEN OTHERS =>
193               FAILED ("WRONG EXCEPTION RAISED -- " &
194                       "X := (TRUE, 4, 2, ""ZZZZ"", 6)");
195     END;
196
197     BEGIN
198          Y := (FALSE, 3, 2, 6.0);
199          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
200                  "Y := (FALSE, 3, 2, 6.0)");
201          IF Y = (FALSE, 3, 2, 6.0) THEN  -- USE Y.
202               COMMENT ("Y ALTERED -- Y := (FALSE, 3, 2, 6.0)");
203          END IF;
204     EXCEPTION
205          WHEN CONSTRAINT_ERROR =>
206               NULL;
207          WHEN OTHERS =>
208               FAILED ("WRONG EXCEPTION RAISED -- " &
209                       "Y := (FALSE, 3, 2, 6.0)");
210     END;
211
212     BEGIN
213          Y := (TRUE, 4, 2, "ZZZZ", 6);
214          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
215                  "Y := (TRUE, 4, 2, ""ZZZZ"", 6)");
216          IF Y = (TRUE, 4, 2, "ZZZZ", 6) THEN  -- USE Y.
217               COMMENT ("Y ALTERED -- Y := (TRUE, 4, 2, ""ZZZZ"", 6)");
218          END IF;
219     EXCEPTION
220          WHEN CONSTRAINT_ERROR =>
221               NULL;
222          WHEN OTHERS =>
223               FAILED ("WRONG EXCEPTION RAISED -- " &
224                       "Y := (TRUE, 4, 2, ""ZZZZ"", 6)");
225     END;
226
227     RESULT;
228END C34006F;
229